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