for review: Aditi [3]
Simon Taylor
stayl at cs.mu.OZ.AU
Tue Jul 7 13:43:38 AEST 1998
Index: compiler/mercury_compile.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_compile.m,v
retrieving revision 1.102
diff -u -t -u -r1.102 mercury_compile.m
--- mercury_compile.m 1998/07/03 02:34:17 1.102
+++ mercury_compile.m 1998/07/07 00:24:21
@@ -36,16 +36,17 @@
:- import_module table_gen.
:- import_module bytecode_gen, bytecode.
:- import_module (lambda), polymorphism, termination, higher_order, inlining.
-:- import_module deforest, dnf, constraint, unused_args, dead_proc_elim.
+:- import_module deforest, dnf, constraint, unused_args, magic, dead_proc_elim.
:- import_module lco, saved_vars, liveness.
:- import_module follow_code, live_vars, arg_info, store_alloc, goal_path.
:- import_module code_gen, optimize, export, base_type_info, base_type_layout.
:- import_module llds_common, llds_out, continuation_info, stack_layout.
+:- import_module rl_gen, rl_opt, rl_out.
% miscellaneous compiler modules
-:- import_module prog_data, hlds_module, hlds_pred, hlds_out, llds.
+:- import_module prog_data, hlds_module, hlds_pred, hlds_out, llds, rl.
:- import_module mercury_to_c, mercury_to_mercury, mercury_to_goedel.
-:- import_module dependency_graph, prog_util.
+:- import_module dependency_graph, prog_util, rl_dump, rl_file.
:- import_module options, globals, passes_aux.
%-----------------------------------------------------------------------------%
@@ -68,7 +69,13 @@
; { Args = [] } ->
usage
;
- process_arg_list(Args, ModulesToLink),
+ globals__io_lookup_bool_option(filenames_from_stdin,
+ FileNamesFromStdin),
+ ( { FileNamesFromStdin = yes } ->
+ process_stdin_arg_list([], ModulesToLink)
+ ;
+ process_arg_list(Args, ModulesToLink)
+ ),
io__get_exit_status(ExitStatus),
( { ExitStatus = 0 } ->
( { Link = yes } ->
@@ -105,6 +112,30 @@
process_arg_list_2(Args, ModulesList),
{ list__condense(ModulesList, Modules) }.
+:- pred process_stdin_arg_list(list(string), list(string),
+ io__state, io__state).
+:- mode process_stdin_arg_list(in, out, di, uo) is det.
+
+process_stdin_arg_list(Modules0, Modules) -->
+ io__read_line(FileResult),
+ (
+ { FileResult = ok(Arg0) },
+ { string__from_char_list(Arg0, Arg) },
+ process_arg(Arg, Module), !,
+ { list__append(Module, Modules0, Modules1) },
+ process_stdin_arg_list(Modules1, Modules)
+ ;
+ { FileResult = eof },
+ { Modules = Modules0 }
+ ;
+ { FileResult = error(Error) },
+ { io__error_message(Error, Msg) },
+ io__write_string("Error reading module name: "),
+ io__write_string(Msg),
+ { Modules = Modules0 },
+ io__set_exit_status(1)
+ ).
+
:- pred process_arg_list_2(list(string), list(list(string)),
io__state, io__state).
:- mode process_arg_list_2(in, out, di, uo) is det.
@@ -337,6 +368,7 @@
globals__io_lookup_bool_option(statistics, Stats),
mercury_compile__maybe_write_dependency_graph(HLDS20,
Verbose, Stats, HLDS21),
+ mercury_compile__maybe_generate_schemas(HLDS21, Verbose),
globals__io_lookup_bool_option(make_optimization_interface,
MakeOptInt),
globals__io_lookup_bool_option(make_transitive_opt_interface,
@@ -369,10 +401,24 @@
Verbose, Stats, HLDS25),
mercury_compile__middle_pass(ModuleName, HLDS25, HLDS50), !,
globals__io_lookup_bool_option(highlevel_c, HighLevelC),
- ( { HighLevelC = yes } ->
+ globals__io_get_do_aditi_compilation(Aditi),
+ globals__io_lookup_bool_option(aditi_only, AditiOnly),
+
+ % magic sets can report errors.
+ { module_info_num_errors(HLDS50, NumErrors) },
+ ( { NumErrors = 0 } ->
+ ( { Aditi = do_aditi_compilation } ->
+ mercury_compile__generate_rl_bytecode(HLDS50,
+ Verbose, MaybeRLFile)
+ ;
+ { MaybeRLFile = no }
+ ),
+ ( { AditiOnly = yes } ->
+ []
+ ; { HighLevelC = yes } ->
module_name_to_file_name(ModuleName, ".c", no, C_File),
mercury_compile__gen_hlds(C_File, HLDS50),
- globals__io_lookup_bool_option(compile_to_c,
+ globals__io_lookup_bool_option(compile_to_c,
CompileToC),
( { CompileToC = no } ->
module_name_to_file_name(ModuleName, ".o", yes,
@@ -380,12 +426,16 @@
mercury_compile__single_c_to_obj(
C_File, O_File, _CompileOK)
;
- []
+ []
)
- ;
- mercury_compile__backend_pass(HLDS50, HLDS70, LLDS), !,
- mercury_compile__output_pass(HLDS70, LLDS,
+ ;
+ mercury_compile__backend_pass(HLDS50,
+ HLDS70, LLDS), !,
+ mercury_compile__output_pass(HLDS70, LLDS, MaybeRLFile,
ModuleName, _CompileErrors)
+ )
+ ;
+ []
)
)
;
@@ -843,8 +893,8 @@
mercury_compile__maybe_dump_hlds(HLDS11, "11",
"stratification"), !,
- mercury_compile__simplify(HLDS11, yes, no,
- Verbose, Stats, HLDS12), !,
+ mercury_compile__simplify(HLDS11, yes, no, Verbose, Stats,
+ process_all_nonimported_procs, HLDS12), !,
mercury_compile__maybe_dump_hlds(HLDS12, "12", "simplify"), !,
%
@@ -943,27 +993,28 @@
Verbose, Stats, HLDS36), !,
mercury_compile__maybe_dump_hlds(HLDS36, "36", "deforestation"), !,
- % dnf transformations should be after inlining
- % magic sets transformations should be before constraints
- mercury_compile__maybe_transform_dnf(HLDS36, Verbose, Stats, HLDS38), !,
- mercury_compile__maybe_dump_hlds(HLDS38, "38", "dnf"), !,
-
- mercury_compile__maybe_constraints(HLDS38, Verbose, Stats, HLDS40), !,
+ mercury_compile__maybe_constraints(HLDS36, Verbose, Stats, HLDS40), !,
mercury_compile__maybe_dump_hlds(HLDS40, "40", "constraint"), !,
- mercury_compile__maybe_unused_args(HLDS40, Verbose, Stats, HLDS43), !,
- mercury_compile__maybe_dump_hlds(HLDS43, "43", "unused_args"), !,
+ mercury_compile__maybe_lco(HLDS40, Verbose, Stats, HLDS43), !,
+ mercury_compile__maybe_dump_hlds(HLDS43, "43", "lco"), !,
- mercury_compile__maybe_dead_procs(HLDS43, Verbose, Stats, HLDS46), !,
- mercury_compile__maybe_dump_hlds(HLDS46, "46", "dead_procs"), !,
+ % DNF transformations should be after inlining.
+ mercury_compile__maybe_transform_dnf(HLDS43, Verbose, Stats, HLDS44), !,
+ mercury_compile__maybe_dump_hlds(HLDS44, "44", "dnf"), !,
+
+ % Magic sets should be the last thing done to Aditi procedures
+ % before RL code generation, and must come immediately after DNF.
+ mercury_compile__maybe_magic(HLDS44, Verbose, Stats, HLDS46), !,
+ mercury_compile__maybe_dump_hlds(HLDS46, "46", "magic"), !,
- mercury_compile__maybe_lco(HLDS46, Verbose, Stats, HLDS47), !,
- mercury_compile__maybe_dump_hlds(HLDS47, "47", "lco"), !,
+ mercury_compile__maybe_dead_procs(HLDS46, Verbose, Stats, HLDS48), !,
+ mercury_compile__maybe_dump_hlds(HLDS48, "48", "dead_procs"), !,
% map_args_to_regs affects the interface to a predicate,
% so it must be done in one phase immediately before code generation
- mercury_compile__map_args_to_regs(HLDS47, Verbose, Stats, HLDS49), !,
+ mercury_compile__map_args_to_regs(HLDS48, Verbose, Stats, HLDS49), !,
mercury_compile__maybe_dump_hlds(HLDS49, "49", "args_to_regs"), !,
{ HLDS50 = HLDS49 },
@@ -971,6 +1022,21 @@
%-----------------------------------------------------------------------------%
+:- pred mercury_compile__generate_rl_bytecode(module_info, bool,
+ maybe(rl_file), io__state, io__state).
+:- mode mercury_compile__generate_rl_bytecode(in, in, out, di, uo) is det.
+
+mercury_compile__generate_rl_bytecode(ModuleInfo, Verbose, MaybeRLFile) -->
+ maybe_write_string(Verbose, "% Generating RL...\n"),
+ maybe_flush_output(Verbose),
+ rl_gen__module(ModuleInfo, RLProcs0),
+ mercury_compile__maybe_dump_rl(RLProcs0, ModuleInfo, "", ""),
+ rl_opt__procs(ModuleInfo, RLProcs0, RLProcs),
+ mercury_compile__maybe_dump_rl(RLProcs, ModuleInfo, "", ".opt"),
+ rl_out__generate_rl_bytecode(ModuleInfo, RLProcs, MaybeRLFile).
+
+%-----------------------------------------------------------------------------%
+
:- pred mercury_compile__backend_pass(module_info, module_info,
list(c_procedure), io__state, io__state).
% :- mode mercury_compile__backend_pass(di, uo, out, di, uo) is det.
@@ -999,7 +1065,8 @@
mercury_compile__maybe_followcode(HLDS50, Verbose, Stats, HLDS52), !,
mercury_compile__maybe_dump_hlds(HLDS52, "52", "followcode"), !,
- mercury_compile__simplify(HLDS52, no, yes, Verbose, Stats, HLDS53), !,
+ mercury_compile__simplify(HLDS52, no, yes, Verbose, Stats,
+ process_all_nonimported_nonaditi_procs, HLDS53), !,
mercury_compile__maybe_dump_hlds(HLDS53, "53", "simplify2"), !,
mercury_compile__maybe_saved_vars(HLDS53, Verbose, Stats, HLDS56), !,
@@ -1058,7 +1125,13 @@
{ module_info_preds(ModuleInfo0, PredTable) },
{ map__lookup(PredTable, PredId, PredInfo) },
{ pred_info_non_imported_procids(PredInfo, ProcIds) },
- ( { ProcIds = [] } ->
+ (
+ {
+ ProcIds = []
+ ;
+ hlds_pred__pred_info_is_aditi_relation(PredInfo)
+ }
+ ->
{ ModuleInfo1 = ModuleInfo0 },
{ Code1 = [] }
;
@@ -1357,10 +1430,12 @@
).
:- pred mercury_compile__simplify(module_info, bool, bool, bool, bool,
+ pred(task, module_info, module_info, io__state, io__state),
module_info, io__state, io__state).
-:- mode mercury_compile__simplify(in, in, in, in, in, out, di, uo) is det.
+:- mode mercury_compile__simplify(in, in, in, in, in,
+ pred(task, in, out, di, uo) is det, out, di, uo) is det.
-mercury_compile__simplify(HLDS0, Warn, Once, Verbose, Stats, HLDS) -->
+mercury_compile__simplify(HLDS0, Warn, Once, Verbose, Stats, Process, HLDS) -->
maybe_write_string(Verbose, "% Simplifying goals...\n"),
maybe_flush_output(Verbose),
globals__io_get_globals(Globals),
@@ -1370,8 +1445,7 @@
;
{ Simplifications = Simplifications0 }
),
- process_all_nonimported_procs(
- update_pred_error(simplify__pred(Simplifications)),
+ call(Process, update_pred_error(simplify__pred(Simplifications)),
HLDS0, HLDS),
maybe_write_string(Verbose, "% done.\n"),
maybe_report_stats(Stats).
@@ -1445,6 +1519,22 @@
%-----------------------------------------------------------------------------%
+:- pred mercury_compile__maybe_generate_schemas(module_info, bool,
+ io__state, io__state).
+:- mode mercury_compile__maybe_generate_schemas(in, in, di, uo) is det.
+
+mercury_compile__maybe_generate_schemas(ModuleInfo, Verbose) -->
+ globals__io_lookup_bool_option(generate_schemas, Generate),
+ ( { Generate = yes } ->
+ maybe_write_string(Verbose, "% Writing schema file..."),
+ rl_out__generate_schema_file(ModuleInfo),
+ maybe_write_string(Verbose, " done.\n")
+ ;
+ []
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- pred mercury_compile__tabling(module_info, bool,
module_info, io__state, io__state).
:- mode mercury_compile__tabling(in, in, out, di, uo) is det.
@@ -1587,7 +1677,6 @@
;
{ HLDS = HLDS0 }
).
-
:- pred mercury_compile__maybe_deforestation(module_info, bool, bool,
module_info, io__state, io__state).
:- mode mercury_compile__maybe_deforestation(in, in, in, out, di, uo) is det.
@@ -1609,16 +1698,37 @@
:- mode mercury_compile__maybe_transform_dnf(in, in, in, out, di, uo) is det.
mercury_compile__maybe_transform_dnf(HLDS0, Verbose, Stats, HLDS) -->
- globals__io_lookup_bool_option(aditi, Aditi),
- ( { Aditi = yes } ->
+ globals__io_get_do_aditi_compilation(Aditi),
+ ( { Aditi = do_aditi_compilation } ->
maybe_write_string(Verbose, "% Disjunctive normal form transformation..."),
maybe_flush_output(Verbose),
- { dnf__transform_module(HLDS0, no, no, HLDS) },
+ { module_info_predids(HLDS0, PredIds) },
+ { set__init(AditiPreds0) },
+ { list__foldl(add_aditi_procs(HLDS0),
+ PredIds, AditiPreds0, AditiPreds) },
+ { dnf__transform_module(HLDS0, no, yes(AditiPreds), HLDS) },
maybe_write_string(Verbose, " done.\n"),
maybe_report_stats(Stats)
;
{ HLDS0 = HLDS }
).
+
+:- pred add_aditi_procs(module_info, pred_id,
+ set(pred_proc_id), set(pred_proc_id)).
+:- mode add_aditi_procs(in, in, in, out) is det.
+
+add_aditi_procs(HLDS0, PredId, AditiPreds0, AditiPreds) :-
+ module_info_pred_info(HLDS0, PredId, PredInfo),
+ ( hlds_pred__pred_info_is_aditi_relation(PredInfo) ->
+ pred_info_procids(PredInfo, ProcIds),
+ AddProc =
+ lambda([ProcId::in, Preds0::in, Preds::out] is det, (
+ set__insert(Preds0, proc(PredId, ProcId), Preds)
+ )),
+ list__foldl(AddProc, ProcIds, AditiPreds0, AditiPreds)
+ ;
+ AditiPreds = AditiPreds0
+ ).
:- pred mercury_compile__maybe_constraints(module_info, bool, bool,
module_info, io__state, io__state).
@@ -1655,6 +1765,21 @@
{ HLDS0 = HLDS }
).
+:- pred mercury_compile__maybe_magic(module_info, bool, bool,
+ module_info, io__state, io__state).
+:- mode mercury_compile__maybe_magic(in, in, in, out, di, uo) is det.
+
+mercury_compile__maybe_magic(HLDS0, Verbose, Stats, HLDS) -->
+ globals__io_get_do_aditi_compilation(Aditi),
+ ( { Aditi = do_aditi_compilation } ->
+ maybe_write_string(Verbose, "% Supplementary magic sets transformation..."),
+ maybe_flush_output(Verbose),
+ magic__process_module(HLDS0, HLDS),
+ maybe_report_stats(Stats)
+ ;
+ { HLDS0 = HLDS }
+ ).
+
:- pred mercury_compile__maybe_dead_procs(module_info, bool, bool,
module_info, io__state, io__state).
:- mode mercury_compile__maybe_dead_procs(in, in, in, out, di, uo)
@@ -1682,7 +1807,7 @@
( { LCO = yes } ->
maybe_write_string(Verbose, "% Looking for LCO modulo constructor application ...\n"),
maybe_flush_output(Verbose),
- process_all_nonimported_procs(
+ process_all_nonimported_nonaditi_procs(
update_proc_io(lco_modulo_constructors), HLDS0, HLDS),
maybe_write_string(Verbose, "% done.\n"),
maybe_report_stats(Stats)
@@ -1734,7 +1859,7 @@
( { FollowCode = yes ; PrevCode = yes } ->
maybe_write_string(Verbose, "% Migrating branch code..."),
maybe_flush_output(Verbose),
- process_all_nonimported_procs(update_module(
+ process_all_nonimported_nonaditi_procs(update_module(
move_follow_code_in_proc), HLDS0, HLDS),
maybe_write_string(Verbose, " done.\n"),
maybe_report_stats(Stats)
@@ -1749,7 +1874,8 @@
mercury_compile__compute_liveness(HLDS0, Verbose, Stats, HLDS) -->
maybe_write_string(Verbose, "% Computing liveness...\n"),
maybe_flush_output(Verbose),
- process_all_nonimported_procs(update_proc_predid(detect_liveness_proc),
+ process_all_nonimported_nonaditi_procs(
+ update_proc_predid(detect_liveness_proc),
HLDS0, HLDS),
maybe_write_string(Verbose, "% done.\n"),
maybe_report_stats(Stats).
@@ -1761,7 +1887,7 @@
mercury_compile__compute_stack_vars(HLDS0, Verbose, Stats, HLDS) -->
maybe_write_string(Verbose, "% Computing stack vars..."),
maybe_flush_output(Verbose),
- process_all_nonimported_procs(
+ process_all_nonimported_nonaditi_procs(
update_proc_predid(allocate_stack_slots_in_proc),
HLDS0, HLDS),
maybe_write_string(Verbose, " done.\n"),
@@ -1774,7 +1900,8 @@
mercury_compile__allocate_store_map(HLDS0, Verbose, Stats, HLDS) -->
maybe_write_string(Verbose, "% Allocating store map..."),
maybe_flush_output(Verbose),
- process_all_nonimported_procs(update_proc_predid(store_alloc_in_proc),
+ process_all_nonimported_nonaditi_procs(
+ update_proc_predid(store_alloc_in_proc),
HLDS0, HLDS),
maybe_write_string(Verbose, " done.\n"),
maybe_report_stats(Stats).
@@ -1889,10 +2016,11 @@
% The LLDS output pass
:- pred mercury_compile__output_pass(module_info, list(c_procedure),
- module_name, bool, io__state, io__state).
-:- mode mercury_compile__output_pass(in, in, in, out, di, uo) is det.
+ maybe(rl_file), module_name, bool, io__state, io__state).
+:- mode mercury_compile__output_pass(in, in, in, in, out, di, uo) is det.
-mercury_compile__output_pass(HLDS0, LLDS0, ModuleName, CompileErrors) -->
+mercury_compile__output_pass(HLDS0, LLDS0, MaybeRLFile,
+ ModuleName, CompileErrors) -->
globals__io_lookup_bool_option(verbose, Verbose),
globals__io_lookup_bool_option(statistics, Stats),
globals__io_lookup_bool_option(basic_stack_layout, BasicStackLayout),
@@ -1917,7 +2045,7 @@
mercury_compile__chunk_llds(C_InterfaceInfo, LLDS1, AllData,
CommonData, LLDS2, NumChunks),
mercury_compile__output_llds(ModuleName, LLDS2, StackLayoutLabelMap,
- Verbose, Stats),
+ MaybeRLFile, Verbose, Stats),
{ C_InterfaceInfo = c_interface_info(_ModuleName,
_C_headerCode, _C_BodyCode, C_ExportDecls, _C_ExportDefns) },
@@ -2025,10 +2153,10 @@
mercury_compile__combine_chunks_2(Chunks, ModName, Num1, Modules).
:- pred mercury_compile__output_llds(module_name, c_file, set_bbbtree(label),
- bool, bool, io__state, io__state).
-:- mode mercury_compile__output_llds(in, in, in, in, in, di, uo) is det.
+ maybe(rl_file), bool, bool, io__state, io__state).
+:- mode mercury_compile__output_llds(in, in, in, in, in, in, di, uo) is det.
-mercury_compile__output_llds(ModuleName, LLDS, StackLayoutLabels,
+mercury_compile__output_llds(ModuleName, LLDS, StackLayoutLabels, MaybeRLFile,
Verbose, Stats) -->
maybe_write_string(Verbose,
"% Writing output to `"),
@@ -2036,7 +2164,7 @@
maybe_write_string(Verbose, FileName),
maybe_write_string(Verbose, "'..."),
maybe_flush_output(Verbose),
- output_c_file(LLDS, StackLayoutLabels),
+ output_c_file(LLDS, StackLayoutLabels, MaybeRLFile),
maybe_write_string(Verbose, " done.\n"),
maybe_flush_output(Verbose),
maybe_report_stats(Stats).
@@ -2511,6 +2639,39 @@
{ string__append_list(["can't open file `",
DumpFile, "' for output."], ErrorMessage) },
report_error(ErrorMessage)
+ ).
+
+
+:- pred mercury_compile__maybe_dump_rl(list(rl_proc), module_info,
+ string, string, io__state, io__state).
+:- mode mercury_compile__maybe_dump_rl(in, in, in, in, di, uo) is det.
+
+mercury_compile__maybe_dump_rl(Procs, ModuleInfo, _StageNum, StageName) -->
+ globals__io_lookup_bool_option(dump_rl, Dump),
+ ( { Dump = yes } ->
+ { module_info_name(ModuleInfo, ModuleName0) },
+ { prog_out__sym_name_to_string(ModuleName0, ModuleName) },
+ { string__append_list([ModuleName, ".rl_dump", StageName],
+ DumpFile) },
+ globals__io_lookup_bool_option(verbose, Verbose),
+ maybe_write_string(Verbose, "% Dumping out RL to `"),
+ maybe_write_string(Verbose, DumpFile),
+ maybe_write_string(Verbose, "'..."),
+ maybe_flush_output(Verbose),
+ io__tell(DumpFile, Res),
+ ( { Res = ok } ->
+ list__foldl(rl_dump__output_procedure(ModuleInfo),
+ Procs),
+ io__told,
+ maybe_write_string(Verbose, " done.\n")
+ ;
+ maybe_write_string(Verbose, "\n"),
+ { string__append_list(["can't open file `",
+ DumpFile, "' for output."], ErrorMessage) },
+ report_error(ErrorMessage)
+ )
+ ;
+ []
).
%-----------------------------------------------------------------------------%
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.138
diff -u -t -u -r1.138 mercury_to_mercury.m
--- mercury_to_mercury.m 1998/06/19 03:16:11 1.138
+++ mercury_to_mercury.m 1998/06/29 00:46:13
@@ -313,6 +313,12 @@
{ Pragma = obsolete(Pred, Arity) },
mercury_output_pragma_decl(Pred, Arity, predicate, "obsolete")
;
+ { Pragma = memo(Pred, Arity) },
+ mercury_output_pragma_decl(Pred, Arity, predicate, "memo")
+ ;
+ { Pragma = no_memo(Pred, Arity) },
+ mercury_output_pragma_decl(Pred, Arity, predicate, "no_memo")
+ ;
{ Pragma = tabled(Type, Pred, Arity, _PredOrFunc, _Mode) },
{ eval_method_to_string(Type, TypeS) },
mercury_output_pragma_decl(Pred, Arity, predicate, TypeS)
@@ -331,6 +337,30 @@
{ Pragma = fact_table(Pred, Arity, FileName) },
mercury_output_pragma_fact_table(Pred, Arity, FileName)
;
+ { Pragma = aditi(Pred, Arity) },
+ mercury_output_pragma_decl(Pred, Arity, predicate, "aditi")
+ ;
+ { Pragma = base_relation(Pred, Arity) },
+ mercury_output_pragma_decl(Pred, Arity,
+ predicate, "base_relation")
+ ;
+ { Pragma = supp_magic(Pred, Arity) },
+ mercury_output_pragma_decl(Pred, Arity,
+ predicate, "supp_magic")
+ ;
+ { Pragma = context(Pred, Arity) },
+ mercury_output_pragma_decl(Pred, Arity,
+ predicate, "context")
+ ;
+ { Pragma = owner(Pred, Arity, Owner) },
+ mercury_output_pragma_owner(Pred, Arity, Owner)
+ ;
+ { Pragma = naive(Pred, Arity) },
+ mercury_output_pragma_decl(Pred, Arity, predicate, "naive")
+ ;
+ { Pragma = psn(Pred, Arity) },
+ mercury_output_pragma_decl(Pred, Arity, predicate, "psn")
+ ;
{ Pragma = promise_pure(Pred, Arity) },
mercury_output_pragma_decl(Pred, Arity, predicate,
"promise_pure")
@@ -488,38 +518,6 @@
%-----------------------------------------------------------------------------%
-mercury_output_pragma_unused_args(PredOrFunc, SymName,
- Arity, ProcId, UnusedArgs) -->
- io__write_string(":- pragma unused_args("),
- hlds_out__write_pred_or_func(PredOrFunc),
- io__write_string(", "),
- mercury_output_bracketed_sym_name(SymName),
- io__write_string(", "),
- io__write_int(Arity),
- io__write_string(", "),
- { proc_id_to_int(ProcId, ProcInt) },
- io__write_int(ProcInt),
- io__write_string(", ["),
- mercury_output_int_list(UnusedArgs),
- io__write_string("]).\n").
-
-:- pred mercury_output_int_list(list(int)::in,
- io__state::di, io__state::uo) is det.
-
-mercury_output_int_list([]) --> [].
-mercury_output_int_list([First | Rest]) -->
- io__write_int(First),
- mercury_output_int_list_2(Rest).
-
-:- pred mercury_output_int_list_2(list(int)::in,
- io__state::di, io__state::uo) is det.
-
-mercury_output_int_list_2([]) --> [].
-mercury_output_int_list_2([First | Rest]) -->
- io__write_string(", "),
- io__write_int(First),
- mercury_output_int_list_2(Rest).
-
:- pred mercury_output_module_defn(varset, module_defn, term__context,
io__state, io__state).
:- mode mercury_output_module_defn(in, in, in, di, uo) is det.
@@ -2033,6 +2031,40 @@
%-----------------------------------------------------------------------------%
+mercury_output_pragma_unused_args(PredOrFunc, SymName,
+ Arity, ProcId, UnusedArgs) -->
+ io__write_string(":- pragma unused_args("),
+ hlds_out__write_pred_or_func(PredOrFunc),
+ io__write_string(", "),
+ mercury_output_bracketed_sym_name(SymName),
+ io__write_string(", "),
+ io__write_int(Arity),
+ io__write_string(", "),
+ { proc_id_to_int(ProcId, ProcInt) },
+ io__write_int(ProcInt),
+ io__write_string(", ["),
+ mercury_output_int_list(UnusedArgs),
+ io__write_string("]).\n").
+
+:- pred mercury_output_int_list(list(int)::in,
+ io__state::di, io__state::uo) is det.
+
+mercury_output_int_list([]) --> [].
+mercury_output_int_list([First | Rest]) -->
+ io__write_int(First),
+ mercury_output_int_list_2(Rest).
+
+:- pred mercury_output_int_list_2(list(int)::in,
+ io__state::di, io__state::uo) is det.
+
+mercury_output_int_list_2([]) --> [].
+mercury_output_int_list_2([First | Rest]) -->
+ io__write_string(", "),
+ io__write_int(First),
+ mercury_output_int_list_2(Rest).
+
+%-----------------------------------------------------------------------------%
+
mercury_output_pragma_decl(PredName, Arity, PredOrFunc, PragmaName) -->
{ PredOrFunc = predicate,
DeclaredArity = Arity
@@ -2119,6 +2151,21 @@
io__write_int(Arity),
io__write_string(", "),
term_io__quote_string(FileName),
+ io__write_string(").\n").
+
+%-----------------------------------------------------------------------------%
+
+:- pred mercury_output_pragma_owner(sym_name, arity, string,
+ io__state, io__state).
+:- mode mercury_output_pragma_owner(in, in, in, di, uo) is det.
+
+mercury_output_pragma_owner(Pred, Arity, Owner) -->
+ io__write_string(":- pragma owner("),
+ mercury_output_sym_name(Pred),
+ io__write_string("/"),
+ io__write_int(Arity),
+ io__write_string(", "),
+ term_io__quote_string(Owner),
io__write_string(").\n").
%-----------------------------------------------------------------------------%
Index: compiler/mode_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/mode_util.m,v
retrieving revision 1.110
diff -u -t -u -r1.110 mode_util.m
--- mode_util.m 1998/06/09 02:13:58 1.110
+++ mode_util.m 1998/06/11 01:05:03
@@ -165,6 +165,12 @@
%-----------------------------------------------------------------------------%
+ % Partition a list of arguments into inputs and others.
+:- pred partition_args(module_info, list(mode), list(T), list(T), list(T)).
+:- mode partition_args(in, in, in, out, out) is det.
+
+%-----------------------------------------------------------------------------%
+
% Construct a mode corresponding to the standard `in',
% `out', or `uo' mode.
:- pred in_mode((mode)::out) is det.
@@ -1559,6 +1565,24 @@
mercury_public_builtin_module(MercuryBuiltin),
QualifiedName = qualified(MercuryBuiltin, Name),
Mode = user_defined_mode(QualifiedName, Args).
+
+%-----------------------------------------------------------------------------%
+
+partition_args(_, [], [_|_], _, _) :-
+ error("partition_args").
+partition_args(_, [_|_], [], _, _) :-
+ error("partition_args").
+partition_args(_, [], [], [], []).
+partition_args(ModuleInfo, [ArgMode | ArgModes], [Arg | Args],
+ InputArgs, OutputArgs) :-
+ partition_args(ModuleInfo, ArgModes, Args, InputArgs1, OutputArgs1),
+ ( mode_is_input(ModuleInfo, ArgMode) ->
+ InputArgs = [Arg | InputArgs1],
+ OutputArgs = OutputArgs1
+ ;
+ InputArgs = InputArgs1,
+ OutputArgs = [Arg | OutputArgs1]
+ ).
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
Index: compiler/module_qual.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/module_qual.m,v
retrieving revision 1.36
diff -u -t -u -r1.36 module_qual.m
--- module_qual.m 1998/05/15 07:07:25 1.36
+++ module_qual.m 1998/05/28 01:04:01
@@ -654,6 +654,9 @@
c_code(Rec, SymName, PredOrFunc, PragmaVars, Varset, CCode),
Info0, Info) -->
qualify_pragma_vars(PragmaVars0, PragmaVars, Info0, Info).
+qualify_pragma(memo(A, B), memo(A, B), Info, Info) --> [].
+qualify_pragma(no_memo(SymName, Arity), no_memo(SymName, Arity),
+ Info, Info) --> [].
qualify_pragma(tabled(A, B, C, D, MModes0), tabled(A, B, C, D, MModes),
Info0, Info) -->
(
@@ -678,7 +681,21 @@
qualify_pragma(unused_args(A, B, C, D, E), unused_args(A, B, C, D, E),
Info, Info) --> [].
qualify_pragma(fact_table(SymName, Arity, FileName),
- fact_table(SymName, Arity, FileName), Info, Info) --> [].
+ fact_table(SymName, Arity, FileName), Info, Info) --> [].
+qualify_pragma(aditi(SymName, Arity), aditi(SymName, Arity),
+ Info, Info) --> [].
+qualify_pragma(base_relation(SymName, Arity), base_relation(SymName, Arity),
+ Info, Info) --> [].
+qualify_pragma(supp_magic(SymName, Arity), supp_magic(SymName, Arity),
+ Info, Info) --> [].
+qualify_pragma(context(SymName, Arity), context(SymName, Arity),
+ Info, Info) --> [].
+qualify_pragma(naive(SymName, Arity), naive(SymName, Arity),
+ Info, Info) --> [].
+qualify_pragma(psn(SymName, Arity), psn(SymName, Arity),
+ Info, Info) --> [].
+qualify_pragma(owner(SymName, Arity, Owner), owner(SymName, Arity, Owner),
+ Info, Info) --> [].
qualify_pragma(promise_pure(SymName, Arity), promise_pure(SymName, Arity),
Info, Info) --> [].
qualify_pragma(termination_info(PredOrFunc, SymName, ModeList0, Args, Term),
Index: compiler/modules.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/modules.m,v
retrieving revision 1.81
diff -u -t -u -r1.81 modules.m
--- modules.m 1998/07/01 04:09:39 1.81
+++ modules.m 1998/07/02 01:45:46
@@ -503,6 +503,8 @@
; Ext = ".hlds_dump"
; Ext = ".dependency_graph"
; Ext = ".order"
+ ; Ext = ".rla"
+ ; Ext = ".rl_dump"
% Mmake targets
; Ext = ".clean"
; Ext = ".clean_nu"
@@ -787,8 +789,8 @@
).
% pragma `obsolete', `terminates', `does_not_terminate'
-% `termination_info' and `check_termination' declarations
-% are supposed to go in the interface,
+% `termination_info', `check_termination' and Aditi pragma
+% declarations are supposed to go in the interface,
% but all other pragma declarations are implementation
% details only, and should go in the implementation.
@@ -799,6 +801,8 @@
pragma_allowed_in_interface(c_header_code(_), no).
pragma_allowed_in_interface(c_code(_), no).
pragma_allowed_in_interface(c_code(_, _, _, _, _, _), no).
+pragma_allowed_in_interface(memo(_, _), no).
+pragma_allowed_in_interface(no_memo(_, _), no).
pragma_allowed_in_interface(inline(_, _), no).
pragma_allowed_in_interface(no_inline(_, _), no).
pragma_allowed_in_interface(obsolete(_, _), yes).
@@ -814,6 +818,15 @@
pragma_allowed_in_interface(terminates(_, _), yes).
pragma_allowed_in_interface(does_not_terminate(_, _), yes).
pragma_allowed_in_interface(check_termination(_, _), yes).
+ % aditi, base_relation and owner pragmas must be in the interface
+ % for exported preds.
+pragma_allowed_in_interface(aditi(_, _), yes).
+pragma_allowed_in_interface(base_relation(_, _), yes).
+pragma_allowed_in_interface(supp_magic(_, _), no).
+pragma_allowed_in_interface(context(_, _), no).
+pragma_allowed_in_interface(naive(_, _), no).
+pragma_allowed_in_interface(psn(_, _), no).
+pragma_allowed_in_interface(owner(_, _, _), yes).
:- pred check_for_no_exports(item_list, module_name, io__state, io__state).
:- mode check_for_no_exports(in, in, di, uo) is det.
@@ -1340,6 +1353,7 @@
OptDateFileName),
module_name_to_file_name(ModuleName, ".c", no, CFileName),
module_name_to_file_name(ModuleName, ".o", no, ObjFileName),
+ module_name_to_file_name(ModuleName, ".rlo", no, RLOFileName),
module_name_to_file_name(ModuleName, ".pic_o", no,
PicObjFileName),
io__write_strings(DepStream, ["\n\n",
@@ -1348,7 +1362,8 @@
CFileName, " ",
ErrFileName, " ",
PicObjFileName, " ",
- ObjFileName, " : ",
+ ObjFileName, " ",
+ RLOFileName, " : ",
SourceFileName
] ),
write_dependencies_list(ParentDeps, ".int0", DepStream),
@@ -2106,6 +2121,12 @@
io__write_string(DepStream, "\n"),
io__write_string(DepStream, MakeVarName),
+ io__write_string(DepStream, ".rlos = "),
+ write_compact_dependencies_list(Modules, "$(rlos_subdir)", ".rlo",
+ Basis, DepStream),
+ io__write_string(DepStream, "\n"),
+
+ io__write_string(DepStream, MakeVarName),
io__write_string(DepStream, ".pic_os = "),
write_compact_dependencies_list(Modules, "$(os_subdir)",
".$(EXT_FOR_PIC_OBJECTS)",
@@ -2207,6 +2228,15 @@
io__write_string(DepStream, "\n"),
io__write_string(DepStream, MakeVarName),
+ io__write_string(DepStream, ".schemas = "),
+ write_compact_dependencies_list(Modules, "", ".base_schema",
+ Basis, DepStream),
+ io__write_string(DepStream, " "),
+ write_compact_dependencies_list(Modules, "", ".derived_schema",
+ Basis, DepStream),
+ io__write_string(DepStream, "\n"),
+
+ io__write_string(DepStream, MakeVarName),
io__write_string(DepStream, ".profs = "),
write_compact_dependencies_list(Modules, "", ".prof",
Basis, DepStream),
@@ -2333,6 +2363,9 @@
module_name_to_file_name(ModuleName, ".opts", no, OptsTargetName),
module_name_to_file_name(ModuleName, ".trans_opts", no,
TransOptsTargetName),
+ module_name_to_file_name(ModuleName, ".rlos", no,
+ RLOsTargetName),
+
io__write_strings(DepStream, [
".PHONY : ", CheckTargetName, "\n",
CheckTargetName, " : $(", MakeVarName, ".errs)\n\n",
@@ -2344,7 +2377,9 @@
OptsTargetName, " : $(", MakeVarName, ".optdates)\n\n",
".PHONY : ", TransOptsTargetName, "\n",
TransOptsTargetName, " : $(", MakeVarName,
- ".trans_opt_dates)\n\n"
+ ".trans_opt_dates)\n\n",
+ ".PHONY : ", RLOsTargetName, "\n",
+ RLOsTargetName, " : $(", MakeVarName, ".rlos)\n\n"
]),
module_name_to_file_name(SourceModuleName, ".clean", no,
@@ -2366,7 +2401,8 @@
"\t-rm -f $(", MakeVarName, ".profs)\n",
"\t-rm -f $(", MakeVarName, ".nos)\n",
"\t-rm -f $(", MakeVarName, ".qls)\n",
- "\t-rm -f $(", MakeVarName, ".errs)\n"
+ "\t-rm -f $(", MakeVarName, ".errs)\n",
+ "\t-rm -f $(", MakeVarName, ".schemas)\n"
]),
io__write_string(DepStream, "\n"),
@@ -2410,7 +2446,8 @@
"\t-rm -f $(", MakeVarName, ".int3s)\n",
"\t-rm -f $(", MakeVarName, ".opts)\n",
"\t-rm -f $(", MakeVarName, ".ds)\n",
- "\t-rm -f $(", MakeVarName, ".hs)\n"
+ "\t-rm -f $(", MakeVarName, ".hs)\n",
+ "\t-rm -f $(", MakeVarName, ".rlos)\n"
]),
module_name_to_file_name(SourceModuleName, ".nu.save", no,
NU_SaveExeFileName),
@@ -2470,8 +2507,10 @@
append_to_init_list(DepStream, InitFileName, Module) -->
{ llds_out__make_init_name(Module, InitFuncName) },
+ { llds_out__make_rl_data_name(Module, RLName) },
io__write_strings(DepStream, [
- "\techo ""INIT ", InitFuncName, """ >> ", InitFileName, "\n"
+ "\techo ""INIT ", InitFuncName, """ >> ", InitFileName, "\n",
+ "\techo ""ADITI_DATA ", RLName, """ >> ", InitFileName, "\n"
]).
%-----------------------------------------------------------------------------%
Index: compiler/opt_debug.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/opt_debug.m,v
retrieving revision 1.82
diff -u -t -u -r1.82 opt_debug.m
--- opt_debug.m 1998/06/09 02:14:06 1.82
+++ opt_debug.m 1998/06/19 01:42:46
@@ -754,6 +754,9 @@
opt_debug__dump_code_addr(do_det_class_method, "do_det_class_method").
opt_debug__dump_code_addr(do_semidet_class_method, "do_semidet_class_method").
opt_debug__dump_code_addr(do_nondet_class_method, "do_nondet_class_method").
+opt_debug__dump_code_addr(do_det_aditi_call, "do_det_aditi_call").
+opt_debug__dump_code_addr(do_semidet_aditi_call, "do_semidet_aditi_call").
+opt_debug__dump_code_addr(do_nondet_aditi_call, "do_nondet_aditi_call").
opt_debug__dump_code_addr(do_not_reached, "do_not_reached").
opt_debug__dump_code_addrs([], "").
Index: compiler/opt_util.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/opt_util.m,v
retrieving revision 1.93
diff -u -t -u -r1.93 opt_util.m
--- opt_util.m 1998/06/09 02:14:09 1.93
+++ opt_util.m 1998/06/19 01:43:13
@@ -1304,6 +1304,9 @@
opt_util__livevals_addr(do_det_class_method, yes).
opt_util__livevals_addr(do_semidet_class_method, yes).
opt_util__livevals_addr(do_nondet_class_method, yes).
+opt_util__livevals_addr(do_det_aditi_call, yes).
+opt_util__livevals_addr(do_semidet_aditi_call, yes).
+opt_util__livevals_addr(do_nondet_aditi_call, yes).
opt_util__livevals_addr(do_not_reached, no).
opt_util__count_temps_instr_list([], R, R, F, F).
Index: compiler/options.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/options.m,v
retrieving revision 1.235
diff -u -t -u -r1.235 options.m
--- options.m 1998/07/01 06:08:27 1.235
+++ options.m 1998/07/07 01:13:24
@@ -72,6 +72,8 @@
; debug_opt
; debug_vn % vn = value numbering
; debug_pd % pd = partial deduction/deforestation
+ ; debug_rl_gen
+ ; debug_rl_opt
% Output options
; make_short_interface
; make_interface
@@ -86,6 +88,7 @@
; errorcheck_only
; compile_to_c
; compile_only
+ ; aditi_only
% Auxiliary output options
; assume_gmake
; trace
@@ -97,6 +100,9 @@
; show_dependency_graph
; dump_hlds
; verbose_dump_hlds
+ ; generate_schemas
+ ; dump_rl
+ ; dump_rl_bytecode
% Language semantics options
; reorder_conj
; reorder_disj
@@ -184,7 +190,6 @@
; cflags_for_gotos
; c_debug
; c_include_directory
- ; aditi
; fact_table_max_array_size
% maximum number of elements in a single
% fact table data array
@@ -264,6 +269,11 @@
; optimize_vnrepeat
; pred_value_number
; vn_fudge
+ % - RL
+ ; optimize_rl
+ ; optimize_rl_cse
+ ; optimize_rl_invariants
+ ; detect_rl_streams
% - C
; use_macro_for_redo_fail
; emit_c_loops
@@ -282,7 +292,10 @@
; search_directories
; intermod_directories
; use_search_directories_for_intermod
+ ; filenames_from_stdin
; use_subdirs
+ ; aditi
+ ; aditi_user
; help.
:- implementation.
@@ -347,7 +360,9 @@
debug_det - bool(no),
debug_opt - bool(no),
debug_vn - int(0),
- debug_pd - bool(no)
+ debug_pd - bool(no),
+ debug_rl_gen - bool(no),
+ debug_rl_opt - bool(no)
]).
option_defaults_2(output_option, [
% Output Options (mutually exclusive)
@@ -363,7 +378,8 @@
typecheck_only - bool(no),
errorcheck_only - bool(no),
compile_to_c - bool(no),
- compile_only - bool(no)
+ compile_only - bool(no),
+ aditi_only - bool(no)
]).
option_defaults_2(aux_output_option, [
% Auxiliary Output Options
@@ -376,7 +392,10 @@
auto_comments - bool(no),
show_dependency_graph - bool(no),
dump_hlds - accumulating([]),
- verbose_dump_hlds - string("")
+ verbose_dump_hlds - string(""),
+ dump_rl - bool(no),
+ dump_rl_bytecode - bool(no),
+ generate_schemas - bool(no)
]).
option_defaults_2(language_semantics_option, [
strict_sequential - special,
@@ -477,7 +496,6 @@
% the `mmc' script will override the
% above default with a value determined
% at configuration time
- aditi - bool(no),
fact_table_max_array_size - int(1024),
fact_table_hash_percent_full - int(90)
]).
@@ -577,7 +595,12 @@
procs_per_c_function - int(1),
everything_in_one_c_function - special,
c_optimize - bool(no),
- inline_alloc - bool(no)
+ inline_alloc - bool(no),
+% RL - not yet implemented
+ optimize_rl - bool(no),
+ optimize_rl_cse - bool(no),
+ optimize_rl_invariants - bool(no),
+ detect_rl_streams - bool(no)
]).
option_defaults_2(link_option, [
% Link Options
@@ -593,11 +616,14 @@
option_defaults_2(miscellaneous_option, [
% Miscellaneous Options
heap_space - int(0),
+ filenames_from_stdin - bool(no),
search_directories - accumulating(["."]),
intermod_directories - accumulating([]),
use_search_directories_for_intermod
- bool(yes),
use_subdirs - bool(no),
+ aditi - bool(no),
+ aditi_user - string(""),
help - bool(no)
]).
@@ -660,6 +686,8 @@
long_option("debug-opt", debug_opt).
long_option("debug-vn", debug_vn).
long_option("debug-pd", debug_pd).
+long_option("debug-rl-gen", debug_rl_gen).
+long_option("debug-rl-opt", debug_rl_opt).
% output options (mutually exclusive)
long_option("generate-dependencies", generate_dependencies).
@@ -690,6 +718,7 @@
long_option("compile-to-c", compile_to_c).
long_option("compile-to-C", compile_to_c).
long_option("compile-only", compile_only).
+long_option("aditi-only", aditi_only).
% aux output options
long_option("assume-gmake", assume_gmake).
@@ -703,6 +732,9 @@
long_option("show-dependency-graph", show_dependency_graph).
long_option("dump-hlds", dump_hlds).
long_option("verbose-dump-hlds", verbose_dump_hlds).
+long_option("dump-rl", dump_rl).
+long_option("dump-rl-bytecode", dump_rl_bytecode).
+long_option("generate-schemas", generate_schemas).
% language semantics options
long_option("reorder-conj", reorder_conj).
@@ -899,6 +931,12 @@
long_option("pred-value-number", pred_value_number).
long_option("vn-fudge", vn_fudge).
+% RL optimizations
+long_option("optimize-rl", optimize_rl).
+long_option("optimize-rl-cse", optimize_rl_cse).
+long_option("optimize-rl-invariants", optimize_rl_invariants).
+long_option("detect-rl-streams", detect_rl_streams).
+
% LLDS->C optimizations
long_option("use-macro-for-redo-fail", use_macro_for_redo_fail).
long_option("emit-c-loops", emit_c_loops).
@@ -926,7 +964,10 @@
long_option("intermod-directory", intermod_directories).
long_option("use-search-directories-for-intermod",
use_search_directories_for_intermod).
+long_option("filenames-from-stdin", filenames_from_stdin).
long_option("use-subdirs", use_subdirs).
+long_option("aditi", aditi).
+long_option("aditi-user", aditi_user).
%-----------------------------------------------------------------------------%
@@ -1290,7 +1331,11 @@
io__write_string("\t\tdifferent types of tracing messages.\n"),
io__write_string("\t--debug-pd\n"),
io__write_string("\t\tOutput detailed debugging traces of the partial\n"),
- io__write_string("\t\tdeduction and deforestation process.\n").
+ io__write_string("\t\tdeduction and deforestation process.\n"),
+ io__write_string("\t--debug-rl-gen\n"),
+ io__write_string("\t\tOutput detailed debugging traces of Aditi-RL code generation.\n"),
+ io__write_string("\t--debug-rl-opt\n"),
+ io__write_string("\t\tOutput detailed debugging traces of Aditi-RL optimization.\n").
:- pred options_help_output(io__state::di, io__state::uo) is det.
@@ -1343,7 +1388,10 @@
io__write_string("\t\tGenerate C code in `<module>.c', but not object code.\n"),
io__write_string("\t-c, --compile-only\n"),
io__write_string("\t\tGenerate C code in `<module>.c' and object code in `<module>.o'\n"),
- io__write_string("\t\tbut do not attempt to link the named modules.\n").
+ io__write_string("\t\tbut do not attempt to link the named modules.\n"),
+ io__write_string("\t--aditi-only\n"),
+ io__write_string("\t\tWrite Aditi-RL bytecode to `<module>.rlo' and\n"),
+ io__write_string("\t\tdo not compile to C.\n").
:- pred options_help_aux_output(io__state::di, io__state::uo) is det.
@@ -1384,7 +1432,17 @@
io__write_string("\t\tWith `--dump-hlds', include extra detail in the dump.\n"),
io__write_string("\t\tEach type of detail is included in the dump if its\n"),
io__write_string("\t\tcorresponding letter occurs in the option argument\n"),
- io__write_string("\t\t(see the Mercury User's Guide for details).\n").
+ io__write_string("\t\t(see the Mercury User's Guide for details).\n"),
+ io__write_string("\t--dump-rl\n"),
+ io__write_string("\t\tOutput a human readable representation of Aditi-RL\n"),
+ io__write_string("\t\tto `<module>.rl_dump'.\n"),
+ io__write_string("\t--dump-rl-bytecode\n"),
+ io__write_string("\t\tOutput a human readable representation of Aditi-RL\n"),
+ io__write_string("\t\tbytecodes to `<module>.rla'.\n"),
+ io__write_string("\t--generate-schemas\n"),
+ io__write_string("\t\tOutput schema strings for Aditi base relations\n"),
+ io__write_string("\t\tto `<module>.base_schema' and for Aditi derived\n"),
+ io__write_string("\t\trelations to `<module>.derived_schema'.\n").
:- pred options_help_semantics(io__state::di, io__state::uo) is det.
@@ -1957,9 +2015,18 @@
io__write_string("\t\tDon't add arguments to `--search-directory' to the list\n"),
io__write_string("\t\tof directories to search for `.opt' files - use only the\n"),
io__write_string("\t\tdirectories given by `--intermod-directory'.\n"),
+ io__write_string("\t--filenames-from-stdin\n"),
+ io__write_string("\t\tRead a newline separated list of `.m' files to compile\n"),
+ io__write_string("\t\tfrom the standard input rather than the command line.\n"),
io__write_string("\t--use-subdirs\n"),
io__write_string("\t\tGenerate intermediate files in a `Mercury' subdirectory,\n"),
- io__write_string("\t\trather than generating them in the current directory.\n").
+ io__write_string("\t\trather than generating them in the current directory.\n"),
+ io__write_string("\t--aditi\n"),
+ io__write_string("\t\tEnable Aditi compilation.\n"),
+ io__write_string("\t--aditi-user\n"),
+ io__write_string("\t\tSpecify the Aditi login of the owner of any Aditi RL.\n"),
+ io__write_string("\t\tfiles produced.\n"),
+ io__write_string("\t\tDefaults to the value of the USER environment variable\n").
:- end_module options.
Index: compiler/passes_aux.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/passes_aux.m,v
retrieving revision 1.27
diff -u -t -u -r1.27 passes_aux.m
--- passes_aux.m 1998/06/17 05:13:51 1.27
+++ passes_aux.m 1998/06/19 04:23:36
@@ -38,8 +38,8 @@
module_info, module_info,
io__state, io__state))
% It would be better to use an existentiallly-quantified type
- % rather than `univ' here, but Mercury 0.6 doesn't support
- % existentially-quantified types.
+ % rather than `univ' here, but the current version of Mercury
+ % doesn't support existentially-quantified types.
; update_module_cookie(pred(
pred_id, proc_id, proc_info, proc_info,
univ, univ, module_info, module_info),
@@ -103,6 +103,21 @@
io__state, io__state).
:- mode process_all_nonimported_procs(task, in, out, di, uo) is det.
+ % Process procedures for which a given test succeeds.
+:- pred process_matching_nonimported_procs(task, pred(pred_info),
+ module_info, module_info, io__state, io__state).
+:- mode process_matching_nonimported_procs(task, pred(in) is semidet,
+ in, out, di, uo) is det.
+
+:- pred process_matching_nonimported_procs(task, task, pred(pred_info),
+ module_info, module_info, io__state, io__state).
+:- mode process_matching_nonimported_procs(task, out(task),
+ pred(in) is semidet, in, out, di, uo) is det.
+
+:- pred process_all_nonimported_nonaditi_procs(task, module_info, module_info,
+ io__state, io__state).
+:- mode process_all_nonimported_nonaditi_procs(task, in, out, di, uo) is det.
+
:- pred process_all_nonimported_procs(task, task,
module_info, module_info, io__state, io__state).
:- mode process_all_nonimported_procs(task, out(task), in, out, di, uo) is det.
@@ -145,29 +160,51 @@
:- import_module varset.
process_all_nonimported_procs(Task, ModuleInfo0, ModuleInfo) -->
+ { True = lambda([_PredInfo::in] is semidet, true) },
+ process_matching_nonimported_procs(Task, True,
+ ModuleInfo0, ModuleInfo).
+
+process_all_nonimported_nonaditi_procs(Task, ModuleInfo0, ModuleInfo) -->
+ { NotAditi = lambda([PredInfo::in] is semidet, (
+ \+ hlds_pred__pred_info_is_aditi_relation(PredInfo)
+ )) },
+ process_matching_nonimported_procs(Task, NotAditi,
+ ModuleInfo0, ModuleInfo).
+
+process_all_nonimported_procs(Task0, Task, ModuleInfo0, ModuleInfo) -->
+ { True = lambda([_PredInfo::in] is semidet, true) },
+ process_matching_nonimported_procs(Task0, Task, True,
+ ModuleInfo0, ModuleInfo).
+
+process_matching_nonimported_procs(Task, Filter, ModuleInfo0, ModuleInfo) -->
{ module_info_predids(ModuleInfo0, PredIds) },
( { Task = update_pred_error(Pred) } ->
- list__foldl2(process_nonimported_pred(Pred), PredIds,
+ list__foldl2(process_nonimported_pred(Pred, Filter), PredIds,
ModuleInfo0, ModuleInfo)
;
- process_nonimported_procs_in_preds(PredIds, Task, _,
+ process_nonimported_procs_in_preds(PredIds, Task, _, Filter,
ModuleInfo0, ModuleInfo)
).
-process_all_nonimported_procs(Task0, Task, ModuleInfo0, ModuleInfo) -->
+process_matching_nonimported_procs(Task0, Task, Filter,
+ ModuleInfo0, ModuleInfo) -->
{ module_info_predids(ModuleInfo0, PredIds) },
- process_nonimported_procs_in_preds(PredIds, Task0, Task,
+ process_nonimported_procs_in_preds(PredIds, Task0, Task, Filter,
ModuleInfo0, ModuleInfo).
-:- pred process_nonimported_pred(pred_error_task, pred_id,
+:- pred process_nonimported_pred(pred_error_task, pred(pred_info), pred_id,
module_info, module_info, io__state, io__state).
-:- mode process_nonimported_pred(in(pred_error_task), in,
+:- mode process_nonimported_pred(in(pred_error_task), pred(in) is semidet, in,
in, out, di, uo) is det.
-process_nonimported_pred(Task, PredId, ModuleInfo0, ModuleInfo,
+process_nonimported_pred(Task, Filter, PredId, ModuleInfo0, ModuleInfo,
IO0, IO) :-
module_info_pred_info(ModuleInfo0, PredId, PredInfo0),
- ( pred_info_is_imported(PredInfo0) ->
+ (
+ ( pred_info_is_imported(PredInfo0)
+ ; \+ call(Filter, PredInfo0)
+ )
+ ->
ModuleInfo = ModuleInfo0,
IO = IO0
;
@@ -180,20 +217,25 @@
).
:- pred process_nonimported_procs_in_preds(list(pred_id), task, task,
- module_info, module_info, io__state, io__state).
-:- mode process_nonimported_procs_in_preds(in, task, out(task), in, out,
- di, uo) is det.
+ pred(pred_info), module_info, module_info, io__state, io__state).
+:- mode process_nonimported_procs_in_preds(in, task, out(task),
+ pred(in) is semidet, in, out, di, uo) is det.
-process_nonimported_procs_in_preds([], Task, Task, ModuleInfo, ModuleInfo)
+process_nonimported_procs_in_preds([], Task, Task, _, ModuleInfo, ModuleInfo)
--> [].
-process_nonimported_procs_in_preds([PredId | PredIds], Task0, Task,
+process_nonimported_procs_in_preds([PredId | PredIds], Task0, Task, Filter,
ModuleInfo0, ModuleInfo) -->
{ module_info_preds(ModuleInfo0, PredTable) },
{ map__lookup(PredTable, PredId, PredInfo) },
- { pred_info_non_imported_procids(PredInfo, ProcIds) },
- process_nonimported_procs(ProcIds, PredId, Task0, Task1,
- ModuleInfo0, ModuleInfo1),
- process_nonimported_procs_in_preds(PredIds, Task1, Task,
+ ( { call(Filter, PredInfo) } ->
+ { pred_info_non_imported_procids(PredInfo, ProcIds) },
+ process_nonimported_procs(ProcIds, PredId, Task0, Task1,
+ ModuleInfo0, ModuleInfo1)
+ ;
+ { ModuleInfo1 = ModuleInfo0 },
+ { Task1 = Task0 }
+ ),
+ process_nonimported_procs_in_preds(PredIds, Task1, Task, Filter,
ModuleInfo1, ModuleInfo).
:- pred process_nonimported_procs(list(proc_id), pred_id, task, task,
Index: compiler/pd_info.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/pd_info.m,v
retrieving revision 1.1
diff -u -t -u -r1.1 pd_info.m
--- pd_info.m 1998/04/27 04:02:03 1.1
+++ pd_info.m 1998/05/07 05:55:08
@@ -735,13 +735,14 @@
{ pred_info_typevarset(PredInfo, TVarSet) },
{ pred_info_get_markers(PredInfo, Markers) },
{ pred_info_get_class_context(PredInfo, ClassContext) },
+ { pred_info_get_aditi_owner(PredInfo, Owner) },
{ proc_info_varset(ProcInfo, VarSet) },
{ proc_info_vartypes(ProcInfo, VarTypes) },
{ proc_info_typeinfo_varmap(ProcInfo, TVarMap) },
{ proc_info_typeclass_info_varmap(ProcInfo, TCVarMap) },
- { hlds_pred__define_new_pred(Goal, CallGoal, Args, InstMap,
- Name, TVarSet, VarTypes, ClassContext, TVarMap, TCVarMap,
- VarSet, Markers, ModuleInfo0, ModuleInfo, PredProcId) },
+ { hlds_pred__define_new_pred(Goal, CallGoal, Args, InstMap, Name,
+ TVarSet, VarTypes, ClassContext, TVarMap, TCVarMap, VarSet,
+ Markers, Owner, ModuleInfo0, ModuleInfo, PredProcId) },
pd_info_set_module_info(ModuleInfo).
%-----------------------------------------------------------------------------%
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/polymorphism.m,v
retrieving revision 1.138
diff -u -t -u -r1.138 polymorphism.m
--- polymorphism.m 1998/06/19 00:42:37 1.138
+++ polymorphism.m 1998/07/02 05:09:57
@@ -281,13 +281,31 @@
:- module polymorphism.
:- interface.
-:- import_module hlds_module, prog_data.
-:- import_module io.
+:- import_module hlds_goal, hlds_module, hlds_pred, prog_data.
+:- import_module io, list, term.
:- pred polymorphism__process_module(module_info, module_info,
io__state, io__state).
:- mode polymorphism__process_module(in, out, di, uo) is det.
+% Given a list of types, create a list of variables to hold the type_info
+% for those types, and create a list of goals to initialize those type_info
+% variables to the appropriate type_info structures for the types.
+% Update the varset and vartypes accordingly.
+
+:- pred polymorphism__make_type_info_vars(list(type),
+ list(var), list(hlds_goal), poly_info, poly_info).
+:- mode polymorphism__make_type_info_vars(in, out, out, in, out) is det.
+
+:- type poly_info.
+
+:- pred poly_info_init(module_info, pred_info, proc_info, poly_info).
+:- mode poly_info_init(in, in, in, out) is det.
+
+:- pred poly_info_extract(poly_info, pred_info, pred_info,
+ proc_info, proc_info, module_info).
+:- mode poly_info_extract(in, in, out, in, out, out) is det.
+
% unsafe_type_cast and unsafe_promise_unique are polymorphic
% builtins which do not need their type_infos. unsafe_type_cast
% can be introduced by common.m after polymorphism is run, so it
@@ -302,13 +320,13 @@
:- implementation.
-:- import_module hlds_pred, hlds_goal, hlds_data, llds, (lambda).
+:- import_module hlds_data, llds, (lambda).
:- import_module type_util, mode_util, quantification, instmap.
:- import_module code_util, unify_proc, special_pred, prog_util, make_hlds.
:- import_module (inst), hlds_out, base_typeclass_info, goal_util, passes_aux.
-:- import_module bool, int, string, list, set, map.
-:- import_module term, varset, std_util, require, assoc_list.
+:- import_module bool, int, string, set, map.
+:- import_module varset, std_util, require, assoc_list.
%-----------------------------------------------------------------------------%
@@ -327,8 +345,12 @@
IO0, IO),
module_info_preds(ModuleInfo1, Preds1),
map__keys(Preds1, PredIds1),
+
polymorphism__fixup_preds(PredIds1, ModuleInfo1, ModuleInfo2),
- polymorphism__expand_class_method_bodies(ModuleInfo2, ModuleInfo).
+ polymorphism__expand_class_method_bodies(ModuleInfo2, ModuleInfo3),
+
+ % Need update the dependency graph to include the lambda predicates.
+ module_info_clobber_dependency_info(ModuleInfo3, ModuleInfo).
:- pred polymorphism__process_preds(list(pred_id), module_info, module_info,
io__state, io__state).
@@ -345,12 +367,21 @@
polymorphism__process_pred(PredId, ModuleInfo0, ModuleInfo, IO0, IO) :-
module_info_pred_info(ModuleInfo0, PredId, PredInfo),
- pred_info_module(PredInfo, PredModule),
- pred_info_name(PredInfo, PredName),
- pred_info_arity(PredInfo, PredArity),
(
- polymorphism__no_type_info_builtin(PredModule,
- PredName, PredArity)
+ (
+ % Leave Aditi aggregates alone, since
+ % calls to them must be monomorphic.
+ % Other Aditi procedures should still be processed
+ % to remove complicated unifications and
+ % lambda expressions.
+ hlds_pred__pred_info_is_aditi_aggregate(PredInfo)
+ ;
+ pred_info_module(PredInfo, PredModule),
+ pred_info_name(PredInfo, PredName),
+ pred_info_arity(PredInfo, PredArity),
+ polymorphism__no_type_info_builtin(PredModule,
+ PredName, PredArity)
+ )
->
ModuleInfo = ModuleInfo0,
IO = IO0
@@ -458,6 +489,7 @@
% the type_info var
% for each of the pred's type
% parameters
+ pred_markers, % from the pred_info
map(class_constraint, var),
% specifies the location of
@@ -480,6 +512,7 @@
% polymorphism.m
string, % pred name
+ string, % Aditi owner
module_info
).
@@ -489,18 +522,16 @@
polymorphism__process_proc(ProcInfo0, PredInfo0, ModuleInfo0,
ProcInfo, PredInfo, ModuleInfo) :-
- % grab the appropriate fields from the pred_info and proc_info
+
pred_info_arg_types(PredInfo0, ArgTypeVarSet, ArgTypes),
- pred_info_typevarset(PredInfo0, TypeVarSet0),
pred_info_get_class_context(PredInfo0, ClassContext),
- pred_info_get_constraint_proofs(PredInfo0, Proofs),
- pred_info_name(PredInfo0, PredName),
- proc_info_headvars(ProcInfo0, HeadVars0),
- proc_info_varset(ProcInfo0, VarSet0),
- proc_info_vartypes(ProcInfo0, VarTypes0),
proc_info_goal(ProcInfo0, Goal0),
+ proc_info_headvars(ProcInfo0, HeadVars0),
proc_info_argmodes(ProcInfo0, ArgModes0),
-
+ poly_info_init(ModuleInfo0, PredInfo0, ProcInfo0, Info0),
+ Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet0,
+ _TypeInfoMap0, Markers, _TypeclassInfoLocations0,
+ Proofs, PredName, Owner, ModuleInfo1),
% Insert extra head variables to hold the address of the
% type_infos and typeclass_infos.
@@ -511,7 +542,7 @@
% Make a fresh variable for each class constraint, returning
% a list of variables that appear in the constraints, along
% with the location of the type infos for them.
- polymorphism__make_typeclass_info_head_vars(ClassContext, ModuleInfo0,
+ polymorphism__make_typeclass_info_head_vars(ClassContext, ModuleInfo1,
VarSet0, VarTypes0, ExtraHeadTypeclassInfoVars,
TypeClassInfoMap, ConstrainedTVars,
VarSet1, VarTypes1),
@@ -552,27 +583,19 @@
map__from_corresponding_lists(ClassContext, ExtraHeadTypeclassInfoVars,
TypeclassInfoLocations0),
- Info0 = poly_info(VarSet2, VarTypes2, TypeVarSet0,
- TypeInfoMap1, TypeclassInfoLocations0,
- Proofs, PredName, ModuleInfo0),
+ Info1 = poly_info(VarSet2, VarTypes2, TypeVarSet0,
+ TypeInfoMap1, Markers, TypeclassInfoLocations0,
+ Proofs, PredName, Owner, ModuleInfo1),
% process any polymorphic calls inside the goal
- polymorphism__process_goal(Goal0, Goal1, Info0, Info1),
- polymorphism__fixup_quantification(Goal1, Goal, _, Info1, Info),
- Info = poly_info(VarSet, VarTypes, TypeVarSet,
- TypeInfoMap, TypeclassInfoLocations,
- _Proofs, _PredName, ModuleInfo),
+ polymorphism__process_goal(Goal0, Goal1, Info1, Info2),
+ polymorphism__fixup_quantification(Goal1, Goal, _, Info2, Info),
- % set the new values of the fields in proc_info and pred_info
proc_info_set_headvars(ProcInfo0, HeadVars, ProcInfo1),
proc_info_set_goal(ProcInfo1, Goal, ProcInfo2),
- proc_info_set_varset(ProcInfo2, VarSet, ProcInfo3),
- proc_info_set_vartypes(ProcInfo3, VarTypes, ProcInfo4),
- proc_info_set_argmodes(ProcInfo4, ArgModes, ProcInfo5),
- proc_info_set_typeinfo_varmap(ProcInfo5, TypeInfoMap, ProcInfo6),
- proc_info_set_typeclass_info_varmap(ProcInfo6, TypeclassInfoLocations,
- ProcInfo),
- pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo).
+ proc_info_set_argmodes(ProcInfo2, ArgModes, ProcInfo3),
+ poly_info_extract(Info, PredInfo0, PredInfo,
+ ProcInfo3, ProcInfo, ModuleInfo).
:- pred polymorphism__process_goal(hlds_goal, hlds_goal,
poly_info, poly_info).
@@ -609,7 +632,7 @@
{ list__length(ArgVars0, Arity) },
{ special_pred_name_arity(SpecialPredId, PredName0,
MangledPredName, Arity) },
- =(poly_info(_, VarTypes, _, _, _, _, _, ModuleInfo)),
+ =(poly_info(_, VarTypes, _, _, _, _, _, _, _, ModuleInfo)),
{ special_pred_get_type(MangledPredName, ArgVars0, MainVar) },
{ map__lookup(VarTypes, MainVar, Type) },
{ Type \= term__variable(_) },
@@ -645,7 +668,8 @@
{ Unification = complicated_unify(UniMode, CanFail) },
{ Y = var(YVar) }
->
- =(poly_info(_, VarTypes, _, TypeInfoMap, _, _, _, ModuleInfo)),
+ =(poly_info(_, VarTypes, _, TypeInfoMap,
+ _, _, _, _, _, ModuleInfo)),
{ map__lookup(VarTypes, XVar, Type) },
( { Type = term__variable(TypeVar) } ->
% Convert polymorphic unifications into calls to
@@ -810,7 +834,7 @@
% so that the c_code can refer to the type_info variable
% for type T as `TypeInfo_for_T'.
%
- =(poly_info(_, _, _, _, _, _, _, ModuleInfo)),
+ =(poly_info(_, _, _, _, _, _, _, _, _, ModuleInfo)),
{ module_info_pred_info(ModuleInfo, PredId, PredInfo) },
{ pred_info_arg_types(PredInfo, PredTypeVarSet, PredArgTypes) },
{ term__vars_list(PredArgTypes, PredTypeVars0) },
@@ -890,7 +914,8 @@
polymorphism__process_call(PredId0, ProcId0, ArgVars0, PredId, ProcId, ArgVars,
ExtraVars, ExtraGoals, Info0, Info) :-
- Info0 = poly_info(A, VarTypes, TypeVarSet0, D, E, F, G, ModuleInfo),
+ Info0 = poly_info(A, VarTypes, TypeVarSet0, D,
+ Markers, F, G, H, I, ModuleInfo),
module_info_pred_info(ModuleInfo, PredId0, PredInfo),
pred_info_arg_types(PredInfo, PredTypeVarSet, PredArgTypes0),
@@ -913,6 +938,12 @@
% some builtins don't need the type_info
polymorphism__no_type_info_builtin(PredModule,
PredName, PredArity)
+ ;
+ % Leave Aditi relations alone, since they must
+ % be monomorphic.
+ hlds_pred__pred_info_is_aditi_relation(PredInfo)
+ ;
+ hlds_pred__pred_info_is_aditi_aggregate(PredInfo)
)
->
PredId = PredId0,
@@ -935,8 +966,8 @@
apply_subst_to_constraints(Subst, PredClassContext0,
PredClassContext),
- Info1 = poly_info(A, VarTypes, TypeVarSet, D, E, F, G,
- ModuleInfo),
+ Info1 = poly_info(A, VarTypes, TypeVarSet, D, Markers,
+ F, G, H, I, ModuleInfo),
% Make the typeclass_infos for the call, and return
% a list of which variables were constrained by the
@@ -955,7 +986,6 @@
term__var_list_to_term_list(PredTypeVars, PredTypes0),
term__apply_rec_substitution_to_list(PredTypes0, TypeSubst,
PredTypes),
-
polymorphism__make_type_info_vars(PredTypes,
ExtraTypeInfoVars, ExtraTypeInfoGoals,
Info2, Info),
@@ -980,8 +1010,8 @@
%
polymorphism__fixup_quantification(Goal0, Goal, NewOutsideVars, Info0, Info) :-
- Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeVarMap,
- TypeClassVarMap, Proofs, PredName, ModuleInfo),
+ Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet, TypeVarMap, Markers,
+ TypeClassVarMap, Proofs, PredName, Owner, ModuleInfo),
( map__is_empty(TypeVarMap) ->
set__init(NewOutsideVars),
Info = Info0,
@@ -995,7 +1025,8 @@
implicitly_quantify_goal(Goal0, VarSet0, VarTypes0,
OutsideVars, Goal, VarSet, VarTypes, _Warnings),
Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeVarMap,
- TypeClassVarMap, Proofs, PredName, ModuleInfo)
+ Markers, TypeClassVarMap, Proofs,
+ PredName, Owner, ModuleInfo)
).
:- pred polymorphism__process_lambda(pred_or_func, list(var),
@@ -1008,8 +1039,8 @@
polymorphism__process_lambda(PredOrFunc, Vars, Modes, Det, OrigNonLocals,
NonLocalTypeInfos, LambdaGoal, Unification0, Functor,
Unification, PolyInfo0, PolyInfo) :-
- PolyInfo0 = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
- TCVarMap, Proofs, PredName, ModuleInfo0),
+ PolyInfo0 = poly_info(VarSet, VarTypes, TVarSet, TVarMap, Markers,
+ TCVarMap, Proofs, PredName, Owner, ModuleInfo0),
% Calculate the constraints which apply to this lambda
% expression.
@@ -1022,10 +1053,11 @@
lambda__transform_lambda(PredOrFunc, PredName, Vars, Modes, Det,
OrigNonLocals, NonLocalTypeInfos, LambdaGoal, Unification0,
- VarSet, VarTypes, Constraints, TVarSet, TVarMap, TCVarMap,
- ModuleInfo0, Functor, Unification, ModuleInfo),
- PolyInfo = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
- TCVarMap, Proofs, PredName, ModuleInfo).
+ VarSet, VarTypes, Constraints, TVarSet, TVarMap, Markers,
+ TCVarMap, Owner, ModuleInfo0, Functor, Unification,
+ ModuleInfo),
+ PolyInfo = poly_info(VarSet, VarTypes, TVarSet, TVarMap, Markers,
+ TCVarMap, Proofs, PredName, Owner, ModuleInfo).
:- pred polymorphism__constraint_contains_vars(list(var), class_constraint).
:- mode polymorphism__constraint_contains_vars(in, in) is semidet.
@@ -1157,7 +1189,8 @@
NewC = constraint(ClassName, ConstrainedTypes),
Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet0, TypeInfoMap0,
- TypeClassInfoMap0, Proofs, PredName, ModuleInfo),
+ Markers, TypeClassInfoMap0, Proofs, PredName,
+ Owner, ModuleInfo),
(
map__search(TypeClassInfoMap0, NewC, Location)
@@ -1326,8 +1359,8 @@
SubClassId = class_id(SubClassName, SubClassArity),
Info1 = poly_info(VarSet1, VarTypes1, TypeVarSet0,
- TypeInfoMap0, TypeClassInfoMap0, Proofs,
- PredName, ModuleInfo),
+ TypeInfoMap0, Markers, TypeClassInfoMap0,
+ Proofs, PredName, Owner, ModuleInfo),
% Make the typeclass_info for the subclass
polymorphism__make_typeclass_info_var(
@@ -1378,16 +1411,16 @@
),
Info2 = poly_info(VarSet2, VarTypes2, TypeVarSet2,
- TypeInfoMap2, TypeClassInfoMap2, Proofs2,
- PredName2, ModuleInfo2),
+ TypeInfoMap2, Markers2, TypeClassInfoMap2,
+ Proofs2, PredName2, Owner2, ModuleInfo2),
polymorphism__make_count_var(SuperClassIndex, VarSet2,
VarTypes2, IndexVar, IndexGoal, VarSet,
VarTypes),
Info = poly_info(VarSet, VarTypes, TypeVarSet2,
- TypeInfoMap2, TypeClassInfoMap2, Proofs2,
- PredName2, ModuleInfo2),
+ TypeInfoMap2, Markers2, TypeClassInfoMap2,
+ Proofs2, PredName2, Owner2, ModuleInfo2),
% We extract the superclass typeclass_info by
% inserting a call to
@@ -1437,7 +1470,7 @@
polymorphism__construct_typeclass_info(ArgTypeInfoVars, ArgTypeClassInfoVars,
ClassId, InstanceNum, NewVar, NewGoals, Info0, Info) :-
- Info0 = poly_info(_, _, _, _, _, _, _, ModuleInfo),
+ Info0 = poly_info(_, _, _, _, _, _, _, _, _, ModuleInfo),
module_info_instances(ModuleInfo, InstanceTable),
map__lookup(InstanceTable, ClassId, InstanceList),
@@ -1452,8 +1485,8 @@
SuperClassProofs, ArgSuperClassVars, SuperClassGoals,
Info0, Info1),
- Info1 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap, TCVarMap,
- Proofs, PredName, _),
+ Info1 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap, Markers,
+ TCVarMap, Proofs, PredName, Owner, _),
% lay out the argument variables as expected in the
% typeclass_info
@@ -1538,8 +1571,8 @@
TypeClassInfoGoal = Unify - GoalInfo,
NewGoals0 = [TypeClassInfoGoal, BaseGoal],
list__append(NewGoals0, SuperClassGoals, NewGoals),
- Info = poly_info(VarSet, VarTypes, TVarSet, TVarMap,
- TCVarMap, Proofs, PredName, ModuleInfo).
+ Info = poly_info(VarSet, VarTypes, TVarSet, TVarMap, Markers,
+ TCVarMap, Proofs, PredName, Owner, ModuleInfo).
%---------------------------------------------------------------------------%
@@ -1552,24 +1585,25 @@
polymorphism__get_arg_superclass_vars(ClassDefn, InstanceTypes,
SuperClassProofs, NewVars, NewGoals, Info0, Info) :-
- Info0 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap0, TCVarMap0,
- Proofs, PredName, ModuleInfo),
+ Info0 = poly_info(VarSet0, VarTypes0, TVarSet, TVarMap0, Markers,
+ TCVarMap0, Proofs, PredName, Owner, ModuleInfo),
ClassDefn = hlds_class_defn(SuperClasses, ClassVars, _, ClassVarSet, _),
map__from_corresponding_lists(ClassVars, InstanceTypes, TypeSubst),
varset__merge_subst(VarSet0, ClassVarSet, VarSet1, Subst),
- Info1 = poly_info(VarSet1, VarTypes0, TVarSet, TVarMap0, TCVarMap0,
- SuperClassProofs, PredName, ModuleInfo),
+ Info1 = poly_info(VarSet1, VarTypes0, TVarSet, TVarMap0, Markers,
+ TCVarMap0, SuperClassProofs, PredName, Owner, ModuleInfo),
polymorphism__make_superclasses_from_proofs(SuperClasses, Subst,
TypeSubst, [], NewGoals, Info1, Info2, [], NewVars),
- Info2 = poly_info(VarSet, VarTypes, _, TVarMap, TCVarMap, _, _, _),
+ Info2 = poly_info(VarSet, VarTypes, _, TVarMap, _, TCVarMap,
+ _, _, _, _),
- Info = poly_info(VarSet, VarTypes, TVarSet, TVarMap, TCVarMap,
- Proofs, PredName, ModuleInfo) .
+ Info = poly_info(VarSet, VarTypes, TVarSet, TVarMap, Markers, TCVarMap,
+ Proofs, PredName, Owner, ModuleInfo).
:- pred polymorphism__make_superclasses_from_proofs(list(class_constraint),
@@ -1595,15 +1629,6 @@
%---------------------------------------------------------------------------%
-% Given a list of types, create a list of variables to hold the type_info
-% for those types, and create a list of goals to initialize those type_info
-% variables to the appropriate type_info structures for the types.
-% Update the varset and vartypes accordingly.
-
-:- pred polymorphism__make_type_info_vars(list(type),
- list(var), list(hlds_goal), poly_info, poly_info).
-:- mode polymorphism__make_type_info_vars(in, out, out, in, out) is det.
-
polymorphism__make_type_info_vars([], [], [], Info, Info).
polymorphism__make_type_info_vars([Type | Types],
ExtraVars, ExtraGoals, Info0, Info) :-
@@ -1648,7 +1673,7 @@
no, Var, ExtraGoals, Info0, Info)
;
Type = term__variable(TypeVar1),
- Info0 = poly_info(_, _, _, TypeInfoMap0, _, _, _, _),
+ Info0 = poly_info(_, _, _, TypeInfoMap0, _, _, _, _, _, _),
map__search(TypeInfoMap0, TypeVar1, TypeInfoLocn)
->
% This occurs for code where a predicate calls a polymorphic
@@ -1725,10 +1750,10 @@
TypeId = unqualified("void") - 0,
polymorphism__construct_type_info(Type, TypeId, [],
no, Var, ExtraGoals, Info0, Info1),
- Info1 = poly_info(A, B, C, TypeInfoMap1, E, F, G, H),
+ Info1 = poly_info(A, B, C, TypeInfoMap1, E, F, G, H, I, J),
map__det_insert(TypeInfoMap1, TypeVar1, type_info(Var),
TypeInfoMap),
- Info = poly_info(A, B, C, TypeInfoMap, E, F, G, H)
+ Info = poly_info(A, B, C, TypeInfoMap, E, F, G, H, I, J)
***************/
;
error("polymorphism__make_var: unknown type")
@@ -1746,7 +1771,7 @@
polymorphism__make_type_info_vars(TypeArgs, ArgTypeInfoVars,
ArgTypeInfoGoals, Info0, Info1),
- Info1 = poly_info(VarSet1, VarTypes1, C, D, E, F, G, ModuleInfo),
+ Info1 = poly_info(VarSet1, VarTypes1, C, D, E, F, G, H, I, ModuleInfo),
polymorphism__init_const_base_type_info_var(Type,
TypeId, ModuleInfo, VarSet1, VarTypes1,
@@ -1756,7 +1781,7 @@
BaseVar, VarSet2, VarTypes2, [BaseGoal],
Var, VarSet, VarTypes, ExtraGoals),
- Info = poly_info(VarSet, VarTypes, C, D, E, F, G, ModuleInfo).
+ Info = poly_info(VarSet, VarTypes, C, D, E, F, G, H, I, ModuleInfo).
% Create a unification for the two-cell type_info
% variable for this type if the type arity is not zero:
@@ -2155,11 +2180,11 @@
extract_type_info(Type, TypeVar, TypeClassInfoVar, Index, Goals,
TypeInfoVar, PolyInfo0, PolyInfo) :-
PolyInfo0 = poly_info(VarSet0, VarTypes0, C, TypeInfoLocns0,
- E, F, G, ModuleInfo),
+ E, F, G, H, I, ModuleInfo),
extract_type_info_2(Type, TypeVar, TypeClassInfoVar, Index, ModuleInfo,
Goals, TypeInfoVar, VarSet0, VarTypes0, TypeInfoLocns0,
VarSet, VarTypes, TypeInfoLocns),
- PolyInfo = poly_info(VarSet, VarTypes, C, TypeInfoLocns, E, F, G,
+ PolyInfo = poly_info(VarSet, VarTypes, C, TypeInfoLocns, E, F, G, H, I,
ModuleInfo).
:- pred extract_type_info_2(type, tvar, var, int, module_info, list(hlds_goal),
@@ -2481,18 +2506,46 @@
%---------------------------------------------------------------------------%
-:- pred polymorphism__get_module_info(module_info, poly_info, poly_info).
+poly_info_init(ModuleInfo0, PredInfo0, ProcInfo0, Info0) :-
+ % grab the appropriate fields from the pred_info and proc_info
+ pred_info_typevarset(PredInfo0, TypeVarSet0),
+ pred_info_get_markers(PredInfo0, Markers),
+ pred_info_get_constraint_proofs(PredInfo0, Proofs),
+ pred_info_name(PredInfo0, PredName),
+ pred_info_get_aditi_owner(PredInfo0, Owner),
+ proc_info_varset(ProcInfo0, VarSet0),
+ proc_info_vartypes(ProcInfo0, VarTypes0),
+ map__init(TypeclassInfoLocations0),
+ map__init(TypeInfoMap0),
+ Info0 = poly_info(VarSet0, VarTypes0, TypeVarSet0,
+ TypeInfoMap0, Markers, TypeclassInfoLocations0,
+ Proofs, PredName, Owner, ModuleInfo0).
+
+poly_info_extract(Info, PredInfo0, PredInfo,
+ ProcInfo0, ProcInfo, ModuleInfo) :-
+ Info = poly_info(VarSet, VarTypes, TypeVarSet, TypeInfoMap, _,
+ TypeclassInfoLocations, _Proofs, _Name, _Owner, ModuleInfo),
+
+ % set the new values of the fields in proc_info and pred_info
+ proc_info_set_varset(ProcInfo0, VarSet, ProcInfo1),
+ proc_info_set_vartypes(ProcInfo1, VarTypes, ProcInfo2),
+ proc_info_set_typeinfo_varmap(ProcInfo2, TypeInfoMap, ProcInfo3),
+ proc_info_set_typeclass_info_varmap(ProcInfo3, TypeclassInfoLocations,
+ ProcInfo),
+ pred_info_set_typevarset(PredInfo0, TypeVarSet, PredInfo).
+
+:- pred polymorphism__get_module_info(module_info, poly_info, poly_info) is det.
:- mode polymorphism__get_module_info(out, in, out) is det.
polymorphism__get_module_info(ModuleInfo, PolyInfo, PolyInfo) :-
- PolyInfo = poly_info(_, _, _, _, _, _, _, ModuleInfo).
+ PolyInfo = poly_info(_, _, _, _, _, _, _, _, _, ModuleInfo).
:- pred polymorphism__set_module_info(module_info, poly_info, poly_info).
:- mode polymorphism__set_module_info(in, in, out) is det.
polymorphism__set_module_info(ModuleInfo, PolyInfo0, PolyInfo) :-
- PolyInfo0 = poly_info(A, B, C, D, E, F, G, _),
- PolyInfo = poly_info(A, B, C, D, E, F, G, ModuleInfo).
+ PolyInfo0 = poly_info(A, B, C, D, E, F, G, H, I, _),
+ PolyInfo = poly_info(A, B, C, D, E, F, G, H, I, ModuleInfo).
%---------------------------------------------------------------------------%
%---------------------------------------------------------------------------%
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/post_typecheck.m,v
retrieving revision 1.1
diff -u -t -u -r1.1 post_typecheck.m
--- post_typecheck.m 1998/06/04 17:25:59 1.1
+++ post_typecheck.m 1998/06/18 23:58:20
@@ -60,6 +60,8 @@
% Do the stuff needed to initialize the proc_infos so that
% a pred is ready for mode checking (copy clauses from the
% clause_info to the proc_info, etc.)
+ % Also check that all predicates with an `aditi' marker have
+ % an `aditi:state' argument.
%
:- pred post_typecheck__finish_pred(module_info, pred_id, pred_info, pred_info,
io__state, io__state).
@@ -73,7 +75,7 @@
:- implementation.
:- import_module typecheck, clause_to_proc, mode_util, inst_match.
-:- import_module mercury_to_mercury, prog_out, hlds_out.
+:- import_module mercury_to_mercury, prog_out, hlds_out, type_util.
:- import_module globals, options.
:- import_module map, set, assoc_list, varset, bool, std_util.
@@ -275,6 +277,23 @@
{ pred_info_arg_types(PredInfo0, _, ArgTypes) },
{ pred_info_procedures(PredInfo0, Procs0) },
{ pred_info_procids(PredInfo0, ProcIds) },
+
+ %
+ % Check that all Aditi predicates have an `aditi:state' argument.
+ %
+ { pred_info_get_markers(PredInfo0, Markers) },
+ (
+ { check_marker(Markers, aditi) },
+ \+ {
+ list__member(ArgType, ArgTypes),
+ type_is_aditi_state(ArgType)
+ }
+ ->
+ report_no_aditi_state(PredInfo0)
+ ;
+ []
+ ),
+
propagate_types_into_proc_modes(ModuleInfo, PredId, ProcIds, ArgTypes,
Procs0, Procs),
{ pred_info_set_procedures(PredInfo0, Procs, PredInfo) }.
@@ -326,5 +345,24 @@
io__write_string(" error: unbound inst variable(s).\n"),
prog_out__write_context(Context),
io__write_string(" (Sorry, polymorphic modes are not supported.)\n").
+
+%-----------------------------------------------------------------------------%
+
+:- pred report_no_aditi_state(pred_info, io__state, io__state).
+:- mode report_no_aditi_state(in, di, uo) is det.
+
+report_no_aditi_state(PredInfo) -->
+ io__set_exit_status(1),
+ { pred_info_context(PredInfo, Context) },
+ prog_out__write_context(Context),
+ { pred_info_module(PredInfo, Module) },
+ { pred_info_name(PredInfo, Name) },
+ { pred_info_arity(PredInfo, Arity) },
+ { pred_info_get_is_pred_or_func(PredInfo, PredOrFunc) },
+ io__write_string("Error: `:- pragma aditi' declaration for "),
+ hlds_out__write_pred_or_func(PredOrFunc),
+ io__write_string(" "),
+ hlds_out__write_pred_call_id(qualified(Module, Name)/Arity),
+ io__write_string(" without an `aditi:state' argument.\n").
%-----------------------------------------------------------------------------%
Index: compiler/prog_data.m
===================================================================
RCS file: /home/staff/zs/imp/mercury/compiler/prog_data.m,v
retrieving revision 1.36
diff -u -t -u -r1.36 prog_data.m
--- prog_data.m 1998/06/09 02:14:23 1.36
+++ prog_data.m 1998/06/11 01:05:16
@@ -104,6 +104,12 @@
% PredName, Predicate or Function, Vars/Mode,
% VarNames, C Code Implementation Info
+ ; memo(sym_name, arity)
+ % Predname, Arity
+
+ ; no_memo(sym_name, int)
+ % Predname, Arity
+
; inline(sym_name, arity)
% Predname, Arity
@@ -136,6 +142,34 @@
; fact_table(sym_name, arity, string)
% Predname, Arity, Fact file name.
+
+ ; aditi(sym_name, int)
+ % Predname, Arity
+
+ ; base_relation(sym_name, int)
+ % Predname, Arity
+ %
+ % Eventually, these should only occur in
+ % automatically generated database interface
+ % files, but for now there's no such thing,
+ % so they can occur in user programs.
+
+ ; naive(sym_name, int)
+ % Predname, Arity
+ % Use naive evaluation.
+
+ ; psn(sym_name, int)
+ % Predname, Arity
+ % Use predicate semi-naive evaluation.
+
+ ; supp_magic(sym_name, int)
+ % Predname, Arity
+
+ ; context(sym_name, int)
+ % Predname, Arity
+
+ ; owner(sym_name, int, string)
+ % PredName, Arity, String.
; tabled(eval_method, sym_name, int, maybe(pred_or_func),
maybe(list(mode)))
More information about the developers
mailing list