for review: Aditi [2]
Simon Taylor
stayl at cs.mu.OZ.AU
Tue Jul 7 13:43:31 AEST 1998
Index: compiler/hlds_module.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_module.m,v
retrieving revision 1.34
diff -u -t -u -r1.34 hlds_module.m
--- hlds_module.m 1998/05/07 06:41:03 1.34
+++ hlds_module.m 1998/06/02 05:14:24
@@ -178,6 +178,9 @@
:- pred module_info_globals(module_info, globals).
:- mode module_info_globals(in, out) is det.
+:- pred module_info_set_globals(module_info, globals, module_info).
+:- mode module_info_set_globals(in, in, out) is det.
+
:- pred module_info_get_c_header(module_info, c_header_info).
:- mode module_info_get_c_header(in, out) is det.
@@ -255,6 +258,10 @@
pred_info, proc_info).
:- mode module_info_pred_proc_info(in, in, in, out, out) is det.
+:- pred module_info_pred_proc_info(module_info, pred_proc_id,
+ pred_info, proc_info).
+:- mode module_info_pred_proc_info(in, in, out, out) is det.
+
% Return a list of the pred_ids of all the "valid" predicates.
% (Predicates whose definition contains a type error, etc.
% get removed from this list, so that later passes can rely
@@ -289,6 +296,10 @@
pred_id, proc_id, pred_info, proc_info, module_info).
:- mode module_info_set_pred_proc_info(in, in, in, in, in, out) is det.
+:- pred module_info_set_pred_proc_info(module_info,
+ pred_proc_id, pred_info, proc_info, module_info).
+:- mode module_info_set_pred_proc_info(in, in, in, in, out) is det.
+
:- pred module_info_typeids(module_info, list(type_id)).
:- mode module_info_typeids(in, out) is det.
@@ -304,6 +315,10 @@
:- pred module_info_dependency_info(module_info, dependency_info).
:- mode module_info_dependency_info(in, out) is det.
+:- pred module_info_aditi_dependency_ordering(module_info,
+ aditi_dependency_ordering).
+:- mode module_info_aditi_dependency_ordering(in, out) is det.
+
:- pred module_info_set_dependency_info(module_info, dependency_info,
module_info).
:- mode module_info_set_dependency_info(in, in, out) is det.
@@ -366,6 +381,9 @@
:- pred module_sub_get_globals(module_sub_info, globals).
:- mode module_sub_get_globals(in, out) is det.
+:- pred module_sub_set_globals(module_sub_info, globals, module_sub_info).
+:- mode module_sub_set_globals(in, in, out) is det.
+
:- pred module_sub_get_c_header_info(module_sub_info, c_header_info).
:- mode module_sub_get_c_header_info(in, out) is det.
@@ -588,6 +606,10 @@
% Various predicates which modify the module_sub_info data structure.
+module_sub_set_globals(MI0, B, MI) :-
+ MI0 = module_sub(A, _, C, D, E, F, G, H, I, J, K, L, M),
+ MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M).
+
module_sub_set_c_header_info(MI0, C, MI) :-
MI0 = module_sub(A, B, _, D, E, F, G, H, I, J, K, L, M),
MI = module_sub(A, B, C, D, E, F, G, H, I, J, K, L, M).
@@ -815,6 +837,11 @@
% Various predicates which modify the module_sub_info data structure
% via the module_info structure.
+module_info_set_globals(MI0, B, MI) :-
+ module_info_get_sub_info(MI0, MS0),
+ module_sub_set_globals(MS0, B, MS),
+ module_info_set_sub_info(MI0, MS, MI).
+
module_info_set_c_header(MI0, C, MI) :-
module_info_get_sub_info(MI0, MS0),
module_sub_set_c_header_info(MS0, C, MS),
@@ -895,6 +922,9 @@
pred_info_procedures(PredInfo, Procs),
map__lookup(Procs, ProcId, ProcInfo).
+module_info_pred_proc_info(MI, proc(PredId, ProcId), PredInfo, ProcInfo) :-
+ module_info_pred_proc_info(MI, PredId, ProcId, PredInfo, ProcInfo).
+
module_info_predids(MI, PredIds) :-
module_info_get_predicate_table(MI, PredTable),
predicate_table_get_predids(PredTable, PredIds).
@@ -924,6 +954,11 @@
map__set(Preds0, PredId, PredInfo, Preds),
module_info_set_preds(MI0, Preds, MI).
+module_info_set_pred_proc_info(MI0, proc(PredId, ProcId),
+ PredInfo, ProcInfo, MI) :-
+ module_info_set_pred_proc_info(MI0, PredId, ProcId,
+ PredInfo, ProcInfo, MI).
+
module_info_set_pred_proc_info(MI0, PredId, ProcId, PredInfo0, ProcInfo, MI) :-
pred_info_procedures(PredInfo0, Procs0),
map__set(Procs0, ProcId, ProcInfo, Procs),
@@ -955,6 +990,16 @@
error("Attempted to access invalid dependency_info")
).
+module_info_aditi_dependency_ordering(MI, AditiOrdering) :-
+ module_info_dependency_info(MI, DepInfo),
+ hlds_dependency_info_get_maybe_aditi_dependency_ordering(DepInfo,
+ MaybeOrdering),
+ ( MaybeOrdering = yes(OrderingPrime) ->
+ AditiOrdering = OrderingPrime
+ ;
+ error("Attempted to access invalid aditi_dependency_ordering")
+ ).
+
module_info_set_dependency_info(MI0, DependencyInfo, MI) :-
module_info_set_maybe_dependency_info(MI0, yes(DependencyInfo), MI).
@@ -1011,8 +1056,16 @@
:- interface.
-:- type dependency_ordering == list(list(pred_proc_id)).
-:- type dependency_graph == relation(pred_proc_id).
+:- type dependency_ordering == list(list(pred_proc_id)).
+
+:- type aditi_dependency_ordering == list(aditi_sub_module).
+
+ % Each Aditi SCC contains one or more SCCs from the original
+ % dependency ordering and the entry points of the SCC.
+:- type aditi_sub_module
+ ---> aditi_sub_module(dependency_ordering, list(pred_proc_id)).
+
+:- type dependency_graph == relation(pred_proc_id).
:- type dependency_info.
:- pred hlds_dependency_info_init(dependency_info).
@@ -1026,6 +1079,11 @@
dependency_ordering).
:- mode hlds_dependency_info_get_dependency_ordering(in, out) is det.
+:- pred hlds_dependency_info_get_maybe_aditi_dependency_ordering(
+ dependency_info, maybe(aditi_dependency_ordering)).
+:- mode hlds_dependency_info_get_maybe_aditi_dependency_ordering(in,
+ out) is det.
+
:- pred hlds_dependency_info_set_dependency_graph(dependency_info,
dependency_graph, dependency_info).
:- mode hlds_dependency_info_set_dependency_graph(in, in, out) is det.
@@ -1034,6 +1092,10 @@
dependency_ordering, dependency_info).
:- mode hlds_dependency_info_set_dependency_ordering(in, in, out) is det.
+:- pred hlds_dependency_info_set_aditi_dependency_ordering(dependency_info,
+ aditi_dependency_ordering, dependency_info).
+:- mode hlds_dependency_info_set_aditi_dependency_ordering(in, in, out) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
@@ -1041,27 +1103,38 @@
:- type dependency_info --->
dependency_info(
dependency_graph, % Dependency graph
- dependency_ordering % Dependency ordering
+ dependency_ordering, % Dependency ordering
+ maybe(aditi_dependency_ordering)
+ % Dependency ordering of Aditi
+ % SCCs with some merged
).
hlds_dependency_info_init(DepInfo) :-
relation__init(DepRel),
DepOrd = [],
- DepInfo = dependency_info(DepRel, DepOrd).
+ DepInfo = dependency_info(DepRel, DepOrd, no).
hlds_dependency_info_get_dependency_graph(DepInfo, A) :-
- DepInfo = dependency_info(A, _).
+ DepInfo = dependency_info(A, _, _).
hlds_dependency_info_get_dependency_ordering(DepInfo, B) :-
- DepInfo = dependency_info(_, B).
+ DepInfo = dependency_info(_, B, _).
+
+hlds_dependency_info_get_maybe_aditi_dependency_ordering(DepInfo, C) :-
+ DepInfo = dependency_info(_, _, C).
-hlds_dependency_info_set_dependency_graph(DepInfo0, A, DepInfo) :-
- DepInfo0 = dependency_info(_, B),
- DepInfo = dependency_info(A, B).
-
-hlds_dependency_info_set_dependency_ordering(DepInfo0, B, DepInfo) :-
- DepInfo0 = dependency_info(A, _),
- DepInfo = dependency_info(A, B).
+hlds_dependency_info_set_dependency_graph(DepInfo0, DepRel, DepInfo) :-
+ DepInfo0 = dependency_info(_, B, C),
+ DepInfo = dependency_info(DepRel, B, C).
+
+hlds_dependency_info_set_dependency_ordering(DepInfo0, DepRel, DepInfo) :-
+ DepInfo0 = dependency_info(A, _, C),
+ DepInfo = dependency_info(A, DepRel, C).
+
+hlds_dependency_info_set_aditi_dependency_ordering(DepInfo0,
+ DepOrd, DepInfo) :-
+ DepInfo0 = dependency_info(A, B, _),
+ DepInfo = dependency_info(A, B, yes(DepOrd)).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_out.m,v
retrieving revision 1.196
diff -u -t -u -r1.196 hlds_out.m
--- hlds_out.m 1998/06/19 03:16:14 1.196
+++ hlds_out.m 1998/07/06 23:57:16
@@ -537,7 +537,8 @@
;
{ AppendVarnums = no }
),
- ( { string__contains_char(Verbose, 'C') } ->
+
+ ( { string__contains_char(Verbose, 'C'), Clauses \= [] } ->
hlds_out__write_var_types(Indent, VarSet, AppendVarnums,
VarTypes, TVarSet),
@@ -566,7 +567,6 @@
hlds_out__marker_name(inline, "inline").
hlds_out__marker_name(no_inline, "no_inline").
hlds_out__marker_name(dnf, "dnf").
-hlds_out__marker_name(magic, "magic").
hlds_out__marker_name(obsolete, "obsolete").
hlds_out__marker_name(class_method, "class_method").
hlds_out__marker_name((impure), "impure").
@@ -575,6 +575,16 @@
hlds_out__marker_name(terminates, "terminates").
hlds_out__marker_name(check_termination, "check_termination").
hlds_out__marker_name(does_not_terminate, "does_not_terminate").
+hlds_out__marker_name(aditi, "aditi").
+hlds_out__marker_name(aditi_interface, "aditi_interface").
+hlds_out__marker_name(base_relation, "base_relation").
+hlds_out__marker_name(generate_inline, "generate_inline").
+hlds_out__marker_name(memo, "memo").
+hlds_out__marker_name(no_memo, "no_memo").
+hlds_out__marker_name(naive, "naive").
+hlds_out__marker_name(psn, "psn").
+hlds_out__marker_name(supp_magic, "supp_magic").
+hlds_out__marker_name(context, "context").
hlds_out__write_marker(Marker) -->
{ hlds_out__marker_name(Marker, Name) },
Index: compiler/hlds_pred.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/hlds_pred.m,v
retrieving revision 1.48
diff -u -t -u -r1.48 hlds_pred.m
--- hlds_pred.m 1998/05/15 07:07:10 1.48
+++ hlds_pred.m 1998/06/04 06:29:24
@@ -204,10 +204,47 @@
% Conflicts with `inline' marker.
; dnf % Requests that this predicate be transformed
% into disjunctive normal form.
- ; magic % Requests that this predicate be transformed
- % using the magic set transformation
- % Used for pragma(memo).
- % Used for pragma(memo).
+ ; memo % Requests that this predicate be evaluated
+ % using memoing.
+ ; no_memo % Ensure that this procedure is not memoed.
+
+ ; aditi % Generate Aditi-RL for this predicate.
+ ; base_relation % This predicate is an Aditi base relation.
+
+ % `naive' and `psn' are mutually exclusive.
+ ; naive % Use naive evaluation.
+ ; psn % Use predicate semi-naive evaluation.
+
+ % `context' and `supp_magic' are mutually
+ % exclusive. One of them must be performed
+ % on all Aditi procedures. `supp_magic'
+ % is the default
+
+ ; supp_magic % Perform the supplementary magic sets
+ % transformation on this predicate.
+ ; context % Perform the context transformation on
+ % the predicate.
+
+ ; generate_inline % Used for small procedures which project
+ % a relation to be used as input to a call.
+ % The goal should consist of fail, true
+ % or a single rule.
+ % These relations are never memoed.
+ % The reason these must be generated inline
+ % is to ensure that the relation used for
+ % input is a projection of the current
+ % value of the projected relation for all
+ % orderings of the SCC.
+
+ ; aditi_interface % No code is actually generated for this
+ % procedure type. A call to a procedure with
+ % this marker is generated as a call to
+ % do_call_aditi_*, which is defined in hand
+ % coded C in extras/aditi/aditi.m.
+
+ % The default flags for Aditi procedures are
+ % aditi, dnf, supp_magic, psn and memo.
+
; class_method % Requests that this predicate be transformed
% into the appropriate call to a class method
; (impure) % Requests that no transformation that would
@@ -267,9 +304,9 @@
:- pred hlds_pred__define_new_pred(hlds_goal, hlds_goal, list(var),
instmap, string, tvarset, map(var, type),
list(class_constraint), map(tvar, type_info_locn),
- map(class_constraint, var), varset, pred_markers,
+ map(class_constraint, var), varset, pred_markers, string,
module_info, module_info, pred_proc_id).
-:- mode hlds_pred__define_new_pred(in, out, in, in, in, in, in,
+:- mode hlds_pred__define_new_pred(in, out, in, in, in, in, in, in,
in, in, in, in, in, in, out, out) is det.
% Various predicates for accessing the information stored in the
@@ -278,23 +315,24 @@
:- pred pred_info_init(module_name, sym_name, arity, tvarset, list(type),
condition, term__context, clauses_info, import_status,
pred_markers, goal_type, pred_or_func, list(class_constraint),
- map(class_constraint, constraint_proof), pred_info).
+ map(class_constraint, constraint_proof), string, pred_info).
:- mode pred_info_init(in, in, in, in, in, in, in, in, in, in, in, in, in, in,
- out) is det.
+ in, out) is det.
:- pred pred_info_create(module_name, sym_name, tvarset, list(type),
condition, term__context, import_status, pred_markers,
- pred_or_func, list(class_constraint), proc_info, proc_id, pred_info).
-:- mode pred_info_create(in, in, in, in, in, in, in, in, in, in, in, out, out)
- is det.
+ pred_or_func, list(class_constraint), string, proc_info,
+ proc_id, pred_info).
+:- mode pred_info_create(in, in, in, in, in, in, in, in, in, in, in, in,
+ out, out) is det.
:- pred pred_info_set(tvarset, list(type), condition, clauses_info, proc_table,
term__context, module_name, string, arity, import_status,
tvarset, goal_type, pred_markers, pred_or_func,
list(class_constraint), map(class_constraint, constraint_proof),
- pred_info).
+ string, pred_info).
:- mode pred_info_set(in, in, in, in, in, in, in, in, in, in, in, in, in, in,
- in, in, out) is det.
+ in, in, in, out) is det.
:- pred pred_info_module(pred_info, module_name).
:- mode pred_info_module(in, out) is det.
@@ -405,6 +443,12 @@
map(class_constraint, constraint_proof), pred_info).
:- mode pred_info_set_constraint_proofs(in, in, out) is det.
+:- pred pred_info_get_aditi_owner(pred_info, string).
+:- mode pred_info_get_aditi_owner(in, out) is det.
+
+:- pred pred_info_set_aditi_owner(pred_info, string, pred_info).
+:- mode pred_info_set_aditi_owner(in, in, out) is det.
+
:- pred pred_info_get_purity(pred_info, purity).
:- mode pred_info_get_purity(in, out) is det.
@@ -434,6 +478,10 @@
:- pred add_marker(pred_markers, marker, pred_markers).
:- mode add_marker(in, in, out) is det.
+ % remove a marker from the set
+:- pred remove_marker(pred_markers, marker, pred_markers).
+:- mode remove_marker(in, in, out) is det.
+
% convert the set to a list
:- pred markers_to_marker_list(pred_markers, list(marker)).
:- mode markers_to_marker_list(in, out) is det.
@@ -505,27 +553,33 @@
list(class_constraint),
% the class constraints on the
% predicate
- map(class_constraint, constraint_proof)
+ map(class_constraint, constraint_proof),
% explanations of how redundant
% constraints were eliminated. These
% are needed by polymorphism.m to
% work out where to get the
% typeclass_infos from.
+ string
+ % The owner of this predicate if
+ % it is an Aditi predicate. Set to
+ % the value of --aditi-user if no
+ % `:- pragma owner' declaration exists.
).
pred_info_init(ModuleName, SymName, Arity, TypeVarSet, Types, Cond, Context,
ClausesInfo, Status, Markers, GoalType, PredOrFunc,
- ClassContext, ClassProofs, PredInfo) :-
+ ClassContext, ClassProofs, User, PredInfo) :-
map__init(Procs),
unqualify_name(SymName, PredName),
sym_name_get_module_name(SymName, ModuleName, PredModuleName),
PredInfo = predicate(TypeVarSet, Types, Cond, ClausesInfo, Procs,
Context, PredModuleName, PredName, Arity, Status, TypeVarSet,
- GoalType, Markers, PredOrFunc, ClassContext, ClassProofs).
+ GoalType, Markers, PredOrFunc, ClassContext, ClassProofs,
+ User).
pred_info_create(ModuleName, SymName, TypeVarSet, Types, Cond, Context,
- Status, Markers, PredOrFunc, ClassContext, ProcInfo, ProcId,
- PredInfo) :-
+ Status, Markers, PredOrFunc, ClassContext, User,
+ ProcInfo, ProcId, PredInfo) :-
map__init(Procs0),
proc_info_declared_determinism(ProcInfo, MaybeDetism),
next_mode_id(Procs0, MaybeDetism, ProcId),
@@ -540,19 +594,21 @@
map__init(ClassProofs),
PredInfo = predicate(TypeVarSet, Types, Cond, ClausesInfo, Procs,
Context, ModuleName, PredName, Arity, Status, TypeVarSet,
- clauses, Markers, PredOrFunc, ClassContext, ClassProofs).
+ clauses, Markers, PredOrFunc, ClassContext, ClassProofs,
+ User).
pred_info_set(HeadTVarSet, Types, Cond, ClausesInfo, Procs, Context,
PredModuleName, PredName, Arity, Status, AllTVarSet,
GoalType, Markers, PredOrFunc, ClassContext, ClassProofs,
- PredInfo) :-
+ User, PredInfo) :-
PredInfo = predicate(HeadTVarSet, Types, Cond, ClausesInfo, Procs,
Context, PredModuleName, PredName, Arity, Status, AllTVarSet,
- GoalType, Markers, PredOrFunc, ClassContext, ClassProofs).
+ GoalType, Markers, PredOrFunc, ClassContext, ClassProofs,
+ User).
pred_info_procids(PredInfo, ProcIds) :-
PredInfo = predicate(_, _, _, _, Procs, _, _, _, _, _, _, _,
- _, _, _, _),
+ _, _, _, _, _),
map__keys(Procs, ProcIds).
pred_info_non_imported_procids(PredInfo, ProcIds) :-
@@ -579,50 +635,53 @@
pred_info_clauses_info(PredInfo, Clauses) :-
PredInfo = predicate(_, _, _, Clauses, _, _, _, _, _, _, _, _,
- _, _, _, _).
+ _, _, _, _, _).
pred_info_set_clauses_info(PredInfo0, Clauses, PredInfo) :-
- PredInfo0 = predicate(A, B, C, _, E, F, G, H, I, J, K, L, M, N, O, P),
+ PredInfo0 = predicate(A, B, C, _, E, F, G, H, I, J, K,
+ L, M, N, O, P, Q),
PredInfo = predicate(A, B, C, Clauses, E, F, G, H, I, J, K,
- L, M, N, O, P).
+ L, M, N, O, P, Q).
pred_info_arg_types(PredInfo, TypeVars, ArgTypes) :-
PredInfo = predicate(TypeVars, ArgTypes,
- _, _, _, _, _, _, _, _, _, _, _, _, _, _).
+ _, _, _, _, _, _, _, _, _, _, _, _, _, _, _).
pred_info_set_arg_types(PredInfo0, TypeVarSet, ArgTypes, PredInfo) :-
- PredInfo0 = predicate(_, _, C, D, E, F, G, H, I, J, K, L, M, N, O, P),
+ PredInfo0 = predicate(_, _,
+ C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q),
PredInfo = predicate(TypeVarSet, ArgTypes,
- C, D, E, F, G, H, I, J, K, L, M, N, O, P).
+ C, D, E, F, G, H, I, J, K, L, M, N, O, P, Q).
pred_info_procedures(PredInfo, Procs) :-
PredInfo = predicate(_, _, _, _, Procs, _, _, _, _, _, _,
- _, _, _, _, _).
+ _, _, _, _, _, _).
pred_info_set_procedures(PredInfo0, Procedures, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, _, F, G, H, I, J, K, L, M, N, O, P),
+ PredInfo0 = predicate(A, B, C, D, _, F, G, H, I, J, K, L, M,
+ N, O, P, Q),
PredInfo = predicate(A, B, C, D, Procedures, F, G, H, I, J, K, L, M,
- N, O, P).
+ N, O, P, Q).
pred_info_context(PredInfo, Context) :-
PredInfo = predicate(_, _, _, _, _, Context, _, _, _,
- _, _, _, _, _, _, _).
+ _, _, _, _, _, _, _, _).
pred_info_module(PredInfo, Module) :-
PredInfo = predicate(_, _, _, _, _, _, Module, _, _, _, _,
- _, _, _, _, _).
+ _, _, _, _, _, _).
pred_info_name(PredInfo, PredName) :-
PredInfo = predicate(_, _, _, _, _, _, _, PredName, _, _, _,
- _, _, _, _, _).
+ _, _, _, _, _, _).
pred_info_arity(PredInfo, Arity) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, Arity, _, _,
- _, _, _, _, _).
+ _, _, _, _, _, _).
pred_info_import_status(PredInfo, ImportStatus) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, _, ImportStatus, _, _, _,
- _, _, _).
+ _, _, _, _).
pred_info_is_imported(PredInfo) :-
pred_info_import_status(PredInfo, imported).
@@ -640,32 +699,36 @@
ImportStatus = pseudo_exported.
pred_info_mark_as_external(PredInfo0, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, _, K, L, M, N, O, P),
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, _, K, L, M,
+ N, O, P, Q),
PredInfo = predicate(A, B, C, D, E, F, G, H, I, imported, K, L, M,
- N, O, P).
+ N, O, P, Q).
pred_info_set_import_status(PredInfo0, Status, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, _, K, L, M, N, O, P),
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, _, K,
+ L, M, N, O, P, Q),
PredInfo = predicate(A, B, C, D, E, F, G, H, I, Status, K,
- L, M, N, O, P).
+ L, M, N, O, P, Q).
pred_info_typevarset(PredInfo, TypeVarSet) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, TypeVarSet, _, _,
- _, _, _).
+ _, _, _, _).
pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, _, L, M, N, O, P),
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, _, L, M,
+ N, O, P, Q),
PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, TypeVarSet, L, M,
- N, O, P).
+ N, O, P, Q).
pred_info_get_goal_type(PredInfo, GoalType) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, GoalType, _,
- _, _, _).
+ _, _, _, _).
pred_info_set_goal_type(PredInfo0, GoalType, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, _, M, N, O, P),
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, _, M,
+ N, O, P, Q),
PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, GoalType, M,
- N, O, P).
+ N, O, P, Q).
pred_info_requested_inlining(PredInfo0) :-
pred_info_get_markers(PredInfo0, Markers),
@@ -699,34 +762,47 @@
pred_info_get_markers(PredInfo, Markers) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, _, Markers,
- _, _, _).
+ _, _, _, _).
pred_info_set_markers(PredInfo0, Markers, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, _, N, O, P),
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, _,
+ N, O, P, Q),
PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, L, Markers,
- N, O, P).
+ N, O, P, Q).
pred_info_get_is_pred_or_func(PredInfo, IsPredOrFunc) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, _, _,
- IsPredOrFunc, _, _).
+ IsPredOrFunc, _, _, _).
pred_info_set_class_context(PredInfo0, ClassContext, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N, _, P),
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
+ _, P, Q),
PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
- ClassContext, P).
+ ClassContext, P, Q).
pred_info_get_class_context(PredInfo, ClassContext) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, _, _, _,
- ClassContext, _).
+ ClassContext, _, _).
pred_info_set_constraint_proofs(PredInfo0, Proofs, PredInfo) :-
- PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N, O, _),
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
+ O, _, Q),
PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
- O, Proofs).
+ O, Proofs, Q).
pred_info_get_constraint_proofs(PredInfo, ConstraintProofs) :-
PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
- ConstraintProofs).
+ ConstraintProofs, _).
+
+pred_info_set_aditi_owner(PredInfo0, Owner, PredInfo) :-
+ PredInfo0 = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
+ O, P, _),
+ PredInfo = predicate(A, B, C, D, E, F, G, H, I, J, K, L, M, N,
+ O, P, Owner).
+
+pred_info_get_aditi_owner(PredInfo, User) :-
+ PredInfo = predicate(_, _, _, _, _, _, _, _, _, _, _, _, _, _, _,
+ _, User).
%-----------------------------------------------------------------------------%
@@ -746,13 +822,16 @@
add_marker(Markers, Marker, [Marker | Markers]).
+remove_marker(Markers0, Marker, Markers) :-
+ list__delete_all(Markers0, Marker, Markers).
+
markers_to_marker_list(Markers, Markers).
%-----------------------------------------------------------------------------%
hlds_pred__define_new_pred(Goal0, Goal, ArgVars0, InstMap0, PredName, TVarSet,
VarTypes0, ClassContext, TVarMap, TCVarMap, VarSet0,
- Markers, ModuleInfo0, ModuleInfo, PredProcId) :-
+ Markers, User, ModuleInfo0, ModuleInfo, PredProcId) :-
Goal0 = _GoalExpr - GoalInfo,
goal_info_get_instmap_delta(GoalInfo, InstMapDelta),
instmap__apply_instmap_delta(InstMap0, InstMapDelta, InstMap),
@@ -802,7 +881,7 @@
pred_info_create(ModuleName, SymName, TVarSet, ArgTypes, true,
Context, local, Markers, predicate, ClassContext,
- ProcInfo, ProcId, PredInfo),
+ User, ProcInfo, ProcId, PredInfo),
module_info_get_predicate_table(ModuleInfo0, PredTable0),
predicate_table_insert(PredTable0, PredInfo, PredId,
@@ -1559,6 +1638,108 @@
%-----------------------------------------------------------------------------%
+ % Predicates to check whether a given predicate
+ % is an Aditi query.
+
+:- interface.
+
+:- pred hlds_pred__is_base_relation(module_info, pred_id).
+:- mode hlds_pred__is_base_relation(in, in) is semidet.
+
+:- pred hlds_pred__is_derived_relation(module_info, pred_id).
+:- mode hlds_pred__is_derived_relation(in, in) is semidet.
+
+ % Is the given predicate a base or derived Aditi relation.
+:- pred hlds_pred__is_aditi_relation(module_info, pred_id).
+:- mode hlds_pred__is_aditi_relation(in, in) is semidet.
+
+:- pred hlds_pred__is_aditi_aggregate(module_info, pred_id).
+:- mode hlds_pred__is_aditi_aggregate(in, in) is semidet.
+
+:- pred hlds_pred__pred_info_is_aditi_relation(pred_info).
+:- mode hlds_pred__pred_info_is_aditi_relation(in) is semidet.
+
+:- pred hlds_pred__pred_info_is_aditi_aggregate(pred_info).
+:- mode hlds_pred__pred_info_is_aditi_aggregate(in) is semidet.
+
+:- pred hlds_pred__pred_info_is_base_relation(pred_info).
+:- mode hlds_pred__pred_info_is_base_relation(in) is semidet.
+
+:- pred hlds_pred__is_memoed(module_info, pred_id).
+:- mode hlds_pred__is_memoed(in, in) is semidet.
+
+:- pred hlds_pred__is_differential(module_info, pred_id).
+:- mode hlds_pred__is_differential(in, in) is semidet.
+
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+hlds_pred__is_base_relation(ModuleInfo, PredId) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ hlds_pred__pred_info_is_base_relation(PredInfo).
+
+hlds_pred__pred_info_is_base_relation(PredInfo) :-
+ pred_info_get_markers(PredInfo, Markers),
+ check_marker(Markers, base_relation).
+
+hlds_pred__is_derived_relation(ModuleInfo, PredId) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_get_markers(PredInfo, Markers),
+ check_marker(Markers, aditi),
+ \+ hlds_pred__pred_info_is_base_relation(PredInfo),
+ \+ hlds_pred__pred_info_is_aditi_aggregate(PredInfo).
+
+hlds_pred__is_aditi_relation(ModuleInfo, PredId) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ hlds_pred__pred_info_is_aditi_relation(PredInfo).
+
+hlds_pred__pred_info_is_aditi_relation(PredInfo) :-
+ pred_info_get_markers(PredInfo, Markers),
+ check_marker(Markers, aditi).
+
+hlds_pred__is_aditi_aggregate(ModuleInfo, PredId) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ hlds_pred__pred_info_is_aditi_aggregate(PredInfo).
+
+hlds_pred__pred_info_is_aditi_aggregate(PredInfo) :-
+ pred_info_module(PredInfo, Module),
+ pred_info_name(PredInfo, Name),
+ pred_info_arity(PredInfo, Arity),
+ hlds_pred__aditi_aggregate(Module, Name, Arity).
+
+:- pred hlds_pred__aditi_aggregate(sym_name, string, int).
+:- mode hlds_pred__aditi_aggregate(in, in, in) is semidet.
+
+hlds_pred__aditi_aggregate(unqualified("aditi"),
+ "aggregate_compute_initial", 5).
+
+hlds_pred__is_memoed(ModuleInfo, PredId) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_get_markers(PredInfo, Markers),
+ (
+ check_marker(Markers, memo)
+ ;
+ % Memoing is the default for Aditi procedures.
+ semidet_fail, % XXXXXXXX
+ check_marker(Markers, aditi),
+ \+ check_marker(Markers, no_memo)
+ ).
+
+hlds_pred__is_differential(ModuleInfo, PredId) :-
+ module_info_pred_info(ModuleInfo, PredId, PredInfo),
+ pred_info_get_markers(PredInfo, Markers),
+ (
+ check_marker(Markers, psn)
+ ;
+ % Predicate semi-naive evaluation is the default.
+ check_marker(Markers, aditi),
+ \+ check_marker(Markers, naive)
+ ).
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
:- interface.
% Check if the given evaluation method is allowed with
@@ -1611,3 +1792,5 @@
eval_method_change_determinism(eval_minimal, Det0, Det) :-
det_conjunction_detism(semidet, Det0, Det).
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
Index: compiler/inlining.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/inlining.m,v
retrieving revision 1.77
diff -u -t -u -r1.77 inlining.m
--- inlining.m 1998/06/09 02:12:58 1.77
+++ inlining.m 1998/07/01 03:56:42
@@ -81,6 +81,7 @@
%-----------------------------------------------------------------------------%
:- interface.
+
:- import_module hlds_goal, hlds_module, hlds_pred, prog_data.
:- import_module io, list, map, term, varset.
@@ -180,7 +181,11 @@
{ list__condense(SCCs, PredProcs) },
{ set__init(InlinedProcs0) },
inlining__do_inlining(PredProcs, NeededMap, Params, InlinedProcs0,
- ModuleInfo1, ModuleInfo).
+ ModuleInfo1, ModuleInfo2),
+
+ % The dependency graph is now out of date and
+ % needs to be rebuilt.
+ { module_info_clobber_dependency_info(ModuleInfo2, ModuleInfo) }.
:- pred inlining__do_inlining(list(pred_proc_id), needed_map, inline_params,
set(pred_proc_id), module_info, module_info,
@@ -240,7 +245,11 @@
\+ {
CalledGoal = pragma_c_code(_,_,_,_,_,_,_) - _,
proc_info_interface_code_model(ProcInfo, model_non)
- }
+ },
+
+ % Don't inline memoed predicates.
+ { pred_info_get_markers(PredInfo, Markers) },
+ { \+ check_marker(Markers, memo) }
->
inlining__mark_proc_as_inlined(PredProcId, ModuleInfo,
InlinedProcs0, InlinedProcs)
@@ -309,9 +318,8 @@
% It also stores some necessary information that is not
% updated.
-:- type inline_info --->
-
- inline_info(
+:- type inline_info
+ ---> inline_info(
int, % variable threshold for inlining
set(pred_proc_id), % inlined procs
module_info, % module_info
@@ -325,9 +333,10 @@
% type variables to variables
% where their type_info is
% stored.
- bool % Did we change the determinism
+ bool, % Did we change the determinism
% of any subgoal?
- ).
+ pred_markers % Markers for the current predicate.
+ ).
:- pred inlining__in_predproc(pred_proc_id, set(pred_proc_id), inline_params,
module_info, module_info, io__state, io__state).
@@ -345,6 +354,7 @@
map__lookup(ProcTable0, ProcId, ProcInfo0),
pred_info_typevarset(PredInfo0, TypeVarSet0),
+ pred_info_get_markers(PredInfo0, Markers),
proc_info_goal(ProcInfo0, Goal0),
proc_info_varset(ProcInfo0, VarSet0),
@@ -354,12 +364,13 @@
DetChanged0 = no,
InlineInfo0 = inline_info(VarThresh, InlinedProcs, ModuleInfo0,
- VarSet0, VarTypes0, TypeVarSet0, TypeInfoVarMap0, DetChanged0),
+ VarSet0, VarTypes0, TypeVarSet0, TypeInfoVarMap0,
+ DetChanged0, Markers),
inlining__inlining_in_goal(Goal0, Goal, InlineInfo0, InlineInfo),
InlineInfo = inline_info(_, _, _, VarSet, VarTypes, TypeVarSet,
- TypeInfoVarMap, DetChanged),
+ TypeInfoVarMap, DetChanged, _),
pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo1),
@@ -426,12 +437,12 @@
InlineInfo0 = inline_info(VarThresh, InlinedProcs, ModuleInfo,
VarSet0, VarTypes0, TypeVarSet0, TypeInfoVarMap0,
- DetChanged0),
+ DetChanged0, Markers),
% should we inline this call?
(
inlining__should_inline_proc(PredId, ProcId, Builtin,
- InlinedProcs, ModuleInfo),
+ InlinedProcs, Markers, ModuleInfo),
% okay, but will we exceed the number-of-variables
% threshold?
varset__vars(VarSet0, ListOfVars),
@@ -471,8 +482,8 @@
TypeInfoVarMap = TypeInfoVarMap0,
DetChanged = DetChanged0
),
- InlineInfo = inline_info(VarThresh, InlinedProcs, ModuleInfo,
- VarSet, VarTypes, TypeVarSet, TypeInfoVarMap, DetChanged).
+ InlineInfo = inline_info(VarThresh, InlinedProcs, ModuleInfo, VarSet,
+ VarTypes, TypeVarSet, TypeInfoVarMap, DetChanged, Markers).
inlining__inlining_in_goal(higher_order_call(A, B, C, D, E, F) - GoalInfo,
higher_order_call(A, B, C, D, E, F) - GoalInfo) --> [].
@@ -608,11 +619,11 @@
% is a conjunction of builtins.
:- pred inlining__should_inline_proc(pred_id, proc_id, builtin_state,
- set(pred_proc_id), module_info).
-:- mode inlining__should_inline_proc(in, in, in, in, in) is semidet.
+ set(pred_proc_id), pred_markers, module_info).
+:- mode inlining__should_inline_proc(in, in, in, in, in, in) is semidet.
inlining__should_inline_proc(PredId, ProcId, BuiltinState, InlinedProcs,
- ModuleInfo) :-
+ CallingPredMarkers, ModuleInfo) :-
% don't inline builtins, the code generator will handle them
@@ -643,6 +654,17 @@
% not to inline.
\+ pred_info_requested_no_inlining(PredInfo),
+
+ % Don't inline Aditi procedures into non-Aditi procedures,
+ % since this could result in joins being performed by
+ % backtracking rather than by more efficient methods in
+ % the database.
+
+ pred_info_get_markers(PredInfo, CalledPredMarkers),
+ \+ (
+ \+ check_marker(CallingPredMarkers, aditi),
+ check_marker(CalledPredMarkers, aditi)
+ ),
% OK, we could inline it - but should we? Apply our heuristic.
Index: compiler/lambda.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/lambda.m,v
retrieving revision 1.43
diff -u -t -u -r1.43 lambda.m
--- lambda.m 1998/06/09 02:13:05 1.43
+++ lambda.m 1998/06/11 01:04:48
@@ -49,10 +49,11 @@
:- pred lambda__transform_lambda(pred_or_func, string, list(var), list(mode),
determinism, list(var), set(var), hlds_goal, unification,
varset, map(var, type), list(class_constraint), tvarset,
- map(tvar, type_info_locn), map(class_constraint, var),
- module_info, unify_rhs, unification, module_info).
+ map(tvar, type_info_locn), pred_markers,
+ map(class_constraint, var), string, module_info,
+ unify_rhs, unification, module_info).
:- mode lambda__transform_lambda(in, in, in, in, in, in, in, in, in, in, in,
- in, in, in, in, in, out, out, out) is det.
+ in, in, in, in, in, in, in, out, out, out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -68,16 +69,18 @@
lambda_info(
varset, % from the proc_info
map(var, type), % from the proc_info
- list(class_constraint), % from the pred_info
- tvarset, % from the proc_info
+ list(class_constraint), % from the pred_info
+ tvarset, % from the pred_info
map(tvar, type_info_locn),
% from the proc_info
% (typeinfos)
+ pred_markers, % from the pred_info
map(class_constraint, var),
% from the proc_info
% (typeclass_infos)
pred_or_func,
string, % pred/func name
+ string, % Aditi owner
module_info
).
@@ -127,7 +130,9 @@
pred_info_name(PredInfo0, PredName),
pred_info_get_is_pred_or_func(PredInfo0, PredOrFunc),
pred_info_typevarset(PredInfo0, TypeVarSet0),
+ pred_info_get_markers(PredInfo0, Markers),
pred_info_get_class_context(PredInfo0, Constraints0),
+ pred_info_get_aditi_owner(PredInfo0, Owner),
proc_info_varset(ProcInfo0, VarSet0),
proc_info_vartypes(ProcInfo0, VarTypes0),
proc_info_goal(ProcInfo0, Goal0),
@@ -136,10 +141,11 @@
% process the goal
Info0 = lambda_info(VarSet0, VarTypes0, Constraints0, TypeVarSet0,
- TVarMap0, TCVarMap0, PredOrFunc, PredName, ModuleInfo0),
+ TVarMap0, Markers, TCVarMap0, PredOrFunc,
+ PredName, Owner, ModuleInfo0),
lambda__process_goal(Goal0, Goal, Info0, Info),
Info = lambda_info(VarSet, VarTypes, Constraints, TypeVarSet,
- TVarMap, TCVarMap, _, _, ModuleInfo),
+ TVarMap, _, TCVarMap, _, _, _, ModuleInfo),
% set the new values of the fields in proc_info and pred_info
proc_info_set_goal(ProcInfo0, Goal, ProcInfo1),
@@ -240,20 +246,21 @@
lambda__process_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals0, LambdaGoal,
Unification0, Functor, Unification, LambdaInfo0, LambdaInfo) :-
LambdaInfo0 = lambda_info(VarSet, VarTypes, Constraints, TVarSet,
- TVarMap, TCVarMap, POF, PredName, ModuleInfo0),
+ TVarMap, Markers, TCVarMap, POF, PredName, Owner, ModuleInfo0),
goal_util__extra_nonlocal_typeinfos(TVarMap, VarTypes,
LambdaGoal, ExtraTypeInfos),
lambda__transform_lambda(PredOrFunc, PredName, Vars, Modes, Det,
OrigNonLocals0, ExtraTypeInfos, LambdaGoal, Unification0,
- VarSet, VarTypes, Constraints, TVarSet, TVarMap, TCVarMap,
- ModuleInfo0, Functor, Unification, ModuleInfo),
+ VarSet, VarTypes, Constraints, TVarSet, TVarMap, Markers,
+ TCVarMap, Owner, ModuleInfo0, Functor, Unification, ModuleInfo),
LambdaInfo = lambda_info(VarSet, VarTypes, Constraints, TVarSet,
- TVarMap, TCVarMap, POF, PredName, ModuleInfo).
+ TVarMap, Markers, TCVarMap, POF, PredName, Owner, ModuleInfo).
lambda__transform_lambda(PredOrFunc, OrigPredName, Vars, Modes, Detism,
OrigVars, ExtraTypeInfos, LambdaGoal, Unification0,
- VarSet, VarTypes, Constraints, TVarSet, TVarMap, TCVarMap,
- ModuleInfo0, Functor, Unification, ModuleInfo) :-
+ VarSet, VarTypes, Constraints, TVarSet, TVarMap, Markers,
+ TCVarMap, Owner, ModuleInfo0, Functor,
+ Unification, ModuleInfo) :-
(
Unification0 = construct(Var0, _, _, UniModes0)
->
@@ -385,6 +392,17 @@
list__append(ArgModes1, Modes, AllArgModes),
map__apply_to_list(AllArgVars, VarTypes, ArgTypes),
+ (
+ % Pass through the aditi markers for
+ % aggregate query closures.
+ Detism = nondet,
+ check_marker(Markers, aditi)
+ ->
+ LambdaMarkers = Markers
+ ;
+ init_markers(LambdaMarkers)
+ ),
+
% Choose an args_method which is always directly callable
% from do_call_*_closure even if the inputs don't preceed
% the outputs in the declaration. mercury_ho_call.c requires
@@ -404,10 +422,9 @@
AllArgModes, Detism, LambdaGoal, LambdaContext,
TVarMap, TCVarMap, ArgsMethod, ProcInfo),
- init_markers(Markers),
pred_info_create(ModuleName, PredName, TVarSet, ArgTypes,
- true, LambdaContext, local, Markers, PredOrFunc,
- Constraints, ProcInfo, ProcId, PredInfo),
+ true, LambdaContext, local, LambdaMarkers, PredOrFunc,
+ Constraints, Owner, ProcInfo, ProcId, PredInfo),
% save the new predicate in the predicate table
Index: compiler/livemap.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/livemap.m,v
retrieving revision 1.35
diff -u -t -u -r1.35 livemap.m
--- livemap.m 1998/06/09 02:13:13 1.35
+++ livemap.m 1998/06/19 01:48:01
@@ -406,6 +406,9 @@
livemap__special_code_addr(do_det_class_method, no).
livemap__special_code_addr(do_semidet_class_method, no).
livemap__special_code_addr(do_nondet_class_method, no).
+livemap__special_code_addr(do_det_aditi_call, no).
+livemap__special_code_addr(do_semidet_aditi_call, no).
+livemap__special_code_addr(do_nondet_aditi_call, no).
livemap__special_code_addr(do_not_reached, no).
%-----------------------------------------------------------------------------%
Index: compiler/llds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/llds.m,v
retrieving revision 1.225
diff -u -t -u -r1.225 llds.m
--- llds.m 1998/06/09 02:13:21 1.225
+++ llds.m 1998/06/19 01:41:22
@@ -689,6 +689,9 @@
; do_det_class_method
; do_semidet_class_method
; do_nondet_class_method
+ ; do_det_aditi_call
+ ; do_semidet_aditi_call
+ ; do_nondet_aditi_call
; do_not_reached. % we should never jump to this address
% A proc_label is a label used for the entry point to a procedure.
Index: compiler/llds_out.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/llds_out.m,v
retrieving revision 1.84
diff -u -t -u -r1.84 llds_out.m
--- llds_out.m 1998/06/18 06:06:32 1.84
+++ llds_out.m 1998/07/07 01:25:18
@@ -17,8 +17,8 @@
:- interface.
-:- import_module llds, prog_data, hlds_data.
-:- import_module set_bbbtree, bool, io.
+:- import_module llds, prog_data, hlds_data, rl_file.
+:- import_module set_bbbtree, bool, io, std_util.
% Given a 'c_file' structure, open the appropriate .c file
% and output the code into that file. The bool says whether
@@ -26,8 +26,9 @@
% tracing; the third argument gives the set of labels that have
% layout structures.
-:- pred output_c_file(c_file, set_bbbtree(label), io__state, io__state).
-:- mode output_c_file(in, in, di, uo) is det.
+:- pred output_c_file(c_file, set_bbbtree(label), maybe(rl_file),
+ io__state, io__state).
+:- mode output_c_file(in, in, in, di, uo) is det.
% Convert an lval to a string description of that lval.
@@ -112,6 +113,12 @@
:- pred llds_out__make_init_name(module_name, string).
:- mode llds_out__make_init_name(in, out) is det.
+ % Returns the name of the Aditi-RL code constant
+ % for a given module.
+
+:- pred llds_out__make_rl_data_name(module_name, string).
+:- mode llds_out__make_rl_data_name(in, out) is det.
+
%-----------------------------------------------------------------------------%
:- implementation.
@@ -120,7 +127,7 @@
:- import_module exprn_aux, prog_util, prog_out, hlds_pred.
:- import_module export, mercury_to_mercury, modules.
-:- import_module int, list, char, string, std_util, term, varset.
+:- import_module int, list, char, string, term, varset.
:- import_module set, bintree_set, assoc_list, require.
:- import_module library. % for the version number.
@@ -138,17 +145,19 @@
; data_addr(data_addr)
; pragma_c_struct(string).
-output_c_file(C_File, StackLayoutLabels) -->
+output_c_file(C_File, StackLayoutLabels, MaybeRLFile) -->
globals__io_lookup_bool_option(split_c_files, SplitFiles),
( { SplitFiles = yes } ->
{ C_File = c_file(ModuleName, C_HeaderInfo, C_Modules) },
module_name_to_file_name(ModuleName, ".dir", yes, ObjDirName),
make_directory(ObjDirName),
- output_c_file_init(ModuleName, C_Modules),
+ output_c_file_init(ModuleName, C_Modules, MaybeRLFile),
output_c_file_list(C_Modules, 1, ModuleName,
- C_HeaderInfo, StackLayoutLabels)
+ C_HeaderInfo, StackLayoutLabels),
+ output_rl_file(ModuleName, MaybeRLFile)
;
- output_single_c_file(C_File, no, StackLayoutLabels)
+ output_single_c_file(C_File, no,
+ StackLayoutLabels, MaybeRLFile)
).
:- pred make_directory(string, io__state, io__state).
@@ -167,15 +176,16 @@
output_c_file_list([Module|Modules], Num, ModuleName, C_HeaderLines,
StackLayoutLabels) -->
output_single_c_file(c_file(ModuleName, C_HeaderLines, [Module]),
- yes(Num), StackLayoutLabels),
+ yes(Num), StackLayoutLabels, no),
{ Num1 is Num + 1 },
output_c_file_list(Modules, Num1, ModuleName, C_HeaderLines,
StackLayoutLabels).
-:- pred output_c_file_init(module_name, list(c_module), io__state, io__state).
-:- mode output_c_file_init(in, in, di, uo) is det.
+:- pred output_c_file_init(module_name, list(c_module), maybe(rl_file),
+ io__state, io__state).
+:- mode output_c_file_init(in, in, in, di, uo) is det.
-output_c_file_init(ModuleName, C_Modules) -->
+output_c_file_init(ModuleName, C_Modules, MaybeRLFile) -->
module_name_to_file_name(ModuleName, ".m", no, SourceFileName),
module_name_to_split_c_file_name(ModuleName, 0, ".c", FileName),
@@ -191,15 +201,12 @@
"** version ", Version, ".\n",
"** Do not edit.\n",
"*/\n"]),
- io__write_string("/*\n"),
- io__write_string("INIT "),
- output_init_name(ModuleName),
- io__write_string("\n"),
- io__write_string("ENDINIT\n"),
- io__write_string("*/\n\n"),
+
+ output_init_comment(ModuleName),
output_c_file_mercury_headers,
io__write_string("\n"),
output_c_module_init_list(ModuleName, C_Modules),
+ output_rl_file(ModuleName, MaybeRLFile),
io__told
;
io__progname_base("llds.m", ProgName),
@@ -225,11 +232,11 @@
).
:- pred output_single_c_file(c_file, maybe(int), set_bbbtree(label),
- io__state, io__state).
-:- mode output_single_c_file(in, in, in, di, uo) is det.
+ maybe(rl_file), io__state, io__state).
+:- mode output_single_c_file(in, in, in, in, di, uo) is det.
output_single_c_file(c_file(ModuleName, C_HeaderLines, Modules), SplitFiles,
- StackLayoutLabels) -->
+ StackLayoutLabels, MaybeRLFile) -->
( { SplitFiles = yes(Num) } ->
module_name_to_split_c_file_name(ModuleName, Num, ".c",
FileName)
@@ -252,12 +259,7 @@
( { SplitFiles = yes(_) } ->
[]
;
- io__write_string("/*\n"),
- io__write_string("INIT "),
- output_init_name(ModuleName),
- io__write_string("\n"),
- io__write_string("ENDINIT\n"),
- io__write_string("*/\n\n")
+ output_init_comment(ModuleName)
),
output_c_file_mercury_headers,
output_c_header_include_lines(C_HeaderLines),
@@ -270,7 +272,8 @@
[]
;
io__write_string("\n"),
- output_c_module_init_list(ModuleName, Modules)
+ output_c_module_init_list(ModuleName, Modules),
+ output_rl_file(ModuleName, MaybeRLFile)
),
io__told
;
@@ -422,6 +425,28 @@
),
output_c_data_init_list(Ms).
+ % Output a comment to tell mkinit what functions to
+ % call from <module>_init.c.
+:- pred output_init_comment(module_name, io__state, io__state).
+:- mode output_init_comment(in, di, uo) is det.
+
+output_init_comment(ModuleName) -->
+ io__write_string("/*\n"),
+ io__write_string("INIT "),
+ output_init_name(ModuleName),
+ io__write_string("\n"),
+ globals__io_lookup_bool_option(aditi, Aditi),
+ ( { Aditi = yes } ->
+ { llds_out__make_rl_data_name(ModuleName, RLName) },
+ io__write_string("ADITI_DATA "),
+ io__write_string(RLName),
+ io__write_string("\n")
+ ;
+ []
+ ),
+ io__write_string("ENDINIT\n"),
+ io__write_string("*/\n\n").
+
:- pred output_init_name(module_name, io__state, io__state).
:- mode output_init_name(in, di, uo) is det.
@@ -434,6 +459,11 @@
string__append_list(["mercury__", MangledModuleName, "__init"],
InitName).
+llds_out__make_rl_data_name(ModuleName, RLDataConstName) :-
+ llds_out__sym_name_mangle(ModuleName, MangledModuleName),
+ string__append("mercury__aditi_rl_data__", MangledModuleName,
+ RLDataConstName).
+
:- pred output_bunch_name(module_name, int, io__state, io__state).
:- mode output_bunch_name(in, in, di, uo) is det.
@@ -2035,6 +2065,9 @@
need_code_addr_decls(do_det_class_method, yes) --> [].
need_code_addr_decls(do_semidet_class_method, yes) --> [].
need_code_addr_decls(do_nondet_class_method, yes) --> [].
+need_code_addr_decls(do_det_aditi_call, yes) --> [].
+need_code_addr_decls(do_semidet_aditi_call, yes) --> [].
+need_code_addr_decls(do_nondet_aditi_call, yes) --> [].
need_code_addr_decls(do_not_reached, yes) --> [].
:- pred output_code_addr_decls(code_addr, io__state, io__state).
@@ -2080,6 +2113,12 @@
io__write_string("Declare_entry(do_call_semidet_class_method);\n").
output_code_addr_decls(do_nondet_class_method) -->
io__write_string("Declare_entry(do_call_nondet_class_method);\n").
+output_code_addr_decls(do_det_aditi_call) -->
+ io__write_string("Declare_entry(do_det_aditi_call);\n").
+output_code_addr_decls(do_semidet_aditi_call) -->
+ io__write_string("Declare_entry(do_semidet_aditi_call);\n").
+output_code_addr_decls(do_nondet_aditi_call) -->
+ io__write_string("Declare_entry(do_nondet_aditi_call);\n").
output_code_addr_decls(do_not_reached) -->
io__write_string("Declare_entry(do_not_reached);\n").
@@ -2255,6 +2294,18 @@
io__write_string("tailcall(ENTRY(do_call_nondet_class_method),\n\t\t"),
output_label_as_code_addr(CallerLabel),
io__write_string(");\n").
+output_goto(do_det_aditi_call, CallerLabel) -->
+ io__write_string("tailcall(ENTRY(do_det_aditi_call),\n\t\t"),
+ output_label_as_code_addr(CallerLabel),
+ io__write_string(");\n").
+output_goto(do_semidet_aditi_call, CallerLabel) -->
+ io__write_string("tailcall(ENTRY(do_semidet_aditi_call),\n\t\t"),
+ output_label_as_code_addr(CallerLabel),
+ io__write_string(");\n").
+output_goto(do_nondet_aditi_call, CallerLabel) -->
+ io__write_string("tailcall(ENTRY(do_nondet_aditi_call),\n\t\t"),
+ output_label_as_code_addr(CallerLabel),
+ io__write_string(");\n").
output_goto(do_not_reached, CallerLabel) -->
io__write_string("tailcall(ENTRY(do_not_reached),\n\t\t"),
output_label_as_code_addr(CallerLabel),
@@ -2332,6 +2383,12 @@
io__write_string("ENTRY(do_call_semidet_class_method)").
output_code_addr(do_nondet_class_method) -->
io__write_string("ENTRY(do_call_nondet_class_method)").
+output_code_addr(do_det_aditi_call) -->
+ io__write_string("ENTRY(do_det_aditi_call)").
+output_code_addr(do_semidet_aditi_call) -->
+ io__write_string("ENTRY(do_semidet_aditi_call)").
+output_code_addr(do_nondet_aditi_call) -->
+ io__write_string("ENTRY(do_nondet_aditi_call)").
output_code_addr(do_not_reached) -->
io__write_string("ENTRY(do_not_reached)").
@@ -3377,5 +3434,52 @@
Labels1 = Labels0
),
gather_labels_from_instrs(Instrs, Labels1, Labels).
+
+%-----------------------------------------------------------------------------%
+
+ % Currently the `.rlo' files are stored as static data in the
+ % executable. It may be better to store them in separate files
+ % in a known location and load them at runtime.
+:- pred output_rl_file(module_name, maybe(rl_file), io__state, io__state).
+:- mode output_rl_file(in, in, di, uo) is det.
+
+output_rl_file(ModuleName, MaybeRLFile) -->
+ globals__io_lookup_bool_option(aditi, Aditi),
+ ( { Aditi = no } ->
+ []
+ ;
+ io__write_string("\n\n/* Aditi-RL code for this module. */\n"),
+ { llds_out__make_rl_data_name(ModuleName, RLDataConstName) },
+ io__write_string("const char "),
+ io__write_string(RLDataConstName),
+ io__write_string("[] = {"),
+ (
+ { MaybeRLFile = yes(RLFile) },
+ rl_file__write_binary(output_rl_byte, RLFile, Length),
+ io__write_string("0};\n")
+ ;
+ { MaybeRLFile = no },
+ io__write_string("};\n"),
+ { Length = 0 }
+ ),
+
+ % Store the length of the data in
+ % mercury__aditi_rl_data__<module>__length.
+
+ { string__append(RLDataConstName, "__length",
+ RLDataConstLength) },
+ io__write_string("const int "),
+ io__write_string(RLDataConstLength),
+ io__write_string(" = "),
+ io__write_int(Length),
+ io__write_string(";\n\n")
+ ).
+
+:- pred output_rl_byte(int, io__state, io__state).
+:- mode output_rl_byte(in, di, uo) is det.
+
+output_rl_byte(Byte) -->
+ io__write_int(Byte),
+ io__write_string(", ").
%-----------------------------------------------------------------------------%
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/make_hlds.m,v
retrieving revision 1.268
diff -u -t -u -r1.268 make_hlds.m
--- make_hlds.m 1998/06/21 08:24:02 1.268
+++ make_hlds.m 1998/07/07 01:23:19
@@ -206,14 +206,16 @@
add_item_decl_pass_1(pred_mode(VarSet, PredName, Modes, MaybeDet, Cond),
Context, Status, Module0, Status, Module) -->
+ { Status = item_status(ImportStatus, _) },
module_add_mode(Module0, VarSet, PredName, Modes, MaybeDet, Cond,
- Context, predicate, _, Module).
+ ImportStatus, Context, predicate, _, Module).
add_item_decl_pass_1(func_mode(VarSet, FuncName, Modes, RetMode, MaybeDet,
Cond), Context, Status, Module0, Status, Module) -->
{ list__append(Modes, [RetMode], Modes1) },
+ { Status = item_status(ImportStatus, _) },
module_add_mode(Module0, VarSet, FuncName, Modes1,
- MaybeDet, Cond, Context, function, _, Module).
+ MaybeDet, Cond, ImportStatus, Context, function, _, Module).
add_item_decl_pass_1(pragma(_), _, Status, Module, Status, Module) --> [].
@@ -323,6 +325,14 @@
% clauses).
{ Pragma = c_code(_, _, _, _, _, _) },
{ Module = Module0 }
+ ;
+ { Pragma = memo(Name, Arity) },
+ add_pred_marker(Module0, "memo", Name, Arity, ImportStatus,
+ Context, memo, [], Module)
+ ;
+ { Pragma = no_memo(PredName, Arity) },
+ add_pred_marker(Module0, "no_memo", PredName, Arity,
+ ImportStatus, Context, no_memo, [memo], Module)
;
% Handle pragma tabled decls later on (when we process
% clauses).
@@ -330,16 +340,16 @@
{ Module = Module0 }
;
{ Pragma = inline(Name, Arity) },
- add_pred_marker(Module0, "inline", Name, Arity, Context,
- inline, [no_inline], Module)
+ add_pred_marker(Module0, "inline", Name, Arity, ImportStatus,
+ Context, inline, [no_inline], Module)
;
{ Pragma = no_inline(Name, Arity) },
- add_pred_marker(Module0, "no_inline", Name, Arity, Context,
- no_inline, [inline], Module)
+ add_pred_marker(Module0, "no_inline", Name, Arity,
+ ImportStatus, Context, no_inline, [inline], Module)
;
{ Pragma = obsolete(Name, Arity) },
- add_pred_marker(Module0, "obsolete", Name, Arity, Context,
- obsolete, [], Module)
+ add_pred_marker(Module0, "obsolete", Name, Arity, ImportStatus,
+ Context, obsolete, [], Module)
;
% Handle pragma import decls later on (when we process
% clauses and pragma c_code).
@@ -370,9 +380,47 @@
{ Pragma = fact_table(_, _, _) },
{ Module = Module0 }
;
+ { Pragma = aditi(PredName, Arity) },
+ maybe_enable_aditi_compilation(Status, Context,
+ Module0, Module1),
+ add_pred_marker(Module1, "aditi", PredName, Arity,
+ ImportStatus, Context, aditi, [], Module2),
+ add_stratified_pred(Module2, "aditi", PredName, Arity, Context,
+ Module)
+ ;
+ { Pragma = base_relation(PredName, Arity) },
+ maybe_enable_aditi_compilation(Status, Context,
+ Module0, Module1),
+ add_pred_marker(Module1, "aditi", PredName, Arity,
+ ImportStatus, Context, aditi, [], Module2),
+ add_pred_marker(Module2, "base_relation", PredName, Arity,
+ ImportStatus, Context, base_relation, [], Module3),
+ module_mark_as_external(PredName, Arity, Context,
+ Module3, Module)
+ ;
+ { Pragma = naive(PredName, Arity) },
+ add_pred_marker(Module0, "naive", PredName, Arity,
+ ImportStatus, Context, naive, [psn], Module)
+ ;
+ { Pragma = psn(PredName, Arity) },
+ add_pred_marker(Module0, "psn", PredName, Arity,
+ ImportStatus, Context, psn, [naive], Module)
+ ;
+ { Pragma = supp_magic(PredName, Arity) },
+ add_pred_marker(Module0, "supp_magic", PredName, Arity,
+ ImportStatus, Context, supp_magic, [context], Module)
+ ;
+ { Pragma = context(PredName, Arity) },
+ add_pred_marker(Module0, "context", PredName, Arity,
+ ImportStatus, Context, context, [supp_magic], Module)
+ ;
+ { Pragma = owner(PredName, Arity, Owner) },
+ set_pred_owner(Module0, PredName, Arity, Owner, ImportStatus,
+ Context, Module)
+ ;
{ Pragma = promise_pure(Name, Arity) },
- add_pred_marker(Module0, "promise_pure", Name, Arity, Context,
- promised_pure, [], Module)
+ add_pred_marker(Module0, "promise_pure", Name, Arity,
+ ImportStatus, Context, promised_pure, [], Module)
;
{ Pragma = termination_info(PredOrFunc, SymName, ModeList,
MaybeArgSizeInfo, MaybeTerminationInfo) },
@@ -382,17 +430,17 @@
;
{ Pragma = terminates(Name, Arity) },
add_pred_marker(Module0, "terminates", Name, Arity,
- Context, terminates,
+ ImportStatus, Context, terminates,
[check_termination, does_not_terminate], Module)
;
{ Pragma = does_not_terminate(Name, Arity) },
add_pred_marker(Module0, "does_not_terminate", Name, Arity,
- Context, does_not_terminate,
+ ImportStatus, Context, does_not_terminate,
[check_termination, terminates], Module)
;
{ Pragma = check_termination(Name, Arity) },
add_pred_marker(Module0, "check_termination", Name, Arity,
- Context, check_termination,
+ ImportStatus, Context, check_termination,
[terminates, does_not_terminate],
Module)
).
@@ -461,6 +509,40 @@
%-----------------------------------------------------------------------------%
+ % If there are local Aditi procedures enable Aditi compilation.
+:- pred maybe_enable_aditi_compilation(item_status, term__context,
+ module_info, module_info, io__state, io__state) is det.
+:- mode maybe_enable_aditi_compilation(in, in, in, out, di, uo) is det.
+
+maybe_enable_aditi_compilation(Status, Context, Module0, Module) -->
+ { Status = item_status(ItemStatus, _) },
+ ( { ItemStatus \= imported } ->
+ globals__io_lookup_bool_option(aditi, Aditi),
+ ( { Aditi = no } ->
+ prog_out__write_context(Context),
+ io__write_string("Error: compilation of Aditi procedures\n"),
+ prog_out__write_context(Context),
+ io__write_string(" requires the --aditi option.\n"),
+ io__set_exit_status(1),
+ { module_info_incr_errors(Module0, Module) }
+ ;
+ % There are local Aditi procedures - enable Aditi
+ % code generation.
+ globals__io_set_do_aditi_compilation,
+
+ % Set the option in the module_info's
+ % version of the globals.
+ { module_info_globals(Module0, Globals0) },
+ { globals__set_do_aditi_compilation(Globals0,
+ Globals) },
+ { module_info_set_globals(Module0, Globals, Module) }
+ )
+ ;
+ { Module = Module0 }
+ ).
+
+%-----------------------------------------------------------------------------%
+
% dispatch on the different types of items
:- pred add_item_clause(item, import_status, import_status, term__context,
@@ -532,7 +614,7 @@
{ TypeLayout = yes }
->
module_add_pragma_tabled(Type, Name, Arity, PredOrFunc,
- Mode, Context, Module0, Module)
+ Mode, Status, Context, Module0, Module)
;
{ module_info_incr_errors(Module0, Module) },
prog_out__write_context(Context),
@@ -719,53 +801,129 @@
%-----------------------------------------------------------------------------%
- % add_pred_marker(ModuleInfo0, PragmaName, Name, Arity, Context,
- % Marker, ConflictMarkers, ModuleInfo, IO0, IO)
+:- pred add_stratified_pred(module_info, string, sym_name, arity,
+ term__context, module_info, io__state, io__state).
+:- mode add_stratified_pred(in, in, in, in, in, out, di, uo) is det.
+
+add_stratified_pred(Module0, PragmaName, Name, Arity, Context, Module) -->
+ { module_info_get_predicate_table(Module0, PredTable0) },
+ (
+ { predicate_table_search_sym_arity(PredTable0, Name,
+ Arity, PredIds) }
+ ->
+ { module_info_stratified_preds(Module0, StratPredIds0) },
+ { set__insert_list(StratPredIds0, PredIds, StratPredIds) },
+ { module_info_set_stratified_preds(Module0, StratPredIds,
+ Module) }
+ ;
+ { string__append_list(
+ ["`:- pragma ", PragmaName, "' declaration"],
+ Description) },
+ undefined_pred_or_func_error(Name, Arity, Context,
+ Description),
+ { module_info_incr_errors(Module0, Module) }
+ ).
+
+%-----------------------------------------------------------------------------%
+
+ % add_pred_marker(ModuleInfo0, PragmaName, Name, Arity, Status,
+ % Context, Marker, ConflictMarkers, ModuleInfo, IO0, IO)
+ %
% Adds Marker to the marker list of the pred(s) with give Name and
% Arity, updating the ModuleInfo. If the named pred does not exist,
% or the pred already has a marker in ConflictMarkers, report
% an error.
:- pred add_pred_marker(module_info, string, sym_name, arity,
- term__context, marker, list(marker), module_info,
+ import_status, term__context, marker, list(marker), module_info,
io__state, io__state).
-:- mode add_pred_marker(in, in, in, in, in, in, in, out, di, uo) is det.
+:- mode add_pred_marker(in, in, in, in, in, in, in, in, out, di, uo) is det.
-add_pred_marker(Module0, PragmaName, Name, Arity, Context, Marker,
+add_pred_marker(Module0, PragmaName, Name, Arity, Status, Context, Marker,
ConflictMarkers, Module) -->
- { module_info_get_predicate_table(Module0, PredTable0) },
- % check that the pragma is module qualified.
- (
- { Name = unqualified(_) }
- ->
- { error("add_pred_marker: unqualified name") }
- ; % else if
- { predicate_table_search_sym_arity(PredTable0, Name,
- Arity, PredIds) }
- ->
+ ( { marker_must_be_exported(Marker) } ->
+ { MustBeExported = yes }
+ ;
+ { MustBeExported = no }
+ ),
+ do_add_pred_marker(Module0, PragmaName, Name, Arity, Status,
+ MustBeExported, Context, add_marker_pred_info(Marker),
+ Module1, PredIds),
+ { module_info_preds(Module1, Preds) },
+ { pragma_check_markers(Preds, PredIds, ConflictMarkers, Conflict) },
+ ( { Conflict = yes } ->
+ pragma_conflict_error(Name, Arity, Context,
+ PragmaName),
+ { module_info_incr_errors(Module1, Module) }
+ ;
+ { Module = Module1 }
+ ).
+
+:- pred set_pred_owner(module_info, sym_name, arity, string, import_status,
+ term__context, module_info, io__state, io__state).
+:- mode set_pred_owner(in, in, in, in, in, in, out, di, uo) is det.
+
+set_pred_owner(Module0, Name, Arity, Owner, Status, Context, Module) -->
+ { SetOwner =
+ lambda([PredInfo0::in, PredInfo::out] is det, (
+ pred_info_set_aditi_owner(PredInfo0, Owner, PredInfo)
+ )) },
+ do_add_pred_marker(Module0, "owner", Name, Arity, Status, yes, Context,
+ SetOwner, Module, _).
+
+:- type add_marker_pred_info == pred(pred_info, pred_info).
+:- inst add_marker_pred_info = (pred(in, out) is det).
+
+:- pred do_add_pred_marker(module_info, string, sym_name, arity,
+ import_status, bool, term__context, add_marker_pred_info,
+ module_info, list(pred_id), io__state, io__state).
+:- mode do_add_pred_marker(in, in, in, in, in, in, in,
+ in(add_marker_pred_info), out, out, di, uo) is det.
+
+do_add_pred_marker(Module0, PragmaName, Name, Arity, Status,
+ MustBeExported, Context, UpdatePredInfo, Module, PredIds) -->
+ ( { get_matching_pred_ids(Module0, Name, Arity, PredIds0) } ->
+ { PredIds = PredIds0 },
+ { module_info_get_predicate_table(Module0, PredTable0) },
{ predicate_table_get_preds(PredTable0, Preds0) },
- { pragma_add_marker(Preds0, PredIds, Marker, Preds) },
- { predicate_table_set_preds(PredTable0, Preds,
- PredTable) },
- { module_info_set_predicate_table(Module0, PredTable,
- Module1) },
- { pragma_check_markers(Preds, PredIds, ConflictMarkers,
- Conflict) },
+
+ { pragma_add_marker(Preds0, PredIds, UpdatePredInfo,
+ Status, MustBeExported, Preds, WrongStatus) },
(
- { Conflict = yes }
+ { WrongStatus = yes }
->
- pragma_conflict_error(Name, Arity, Context,
- PragmaName),
- { module_info_incr_errors(Module1, Module) }
+ pragma_status_error(Name, Arity, Context, PragmaName),
+ { module_info_incr_errors(Module0, Module1) }
;
- { Module = Module1 }
- )
+ { Module1 = Module0 }
+ ),
+
+ { predicate_table_set_preds(PredTable0, Preds,
+ PredTable) },
+ { module_info_set_predicate_table(Module1, PredTable,
+ Module) }
;
+ { PredIds = [] },
{ string__append_list(["`", PragmaName, "' pragma"],
Description) },
undefined_pred_or_func_error(Name, Arity, Context,
Description),
{ module_info_incr_errors(Module0, Module) }
).
+
+:- pred get_matching_pred_ids(module_info, sym_name, arity, list(pred_id)).
+:- mode get_matching_pred_ids(in, in, in, out) is semidet.
+
+get_matching_pred_ids(Module0, Name, Arity, PredIds) :-
+ module_info_get_predicate_table(Module0, PredTable0),
+ % check that the pragma is module qualified.
+ (
+ Name = unqualified(_)
+ ->
+ error("get_matching_pred_ids: unqualified name")
+ ;
+ predicate_table_search_sym_arity(PredTable0, Name,
+ Arity, PredIds)
+ ).
%-----------------------------------------------------------------------------%
@@ -1232,7 +1390,7 @@
{ MaybeModes = yes(Modes) }
->
module_add_mode(Module1, VarSet, PredName, Modes, MaybeDet,
- Cond, Context, predicate, PredProcId, Module),
+ Cond, Status, Context, predicate, PredProcId, Module),
{ MaybePredProcId = yes(PredProcId) }
;
{ Module = Module1 },
@@ -1268,7 +1426,8 @@
->
{ list__append(Modes, [RetMode], Modes1) },
module_add_mode(Module1, VarSet, FuncName, Modes1,
- MaybeDet, Cond, Context, function, PredProcId, Module),
+ MaybeDet, Cond, Status, Context, function,
+ PredProcId, Module),
{ MaybePredProcId = yes(PredProcId) }
;
{ Module = Module1 },
@@ -1392,16 +1551,19 @@
;
{ Method = pred_mode(VarSet, PredName, Modes, MaybeDet,
Cond, Context) },
+ { Status = item_status(ImportStatus, _) },
module_add_mode(Module0, VarSet, PredName, Modes, MaybeDet,
- Cond, Context, predicate, PredIdProcId, Module),
+ Cond, ImportStatus, Context, predicate,
+ PredIdProcId, Module),
{ MaybePredIdProcId = yes(PredIdProcId) }
;
{ Method = func_mode(VarSet, FuncName, Modes, RetMode, MaybeDet,
Cond, Context) },
{ list__append(Modes, [RetMode], Modes1) },
+ { Status = item_status(ImportStatus, _) },
module_add_mode(Module0, VarSet, FuncName, Modes1,
- MaybeDet, Cond, Context, function, PredIdProcId,
- Module),
+ MaybeDet, Cond, ImportStatus, Context, function,
+ PredIdProcId, Module),
{ MaybePredIdProcId = yes(PredIdProcId) }
).
@@ -1532,10 +1694,11 @@
add_marker(TheMarkers0, M, TheMarkers)
)) },
{ list__foldl(AddMarker, MarkersList, Markers0, Markers) },
+ globals__io_lookup_string_option(aditi_user, Owner),
{ pred_info_init(ModuleName, PredName, Arity, TVarSet, Types,
Cond, Context, ClausesInfo, Status, Markers,
none, PredOrFunc, ClassContext, Proofs,
- PredInfo0) },
+ Owner, PredInfo0) },
(
{ predicate_table_search_pf_m_n_a(PredicateTable0,
PredOrFunc, MNameOfPred, PName, Arity,
@@ -1718,11 +1881,12 @@
% XXX If/when we have "comparable" or "unifiable" typeclasses,
% XXX this context might not be empty
ClassContext = [],
+ module_info_globals(Module0, Globals),
+ globals__lookup_string_option(Globals, aditi_user, Owner),
pred_info_init(ModuleName, PredName, Arity, TVarSet, ArgTypes, Cond,
Context, ClausesInfo0, Status, Markers, none, predicate,
- ClassContext, Proofs, PredInfo0),
+ ClassContext, Proofs, Owner, PredInfo0),
ArgLives = no,
- module_info_globals(Module0, Globals),
globals__get_args_method(Globals, ArgsMethod),
add_new_proc(PredInfo0, Arity, ArgModes, yes(ArgModes),
ArgLives, yes(Det), Context, ArgsMethod, PredInfo, _),
@@ -1778,17 +1942,17 @@
% Add a mode declaration for a predicate.
:- pred module_add_mode(module_info, varset, sym_name, list(mode),
- maybe(determinism), condition, term__context, pred_or_func,
- pair(pred_id, proc_id), module_info,
+ maybe(determinism), condition, import_status, term__context,
+ pred_or_func, pair(pred_id, proc_id), module_info,
io__state, io__state).
-:- mode module_add_mode(in, in, in, in, in, in, in, in, out, out,
+:- mode module_add_mode(in, in, in, in, in, in, in, in, in, out, out,
di, uo) is det.
% We should store the mode varset and the mode condition
% in the hlds - at the moment we just ignore those two arguments.
module_add_mode(ModuleInfo0, _VarSet, PredName, Modes, MaybeDet, _Cond,
- MContext, PredOrFunc, PredProcId, ModuleInfo) -->
+ Status, MContext, PredOrFunc, PredProcId, ModuleInfo) -->
% Lookup the pred or func declaration in the predicate table.
% If it's not there (or if it is ambiguous), optionally print a
@@ -1810,9 +1974,9 @@
;
maybe_undefined_pred_error(PredName, Arity, PredOrFunc,
MContext, "mode declaration"),
- { preds_add_implicit(PredicateTable0,
- ModuleName, PredName, Arity, MContext,
- PredOrFunc,
+ { preds_add_implicit(ModuleInfo0, PredicateTable0,
+ ModuleName, PredName, Arity, Status,
+ MContext, PredOrFunc,
PredId, PredicateTable1) }
),
@@ -1859,14 +2023,13 @@
% for that predicate; the real types will be inferred by
% type inference.
-:- pred preds_add_implicit(predicate_table, module_name, sym_name, arity,
- term__context, pred_or_func,
- pred_id, predicate_table).
-:- mode preds_add_implicit(in, in, in, in, in, in, out, out) is det.
-
-preds_add_implicit(PredicateTable0,
- ModuleName, PredName, Arity, Context, PredOrFunc,
- PredId, PredicateTable) :-
+:- pred preds_add_implicit(module_info, predicate_table, module_name,
+ sym_name, arity, import_status, term__context,
+ pred_or_func, pred_id, predicate_table).
+:- mode preds_add_implicit(in, in, in, in, in, in, in, in, out, out) is det.
+
+preds_add_implicit(ModuleInfo, PredicateTable0, ModuleName, PredName, Arity,
+ Status, Context, PredOrFunc, PredId, PredicateTable) :-
varset__init(TVarSet0),
make_n_fresh_vars("T", Arity, TVarSet0, TypeVars, TVarSet),
term__var_list_to_term_list(TypeVars, Types),
@@ -1877,9 +2040,11 @@
% definition. Inference will fill it in.
ClassContext = [],
init_markers(Markers0),
+ module_info_globals(ModuleInfo, Globals),
+ globals__lookup_string_option(Globals, aditi_user, Owner),
pred_info_init(ModuleName, PredName, Arity, TVarSet, Types, Cond,
- Context, ClausesInfo, local, Markers0, none, PredOrFunc,
- ClassContext, Proofs, PredInfo0),
+ Context, ClausesInfo, Status, Markers0, none, PredOrFunc,
+ ClassContext, Proofs, Owner, PredInfo0),
add_marker(Markers0, infer_type, Markers),
pred_info_set_markers(PredInfo0, Markers, PredInfo),
(
@@ -1971,8 +2136,8 @@
maybe_undefined_pred_error(PredName, Arity, PredOrFunc,
Context, "clause"),
- { preds_add_implicit(PredicateTable0,
- ModuleName, PredName, Arity, Context,
+ { preds_add_implicit(ModuleInfo0, PredicateTable0,
+ ModuleName, PredName, Arity, Status, Context,
PredOrFunc,
PredId, PredicateTable1) }
),
@@ -2127,8 +2292,8 @@
;
maybe_undefined_pred_error(PredName, Arity, PredOrFunc,
Context, "`:- pragma import' declaration"),
- { preds_add_implicit(PredicateTable0,
- ModuleName, PredName, Arity, Context,
+ { preds_add_implicit(ModuleInfo0, PredicateTable0,
+ ModuleName, PredName, Arity, Status, Context,
PredOrFunc, PredId, PredicateTable1) }
),
%
@@ -2431,8 +2596,8 @@
;
maybe_undefined_pred_error(PredName, Arity, PredOrFunc,
Context, "`:- pragma c_code' declaration"),
- { preds_add_implicit(PredicateTable0,
- ModuleName, PredName, Arity, Context,
+ { preds_add_implicit(ModuleInfo0, PredicateTable0,
+ ModuleName, PredName, Arity, Status, Context,
PredOrFunc, PredId, PredicateTable1) }
),
% Lookup the pred_info for this pred,
@@ -2518,13 +2683,13 @@
:- pred module_add_pragma_tabled(eval_method, sym_name, int,
maybe(pred_or_func), maybe(list(mode)),
- term__context, module_info, module_info,
+ import_status, term__context, module_info, module_info,
io__state, io__state).
-:- mode module_add_pragma_tabled(in, in, in, in, in, in, in, out,
+:- mode module_add_pragma_tabled(in, in, in, in, in, in, in, in, out,
di, uo) is det.
module_add_pragma_tabled(EvalMethod, PredName, Arity, MaybePredOrFunc,
- MaybeModes, Context, ModuleInfo0, ModuleInfo) -->
+ MaybeModes, Status, Context, ModuleInfo0, ModuleInfo) -->
{ module_info_get_predicate_table(ModuleInfo0, PredicateTable0) },
{ eval_method_to_string(EvalMethod, EvalMethodS) },
@@ -2549,8 +2714,8 @@
Message1) },
maybe_undefined_pred_error(PredName, Arity,
PredOrFunc, Context, Message1),
- { preds_add_implicit(PredicateTable0,
- ModuleName, PredName, Arity, Context,
+ { preds_add_implicit(ModuleInfo0, PredicateTable0,
+ ModuleName, PredName, Arity, Status, Context,
PredOrFunc, PredId, PredicateTable1) },
{ module_info_set_predicate_table(ModuleInfo0,
PredicateTable1, ModuleInfo1) },
@@ -2569,8 +2734,8 @@
Message1) },
maybe_undefined_pred_error(PredName, Arity,
predicate, Context, Message1),
- { preds_add_implicit(PredicateTable0,
- ModuleName, PredName, Arity, Context,
+ { preds_add_implicit(ModuleInfo0, PredicateTable0,
+ ModuleName, PredName, Arity, Status, Context,
predicate, PredId, PredicateTable1) },
{ module_info_set_predicate_table(ModuleInfo0,
PredicateTable1, ModuleInfo1) },
@@ -2766,17 +2931,45 @@
% For each pred_id in the list, add the given markers to the
% list of markers in the corresponding pred_info.
-:- pred pragma_add_marker(pred_table, list(pred_id), marker, pred_table).
-:- mode pragma_add_marker(in, in, in, out) is det.
-
-pragma_add_marker(PredTable, [], _, PredTable).
-pragma_add_marker(PredTable0, [PredId | PredIds], Marker, PredTable) :-
+:- pred pragma_add_marker(pred_table, list(pred_id), add_marker_pred_info,
+ import_status, bool, pred_table, bool).
+:- mode pragma_add_marker(in, in, in(add_marker_pred_info),
+ in, in, out, out) is det.
+
+pragma_add_marker(PredTable, [], _, _, _, PredTable, no).
+pragma_add_marker(PredTable0, [PredId | PredIds], UpdatePredInfo, Status,
+ MustBeExported, PredTable, WrongStatus) :-
map__lookup(PredTable0, PredId, PredInfo0),
+ call(UpdatePredInfo, PredInfo0, PredInfo),
+ (
+ pred_info_is_exported(PredInfo),
+ MustBeExported = yes,
+ Status \= exported
+ ->
+ WrongStatus0 = yes
+ ;
+ WrongStatus0 = no
+ ),
+ map__det_update(PredTable0, PredId, PredInfo, PredTable1),
+ pragma_add_marker(PredTable1, PredIds, UpdatePredInfo, Status,
+ MustBeExported, PredTable, WrongStatus1),
+ bool__or(WrongStatus0, WrongStatus1, WrongStatus).
+
+:- pred add_marker_pred_info(marker, pred_info, pred_info).
+:- mode add_marker_pred_info(in, in, out) is det.
+
+add_marker_pred_info(Marker, PredInfo0, PredInfo) :-
pred_info_get_markers(PredInfo0, Markers0),
add_marker(Markers0, Marker, Markers),
- pred_info_set_markers(PredInfo0, Markers, PredInfo),
- map__det_update(PredTable0, PredId, PredInfo, PredTable1),
- pragma_add_marker(PredTable1, PredIds, Marker, PredTable).
+ pred_info_set_markers(PredInfo0, Markers, PredInfo).
+
+ % Succeed if a marker for an exported procedure must also
+ % be exported.
+:- pred marker_must_be_exported(marker).
+:- mode marker_must_be_exported(in) is semidet.
+
+marker_must_be_exported(aditi).
+marker_must_be_exported(base_relation).
%---------------------------------------------------------------------------%
@@ -4561,6 +4754,21 @@
io__write_string("'.\n"),
prog_out__write_context(Context),
io__write_string(" should have been qualified by prog_io.m.\n").
+
+:- pred pragma_status_error(sym_name, int, term__context, string,
+ io__state, io__state).
+:- mode pragma_status_error(in, in, in, in, di, uo) is det.
+
+pragma_status_error(Name, Arity, Context, PragmaName) -->
+ io__set_exit_status(1),
+ prog_out__write_context(Context),
+ io__write_string("Error: `:- pragma "),
+ io__write_string(PragmaName),
+ io__write_string("' declaration for exported\n"),
+ prog_out__write_context(Context),
+ io__write_string("predicate or function "),
+ hlds_out__write_pred_call_id(Name/Arity),
+ io__write_string(" must also be exported.\n").
:- pred pragma_conflict_error(sym_name, int, term__context, string,
io__state, io__state).
More information about the developers
mailing list