mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2026-04-16 18:03:36 +00:00
Code Issues Projects Releases Wiki Activity
Files
b357a3dadcdf29c8d8ca184d65f7634a1a94de36
mercury/compiler/fact_table.m
Zoltan Somogyi b21e9e459a Delete all calls to get_progress_output_stream ... 
... and almost all calls to get_error_output_stream. Replace them
with ProgressStreams and ErrorStreams passed down from higher in the
call tree.

Use ProgressStreams, not ErrorStreams, to write out error messages about
any failures of filesystem operations. These are not appropriate to put
into a module's .err file, since they are not about an error in the
Mercury code of the module.

compiler/globals.m:
    Delete the predicates that return progress streams, and the mutable
    behind them.

compiler/passes_aux.m:
    Delete the predicates that return progress streams. Delete the
    versions of the progress-message-writing predicates that didn't get
    the progress stream from their caller.

compiler/*.m:
    Pass around ProgressStreams and/or ErrorStreams explicitly,
    as mentioned at the top of log message.

    In a few places, don't write out error_specs to ErrorStream,
    returning it to be printed by our caller, or its caller etc instead.
    In some of those places, this allowed the deletion an existing
    ErrorStream argument.

    Given that get_{progress,error}_output_stream took a ModuleName input,
    deleting some of the calls to those predicates left ModuleName unused.
    Delete such unused ModuleNames.

    In a few places, change argument orders to conform to our usual
    programming style.

    Fix too-long lines.
2023-10-17 20:41:33 +11:00

3907 lines
148 KiB
Mathematica
Raw Blame History

%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%---------------------------------------------------------------------------%
% Copyright (C) 1996-2001, 2003-2012 The University of Melbourne.
% Copyright (C) 2015 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: fact_table.m.
% Main author: dmo.
%
% This module handles compilation of fact tables contained in external files
% that have been declared with a `pragma fact_table' declaration.
%
% The facts are processed one by one. Each fact is read in and type and mode
% checked. If there are no modes with input arguments, the data is written
% out to arrays of C structures as each fact is processed. If there are input
% modes, the input arguments for each mode are written out to a temporary
% sort file -- one sort file per input mode. The output arguments are also
% included in the sort file for the primary input mode. (At the moment,
% the primary input mode is the one with the lowest ProcId number, however
% this may change in the future to select the mode that is likely to give
% the biggest increase in efficiency by being the primary mode).
%
% After all the facts have been read, the sort files are sorted by the Unix
% `sort' program. They are then scanned for duplicate input keys to infer
% the determinisms of each mode.
%
% The sort files are then read back in one by one and hash tables are created
% for each input mode. While the sort file for the primary input mode is
% being read, the output arguments are also read back in and output as C
% arrays in another temporary file. (This file is concatenated to the end
% of the fact table C file after all the hash tables have been created.)
% This means that the output data for identical keys in the primary input
% mode will be grouped together allowing the code that accesses this mode
% to be just pick the next item in the data array when backtracking.
%
% The inferred determinism for each mode is added to the proc_info. If a
% determinism has been declared for the procedure, it will be tested against
% the inferred determinism later on in det_report.m.
%
% XXX All combinations of `in' and `out' arguments are now supported for all
% determinisms. Only the builtin `string', `int' and `float' types are
% supported at the moment.
%
% XXX Cross compilation is not supported for fact tables that are indexed on
% floats.
%
%---------------------------------------------------------------------------%
:- module ll_backend.fact_table.
:- interface.
:- import_module hlds.
:- import_module hlds.hlds_module.
:- import_module hlds.hlds_pred.
:- import_module mdbcomp.
:- import_module mdbcomp.sym_name.
:- import_module parse_tree.
:- import_module parse_tree.error_spec.
:- import_module parse_tree.prog_data.
:- import_module parse_tree.prog_data_foreign.
:- import_module io.
:- import_module list.
%---------------------------------------------------------------------------%
:- type fact_table_arg_check_result
---> fact_table_args_ok(fact_table_gen_info)
; fact_table_args_not_ok(list(error_spec)).
:- type fact_table_gen_info.
% Check whether the declaration of the given predicate and its mode(s)
% are suitable for fact tables. If not, return a message for each error.
% Otherwise, return an opaque data structure that the caller can give
% to the other two exported predicates of this module to generate code
% for the predicate.
%
:- pred fact_table_check_args(module_info::in, prog_context::in,
pred_id::in, pred_info::in, fact_table_arg_check_result::out) is det.
% fact_table_compile_facts(ProgressStream, ModuleInfo, FileName, Context,
% GenInfo, HeaderCode, PrimaryProcId, !PredInfo, !Specs, !IO):
%
% Compile the fact table in FileName for PredInfo into a separate .c file.
% Return error specs for any errors discovered while processing the
% contents of FileName, such as syntax errors (such as found fact for
% wrong predicate, found fact with wrong number of arguments, found fact
% in function form when expecting fact for predicate), type errors
% (expected int, found float) and mode errors (expected int,
% found variable).
%
:- pred fact_table_compile_facts(io.text_output_stream::in, module_info::in,
string::in, prog_context::in, fact_table_gen_info::in, string::out,
proc_id::out, pred_info::in, pred_info::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
% fact_table_generate_c_code_for_proc(ModuleInfo, PredName,
% ProcId, PrimaryProcId, ProcInfo, GenInfo, VarSet, PragmaVars,
% ProcCode, ExtraCode):
%
% Generate C code to look up a fact table in a given mode.
% ProcCode is the C code for the procedure, ExtraCode is extra C code
% that should be included in the module. VarSet is the varset of
% the foreign_proc our caller should construct, and PragmaVars
% are its arguments.
%
% Model_non foreign_procs were not supported by the compiler when this
% code was written. To get around this, the C_ProcCode generated for
% model_non code pops off the stack frame that is automatically created
% by the compiler and jumps to the code contained in ExtraCode.
% ExtraCode declares the required labels and creates a new stack frame
% with the required number of framevars. It then does all the work required
% to look up the fact table.
%
:- pred fact_table_generate_c_code_for_proc(module_info::in, sym_name::in,
proc_id::in, proc_id::in, proc_info::in, fact_table_gen_info::in,
prog_varset::out, list(pragma_var)::out, string::out, string::out) is det.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
:- implementation.
:- import_module backend_libs.
:- import_module backend_libs.c_util.
:- import_module check_hlds.
:- import_module check_hlds.inst_test.
:- import_module check_hlds.mode_test.
:- import_module check_hlds.mode_util.
:- import_module hlds.arg_info.
:- import_module hlds.code_model.
:- import_module hlds.hlds_error_util.
:- import_module hlds.hlds_llds.
:- import_module hlds.hlds_proc_util.
:- import_module libs.
:- import_module libs.file_util.
:- import_module libs.globals.
:- import_module libs.options.
:- import_module ll_backend.llds_out.
:- import_module ll_backend.llds_out.llds_out_data.
:- import_module mdbcomp.prim_data.
:- import_module parse_tree.builtin_lib_types.
:- import_module parse_tree.file_names.
:- import_module parse_tree.module_cmds.
:- import_module parse_tree.parse_tree_out_term.
:- import_module parse_tree.parse_tree_out_type.
:- import_module parse_tree.prog_foreign.
:- import_module parse_tree.prog_mode.
:- import_module parse_tree.prog_util.
:- import_module assoc_list.
:- import_module bool.
:- import_module char.
:- import_module cord.
:- import_module float.
:- import_module int.
:- import_module integer.
:- import_module io.call_system.
:- import_module io.file.
:- import_module library.
:- import_module map.
:- import_module maybe.
:- import_module mercury_term_parser.
:- import_module pair.
:- import_module require.
:- import_module string.
:- import_module term.
:- import_module term_context.
:- import_module varset.
%---------------------------------------------------------------------------%
% This is the data structure we construct if the semantic checks
% on the fact table predicate and its procedures all succeed.
:- type fact_table_gen_info
---> fact_table_gen_info(
% Information about the arguments of the predicate.
fgti_arg_infos :: list(fact_arg_info),
% Information about each procedure of the predicate.
ftgi_proc_info_map :: fact_table_proc_map,
% We record the identities of kinds of procedures for use
% by fact_table_compile_facts: the procedure (if any)
% whose args are all inputs, and the procedures that have
% both input and output arguments.
ftgi_all_in_proc_id :: maybe(proc_id),
ftgi_in_out_proc_ids :: list(proc_id)
).
%---------------------%
% The most important information we record about each predicate argument
% is its type, which must be one of the types supported in fact tables.
% However, some parts of fact_table_compile_facts also want to know,
% for each argument, whether it has a given in mode in *any* procedure.
:- type fact_arg_info
---> fact_arg_info(
fact_arg_type,
maybe_input_for_some_mode,
maybe_in_or_output_for_some_mode
).
% XXX UINT - handle uints here too when we support them in fact tables.
:- type fact_arg_type
---> fact_arg_type_int
; fact_arg_type_float
; fact_arg_type_string.
:- type maybe_input_for_some_mode
---> is_not_input_for_any_mode
; is_input_for_some_mode.
% XXX I think the bool that this bespoke type replaces was originally
% meant to be set only for arguments that are output in some mode,
% but then the code whose job is to fill it in set if the arg
% is ever either input *or* output, which (since these are the only
% two modes we support in fact table predicates) means it is *always*
% set to is_in_or_output_for_some_mode.
:- type maybe_in_or_output_for_some_mode
---> is_not_in_or_output_for_any_mode
; is_in_or_output_for_some_mode.
%---------------------%
% We record, for each argument of each procedure,
%
% - the name of the C variable holding it,
% - whether its mode is input or output,
% - whether we need to make it unique when we copy it out of the table
% (this matters only for strings), and
% - the pragma var that should represent this argument in the
% foreign proc.
%
% All this info is in the fact_table_var type.
% The mode class effectively summarizes the arguments' modes, while
% the prog_varset here contains the variables in the pragma_vars,
%
:- type fact_table_proc_map == map(proc_id, fact_table_proc_info).
:- type fact_table_proc_info
---> fact_table_proc_info(
list(fact_table_var),
fact_table_mode_class,
prog_varset
).
:- type fact_table_var
---> fact_table_var(
ftv_name :: string,
ftv_mode :: fact_table_mode,
ftv_make_unique :: maybe_make_unique,
ftv_pragma_var :: pragma_var
).
:- type fact_table_mode
---> fully_in
; fully_out.
:- type maybe_make_unique
---> do_not_make_unique
; make_unique.
:- type fact_table_mode_class
---> all_in
; in_out
; all_out.
%---------------------------------------------------------------------------%
% Proc_stream contains information about an open sort file for
% a particular procedure.
%
:- type proc_stream
---> proc_stream(
proc_id, % ID of procedure.
list(fact_table_mode), % The modes of the arguments.
string, % The name of the sort file.
io.text_output_stream % Sort file stream.
).
:- type hash_entry
---> hash_entry(
fact_arg, % Lookup key.
hash_index, % Pointer to next hash table or index to fact data.
int % Position of next entry with same hash value.
).
% Data structure used to build up a hash table before writing it out
% as a C array.
:- type hash_table
---> hash_table(
int, % Size of hash table.
map(int, hash_entry)
).
:- type hash_index
---> fact(int) % Index into fact table.
; hash_table(int, string). % Hash table for next arg.
% Sort_file_line contains the information read in from a sort file
% after sorting.
:- type sort_file_line
---> sort_file_line(
list(fact_arg), % Input arguments.
int, % Index of fact in original file.
list(fact_arg) % Output arguments.
).
:- type fact_arg
---> fact_arg_int(int)
; fact_arg_float(float)
; fact_arg_string(string).
:- type inferred_determinism
---> inferred(determinism) % Determinism has been inferred.
; not_yet % Determinism has not yet been inferred.
; error. % An error occurred trying to infer
% determinism.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
fact_table_check_args(ModuleInfo, PragmaContext, PredId, PredInfo, Result) :-
pred_info_get_arg_types(PredInfo, Types),
(
Types = [],
% We can say "predicate" because a function has at least one argument,
% the result.
Pieces = [words("Error:"), pragma_decl("fact_table"),
words("declaration for a predicate without arguments."), nl],
Spec = simplest_spec($pred, severity_error, phase_fact_table_check,
PragmaContext, Pieces),
% Since there are no arguments, they cannot have an unsupported
% type or mode.
Result = fact_table_args_not_ok([Spec])
;
Types = [_ | _],
init_fact_arg_infos(PredInfo, Types, FactArgInfos0, [], TypeSpecs),
ProcIds = pred_info_all_procids(PredInfo),
(
ProcIds = [],
ModePieces = [words("Error:"), pragma_decl("fact_table"),
words("declaration for a predicate with no declared modes."),
nl],
ModeSpec = simplest_spec($pred, severity_error,
phase_fact_table_check, PragmaContext, ModePieces),
ModeSpecs = [ModeSpec],
FactArgInfos = FactArgInfos0, % dummy; won't be used
map.init(FactTableProcMap), % dummy; won't be used
MaybeAllInProcId = no, % dummy; won't be used
InOutProcIds = [] % dummy; won't be used
;
ProcIds = [_ | _],
pred_info_get_proc_table(PredInfo, ProcTable),
fact_table_check_proc_modes(ModuleInfo, PredId, ProcTable, ProcIds,
FactArgInfos0, FactArgInfos, map.init, FactTableProcMap,
[], RevAllInProcIds, [], RevInOutProcIds, [], ModeSpecs0),
list.reverse(RevAllInProcIds, AllInProcIds),
list.reverse(RevInOutProcIds, InOutProcIds),
(
AllInProcIds = [],
MaybeAllInProcId = no,
ModeSpecs = ModeSpecs0
;
AllInProcIds = [AllInProcId],
MaybeAllInProcId = yes(AllInProcId),
ModeSpecs = ModeSpecs0
;
AllInProcIds = [_, _ | _],
AllInPieces = [words("Error:"), pragma_decl("fact_table"),
words("declaration for a predicate"),
words("with more than one mode"),
words("in which all arguments are input."), nl],
AllInSpec = simplest_spec($pred, severity_error,
phase_fact_table_check, PragmaContext, AllInPieces),
ModeSpecs = [AllInSpec | ModeSpecs0],
MaybeAllInProcId = no % dummy; won't be used
)
),
Specs = TypeSpecs ++ ModeSpecs,
(
Specs = [],
GenInfo = fact_table_gen_info(FactArgInfos, FactTableProcMap,
MaybeAllInProcId, InOutProcIds),
Result = fact_table_args_ok(GenInfo)
;
Specs = [_ | _],
Result = fact_table_args_not_ok(Specs)
)
).
:- pred fact_table_check_proc_modes(module_info::in, pred_id::in,
proc_table::in, list(proc_id)::in,
list(fact_arg_info)::in, list(fact_arg_info)::out,
fact_table_proc_map::in, fact_table_proc_map::out,
list(proc_id)::in, list(proc_id)::out,
list(proc_id)::in, list(proc_id)::out,
list(error_spec)::in, list(error_spec)::out) is det.
fact_table_check_proc_modes(_, _, _, [],
!FactArgInfos, !FactTableProcMap,
!RevAllInProcIds, !RevInOutProcIds, !Specs).
fact_table_check_proc_modes(ModuleInfo, PredId, ProcTable, [ProcId | ProcIds],
!FactArgInfos, !FactTableProcMap,
!RevAllInProcIds, !RevInOutProcIds, !Specs) :-
map.lookup(ProcTable, ProcId, ProcInfo),
proc_info_get_argmodes(ProcInfo, ArgModes),
PredProcId = proc(PredId, ProcId),
varset.init(VarSet0),
check_proc_arg_modes(ModuleInfo, PredProcId, ProcInfo, ArgModes, 1,
FactTableVars, VarSet0, VarSet, [], ArgModeSpecs),
(
ArgModeSpecs = [_ | _],
!:Specs = ArgModeSpecs ++ !.Specs
% There is no point in processing this procedure any further.
;
ArgModeSpecs = [],
FactTableModes = list.map((func(fact_table_var(_, M, _, _)) = M),
FactTableVars),
fill_in_fact_arg_infos(FactTableModes, !FactArgInfos),
list.sort_and_remove_dups(FactTableModes, PresentModes),
( if PresentModes = [fully_in] then
ModeClass = all_in,
!:RevAllInProcIds = [ProcId | !.RevAllInProcIds]
else if PresentModes = [fully_in, fully_out] then
ModeClass = in_out,
!:RevInOutProcIds = [ProcId | !.RevInOutProcIds]
else if PresentModes = [fully_out] then
ModeClass = all_out
else
unexpected($pred, "impossible mode class")
),
FactTableProcInfo =
fact_table_proc_info(FactTableVars, ModeClass, VarSet),
map.det_insert(ProcId, FactTableProcInfo, !FactTableProcMap)
),
fact_table_check_proc_modes(ModuleInfo, PredId, ProcTable, ProcIds,
!FactArgInfos, !FactTableProcMap,
!RevAllInProcIds, !RevInOutProcIds, !Specs).
%-------------%
% Initialise list of fact argument information. Input and output flags
% are initialised to `no' and filled in correctly by
% infer_determinism_pass_1.
%
:- pred init_fact_arg_infos(pred_info::in, list(mer_type)::in,
list(fact_arg_info)::out,
list(error_spec)::in, list(error_spec)::out) is det.
init_fact_arg_infos(_, [], [], !Specs).
init_fact_arg_infos(PredInfo, [Type | Types], [Info | Infos], !Specs) :-
( if
Type = builtin_type(BuiltinType),
(
BuiltinType = builtin_type_int(int_type_int),
FactArgTypePrime = fact_arg_type_int
;
BuiltinType = builtin_type_float,
FactArgTypePrime = fact_arg_type_float
;
BuiltinType = builtin_type_string,
FactArgTypePrime = fact_arg_type_string
)
then
FactArgType = FactArgTypePrime
else
pred_info_get_typevarset(PredInfo, TVarSet),
TypeStr = mercury_type_to_string(TVarSet, print_name_only, Type),
pred_info_get_context(PredInfo, Context),
Pieces = [words("Error: type"), quote(TypeStr),
words("is not allowed in fact tables."),
words("The only types allowed in fact tables are"),
quote("int"), suffix(","), quote("float"), suffix(","),
words("and"), quote("string"), suffix("."), nl],
add_error_context_and_pieces(Context, Pieces, !Specs),
FactArgType = fact_arg_type_int % Dummy; won't be used.
),
Info = fact_arg_info(FactArgType,
is_not_input_for_any_mode, is_not_in_or_output_for_any_mode),
init_fact_arg_infos(PredInfo, Types, Infos, !Specs).
:- pred check_proc_arg_modes(module_info::in, pred_proc_id::in, proc_info::in,
list(mer_mode)::in, int::in, list(fact_table_var)::out,
prog_varset::in, prog_varset::out,
list(error_spec)::in, list(error_spec)::out) is det.
check_proc_arg_modes(_, _, _, [], _, [], !VarSet, !Specs).
check_proc_arg_modes(ModuleInfo, PredProcId, ProcInfo, [Mode | Modes], ArgNum,
[FactTableVar | FactTableVars], !VarSet, !Specs) :-
( if mode_get_insts_semidet(ModuleInfo, Mode, _, FinalInst) then
( if mode_is_fully_input(ModuleInfo, Mode) then
FactTableMode = fully_in
else if mode_is_fully_output(ModuleInfo, Mode) then
FactTableMode = fully_out
else
ProcPieces = describe_one_proc_name(ModuleInfo,
should_not_module_qualify, PredProcId),
proc_info_get_context(ProcInfo, Context),
Pieces = [words("Error: the"), pragma_decl("fact_table"),
words("declaration requires all the arguments of") |
ProcPieces] ++
[words("to be either fully input or fully output,"),
words("but the"), nth_fixed(ArgNum), words("argument"),
words("is neither."), nl],
Spec = simplest_spec($pred, severity_error, phase_fact_table_check,
Context, Pieces),
!:Specs = [Spec | !.Specs],
FactTableMode = fully_in % dummy; won't be used.
),
( if inst_is_not_partly_unique(ModuleInfo, FinalInst) then
MakeUnique = do_not_make_unique
else
MakeUnique = make_unique
)
else
% Module qualification will catch and report this error,
% so generating an error message here for the user would be redundant.
% However, we *did* find an error that prevents us from generating
% fact table code for this procedure, and we have to signal this
% by an error_spec. So we generate and return an empty error_spec.
proc_info_get_context(ProcInfo, Context),
Spec = simplest_spec($pred, severity_error, phase_fact_table_check,
Context, []),
!:Specs = [Spec | !.Specs],
FactTableMode = fully_in, % dummy; won't be used.
MakeUnique = do_not_make_unique % dummy; won't be used.
),
% The name we set is the default name for an unnamed variable,
% because old hand-written C code uses this name.
% This works only because for variables in foreign_procs never have
% their variable numbers appended to their name, precisely to avoid
% mismatches with the foreign language code inside the foreign_proc.
string.format("V_%d", [i(ArgNum)], VarName),
varset.new_named_var(VarName, Var, !VarSet),
PragmaVar = pragma_var(Var, VarName, Mode, bp_native_if_possible),
FactTableVar =
fact_table_var(VarName, FactTableMode, MakeUnique, PragmaVar),
check_proc_arg_modes(ModuleInfo, PredProcId, ProcInfo, Modes, ArgNum + 1,
FactTableVars, !VarSet, !Specs).
:- pred fill_in_fact_arg_infos(list(fact_table_mode)::in,
list(fact_arg_info)::in, list(fact_arg_info)::out) is det.
fill_in_fact_arg_infos([], [], []).
fill_in_fact_arg_infos([_ | _], [], _) :-
unexpected($pred, "too many argmodes").
fill_in_fact_arg_infos([], [_ | _], _) :-
unexpected($pred, "too many fact_arg_infos").
fill_in_fact_arg_infos([FactTableMode | FactTableModes],
[Info0 | Infos0], [Info | Infos]) :-
Info0 = fact_arg_info(Type, IsInput, _IsOutput),
(
FactTableMode = fully_in,
% XXX Info = fact_arg_info(Type, yes, IsOutput)
% XXX currently the first input mode requires _all_ arguments to be
% written in the fact data table so it can do lookups on backtracking.
% This may change if it is found to be less efficient than doing these
% lookups via the hash table.
Info = fact_arg_info(Type,
is_input_for_some_mode, is_in_or_output_for_some_mode)
;
FactTableMode = fully_out,
Info = fact_arg_info(Type, IsInput, is_in_or_output_for_some_mode)
),
fill_in_fact_arg_infos(FactTableModes, Infos0, Infos).
%---------------------------------------------------------------------------%
fact_table_compile_facts(ProgressStream, ModuleInfo, FileName, Context,
GenInfo, HeaderCode, PrimaryProcId, !PredInfo, !Specs, !IO) :-
module_info_get_globals(ModuleInfo, Globals),
io.open_input(FileName, FileResult, !IO),
(
FileResult = ok(FileStream),
fact_table_file_name_return_dirs(Globals, $pred,
ext_cur_ngs_gs(ext_cur_ngs_gs_target_c),
FileName, Dirs, OutputFileName),
create_any_dirs_on_path(Dirs, !IO),
io.open_output(OutputFileName, OpenResult, !IO),
(
OpenResult = ok(OutputStream),
pred_info_get_module_name(!.PredInfo, ModuleName),
pred_info_get_name(!.PredInfo, PredName),
PredSymName = qualified(ModuleName, PredName),
fact_table_size(Globals, FactTableSize),
get_maybe_progress_output_stream(ModuleInfo, ProgressStream,
MaybeProgressStream),
compile_fact_table_in_file(MaybeProgressStream,
FileStream, FileName, OutputStream,
FactTableSize, ModuleInfo, PredSymName, GenInfo,
HeaderCode, PrimaryProcId, MaybeDataFileName,
!PredInfo, !Specs, !IO),
io.close_output(OutputStream, !IO),
(
MaybeDataFileName = no
;
MaybeDataFileName = yes(DataFileName),
append_data_table(MaybeProgressStream,
OutputFileName, DataFileName, !Specs, !IO)
)
;
OpenResult = error(Error),
add_file_open_error(yes(Context), FileName, "output", Error,
!Specs, !IO),
HeaderCode = "",
PrimaryProcId = invalid_proc_id
),
io.close_input(FileStream, !IO)
;
FileResult = error(Error),
add_file_open_error(yes(Context), FileName, "input", Error,
!Specs, !IO),
HeaderCode = "",
PrimaryProcId = invalid_proc_id
).
:- pred compile_fact_table_in_file(maybe(io.text_output_stream)::in,
io.text_input_stream::in, string::in, io.text_output_stream::in,
int::in, module_info::in, sym_name::in, fact_table_gen_info::in,
string::out, proc_id::out, maybe(string)::out,
pred_info::in, pred_info::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
compile_fact_table_in_file(MaybeProgressStream, FileStream, FileName,
OutputStream, FactTableSize, ModuleInfo, PredSymName, GenInfo,
HeaderCode, PrimaryProcId, MaybeDataFileName,
!PredInfo, !Specs, !IO) :-
infer_determinism_pass_1(GenInfo, WriteHashTables, WriteDataTable,
!PredInfo),
create_fact_table_header(PredSymName, FactArgInfos,
HeaderCode0, StructName),
GenInfo = fact_table_gen_info(FactArgInfos, FactTableProcMap,
MaybeAllInProcId, InOutProcIds),
% We need to get the order right for CheckProcs because the first
% procedure in list is used to derive the primary lookup key.
% XXX Document what "getting the order right" means ...
%
% If there is an all_in procedure, it needs to be put on the end of
% the list so a sort file is created for it. This is required when
% building the hash table, not for determinism inference.
(
MaybeAllInProcId = yes(AllInProcId),
CheckProcs = InOutProcIds ++ [AllInProcId]
;
MaybeAllInProcId = no,
CheckProcs = InOutProcIds
),
io.write_string(OutputStream, fact_table_file_header(FileName), !IO),
io.write_string(OutputStream, HeaderCode0, !IO),
open_sort_files(FactTableProcMap, CheckProcs, ProcStreams,
[], OpenSpecs, !IO),
% As the documentation on the fact_table_size predicate says,
% we impose a limit on the size of the arrays we generate.
% The data table may need to be broken into pieces to respect
% this limit.
%
% The nice way to do this would be to
%
% - generate all the array entries we need,
% - break them into chunks that respect the maximum size, and then
% - write out each chunk with its prologue and epilogue, with
% the prologue containing the start of the subarray's definition,
% including an opening brace, and the prologue containing
% the matching close brace and the final semicolon.
%
% This two level loop (first over the chunks, then over the entries
% in each chunk) is nice because there is a natural place to put
% the prologues and epilogues.
%
% Unfortunately, this design also requires the whole array to be
% in memory at the same time. Since fact tables may be extremely large,
% we want to avoid this. We therefore adopt a cruder approach using
% a single loop over the entries. In this approach, most loop
% iterations just process one entry, but when the entry is the last
% entry in what *would have been* a chunk, we also output the epilogue,
% and if there are any more entries after it, then the prologue as
% well. This requires us to handle the initial prologue and the final
% epilogue here, outside the loop.
(
WriteDataTable = write_data_table,
(
CheckProcs = [],
MaybeOutput = yes(OutputStream - StructName),
% Outputs opening brace for first fact array.
write_new_data_array_opening_brace(OutputStream, StructName,
0, !IO),
WriteDataAfterSorting = do_not_write_data_table
;
CheckProcs = [_ | _],
MaybeOutput = no,
WriteDataAfterSorting = write_data_table
)
;
WriteDataTable = do_not_write_data_table,
MaybeOutput = no,
WriteDataAfterSorting = do_not_write_data_table
),
list.length(FactArgInfos, NumFactArgInfos),
FactNum0 = 0,
CompileSpecs0 = [],
read_in_and_compile_facts(FileStream, FileName, MaybeProgressStream,
FactTableSize, !.PredInfo, NumFactArgInfos, FactArgInfos,
ProcStreams, MaybeOutput, FactNum0, FactNum,
CompileSpecs0, CompileSpecs, !IO),
NumFacts = FactNum,
(
MaybeOutput = yes(_),
% Outputs closing brace for last fact array.
write_closing_brace(OutputStream, !IO),
write_fact_table_pointer_array(OutputStream, FactTableSize,
StructName, NumFacts, HeaderCode2, !IO)
;
MaybeOutput = no,
HeaderCode2 = ""
),
close_sort_files(ProcStreams, ProcFiles, !IO),
OpenCompileSpecs = OpenSpecs ++ CompileSpecs,
(
OpenCompileSpecs = [],
pred_info_get_proc_table(!.PredInfo, ProcTable0),
infer_determinism_pass_2(MaybeProgressStream, GenInfo, ProcFiles,
ProcTable0, ProcTable, !Specs, !IO),
pred_info_set_proc_table(ProcTable, !PredInfo),
io.file.make_temp_file(DataFileNameResult, !IO),
(
DataFileNameResult = ok(DataFileName),
write_fact_table_arrays(MaybeProgressStream, OutputStream,
FactTableSize, ModuleInfo, ProcFiles, DataFileName,
FactTableProcMap, StructName, NumFacts, FactArgInfos,
WriteHashTables, WriteDataAfterSorting,
HeaderCode1, PrimaryProcId, !Specs, !IO),
write_fact_table_numfacts(OutputStream, PredSymName, NumFacts,
HeaderCode3, !IO),
HeaderCode =
HeaderCode0 ++ HeaderCode1 ++ HeaderCode2 ++ HeaderCode3,
MaybeDataFileName = yes(DataFileName)
;
DataFileNameResult = error(Error),
TmpPieces = [words("Could not create temporary file:"),
quote(io.error_message(Error)), nl],
add_error_pieces(TmpPieces, !Specs),
HeaderCode = HeaderCode0,
PrimaryProcId = invalid_proc_id,
MaybeDataFileName = no
)
;
OpenCompileSpecs = [_ | _],
!:Specs = OpenCompileSpecs ++ !.Specs,
HeaderCode = HeaderCode0,
PrimaryProcId = invalid_proc_id,
MaybeDataFileName = no
).
%---------------------------------------------------------------------------%
:- type maybe_write_hash_tables
---> do_not_write_hash_tables
; write_hash_tables.
:- type maybe_write_data_table
---> do_not_write_data_table
; write_data_table.
% First pass of determinism inference. (out, out, ..., out) procs are
% multi and (in, in, .., in) procs are semidet. Return a list of procs
% containing both in's and out's. These need further analysis later
% in pass 2.
%
:- pred infer_determinism_pass_1(fact_table_gen_info::in,
maybe_write_hash_tables::out, maybe_write_data_table::out,
pred_info::in, pred_info::out) is det.
infer_determinism_pass_1(GenInfo,
WriteHashTables, WriteDataTable, !PredInfo) :-
pred_info_get_proc_table(!.PredInfo, ProcTable0),
ProcIds = pred_info_all_procids(!.PredInfo),
infer_procs_determinism_pass_1(GenInfo, ProcIds,
ProcTable0, ProcTable,
do_not_write_hash_tables, WriteHashTables,
do_not_write_data_table, WriteDataTable),
pred_info_set_proc_table(ProcTable, !PredInfo).
:- pred infer_procs_determinism_pass_1(fact_table_gen_info::in,
list(proc_id)::in, proc_table::in, proc_table::out,
maybe_write_hash_tables::in, maybe_write_hash_tables::out,
maybe_write_data_table::in, maybe_write_data_table::out) is det.
infer_procs_determinism_pass_1(_, [],
!ProcTable, !WriteHashTables, !WriteDataTable).
infer_procs_determinism_pass_1(GenInfo, [ProcId | ProcIds],
!ProcTable, !WriteHashTables, !WriteDataTable) :-
map.lookup(!.ProcTable, ProcId, ProcInfo0),
GenInfo = fact_table_gen_info(_, FactTableProcMap, _, _),
map.lookup(FactTableProcMap, ProcId, FactTableProcInfo),
FactTableProcInfo = fact_table_proc_info(_, ModeClass, _),
(
ModeClass = all_in,
InferredDetism = inferred(detism_semi),
!:WriteHashTables = write_hash_tables
;
ModeClass = all_out,
proc_info_get_declared_determinism(ProcInfo0, MaybeDetism),
( if
MaybeDetism = yes(Detism),
( Detism = detism_cc_multi
; Detism = detism_cc_non
)
then
InferredDetism = inferred(detism_cc_multi)
else
InferredDetism = inferred(detism_multi)
),
!:WriteDataTable = write_data_table
;
ModeClass = in_out,
% Don't have enough info to infer determinism yet.
% Put it off till the second pass.
InferredDetism = not_yet,
% Add to list and check in pass 2.
!:WriteHashTables = write_hash_tables,
!:WriteDataTable = write_data_table
),
( if InferredDetism = inferred(Determinism) then
proc_info_set_inferred_determinism(Determinism,
ProcInfo0, ProcInfo),
map.det_update(ProcId, ProcInfo, !ProcTable)
else
true
),
infer_procs_determinism_pass_1(GenInfo, ProcIds,
!ProcTable, !WriteHashTables, !WriteDataTable).
%---------------------------------------------------------------------------%
% Read in facts one by one and check and compile them.
%
:- pred read_in_and_compile_facts(io.text_input_stream::in, string::in,
maybe(io.text_output_stream)::in, int::in, pred_info::in,
int::in, list(fact_arg_info)::in, list(proc_stream)::in,
maybe(pair(io.text_output_stream, string))::in, int::in, int::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
read_in_and_compile_facts(FileStream, FileName, MaybeProgressStream,
FactTableSize, PredInfo, NumFactArgInfos, FactArgInfos,
ProcStreams, MaybeOutput, !FactNum, !Specs, !IO) :-
mercury_term_parser.read_term(FileStream, Result0, !IO),
(
Result0 = eof
;
Result0 = error(Message, LineNum),
Context = context(FileName, LineNum),
add_error_context_and_pieces(Context, [words(Message)], !Specs)
;
Result0 = term(VarSet, Term),
( if 0 = !.FactNum mod FactTableSize then
(
MaybeProgressStream = yes(ProgressStream),
io.format(ProgressStream, "%% Read fact %d\n",
[i(!.FactNum)], !IO)
;
MaybeProgressStream = no
)
else
true
),
check_fact_term(FileStream, FileName, MaybeProgressStream,
FactTableSize, PredInfo, NumFactArgInfos, FactArgInfos,
!.FactNum, VarSet, Term, ProcStreams, MaybeOutput,
CheckSpecs, !IO),
(
CheckSpecs = [],
!:FactNum = !.FactNum + 1
;
CheckSpecs = [_ | _],
!:Specs = CheckSpecs ++ !.Specs
),
read_in_and_compile_facts(FileStream, FileName, MaybeProgressStream,
FactTableSize, PredInfo, NumFactArgInfos, FactArgInfos,
ProcStreams, MaybeOutput, !FactNum, !Specs, !IO)
).
% Do syntactic and semantic checks on a fact term.
%
:- pred check_fact_term(io.text_input_stream::in, string::in,
maybe(io.text_output_stream)::in, int::in, pred_info::in,
int::in, list(fact_arg_info)::in, int::in, prog_varset::in, prog_term::in,
list(proc_stream)::in, maybe(pair(io.text_output_stream, string))::in,
list(error_spec)::out, io::di, io::uo) is det.
check_fact_term(FileStream, FileName, MaybeProgressStream, FactTableSize,
PredInfo, NumFactArgInfos, FactArgInfos, FactNum,
VarSet, Term, ProcStreams, MaybeOutput, Specs, !IO) :-
(
Term = term.variable(_, _),
io.get_line_number(FileStream, LineNum, !IO),
Context = context(FileName, LineNum),
Pieces = [words("Error: term is not a fact."), nl],
add_error_context_and_pieces(Context, Pieces, [], Specs)
;
Term = term.functor(Functor, ArgTerms0, Context),
( if Functor = term.atom(FunctorAtom) then
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
pred_info_get_name(PredInfo, PredName),
( if
(
PredOrFunc = pf_predicate,
FunctorAtom = PredName,
ArgTerms = ArgTerms0
;
PredOrFunc = pf_function,
FunctorAtom = "=",
ArgTerms0 = [BeforeEqualTerm, ResultTerm],
BeforeEqualTerm =
term.functor(term.atom(PredName), BeforeEqualTerms, _),
ArgTerms = BeforeEqualTerms ++ [ResultTerm]
)
then
check_fact_term_args(MaybeProgressStream, FactTableSize,
PredInfo, NumFactArgInfos, FactArgInfos,
FactNum, VarSet, ArgTerms, Context,
ProcStreams, MaybeOutput, Specs, !IO)
else
PredPieces = describe_one_pred_info_name(
should_not_module_qualify, PredInfo),
Pieces = [words("Error: clause is not for") | PredPieces]
++ [suffix("."), nl],
add_error_context_and_pieces(Context, Pieces, [], Specs)
)
else
Pieces = [words("Error: term is not a fact."), nl],
add_error_context_and_pieces(Context, Pieces, [], Specs)
)
).
:- pred check_fact_term_args(maybe(io.text_output_stream)::in, int::in,
pred_info::in, int::in, list(fact_arg_info)::in,
int::in, prog_varset::in, list(prog_term)::in, prog_context::in,
list(proc_stream)::in, maybe(pair(io.text_output_stream, string))::in,
list(error_spec)::out, io::di, io::uo) is det.
check_fact_term_args(MaybeProgressStream, FactTableSize, PredInfo,
NumFactArgInfos, FactArgInfos, FactNum, VarSet, ArgTerms, Context,
ProcStreams, MaybeOutput, Specs, !IO) :-
% Check that arity of the fact is correct.
list.length(ArgTerms, NumArgTerms),
( if NumFactArgInfos = NumArgTerms then
PredOrFunc = pred_info_is_pred_or_func(PredInfo),
check_fact_type_and_mode(PredOrFunc, VarSet,
FactArgInfos, ArgTerms, 1, FactArgs, [], Specs),
% XXX We should probably avoid executing some of the code below
% if Specs is not empty.
string.int_to_string(FactNum, FactNumStr),
write_sort_file_lines(FactNumStr, FactArgs,
is_primary_proc(FactArgInfos), ProcStreams, !IO),
% If there are no in_out modes to the predicate, we need to write out
% the facts at this point. If there are input modes, the facts are
% written out later on after being sorted on the first input mode.
( if
MaybeOutput = yes(OutputStream - StructName),
Specs = []
then
write_fact_data(OutputStream, MaybeProgressStream, FactTableSize,
StructName, FactArgs, FactNum, !IO)
else
% If list.map above fails, don't do anything here. The error will
% have already been reported in check_fact_type_and_mode.
true
)
else
Pieces = [words("Error: fact has wrong number of arguments."),
words("Expected"), int_fixed(NumFactArgInfos), words("arguments,"),
words("got"), int_fixed(NumArgTerms), suffix("."), nl],
add_error_context_and_pieces(Context, Pieces, [], Specs)
).
% Check that the mode of the fact is correct. All terms must be ground
% and be a constant of the expected type.
%
:- pred check_fact_type_and_mode(pred_or_func::in, prog_varset::in,
list(fact_arg_info)::in, list(prog_term)::in, int::in, list(fact_arg)::out,
list(error_spec)::in, list(error_spec)::out) is det.
check_fact_type_and_mode(_, _, [], [], _, [], !Specs).
check_fact_type_and_mode(_, _, [_ | _], [], _, _, !Specs) :-
unexpected($pred, "list length mismatch").
check_fact_type_and_mode(_, _, [], [_ | _], _, _, !Specs) :-
unexpected($pred, "list length mismatch").
check_fact_type_and_mode(PredOrFunc, VarSet,
[ArgInfo | ArgInfos], [ArgTerm | ArgTerms], ArgNum,
[FactArg | FactArgs], !Specs) :-
(
ArgTerm = term.variable(_, _),
report_arg_error(PredOrFunc, VarSet, ArgNum, ArgTerm, ArgTerms,
"Mode", "a ground term", FactArg, !Specs)
;
ArgTerm = term.functor(Functor, _SubTerms, _Context),
% The term parser should never generate an int, a float or a string
% with a nonempty list of subterms.
ArgInfo = fact_arg_info(ArgType, _, _),
(
ArgType = fact_arg_type_int,
( if Functor = term.integer(Base, Integer, signed, size_word) then
( if source_integer_to_int(Base, Integer, Int) then
FactArg = fact_arg_int(Int)
else
report_arg_error(PredOrFunc, VarSet, ArgNum,
ArgTerm, ArgTerms,
"Type", "an int that fits in a word", FactArg, !Specs)
)
else
report_arg_error(PredOrFunc, VarSet, ArgNum, ArgTerm, ArgTerms,
"Type", "an int", FactArg, !Specs)
)
;
ArgType = fact_arg_type_float,
( if Functor = term.float(Float) then
FactArg = fact_arg_float(Float)
else
report_arg_error(PredOrFunc, VarSet, ArgNum, ArgTerm, ArgTerms,
"Type", "a float", FactArg, !Specs)
)
;
ArgType = fact_arg_type_string,
( if Functor = term.string(Str) then
FactArg = fact_arg_string(Str)
else
report_arg_error(PredOrFunc, VarSet, ArgNum, ArgTerm, ArgTerms,
"Type", "a string", FactArg, !Specs)
)
)
),
check_fact_type_and_mode(PredOrFunc, VarSet,
ArgInfos, ArgTerms, ArgNum + 1, FactArgs, !Specs).
:- pred report_arg_error(pred_or_func::in, prog_varset::in, int::in,
prog_term::in, list(prog_term)::in, string::in, string::in,
fact_arg::out, list(error_spec)::in, list(error_spec)::out) is det.
report_arg_error(PredOrFunc, VarSet, ArgNum, ArgTerm, RemainingArgTerms,
TypeOrMode, Expected, DummyFactArg, !Specs) :-
ArgStr = describe_error_term(VarSet, ArgTerm),
ExpectedGotPieces = [words("expected"), words(Expected), suffix(","),
words("got"), quote(ArgStr), suffix("."), nl],
( if
PredOrFunc = pf_function,
RemainingArgTerms = []
then
Pieces = [words(TypeOrMode), words("error in"),
words("return value of function:") | ExpectedGotPieces]
else
Pieces = [words(TypeOrMode), words("error in"),
words("argument"), int_fixed(ArgNum), suffix(":")
| ExpectedGotPieces]
),
Context = get_term_context(ArgTerm),
add_error_context_and_pieces(Context, Pieces, !Specs),
DummyFactArg = fact_arg_string("dummy").
%---------------------------------------------------------------------------%
:- func fact_table_file_header(string) = string.
fact_table_file_header(FileName) = FileHeader :-
library.version(Version, Fullarch),
string.append_list(
["/*\n",
"** Automatically generated from `", FileName, "'\n",
"** by the Mercury compiler, version ", Version, ",\n",
"** configured for ", Fullarch, ".\n",
"** Do not edit.\n",
"*/\n",
"\n",
"#include ""mercury_imp.h""\n\n"],
FileHeader).
:- pred create_fact_table_header(sym_name::in, list(fact_arg_info)::in,
string::out, string::out) is det.
create_fact_table_header(PredSymName, FactArgInfos, HeaderCode, StructName) :-
make_fact_table_identifier(PredSymName, Identifier),
StructName = "mercury__" ++ Identifier ++ "_fact_table",
% Define a struct for a fact table entry.
create_fact_table_struct(FactArgInfos, 1, StructContents),
( if StructContents = "" then
StructDef = ""
else
StructDef = "struct " ++ StructName ++ "_struct {\n"
++ StructContents ++ "};\n\n"
),
HashDef = hash_def,
HeaderCode = StructDef ++ HashDef.
% Create a struct for the fact table consisting of any arguments
% that are output in some mode. Also ensure that are arguments are
% either string, float or int.
%
:- pred create_fact_table_struct(list(fact_arg_info)::in, int::in, string::out)
is det.
create_fact_table_struct([], _, "").
create_fact_table_struct([Info | Infos], ArgNum, StructContents) :-
create_fact_table_struct(Infos, ArgNum + 1, StructContentsTail),
Info = fact_arg_info(Type, _IsInput, IsOutput),
(
Type = fact_arg_type_int,
TypeStr = "MR_Integer"
;
Type = fact_arg_type_float,
TypeStr = "MR_Float"
;
Type = fact_arg_type_string,
TypeStr = "MR_ConstString"
),
(
IsOutput = is_in_or_output_for_some_mode,
string.format("\t%s V_%d;\n", [s(TypeStr), i(ArgNum)], StructField),
string.append(StructField, StructContentsTail, StructContents)
;
IsOutput = is_not_in_or_output_for_any_mode,
StructContents = StructContentsTail
).
% Define a struct for a hash table entry.
%
:- func hash_def = string.
hash_def = "
#ifndef MERCURY_FACT_TABLE_HASH_TABLES
#define MERCURY_FACT_TABLE_HASH_TABLES
struct MR_fact_table_hash_table_s {
MR_Integer size; // size of the hash table
struct MR_fact_table_hash_entry_s *table; // the actual table
};
struct MR_fact_table_hash_table_f {
MR_Integer size; // size of the hash table
struct MR_fact_table_hash_entry_f *table; // the actual table
};
struct MR_fact_table_hash_table_i {
MR_Integer size; // size of the hash table
struct MR_fact_table_hash_entry_i *table; // the actual table
};
// hash table for string keys
struct MR_fact_table_hash_entry_s {
MR_ConstString key; // lookup key
const MR_Word *index; // index into fact table data array or
// pointer to hash table for next argument
#if TAGBITS < 2
short type; // 0 if entry empty,
// 1 if entry is a pointer to the data table
// 2 if entry is a pointer to another
// hash table
#endif
int next; // location of next entry with the same hash
// value
};
// hash table for float keys
struct MR_fact_table_hash_entry_f {
MR_Float key;
const MR_Word *index;
#if TAGBITS < 2
short type;
#endif
int next;
};
// hash table for int keys
struct MR_fact_table_hash_entry_i {
MR_Integer key;
const MR_Word *index;
#if TAGBITS < 2
short type;
#endif
int next;
};
#if TAGBITS >= 2
#define MR_FACT_TABLE_MAKE_TAGGED_INDEX(i, t) \
MR_mkword(MR_mktag(t), MR_mkbody(i))
#define MR_FACT_TABLE_MAKE_TAGGED_POINTER(p, t) \
MR_mkword(MR_mktag(t), p)
#define MR_FACT_TABLE_HASH_ENTRY_TYPE(p) \
MR_tag((MR_Word)((p).index))
#define MR_FACT_TABLE_HASH_INDEX(w) \
MR_unmkbody(w)
#define MR_FACT_TABLE_HASH_POINTER(w) \
MR_body(w, MR_tag(w))
#else
#define MR_FACT_TABLE_MAKE_TAGGED_INDEX(i, t) \
((const MR_Word *) i), (t)
#define MR_FACT_TABLE_MAKE_TAGGED_POINTER(p, t) \
((const MR_Word *) p), (t)
#define MR_FACT_TABLE_HASH_ENTRY_TYPE(p) ((p).type)
#define MR_FACT_TABLE_HASH_INDEX(w) (w)
#define MR_FACT_TABLE_HASH_POINTER(w) (w)
#endif
#endif // not MERCURY_FACT_TABLE_HASH_TABLES
".
%---------------------------------------------------------------------------%
% open_sort_files(ProcIds, ProcStreams):
%
% Open a temporary sort file for each proc_id in ProcIds.
% Return a list of proc_streams for all the files opened.
%
:- pred open_sort_files(fact_table_proc_map::in,
list(proc_id)::in, list(proc_stream)::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
open_sort_files(_, [], [], !Specs, !IO).
open_sort_files(ProcMap, [HeadProcId | TailProcIds], ProcStreams,
!Specs, !IO) :-
open_temp_output(SortFileNameResult, !IO),
(
SortFileNameResult = ok({SortFileName, Stream}),
map.lookup(ProcMap, HeadProcId, ProcEntry),
ProcEntry = fact_table_proc_info(FactTableVars, _, _),
Modes = list.map((func(fact_table_var(_, M, _, _)) = M),
FactTableVars),
HeadProcStream = proc_stream(HeadProcId, Modes, SortFileName, Stream),
open_sort_files(ProcMap, TailProcIds, TailProcStreams, !Specs, !IO),
ProcStreams = [HeadProcStream | TailProcStreams]
;
SortFileNameResult = error(ErrorMessage),
ProcStreams = [],
add_error_pieces([words(ErrorMessage)], !Specs)
).
% close_sort_files(ProcStreams, ProcFiles, !IO):
%
% Close the sort file of each procedure, and return its name.
%
:- pred close_sort_files(list(proc_stream)::in,
assoc_list(proc_id, string)::out, io::di, io::uo) is det.
close_sort_files([], [], !IO).
close_sort_files([ProcStream | ProcStreams], [ProcId - FileName | ProcFiles],
!IO) :-
ProcStream = proc_stream(ProcId, _Modes, FileName, Stream),
io.close_output(Stream, !IO),
close_sort_files(ProcStreams, ProcFiles, !IO).
%---------------------%
:- type maybe_primary_proc
---> is_not_primary_proc
; is_primary_proc(list(fact_arg_info)).
% write_sort_file_lines(ModuleInfo, ProcStreams, ProcTable, Terms):
%
% Write out a line to each sort file for this fact. The line is made up
% of the input arguments of the procedure (the key) followed by the
% position of the fact in the original input table.
%
% Note lines written out here need to be read back in by
% read_sort_file_line, so if any changes are made here, corresponding
% changes should be made there too.
%
:- pred write_sort_file_lines(string::in, list(fact_arg)::in,
maybe_primary_proc::in, list(proc_stream)::in, io::di, io::uo) is det.
write_sort_file_lines(_, _, _, [], !IO).
write_sort_file_lines(FactNumStr, FactArgs, IsPrimary,
[ProcStream | ProcStreams], !IO) :-
ProcStream = proc_stream(_ProcId, Modes, _SortFileName, Stream),
make_sort_file_key(Modes, FactArgs, Key),
(
IsPrimary = is_primary_proc(FactArgInfos),
make_fact_data_string(FactArgInfos, FactArgs, DataString)
;
IsPrimary = is_not_primary_proc,
DataString = ""
),
io.format(Stream, "%s~%s~%s\n",
[s(Key), s(FactNumStr), s(DataString)], !IO),
write_sort_file_lines(FactNumStr, FactArgs, is_not_primary_proc,
ProcStreams, !IO).
% Create a key for the fact table entry.
% Arguments are separated by ":".
% Colons in string literals are replaced by "\c", tildes are replaced
% by "\t", newlines are replaced by "\n" and backslashes by "\\".
% This ensures that each possible set of arguments maps to a unique key
% and guarantees that duplicate keys will be adjacent after sorting
% with the sort program. The tilde ('~') character is used in the
% sort file to separate the sort key from the data.
%
:- pred make_sort_file_key(list(fact_table_mode)::in, list(fact_arg)::in,
string::out) is det.
make_sort_file_key([], [], "").
make_sort_file_key([], [_ | _], _) :-
unexpected($pred, "list length mismatch").
make_sort_file_key([_ | _], [], _) :-
unexpected($pred, "list length mismatch").
make_sort_file_key([HeadMode | TailModes], [HeadArg | TailArgs], Key) :-
make_sort_file_key(TailModes, TailArgs, TailKey),
(
HeadMode = fully_in,
HeadKey = make_key_part(HeadArg),
Key = HeadKey ++ ":" ++ TailKey
;
HeadMode = fully_out,
Key = TailKey
).
% Like make_sort_file_key but for the output arguments of the fact.
%
:- pred make_fact_data_string(list(fact_arg_info)::in, list(fact_arg)::in,
string::out) is det.
make_fact_data_string([], [], "").
make_fact_data_string([], [_ | _], _) :-
unexpected($pred, "list length mismatch").
make_fact_data_string([_ | _], [], _) :-
unexpected($pred, "list length mismatch").
make_fact_data_string([HeadInfo | TailInfos], [HeadArg | TailArgs], String) :-
make_fact_data_string(TailInfos, TailArgs, TailString),
HeadInfo = fact_arg_info(_, _, HeadIsOutput),
(
HeadIsOutput = is_in_or_output_for_some_mode,
HeadString = make_key_part(HeadArg),
String = HeadString ++ ":" ++ TailString
;
HeadIsOutput = is_not_in_or_output_for_any_mode,
String = TailString
).
:- func make_key_part(fact_arg) = string.
make_key_part(Arg) = Key :-
(
Arg = fact_arg_int(Int),
% Print the integer in base 36 to reduce the amount of I/O that we do.
Key = string.int_to_base_string(Int, 36)
;
Arg = fact_arg_float(F),
Key = string.float_to_string(F)
;
Arg = fact_arg_string(Str),
string.to_char_list(Str, Chars),
key_from_chars(Chars, EscapedChars),
string.from_char_list(EscapedChars, Key)
).
% Escape all backslashes with a backslash, and replace all newlines
% with "\n", colons with "\c" and tildes with "\t".
%
:- pred key_from_chars(list(char)::in, list(char)::out) is det.
key_from_chars(Chars, EscapedChars) :-
key_from_chars_loop(Chars, cord.init, EscapedCharsCord),
EscapedChars = cord.to_list(EscapedCharsCord).
:- pred key_from_chars_loop(list(char)::in, cord(char)::in, cord(char)::out)
is det.
key_from_chars_loop([], !EscapedCharsCord).
key_from_chars_loop([Char | Chars], !EscapedCharsCord) :-
( if Char = ('\\') then
!:EscapedCharsCord = !.EscapedCharsCord ++ cord.from_list(['\\', '\\'])
else if Char = ('\n') then
!:EscapedCharsCord = !.EscapedCharsCord ++ cord.from_list(['\\', 'n'])
else if Char = (':') then
!:EscapedCharsCord = !.EscapedCharsCord ++ cord.from_list(['\\', 'c'])
else if Char = ('~') then
!:EscapedCharsCord = !.EscapedCharsCord ++ cord.from_list(['\\', 't'])
else
cord.snoc(Char, !EscapedCharsCord)
),
key_from_chars_loop(Chars, !EscapedCharsCord).
%---------------------------------------------------------------------------%
% infer_determinism_pass_2(ModuleInfo, GenInfo, ProcFiles,
% !ProcTable, !Specs, !IO):
%
% Run `sort' on each sort file to see if the keys are unique.
% If they are, the procedure is semidet, otherwise it is nondet.
% Return the updated proc_table.
%
:- pred infer_determinism_pass_2(maybe(io.text_output_stream)::in,
fact_table_gen_info::in, assoc_list(proc_id, string)::in,
proc_table::in, proc_table::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
infer_determinism_pass_2(_, _, [], !ProcTable, !Specs, !IO).
infer_determinism_pass_2(MaybeProgressStream, GenInfo,
[ProcId - FileName | ProcFiles], !ProcTable, !Specs, !IO) :-
map.lookup(!.ProcTable, ProcId, ProcInfo0),
% XXX This sends the output to the *input* file.
% This works in the usual implementations of sort,
% since you have to finish reading the input before you can generate
% any part of the output, but it is not *guaranteed* to work,
% since sort may *open* the output file before finishing reading.
% XXX Also, this requires "sort" and "cut" to be installed,
% but we don't check that. We should have autoconf tests for their
% presence/absence, and if either is absent, we should generate
% a more specific error message than what results from the failure
% of Command.
string.format(
"LC_ALL=C sort -o %s %s && " ++
"cut -d'~' -f1 %s | LC_ALL=C sort -cu >/dev/null 2>&1",
[s(FileName), s(FileName), s(FileName)], Command0),
make_command_string(Command0, double, Command),
(
MaybeProgressStream = no,
io.call_system.call_system(Command, Result, !IO)
;
MaybeProgressStream = yes(ProgressStream),
io.format(ProgressStream, "%% Invoking system command `%s' ...",
[s(Command)], !IO),
io.call_system.call_system(Command, Result, !IO),
io.write_string(ProgressStream, "done.\n", !IO)
),
(
Result = ok(ExitStatus),
% sort -cu returns 0 if file is sorted and contains no duplicate keys,
% >=1 if duplicate keys exist.
( if
(
ExitStatus = 0
;
GenInfo = fact_table_gen_info(_, _, MaybeAllInProcId, _),
% This is an all_in mode so it is semidet.
% XXX This means that *some* procedure is all_in,
% but what allows that comment to say that *this* procedure
% is all_in?
MaybeAllInProcId = yes(_),
ProcFiles = []
)
then
% No duplicate keys => procedure is semidet.
Determinism = detism_semi
else if
ExitStatus >= 1
then
% Duplicate keys => procedure is nondet.
proc_info_get_declared_determinism(ProcInfo0, MaybeDet),
( if
( MaybeDet = yes(detism_cc_multi)
; MaybeDet = yes(detism_cc_non)
)
then
Determinism = detism_cc_non
else
Determinism = detism_non
)
else
io.progname_base("mercury_compile", ProgName, !IO),
Pieces =
[fixed(ProgName), suffix(":"), words("an error occurred"),
words("in ether the"), quote("sort"),
words("or the"), quote("cut"), words("program"),
words("during fact table determinism inference."), nl],
Spec = simplest_no_context_spec($pred, severity_error,
phase_fact_table_check, Pieces),
!:Specs = [Spec | !.Specs],
Determinism = detism_erroneous
)
;
Result = error(ErrorCode),
add_call_system_error("sort", ErrorCode, !Specs, !IO),
Determinism = detism_erroneous
),
proc_info_set_inferred_determinism(Determinism, ProcInfo0, ProcInfo),
map.det_update(ProcId, ProcInfo, !ProcTable),
infer_determinism_pass_2(MaybeProgressStream, GenInfo, ProcFiles,
!ProcTable, !Specs, !IO).
%---------------------------------------------------------------------------%
% Write out the fact table data arrays and hash tables.
%
:- pred write_fact_table_arrays(maybe(io.text_output_stream)::in,
io.text_output_stream::in, int::in,
module_info::in, assoc_list(proc_id, string)::in, string::in,
fact_table_proc_map::in, string::in, int::in, list(fact_arg_info)::in,
maybe_write_hash_tables::in, maybe_write_data_table::in,
string::out, proc_id::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
write_fact_table_arrays(MaybeProgressStream, OutputStream, FactTableSize,
ModuleInfo, ProcFiles, DataFileName, FactTableProcMap,
StructName, NumFacts, FactArgInfos, WriteHashTables, WriteDataTable,
HeaderCode, PrimaryProcId, !Specs, !IO) :-
(
% No sort files => there was only and all_out mode
% => nothing left to be done here.
ProcFiles = [],
HeaderCode = "",
% This won't get used anyway.
PrimaryProcId = hlds_pred.initial_proc_id
;
ProcFiles = [PrimaryProcId - FileName | TailProcFiles],
(
WriteHashTables = write_hash_tables,
(
TailProcFiles = [],
CreateFactMap = do_not_create_fact_map
;
% If there we need to build secondary hash tables (i.e. if
% there is >1 input mode) we need to create a ``FactMap''
% while writing out the primary table.
TailProcFiles = [_ | _],
CreateFactMap = create_fact_map
),
write_primary_hash_table(MaybeProgressStream, OutputStream,
FactTableSize, ModuleInfo, FactTableProcMap, PrimaryProcId,
FileName, DataFileName, StructName, FactArgInfos,
WriteDataTable, NumFacts, CreateFactMap, PrimaryResult,
!Specs, !IO),
(
PrimaryResult = ok(FactMap, PrimaryHeaderCode),
write_secondary_hash_tables(MaybeProgressStream, OutputStream,
FactTableSize, ModuleInfo, FactTableProcMap, StructName,
FactArgInfos, FactMap, TailProcFiles,
"", SecondaryHeadCode, !Specs, !IO),
HeaderCode = PrimaryHeaderCode ++ SecondaryHeadCode
;
PrimaryResult = error,
HeaderCode = ""
)
;
WriteHashTables = do_not_write_hash_tables,
HeaderCode = ""
)
).
% Write out the data for the fact table.
%
:- pred write_fact_table_data(io.text_output_stream::in,
maybe(io.text_output_stream)::in, int::in, string::in,
list(list(fact_arg))::in, int::in, io::di, io::uo) is det.
write_fact_table_data(_, _, _, _, [], _, !IO).
write_fact_table_data(OutputStream, MaybeProgressStream, FactTableSize,
StructName, [Fact | Facts], FactNum, !IO) :-
write_fact_data(OutputStream, MaybeProgressStream, FactTableSize,
StructName, Fact, FactNum, !IO),
write_fact_table_data(OutputStream, MaybeProgressStream, FactTableSize,
StructName, Facts, FactNum + 1, !IO).
% Write out the data for a single fact, starting a new array if necessary.
% Note: this predicate will not write the declaration or opening brace
% for the first array or the closing brace of the last array.
%
:- pred write_fact_data(io.text_output_stream::in,
maybe(io.text_output_stream)::in, int::in, string::in,
list(fact_arg)::in, int::in, io::di, io::uo) is det.
write_fact_data(OutputStream, MaybeProgressStream, FactTableSize,
StructName, Args, FactNum, !IO) :-
( if 0 = FactNum mod FactTableSize then
( if FactNum = 0 then
true
else
write_closing_brace(OutputStream, !IO),
write_new_data_array_opening_brace(OutputStream, StructName,
FactNum, !IO)
),
(
MaybeProgressStream = yes(ProgressStream),
io.format(ProgressStream,
"%% Writing fact %d\n", [i(FactNum)], !IO)
;
MaybeProgressStream = no
)
else
true
),
io.write_string(OutputStream, "\t{", !IO),
write_fact_args(OutputStream, Args, !IO),
io.write_string(OutputStream, " },\n", !IO).
% Write out the declaration of a new data array followed by " = {\n".
%
:- pred write_new_data_array_opening_brace(io.text_output_stream::in,
string::in, int::in, io::di, io::uo) is det.
write_new_data_array_opening_brace(OutputStream, StructName, FactNum, !IO) :-
io.format(OutputStream, "const struct %s_struct %s%d[] = {\n",
[s(StructName), s(StructName), i(FactNum)], !IO).
% Write out the closing brace of an array.
%
:- pred write_closing_brace(io.text_output_stream::in, io::di, io::uo) is det.
write_closing_brace(OutputStream, !IO) :-
io.write_string(OutputStream, "};\n\n", !IO).
:- pred write_fact_args(io.text_output_stream::in, list(fact_arg)::in,
io::di, io::uo) is det.
write_fact_args(_, [], !IO).
write_fact_args(OutputStream, [FactArg | FactArgs], !IO) :-
(
FactArg = fact_arg_string(String),
output_quoted_string_c(OutputStream, String, !IO),
io.write_string(OutputStream, ", ", !IO)
;
FactArg = fact_arg_int(Int),
io.write_int(OutputStream, Int, !IO),
io.write_string(OutputStream, ", ", !IO)
;
FactArg = fact_arg_float(Float),
io.write_float(OutputStream, Float, !IO),
io.write_string(OutputStream, ", ", !IO)
),
write_fact_args(OutputStream, FactArgs, !IO).
% If a data table has been created in a separate file, append it to the
% end of the main output file and then delete it.
%
:- pred append_data_table(maybe(io.text_output_stream)::in,
string::in, string::in, list(error_spec)::in, list(error_spec)::out,
io::di, io::uo) is det.
append_data_table(MaybeProgressStream, OutputFileName, DataFileName,
!Specs, !IO) :-
make_command_string(string.format("cat %s >>%s",
[s(DataFileName), s(OutputFileName)]), forward, Command),
(
MaybeProgressStream = no,
io.call_system.call_system(Command, Result, !IO)
;
MaybeProgressStream = yes(ProgressStream),
io.format(ProgressStream, "%% Invoking system command `%s' ...",
[s(Command)], !IO),
io.call_system.call_system(Command, Result, !IO),
io.write_string(ProgressStream, "done.\n", !IO)
),
(
Result = ok(ExitStatus),
( if ExitStatus = 0 then
true
else
Pieces = [words("An error occurred while concatenating"),
words("fact table output files."), nl],
Spec = simplest_no_context_spec($pred, severity_error,
phase_fact_table_check, Pieces),
!:Specs = [Spec | !.Specs]
)
;
Result = error(ErrorCode),
add_call_system_error("cat", ErrorCode, !Specs, !IO)
),
delete_temporary_file(DataFileName, !Specs, !IO).
:- type fact_result
---> ok(map(int, int), string)
; error.
% Write hash tables for the primary key. Create a map from indices in the
% original input table to the table sorted on the primary key.
% Write out the data table if required.
%
:- pred write_primary_hash_table(maybe(io.text_output_stream)::in,
io.text_output_stream::in, int::in,
module_info::in, fact_table_proc_map::in, proc_id::in,
string::in, string::in, string::in, list(fact_arg_info)::in,
maybe_write_data_table::in, int::in, maybe_create_fact_map::in,
fact_result::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
write_primary_hash_table(MaybeProgressStream, OutputStream, FactTableSize,
ModuleInfo, FactTableProcMap, ProcId, FileName, DataFileName,
StructName, FactArgInfos, WriteDataTable, NumFacts,
CreateFactMap, Result, !Specs, !IO) :-
io.open_input(FileName, FileResult, !IO),
(
FileResult = ok(FileStream),
(
WriteDataTable = write_data_table,
io.open_output(DataFileName, OpenResult, !IO),
(
OpenResult = ok(DataStream),
proc_id_to_int(ProcId, ProcIdInt),
string.format("%s_hash_table_%d_",
[s(StructName), i(ProcIdInt)], HashTableName),
% Note: the type declared here is not necessarily correct.
% We declare it just to stop the C compiler emitting warnings.
string.format(
"extern struct MR_fact_table_hash_table_i %s0;\n",
[s(HashTableName)], HeaderCode0),
map.lookup(FactTableProcMap, ProcId, FactTableProcInfo),
FactTableProcInfo = fact_table_proc_info(FactTableVars, _, _),
FactTableModes =
list.map((func(fact_table_var(_, M, _, _)) = M),
FactTableVars),
read_sort_file_line(FileStream, FileName,
FactArgInfos, FactTableModes, MaybeFirstFact, !Specs, !IO),
% Output opening brace for first fact array,
% XXX This design is inelegant.
write_new_data_array_opening_brace(DataStream, StructName,
0, !IO),
(
MaybeFirstFact = yes(FirstFact),
build_hash_table(MaybeProgressStream, FileStream, FileName,
OutputStream, yes(DataStream), FactTableSize,
ModuleInfo, primary_table, StructName, FactArgInfos,
FactTableModes, 0, HashTableName, 0, FirstFact, 0,
CreateFactMap, map.init, FactMap1, !Specs, !IO),
MaybeFactMap = yes(FactMap1)
;
MaybeFirstFact = no,
MaybeFactMap = no
),
% Closing brace for last fact data array.
write_closing_brace(DataStream, !IO),
write_fact_table_pointer_array(DataStream, FactTableSize,
StructName, NumFacts, HeaderCode1, !IO),
io.close_output(DataStream, !IO),
(
MaybeFactMap = no,
Result = error
;
MaybeFactMap = yes(FactMap),
HeaderCode = HeaderCode0 ++ HeaderCode1,
Result = ok(FactMap, HeaderCode)
)
;
OpenResult = error(Error),
add_file_open_error(no, DataFileName, "output", Error,
!Specs, !IO),
Result = error
)
;
WriteDataTable = do_not_write_data_table,
Result = error
),
io.close_input(FileStream, !IO),
delete_temporary_file(FileName, !Specs, !IO)
;
FileResult = error(Error),
add_file_open_error(no, FileName, "input", Error, !Specs, !IO),
Result = error
).
% Build hash tables for non-primary input procs.
%
:- pred write_secondary_hash_tables(maybe(io.text_output_stream)::in,
io.text_output_stream::in, int::in,
module_info::in, fact_table_proc_map::in, string::in,
list(fact_arg_info)::in, map(int, int)::in,
assoc_list(proc_id, string)::in,
string::in, string::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
write_secondary_hash_tables(_, _, _, _, _, _, _, _, [],
!HeaderCode, !Specs, !IO).
write_secondary_hash_tables(MaybeProgressStream, OutputStream, FactTableSize,
ModuleInfo, FactTableProcMap, StructName, FactArgInfos, FactMap,
[ProcId - FileName | ProcFiles], !HeaderCode, !Specs, !IO) :-
io.open_input(FileName, FileResult, !IO),
(
FileResult = ok(FileStream),
proc_id_to_int(ProcId, ProcIdInt),
string.format("%s_hash_table_%d_",
[s(StructName), i(ProcIdInt)], HashTableName),
% Note: the type declared here is not necessarily correct.
% The type is declared just to stop the C compiler emitting warnings.
string.format(
"extern struct MR_fact_table_hash_table_i %s0;\n",
[s(HashTableName)], StructDeclCode),
!:HeaderCode = !.HeaderCode ++ StructDeclCode,
map.lookup(FactTableProcMap, ProcId, FactTableProcInfo),
FactTableProcInfo = fact_table_proc_info(FactTableVars, _, _),
FactTableModes = list.map((func(fact_table_var(_, M, _, _)) = M),
FactTableVars),
read_sort_file_line(FileStream, FileName,
FactArgInfos, FactTableModes, MaybeFirstFact, !Specs, !IO),
(
MaybeFirstFact = yes(FirstFact),
build_hash_table(MaybeProgressStream, FileStream, FileName,
OutputStream, no, FactTableSize, ModuleInfo, not_primary_table,
StructName, FactArgInfos, FactTableModes, 0, HashTableName, 0,
FirstFact, 0, do_not_create_fact_map, FactMap, _, !Specs, !IO),
io.close_input(FileStream, !IO),
delete_temporary_file(FileName, !Specs, !IO),
write_secondary_hash_tables(MaybeProgressStream, OutputStream,
FactTableSize, ModuleInfo, FactTableProcMap, StructName,
FactArgInfos, FactMap, ProcFiles, !HeaderCode, !Specs, !IO)
;
MaybeFirstFact = no,
io.close_input(FileStream, !IO)
)
;
FileResult = error(Error),
add_file_open_error(no, FileName, "input", Error, !Specs, !IO)
).
%---------------------------------------------------------------------------%
:- pred read_sort_file_line(io.text_input_stream::in, string::in,
list(fact_arg_info)::in, list(fact_table_mode)::in,
maybe(sort_file_line)::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
read_sort_file_line(InputStream, InputFileName,
FactArgInfos, Modes, MaybeSortFileLine, !Specs, !IO) :-
io.read_line(InputStream, Result, !IO),
(
Result = ok(LineChars),
string.from_char_list(LineChars, LineString),
split_sort_file_line(FactArgInfos, Modes, LineString, SortFileLine),
MaybeSortFileLine = yes(SortFileLine)
;
Result = eof,
MaybeSortFileLine = no
;
Result = error(ErrorCode),
io.error_message(ErrorCode, ErrorMessage),
Pieces =
[words("Error reading file"), quote(InputFileName),
suffix(":"), nl,
words(ErrorMessage), nl],
Spec = simplest_no_context_spec($pred, severity_error,
phase_fact_table_check, Pieces),
!:Specs = [Spec | !.Specs],
MaybeSortFileLine = no
).
% Break up a string into the components of a sort file line.
%
:- pred split_sort_file_line(list(fact_arg_info)::in,
list(fact_table_mode)::in, string::in, sort_file_line::out) is det.
split_sort_file_line(FactArgInfos, Modes, Line0, SortFileLine) :-
( if
string.sub_string_search(Line0, "~", Pos0),
string.split(Line0, Pos0, InputArgsString, Line1),
string.first_char(Line1, _, Line2),
string.sub_string_search(Line2, "~", Pos1),
string.split(Line2, Pos1, IndexString, Line3),
string.first_char(Line3, _, Line4),
string.remove_suffix(Line4, "\n", OutputArgsString),
string.to_int(IndexString, Index0)
then
split_key_to_arg_strings(InputArgsString, InputArgStrings),
get_input_args_list(FactArgInfos, Modes,
InputArgStrings, InputArgs),
split_key_to_arg_strings(OutputArgsString, OutputArgStrings),
(
% Only extract the output arguments if they have actually been
% written to this sort file.
OutputArgStrings = [_ | _],
get_output_args_list(FactArgInfos, OutputArgStrings, OutputArgs)
;
OutputArgStrings = [],
OutputArgs = []
),
SortFileLine = sort_file_line(InputArgs, Index0, OutputArgs)
else
unexpected($pred, "sort file format incorrect")
).
% Split up a string containing a sort file key into a list of strings
% containing the key arguments. Arguments in the key are separated by `:'.
%
:- pred split_key_to_arg_strings(string::in, list(string)::out) is det.
split_key_to_arg_strings(Key0, ArgStrings) :-
( if Key0 = "" then
ArgStrings = []
else
( if
string.sub_string_search(Key0, ":", Pos),
string.split(Key0, Pos, ArgString, Key1),
string.first_char(Key1, _, Key2)
then
split_key_to_arg_strings(Key2, ArgStrings0),
ArgStrings = [ArgString | ArgStrings0]
else
unexpected($pred, "sort file key format is incorrect")
)
).
:- pred get_input_args_list(list(fact_arg_info)::in, list(fact_table_mode)::in,
list(string)::in, list(fact_arg)::out) is det.
get_input_args_list([], [], _, []).
get_input_args_list([_ | _], [], _, _) :-
unexpected($pred, "too many fact_arg_infos").
get_input_args_list([], [_ | _], _, _) :-
unexpected($pred, "too many argmodes").
get_input_args_list([Info | Infos], [Mode | Modes], ArgStrings0, Args) :-
(
Mode = fully_in,
(
ArgStrings0 = [ArgString | ArgStrings],
Info = fact_arg_info(Type, _, _),
convert_key_string_to_arg(ArgString, Type, Arg),
get_input_args_list(Infos, Modes, ArgStrings, ArgsTail),
Args = [Arg | ArgsTail]
;
ArgStrings0 = [],
unexpected($pred, "not enough ArgStrings")
)
;
Mode = fully_out,
% This argument is not input, so skip it and try the next one.
get_input_args_list(Infos, Modes, ArgStrings0, Args)
).
:- pred get_output_args_list(list(fact_arg_info)::in, list(string)::in,
list(fact_arg)::out) is det.
get_output_args_list([], _, []).
get_output_args_list([Info | Infos], ArgStrings0, Args) :-
Info = fact_arg_info(Type, _, IsOutput),
(
IsOutput = is_in_or_output_for_some_mode,
(
ArgStrings0 = [ArgString | ArgStrings],
convert_key_string_to_arg(ArgString, Type, Arg),
get_output_args_list(Infos, ArgStrings, Args0),
Args = [Arg | Args0]
;
ArgStrings0 = [],
unexpected($pred, "not enough ArgStrings")
)
;
IsOutput = is_not_in_or_output_for_any_mode,
get_output_args_list(Infos, ArgStrings0, Args)
).
:- pred convert_key_string_to_arg(string::in, fact_arg_type::in, fact_arg::out)
is det.
convert_key_string_to_arg(ArgString, Type, Arg) :-
(
Type = fact_arg_type_int,
( if string.base_string_to_int(36, ArgString, Int) then
Arg = fact_arg_int(Int)
else
unexpected($pred, "could not convert string to int")
)
;
Type = fact_arg_type_float,
( if string.to_float(ArgString, F) then
Arg = fact_arg_float(F)
else
unexpected($pred, "could not convert string to float")
)
;
Type = fact_arg_type_string,
string.to_char_list(ArgString, Chars0),
remove_sort_file_escapes(Chars0, [], RevChars),
list.reverse(RevChars, Chars),
string.from_char_list(Chars, S),
Arg = fact_arg_string(S)
).
% Remove the escape characters put in the string by make_sort_file_key.
%
:- pred remove_sort_file_escapes(list(char)::in,
list(char)::in, list(char)::out) is det.
remove_sort_file_escapes([], !RevChars).
remove_sort_file_escapes([C0 | Cs0], !RevChars) :-
( if C0 = ('\\') then
(
Cs0 = [C1 | Cs1],
( if C1 = ('\\') then
C = ('\\')
else if C1 = ('c') then
C = (':')
else if C1 = ('t') then
C = ('~')
else if C1 = ('n') then
C = ('\n')
else
unexpected($pred, "something went wrong")
),
!:RevChars = [C | !.RevChars],
remove_sort_file_escapes(Cs1, !RevChars)
;
Cs0 = [],
unexpected($pred, "something went wrong")
)
else
!:RevChars = [C0 | !.RevChars],
remove_sort_file_escapes(Cs0, !RevChars)
).
%---------------------------------------------------------------------------%
:- type maybe_primary_table
---> not_primary_table
; primary_table.
:- type maybe_create_fact_map
---> do_not_create_fact_map
; create_fact_map.
% Build and write out a top level hash table and all the lower level
% tables connected to it.
%
:- pred build_hash_table(maybe(io.text_output_stream)::in,
io.text_input_stream::in, string::in,
io.text_output_stream::in, maybe(io.text_output_stream)::in, int::in,
module_info::in, maybe_primary_table::in, string::in,
list(fact_arg_info)::in, list(fact_table_mode)::in,
int::in, string::in, int::in, sort_file_line::in, int::in,
maybe_create_fact_map::in, map(int, int)::in, map(int, int)::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
build_hash_table(MaybeProgressStream, InputStream, InputFileName, OutputStream,
MaybeDataStream, FactTableSize, ModuleInfo, IsPrimaryTable,
StructName, Infos, Modes, InputArgNum, HashTableName, TableNum,
FirstFact, FactNum, CreateFactMap, !FactMap, !Specs, !IO) :-
build_hash_table_loop(MaybeProgressStream, InputStream, InputFileName,
OutputStream, MaybeDataStream, FactTableSize, ModuleInfo,
IsPrimaryTable, StructName, Infos, Modes, InputArgNum,
HashTableName, TableNum, FirstFact, FactNum, CreateFactMap,
!FactMap, [], HashList, !Specs, !IO),
list.length(HashList, Len),
module_info_get_globals(ModuleInfo, Globals),
calculate_hash_table_size(Globals, Len, HashSize),
hash_table_init(HashSize, HashTable0),
hash_table_from_list(HashList, HashSize, HashTable0, HashTable),
write_hash_table(OutputStream, HashTableName, TableNum, HashTable, !IO).
:- pred build_hash_table_loop(maybe(io.text_output_stream)::in,
io.text_input_stream::in, string::in,
io.text_output_stream::in, maybe(io.text_output_stream)::in, int::in,
module_info::in, maybe_primary_table::in, string::in,
list(fact_arg_info)::in, list(fact_table_mode)::in,
int::in, string::in, int::in, sort_file_line::in, int::in,
maybe_create_fact_map::in, map(int, int)::in, map(int, int)::out,
list(hash_entry)::in, list(hash_entry)::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
build_hash_table_loop(MaybeProgressStream, InputStream, InputFileName,
OutputStream, MaybeDataStream, FactTableSize, ModuleInfo,
IsPrimaryTable, StructName, Infos, Modes, InputArgNum,
HashTableName, !.TableNum, FirstFact, FactNum, CreateFactMap,
!FactMap, !HashList, !Specs, !IO) :-
top_level_collect_matching_facts(InputStream, InputFileName,
Infos, Modes, FirstFact, MatchingFacts, MaybeNextFact, !Specs, !IO),
(
CreateFactMap = create_fact_map,
update_fact_map(FactNum, MatchingFacts, !FactMap)
;
CreateFactMap = do_not_create_fact_map
),
(
MaybeDataStream = yes(DataStream),
OutputData = list.map(
(func(sort_file_line(_, _, OutArgs)) = OutArgs),
MatchingFacts),
write_fact_table_data(DataStream, MaybeProgressStream, FactTableSize,
StructName, OutputData, FactNum, !IO)
;
MaybeDataStream = no
),
module_info_get_globals(ModuleInfo, Globals),
do_build_hash_table(OutputStream, Globals, IsPrimaryTable,
!.FactMap, FactNum, InputArgNum, HashTableName,
MatchingFacts, !TableNum, !HashList, !IO),
(
MaybeNextFact = no
;
MaybeNextFact = yes(NextFact),
list.length(MatchingFacts, Len),
NextFactNum = FactNum + Len,
build_hash_table_loop(MaybeProgressStream, InputStream, InputFileName,
OutputStream, MaybeDataStream, FactTableSize, ModuleInfo,
IsPrimaryTable, StructName, Infos, Modes, InputArgNum,
HashTableName, !.TableNum, NextFact, NextFactNum, CreateFactMap,
!FactMap, !HashList, !Specs, !IO)
).
% Build a lower level hash table. The main difference to build_hash_table
% (above) is that ``sort file lines'' are read from a list rather than
% from the actual sort file.
%
:- pred build_hash_table_lower_levels(io.text_output_stream::in, globals::in,
maybe_primary_table::in, map(int, int)::in, int::in, string::in,
list(sort_file_line)::in, int::in, int::in, int::out,
io::di, io::uo) is det.
build_hash_table_lower_levels(OutputStream, Globals, IsPrimaryTable, FactMap,
InputArgNum, HashTableName, Facts, FactNum,
TableNum0, TableNum, !IO) :-
build_hash_table_lower_levels_loop(OutputStream, Globals, IsPrimaryTable,
FactMap, InputArgNum, HashTableName, Facts, FactNum,
TableNum0, TableNum, [], HashList, !IO),
list.length(HashList, Len),
calculate_hash_table_size(Globals, Len, HashSize),
hash_table_init(HashSize, HashTable0),
hash_table_from_list(HashList, HashSize, HashTable0, HashTable),
write_hash_table(OutputStream, HashTableName, TableNum0, HashTable, !IO).
:- pred build_hash_table_lower_levels_loop(io.text_output_stream::in,
globals::in, maybe_primary_table::in, map(int, int)::in, int::in,
string::in, list(sort_file_line)::in, int::in, int::in, int::out,
list(hash_entry)::in, list(hash_entry)::out, io::di, io::uo) is det.
build_hash_table_lower_levels_loop(_, _, _, _, _, _,
[], _, !TableNum, !HashList, !IO).
build_hash_table_lower_levels_loop(OutputStream, Globals, IsPrimaryTable,
FactMap, InputArgNum, HashTableName,
[Fact | Facts0], FactNum, !TableNum, !HashList, !IO) :-
lower_level_collect_matching_facts(InputArgNum, Fact, Facts0,
MatchingFacts, RemainingFacts),
do_build_hash_table(OutputStream, Globals, IsPrimaryTable,
FactMap, FactNum, InputArgNum, HashTableName,
MatchingFacts, !TableNum, !HashList, !IO),
list.length(MatchingFacts, Len),
NextFactNum = FactNum + Len,
build_hash_table_lower_levels_loop(OutputStream, Globals, IsPrimaryTable,
FactMap, InputArgNum, HashTableName,
RemainingFacts, NextFactNum, !TableNum, !HashList, !IO).
% This is where most of the actual work is done in building up the
% hash table.
%
:- pred do_build_hash_table(io.text_output_stream::in, globals::in,
maybe_primary_table::in, map(int, int)::in, int::in, int::in, string::in,
list(sort_file_line)::in, int::in, int::out,
list(hash_entry)::in, list(hash_entry)::out, io::di, io::uo) is det.
do_build_hash_table(OutputStream, Globals, IsPrimaryTable, FactMap,
FactNum, InputArgNum, HashTableName, Facts,
!TableNum, !HashList, !IO) :-
(
Facts = [],
unexpected($pred, "no facts")
;
Facts = [Fact | TailFacts],
fact_get_arg_and_index(Fact, InputArgNum, Arg, Index),
(
IsPrimaryTable = primary_table,
HashIndex = FactNum
;
IsPrimaryTable = not_primary_table,
map.lookup(FactMap, Index, HashIndex)
),
(
TailFacts = [],
% If only one matching index, insert a pointer to the fact table
% entry into the current hash table.
!:HashList = [hash_entry(Arg, fact(HashIndex), -1) | !.HashList]
;
TailFacts = [_ | _],
( if
% See if there are any more input arguments.
NextInputArgNum = InputArgNum + 1,
Fact = sort_file_line(InputArgs, _, _),
N = NextInputArgNum + 1,
list.drop(N, InputArgs, _)
then
!:TableNum = !.TableNum + 1,
ThisTableNum = !.TableNum,
build_hash_table_lower_levels(OutputStream, Globals,
IsPrimaryTable, FactMap, NextInputArgNum,
HashTableName, Facts, FactNum, !TableNum, !IO),
EntryIndex = hash_table(ThisTableNum, HashTableName),
!:HashList = [hash_entry(Arg, EntryIndex, -1) | !.HashList]
else
(
IsPrimaryTable = primary_table,
% Insert only the first matching index into the hash table.
Entry = hash_entry(Arg, fact(HashIndex), -1),
!:HashList = [Entry | !.HashList]
;
IsPrimaryTable = not_primary_table,
% Insert all matching indexes into the hash table.
hash_list_insert_many(IsPrimaryTable, FactMap, FactNum,
InputArgNum, Facts, !HashList)
)
)
)
).
%---------------------%
% Read lines from the sort file that have the same first input
% argument as Fact. Places these lines into MatchingFacts. The first fact
% in MatchingFacts is always Fact. If an extra fact is read in following
% the matching facts, it is placed in MaybeNextFact.
%
:- pred top_level_collect_matching_facts(io.text_input_stream::in, string::in,
list(fact_arg_info)::in, list(fact_table_mode)::in,
sort_file_line::in, list(sort_file_line)::out, maybe(sort_file_line)::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
top_level_collect_matching_facts(InputStream, InputFileName,
Infos, Modes, Fact, MatchingFacts, MaybeNextFact, !Specs, !IO) :-
top_level_collect_matching_facts_loop(InputStream, InputFileName,
Infos, Modes, Fact, [], RevMatchingFacts, MaybeNextFact, !Specs, !IO),
list.reverse(RevMatchingFacts, MatchingFactsTail),
MatchingFacts = [Fact | MatchingFactsTail].
:- pred top_level_collect_matching_facts_loop(io.text_input_stream::in,
string::in, list(fact_arg_info)::in, list(fact_table_mode)::in,
sort_file_line::in, list(sort_file_line)::in, list(sort_file_line)::out,
maybe(sort_file_line)::out,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
top_level_collect_matching_facts_loop(InputStream, InputFileName,
Infos, Modes, Fact, !RevMatchingFacts, MaybeNextFact, !Specs, !IO) :-
read_sort_file_line(InputStream, InputFileName,
Infos, Modes, MaybeSortFileLine, !Specs, !IO),
(
MaybeSortFileLine = yes(Fact1),
( if
Fact1 = sort_file_line([Arg1 | _], _, _),
Fact = sort_file_line([Arg | _], _, _)
then
( if Arg = Arg1 then
!:RevMatchingFacts = [Fact1 | !.RevMatchingFacts],
top_level_collect_matching_facts_loop(InputStream,
InputFileName, Infos, Modes, Fact,
!RevMatchingFacts, MaybeNextFact, !Specs, !IO)
else
MaybeNextFact = yes(Fact1)
)
else
unexpected($pred, "no input args")
)
;
MaybeSortFileLine = no,
MaybeNextFact = no
).
% Same as above, but reads facts from a list instead of from the sort file.
%
:- pred lower_level_collect_matching_facts(int::in, sort_file_line::in,
list(sort_file_line)::in, list(sort_file_line)::out,
list(sort_file_line)::out) is det.
lower_level_collect_matching_facts(InputArgNum, Fact, Facts,
MatchingFacts, RemainingFacts) :-
Fact = sort_file_line(InputArgs, _, _),
list.det_index0(InputArgs, InputArgNum, MatchArg),
lower_level_collect_matching_facts_loop(InputArgNum, MatchArg, Facts,
[], RevMatchingFacts, RemainingFacts),
list.reverse(RevMatchingFacts, TailMatchingFacts),
MatchingFacts = [Fact | TailMatchingFacts].
:- pred lower_level_collect_matching_facts_loop(int::in, fact_arg::in,
list(sort_file_line)::in, list(sort_file_line)::in,
list(sort_file_line)::out, list(sort_file_line)::out) is det.
lower_level_collect_matching_facts_loop(_, _, [], !RevMatchingFacts, []).
lower_level_collect_matching_facts_loop(InputArgNum, MatchArg,
[Fact | Facts], !RevMatchingFacts, RemainingFacts) :-
Fact = sort_file_line(InputArgs, _, _),
list.det_index0(InputArgs, InputArgNum, Arg),
( if MatchArg = Arg then
!:RevMatchingFacts = [Fact | !.RevMatchingFacts],
lower_level_collect_matching_facts_loop(InputArgNum, MatchArg,
Facts, !RevMatchingFacts, RemainingFacts)
else
RemainingFacts = [Fact | Facts]
).
:- pred update_fact_map(int::in, list(sort_file_line)::in,
map(int, int)::in, map(int, int)::out) is det.
update_fact_map(_, [], !FactMap).
update_fact_map(FactNum, [Fact | Facts], !FactMap) :-
Fact = sort_file_line(_, Index, _),
map.set(Index, FactNum, !FactMap),
update_fact_map(FactNum + 1, Facts, !FactMap).
%---------------------------------------------------------------------------%
% Select a prime number > NumEntries * 100 / PercentFull.
% The prime number is selected from a list of primes each of which is
% close to a power of 2 between 2^1 and 2^31.
%
:- pred calculate_hash_table_size(globals::in, int::in, int::out) is det.
calculate_hash_table_size(Globals, NumEntries, HashTableSize) :-
globals.lookup_int_option(Globals, fact_table_hash_percent_full,
PercentFull),
Primes = [2, 3, 5, 11, 17, 37, 67, 131, 257, 521, 1031, 2053, 4099, 8209,
16411, 32771, 65537, 131101, 262147, 524309, 1048627, 2097257, 4194493,
8388949, 16777903, 33555799, 67108879, 134217757, 268435459, 536870923,
1073741827, 2147483647],
N = (NumEntries * 100) // PercentFull,
find_first_big_enough_prime(N, Primes, HashTableSize).
:- pred find_first_big_enough_prime(int::in, list(int)::in, int::out) is det.
find_first_big_enough_prime(_, [], _) :-
unexpected($pred, "hash table too large (max size 2147483647)").
find_first_big_enough_prime(NumSlotsNeeded, [Prime | Primes], Size) :-
( if Prime > NumSlotsNeeded then
Size = Prime
else
find_first_big_enough_prime(NumSlotsNeeded, Primes, Size)
).
% Insert an entry in a hash table. If a collision occurrs, find an empty
% hash slot to place the data in and put a pointer to the new slot in the
% Next field of the old one. This technique is called ``open-addressing''.
%
:- pred hash_table_insert(hash_entry::in, int::in,
hash_table::in, hash_table::out) is det.
hash_table_insert(Entry, HashSize, !HashTable) :-
Entry = hash_entry(Key, Index, _),
fact_table_hash(HashSize, Key, HashVal),
( if hash_table_search(!.HashTable, HashVal, _) then
hash_table_insert_open_address_loop(HashVal, Key, Index, !HashTable)
else
hash_table_set(HashVal, hash_entry(Key, Index, -1), !HashTable)
).
:- pred hash_table_insert_open_address_loop(int::in,
fact_arg::in, hash_index::in, hash_table::in, hash_table::out) is det.
hash_table_insert_open_address_loop(HashVal, Key0, Index0,
!HashTable) :-
( if hash_table_search(!.HashTable, HashVal, OldEntry1) then
OldEntry1 = hash_entry(Key1, Index1, Next),
( if Next = -1 then
get_free_hash_slot(!.HashTable, HashVal, FreeVal),
NewEntry = hash_entry(Key0, Index0, -1),
hash_table_set(FreeVal, NewEntry, !HashTable),
OldEntry = hash_entry(Key1, Index1, FreeVal),
hash_table_set(HashVal, OldEntry, !HashTable)
else
hash_table_insert_open_address_loop(Next, Key0, Index0, !HashTable)
)
else
unexpected($pred, "hash table entry empty")
).
% Probe through the hash table to find a free slot. This will eventually
% terminate because the hash table size is selected to be larger than
% the number of entries that need to go in it.
%
% XXX "This will eventually terminate" is not something one enjoys reading
% in the documentation the implementation of a language feature
% whose only purpose is to improve compiler performance :-(
%
:- pred get_free_hash_slot(hash_table::in, int::in, int::out) is det.
get_free_hash_slot(HashTable, Start, Free) :-
HashTable = hash_table(Size, _),
Max = Size - 1,
get_free_hash_slot_loop(HashTable, Start, Max, Free).
:- pred get_free_hash_slot_loop(hash_table::in, int::in, int::in, int::out)
is det.
get_free_hash_slot_loop(HashTable, Start, Max, Free) :-
Next = (Start + 1) mod Max,
( if hash_table_search(HashTable, Next, _) then
get_free_hash_slot_loop(HashTable, Next, Max, Free)
else
Free = Next
).
% Hash computation predicate.
% Note: if you change this predicate, you will also need to change
% the C code that is output to compute the hash value at runtime.
% This C code is generated in `generate_hash_code'.
%
:- pred fact_table_hash(int::in, fact_arg::in, int::out) is det.
fact_table_hash(HashSize, Key, HashVal) :-
(
Key = fact_arg_string(String),
% XXX This method of hashing strings may not work if cross-compiling
% between systems that have different character representations.
string.to_char_list(String, Cs),
list.map((pred(C::in, I::out) is det :- char.to_int(C, I)), Cs, Ns)
;
Key = fact_arg_int(Int),
int.abs(Int, N),
Ns = [N]
;
Key = fact_arg_float(Float),
% XXX This method of hashing floats may not work cross-compiling
% between architectures that have different floating-point
% representations.
int.abs(float.hash(Float), N),
Ns = [N]
),
fact_table_hash_2(HashSize, Ns, 0, HashVal).
:- pred fact_table_hash_2(int::in, list(int)::in, int::in, int::out) is det.
fact_table_hash_2(_, [], !HashVal).
fact_table_hash_2(HashSize, [N | Ns], !HashVal) :-
!:HashVal = (N + 31 * !.HashVal) mod HashSize,
fact_table_hash_2(HashSize, Ns, !HashVal).
:- pred hash_list_insert_many(maybe_primary_table::in,
map(int, int)::in, int::in, int::in ,list(sort_file_line)::in,
list(hash_entry)::in, list(hash_entry)::out) is det.
hash_list_insert_many(_, _, _, _, [], !HashList).
hash_list_insert_many(IsPrimaryTable, FactMap, FactNum, InputArgNum,
[Fact | Facts], !HashList) :-
fact_get_arg_and_index(Fact, InputArgNum, Arg, Index),
(
IsPrimaryTable = primary_table,
HashIndex = FactNum
;
IsPrimaryTable = not_primary_table,
map.lookup(FactMap, Index, HashIndex)
),
!:HashList = [hash_entry(Arg, fact(HashIndex), -1) | !.HashList],
hash_list_insert_many(IsPrimaryTable, FactMap, FactNum, InputArgNum,
Facts, !HashList).
:- pred hash_table_init(int::in, hash_table::out) is det.
hash_table_init(Size, HashTable) :-
map.init(Map),
HashTable = hash_table(Size, Map).
:- pred hash_table_from_list(list(hash_entry)::in, int::in, hash_table::in,
hash_table::out) is det.
hash_table_from_list([], _, !HashTable).
hash_table_from_list([Entry | Entrys], HashSize, !HashTable) :-
hash_table_insert(Entry, HashSize, !HashTable),
hash_table_from_list(Entrys, HashSize, !HashTable).
:- pred hash_table_search(hash_table::in, int::in, hash_entry::out) is semidet.
hash_table_search(HashTable, Index, Value) :-
HashTable = hash_table(_, Map),
map.search(Map, Index, Value).
:- pred hash_table_set(int::in, hash_entry::in,
hash_table::in, hash_table::out) is det.
hash_table_set(Index, Value, HashTable0, HashTable) :-
HashTable0 = hash_table(Size, Map0),
map.set(Index, Value, Map0, Map),
HashTable = hash_table(Size, Map).
%---------------------%
:- pred fact_get_arg_and_index(sort_file_line::in, int::in, fact_arg::out,
int::out) is det.
fact_get_arg_and_index(Fact, InputArgNum, Arg, Index) :-
Fact = sort_file_line(InputArgs, Index, _),
list.det_index0(InputArgs, InputArgNum, Arg).
%---------------------------------------------------------------------------%
% Write out the C code for a hash table.
%
:- pred write_hash_table(io.text_output_stream::in, string::in, int::in,
hash_table::in, io::di, io::uo) is det.
write_hash_table(OutputStream, BaseName, TableNum, HashTable, !IO) :-
get_hash_table_type(HashTable, TableType),
string.format("struct MR_fact_table_hash_entry_%c %s%d_data[]",
[c(TableType), s(BaseName), i(TableNum)], HashTableDataName),
io.write_strings(OutputStream, [HashTableDataName, " = {\n"], !IO),
HashTable = hash_table(Size, _),
MaxIndex = Size - 1,
write_hash_table_loop(OutputStream, HashTable, 0, MaxIndex, !IO),
io.write_string(OutputStream, "};\n\n", !IO),
StructDefnTemplate = "
struct MR_fact_table_hash_table_%c %s%d = {
%d,
%s%d_data
};
",
io.format(OutputStream, StructDefnTemplate,
[c(TableType), s(BaseName), i(TableNum), i(Size),
s(BaseName), i(TableNum)], !IO).
:- pred write_hash_table_loop(io.text_output_stream::in, hash_table::in,
int::in, int::in, io::di, io::uo) is det.
write_hash_table_loop(Stream, HashTable, CurIndex, MaxIndex, !IO) :-
( if CurIndex > MaxIndex then
true
else
io.write_string(Stream, "\t{ ", !IO),
( if hash_table_search(HashTable, CurIndex, HashEntry) then
HashEntry = hash_entry(Key, Index, Next),
(
Key = fact_arg_string(String),
output_quoted_string_c(Stream, String, !IO)
;
Key = fact_arg_int(Int),
io.write_int(Stream, Int, !IO)
;
Key = fact_arg_float(Float),
io.write_float(Stream, Float, !IO)
),
(
Index = fact(I),
io.format(Stream,
", MR_FACT_TABLE_MAKE_TAGGED_INDEX(%d, 1), ",
[i(I)], !IO)
;
Index = hash_table(I, H),
io.format(Stream,
", MR_FACT_TABLE_MAKE_TAGGED_POINTER(&%s%d, 2), ",
[s(H), i(I)], !IO)
),
io.write_int(Stream, Next, !IO)
else
io.write_string(Stream,
"0, MR_FACT_TABLE_MAKE_TAGGED_POINTER(NULL, 0), -1 ", !IO)
),
io.write_string(Stream, "},\n", !IO),
write_hash_table_loop(Stream, HashTable, CurIndex + 1, MaxIndex, !IO)
).
%---------------------%
% Return 's' for string, 'i' for int, 'f' for float.
% Don't call this with an empty hash table.
%
:- pred get_hash_table_type(hash_table::in, char::out(key_char)) is det.
get_hash_table_type(HashTable, TableType) :-
HashTable = hash_table(_Size, Map),
( if map.is_empty(Map) then
unexpected($pred, "empty hash table")
else
get_hash_table_type_loop(Map, 0, TableType)
).
:- pred get_hash_table_type_loop(map(int, hash_entry)::in, int::in,
char::out(key_char)) is det.
get_hash_table_type_loop(Map, Index, TableType) :-
( if map.search(Map, Index, Entry) then
Entry = hash_entry(Key, _, _),
(
Key = fact_arg_string(_),
TableType = 's'
;
Key = fact_arg_int(_),
TableType = 'i'
;
Key = fact_arg_float(_),
TableType = 'f'
)
else
get_hash_table_type_loop(Map, Index + 1, TableType)
).
%---------------------%
% Write out the array of pointers to the fact table arrays.
%
:- pred write_fact_table_pointer_array(io.text_output_stream::in, int::in,
string::in, int::in, string::out, io::di, io::uo) is det.
write_fact_table_pointer_array(OutputStream, FactTableSize,
StructName, NumFacts, HeaderCode, !IO) :-
string.format("const struct %s_struct *%s[]",
[s(StructName), s(StructName)], PointerArrayName),
HeaderCode = "extern " ++ PointerArrayName ++ ";\n",
io.format(OutputStream, "%s = {\n", [s(PointerArrayName)], !IO),
write_fact_table_pointer_array_loop(OutputStream, FactTableSize,
StructName, 0, NumFacts, !IO),
io.write_string(OutputStream, "};\n", !IO).
:- pred write_fact_table_pointer_array_loop(io.text_output_stream::in, int::in,
string::in, int::in, int::in, io::di, io::uo) is det.
write_fact_table_pointer_array_loop(OutputStream, FactTableSize,
StructName, CurFact, NumFacts, !IO) :-
( if CurFact >= NumFacts then
true
else
io.format(OutputStream, "\t%s%d,\n", [s(StructName), i(CurFact)], !IO),
NextFact = CurFact + FactTableSize,
write_fact_table_pointer_array_loop(OutputStream, FactTableSize,
StructName, NextFact, NumFacts, !IO)
).
%---------------------%
:- pred write_fact_table_numfacts(io.text_output_stream::in,
sym_name::in, int::in, string::out, io::di, io::uo) is det.
write_fact_table_numfacts(OutputStream, PredName, NumFacts, HeaderCode, !IO) :-
% Write out the size of the fact table.
make_fact_table_identifier(PredName, Identifier),
io.format(OutputStream,
"const MR_Integer mercury__%s_fact_table_num_facts = %d;\n\n",
[s(Identifier), i(NumFacts)], !IO),
string.format(
"extern const MR_Integer mercury__%s_fact_table_num_facts;\n",
[s(Identifier)], HeaderCode).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
fact_table_generate_c_code_for_proc(ModuleInfo, PredName,
ProcId, PrimaryProcId, ProcInfo, GenInfo, VarSet, PragmaVars,
ProcCode, ExtraCode) :-
module_info_get_globals(ModuleInfo, Globals),
fact_table_size(Globals, FactTableSize),
proc_info_interface_determinism(ProcInfo, Determinism),
make_fact_table_identifier(PredName, PredNameIdent),
GenInfo = fact_table_gen_info(FactArgInfos, FactTableProcMap, _, _),
Types = list.map((func(fact_arg_info(Type, _, _)) = Type), FactArgInfos),
map.lookup(FactTableProcMap, ProcId, FactTableProcInfo),
FactTableProcInfo = fact_table_proc_info(FactTableVars, ModeClass, VarSet),
PragmaVars =
list.map((func(fact_table_var(_, _, _, PV)) = PV), FactTableVars),
(
ModeClass = all_out,
(
Determinism = detism_multi,
generate_multi_code(ModuleInfo, FactTableSize, PredNameIdent,
ProcId, Types, FactTableVars, ProcCode, ExtraCode)
;
Determinism = detism_cc_multi,
generate_cc_multi_code(PredNameIdent, FactTableVars, ProcCode),
ExtraCode = ""
;
( Determinism = detism_det
; Determinism = detism_semi
; Determinism = detism_non
; Determinism = detism_cc_non
; Determinism = detism_failure
; Determinism = detism_erroneous
),
generate_dummy_code(FactTableVars, ProcCode, ExtraCode)
)
;
ModeClass = all_in,
(
Determinism = detism_semi,
generate_semidet_all_in_code(FactTableSize, PredNameIdent, ProcId,
Types, FactTableVars, ProcCode),
ExtraCode = ""
;
( Determinism = detism_det
; Determinism = detism_multi
; Determinism = detism_non
; Determinism = detism_cc_multi
; Determinism = detism_cc_non
; Determinism = detism_failure
; Determinism = detism_erroneous
),
generate_dummy_code(FactTableVars, ProcCode, ExtraCode)
)
;
ModeClass = in_out,
(
( Determinism = detism_semi
; Determinism = detism_cc_non
),
generate_semidet_in_out_code(FactTableSize, PredNameIdent, ProcId,
Types, FactTableVars, ProcCode),
ExtraCode = ""
;
Determinism = detism_non,
( if ProcId = PrimaryProcId then
generate_primary_nondet_code(ModuleInfo, FactTableSize,
PredNameIdent, ProcId, Types, FactTableVars,
ProcCode, ExtraCode)
else
generate_secondary_nondet_code(ModuleInfo, FactTableSize,
PredNameIdent, ProcId, Types, FactTableVars,
ProcCode, ExtraCode)
)
;
( Determinism = detism_det
; Determinism = detism_multi
; Determinism = detism_cc_multi
; Determinism = detism_failure
; Determinism = detism_erroneous
),
generate_dummy_code(FactTableVars, ProcCode, ExtraCode)
)
).
% Generate contents for a dummy implementation of a fact table.
% Used when there is a determinism error in a procedure, which
% should be reported during determinism analysis when the inferred
% determinism we recorded above is compared to the declared determinism.
% So all we need to do here is return some C code that does nothing.
%
:- pred generate_dummy_code(list(fact_table_var)::in,
string::out, string::out) is det.
generate_dummy_code(FactTableVars, ProcCode, ExtraCode) :-
% List the variables in the C code to stop the compiler giving
% a warning about them not being there.
fact_table_vars_to_names_string(FactTableVars, NamesString),
string.format("/* %s */", [s(NamesString)], ProcCode),
ExtraCode = "".
%---------------------------------------------------------------------------%
%
% Implement detism_multi procedures.
%
:- pred generate_multi_code(module_info::in, int::in, string::in, proc_id::in,
list(fact_arg_type)::in, list(fact_table_var)::in,
string::out, string::out) is det.
generate_multi_code(ModuleInfo, FactTableSize, PredName, ProcId,
Types, FactTableVars, ProcCode, ExtraCode) :-
generate_nondet_proc_code(PredName, ProcId, FactTableVars,
ExtraCodeLabel, ProcCode),
ExtraCodeTemplate = "
MR_define_extern_entry(%s);
MR_declare_label(%s_i1);
MR_BEGIN_MODULE(%s_module)
MR_init_entry(%s);
MR_init_label(%s_i1);
MR_BEGIN_CODE
MR_define_entry(%s);
MR_mkframe(""%s/%d"", 1, MR_LABEL(%s_i1));
MR_framevar(1) = (MR_Integer) 0;
MR_GOTO(MR_LABEL(%s_i1));
MR_define_label(%s_i1);
if (MR_framevar(1) >= %s) MR_fail();
{
// declare argument vars
%s
MR_Word ind = MR_framevar(1), tmp;
// lookup fact table
%s
// save output args to registers
%s
}
MR_framevar(1)++;
MR_succeed();
MR_END_MODULE
extern MR_ModuleFunc %s_module;
/*
INIT mercury_sys_init_%s_module
*/
void mercury_sys_init_%s_module(void);
void mercury_sys_init_%s_module(void) {
%s_module();
}
",
string.format("mercury__%s_fact_table_num_facts",
[s(PredName)], NumFactsVar),
list.length(FactTableVars, Arity),
generate_argument_vars_code(ModuleInfo, Types, FactTableVars,
ArgDeclCode, _InputCode, OutputCode, _, _, _),
generate_fact_lookup_code(FactTableSize, PredName,
Types, FactTableVars, 1, FactLookupCode),
string.format(ExtraCodeTemplate, [
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(PredName),
i(Arity),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(NumFactsVar),
s(ArgDeclCode),
s(FactLookupCode),
s(OutputCode),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel)],
ExtraCode).
:- pred generate_nondet_proc_code(string::in, proc_id::in,
list(fact_table_var)::in, string::out, string::out) is det.
generate_nondet_proc_code(PredName, ProcId, FactTableVars,
ExtraCodeLabel, ProcCode) :-
ProcCodeTemplate = "
// Mention arguments %s to stop the compiler giving a warning.
//
// Pop off the nondet stack frame that the pragma c_code generates
// then jump to the code where the work is actually done.
MR_maxfr_word = MR_prevfr_slot_word(MR_curfr);
MR_curfr_word = MR_succfr_slot_word(MR_curfr);
{
MR_declare_entry(%s);
MR_GOTO(MR_ENTRY(%s));
}
",
list.length(FactTableVars, Arity),
proc_id_to_int(ProcId, ProcIdInt),
string.format("mercury__%s_%d_%d_xx",
[s(PredName), i(Arity), i(ProcIdInt)], ExtraCodeLabel),
fact_table_vars_to_names_string(FactTableVars, NamesString),
string.format(ProcCodeTemplate, [s(NamesString), s(ExtraCodeLabel),
s(ExtraCodeLabel)], ProcCode).
%---------------------------------------------------------------------------%
%
% Implement detism_cc_multi procedures.
%
% For cc_multi output mode, just return the first fact in the table.
%
:- pred generate_cc_multi_code(string::in, list(fact_table_var)::in,
string::out) is det.
generate_cc_multi_code(PredName, FactTableVars, ProcCode) :-
string.format("mercury__%s_fact_table", [s(PredName)], StructName),
generate_cc_multi_code_loop(StructName, FactTableVars, 1, "", ProcCode).
:- pred generate_cc_multi_code_loop(string::in,
list(fact_table_var)::in, int::in, string::in, string::out) is det.
generate_cc_multi_code_loop(_, [], _, !ProcCode).
generate_cc_multi_code_loop(StructName, [FactTableVar | FactTableVars], ArgNum,
!ProcCode) :-
FactTableVar = fact_table_var(VarName, _, _, _),
string.format("\t\t%s = %s[0][0].V_%d;\n", [s(VarName), s(StructName),
i(ArgNum)], ArgAssignCode),
!:ProcCode = !.ProcCode ++ ArgAssignCode,
generate_cc_multi_code_loop(StructName, FactTableVars, ArgNum + 1,
!ProcCode).
%---------------------------------------------------------------------------%
%
% Implement detism_non procedures.
%
% Generate code for the nondet mode with the primary key.
%
:- pred generate_primary_nondet_code(module_info::in, int::in,
string::in, proc_id::in, list(fact_arg_type)::in, list(fact_table_var)::in,
string::out, string::out) is det.
generate_primary_nondet_code(ModuleInfo, FactTableSize, PredName, ProcId,
Types, FactTableVars, ProcCode, ExtraCode) :-
generate_nondet_proc_code(PredName, ProcId, FactTableVars,
ExtraCodeLabel, ProcCode),
ExtraCodeTemplate = "
MR_define_extern_entry(%s);
MR_declare_label(%s_i1);
MR_BEGIN_MODULE(%s_module)
MR_init_entry(%s);
MR_init_label(%s_i1);
MR_BEGIN_CODE
MR_define_entry(%s);
MR_mkframe(""%s/%d"", %d, MR_LABEL(%s_i1));
{
// create argument vars
%s
// declare local variables
%s
// copy registers to input arg vars
%s
// copy registers to framevars
%s
// lookup hash table
%s
success_code_%s:
// lookup fact table
%s
// save output args to registers
%s
MR_framevar(1) = ind + 1;
MR_succeed();
failure_code_%s:
MR_fail();
}
MR_define_label(%s_i1);
if (MR_framevar(1) >= %s)
MR_fail();
{
// create argument vars
%s
int ind = MR_framevar(1);
// copy framevars to registers
%s
// copy registers to input arg vars
%s
// test fact table entry
%s
// lookup fact table
%s
// save output args to registers
%s
}
MR_framevar(1)++;
MR_succeed();
MR_END_MODULE
extern MR_ModuleFunc %s_module;
/*
INIT mercury_sys_init_%s_module
*/
void mercury_sys_init_%s_module(void);
void mercury_sys_init_%s_module(void) {
%s_module();
}
",
generate_argument_vars_code(ModuleInfo, Types, FactTableVars,
ArgDeclCode, InputCode, OutputCode, SaveRegsCode, GetRegsCode,
NumFrameVars),
generate_decl_code(PredName, ProcId, DeclCode),
proc_id_to_int(ProcId, ProcIdInt),
string.format("%s_%d", [s(PredName), i(ProcIdInt)], LabelName),
generate_hash_code(FactTableSize, PredName, LabelName, 0,
Types, FactTableVars, 1, HashCode),
generate_fact_lookup_code(FactTableSize, PredName,
Types, FactTableVars, 1, FactLookupCode),
generate_fact_test_code(FactTableSize, PredName,
Types, FactTableVars, FactTestCode),
string.format("mercury__%s_fact_table_num_facts",
[s(PredName)], NumFactsVar),
list.length(FactTableVars, Arity),
string.format(ExtraCodeTemplate, [
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(PredName),
i(Arity),
i(NumFrameVars),
s(ExtraCodeLabel),
s(ArgDeclCode),
s(DeclCode),
s(InputCode),
s(SaveRegsCode),
s(HashCode),
s(LabelName),
s(FactLookupCode),
s(OutputCode),
s(LabelName),
s(ExtraCodeLabel),
s(NumFactsVar),
s(ArgDeclCode),
s(GetRegsCode),
s(InputCode),
s(FactTestCode),
s(FactLookupCode),
s(OutputCode),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel)
],
ExtraCode).
% Generate code for a nondet mode using a secondary key.
%
:- pred generate_secondary_nondet_code(module_info::in, int::in, string::in,
proc_id::in, list(fact_arg_type)::in, list(fact_table_var)::in,
string::out, string::out) is det.
generate_secondary_nondet_code(ModuleInfo, FactTableSize, PredName, ProcId,
Types, FactTableVars, ProcCode, ExtraCode) :-
generate_nondet_proc_code(PredName, ProcId, FactTableVars,
ExtraCodeLabel, ProcCode),
ExtraCodeTemplate = "
MR_define_extern_entry(%s);
MR_declare_label(%s_i1);
MR_BEGIN_MODULE(%s_module)
MR_init_entry(%s);
MR_init_label(%s_i1);
MR_BEGIN_CODE
MR_define_entry(%s);
MR_mkframe(""%s/%d"", 4, MR_LABEL(%s_i1));
{
// create argument vars
%s
// declare local variables
%s
// copy registers to input arg vars
%s
// lookup hash table
%s
success_code_%s:
// lookup fact table
%s
// save output args to registers
%s
if (hashval == -1) MR_succeed_discard();
MR_framevar(1) = hashval;
MR_framevar(2) = (MR_Word) current_table;
MR_framevar(3) = (MR_Word) keytype;
MR_framevar(4) = current_key;
MR_succeed();
failure_code_%s:
MR_fail();
}
MR_define_label(%s_i1);
{
// create argument vars
%s
MR_Integer hashval = MR_framevar(1);
MR_Word ind;
void *current_table = (void *) MR_framevar(2);
char keytype = (char) MR_framevar(3);
// lookup hash table
switch(keytype)
{
case 's':
%s
break;
case 'i':
%s
break;
case 'f':
%s
break;
default:
MR_fatal_error(
""fact table hash lookup: nondet stack corrupted?"");
}
success_code_%s:
// lookup fact table
%s
// save output args to registers
%s
if (hashval == -1) MR_succeed_discard();
MR_framevar(1) = hashval;
MR_succeed();
failure_code_%s:
MR_fail();
}
MR_END_MODULE
extern MR_ModuleFunc %s_module;
/*
INIT mercury_sys_init_%s_module
*/
void mercury_sys_init_%s_module(void);
void mercury_sys_init_%s_module(void) {
%s_module();
}
",
generate_argument_vars_code(ModuleInfo, Types, FactTableVars,
ArgDeclCode, InputCode, OutputCode, _SaveRegsCode, _GetRegsCode,
_NumFrameVars),
generate_decl_code(PredName, ProcId, DeclCode),
proc_id_to_int(ProcId, ProcIdInt),
string.format("%s_%d", [s(PredName), i(ProcIdInt)], LabelName),
string.append(LabelName, "_2", LabelName2),
generate_hash_code(FactTableSize, PredName, LabelName, 0,
Types, FactTableVars, 1, HashCode),
StringVarName = "(char *) MR_framevar(4)",
IntVarName = "MR_framevar(4)",
FloatVarName = "MR_word_to_float(MR_framevar(4))",
generate_hash_lookup_code(StringVarName, LabelName2, 0,
string_equals, 's', do_not_test_keys, StringHashLookupCode),
generate_hash_lookup_code(IntVarName, LabelName2, 1,
plain_equals, 'i', do_not_test_keys, IntHashLookupCode),
generate_hash_lookup_code(FloatVarName, LabelName2, 2,
plain_equals, 'f', do_not_test_keys, FloatHashLookupCode),
generate_fact_lookup_code(FactTableSize, PredName,
Types, FactTableVars, 1, FactLookupCode),
list.length(FactTableVars, Arity),
string.format(ExtraCodeTemplate, [
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(PredName),
i(Arity),
s(ExtraCodeLabel),
s(ArgDeclCode),
s(DeclCode),
s(InputCode),
s(HashCode),
s(LabelName),
s(FactLookupCode),
s(OutputCode),
s(LabelName),
s(ExtraCodeLabel),
s(ArgDeclCode),
s(StringHashLookupCode),
s(IntHashLookupCode),
s(FloatHashLookupCode),
s(LabelName2),
s(FactLookupCode),
s(OutputCode),
s(LabelName2),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel),
s(ExtraCodeLabel)
],
ExtraCode).
%---------------------------------------------------------------------------%
%
% Implement detism_semi procedures.
%
% Generate semidet code for all_in mode.
%
:- pred generate_semidet_all_in_code(int::in, string::in, proc_id::in,
list(fact_arg_type)::in, list(fact_table_var)::in, string::out) is det.
generate_semidet_all_in_code(FactTableSize, PredName, ProcId,
Types, FactTableVars, ProcCode) :-
generate_decl_code(PredName, ProcId, DeclCode),
proc_id_to_int(ProcId, ProcIdInt),
string.format("%s_%d", [s(PredName), i(ProcIdInt)], LabelName),
generate_hash_code(FactTableSize, PredName, LabelName, 0,
Types, FactTableVars, 1, HashCode),
SuccessCodeTemplate = "
success_code_%s:
SUCCESS_INDICATOR = MR_TRUE;
goto skip_%s;
failure_code_%s:
SUCCESS_INDICATOR = MR_FALSE;
skip_%s:
;
",
string.format(SuccessCodeTemplate, [s(LabelName), s(LabelName),
s(LabelName), s(LabelName)], SuccessCode),
ProcCode = "\t{\n" ++ DeclCode ++ HashCode ++ SuccessCode ++ "\t}\n".
%---------------------%
% Generate code for semidet and cc_nondet in_out modes. Lookup key in
% hash table and if found return first match. If not found, fail.
%
:- pred generate_semidet_in_out_code(int::in, string::in, proc_id::in,
list(fact_arg_type)::in, list(fact_table_var)::in, string::out) is det.
generate_semidet_in_out_code(FactTableSize, PredName, ProcId,
Types, FactTableVars, ProcCode):-
generate_decl_code(PredName, ProcId, DeclCode),
proc_id_to_int(ProcId, ProcIdInt),
string.format("%s_%d", [s(PredName), i(ProcIdInt)], LabelName),
generate_hash_code(FactTableSize, PredName, LabelName, 0,
Types, FactTableVars, 1, HashCode),
SuccessCodeTemplate = "
success_code_%s:
SUCCESS_INDICATOR = MR_TRUE;
",
string.format(SuccessCodeTemplate, [s(LabelName)], SuccessCode),
generate_fact_lookup_code(FactTableSize, PredName,
Types, FactTableVars, 1, FactLookupCode),
FailCodeTemplate = "
goto skip_%s;
failure_code_%s:
SUCCESS_INDICATOR = MR_FALSE;
skip_%s:
;
",
string.format(FailCodeTemplate, [s(LabelName), s(LabelName),
s(LabelName)], FailCode),
ProcCode = "\t{\n" ++ DeclCode ++ HashCode ++ SuccessCode
++ FactLookupCode ++ FailCode ++ "\t}\n".
%---------------------------------------------------------------------------%
%
% Some service procedures used by the generate_*_code predicates above.
%
:- pred generate_decl_code(string::in, proc_id::in, string::out) is det.
generate_decl_code(Name, ProcId, DeclCode) :-
DeclCodeTemplate = "
MR_Integer hashval, hashsize;
MR_Word ind;
void *current_table;
char keytype = '\\0';
MR_Word current_key, tmp;
// Initialise current_table to the top level hash table
// for this ProcId.
current_table =
&mercury__%s_fact_table_hash_table_%d_0;
",
proc_id_to_int(ProcId, ProcIdInt),
string.format(DeclCodeTemplate, [s(Name), i(ProcIdInt)], DeclCode).
% Generate code to calculate hash values and lookup the hash tables.
%
:- pred generate_hash_code(int::in, string::in, string::in, int::in,
list(fact_arg_type)::in, list(fact_table_var)::in, int::in,
string::out) is det.
generate_hash_code(_, _, _, _, [], [], _, "").
generate_hash_code(_, _, _, _, [], [_ | _], _, _) :-
unexpected($pred, "length mismatch").
generate_hash_code(_, _, _, _, [_ | _], [], _, _) :-
unexpected($pred, "length mismatch").
generate_hash_code(FactTableSize, PredName, LabelName, LabelNum,
[Type | Types], [FactTableVar | FactTableVars], ArgNum, Code) :-
FactTableVar = fact_table_var(VarName, Mode, _, _),
NextArgNum = ArgNum + 1,
(
Mode = fully_in,
(
Type = fact_arg_type_int,
generate_hash_int_code(FactTableSize, PredName, VarName,
LabelName, LabelNum, Types, FactTableVars, NextArgNum, ArgCode)
;
Type = fact_arg_type_float,
generate_hash_float_code(FactTableSize, PredName, VarName,
LabelName, LabelNum, Types, FactTableVars, NextArgNum, ArgCode)
;
Type = fact_arg_type_string,
generate_hash_string_code(FactTableSize, PredName, VarName,
LabelName, LabelNum, Types, FactTableVars, NextArgNum, ArgCode)
),
generate_hash_code(FactTableSize, PredName, LabelName, LabelNum + 1,
Types, FactTableVars, NextArgNum, ArgsCode),
Code = ArgCode ++ ArgsCode
;
Mode = fully_out,
% Skip non-input arguments.
generate_hash_code(FactTableSize, PredName, LabelName, LabelNum,
Types, FactTableVars, NextArgNum, Code)
).
:- pred generate_hash_int_code(int::in, string::in, string::in,
string::in, int::in,
list(fact_arg_type)::in, list(fact_table_var)::in, int::in,
string::out) is det.
generate_hash_int_code(FactTableSize, PredName, VarName, LabelName, LabelNum,
Types, FactTableVars, ArgNum, Code) :-
TestKeys =
test_keys(FactTableSize, PredName, Types, FactTableVars, ArgNum),
generate_hash_lookup_code(VarName, LabelName, LabelNum,
plain_equals, 'i', TestKeys, HashLookupCode),
CodeTemplate = "
// calculate hash value for an integer
hashsize = ((struct MR_fact_table_hash_table_i *) current_table)
->size;
hashval = (%s >= 0 ? %s : -%s) %% hashsize;
current_key = %s;
// lookup the hash table
%s
",
string.format(CodeTemplate,
[s(VarName), s(VarName), s(VarName), s(VarName), s(HashLookupCode)],
Code).
:- pred generate_hash_float_code(int::in, string::in, string::in,
string::in, int::in,
list(fact_arg_type)::in, list(fact_table_var)::in, int::in,
string::out) is det.
generate_hash_float_code(FactTableSize, PredName, VarName, LabelName, LabelNum,
Types, FactTableVars, ArgNum, Code) :-
TestKeys =
test_keys(FactTableSize, PredName, Types, FactTableVars, ArgNum),
generate_hash_lookup_code(VarName, LabelName, LabelNum,
plain_equals, 'f', TestKeys, HashLookupCode),
CodeTemplate = "
// calculate hash value for a float
hashsize = ((struct MR_fact_table_hash_table_f *) current_table)
->size;
hashval = MR_hash_float(%s);
hashval = (hashval >= 0 ? hashval : -hashval) %% hashsize;
current_key = MR_float_to_word(%s);
// lookup the hash table
%s
",
string.format(CodeTemplate,
[s(VarName), s(VarName), s(HashLookupCode)], Code).
:- pred generate_hash_string_code(int::in, string::in, string::in,
string::in, int::in,
list(fact_arg_type)::in, list(fact_table_var)::in, int::in,
string::out) is det.
generate_hash_string_code(FactTableSize, PredName, VarName,
LabelName, LabelNum, Types, FactTableVars, ArgNum, Code) :-
TestKeys =
test_keys(FactTableSize, PredName, Types, FactTableVars, ArgNum),
generate_hash_lookup_code(VarName, LabelName, LabelNum,
string_equals, 's', TestKeys, HashLookupCode),
CodeTemplate = "
hashsize = ((struct MR_fact_table_hash_table_s *) current_table)->size;
// calculate hash value for a string
{
char *p;
hashval = 0;
for (p = %s ; *p != '\\0' ; p++) {
hashval = (*p + 31 * hashval) %% hashsize;
}
}
current_key = (MR_Word) %s;
// lookup the hash table
%s
",
string.format(CodeTemplate,
[s(VarName), s(VarName), s(HashLookupCode)], Code).
%---------------------%
:- type comparison_kind
---> plain_equals
; string_equals.
:- inst key_char for char/0
---> ('s')
; ('i')
; ('f').
:- type maybe_test_keys
---> do_not_test_keys
; test_keys(
int, % The fact_table_size parameter.
string, % predicate name
list(fact_arg_type),
list(fact_table_var),
int % The argument number.
).
% Generate code to lookup the key in the hash table.
% KeyType should be 's', 'i' or 'f' for string, int or float,
% respectively. CompareTemplate should be a template for testing for
% equality for the type given, e.g. "%s == %s" for ints,
% "strcmp(%s, %s) == 0" for strings.
%
:- pred generate_hash_lookup_code(string::in, string::in, int::in,
comparison_kind::in, char::in(key_char), maybe_test_keys::in,
string::out) is det.
generate_hash_lookup_code(VarName, LabelName, LabelNum,
ComparisonKind, KeyType, TestKeys, HashLookupCode) :-
string.format("((struct MR_fact_table_hash_table_%c *) current_table)"
++ "->table[hashval]", [c(KeyType)], HashTableEntry),
HashTableKey = HashTableEntry ++ ".key",
(
ComparisonKind = plain_equals,
string.format("%s == %s", [s(HashTableKey), s(VarName)],
CompareString)
;
ComparisonKind = string_equals,
string.format("strcmp(%s, %s) == 0", [s(HashTableKey), s(VarName)],
CompareString)
),
HashLookupCodeTemplate = "
do {
if (MR_FACT_TABLE_HASH_ENTRY_TYPE(%s) != 0 && %s) {
ind = (MR_Word) %s.index;
goto found_%s_%d;
}
} while ((hashval = %s.next) != -1);
// key not found
goto failure_code_%s;
found_%s_%d:
if (MR_FACT_TABLE_HASH_ENTRY_TYPE(%s) == 1) {
ind = MR_FACT_TABLE_HASH_INDEX(ind);
// check that any remaining input arguments match
%s
keytype = '%c';
hashval = %s.next;
goto success_code_%s;
}
current_table = (void *) MR_FACT_TABLE_HASH_POINTER(ind);
",
(
TestKeys =
test_keys(FactTableSize, PredName, Types, FactTableVars, ArgNum),
FactTableName = "mercury__" ++ PredName ++ "_fact_table",
generate_test_condition_code(FactTableSize, FactTableName,
Types, FactTableVars, ArgNum, have_not_seen_input_arg, CondCode),
( if CondCode = "" then
TestCode = ""
else
TestCodeTemplate = "if (%s\t\t\t) goto failure_code_%s;\n",
string.format(TestCodeTemplate, [s(CondCode), s(LabelName)],
TestCode)
)
;
TestKeys = do_not_test_keys,
TestCode = ""
),
string.format(HashLookupCodeTemplate,
[s(HashTableEntry), s(CompareString),
s(HashTableEntry), s(LabelName), i(LabelNum),
s(HashTableEntry), s(LabelName), s(LabelName), i(LabelNum),
s(HashTableEntry), s(TestCode), c(KeyType),
s(HashTableEntry), s(LabelName)],
HashLookupCode).
%---------------------%
% Generate code to lookup the fact table with a given index
%
:- pred generate_fact_lookup_code(int::in, string::in,
list(fact_arg_type)::in, list(fact_table_var)::in, int::in,
string::out) is det.
generate_fact_lookup_code(_, _, [], [], _, "").
generate_fact_lookup_code(_, _, [_ | _], [], _, _) :-
unexpected($pred, "too many pragma vars").
generate_fact_lookup_code(_, _, [], [_ | _], _, _) :-
unexpected($pred, "too many types").
generate_fact_lookup_code(FactTableSize, PredName,
[Type | Types], [FactTableVar | FactTableVars], ArgNum, Code) :-
FactTableVar = fact_table_var(VarName, Mode, MakeUnique, _),
(
Mode = fully_out,
TableEntryTemplate = "mercury__%s_fact_table[ind/%d][ind%%%d].V_%d",
string.format(TableEntryTemplate,
[s(PredName), i(FactTableSize), i(FactTableSize), i(ArgNum)],
TableEntry),
(
Type = fact_arg_type_string,
(
MakeUnique = do_not_make_unique,
% Cast MR_ConstString -> MR_Word -> MR_String to avoid gcc
% warning "assignment discards `const'".
Template = "\t\tMR_make_aligned_string(%s, " ++
"(MR_String) (MR_Word) %s);\n",
string.format(Template, [s(VarName), s(TableEntry)], ArgCode)
;
MakeUnique = make_unique,
% Unique modes need to allow destructive update,
% so we need to make a copy of the string on the heap.
Template =
" MR_incr_hp_atomic(tmp,
(strlen(%s) + sizeof(MR_Word))
/ sizeof(MR_Word));
%s = (MR_String) tmp;
strcpy(%s, %s);
",
string.format(Template,
[s(TableEntry), s(VarName), s(VarName), s(TableEntry)],
ArgCode)
)
;
( Type = fact_arg_type_int
; Type = fact_arg_type_float
),
Template = "\t\t%s = %s;\n",
string.format(Template, [s(VarName), s(TableEntry)], ArgCode)
),
generate_fact_lookup_code(FactTableSize, PredName,
Types, FactTableVars, ArgNum + 1, ArgsCode),
Code = ArgCode ++ ArgsCode
;
Mode = fully_in,
% Skip non-output arguments.
generate_fact_lookup_code(FactTableSize, PredName,
Types, FactTableVars, ArgNum + 1, Code)
).
% Generate code to create argument variables and assign them to registers.
%
:- pred generate_argument_vars_code(module_info::in,
list(fact_arg_type)::in, list(fact_table_var)::in,
string::out, string::out, string::out,
string::out, string::out, int::out) is det.
generate_argument_vars_code(ModuleInfo, FactArgTypes, FactTableVars,
DeclCode, InputCode, OutputCode, SaveRegsCode, GetRegsCode,
NumInputArgs) :-
Types = list.map(
( func(FactArgType) = Type :-
( FactArgType = fact_arg_type_int, Type = int_type
; FactArgType = fact_arg_type_float, Type = float_type
; FactArgType = fact_arg_type_string, Type = string_type
)
), FactArgTypes),
Modes = list.map(
( func(fact_table_var(_, FactTableMode, _, _)) = Mode :-
( FactTableMode = fully_in, Mode = in_mode
; FactTableMode = fully_out, Mode = out_mode
)
), FactTableVars),
make_standard_arg_infos(ModuleInfo, model_non, Types, Modes, ArgInfos),
% XXX Starting counting NumInputArgs at 1 looks strange, since
% we have not seen any input args yet. However, while the code of
% generate_argument_vars_code_loop also refers to this arg pair
% as !NumInputArgs, generate_arg_input_code refers to it as FrameVarNum,
% and uses it accordingly.
generate_argument_vars_code_loop(FactArgTypes, FactTableVars, ArgInfos,
DeclCode, InputCode, OutputCode, SaveRegsCode, GetRegsCode,
1, NumInputArgs).
:- pred generate_argument_vars_code_loop(
list(fact_arg_type)::in, list(fact_table_var)::in, list(arg_info)::in,
string::out, string::out, string::out,
string::out, string::out, int::in, int::out) is det.
generate_argument_vars_code_loop(Types, FactTableVars, ArgInfos,
DeclCode, InputCode, OutputCode, SaveRegsCode, GetRegsCode,
!NumInputArgs) :-
( if
Types = [],
FactTableVars = [],
ArgInfos = []
then
DeclCode = "",
InputCode = "",
OutputCode = "",
SaveRegsCode = "",
GetRegsCode = ""
else if
Types = [Type | TailTypes],
FactTableVars = [FactTableVar | TailFactTableVars],
ArgInfos = [ArgInfo | TailArgInfos]
then
FactTableVar = fact_table_var(VarName, Mode, _, _),
ArgInfo = arg_info(Loc, _),
generate_arg_decl_code(VarName, Type, ArgDeclCode),
(
Mode = fully_in,
!:NumInputArgs = !.NumInputArgs + 1,
generate_arg_input_code(VarName, Type, Loc, !.NumInputArgs,
ArgInputCode, ArgSaveRegsCode, ArgGetRegsCode),
ArgOutputCode = ""
;
Mode = fully_out,
generate_arg_output_code(VarName, Type, Loc, ArgOutputCode),
ArgInputCode = "",
ArgSaveRegsCode = "",
ArgGetRegsCode = ""
),
generate_argument_vars_code_loop(
TailTypes, TailFactTableVars, TailArgInfos,
ArgsDeclCode, ArgsInputCode, ArgsOutputCode, ArgsSaveRegsCode,
ArgsGetRegsCode, !NumInputArgs),
DeclCode = ArgDeclCode ++ ArgsDeclCode,
InputCode = ArgInputCode ++ ArgsInputCode,
OutputCode = ArgOutputCode ++ ArgsOutputCode,
SaveRegsCode = ArgSaveRegsCode ++ ArgsSaveRegsCode,
GetRegsCode = ArgGetRegsCode ++ ArgsGetRegsCode
else
unexpected($pred, "list length mismatch")
).
:- pred generate_arg_decl_code(string::in, fact_arg_type::in, string::out)
is det.
generate_arg_decl_code(Name, Type, DeclCode) :-
( Type = fact_arg_type_int, CType = "MR_Integer"
; Type = fact_arg_type_float, CType = "MR_Float"
; Type = fact_arg_type_string, CType = "MR_String"
),
string.format("\t\t%s %s;\n", [s(CType), s(Name)], DeclCode).
:- pred generate_arg_input_code(string::in, fact_arg_type::in, arg_loc::in,
int::in, string::out, string::out, string::out) is det.
generate_arg_input_code(Name, Type, ArgLoc, FrameVarNum,
InputCode, SaveRegCode, GetRegCode) :-
ArgLoc = reg(RegType, RegNum),
(
RegType = reg_r,
ConvertToFrameVar = "",
ConvertFromFrameVar = ""
;
RegType = reg_f,
ConvertToFrameVar = "MR_float_to_word",
ConvertFromFrameVar = "MR_word_to_float"
),
RegNameStr = reg_to_string(RegType, RegNum),
convert_arg_type_from_mercury(ArgLoc, RegNameStr, Type,
ConvertedRegNameStr),
string.format("\t\t%s = %s;\n",
[s(Name), s(ConvertedRegNameStr)], InputCode),
string.format("\t\tMR_framevar(%d) = %s(%s);\n",
[i(FrameVarNum), s(ConvertToFrameVar), s(RegNameStr)], SaveRegCode),
string.format("\t\t%s = %s(MR_framevar(%d));\n",
[s(RegNameStr), s(ConvertFromFrameVar), i(FrameVarNum)], GetRegCode).
:- pred generate_arg_output_code(string::in, fact_arg_type::in, arg_loc::in,
string::out) is det.
generate_arg_output_code(Name, Type, ArgLoc, OutputCode) :-
ArgLoc = reg(RegType, RegNum),
RegName = reg_to_string(RegType, RegNum),
convert_arg_type_to_mercury(Name, Type, ArgLoc, ConvertedName),
Template = "\t\t%s = %s;\n",
string.format(Template, [s(RegName), s(ConvertedName)], OutputCode).
%---------------------%
:- pred convert_arg_type_to_mercury(string::in, fact_arg_type::in, arg_loc::in,
string::out) is det.
convert_arg_type_to_mercury(RvalStr, Type, TargetArgLoc, ConvertedRvalStr) :-
% This code is a version of convert_type_to_mercury that has been cut down
% to handle only fact_arg_types.
(
Type = fact_arg_type_int,
ConvertedRvalStr = RvalStr
;
Type = fact_arg_type_float,
(
TargetArgLoc = reg(reg_r, _),
ConvertedRvalStr = "MR_float_to_word(" ++ RvalStr ++ ")"
;
TargetArgLoc = reg(reg_f, _),
ConvertedRvalStr = RvalStr
)
;
Type = fact_arg_type_string,
ConvertedRvalStr = "(MR_Word) " ++ RvalStr
).
:- pred convert_arg_type_from_mercury(arg_loc::in, string::in,
fact_arg_type::in, string::out) is det.
convert_arg_type_from_mercury(SourceArgLoc, RvalStr, Type, ConvertedRvalStr) :-
% This code is a version of convert_type_from_mercury
% cut down to handle only fact_arg_types.
(
Type = fact_arg_type_int,
ConvertedRvalStr = RvalStr
;
Type = fact_arg_type_float,
(
SourceArgLoc = reg(reg_r, _),
ConvertedRvalStr = "MR_word_to_float(" ++ RvalStr ++ ")"
;
SourceArgLoc = reg(reg_f, _),
ConvertedRvalStr = RvalStr
)
;
Type = fact_arg_type_string,
ConvertedRvalStr = "(MR_String) " ++ RvalStr
).
%---------------------%
% Generate code to test that the fact found matches the input arguments.
% This is only required for generate_primary_nondet_code. Other procedures
% can test the key in the hash table against the input arguments.
%
:- pred generate_fact_test_code(int::in, string::in,
list(fact_arg_type)::in, list(fact_table_var)::in, string::out) is det.
generate_fact_test_code(FactTableSize, PredName,
Types, FactTableVars, FactTestCode) :-
FactTableName = "mercury__" ++ PredName ++ "_fact_table",
generate_test_condition_code(FactTableSize, FactTableName,
Types, FactTableVars, 1, have_not_seen_input_arg, CondCode),
FactTestCode = "\t\tif(" ++ CondCode ++ "\t\t) MR_fail();\n".
:- type maybe_seen_input_arg
---> have_seen_input_arg
; have_not_seen_input_arg.
:- pred generate_test_condition_code(int::in, string::in,
list(fact_arg_type)::in, list(fact_table_var)::in, int::in,
maybe_seen_input_arg::in, string::out) is det.
generate_test_condition_code(_, _, [], [], _, _, "").
generate_test_condition_code(_, _, [_ | _], [], _, _, "") :-
unexpected($pred, "too many PragmaVars").
generate_test_condition_code(_, _, [], [_ | _], _, _, "") :-
unexpected($pred, "too many ArgTypes").
generate_test_condition_code(FactTableSize, FactTableName,
[Type | Types], [FactTableVar | FactTableVars], ArgNum,
!.IsFirstInputArg, CondCode) :-
FactTableVar = fact_table_var(Name, Mode, _, _),
(
Mode = fully_in,
(
Type = fact_arg_type_string,
Template = "strcmp(%s[ind/%d][ind%%%d].V_%d, %s) != 0\n",
string.format(Template, [s(FactTableName), i(FactTableSize),
i(FactTableSize), i(ArgNum), s(Name)], ArgCondCode0)
;
( Type = fact_arg_type_int
; Type = fact_arg_type_float
),
Template = "%s[ind/%d][ind%%%d].V_%d != %s\n",
string.format(Template, [s(FactTableName), i(FactTableSize),
i(FactTableSize), i(ArgNum), s(Name)], ArgCondCode0)
),
(
!.IsFirstInputArg = have_seen_input_arg,
ArgCondCode = "\t\t|| " ++ ArgCondCode0
;
!.IsFirstInputArg = have_not_seen_input_arg,
ArgCondCode = ArgCondCode0
),
!:IsFirstInputArg = have_seen_input_arg
;
Mode = fully_out,
ArgCondCode = ""
),
generate_test_condition_code(FactTableSize, FactTableName,
Types, FactTableVars, ArgNum + 1, !.IsFirstInputArg, ArgsCondCode),
CondCode = ArgCondCode ++ ArgsCondCode.
%---------------------------------------------------------------------------%
:- pred make_fact_table_identifier(sym_name::in, string::out) is det.
make_fact_table_identifier(SymName, Identifier) :-
Identifier = sym_name_mangle(SymName).
%---------------------------------------------------------------------------%
% fact_table_vars_to_names_string(PragmaVars, NamesString):
%
% Create a string containing the names of the vars separated by commas.
%
:- pred fact_table_vars_to_names_string(list(fact_table_var)::in,
string::out) is det.
fact_table_vars_to_names_string([], "").
fact_table_vars_to_names_string([FactTableVar | FactTableVars],
NamesString) :-
fact_table_vars_to_names_string(FactTableVars, NamesStringTail),
FactTableVar = fact_table_var(Name, _, _, _),
NamesString = Name ++ ", " ++ NamesStringTail.
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
% fact_table_size(Globals, FactTableSize):
%
% FactTableSize is the maximum size of each array in the fact data table.
% GCC doesn't cope very well with huge arrays, so we break the fact data
% table into a number of smaller arrays, each with a maximum size given
% by FactTableSize, and create an array of pointers to these arrays
% to access the data. The size should be a power of 2 to make the
% generated code more efficient.
%
:- pred fact_table_size(globals::in, int::out) is det.
fact_table_size(Globals, FactTableSize) :-
globals.lookup_int_option(Globals, fact_table_max_array_size,
FactTableSize).
%---------------------------------------------------------------------------%
% Delete a file. Report an error message if something goes wrong.
%
:- pred delete_temporary_file(string::in,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
delete_temporary_file(FileName, !Specs, !IO) :-
io.file.remove_file(FileName, Result, !IO),
(
Result = ok
;
Result = error(ErrorCode),
io.error_message(ErrorCode, ErrorMsg),
io.progname_base("mercury_compile", ProgName, !IO),
Pieces = [fixed(ProgName), suffix(":"), words("error deleting file"),
quote(FileName), suffix(":"), nl,
words(ErrorMsg), suffix("."), nl],
Spec = error_spec($pred, severity_error, phase_fact_table_check,
[error_msg(no, treat_based_on_posn, 0, [always(Pieces)])]),
!:Specs = [Spec | !.Specs]
).
%---------------------------------------------------------------------------%
:- pred add_call_system_error(string::in, io.error::in,
list(error_spec)::in, list(error_spec)::out, io::di, io::uo) is det.
add_call_system_error(Cmd, ErrorCode, !Specs, !IO) :-
io.progname_base("mercury_compile", ProgName, !IO),
io.error_message(ErrorCode, ErrorMsg),
Pieces = [fixed(ProgName), suffix(":"),
words("error executing system command"), quote(Cmd), suffix(":"), nl,
words(ErrorMsg), suffix("."), nl],
Spec = error_spec($pred, severity_error, phase_fact_table_check,
[error_msg(no, treat_based_on_posn, 0, [always(Pieces)])]),
!:Specs = [Spec | !.Specs].
%---------------------------------------------------------------------------%
:- pred add_file_open_error(maybe(prog_context)::in, string::in, string::in,
io.error::in, list(error_spec)::in, list(error_spec)::out,
io::di, io::uo) is det.
add_file_open_error(MaybeContext, FileName, InOrOut, Error, !Specs, !IO) :-
io.progname_base("mercury_compile", ProgName, !IO),
io.error_message(Error, ErrorMsg),
Pieces = [fixed(ProgName), suffix(":"),
words("error opening file"), quote(FileName),
words("for"), words(InOrOut), suffix(":"), nl,
words(ErrorMsg), nl],
Spec = error_spec($pred, severity_error, phase_fact_table_check,
[error_msg(MaybeContext, treat_based_on_posn, 0, [always(Pieces)])]),
!:Specs = [Spec | !.Specs].
%---------------------------------------------------------------------------%
:- pred add_error_context_and_pieces(prog_context::in,
list(format_piece)::in,
list(error_spec)::in, list(error_spec)::out) is det.
add_error_context_and_pieces(Context, Pieces, !Specs) :-
Spec = simplest_spec($pred, severity_error, phase_fact_table_check,
Context, Pieces),
!:Specs = [Spec | !.Specs].
:- pred add_error_pieces(list(format_piece)::in,
list(error_spec)::in, list(error_spec)::out) is det.
add_error_pieces(Pieces, !Specs) :-
Spec = simplest_no_context_spec($pred, severity_error,
phase_fact_table_check, Pieces),
!:Specs = [Spec | !.Specs].
%---------------------------------------------------------------------------%
:- pred get_maybe_progress_output_stream(module_info::in,
io.text_output_stream::in, maybe(io.text_output_stream)::out) is det.
get_maybe_progress_output_stream(ModuleInfo, ProgressStream,
MaybeProgressStream) :-
module_info_get_globals(ModuleInfo, Globals),
globals.lookup_bool_option(Globals, very_verbose, VeryVerbose),
(
VeryVerbose = no,
MaybeProgressStream = no
;
VeryVerbose = yes,
MaybeProgressStream = yes(ProgressStream)
).
%---------------------------------------------------------------------------%
:- end_module ll_backend.fact_table.
%---------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink