diff: split mercury_builtin.m
Fergus Henderson
fjh at cs.mu.OZ.AU
Tue May 26 07:34:40 AEST 1998
Estimated hours taken: 5
Fix various invasions of the user's namespace by `mercury_builtin.m',
by splitting mercury_builtin.m into two modules, called builtin.m and
private_builtin.m, and ensuring that the latter is imported as if
by `:- use_module' rather than `:- import_module'.
library/builtin.m:
library/private_builtin.m:
Split mercury_builtin.m into two modules, builtin.m,
which contains stuff intended to be public,
and private_builtin.m, which contains implementation
details that are not supposed to be public.
library/mercury_builtin.m:
Add a comment saying that this module is no longer used, and
should eventually be removed. I have not removed it yet, since
that would prevent bootstrapping with the current compiler. It
will be removed as a seperate change later, once all the
changes have propagated.
compiler/prog_util.m:
Change the definition of mercury_private_builtin_module/1 and
mercury_public_builtin_module so that instead of automatically
importing mercury_builtin.m as if by `import_module', the
copiler will now automatically import builtin.m as if by
`import_module' and private_builtin.m as if by `use_module'.
compiler/polymorphism.m:
Change a call to mercury_private_builtin_module/1 for
unsafe_promise_unique to instead call mercury_public_builtin_module/1.
compiler/unify_proc.m:
Avoid hard-coding "mercury_builtin" by instead
calling one of mercury_{private,public}_builtin_module/1.
runtime/mercury_type_info.[ch]:
library/term.m:
library/std_util.m:
compiler/code_util.m:
Change a few hard-coded instances of "mercury_builtin"
to "builtin" or "private_builtin" as appropriate.
runtime/mercury_trace_util.c:
runtime/mercury_trace_internal.c:
library/prolog.m:
compiler/*.m:
Update comments that refer to "mercury_builtin" to instead
refer to either "builtin" or "private_builtin".
doc/Mmakefile:
Don't include the interface to private_builtin.m in the
library reference manual.
tools/bootcheck:
Add `-p'/`--copy-profiler' option. This is needed to get
the above changes to bootstrap.
tools/test_mercury:
Pass `-p' to tools/bootcheck.
cvs diff: Diffing .
cvs diff: Diffing bindist
cvs diff: Diffing boehm_gc
cvs diff: Diffing boehm_gc/Mac_files
cvs diff: Diffing boehm_gc/cord
cvs diff: Diffing boehm_gc/cord/private
cvs diff: Diffing boehm_gc/include
cvs diff: Diffing boehm_gc/include/private
cvs diff: Diffing bytecode
cvs diff: Diffing bytecode/test
cvs diff: Diffing compiler
Index: compiler/base_type_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/base_type_info.m,v
retrieving revision 1.16
diff -u -u -r1.16 base_type_info.m
--- base_type_info.m 1998/03/03 17:33:31 1.16
+++ base_type_info.m 1998/05/25 19:05:43
@@ -141,13 +141,12 @@
ArityArg = yes(const(int_const(TypeArity))),
(
( Status = exported ; Status = abstract_exported
- ; Status = imported % XXX this is a hack to make it work
- % for `term__context', which is defined
- % in mercury_builtin.m, but whose
- % base_type_info is generated in
- % term.m. Apart from special cases
- % in mercury_builtin.m, this should
- % never happen.
+ ; Status = imported % XXX this is an old hack to make it
+ % work for `term__context', which was
+ % once defined in mercury_builtin.m,
+ % but whose base_type_info was
+ % generated in term.m.
+ % It's probably not needed anymore.
)
->
Exported = yes
@@ -205,7 +204,7 @@
module_info_globals(ModuleInfo, Globals),
% If eliminated, make procs point to
- % mercury_builtin__unused. (Or, if static code
+ % private_builtin__unused. (Or, if static code
% addresses are not available, use NULL
% pointers).
(
Index: compiler/base_type_layout.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/base_type_layout.m,v
retrieving revision 1.29
diff -u -u -r1.29 base_type_layout.m
--- base_type_layout.m 1998/05/15 07:06:58 1.29
+++ base_type_layout.m 1998/05/25 19:06:59
@@ -32,7 +32,7 @@
% solutions
% array.m - array type
% io.m - io__stream type
-% mercury_builtin.m - builtin types
+% builtin.m - builtin types
%
% runtime: mercury_type_info.h - defines layout macros
% mercury_deep_copy.{c,h} - deep_copy
Index: compiler/code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_util.m,v
retrieving revision 1.96
diff -u -u -r1.96 code_util.m
--- code_util.m 1998/04/08 11:31:23 1.96
+++ code_util.m 1998/05/25 18:28:20
@@ -368,14 +368,14 @@
maybe(rval), maybe(pair(var, rval))).
:- mode code_util__translate_builtin_2(in, in, in, in, out, out) is semidet.
-code_util__translate_builtin_2("mercury_builtin", "unsafe_type_cast", 0,
+code_util__translate_builtin_2("private_builtin", "unsafe_type_cast", 0,
[X, Y], no, yes(Y - var(X))).
-code_util__translate_builtin_2("mercury_builtin", "unsafe_promise_unique", 0,
+code_util__translate_builtin_2("builtin", "unsafe_promise_unique", 0,
[X, Y], no, yes(Y - var(X))).
-code_util__translate_builtin_2("mercury_builtin", "builtin_int_gt", 0, [X, Y],
+code_util__translate_builtin_2("private_builtin", "builtin_int_gt", 0, [X, Y],
yes(binop((>), var(X), var(Y))), no).
-code_util__translate_builtin_2("mercury_builtin", "builtin_int_lt", 0, [X, Y],
+code_util__translate_builtin_2("private_builtin", "builtin_int_lt", 0, [X, Y],
yes(binop((<), var(X), var(Y))), no).
code_util__translate_builtin_2("int", "builtin_plus", 0, [X, Y, Z],
Index: compiler/dead_proc_elim.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/dead_proc_elim.m,v
retrieving revision 1.38
diff -u -u -r1.38 dead_proc_elim.m
--- dead_proc_elim.m 1998/03/03 17:33:56 1.38
+++ dead_proc_elim.m 1998/05/25 19:07:32
@@ -692,8 +692,9 @@
% polymorphism.
code_util__compiler_generated(PredInfo)
;
- % Don't eliminate preds from mercury_builtin.m since
- % polymorphism.m needs unify/2 and friends.
+ % Don't eliminate preds from builtin.m or
+ % private_builtin.m, since polymorphism.m
+ % needs unify/2 and friends.
mercury_public_builtin_module(PredModule)
;
mercury_private_builtin_module(PredModule)
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.80
diff -u -u -r1.80 llds_out.m
--- llds_out.m 1998/05/16 07:30:19 1.80
+++ llds_out.m 1998/05/25 19:08:20
@@ -2495,8 +2495,8 @@
)
% The conditions above define which labels are printed without
% module qualification. XXX Changes to runtime/* are necessary
- % to allow `mercury_builtin' labels to be qualified/
- % overloaded.
+ % to allow `builtin' or `private_builtin' labels to be
+ % qualified.
->
LabelName0 = Name0
;
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.108
diff -u -u -r1.108 mode_util.m
--- mode_util.m 1998/03/03 17:35:15 1.108
+++ mode_util.m 1998/05/25 19:08:49
@@ -135,7 +135,7 @@
:- mode get_arg_lives(in, in, out) is det.
% Predicates to make error messages more readable by stripping
- % "mercury_builtin" module qualifiers from modes.
+ % "builtin:" module qualifiers from modes.
:- pred strip_builtin_qualifier_from_cons_id(cons_id, cons_id).
:- mode strip_builtin_qualifier_from_cons_id(in, out) is det.
@@ -1357,7 +1357,7 @@
%
% Predicates to make error messages more readable by stripping
- % "mercury_builtin" module qualifiers from modes and insts.
+ % "builtin:" module qualifiers from modes and insts.
% The interesting part is strip_builtin_qualifier_from_sym_name;
% the rest is basically just recursive traversals.
%
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.70
diff -u -u -r1.70 modules.m
--- modules.m 1998/05/18 03:18:37 1.70
+++ modules.m 1998/05/25 19:09:17
@@ -918,7 +918,8 @@
% following this do not need module qualifiers.
{ append_pseudo_decl(Module1, imported, Module2) },
- % Add `mercury_builtin' to the list of imported modules
+ % Add `builtin' and `private_builtin' to the
+ % list of imported modules
{ add_implicit_imports(ImportedModules1, UsedModules1,
ImportedModules2, UsedModules2) },
@@ -962,7 +963,7 @@
{ init_module_imports(ModuleName, Items0, [], [], Module0) },
{ append_pseudo_decl(Module0, imported, Module1) },
- % Add `mercury_builtin' to the imported modules.
+ % Add `builtin' and `private_builtin' to the imported modules.
{ add_implicit_imports(ImportDeps0, UseDeps0, ImportDeps1, UseDeps1) },
%
Index: compiler/polymorphism.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/polymorphism.m,v
retrieving revision 1.133
diff -u -u -r1.133 polymorphism.m
--- polymorphism.m 1998/04/08 15:23:25 1.133
+++ polymorphism.m 1998/05/25 19:10:05
@@ -139,7 +139,7 @@
% <base_type_layout for int/0>,
% <base_type_functors for int/0>,
% "int",
-% "mercury_builtin"),
+% "builtin"),
% r(TypeInfoT3, 0).
%
% Note that base_type_infos are actually generated as references to a
@@ -392,7 +392,7 @@
mercury_private_builtin_module(MercuryBuiltin).
polymorphism__no_type_info_builtin(MercuryBuiltin,
"unsafe_promise_unique", 2) :-
- mercury_private_builtin_module(MercuryBuiltin).
+ mercury_public_builtin_module(MercuryBuiltin).
%---------------------------------------------------------------------------%
@@ -660,7 +660,7 @@
->
PredId = CallPredId
;
- error("polymorphism.m: can't find `mercury_builtin:unify/2'")
+ error("polymorphism.m: can't find `builtin:unify/2'")
},
% XXX Bug! - we should check that the mode is (in, in),
% and report an error (e.g. "unification of
@@ -714,7 +714,7 @@
->
PredId = PredId0
;
- error("can't locate mercury_builtin:builtin_unify_pred/2")
+ error("can't locate private_builtin:builtin_unify_pred/2")
},
{ hlds_pred__in_in_unification_proc_id(ProcId) },
{ CallContext = call_unify_context(XVar, Y, Context) },
@@ -1382,7 +1382,7 @@
% We extract the superclass typeclass_info by
% inserting a call to
% superclass_from_typeclass_info in
- % mercury_builtin.
+ % private_builtin.
% Make the goal for the call
varset__init(Empty),
Index: compiler/prog_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_util.m,v
retrieving revision 1.40
diff -u -u -r1.40 prog_util.m
--- prog_util.m 1998/04/27 04:02:15 1.40
+++ prog_util.m 1998/05/25 16:59:40
@@ -19,15 +19,16 @@
%-----------------------------------------------------------------------------%
% Returns the name of the module containing public builtins;
- % traditionally this was "mercury_builtin", but it may eventually
- % be renamed "std:builtin".
+ % originally this was "mercury_builtin", but it later became
+ % just "builtin", and it may eventually be renamed "std:builtin".
:- pred mercury_public_builtin_module(sym_name).
:- mode mercury_public_builtin_module(out) is det.
% Returns the name of the module containing private builtins;
- % traditionally this was "mercury_builtin", but it may eventually
- % be renamed "std:private_builtin".
+ % traditionally this was "mercury_builtin", but it later became
+ % "private_builtin", and it may eventually be renamed
+ % "std:private_builtin".
:- pred mercury_private_builtin_module(sym_name).
:- mode mercury_private_builtin_module(out) is det.
@@ -118,13 +119,13 @@
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
-% -- not yet:
+% We may eventually want to put the standard library into a package "std":
% mercury_public_builtin_module(M) :-
% M = qualified(unqualified("std"), "builtin"))).
% mercury_private_builtin_module(M) :-
% M = qualified(unqualified("std"), "private_builtin"))).
-mercury_public_builtin_module(unqualified("mercury_builtin")).
-mercury_private_builtin_module(unqualified("mercury_builtin")).
+mercury_public_builtin_module(unqualified("builtin")).
+mercury_private_builtin_module(unqualified("private_builtin")).
unqualify_name(unqualified(PredName), PredName).
unqualify_name(qualified(_ModuleName, PredName), PredName).
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.21
diff -u -u -r1.21 special_pred.m
--- special_pred.m 1998/03/03 17:36:00 1.21
+++ special_pred.m 1998/05/25 19:10:30
@@ -34,7 +34,7 @@
% special_pred_name_arity(SpecialPredType, GenericPredName,
% TypeSpecificVersionPredName, Arity):
% true iff there is a special predicate of category
- % SpecialPredType, called mercury_builtin:GenericPredName/Arity,
+ % SpecialPredType, called builtin:GenericPredName/Arity,
% for which the type-specific versions will be called
% TypeSpecificVersionPredName.
:- pred special_pred_name_arity(special_pred_id, string, string, int).
Index: compiler/termination.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/termination.m,v
retrieving revision 1.11
diff -u -u -r1.11 termination.m
--- termination.m 1998/03/18 08:07:47 1.11
+++ termination.m 1998/05/25 19:13:31
@@ -459,8 +459,12 @@
%----------------------------------------------------------------------------%
% This predicate checks each ProcId in the list to see if it is a compiler
-% generated predicate, or a mercury_builtin predicate. If it is, then the
-% compiler sets the termination property of the ProcIds accordingly.
+% generated predicate, or a predicate from builtin.m or private_builtin.m.
+% If it is, then the compiler sets the termination property of the ProcIds
+% accordingly.
+
+% XXX This does the wrong thing for calls to unify/2,
+% which might not terminate in the case of user-defined equality predicates.
:- pred set_compiler_gen_terminates(pred_info, list(proc_id), pred_id,
module_info, proc_table, proc_table).
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.53
diff -u -u -r1.53 type_util.m
--- type_util.m 1998/05/20 17:58:03 1.53
+++ type_util.m 1998/05/25 19:15:04
@@ -107,7 +107,7 @@
% check whether that type is a no_tag type
% (i.e. one with only one constructor, and
% whose one constructor has only one argument,
- % and which is not mercury_builtin:type_info/1),
+ % and which is not private_builtin:type_info/1),
% and if so, return its constructor symbol and argument type.
:- pred type_is_no_tag_type(list(constructor), sym_name, type).
@@ -378,9 +378,9 @@
% The checks for type_info and base_type_info
% are needed because those types lie about their
% arity; it might be cleaner to change that in
- % mercury_builtin.m, but that would cause some
+ % private_builtin.m, but that would cause some
% bootstrapping difficulties.
- % It might be slightly better to check for mercury_builtin:type_info
+ % It might be slightly better to check for private_builtin:type_info
% etc. rather than just checking the unqualified type name,
% but I found it difficult to verify that the constructors
% would always be fully module-qualified at points where
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.237
diff -u -u -r1.237 typecheck.m
--- typecheck.m 1998/05/07 06:41:50 1.237
+++ typecheck.m 1998/05/25 19:15:18
@@ -4767,7 +4767,7 @@
type_list_subsumes(TypesList2, TypesList1, _).
- % Make error messages more readable by removing "mercury_builtin"
+ % Make error messages more readable by removing "builtin:"
% qualifiers.
:- pred strip_builtin_qualifiers_from_type((type), (type)).
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.67
diff -u -u -r1.67 unify_proc.m
--- unify_proc.m 1998/04/27 04:02:24 1.67
+++ unify_proc.m 1998/05/25 18:17:32
@@ -940,7 +940,16 @@
unify_proc__info_get_module_info(ModuleInfo),
{ module_info_get_predicate_table(ModuleInfo, PredicateTable) },
{ list__length(ArgVars, Arity) },
- { MercuryBuiltin = unqualified("mercury_builtin") },
+ %
+ % We assume that the special preds compare/3, index/2, and unify/2
+ % are the only public builtins called by code generated
+ % by this module.
+ %
+ { special_pred_name_arity(_, Name, _, Arity) ->
+ mercury_public_builtin_module(MercuryBuiltin)
+ ;
+ mercury_private_builtin_module(MercuryBuiltin)
+ },
{
predicate_table_search_pred_m_n_a(PredicateTable,
MercuryBuiltin, Name, Arity, [PredId])
cvs diff: Diffing compiler/notes
cvs diff: Diffing doc
Index: doc/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/Mmakefile,v
retrieving revision 1.8
diff -u -u -r1.8 Mmakefile
--- Mmakefile 1998/04/08 11:22:53 1.8
+++ Mmakefile 1998/05/25 20:30:44
@@ -97,6 +97,7 @@
# by extracting the module interfaces from the library source code.
# Note that the debugger_interface.m module is just an implementation
# detail of the library, so it is not documented.
+# Same goes for private_builtin.m.
library-menu.texi: $(LIBRARY_DIR)/*.m
{ \
@@ -105,6 +106,8 @@
case $$filename in \
$(LIBRARY_DIR)/debugger_interface.m) \
;; \
+ $(LIBRARY_DIR)/private_builtin.m) \
+ ;; \
*) \
echo "* `basename $$filename .m`::"; \
;; \
@@ -116,6 +119,8 @@
for filename in $(LIBRARY_DIR)/*.m; do \
case $$filename in \
$(LIBRARY_DIR)/debugger_interface.m) \
+ ;; \
+ $(LIBRARY_DIR)/private_builtin.m) \
;; \
*) \
file="`basename $$filename .m`"; \
cvs diff: Diffing extras
cvs diff: Diffing extras/cgi
cvs diff: Diffing extras/clpr
cvs diff: Diffing extras/clpr/clpr
cvs diff: Diffing extras/clpr/samples
cvs diff: Diffing extras/complex_numbers
cvs diff: Diffing extras/complex_numbers/samples
cvs diff: Diffing extras/complex_numbers/tests
cvs diff: Diffing extras/graphics
cvs diff: Diffing extras/graphics/Togl-1.2
cvs diff: Diffing extras/graphics/mercury_opengl
cvs diff: Diffing extras/graphics/mercury_tcltk
cvs diff: Diffing extras/graphics/samples
cvs diff: Diffing extras/graphics/samples/calc
cvs diff: Diffing extras/graphics/samples/maze
cvs diff: Diffing extras/odbc
cvs diff: Diffing extras/references
cvs diff: Diffing extras/trailed_update
cvs diff: Diffing extras/trailed_update/samples
cvs diff: Diffing library
cvs diff: library/builtin.m is a new entry, no comparison available
Index: library/mercury_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/mercury_builtin.m,v
retrieving revision 1.97
diff -u -u -r1.97 mercury_builtin.m
--- mercury_builtin.m 1998/05/18 05:30:37 1.97
+++ mercury_builtin.m 1998/05/25 16:49:01
@@ -8,10 +8,11 @@
% Main author: fjh.
% Stability: low.
-% This file is automatically imported into every module.
-% It is intended for things that are part of the language,
-% but which are implemented just as normal user-level code
-% rather than with special coding in the compiler.
+% IMPORTANT NOTE! This file is no longer used.
+% Its contents have been moved to builtin.m and private_builtin.m.
+% The stuff that is here remains here only for bootstrapping
+% reasons; once the changes to compiler/modules.m have been installed
+% everywhere, we should delete this file.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
cvs diff: library/private_builtin.m is a new entry, no comparison available
Index: library/prolog.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/prolog.m,v
retrieving revision 1.9
diff -u -u -r1.9 prolog.m
--- prolog.m 1998/01/23 12:33:28 1.9
+++ prolog.m 1998/05/25 19:01:15
@@ -21,7 +21,7 @@
% if all your cuts are green cuts.
/********
-cut is currently defined in mercury_builtin.m, for historical reasons.
+cut is currently defined in builtin.m, for historical reasons.
:- pred ! is det.
@@ -97,7 +97,7 @@
:- import_module require, int.
/*********
-% !/0 and !/2 currently defined in mercury_builtin.m, for historical reasons.
+% !/0 and !/2 currently defined in builtin.m, for historical reasons.
!.
!(X, X).
*********/
Index: library/std_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/std_util.m,v
retrieving revision 1.118
diff -u -u -r1.118 std_util.m
--- std_util.m 1998/05/15 07:08:45 1.118
+++ std_util.m 1998/05/25 19:03:38
@@ -222,7 +222,7 @@
% type_name(Type) returns the name of the specified type
% (e.g. type_name(type_of([2,3])) = "list:list(int)").
% Any equivalence types will be fully expanded.
- % Builtin types (those defined in mercury_builtin.m) will
+ % Builtin types (those defined in builtin.m) will
% not have a module qualifier.
%
:- func type_name(type_info) = string.
@@ -267,8 +267,7 @@
% type_ctor_module_name(TypeCtor) returns the module name of specified
% type constructor.
- % (e.g. type_ctor_module_name(type_ctor(type_of(2))) =
- % "mercury_builtin").
+ % (e.g. type_ctor_module_name(type_ctor(type_of(2))) = "builtin").
%
:- func type_ctor_module_name(type_ctor_info) = string.
@@ -1323,9 +1322,13 @@
( Arity = 0 ->
UnqualifiedTypeName = Name
;
+ % XXX the test for mercury_builtin is for bootstrapping
+ % only; it should eventually be deleted.
( ModuleName = "mercury_builtin", Name = "func" ->
IsFunc = yes
- ;
+ ; ModuleName = "builtin", Name = "func" ->
+ IsFunc = yes
+ ;
IsFunc = no
),
(
@@ -1342,7 +1345,9 @@
UnqualifiedTypeName)
)
),
- ( ModuleName = "mercury_builtin" ->
+ % XXX the test for mercury_builtin is for bootstrapping
+ % only; it should eventually be deleted.
+ ( (ModuleName = "mercury_builtin" ; ModuleName = "builtin") ->
TypeName = UnqualifiedTypeName
;
string__append_list([ModuleName, ":",
Index: library/term.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/term.m,v
retrieving revision 1.81
diff -u -u -r1.81 term.m
--- term.m 1998/04/02 07:40:16 1.81
+++ term.m 1998/05/25 19:00:00
@@ -367,6 +367,10 @@
term::in(bound(term__functor(ground, ground, ground))),
type_info::in, term_to_type_context::in,
term_to_type_result(univ)::out) is semidet.
+/*
+** XXX the following clauses for mercury_builtin:* are
+** for bootstrapping only, and should eventually be deleted
+*/
term__term_to_univ_special_case("mercury_builtin", "character", [],
Term, _, _, ok(Univ)) :-
Term = term__functor(term__atom(FunctorName), [], _),
@@ -384,6 +388,24 @@
Term, _, _, ok(Univ)) :-
Term = term__functor(term__float(Float), [], _),
type_to_univ(Float, Univ).
+
+term__term_to_univ_special_case("builtin", "character", [],
+ Term, _, _, ok(Univ)) :-
+ Term = term__functor(term__atom(FunctorName), [], _),
+ string__first_char(FunctorName, Char, ""),
+ type_to_univ(Char, Univ).
+term__term_to_univ_special_case("builtin", "int", [],
+ Term, _, _, ok(Univ)) :-
+ Term = term__functor(term__integer(Int), [], _),
+ type_to_univ(Int, Univ).
+term__term_to_univ_special_case("builtin", "string", [],
+ Term, _, _, ok(Univ)) :-
+ Term = term__functor(term__string(String), [], _),
+ type_to_univ(String, Univ).
+term__term_to_univ_special_case("builtin", "float", [],
+ Term, _, _, ok(Univ)) :-
+ Term = term__functor(term__float(Float), [], _),
+ type_to_univ(Float, Univ).
term__term_to_univ_special_case("array", "array", [ElemType], Term, _Type,
PrevContext, Result) :-
%
@@ -425,7 +447,7 @@
ArgResult = error(Error),
Result = error(Error)
).
-term__term_to_univ_special_case("mercury_builtin", "c_pointer", _, _, _,
+term__term_to_univ_special_case("builtin", "c_pointer", _, _, _,
_, _) :-
fail.
term__term_to_univ_special_case("std_util", "univ", _, _, _, _, _) :-
@@ -581,6 +603,10 @@
list(type_info)::in, univ::in, term__context::in,
term::out) is semidet.
+/*
+** XXX the following clauses for mercury_builtin:* are
+** for bootstrapping only, and should eventually be deleted
+*/
term__univ_to_term_special_case("mercury_builtin", "int", [], Univ, Context,
term__functor(term__integer(Int), [], Context)) :-
det_univ_to_type(Univ, Int).
@@ -594,6 +620,20 @@
term__univ_to_term_special_case("mercury_builtin", "string", [], Univ, Context,
term__functor(term__string(String), [], Context)) :-
det_univ_to_type(Univ, String).
+
+term__univ_to_term_special_case("builtin", "int", [], Univ, Context,
+ term__functor(term__integer(Int), [], Context)) :-
+ det_univ_to_type(Univ, Int).
+term__univ_to_term_special_case("builtin", "float", [], Univ, Context,
+ term__functor(term__float(Float), [], Context)) :-
+ det_univ_to_type(Univ, Float).
+term__univ_to_term_special_case("builtin", "character", [], Univ,
+ Context, term__functor(term__atom(CharName), [], Context)) :-
+ det_univ_to_type(Univ, Character),
+ string__char_to_string(Character, CharName).
+term__univ_to_term_special_case("builtin", "string", [], Univ, Context,
+ term__functor(term__string(String), [], Context)) :-
+ det_univ_to_type(Univ, String).
term__univ_to_term_special_case("std_util", "type_info", [], Univ, Context,
term__functor(term__atom("type_info"), [Term], Context)) :-
det_univ_to_type(Univ, TypeInfo),
@@ -652,10 +692,14 @@
ModuleName = type_ctor_name(TypeCtor),
list__map(type_info_to_term(Context), ArgTypes, ArgTerms),
- ( ModuleName = "mercury_builtin" ->
+ /*
+ ** XXX the test for mercury_builtin is for bootstrapping only,
+ ** and should eventually be deleted
+ */
+ ( (ModuleName = "mercury_builtin" ; ModuleName = "builtin") ->
Term = term__functor(term__atom(TypeName), ArgTerms, Context)
;
- Term = term__functor(term__atom(":"), % TYPE_QUAL_OP
+ Term = term__functor(term__atom(":"),
[term__functor(term__atom(ModuleName), [], Context),
term__functor(term__atom(TypeName),
ArgTerms, Context)], Context)
cvs diff: Diffing lp_solve
cvs diff: Diffing lp_solve/lp_examples
cvs diff: Diffing profiler
cvs diff: Diffing runtime
Index: runtime/mercury_trace_internal.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_trace_internal.c,v
retrieving revision 1.2
diff -u -u -r1.2 mercury_trace_internal.c
--- mercury_trace_internal.c 1998/05/19 05:15:10 1.2
+++ mercury_trace_internal.c 1998/05/25 18:50:45
@@ -283,7 +283,7 @@
/*
** XXX The printing of type_infos is buggy at the moment
- ** due to the fake arity of the type mercury_builtin:typeinfo/1.
+ ** due to the fake arity of the type private_builtin:typeinfo/1.
**
** XXX The printing of large data structures is painful
** at the moment due to the lack of a true browser.
Index: runtime/mercury_trace_util.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_trace_util.c,v
retrieving revision 1.1
diff -u -u -r1.1 mercury_trace_util.c
--- mercury_trace_util.c 1998/05/16 07:28:31 1.1
+++ mercury_trace_util.c 1998/05/25 18:50:50
@@ -103,7 +103,7 @@
/*
** XXX The printing of type_infos is buggy at the moment
- ** due to the fake arity of mercury_builtin:typeinfo/1.
+ ** due to the fake arity of private_builtin:typeinfo/1.
**
** XXX The printing of large data structures is painful
** at the moment due to the lack of a true browser.
Index: runtime/mercury_type_info.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.c,v
retrieving revision 1.5
diff -u -u -r1.5 mercury_type_info.c
--- mercury_type_info.c 1998/05/15 07:09:28 1.5
+++ mercury_type_info.c 1998/05/25 18:52:09
@@ -126,7 +126,7 @@
/* code for predicate 'builtin_unify_pred'/2 in mode 0 */
Define_entry(mercury__builtin_unify_pred_2_0);
- incr_sp_push_msg(2, "mercury_builtin:builtin_unify_pred");
+ incr_sp_push_msg(2, "private_builtin:builtin_unify_pred");
fatal_error("attempted unification of higher-order terms");
END_MODULE
@@ -147,7 +147,7 @@
/* code for predicate 'builtin_compare_pred'/3 in mode 0 */
Define_entry(mercury__builtin_compare_pred_3_0);
- incr_sp_push_msg(2, "mercury_builtin:builtin_compare_pred");
+ incr_sp_push_msg(2, "private_builtin:builtin_compare_pred");
fatal_error("attempted comparison of higher-order terms");
END_MODULE
Index: runtime/mercury_type_info.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.h,v
retrieving revision 1.6
diff -u -u -r1.6 mercury_type_info.h
--- mercury_type_info.h 1998/05/15 07:09:29 1.6
+++ mercury_type_info.h 1998/05/25 18:53:06
@@ -141,7 +141,7 @@
/*
** Code intended for defining type_layouts for handwritten code.
**
-** See library/io.m or library/mercury_builtin.m for details.
+** See library/io.m or library/builtin.m for details.
*/
#if TAGBITS >= 2
typedef const Word *TypeLayoutField;
@@ -281,7 +281,7 @@
#define MR_TYPECTOR_GET_HOT_NAME(T) \
((ConstString) ( ( ((Integer) (T)) % 2 ) ? "func" : "pred" ))
#define MR_TYPECTOR_GET_HOT_MODULE_NAME(T) \
- ((ConstString) "mercury_builtin")
+ ((ConstString) "builtin")
#define MR_TYPECTOR_GET_HOT_BASE_TYPE_INFO(T) \
((Word) ( ( ((Integer) (T)) % 2 ) ? \
(const Word *) &mercury_data___base_type_info_func_0 : \
@@ -347,7 +347,7 @@
/*
** Macros are provided here to initialize base_type_infos, both for
-** builtin types (such as in library/mercury_builtin.m) and user
+** builtin types (such as in library/builtin.m) and user
** defined C types (like library/array.m). Also, the automatically
** generated code uses these initializers.
**
cvs diff: Diffing runtime/machdeps
cvs diff: Diffing samples
cvs diff: Diffing samples/c_interface
cvs diff: Diffing samples/c_interface/c_calls_mercury
cvs diff: Diffing samples/c_interface/cplusplus_calls_mercury
cvs diff: Diffing samples/c_interface/mercury_calls_c
cvs diff: Diffing samples/c_interface/mercury_calls_cplusplus
cvs diff: Diffing samples/c_interface/mercury_calls_fortran
cvs diff: Diffing samples/c_interface/simpler_c_calls_mercury
cvs diff: Diffing samples/c_interface/simpler_cplusplus_calls_mercury
cvs diff: Diffing samples/diff
cvs diff: Diffing scripts
cvs diff: Diffing tests
cvs diff: Diffing tests/benchmarks
cvs diff: Diffing tests/debugger
cvs diff: Diffing tests/general
cvs diff: Diffing tests/hard_coded
cvs diff: Diffing tests/hard_coded/typeclasses
cvs diff: Diffing tests/invalid
cvs diff: Diffing tests/misc_tests
cvs diff: Diffing tests/term
cvs diff: Diffing tests/valid
cvs diff: Diffing tests/warnings
cvs diff: Diffing tools
Index: tools/bootcheck
===================================================================
RCS file: /home/mercury1/repository/mercury/tools/bootcheck,v
retrieving revision 1.54
diff -u -u -r1.54 bootcheck
--- bootcheck 1998/05/18 09:51:16 1.54
+++ bootcheck 1998/05/25 20:56:29
@@ -24,6 +24,10 @@
Copy the runtime directory instead of linking it.
This is necessary if one wants to bootcheck a grade
that is not compatible with the standard one.
+ -p, --copy-profiler
+ Copy the profiler directory instead of linking it.
+ This is sometimes necessary for bootstrapping
+ changes.
-s, --sicstus
As well as running the normal bootcheck, also build a SICStus
Prolog version of the compiler and check it against the
@@ -58,6 +62,7 @@
runtests=true
do_bootcheck=true
copy_runtime=false
+copy_profiler=false
keep_stage_2=false
keep_stage_3=false
keep_stage_2_sicstus=false
@@ -94,6 +99,9 @@
-o*)
outfile="` expr $1 : '-o\(.*\)' `"; ;;
+ -p|--copy-profiler)
+ copy_profiler=true ;;
+
-r|--copy-runtime)
copy_runtime=true ;;
@@ -241,7 +249,16 @@
ln -s $root/doc .
ln -s $root/scripts .
ln -s $root/util .
- ln -s $root/profiler .
+ if test "$copy_profiler" = "true"
+ then
+ mkdir profiler
+ cd profiler
+ ln -s $root/profiler/*.m .
+ cp $root/profiler/Mmake* .
+ cd $root/stage2_sicstus
+ else
+ ln -s $root/profiler .
+ fi
ln -s $root/conf* .
ln -s $root/VERSION .
ln -s $root/.README.in .
@@ -259,7 +276,8 @@
if
cd stage2_sicstus &&
- mmake $mmake_opts depend_library depend_compiler &&
+ mmake $mmake_opts depend_library depend_compiler \
+ depend_profiler &&
cd $root
then
echo "building of SICStus stage 2 dependencies successful"
@@ -343,6 +361,8 @@
mmake depend
cd $root/compiler;
mmake depend
+ cd $root/profiler;
+ mmake depend
cd $root
if mmake $mmake_opts MMAKEFLAGS=$jfactor all
then
@@ -417,7 +437,16 @@
ln -s $root/doc .
ln -s $root/scripts .
ln -s $root/util .
- ln -s $root/profiler .
+ if test "$copy_profiler" = "true"
+ then
+ mkdir profiler
+ cd profiler
+ ln -s $root/profiler/*.m .
+ cp $root/profiler/Mmake* .
+ cd $root/stage2
+ else
+ ln -s $root/profiler .
+ fi
ln -s $root/conf* .
ln -s $root/VERSION .
ln -s $root/.README.in .
@@ -441,7 +470,8 @@
exit 1
fi
- if (cd stage2 && mmake $mmake_opts depend_library depend_compiler)
+ if (cd stage2 && mmake $mmake_opts depend_library depend_compiler \
+ depend_profiler)
then
echo "building of stage 2 dependencies successful"
else
Index: tools/test_mercury
===================================================================
RCS file: /home/mercury1/repository/mercury/tools/test_mercury,v
retrieving revision 1.69
diff -u -u -r1.69 test_mercury
--- test_mercury 1998/05/25 07:50:14 1.69
+++ test_mercury 1998/05/25 20:57:27
@@ -188,7 +188,7 @@
mmake realclean MMAKEFLAGS=$PARALLEL || { false; exit 1; }
./configure --prefix=$INSTALL_DIR $CONFIG_OPTS || { false; exit 1; }
mmake depend $PARALLEL || { false; exit 1; }
-tools/bootcheck -r -t $PARALLEL || $install_anyway || { false; exit 1; }
+tools/bootcheck -r -p -t $PARALLEL || $install_anyway || { false; exit 1; }
cd .. || { false; exit 1; }
#-----------------------------------------------------------------------------#
cvs diff: Diffing trial
cvs diff: Diffing util
===============================================================================
library/builtin.m:
===============================================================================
%---------------------------------------------------------------------------%
% Copyright (C) 1994-1998 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
% File: builtin.m.
% Main author: fjh.
% Stability: low.
% This file is automatically imported into every module.
% It is intended for things that are part of the language,
% but which are implemented just as normal user-level code
% rather than with special coding in the compiler.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- module builtin.
:- interface.
%-----------------------------------------------------------------------------%
% TYPES.
% The types `character', `int', `float', and `string',
% and the types `pred', `pred(T)', `pred(T1, T2)', `pred(T1, T2, T3)', ...
% and `func(T1) = T2', `func(T1, T2) = T3', `func(T1, T2, T3) = T4', ...
% are builtin and are implemented using special code in the
% type-checker. (XXX TODO: report an error for attempts to redefine
% these types.)
% The type c_pointer can be used by predicates which use the C interface.
:- type c_pointer.
%-----------------------------------------------------------------------------%
% INSTS.
% The standard insts `free', `ground', and `bound(...)' are builtin
% and are implemented using special code in the parser and mode-checker.
% So are the standard unique insts `unique', `unique(...)',
% `mostly_unique', `mostly_unique(...)', and `clobbered'.
% The name `dead' is allowed as a synonym for `clobbered'.
% Similarly `mostly_dead' is a synonym for `mostly_clobbered'.
:- inst dead = clobbered.
:- inst mostly_dead = mostly_clobbered.
% The `any' inst used for the constraint solver interface is also builtin.
% Higher-order predicate insts `pred(<modes>) is <detism>'
% and higher-order functions insts `func(<modes>) = <mode> is det'
% are also builtin.
%-----------------------------------------------------------------------------%
% MODES.
% The standard modes.
:- mode unused :: (free -> free).
:- mode output :: (free -> ground).
:- mode input :: (ground -> ground).
:- mode in :: (ground -> ground).
:- mode out :: (free -> ground).
:- mode in(Inst) :: (Inst -> Inst).
:- mode out(Inst) :: (free -> Inst).
:- mode di(Inst) :: (Inst -> clobbered).
:- mode mdi(Inst) :: (Inst -> mostly_clobbered).
% Unique modes. These are still not fully implemented.
% unique output
:- mode uo :: free -> unique.
% unique input
:- mode ui :: unique -> unique.
% destructive input
:- mode di :: unique -> clobbered.
% "Mostly" unique modes (unique except that that may be referenced
% again on backtracking).
% mostly unique output
:- mode muo :: free -> mostly_unique.
% mostly unique input
:- mode mui :: mostly_unique -> mostly_unique.
% mostly destructive input
:- mode mdi :: mostly_unique -> mostly_clobbered.
% Higher-order predicate modes are builtin.
%-----------------------------------------------------------------------------%
% PREDICATES.
% Most of these probably ought to be moved to another
% module in the standard library such as std_util.m.
% copy/2 makes a deep copy of a data structure. The resulting copy is a
% `unique' value, so you can use destructive update on it.
:- pred copy(T, T).
:- mode copy(ui, uo) is det.
:- mode copy(in, uo) is det.
% unsafe_promise_unique/2 is used to promise the compiler that you have a
% `unique' copy of a data structure, so that you can use destructive update.
% It is used to work around limitations in the current support for unique
% modes. `unsafe_promise_unique(X, Y)' is the same as `Y = X' except that
% the compiler will assume that `Y' is unique.
:- pred unsafe_promise_unique(T, T).
:- mode unsafe_promise_unique(in, uo) is det.
% We define !/0 (and !/2 for dcgs) to be equivalent to `true'. This is for
% backwards compatibility with Prolog systems. But of course it only works
% if all your cuts are green cuts.
:- pred ! is det.
:- pred !(T, T).
:- mode !(di, uo) is det.
:- mode !(in, out) is det.
%-----------------------------------------------------------------------------%
% unify(X, Y) is true iff X = Y.
:- pred unify(T::in, T::in) is semidet.
:- type comparison_result ---> (=) ; (<) ; (>).
% compare(Res, X, Y) binds Res to =, <, or >
% depending on wheither X is =, <, or > Y in the
% standard ordering.
:- pred compare(comparison_result, T, T).
:- mode compare(uo, ui, ui) is det.
:- mode compare(uo, ui, in) is det.
:- mode compare(uo, in, ui) is det.
:- mode compare(uo, in, in) is det.
% index(X, N): if X is a discriminated union type, this is
% true iff the top-level functor of X is the (N-1)th functor in its
% type. If X is of type int, then it is true iff N = X.
% Otherwise, it is true iff N = -1.
:- pred index(T::in, int::out) is det.
% In addition, the following predicate-like constructs are builtin:
%
% :- pred (T = T).
% :- pred (T \= T).
% :- pred (pred , pred).
% :- pred (pred ; pred).
% :- pred (\+ pred).
% :- pred (not pred).
% :- pred (pred -> pred).
% :- pred (if pred then pred).
% :- pred (if pred then pred else pred).
% :- pred (pred => pred).
% :- pred (pred <= pred).
% :- pred (pred <=> pred).
%
% (pred -> pred ; pred).
% some Vars pred
% all Vars pred
% call/N
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module require, string, std_util, int, float, char, string, list.
%-----------------------------------------------------------------------------%
!.
!(X, X).
%-----------------------------------------------------------------------------%
:- external(unify/2).
:- external(index/2).
:- external(compare/3).
%-----------------------------------------------------------------------------%
:- pragma c_header_code("#include ""mercury_type_info.h""").
:- pragma c_code("
#ifdef USE_TYPE_LAYOUT
/* base_type_layout definitions */
/* base_type_layout for `int' */
const struct mercury_data___base_type_layout_int_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_int_0 = {
make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
mkbody(TYPELAYOUT_INT_VALUE))
};
/* base_type_layout for `character' */
const struct mercury_data___base_type_layout_character_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_character_0 = {
make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
mkbody(TYPELAYOUT_CHARACTER_VALUE))
};
/* base_type_layout for `string' */
const struct mercury_data___base_type_layout_string_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_string_0 = {
make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
mkbody(TYPELAYOUT_STRING_VALUE))
};
/* base_type_layout for `float' */
const struct mercury_data___base_type_layout_float_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_float_0 = {
make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
mkbody(TYPELAYOUT_FLOAT_VALUE))
};
/* base_type_layout for `void' */
const struct mercury_data___base_type_layout_void_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data___base_type_layout_void_0 = {
make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
mkbody(TYPELAYOUT_VOID_VALUE))
};
/* base_type_functors definitions */
/* base_type_functors for `int' */
const struct mercury_data___base_type_functors_int_0_struct {
Integer f1;
} mercury_data___base_type_functors_int_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
/* base_type_functors for `character' */
const struct mercury_data___base_type_functors_character_0_struct {
Integer f1;
} mercury_data___base_type_functors_character_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
/* base_type_functors for `string' */
const struct mercury_data___base_type_functors_string_0_struct {
Integer f1;
} mercury_data___base_type_functors_string_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
/* base_type_functors for `float' */
const struct mercury_data___base_type_functors_float_0_struct {
Integer f1;
} mercury_data___base_type_functors_float_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
/* base_type_functors for `void' */
const struct mercury_data___base_type_functors_void_0_struct {
Integer f1;
} mercury_data___base_type_functors_void_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
#endif /* USE_TYPE_LAYOUT */
/* base_type_infos definitions */
/* base_type_info for `int' */
Declare_entry(mercury__builtin_unify_int_2_0);
Declare_entry(mercury__builtin_index_int_2_0);
Declare_entry(mercury__builtin_compare_int_3_0);
MR_STATIC_CODE_CONST struct mercury_data___base_type_info_int_0_struct {
Integer f1;
Code *f2;
Code *f3;
Code *f4;
#ifdef USE_TYPE_LAYOUT
const Word *f5;
const Word *f6;
const Word *f7;
const Word *f8;
#endif
} mercury_data___base_type_info_int_0 = {
((Integer) 0),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_unify_int_2_0)),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_index_int_2_0)),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_compare_int_3_0)),
#ifdef USE_TYPE_LAYOUT
(const Word *) & mercury_data___base_type_layout_int_0,
(const Word *) & mercury_data___base_type_functors_int_0,
(const Word *) string_const(""builtin"", 15),
(const Word *) string_const(""int"", 3)
#endif
};
/* base_type_info for `character' */
Declare_entry(mercury__builtin_unify_character_2_0);
Declare_entry(mercury__builtin_index_character_2_0);
Declare_entry(mercury__builtin_compare_character_3_0);
MR_STATIC_CODE_CONST struct
mercury_data___base_type_info_character_0_struct {
Integer f1;
Code *f2;
Code *f3;
Code *f4;
#ifdef USE_TYPE_LAYOUT
const Word *f5;
const Word *f6;
const Word *f7;
const Word *f8;
#endif
} mercury_data___base_type_info_character_0 = {
((Integer) 0),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_unify_character_2_0)),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_index_character_2_0)),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_compare_character_3_0)),
#ifdef USE_TYPE_LAYOUT
(const Word *) & mercury_data___base_type_layout_character_0,
(const Word *) & mercury_data___base_type_functors_character_0,
(const Word *) string_const(""builtin"", 15),
(const Word *) string_const(""character"", 9)
#endif
};
/* base_type_info for `string' */
Declare_entry(mercury__builtin_unify_string_2_0);
Declare_entry(mercury__builtin_index_string_2_0);
Declare_entry(mercury__builtin_compare_string_3_0);
MR_STATIC_CODE_CONST struct mercury_data___base_type_info_string_0_struct {
Integer f1;
Code *f2;
Code *f3;
Code *f4;
#ifdef USE_TYPE_LAYOUT
const Word *f5;
const Word *f6;
const Word *f7;
const Word *f8;
#endif
} mercury_data___base_type_info_string_0 = {
((Integer) 0),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_unify_string_2_0)),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_index_string_2_0)),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_compare_string_3_0)),
#ifdef USE_TYPE_LAYOUT
(const Word *) & mercury_data___base_type_layout_string_0,
(const Word *) & mercury_data___base_type_functors_string_0,
(const Word *) string_const(""builtin"", 15),
(const Word *) string_const(""string"", 6)
#endif
};
/* base_type_info for `float' */
Declare_entry(mercury__builtin_unify_float_2_0);
Declare_entry(mercury__builtin_index_float_2_0);
Declare_entry(mercury__builtin_compare_float_3_0);
MR_STATIC_CODE_CONST struct mercury_data___base_type_info_float_0_struct {
Integer f1;
Code *f2;
Code *f3;
Code *f4;
#ifdef USE_TYPE_LAYOUT
const Word *f5;
const Word *f6;
const Word *f7;
const Word *f8;
#endif
} mercury_data___base_type_info_float_0 = {
((Integer) 0),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_unify_float_2_0)),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_index_float_2_0)),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__builtin_compare_float_3_0)),
#ifdef USE_TYPE_LAYOUT
(const Word *) & mercury_data___base_type_layout_float_0,
(const Word *) & mercury_data___base_type_functors_float_0,
(const Word *) string_const(""builtin"", 15),
(const Word *) string_const(""float"", 5)
#endif
};
/* base_type_info for `void' */
Declare_entry(mercury__unused_0_0);
MR_STATIC_CODE_CONST struct mercury_data___base_type_info_void_0_struct {
Integer f1;
Code *f2;
Code *f3;
Code *f4;
#ifdef USE_TYPE_LAYOUT
const Word *f5;
const Word *f6;
const Word *f7;
const Word *f8;
#endif
} mercury_data___base_type_info_void_0 = {
((Integer) 0),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__unused_0_0)),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__unused_0_0)),
MR_MAYBE_STATIC_CODE(ENTRY(mercury__unused_0_0)),
#ifdef USE_TYPE_LAYOUT
(const Word *) & mercury_data___base_type_layout_void_0,
(const Word *) & mercury_data___base_type_functors_void_0,
(const Word *) string_const(""builtin"", 15),
(const Word *) string_const(""void"", 4)
#endif
};
BEGIN_MODULE(builtin_types_module)
BEGIN_CODE
END_MODULE
/*
INIT sys_init_builtin_types_module
*/
extern ModuleFunc builtin_types_module;
extern void mercury__builtin__init(void);
void sys_init_builtin_types_module(void);
void sys_init_builtin_types_module(void) {
builtin_types_module();
/*
** We had better call this init() because we use the
** labels for the special preds of int, float, pred,
** character and string. If they aren't initialized,
** we might initialize the base_type_info with
** garbage
*/
mercury__builtin__init();
MR_INIT_BUILTIN_BASE_TYPE_INFO(
mercury_data___base_type_info_int_0, _int_);
MR_INIT_BUILTIN_BASE_TYPE_INFO(
mercury_data___base_type_info_float_0, _float_);
MR_INIT_BUILTIN_BASE_TYPE_INFO(
mercury_data___base_type_info_character_0, _character_);
MR_INIT_BUILTIN_BASE_TYPE_INFO(
mercury_data___base_type_info_string_0, _string_);
MR_INIT_BASE_TYPE_INFO_WITH_PRED(
mercury_data___base_type_info_void_0, mercury__unused_0_0);
}
").
%-----------------------------------------------------------------------------%
% unsafe_promise_unique/2 is a compiler builtin.
%-----------------------------------------------------------------------------%
/* copy/2
:- pred copy(T, T).
:- mode copy(ui, uo) is det.
:- mode copy(in, uo) is det.
*/
/*************
Using `pragma c_code' doesn't work, due to the lack of support for
aliasing, and in particular the lack of support for `ui' modes.
:- pragma c_code(copy(Value::ui, Copy::uo), "
save_transient_registers();
Copy = deep_copy(Value, TypeInfo_for_T, NULL, NULL);
restore_transient_registers();
").
:- pragma c_code(copy(Value::in, Copy::uo), "
save_transient_registers();
Copy = deep_copy(Value, TypeInfo_for_T, NULL, NULL);
restore_transient_registers();
").
*************/
:- external(copy/2).
:- pragma c_header_code("#include ""mercury_deep_copy.h""").
:- pragma c_code("
Define_extern_entry(mercury__copy_2_0);
Define_extern_entry(mercury__copy_2_1);
MR_MAKE_STACK_LAYOUT_ENTRY(mercury__copy_2_0);
MR_MAKE_STACK_LAYOUT_ENTRY(mercury__copy_2_1);
BEGIN_MODULE(copy_module)
init_entry(mercury__copy_2_0);
init_entry(mercury__copy_2_1);
BEGIN_CODE
#ifdef PROFILE_CALLS
#define fallthru(target, caller) { tailcall((target), (caller)); }
#else
#define fallthru(target, caller)
#endif
Define_entry(mercury__copy_2_0);
fallthru(ENTRY(mercury__copy_2_1), ENTRY(mercury__copy_2_0))
Define_entry(mercury__copy_2_1);
{
Word value, copy, type_info;
type_info = r1;
value = r2;
save_transient_registers();
copy = deep_copy(value, (Word *) type_info, NULL, NULL);
restore_transient_registers();
#ifdef COMPACT_ARGS
r1 = copy;
#else
r3 = copy;
#endif
proceed();
}
END_MODULE
/* Ensure that the initialization code for the above module gets run. */
/*
INIT sys_init_copy_module
*/
extern ModuleFunc copy_module;
void sys_init_copy_module(void);
/* extra declaration to suppress gcc -Wmissing-decl warning */
void sys_init_copy_module(void) {
copy_module();
}
").
%-----------------------------------------------------------------------------%
% The type c_pointer can be used by predicates which use the C interface.
:- pragma c_code("
/*
* c_pointer has a special value reserved for its layout, since it needs to
* be handled as a special case.
*/
#ifdef USE_TYPE_LAYOUT
const struct mercury_data_builtin__base_type_layout_c_pointer_0_struct {
TYPE_LAYOUT_FIELDS
} mercury_data_builtin__base_type_layout_c_pointer_0 = {
make_typelayout_for_all_tags(TYPELAYOUT_CONST_TAG,
mkbody(TYPELAYOUT_C_POINTER_VALUE))
};
const struct
mercury_data_builtin__base_type_functors_c_pointer_0_struct {
Integer f1;
} mercury_data_builtin__base_type_functors_c_pointer_0 = {
MR_TYPEFUNCTORS_SPECIAL
};
#endif
Define_extern_entry(mercury____Unify___builtin__c_pointer_0_0);
Define_extern_entry(mercury____Index___builtin__c_pointer_0_0);
Define_extern_entry(mercury____Compare___builtin__c_pointer_0_0);
MR_MAKE_STACK_LAYOUT_ENTRY(mercury____Unify___builtin__c_pointer_0_0);
MR_MAKE_STACK_LAYOUT_ENTRY(mercury____Index___builtin__c_pointer_0_0);
MR_MAKE_STACK_LAYOUT_ENTRY(mercury____Compare___builtin__c_pointer_0_0);
BEGIN_MODULE(unify_c_pointer_module)
init_entry(mercury____Unify___builtin__c_pointer_0_0);
init_entry(mercury____Index___builtin__c_pointer_0_0);
init_entry(mercury____Compare___builtin__c_pointer_0_0);
BEGIN_CODE
Define_entry(mercury____Unify___builtin__c_pointer_0_0);
/*
** For c_pointer, we assume that equality and comparison
** can be based on object identity (i.e. using address comparisons).
** This is correct for types like io__stream, and necessary since
** the io__state contains a map(io__stream, filename).
** However, it might not be correct in general...
*/
unify_output = (unify_input1 == unify_input2);
proceed();
Define_entry(mercury____Index___builtin__c_pointer_0_0);
index_output = -1;
proceed();
Define_entry(mercury____Compare___builtin__c_pointer_0_0);
compare_output = (compare_input1 == compare_input2 ? COMPARE_EQUAL :
compare_input1 < compare_input2 ? COMPARE_LESS :
COMPARE_GREATER);
proceed();
END_MODULE
/* Ensure that the initialization code for the above module gets run. */
/*
INIT sys_init_unify_c_pointer_module
*/
extern ModuleFunc unify_c_pointer_module;
void sys_init_unify_c_pointer_module(void);
/* duplicate declaration to suppress gcc -Wmissing-decl warning */
void sys_init_unify_c_pointer_module(void) {
unify_c_pointer_module();
}
").
:- end_module builtin.
%-----------------------------------------------------------------------------%
===============================================================================
library/private_builtin.m:
===============================================================================
%---------------------------------------------------------------------------%
% Copyright (C) 1994-1998 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
% File: private_builtin.m.
% Main authors: fjh, ohutch.
% Stability: low.
% This file is automatically imported, as if via `use_module', into every
% module. It is intended for builtins that are just implementation details,
% such as procedures that the compiler generates implicit calls to when
% implementing polymorphism, unification, compare/3, tabling, etc.
% This module is a private part of the Mercury implementation;
% user modules should never explicitly import this module.
% The interface for this module does not get included in the
% Mercury library library reference manual.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- module private_builtin.
:- interface.
%-----------------------------------------------------------------------------%
% unsafe_type_cast/2 is used internally by the compiler. Bad things
% will happen if this is used in programs. This is generated inline
% by the compiler.
:- pred unsafe_type_cast(T1, T2).
:- mode unsafe_type_cast(in, out) is det.
% The following are used by the compiler, to implement polymorphism.
% They should not be used in programs.
:- pred builtin_unify_int(int::in, int::in) is semidet.
:- pred builtin_index_int(int::in, int::out) is det.
:- pred builtin_compare_int(comparison_result::uo, int::in, int::in) is det.
:- pred builtin_unify_character(character::in, character::in) is semidet.
:- pred builtin_index_character(character::in, int::out) is det.
:- pred builtin_compare_character(comparison_result::uo, character::in,
character::in) is det.
:- pred builtin_unify_string(string::in, string::in) is semidet.
:- pred builtin_index_string(string::in, int::out) is det.
:- pred builtin_compare_string(comparison_result::uo, string::in, string::in)
is det.
:- pred builtin_unify_float(float::in, float::in) is semidet.
:- pred builtin_index_float(float::in, int::out) is det.
:- pred builtin_compare_float(comparison_result::uo, float::in, float::in)
is det.
:- pred builtin_unify_pred((pred)::in, (pred)::in) is semidet.
:- pred builtin_index_pred((pred)::in, int::out) is det.
:- pred builtin_compare_pred(comparison_result::uo, (pred)::in, (pred)::in)
is det.
% The following two preds are used for index/1 or compare/3 on
% non-canonical types (types for which there is a `where equality is ...'
% declaration).
:- pred builtin_index_non_canonical_type(T::in, int::out) is det.
:- pred builtin_compare_non_canonical_type(comparison_result::uo,
T::in, T::in) is det.
:- pred unused is det.
% compare_error is used in the code generated for compare/3 preds
:- pred compare_error is erroneous.
% The code generated by polymorphism.m always requires
% the existence of a type_info functor, and requires
% the existence of a base_type_info functor as well
% when using --type-info {shared-,}one-or-two-cell.
%
% The actual arities of these two function symbols are variable;
% they depend on the number of type parameters of the type represented
% by the type_info, and how many predicates we associate with each
% type.
%
% Note that, since these types look to the compiler as though they
% are candidates to become no_tag types, special code is required in
% type_util:type_is_no_tag_type/3.
:- type type_info(T) ---> type_info(base_type_info(T) /*, ... */).
:- type base_type_info(T) ---> base_type_info(int /*, ... */).
% Note that, since these types look to the compiler as though they
% are candidates to become no_tag types, special code is required in
% type_util:type_is_no_tag_type/3.
:- type typeclass_info ---> typeclass_info(base_typeclass_info /*, ... */).
:- type base_typeclass_info ---> typeclass_info(int /*, ... */).
% type_info_from_typeclass_info(TypeClassInfo, Index, TypeInfo)
% extracts TypeInfo from TypeClassInfo, where TypeInfo is the Indexth
% type_info in the typeclass_info
%
% Note: Index must be equal to the number of the desired type_info
% plus the number of superclasses for this class.
:- pred type_info_from_typeclass_info(typeclass_info, int, type_info(T)).
:- mode type_info_from_typeclass_info(in, in, out) is det.
% superclass_from_typeclass_info(TypeClassInfo, Index, SuperClass)
% extracts SuperClass from TypeClassInfo where TypeInfo is the Indexth
% superclass of the class.
:- pred superclass_from_typeclass_info(typeclass_info, int, typeclass_info).
:- mode superclass_from_typeclass_info(in, in, out) is det.
% the builtin < operator on ints, used in the code generated
% for compare/3 preds
:- pred builtin_int_lt(int, int).
:- mode builtin_int_lt(in, in) is semidet.
:- external(builtin_int_lt/2).
% the builtin > operator on ints, used in the code generated
% for compare/3 preds
:- pred builtin_int_gt(int, int).
:- mode builtin_int_gt(in, in) is semidet.
:- external(builtin_int_gt/2).
%
% The following predicates are used in code transformed by the table_gen pass
% of the compiler. The predicates fall into three categories :
% 1) Predicates to do lookups or insertions into the tables. This group
% also contains function to create and initialise tables. There are
% currently two types of table used by the tabling system. 1) A subgoal
% table, this is a table containing all of the subgoal calls that have
% or are being processed for a given predicate. 2) An answer table,
% this is a table of all the answers a subgoal has returned. It is used
% for duplicate answer elimination in the minimal model tabling
% scheme.
%
% 2) Predicates to test and set the status of the tables. These predicates
% expect either a subgoal or answer table node depending on their
% functionality.
%
% 3) Predicates to save answers into the tables. Answers are saved in
% an answer block, which is a vector of n elements where n is the number
% of output arguments of the predicate it belongs to. For det and
% semidet tabling the answer block is connected directly to subgoal
% table nodes. In the case of nondet tabling answer blocks are connected
% to answered slots which are strung together to form a list.
%
% All of the predicates with the impure declaration modify the table
% structures. Because the tables are persistent through backtracking, this
% causes the predicates to become impure. The predicates with the semipure
% directive only examine the trees but do not have any side effects.
%
% This type is used as a generic table: it can in fact represent two
% types, either a subgoal_table or an answer_table. The subgoal_table
% and answer_table types are differentiated by what they have at the
% table nodes but not by the actual underling trie structure.
:- type ml_table.
% This type is used in contexts where a node of a subgoal table is
% expected.
:- type ml_subgoal_table_node.
% This type is used in contexts where a node of an answer table is
% expected.
:- type ml_answer_table_node.
% This type is used in contexts where an answer slot is expected.
:- type ml_answer_slot.
% This type is used in contexts where an answer block is expected.
:- type ml_answer_block.
% This is a dummy predicate: its pred_proc_id, but not its code,
% is used. See the comment in compiler/table_gen.m for more
% information.
:- impure pred get_table(ml_table).
:- mode get_table(out) is det.
% Save important information in nondet table and initialise all of
% its fields. If called on an already initialised table do nothing.
:- impure pred table_setup(ml_subgoal_table_node, ml_subgoal_table_node).
:- mode table_setup(in, out) is det.
% Return all of the answer blocks stored in the given table.
:- semipure pred table_return_all_ans(ml_subgoal_table_node, ml_answer_block).
:- mode table_return_all_ans(in, out) is nondet.
% Returns true if the given nondet table has returned some of its
% answers.
:- semipure pred table_have_some_ans(ml_subgoal_table_node).
:- mode table_have_some_ans(in) is semidet.
% Return true if the given nondet table has returned all of its
% answers.
:- semipure pred table_have_all_ans(ml_subgoal_table_node).
:- mode table_have_all_ans(in) is semidet.
% Mark a table as having some answers.
:- impure pred table_mark_have_some_ans(ml_subgoal_table_node).
:- mode table_mark_have_some_ans(in) is det.
% Make a table as having all of its answers.
:- impure pred table_mark_have_all_ans(ml_subgoal_table_node).
:- mode table_mark_have_all_ans(in) is det.
% currently being evaluated (working on an answer).
:- semipure pred table_working_on_ans(ml_subgoal_table_node).
:- mode table_working_on_ans(in) is semidet.
% Return false if the subgoal represented by the given table is
% currently being evaluated (working on an answer).
:- semipure pred table_not_working_on_ans(ml_subgoal_table_node).
:- mode table_not_working_on_ans(in) is semidet.
% Mark the subgoal represented by the given table as currently
% being evaluated (working on an answer).
:- impure pred table_mark_as_working(ml_subgoal_table_node).
:- mode table_mark_as_working(in) is det.
% Mark the subgoal represented by the given table as currently
% not being evaluated (working on an answer).
:- impure pred table_mark_done_working(ml_subgoal_table_node).
:- mode table_mark_done_working(in) is det.
% Report an error message about the current subgoal looping.
:- pred table_loopcheck_error(string).
:- mode table_loopcheck_error(in) is erroneous.
%
% The following table_lookup_insert... predicates lookup or insert the second
% argument into the trie pointed to by the first argument. The value returned
% is a pointer to the leaf of the trie reached by the lookup. From the
% returned leaf another trie may be connected.
%
% Lookup or insert an integer in the given table.
:- impure pred table_lookup_insert_int(ml_table, int, ml_table).
:- mode table_lookup_insert_int(in, in, out) is det.
% Lookup or insert a character in the given trie.
:- impure pred table_lookup_insert_char(ml_table, character, ml_table).
:- mode table_lookup_insert_char(in, in, out) is det.
% Lookup or insert a string in the given trie.
:- impure pred table_lookup_insert_string(ml_table, string, ml_table).
:- mode table_lookup_insert_string(in, in, out) is det.
% Lookup or insert a float in the current trie.
:- impure pred table_lookup_insert_float(ml_table, float, ml_table).
:- mode table_lookup_insert_float(in, in, out) is det.
% Lookup or inert an enumeration type in the given trie.
:- impure pred table_lookup_insert_enum(ml_table, int, T, ml_table).
:- mode table_lookup_insert_enum(in, in, in, out) is det.
% Lookup or insert a monomorphic user defined type in the given trie.
:- impure pred table_lookup_insert_user(ml_table, T, ml_table).
:- mode table_lookup_insert_user(in, in, out) is det.
% Lookup or insert a polymorphic user defined type in the given trie.
:- impure pred table_lookup_insert_poly(ml_table, T, ml_table).
:- mode table_lookup_insert_poly(in, in, out) is det.
% Return true if the subgoal represented by the given table has an
% answer. NOTE : this is only used for det and semidet procedures.
:- semipure pred table_have_ans(ml_subgoal_table_node).
:- mode table_have_ans(in) is semidet.
% Save the fact the the subgoal has succeeded in the given table.
:- impure pred table_mark_as_succeeded(ml_subgoal_table_node).
:- mode table_mark_as_succeeded(in) is det.
% Save the fact the the subgoal has failed in the given table.
:- impure pred table_mark_as_failed(ml_subgoal_table_node).
:- mode table_mark_as_failed(in) is det.
% Return true if the subgoal represented by the given table has a
% true answer. NOTE : this is only used for det and semidet
% procedures.
:- semipure pred table_has_succeeded(ml_subgoal_table_node).
:- mode table_has_succeeded(in) is semidet.
% Return true if the subgoal represented by the given table has
% failed. NOTE : this is only used for semidet procedures.
:- semipure pred table_has_failed(ml_subgoal_table_node).
:- mode table_has_failed(in) is semidet.
% Create an answer block with the given number of slots and add it
% to the given table.
:- impure pred table_create_ans_block(ml_subgoal_table_node, int,
ml_answer_block).
:- mode table_create_ans_block(in, in, out) is det.
% Create a new slot in the answer list.
:- impure pred table_new_ans_slot(ml_subgoal_table_node, ml_answer_slot).
:- mode table_new_ans_slot(in, out) is det.
% Save an integer answer in the given answer block at the given
% offset.
:- impure pred table_save_int_ans(ml_answer_block, int, int).
:- mode table_save_int_ans(in, in, in) is det.
% Save a character answer in the given answer block at the given
% offset.
:- impure pred table_save_char_ans(ml_answer_block, int, character).
:- mode table_save_char_ans(in, in, in) is det.
% Save a string answer in the given answer block at the given
% offset.
:- impure pred table_save_string_ans(ml_answer_block, int, string).
:- mode table_save_string_ans(in, in, in) is det.
% Save a float answer in the given answer block at the given
% offset.
:- impure pred table_save_float_ans(ml_answer_block, int, float).
:- mode table_save_float_ans(in, in, in) is det.
% Save any type of answer in the given answer block at the given
% offset.
:- impure pred table_save_any_ans(ml_answer_block, int, T).
:- mode table_save_any_ans(in, in, in) is det.
% Restore an integer answer from the given answer block at the
% given offset.
:- semipure pred table_restore_int_ans(ml_answer_block, int, int).
:- mode table_restore_int_ans(in, in, out) is det.
% Restore a character answer from the given answer block at the
% given offset.
:- semipure pred table_restore_char_ans(ml_answer_block, int, character).
:- mode table_restore_char_ans(in, in, out) is det.
% Restore a string answer from the given answer block at the
% given offset.
:- semipure pred table_restore_string_ans(ml_answer_block, int, string).
:- mode table_restore_string_ans(in, in, out) is det.
% Restore a float answer from the given answer block at the
% given offset.
:- semipure pred table_restore_float_ans(ml_answer_block, int, float).
:- mode table_restore_float_ans(in, in, out) is det.
% Restore any type of answer from the given answer block at the
% given offset.
:- semipure pred table_restore_any_ans(ml_answer_block, int, T).
:- mode table_restore_any_ans(in, in, out) is det.
% Return the table of answers already return to the given nondet
% table.
:- impure pred table_get_ans_table(ml_subgoal_table_node, ml_table).
:- mode table_get_ans_table(in, out) is det.
% Return true if the answer represented by the given answer
% table has not been returned to its parent nondet table.
:- semipure pred table_has_not_returned(ml_answer_table_node).
:- mode table_has_not_returned(in) is semidet.
% Make the answer represented by the given answer table as
% having been return to its parent nondet table.
:- impure pred table_mark_as_returned(ml_answer_table_node).
:- mode table_mark_as_returned(in) is det.
% Save the state of the current subgoal and fail. When this subgoal
% is resumed answers are returned through the second argument.
% The saved state will be used by table_resume/1 to resume the
% subgoal.
:- impure pred table_suspend(ml_subgoal_table_node, ml_answer_block).
:- mode table_suspend(in, out) is nondet.
% Resume all suspended subgoal calls. This predicate will resume each
% of the suspended subgoals in turn until it reaches a fixed point at
% which all suspended subgoals have had all available answers returned
% to them.
:- impure pred table_resume(ml_subgoal_table_node).
:- mode table_resume(in) is det.
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module require, string, std_util, int, float, char, string, list.
% Many of the predicates defined in this module are builtin -
% the compiler generates code for them inline.
:- pragma c_code(type_info_from_typeclass_info(TypeClassInfo::in, Index::in,
TypeInfo::out), will_not_call_mercury,
"
TypeInfo = MR_typeclass_info_type_info(TypeClassInfo, Index);
").
:- pragma c_code(superclass_from_typeclass_info(TypeClassInfo0::in, Index::in,
TypeClassInfo::out), will_not_call_mercury,
"
TypeClassInfo =
MR_typeclass_info_superclass_info(TypeClassInfo0, Index);
").
%-----------------------------------------------------------------------------%
builtin_unify_int(X, X).
builtin_index_int(X, X).
builtin_compare_int(R, X, Y) :-
( X < Y ->
R = (<)
; X = Y ->
R = (=)
;
R = (>)
).
builtin_unify_character(C, C).
builtin_index_character(C, N) :-
char__to_int(C, N).
builtin_compare_character(R, X, Y) :-
char__to_int(X, XI),
char__to_int(Y, YI),
( XI < YI ->
R = (<)
; XI = YI ->
R = (=)
;
R = (>)
).
builtin_unify_string(S, S).
builtin_index_string(_, -1).
builtin_compare_string(R, S1, S2) :-
builtin_strcmp(Res, S1, S2),
( Res < 0 ->
R = (<)
; Res = 0 ->
R = (=)
;
R = (>)
).
builtin_unify_float(F, F).
builtin_index_float(_, -1).
builtin_compare_float(R, F1, F2) :-
( F1 < F2 ->
R = (<)
; F1 > F2 ->
R = (>)
;
R = (=)
).
:- pred builtin_strcmp(int, string, string).
:- mode builtin_strcmp(out, in, in) is det.
:- pragma c_code(builtin_strcmp(Res::out, S1::in, S2::in),
will_not_call_mercury,
"Res = strcmp(S1, S2);").
builtin_index_non_canonical_type(_, -1).
builtin_compare_non_canonical_type(Res, X, _Y) :-
% suppress determinism warning
( semidet_succeed ->
string__append_list([
"call to compare/3 for non-canonical type `",
type_name(type_of(X)),
"'"],
Message),
error(Message)
;
% the following is never executed
Res = (<)
).
:- external(builtin_unify_pred/2).
:- external(builtin_index_pred/2).
:- external(builtin_compare_pred/3).
unused :-
( semidet_succeed ->
error("attempted use of dead predicate")
;
% the following is never executed
true
).
% This is used by the code that the compiler generates for compare/3.
compare_error :-
error("internal error in compare/3").
:- pragma c_header_code("#include ""mercury_type_info.h"""). % XXX needed?
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- type ml_table == c_pointer.
:- type ml_subgoal_table_node == c_pointer.
:- type ml_answer_table_node == c_pointer.
:- type ml_answer_slot == c_pointer.
:- type ml_answer_block == c_pointer.
:- pragma c_header_code("
/* Used to mark the status of the table */
#define ML_UNINITIALIZED 0
#define ML_WORKING_ON_ANS 1
#define ML_FAILED 2
/* The values 3..TYPELAYOUT_MAX_VARINT are reserved for future use */
#define ML_SUCCEEDED TYPELAYOUT_MAX_VARINT
/* This or any greater value indicate that the subgoal has
** succeeded. */
").
% This is a dummy procedure that never actually gets called.
% See the comments in table_gen.m for its purpose.
:- pragma c_code(get_table(_T::out), will_not_call_mercury, "").
:- pragma c_code(table_working_on_ans(T::in), will_not_call_mercury, "
SUCCESS_INDICATOR = (*((Word*) T) == ML_WORKING_ON_ANS);
").
:- pragma c_code(table_not_working_on_ans(T::in), will_not_call_mercury, "
SUCCESS_INDICATOR = (*((Word*) T) != ML_WORKING_ON_ANS);
").
:- pragma c_code(table_mark_as_working(T::in), will_not_call_mercury, "
*((Word*) T) = ML_WORKING_ON_ANS;
").
:- pragma c_code(table_mark_done_working(T::in), will_not_call_mercury, "
*((Word*) T) = ML_UNINITIALIZED;
").
table_loopcheck_error(Message) :-
error(Message).
:- pragma c_code(table_lookup_insert_int(T0::in, I::in, T::out),
will_not_call_mercury, "
T = (Word) MR_TABLE_INT((Word**)T0, I);
").
:- pragma c_code(table_lookup_insert_char(T0::in, C::in, T::out),
will_not_call_mercury, "
T = (Word) MR_TABLE_CHAR((Word **) T0, C);
").
:- pragma c_code(table_lookup_insert_string(T0::in, S::in, T::out),
will_not_call_mercury, "
T = (Word) MR_TABLE_STRING((Word **) T0, S);
").
:- pragma c_code(table_lookup_insert_float(T0::in, F::in, T::out),
will_not_call_mercury, "
T = (Word) MR_TABLE_FLOAT((Word **) T0, F);
").
:- pragma c_code(table_lookup_insert_enum(T0::in, R::in, V::in, T::out),
will_not_call_mercury, "
T = (Word) MR_TABLE_ENUM((Word **) T0, R, V);
").
:- pragma c_code(table_lookup_insert_user(T0::in, V::in, T::out),
will_not_call_mercury, "
T = (Word) MR_TABLE_ANY((Word **) T0, TypeInfo_for_T, V);
").
:- pragma c_code(table_lookup_insert_poly(T0::in, V::in, T::out),
will_not_call_mercury, "
Word T1 = (Word) MR_TABLE_TYPE_INFO((Word **) T0, TypeInfo_for_T);
T = (Word) MR_TABLE_ANY((Word **) T1, TypeInfo_for_T, V);
").
:- pragma c_code(table_have_ans(T::in), will_not_call_mercury, "
if (*((Word*) T) == ML_FAILED || *((Word*) T) >= ML_SUCCEEDED) {
SUCCESS_INDICATOR = TRUE;
} else {
SUCCESS_INDICATOR = FALSE;
}
").
:- pragma c_code(table_has_succeeded(T::in), will_not_call_mercury, "
SUCCESS_INDICATOR = (*((Word*) T) >= ML_SUCCEEDED)
").
:- pragma c_code(table_has_failed(T::in), will_not_call_mercury, "
SUCCESS_INDICATOR = (*((Word*) T) == ML_FAILED);
").
:- pragma c_code(table_create_ans_block(T0::in, Size::in, T::out) ,"
MR_TABLE_CREATE_ANSWER_BLOCK(T0, Size);
T = T0;
").
:- pragma c_code(table_save_int_ans(T::in, Offset::in, I::in),
will_not_call_mercury, "
MR_TABLE_SAVE_ANSWER(Offset, T, I,
mercury_data___base_type_info_int_0);
").
:- pragma c_code(table_save_char_ans(T::in, Offset::in, C::in),
will_not_call_mercury, "
MR_TABLE_SAVE_ANSWER(Offset, T, C,
mercury_data___base_type_info_character_0);
").
:- pragma c_code(table_save_string_ans(T::in, Offset::in, S::in),
will_not_call_mercury, "
MR_TABLE_SAVE_ANSWER(Offset, T, (Word) S,
mercury_data___base_type_info_string_0);
").
:- pragma c_code(table_save_float_ans(T::in, Offset::in, F::in),
will_not_call_mercury, "
MR_TABLE_SAVE_ANSWER(Offset, T, float_to_word(F),
mercury_data___base_type_info_float_0);
").
:- pragma c_code(table_save_any_ans(T::in, Offset::in, V::in),
will_not_call_mercury, "
MR_TABLE_SAVE_ANSWER(Offset, T, V, TypeInfo_for_T);
").
:- pragma c_code(table_mark_as_succeeded(T::in), will_not_call_mercury, "
*((Word*) T) = ML_SUCCEEDED;
").
:- pragma c_code(table_mark_as_failed(T::in), will_not_call_mercury, "
*((Word*) T) = ML_FAILED;
").
:- pragma c_code(table_restore_int_ans(T::in, Offset::in, I::out),
will_not_call_mercury, "
I = (Integer) MR_TABLE_GET_ANSWER(Offset, T);
").
:- pragma c_code(table_restore_char_ans(T::in, Offset::in, C::out),
will_not_call_mercury, "
C = (Char) MR_TABLE_GET_ANSWER(Offset, T);
").
:- pragma c_code(table_restore_string_ans(T::in, Offset::in, S::out),
will_not_call_mercury, "
S = (String) MR_TABLE_GET_ANSWER(Offset, T);
").
:- pragma c_code(table_restore_float_ans(T::in, Offset::in, F::out),
will_not_call_mercury, "
F = word_to_float(MR_TABLE_GET_ANSWER(Offset, T));
").
:- pragma c_code(table_restore_any_ans(T::in, Offset::in, V::out),
will_not_call_mercury, "
V = (Word) MR_TABLE_GET_ANSWER(Offset, T);
").
:- pragma c_header_code("
/*
** The following structures are used by the code for non deterministic tabling.
*/
/* Used to hold a single answer. */
typedef struct {
Word ans_num;
Word ans;
} AnswerListNode;
/* Used to save the state of a subgoal */
typedef struct {
Word *last_ret_ans; /* Pointer to the last answer returned
to the node */
Code *succ_ip; /* Saved succip */
Word *s_p; /* Saved SP */
Word *cur_fr; /* Saved curfr */
Word *max_fr; /* Saved maxfr */
Word non_stack_block_size; /* Size of saved non stack block */
Word *non_stack_block; /* Saved non stack */
Word det_stack_block_size; /* Size of saved det stack block */
Word *det_stack_block; /* Saved det stack */
} SuspendListNode;
typedef enum {
have_no_ans,
have_some_ans,
have_all_ans
} TableStatus;
/* Used to save info about a single subgoal in the table */
typedef struct {
TableStatus status; /* Status of subgoal */
Word answer_table; /* Table of answers returned by the
subgoal */
Word num_ans; /* Number of answers returned by the
subgoal */
Word answer_list; /* List of answers returned by the
subgoal */
Word *answer_list_tail; /* Pointer to the tail of the answer
list. This is used to update the
tail rather than the head of the
ans list. */
Word suspend_list; /* List of suspended calls to the
subgoal */
Word *suspend_list_tail; /* Ditto for answer_list_tail */
Word *non_stack_bottom; /* Pointer to the bottom point of
the nondet stack from which to
copy */
Word *det_stack_bottom; /* Pointer to the bottom point of
the det stack from which to copy */
} NondetTable;
/* Flag used to indicate the answer has been returned */
#define ML_ANS_NOT_RET 0
#define ML_ANS_RET 1
/*
** Cast a Word to a NondetTable*: saves on typing and improves
** readability.
*/
#define NON_TABLE(T) (*(NondetTable **)T)
").
:- pragma c_code(table_setup(T0::in, T::out), will_not_call_mercury, "
/* Init the table if this is the first time me see it */
if (NON_TABLE(T0) == NULL) {
NON_TABLE(T0) = (NondetTable *) table_allocate(
sizeof(NondetTable));
NON_TABLE(T0)->status = have_no_ans;
NON_TABLE(T0)->answer_table = (Word) NULL;
NON_TABLE(T0)->num_ans = 0;
NON_TABLE(T0)->answer_list = list_empty();
NON_TABLE(T0)->answer_list_tail =
&NON_TABLE(T0)->answer_list;
NON_TABLE(T0)->suspend_list = list_empty();
NON_TABLE(T0)->suspend_list_tail =
&NON_TABLE(T0)->suspend_list;
NON_TABLE(T0)->non_stack_bottom = curprevfr;
NON_TABLE(T0)->det_stack_bottom = MR_sp;
}
T = T0;
").
table_return_all_ans(T, A) :-
semipure table_return_all_ans_list(T, AnsList),
list__member(Node, AnsList),
semipure table_return_all_ans_2(Node, A).
:- semipure pred table_return_all_ans_list(ml_table, list(ml_table)).
:- mode table_return_all_ans_list(in, out) is det.
:- pragma c_code(table_return_all_ans_list(T::in, A::out),
will_not_call_mercury, "
A = NON_TABLE(T)->answer_list;
").
:- semipure pred table_return_all_ans_2(ml_table, ml_table).
:- mode table_return_all_ans_2(in, out) is det.
:- pragma c_code(table_return_all_ans_2(P::in, A::out),
will_not_call_mercury, "
A = (Word) &((AnswerListNode*) P)->ans;
").
:- pragma c_code(table_get_ans_table(T::in, AT::out),
will_not_call_mercury, "
AT = (Word) &(NON_TABLE(T)->answer_table);
").
:- pragma c_code(table_have_all_ans(T::in),"
SUCCESS_INDICATOR = (NON_TABLE(T)->status == have_all_ans);
").
:- pragma c_code(table_have_some_ans(T::in), will_not_call_mercury, "
SUCCESS_INDICATOR = (NON_TABLE(T)->status == have_some_ans);
").
:- pragma c_code(table_has_not_returned(T::in), will_not_call_mercury, "
SUCCESS_INDICATOR = (*((Word*) T) == ML_ANS_NOT_RET);
").
:- pragma c_code(table_mark_have_all_ans(T::in), will_not_call_mercury, "
NON_TABLE(T)->status = have_all_ans;
").
:- pragma c_code(table_mark_have_some_ans(T::in), will_not_call_mercury, "
NON_TABLE(T)->status = have_some_ans;
").
:- pragma c_code(table_mark_as_returned(T::in), will_not_call_mercury, "
*((Word *) T) = ML_ANS_RET;
").
:- external(table_suspend/2).
:- external(table_resume/1).
:- pragma c_code("
/*
** The following procedure saves the state of the mercury runtime
** so that it may be used in the table_resume procedure below to return
** answers through this saved state. The procedure table_suspend is
** declared as nondet but the code below is obviously of detism failure,
** the reason for this is quite simple. Normally when a nondet proc
** is called it will first return all of its answers and then fail. In the
** case of calls to this procedure this is reversed first the call will fail
** then later on, when the answers are found, answers will be returned.
** It is also important to note that the answers are returned not from the
** procedure that was originally called (table_suspend) but from the procedure
** table_resume. So essentially what is below is the code to do the initial
** fail; the code to return the answers is in table_resume.
*/
Define_extern_entry(mercury__table_suspend_2_0);
MR_MAKE_STACK_LAYOUT_ENTRY(mercury__table_suspend_2_0);
BEGIN_MODULE(table_suspend_module)
init_entry_sl(mercury__table_suspend_2_0);
BEGIN_CODE
Define_entry(mercury__table_suspend_2_0);
mkframe(mercury__table_suspend/2, 0, ENTRY(do_fail));
{
Word *non_stack_top = MR_maxfr;
Word *det_stack_top = MR_sp;
Word *non_stack_bottom = NON_TABLE(r1)->non_stack_bottom;
Word *det_stack_bottom = NON_TABLE(r1)->det_stack_bottom;
Word non_stack_delta = non_stack_top - non_stack_bottom;
Word det_stack_delta = det_stack_top - det_stack_bottom;
Word ListNode;
SuspendListNode *Node = table_allocate(sizeof(SuspendListNode));
Node->last_ret_ans = &(NON_TABLE(r1)->answer_list);
Node->non_stack_block_size = non_stack_delta;
Node->non_stack_block = table_allocate(non_stack_delta);
table_copy_mem((void *)Node->non_stack_block, (void *)non_stack_bottom,
non_stack_delta);
Node->det_stack_block_size = det_stack_delta;
Node->det_stack_block = table_allocate(det_stack_delta);
table_copy_mem((void *)Node->det_stack_block, (void *)det_stack_bottom,
det_stack_delta);
Node->succ_ip = MR_succip;
Node->s_p = MR_sp;
Node->cur_fr = MR_curfr;
Node->max_fr = MR_maxfr;
ListNode = MR_table_list_cons(Node, *NON_TABLE(r1)->suspend_list_tail);
*NON_TABLE(r1)->suspend_list_tail = ListNode;
NON_TABLE(r1)->suspend_list_tail = &list_tail(ListNode);
}
fail();
END_MODULE
/*
** The following structure is used to hold the state and variables used in
** the table_resume procedure. The state and variables must be held in a
** globally rooted structure as the process of resuming overwrites the mercury
** and C stacks. A new stack is used to avoid this overwriting. This stack is
** defined and accessed by the following macros and global variables.
*/
typedef struct {
NondetTable *table;
Word non_stack_block_size;
Word *non_stack_block;
Word det_stack_block_size;
Word *det_stack_block;
Code *succ_ip;
Word *s_p;
Word *cur_fr;
Word *max_fr;
Word changed;
Word num_ans, new_num_ans;
Word suspend_list;
SuspendListNode *suspend_node;
Word ans_list;
AnswerListNode *ansNode;
} ResumeStackNode;
Integer ML_resumption_sp = -1;
Word ML_resumption_stack_size = 4; /* Half the initial size of
the stack in ResumeStackNode's */
ResumeStackNode** ML_resumption_stack = NULL;
#define ML_RESUME_PUSH() \
do { \
++ML_resumption_sp; \
if (ML_resumption_sp >= ML_resumption_stack_size || \
ML_resumption_stack == NULL) \
{ \
ML_resumption_stack_size = \
ML_resumption_stack_size*2; \
ML_resumption_stack = table_reallocate( \
ML_resumption_stack, \
ML_resumption_stack_size*sizeof( \
ResumeStackNode*)); \
} \
ML_resumption_stack[ML_resumption_sp] = table_allocate( \
sizeof(ResumeStackNode)); \
} while (0)
#define ML_RESUME_POP() \
do { \
if (ML_resumption_sp < 0) { \
fatal_error(""resumption stack underflow""); \
} \
table_free(ML_resumption_stack[ML_resumption_sp]); \
--ML_resumption_sp; \
} while (0)
#define ML_RESUME_VAR \
ML_resumption_stack[ML_resumption_sp]
/*
** The procedure defined below restores answers to suspended nodes. It
** works by restoring the states saved when calls to table_suspend were
** made. By restoring the states saved in table_suspend and then returning
** answers it is essentially returning answers out of the call to table_suspend
** not out of the call to table_resume.
** This procedure iterates until it has returned all answers to all
** suspend nodes. The iteration is a fixpoint type as each time an answer
** is returned to a suspended node it has the chance of introducing more
** answers and/or suspended nodes.
*/
Define_extern_entry(mercury__table_resume_1_0);
Declare_label(mercury__table_resume_1_0_ChangeLoop);
Declare_label(mercury__table_resume_1_0_ChangeLoopDone);
Declare_label(mercury__table_resume_1_0_SolutionsListLoop);
Declare_label(mercury__table_resume_1_0_AnsListLoop);
Declare_label(mercury__table_resume_1_0_AnsListLoopDone1);
Declare_label(mercury__table_resume_1_0_AnsListLoopDone2);
Declare_label(mercury__table_resume_1_0_SkipAns);
Declare_label(mercury__table_resume_1_0_RedoPoint);
MR_MAKE_STACK_LAYOUT_ENTRY(mercury__table_resume_1_0);
MR_MAKE_STACK_LAYOUT_INTERNAL_WITH_ENTRY(
mercury__table_resume_1_0_ChangeLoop, mercury__table_resume_1_0);
MR_MAKE_STACK_LAYOUT_INTERNAL_WITH_ENTRY(
mercury__table_resume_1_0_ChangeLoopDone, mercury__table_resume_1_0);
MR_MAKE_STACK_LAYOUT_INTERNAL_WITH_ENTRY(
mercury__table_resume_1_0_SolutionsListLoop, mercury__table_resume_1_0);
MR_MAKE_STACK_LAYOUT_INTERNAL_WITH_ENTRY(
mercury__table_resume_1_0_AnsListLoop, mercury__table_resume_1_0);
MR_MAKE_STACK_LAYOUT_INTERNAL_WITH_ENTRY(
mercury__table_resume_1_0_AnsListLoopDone1, mercury__table_resume_1_0);
MR_MAKE_STACK_LAYOUT_INTERNAL_WITH_ENTRY(
mercury__table_resume_1_0_AnsListLoopDone2, mercury__table_resume_1_0);
MR_MAKE_STACK_LAYOUT_INTERNAL_WITH_ENTRY(
mercury__table_resume_1_0_SkipAns, mercury__table_resume_1_0);
MR_MAKE_STACK_LAYOUT_INTERNAL_WITH_ENTRY(
mercury__table_resume_1_0_RedoPoint, mercury__table_resume_1_0);
BEGIN_MODULE(table_resume_module)
init_entry_sl(mercury__table_resume_1_0);
init_label_sl(mercury__table_resume_1_0_ChangeLoop);
init_label_sl(mercury__table_resume_1_0_ChangeLoopDone);
init_label_sl(mercury__table_resume_1_0_SolutionsListLoop);
init_label_sl(mercury__table_resume_1_0_AnsListLoop);
init_label_sl(mercury__table_resume_1_0_AnsListLoopDone1);
init_label_sl(mercury__table_resume_1_0_AnsListLoopDone2);
init_label_sl(mercury__table_resume_1_0_SkipAns);
init_label_sl(mercury__table_resume_1_0_RedoPoint);
BEGIN_CODE
Define_entry(mercury__table_resume_1_0);
/* Check that we have answers to return and nodes to return
them to. */
if (list_is_empty(NON_TABLE(r1)->answer_list) ||
list_is_empty(NON_TABLE(r1)->suspend_list))
proceed();
/* Save the current state. */
ML_RESUME_PUSH();
ML_RESUME_VAR->table = NON_TABLE(r1);
ML_RESUME_VAR->non_stack_block_size = (char *) MR_maxfr -
(char *) ML_RESUME_VAR->table->non_stack_bottom;
ML_RESUME_VAR->det_stack_block_size = (char *) MR_sp -
(char *) ML_RESUME_VAR->table->det_stack_bottom;
ML_RESUME_VAR->succ_ip = MR_succip;
ML_RESUME_VAR->s_p = MR_sp;
ML_RESUME_VAR->cur_fr = MR_curfr;
ML_RESUME_VAR->max_fr = MR_maxfr;
ML_RESUME_VAR->changed = 1;
ML_RESUME_VAR->non_stack_block = (Word *) table_allocate(
ML_RESUME_VAR->non_stack_block_size);
table_copy_mem(ML_RESUME_VAR->non_stack_block,
ML_RESUME_VAR->table->non_stack_bottom,
ML_RESUME_VAR->non_stack_block_size);
ML_RESUME_VAR->det_stack_block = (Word *) table_allocate(
ML_RESUME_VAR->det_stack_block_size);
table_copy_mem(ML_RESUME_VAR->det_stack_block,
ML_RESUME_VAR->table->det_stack_bottom,
ML_RESUME_VAR->det_stack_block_size);
/* If the number of ans or suspended nodes has changed. */
Define_label(mercury__table_resume_1_0_ChangeLoop);
if (! ML_RESUME_VAR->changed)
GOTO_LABEL(mercury__table_resume_1_0_ChangeLoopDone);
ML_RESUME_VAR->suspend_list = ML_RESUME_VAR->table->suspend_list;
ML_RESUME_VAR->changed = 0;
ML_RESUME_VAR->num_ans = ML_RESUME_VAR->table->num_ans;
/* For each of the suspended nodes */
Define_label(mercury__table_resume_1_0_SolutionsListLoop);
if (list_is_empty(ML_RESUME_VAR->suspend_list))
GOTO_LABEL(mercury__table_resume_1_0_ChangeLoop);
ML_RESUME_VAR->suspend_node = (SuspendListNode *)list_head(
ML_RESUME_VAR->suspend_list);
ML_RESUME_VAR->ans_list = *ML_RESUME_VAR->suspend_node->
last_ret_ans;
if (list_is_empty(ML_RESUME_VAR->ans_list))
GOTO_LABEL(mercury__table_resume_1_0_AnsListLoopDone2);
ML_RESUME_VAR->ansNode = (AnswerListNode *)list_head(
ML_RESUME_VAR->ans_list);
/*
** Restore the state of the suspended node and return the answer
** through the redoip we saved when the node was originally
** suspended
*/
table_copy_mem(ML_RESUME_VAR->table->non_stack_bottom,
ML_RESUME_VAR->suspend_node->non_stack_block,
ML_RESUME_VAR->suspend_node->non_stack_block_size);
table_copy_mem(ML_RESUME_VAR->table->det_stack_bottom,
ML_RESUME_VAR->suspend_node->det_stack_block,
ML_RESUME_VAR->suspend_node->det_stack_block_size);
MR_succip = ML_RESUME_VAR->suspend_node->succ_ip;
MR_sp = ML_RESUME_VAR->suspend_node->s_p;
MR_curfr = ML_RESUME_VAR->suspend_node->cur_fr;
MR_maxfr = ML_RESUME_VAR->suspend_node->max_fr;
bt_redoip(maxfr) = LABEL(mercury__table_resume_1_0_RedoPoint);
/*
** For each answer not returned to the node whose state we are
** currently in.
*/
Define_label(mercury__table_resume_1_0_AnsListLoop);
#ifdef COMPACT_ARGS
r1 = (Word) &ML_RESUME_VAR->ansNode->ans;
#else
r2 = (word) &ML_RESUME_VAR->ansNode->ans;
#endif
/*
** Return the answer though the point where suspend should have
** returned.
*/
succeed();
Define_label(mercury__table_resume_1_0_RedoPoint);
update_prof_current_proc(LABEL(mercury__table_resume_1_0));
ML_RESUME_VAR->ans_list = list_tail(ML_RESUME_VAR->ans_list);
if (list_is_empty(ML_RESUME_VAR->ans_list))
GOTO_LABEL(mercury__table_resume_1_0_AnsListLoopDone1);
ML_RESUME_VAR->ansNode = (AnswerListNode *)list_head(
ML_RESUME_VAR->ans_list);
GOTO_LABEL(mercury__table_resume_1_0_AnsListLoop);
Define_label(mercury__table_resume_1_0_AnsListLoopDone1);
if (ML_RESUME_VAR->num_ans == ML_RESUME_VAR->table->num_ans)
ML_RESUME_VAR->changed = 0;
else
ML_RESUME_VAR->changed = 1;
ML_RESUME_VAR->suspend_node->last_ret_ans =
&ML_RESUME_VAR->ans_list;
Define_label(mercury__table_resume_1_0_AnsListLoopDone2);
ML_RESUME_VAR->suspend_list = list_tail(ML_RESUME_VAR->suspend_list);
GOTO_LABEL(mercury__table_resume_1_0_SolutionsListLoop);
Define_label(mercury__table_resume_1_0_SkipAns);
ML_RESUME_VAR->ans_list = list_tail(ML_RESUME_VAR->ans_list);
GOTO_LABEL(mercury__table_resume_1_0_AnsListLoop);
Define_label(mercury__table_resume_1_0_ChangeLoopDone);
/* Restore the original state we had when this proc was called */
table_copy_mem(ML_RESUME_VAR->table->non_stack_bottom,
ML_RESUME_VAR->non_stack_block,
ML_RESUME_VAR->non_stack_block_size);
table_free(ML_RESUME_VAR->non_stack_block);
table_copy_mem(ML_RESUME_VAR->table->det_stack_bottom,
ML_RESUME_VAR->det_stack_block,
ML_RESUME_VAR->det_stack_block_size);
table_free(ML_RESUME_VAR->det_stack_block);
MR_succip = ML_RESUME_VAR->succ_ip;
MR_sp = ML_RESUME_VAR->s_p;
MR_curfr = ML_RESUME_VAR->cur_fr;
MR_maxfr = ML_RESUME_VAR->max_fr;
ML_RESUME_POP();
proceed();
END_MODULE
/* Ensure that the initialization code for the above module gets run. */
/*
INIT sys_init_table_suspend_module
INIT sys_init_table_resume_module
*/
void sys_init_table_suspend_module(void);
/* extra declaration to suppress gcc -Wmissing-decl warning */
void sys_init_table_suspend_module(void) {
extern ModuleFunc table_suspend_module;
table_suspend_module();
}
void sys_init_table_resume_module(void);
/* extra declaration to suppress gcc -Wmissing-decl warning */
void sys_init_table_resume_module(void) {
extern ModuleFunc table_resume_module;
table_resume_module();
}
").
:- pragma c_code(table_new_ans_slot(T::in, Slot::out),
will_not_call_mercury, "
Word ListNode;
Word ans_num;
AnswerListNode *n = table_allocate(sizeof(AnswerListNode));
++(NON_TABLE(T)->num_ans);
ans_num = NON_TABLE(T)->num_ans;
n->ans_num = ans_num;
n->ans = 0;
ListNode = MR_table_list_cons(n, *NON_TABLE(T)->answer_list_tail);
*NON_TABLE(T)->answer_list_tail = ListNode;
NON_TABLE(T)->answer_list_tail = &list_tail(ListNode);
Slot = (Word) &n->ans;
").
:- end_module private_builtin.
%-----------------------------------------------------------------------------%
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
WWW: <http://www.cs.mu.oz.au/~fjh> | of excellence is a lethal habit"
PGP: finger fjh at 128.250.37.3 | -- the last words of T. S. Garp.
More information about the developers
mailing list