mirror of
https://github.com/Mercury-Language/mercury.git
synced 2026-04-16 18:03:36 +00:00
307b1dc148
compiler/error_spec.m:
This new module contains the part of the old error_util.m that defines
the error_spec type, and some functions that can help construct pieces
of error_specs. Most modules of the compiler that deal with errors
will need to import only this part of the old error_util.m.
This change also renames the format_component type to format_piece,
which matches our long-standing naming convention for variables containing
(lists of) values of this type.
compiler/write_error_spec.m:
This new module contains the part of the old error_util.m that
writes out error specs, and converts them to strings.
This diff marks as obsolete the versions of predicates that
write out error specs to the current output stream, without
*explicitly* specifying the intended stream.
compiler/error_sort.m:
This new module contains the part of the old error_util.m that
sorts lists of error specs and error msgs.
compiler/error_type_util.m:
This new module contains the part of the old error_util.m that
convert types to format_pieces that generate readable output.
compiler/parse_tree.m:
compiler/notes/compiler_design.html:
Include and document the new modules.
compiler/error_util.m:
The code remaining in the original error_util.m consists of
general utility predicates and functions that don't fit into
any of the modules above.
Delete an unneeded pair of I/O states from the argument list
of a predicate.
compiler/file_util.m:
Move the unable_to_open_file predicate here from error_util.m,
since it belongs here. Mark another predicate that writes
to the current output stream as obsolete.
compiler/hlds_error_util.m:
Mark two predicates that wrote out error_spec to the current output
stream as obsolete, and add versions that take an explicit output stream.
compiler/Mercury.options:
Compile the modules that call the newly obsoleted predicates
with --no-warn-obsolete, for the time being.
compiler/*.m:
Conform to the changes above, mostly by updating import_module
declarations, and renaming format_component to format_piece.
825 lines
31 KiB
Mathematica
825 lines
31 KiB
Mathematica
%---------------------------------------------------------------------------%
|
|
% vim: ft=mercury ts=4 sw=4 et
|
|
%---------------------------------------------------------------------------%
|
|
% Copyright (C) 1995-2012, 2014 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: polymorphism_info.m.
|
|
% Main authors: fjh and zs (when this code was in polymorphism.m).
|
|
%
|
|
% This module defines the poly_info structure used by polymorphism.m.
|
|
%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- module check_hlds.polymorphism_info.
|
|
:- interface.
|
|
|
|
:- import_module hlds.
|
|
:- import_module hlds.const_struct.
|
|
:- import_module hlds.hlds_class.
|
|
:- import_module hlds.hlds_clauses.
|
|
:- import_module hlds.hlds_goal.
|
|
:- import_module hlds.hlds_module.
|
|
:- import_module hlds.hlds_pred.
|
|
:- import_module hlds.hlds_rtti.
|
|
:- import_module parse_tree.
|
|
:- import_module parse_tree.error_spec.
|
|
:- import_module parse_tree.prog_data.
|
|
:- import_module parse_tree.var_table.
|
|
|
|
:- import_module assoc_list.
|
|
:- import_module io.
|
|
:- import_module list.
|
|
:- import_module map.
|
|
:- import_module maybe.
|
|
:- import_module pair.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type const_or_var_arg
|
|
---> cova_const(const_struct_arg)
|
|
; cova_var(prog_var).
|
|
|
|
:- type type_info_var_map ==
|
|
map(type_ctor,
|
|
map(list(mer_type), pair(prog_var, maybe(const_struct_arg)))).
|
|
|
|
:- type typeclass_info_map_entry
|
|
---> typeclass_info_map_entry(
|
|
% The cons_id representing the base_typeclass_info.
|
|
cons_id,
|
|
|
|
% Maps the arguments of the typeclass_info_cell_constructor
|
|
% after the base_typeclass_info to the variable that holds the
|
|
% typeclass_info for that cell.
|
|
map(list(const_or_var_arg),
|
|
pair(prog_var, maybe(const_struct_arg)))
|
|
).
|
|
|
|
:- type typeclass_info_map ==
|
|
map(class_name, map(list(mer_type), typeclass_info_map_entry)).
|
|
|
|
:- type int_const_map == map(int, prog_var).
|
|
|
|
% If the value that can be a constant structure argument is currently
|
|
% available in a variable, give the id of that variable.
|
|
%
|
|
:- type const_struct_var_map == map(const_struct_arg, prog_var).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type poly_info.
|
|
|
|
% Init_poly_info initializes a poly_info from a pred_info and clauses_info.
|
|
% (See also create_poly_info.)
|
|
%
|
|
:- pred init_poly_info(module_info::in, pred_info::in, clauses_info::in,
|
|
poly_info::out) is det.
|
|
|
|
% Extract some fields from a pred_info and proc_info and use them to
|
|
% create a poly_info, for use by the polymorphism transformation.
|
|
%
|
|
:- pred create_poly_info(module_info::in, pred_info::in,
|
|
proc_info::in, poly_info::out) is det.
|
|
|
|
% Update the fields in a pred_info and proc_info with
|
|
% the values in a poly_info.
|
|
%
|
|
:- pred poly_info_extract(poly_info::in, list(error_spec)::out,
|
|
pred_info::in, pred_info::out, proc_info::in, proc_info::out,
|
|
module_info::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type maybe_must_requantify
|
|
---> no_must_requantify
|
|
; must_requantify.
|
|
|
|
:- pred poly_info_get_module_info(poly_info::in,
|
|
module_info::out) is det.
|
|
:- pred poly_info_get_var_table(poly_info::in,
|
|
var_table::out) is det.
|
|
:- pred poly_info_get_rtti_varmaps(poly_info::in,
|
|
rtti_varmaps::out) is det.
|
|
:- pred poly_info_get_typevarset(poly_info::in,
|
|
tvarset::out) is det.
|
|
:- pred poly_info_get_tvar_kind_map(poly_info::in,
|
|
tvar_kind_map::out) is det.
|
|
:- pred poly_info_get_proof_map(poly_info::in,
|
|
constraint_proof_map::out) is det.
|
|
:- pred poly_info_get_constraint_map(poly_info::in,
|
|
constraint_map::out) is det.
|
|
:- pred poly_info_get_type_info_var_map(poly_info::in,
|
|
type_info_var_map::out) is det.
|
|
:- pred poly_info_get_typeclass_info_map(poly_info::in,
|
|
typeclass_info_map::out) is det.
|
|
:- pred poly_info_get_int_const_map(poly_info::in,
|
|
int_const_map::out) is det.
|
|
:- pred poly_info_get_const_struct_var_map(poly_info::in,
|
|
const_struct_var_map::out) is det.
|
|
:- pred poly_info_get_num_reuses(poly_info::in,
|
|
int::out) is det.
|
|
:- pred poly_info_get_const_struct_db(poly_info::in,
|
|
const_struct_db::out) is det.
|
|
:- pred poly_info_get_defined_where(poly_info::in,
|
|
defined_where::out) is det.
|
|
:- pred poly_info_get_must_requantify(poly_info::in,
|
|
maybe_must_requantify::out) is det.
|
|
:- pred poly_info_get_errors(poly_info::in,
|
|
list(error_spec)::out) is det.
|
|
|
|
:- pred poly_info_set_var_table(var_table::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_var_table_rtti(var_table::in, rtti_varmaps::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_rtti_varmaps(rtti_varmaps::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_typevarset(tvarset::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_proof_map(constraint_proof_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_type_info_var_map(type_info_var_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_typeclass_info_map(typeclass_info_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_int_const_map(int_const_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_const_struct_var_map(const_struct_var_map::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_num_reuses(int::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_const_struct_db(const_struct_db::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_must_requantify(
|
|
poly_info::in, poly_info::out) is det.
|
|
:- pred poly_info_set_errors(list(error_spec)::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type cache_maps
|
|
---> cache_maps(
|
|
cm_snapshot_num :: int,
|
|
cm_type_info_var_map :: type_info_var_map,
|
|
cm_typeclass_info_map :: typeclass_info_map,
|
|
cm_int_const_map :: int_const_map,
|
|
cm_const_struct_var_map :: const_struct_var_map
|
|
).
|
|
|
|
:- pred get_cache_maps_snapshot(string::in, cache_maps::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
:- pred set_cache_maps_snapshot(string::in, cache_maps::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
:- pred empty_cache_maps(poly_info::in, poly_info::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type var_maps
|
|
---> var_maps(
|
|
vm_snapshot_num :: int,
|
|
vm_var_table :: var_table,
|
|
vm_rtti_varmaps :: rtti_varmaps,
|
|
vm_cache_maps :: cache_maps
|
|
).
|
|
|
|
:- pred get_var_maps_snapshot(string::in, var_maps::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
:- pred set_var_maps_snapshot(string::in, var_maps::in,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pred get_poly_const(int::in, prog_var::out, list(hlds_goal)::out,
|
|
poly_info::in, poly_info::out) is det.
|
|
|
|
:- pred all_are_const_struct_args(
|
|
assoc_list(prog_var, maybe(const_struct_arg))::in,
|
|
list(const_struct_arg)::out) is semidet.
|
|
|
|
:- pred get_inst_of_const_struct_arg(const_struct_db::in, const_struct_arg::in,
|
|
mer_inst::out) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type maybe_selected_pred
|
|
---> is_not_selected_pred
|
|
; is_selected_pred.
|
|
|
|
:- pred poly_info_get_selected_pred(maybe_selected_pred::out,
|
|
io::di, io::uo) is det.
|
|
:- pred poly_info_set_selected_pred(maybe_selected_pred::in,
|
|
io::di, io::uo) is det.
|
|
:- pred poly_info_get_indent_level(int::out, io::di, io::uo) is det.
|
|
:- pred poly_info_set_indent_level(int::in, io::di, io::uo) is det.
|
|
|
|
:- pred poly_info_get_debug_stream(poly_info::in, io.text_output_stream::out,
|
|
io::di, io::uo) is det.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- implementation.
|
|
|
|
:- import_module hlds.make_goal.
|
|
:- import_module hlds.status.
|
|
:- import_module libs.
|
|
:- import_module libs.globals.
|
|
|
|
:- import_module bool.
|
|
:- import_module int.
|
|
:- import_module string.
|
|
:- import_module varset.
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- type poly_info
|
|
---> poly_info(
|
|
poly_module_info :: module_info,
|
|
|
|
poly_var_table :: var_table,
|
|
poly_rtti_varmaps :: rtti_varmaps,
|
|
|
|
poly_typevarset :: tvarset,
|
|
poly_tvar_kind_map :: tvar_kind_map,
|
|
|
|
% Specifies why each constraint that was eliminated from the
|
|
% pred was able to be eliminated (this allows us to efficiently
|
|
% construct the dictionary).
|
|
% Note that the rtti_varmaps is separate from the
|
|
% constraint_proof_map, since the second is the information
|
|
% calculated during typechecking, while the first is
|
|
% the information calculated in the polymorphism pass.
|
|
poly_proof_map :: constraint_proof_map,
|
|
|
|
% Specifies the constraints at each location in the goal.
|
|
poly_constraint_map :: constraint_map,
|
|
|
|
% The next four maps hold information about what
|
|
% type_ctor_infos, type_infos, base_typeclass_infos,
|
|
% typeclass_infos and ints are guaranteed to be available
|
|
% (i.e. created by previous code on all execution paths)
|
|
% at the current point in the code, so they can be reused.
|
|
% The fifth field counts the number of times that one of these
|
|
% variables has in fact been reused.
|
|
%
|
|
% The type_infos and typeclass_infos are in the first two maps.
|
|
% The type_ctor_infos and base_typeclass_infos are in the
|
|
% fourth map. The integers are in the third map.
|
|
% The fourth map also caches typeclass_infos for instance ids.
|
|
poly_type_info_var_map :: type_info_var_map,
|
|
poly_typeclass_info_map :: typeclass_info_map,
|
|
poly_int_const_map :: int_const_map,
|
|
poly_const_struct_var_map :: const_struct_var_map,
|
|
poly_num_reuses :: int,
|
|
|
|
poly_snapshot_num :: int,
|
|
|
|
% The database of constant structures of the module.
|
|
% If a type_info or typeclass_info we construct is a constant
|
|
% term, we allocate it in this database.
|
|
poly_const_struct_db :: const_struct_db,
|
|
|
|
poly_defined_where :: defined_where,
|
|
|
|
poly_must_requantify :: maybe_must_requantify,
|
|
|
|
% The list of errors we have discovered during the polymorphism
|
|
% pass.
|
|
poly_errors :: list(error_spec)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
init_poly_info(ModuleInfo, PredInfo, ClausesInfo, PolyInfo) :-
|
|
clauses_info_get_var_table(ClausesInfo, VarTable),
|
|
pred_info_get_typevarset(PredInfo, TypeVarSet),
|
|
pred_info_get_tvar_kind_map(PredInfo, TypeVarKinds),
|
|
pred_info_get_constraint_proof_map(PredInfo, ProofMap),
|
|
pred_info_get_constraint_map(PredInfo, ConstraintMap),
|
|
rtti_varmaps_init(RttiVarMaps),
|
|
map.init(TypeInfoVarMap),
|
|
map.init(TypeClassInfoMap),
|
|
map.init(IntConstMap),
|
|
map.init(ConstStructVarMap),
|
|
NumReuses = 0,
|
|
SnapshotNum = 0,
|
|
module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
|
|
pred_info_get_status(PredInfo, PredStatus),
|
|
pred_status_defined_in_this_module(PredStatus) = InThisModule,
|
|
( InThisModule = yes, DefinedWhere = defined_in_this_module
|
|
; InThisModule = no, DefinedWhere = defined_in_other_module
|
|
),
|
|
Requant = no_must_requantify,
|
|
Specs = [],
|
|
PolyInfo = poly_info(ModuleInfo, VarTable, RttiVarMaps,
|
|
TypeVarSet, TypeVarKinds, ProofMap, ConstraintMap,
|
|
TypeInfoVarMap, TypeClassInfoMap, IntConstMap, ConstStructVarMap,
|
|
NumReuses, SnapshotNum, ConstStructDb, DefinedWhere, Requant, Specs).
|
|
|
|
create_poly_info(ModuleInfo, PredInfo, ProcInfo, PolyInfo) :-
|
|
pred_info_get_typevarset(PredInfo, TypeVarSet),
|
|
pred_info_get_tvar_kind_map(PredInfo, TypeVarKinds),
|
|
pred_info_get_constraint_proof_map(PredInfo, ProofMap),
|
|
pred_info_get_constraint_map(PredInfo, ConstraintMap),
|
|
proc_info_get_var_table(ProcInfo, VarTable),
|
|
proc_info_get_rtti_varmaps(ProcInfo, RttiVarMaps),
|
|
map.init(TypeInfoVarMap),
|
|
map.init(TypeClassInfoMap),
|
|
map.init(IntConstMap),
|
|
map.init(ConstStructVarMap),
|
|
NumReuses = 0,
|
|
SnapshotNum = 0,
|
|
module_info_get_const_struct_db(ModuleInfo, ConstStructDb),
|
|
pred_info_get_status(PredInfo, PredStatus),
|
|
pred_status_defined_in_this_module(PredStatus) = InThisModule,
|
|
( InThisModule = yes, DefinedWhere = defined_in_this_module
|
|
; InThisModule = no, DefinedWhere = defined_in_other_module
|
|
),
|
|
Requant = no_must_requantify,
|
|
Specs = [],
|
|
PolyInfo = poly_info(ModuleInfo, VarTable, RttiVarMaps,
|
|
TypeVarSet, TypeVarKinds, ProofMap, ConstraintMap,
|
|
TypeInfoVarMap, TypeClassInfoMap, IntConstMap, ConstStructVarMap,
|
|
NumReuses, SnapshotNum, ConstStructDb, DefinedWhere, Requant, Specs).
|
|
|
|
poly_info_extract(Info, Specs, !PredInfo, !ProcInfo, !:ModuleInfo) :-
|
|
Info = poly_info(!:ModuleInfo, VarTable, RttiVarMaps,
|
|
TypeVarSet, TypeVarKinds, _ProofMap, _ConstraintMap,
|
|
_TypeInfoVarMap, _TypeClassInfoMap, _IntConstMap, _ConstStructVarMap,
|
|
_NumReuses, _SnapshotNum, ConstStructDb, _DefinedWhere,
|
|
_Requant, Specs),
|
|
|
|
module_info_set_const_struct_db(ConstStructDb, !ModuleInfo),
|
|
|
|
% Set the new values of the fields in proc_info and pred_info.
|
|
proc_info_set_var_table(VarTable, !ProcInfo),
|
|
proc_info_set_rtti_varmaps(RttiVarMaps, !ProcInfo),
|
|
pred_info_set_typevarset(TypeVarSet, !PredInfo),
|
|
pred_info_set_tvar_kind_map(TypeVarKinds, !PredInfo).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- pragma inline(pred(poly_info_get_module_info/2)).
|
|
:- pragma inline(pred(poly_info_get_var_table/2)).
|
|
:- pragma inline(pred(poly_info_get_rtti_varmaps/2)).
|
|
:- pragma inline(pred(poly_info_get_typevarset/2)).
|
|
:- pragma inline(pred(poly_info_get_tvar_kind_map/2)).
|
|
:- pragma inline(pred(poly_info_get_proof_map/2)).
|
|
:- pragma inline(pred(poly_info_get_constraint_map/2)).
|
|
:- pragma inline(pred(poly_info_get_type_info_var_map/2)).
|
|
:- pragma inline(pred(poly_info_get_typeclass_info_map/2)).
|
|
:- pragma inline(pred(poly_info_get_const_struct_var_map/2)).
|
|
:- pragma inline(pred(poly_info_get_int_const_map/2)).
|
|
:- pragma inline(pred(poly_info_get_num_reuses/2)).
|
|
:- pragma inline(pred(poly_info_get_const_struct_db/2)).
|
|
:- pragma inline(pred(poly_info_get_errors/2)).
|
|
|
|
poly_info_get_module_info(!.PI, X) :-
|
|
X = !.PI ^ poly_module_info.
|
|
poly_info_get_var_table(!.PI, X) :-
|
|
X = !.PI ^ poly_var_table.
|
|
poly_info_get_rtti_varmaps(!.PI, X) :-
|
|
X = !.PI ^ poly_rtti_varmaps.
|
|
poly_info_get_typevarset(!.PI, X) :-
|
|
X = !.PI ^ poly_typevarset.
|
|
poly_info_get_tvar_kind_map(!.PI, X) :-
|
|
X = !.PI ^ poly_tvar_kind_map.
|
|
poly_info_get_proof_map(!.PI, X) :-
|
|
X = !.PI ^ poly_proof_map.
|
|
poly_info_get_constraint_map(!.PI, X) :-
|
|
X = !.PI ^ poly_constraint_map.
|
|
poly_info_get_type_info_var_map(!.PI, X) :-
|
|
X = !.PI ^ poly_type_info_var_map.
|
|
poly_info_get_typeclass_info_map(!.PI, X) :-
|
|
X = !.PI ^ poly_typeclass_info_map.
|
|
poly_info_get_int_const_map(!.PI, X) :-
|
|
X = !.PI ^ poly_int_const_map.
|
|
poly_info_get_const_struct_var_map(!.PI, X) :-
|
|
X = !.PI ^ poly_const_struct_var_map.
|
|
poly_info_get_num_reuses(!.PI, X) :-
|
|
X = !.PI ^ poly_num_reuses.
|
|
poly_info_get_const_struct_db(!.PI, X) :-
|
|
X = !.PI ^ poly_const_struct_db.
|
|
poly_info_get_defined_where(!.PI, X) :-
|
|
X = !.PI ^ poly_defined_where.
|
|
poly_info_get_must_requantify(!.PI, X) :-
|
|
X = !.PI ^ poly_must_requantify.
|
|
poly_info_get_errors(!.PI, X) :-
|
|
X = !.PI ^ poly_errors.
|
|
|
|
:- pragma inline(pred(poly_info_set_var_table/3)).
|
|
:- pragma inline(pred(poly_info_set_var_table_rtti/4)).
|
|
:- pragma inline(pred(poly_info_set_rtti_varmaps/3)).
|
|
:- pragma inline(pred(poly_info_set_typevarset/3)).
|
|
:- pragma inline(pred(poly_info_set_proof_map/3)).
|
|
:- pragma inline(pred(poly_info_set_type_info_var_map/3)).
|
|
:- pragma inline(pred(poly_info_set_typeclass_info_map/3)).
|
|
:- pragma inline(pred(poly_info_set_int_const_map/3)).
|
|
:- pragma inline(pred(poly_info_set_const_struct_var_map/3)).
|
|
:- pragma inline(pred(poly_info_set_num_reuses/3)).
|
|
:- pragma inline(pred(poly_info_set_const_struct_db/3)).
|
|
:- pragma inline(pred(poly_info_set_errors/3)).
|
|
|
|
poly_info_set_var_table(X, !PI) :-
|
|
!PI ^ poly_var_table := X.
|
|
poly_info_set_var_table_rtti(X, Y, !PI) :-
|
|
!:PI = ((!.PI
|
|
^ poly_var_table := X)
|
|
^ poly_rtti_varmaps := Y).
|
|
poly_info_set_rtti_varmaps(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_rtti_varmaps) then
|
|
true
|
|
else
|
|
!PI ^ poly_rtti_varmaps := X
|
|
).
|
|
poly_info_set_typevarset(X, !PI) :-
|
|
!PI ^ poly_typevarset := X.
|
|
poly_info_set_proof_map(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_proof_map) then
|
|
true
|
|
else
|
|
!PI ^ poly_proof_map := X
|
|
).
|
|
poly_info_set_type_info_var_map(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_type_info_var_map) then
|
|
true
|
|
else
|
|
!PI ^ poly_type_info_var_map := X
|
|
).
|
|
poly_info_set_typeclass_info_map(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_typeclass_info_map) then
|
|
true
|
|
else
|
|
!PI ^ poly_typeclass_info_map := X
|
|
).
|
|
poly_info_set_int_const_map(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_int_const_map) then
|
|
true
|
|
else
|
|
!PI ^ poly_int_const_map := X
|
|
).
|
|
poly_info_set_const_struct_var_map(X, !PI) :-
|
|
( if
|
|
private_builtin.pointer_equal(X, !.PI ^ poly_const_struct_var_map)
|
|
then
|
|
true
|
|
else
|
|
!PI ^ poly_const_struct_var_map := X
|
|
).
|
|
poly_info_set_num_reuses(X, !PI) :-
|
|
( if X = !.PI ^ poly_num_reuses then
|
|
true
|
|
else
|
|
!PI ^ poly_num_reuses := X
|
|
).
|
|
poly_info_set_const_struct_db(X, !PI) :-
|
|
( if private_builtin.pointer_equal(X, !.PI ^ poly_const_struct_db) then
|
|
true
|
|
else
|
|
!PI ^ poly_const_struct_db := X
|
|
).
|
|
poly_info_set_must_requantify(!PI) :-
|
|
!PI ^ poly_must_requantify := must_requantify.
|
|
poly_info_set_errors(X, !PI) :-
|
|
!PI ^ poly_errors := X.
|
|
|
|
% i read same diff same%
|
|
% 0 6245285 0 1560789 0.000% varset
|
|
% 1 6662703 0 0 vartypes
|
|
% 2 0 1110 129008 0.853% varset, vartypes
|
|
% 17 0 131468 1961967 6.280% varset, vartypes, rtti_varmaps
|
|
% 3 3052707 4 245972 0.002% typevarset
|
|
% 4 1578929 0 0 tvar_kind_map
|
|
% 5 8959328 2116731 988195 68.173% rtti_varmaps
|
|
% 6 14812 3980 4058 49.515% proof_map
|
|
% 7 3030093 0 0 constraint_map
|
|
% 8 811687 776589 288951 72.882% type_info_var_map
|
|
% 9 385071 863384 6104 99.298% typeclass_info_map
|
|
% 10 385706 863310 8464 99.029% int_const_map
|
|
% 11 253310 331092 41528 88.855% num_reuses
|
|
% 12 2559364 25821 15631 62.291% const_struct_db
|
|
% 13 583633 780835 286464 73.160% const_struct_var_map
|
|
% 14 0 0 0 pred_info
|
|
% 15 3933469 0 0 module_info
|
|
% 16 0 431065 87104 83.190% cache_maps_snapshot
|
|
|
|
% :- pragma foreign_decl("C", local,
|
|
% "
|
|
% #define MR_NUM_INFO_STATS 18
|
|
% unsigned long MR_stats_read[MR_NUM_INFO_STATS];
|
|
% unsigned long MR_stats_same[MR_NUM_INFO_STATS];
|
|
% unsigned long MR_stats_diff[MR_NUM_INFO_STATS];
|
|
% ").
|
|
%
|
|
% :- pred gather_poly_info_read_stats(int::in,
|
|
% poly_info::in, poly_info::out) is det.
|
|
%
|
|
% :- pragma foreign_proc("C",
|
|
% gather_poly_info_read_stats(N::in, PI0::in, PI::out),
|
|
% [will_not_call_mercury, promise_pure],
|
|
% "
|
|
% ++MR_stats_read[N];
|
|
% PI = PI0;
|
|
% ").
|
|
%
|
|
% :- pred gather_poly_info_write_stats(int::in, T::in, T::in,
|
|
% poly_info::in, poly_info::out) is det.
|
|
%
|
|
% :- pragma foreign_proc("C",
|
|
% gather_poly_info_write_stats(N::in, Old::in, New::in,
|
|
% PI0::in, PI::out),
|
|
% [will_not_call_mercury, promise_pure],
|
|
% "
|
|
% if (((MR_Unsigned) Old) == ((MR_Unsigned) New)) {
|
|
% ++MR_stats_same[N];
|
|
% } else {
|
|
% ++MR_stats_diff[N];
|
|
% }
|
|
%
|
|
% PI = PI0;
|
|
% ").
|
|
%
|
|
% :- pred gather_poly_info_write_stats_2(int::in, T::in, T::in, U::in, U::in,
|
|
% poly_info::in, poly_info::out) is det.
|
|
%
|
|
% :- pragma foreign_proc("C",
|
|
% gather_poly_info_write_stats_2(N::in, OldA::in, NewA::in,
|
|
% OldB::in, NewB::in, PI0::in, PI::out),
|
|
% [will_not_call_mercury, promise_pure],
|
|
% "
|
|
% if ((((MR_Unsigned) OldA) == ((MR_Unsigned) NewA)) &&
|
|
% (((MR_Unsigned) OldB) == ((MR_Unsigned) NewB)))
|
|
% {
|
|
% ++MR_stats_same[N];
|
|
% } else {
|
|
% ++MR_stats_diff[N];
|
|
% }
|
|
%
|
|
% PI = PI0;
|
|
% ").
|
|
%
|
|
% :- pred gather_poly_info_write_stats_3(int::in, T::in, T::in, U::in, U::in,
|
|
% V::in, V::in, poly_info::in, poly_info::out) is det.
|
|
%
|
|
% :- pragma foreign_proc("C",
|
|
% gather_poly_info_write_stats_3(N::in, OldA::in, NewA::in,
|
|
% OldB::in, NewB::in, OldC::in, NewC::in, PI0::in, PI::out),
|
|
% [will_not_call_mercury, promise_pure],
|
|
% "
|
|
% if ((((MR_Unsigned) OldA) == ((MR_Unsigned) NewA)) &&
|
|
% (((MR_Unsigned) OldB) == ((MR_Unsigned) NewB)) &&
|
|
% (((MR_Unsigned) OldC) == ((MR_Unsigned) NewC)))
|
|
% {
|
|
% ++MR_stats_same[N];
|
|
% } else {
|
|
% ++MR_stats_diff[N];
|
|
% }
|
|
%
|
|
% PI = PI0;
|
|
% ").
|
|
%
|
|
% :- interface.
|
|
% :- import_module io.
|
|
% :- pred write_poly_info_stats(io::di, io::uo) is det.
|
|
% :- implementation.
|
|
%
|
|
% :- pragma foreign_proc("C",
|
|
% write_poly_info_stats(IO0::di, IO::uo),
|
|
% [will_not_call_mercury, promise_pure],
|
|
% "
|
|
% FILE *fp;
|
|
%
|
|
% fp = fopen(""/tmp/POLY_INFO_STATS"", ""a"");
|
|
% if (fp != NULL) {
|
|
% int i;
|
|
% for (i = 0; i < MR_NUM_INFO_STATS; i++) {
|
|
% fprintf(fp, ""stat_rsd %d %lu %lu %lu\\n"",
|
|
% i, MR_stats_read[i], MR_stats_same[i], MR_stats_diff[i]);
|
|
% }
|
|
% }
|
|
%
|
|
% IO = IO0;
|
|
% ").
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
get_cache_maps_snapshot(Name, CacheMaps, !Info) :-
|
|
poly_info_get_type_info_var_map(!.Info, TypeInfoVarMap),
|
|
poly_info_get_typeclass_info_map(!.Info, TypeClassInfoMap),
|
|
poly_info_get_int_const_map(!.Info, IntConstMap),
|
|
poly_info_get_const_struct_var_map(!.Info, ConstStructVarMap),
|
|
|
|
SnapshotNum = !.Info ^ poly_snapshot_num,
|
|
CacheMaps = cache_maps(SnapshotNum, TypeInfoVarMap, TypeClassInfoMap,
|
|
IntConstMap, ConstStructVarMap),
|
|
!Info ^ poly_snapshot_num := SnapshotNum + 1,
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
get_selected_pred(SelectedPred, !IO),
|
|
get_indent_level(Level, !IO),
|
|
( if
|
|
SelectedPred = is_selected_pred,
|
|
Name \= ""
|
|
then
|
|
poly_info_get_debug_stream(!.Info, Stream, !IO),
|
|
IndentStr = string.duplicate_char(' ', Level * 4),
|
|
poly_info_get_var_table(!.Info, VarTable),
|
|
var_table_count(VarTable, NumVars),
|
|
io.format(Stream, "%sget_cache_maps_snapshot %d %s\n",
|
|
[s(IndentStr), i(SnapshotNum), s(Name)], !IO),
|
|
io.format(Stream, "%snum_allocated vars: %d\n\n",
|
|
[s(IndentStr), i(NumVars)], !IO)
|
|
else
|
|
true
|
|
)
|
|
).
|
|
|
|
set_cache_maps_snapshot(Name, CacheMaps, !Info) :-
|
|
CacheMaps = cache_maps(SnapshotNum, TypeInfoVarMap, TypeClassInfoMap,
|
|
IntConstMap, ConstStructVarMap),
|
|
( if
|
|
private_builtin.pointer_equal(TypeInfoVarMap,
|
|
!.Info ^ poly_type_info_var_map),
|
|
private_builtin.pointer_equal(TypeClassInfoMap,
|
|
!.Info ^ poly_typeclass_info_map),
|
|
private_builtin.pointer_equal(IntConstMap,
|
|
!.Info ^ poly_int_const_map),
|
|
private_builtin.pointer_equal(ConstStructVarMap,
|
|
!.Info ^ poly_const_struct_var_map)
|
|
then
|
|
true
|
|
else
|
|
!:Info = ((((!.Info
|
|
^ poly_type_info_var_map := TypeInfoVarMap)
|
|
^ poly_typeclass_info_map := TypeClassInfoMap)
|
|
^ poly_int_const_map := IntConstMap)
|
|
^ poly_const_struct_var_map := ConstStructVarMap)
|
|
),
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
get_selected_pred(SelectedPred, !IO),
|
|
get_indent_level(Level, !IO),
|
|
( if
|
|
SelectedPred = is_selected_pred,
|
|
Name \= ""
|
|
then
|
|
poly_info_get_debug_stream(!.Info, Stream, !IO),
|
|
IndentStr = string.duplicate_char(' ', Level * 4),
|
|
poly_info_get_var_table(!.Info, VarTable),
|
|
var_table_count(VarTable, NumVars),
|
|
|
|
io.format(Stream, "%sset_cache_maps_snapshot %d %s\n",
|
|
[s(IndentStr), i(SnapshotNum), s(Name)], !IO),
|
|
io.format(Stream, "%snum_allocated vars: %d\n\n",
|
|
[s(IndentStr), i(NumVars)], !IO),
|
|
|
|
io.format(Stream, "%stype_info_var_map ", [s(IndentStr)], !IO),
|
|
io.write_line(Stream, CacheMaps ^ cm_type_info_var_map, !IO),
|
|
io.format(Stream, "%stypeclass_info_map ",
|
|
[s(IndentStr)], !IO),
|
|
io.write_line(Stream, CacheMaps ^ cm_typeclass_info_map, !IO),
|
|
io.format(Stream, "%sstruct_var_map ", [s(IndentStr)], !IO),
|
|
io.write_line(Stream,
|
|
CacheMaps ^ cm_const_struct_var_map, !IO),
|
|
io.nl(Stream, !IO)
|
|
else
|
|
true
|
|
)
|
|
).
|
|
|
|
empty_cache_maps(!Info) :-
|
|
poly_info_set_type_info_var_map(map.init, !Info),
|
|
poly_info_set_typeclass_info_map(map.init, !Info),
|
|
poly_info_set_int_const_map(map.init, !Info),
|
|
poly_info_set_const_struct_var_map(map.init, !Info).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
get_var_maps_snapshot(Name, VarMaps, !Info) :-
|
|
SnapshotNum = !.Info ^ poly_snapshot_num,
|
|
poly_info_get_var_table(!.Info, VarTable),
|
|
poly_info_get_rtti_varmaps(!.Info, RttiVarMaps),
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
get_selected_pred(SelectedPred, !IO),
|
|
get_indent_level(Level, !IO),
|
|
(
|
|
SelectedPred = is_not_selected_pred
|
|
;
|
|
SelectedPred = is_selected_pred,
|
|
poly_info_get_debug_stream(!.Info, Stream, !IO),
|
|
IndentStr = string.duplicate_char(' ', Level * 4),
|
|
var_table_count(VarTable, NumVars),
|
|
io.format(Stream, "%sget_var_maps_snapshot %d %s\n",
|
|
[s(IndentStr), i(SnapshotNum), s(Name)], !IO),
|
|
io.format(Stream, "%snum_allocated vars: %d\n\n",
|
|
[s(IndentStr), i(NumVars)], !IO)
|
|
)
|
|
),
|
|
|
|
get_cache_maps_snapshot("", CacheMaps, !Info),
|
|
VarMaps = var_maps(SnapshotNum, VarTable, RttiVarMaps, CacheMaps).
|
|
|
|
set_var_maps_snapshot(Name, VarMaps, !Info) :-
|
|
VarMaps = var_maps(SnapshotNum, VarTable, RttiVarMaps, CacheMaps),
|
|
|
|
trace [compiletime(flag("debug_poly_caches")), io(!IO)] (
|
|
get_selected_pred(SelectedPred, !IO),
|
|
get_indent_level(Level, !IO),
|
|
(
|
|
SelectedPred = is_not_selected_pred
|
|
;
|
|
SelectedPred = is_selected_pred,
|
|
poly_info_get_debug_stream(!.Info, Stream, !IO),
|
|
IndentStr = string.duplicate_char(' ', Level * 4),
|
|
io.format(Stream, "%sset_var_maps_snapshot %d %s\n",
|
|
[s(IndentStr), i(SnapshotNum), s(Name)], !IO),
|
|
|
|
io.format(Stream, "%stype_info_var_map ",
|
|
[s(IndentStr)], !IO),
|
|
io.write_line(Stream, CacheMaps ^ cm_type_info_var_map, !IO),
|
|
io.format(Stream, "%stypeclass_info_map ",
|
|
[s(IndentStr)], !IO),
|
|
io.write_line(Stream, CacheMaps ^ cm_typeclass_info_map, !IO),
|
|
io.format(Stream, "%sstruct_var_map ", [s(IndentStr)], !IO),
|
|
io.write_line(Stream,
|
|
CacheMaps ^ cm_const_struct_var_map, !IO),
|
|
io.nl(Stream, !IO)
|
|
)
|
|
),
|
|
|
|
poly_info_set_var_table_rtti(VarTable, RttiVarMaps, !Info),
|
|
set_cache_maps_snapshot("", CacheMaps, !Info).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
get_poly_const(IntConst, IntVar, Goals, !Info) :-
|
|
poly_info_get_int_const_map(!.Info, IntConstMap0),
|
|
( if map.search(IntConstMap0, IntConst, IntVarPrime) then
|
|
poly_info_get_num_reuses(!.Info, NumReuses),
|
|
poly_info_set_num_reuses(NumReuses + 1, !Info),
|
|
IntVar = IntVarPrime,
|
|
Goals = []
|
|
else
|
|
Name = "PolyConst" ++ string.int_to_string(IntConst),
|
|
poly_info_get_var_table(!.Info, VarTable0),
|
|
make_int_const_construction_alloc(IntConst, Name, Goal, IntVar,
|
|
VarTable0, VarTable),
|
|
poly_info_set_var_table(VarTable, !Info),
|
|
map.det_insert(IntConst, IntVar, IntConstMap0, IntConstMap),
|
|
poly_info_set_int_const_map(IntConstMap, !Info),
|
|
Goals = [Goal]
|
|
).
|
|
|
|
all_are_const_struct_args([], []).
|
|
all_are_const_struct_args([VarMCA | VarsMCAs], [ConstArg | ConstArgs]) :-
|
|
VarMCA = _Var - MCA,
|
|
MCA = yes(ConstArg),
|
|
all_are_const_struct_args(VarsMCAs, ConstArgs).
|
|
|
|
get_inst_of_const_struct_arg(ConstStructDb, ConstArg, Inst) :-
|
|
(
|
|
ConstArg = csa_constant(ConsId, _),
|
|
Inst = bound(shared, inst_test_results_fgtc,
|
|
[bound_functor(ConsId, [])])
|
|
;
|
|
ConstArg = csa_const_struct(StructNum),
|
|
lookup_const_struct_num(ConstStructDb, StructNum, Struct),
|
|
Struct = const_struct(_, _, _, Inst, _)
|
|
).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
|
|
:- mutable(selected_pred, maybe_selected_pred, is_not_selected_pred, ground,
|
|
[untrailed, attach_to_io_state]).
|
|
:- mutable(indent_level, int, 0, ground,
|
|
[untrailed, attach_to_io_state]).
|
|
|
|
poly_info_get_selected_pred(Selected, !IO) :-
|
|
get_selected_pred(Selected, !IO).
|
|
|
|
poly_info_set_selected_pred(Selected, !IO) :-
|
|
set_selected_pred(Selected, !IO).
|
|
|
|
poly_info_get_indent_level(Level, !IO) :-
|
|
get_indent_level(Level, !IO).
|
|
|
|
poly_info_set_indent_level(Level, !IO) :-
|
|
set_indent_level(Level, !IO).
|
|
|
|
poly_info_get_debug_stream(PolyInfo, Stream, !IO) :-
|
|
poly_info_get_module_info(PolyInfo, ModuleInfo),
|
|
module_info_get_globals(ModuleInfo, Globals),
|
|
module_info_get_name(ModuleInfo, ModuleName),
|
|
get_debug_output_stream(Globals, ModuleName, Stream, !IO).
|
|
|
|
%---------------------------------------------------------------------------%
|
|
:- end_module check_hlds.polymorphism_info.
|
|
%---------------------------------------------------------------------------%
|