[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