[m-dev.] for review: prelim support for hash consing
Peter Ross
petdr at cs.mu.OZ.AU
Fri Aug 20 14:37:43 AEST 1999
Hi,
This is for Zoltan to review and ask questions about.
===================================================================
Estimated hours taken: 15
Add preliminary support for memoing type constructors (hash consing)
compiler/make_hlds.m:
The core of the change.
For every
:- pragma memo_cons(Constructor/Arity).
Construct a function
hash_cons_C(X1, ..., XN) = C(X1, ..., XN).
where hash_cons_C is a suitably name mangled function.
compiler/hlds_pred.m:
Add a new marker which indicates that the predicate is an
automatically generated predicate which is meant to do a hash consed
construction unification.
compiler/hlds_out.m:
compiler/intermod.m:
Support the memo_cons marker.
compiler/mercury_to_mercury.m:
Handle the pragma memo_cons.
compiler/module_qual.m:
compiler/modules.m:
Handle the new type tabled_cons.
compiler/prog_data.m:
Add type tabled_cons which stores the information declared in the
pragma.
compiler/prog_io_pragma.m:
Parse the memo_cons pragma.
compiler/prog_out.m:
Add a new predicate sym_name_to_term, which given a symname
constructs a valid prog_term for that name.
Index: hlds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_out.m,v
retrieving revision 1.224
diff -u -r1.224 hlds_out.m
--- hlds_out.m 1999/08/13 01:43:00 1.224
+++ hlds_out.m 1999/08/19 12:54:34
@@ -810,6 +810,7 @@
hlds_out__marker_name(psn, "psn").
hlds_out__marker_name(supp_magic, "supp_magic").
hlds_out__marker_name(context, "context").
+hlds_out__marker_name(memo_cons, "memo_cons").
hlds_out__write_marker(Marker) -->
{ hlds_out__marker_name(Marker, Name) },
Index: hlds_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_pred.m,v
retrieving revision 1.65
diff -u -r1.65 hlds_pred.m
--- hlds_pred.m 1999/08/18 10:03:00 1.65
+++ hlds_pred.m 1999/08/20 01:54:51
@@ -382,6 +382,11 @@
% the termination of this predicate.
% If the compiler cannot guarantee termination
% then it must give an error message.
+
+ ; memo_cons
+ % The predicate should have its
+ % construction unification use hashcons
+ % memoing.
.
% Aditi predicates are identified by their owner as well as
Index: intermod.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/intermod.m,v
retrieving revision 1.66
diff -u -r1.66 intermod.m
--- intermod.m 1999/07/13 08:53:01 1.66
+++ intermod.m 1999/08/19 12:53:43
@@ -1188,6 +1188,8 @@
intermod__should_output_marker(generate_inline, _) :-
% This marker should only occur after the magic sets transformation.
error("intermod__should_output_marker: generate_inline").
+ % XXX is this correct?
+intermod__should_output_marker(memo_cons, yes).
% Some pretty kludgy stuff to get c code written correctly.
:- pred intermod__write_c_code(sym_name::in, pred_or_func::in,
Index: make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.300
diff -u -r1.300 make_hlds.m
--- make_hlds.m 1999/07/14 14:56:11 1.300
+++ make_hlds.m 1999/08/19 12:45:38
@@ -373,6 +373,11 @@
{ Pragma = tabled(_, _, _, _, _) },
{ Module = Module0 }
;
+ % Handle pragma tabled_cons decls later on (after we
+ % have processed the type defns)
+ { Pragma = tabled_cons(_, _) },
+ { Module = Module0 }
+ ;
{ Pragma = inline(Name, Arity) },
add_pred_marker(Module0, "inline", Name, Arity, ImportStatus,
Context, inline, [no_inline], Module)
@@ -689,6 +694,11 @@
),
{ Info = Info0 }
;
+ { Pragma = tabled_cons(Constructor, Arity) }
+ ->
+ module_add_pragma_tabled_cons(Constructor, Arity,
+ Status, Context, Module0, Module, Info0, Info)
+ ;
% don't worry about any pragma decs but c_code, tabling
% and fact_table here
{ Module = Module0 },
@@ -3577,6 +3587,176 @@
map__det_update(Procs0, ProcId, ProcInfo, Procs1),
set_eval_method_list(Rest, EvalMethod, Procs1, Procs).
+%-----------------------------------------------------------------------------%
+
+:- pred module_add_pragma_tabled_cons(sym_name::in, arity::in,
+ import_status::in, prog_context::in,
+ module_info::in, module_info::out,
+ qual_info::in, qual_info::out,
+ io__state::di, io__state::uo) is det.
+
+module_add_pragma_tabled_cons(Constructor, Arity, Status, Context,
+ Module0, Module, Info0, Info) -->
+ { module_info_ctors(Module0, ConsTable) },
+ (
+ { map__search(ConsTable, cons(Constructor, Arity), Defns) }
+ ->
+ (
+ { Defns = [hlds_cons_defn(_, _, _, TypeId, _)] }
+ ->
+ { module_info_types(Module0, Types) },
+ { map__lookup(Types, TypeId, TypeDefn) },
+ { hlds_data__get_type_defn_status(TypeDefn,
+ TypeStatus) },
+ (
+ { Status = TypeStatus }
+ ->
+ module_add_pragma_tabled_cons_2(Constructor,
+ Arity, TypeId, TypeDefn,
+ Status, Context,
+ Module0, Module,
+ Info0, Info)
+ ;
+ { module_info_incr_errors(Module0, Module) },
+ prog_out__write_context(Context),
+ io__write_string(
+ "Error: export status mismatch.\n"),
+ { Info = Info0 }
+ )
+ ;
+ { module_info_incr_errors(Module0, Module) },
+ prog_out__write_context(Context),
+ io__write_string("Error: constructor '"),
+ hlds_out__write_cons_id(cons(Constructor, Arity)),
+ io__write_string("' in multiple types.\n"),
+ { Info = Info0 }
+
+ % XXX should list what those types are if -E
+ )
+ ;
+ { module_info_incr_errors(Module0, Module) },
+ prog_out__write_context(Context),
+ io__write_string("Error: unknown constructor '"),
+ hlds_out__write_cons_id(cons(Constructor, Arity)),
+ io__write_string("'.\n"),
+ { Info = Info0 }
+ ).
+
+:- pred module_add_pragma_tabled_cons_2(sym_name::in, arity::in,
+ type_id::in, hlds_type_defn::in,
+ import_status::in, prog_context::in,
+ module_info::in, module_info::out,
+ qual_info::in, qual_info::out,
+ io__state::di, io__state::uo) is det.
+
+module_add_pragma_tabled_cons_2(ConsName, Arity, TypeId, TypeDefn,
+ Status, Context, Module0, Module, Info0, Info) -->
+ { hlds_data__get_type_defn_tvarset(TypeDefn, TypeVarSet) },
+ { varset__init(InstVarSet) },
+
+ { module_info_name(Module0, ModuleName) },
+ { make_hashcons_func_name(ConsName, Arity, TypeId, FuncStr) },
+ { FuncName = qualified(ModuleName, FuncStr) },
+
+ { construct_types_and_modes(ConsName, Arity, TypeId, TypeDefn,
+ Module0, ReturnTypeAndMode, TypesAndModes) },
+
+ { MaybeDet = no },
+ { Cond = true },
+ { Purity = pure },
+ { init_markers(Markers0) },
+ { add_marker(Markers0, memo_cons, Markers) },
+ { ItemStatus = item_status(Status, must_be_qualified) },
+
+ % XXX Need to handle existential construction
+ % unifications correctly.
+ { ExistQVars = [] },
+ { ClassContext = constraints([], []) },
+
+ module_add_func(Module0, TypeVarSet, InstVarSet, ExistQVars,
+ FuncName, TypesAndModes, ReturnTypeAndMode,
+ MaybeDet, Cond, Purity,
+ ClassContext, Markers, Context, ItemStatus, _, Module1),
+
+ { create_hashcons_goal(Arity, ConsName, Context,
+ ClauseVarSet, Result, Args, Body) },
+ { IsAssertion = no },
+
+ module_add_func_clause(Module1, ClauseVarSet, FuncName, Args,
+ Result, Body, Status, Context, IsAssertion, Module,
+ Info0, Info).
+
+ % XXX this actually be in the module that handles hashconsing
+ % when it is made.
+:- pred make_hashcons_func_name(sym_name::in, arity::in, type_id::in,
+ string::out) is det.
+
+make_hashcons_func_name(ConsName, ConsArity, TypeName - TypeArity, Name) :-
+ prog_out__sym_name_to_string(ConsName, ConsStr),
+ prog_out__sym_name_to_string(TypeName, TypeStr),
+ string__format("cons_%s/%d_%s/%d", [s(TypeStr), i(TypeArity),
+ s(ConsStr), i(ConsArity)], Name).
+
+:- pred construct_types_and_modes(sym_name::in, arity::in,
+ type_id::in, hlds_type_defn::in, module_info::in,
+ type_and_mode::out, list(type_and_mode)::out) is det.
+
+construct_types_and_modes(ConsName, Arity, TypeId, TypeDefn,
+ ModuleInfo, TypeAndMode, TypesAndModes) :-
+ hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
+ construct_type(TypeId, TypeParams, Type),
+
+ type_util__get_cons_id_arg_types(ModuleInfo, Type,
+ cons(ConsName, Arity), TypeArgs),
+
+ P = (pred(T0::in, T::out) is det :- T = type_only(T0)),
+ P(Type, TypeAndMode),
+ list__map(P, TypeArgs, TypesAndModes).
+
+
+
+ %
+ % create_hashcons_goal(A,C,Ctxt,VS,RV,As,G)
+ %
+ % Given the the constructor, C, with arity, A, construct a goal,
+ % G, which is the unification of RV = C(As) where RV is the
+ % return variable and As are the input args.
+ %
+:- pred create_hashcons_goal(arity::in, sym_name::in, prog_context::in,
+ prog_varset::out, prog_term::out,
+ list(prog_term)::out, goal::out) is det.
+
+create_hashcons_goal(Arity, ConsName, ProgContext,
+ VarSet, ReturnVar, Args, Goal) :-
+ varset__init(VarSet0),
+ create_hashcons_goal_2(Arity, ConsName, ProgContext,
+ VarSet0, [], VarSet, ReturnVar, Args, Goal).
+
+:- pred create_hashcons_goal_2(arity::in, sym_name::in, prog_context::in,
+ prog_varset::in, list(prog_term)::in, prog_varset::out,
+ prog_term::out, list(prog_term)::out, goal::out) is det.
+
+create_hashcons_goal_2(Arity, ConsName, ProgContext, VarSet0, Args0,
+ VarSet, ReturnVar, Args, Goal) :-
+ (
+ Arity = 0
+ ->
+ Args = Args0,
+ varset__new_var(VarSet0, Var, VarSet),
+
+ ReturnVar = term__variable(Var),
+
+ prog_out__sym_name_to_term(ConsName, Args, RHS),
+ Goal = unify(ReturnVar, RHS) - ProgContext
+ ;
+ varset__new_var(VarSet0, Var, VarSet1),
+ Args1 = [term__variable(Var) | Args0],
+
+ create_hashcons_goal_2(Arity-1, ConsName, ProgContext, VarSet1,
+ Args1, VarSet, ReturnVar, Args, Goal)
+ ).
+
+
%-----------------------------------------------------------------------------%
% from the list of pragma_vars extract the modes.
Index: mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.160
diff -u -r1.160 mercury_to_mercury.m
--- mercury_to_mercury.m 1999/07/13 08:53:12 1.160
+++ mercury_to_mercury.m 1999/08/19 08:44:54
@@ -346,6 +346,9 @@
{ eval_method_to_string(Type, TypeS) },
mercury_output_pragma_decl(Pred, Arity, predicate, TypeS)
;
+ { Pragma = tabled_cons(Cons, Arity) },
+ mercury_output_pragma_decl(Cons, Arity, predicate, "memo_cons")
+ ;
{ Pragma = type_spec(PredName, SymName, Arity,
MaybePredOrFunc, MaybeModes, Subst, VarSet) },
mercury_output_pragma_type_spec(PredName, SymName, Arity,
Index: module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.49
diff -u -r1.49 module_qual.m
--- module_qual.m 1999/07/14 14:56:13 1.49
+++ module_qual.m 1999/08/19 08:39:37
@@ -745,6 +745,7 @@
{ Info = Info0 },
{ MModes = no }
).
+qualify_pragma(tabled_cons(A, B), tabled_cons(A, B), Info, Info) --> [].
qualify_pragma(inline(A, B), inline(A, B), Info, Info) --> [].
qualify_pragma(no_inline(A, B), no_inline(A, B), Info, Info) --> [].
qualify_pragma(obsolete(A, B), obsolete(A, B), Info, Info) --> [].
Index: modules.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modules.m,v
retrieving revision 1.107
diff -u -r1.107 modules.m
--- modules.m 1999/08/18 06:26:04 1.107
+++ modules.m 1999/08/20 01:54:54
@@ -874,6 +874,7 @@
% yes, but the parser will strip out `source_file' pragmas anyway...
pragma_allowed_in_interface(fact_table(_, _, _), no).
pragma_allowed_in_interface(tabled(_, _, _, _, _), no).
+pragma_allowed_in_interface(tabled_cons(_, _), yes).
pragma_allowed_in_interface(promise_pure(_, _), no).
pragma_allowed_in_interface(unused_args(_, _, _, _, _), no).
pragma_allowed_in_interface(type_spec(_, _, _, _, _, _, _), yes).
Index: prog_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_data.m,v
retrieving revision 1.48
diff -u -r1.48 prog_data.m
--- prog_data.m 1999/07/13 08:53:23 1.48
+++ prog_data.m 1999/08/19 08:40:22
@@ -230,6 +230,9 @@
; tabled(eval_method, sym_name, int, maybe(pred_or_func),
maybe(list(mode)))
% Tabling type, Predname, Arity, PredOrFunc?, Mode?
+
+ ; tabled_cons(sym_name, arity)
+ % Constructor name, Arity
; promise_pure(sym_name, arity)
% Predname, Arity
Index: prog_io_pragma.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.21
diff -u -r1.21 prog_io_pragma.m
--- prog_io_pragma.m 1999/07/13 08:53:24 1.21
+++ prog_io_pragma.m 1999/08/19 08:40:49
@@ -320,6 +320,13 @@
parse_tabling_pragma(ModuleName, "minimal_model", eval_minimal,
PragmaTerms, ErrorTerm, Result).
+parse_pragma_type(ModuleName, "memo_cons", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
+ parse_simple_pragma(ModuleName, "memo_cons",
+ lambda([Name::in, Arity::in, Pragma::out] is det,
+ Pragma = tabled_cons(Name, Arity)),
+ PragmaTerms, ErrorTerm, Result).
+
parse_pragma_type(ModuleName, "obsolete", PragmaTerms, ErrorTerm,
_VarSet, Result) :-
parse_simple_pragma(ModuleName, "obsolete",
Index: prog_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_out.m,v
retrieving revision 1.43
diff -u -r1.43 prog_out.m
--- prog_out.m 1999/07/13 08:53:25 1.43
+++ prog_out.m 1999/08/19 08:28:12
@@ -68,6 +68,12 @@
:- pred prog_out__sym_name_to_string(sym_name, string, string).
:- mode prog_out__sym_name_to_string(in, in, out) is det.
+ % sym_name_to_term(SymName, Args, Term):
+ % convert a symbol name with an associated list of terms
+ % into a term.
+:- pred prog_out__sym_name_to_term(sym_name, list(prog_term), prog_term).
+:- mode prog_out__sym_name_to_term(in, in, out) is det.
+
:- pred prog_out__write_module_spec(module_specifier, io__state, io__state).
:- mode prog_out__write_module_spec(in, di, uo) is det.
@@ -230,6 +236,17 @@
[Separator, Name].
prog_out__sym_name_to_string_2(unqualified(Name), _) -->
[Name].
+
+prog_out__sym_name_to_term(unqualified(String), Args, Term) :-
+ Const = term__atom(String),
+ term__context_init(Context),
+ Term = term__functor(Const, Args, Context).
+prog_out__sym_name_to_term(qualified(Qualifier, String), Args, Term) :-
+ Const = term__atom(":"),
+ term__context_init(Context),
+ prog_out__sym_name_to_term(Qualifier, [], TermA),
+ prog_out__sym_name_to_term(unqualified(String), Args, TermB),
+ Term = term__functor(Const, [TermA, TermB], Context).
% write out a module specifier
----
+----------------------------------------------------------------------+
| Peter Ross M Sci/Eng Melbourne Uni |
| petdr at cs.mu.oz.au WWW: www.cs.mu.oz.au/~petdr/ ph: +61 3 9344 9158 |
+----------------------------------------------------------------------+
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list