For review: declarative debugging back end (1/3)
Mark Anthony BROWN
dougl at cs.mu.OZ.AU
Tue Jul 14 20:03:55 AEST 1998
Hi,
Fergus, could you review this please? Zoltan, I would also appreciate
your comments.
Estimated hours taken: 650
Add support for declarative debugging (of wrong answers) to the
compiler. When the option --generate-evaluation-tree is set, the
module is compiled with extra procedures added that generate
evaluation dependence trees. These form the back end of a
declarative debugger.
Added files:
compiler/evaluation_tree_gen:
Implements the compiler stage that adds the code to generate
evaluation trees (stage 23).
compiler/proof_tree:
An HLDS transformation to make code generate proof trees from
successful computations.
compiler/evaluation_tree_util:
Data structures and predicates to support the new stage.
library/evaluation_tree:
Contains declarations needed by the transformed module. Any
module compiled with --generate-evaluation-tree will have
this file imported automatically.
Modified files:
compiler/hlds_data:
Added make_constructor_cons_id/2. This makes a cons_id from
a constructor, retaining the constructor's module qualification.
compiler/make_hlds:
Added add_new_exported_type/8. This adds a new type to the
module and performs semantic analysis on the special preds.
compiler/mercury_compile:
If --generate-evaluation-tree is set, then calculate goal paths
and then call evaluation_tree_gen, in stage 23 <fnord>.
compiler/modules:
Add extra imported modules to modules being compiled with
--generate-evaluation-tree.
Write out some extra declarations in the interface and short
interface files.
compiler/options:
Added the option --generate-evaluation-tree, of type bool.
compiler/typecheck:
Moved typecheck_pred_type/7 into the interface.
library/library:
Added evaluation_tree to the list of imports.
-Mark
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.25
diff -u -t -r1.25 hlds_data.m
--- hlds_data.m 1998/07/08 20:56:10 1.25
+++ hlds_data.m 1998/07/13 05:00:24
@@ -93,6 +93,9 @@
:- pred make_cons_id(sym_name, list(constructor_arg), type_id, cons_id).
:- mode make_cons_id(in, in, in, out) is det.
+:- pred make_constructor_cons_id(constructor, cons_id).
+:- mode make_constructor_cons_id(in, out) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
@@ -149,6 +152,11 @@
)
),
list__length(Args, Arity).
+
+make_constructor_cons_id(Ctor, ConsId) :-
+ Ctor = ctor(_, _, SymName, ConsArgs),
+ list__length(ConsArgs, Arity),
+ ConsId = cons(SymName, Arity).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.269
diff -u -t -r1.269 make_hlds.m
--- make_hlds.m 1998/07/08 20:56:38 1.269
+++ make_hlds.m 1998/07/12 07:03:53
@@ -46,6 +46,14 @@
term__context, args_method, pred_info, proc_id).
:- mode add_new_proc(in, in, in, in, in, in, in, in, out, out) is det.
+ %
+ % Add a new exported type to an existing HLDS structure. This
+ % is used by evaluation_tree_gen.
+ %
+:- pred add_new_exported_type(module_info, tvarset, type_defn, condition,
+ term__context, module_info, io__state, io__state).
+:- mode add_new_exported_type(in, in, in, in, in, out, di, uo) is det.
+
:- pred clauses_info_init(int::in, clauses_info::out) is det.
:- pred next_mode_id(proc_table, maybe(determinism), proc_id).
@@ -62,6 +70,8 @@
:- import_module code_util, unify_proc, special_pred, type_util, mode_util.
:- import_module mercury_to_mercury, passes_aux, clause_to_proc, inst_match.
:- import_module fact_table, purity, goal_util, term_util, export, llds.
+:- import_module typecheck, post_typecheck, modes, mode_info.
+:- import_module switch_detection, det_analysis.
:- import_module string, char, int, set, bintree, map, multi_map, require.
:- import_module getopt, assoc_list, term_io, varset.
@@ -896,6 +906,67 @@
mode_name_args(eqv_mode(Name, Args, Body), Name, Args, eqv_mode(Body)).
%-----------------------------------------------------------------------------%
+
+add_new_exported_type(Module0, TVarSet, TypeDefn, Cond, Context, Module) -->
+ module_add_type_defn(Module0, TVarSet, TypeDefn, Cond, Context,
+ item_status(exported, must_be_qualified), Module1),
+
+ globals__io_get_globals(Globals),
+ { convert_type_defn(TypeDefn, Globals, Name, Args, _Body) },
+ { list__length(Args, Arity) },
+ { TypeId = Name - Arity },
+ { special_pred_list(SpecialPreds) },
+ update_special_preds(Module1, SpecialPreds, TypeId, Module).
+
+
+:- pred update_special_preds(module_info, list(special_pred_id), type_id,
+ module_info, io__state, io__state).
+:- mode update_special_preds(in, in, in, out, di, uo) is det.
+
+update_special_preds(Module, [], _, Module) -->
+ [].
+update_special_preds(Module0, [SpecialPred | SpecialPreds], TypeId, Module) -->
+ { module_info_get_special_pred_map(Module0, SpecialPredMap) },
+ { map__lookup(SpecialPredMap, SpecialPred - TypeId, PredId) },
+ { module_info_preds(Module0, Preds0) },
+ { map__lookup(Preds0, PredId, PredInfo0) },
+ typecheck_pred_type(PredId, PredInfo0, Module0, MaybePredInfo,
+ _Changed),
+ { MaybePredInfo = yes(PredInfo1) ->
+ PredInfo2 = PredInfo1
+ ;
+ error("add_new_exported_type: typecheck failed")
+ },
+ post_typecheck__finish_pred(Module0, PredId, PredInfo2, PredInfo3),
+ { map__det_update(Preds0, PredId, PredInfo3, Preds) },
+ { module_info_get_predicate_table(Module0, PredTable0) },
+ { predicate_table_set_preds(PredTable0, Preds, PredTable) },
+ { module_info_set_predicate_table(Module0, PredTable, Module1) },
+
+ modecheck_pred_mode(PredId, PredInfo3, check_modes, Module1,
+ Module2, _),
+ globals__io_get_globals(Globals),
+ { module_info_pred_info(Module2, PredId, PredInfo4) },
+ { pred_info_procedures(PredInfo4, ProcTable) },
+ { map__keys(ProcTable, ProcIds) },
+ { update_special_procs(Module2, PredId, ProcIds, Globals, Module3) },
+ { module_info_pred_info(Module3, PredId, PredInfo5) },
+ modecheck_pred_mode(PredId, PredInfo5,
+ check_unique_modes(may_change_called_proc),
+ Module3, Module4, _),
+ update_special_preds(Module4, SpecialPreds, TypeId, Module).
+
+
+:- pred update_special_procs(module_info, pred_id, list(proc_id), globals,
+ module_info).
+:- mode update_special_procs(in, in, in, in, out) is det.
+
+update_special_procs(Module, _PredId, [], _Globals, Module).
+update_special_procs(Module0, PredId, [ProcId | ProcIds], Globals, Module) :-
+ detect_switches_in_proc(ProcId, PredId, Module0, Module1),
+ det_infer_proc(PredId, ProcId, Module1, Module2, Globals, _, _, _),
+ update_special_procs(Module2, PredId, ProcIds, Globals, Module).
+
% We allow more than one "definition" for a given type so
% long all of them except one are actually just declarations,
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_compile.m,v
retrieving revision 1.102
diff -u -t -r1.102 mercury_compile.m
--- mercury_compile.m 1998/07/03 02:34:17 1.102
+++ mercury_compile.m 1998/07/04 15:17:07
@@ -35,9 +35,9 @@
:- import_module stratify, check_typeclass, simplify, intermod, trans_opt.
:- import_module table_gen.
:- import_module bytecode_gen, bytecode.
-:- import_module (lambda), polymorphism, termination, higher_order, inlining.
-:- import_module deforest, dnf, constraint, unused_args, dead_proc_elim.
-:- import_module lco, saved_vars, liveness.
+:- import_module evaluation_tree_gen, (lambda), polymorphism, termination.
+:- import_module higher_order, inlining, deforest, dnf, constraint.
+:- import_module unused_args, dead_proc_elim, saved_vars, lco, liveness.
:- import_module follow_code, live_vars, arg_info, store_alloc, goal_path.
:- import_module code_gen, optimize, export, base_type_info, base_type_layout.
:- import_module llds_common, llds_out, continuation_info, stack_layout.
@@ -888,11 +888,14 @@
% :- mode mercury_compile__middle_pass(in, di, uo, di, uo) is det.
:- mode mercury_compile__middle_pass(in, in, out, di, uo) is det.
-mercury_compile__middle_pass(ModuleName, HLDS24, HLDS50) -->
+mercury_compile__middle_pass(ModuleName, HLDS20, HLDS50) -->
globals__io_lookup_bool_option(verbose, Verbose),
globals__io_lookup_bool_option(statistics, Stats),
- mercury_compile__tabling(HLDS24, Verbose, HLDS25),
+ mercury_compile__maybe_evaluation_tree(HLDS20, Verbose, Stats, HLDS23),
+ mercury_compile__maybe_dump_hlds(HLDS23, "23", "evaluation_tree"),
+
+ mercury_compile__tabling(HLDS23, Verbose, HLDS25),
mercury_compile__maybe_dump_hlds(HLDS25, "25", "tabling"), !,
mercury_compile__maybe_polymorphism(HLDS25, Verbose, Stats, HLDS26),
@@ -1445,6 +1448,32 @@
%-----------------------------------------------------------------------------%
+:- pred mercury_compile__maybe_evaluation_tree(module_info, bool, bool,
+ module_info, io__state, io__state).
+:- mode mercury_compile__maybe_evaluation_tree(in, in, in, out, di, uo) is det.
+
+mercury_compile__maybe_evaluation_tree(HLDS0, Verbose, Stats, HLDS) -->
+ globals__io_lookup_bool_option(generate_evaluation_tree, GenEDT),
+ (
+ { GenEDT = yes }
+ ->
+ maybe_write_string(Verbose, "% Calculating goal paths..."),
+ maybe_flush_output(Verbose),
+ process_all_nonimported_procs(
+ update_proc(goal_path__fill_slots),
+ HLDS0, HLDS1),
+ maybe_write_string(Verbose, " done.\n"),
+
+ maybe_write_string(Verbose,
+ "% Transforming to generate evaluation trees..."),
+ maybe_flush_output(Verbose),
+ evaluation_tree_gen__process_module(HLDS1, HLDS),
+ maybe_write_string(Verbose, " done.\n"),
+ maybe_report_stats(Stats)
+ ;
+ { HLDS = HLDS0 }
+ ).
+
:- pred mercury_compile__tabling(module_info, bool,
module_info, io__state, io__state).
:- mode mercury_compile__tabling(in, in, out, di, uo) is det.
@@ -1455,8 +1484,6 @@
maybe_flush_output(Verbose),
{ table_gen__process_module(HLDS0, HLDS) },
maybe_write_string(Verbose, " done.\n").
-
-%-----------------------------------------------------------------------------%
:- pred mercury_compile__maybe_polymorphism(module_info, bool, bool,
module_info, io__state, io__state).
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.82
diff -u -t -r1.82 modules.m
--- modules.m 1998/07/09 22:03:09 1.82
+++ modules.m 1998/07/12 07:03:57
@@ -469,6 +469,7 @@
:- implementation.
:- import_module llds_out, passes_aux, prog_out, prog_util, mercury_to_mercury.
:- import_module prog_io_util, globals, options, intermod, module_qual.
+:- import_module evaluation_tree_gen.
:- import_module string, set, map, term, varset, dir, library.
:- import_module assoc_list, relation, char, require.
@@ -701,15 +702,18 @@
;
%
% Strip out the imported interfaces,
- % check for some warnings, and then
- % write out the `.int' and `int2' files
- % and touch the `.date' file.
+ % check for some warnings, maybe add the
+ % evaluation tree interface and then write out
+ % the `.int' and `int2' files and touch the
+ % `.date' file.
%
{ strip_imported_items(InterfaceItems2, [],
InterfaceItems3) },
check_for_clauses_in_interface(InterfaceItems3,
- InterfaceItems),
- check_for_no_exports(InterfaceItems, ModuleName),
+ InterfaceItems4),
+ check_for_no_exports(InterfaceItems4, ModuleName),
+ maybe_add_evaluation_tree_interface(ModuleName,
+ InterfaceItems4, InterfaceItems),
write_interface_file(ModuleName, ".int",
InterfaceItems),
{ get_short_interface(InterfaceItems,
@@ -727,7 +731,9 @@
check_for_clauses_in_interface(InterfaceItems0, InterfaceItems),
{ get_short_interface(InterfaceItems, ShortInterfaceItems0) },
module_qual__module_qualify_items(ShortInterfaceItems0,
- ShortInterfaceItems, ModuleName, no, _, _, _, _),
+ ShortInterfaceItems1, ModuleName, no, _, _, _, _),
+ maybe_add_evaluation_tree_short_interface(ModuleName,
+ ShortInterfaceItems1, ShortInterfaceItems),
write_interface_file(ModuleName, ".int3", ShortInterfaceItems),
touch_interface_datestamp(ModuleName, ".date3").
@@ -896,6 +902,34 @@
[]
).
+:- pred maybe_add_evaluation_tree_interface(module_name, item_list, item_list,
+ io__state, io__state).
+:- mode maybe_add_evaluation_tree_interface(in, in, out, di, uo) is det.
+
+maybe_add_evaluation_tree_interface(ModuleName, Items0, Items) -->
+ globals__io_lookup_bool_option(generate_evaluation_tree, GenEDT),
+ { GenEDT = yes ->
+ evaluation_tree_gen__get_interface_items(ModuleName, NewItems),
+ list__append(Items0, NewItems, Items)
+ ;
+ Items = Items0
+ }.
+
+:- pred maybe_add_evaluation_tree_short_interface(module_name, item_list,
+ item_list, io__state, io__state).
+:- mode maybe_add_evaluation_tree_short_interface(in, in, out, di, uo) is det.
+
+maybe_add_evaluation_tree_short_interface(ModuleName, Items0, Items) -->
+ globals__io_lookup_bool_option(generate_evaluation_tree, GenEDT),
+ { GenEDT = yes ->
+ evaluation_tree_gen__get_short_interface_items(ModuleName,
+ NewItems),
+ list__append(Items0, NewItems, Items)
+ ;
+ Items = Items0
+ }.
+
+
%-----------------------------------------------------------------------------%
:- pred write_interface_file(module_name, string, item_list, io__state, io__state).
@@ -1010,9 +1044,15 @@
{ add_implicit_imports(ImportedModules1, UsedModules1,
ImportedModules2, UsedModules2) },
+ % Add `evaluation_tree', `std_util' and `list' to the
+ % list of imported modules if --generate-evaluation-tree
+ % is set and they are not already there.
+ maybe_add_evaluation_tree_imports(ImportedModules2, UsedModules2,
+ UsedModules3),
+
% Process the ancestor modules
process_module_private_interfaces(AncestorModules,
- ImportedModules2, ImportedModules, UsedModules2, UsedModules,
+ ImportedModules2, ImportedModules, UsedModules3, UsedModules,
Module2, Module3),
% Process the modules imported using `import_module'.
@@ -1156,6 +1196,26 @@
;
UseDeps = [MercuryPrivateBuiltin | UseDeps0]
).
+
+:- pred maybe_add_evaluation_tree_imports(list(module_name), list(module_name),
+ list(module_name), io__state, io__state).
+:- mode maybe_add_evaluation_tree_imports(in, in, out, di, uo) is det.
+
+maybe_add_evaluation_tree_imports(Imported, Modules0, Modules) -->
+ globals__io_lookup_bool_option(generate_evaluation_tree, GenEDT),
+ {
+ GenEDT = yes
+ ->
+ evaluation_tree_gen__import_modules(NewModules0),
+ %
+ % Don't import any modules we already have.
+ %
+ list__delete_elems(NewModules0, Modules0, NewModules1),
+ list__delete_elems(NewModules1, Imported, NewModules),
+ list__append(NewModules, Modules0, Modules)
+ ;
+ Modules = Modules0
+ }.
:- pred warn_if_import_self_or_ancestor(module_name, list(module_name),
list(module_name), list(module_name),
Index: compiler/options.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/options.m,v
retrieving revision 1.235
diff -u -t -r1.235 options.m
--- options.m 1998/07/01 06:08:27 1.235
+++ options.m 1998/07/04 14:14:34
@@ -89,6 +89,7 @@
% Auxiliary output options
; assume_gmake
; trace
+ ; generate_evaluation_tree
; generate_bytecode
; generate_prolog
; prolog_dialect
@@ -369,6 +370,7 @@
% Auxiliary Output Options
assume_gmake - bool(yes),
trace - string("default"),
+ generate_evaluation_tree - bool(no),
generate_bytecode - bool(no),
generate_prolog - bool(no),
prolog_dialect - string("default"),
@@ -694,6 +696,7 @@
% aux output options
long_option("assume-gmake", assume_gmake).
long_option("trace", trace).
+long_option("generate-evaluation-tree", generate_evaluation_tree).
long_option("generate-bytecode", generate_bytecode).
long_option("generate-prolog", generate_prolog).
long_option("generate-Prolog", generate_prolog).
@@ -1013,6 +1016,7 @@
N = N0
),
set_opt_level(N, OptionTable0, OptionTable).
:- pred set_opt_level(int, option_table, option_table).
:- mode set_opt_level(in, in, out) is det.
@@ -1358,6 +1362,10 @@
io__write_string("\t\tof execution tracing.\n"),
io__write_string("\t\tSee the [XXX not yet written!] chapter of the\n"),
io__write_string("\t\tMercury User's Guide for details.\n"),
+ io__write_string("\t--generate-evaluation-tree\n"),
+ io__write_string("\t\tInclude code to generate evaluation trees in the\n"),
+ io__write_string("\t\tC code output by the compiler. These can be analysed\n"),
+ io__write_string("\t\tby a declarative debugger.\n"),
io__write_string("\t--generate-bytecode\n"),
io__write_string("\t\tOutput a bytecode form of the module for use\n"),
io__write_string("\t\tby an experimental debugger.\n"),
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.244
diff -u -t -r1.244 typecheck.m
--- typecheck.m 1998/07/13 16:26:43 1.244
+++ typecheck.m 1998/07/14 06:25:03
@@ -103,7 +103,7 @@
:- interface.
:- import_module hlds_module, hlds_pred, hlds_data, prog_data.
-:- import_module bool, io, list, map, term.
+:- import_module bool, io, list, map, term, std_util.
:- pred typecheck(module_info, module_info, bool, io__state, io__state).
:- mode typecheck(in, out, out, di, uo) is det.
@@ -154,6 +154,10 @@
:- mode typecheck__reduce_context_by_rule_application(in, in, in, in, in, out,
in, out, in, out) is det.
+:- pred typecheck_pred_type(pred_id, pred_info, module_info,
+ maybe(pred_info), bool, io__state, io__state).
+:- mode typecheck_pred_type(in, in, in, out, out, di, uo) is det.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -164,8 +168,8 @@
:- import_module mercury_to_mercury, mode_util, options, getopt, globals.
:- import_module passes_aux, clause_to_proc, special_pred, inst_match.
-:- import_module int, set, string, require, std_util, tree234, multi_map.
-:- import_module assoc_list, varset, term_io.
+:- import_module int, set, string, require, tree234, multi_map, assoc_list.
+:- import_module varset, term_io.
%-----------------------------------------------------------------------------%
@@ -284,10 +288,6 @@
),
typecheck_pred_types_2(PredIds, ModuleInfo1, ModuleInfo,
Error1, Error, Changed2, Changed).
-
-:- pred typecheck_pred_type(pred_id, pred_info, module_info,
- maybe(pred_info), bool, io__state, io__state).
-:- mode typecheck_pred_type(in, in, in, out, out, di, uo) is det.
typecheck_pred_type(PredId, PredInfo0, ModuleInfo, MaybePredInfo, Changed,
IOState0, IOState) :-
Index: library/library.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/library.m,v
retrieving revision 1.41
diff -u -t -r1.41 library.m
--- library.m 1998/04/15 06:48:17 1.41
+++ library.m 1998/07/02 12:51:23
@@ -32,7 +32,7 @@
:- import_module std_util, string, term, term_io, tree234, varset.
:- import_module store, rbtree, parser, lexer, ops.
:- import_module prolog.
-:- import_module debugger_interface.
+:- import_module debugger_interface, evaluation_tree.
:- import_module integer, rational.
% library__version must be implemented using pragma c_code,
===================================================================
%-----------------------------------------------------------------------------%
% Copyright (C) 1998 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
% File: evaluation_tree_gen.m
% Author: dougl
% Purpose:
% This module implements a compiler pass that adds code to
% generate Mercury Evaluation Dependence Trees (EDTs) to the
% module being compiled. The module so compiled can be used as
% the back end of a declarative debugger (see comments in
% library/evaluation_tree.m), or it can be linked to other
% modules in the usual way.
%
% This module does two passes of the HLDS. The first collects all
% the required information, adds stubs for the new procedures, and
% decides how atoms from the compilee will be represented. The
% second creates the bodies of the new procedures.
%
% For wrong answer analysis, the EDT required is a proof tree.
% This module calls proof_tree.m to obtain the new procedures by
% HLDS transformation of the originals.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- module evaluation_tree_gen.
:- interface.
:- import_module hlds_module, prog_data.
:- import_module io, list.
%
% Perform the transformation on an entire module. This is used
% in the middle pass of mercury_compile.
%
:- pred evaluation_tree_gen__process_module(module_info, module_info,
io__state, io__state).
:- mode evaluation_tree_gen__process_module(in, out, di, uo) is det.
%
% Create the new interface or short interface items for a module.
% This is used when making the .int, .int2 and .int3 files.
%
:- pred evaluation_tree_gen__get_interface_items(module_name, item_list).
:- mode evaluation_tree_gen__get_interface_items(in, out) is det.
:- pred evaluation_tree_gen__get_short_interface_items(module_name, item_list).
:- mode evaluation_tree_gen__get_short_interface_items(in, out) is det.
%
% The names of modules that must be automatically imported when
% compiling with --generate-evaluation-tree.
%
:- pred evaluation_tree_gen__import_modules(list(module_name)).
:- mode evaluation_tree_gen__import_modules(out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module evaluation_tree_util, hlds_pred, hlds_data, globals, options.
:- import_module code_util, passes_aux, purity, (inst), make_hlds, proof_tree.
:- import_module bool, std_util, term, map, varset, require, int, string.
%
% Module is Module0 with some procedures duplicated by versions
% that produce evaluation_trees, a type added as an instance of
% the evaluation_atom typeclass, and interface procedures to
% satisfy the typeclass constraint.
%
evaluation_tree_gen__process_module(Module0, Module) -->
%
% Miss trees are not implemented yet.
%
{ MissTreeGen = no },
globals__io_lookup_bool_option(very_verbose, VeryVerbose),
%
% The first pass:
% - Decides which procedures are to be transformed.
% - Creates new predicate stubs.
% - Decides on the representation of atoms that
% match that procedure head; creates constructors
% for such atoms.
%
maybe_write_string(VeryVerbose, "\n% Evaluation tree first pass...\n"),
{ evaluation_tree_gen__first_pass(Module0, MissTreeGen, EDTInfo,
Module1) },
%
% Using the constructors just created, we add a new type
% to the module.
%
maybe_write_string(VeryVerbose, "% Adding evaluation_atom type...\n"),
evaluation_tree_gen__make_atom_type(Module1, EDTInfo, Module2),
%
% The second pass, for each new procedure:
% - Transforms the head, adding an argument in
% which the proc creates an evaluation_tree.
% - Transforms the body, making calls go to their
% corresponding evaluation_tree generating
% versions where possible. Constructions are
% added to build the node and evaluation_tree.
%
maybe_write_string(VeryVerbose, "% Creating evaluation_tree generating procedures...\n"),
{ evaluation_tree_gen__create_procs(Module2, EDTInfo, Module3) },
%
% Finally we create the interface to an instance of
% evaluation_atom, and add it to the module.
%
maybe_write_string(VeryVerbose, "% Adding evaluation_atom interface...\n"),
{ evaluation_tree_gen__make_interface_preds(Module3, EDTInfo,
Module) },
maybe_write_edt_info(VeryVerbose, Module, EDTInfo),
maybe_write_string(VeryVerbose, "%").
%-----------------------------------------------------------------------------%
evaluation_tree_gen__get_interface_items(ModuleName, Items) :-
evaluation_tree_gen__get_short_interface_items(ModuleName, Items0),
make_wrong_analysis_pred_decl(ModuleName, PredDecl),
make_wrong_analysis_mode_decl(ModuleName, ModeDecl),
generated_code_context(Context),
Items = [PredDecl - Context, ModeDecl - Context | Items0].
evaluation_tree_gen__get_short_interface_items(ModuleName, Items) :-
make_evaluation_atom_type_decl(ModuleName, TypeDecl),
generated_code_context(Context),
Items = [TypeDecl - Context].
:- pred make_wrong_analysis_pred_decl(module_name, item).
:- mode make_wrong_analysis_pred_decl(in, out) is det.
make_wrong_analysis_pred_decl(ModuleName, PredItem) :-
varset__init(VarSet),
wrong_analysis_pred_sym_name(ModuleName, SymName),
local_evaluation_atom_type(ModuleName, NodeType),
local_analysis_type(ModuleName, AnalysisType),
Types = [type_only(NodeType), type_only(AnalysisType)],
ClassConstraints = constraints([], []),
PredItem = pred(VarSet, [], SymName, Types, no, true, pure,
ClassConstraints).
:- pred make_wrong_analysis_mode_decl(module_name, item).
:- mode make_wrong_analysis_mode_decl(in, out) is det.
make_wrong_analysis_mode_decl(ModuleName, ModeItem) :-
varset__init(VarSet),
wrong_analysis_pred_sym_name(ModuleName, SymName),
ground_inst(Ground),
PredModes = [(free -> Ground)],
PredInst = pred_inst_info(predicate, PredModes, nondet),
Inst = ground(shared, yes(PredInst)),
Modes = [(Ground -> Ground), (free -> Inst)],
Detism = semidet,
ModeItem = pred_mode(VarSet, SymName, Modes, yes(Detism), true).
:- pred make_evaluation_atom_type_decl(module_name, item).
:- mode make_evaluation_atom_type_decl(in, out) is det.
make_evaluation_atom_type_decl(ModuleName, TypeItem) :-
varset__init(VarSet),
evaluation_atom_type_name(ModuleName, SymName),
TypeDefn = abstract_type(SymName, []),
TypeItem = type_defn(VarSet, TypeDefn, true).
evaluation_tree_gen__import_modules(Modules) :-
List = unqualified("list"),
StdUtil = unqualified("std_util"),
evaluation_tree_interface_module(EvaluationTree),
Modules = [List, StdUtil, EvaluationTree].
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- pred evaluation_tree_gen__first_pass(module_info, bool, edt_info,
module_info).
:- mode evaluation_tree_gen__first_pass(in, in, out, out) is det.
evaluation_tree_gen__first_pass(Module0, MissTreeGen, EDTInfo, Module) :-
edt_info_init(Module0, EDTInfo0),
%
% Pass through the HLDS, building an edt_info
%
module_info_predids(Module0, PredIds0),
evaluation_tree_gen__first_pass_preds(PredIds0, MissTreeGen, EDTInfo0,
EDTInfo, Module0, Module).
:- pred evaluation_tree_gen__first_pass_preds(list(pred_id), bool, edt_info,
edt_info, module_info, module_info).
:- mode evaluation_tree_gen__first_pass_preds(in, in, in, out, in, out) is det.
evaluation_tree_gen__first_pass_preds([], _, EDTInfo, EDTInfo, Module, Module).
evaluation_tree_gen__first_pass_preds([PredId | PredIds], MissTreeGen,
EDTInfo0, EDTInfo, Module0, Module) :-
(
analysis_is_not_required(Module0, PredId)
->
EDTInfo1 = EDTInfo0,
Module1 = Module0
;
evaluation_tree_gen__first_pass_pred(PredId, MissTreeGen,
EDTInfo0, EDTInfo1, Module0, Module1)
),
evaluation_tree_gen__first_pass_preds(PredIds, MissTreeGen, EDTInfo1,
EDTInfo, Module1, Module).
:- pred analysis_is_not_required(module_info, pred_id).
:- mode analysis_is_not_required(in, in) is semidet.
analysis_is_not_required(Module, PredId) :-
module_info_pred_info(Module, PredId, PredInfo),
(
code_util__compiler_generated(PredInfo)
;
pred_info_is_imported(PredInfo)
).
:- pred evaluation_tree_gen__first_pass_pred(pred_id, bool, edt_info, edt_info,
module_info, module_info).
:- mode evaluation_tree_gen__first_pass_pred(in, in, in, out, in, out) is det.
evaluation_tree_gen__first_pass_pred(PredId, MissTreeGen, EDTInfo0, EDTInfo,
Module0, Module) :-
( MissTreeGen = yes ->
error("evaluation_tree_gen: unsupported feature")
;
MaybeMissTreePred = no
),
%
% Prepare a place for the new predicate. Its body
% will be filled in by create_procs.
%
make_wrong_answer_pred_stub(EDTInfo0, Module0, PredId, NewPredInfo),
module_info_get_predicate_table(Module0, PredTable0),
predicate_table_insert(PredTable0, NewPredInfo, NewPredId, PredTable),
module_info_set_predicate_table(Module0, PredTable, Module1),
module_info_pred_info(Module1, PredId, PredInfo),
pred_info_procids(PredInfo, ProcIds),
evaluation_tree_gen__first_pass_procs(PredInfo, PredId, ProcIds,
NewPredInfo, NewPredId, MaybeMissTreePred, EDTInfo0,
EDTInfo, Module1, Module).
:- pred evaluation_tree_gen__first_pass_procs(pred_info, pred_id,
list(proc_id), pred_info, pred_id,
maybe(pair(pred_info, pred_id)), edt_info, edt_info,
module_info, module_info).
:- mode evaluation_tree_gen__first_pass_procs(in, in, in, in, in, in, in, out,
in, out) is det.
evaluation_tree_gen__first_pass_procs(_, _, [], WrongPredInfo, WrongPredId,
MaybeMissTreePred, EDTInfo, EDTInfo, Module0, Module) :-
(
MaybeMissTreePred = yes(MissPredInfo - MissPredId)
->
module_info_set_pred_info(Module0, MissPredId, MissPredInfo,
Module1)
;
Module1 = Module0
),
module_info_set_pred_info(Module1, WrongPredId, WrongPredInfo, Module).
evaluation_tree_gen__first_pass_procs(PredInfo, PredId, [ProcId | ProcIds],
WrongPredInfo0, WrongPredId, MaybeMissTreePred, EDTInfo0,
EDTInfo, Module0, Module) :-
evaluation_tree_gen__first_pass_proc(PredInfo, PredId, ProcId,
WrongPredInfo0, WrongPredInfo1, WrongPredId,
EDTInfo0, EDTInfo1),
( MaybeMissTreePred = yes(_) ->
error("evaluation_tree_gen: unsupported feature")
;
true
),
evaluation_tree_gen__first_pass_procs(PredInfo, PredId, ProcIds,
WrongPredInfo1, WrongPredId, MaybeMissTreePred,
EDTInfo1, EDTInfo, Module0, Module).
:- pred evaluation_tree_gen__first_pass_proc(pred_info, pred_id, proc_id,
pred_info, pred_info, pred_id, edt_info, edt_info).
:- mode evaluation_tree_gen__first_pass_proc(in, in, in, in, out, in, in, out)
is det.
evaluation_tree_gen__first_pass_proc(PredInfo, PredId, ProcId, WrongPredInfo0,
WrongPredInfo, WrongPredId, EDTInfo0, EDTInfo) :-
pred_info_procedures(PredInfo, Procs),
map__lookup(Procs, ProcId, ProcInfo),
%
% Add a procedure stub to the new predicate. Initially
% we duplicate the original procedure, this is
% transformed later in the pass.
%
% An invariant is that the proc_id of a transformed
% procedure is always the same as the original. This
% allows the alternative versions of procedures to be
% found after mode analysis has been performed on the
% original versions.
%
pred_info_procedures(WrongPredInfo0, WrongProcs0),
map__det_insert(WrongProcs0, ProcId, ProcInfo, WrongProcs),
pred_info_set_procedures(WrongPredInfo0, WrongProcs, WrongPredInfo),
%
% Decide how an atom (that matches this procedure) will be
% represented.
%
proc_info_headvars(ProcInfo, HeadVars),
pred_info_arg_types(PredInfo, _, _, ArgTypes),
make_atom_descriptor(EDTInfo0, HeadVars, ArgTypes, AtomDesc),
%
% Make two constructors, one for the atom in its initial
% inst, the other for its final inst.
%
make_atom_constructors(PredInfo, ProcId, AtomDesc, InitialCtor,
FinalCtor),
edt_info_add_atom_ctor(EDTInfo0, InitialCtor, EDTInfo1),
edt_info_add_atom_ctor(EDTInfo1, FinalCtor, EDTInfo2),
make_constructor_cons_id(InitialCtor, InitialConsId),
make_constructor_cons_id(FinalCtor, FinalConsId),
edt_proc_info_init(WrongPredId, ProcId, InitialConsId, FinalConsId,
AtomDesc, EDTProcInfo),
edt_info_add_proc(EDTInfo2, proc(PredId, ProcId), EDTProcInfo,
EDTInfo).
%-----------------------------------------------------------------------------%
:- pred make_atom_descriptor(edt_info, list(var), list(type), atom_descriptor).
:- mode make_atom_descriptor(in, in, in, out) is det.
make_atom_descriptor(EDTInfo, HeadVars, ArgTypes, AtomDesc) :-
%
% We number off the original head variables, starting
% from 1:
%
make_atom_arg_descriptors(EDTInfo, 1, HeadVars, ArgTypes, AtomDesc).
:- pred make_atom_arg_descriptors(edt_info, int, list(var), list(type),
list(atom_arg_descriptor)).
:- mode make_atom_arg_descriptors(in, in, in, in, out) is det.
make_atom_arg_descriptors(EDTInfo, Count, HeadVars, Types, AtomArgs) :-
(
HeadVars = [],
Types = []
->
AtomArgs = []
;
HeadVars = [HeadVar | HeadVars0],
Types = [Type | Types0]
->
make_atom_arg_descriptors(EDTInfo, Count + 1, HeadVars0,
Types0, AtomArgs0),
make_atom_arg_descriptor(EDTInfo, Count, HeadVar, Type,
AtomArg),
AtomArgs = [AtomArg | AtomArgs0]
;
error("make_atom_arg_descriptors: length mismatch")
).
:- pred make_atom_arg_descriptor(edt_info, int, var, (type),
atom_arg_descriptor).
:- mode make_atom_arg_descriptor(in, in, in, in, out) is det.
make_atom_arg_descriptor(_EDTInfo, HeadVarNum, HeadVar, Type, AtomArg) :-
%
% XXX Here is where we should detect that an io__state
% is being passed and set up something that acts like
% backtrackable destructive update on the io__state.
%
(
term__is_ground(Type)
->
AtomArg = direct_var(HeadVarNum, HeadVar, Type)
;
AtomArg = univ_var(HeadVarNum, HeadVar, Type)
).
:- pred make_atom_constructors(pred_info, proc_id, atom_descriptor,
constructor, constructor).
:- mode make_atom_constructors(in, in, in, out, out) is det.
make_atom_constructors(PredInfo, ProcId, AtomDesc, InitialCtor, FinalCtor) :-
pred_info_module(PredInfo, Module),
pred_info_name(PredInfo, PredName),
proc_id_to_int(ProcId, IntProcId),
string__int_to_string(IntProcId, StringProcId),
string__append_list([PredName, "_", StringProcId], CtorName),
string__append(CtorName, "_initial", InitialCtorName),
string__append(CtorName, "_final", FinalCtorName),
library_type_univ(UnivType),
make_atom_constructor_args(UnivType, AtomDesc, ConsArgs),
make_atom_constructor(Module, InitialCtorName, ConsArgs, InitialCtor),
make_atom_constructor(Module, FinalCtorName, ConsArgs, FinalCtor).
:- pred make_atom_constructor(module_name, string, list(constructor_arg),
constructor).
:- mode make_atom_constructor(in, in, in, out) is det.
make_atom_constructor(Module, CtorName, ConsArgs, Ctor) :-
SymName = qualified(Module, CtorName),
Ctor = ctor([], [], SymName, ConsArgs).
:- pred make_atom_constructor_args((type), atom_descriptor,
list(constructor_arg)).
:- mode make_atom_constructor_args(in, in, out) is det.
make_atom_constructor_args(_, [], []).
make_atom_constructor_args(UnivType, [AtomArg | AtomArgs],
[ConsArg | ConsArgs]) :-
AtomArg = direct_var(_, _, ArgType),
ConsArg = "" - ArgType,
make_atom_constructor_args(UnivType, AtomArgs, ConsArgs).
make_atom_constructor_args(UnivType, [AtomArg | AtomArgs],
[ConsArg | ConsArgs]) :-
AtomArg = univ_var(_, _, _),
ConsArg = "" - UnivType,
make_atom_constructor_args(UnivType, AtomArgs, ConsArgs).
make_atom_constructor_args(UnivType, [AtomArg | AtomArgs], ConsArgs) :-
AtomArg = io_state_di(_, _),
make_atom_constructor_args(UnivType, AtomArgs, ConsArgs).
make_atom_constructor_args(UnivType, [AtomArg | AtomArgs], ConsArgs) :-
AtomArg = io_state_uo(_, _),
make_atom_constructor_args(UnivType, AtomArgs, ConsArgs).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
%
% To add a new type we first build a type_defn, such as would
% appear in the parse tree. This can be added to the HLDS by
% make_hlds:add_new_exported_type.
%
:- pred evaluation_tree_gen__make_atom_type(module_info, edt_info, module_info,
io__state, io__state).
:- mode evaluation_tree_gen__make_atom_type(in, in, out, di, uo) is det.
evaluation_tree_gen__make_atom_type(Module0, EDTInfo, Module) -->
{ make_evaluation_atom_type_defn(EDTInfo, TVarSet, AtomTypeDefn) },
{ generated_code_context(Context) },
add_new_exported_type(Module0, TVarSet, AtomTypeDefn, true, Context,
Module).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- pred evaluation_tree_gen__create_procs(module_info, edt_info, module_info).
:- mode evaluation_tree_gen__create_procs(in, in, out) is det.
evaluation_tree_gen__create_procs(Module0, EDTInfo, Module) :-
edt_info_get_proc_map(EDTInfo, ProcMap),
map__keys(ProcMap, ProcIds),
evaluation_tree_gen__create_procs_1(Module0, ProcIds, EDTInfo, ProcMap,
Module).
:- pred evaluation_tree_gen__create_procs_1(module_info, list(pred_proc_id),
edt_info, map(pred_proc_id, edt_proc_info), module_info).
:- mode evaluation_tree_gen__create_procs_1(in, in, in, in, out) is det.
evaluation_tree_gen__create_procs_1(Module, [], _, _, Module).
evaluation_tree_gen__create_procs_1(Module0, [PredProcId | PredProcIds],
EDTInfo, ProcMap, Module) :-
map__lookup(ProcMap, PredProcId, EDTProcInfo),
proof_tree__create_proc(Module0, EDTInfo, EDTProcInfo, Module1),
(
edt_proc_info_get_miss_proc(EDTProcInfo, _, _)
->
error("evaluation_tree_gen: unsupported feature")
;
true
),
evaluation_tree_gen__create_procs_1(Module1, PredProcIds, EDTInfo,
ProcMap, Module).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- pred evaluation_tree_gen__make_interface_preds(module_info, edt_info,
module_info).
:- mode evaluation_tree_gen__make_interface_preds(in, in, out) is det.
evaluation_tree_gen__make_interface_preds(Module0, EDTInfo, Module) :-
%
% Actually, there is only one interface predicate
% implemented at this stage, so we just make that one.
%
proof_tree__make_wrong_analysis_pred(Module0, EDTInfo, PredInfo),
module_info_get_predicate_table(Module0, PredTable0),
predicate_table_insert(PredTable0, PredInfo, _, PredTable),
module_info_set_predicate_table(Module0, PredTable, Module).
More information about the developers
mailing list