[m-dev.] diff: more MLDS stuff
Fergus Henderson
fjh at cs.mu.OZ.AU
Tue May 9 02:10:16 AEST 2000
With these changes, I was able to get quite a few non-trivial programs
working with the MLDS back-end, e.g. `cat', `eliza', and `interpreter'
from the samples directory, using the following Mmake.stage.params:
GRADE=hlc.gc
EXTRA_MCFLAGS=--no-line-numbers
EXTRA_CFLAGS=-Wno-write-strings -Wno-pointer-arith -I../library
LIBRARY_INTERMODULE=no
MCFLAGS-std_util = -O0
MCFLAGS-benchmarking = -O0
----------
Estimated hours taken: 6
More work on the MLDS back-end.
runtime/mercury.c:
Fix a cut-and-paste bug in the code for compare/3:
I forgot to add `break' after each case of a `switch' statement.
library/builtin.m:
library/private_builtin.m:
Replace the hand-coded definition of builtin_{compare,unify}_pred
in builtin.m with ordinary Mercury clauses in private_builtin.m.
This ensures that it works with the MLDS back-end.
(It also means that these procedures call error/1 rather than
MR_fatal_error(), so you get an exception rather than a
program abort.)
runtime/mercury.h:
runtime/mercury.c:
Add declarations and definitions of the compare and unify
procedures for the builtin types. (For some types,
the definitions here are still just stubs.)
runtime/mercury.h:
runtime/mercury.c:
runtime/mercury_init.h:
Add some hacks to work-around the current lack of support
for `pragma export'.
runtime/mercury_type_info.c:
If MR_HIGHLEVEL_CODE is defined, don't #include "mercury_imp.h",
since it is not needed.
runtime/mercury_wrapper.c:
runtime/mercury_wrapper.h:
runtime/mercury_init.h:
util/mkinit.c:
scripts/c2init.in:
Add support for the MLDS back-end to the program start-up
code.
Workspace: /home/pgrad/fjh/ws/hg
Index: library/builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/builtin.m,v
retrieving revision 1.34
diff -u -d -r1.34 builtin.m
--- library/builtin.m 2000/05/08 13:48:34 1.34
+++ library/builtin.m 2000/05/08 14:18:59
@@ -294,24 +294,6 @@
MR_DEFINE_BUILTIN_TYPE_CTOR_INFO_UNUSED(trailptr, 0, MR_TYPECTOR_REP_TRAIL_PTR);
MR_DEFINE_BUILTIN_TYPE_CTOR_INFO_UNUSED(ticket, 0, MR_TYPECTOR_REP_TICKET);
-Define_extern_entry(mercury__builtin_unify_pred_2_0);
-Define_extern_entry(mercury__builtin_compare_pred_3_0);
-
-BEGIN_MODULE(builtin_types_module)
- init_entry_ai(mercury__builtin_unify_pred_2_0);
- init_entry_ai(mercury__builtin_compare_pred_3_0);
-BEGIN_CODE
-/* code for predicate 'builtin_unify_pred'/2 in mode 0 */
-Define_entry(mercury__builtin_unify_pred_2_0);
- MR_incr_sp_push_msg(2, ""private_builtin:builtin_unify_pred"");
- MR_fatal_error(""attempted unification of higher-order terms"");
-
-/* code for predicate 'builtin_compare_pred'/3 in mode 0 */
-Define_entry(mercury__builtin_compare_pred_3_0);
- MR_incr_sp_push_msg(2, ""private_builtin:builtin_compare_pred"");
- MR_fatal_error(""attempted comparison of higher-order terms"");
-END_MODULE
-
/*
INIT sys_init_builtin_types_module
*/
@@ -320,8 +302,6 @@
void sys_init_builtin_types_module(void); /* suppress gcc warning */
void sys_init_builtin_types_module(void) {
-
- builtin_types_module();
/*
** We had better call this init() because we use the
Index: library/private_builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/private_builtin.m,v
retrieving revision 1.51
diff -u -d -r1.51 private_builtin.m
--- library/private_builtin.m 2000/05/08 13:48:36 1.51
+++ library/private_builtin.m 2000/05/08 14:04:06
@@ -166,9 +166,25 @@
[will_not_call_mercury, thread_safe],
"Res = strcmp(S1, S2);").
-:- external(builtin_unify_pred/2).
-:- external(builtin_compare_pred/3).
+:- pragma no_inline(builtin_unify_pred/2).
+builtin_unify_pred(_X, _Y) :-
+ ( semidet_succeed ->
+ error("attempted higher-order unification")
+ ;
+ % the following is never executed
+ semidet_succeed
+ ).
+:- pragma no_inline(builtin_compare_pred/3).
+builtin_compare_pred(Result, _X, _Y) :-
+ ( semidet_succeed ->
+ error("attempted higher-order comparison")
+ ;
+ % the following is never executed
+ Result = (<)
+ ).
+
+:- pragma no_inline(builtin_compare_non_canonical_type/3).
builtin_compare_non_canonical_type(Res, X, _Y) :-
% suppress determinism warning
( semidet_succeed ->
@@ -184,6 +200,7 @@
).
% This is used by the code that the compiler generates for compare/3.
+:- pragma no_inline(compare_error/0).
compare_error :-
error("internal error in compare/3").
Index: runtime/mercury.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.c,v
retrieving revision 1.3
diff -u -d -r1.3 mercury.c
--- runtime/mercury.c 2000/05/08 13:48:44 1.3
+++ runtime/mercury.c 2000/05/08 15:46:51
@@ -12,7 +12,7 @@
#include "mercury.h"
#include "mercury_type_info.h" /* for MR_TYPECTOR_REP* */
-#include "mercury_misc.h" /* for fatal_error() */
+#include "mercury_misc.h" /* for MR_fatal_error() */
#ifdef MR_HIGHLEVEL_CODE
@@ -28,6 +28,8 @@
** Type definitions
*/
+/* Types for the wrapper versions of type-specific unify/compare procedures. */
+
typedef bool MR_UnifyFunc_0(MR_Box, MR_Box);
typedef bool MR_UnifyFunc_1(MR_Word, MR_Box, MR_Box);
typedef bool MR_UnifyFunc_2(MR_Word, MR_Word, MR_Box, MR_Box);
@@ -49,6 +51,51 @@
/*---------------------------------------------------------------------------*/
/*
+** Forward declarations of static functions.
+** These functions are used in the initializers
+** for the type_ctor_info constants defined below.
+*/
+
+static MR_UnifyFunc_0
+ mercury__builtin__do_unify__int_0_0,
+ mercury__builtin__do_unify__string_0_0,
+ mercury__builtin__do_unify__float_0_0,
+ mercury__builtin__do_unify__character_0_0,
+ mercury__builtin__do_unify__void_0_0,
+ mercury__builtin__do_unify__c_pointer_0_0,
+ mercury__builtin__do_unify__func_0_0,
+ mercury__builtin__do_unify__pred_0_0,
+ mercury__std_util__do_unify__univ_0_0,
+ mercury__std_util__do_unify__type_desc_0_0;
+
+static MR_UnifyFunc_1
+ mercury__array__do_unify__array_1_0,
+ mercury__private_builtin__do_unify__type_ctor_info_1_0,
+ mercury__private_builtin__do_unify__type_info_1_0,
+ mercury__private_builtin__do_unify__typeclass_info_1_0,
+ mercury__private_builtin__do_unify__base_typeclass_info_1_0;
+
+static MR_CompareFunc_0
+ mercury__builtin__do_compare__int_0_0,
+ mercury__builtin__do_compare__string_0_0,
+ mercury__builtin__do_compare__float_0_0,
+ mercury__builtin__do_compare__character_0_0,
+ mercury__builtin__do_compare__void_0_0,
+ mercury__builtin__do_compare__c_pointer_0_0,
+ mercury__builtin__do_compare__func_0_0,
+ mercury__builtin__do_compare__pred_0_0,
+ mercury__std_util__do_compare__univ_0_0,
+ mercury__std_util__do_compare__type_desc_0_0;
+
+static MR_CompareFunc_1
+ mercury__array__do_compare__array_1_0,
+ mercury__private_builtin__do_compare__type_ctor_info_1_0,
+ mercury__private_builtin__do_compare__type_info_1_0,
+ mercury__private_builtin__do_compare__typeclass_info_1_0,
+ mercury__private_builtin__do_compare__base_typeclass_info_1_0;
+
+/*---------------------------------------------------------------------------*/
+/*
** Constant definitions
*/
@@ -74,28 +121,23 @@
MR_PASTE2(__, \
MR_PASTE2(TYPE, \
MR_PASTE2(_, \
- ARITY)))))))
+ MR_PASTE2(ARITY, \
+ _0))))))))
#define MR_special_func_type(NAME, ARITY) \
MR_PASTE2(MR_, MR_PASTE2(NAME, MR_PASTE2(Func_, ARITY)))
#define MR_define_type_ctor_info(module, type, arity, type_rep) \
- \
- extern MR_special_func_type(Unify, arity) \
- MR_type_ctor_info_func_name(module, type, arity, __Unify__); \
- extern MR_special_func_type(Compare, arity) \
- MR_type_ctor_info_func_name(module, type, arity, __Compare__);\
- \
const struct MR_TypeCtorInfo_Struct \
MR_type_ctor_info_name(module, type, arity) = \
{ \
arity, \
(MR_Box) MR_type_ctor_info_func_name(module, type, arity, \
- __Unify__), \
+ do_unify), \
(MR_Box) MR_type_ctor_info_func_name(module, type, arity, \
- __Unify__), \
+ do_unify), \
(MR_Box) MR_type_ctor_info_func_name(module, type, arity, \
- __Compare__), \
+ do_compare), \
type_rep, \
NULL, \
NULL, \
@@ -129,16 +171,21 @@
MR_TYPECTOR_REP_TYPECLASSINFO);
/*---------------------------------------------------------------------------*/
+
+#define SORRY(msg) MR_fatal_error("Sorry, not yet implemented: " msg);
+
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
/*
** Function definitions
*/
/*
-** Define the builtin unify/2 and compare/3 functions.
+** Define the generic unify/2 and compare/3 functions.
*/
bool
-mercury__builtin__unify_2_p_0(Word ti, MR_Box x, MR_Box y)
+mercury__builtin__unify_2_p_0(MR_Word ti, MR_Box x, MR_Box y)
{
MR_TypeInfo type_info;
MR_TypeCtorInfo type_ctor_info;
@@ -179,12 +226,13 @@
(args[1], args[2], args[3],
args[4], args[5], x, y);
default:
- MR_fatal_error("unify/2: type arity > 5 not supported");
+ MR_fatal_error(
+ "unify/2: type arity > 5 not supported");
}
}
void
-mercury__builtin__compare_3_p_0(Word ti, Word *res, MR_Box x, MR_Box y)
+mercury__builtin__compare_3_p_0(MR_Word ti, MR_Word *res, MR_Box x, MR_Box y)
{
MR_TypeInfo type_info;
MR_TypeCtorInfo type_ctor_info;
@@ -211,39 +259,535 @@
*/
case 0: ((MR_CompareFunc_0 *) type_ctor_info->compare_pred)
(res, x, y);
+ break;
case 1: ((MR_CompareFunc_1 *) type_ctor_info->compare_pred)
(args[1], res, x, y);
+ break;
case 2: ((MR_CompareFunc_2 *) type_ctor_info->compare_pred)
(args[1], args[2], res, x, y);
+ break;
case 3: ((MR_CompareFunc_3 *) type_ctor_info->compare_pred)
(args[1], args[2], args[3], res, x, y);
+ break;
case 4: ((MR_CompareFunc_4 *) type_ctor_info->compare_pred)
(args[1], args[2], args[3],
args[4], res, x, y);
+ break;
case 5: ((MR_CompareFunc_5 *) type_ctor_info->compare_pred)
(args[1], args[2], args[3],
args[4], args[5], res, x, y);
+ break;
default:
- MR_fatal_error("index/2: type arity > 5 not supported");
+ MR_fatal_error(
+ "index/2: type arity > 5 not supported");
}
}
void
-mercury__builtin__compare_3_p_1(Word type_info, Word *res, MR_Box x, MR_Box y)
+mercury__builtin__compare_3_p_1(
+ MR_Word type_info, MR_Word *res, MR_Box x, MR_Box y)
{
return mercury__builtin__compare_3_p_0(type_info, res, x, y);
}
void
-mercury__builtin__compare_3_p_2(Word type_info, Word *res, MR_Box x, MR_Box y)
+mercury__builtin__compare_3_p_2(
+ MR_Word type_info, MR_Word *res, MR_Box x, MR_Box y)
{
return mercury__builtin__compare_3_p_0(type_info, res, x, y);
}
void
-mercury__builtin__compare_3_p_3(Word type_info, Word *res, MR_Box x, MR_Box y)
+mercury__builtin__compare_3_p_3(
+ MR_Word type_info, MR_Word *res, MR_Box x, MR_Box y)
{
return mercury__builtin__compare_3_p_0(type_info, res, x, y);
}
+
+/*---------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
+/*
+** Definitions of the type-specific __Unify__ and __Compare__ procedures
+** for the builtin types.
+**
+** There are two versions of each of these. The first version, __Unify__,
+** which is called when the type is known at compile time,
+** has the arguments unboxed. The second version, do_unify_, which is
+** stored in the type_ctor_info and called from the generic
+** unify/2 or compare/3, is a wrapper that has the arguments boxed,
+** and just calls the first version.
+*/
+
+/*---------------------------------------------------------------------------*/
+/*
+** Unification procedures with the arguments unboxed.
+*/
+
+bool
+mercury__builtin____Unify____int_0_0(MR_Integer x, MR_Integer y)
+{
+ return x == y;
+}
+
+bool
+mercury__builtin____Unify____string_0_0(MR_String x, MR_String y)
+{
+ return strcmp(x, y) == 0;
+}
+
+bool
+mercury__builtin____Unify____float_0_0(MR_Float x, MR_Float y)
+{
+ /* XXX what should this function do when x and y are both NaNs? */
+ return x == y;
+}
+
+bool
+mercury__builtin____Unify____character_0_0(MR_Char x, MR_Char y)
+{
+ return x == y;
+}
+
+bool
+mercury__builtin____Unify____void_0_0(MR_Word x, MR_Word y)
+{
+ MR_fatal_error("called unify for type `void'");
+}
+
+bool
+mercury__builtin____Unify____c_pointer_0_0(MR_Word x, MR_Word y)
+{
+ return (void *) x == (void *) y;
+}
+
+bool
+mercury__builtin____Unify____func_0_0(MR_Word x, MR_Word y)
+{
+ MR_fatal_error("called unify for `func' type");
+}
+
+bool
+mercury__builtin____Unify____pred_0_0(MR_Word x, MR_Word y)
+{
+ MR_fatal_error("called unify for `pred' type");
+}
+
+bool
+mercury__array____Unify____array_1_0(MR_Word type_info, MR_Word x, MR_Word y)
+{
+ SORRY("unify for array");
+}
+
+bool
+mercury__std_util____Unify____univ_0_0(MR_Word x, MR_Word y)
+{
+ SORRY("unify for univ");
+}
+
+bool
+mercury__std_util____Unify____type_desc_0_0(MR_Word x, MR_Word y)
+{
+ SORRY("unify for type_desc");
+}
+
+bool
+mercury__private_builtin____Unify____type_ctor_info_1_0(
+ MR_Word type_info, MR_Word x, MR_Word y)
+{
+ SORRY("unify for type_ctor_info");
+}
+
+bool
+mercury__private_builtin____Unify____type_info_1_0(
+ MR_Word type_info, MR_Word x, MR_Word y)
+{
+ SORRY("unify for type_info");
+}
+
+bool
+mercury__private_builtin____Unify____typeclass_info_1_0(
+ MR_Word type_info, MR_Word x, MR_Word y)
+{
+ SORRY("unify for typeclass_info");
+}
+
+bool
+mercury__private_builtin____Unify____base_typeclass_info_1_0(
+ MR_Word type_info, MR_Word x, MR_Word y)
+{
+ SORRY("unify for base_typeclass_info");
+}
+
+/*---------------------------------------------------------------------------*/
+/*
+** Comparison procedures with the arguments unboxed.
+*/
+
+void
+mercury__builtin____Compare____int_0_0(
+ MR_Word *result, MR_Integer x, MR_Integer y)
+{
+ *result = (x > y ? MR_COMPARE_GREATER :
+ x == y ? MR_COMPARE_EQUAL :
+ MR_COMPARE_LESS);
+}
+
+void
+mercury__builtin____Compare____string_0_0(MR_Word *result,
+ MR_String x, MR_String y)
+{
+ int res = strcmp(x, y);
+ *result = (res > 0 ? MR_COMPARE_GREATER :
+ res == 0 ? MR_COMPARE_EQUAL :
+ MR_COMPARE_LESS);
+}
+
+void
+mercury__builtin____Compare____float_0_0(
+ MR_Word *result, MR_Float x, MR_Float y)
+{
+ /* XXX what should this function do when x and y are both NaNs? */
+ *result = (x > y ? MR_COMPARE_GREATER :
+ x == y ? MR_COMPARE_EQUAL :
+ x < y ? MR_COMPARE_LESS :
+ (MR_fatal_error("incomparable floats in compare/3"),
+ MR_COMPARE_EQUAL));
+}
+
+void
+mercury__builtin____Compare____character_0_0(
+ MR_Word *result, MR_Char x, MR_Char y)
+{
+ *result = (x > y ? MR_COMPARE_GREATER :
+ x == y ? MR_COMPARE_EQUAL :
+ MR_COMPARE_LESS);
+}
+
+void
+mercury__builtin____Compare____void_0_0(MR_Word *result, MR_Word x, MR_Word y)
+{
+ MR_fatal_error("called compare/3 for type `void'");
+}
+
+void
+mercury__builtin____Compare____c_pointer_0_0(
+ MR_Word *result, MR_Word x, MR_Word y)
+{
+ *result =
+ ( (void *) x == (void *) y ? MR_COMPARE_EQUAL
+ : (void *) x < (void *) y ? MR_COMPARE_LESS
+ : MR_COMPARE_GREATER
+ );
+}
+
+void
+mercury__builtin____Compare____func_0_0(MR_Word *result, MR_Word x, MR_Word y)
+{
+ MR_fatal_error("called compare/3 for `func' type");
+}
+
+void
+mercury__builtin____Compare____pred_0_0(MR_Word *result, MR_Word x, MR_Word y)
+{
+ MR_fatal_error("called compare/3 for `pred' type");
+}
+
+void
+mercury__array____Compare____array_1_0(
+ MR_Word type_info, MR_Word *result, MR_Word x, MR_Word y)
+{
+ SORRY("compare for array");
+}
+
+void
+mercury__std_util____Compare____univ_0_0(MR_Word *result, MR_Word x, MR_Word y)
+{
+ SORRY("compare for univ");
+}
+
+void
+mercury__std_util____Compare____type_desc_0_0(
+ MR_Word *result, MR_Word x, MR_Word y)
+{
+ SORRY("compare for type_desc");
+}
+
+void
+mercury__private_builtin____Compare____type_ctor_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Word x, MR_Word y)
+{
+ SORRY("compare for type_ctor_info");
+}
+
+void
+mercury__private_builtin____Compare____type_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Word x, MR_Word y)
+{
+ SORRY("compare for type_info");
+}
+
+void
+mercury__private_builtin____Compare____typeclass_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Word x, MR_Word y)
+{
+ SORRY("compare for typeclass_info");
+}
+
+void
+mercury__private_builtin____Compare____base_typeclass_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Word x, MR_Word y)
+{
+ SORRY("compare for base_typeclass_info");
+}
+
+/*---------------------------------------------------------------------------*/
+/*
+** Unification procedures with the arguments boxed.
+** These are just wrappers which call the unboxed version.
+*/
+
+static bool
+mercury__builtin__do_unify__int_0_0(MR_Box x, MR_Box y)
+{
+ return mercury__builtin____Unify____int_0_0(
+ (MR_Integer) x, (MR_Integer) y);
+}
+
+static bool
+mercury__builtin__do_unify__string_0_0(MR_Box x, MR_Box y)
+{
+ return mercury__builtin____Unify____string_0_0(
+ (MR_String) x, (MR_String) y);
+}
+
+static bool
+mercury__builtin__do_unify__float_0_0(MR_Box x, MR_Box y)
+{
+ return mercury__builtin____Unify____float_0_0(
+ MR_unbox_float(x), MR_unbox_float(y));
+}
+
+static bool
+mercury__builtin__do_unify__character_0_0(MR_Box x, MR_Box y)
+{
+ return mercury__builtin____Unify____character_0_0(
+ (MR_Char) (MR_Word) x, (MR_Char) (MR_Word) y);
+}
+
+static bool
+mercury__builtin__do_unify__void_0_0(MR_Box x, MR_Box y)
+{
+ MR_fatal_error("called unify for type `void'");
+}
+
+static bool
+mercury__builtin__do_unify__c_pointer_0_0(MR_Box x, MR_Box y)
+{
+ return mercury__builtin____Unify____c_pointer_0_0(
+ (MR_Word) x, (MR_Word) y);
+}
+
+static bool
+mercury__builtin__do_unify__func_0_0(MR_Box x, MR_Box y)
+{
+ MR_fatal_error("called unify for `func' type");
+}
+
+static bool
+mercury__builtin__do_unify__pred_0_0(MR_Box x, MR_Box y)
+{
+ MR_fatal_error("called unify for `pred' type");
+}
+
+static bool
+mercury__array__do_unify__array_1_0(MR_Word type_info, MR_Box x, MR_Box y)
+{
+ return mercury__array____Unify____array_1_0(
+ type_info, (MR_Word) x, (MR_Word) y);
+}
+
+static bool
+mercury__std_util__do_unify__univ_0_0(MR_Box x, MR_Box y)
+{
+ return mercury__std_util____Unify____univ_0_0(
+ (MR_Word) x, (MR_Word) y);
+}
+
+static bool
+mercury__std_util__do_unify__type_desc_0_0(MR_Box x, MR_Box y)
+{
+ return mercury__std_util____Unify____type_desc_0_0(
+ (MR_Word) x, (MR_Word) y);
+}
+
+static bool
+mercury__private_builtin__do_unify__type_ctor_info_1_0(
+ MR_Word type_info, MR_Box x, MR_Box y)
+{
+ return mercury__private_builtin____Unify____type_ctor_info_1_0(
+ type_info, (MR_Word) x, (MR_Word) y);
+}
+
+static bool
+mercury__private_builtin__do_unify__type_info_1_0(
+ MR_Word type_info, MR_Box x, MR_Box y)
+{
+ return mercury__private_builtin____Unify____type_info_1_0(
+ type_info, (MR_Word) x, (MR_Word) y);
+}
+
+static bool
+mercury__private_builtin__do_unify__typeclass_info_1_0(
+ MR_Word type_info, MR_Box x, MR_Box y)
+{
+ return mercury__private_builtin____Unify____typeclass_info_1_0(
+ type_info, (MR_Word) x, (MR_Word) y);
+}
+
+static bool
+mercury__private_builtin__do_unify__base_typeclass_info_1_0(
+ MR_Word type_info, MR_Box x, MR_Box y)
+{
+ return mercury__private_builtin____Unify____base_typeclass_info_1_0(
+ type_info, (MR_Word) x, (MR_Word) y);
+}
+
+/*---------------------------------------------------------------------------*/
+/*
+** Comparison procedures with the arguments boxed.
+** These are just wrappers which call the unboxed version.
+*/
+
+static void
+mercury__builtin__do_compare__int_0_0(MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__builtin____Compare____int_0_0(result,
+ (Integer) x, (Integer) y);
+}
+
+static void
+mercury__builtin__do_compare__string_0_0(MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__builtin____Compare____string_0_0(result,
+ (MR_String) x, (MR_String) y);
+}
+
+static void
+mercury__builtin__do_compare__float_0_0(MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__builtin____Compare____float_0_0(result,
+ MR_unbox_float(x), MR_unbox_float(y));
+}
+
+static void
+mercury__builtin__do_compare__character_0_0(
+ MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__builtin____Compare____character_0_0(
+ result, (MR_Char) (MR_Word) x, (MR_Char) (MR_Word) y);
+}
+
+static void
+mercury__builtin__do_compare__void_0_0(MR_Word *result, MR_Box x, MR_Box y)
+{
+ MR_fatal_error("called compare/3 for type `void'");
+}
+
+static void
+mercury__builtin__do_compare__c_pointer_0_0(
+ MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__builtin____Compare____c_pointer_0_0(
+ result, (MR_Word) x, (MR_Word) y);
+}
+
+static void
+mercury__builtin__do_compare__func_0_0(MR_Word *result, MR_Box x, MR_Box y)
+{
+ MR_fatal_error("called compare/3 for func type");
+}
+
+static void
+mercury__builtin__do_compare__pred_0_0(MR_Word *result, MR_Box x, MR_Box y)
+{
+ MR_fatal_error("called compare/3 for pred type");
+}
+
+static void
+mercury__array__do_compare__array_1_0(
+ MR_Word type_info, MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__array____Compare____array_1_0(
+ type_info, result, (MR_Word) x, (MR_Word) y);
+}
+
+static void
+mercury__std_util__do_compare__univ_0_0(MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__std_util____Compare____univ_0_0(
+ result, (MR_Word) x, (MR_Word) y);
+}
+
+static void
+mercury__std_util__do_compare__type_desc_0_0(
+ MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__std_util____Compare____type_desc_0_0(
+ result, (MR_Word) x, (MR_Word) y);
+}
+
+static void
+mercury__private_builtin__do_compare__type_ctor_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__private_builtin____Compare____type_ctor_info_1_0(
+ type_info, result, (MR_Word) x, (MR_Word) y);
+}
+
+static void
+mercury__private_builtin__do_compare__type_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__private_builtin____Compare____type_info_1_0(
+ type_info, result, (MR_Word) x, (MR_Word) y);
+}
+
+static void
+mercury__private_builtin__do_compare__typeclass_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__private_builtin____Compare____typeclass_info_1_0(
+ type_info, result, (MR_Word) x, (MR_Word) y);
+}
+
+static void
+mercury__private_builtin__do_compare__base_typeclass_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Box x, MR_Box y)
+{
+ mercury__private_builtin____Compare____base_typeclass_info_1_0(
+ type_info, result, (MR_Word) x, (MR_Word) y);
+}
+
+/*---------------------------------------------------------------------------*/
+
+/*
+** XXX this is a hack to work-around the current lack of
+** support for `pragma export'.
+*/
+
+extern void mercury__io__print_3_p_0(MR_Word ti, MR_Box x);
+extern void mercury__io__print_4_p_0(MR_Word ti, MR_Word stream, MR_Box x);
+
+void
+ML_io_print_to_cur_stream(MR_Word ti, MR_Word x) {
+ mercury__io__print_3_p_0(ti, (MR_Box) x);
+}
+
+void
+ML_io_print_to_stream(MR_Word ti, MR_Word stream, MR_Word x) {
+ mercury__io__print_4_p_0(ti, stream, (MR_Box) x);
+}
+
+/*---------------------------------------------------------------------------*/
#endif /* MR_HIGHLEVEL_CODE */
Index: runtime/mercury.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury.h,v
retrieving revision 1.6
diff -u -d -r1.6 mercury.h
--- runtime/mercury.h 2000/05/05 10:14:47 1.6
+++ runtime/mercury.h 2000/05/08 14:06:12
@@ -39,6 +39,20 @@
/*---------------------------------------------------------------------------*/
/*
+** XXX this is a hack to work-around the current lack of
+** support for `pragma export'.
+*/
+#define ML_report_uncaught_exception \
+ mercury__exception__report_uncaught_exception_3_p_0
+#define ML_throw_io_error mercury__io__throw_io_error_1_p_0
+#define ML_io_finalize_state mercury__io__finalize_state_2_p_0
+#define ML_io_init_state mercury__io__init_state_2_p_0
+#define ML_io_stderr_stream mercury__io__stderr_stream_3_p_0
+#define ML_io_stdin_stream mercury__io__stdin_stream_3_p_0
+#define ML_io_stdout_stream mercury__io__stdout_stream_3_p_0
+
+/*---------------------------------------------------------------------------*/
+/*
** Type definitions
*/
@@ -50,6 +64,7 @@
typedef Float MR_Float;
typedef Integer MR_Integer;
typedef String MR_String;
+typedef ConstString MR_ConstString;
/*
** The MR_Box type is used for representing polymorphic types.
@@ -180,6 +195,11 @@
*/
extern const MR_TypeCtorInfo_Struct
mercury__tree234__tree234__type_ctor_info_tree234_2;
+bool mercury__tree234____Unify____tree234_2_0(
+ MR_Word key_type, MR_Word val_type, MR_Word x, MR_Word y);
+void mercury__tree234____Compare____tree234_2_0(
+ MR_Word key_type, MR_Word val_type,
+ MR_Word *result, MR_Word x, MR_Word y);
/*
** XXX this is a bit of a hack: really we should change it so that
@@ -302,7 +322,7 @@
(*(dest) = (src))
#endif
-/*-----------------------------------------------------------------------------*/
+/*---------------------------------------------------------------------------*/
/*
** Function declarations
*/
@@ -313,6 +333,68 @@
void mercury__builtin__compare_3_p_2(Word type_info, Word *, MR_Box, MR_Box);
void mercury__builtin__compare_3_p_3(Word type_info, Word *, MR_Box, MR_Box);
-/*-----------------------------------------------------------------------------*/
+bool mercury__builtin____Unify____int_0_0(MR_Integer x, MR_Integer y);
+bool mercury__builtin____Unify____string_0_0(MR_String x, MR_String y);
+bool mercury__builtin____Unify____float_0_0(MR_Float x, MR_Float y);
+bool mercury__builtin____Unify____character_0_0(MR_Char x, MR_Char);
+bool mercury__builtin____Unify____void_0_0(MR_Word x, MR_Word y);
+bool mercury__builtin____Unify____c_pointer_0_0(MR_Word x, MR_Word y);
+bool mercury__builtin____Unify____func_0_0(MR_Word x, MR_Word y);
+bool mercury__builtin____Unify____pred_0_0(MR_Word x, MR_Word y);
+bool mercury__array____Unify____array_1_0(Word type_info, MR_Word x, MR_Word y);
+bool mercury__std_util____Unify____univ_0_0(MR_Word x, MR_Word y);
+bool mercury__std_util____Unify____type_desc_0_0(MR_Word x, MR_Word y);
+bool mercury__private_builtin____Unify____type_ctor_info_1_0(
+ MR_Word type_info, MR_Word x, MR_Word y);
+bool mercury__private_builtin____Unify____type_info_1_0(
+ MR_Word type_info, MR_Word x, MR_Word y);
+bool mercury__private_builtin____Unify____typeclass_info_1_0(
+ MR_Word type_info, MR_Word x, MR_Word y);
+bool mercury__private_builtin____Unify____base_typeclass_info_1_0(
+ MR_Word type_info, MR_Word x, MR_Word y);
+
+void mercury__builtin____Compare____int_0_0(
+ MR_Word *result, MR_Integer x, MR_Integer y);
+void mercury__builtin____Compare____string_0_0(MR_Word *result,
+ MR_String x, MR_String y);
+void mercury__builtin____Compare____float_0_0(
+ MR_Word *result, MR_Float x, MR_Float y);
+void mercury__builtin____Compare____character_0_0(
+ MR_Word *result, MR_Char x, MR_Char y);
+void mercury__builtin____Compare____void_0_0(
+ MR_Word *result, MR_Word x, MR_Word y);
+void mercury__builtin____Compare____c_pointer_0_0(
+ MR_Word *result, MR_Word x, MR_Word y);
+void mercury__builtin____Compare____func_0_0(
+ MR_Word *result, MR_Word x, MR_Word y);
+void mercury__builtin____Compare____pred_0_0(
+ MR_Word *result, MR_Word x, MR_Word y);
+void mercury__array____Compare____array_1_0(
+ Word type_info, MR_Word *result, MR_Word x, MR_Word y);
+void mercury__std_util____Compare____univ_0_0(
+ MR_Word *result, MR_Word x, MR_Word y);
+void mercury__std_util____Compare____type_desc_0_0(
+ MR_Word *result, MR_Word x, MR_Word y);
+void mercury__private_builtin____Compare____type_ctor_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Word x, MR_Word y);
+void mercury__private_builtin____Compare____type_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Word x, MR_Word y);
+void mercury__private_builtin____Compare____typeclass_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Word x, MR_Word y);
+void mercury__private_builtin____Compare____base_typeclass_info_1_0(
+ MR_Word type_info, MR_Word *result, MR_Word x, MR_Word y);
+
+/*---------------------------------------------------------------------------*/
+
+/*
+** XXX this is a hack to work-around the current lack of
+** support for `pragma export'.
+*/
+void ML_io_print_to_cur_stream(MR_Word ti, MR_Word x);
+void ML_io_print_to_stream(MR_Word ti, MR_Word stream, MR_Word x);
+void ML_report_uncaught_exception(MR_Word ti);
+void ML_throw_io_error(MR_String);
+
+/*---------------------------------------------------------------------------*/
#endif /* not MERCURY_H */
Index: runtime/mercury_init.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_init.h,v
retrieving revision 1.20
diff -u -d -r1.20 mercury_init.h
--- runtime/mercury_init.h 2000/02/08 02:08:05 1.20
+++ runtime/mercury_init.h 2000/05/08 15:06:23
@@ -90,6 +90,10 @@
#include "gc.h"
#endif
+#ifdef MR_HIGHLEVEL_CODE
+ #include "mercury.h"
+#endif
+
/*
** mercury_main() takes the address of the following predicates/functions,
** which are defined elsewhere.
@@ -103,9 +107,6 @@
** in the trace directory, which is allowed to rely on the browser
** directory.
*/
-
-/* in the user's program */
-Declare_entry(mercury__main_2_0);
/* in library/io.h */
extern void mercury_init_io(void);
Index: runtime/mercury_type_info.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_type_info.c,v
retrieving revision 1.37
diff -u -d -r1.37 mercury_type_info.c
--- runtime/mercury_type_info.c 2000/05/08 13:48:45 1.37
+++ runtime/mercury_type_info.c 2000/05/08 14:06:12
@@ -10,8 +10,13 @@
** runtime system.
*/
-#include "mercury_imp.h"
+#include "mercury_conf.h"
+#ifndef MR_HIGHLEVEL_CODE
+ #include "mercury_imp.h"
+#endif
#include "mercury_type_info.h"
+#include "mercury_misc.h" /* for MR_fatal_error() */
+#include "mercury_heap.h" /* for incr_saved_hp() */
/*---------------------------------------------------------------------------*/
Index: runtime/mercury_wrapper.c
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.c,v
retrieving revision 1.59
diff -u -d -r1.59 mercury_wrapper.c
--- runtime/mercury_wrapper.c 2000/04/18 04:59:13 1.59
+++ runtime/mercury_wrapper.c 2000/05/08 15:08:24
@@ -181,8 +181,14 @@
void (*address_of_init_gc)(void);
#endif
+#ifdef MR_HIGHLEVEL_CODE
+void (*program_entry_point)(void);
+ /* normally main_2_p_0 (main/2) */
+#else
Code *program_entry_point;
/* normally mercury__main_2_0 (main/2) */
+#endif
+
void (*MR_library_initializer)(void);
/* normally ML_io_init_state (io__init_state/2)*/
void (*MR_library_finalizer)(void);
@@ -239,7 +245,11 @@
MR_TypeStat *type_stat);
#endif
-Declare_entry(do_interpreter);
+#ifdef MR_HIGHLEVEL_CODE
+ static void do_interpreter(void);
+#else
+ Declare_entry(do_interpreter);
+#endif
/*---------------------------------------------------------------------------*/
@@ -901,9 +911,13 @@
time_at_last_stat = time_at_start;
for (repcounter = 0; repcounter < repeats; repcounter++) {
+#ifdef MR_HIGHLEVEL_CODE
+ do_interpreter();
+#else
debugmsg0("About to call engine\n");
(void) MR_call_engine(ENTRY(do_interpreter), FALSE);
debugmsg0("Returning from MR_call_engine()\n");
+#endif
}
if (use_own_timer) {
@@ -1128,6 +1142,25 @@
} /* end print_register_usage_counts() */
#endif
+#ifdef MR_HIGHLEVEL_CODE
+
+void
+do_interpreter(void)
+{
+ #ifdef PROFILE_TIME
+ if (MR_profiling) MR_prof_turn_on_time_profiling();
+ #endif
+
+ /* call the Mercury predicate main/2 */
+ (*program_entry_point)();
+
+ #ifdef PROFILE_TIME
+ if (MR_profiling) MR_prof_turn_off_time_profiling();
+ #endif
+}
+
+#else /* ! MR_HIGHLEVEL_CODE */
+
Define_extern_entry(do_interpreter);
Declare_label(global_success);
Declare_label(global_fail);
@@ -1213,6 +1246,8 @@
#endif
END_MODULE
+#endif
+
/*---------------------------------------------------------------------------*/
int
@@ -1272,5 +1307,7 @@
/*---------------------------------------------------------------------------*/
void mercury_sys_init_wrapper(void); /* suppress gcc warning */
void mercury_sys_init_wrapper(void) {
+#ifndef MR_HIGHLEVEL_CODE
interpreter_module();
+#endif
}
Index: runtime/mercury_wrapper.h
===================================================================
RCS file: /home/mercury1/repository/mercury/runtime/mercury_wrapper.h,v
retrieving revision 1.31
diff -u -d -r1.31 mercury_wrapper.h
--- runtime/mercury_wrapper.h 2000/04/18 04:59:14 1.31
+++ runtime/mercury_wrapper.h 2000/05/08 15:06:06
@@ -63,7 +63,12 @@
** The address_of_foo pointers are set to the address of
** the corresponding foo.
*/
+
+#ifdef MR_HIGHLEVEL_CODE
+extern void (*program_entry_point)(void); /* normally main_2_p_0 */
+#else
extern Code *program_entry_point; /* normally mercury__main_2_0; */
+#endif
extern void (*MR_library_initializer)(void);
extern void (*MR_library_finalizer)(void);
Index: scripts/c2init.in
===================================================================
RCS file: /home/mercury1/repository/mercury/scripts/c2init.in,v
retrieving revision 1.26
diff -u -d -r1.26 c2init.in
--- scripts/c2init.in 1999/11/09 01:45:41 1.26
+++ scripts/c2init.in 2000/05/08 15:21:07
@@ -25,7 +25,7 @@
# maximum number of calls to put in a single function
maxcalls=40
-defentry=mercury__main_2_0
+defentry_opt=""
init_opt=""
trace_opt=""
library_opt=""
@@ -70,7 +70,7 @@
locate \`.init' files.
-w <label>, --entry-point <label>
Set entry point to <label>.
- (Default value is \`mercury__main_2_0'.)
+ (Default value corresponds to main/2.)
-x, --extra-inits
Search \`.c' files for extra initialization functions.
(This may be necessary if the C files contain
@@ -109,7 +109,7 @@
extra_init_dirs="$extra_init_dirs -I $2"; shift;;
-w|--entry-point)
- defentry="$2"; shift;;
+ defentry_opt="-w$2"; shift;;
-x|--extra-inits)
extra_inits_opt="-x";;
@@ -170,11 +170,11 @@
case $# in
0) exec $MKINIT $aditi_opt -c"$maxcalls" $init_opt $trace_opt \
- $library_opt -w"$defentry" $extra_inits_opt \
+ $library_opt $defentry_opt $extra_inits_opt \
$extra_init_dirs $EXTRA_INIT_FILES $MERCURY_MOD_LIB_MODS
;;
*) exec $MKINIT $aditi_opt -c"$maxcalls" $init_opt $trace_opt \
- $library_opt -w"$defentry" $extra_inits_opt \
+ $library_opt $defentry_opt $extra_inits_opt \
$extra_init_dirs "$@" $EXTRA_INIT_FILES $MERCURY_MOD_LIB_MODS
;;
esac
Index: util/mkinit.c
===================================================================
RCS file: /home/mercury1/repository/mercury/util/mkinit.c,v
retrieving revision 1.62
diff -u -d -r1.62 mkinit.c
--- util/mkinit.c 2000/02/12 15:53:49 1.62
+++ util/mkinit.c 2000/05/08 15:14:10
@@ -47,6 +47,7 @@
/* options and arguments, set by parse_options() */
static const char *entry_point = "mercury__main_2_0";
+static const char *hl_entry_point = "main_2_p_0";
static int maxcalls = MAXCALLS;
static int num_files;
static char **files;
@@ -113,10 +114,14 @@
"\n"
"#define MR_TRACE_ENABLED %d\n"
"\n"
- "Declare_entry(%s);\n"
+ "#ifdef MR_HIGHLEVEL_CODE\n"
+ " extern void %s(void);\n"
+ "#else\n"
+ " Declare_entry(%s);\n"
+ "#endif\n"
"\n"
"#ifdef CONSERVATIVE_GC\n"
- "extern char *GC_stackbottom;\n"
+ " extern char *GC_stackbottom;\n"
"#endif\n"
"\n"
"#if defined(USE_DLLS)\n"
@@ -196,7 +201,11 @@
"#if defined(USE_GCC_NONLOCAL_GOTOS) && !defined(USE_ASM_LABELS)\n"
" do_init_modules();\n"
"#endif\n"
+ "#ifdef MR_HIGHLEVEL_CODE\n"
+ " program_entry_point = %s;\n"
+ "#else\n"
" program_entry_point = ENTRY(%s);\n"
+ "#endif\n"
"\n"
" mercury_runtime_init(argc, argv);\n"
" return;\n"
@@ -367,7 +376,7 @@
break;
case 'w':
- entry_point = optarg;
+ hl_entry_point = entry_point = optarg;
break;
case 'x':
@@ -550,8 +559,8 @@
aditi_load_func = "NULL";
}
- printf(mercury_funcs, need_tracing, entry_point,
- aditi_load_func, entry_point);
+ printf(mercury_funcs, need_tracing, hl_entry_point, entry_point,
+ aditi_load_func, hl_entry_point, entry_point);
if (output_main_func) {
fputs(main_func, stdout);
--
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.
--------------------------------------------------------------------------
mercury-developers mailing list
Post messages to: mercury-developers at cs.mu.oz.au
Administrative Queries: owner-mercury-developers at cs.mu.oz.au
Subscriptions: mercury-developers-request at cs.mu.oz.au
--------------------------------------------------------------------------
More information about the developers
mailing list