[m-dev.] For Review: Bytecode interpreter
Levi Cameron
l.cameron2 at ugrad.unimelb.edu.au
Tue Feb 13 21:03:19 AEDT 2001
Now that all in tests/general (except floats) run happily....
Estimated hours taken: 180
compiler:
Added extra argument to test instruction (string comparisons were
being treated as integer comparisons; properly deals with different
atomic type unifications now)
Changed bytecode stub functions
interpreter:
Cleaned up comments
Forked part of mb_machine to mb_exec
Added test cases to repository
Added support for submodules
Added support for nondet procedures
Added support for cc_xxx procedures
Finished higher order calls
Added (very basic) debug interface
Added support for type information
Added memory corruption checking
Changed machine state dump formatting
Fixed bug in nested switches
Resolved builtin__unify and builtin_compare failures
Now passes all tests/general/* test cases except those with floats
Modified bytecode tags generation so .c & .m tag files are separate
Header usage rationalised
bytecode/Mmakefile
Modified bytecode tags generation so .c & .m tag files are separate
mb_machine split into mb_exec
test file renamed to simple.m (copy over tests/simple??.m to test)
bytecode/TODO
Updated
bytecode/mb_basetypes.h
Removed redundant MB_WORD_BITS (use MR_WORDBITS instead)
bytecode/mb_bytecode.h
bytecode/mpb_bytecode.c
Formatting changes
Third test instruction argument added
bytecode/mb_disasm.h
bytecode/mb_disasm.c
Formatting changes
Third test instruction argument added
Added MB_FMT_INTWIDE
bytecode/mb_exec.h
bytecode/mb_exec.c
bytecode/mb_machine.h
bytecode/mb_machine.c
mb_machine* split into mb_exec* and mb_machine*
Almost all instructions now work (see important changes above)
bytecode/mb_interface.h
bytecode/mb_interface.c
Added nondet stub functions
Added functions to lookup builtin compiler procedures:
do_redo, do_fail, __unify, __compare
Removed old debugging code
Stack layout changed to support nondet procedures
bytecode/mb_interface_stub.c
bytecode/mb_interface_stub.h
Split off bare minimum of includes for bytecode stubs
Added nondet stubs
bytecode/mb_machine_show.c
Made code cleaner (added subfunctions for MB_show_state)
Added variable names to machine state dump
bytecode/mb_mem.h
bytecode/mb_mem.c
Added limited memory corruption checking
bytecode/mb_module.h
bytecode/mb_module.c
Swapped order of temps & vars on stack
Fixed nested switches causing random crashes
Added nested module support
bytecode/test/simple??.m
Various test files - just to check that it doesn't crash
(Most do not output anything & must be verified by stepping through
manually)
compiler/bytecode.m
compiler/bytecode_gen.m
Added extra argument to test instruction (otherwise
string comparisons would be treated as integer comparisons
compiler/code_gen.m
Changed call structure name in bytecode stub to resolve
issues with illegal characters in C structure names
Changed bytecode stub header file name
Levi
l.cameron2 at ugrad.unimelb.edu.au
Index: bytecode/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/Mmakefile,v
retrieving revision 1.16
diff -u -r1.16 Mmakefile
--- bytecode/Mmakefile 2001/02/01 05:20:25 1.16
+++ bytecode/Mmakefile 2001/02/13 09:27:26
@@ -20,6 +20,7 @@
MERCURY_SYSTEM = \
$(RUNTIME_DIR)/*.c $(RUNTIME_DIR)/*.h \
$(RUNTIME_DIR)/machdeps/*.c $(RUNTIME_DIR)/machdeps/*.h\
+ $(LIBRARY_DIR)/*.m \
$(TRACE_DIR)/*.h $(TRACE_DIR)/*.c \
$(BROWSER_DIR)/*.h $(BROWSER_DIR)/*.c \
$(BOEHM_GC_DIR)/*.h $(BOEHM_GC_DIR)/include/*.h
@@ -50,6 +51,7 @@
mb_basetypes.h \
mb_bytecode.h \
mb_disasm.h \
+ mb_exec.h \
mb_interface.h \
mb_machine.h \
mb_machine_def.h \
@@ -63,6 +65,7 @@
MB_CFILES = \
mb_bytecode.c \
mb_disasm.c \
+ mb_exec.c \
mb_interface.c \
mb_interface_stub.c \
mb_machine.c \
@@ -89,9 +92,9 @@
CFILES =
-MFILES = simple01.m
+MFILES = simple.m
-OBJS = simple01_init.o $(MFILES:%.m=%.o) $(CFILES:%.c=%.o)
+OBJS = simple_init.o $(MFILES:%.m=%.o) $(CFILES:%.c=%.o)
$(OBJS): $(HDRS) $(MB_HDRS)
@@ -110,14 +113,18 @@
MLOBJS = $(MB_OBJS)
.PHONY: check
-check: simple01
+check: simple
#-----------------------------------------------------------------------------#
# tags actually depends on $(MERCURY_SYSTEM) too but since changes to that
# hardly ever have an effect, just ignore them
-tags: $(ALL_MFILES) $(ALL_CFILES) $(ALL_HDRS)
- ctags $(TAGFLAGS) $(ALL_MFILES) $(ALL_CFILES) $(ALL_HDRS) $(MERCURY_SYSTEM)
+tags: $(ALL_CFILES) $(ALL_HDRS) tags2
+ ctags $(TAGFLAGS) $(ALL_CFILES) $(ALL_HDRS) $(MERCURY_SYSTEM)
+tags2: $(ALL_MFILES)
+ mtags $(TAGFLAGS) $(ALL_MFILES) $(MERCURY_SYSTEM)
+ mv tags tags2
+
.PHONY: depend
depend: $(ALL_DEPENDS)
@@ -129,7 +136,10 @@
.PHONY: realclean_local
realclean_local:
- rm -f tags test
+ rm -f tags tags2 *.mbc *.bytedebug
+# XXX: The dependencies in mmake ignore .mbc and .bytedebug files
+# so we have to manually delete them. We delete all bytecode files
+# because it will leave submodule files if we don't
#-----------------------------------------------------------------------------#
Index: bytecode/TODO
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/TODO,v
retrieving revision 1.1
diff -u -r1.1 TODO
--- bytecode/TODO 2001/02/01 05:20:25 1.1
+++ bytecode/TODO 2001/02/13 07:23:24
@@ -1,28 +1,29 @@
- -> Get compiler to generate entry stubs for nondet code
- -> Nondet code called from native code
- -> Closely related: calling native code from bytecode
-
+ Todo:
+
+ -> floats
+
+ -> Closure layout structures
+
-> 'complex' constructors (I think 'partially instantiated' was the term
that everybody else was familiar with)
- -> Closures
-
-> Make the bytecode debugger interface nicer (add breakpoints, step,
more user friendly machine state dump etc.)
-> Add variable type information to bytecode debugger
- -> Hash module & predicate names on load rather than linear search
+ -> Rest of the Unary ops (Zoltan said to ignore them for now - I haven't
+ actually even been able to generate mercury code that actually uses
+ the tag ops)
- -> Handle nested modules
+ Efficiency:
+ -> Hash module & predicate names on load rather than linear search
- -> Handle foreign code in mercury gracefully
+ -> Remove do_fail & do_redo switches between native/bytecode when
+ not necessary. (Currently reverts to native code to execute
+ all do_redos & do_fails)
- -> Entry stub generation still generates C code internally; fix this
- (in code_gen.m/generate_proc_code)
-
-> Remove fixed size code limit
-
-> Remove best case 64MB code size limit (worst case is 16MB)
[can easily be upped to 256MB (64MB worst) but beyond that will
suffer a performance penalty -- should check how much this is
@@ -31,14 +32,3 @@
a hash then can store bytecode id/arguments in one contiguous
aray which would be best for performance
- -> Unary ops (Zoltan said to ignore them for now - I haven't actually
- even been able to generate mercury code that actually uses them)
-
-
-Outstanding Issues
- -> Jumps out of C blocks { } with local variables won't leave leaks
- onto the stack?
-
- [ Probably; other mercury code relies on this so it should be ok ]
-
-MR_INTEGER_LENGTH_MODIFIER
Index: bytecode/mb_basetypes.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_basetypes.h,v
retrieving revision 1.1
diff -u -r1.1 mb_basetypes.h
--- bytecode/mb_basetypes.h 2001/02/01 05:20:27 1.1
+++ bytecode/mb_basetypes.h 2001/02/08 04:30:49
@@ -29,8 +29,6 @@
typedef MR_Unsigned
MB_Unsigned;
-#define MB_WORD_BITS MR_WORDBITS
-
typedef MR_Integer
MB_Integer;
Index: bytecode/mb_bytecode.c
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_bytecode.c,v
retrieving revision 1.2
diff -u -r1.2 mb_bytecode.c
--- bytecode/mb_bytecode.c 2001/02/01 05:20:28 1.2
+++ bytecode/mb_bytecode.c 2001/02/13 01:56:09
@@ -7,52 +7,30 @@
*/
/* Imports */
-#include <assert.h>
-#include <limits.h>
-#include <string.h>
-
#include "mb_bytecode.h"
+
+#include <string.h>
#include "mb_mem.h"
#include "mb_module.h"
#include "mb_util.h"
/* Exported definitions */
-
+MB_Bool MB_read_bytecode(FILE *fp, MB_Bytecode *bc_p);
+MB_Bool MB_read_bytecode_version_number(FILE *fp,
+ MB_Short *version_number_p);
/* Local declarations */
-
-/*
-** All read functions return true if successful
-*/
-static MB_Bool
-MB_read_byte(FILE *fp, MB_Byte *byte_p);
-
-static MB_Bool
-MB_read_short(FILE *fp, MB_Short *short_p);
-
-static MB_Bool
-MB_read_int(FILE *fp, MB_Integer *int_p);
-
-static MB_Bool
-MB_read_word(FILE *fp, MB_Word *word_p);
-
-static MB_Bool
-MB_read_float(FILE *fp, MB_Float *float_p);
-
-static MB_Bool
-MB_read_cstring(FILE *fp, MB_CString *str_p);
-
-static MB_Bool
-MB_read_cons_id(FILE *fp, MB_Cons_id *cons_id_p);
-
-static MB_Bool
-MB_read_tag(FILE *fp, MB_Tag *tag_p);
-
-static MB_Bool
-MB_read_var_dir(FILE *fp, MB_Var_dir *var_dir_p);
-
-static MB_Bool
-MB_read_op_arg(FILE *fp, MB_Op_arg *op_arg_p);
+/* All read functions return true if successful */
+static MB_Bool MB_read_byte(FILE *fp, MB_Byte *byte_p);
+static MB_Bool MB_read_short(FILE *fp, MB_Short *short_p);
+static MB_Bool MB_read_int(FILE *fp, MB_Integer *int_p);
+static MB_Bool MB_read_word(FILE *fp, MB_Word *word_p);
+static MB_Bool MB_read_float(FILE *fp, MB_Float *float_p);
+static MB_Bool MB_read_cstring(FILE *fp, MB_CString *str_p);
+static MB_Bool MB_read_cons_id(FILE *fp, MB_Cons_id *cons_id_p);
+static MB_Bool MB_read_tag(FILE *fp, MB_Tag *tag_p);
+static MB_Bool MB_read_var_dir(FILE *fp, MB_Var_dir *var_dir_p);
+static MB_Bool MB_read_op_arg(FILE *fp, MB_Op_arg *op_arg_p);
/* Implementation */
@@ -383,12 +361,15 @@
}
case MB_BC_test: {
MB_Short var1, var2;
+ MB_Byte test_id;
if (MB_read_short(fp, &var1) &&
- MB_read_short(fp, &var2))
+ MB_read_short(fp, &var2) &&
+ MB_read_byte(fp, &test_id))
{
bc_p->opt.test.var1 = var1;
bc_p->opt.test.var2 = var2;
+ bc_p->opt.test.id = test_id;
return TRUE;
} else {
MB_fatal("test read error");
@@ -605,7 +586,8 @@
** it somehow gets executed
*/
bc_p->opt.call.addr.is_native = FALSE;
- bc_p->opt.call.addr.addr.bc = MB_CODE_INVALID_ADR;
+ bc_p->opt.call.addr.addr.bc =
+ MB_CODE_INVALID_ADR;
return TRUE;
} else {
MB_fatal("call read error");
@@ -784,9 +766,7 @@
static MB_Bool
MB_read_int(FILE *fp, MB_Integer *int_p)
{
- /*
- ** c0 is the big end.
- */
+ /* c0 is the big end */
MB_Byte c0, c1, c2, c3, c4, c5, c6, c7;
if (MB_read_byte(fp, &c0) && MB_read_byte(fp, &c1) &&
@@ -1113,12 +1093,21 @@
MB_read_cstring(fp, &type_name) &&
MB_read_byte(fp, &type_arity))
{
+ /* XXX: Should we really do this? */
+ /* If no module, replace with 'builtin' */
+ if (MB_str_cmp(module_id, "") == 0) {
+ MB_str_delete(module_id);
+ module_id = MB_str_dup("builtin");
+ }
+
cons_id_p->opt.base_type_info_const.module_name
= module_id;
cons_id_p->opt.base_type_info_const.type_name =
type_name;
cons_id_p->opt.base_type_info_const.type_arity =
type_arity;
+ cons_id_p->opt.base_type_info_const.type_info =
+ NULL;
return TRUE;
} else {
MB_util_error("Unable to read constructor"
@@ -1158,7 +1147,7 @@
if (!MB_read_byte(fp, &c)) {
MB_util_error("Unable to read tag\n");
- return FALSE; /* not reached */
+ return FALSE;
}
tag_p->id = c;
@@ -1176,9 +1165,7 @@
}
break;
}
- /*
- ** The following two cases behave identically.
- */
+ /* The following two cases behave identically */
case MB_TAG_COMPLICATED:
case MB_TAG_COMPLICATED_CONSTANT:
{
@@ -1212,7 +1199,8 @@
}
case MB_TAG_NONE:
/* XXX: Hmm... What's MB_TAG_NONE for?? */
- return TRUE;
+ /*MB_fatal("Tag TAG_NONE not implemented");*/
+ return TRUE;
break;
default:
MB_util_error("Unknown tag type\n");
Index: bytecode/mb_bytecode.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_bytecode.h,v
retrieving revision 1.2
diff -u -r1.2 mb_bytecode.h
--- bytecode/mb_bytecode.h 2001/02/01 05:20:28 1.2
+++ bytecode/mb_bytecode.h 2001/02/13 06:35:59
@@ -13,12 +13,9 @@
#include <stdio.h>
-#include "mercury_conf.h"
-#include "mercury_types.h"
-#include "mercury_float.h"
+#include "mercury_type_info.h"
#include "mb_basetypes.h"
-#include "mb_stack.h"
#include "mb_util.h"
typedef struct MB_Tag_Struct {
@@ -34,8 +31,8 @@
} MB_Tag;
/*
- * Possible values for Tag.id ...
- */
+** Possible values for Tag.id ...
+*/
#define MB_TAG_SIMPLE 0
#define MB_TAG_COMPLICATED 1
#define MB_TAG_COMPLICATED_CONSTANT 2
@@ -45,8 +42,8 @@
typedef MB_Byte
MB_Determinism;
/*
- * Possible values for Determinism ...
- */
+** Possible values for Determinism ...
+*/
#define MB_DET_DET 0
#define MB_DET_SEMIDET 1
#define MB_DET_MULTIDET 2
@@ -88,8 +85,8 @@
} MB_Op_arg;
/*
- * Possible values for Op_arg.id
- */
+** Possible values for Op_arg.id
+*/
#define MB_ARG_VAR 0
#define MB_ARG_INT_CONST 1
#define MB_ARG_FLOAT_CONST 2
@@ -104,8 +101,8 @@
} MB_Var_dir;
/*
- * Possible values for Direction ...
- */
+** Possible values for Direction ...
+*/
#define MB_DIR_TO_ARG 0
#define MB_DIR_TO_VAR 1
#define MB_DIR_TO_NONE 2
@@ -129,7 +126,7 @@
MB_Short arity;
MB_Tag tag;
} cons;
- MB_Integer int_const;
+ MB_Integer int_const;
MB_CString string_const;
MB_Float float_const;
struct {
@@ -138,8 +135,8 @@
MB_Short arity;
MB_Bool is_func;
MB_Byte mode_num;
- /* Actual call address */
- MB_Code_Addr addr;
+ /* Cached call address (may be NULL) */
+ MB_Native_Addr native_addr;
} pred_const;
struct {
MB_CString module_name;
@@ -151,6 +148,8 @@
MB_CString module_name;
MB_CString type_name;
MB_Byte type_arity;
+ /* Cached type info address (may be NULL) */
+ MR_TypeCtorInfo type_info;
} base_type_info_const;
struct {
MB_Byte ch;
@@ -159,8 +158,8 @@
} MB_Cons_id;
/*
- * Possible values for Cons_id.id ...
- */
+** Possible values for Cons_id.id ...
+*/
#define MB_CONSID_CONS 0
#define MB_CONSID_INT_CONST 1
#define MB_CONSID_STRING_CONST 2
@@ -171,6 +170,17 @@
#define MB_CONSID_CHAR_CONST 7
/*
+** Possible values for Test_id
+*/
+typedef MB_Byte MB_Test_id;
+
+#define MB_TESTID_INT 0
+#define MB_TESTID_CHAR 1
+#define MB_TESTID_STRING 2
+#define MB_TESTID_FLOAT 3
+#define MB_TESTID_ENUM 4
+
+/*
** Internal label structure. At load time the index is read from the file
** and stored. translate_labels translates indexes into actual memory
** addresses. The module load and label translation functions are the only
@@ -312,6 +322,7 @@
struct {
MB_Short var1;
MB_Short var2;
+ MB_Test_id id;
} test;
struct {
Index: bytecode/mb_disasm.c
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_disasm.c,v
retrieving revision 1.2
diff -u -r1.2 mb_disasm.c
--- bytecode/mb_disasm.c 2001/02/01 05:20:28 1.2
+++ bytecode/mb_disasm.c 2001/02/13 06:36:20
@@ -9,21 +9,15 @@
*/
/* Imports */
-#include <assert.h>
-#include <ctype.h>
-#include <string.h>
-#include <stdio.h>
-
#include "mb_disasm.h"
-#include "mb_module.h"
-#include "mb_util.h"
-#include "mb_machine_def.h"
+#include <string.h>
+#include "mb_module.h"
/* Exported definitions */
-int MB_str_bytecode(MB_Machine_State *ms, MB_Bytecode_Addr addr,
- char *buffer, int buffer_len, int indent_level);
+int MB_str_bytecode(MB_Bytecode_Addr addr, char *buffer, int buffer_len,
+ int indent_level);
void MB_listing(MB_Machine_State *ms, FILE *fp, MB_Bytecode_Addr start,
MB_Bytecode_Addr end, MB_Word line_len);
@@ -39,6 +33,9 @@
/* Returns a string corresponding to the name of a bytecode type */
static MB_CString_Const str_bytecode_name(MB_Byte bytecode_id);
+/* Returns a string corresponding to the name of a test type */
+static MB_CString_Const str_test_id(MB_Test_id test_id);
+
/* Returns a string corresponding to the name of a determinism type */
static MB_CString_Const str_determinism_name(MB_Byte determinism_id);
@@ -63,50 +60,49 @@
/*
** Macros for printing:
-** Expects buffer, buffer_len & last_len to be defined.
+** Expects buffer & buffer_len to be defined.
** Wraps calls to snprintf, checks if the buffer is full and
** if it is, returns from the function
*/
-#define PRINT() if (buffer_len > 1) { \
- int last_len; \
- assert(buffer_len > 0); \
+#define PRINT() if (buffer_len > 1) { \
+ int last_len; \
+ assert(buffer_len > 0); \
last_len = snprintf(buffer, buffer_len,
/* printf arguments get sandwiched between these macros */
-#define ENDPRINT() ); \
- if (last_len >= buffer_len) {\
- last_len = buffer_len-1; \
- } \
- buffer += last_len; \
- buffer_len -= last_len; \
- assert(buffer_len > 0); \
- } else { \
- assert(buffer_len >= 0); \
- if (buffer_len == 0) { \
- buffer--; \
- buffer_len++; \
+#define ENDPRINT() ); \
+ if (last_len >= buffer_len) { \
+ last_len = buffer_len-1;\
} \
+ buffer += last_len; \
+ buffer_len -= last_len; \
+ assert(buffer_len > 0); \
+ } else { \
+ assert(buffer_len >= 0); \
+ if (buffer_len == 0) { \
+ buffer--; \
+ buffer_len++; \
+ } \
}
-
/*
** Call this after calling a function that has added characters to the buffer
-** Requires that if the function filled the buffer, it must have at least
-** put a null terminator at the end
+** Requires that if the function filled the buffer, it must have put a null
+** terminator at the end
*/
-#define PRINTFILLCHECK() { \
+#define PRINTFILLCHECK() { \
int str_len = strlen(buffer); \
buffer += str_len; \
buffer_len -= str_len; \
- assert(buffer_len > 0); \
+ assert(buffer_len > 0); \
}
/*
** Macro to call a function of the format f(arg, buffer, buffer_len)
** where the function fills all or part of the buffer
*/
-#define PRINTCALL(x, y) (x)((y), buffer, buffer_len); \
+#define PRINTCALL(x, y) (x)((y), buffer, buffer_len); \
PRINTFILLCHECK()
/*
@@ -121,7 +117,7 @@
*/
int
-MB_str_bytecode(MB_Machine_State *ms, MB_Bytecode_Addr addr, char *buffer,
+MB_str_bytecode(MB_Bytecode_Addr addr, char *buffer,
int buffer_len, int indent_level)
{
MB_Byte bc_id = MB_code_get_id(addr);
@@ -192,20 +188,10 @@
/* if we only wanted to calculate the indents, return now */
if (buffer == NULL || buffer_len <= 0) return next_indent;
-
- /* indicate det/nondet code */
- /*
- PRINT()
- "%c",
- (MB_code_get_det(addr) ? '+' : '-')
- ENDPRINT()
- */
-
-
/* print the indents */
while (this_indent > 0) {
PRINT()
- " "
+ " "
ENDPRINT()
this_indent--;
}
@@ -409,9 +395,10 @@
case MB_BC_test:
PRINT()
- " [var %d] == [var %d]",
+ " [var %d] == [var %d] [type %s]",
(int) bca->test.var1,
- (int) bca->test.var2
+ (int) bca->test.var2,
+ str_test_id(bca->test.id)
ENDPRINT()
break;
@@ -490,7 +477,9 @@
len = bca->complex_construct.list_length;
PRINT()
- " %d", (int) len
+ " [%d var%s]",
+ (int) len,
+ (len == 1) ? "" : "s"
ENDPRINT()
for (i = 0; i < len; i++) {
@@ -516,8 +505,9 @@
len = bca->complex_deconstruct.list_length;
PRINT()
- " %d",
- (int) len
+ " [%d var%s]",
+ (int) len,
+ (len == 1) ? "" : "s"
ENDPRINT()
for (i = 0; i < len; i++) {
@@ -597,10 +587,10 @@
str_unop_name(bca->builtin_unop.unop)
ENDPRINT()
- PRINTCALL(str_op_arg,bca->builtin_unop.arg)
+ PRINTCALL(str_op_arg, bca->builtin_unop.arg)
PRINT()
- " %d",
+ " => [var %d]",
(int) bca->builtin_unop.to_var
ENDPRINT()
break;
@@ -663,7 +653,7 @@
return next_indent;
-} /* end print_bytecode() */
+} /* end str_bytecode() */
static void
str_cons_id(MB_Cons_id cons_id, char *buffer, int buffer_len)
@@ -712,13 +702,8 @@
cons_id.opt.pred_const.pred_name,
(int) cons_id.opt.pred_const.arity,
(int) cons_id.opt.pred_const.mode_num,
- cons_id.opt.pred_const.addr.is_native
- ? "natv" : "byte",
- cons_id.opt.pred_const.addr.is_native
- ? (MB_Word *) cons_id.opt.pred_const
- .addr.addr.native
- : (MB_Word *) cons_id.opt.pred_const
- .addr.addr.bc
+ "natv",
+ (MB_Word *) cons_id.opt.pred_const.native_addr
ENDPRINT()
break;
case MB_CONSID_CODE_ADDR_CONST:
@@ -766,7 +751,7 @@
ENDPRINT()
buffer[buffer_len-1] = 0; /* snprintf may not do it if a long string */
-} /* end print_cons_id() */
+} /* end str_cons_id() */
static void
str_tag(MB_Tag tag, char *buffer, int buffer_len)
@@ -812,7 +797,7 @@
/* snprintf may not append a null character */
buffer[buffer_len-1] = 0;
-} /* end print_tag() */
+} /* end str_tag() */
/*
** XXX ORDER: Currently we depend on the order of elements in the table.
@@ -877,6 +862,29 @@
** XXX ORDER: Currently we depend on the order of elements in the table.
*/
static const char *
+test_id_table[] = {
+ "int",
+ "char",
+ "string",
+ "float",
+ "user"
+};
+
+/* Returns a string corresponding to the name of a test type */
+static MB_CString_Const
+str_test_id(MB_Test_id test_id)
+{
+ if (test_id >= sizeof(test_id_table) / sizeof(*test_id_table)) {
+ return "<<unknown test type";
+ } else {
+ return (MB_CString_Const) test_id_table[test_id];
+ }
+}
+
+/*
+** XXX ORDER: Currently we depend on the order of elements in the table.
+*/
+static const char *
determinism_table[] = {
"det",
"semidet",
@@ -893,7 +901,7 @@
str_determinism_name(MB_Byte determinism_id)
{
if (determinism_id >=
- sizeof(determinism_table) / sizeof(*determinism_table))
+ sizeof(determinism_table) / sizeof(*determinism_table))
{
return (MB_CString_Const) "<<unknown determinism>>"; /* XXX */
} else {
@@ -972,7 +980,7 @@
"float_le",
"float_ge",
"body"
-};
+}; /* end binop_table */
static MB_CString_Const
str_binop_name(MB_Byte binop)
@@ -1058,12 +1066,6 @@
break;
case MB_ARG_INT_CONST:
PRINT()
- /*
- ** XXX: int_const has type Integer which could
- ** be int, long or long long. Correct solution
- ** is to define a format string in conf.h, but
- ** for now assume long is enough
- */
"[int " MB_FMT_INT " (" MB_FMT_HEX ")]",
op_arg.opt.int_const,
op_arg.opt.int_const
@@ -1082,19 +1084,17 @@
} /* end str_op_arg() */
/*
-** displays a code listing from address start to end
+** Displays a code listing from address start to end
+** ms may be NULL if desired
*/
-
void
-MB_listing(MB_Machine_State *ms, FILE *fp, MB_Bytecode_Addr start,
MB_Bytecode_Addr end,
- MB_Word line_len)
+MB_listing(MB_Machine_State *ms, FILE *fp, MB_Bytecode_Addr start,
+ MB_Bytecode_Addr end, MB_Word line_len)
{
- char buffer[256];
+ char buffer[256];
+ MB_Word indent = 0;
MB_Bytecode_Addr i;
- MB_Word indent = 0;
- MB_Bytecode_Addr ip = MB_ip_get(ms);
-
- MB_SAY("linelen: %d\n", line_len);
+ MB_Bytecode_Addr ip = (ms != NULL) ? MB_ip_get(ms) : NULL;
start = MB_code_range_clamp(start);
end = MB_code_range_clamp(end);
@@ -1110,16 +1110,14 @@
if (i != MB_CODE_INVALID_ADR) {
/* work out the indent level at the start */
while (i != start) {
- indent = MB_str_bytecode(ms,
- i, NULL, 0, indent);
+ indent = MB_str_bytecode(i, NULL, 0, indent);
i++;
}
}
/* Show the code */
for (; i != end+1; i++) {
- indent = MB_str_bytecode(ms, i,
- buffer, line_len, indent);
+ indent = MB_str_bytecode(i, buffer, line_len, indent);
fprintf(fp, "%s%p %s\n",
(i == ip) ? "-> " : " ",
i,
Index: bytecode/mb_disasm.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_disasm.h,v
retrieving revision 1.2
diff -u -r1.2 mb_disasm.h
--- bytecode/mb_disasm.h 2001/02/01 05:20:28 1.2
+++ bytecode/mb_disasm.h 2001/02/08 04:30:49
@@ -10,25 +10,27 @@
#define MB_DISASM_H
#include <stdio.h>
-
-#include "mb_bytecode.h"
+#include "mb_basetypes.h"
#include "mb_machine.h"
-#include "mb_module.h"
/*
** Fills a string buffer with the name of a bytecode (if buffer_len > 0)
** Returns the new indent level after the instruction
*/
-int MB_str_bytecode(MB_Machine_State *module, MB_Bytecode_Addr addr, char
*buffer,
- int buffer_len, int indent_level);
+int MB_str_bytecode(MB_Bytecode_Addr addr, char *buffer, int buffer_len,
+ int indent_level);
-/* displays a code listing (see source file for argument description) */
-void MB_listing(MB_Machine_State *ms, FILE *fp, MB_Bytecode_Addr start,
- MB_Bytecode_Addr end, MB_Word line_len);
+/*
+** Displays a code listing (see source file for argument description)
+** ms may be NULL if desired (you just won't get a little -> at the current ip)
+*/
+void MB_listing(MB_Machine_State *ms, FILE *fp, MB_Bytecode_Addr start,
+ MB_Bytecode_Addr end, MB_Word line_len);
/* XXX: width fields below may not be correct for all platforms */
/* printf Format string specifiers */
-#define MB_FMT_INT "% 11" MR_INTEGER_LENGTH_MODIFIER "d"
+#define MB_FMT_INT "%" MR_INTEGER_LENGTH_MODIFIER "d"
+#define MB_FMT_INTWIDE "% 11" MR_INTEGER_LENGTH_MODIFIER "d"
#define MB_FMT_HEX "0x%08" MR_INTEGER_LENGTH_MODIFIER "x"
/* XXX: No string for 'MB_Short's. For now promote to int and use %d */
Index: bytecode/mb_exec.c
===================================================================
RCS file: mb_exec.c
diff -N mb_exec.c
--- /dev/null Thu Mar 30 14:06:13 2000
+++ mb_exec.c Tue Feb 13 20:16:34 2001
@@ -0,0 +1,1640 @@
+/*
+** Copyright (C) 2000-2001 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.
+**
+*/
+
+/* Imports */
+#include "mercury_imp.h"
+#include "mercury_ho_call.h"
+
+#include "mb_exec.h"
+
+#include <assert.h>
+#include <stdio.h>
+#include <string.h>
+#include "mb_interface.h"
+#include "mb_mem.h"
+#include "mb_machine_show.h"
+#include "mb_module.h"
+
+/* Exported definitions */
+MB_Native_Addr MB_machine_exec(MB_Bytecode_Addr new_ip,
+ MB_Word *initial_stack);
+
+/* Local declarations */
+
+/* Set new stack vars to this help find bugs */
+#define CLOBBERED 0xbadbad00
+
+#define CLOBBERPICKUPS 0 /* clobber reg after pickup */
+#define CLOBBERPLACES 0 /* clobber slot after place */
+#define CLOBBERSTACK 1 /* reset new stack vars */
+
+static MB_Bool dispatch(MB_Byte bc_id, MB_Machine_State *ms);
+
+static void instr_do_redo (MB_Machine_State*ms, MB_Bytecode_Arg*bca);
+static void instr_do_fail (MB_Machine_State*ms, MB_Bytecode_Arg*bca);
+
+static void instr_invalid (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_enter_proc (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_endof_proc (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_enter_disjunction (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_endof_disjunction (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_enter_disjunct (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_endof_disjunct (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_enter_switch (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_enter_switch_arm (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_endof_switch_arm (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_endof_switch (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_enter_if (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_enter_then (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_endof_then (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+/* instr_enter_else is identical to enter_then */
+static void instr_endof_if (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_enter_negation (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_endof_negation_goal (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_endof_negation (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_enter_commit (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_endof_commit (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_assign (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_test (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_construct (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_deconstruct (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_place (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_pickup (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_call (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_higher_order_call (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_builtin_binop (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_builtin_bintest (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_builtin_unop (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_builtin_untest (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_semidet_success (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_semidet_success_check (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_do_redo (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_do_fail (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_noop (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+static void instr_notdone (MB_Machine_State *ms,
+ MB_Bytecode_Arg *bca);
+
+/* return true if a construction succeeds */
+static MB_Word do_construct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
+ MB_Word list_length, MB_Short *var_list);
+
+/* return true if a deconstruction succeeds */
+static MB_Bool do_deconstruct(MB_Machine_State *ms, const MB_Cons_id *cid,
+ MB_Word var, MB_Word list_length, MB_Short *var_list);
+static MB_Bool do_deconstruct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
+ MB_Word val, MB_Word list_length, MB_Short *var_list);
+
+/* Calls a native code procedure and sets up reentry variables */
+static void call_native_proc(MB_Machine_State *ms,
+ MB_Native_Addr native_addr,
+ MB_Bytecode_Addr return_ip);
+
+typedef void (*MB_Instruction_Handler) (MB_Machine_State *, MB_Bytecode_Arg *);
+
+/* XXX ORDER: relies on the order of the definitions */
+static MB_Instruction_Handler instruction_table[] = {
+ instr_invalid, /* enter_pred */
+ instr_invalid, /* endof_pred */
+ instr_enter_proc,
+ instr_endof_proc,
+ instr_noop, /* label */
+ instr_enter_disjunction,
+ instr_endof_disjunction,
+ instr_enter_disjunct,
+ instr_endof_disjunct,
+ instr_enter_switch,
+ instr_endof_switch,
+ instr_enter_switch_arm,
+ instr_endof_switch_arm,
+ instr_enter_if,
+ instr_enter_then,
+ instr_endof_then,
+ instr_endof_if,
+ instr_enter_negation,
+ instr_endof_negation,
+ instr_enter_commit,
+ instr_endof_commit,
+ instr_assign,
+ instr_test,
+ instr_construct,
+ instr_deconstruct,
+ instr_notdone, /* XXX complex construct */
+ instr_notdone, /* XXX complex deconstruct */
+ instr_place,
+ instr_pickup,
+ instr_call,
+ instr_higher_order_call,
+ instr_builtin_binop,
+ instr_builtin_unop, /* XXX unop */
+ instr_builtin_bintest,
+ instr_builtin_untest, /* XXX unop test */
+ instr_semidet_success,
+ instr_semidet_success_check,
+ instr_do_redo, /* fail */
+ instr_noop, /* context */
+ instr_notdone, /* not supported */
+ instr_enter_then, /* enter_else (identical to enter_then) */
+ instr_endof_negation_goal
+};
+
+static void
+instr_invalid(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ MB_fatal("Invalid instruction encountered");
+}
+
+
+/* Enter/exit procedure */
+static void
+instr_enter_proc(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ switch (bca->enter_proc.det) {
+ case MB_DET_FAILURE:
+ case MB_DET_SEMIDET:
+ case MB_DET_CC_NONDET:
+ case MB_DET_DET:
+ case MB_DET_CC_MULTIDET: {
+ MB_Word detframe_size =
+ bca->enter_proc.temp_count +
+ bca->enter_proc.list_length +
+ MB_DETFRAME_SIZE;
+
+ /*
+ ** Save the initial stack frame if this function is
+ ** going to be the one that returns to native code
+ */
+ if (MB_initialstackframe_get(ms) == NULL) {
+ MB_initialstackframe_set(ms, MB_sp);
+ }
+
+ MB_incr_sp(detframe_size);
+
+ /* save succip */
+ MB_stackitem(MB_DETFRAME_SUCCIP) = (MB_Word) MB_succip;
+
+ MB_ip_set(ms, MB_ip_get(ms) + 1);
+
+ break;
+ }
+ case MB_DET_MULTIDET:
+ case MB_DET_NONDET: {
+
+ MB_Word *prevfr = MB_maxfr;
+ MB_Word *succfr = MB_curfr;
+
+ if (MB_initialstackframe_get(ms) == NULL) {
+ MB_initialstackframe_set(ms, MB_maxfr);
+ }
+
+ MB_maxfr += MB_FRAME_NORMAL_SIZE
+ + bca->enter_proc.list_length
+ + bca->enter_proc.temp_count;
+
+ MB_curfr = MB_maxfr;
+
+ MB_fr_prevfr(MB_curfr) = prevfr;
+ MB_fr_redoip(MB_curfr) = (MB_Word)
+ MB_native_get_do_fail();
+ MB_fr_redofr(MB_curfr) = (MB_Word) MB_maxfr;
+ MB_fr_succip(MB_curfr) = (MB_Word) MB_succip;
+ MB_fr_succfr(MB_curfr) = succfr;
+ /*
+ ** bcretip is set just before a procedure call so that
+ ** bytecode_return_nondet knows where in the bytecode to
+ ** jump to. Set to NULL for now to catch errors.
+ */
+ MB_fr_bcretip(MB_curfr) = (MB_Word) NULL;
+ MB_fr_bcinitfr(MB_curfr) = (MB_Word)
+ MB_initialstackframe_get(ms);
+
+ MB_ip_set(ms, MB_ip_get(ms) + 1);
+
+ break;
+ }
+ /* XXX Other options */
+ default:
+ MB_fatal("enter_proc det type not implemented");
+ }
+
+ /* set procedure detism info & variable stack pointer */
+ MB_proc_var_init(ms);
+
+ #if CLOBBERSTACK
+ {
+ MB_Word i;
+ MB_Word count = bca->enter_proc.list_length +
+ bca->enter_proc.temp_count;
+ for (i = 0; i < count; i++) {
+ MB_var_set(ms, i, CLOBBERED + i);
+ }
+ }
+ #endif
+
+ if (MB_model_semi(bca->enter_proc.det)) {
+ /*
+ ** If a semidet procedure then mark our success slot as failure
+ ** until we know otherwise.
+ */
+ MB_stackitem(MB_DETFRAME_SEMIDET_SUCCESS) = MB_SEMIDET_FAILURE;
+
+ /* Also push a failure context in case fail is encountered */
+ MB_frame_temp_push(ms, bca->enter_proc.end_label.addr);
+ }
+}
+
+static void
+instr_endof_proc(MB_Machine_State *ms, MB_Bytecode_Arg *endof_bca)
+{
+ /* get the current proc */
+ MB_Bytecode_Arg *bca =
+ MB_code_get_arg(endof_bca->endof_proc.proc_start);
+
+ switch (bca->enter_proc.det) {
+ case MB_DET_FAILURE:
+ case MB_DET_CC_NONDET:
+ case MB_DET_SEMIDET:
+ /* put the success indicator into a register */
+ MB_reg(MB_SEMIDET_SUCCESS_REG) =
+ MB_stackitem(MB_DETFRAME_SEMIDET_SUCCESS);
+
+ /* remove the failure context */
+ MB_maxfr = MB_fr_prevfr(MB_maxfr);
+ case MB_DET_CC_MULTIDET:
+ case MB_DET_DET: {
+ MB_Word detframe_size =
+ bca->enter_proc.temp_count +
+ bca->enter_proc.list_length +
+ MB_DETFRAME_SIZE;
+
+ MB_succip = MB_stackitem(MB_DETFRAME_SUCCIP);
+
+ /* deallocate stack variables */
+ MB_decr_sp(detframe_size);
+
+ /* Check whether we should return to native code */
+ if (MB_sp == MB_initialstackframe_get(ms)) {
+ MB_native_return_set(ms, MB_succip);
+ } else {
+ MB_ip_set(ms, MB_succip);
+ }
+ break;
+ }
+
+ case MB_DET_MULTIDET:
+ case MB_DET_NONDET: {
+ /* We don't deallocate the stack */
+
+ MB_Word *old_curfr = MB_curfr;
+ /* Restore succip */
+ MB_succip = MB_fr_succip(MB_curfr);
+
+ /* Restore curfr */
+ MB_curfr = MB_fr_succfr(MB_curfr);
+
+ /* Check whether we should return to native code */
+ if (MB_fr_prevfr(old_curfr) ==
+ MB_initialstackframe_get(ms))
+ {
+ MB_native_return_set(ms, MB_succip);
+ } else {
+ MB_ip_set(ms, MB_succip);
+ }
+
+ break;
+ }
+ /* XXX other options */
+ default:
+ MB_fatal("endof_proc det type not implemented");
+ }
+
+ MB_proc_var_init(ms);
+}
+
+static void
+instr_enter_disjunction(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* push a new temp frame */
+ MB_frame_temp_push(ms, MB_CODE_INVALID_ADR);
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_enter_disjunct(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /*
+ ** set the redo point of the topmost frame (pushed in
+ ** enter_disjunction) to the disjunct after the current one
+ **
+ ** if this is the last disjunct, then remove the top frame instead
+ */
+ if (bca->enter_disjunct.next_label.addr == MB_CODE_INVALID_ADR) {
+ /* remove the top frame */
+ /* XXX TESTING */
+ MB_maxfr = MB_fr_prevfr(MB_maxfr);
+ } else {
+ /* set a new redoip */
+
+ /*
+ ** We know it is a frame from bytecode, but was it a temp nondet
+ ** frame from a det or nondet proc?
+ */
+
+ assert(MB_FRAME_TEMP_DET_SIZE != MB_FRAME_TEMP_NONDET_SIZE);
+
+ if (MB_frame_size(MB_maxfr) == MB_FRAME_TEMP_DET_SIZE) {
+ MB_fr_temp_det_bcredoip(MB_maxfr)
+ = (MB_Word) bca->enter_disjunct.next_label.addr;
+ } else {
+ MB_fr_temp_nondet_bcredoip(MB_maxfr)
+ = (MB_Word) bca->enter_disjunct.next_label.addr;
+ }
+ }
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_endof_disjunct(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /*
+ ** a simple jump to the end of the disjunction
+ ** if we are coming from a nonlast disjunct then we will
+ ** be leaving one or more nondet stack frames so we can backtrack
+ ** into the disjunction if we fail later on
+ */
+ MB_ip_set(ms, bca->endof_disjunct.end_label.addr);
+}
+
+static void
+instr_endof_disjunction(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /*
+ ** do nothing
+ */
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_enter_switch(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_enter_switch_arm(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* Check if this deconstruct is going to succeed */
+ if (do_deconstruct(ms, &bca->enter_switch_arm.cons_id,
+ bca->enter_switch_arm.var, 0, 0))
+ {
+ /*
+ ** If it does succeed, then step into the switch
+ */
+ instr_noop(ms, NULL);
+
+ } else {
+ /*
+ ** If it fails, go to the next switch arm
+ */
+ MB_ip_set(ms, bca->enter_switch_arm.next_label.addr);
+ }
+}
+
+static void
+instr_endof_switch_arm(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* This switch arm has succeeded, now go to the end of the switch */
+ MB_ip_set(ms, bca->endof_switch_arm.end_label.addr);
+}
+
+static void
+instr_endof_switch(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /*
+ ** If we get here, no switch arm matched, so trigger a redo
+ */
+ instr_do_redo(ms, NULL);
+}
+
+static void
+instr_enter_if(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /*
+ ** push a failure context and save the frame address in a
+ ** temp stack slot
+ */
+ MB_frame_temp_push(ms, bca->enter_if.else_label.addr);
+ MB_var_set(ms, bca->enter_if.frame_ptr_tmp, (MB_Word) MB_maxfr);
+
+ instr_noop(ms, NULL);
+}
+
+/* enter_else is identical to enter_then */
+/*
+instr_enter_else()
+*/
+static void
+instr_enter_then(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ MB_Word *tempfr = (MB_Word *)
+ MB_var_get(ms, bca->enter_then.frame_ptr_tmp);
+
+ /* If the frame is on top, can we pop it */
+ if (MB_maxfr == tempfr) {
+ MB_maxfr = MB_fr_prevfr(MB_maxfr);
+ } else {
+ /* otherwise replace redoip with do_fail, effectively
+ * discarding it when the stack gets unwound */
+ MB_fr_redoip(tempfr) = (MB_Word) MB_native_get_do_fail();
+ }
+
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_endof_then(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* Jump to the end of the construct */
+ MB_ip_set(ms, bca->endof_then.follow_label.addr);
+}
+
+static void
+instr_endof_if(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* Do nothing */
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_enter_negation(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /*
+ ** Push a fail context: If the negation fails we want it
+ ** to drop through to the end of the negation and succeed
+ */
+ MB_var_set(ms, bca->enter_negation.frame_ptr_tmp, (MB_Word) MB_maxfr);
+ MB_frame_temp_push(ms, bca->enter_negation.end_label.addr);
+
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_endof_negation_goal(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /*
+ ** The negation has succeeded. Now we want to indicate failure.
+ ** Rewind the stack back to before the negation and issue a redo
+ */
+
+ MB_maxfr = MB_var_get(ms, bca->endof_negation_goal.frame_ptr_tmp);
+
+ instr_do_redo(ms, NULL);
+}
+
+static void
+instr_endof_negation(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /*
+ ** The negation failed.
+ ** Remove the temp frame which will be at the top and continue
+ */
+ MB_maxfr = MB_fr_prevfr(MB_maxfr);
+
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_enter_commit(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* push a new stack frame & save its location in a temp stack slot */
+ MB_frame_temp_push_do_fail(ms);
+ MB_var_set(ms, bca->enter_commit.frame_ptr_tmp, (MB_Word) MB_maxfr);
+
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_endof_commit(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* Unwind the stack back to where it was before the commit */
+ MB_maxfr = MB_var_get(ms, bca->endof_commit.frame_ptr_tmp);
+
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_assign(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* copy variable from one slot to another */
+ MB_var_set(ms, bca->assign.to_var,
+ MB_var_get(ms, bca->assign.from_var));
+
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_test(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ int result;
+
+ /* test the equality of two variable slots */
+ switch (bca->test.id) {
+ case MB_TESTID_INT:
+ case MB_TESTID_CHAR:
+ case MB_TESTID_ENUM:
+ result =
+ MB_var_get(ms, bca->test.var1)
+ == MB_var_get(ms, bca->test.var2);
+ break;
+ case MB_TESTID_STRING:
+ result = !strcmp(MB_var_get(ms, bca->test.var1),
+ MB_var_get(ms, bca->test.var2));
+ break;
+ case MB_TESTID_FLOAT:
+ MB_fatal("Float testing not supported");
+ default:
+ MB_fatal("Unexpected test type");
+ }
+
+ if (result) {
+ instr_noop(ms, NULL);
+ } else {
+ instr_do_redo(ms, NULL);
+ }
+}
+
+static MB_Word
+do_construct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
+ MB_Word list_length, MB_Short *var_list)
+{
+ const MB_Tag *cons_tag = &cid->opt.cons.tag;
+ MB_Word *val = MB_mkword(
+ MB_mktag(cons_tag->opt.pair.primary),
+ MB_mkbody((MB_Word) NULL));
+
+ /* the final value we will put in the reg */
+
+ assert(cid->id == MB_CONSID_CONS);
+
+ /*
+ ** XXX: If list_length can be anything, then what is the use of
+ ** the arity field for functors??
+ */
+ /* assert(list_length != 0); */
+
+ switch (cons_tag->id) {
+ case MB_TAG_SIMPLE: /* only need a primary tag */
+ case MB_TAG_COMPLICATED:/* need primary + remote 2ndary tag */
+ {
+ /*
+ ** The code for these two is virtually identical except
+ ** that if it is tag_complicated we need one extra heap
+ ** slot for the remote secondary tag
+ */
+ MB_Word extra = (cons_tag->id == MB_TAG_COMPLICATED)
+ ? 1 : 0;
+ MB_Word *heap_data;
+
+ if (list_length + extra != 0) {
+ MB_Unsigned i;
+
+ /* allocate heap memory */
+ heap_data = (MB_Word *) MB_GC_NEW_ARRAY(
+ MB_Word, list_length + extra);
+
+ /* ensure tag bits aren't used */
+ assert(MB_tag((MB_Word) heap_data) == 0);
+
+ /* copy variables to allocated heap block */
+ for (i = 0; i < list_length; i++) {
+ heap_data[i + extra] =
+ MB_var_get(ms, var_list[i]);
+ }
+ } else {
+ heap_data = NULL;
+ }
+
+ /*
+ ** copy the secondary tag if we need to
+ ** and combine the pointer & tag
+ */
+ if (cons_tag->id == MB_TAG_COMPLICATED_CONSTANT) {
+ heap_data[0] = cons_tag->opt.pair.secondary;
+ val = MB_mkword(
+ MB_mktag(cons_tag->opt.pair.primary),
+ MB_body((MB_Word) heap_data,
+ MB_mktag(0)));
+ } else {
+ val = MB_mkword(
+ MB_mktag(cons_tag->opt.primary),
+ MB_body((MB_Word) heap_data,
+ MB_mktag(0)));
+ }
+
+ break;
+ }
+
+ case MB_TAG_COMPLICATED_CONSTANT:
+ /* primary + local secondary tag */
+ assert(list_length == 0);
+ val = MB_mkword(
+ MB_mktag(cons_tag->opt.pair.primary),
+ MB_mkbody(cons_tag->opt.pair.secondary));
+
+ break;
+
+ case MB_TAG_ENUM:
+ /* Simple tag with no body */
+ assert(list_length == 0);
+ val = MB_mkword(MB_mktag(cons_tag->opt.enum_tag),
+ MB_mkbody(0));
+ break;
+
+ case MB_TAG_NONE:
+ assert(list_length == 1);
+ val = (MB_Word *) MB_var_get(ms, var_list[0]);
+ break;
+ MB_fatal("tag_none not done");
+ default:
+ MB_fatal("Unknown tag type in construct");
+ }
+ return (MB_Word) val;
+}
+
+static void
+instr_construct(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ MB_Word val;
+ /* construct a variable into a slot */
+ switch (bca->construct.consid.id) {
+ case MB_CONSID_INT_CONST:
+ assert(bca->construct.list_length == 0);
+ val = bca->construct.consid.opt.int_const;
+ break;
+
+ case MB_CONSID_STRING_CONST:
+ assert(bca->construct.list_length == 0);
+ val = (MB_Word) bca->construct.consid.opt.string_const;
+ break;
+
+ case MB_CONSID_CONS:
+ val = do_construct_cons(ms,
+ &bca->construct.consid,
+ bca->construct.list_length,
+ bca->construct.var_list);
+ break;
+
+ case MB_CONSID_FLOAT_CONST:
+ MB_fatal("Construct float not implemented");
+
+ case MB_CONSID_PRED_CONST: {
+ /* XXX Closure layouts not done */
+
+ int i;
+ MB_Word num_hidden_args;
+ MR_Closure *closure;
+ MB_Short *var_list;
+ MB_Cons_id *consid = &(bca->construct.consid);
+
+ /*MB_util_error("Closure layouts not implemented");*/
+
+ if (consid->opt.pred_const.native_addr == NULL) {
+ consid->opt.pred_const.native_addr =
+ MB_code_find_proc_native(
+ consid->opt.pred_const.
+ module_name,
+ consid->opt.pred_const.
+ pred_name,
+ consid->opt.pred_const.mode_num,
+ consid->opt.pred_const.arity,
+ consid->opt.pred_const.is_func
+ );
+
+ if (consid->opt.pred_const.native_addr == NULL){
+ MB_util_error("%s %s__%s/%d (%d)",
+ consid->opt.pred_const.is_func
+ ? "func" : "pred",
+ consid->opt.pred_const.
+ module_name,
+ consid->opt.pred_const.
+ pred_name,
+ consid->opt.pred_const.arity,
+ consid->opt.pred_const.mode_num
+ );
+ MB_fatal("Unable to find closure code");
+ }
+ }
+
+ /* Create a closure */
+ num_hidden_args = bca->construct.list_length;
+ var_list = bca->construct.var_list;
+
+ /* Fill in the closure */
+
+ closure = (MR_Closure *) MB_GC_malloc(
+ offsetof(MR_Closure, MR_closure_hidden_args_0)
+ + sizeof(MR_Word) * num_hidden_args);
+ closure->MR_closure_layout = NULL;
+ closure->MR_closure_code =
+ consid->opt.pred_const.native_addr;
+ closure->MR_closure_num_hidden_args = num_hidden_args;
+
+ /* Copy the hidden arguments */
+ for (i = 0; i < num_hidden_args; i++) {
+ closure->MR_closure_hidden_args(i+1) =
+ MB_var_get(ms, var_list[i]);
+ }
+
+ val = (MB_Word) closure;
+ break;
+ }
+
+ case MB_CONSID_CODE_ADDR_CONST:
+ MB_fatal("Construct code_addr not implemented");
+
+ case MB_CONSID_BASE_TYPE_INFO_CONST: {
+
+ MB_Cons_id *consid = &(bca->construct.consid);
+
+ if (consid->opt.base_type_info_const.type_info == NULL) {
+ consid->opt.base_type_info_const.type_info =
+ MB_type_find_ctor_info_guaranteed(
+ consid->opt.base_type_info_const
+ .module_name,
+ consid->opt.base_type_info_const
+ .type_name,
+ consid->opt.base_type_info_const
+ .type_arity);
+ }
+
+ val = (MB_Word) consid->opt.base_type_info_const
+ .type_info;
+ break;
+ }
+
+ case MB_CONSID_CHAR_CONST:
+ val = (MB_Word) bca->construct.consid.opt.char_const.ch;
+ break;
+
+ default:
+ MB_fatal("Unknown constructor id");
+ }
+ MB_var_set(ms, bca->construct.to_var, val);
+ instr_noop(ms, NULL);
+}
+
+/*
+** returns true if the deconstruction succeeds
+** if a int/string/char const, checks for equality and triggers a redo if it
+** fails.
+** if a functor then deconstructs arguments into variable slots
+*/
+static MB_Bool
+do_deconstruct(MB_Machine_State *ms, const MB_Cons_id *cid, MB_Word var,
+ MB_Word list_length, MB_Short *var_list)
+{
+ MB_Word var_val = MB_var_get(ms, var);
+
+ /* XXX not all deconstructions done */
+ switch (cid->id) {
+ case MB_CONSID_INT_CONST:
+ return (var_val == cid->opt.int_const);
+
+ case MB_CONSID_STRING_CONST:
+ return (!MB_str_cmp((char *)var_val,
+ cid->opt.string_const));
+
+ case MB_CONSID_CONS: {
+ return do_deconstruct_cons(ms, cid, var_val,
+ list_length, var_list);
+ }
+
+ case MB_CONSID_CHAR_CONST:
+ return (var_val == (MB_Word) cid->opt.char_const.ch);
+
+ default:
+ MB_fatal("Deconstruct type not implemented");
+ }
+
+ assert(FALSE);
+ return FALSE;
+}
+
+/* returns true if val is equivalent to a construction given by cid */
+static MB_Bool
+do_deconstruct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
+ MB_Word val, MB_Word list_length, MB_Short *var_list)
+{
+ const MB_Tag *cons_tag = &cid->opt.cons.tag;
+
+ assert(cid->id == MB_CONSID_CONS);
+
+ /*
+ ** We should either check all variables (eg: deconstruct instruction)
+ ** or none of them (eg: switch_arm instruction)
+ */
+ assert((cid->opt.cons.arity == list_length) || (list_length == 0));
+
+ switch (cons_tag->id) {
+ case MB_TAG_SIMPLE: /* only need a primary tag */
+ case MB_TAG_COMPLICATED:/* need primary + remote 2ndary tag */
+ {
+ /*
+ ** The code for these two is virtually identical except
+ ** that if it is complicated we need one extra heap
+ ** slot for the remote secondary tag
+ */
+ MB_Word extra = (cons_tag->id == MB_TAG_COMPLICATED)
+ ? 1 : 0;
+ MB_Word *heap_data = (MB_Word *) MB_strip_tag(val);
+ MB_Word i;
+
+ /* check that tags are identical */
+ if (cons_tag->id == MB_TAG_COMPLICATED) {
+ if ((MB_tag(val) != cons_tag->opt.pair.primary)
+ || (heap_data[0] !=
+ cons_tag->opt.pair.secondary))
+ {
+ return FALSE;
+ }
+ } else {
+ if (MB_tag(val) != cons_tag->opt.primary) {
+ return FALSE;
+ }
+ }
+
+
+ /* Deconstruct into variable slots */
+ for (i = 0; i < list_length; i++) {
+ MB_var_set(ms, var_list[i],
+ heap_data[i + extra]);
+ }
+
+ break;
+ }
+
+ case MB_TAG_COMPLICATED_CONSTANT:
+ /* primary + local secondary tag */
+ assert(list_length == 0);
+ if (val != (MB_Word) MB_mkword(
+ MB_mktag(cons_tag->opt.pair.primary),
+ MB_mkbody(cons_tag->opt.pair.secondary)))
+ {
+ return FALSE;
+ }
+
+ break;
+
+ case MB_TAG_ENUM:
+ assert(list_length == 0);
+ if (val != (MB_Word)
+ MB_mkword(MB_mktag(cons_tag->opt.enum_tag),
+ MB_mkbody(0)))
+ {
+ return FALSE;
+ }
+ break;
+
+ case MB_TAG_NONE:
+ MB_fatal("tag_none not done");
+
+ default:
+ MB_fatal("Unknown deconstruct tag");
+ }
+
+ return TRUE;
+}
+
+
+static void
+instr_deconstruct(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* test the equality of a variable in a slot with a given value */
+ if (!do_deconstruct(ms, &bca->deconstruct.consid,
+ bca->deconstruct.from_var,
+ bca->deconstruct.list_length,
+ bca->deconstruct.var_list))
+ {
+ instr_do_redo(ms, NULL);
+ } else {
+ instr_noop(ms, NULL);
+ }
+}
+
+static void
+instr_place(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* copy value from var slot to reg */
+ MB_reg(bca->place_arg.to_reg) =
+ MB_var_get(ms, bca->place_arg.from_var);
+
+ #if CLOBBERPLACES
+ /* XXX for debugging only */
+ MB_var_set(ms, bca->place_arg.from_var, CLOBBERED);
+ #endif
+
+ /* go to the next instruction */
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_pickup(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* copy value from reg to var slot */
+ MB_var_set(ms, bca->pickup_arg.to_var,
+ MB_reg(bca->pickup_arg.from_reg));
+
+ #if CLOBBERPICKUPS
+ /* XXX for debugging only */
+ MB_reg_set(ms, bca->pickup_arg.from_reg, CLOBBERED);
+ #endif
+
+ /* go to the next instruction */
+ instr_noop(ms, NULL);
+}
+
+/* Calls a native code procedure and sets up reentry variables */
+static void
+call_native_proc(MB_Machine_State *ms, MB_Native_Addr native_addr,
+ MB_Bytecode_Addr return_ip)
+{
+ if (MB_proc_is_det(ms)) {
+ /*
+ ** Call native code from det function
+ */
+
+ /* Push a interface det stack frame */
+ MB_incr_sp(MB_DETFRAME_INTERFACE_SIZE);
+
+ /* Set success ip to reentry stub */
+ MB_succip = MB_native_get_return_det();
+
+ /* Save initial stack frame pointer */
+ MB_stackitem(MB_DETFRAME_INTERFACE_BCINITFR)
+ = (MB_Word) MB_initialstackframe_get(ms);
+
+ /* Save bytecode reentry point */
+ MB_stackitem(MB_DETFRAME_INTERFACE_BCRETIP)
+ = (MB_Word) return_ip;
+
+ } else {
+ /*
+ ** Call native code from nondet function
+ */
+
+ /* Set success ip to reentry point */
+ MB_succip = MB_native_get_return_nondet();
+
+ /* Save bytecode reentry point */
+ MB_fr_bcretip(MB_curfr) = (MB_Word) return_ip;
+ }
+
+ /* return to native code at address new_addr */
+ MB_native_return_set(ms, native_addr);
+}
+
+static void
+instr_call(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* Call another procedure */
+
+ MB_Bytecode_Addr next_ip = MB_ip_get(ms) + 1;
+
+ /* Call bytecode */
+ if (!bca->call.addr.is_native) {
+ MB_Bytecode_Addr new_addr = bca->call.addr.addr.bc;
+ if (new_addr == MB_CODE_INVALID_ADR) {
+ MB_util_error("Attempt to call unknown bytecode"
+ " %s %s__%s/%d mode %d",
+ bca->call.is_func ? "func" : "pred",
+ bca->call.module_name,
+ bca->call.pred_name,
+ (int) bca->call.arity,
+ (int) bca->call.mode_num);
+ MB_fatal("");
+ } else {
+ if (MB_ip_normal(new_addr)) {
+ /* set the return address to the next instr */
+ MB_succip = next_ip;
+ /* set the new execution point */
+ MB_ip_set(ms, new_addr);
+ } else {
+ MB_fatal("Unexpected call address"
+ " (special address not implemented?)");
+ }
+ }
+
+ /* Call native code */
+ } else {
+
+ MB_Native_Addr new_addr = bca->call.addr.addr.native;
+
+ /* Make sure the address has been looked up */
+ if (new_addr == NULL) {
+ new_addr = MB_code_find_proc_native(
+ bca->call.module_name,
+ bca->call.pred_name,
+ bca->call.mode_num,
+ bca->call.arity,
+ bca->call.is_func);
+ if (new_addr == NULL) {
+ MB_util_error(
+ "Warning: proc ref in bytecode"
+ " to unknown %s %s__%s/%d mode %d",
+ bca->call.is_func ? "func" : "pred",
+ bca->call.module_name,
+ bca->call.pred_name,
+ (int) bca->call.arity,
+ (int) bca->call.mode_num);
+ MB_fatal("Are you sure the module"
+ " was compiled with trace"
+ " information enabled?");
+ }
+
+ /* XXX: Write to constant data */
+ bca->call.addr.addr.native = new_addr;
+ }
+
+ call_native_proc(ms, new_addr, next_ip);
+ }
+}
+
+/*
+** Why does the call need to know the number of output arguments ???
+**
+** XXX: If semidet, do I need to make space for the extra argument or has
+** the mercury compiler already done that ???
+*/
+static void
+instr_higher_order_call(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* We are doing the call */
+ MR_Closure *closure = (MR_Closure *)
+ MB_var_get(ms, bca->higher_order_call.pred_var);
+
+ /*
+ ** Shift the input arguments to the right so we can insert the
+ ** arguments inside the closure
+ */
+ if (bca->higher_order_call.in_var_count != 0) {
+ signed int i = closure->MR_closure_num_hidden_args;
+ signed int j = i + bca->higher_order_call.in_var_count;
+ for (; i >= 1; i--, j--) {
+ MB_reg(j) = MB_reg(i);
+ }
+ }
+
+ /*
+ ** Now insert the hidden arguments
+ */
+ if (closure->MR_closure_num_hidden_args) {
+ signed int i;
+ MB_Word num_hidden_args =
+ closure->MR_closure_num_hidden_args;
+
+ for (i = 1; i <= num_hidden_args; i++) {
+ MB_reg(i) = closure->MR_closure_hidden_args(i);
+ }
+ }
+
+ /*
+ ** Do the actual call
+ */
+
+ call_native_proc(ms, closure->MR_closure_code, MB_ip_get(ms) + 1);
+
+}
+/*----------------------------------------------------------------------------*/
+
+static MB_Word binop_add (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_sub (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_mul (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_div (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_mod (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_lshift (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_rshift (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_and (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_or (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_xor (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_logand (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_logor (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_eq (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_ne (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_lt (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_gt (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_le (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_ge (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word binop_bad (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+
+
+typedef MB_Word (*MB_Instruction_Binop) (MB_Machine_State *,
+ const MB_Bytecode_Arg *);
+/*
+** XXX ORDER Currently we depend on the order of elements in the table.
+*/
+static MB_Instruction_Binop binop_table[] = {
+ binop_add,
+ binop_sub,
+ binop_mul,
+ binop_div,
+ binop_mod,
+ binop_lshift,
+ binop_rshift, /* XXX signed */
+ binop_and,
+ binop_or,
+ binop_xor,
+ binop_logand,
+ binop_logor,
+ binop_eq,
+ binop_ne,
+ binop_bad, /* array_index */
+ binop_bad, /* str_eq */
+ binop_bad, /* str_ne */
+ binop_bad, /* str_lt */
+ binop_bad, /* str_gt */
+ binop_bad, /* str_le */
+ binop_bad, /* str_ge */
+ binop_lt,
+ binop_gt,
+ binop_le,
+ binop_ge,
+ binop_bad, /* float_plus */
+ binop_bad, /* float_minus */
+ binop_bad, /* float_times */
+ binop_bad, /* float_divide */
+ binop_bad, /* float_eq */
+ binop_bad, /* float_ne */
+ binop_bad, /* float_lt */
+ binop_bad, /* float_gt */
+ binop_bad, /* float_le */
+ binop_bad, /* float_ge */
+ binop_bad /* body */
+};
+
+#define SIMPLEBINOP(name, op) \
+ static MB_Word \
+ binop_##name(MB_Machine_State *ms, const MB_Bytecode_Arg *bca) \
+ { \
+ assert(bca->builtin_binop.arg1.id == MB_ARG_VAR); \
+ assert(bca->builtin_binop.arg2.id == MB_ARG_VAR); \
+ return (MB_Integer)(MB_var_get(ms, \
+ bca->builtin_binop.arg1.opt.var)) \
+ op (MB_Integer)(MB_var_get(ms, \
+ bca->builtin_binop.arg2.opt.var)); \
+ }
+
+SIMPLEBINOP(add, +)
+SIMPLEBINOP(sub, -)
+SIMPLEBINOP(mul, *)
+SIMPLEBINOP(div, /)
+SIMPLEBINOP(mod, %)
+SIMPLEBINOP(lshift, <<)
+SIMPLEBINOP(rshift, >>)
+SIMPLEBINOP(and, &)
+SIMPLEBINOP(or, |)
+SIMPLEBINOP(xor, ^)
+SIMPLEBINOP(logand, &&)
+SIMPLEBINOP(logor, ||)
+SIMPLEBINOP(eq, ==)
+SIMPLEBINOP(ne, !=)
+SIMPLEBINOP(lt, <)
+SIMPLEBINOP(gt, >)
+SIMPLEBINOP(le, <=)
+SIMPLEBINOP(ge, >=)
+
+
+static MB_Word
+binop_bad(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
+{
+ MB_fatal("Unsupported binop\n");
+ return 0;
+}
+
+
+
+static void
+instr_builtin_binop(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ MB_Byte binop = bca->builtin_binop.binop;
+ if (binop < (sizeof(binop_table)/sizeof(binop_table[0]))) {
+ MB_var_set(ms,
+ bca->builtin_binop.to_var,
+ binop_table[bca->builtin_binop.binop](ms, bca));
+
+ instr_noop(ms, NULL);
+ } else {
+ MB_fatal("Invalid binop");
+ }
+}
+
+static void
+instr_builtin_bintest(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ MB_Byte binop = bca->builtin_binop.binop;
+ if (binop < (sizeof(binop_table)/sizeof(binop_table[0]))) {
+ if (binop_table[bca->builtin_binop.binop](ms, bca)) {
+ /* If successful, just go to the next instr */
+ instr_noop(ms, NULL);
+ } else {
+ /* otherwise follow the failure context */
+ /*instr_do_fail(ms, NULL);*/
+ instr_do_redo(ms, NULL);
+ }
+ } else {
+ MB_fatal("Invalid bintest");
+ }
+}
+/*----------------------------------------------------------------------------*/
+static MB_Word unop_bad (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word unop_bitwise_complement
+ (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+static MB_Word unop_not (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
+/*
+** XXX ORDER Currently we depend on the order of elements in the table
+*/
+static MB_Word (*unop_table[])(MB_Machine_State *ms,
+ const MB_Bytecode_Arg *bca) =
+{
+ unop_bad, /* mktag */
+ unop_bad, /* tag */
+ unop_bad, /* unmktag */
+ unop_bad, /* mkbody */
+ unop_bad, /* unmkbody */
+ unop_bad, /* cast_to_unsigned */
+ unop_bad, /* hash_string */
+ unop_bitwise_complement,
+ unop_not
+};
+
+#define SIMPLEUNOP(name, op) \
+ static MB_Word \
+ unop_##name(MB_Machine_State *ms, const MB_Bytecode_Arg *bca) \
+ { \
+ return op MB_var_get(ms, bca->builtin_unop.arg.opt.var); \
+ }
+
+SIMPLEUNOP(bitwise_complement, ~)
+SIMPLEUNOP(not, !)
+
+static MB_Word
+unop_bad(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
+{
+ MB_fatal("Unsupported unop\n");
+ return 0;
+}
+
+static void
+instr_builtin_unop(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ MB_Byte unop = bca->builtin_unop.unop;
+
+ if (unop < (sizeof(unop_table)/sizeof(unop_table[0]))) {
+
+ MB_var_set(ms, bca->builtin_unop.to_var,
+ unop_table[bca->builtin_unop.unop](ms, bca));
+
+ instr_noop(ms, NULL);
+ } else {
+ MB_fatal("Invalid unop");
+ }
+}
+
+
+static void
+instr_builtin_untest(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ MB_fatal("builtin_untest not done");
+}
+
+/*----------------------------------------------------------------------------*/
+static void
+instr_semidet_success(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ MB_stackitem(MB_DETFRAME_SEMIDET_SUCCESS) = MB_SEMIDET_SUCCESS;
+
+ instr_noop(ms, NULL);
+}
+
+static void
+instr_semidet_success_check(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ if (MB_reg(MB_SEMIDET_SUCCESS_REG) != MB_SEMIDET_SUCCESS) {
+ instr_do_redo(ms, NULL);
+ } else {
+ instr_noop(ms, NULL);
+ }
+}
+
+static void
+instr_do_redo(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /*
+ ** XXX: redo to bytecode could be sped up by going directly to the
+ ** right location instead of jumping back into native code first
+ */
+
+ /* return to native code at address new_addr */
+ MB_native_return_set(ms, MB_native_get_do_redo());
+}
+
+static void
+instr_do_fail(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /*
+ ** XXX: fail to bytecode could be sped up by going directly to the
+ ** right location instead of jumping back into native code first
+ */
+
+ /* return to native code at address new_addr */
+ MB_native_return_set(ms, MB_native_get_do_fail());
+}
+
+static void
+instr_noop(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ /* increment instruction pointer */
+ MB_ip_set(ms, MB_ip_get(ms) + 1);
+}
+
+static void
+instr_notdone(MB_Machine_State *ms, MB_Bytecode_Arg *bca)
+{
+ MB_fatal("Instruction type not (yet) completed");
+
+ /* invalid instruction */
+ instr_noop(ms, NULL);
+}
+
+/*
+** Execute the current instruction. Returns false if instruction could
+** not be executed
+*/
+static MB_Bool
+dispatch(MB_Byte bc_id, MB_Machine_State *ms)
+{
+ MB_Bytecode_Addr ip = MB_ip_get(ms);
+
+ if (bc_id < sizeof(instruction_table) / sizeof(instruction_table[0])) {
+ instruction_table[bc_id](ms, MB_code_get_arg(ip));
+ return TRUE;
+ }
+
+ return FALSE;
+}
+
+/*----------------------------------------------------------------------------*/
+/*
+** XXX: This is debugging code *only*. It won't work in threads, and
+** is rather fragile. Don't push it too hard, and it will be kind to you.
+*/
+
+#define DODEBUG 1
+
+#include "mb_disasm.h"
+
+static void
+MB_machine_debug(MB_Machine_State* ms) {
+
+
+ static MB_Bytecode_Addr stopat =
+ #if DODEBUG
+ NULL;
+ #else
+ (MB_Bytecode_Addr) MB_CODE_INVALID_ADR;
+ #endif
+ static int line_len = 80;
+
+ static MB_Word count = 0;
+ static MB_Word stopcount = 0;
+ char buffer[60];
+ MB_Bytecode_Addr cur_ip = MB_ip_get(ms);
+
+ count++;
+
+ if (count == stopcount) {
+ stopat = cur_ip;
+ }
+
+ if (stopat != NULL && stopat != cur_ip) return;
+
+ if (cur_ip == MB_CODE_NATIVE_RETURN) {
+ stopat = NULL;
+ return;
+ }
+
+ MB_show_state(ms, stderr);
+
+ MB_SAY("exec count %d", count);
+
+Reread:
+ fgets(buffer, sizeof(buffer), stdin);
+
+ switch (buffer[0]) {
+ case 0:
+ case '\n':
+ case 's': /* step */
+ stopat = NULL;
+ break;
+ case 'c': /* instruction count */
+ if (sscanf(buffer, "c %d", &stopcount)
+ == 1)
+ {
+ stopat = MB_CODE_INVALID_ADR;
+ }
+ break;
+ case 'd': /* code dump */
+ MB_listing(ms, stderr,
+ (MB_Bytecode_Addr) NULL,
+ (MB_Bytecode_Addr) ((MB_Word)
+ (((char *) NULL - 1)) / 3),
+ line_len);
+ goto Reread;
+ case '-':
+ line_len *= 3;
+ line_len /= 4;
+ goto Reread;
+ case '+':
+ line_len *= 4;
+ line_len /= 3;
+ goto Reread;
+ case 'l': { /* code listing */
+ MB_Bytecode_Addr start;
+ MB_Bytecode_Addr end;
+ switch (sscanf(buffer, "l %p %p", &start, &end)) {
+ case EOF:
+ case 0:
+ start = MB_ip_get(ms);
+ case 1:
+ start -= 12;
+ end = start + 48;
+ break;
+ case 2:
+ break;
+ }
+ MB_listing(ms, stderr, start, end,
+ line_len);
+ goto Reread;
+ }
+ case 'S': /* machine state */
+ MB_show_state(ms, stderr);
+ goto Reread;
+ case 'n': /* next */
+ stopat = cur_ip + 1;
+ break;
+ case 'r': /* run */
+ stopat = MB_CODE_INVALID_ADR;
+ break;
+ case 'e': /* run to reentry */
+ stopat = MB_CODE_NATIVE_RETURN;
+ break;
+ case 'R': /* to return */
+ do {
+ cur_ip++;
+ } while (MB_code_get_id(cur_ip) != MB_BC_endof_proc);
+ stopat = cur_ip;
+ break;
+ case 'x':
+ exit(0);
+ case '?':
+ MB_SAY(
+ "s - step\n"
+ "n - next (step over)\n"
+ "r - run to end\n"
+ "c $1 - run to Count $1\n"
+ "e - run to reEntry\n"
+ "R - run to immediate return\n"
+ "x - exit"
+ );
+ goto Reread;
+ case 'v': /* view [data] */
+ switch (buffer[1]) {
+ case 's': {
+ char *strbuf = NULL;
+ sscanf(buffer, "vs %p", &strbuf);
+ MB_SAY("String at %p: %s", strbuf, strbuf);
+ break;
+ }
+ case 'l': {
+ MB_Word list_ptr;
+ MB_Word tag;
+ sscanf(buffer, "vl %p", &list_ptr);
+ MB_SAY("List at %p: [", list_ptr);
+
+ tag = MB_tag(list_ptr);
+ while (tag != 0) {
+ MB_SAY("\t%08x",
+ MB_field(tag, list_ptr, 0));
+ list_ptr = MB_field(tag, list_ptr, 1);
+
+ tag = MB_tag(list_ptr);
+ }
+ MB_SAY("]\n");
+ break;
+ }
+ default:
+ MB_SAY("Unknown data type");
+ }
+ goto Reread;
+ default:
+ MB_SAY("Unknown command");
+ goto Reread;
+ }
+ MB_SAY("Will stop at %p", stopat);
+}
+/*----------------------------------------------------------------------------*/
+#include "mb_machine_def.h" /* reqd to instantiate MB_Machine_State */
+MB_Native_Addr
+MB_machine_exec(MB_Bytecode_Addr new_ip, MB_Word *initial_stack)
+{
+ /* Create Machine State */
+ MB_Machine_State ms;
+ ms.ip = new_ip;
+ ms.initial_stack = initial_stack;
+ MB_proc_var_init(&ms);
+
+ do {
+ MB_Bytecode_Addr ip;
+
+ MB_machine_debug(&ms);
+
+ ip = MB_ip_get(&ms);
+ if (MB_ip_normal(ip)) {
+
+ MB_Byte bc_id = MB_code_get_id(ip);
+
+
+ if (!dispatch(bc_id, &ms)) {
+ switch (bc_id) {
+ case MB_BC_debug_trap:
+ return 0;
+ }
+ MB_util_error("Attempt to execute"
+ " invalid instruction\n");
+ instr_noop(&ms, NULL);
+ return 0;
+ }
+ } else {
+ switch ((MB_Word) ip) {
+ case (MB_Word) MB_CODE_DO_FAIL:
+ instr_do_fail(&ms, NULL);
+ break;
+
+ case (MB_Word) MB_CODE_DO_REDO:
+ instr_do_redo(&ms, NULL);
+ break;
+
+ case (MB_Word) MB_CODE_NATIVE_RETURN:
+ return MB_native_return_get(&ms);
+ default:
+ MB_util_error("At address %p:", ip);
+ MB_fatal("Attempt to execute invalid"
+ " address\n");
+ }
+ }
+ } while (1);
+
+ assert(FALSE);
+ return NULL;
+}
+
+
Index: bytecode/mb_exec.h
===================================================================
RCS file: mb_exec.h
diff -N mb_exec.h
--- /dev/null Thu Mar 30 14:06:13 2000
+++ mb_exec.h Thu Feb 8 15:30:52 2001
@@ -0,0 +1,27 @@
+/*
+** Copyright (C) 1997,2000-2001 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.
+**
+** Execution of bytecode
+**
+*/
+
+#ifndef MB_EXEC_H
+#define MB_EXEC_H
+
+#include "mb_basetypes.h"
+
+#include <stdio.h>
+#include "mb_bytecode.h"
+#include "mb_machine.h"
+
+/*
+** Execute a bytecode machine until native code invocation required.
+** Returns address of native code to return to
+*/
+MB_Native_Addr MB_machine_exec(MB_Bytecode_Addr new_ip,
+ MB_Word *initial_stack);
+
+#endif /* MB_EXEC_H */
+
Index: bytecode/mb_interface.c
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_interface.c,v
retrieving revision 1.1
diff -u -r1.1 mb_interface.c
--- bytecode/mb_interface.c 2001/02/01 05:20:28 1.1
+++ bytecode/mb_interface.c 2001/02/13 03:32:49
@@ -8,21 +8,49 @@
#include "mercury_imp.h"
-#include "mercury_regs.h"
-#include "mercury_trace.h"
#include "mercury_trace_tables.h"
#include "mb_interface.h"
+
+#include "mb_disasm.h"
+#include "mb_exec.h"
#include "mb_module.h"
-#include "mb_machine.h"
/* Exported definitions */
-
+MB_Native_Addr MB_bytecode_call_entry(MB_Call *bytecode_call);
+MB_Native_Addr MB_bytecode_return_det(void);
+MB_Native_Addr MB_bytecode_return_temp_det(void);
+MB_Native_Addr MB_bytecode_return_temp_nondet(void);
+MB_Native_Addr MB_bytecode_return_nondet(void);
+MB_Native_Addr MB_native_get_return_det(void);
+MB_Native_Addr MB_native_get_return_temp_det(void);
+MB_Native_Addr MB_native_get_return_temp_nondet(void);
+MB_Native_Addr MB_native_get_return_nondet(void);
+MB_Native_Addr MB_native_get_do_redo(void);
+MB_Native_Addr MB_native_get_do_fail(void);
+MB_Native_Addr MB_native_get_unify_2(void);
+MB_Native_Addr MB_native_get_compare_3(void);
+MB_Native_Addr MB_code_find_proc_native(MB_CString_Const module_name,
+ MB_CString_Const pred_name,
+ MB_Word mode_num, MB_Word arity,
+ MB_Bool is_func);
+MB_Native_Addr MB_code_find_proc_native(MB_CString_Const module_name,
+ MB_CString_Const pred_name,
+ MB_Word mode_num, MB_Word arity,
+ MB_Bool is_func);
+MR_TypeCtorInfo MB_type_find_ctor_info_guaranteed(
+ MB_CString_Const module_name,
+ MB_CString_Const type_name,
+ MB_Word type_arity);
/* Local declarations */
/* Implementation */
+/* Reentry stubs */
MR_declare_entry(MB_native_return_det_stub);
+MR_declare_entry(MB_native_return_temp_det_stub);
+MR_declare_entry(MB_native_return_temp_nondet_stub);
+MR_declare_entry(MB_native_return_nondet_stub);
MB_Native_Addr
MB_native_get_return_det(void)
@@ -30,61 +58,93 @@
return (MB_Native_Addr) MR_ENTRY(MB_native_return_det_stub);
}
+MB_Native_Addr
+MB_native_get_return_temp_det(void)
+{
+ return (MB_Native_Addr) MR_ENTRY(MB_native_return_temp_det_stub);
+}
+
+MB_Native_Addr
+MB_native_get_return_temp_nondet(void)
+{
+ return (MB_Native_Addr) MR_ENTRY(MB_native_return_temp_nondet_stub);
+}
+
+MB_Native_Addr
+MB_native_get_return_nondet(void)
+{
+ return (MB_Native_Addr) MR_ENTRY(MB_native_return_nondet_stub);
+}
+
+MB_Native_Addr
+MB_native_get_do_redo(void)
+{
+ return (MB_Native_Addr) MR_ENTRY(do_redo);
+}
+
+MB_Native_Addr
+MB_native_get_do_fail(void)
+{
+ return (MB_Native_Addr) MR_ENTRY(do_fail);
+}
+
+MR_declare_entry(mercury__unify_2_0);
+MR_declare_entry(mercury__compare_3_0);
+
+MB_Native_Addr
+MB_native_get_unify_2(void)
+{
+ return (MB_Native_Addr) MR_ENTRY(mercury__unify_2_0);
+}
+
+MB_Native_Addr
+MB_native_get_compare_3(void)
+{
+ return (MB_Native_Addr) MR_ENTRY(mercury__compare_3_0);
+}
+
/* Search for the native code address of a procedure */
MB_Native_Addr
-MB_code_find_proc_native(MB_CString_Const module, MB_CString_Const pred,
- MB_Word proc, MB_Word arity, MB_Bool is_func)
+MB_code_find_proc_native(MB_CString_Const module_name,
+ MB_CString_Const pred_name, MB_Word mode_num,
+ MB_Word arity, MB_Bool is_func)
{
- MR_Matches_Info matches;
- MR_Proc_Spec spec;
+ MR_Matches_Info matches;
+ MR_Proc_Spec spec;
- MR_register_all_modules_and_procs(stderr, TRUE);
- MB_SAY("\n");
+ MR_register_all_modules_and_procs(stderr, FALSE);
- spec.MR_proc_module = module;
- spec.MR_proc_name = pred;
+ spec.MR_proc_module = module_name;
+ spec.MR_proc_name = pred_name;
spec.MR_proc_arity = arity;
- spec.MR_proc_mode = proc;
+ spec.MR_proc_mode = mode_num;
spec.MR_proc_pf = (is_func) ? MR_FUNCTION : MR_PREDICATE;
- MB_SAY("Looking for procedures .... ");
matches = MR_search_for_matching_procedures(&spec);
- {
- MB_Word i;
- for (i = 0; i < matches.match_proc_next; i++) {
- MB_SAY("Match %d: %s %s__%s/%d (%d)",
- i,
- (matches.match_procs[i]
- ->MR_sle_proc_id.MR_proc_user
- .MR_user_pred_or_func == MR_PREDICATE) ?
- "pred" : "func",
- matches.match_procs[i]
- ->MR_sle_proc_id.MR_proc_user
- .MR_user_def_module,
- matches.match_procs[i]
- ->MR_sle_proc_id.MR_proc_user
- .MR_user_name,
- matches.match_procs[i]
- ->MR_sle_proc_id.MR_proc_user
- .MR_user_arity,
- matches.match_procs[i]
- ->MR_sle_proc_id.MR_proc_user
- .MR_user_mode
- );
- }
- }
-
switch (matches.match_proc_next) {
case 0:
+ if (MB_str_cmp("builtin", module_name) == 0) {
+ if (mode_num == 0 && is_func == FALSE) {
+ if (arity == 2 &&
+ MB_str_cmp("unify", pred_name) == 0)
+ {
+ return MB_native_get_unify_2();
+ } else if (arity == 3 &&
+ MB_str_cmp("compare", pred_name) == 0)
+ {
+ return MB_native_get_compare_3();
+ }
+
+ }
+ }
return NULL;
case 1:
{
MB_Native_Addr addr = (MB_Native_Addr)
matches.match_procs[0]->
MR_sle_traversal.MR_trav_code_addr;
- MB_SAY("Adr %08x", addr);
}
return (MB_Native_Addr)matches.match_procs[0]->
MR_sle_traversal.MR_trav_code_addr;
@@ -95,95 +155,131 @@
}
/*
-** A native code procedure wishes to call a deterministic bytecode procedure
+** Looks up type constructor info.
+** Guaranteed to succeed (aborts program if it fails)
*/
+MR_TypeCtorInfo
+MB_type_find_ctor_info_guaranteed(MB_CString_Const module_name,
+ MB_CString_Const type_name, MB_Word type_arity)
+{
+ MR_TypeCtorInfo ret_val;
+ MR_do_init_modules_type_tables();
+
+ ret_val = MR_lookup_type_ctor_info(module_name, type_name, type_arity);
+ if (ret_val == NULL) {
+ MB_util_error("Type %s__%s/" MB_FMT_INT " not found",
+ module_name, type_name, type_arity);
+ MB_fatal("Unable to find type ctor info");
+ }
+
+ return ret_val;
+}
+
/*
-** Needed to instantiate MB_Machine_State. Not #included above because nothing
-** else in this module should need to know what is inside an MB_Machine_State
+** A native code procedure wishes to call a deterministic bytecode procedure
*/
-#include "mb_machine_def.h"
-
MB_Native_Addr
MB_bytecode_call_entry(MB_Call *bytecode_call)
{
-
- MB_Native_Addr native_ip;
MB_Bytecode_Addr bc_ip;
- MB_SAY("Det stack is at %08x", MB_sp);
-
- MB_SAY("\n\nHello from bytecode_entry_det");
if ((void *) bytecode_call->cached_ip == NULL) {
bc_ip = MB_code_find_proc(bytecode_call->module_name,
bytecode_call->pred_name,
- bytecode_call->proc_num,
+ bytecode_call->mode_num,
bytecode_call->arity,
bytecode_call->is_func);
} else {
bc_ip = bytecode_call->cached_ip;
}
+
if (bc_ip == MB_CODE_INVALID_ADR) {
- MB_util_error("Attempting to call bytecode %s %s__%s/%d (%d):",
+ MB_util_error("Attempting to call bytecode %s %s__%s/"
+ MB_FMT_INT " (" MB_FMT_INT "):",
bytecode_call->is_func ? "func" : "pred",
bytecode_call->module_name,
bytecode_call->pred_name,
bytecode_call->arity,
- bytecode_call->proc_num);
+ bytecode_call->mode_num);
MB_fatal("Unable to find procedure\n"
"(Is the native code and the bytecode consistent?)");
}
-
- MB_SAY(" bytecode addr %08x", bc_ip);
-
- {
- /* Create a new machine and start executing */
- MB_Machine_State ms;
- MB_machine_create(&ms, bc_ip, NULL);
-
- MB_SAY("ZZZ ENTERING BYTECODE");
- MB_show_state(&ms, stderr);
-
- native_ip = MB_machine_exec(&ms);
- MB_SAY("ZZZ RETURNING TO NATIVE1");
- MB_show_state(&ms, stderr);
- }
-
- return native_ip;
+ return MB_machine_exec(bc_ip, NULL);
}
/*
-** This is the reentry point after a det bytecode procedure has called
-** native code. See mb_interface.h for a description of how this occurs
+** Reentry point det bytecode procedure has called native code.
*/
MB_Native_Addr
MB_bytecode_return_det(void)
{
/* Get the bytecode reentry address */
MB_Bytecode_Addr ip = (MB_Bytecode_Addr)
- MB_stackitem(MB_DETFRAME_INTERFACE_BC_SUCCIP);
+ MB_stackitem(MB_DETFRAME_INTERFACE_BCRETIP);
/* Get the initial stack frame */
MB_Word *initial_frame = (MB_Word *)
- MB_stackitem(MB_DETFRAME_INTERFACE_INITIAL_FRAME);
+ MB_stackitem(MB_DETFRAME_INTERFACE_BCINITFR);
- MB_Native_Addr ret_ip;
+ /* Remove interface frame */
+ MB_decr_sp(MB_DETFRAME_INTERFACE_SIZE);
- MB_Machine_State ms;
+ /* Execute */
+ return MB_machine_exec(ip, initial_frame);
+}
- MB_decr_sp(MB_DETFRAME_INTERFACE_SIZE);
+/*
+** Reentry point after a redo/fail was executed and used a temp nondet stack
+** frame generated by a det procedure
+*/
+MB_Native_Addr
+MB_bytecode_return_temp_det(void)
+{
+ /* Get the bytecode reentry address */
+ MB_Bytecode_Addr ip = (MB_Bytecode_Addr)
+ MB_fr_temp_det_bcredoip(MB_maxfr);
+ /* Get the initial stack frame */
+ MB_Word *initial_frame = (MB_Word *)
+ MB_fr_temp_det_bcinitfr(MB_maxfr);
- MB_machine_create(&ms, ip, initial_frame);
+ /* execute */
+ return MB_machine_exec(ip, initial_frame);
+}
- MB_SAY("ZZZ RETURNING TO BYTECODE");
- MB_show_state(&ms, stderr);
+/*
+** Reentry point after a redo/fail was executed and used a temp nondet stack
+** frame generated by a nondet procedure
+*/
+MB_Native_Addr
+MB_bytecode_return_temp_nondet(void)
+{
+ /* Get the bytecode reentry address */
+ MB_Bytecode_Addr ip = (MB_Bytecode_Addr)
+ MB_fr_temp_nondet_bcredoip(MB_maxfr);
- ret_ip = MB_machine_exec(&ms);
+ /* Get the initial stack frame */
+ MB_Word *initial_frame = (MB_Word *)
+ MB_fr_bcinitfr(MB_curfr);
- MB_SAY("ZZZ RETURNING TO NATIVE2");
- MB_show_state(&ms, stderr);
+ /* execute */
+ return MB_machine_exec(ip, initial_frame);
+}
- return ret_ip;
+/*
+** Reentry point after a call by a nondet procedure
+*/
+MB_Native_Addr
+MB_bytecode_return_nondet(void)
+{
+ /* Get the bytecode reentry address */
+ MB_Bytecode_Addr ip = (MB_Bytecode_Addr)
+ MB_fr_bcretip(MB_curfr);
+ /* Get the initial stack frame */
+ MB_Word *initial_frame = (MB_Word *)
+ MB_fr_bcinitfr(MB_curfr);
+ /* execute */
+ return MB_machine_exec(ip, initial_frame);
}
Index: bytecode/mb_interface.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_interface.h,v
retrieving revision 1.1
diff -u -r1.1 mb_interface.h
--- bytecode/mb_interface.h 2001/02/01 05:20:28 1.1
+++ bytecode/mb_interface.h 2001/02/13 05:10:45
@@ -1,4 +1,3 @@
-
/*
** Copyright (C) 2000-2001 The University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
@@ -10,43 +9,37 @@
#ifndef MB_INTERFACE_H
#define MB_INTERFACE_H
-
-#include "mb_basetypes.h"
-#include "mb_module.h"
-#include "mb_util.h"
-
-typedef struct {
- /* if cached_ip is NULL, this procedure hasn't been looked up yet */
- MB_Bytecode_Addr cached_ip;
- const char *module_name;
- const char *pred_name;
- MB_Word proc_num;
- MB_Word arity;
- MB_Bool is_func;
-} MB_Call;
-
-/*
-** Entry point for a native code call to det bytecode.
-** Returns native code address to return to
-*/
-MB_Native_Addr MB_bytecode_call_entry(MB_Call *bytecode_call);
+#include "mb_interface_stub.h"
-/*
-** Return to deterministic code after call to native code.
-** Returns native code address to return to.
-** Determines bytecode address to jump to by the contents of the
-** MB_DETFRAME_BC_SUCCIP det stack slot
-*/
-MB_Native_Addr MB_bytecode_return_det(void);
+#include "mb_util.h"
-/* Returns pointer to the stub that calls bytecode_return_det */
+/* Returns pointer to the stub that calls corresponding function */
MB_Native_Addr MB_native_get_return_det(void);
+MB_Native_Addr MB_native_get_return_temp_det(void);
+MB_Native_Addr MB_native_get_return_temp_nondet(void);
+MB_Native_Addr MB_native_get_return_nondet(void);
+
+MB_Native_Addr MB_native_get_do_redo(void);
+MB_Native_Addr MB_native_get_do_fail(void);
+MB_Native_Addr MB_native_get_unify_2(void);
+MB_Native_Addr MB_native_get_compare_3(void);
/* Find the native code entry point for a procedure */
-MB_Native_Addr MB_code_find_proc_native(MB_CString_Const module,
- MB_CString_Const pred, MB_Word proc,
- MB_Word arity, MB_Bool is_func);
+MB_Native_Addr MB_code_find_proc_native(MB_CString_Const module_name,
+ MB_CString_Const pred_name,
+ MB_Word mode_num, MB_Word arity,
+ MB_Bool is_func);
+MB_Native_Addr MB_code_find_proc_native(MB_CString_Const module_name,
+ MB_CString_Const pred_name,
+ MB_Word mode_num, MB_Word arity,
+ MB_Bool is_func);
+
+/* Get type info. Will abort program if it cannot find it */
+MR_TypeCtorInfo MB_type_find_ctor_info_guaranteed(
+ MB_CString_Const module_name,
+ MB_CString_Const type_name,
+ MB_Word type_arity);
/**************************************************************/
/*
@@ -54,14 +47,17 @@
**
** Each normal det stack frame looks like the following:
** sp-1: [succip]
-** sp-2: [var 0]
-** sp-3: [var 1]
+** sp-2: [temp 0]
+** sp-3: [temp 1]
** ...
-** sp-n: [temp 0]
-** sp-n-1: [temp 1]
+** sp-n: [var 0]
+** sp-n-1: [var 1]
** ...
**
** If model semidet, then temp 0 is the semidet success indicator
+** This is why putting the temps straight after the fixed stack
+** slots allows SEMIDET_SUCCESS to be in a fixed location
+**
*/
/* saved succip */
@@ -70,26 +66,21 @@
/* fixed size of deterministic stack frame */
#define MB_DETFRAME_SIZE (1)
+/* semidet success indicator (loaded into r0 at endof_proc) */
+#define MB_DETFRAME_SEMIDET_SUCCESS (2)
+
/*
-**
** An interface det stack frame is pushed when bytecode wishes
-** to jump to native code and later return to bytecode. succip
+** to jump to native code and later return to bytecode. Succip
** will have been set to a stub that reads the interface stack
-** frame and directs control appropriately
+** frame and directs control appropriately (MB_bytecode_return_det_stub)
** sp-1: [succip in bytecode to return to]
-** sp-2: [initial frame]
-**
-** The initial frame field is used to determine whether a procedure should
-** return to bytecode or native code when it reaches endof_proc. If it reaches
-** an endof_proc instruction and after removing its stack frame finds that the
-** (det or nondet) stack pointer is equal to the initial frame it knows that
-** it is the most ancestral called procedure and should return to native code
-**
+** sp-2: [saved machine state initial frame]
*/
/* bytecode return address for stub */
-#define MB_DETFRAME_INTERFACE_BC_SUCCIP (1)
-#define MB_DETFRAME_INTERFACE_INITIAL_FRAME (2)
+#define MB_DETFRAME_INTERFACE_BCRETIP (1)
+#define MB_DETFRAME_INTERFACE_BCINITFR (2)
/* Size of a deterministic interface frame */
#define MB_DETFRAME_INTERFACE_SIZE (2)
@@ -98,32 +89,85 @@
** Nondet stack
**
** An ordinary stack frame looks like so:
-** curfr[ 0] prevfr
-** curfr[-1] redoip
-** curfr[-2] redofr
-** curfr[-3] succip
-** curfr[-4] succfr
+** curfr[ 0] prevfr (frame below this one)
+** curfr[-1] redoip (ip to use at redo) = do_fail
+** curfr[-2] redofr (curfr to use at redo)
+** curfr[-3] succip (ip to use at success [caller return] )
+** curfr[-4] succfr (frame to use at success [calling frame])
+** curfr[-5] bcretip (stack slot with next bytecode IP to return
+** to following a call to native code)
+** curfr[-6] initfr (saved initfr)
** then follows var[0] to var[n]
** then follows temp[0] to temp[n]
+**
+** A temp stack frame from nondet code looks like so:
+** curfr[ 0] prevfr (frame below this one)
+** curfr[-1] redoip (ip to use at redo) = MB_bytecode_return_temp_nondet
+** curfr[-2] redofr (curfr to use at redo)
+** curfr[-3] bcredoip (bytecode ip to return to when redoing this frame)
**
+** A temp stack frame from det code looks like so:
+** curfr[ 0] prevfr (frame below this one)
+** curfr[-1] redoip (ip to use at redo) = MB_bytecode_return_temp_det
+** curfr[-2] redofr (curfr to use at redo)
+** curfr[-3] detfr (deterministic stack frame (used by accurate GC))
+** curfr[-4] bcredoip (bytecode ip to return to when redoing this frame)
+** curfr[-5] initfr (saved initfr)
+**
+** When entering nondet code:
+** If initfr is not already set, set it to maxfr
+** Push normal nondet stack frame
+**
+** When calling native code from nondet code:
+** bcretip = next bytecode instruction after the call
+** MB_succip = MB_bytecode_return_nondet_stub which calls
+** MB_bytecode_return_nondet which reads bcretip and jumps
+** to the correct bytecode instruction
+**
+** When returning from nondet code:
+** Check if curfr->prevfr = initfr then this procedure was the one that
+** set initfr.
+** If it was, we should return to native code address succip.
+** If it wasn't, we should return to bytecode address succip.
+*/
+
+/* Present in all stack frames on the nondet stack */
+#define MB_FRAME_PREVFR (0)
+#define MB_FRAME_REDOIP (1)
+#define MB_FRAME_REDOFR (2)
+
+/* Present in temporary nondet stack frames on the nondet stack */
+#define MB_FRAME_TEMP_NONDET_BCREDOIP (3)
+
+/* Present in temporary det stack frames on the nondet stack */
+#define MB_FRAME_DETFR (3)
+#define MB_FRAME_TEMP_DET_BCREDOIP (4)
+#define MB_FRAME_TEMP_DET_BCINITFR (5)
+
+/* Present in all normal nondet stack frames */
+#define MB_FRAME_SUCCIP (3)
+#define MB_FRAME_SUCCFR (4)
+
+#define MB_FRAME_BCRETIP (5)
+#define MB_FRAME_BCINITFR (6)
+
+/*
+** Note that the 3-4-5 size of the original native stack frames no longer
+** applies; bytecode stack frames can have sizes of 4-6-7.
+** The redoip of a bytecode stack frame will always be one of:
+** MR_do_fail
+** MB_bytecode_return_temp_det_stub
+** MB_bytecode_return_temp_nondet_stub
+**
*/
-#define MB_FRAME_PREVFR (0)
-#define MB_FRAME_REDOIP (1)
-#define MB_FRAME_REDOFR (2)
-
-#define MB_FRAME_DETFR (3)
-
-#define MB_FRAME_SUCCIP (3)
-#define MB_FRAME_SUCCFR (4)
-
/* size of normal nondet stack frame */
-#define MB_FRAME_SIZE 5
+#define MB_FRAME_NORMAL_SIZE 7
/* size of temp nondet stack frame created by model det/semidet code */
-#define MB_FRAME_TEMP_DET_SIZE 4
+#define MB_FRAME_TEMP_DET_SIZE 6
/* size of temp nondet stack frame created by model nondet code */
-#define MB_FRAME_TEMP_SIZE 3
+#define MB_FRAME_TEMP_NONDET_SIZE 4
/* Invalid frame address */
#define MB_FRAME_INVALID ((MB_Word) (-1))
@@ -136,7 +180,6 @@
#define MB_SEMIDET_FAILURE FALSE
#define MB_SEMIDET_SUCCESS_REG 1
-#define MB_SEMIDET_SUCCESS_SLOT 0
/**************************************************************/
/* register definitions */
@@ -146,11 +189,10 @@
#define MB_curfr MR_virtual_curfr
#define MB_maxfr MR_virtual_maxfr
-/* Det stack: 1 is the top (used - slot 0 is unused) */
-#define MB_stackitem(x) ((MB_sp)[-(x)])
+/* Det stack: slot 1 is the top (used - slot 0 is unused) */
+#define MB_stackvar(x) ((MB_sp)[-((x) + MB_DETFRAME_SIZE + 1)])
-/* Nondet stack - same as with det statck */
-#define MB_frameitem(x) ((MB_maxfr)[-(x)])
+#define MB_stackitem(x) ((MB_sp)[-(x)])
#define MB_incr_sp(x) ( \
MB_sp += (x), \
@@ -159,15 +201,51 @@
#define MB_decr_sp(x) MB_incr_sp(-(x))
+/* Nondet stack - same as with det statck */
+#define MB_frameitem(frame_ptr, x) ((frame_ptr)[-(x)])
+#define MB_framevar(x) (MB_frameitem(MB_curfr, MB_FRAME_NORMAL_SIZE))
+
+#define MB_fr_prevfr(frame_ptr) \
+ ((MB_Word *) MB_frameitem(frame_ptr, MB_FRAME_PREVFR))
+#define MB_fr_redoip(frame_ptr) \
+ MB_frameitem(frame_ptr, MB_FRAME_REDOIP)
+#define MB_fr_redofr(frame_ptr) \
+ MB_frameitem(frame_ptr, MB_FRAME_REDOFR)
+
+
+#define MB_fr_temp_nondet_bcredoip(frame_ptr) \
+ MB_frameitem(frame_ptr, MB_FRAME_TEMP_NONDET_BCREDOIP)
+
+
+#define MB_fr_detfr(frame_ptr) \
+ MB_frameitem(frame_ptr, MB_FRAME_DETFR)
+#define MB_fr_temp_det_bcredoip(frame_ptr) \
+ MB_frameitem(frame_ptr, MB_FRAME_TEMP_DET_BCREDOIP)
+#define MB_fr_temp_det_bcinitfr(frame_ptr) \
+ MB_frameitem(frame_ptr, MB_FRAME_TEMP_DET_BCINITFR)
+
+
+#define MB_fr_succip(frame_ptr) \
+ MB_frameitem(frame_ptr, MB_FRAME_SUCCIP)
+#define MB_fr_succfr(frame_ptr) \
+ ((MB_Word *) MB_frameitem(frame_ptr, MB_FRAME_SUCCFR))
+#define MB_fr_bcretip(frame_ptr) \
+ MB_frameitem(frame_ptr, MB_FRAME_BCRETIP)
+#define MB_fr_bcinitfr(frame_ptr) \
+ MB_frameitem(frame_ptr, MB_FRAME_BCINITFR)
+
+#define MB_frame_size(frame_ptr) \
+ (frame_ptr - (MB_Word *) MB_fr_prevfr(frame_ptr))
/**************************************************************/
/* tags */
#include "mercury_tags.h"
#define MB_mktag(t) MR_mktag(t)
-#define MB_mkbody(b) MR_mkbody(b)
-#define MB_tag(t) MR_tag(t)
+#define MB_mkbody(p) MR_mkbody(p)
+#define MB_tag(w) MR_tag(w)
#define MB_body(w,t) MR_body(w,t)
-#define MB_mkword(t,b) MR_mkword(t,b)
+#define MB_mkword(t,p) MR_mkword(t,p)
#define MB_strip_tag(w) MR_strip_tag(w)
+#define MB_field(t, w, i) MR_field(t,w,i)
#endif /* MB_INTERFACE_H */
Index: bytecode/mb_interface_stub.c
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_interface_stub.c,v
retrieving revision 1.1
diff -u -r1.1 mb_interface_stub.c
--- bytecode/mb_interface_stub.c 2001/02/01 05:20:28 1.1
+++ bytecode/mb_interface_stub.c 2001/02/08 04:30:49
@@ -1,5 +1,5 @@
/*
-** Copyright (C) 2000-2001 The University of Melbourne.
+** Copyright (C) 2001 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.
**
@@ -11,18 +11,63 @@
#include "mercury_imp.h"
#include "mb_interface.h"
-/* Define the return to deterministic bytecode stub */
MR_define_extern_entry(MB_native_return_det_stub);
+MR_define_extern_entry(MB_native_return_temp_det_stub);
+MR_define_extern_entry(MB_native_return_temp_nondet_stub);
+MR_define_extern_entry(MB_native_return_nondet_stub);
MR_BEGIN_MODULE(mb_interface_stub)
MR_init_entry_ai(MB_native_return_det_stub);
+ MR_init_entry_ai(MB_native_return_temp_det_stub);
+ MR_init_entry_ai(MB_native_return_temp_nondet_stub);
+ MR_init_entry_ai(MB_native_return_nondet_stub);
MR_BEGIN_CODE
+/* Define the return to deterministic bytecode stub after calling a det proc */
MR_define_entry(MB_native_return_det_stub);
{
MR_Code *ret_addr;
MR_save_registers();
ret_addr = MB_bytecode_return_det();
+ MR_restore_registers();
+ MR_GOTO(ret_addr);
+ }
+
+/*
+** Define the return to deterministic bytecode through a temp nondet stack
frame
+** pushed by a det procedure
+*/
+MR_define_entry(MB_native_return_temp_det_stub);
+ {
+ MR_Code *ret_addr;
+ MR_save_registers();
+ ret_addr = MB_bytecode_return_temp_det();
+ MR_restore_registers();
+ MR_GOTO(ret_addr);
+ }
+
+/*
+** Define the return to deterministic bytecode through a temp nondet stack
frame
+** pushed by a nondet procedure
+*/
+MR_define_entry(MB_native_return_temp_nondet_stub);
+ {
+ MR_Code *ret_addr;
+ MR_save_registers();
+ ret_addr = MB_bytecode_return_temp_nondet();
+ MR_restore_registers();
+ MR_GOTO(ret_addr);
+ }
+
+/*
+** Define the return to deterministic bytecode through a temp nondet stack
frame
+** pushed by a nondet procedure
+*/
+MR_define_entry(MB_native_return_nondet_stub);
+ {
+ MR_Code *ret_addr;
+ MR_save_registers();
+ ret_addr = MB_bytecode_return_nondet();
MR_restore_registers();
MR_GOTO(ret_addr);
}
Index: bytecode/mb_machine.c
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_machine.c,v
retrieving revision 1.2
diff -u -r1.2 mb_machine.c
--- bytecode/mb_machine.c 2001/02/01 05:20:28 1.2
+++ bytecode/mb_machine.c 2001/02/09 06:16:46
@@ -5,49 +5,19 @@
**
*/
-/* XXX: make this variable */
-#define MAX_CODE_SIZE 10000
-#define INIT_CODE_SIZE 10000
-#define INIT_CODE_DATA 100000
-#define INIT_DET_SIZE 10000
-#define INIT_NONDET_SIZE 10000
-#define INIT_CALLSTACK_SIZE 500
-#define INIT_LABELSTACK_SIZE 1000
-
/* Imports */
#include "mercury_imp.h"
-#include <assert.h>
-#include <stdio.h>
-#include <string.h>
-
-#include "mb_bytecode.h"
-#include "mb_disasm.h"
-#include "mb_interface.h"
#include "mb_machine.h"
-#include "mb_machine_def.h"
-#include "mb_mem.h"
-#include "mb_stack.h"
+#include "mb_interface.h"
+#include "mb_machine_def.h"
+#include "mb_module.h"
/* Exported definitions */
-/* Set new stack vars to this help find bugs */
-#define CLOBBERED 0xbadbad00
-
-#define CLOBBERPICKUPS 0 /* clobber reg after pickup */
-#define CLOBBERPLACES 0 /* clobber slot after place */
-#define CLOBBERSTACK 1 /* reset new stack vars */
-
-#define FILEVERSION 9
-
/* Local declarations */
-static MB_Bool dispatch(MB_Byte bc_id, MB_Machine_State *ms);
-
-static void instr_do_redo (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static void instr_do_fail (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-
/* Implementation */
/* Get the next instruction pointer */
@@ -61,12 +31,29 @@
void
MB_native_return_set(MB_Machine_State *ms, MB_Native_Addr native_return)
{
+#if 0
+ MB_SAY("Returning to %p", native_return);
+ MB_SAY("MB_succip is %p (%s)",
+ MB_succip,
+ (MB_succip == MB_native_get_return_temp_det()) ?
+ "temp det return" :
+ (MB_succip == MB_native_get_return_temp_nondet()) ?
+ "temp nondet return" :
+ (MB_succip == MB_native_get_return_nondet()) ?
+ "nondet return" :
+ (MB_succip == MB_native_get_return_det()) ?
+ "det return" : "unknown");
+#endif
+
+ MB_ip_set(ms, MB_CODE_NATIVE_RETURN);
ms->native_return = native_return;
}
MB_Native_Addr
MB_native_return_get(MB_Machine_State * ms)
{
+ assert(ms->ip == MB_CODE_NATIVE_RETURN);
+
return ms->native_return;
}
@@ -76,13 +63,7 @@
if (MB_ip_special(new_ip)) {
switch ((MB_Word) new_ip) {
case (MB_Word) MB_CODE_DO_FAIL:
- instr_do_fail(ms, NULL);
- break;
-
case (MB_Word) MB_CODE_DO_REDO:
- instr_do_redo(ms, NULL);
- break;
-
case (MB_Word) MB_CODE_NATIVE_RETURN:
ms->ip = new_ip;
break;
@@ -109,8 +90,6 @@
{
MB_Bytecode_Addr ip = MB_ip_get(ms);
- MB_SAY("Hello from proc_var_init");
-
if (!MB_ip_normal(ip)) return;
/* Check that we are actually in a procedure and not just entering one*/
@@ -120,14 +99,17 @@
ms->cur_proc.is_det = MB_code_get_det(ip);
ms->cur_proc.var = (ms->cur_proc.is_det == MB_ISDET_YES)
- ? &(MB_stackitem(MB_DETFRAME_SIZE+1))
- : &(MB_frameitem(MB_FRAME_SIZE));
-
- } else {
- MB_SAY(" not getting proc det of unentered procedure");
+ ? &(MB_stackvar(0))
+ : &(MB_framevar(0));
}
}
+MB_Bool
+MB_proc_is_det(MB_Machine_State* ms)
+{
+ return ms->cur_proc.is_det == MB_ISDET_YES;
+}
+
/*
** Get a variable from the appropriate mercury stack
**
@@ -162,1595 +144,61 @@
void
MB_initialstackframe_set(MB_Machine_State *ms, MB_Word *frame)
{
- MB_SAY("'spector gadget %08x\n", frame);
assert(ms->initial_stack == NULL);
ms->initial_stack = frame;
}
-
-/* Add a temporary det stack frame */
-MB_Word
-MB_frame_temp_det_push(MB_Machine_State *ms, MB_Word redoip)
-{
- MB_fatal("MB_frame_temp_det_push not implemented yet");
- return 0;
-#if 0
- MB_Word maxfr = MB_maxfr_get(ms);
- MB_Word prevfr = maxfr;
-
- maxfr += MB_FRAME_TEMP_DET_SIZE;
- MB_maxfr_set(ms, maxfr);
-
- MB_frame_max_set(ms, MB_FRAME_PREVFR, prevfr);
- MB_frame_max_set(ms, MB_FRAME_REDOIP, redoip);
- MB_frame_max_set(ms, MB_FRAME_REDOFR, MB_curfr_get(ms));
- MB_frame_max_set(ms, MB_FRAME_DETFR, MB_stack_size(&ms->det.stack));
-
- return maxfr;
-#endif
-}
-
-/* Add a temporary stack frame */
-MB_Word
-MB_frame_temp_push(MB_Machine_State *ms, MB_Word redoip)
-{
- MB_fatal("MB_frame_temp_push not implemented yet");
- return 0;
-#if 0
- if (ms->cur_proc.detism == MB_CUR_DET) {
- return MB_frame_temp_det_push(ms, redoip);
- } else {
- MB_Word maxfr = MB_maxfr_get(ms);
- MB_Word prevfr = maxfr;
-
- maxfr += MB_FRAME_TEMP_SIZE;
- MB_maxfr_set(ms, maxfr);
-
- MB_frame_max_set(ms, MB_FRAME_PREVFR, prevfr);
- MB_frame_max_set(ms, MB_FRAME_REDOIP, redoip);
- MB_frame_max_set(ms, MB_FRAME_REDOFR, MB_curfr_get(ms));
-
- return maxfr;
- }
-#endif
-}
-
-/* Add a stack frame */
-MB_Word
-MB_frame_push(MB_Machine_State *ms, MB_Word redoip,
- MB_Word succip, MB_Word vars, MB_Word temps)
-{
- MB_fatal("MB_frame_temp_push not implemented yet");
- return 0;
-#if 0
- MB_Word maxfr = MB_maxfr_get(ms);
- MB_Word prevfr = maxfr;
- MB_Word succfr = MB_curfr_get(ms);
-
- maxfr += MB_FRAME_SIZE + vars + temps;
-
- MB_maxfr_set(ms, maxfr);
- MB_curfr_set(ms, maxfr);
-
- MB_frame_cur_set(ms, MB_FRAME_NUMVARS, vars);
- MB_frame_cur_set(ms, MB_FRAME_REDOIP, redoip);
- MB_frame_cur_set(ms, MB_FRAME_PREVFR, prevfr);
- MB_frame_cur_set(ms, MB_FRAME_SUCCIP, succip);
- MB_frame_cur_set(ms, MB_FRAME_SUCCFR, succfr);
- MB_frame_cur_set(ms, MB_FRAME_REDOFR, MB_curfr_get(ms));
-
- return maxfr;
-#endif
-}
-
-/* Get/set a variable in the current stack frame variable list */
-void
-MB_frame_var_set(MB_Machine_State *ms, MB_Word idx, MB_Word val)
-{
- MB_fatal("MB_frame_var_set not implemented yet");
-#if 0
- MB_stack_poke(&ms->nondet.stack,
- MB_curfr_get(ms) - MB_FRAME_SIZE - idx, val);
-#endif
-}
-/* Get/set a variable in the current stack frame variable list */
-MB_Word
-MB_frame_var_get(MB_Machine_State *ms, MB_Word idx)
-{
- MB_fatal("MB_frame_var_get not implemented yet");
- return 0;
-#if 0
- return MB_stack_peek(&ms->nondet.stack,
- MB_curfr_get(ms) - MB_FRAME_SIZE - idx);
-#endif
-}
-/* --------------------------------------------------------------------------
*/
-static void instr_invalid (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_enter_proc (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_endof_proc (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_enter_disjunction (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_endof_disjunction (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_enter_disjunct (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_endof_disjunct (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_enter_switch (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_enter_switch_arm (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_endof_switch_arm (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_endof_switch (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_enter_if (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_enter_then (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_endof_then (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-/* instr_enter_else is identical to enter_then */
-static void instr_endof_if (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_enter_negation (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_endof_negation_goal (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_endof_negation (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_enter_commit (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_endof_commit (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_assign (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_test (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_construct (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_deconstruct (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_place (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_pickup (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_call (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_higher_order_call (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_builtin_binop (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_builtin_bintest (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_builtin_unop (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_builtin_untest (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_semidet_success (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_semidet_success_check (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_do_redo (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_do_fail (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_noop (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-static void instr_notdone (MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca);
-
-/* return true if a construction succeeds */
-static MB_Word do_construct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
- MB_Word list_length, MB_Short *var_list);
-
-/* return true if a deconstruction succeeds */
-static MB_Bool do_deconstruct(MB_Machine_State *ms, const MB_Cons_id *cid,
- MB_Word var, MB_Word list_length, MB_Short *var_list);
-static MB_Bool do_deconstruct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
- MB_Word val, MB_Word list_length, MB_Short *var_list);
-
-/* XXX det and nondet conditions (ite / disjunct / commit) all use the same
-** [would require modifying bytecode ids?]
-*/
-
-/*typedef void (MB_Instruction_Handler)(MB_Machine_State *,
- const MB_Bytecode_Arg *);
-*/
-
-typedef void (*MB_Instruction_Handler) (MB_Machine_State *,
- const MB_Bytecode_Arg *);
-
-/* XXX ORDER: relies on the order of the definitions */
-static MB_Instruction_Handler instruction_table[] = {
- instr_invalid, /* enter_pred */
- instr_invalid, /* endof_pred */
- instr_enter_proc,
- instr_endof_proc,
- instr_noop, /* label */
- instr_enter_disjunction,
- instr_endof_disjunction,
- instr_enter_disjunct,
- instr_endof_disjunct,
- instr_enter_switch,
- instr_endof_switch,
- instr_enter_switch_arm,
- instr_endof_switch_arm,
- instr_enter_if,
- instr_enter_then,
- instr_endof_then,
- instr_endof_if,
- instr_enter_negation,
- instr_endof_negation,
- instr_enter_commit,
- instr_endof_commit,
- instr_assign,
- instr_test,
- instr_construct,
- instr_deconstruct,
- instr_notdone, /* XXX complex construct */
- instr_notdone, /* XXX complex deconstruct */
- instr_place,
- instr_pickup,
- instr_call,
- instr_higher_order_call,
- instr_builtin_binop,
- instr_builtin_unop, /* XXX unop */
- instr_builtin_bintest,
- instr_builtin_untest, /* XXX unop test */
- instr_semidet_success,
- instr_semidet_success_check,
- instr_do_redo, /* fail */
- instr_noop, /* context */
- instr_notdone, /* not supported */
- instr_enter_then, /* enter_else (identical to enter_then) */
- instr_endof_negation_goal
-};
-
-static void
-instr_invalid(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("Invalid instruction encountered");
-}
-
-
-/* Enter/exit procedure */
-static void
-instr_enter_proc(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- switch (bca->enter_proc.det) {
- case MB_DET_SEMIDET:
- MB_fatal("semidet");
-
- case MB_DET_DET: {
- MB_Word detframe_size =
- bca->enter_proc.temp_count +
- bca->enter_proc.list_length +
- MB_DETFRAME_SIZE;
-
- /*
- ** Save the initial stack frame if this function is
- ** going to be the one that returns to native code
- */
- MB_SAY( "MB_sp: %08x\n"
- "initialstackframe: %08x\n",
- MB_sp,
- ms->initial_stack);
-
- if (MB_initialstackframe_get(ms) == NULL) {
- MB_initialstackframe_set(ms, MB_sp);
- }
-
- MB_incr_sp(detframe_size);
-
- /* save succip */
- MB_stackitem(MB_DETFRAME_SUCCIP) = (MB_Word) MB_succip;
-
- MB_ip_set(ms, MB_ip_get(ms) + 1);
-
- break;
- }
- case MB_DET_MULTIDET:
- case MB_DET_NONDET: {
-
- MB_fatal("enter_proc/multidet,nondet");
-
- #if 0
- MB_frame_push(ms,
- MB_CODE_DO_FAIL,
- MB_succip_get(ms),
- bca->enter_proc.list_length,
- bca->enter_proc.temp_count);
-
- MB_ip_set(ms, MB_ip_get(ms) + 1);
- #endif
-
- break;
- }
- /* XXX Other options */
- default:
- instr_notdone(ms, NULL);
- }
-
- /* set procedure detism info & variable stack pointer */
- MB_proc_var_init(ms);
-
- #if CLOBBERSTACK
- {
- MB_Word i;
- MB_Word count = bca->enter_proc.list_length +
- bca->enter_proc.temp_count;
- for (i = 0; i < count; i++) {
- MB_var_set(ms, i, CLOBBERED + i);
- }
- }
- #endif
-#if 0
- if (MB_model_semi(bca->enter_proc.det)) {
- /*
- ** If a semidet procedure then mark our success slot as failure
- ** until we know otherwise.
- */
- MB_temp_set(ms, MB_SEMIDET_SUCCESS_SLOT, MB_SEMIDET_FAILURE);
-
- /*
- ** Also push a failure context in case fail is encountered
- */
- MB_frame_temp_push(ms, bca->enter_proc.end_label.addr);
- }
-#endif
-}
-
-static void
-instr_endof_proc(MB_Machine_State *ms, const MB_Bytecode_Arg *endof_bca)
-{
- /* get the current proc */
- MB_Bytecode_Arg *bca =
- MB_code_get_arg(endof_bca->endof_proc.proc_start);
-
- switch (bca->enter_proc.det) {
- case MB_DET_SEMIDET:
- MB_fatal("endof semidet");
-#if 0
- /* put the success indicator into a register */
- MB_reg_set(ms, MB_SEMIDET_SUCCESS_REG,
- MB_temp_get(ms, MB_SEMIDET_SUCCESS_SLOT));
-
- /* remove the failure context */
- MB_maxfr_pop(ms);
-#endif
-
- case MB_DET_DET: {
- MB_Word detframe_size =
- bca->enter_proc.temp_count +
- bca->enter_proc.list_length +
- MB_DETFRAME_SIZE;
-
- MB_succip = MB_stackitem(MB_DETFRAME_SUCCIP);
-
- /* deallocate stack variables */
- MB_decr_sp(detframe_size);
-
- /* Check whether we should return to native code */
- if (MB_sp == MB_initialstackframe_get(ms)) {
- MB_SAY("trying to go native again");
- MB_native_return_set(ms, MB_succip);
- MB_ip_set(ms, MB_CODE_NATIVE_RETURN);
- } else {
- MB_SAY("just doing an easy bc ret");
- MB_SAY( "MB_sp: %08x\n"
- "initialstackframe: %08x\n",
- MB_sp,
- ms->initial_stack);
- MB_ip_set(ms, MB_succip);
- }
- return;
- }
-#if 0
- case MB_DET_MULTIDET:
- case MB_DET_NONDET: {
- MB_ip_set(ms, MB_frame_cur_get(ms, MB_FRAME_SUCCIP));
- MB_curfr_set(ms, MB_frame_cur_get(ms, MB_FRAME_SUCCFR));
- break;
- }
-#endif
- /* XXX other options */
- default:
- instr_notdone(ms, NULL);
- }
-
- MB_proc_var_init(ms);
-}
-
-static void
-instr_enter_disjunction(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("enter_disjunction");
-#if 0
- /* push a new temp frame */
- MB_frame_temp_push(ms, MB_CODE_INVALID_ADR);
- instr_noop(ms, NULL);
-#endif
-}
-
-static void
-instr_enter_disjunct(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("enter_disjunct");
-#if 0
- /*
- ** set the redo point of the topmost frame (pushed in
- ** enter_disjunction) to the disjunct after the current one
- **
- ** if this is the last disjunct, then remove the top frame instead
- */
- if (bca->enter_disjunct.next_label.addr == MB_CODE_INVALID_ADR) {
- /* remove the top frame */
- MB_maxfr_set(ms, MB_frame_max_get(ms, MB_FRAME_REDOFR));
- } else {
- /* set a new redoip */
- MB_frame_max_set(ms, MB_FRAME_REDOIP,
- bca->enter_disjunct.next_label.addr);
- }
- instr_noop(ms, NULL);
-#endif
-}
-
-static void
-instr_endof_disjunct(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("endof_disjunct");
-#if 0
- /*
- ** a simple jump to the end of the disjunction
- ** if we are coming from a nonlast disjunct then we will
- ** be leaving one or more nondet stack frames so we can backtrack
- ** into the disjunction if we fail later on
- */
- MB_ip_set(ms, bca->endof_disjunct.end_label.addr);
-#endif
-}
-
-static void
-instr_endof_disjunction(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("endof_disjunction");
-#if 0
- /*
- ** do nothing
- */
- instr_noop(ms, NULL);
-#endif
-}
-
-static void
-instr_enter_switch(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- instr_noop(ms, NULL);
-}
-
-static void
-instr_enter_switch_arm(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- /* Check if this deconstruct is going to succeed */
- if (do_deconstruct(ms, &bca->enter_switch_arm.cons_id,
- bca->enter_switch_arm.var, 0, 0))
- {
- /*
- ** If it does succeed, then step into the switch
- */
- instr_noop(ms, NULL);
-
- } else {
- /*
- ** If it fails, go to the next switch arm
- */
- MB_ip_set(ms, bca->enter_switch_arm.next_label.addr);
- }
-}
-
-static void
-instr_endof_switch_arm(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- /* This switch arm has succeeded, now go to the end of the switch */
- MB_ip_set(ms, bca->endof_switch_arm.end_label.addr);
-}
-
-static void
-instr_endof_switch(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- /*
- ** If we get here, no switch arm matched, so trigger a redo
- */
- instr_do_redo(ms, NULL);
-}
-
-static void
-instr_enter_if(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("enter_if");
-#if 0
- /*
- ** push a failure context and save the frame address in a
- ** temp stack slot
- */
- MB_temp_set(ms, bca->enter_if.frame_ptr_tmp,
- MB_frame_temp_push(ms, bca->enter_if.else_label.addr)
- );
-
- instr_noop(ms, NULL);
-#endif
-}
-
-/* enter_else is identical to enter_then */
-/*
-instr_enter_else()
-*/
-static void
-instr_enter_then(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("enter_then");
-#if 0
- MB_Word tempfr = MB_temp_get(ms, bca->enter_then.frame_ptr_tmp);
-
- /* If the frame is on top, can we pop it */
- if (MB_maxfr_get(ms) == tempfr) {
- MB_maxfr_pop(ms);
- } else {
- /* otherwise replace redoip with do_fail, effectively
- * discarding it when the stack gets unwound */
- MB_frame_set(ms,
- tempfr + MB_FRAME_REDOIP,
- MB_CODE_DO_FAIL
- );
- }
-
- instr_noop(ms, NULL);
-#endif
-}
-
-static void
-instr_endof_then(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("endof_then");
-#if 0
- /* jump to the end of the construct */
- MB_ip_set(ms, bca->endof_then.follow_label.addr);
-#endif
-}
-
-static void
-instr_endof_if(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("endof_if");
-#if 0
- /* do nothing */
- instr_noop(ms, NULL);
-#endif
-}
-
-static void
-instr_enter_negation(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("enter_negation");
-#if 0
- /* push a fail context: if the negation fails we want it
- ** to drop through to the end of the negation and succeed
- */
- MB_temp_set(ms, bca->enter_negation.frame_ptr_tmp,
- MB_frame_temp_push(ms, bca->enter_negation.end_label.addr));
-
- instr_noop(ms, NULL);
-#endif
-}
-
-static void
-instr_endof_negation_goal(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("endof_negation_goal");
-#if 0
- /*
- ** the negation has succeeded. Now we want to indicate
- ** failure.
- ** Rewind the stack back to before the negation and do a redo
- */
-
- MB_maxfr_set(ms,
- MB_frame_get(ms, MB_FRAME_PREVFR +
- MB_temp_get(ms, bca->endof_negation_goal.frame_ptr_tmp))
- );
-
- instr_do_redo(ms, NULL);
-#endif
-}
-
-static void
-instr_endof_negation(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("endof_negation");
-#if 0
- /*
- ** the negation failed. remove the temp frame which will
- ** be at the top and continue
- */
- MB_maxfr_pop(ms);
-
- instr_noop(ms, NULL);
-#endif
-}
-
-static void
-instr_enter_commit(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("enter_commit");
-#if 0
- /*
- ** push a new stack frame & save its location in a temp
- ** stack slot
- */
- MB_temp_set(ms, bca->enter_commit.frame_ptr_tmp,
- MB_frame_temp_push(ms, MB_CODE_DO_FAIL));
-
- instr_noop(ms, NULL);
-#endif
-}
-
-static void
-instr_endof_commit(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("endof_commit");
-#if 0
- /*
- ** Unwind the stack back to where it was before the commit
- */
- MB_maxfr_set(ms,
- MB_frame_get(ms, MB_FRAME_PREVFR +
- MB_temp_get(ms, bca->endof_commit.frame_ptr_tmp))
- );
-
- instr_noop(ms, NULL);
-#endif
-}
-
-static void
-instr_assign(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("assign");
-#if 0
- /* copy variable from one slot to another */
- MB_var_set(ms, bca->assign.to_var, MB_var_get(ms,bca->assign.from_var));
-
- instr_noop(ms, NULL);
-#endif
-}
-
-static void
-instr_test(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("test");
-#if 0
- /* test the equality of two variable slots */
- if (MB_var_get(ms, bca->test.var1) == MB_var_get(ms, bca->test.var2)) {
- instr_noop(ms, NULL);
- } else {
- instr_do_redo(ms, NULL);
- }
-#endif
-}
-
-static MB_Word
-do_construct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
- MB_Word list_length, MB_Short *var_list)
-{
- MB_fatal("do_construct_cons");
-#if 0
- const MB_Tag *cons_tag = &cid->opt.cons.tag;
- MB_Word *val = MB_mkword(
- MB_mktag(cons_tag->opt.pair.primary),
- MB_mkbody((MB_Word) NULL));
-
- /* the final value we will put in the reg */
-
- assert(cid->id == MB_CONSID_CONS);
-
- assert(cid->opt.cons.arity == list_length);
-
- switch (cons_tag->id) {
- case MB_TAG_SIMPLE: /* only need a primary tag */
- case MB_TAG_COMPLICATED: /* need primary + remote 2ndary tag */
- {
- /*
- ** The code for these two is virtually identical except
- ** that if it is complicated we need one extra heap
- ** slot for the remote secondary tag
- */
- MB_Word extra = (cons_tag->id == MB_TAG_COMPLICATED)
- ? 1 : 0;
- MB_Word *heap_data;
- MB_Word i;
-
-
- if (list_length + extra) {
- MB_Short *var_list;
-
- /* allocate heap memory */
- heap_data = (MB_Word *) MB_GC_new_array(
- MB_Word, list_length + extra);
-
- /* ensure tag bits aren't used */
- assert(MB_tag((MB_Word) heap_data) == 0);
-
- /* get variable list */
- var_list = (MB_Short *)MB_stack_peek_p(
- &ms->code.data,
- var_list_index);
-
- /* copy variables to allocate heap block */
- for (i = 0; i < list_length; i++) {
- heap_data[i + extra] =
- MB_var_get(ms, var_list[i]);
- }
- } else {
- heap_data = NULL;
- }
-
- /*
- ** copy the secondary tag if we need to
- ** and combine the pointer & tag
- */
- if (cons_tag->id == MB_TAG_COMPLICATED_CONSTANT) {
- heap_data[0] = cons_tag->opt.pair.secondary;
- val = MB_mkword(
- MB_mktag(cons_tag->opt.pair.primary),
- MB_body((MB_Word) heap_data,
- MB_mktag(0)));
- } else {
- val = MB_mkword(
- MB_mktag(cons_tag->opt.primary),
- MB_body((MB_Word) heap_data,
- MB_mktag(0)));
- }
-
- break;
- }
-
- case MB_TAG_COMPLICATED_CONSTANT:
- /* primary + local secondary tag */
- assert(list_length == 0);
- val = MB_mkword(
- MB_mktag(cons_tag->opt.pair.primary),
- MB_mkbody(cons_tag->opt.pair.secondary));
-
- break;
-
- case MB_TAG_ENUM:
- assert(list_length == 0);
- val = MB_mkword(MB_mktag(cons_tag->opt.enum_tag),
- MB_mkbody(0));
- break;
-
- case MB_TAG_NONE:
- default:
- instr_notdone(ms, NULL);
- }
- return (MB_Word) val;
-#endif
- return 0;
-}
-
-static void
-instr_construct(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_Word val;
- /* construct a variable into a slot */
- switch (bca->construct.consid.id) {
- case MB_CONSID_INT_CONST:
- assert(bca->construct.list_length == 0);
- val = bca->construct.consid.opt.int_const;
- break;
-
- case MB_CONSID_STRING_CONST:
- assert(bca->construct.list_length == 0);
- val = (MB_Word) bca->construct.consid.opt.string_const;
- break;
-
- case MB_CONSID_CONS:
- val = do_construct_cons(ms,
- &bca->construct.consid,
- bca->construct.list_length,
- bca->construct.var_list);
- break;
-
- case MB_CONSID_FLOAT_CONST:
- instr_notdone(ms, NULL);
-
- case MB_CONSID_PRED_CONST: {
- MB_fatal("Construct closure not done");
- #if 0
- int i;
-
- MB_Closure *closure = MB_GC_malloc(
- MB_CLOSURE_SIZE(bca->construct.list_length),
- MB_GC_NOT_ATOMIC);
- MB_Short *var_list = (MB_Short *)MB_stack_peek_p(
- &ms->code.data,
- bca->construct.var_list_index);
-
- closure->code_addr = bca->construct
- .consid.opt.pred_const.addr;
- closure->num_hidden_args = bca->construct.list_length;
-
- for (i = 0; i < closure->num_hidden_args; i++) {
- closure->closure_hidden_args[i] =
- MB_var_get(ms, var_list[i]);
- }
-
- val = (MB_Word) closure;
-
- break;
- #endif
- }
-
- case MB_CONSID_CODE_ADDR_CONST:
- case MB_CONSID_BASE_TYPE_INFO_CONST:
- instr_notdone(ms, NULL);
-
- case MB_CONSID_CHAR_CONST:
- val = (MB_Word) bca->construct.consid.opt.char_const.ch;
- break;
-
- default:
- instr_notdone(ms, NULL);
- }
- MB_var_set(ms, bca->construct.to_var, val);
- instr_noop(ms, NULL);
-}
-
-/*
-** returns true if the deconstruction succeeds
-** if a int/string/char const, checks for equality and triggers a redo if it
-** fails.
-** if a functor then deconstructs arguments into variable slots
-*/
-static MB_Bool
-do_deconstruct(MB_Machine_State *ms, const MB_Cons_id *cid, MB_Word var,
- MB_Word list_length, MB_Short *var_list)
-{
- MB_Word var_val = MB_var_get(ms, var);
-
- /* XXX not all deconstructions done */
- switch (cid->id) {
- case MB_CONSID_INT_CONST:
- return (var_val == cid->opt.int_const);
-
- case MB_CONSID_STRING_CONST:
- return (!MB_str_cmp((char *)var_val,
- cid->opt.string_const));
-
- case MB_CONSID_CONS: {
- return do_deconstruct_cons(ms, cid, var_val,
- list_length, var_list);
- }
-
- case MB_CONSID_CHAR_CONST:
- return (var_val == (MB_Word) cid->opt.char_const.ch);
-
- default:
- instr_notdone(ms, NULL);
- }
-
- assert(FALSE);
- return FALSE;
-}
-
-/* returns true if val is equivalent to a construction given by cid */
-static MB_Bool
-do_deconstruct_cons(MB_Machine_State *ms, const MB_Cons_id *cid,
- MB_Word val, MB_Word list_length, MB_Short *var_list)
-{
- const MB_Tag *cons_tag = &cid->opt.cons.tag;
-
- assert(cid->id == MB_CONSID_CONS);
-
- /*
- ** We should either check all variables (eg: deconstruct instruction)
- ** or none of them (eg: switch_arm instruction)
- */
- assert((cid->opt.cons.arity == list_length) || (list_length == 0));
-
- switch (cons_tag->id) {
- case MB_TAG_SIMPLE: /* only need a primary tag */
- case MB_TAG_COMPLICATED: /* need primary + remote 2ndary tag */
- {
- /*
- ** The code for these two is virtually identical except
- ** that if it is complicated we need one extra heap
- ** slot for the remote secondary tag
- */
- MB_Word extra = (cons_tag->id == MB_TAG_COMPLICATED)
- ? 1 : 0;
- MB_Word *heap_data = (MB_Word *)MB_strip_tag(val);
- MB_Word i;
-
- /* check that tags are identical */
- if (cons_tag->id == MB_TAG_COMPLICATED) {
- if ((MB_tag(val) != cons_tag->opt.pair.primary)
- || (heap_data[0] !=
- cons_tag->opt.pair.secondary))
- {
- return FALSE;
- }
- } else {
- if (MB_tag(val) != cons_tag->opt.primary) {
- return FALSE;
- }
- }
-
-
- /* Deconstruct variables */
- if (list_length) {
- /* ensure variables are the same */
- for (i = 0; i < list_length; i++)
- {
- MB_var_set(ms, var_list[i],
- heap_data[i + extra]);
- }
- }
-
- break;
- }
-
- case MB_TAG_COMPLICATED_CONSTANT:
- /* primary + local secondary tag */
- assert(list_length == 0);
- if (val != (MB_Word) MB_mkword(
- MB_mktag(cons_tag->opt.pair.primary),
- MB_mkbody(cons_tag->opt.pair.secondary)))
- {
- return FALSE;
- }
-
- break;
-
- case MB_TAG_ENUM:
- assert(list_length == 0);
- if (val != (MB_Word)
- MB_mkword(MB_mktag(cons_tag->opt.enum_tag),
- MB_mkbody(0)))
- {
- return FALSE;
- }
- break;
-
- case MB_TAG_NONE:
- default:
- instr_notdone(ms, NULL);
- }
-
- return TRUE;
-}
-
-
-static void
-instr_deconstruct(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("deconstruct");
- /* test the equality of a variable in a slot with a given value */
- if (!do_deconstruct(ms, &bca->deconstruct.consid,
- bca->deconstruct.from_var,
- bca->deconstruct.list_length,
- bca->deconstruct.var_list))
- {
- instr_do_redo(ms, NULL);
- } else {
- instr_noop(ms, NULL);
- }
-}
-
-static void
-instr_place(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- /* copy value from var slot to reg */
- MB_reg(bca->place_arg.to_reg) =
- MB_var_get(ms, bca->place_arg.from_var);
-
- #if CLOBBERPLACES
- /* XXX for debugging only */
- MB_var_set(ms, bca->place_arg.from_var, CLOBBERED);
- #endif
-
- /* go to the next instruction */
- instr_noop(ms, NULL);
-}
-
-static void
-instr_pickup(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- /* copy value from reg to var slot */
- MB_var_set(ms, bca->pickup_arg.to_var,
- MB_reg(bca->pickup_arg.from_reg));
-
- #if CLOBBERPICKUPS
- /* XXX for debugging only */
- MB_reg_set(ms, bca->pickup_arg.from_reg, CLOBBERED);
- #endif
-
- /* go to the next instruction */
- instr_noop(ms, NULL);
-}
-
-static void
-instr_call(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- /* Call another procedure */
-
- MB_Bytecode_Addr next_ip = MB_ip_get(ms) + 1;
-
- /* Call bytecode */
- if (!bca->call.addr.is_native) {
- MB_Bytecode_Addr new_addr = bca->call.addr.addr.bc;
- if (new_addr == MB_CODE_INVALID_ADR) {
- MB_util_error("Attempt to call unknown bytecode"
- " %s %s__%s/%d mode %d",
- bca->call.is_func ? "func" : "pred",
- bca->call.module_name,
- bca->call.pred_name,
- (int) bca->call.arity,
- (int) bca->call.mode_num);
- MB_fatal("");
- } else {
- if (MB_ip_normal(new_addr)) {
- /* set the return address to the next instr */
- MB_succip = next_ip;
- /* set the new execution point */
- MB_ip_set(ms, new_addr);
- } else {
- MB_fatal("Unexpected call address"
- " (special address not implemented?)");
- }
- }
-
- /* Call native code */
- } else {
- MB_Native_Addr new_addr = bca->call.addr.addr.native;
- MB_SAY("Attempting to call native code from bytecode");
-
- /* Make sure the address has been looked up */
- if (new_addr == NULL) {
- new_addr = MB_code_find_proc_native(
- bca->call.module_name,
- bca->call.pred_name,
- bca->call.arity,
- bca->call.mode_num,
- bca->call.is_func);
- if (new_addr == NULL) {
- MB_util_error(
- "Warning: proc ref in bytecode"
- " to unknown %s %s__%s/%d mode %d",
- bca->call.is_func ? "func" : "pred",
- bca->call.module_name,
- bca->call.pred_name,
- (int) bca->call.arity,
- (int) bca->call.mode_num);
- MB_fatal("Are you sure the module"
- " was compiled with trace"
- " information enabled?");
- }
-
- /* XXX: Write to constant data */
- bca->call.addr.addr.native = new_addr;
- }
-
- if (ms->cur_proc.is_det == MB_ISDET_YES) {
- /* Push a interface det stack frame */
- MB_incr_sp(MB_DETFRAME_INTERFACE_SIZE);
-
- /* Set success ip to reentry stub */
- MB_succip = MB_native_get_return_det();
-
- /* Save initial stack frame pointer */
- MB_stackitem(MB_DETFRAME_INTERFACE_INITIAL_FRAME)
- = (MB_Word) MB_initialstackframe_get(ms);
-
- /* Save bytecode reentry point */
- MB_stackitem(MB_DETFRAME_INTERFACE_BC_SUCCIP)
- = (MB_Word) next_ip;
-
- /* return to native code at address new_addr */
- MB_ip_set(ms, MB_CODE_NATIVE_RETURN);
- MB_native_return_set(ms, new_addr);
-
- MB_SAY("New ip: %08x\n", ms->ip);
- MB_SAY("native_return: %08x\n", ms->native_return);
- } else {
- MB_fatal("Native calls from nondet code not done");
- }
- }
-}
-
-/*
-**
-** XXX:
-**
-** Why does the call need to know the number of output arguments ???
-**
-** If semidet, do I need to make space for the extra argument or has
-** the mercury compiler already done that ???
-**
-*/
-static void
-instr_higher_order_call(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("higher_order_call");
-#if 0
- MB_Closure *closure = (MB_Closure *)MB_var_get(ms,
- bca->higher_order_call.pred_var);
- /*
- ** shift the input arguments to the right so we can insert the
- ** arguments inside the closure
- */
- if (bca->higher_order_call.in_var_count != 0) {
- signed int i = closure->num_hidden_args;
- signed int j = i + bca->higher_order_call.in_var_count;
- for (; i >= 1; i--, j--) {
- MB_reg_set(ms, j, MB_reg_get(ms, i));
- }
- }
- /*
- ** Now insert the hidden arguments
- */
- if (closure->num_hidden_args) {
- signed int i;
- MB_Word num_hidden_args = closure->num_hidden_args;
- for (i = 1; i <= num_hidden_args; i++) {
- MB_reg_set(ms, i, closure->closure_hidden_args[i-1]);
- }
- }
-
- /*
- ** Do the actual call
- */
-
- /* set the return address to the next instruction */
- MB_succip_set(ms, MB_ip_get(ms) + 1);
-
- /* set the new execution point */
- MB_ip_set(ms, closure->code_addr);
-#endif
-}
-/* --------------------------------------------------------------------------
*/
-
-static MB_Word binop_add (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_sub (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_mul (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_div (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_mod (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_lshift (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_rshift (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_and (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_or (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_xor (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_logand (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_logor (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_eq (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_ne (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_lt (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_gt (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_le (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_ge (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word binop_bad (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-
-
-typedef MB_Word (*MB_Instruction_Binop) (MB_Machine_State *,
- const MB_Bytecode_Arg *);
-/*
-** XXX ORDER Currently we depend on the order of elements in the table.
-*/
-static MB_Instruction_Binop binop_table[] = {
- binop_add,
- binop_sub,
- binop_mul,
- binop_div,
- binop_mod,
- binop_lshift,
- binop_rshift, /* XXX signed */
- binop_and,
- binop_or,
- binop_xor,
- binop_logand,
- binop_logor,
- binop_eq,
- binop_ne,
- binop_bad, /* array_index */
- binop_bad, /* str_eq */
- binop_bad, /* str_ne */
- binop_bad, /* str_lt */
- binop_bad, /* str_gt */
- binop_bad, /* str_le */
- binop_bad, /* str_ge */
- binop_lt,
- binop_gt,
- binop_le,
- binop_ge,
- binop_bad, /* float_plus */
- binop_bad, /* float_minus */
- binop_bad, /* float_times */
- binop_bad, /* float_divide */
- binop_bad, /* float_eq */
- binop_bad, /* float_ne */
- binop_bad, /* float_lt */
- binop_bad, /* float_gt */
- binop_bad, /* float_le */
- binop_bad, /* float_ge */
- binop_bad /* body */
-};
-
-#define SIMPLEBINOP(name, op) \
- static MB_Word \
- binop_##name(MB_Machine_State *ms, const MB_Bytecode_Arg *bca) \
- { \
- assert(bca->builtin_binop.arg1.id == MB_ARG_VAR); \
- assert(bca->builtin_binop.arg2.id == MB_ARG_VAR); \
- return (MB_Integer)(MB_var_get(ms, \
- bca->builtin_binop.arg1.opt.var)) \
- op (MB_Integer)(MB_var_get(ms, \
- bca->builtin_binop.arg2.opt.var)); \
- }
-
-SIMPLEBINOP(add, +)
-SIMPLEBINOP(sub, -)
-SIMPLEBINOP(mul, *)
-SIMPLEBINOP(div, /)
-SIMPLEBINOP(mod, %)
-SIMPLEBINOP(lshift, <<)
-SIMPLEBINOP(rshift, >>)
-SIMPLEBINOP(and, &)
-SIMPLEBINOP(or, |)
-SIMPLEBINOP(xor, ^)
-SIMPLEBINOP(logand, &&)
-SIMPLEBINOP(logor, ||)
-SIMPLEBINOP(eq, ==)
-SIMPLEBINOP(ne, !=)
-SIMPLEBINOP(lt, <)
-SIMPLEBINOP(gt, >)
-SIMPLEBINOP(le, <=)
-SIMPLEBINOP(ge, >=)
-
-
-static MB_Word
-binop_bad(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("Unsupported binop\n");
- return 0;
-}
-
-
-
-static void
-instr_builtin_binop(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_Byte binop = bca->builtin_binop.binop;
- if (binop < (sizeof(binop_table)/sizeof(binop_table[0]))) {
- MB_var_set(ms,
- bca->builtin_binop.to_var,
- binop_table[bca->builtin_binop.binop](ms, bca));
-
- instr_noop(ms, NULL);
- } else {
- MB_fatal("Invalid binop");
- }
-}
-static void
-instr_builtin_bintest(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("builtin_bintest");
-#if 0
- MB_Byte binop = bca->builtin_binop.binop;
- if (binop < (sizeof(binop_table)/sizeof(binop_table[0]))) {
- if (binop_table[bca->builtin_binop.binop](ms, bca)) {
- /* If successful, just go to the next instr */
- instr_noop(ms, NULL);
- } else {
- /* otherwise follow the failure context */
- /*instr_do_fail(ms, NULL);*/
- instr_do_redo(ms, NULL);
- }
- } else {
- MB_fatal("Invalid bintest");
- }
-#endif
-}
-/* --------------------------------------------------------------------------
*/
-static MB_Word unop_bad (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word unop_bitwise_complement
- (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-static MB_Word unop_not (MB_Machine_State*ms,const MB_Bytecode_Arg*bca);
-/*
-** XXX ORDER Currently we depend on the order of elements in the table
+/* Add a temporary stack frame with a redo_ip of do_fail
+** Because the do_fail is native code, we can get by with
+** a nativecode-type stack frame
*/
-static MB_Word (*unop_table[])(MB_Machine_State *ms,
- const MB_Bytecode_Arg *bca) =
-{
- unop_bad, /* mktag */
- unop_bad, /* tag */
- unop_bad, /* unmktag */
- unop_bad, /* unmkbody */
- unop_bad, /* cast_to_unsigned */
- unop_bad, /* hash_string */
- unop_bitwise_complement,
- unop_not
-};
-
-#define SIMPLEUNOP(name, op) \
- static MB_Word \
- unop_##name(MB_Machine_State *ms, const MB_Bytecode_Arg *bca) \
- { \
- assert(bca->builtin_unop.arg.id == MB_ARG_VAR); \
- return op (MB_Integer) \
- (MB_var_get(ms, bca->builtin_unop.arg.opt.var)); \
- }
-
-SIMPLEUNOP(bitwise_complement, ~)
-SIMPLEUNOP(not, !)
-
-static MB_Word
-unop_bad(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("Unsupported unop\n");
- return 0;
-}
-
-static void
-instr_builtin_unop(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("builtin_unop");
-#if 0
- MB_Byte unop = bca->builtin_unop.unop;
-
- /* XXX until I learn properly what unary operations are */
- instr_notdone(ms, NULL);
-
- if (unop < (sizeof(unop_table)/sizeof(unop_table[0]))) {
- MB_var_set(ms,
- bca->builtin_unop.to_var,
- unop_table[bca->builtin_unop.unop](ms, bca));
-
- instr_noop(ms, NULL);
- } else {
- MB_fatal("Invalid unop");
- }
-#endif
-}
-
-
-static void
-instr_builtin_untest(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
+void
+MB_frame_temp_push_do_fail(MB_Machine_State *ms)
{
- MB_fatal("builtin_untest");
-#if 0
- instr_notdone(ms, NULL);
-#endif
-}
+ MB_Word *prevfr = MB_maxfr;
-/* --------------------------------------------------------------------- */
-static void
-instr_semidet_success(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("semidet_success");
-#if 0
- MB_temp_set(ms, MB_SEMIDET_SUCCESS_SLOT, MB_SEMIDET_SUCCESS);
+ if (ms->cur_proc.is_det) {
- instr_noop(ms, NULL);
-#endif
-}
+ MB_maxfr += MR_DET_TEMP_SIZE;
-static void
-instr_semidet_success_check(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("semidet_success_check");
-#if 0
- if (MB_reg_get(ms, MB_SEMIDET_SUCCESS_REG) != MB_SEMIDET_SUCCESS) {
- instr_do_redo(ms, NULL);
+ MB_fr_prevfr(MB_maxfr) = prevfr;
+ MB_fr_redoip(MB_maxfr) = (MB_Word) MB_native_get_do_fail();
+ MB_fr_redofr(MB_maxfr) = (MB_Word) MB_curfr;
+ MB_fr_detfr(MB_maxfr) = (MB_Word) MB_sp;
} else {
- instr_noop(ms, NULL);
- }
-#endif
-}
-
-static void
-instr_do_redo(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("do_redo");
-#if 0
- MB_SAY("setting redo -> %d", MB_frame_max_get(ms, MB_FRAME_REDOIP));
- MB_ip_set(ms, MB_frame_max_get(ms, MB_FRAME_REDOIP));
- MB_curfr_set(ms, MB_frame_max_get(ms, MB_FRAME_REDOFR));
-
- MB_SAY("checking proc", MB_frame_max_get(ms, MB_FRAME_REDOIP));
- MB_proc_var_init(ms);
- MB_SAY("checked proc", MB_frame_max_get(ms, MB_FRAME_REDOIP));
-#endif
-}
+ MB_maxfr += MR_NONDET_TEMP_SIZE;
-static void
-instr_do_fail(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("do_fail");
-#if 0
- MB_maxfr_pop(ms);
- instr_do_redo(ms, bca);
-#endif
-}
-
-static void
-instr_noop(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- /* increment instruction pointer */
- MB_ip_set(ms, MB_ip_get(ms) + 1);
-}
-
-static void
-instr_notdone(MB_Machine_State *ms, const MB_Bytecode_Arg *bca)
-{
- MB_fatal("notdone");
-#if 0
- /* invalid instruction */
- MB_fatal("That instruction is not implemented yet\n");
- instr_noop(ms, NULL);
-#endif
-}
-
-/*
-** Execute the current instruction. Returns false if instruction could
-** not be executed
-*/
-static MB_Bool
-dispatch(MB_Byte bc_id, MB_Machine_State *ms)
-{
- MB_Bytecode_Addr ip = MB_ip_get(ms);
-
- if (bc_id < sizeof(instruction_table) / sizeof(instruction_table[0])) {
- instruction_table[bc_id](ms, MB_code_get_arg(ip));
- return TRUE;
+ MB_fr_prevfr(MB_maxfr) = prevfr;
+ MB_fr_redoip(MB_maxfr) = (MB_Word) MB_native_get_do_fail();
+ MB_fr_redofr(MB_maxfr) = (MB_Word) MB_curfr;
}
-
- return FALSE;
-}
-
-/* Single step execute */
-void
-MB_step(MB_Machine_State *ms)
-{
- MB_fatal("Untested step");
-#if 0
- MB_Word ip = MB_ip_get(ms);
-
- MB_Byte bc_id = MB_code_get_id(ms, ip);
- if (!dispatch(bc_id, ms)) {
- MB_fatal("Invalid instruction encountered\n");
- instr_noop(ms, NULL);
- }
-#endif
}
+/* Add a temporary stack frame */
void
-MB_step_over(MB_Machine_State *ms)
+MB_frame_temp_push(MB_Machine_State *ms, MB_Bytecode_Addr redoip)
{
- MB_fatal("Untested step_over");
-#if 0
- MB_Word ip = MB_ip_get(ms);
- MB_Byte bc_id = MB_code_get_id(ms, ip);
-
- if (ip == MB_CODE_INVALID_ADR) {
- MB_util_error("Attempt to execute invalid code address\n");
- }
+ MB_Word *prevfr = MB_maxfr;
+ if (ms->cur_proc.is_det) {
- switch (bc_id) {
- case MB_BC_call: {
-
- /* If we are about to step into a predicate */
- /* then replace the following bytecode with */
- /* an MB_BC_debug_trap and run until it halts */
- /* then put things back to what they were */
- MB_Byte old_id;
- assert(ip + 1 < MB_code_size(ms));
- old_id = ms->code.id[ip + 1];
+ MB_maxfr += MB_FRAME_TEMP_DET_SIZE;
- ms->code.id[ip + 1] = MB_BC_debug_trap;
- MB_run(ms);
-
- ms->code.id[ip + 1] = old_id;
- break;
- }
- default:
- MB_step(ms);
+ MB_fr_prevfr(MB_maxfr) = prevfr;
+ MB_fr_redoip(MB_maxfr) =
+ (MB_Word) MB_native_get_return_temp_det();
+ MB_fr_redofr(MB_maxfr) = (MB_Word) MB_curfr;
+ MB_fr_detfr(MB_maxfr) = (MB_Word) MB_sp;
+ MB_fr_temp_det_bcredoip(MB_maxfr) = (MB_Word) redoip;
+ MB_fr_temp_det_bcinitfr(MB_maxfr) =
+ (MB_Word) MB_initialstackframe_get(ms);
+ } else {
+ MB_maxfr += MB_FRAME_TEMP_NONDET_SIZE;
+
+ MB_fr_prevfr(MB_maxfr) = prevfr;
+ MB_fr_redoip(MB_maxfr) =
+ (MB_Word) MB_native_get_return_temp_nondet();
+ MB_fr_redofr(MB_maxfr) = (MB_Word) MB_curfr;
+ MB_fr_temp_nondet_bcredoip(MB_maxfr) = (MB_Word) redoip;
}
-#endif
}
-
-/* Run until invalid instruction or debug_trap bytecode encountered */
-void
-MB_run(MB_Machine_State *ms)
-{
- MB_fatal("Untested run");
-#if 0
- do {
- MB_Word ip = MB_ip_get(ms);
-
- MB_Byte bc_id = MB_code_get_id(ms, ip);
- if (!dispatch(bc_id, ms)) {
- switch (bc_id) {
- case MB_BC_debug_trap:
- return;
- }
- MB_util_error(
- "Attempt to execute invalid instruction\n");
- instr_noop(ms, NULL);
- return;
- }
- } while (1);
-#endif
-}
-
-/* --------------------------------------------------------------------- */
-void
-MB_machine_create(MB_Machine_State *ms, MB_Bytecode_Addr new_ip,
- MB_Word *initial_stack)
-{
-
- ms->ip = new_ip;
- ms->initial_stack = initial_stack;
- MB_proc_var_init(ms);
-}
-
-MB_Native_Addr
-MB_machine_exec(MB_Machine_State *ms)
-{
- char buffer[4];
- MB_Word count = 0;
- MB_SAY("Hello from machine_exec");
-
- do {
- MB_Bytecode_Addr ip = MB_ip_get(ms);
-
- if (MB_ip_normal(ip)) {
-
- MB_Byte bc_id = MB_code_get_id(ip);
-
- #if 1
- MB_show_state(ms, stdout);
- MB_SAY("count: %d, execing %p", count++, ip);
- MB_SAY("press enter to continue");
- fgets(buffer, sizeof(buffer), stdin);
- #endif
-
- if (!dispatch(bc_id, ms)) {
- switch (bc_id) {
- case MB_BC_debug_trap:
- return 0;
- }
- MB_util_error("Attempt to execute"
- " invalid instruction\n");
- instr_noop(ms, NULL);
- return 0;
- }
- } else {
- switch ((MB_Word) ip) {
- case (MB_Word) MB_CODE_NATIVE_RETURN:
- MB_SAY("Returning to a native state");
- return MB_native_return_get(ms);
- default:
- MB_SAY("Address %08x", ip);
- MB_fatal("Attempt to execute invalid"
- " address\n");
- }
- }
- } while (1);
-
- return 0;
-}
-
Index: bytecode/mb_machine.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_machine.h,v
retrieving revision 1.2
diff -u -r1.2 mb_machine.h
--- bytecode/mb_machine.h 2001/02/01 05:20:29 1.2
+++ bytecode/mb_machine.h 2001/02/08 04:30:49
@@ -13,28 +13,30 @@
#include <stdio.h>
#include "mb_bytecode.h"
-/*#include "mb_module.h"*/
#include "mb_util.h"
-#include "mb_stack.h"
struct MB_Machine_State_Struct;
typedef struct MB_Machine_State_Struct MB_Machine_State;
/*
-** Returns an instruction describing a pointer to the next instruction
-** Executes some 'special' IPs (eg: redo, fail) & returns their resultant ip
+** Set/get the next execution point
*/
void MB_ip_set(MB_Machine_State *ms, MB_Bytecode_Addr new_ip);
MB_Bytecode_Addr MB_ip_get(MB_Machine_State *ms);
-void MB_native_return_set(MB_Machine_State *ms, MB_Native_Addr return_addr);
+void MB_native_return_set(MB_Machine_State *ms,
+ MB_Native_Addr return_addr);
MB_Native_Addr MB_native_return_get(MB_Machine_State *ms);
/*
** Check which procedure we are in & set variable stack pointer appropriately
+** (Required before MB_var_get and MB_var_set are used)
*/
void MB_proc_var_init(MB_Machine_State *ms);
-/* Get/set a variable on the det stack */
+/* Is the currently execting proc det/semidet */
+MB_Bool MB_proc_is_det(MB_Machine_State* ms);
+
+/* Get/set a variable in the current proc variable list */
MB_Word MB_var_get(MB_Machine_State *ms, MB_Word idx);
void MB_var_set(MB_Machine_State *ms, MB_Word idx, MB_Word value);
@@ -42,51 +44,14 @@
MB_Word *MB_initialstackframe_get(MB_Machine_State *ms);
void MB_initialstackframe_set(MB_Machine_State *ms, MB_Word *stack);
-/* Get/set an entry on the nondet stack, relative to curfr */
-/* index zero is the topmost element */
-MB_Word MB_frame_max_get(MB_Machine_State *ms, MB_Word idx);
-void MB_frame_max_set(MB_Machine_State *ms, MB_Word idx,MB_Word val);
-
-/* Get an entry on the nondet stack */
-MB_Word MB_frame_get(MB_Machine_State *ms, MB_Word idx);
-void MB_frame_set(MB_Machine_State *ms, MB_Word idx, MB_Word val);
-
-/* Add nondet stack frame */
-MB_Word MB_frame_temp_det_push(MB_Machine_State *ms, MB_Word redoip);
-MB_Word MB_frame_temp_push(MB_Machine_State *ms, MB_Word redoip);
-MB_Word MB_frame_push(MB_Machine_State *ms, MB_Word redoip,
- MB_Word succip, MB_Word vars, MB_Word temps);
-
-/* Get/set a variable in the current stack frame variable list */
-MB_Word MB_frame_var_get(MB_Machine_State *ms, MB_Word idx);
-void MB_frame_var_set(MB_Machine_State *ms, MB_Word idx,MB_Word val);
-
-/* Display the current state of the machine */
-void MB_show_state(MB_Machine_State *ms, FILE *fp);
-
-/* Display the call stack of the machine */
-void MB_show_call(MB_Machine_State *ms, FILE *fp);
-
-/* Single step execute */
-void MB_step(MB_Machine_State *ms);
-
-/* Single step execute over predicates */
-void MB_step_over(MB_Machine_State *ms);
-
-/* Run until exception */
-void MB_run(MB_Machine_State *ms);
-
-/*
-** Create a bytecode interpreter machine with an initial bytecode ip of new_ip
-*/
-void MB_machine_create(MB_Machine_State *ms, MB_Bytecode_Addr new_ip,
- MB_Word *initial_stack);
-
/*
-** Execute a bytecode machine until native code invocation required.
-** Return address of native code to return to
+** Add a temporary nondet stack frame
+** Will push a temp nondet or temp det frame automatically
+** (assuming proc_var_init was called)
*/
-MB_Native_Addr MB_machine_exec(MB_Machine_State *ms);
+void MB_frame_temp_push_do_fail(MB_Machine_State *ms);
+void MB_frame_temp_push(MB_Machine_State *ms,
+ MB_Bytecode_Addr MB_redoip);
#endif /* MB_MACHINE_H */
Index: bytecode/mb_machine_def.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_machine_def.h,v
retrieving revision 1.1
diff -u -r1.1 mb_machine_def.h
--- bytecode/mb_machine_def.h 2001/02/01 05:20:29 1.1
+++ bytecode/mb_machine_def.h 2001/02/08 04:30:49
@@ -12,17 +12,31 @@
struct MB_Machine_State_Struct {
- MB_Module *module;
MB_Bytecode_Addr ip; /* next instruction pointer */
/*
** The stack that the most ancestral bytecode function was using.
- ** If a procedure finds that its stack frame is equal to this then
- ** it knows it should return to native code rather than bytecode
+ **
+ ** At entry, each procedure checks to see if initial_stack is
+ ** NULL. If it is, then it replaces it with the current stack
+ ** pointer (MB_sp or MB_maxfr depending on code model)
+ **
+ ** At procedure exit (MB_BC_endof_proc), the procedure checks the
+ ** stack to see whether this invocation was the one that set initfr.
+ ** If it was the one that set initfr, it knows it should return to
+ ** native code
+ ** If it wasn't, then it must have been called by a bytecode proc
+ ** and returns directly to a bytecode address
+ **
*/
MB_Word *initial_stack;
- /* The native code address to return to at finish */
+ /*
+ ** The native code address to return to
+ ** When a procedure wants to call/return to native code, it sets
+ ** ip to MB_CODE_NATIVE_RETURN and native_return to the actual
+ ** native code address to return to
+ */
MB_Native_Addr native_return;
/* The following proc information is all set by MB_proc_type_check() */
@@ -41,27 +55,5 @@
MB_Word *var;
} cur_proc;
};
-
-#include "mercury_std.h"
-
-#if 0
-
-/* When you redo this, try offsetof() instead */
-
-#if (MR_VARIABLE_SIZED > 0)
-# define MB_CLOSURE_SIZE(x) (sizeof(MB_Closure) \
- - sizeof(((MB_Closure *)(NULL))-> \
- closure_hidden_args \
- + sizeof(MB_Word)*(x))
-#else
-# define MB_CLOSURE_SIZE(x) (sizeof(MB_Closure) \
- + sizeof(MB_Word)*(x))
-#endif
-typedef struct {
- MB_Word code_addr;
- MB_Word num_hidden_args;
- MB_Word closure_hidden_args[MR_VARIABLE_SIZED];
-} MB_Closure;
-#endif
#endif /* MB_MACHINE_DEF_H */
Index: bytecode/mb_machine_show.c
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_machine_show.c,v
retrieving revision 1.2
diff -u -r1.2 mb_machine_show.c
--- bytecode/mb_machine_show.c 2001/02/01 05:20:29 1.2
+++ bytecode/mb_machine_show.c 2001/02/08 04:30:49
@@ -6,31 +6,185 @@
**
*/
+/* Imports */
#include "mercury_imp.h"
-/* Imports */
-#include <stdio.h>
-#include <assert.h>
+#include "mb_machine_show.h"
-#include "mb_stack.h"
#include "mb_disasm.h"
#include "mb_interface.h"
-#include "mb_machine.h"
#include "mb_machine_def.h"
-#include "mb_machine_show.h"
+#include "mb_module.h"
/* Exported definitions */
-
void MB_show_state(MB_Machine_State *ms, FILE *fp);
/* Local declarations */
+static void show_regs(MB_Machine_State *ms, FILE *fp);
+static void show_stack(MB_Machine_State *ms, FILE *fp);
-#define NREGS 14
-#define NSTACK 8
+/* Number of registers to display */
+#define NREGS 8
+/* Number of entries in each stack to display */
+#define NSTACK 27
+/* Maximum line length for disassembly */
+#define LINE_LEN 78 /* XXX: make this adjustable */
/* Display the current state of the machine */
-#define LINE_LEN 78 /* XXX: make this adjustable */
+static void
+show_regs(MB_Machine_State *ms, FILE *fp)
+{
+ int i;
+
+ /*
+ ** Show the registers in two columns, like so:
+ ** r0 r4
+ ** r1 r5
+ ** r2 r6
+ ** r3 r7
+ */
+ for (i = 0; i < NREGS; i++) {
+ int j = i / 2 +
+ ((i & 1) ? (NREGS / 2) : 0);
+ fprintf(fp,
+ "reg[%02d] = " MB_FMT_INTWIDE
+ " ("MB_FMT_HEX ") ",
+ j, MB_reg(j), MB_reg(j));
+ if (i & 1) {
+ fprintf(fp, "\n");
+ }
+ }
+ if (!(i & 1)) {
+ fprintf(fp, "\n");
+ }
+
+}
+
+static char *
+get_var_name(MB_Machine_State* ms, MB_Bytecode_Arg *cur_proc, MB_Word *var)
+{
+ static char *var_name = NULL;
+ if (var_name == NULL) {
+ var_name = MB_str_dup("tmp000");
+ }
+
+ if (cur_proc != NULL) {
+ MB_Integer offset = ms->cur_proc.var - var;
+
+ if (offset >= 0) {
+ MB_Integer temp_count = cur_proc->enter_proc.temp_count;
+ MB_Integer var_count = cur_proc->enter_proc.list_length;
+ if (offset < temp_count) {
+ sprintf(var_name+3, "%03d", (int) offset);
+ return var_name;
+ } else if ((offset -= temp_count) < var_count) {
+ return cur_proc->enter_proc.var_info[offset];
+ }
+
+ }
+ }
+
+ return NULL;
+}
+/* Display the top stack entries */
+static void
+show_stack(MB_Machine_State *ms, FILE *fp)
+{
+ int i;
+ int frame_index;
+ MB_Word *thisfr;
+ char det_sym[NSTACK];
+ char nondet_sym[NSTACK][2];
+ MB_Bytecode_Addr ip = MB_ip_get(ms);
+ MB_Bytecode_Arg *cur_proc = MB_ip_normal(ip)
+ ? MB_code_get_arg(
+ MB_code_get_proc_addr(ip))
+ : NULL;
+
+ for (i = 0; i < NSTACK; i++) {
+ /* Indicate variable list */
+ det_sym[i] =
+ (&MB_stackitem(i + 1) == ms->cur_proc.var) ? '>'
+ : ' ';
+
+ /* Indicate variable list */
+ if (&MB_frameitem(MB_maxfr, i) == ms->cur_proc.var) {
+ nondet_sym[i][0] = '[';
+ nondet_sym[i][1] = '>';
+ } else {
+ nondet_sym[i][0] = ' ';
+ nondet_sym[i][1] = ' ';
+ }
+ }
+
+ /* Indicate stack frames */
+ thisfr = MB_maxfr;
+ frame_index = 0;
+ i = 0;
+ do {
+ while (i < frame_index) {
+ if (nondet_sym[i][0] == ' ') {
+ nondet_sym[i][0] = '|';
+ }
+ i++;
+ }
+ i++;
+
+ if ((MB_Word *) MB_fr_prevfr(thisfr) != NULL) {
+ nondet_sym[frame_index][0] = '/';
+ nondet_sym[frame_index][1] = '=';
+ }
+
+ if (frame_index > 0) {
+ nondet_sym[frame_index-1][0] = '[';
+ nondet_sym[frame_index-1][1] = '_';
+ }
+
+ thisfr = (MB_Word *) MB_fr_prevfr(thisfr);
+ frame_index = (&MB_frameitem(MB_maxfr, 0) - thisfr);
+
+ } while ((frame_index < NSTACK) && (thisfr != NULL));
+
+
+ /* Show the stack */
+ fprintf(fp, "\n");
+
+ fprintf(fp, " sp = " MB_FMT_HEX " "
+ " maxfr = " MB_FMT_HEX "\n",
+ (MB_Unsigned) MB_sp,
+ (MB_Unsigned) MB_maxfr);
+
+ for (i = 0; i < NSTACK; i++) {
+ char *var_name;
+ var_name = get_var_name(ms, cur_proc, &MB_stackitem(i + 1));
+ if (var_name == NULL) {
+ var_name = get_var_name(ms, cur_proc,
+ &MB_frameitem(MB_maxfr, i));
+ }
+ if (var_name == NULL) {
+ var_name = "";
+ }
+
+ fprintf(fp,
+ "%cdet[%02d] = " MB_FMT_INTWIDE " ("MB_FMT_HEX ") "
+ "%c%c%p=" MB_FMT_INTWIDE " (" MB_FMT_HEX ") %s\n",
+
+ det_sym[i],
+ (int) i + 1,
+ MB_stackitem(i + 1),
+ MB_stackitem(i + 1),
+
+ nondet_sym[i][0],
+ nondet_sym[i][1],
+ &(MB_frameitem(MB_maxfr, i)),
+ MB_frameitem(MB_maxfr, i),
+ MB_frameitem(MB_maxfr, i),
+ var_name
+ );
+ }
+}
+
void
MB_show_state(MB_Machine_State *ms, FILE *fp)
{
@@ -51,10 +205,10 @@
cur_pred = MB_code_get_pred_addr(ip);
cur_proc = MB_code_get_proc_addr(ip);
- MB_str_bytecode(ms, cur_pred, buffer, sizeof(buffer), 0);
+ MB_str_bytecode(cur_pred, buffer, sizeof(buffer), 0);
fprintf(fp, "%s\n", buffer);
- MB_str_bytecode(ms, cur_proc, buffer, sizeof(buffer), 1);
+ MB_str_bytecode(cur_proc, buffer, sizeof(buffer), 1);
fprintf(fp, "%s\n", buffer);
fprintf(fp, "\n");
@@ -67,62 +221,33 @@
if (MB_ip_special(ip)) {
fprintf(fp, " Special execution address (%p)\n", ip);
} else {
- fprintf(fp, " Invalid execution address\n");
+ fprintf(fp, " Invalid execution address (%p)\n", ip);
}
}
fprintf(fp, "\n");
-
- {
- int i;
- /* Show the registers */
- for (i = 0; i < NREGS; i++) {
- int j = i / 2 +
- ((i & 1) ? (NREGS / 2) : 0);
- fprintf(fp, "reg[%02d] = " MB_FMT_INT" ("MB_FMT_HEX ") ",
- j, MB_reg(j), MB_reg(j));
- if (i & 1) {
- fprintf(fp, "\n");
- }
- }
- if (!(i & 1)) {
- fprintf(fp, "\n");
- }
+ show_regs(ms, fp);
- fprintf(fp, "\n");
-
- /* Show the machine state */
- fprintf(fp, " succip = " MB_FMT_HEX " "
- " 0 = " MB_FMT_HEX "\n",
- (MB_Unsigned) MB_succip,
- (MB_Unsigned) 0);
-
- fprintf(fp, " init_frame = " MB_FMT_HEX " "
- " natv_retun = " MB_FMT_HEX "\n",
- (MB_Unsigned) ms->initial_stack,
- (MB_Unsigned) ms->native_return);
+ fprintf(fp, "\n");
- /* Show the stack */
- fprintf(fp, "\n");
+ /* Show the machine state */
+ fprintf(fp, " succip = " MB_FMT_HEX " "
+ " var_ptr = " MB_FMT_HEX "\n",
+ (MB_Unsigned) MB_succip,
+ (MB_Unsigned) ms->cur_proc.var);
+
+ fprintf(fp, " init_frame = " MB_FMT_HEX " "
+ " natv_retun = " MB_FMT_HEX "\n",
+ (MB_Unsigned) ms->initial_stack,
+ (MB_Unsigned) ms->native_return);
+
+ fprintf(fp, " cur_frame = " MB_FMT_HEX " "
+ " = " MB_FMT_HEX "\n",
+ (MB_Unsigned) MB_curfr,
+ (MB_Unsigned) 0);
- fprintf(fp, " sp = " MB_FMT_HEX " "
- " maxfr = " MB_FMT_HEX "\n",
- (MB_Unsigned) MB_sp,
- (MB_Unsigned) MB_maxfr);
- for (i = 1; i < NSTACK; i++) {
- fprintf(fp, "%cdet[%02d] = " MB_FMT_INT
- " (" MB_FMT_HEX ") "
- "%cnondet[%02d] = " MB_FMT_INT
- " (" MB_FMT_HEX ")\n",
- (&MB_stackitem(i) == ms->cur_proc.var) ?
- '>' : ' ',
- (int) i, MB_stackitem(i), MB_stackitem(i),
- (&MB_frameitem(i) == ms->cur_proc.var) ?
- '>' : ' ',
- (int) i, MB_frameitem(i), MB_frameitem(i));
- }
- }
+ show_stack(ms, fp);
fprintf(fp, "\n");
Index: bytecode/mb_machine_show.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_machine_show.h,v
retrieving revision 1.2
diff -u -r1.2 mb_machine_show.h
--- bytecode/mb_machine_show.h 2001/02/01 05:20:29 1.2
+++ bytecode/mb_machine_show.h 2001/02/08 04:30:49
@@ -11,8 +11,9 @@
#ifndef MB_MACHINE_SHOW_H
#define MB_MACHINE_SHOW_H
-#include <stdio.h>
+#include "mb_basetypes.h"
+#include <stdio.h>
#include "mb_machine.h"
/* Display the current state of the machine */
Index: bytecode/mb_mem.c
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_mem.c,v
retrieving revision 1.2
diff -u -r1.2 mb_mem.c
--- bytecode/mb_mem.c 2001/02/01 05:20:29 1.2
+++ bytecode/mb_mem.c 2001/02/12 01:40:40
@@ -15,104 +15,196 @@
#include "mb_util.h"
/* Exported definitions */
+void *MB_malloc(size_t size);
+void *MB_realloc(void* mem, size_t size);
+void MB_free(void *mem);
+void *MB_GC_malloc(size_t size);
+void *MB_GC_malloc_atomic(size_t size);
+void *MB_GC_realloc(void* mem, size_t size);
+void MB_GC_free(void *mem);
/* Local declarations */
+#ifdef MB_MALLOC_CHECK
+void *block_get(void *mem);
+void block_check(void *block);
+#endif
+
/* Implementation */
-/*
- * Make sure the size of guard_bytes is a multiple of 8 to ensure we
- * don't get unaligned accesses, even on 64-bit architectures.
- */
+#ifdef MB_MALLOC_CHECK
+/*
+** Memory block layout:
+** char guardbytes[]
+** size_t size
+** memory passed to client
+** char guardbytes[]
+**
+** Make sure the size of guard_bytes is a multiple of 8 to ensure we
+** don't get unaligned accesses, even on 64-bit architectures.
+*/
+#define GRANULARITY 8 /* Alignment for block elements expect */
+#define GUARD_VAL 0xa5
+#define GUARD_SIZE sizeof(guard_bytes)
static const unsigned char
-guard_bytes[] = {0xa5,0xa5,0xa5,0xa5,0xa5,0xa5,0xa5,0xa5};
+guard_bytes[] = { GUARD_VAL+0, GUARD_VAL+1, GUARD_VAL+2, GUARD_VAL+3,
+ GUARD_VAL+4, GUARD_VAL+5, GUARD_VAL+6, GUARD_VAL+7 };
-/* Implementation */
+/* Offset of prologue guard bytes */
+#define MEMBLOCK_PREGUARD(block, i) \
+ (((unsigned char *) block)[i])
+
+/* Offset of size field */
+#define MEMBLOCK_SIZE(block) \
+ (* (size_t *) \
+ ((unsigned char *) block \
+ + MB_MULTIPLEOF(GUARD_SIZE, GRANULARITY) \
+ ) \
+ )
+
+/* Offset of memory block */
+/* Offset of size field */
+#define MEMBLOCK_MEM(block) \
+ ( \
+ ((unsigned char *) block \
+ + MB_MULTIPLEOF(GUARD_SIZE, GRANULARITY) \
+ + MB_MULTIPLEOF(sizeof(size_t), GRANULARITY ) \
+ ) \
+ )
+
+/* Offset of epilogue guard bytes */
+#define MEMBLOCK_POSTGUARD(block, i) \
+ ( \
+ (MEMBLOCK_MEM(block) \
+ + MB_MULTIPLEOF(MEMBLOCK_SIZE(block), GRANULARITY) \
+ )[i] \
+ )
+
+/* Total size of memory block */
+#define MEMBLOCK_TOTALSIZE(memsize) \
+ ( MB_MULTIPLEOF(GUARD_SIZE, GRANULARITY) \
+ + MB_MULTIPLEOF(sizeof(size_t), GRANULARITY) \
+ + MB_MULTIPLEOF(memsize, GRANULARITY) \
+ + MB_MULTIPLEOF(GUARD_SIZE, GRANULARITY) \
+ )
-#ifndef MB_NO_GC
+/* Get the actual memory block start */
+void *
+block_get(void *mem)
+{
+ return (unsigned char *) mem
+ - MB_MULTIPLEOF(GUARD_SIZE, GRANULARITY)
+ - MB_MULTIPLEOF(sizeof(size_t), GRANULARITY);
+}
-#include "gc.h"
+/* Checks a memory block for corruption and if not corrupt returns its size */
+void
+block_check(void *block)
+{
+ int i;
-#endif
+ /* Check prologue guard bytes */
+ for (i = 0; i < GUARD_SIZE; i++) {
+ if (MEMBLOCK_PREGUARD(block, i) != guard_bytes[i]) {
+ MB_fatal("mb_mem: block_check:"
+ " memory corruption detected");
+ }
+ }
+ /* Check epilogue guard bytes */
+ for (i = 0; i < GUARD_SIZE; i++) {
+ if (MEMBLOCK_POSTGUARD(block, i) != guard_bytes[i]) {
+ MB_fatal("mb_mem: block_check:"
+ " memory corruption detected");
+ }
+ }
+}
+
void *
MB_malloc(size_t size)
{
- size_t real_size;
- size_t guard_size;
- unsigned char *real_mem, *mem;
-
- guard_size = sizeof(guard_bytes) / sizeof(*guard_bytes);
- real_size = size + 2 * guard_size;
-
- real_mem = malloc(real_size);
- if (real_mem == NULL) {
- MB_fatal("mem.MB_alloc: malloc failed");
+ unsigned char *block= malloc(MEMBLOCK_TOTALSIZE(size));
+
+
+ if (block== NULL) {
+ MB_fatal("MB_malloc failed");
}
+
+ MEMBLOCK_SIZE(block) = size;
+ memcpy(&(MEMBLOCK_PREGUARD(block, 0)), guard_bytes, GUARD_SIZE);
+ memcpy(&(MEMBLOCK_POSTGUARD(block, 0)), guard_bytes, GUARD_SIZE);
- /*
- * Now check all allocated memory for corruption.
- * XXX: Fill this in later...
- */
-
- mem = real_mem + guard_size;
- return mem;
+ return MEMBLOCK_MEM(block);
}
void
MB_free(void *mem)
{
- size_t guard_size;
- unsigned char *real_mem;
+ void* block = block_get(mem);
- /*
- * Check that the memory to be freed was actually allocated.
- * We can't check for still-remaining references to the
- * memory without some sort of memory-marking as done in
- * Hans Boehm's conservative garbage collector.
- */
-
- /*
- * Check all allocated memory for corruption.
- * XXX: Do this later...
- */
-
- guard_size = sizeof(guard_bytes) / sizeof(*guard_bytes);
- real_mem = (unsigned char *) mem - guard_size;
- free(real_mem);
+ block_check(block);
- return;
+ /* Free the memory */
+ free(block);
}
void *
-MB_realloc(void *mem, size_t size)
+MB_realloc(void *mem, size_t new_size)
{
+ void* block = block_get(mem);
- return realloc(mem, size);
-#if 0
- void *new_mem;
+ if (new_size == 0) {
+ MB_free(mem);
+ return NULL;
- /*
- * Check all allocated memory for corruption.
- * XXX: Do this later...
- */
+ } else if (mem == NULL) {
+ return MB_malloc(new_size);
+
+ } else if (MEMBLOCK_SIZE(block) != new_size) {
+ block_check(block);
- new_mem = MB_malloc(size);
- memcpy(new_mem, mem, size);
+ block = realloc(block, MEMBLOCK_TOTALSIZE(new_size));
- /*
- * Check mem was actually allocated.
- * XXX: Do later...
- */
- MB_free(mem);
+ /* Update the size */
+ MEMBLOCK_SIZE(block) = new_size;
- return new_mem;
-#endif
+ /* Redo the guard bytes at the end */
+ memcpy(&MEMBLOCK_POSTGUARD(block, 0), guard_bytes, GUARD_SIZE);
+
+ }
+
+ block_check(block);
+
+ return MEMBLOCK_MEM(block);
+}
+
+#else /* MB_MALLOC_CHECK */
+
+void *
+MB_malloc(size_t size)
+{
+ return malloc(size);
+}
+
+void
+MB_free(void *mem)
+{
+ return free(mem);
+}
+
+void *
+MB_realloc(void *mem, size_t new_size)
+{
+ return realloc(mem, new_size);
}
+#endif /* MB_MALLOC_CHECK */
+
/* ------------------------------------------------------------------------- */
#ifndef MB_NO_GC
+
+#include "gc.h"
void *
MB_GC_malloc(size_t size)
Index: bytecode/mb_mem.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_mem.h,v
retrieving revision 1.2
diff -u -r1.2 mb_mem.h
--- bytecode/mb_mem.h 2001/02/01 05:20:29 1.2
+++ bytecode/mb_mem.h 2001/02/08 04:30:49
@@ -15,6 +15,12 @@
#include "mb_basetypes.h"
+/* Define to convert garbage collection allocations to normal mallocs */
+/* #define MB_NO_GC */
+
+/* Define to add memory corruption checking when allocating/deallocating mem */
+#define MB_MALLOC_CHECK
+
/*
** Do not use MB_malloc() or MB_realloc() directly, unless you want
** to allocate raw memory. Normally you should use the macros
Index: bytecode/mb_module.c
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_module.c,v
retrieving revision 1.1
diff -u -r1.1 mb_module.c
--- bytecode/mb_module.c 2001/02/01 05:20:29 1.1
+++ bytecode/mb_module.c 2001/02/13 05:33:21
@@ -5,30 +5,12 @@
**
*/
-/*
-#include "mercury_layout_util.h"
-#include "mercury_array_macros.h"
-#include "mercury_getopt.h"
-
-#include "mercury_trace.h"
-#include "mercury_trace_internal.h"
-#include "mercury_trace_declarative.h"
-#include "mercury_trace_alias.h"
-#include "mercury_trace_help.h"
-#include "mercury_trace_browse.h"
-#include "mercury_trace_spy.h"
-#include "mercury_trace_tables.h"
-#include "mercury_trace_util.h"
-#include "mercury_trace_vars.h"
-#include "mercury_trace_readline.h"
-*/
-
#include "mb_module.h"
-#include "mb_interface.h"
-#include <assert.h>
#include <string.h>
+#include "mb_interface.h"
#include "mb_mem.h"
+#include "mb_stack.h"
/* XXX: We should remove these fixed limits */
#define MAX_CODE_COUNT 10000
@@ -61,24 +43,6 @@
** XXX: Can only handle 64MB of bytecode data
*/
-#if 0
-#define MB_BCID_MAKE(id, arg) ( ((id) & ((1 << CHAR_BIT) - 1)) | \
- (((MB_Word*)(arg) - code_arg_data) << CHAR_BIT)\
- )
-/* get the bytecode id */
-#define MB_BCID_ID(x) ((x) & ((1<<(CHAR_BIT-1)) - 1))
-
-/* get the determinism flag for the given bytecode */
-#define MB_BCID_ISDET ((1) << (CHAR_BIT-1))
-#define MB_BCID_DET(x) ((x) & MB_BCID_ISDET)
-/* get the bytecode argument pointer */
-#define MB_BCID_ARG(x) ((MB_Bytecode_Arg *) \
- (code_arg_data + \
- ((MB_Unsigned)(x) >> CHAR_BIT)) \
- )
-#else
-
-
#define MB_BCID_MAKE(dest, new_id, new_arg) \
((dest).id = (new_id), \
(dest).is_det = 0, \
@@ -93,8 +57,6 @@
#define MB_BCID_DET_SET(x, det) ((x).is_det = (det))
#define MB_BCID_ARG(x) ((MB_Bytecode_Arg *) (code_arg_data + (x).arg))
-#endif
-
/* XXX: not thread safe */
static MB_Word code_count = 0;
@@ -133,7 +95,7 @@
MB_Stack *label_stack);
static MB_Bool translate_detism(MB_Bytecode_Addr bc, MB_Unsigned number_codes);
static MB_Bool translate_switch(MB_Bytecode_Addr bc, MB_Unsigned number_codes);
-static MB_Bool translate_temps(MB_Bytecode_Addr bc, MB_Unsigned number_codes);
+static MB_Bool translate_vars(MB_Bytecode_Addr bc, MB_Unsigned number_codes);
/* Implementation */
@@ -161,6 +123,7 @@
MB_Word mode_num;
/* location to store the proc to be called */
MB_Code_Addr *target_addr = NULL;
+ MB_Native_Addr *target_native = NULL;
/* Get the information about the procedure to call */
MB_Byte call_id = MB_code_get_id(bc);
@@ -172,6 +135,7 @@
pred_name = call_arg->call.pred_name;
mode_num = call_arg->call.mode_num;
target_addr = &call_arg->call.addr;
+ target_native = NULL;
} else if (call_id == MB_BC_construct) {
MB_Bytecode_Arg *construct_arg =
@@ -179,8 +143,6 @@
if (construct_arg->construct.consid.id ==
MB_CONSID_PRED_CONST)
{
- MB_fatal("Unable to translate predicate constructs");
- #if 0
module_name = construct_arg->construct.
consid.opt.pred_const.module_name;
arity = construct_arg->construct.
@@ -191,28 +153,19 @@
consid.opt.pred_const.pred_name;
mode_num = construct_arg->construct.
consid.opt.pred_const.mode_num;
- target_addr = &construct_arg->construct.
- consid.opt.pred_const.addr;
- #endif
+ target_addr = NULL;
+ target_native = &construct_arg->construct.
+ consid.opt.pred_const.native_addr;
}
}
- if (pred_name != NULL) {
- MB_SAY("Looking for %s %s__%s/%d mode %d",
- (is_func) ? "func" : "pred",
- module_name,
- pred_name,
- arity,
- mode_num);
- }
-
/* Find the predicate start */
if (pred_name != NULL) {
/* First check if we can find it in the bytecode */
- MB_Bytecode_Addr bc_addr = MB_code_find_proc(module_name,
- pred_name, mode_num,
- arity, is_func);
+ MB_Bytecode_Addr bc_addr =
+ MB_code_find_proc(module_name, pred_name,
+ mode_num, arity, is_func);
if (bc_addr == MB_CODE_INVALID_ADR) {
/* Otherwise look in the native code */
@@ -220,32 +173,41 @@
MB_code_find_proc_native(module_name,
pred_name, mode_num, arity, is_func);
- MB_SAY(" Not found in bytecode");
-
- MB_SAY(" Address from native: %08x"
- , native_addr);
-
if (native_addr == NULL) {
+ /*
MB_util_error(
- "Warning: proc ref in bytecode"
+ "Warning: Proc ref in bytecode"
" at %08x to unknown"
- " %s %s__%s/%d mode %d"
- " (will evaluate lazily)",
+ " (will evaluate lazily)\n"
+ " Unknown: %s"
+ " %s__%s/%d mode %d\n"
+ " Are you sure the module"
+ " was compiled with trace"
+ " information enabled?\n",
(int) i,
is_func ? "func" : "pred",
module_name,
pred_name,
(int) arity,
- (int) mode_num);
- MB_util_error("Are you sure the module"
- " was compiled with trace"
- " information enabled?");
+ (int) mode_num
+ );
+ */
+ }
+ if (target_addr != NULL) {
+ target_addr->is_native = TRUE;
+ target_addr->addr.native = native_addr;
}
- target_addr->is_native = TRUE;
- target_addr->addr.native = native_addr;
+ if (target_native != NULL) {
+ *target_native = native_addr;
+ }
} else {
- target_addr->is_native = FALSE;
- target_addr->addr.bc = bc_addr;
+ if (target_addr != NULL) {
+ target_addr->is_native = FALSE;
+ target_addr->addr.bc = bc_addr;
+ }
+ if (target_native != NULL) {
+ *target_native = NULL;
+ }
}
}
}
@@ -362,8 +324,11 @@
bc_id = MB_code_get_id(bc);
if (bc_id == MB_BC_enter_proc) {
switch (MB_code_get_arg(bc)->enter_proc.det) {
- case MB_DET_DET:
+ case MB_DET_FAILURE:
+ case MB_DET_CC_NONDET:
case MB_DET_SEMIDET:
+ case MB_DET_CC_MULTIDET:
+ case MB_DET_DET:
cur_detism = MB_BCID_ISDET;
break;
case MB_DET_MULTIDET:
@@ -390,59 +355,204 @@
/*
** Fill in the variable that each switch arm is using
** Returns TRUE if successful
+**
+** XXX: Can only handle a fixed number of nested switched
*/
static MB_Bool
translate_switch(MB_Bytecode_Addr bc, MB_Unsigned number_codes)
{
+ #define MAXNESTEDSWITCH 32
MB_Unsigned i;
- MB_Bytecode_Arg *cur_switch = NULL;
+ /* Leave the first switch as NULL to trap any errors */
+ MB_Word cur_switch = 0;
+ MB_Bytecode_Arg *switch_ptr[MAXNESTEDSWITCH] = { NULL };
for (i = 0; i < number_codes; i++, bc++) {
switch (MB_code_get_id(bc)) {
case MB_BC_enter_switch:
- cur_switch = MB_code_get_arg(bc);
+ cur_switch++;
+ if (cur_switch >= MAXNESTEDSWITCH) {
+ MB_fatal("Too many nested switches");
+ }
+ switch_ptr[cur_switch] = MB_code_get_arg(bc);
break;
case MB_BC_enter_switch_arm: {
MB_Bytecode_Arg *cur_arg
= MB_code_get_arg(bc);
- cur_arg->enter_switch_arm.var =
- cur_switch->enter_switch.var;
+ cur_arg->enter_switch_arm.var =
+ switch_ptr[cur_switch]
+ ->enter_switch.var;
break;
}
+
+ case MB_BC_endof_switch: {
+ cur_switch--;
+ assert(cur_switch >= 0);
+ break;
+ }
}
}
return TRUE;
} /* translate_switch */
/*
-** Transform temporary stack slot numbers into variable slot numbers
-** for all bytecodes that use a temporary stack slot
+** Transform variable numbers.
+** See mb_interface.h for the det stack layout.
+** Since there is no distinction between vars and temps once loaded (they all
+** use MB_var_[get/set], the var numbers must be incremented by the number
+** of temps
+**
+** Note that translate_switch must already have been called to fill in
+** missing values in enter_switch_arm
+**
** Returns TRUE if successful
*/
-#define XLATTEMP(name) case MB_BC_##name: \
- cur_arg = MB_code_get_arg(bc); \
- cur_arg->name.frame_ptr_tmp += \
- cur_proc_arg->enter_proc.list_length; \
- break;
+
static MB_Bool
-translate_temps(MB_Bytecode_Addr bc, MB_Unsigned number_codes)
+translate_vars(MB_Bytecode_Addr bc, MB_Unsigned number_codes)
{
- MB_Unsigned i;
+ MB_Unsigned j;
+ MB_Unsigned temp_count = 0;
MB_Bytecode_Arg *cur_arg ;
- MB_Bytecode_Arg *cur_proc_arg = NULL;
MB_Word code_size = MB_code_size();
- for (i = 0; i < number_codes; i++, bc++) {
+
+ for (j = 0; j < number_codes; j++, bc++) {
switch (MB_code_get_id(bc)) {
case MB_BC_enter_proc:
- cur_proc_arg = MB_code_get_arg(bc);
+ temp_count = MB_code_get_arg(bc)->
+ enter_proc.temp_count;
+ break;
+
+ case MB_BC_enter_switch:
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->enter_switch.var += temp_count;
break;
- XLATTEMP(enter_if);
- XLATTEMP(enter_then);
- XLATTEMP(enter_negation);
- XLATTEMP(endof_negation_goal);
- XLATTEMP(enter_commit);
+
+ case MB_BC_enter_switch_arm:
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->enter_switch_arm.var += temp_count;
+ break;
+
+ case MB_BC_assign:
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->assign.to_var += temp_count;
+ cur_arg->assign.from_var += temp_count;
+ break;
+
+ case MB_BC_test:
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->test.var1 += temp_count;
+ cur_arg->test.var2 += temp_count;
+ break;
+
+ case MB_BC_construct: {
+ MB_Unsigned i;
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->construct.to_var += temp_count;
+ for (i = 0;
+ i < cur_arg->construct.list_length;
+ i++)
+ {
+ cur_arg->construct.var_list[i] +=
+ temp_count;
+ }
+
+ break;
+ }
+
+ case MB_BC_deconstruct: {
+ MB_Unsigned i;
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->deconstruct.from_var += temp_count;
+ for (i = 0;
+ i < cur_arg->deconstruct.list_length;
+ i++)
+ {
+ cur_arg->deconstruct.var_list[i] +=
+ temp_count;
+ }
+ break;
+ }
+
+ case MB_BC_complex_construct: {
+ MB_Unsigned i;
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->complex_construct.to_var += temp_count;
+ for (i = 0;
+ i < cur_arg->complex_construct
+ .list_length;
+ i++)
+ {
+ cur_arg->complex_construct.var_dir[i]
+ .var += temp_count;
+ }
+ break;
+ }
+
+ case MB_BC_complex_deconstruct: {
+ MB_Unsigned i;
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->complex_deconstruct.from_var +=
+ temp_count;
+ for (i = 0;
+ i < cur_arg->complex_deconstruct
+ .list_length;
+ i++)
+ {
+ cur_arg->complex_deconstruct.var_dir[i]
+ .var += temp_count;
+ }
+ break;
+ }
+
+ case MB_BC_place_arg:
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->place_arg.from_var += temp_count;
+ break;
+
+ case MB_BC_pickup_arg:
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->pickup_arg.to_var += temp_count;
+ break;
+
+ /* XXX: HIGHER This should not need to be here */
+ case MB_BC_higher_order_call:
+ cur_arg = MB_code_get_arg(bc);
+ cur_arg->higher_order_call.pred_var +=
+ temp_count;
+ break;
+
+ #define TRANSLATE_OPARG(oparg) \
+ if ((oparg).id == MB_ARG_VAR) { \
+ (oparg).opt.var += temp_count; \
+ }
+
+ case MB_BC_builtin_binop:
+ cur_arg = MB_code_get_arg(bc);
+ TRANSLATE_OPARG(cur_arg->builtin_binop.arg1);
+ TRANSLATE_OPARG(cur_arg->builtin_binop.arg2);
+ cur_arg->builtin_binop.to_var += temp_count;
+ break;
+
+ case MB_BC_builtin_unop:
+ cur_arg = MB_code_get_arg(bc);
+ TRANSLATE_OPARG(cur_arg->builtin_unop.arg);
+ cur_arg->builtin_unop.to_var += temp_count;
+ break;
+
+ case MB_BC_builtin_bintest:
+ cur_arg = MB_code_get_arg(bc);
+ TRANSLATE_OPARG(cur_arg->builtin_bintest.arg1);
+ TRANSLATE_OPARG(cur_arg->builtin_bintest.arg2);
+ break;
+
+ case MB_BC_builtin_untest:
+ cur_arg = MB_code_get_arg(bc);
+ TRANSLATE_OPARG(cur_arg->builtin_untest.arg);
+ break;
+
}
}
return TRUE;
@@ -455,10 +565,40 @@
MB_Module *
MB_module_load_name(MB_CString_Const module_name)
{
- MB_Module *module;
- MB_CString filename = MB_str_new_cat(module_name, ".mbc");
+ MB_Module *module;
+ MB_CString filename;
+ FILE *fp;
+ char *src;
+ char *dst;
+
+ /* Turn the : and __ into . for the file name*/
+ filename = MB_str_new_cat(module_name, ".mbc");
+ src = filename;
+ dst = filename;
+ do {
+ if (*src == ':') {
+ *dst = '.';
+ } else if (src[0] == '_' && src[1] == '_') {
+ src ++;
+ *dst = '.';
+ } else {
+ *dst = *src;
+ }
+ dst++;
+ src++;
+ } while (*src);
+ *dst = *src;
+
+ fp = fopen(filename, "rb");
- FILE *fp = fopen(filename, "rb");
+ /* Turn the dots back into colons for the module name */
+ src = filename;
+ do {
+ if (*src == '.') {
+ *src = ':';
+ }
+ src++;
+ } while (*src);
module = MB_module_load(module_name, fp);
@@ -476,17 +616,13 @@
{
/* Search for the module */
MB_Word i;
- MB_SAY(" Looking for %s among %d modules", module_name, module_count);
+
for (i = 0; i < module_count; i++) {
- MB_SAY(" Testing module %d", i);
if (!MB_str_cmp(module_name, module_arr[i]->module_name)) {
- MB_SAY(" Module %s found", module_name);
return module_arr[i];
}
}
- MB_SAY(" module %s not found, attempting to load", module_name);
-
/* We didn't find it so load it */
return MB_module_load_name(module_name);
} /* MB_module_get */
@@ -559,6 +695,7 @@
/* Create the new module */
MB_Module *module = MB_GC_NEW(MB_Module);
+
module->pred_index_stack= MB_stack_new((fp == NULL) ? 0 : 64, FALSE);
module->module_name = MB_str_dup(module_name);
@@ -696,7 +833,7 @@
(translate_calls(module_start, module_code_count)) &&
(translate_detism(module_start, module_code_count)) &&
(translate_switch(module_start, module_code_count)) &&
- (translate_temps(module_start, module_code_count)))
+ (translate_vars(module_start, module_code_count)))
{
/* Delete the label stack (we've done all the translations) */
MB_stack_delete(&label_stack);
@@ -706,7 +843,6 @@
MB_fatal("Error reading bytecode file");
}
return NULL;
-
} /* MB_module_load */
@@ -819,12 +955,7 @@
MB_Module *module = MB_module_get(module_name);
MB_Word j;
- MB_SAY(" Looking for %s %s__%s/%d mode %d",
- (is_func) ? "func" : "pred",
- module_name, pred_name, arity, mode_num);
-
if (MB_stack_size(&module->pred_index_stack) == 0) {
- MB_SAY(" No bytecode information for this module");
return MB_CODE_INVALID_ADR;
}
@@ -849,7 +980,6 @@
/* Check if any of the predicates matched */
if (j == MB_stack_size(&module->pred_index_stack)) {
- MB_SAY(" Not found");
return MB_CODE_INVALID_ADR;
}
@@ -875,11 +1005,6 @@
} else if ((bc_id == MB_BC_endof_pred) ||
(bc_id == MB_BC_enter_pred))
{
- MB_SAY("Predicate does not contain "
- "procedure: %s/%d mode %d",
- pred_name,
- (int) arity,
- (int) mode_num);
return MB_CODE_INVALID_ADR;
}
@@ -887,6 +1012,7 @@
return MB_CODE_INVALID_ADR;
}
+
MB_Word *
Index: bytecode/mb_module.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_module.h,v
retrieving revision 1.1
diff -u -r1.1 mb_module.h
--- bytecode/mb_module.h 2001/02/01 05:20:29 1.1
+++ bytecode/mb_module.h 2001/02/08 04:30:49
@@ -33,6 +33,7 @@
/* Ensure a module is loaded */
MB_Module *MB_module_load_name(MB_CString_Const module_name);
MB_Module *MB_module_load(MB_CString_Const module_name, FILE *fp);
+
/* Unload a module */
void MB_module_unload(MB_Module *module);
@@ -82,19 +83,22 @@
/* Allocate memory in the code argument data array */
#define MB_CODE_DATA_ALLOC(type, number) \
- ((type *) (MB_code_data_alloc_words(MB_NUMBLOCKS(sizeof(type)*(number),
sizeof(MB_Word)))))
+ ((type *) (MB_code_data_alloc_words( \
+ MB_NUMBLOCKS(sizeof(type)*(number), sizeof(MB_Word))) \
+ ) \
+ )
MB_Word *MB_code_data_alloc_words(MB_Word num_words);
/*
-** This is only here so pointer arithmetic will work; you shold never need
-** to use any of these fields: the MB_BCID_xxx wrappers in mb_module.c are
-** the only things that should use them
+** This is only defined here so instruction pointers can be incremented; you
should
+** never need to use any of these fields: the MB_BCID_xxx wrappers in
mb_module.c
+** are the only things that should use them
*/
struct MB_BCId_Struct {
MB_Unsigned id : 7;
MB_Unsigned is_det : 1;
- MB_Unsigned arg : MB_WORD_BITS - (7 + 1);
+ MB_Unsigned arg : MR_WORDBITS - (7 + 1);
};
#endif /* MB_MODULE_H */
Index: bytecode/mb_stack.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_stack.h,v
retrieving revision 1.2
diff -u -r1.2 mb_stack.h
--- bytecode/mb_stack.h 2001/02/01 05:20:30 1.2
+++ bytecode/mb_stack.h 2001/02/08 04:30:49
@@ -14,50 +14,51 @@
#include "mb_basetypes.h"
#include "mb_util.h"
+/* Stack structure */
typedef struct MB_Stack_Struct {
MB_Word *data;
MB_Word sp;
- MB_Word max_size: (MB_WORD_BITS-1);
+ MB_Word max_size: (MR_WORDBITS-1);
MB_Word gc : 1;
} MB_Stack;
/*
** Allocates space for a new stack. 'gc' indicates whether the stack region
-** should be allocated with the garbage collector (see mb_mem.h) or with the
-** C malloc (the garbage collector won't follow references from the c malloc
-** area)
+** should be allocated with the conservative garbage collector (see mb_mem.h)
+** with C's malloc (the garbage collector won't follow references from the C
+** malloc area)
**
** For the garbage collector, assumes that data is not atomic
*/
MB_Stack MB_stack_new(MB_Word init_size, MB_Bool gc);
-/* get number of words already pushed on stack */
+/* Get number of words already pushed on stack */
MB_Word MB_stack_size(MB_Stack *s);
-/* pushes a value onto the stack. Return index of pushed word */
+/* Pushes a value onto the stack. Return index of pushed word */
MB_Word MB_stack_push(MB_Stack *s, MB_Word x);
-/* removes a value off the stack */
+/* Removes a value off the stack */
MB_Word MB_stack_pop(MB_Stack *s);
-/* allocates space for multiple places on the stack */
-/* return value is index of lowest word */
+/* Allocates space for multiple places on the stack */
+/* Return value is index of lowest word */
MB_Word MB_stack_alloc(MB_Stack *s, MB_Word num_words);
-/* remove multiple items off the stack */
+/* Remove multiple items off the stack */
void MB_stack_free(MB_Stack *s, MB_Word num_words);
-/* peek at an item at a given stack index */
+/* Peek at an item at a given stack index */
MB_Word MB_stack_peek(MB_Stack *s, MB_Word idx);
-/* peek at an item index items away from the top of the stack */
+/* Peek at an item index items away from the top of the stack */
MB_Word MB_stack_peek_rel(MB_Stack *s, MB_Word idx);
-/* get the address for the item at index
+/* Get the address for the item at index
** NOTE: if you add or remove items, this value could change */
MB_Word *MB_stack_peek_p(MB_Stack *s, MB_Word idx);
-/* get the address for the item at index relative to the top of the stack */
+/* Get the address for the item at index relative to the top of the stack */
MB_Word *MB_stack_peek_rel_p(MB_Stack *s, MB_Word idx);
/* Set the value of an item on the stack */
@@ -66,15 +67,8 @@
/* Set the value of an item on the stack, idx items from the top */
void MB_stack_poke_rel(MB_Stack *s, MB_Word rel_idx, MB_Word value);
-/* deallocate space for the stack */
+/* Deallocate space for the stack */
void MB_stack_delete(MB_Stack *s);
-
-/*
-** Uses the stack to allocate num elements of type, returns pointer to first
-** element (rounds total memory allocated up to a multiple of sizeof(MB_Word))
-*/
-#define MB_STACK_ALLOC(stack, type, num) \
- MB_STACK_ALLOC((stack), MB_NUMBLOCKS(num * sizeof(type), sizeof(MB_Word))
#endif /* MB_STACK_H */
Index: bytecode/mb_util.c
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_util.c,v
retrieving revision 1.2
diff -u -r1.2 mb_util.c
--- bytecode/mb_util.c 2001/02/01 05:20:30 1.2
+++ bytecode/mb_util.c 2001/02/08 04:30:49
@@ -1,4 +1,3 @@
-#define NOSAY 1 /* To disable SAYings */
/*
** Copyright (C) 1997,2000-2001 The University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
@@ -6,6 +5,8 @@
**
*/
+#define NOSAY 0 /* To disable SAYings */
+
/* Imports */
#include <stdio.h>
#include <stdarg.h>
@@ -43,11 +44,13 @@
fprintf(stderr, "\n");
}
+#ifndef NOSAY
+#define NOSAY 1
+#endif
+
void MB_SAY(const char *fmt, ...)
{
-#if NOSAY
-
-#else
+#if !NOSAY
va_list arg_p;
va_start(arg_p, fmt);
vfprintf(stderr, fmt, arg_p);
@@ -74,6 +77,10 @@
return strcmp(a, b);
}
+/*
+** Allocate space for a new string
+** Allocates in atomic garbage collected memory
+*/
MB_CString
MB_str_new(MB_Word len)
{
@@ -83,6 +90,9 @@
return c;
}
+/*
+** Create a new string that is the concatenation of two existing strings
+*/
MB_CString
MB_str_new_cat(MB_CString_Const a, MB_CString_Const b)
{
@@ -98,6 +108,7 @@
return new_str;
}
+/* Duplicate a string */
MB_CString
MB_str_dup(MB_CString_Const str)
{
@@ -106,6 +117,7 @@
return c;
}
+/* Free storage associated with a given string */
void
MB_str_delete(MB_CString str)
{
Index: bytecode/mb_util.h
===================================================================
RCS file: /home/mercury1/repository/mercury/bytecode/mb_util.h,v
retrieving revision 1.2
diff -u -r1.2 mb_util.h
--- bytecode/mb_util.h 2001/02/01 05:20:30 1.2
+++ bytecode/mb_util.h 2001/02/08 04:30:49
@@ -28,15 +28,13 @@
#endif
/* Prints an error (doesn't exit) */
-void
-MB_util_error(const char *fmt, ...);
+void MB_util_error(const char *fmt, ...);
/* Debugging printf */
-void MB_SAY(const char *fmt, ...);
+void MB_SAY(const char *fmt, ...);
/* Prints an error message and exits */
-void
-MB_fatal(const char *message);
+void MB_fatal(const char *message);
/* allocate space for a new string */
MB_CString MB_str_new(MB_Word len); /* len is w/o null terminator */
@@ -56,7 +54,6 @@
/* deallocate space for string */
void MB_str_delete(MB_CString str);
-
/*
** Given an arbitrary blocksize, returns how many blocks are required to
** contain something of size x
@@ -64,4 +61,8 @@
#define MB_NUMBLOCKS(x, blocksize) \
(((x) + (blocksize) - 1) / (blocksize))
+#define MB_MULTIPLEOF(x, blocksize) \
+ (MB_NUMBLOCKS((x), (blocksize))*(blocksize))
+
#endif /* MB_UTIL_H */
+
Index: bytecode/simple.m
===================================================================
RCS file: simple.m
diff -N simple.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple.m Tue Feb 13 17:36:45 2001
@@ -0,0 +1,64 @@
+% simple22
+% test
+
+% the test is just that this compiles
+% (testing the generate_unify in bytecode_gen.m)
+
+% --------------------------------------------------------------------------
+:- module simple.
+
+% --------------------------------------------------------------------------
+:- interface.
+
+:- import_module io.
+:- import_module int.
+:- import_module char.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+% --------------------------------------------------------------------------
+:- implementation.
+
+main -->
+ {
+ dothings
+ }.
+
+% ------------------------------------------
+:- func sgetch = character is det.
+sgetch = 'a'.
+
+:- pred checkch is det.
+checkch :- ( sgetch = sgetch
+ -> true ; true).
+% ---------------------------------
+:- func sgets = string is det.
+sgets = "a".
+
+:- pred checks is det.
+checks :- ( sgets = sgets
+ -> true ; true).
+% ---------------------------------
+:- func sgeti = int is det.
+sgeti = 3.
+
+:- pred checki is det.
+checki :- ( sgeti = sgeti
+ -> true ; true).
+% ---------------------------------
+:- func sgetf = float is det.
+sgetf = 3.0.
+
+:- pred checkf is det.
+checkf :- ( sgetf = sgetf
+ -> true ; true).
+
+% -----------------------------------------------
+:- pred dothings is det.
+dothings :-
+ checkch,
+ checks,
+ checki,
+ checkf.
+
Index: bytecode/simple01.m
===================================================================
RCS file: simple01.m
diff -N simple01.m
--- /tmp/cvsKNhg3g Tue Feb 13 20:36:39 2001
+++ /dev/null Thu Mar 30 14:06:13 2000
@@ -1,67 +0,0 @@
-/*
-** Copyright (C) 2000-2001 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.
-**
-*/
-
-% enum tags
-
-:- module simple01.
-
-:- interface.
-
-:- import_module int, io.
-
-:- pred main(io__state, io__state).
-:- mode main(di, uo) is det.
-
-:- func temp(colour) = int.
-:- mode temp(in) = out is det.
-
-:- func temp2(int) = int.
-:- mode temp2(in) = out is det.
-
-:- pred ccode(int, int, int, int, int).
-:- mode ccode(in, in, in, out, out) is det.
-
-:- type colour
- ---> red
- ; green
- ; blue
- .
-
-:- implementation.
-
-:- import_module bool.
-:- pred forcebool(bool::out) is det.
-
-forcebool(X) :- X = yes.
-
-:- pragma c_code(
- ccode(A::in, B::in, C::in, X::out, Y::out),
- [may_call_mercury],
- "X = A+B; Y = A+B+C;"
- ).
-
-temp(X) = Y :-
- ( X = red, ccode(1, 2, 3, Q, R), Y = Q+R
- ; X = green, Y = temp2(3)
- ; X = blue, Y = temp2(5)
- ).
-
-temp2(X) = X + 1.
-
-main -->
- {
- R = temp(red),
- G = temp(green),
- B = temp(blue)
-
- },
- io__write_int(R),
- io__write_int(G),
- io__write_int(B),
- { forcebool(X) },
- io__write(X).
-
Index: bytecode/test/simple01.m
===================================================================
RCS file: simple01.m
diff -N simple01.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple01.m Thu Feb 8 15:30:49 2001
@@ -0,0 +1,39 @@
+% simple01
+% enum tags
+
+:- module simple.
+
+:- interface.
+
+:- import_module int, io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- func temp(colour) = int.
+:- mode temp(in) = out is det.
+
+:- type colour
+ ---> red
+ ; green
+ ; blue
+ .
+
+:- implementation.
+
+temp(X) = Y :-
+ ( X = red, Y = 0x401
+ ; X = green, Y = 0x403
+ ; X = blue, Y = 0x406
+ ).
+
+main -->
+ {
+ R = temp(red),
+ G = temp(green),
+ B = temp(blue)
+
+ },
+ io__write_int(R),
+ io__write_int(G),
+ io__write_int(B).
Index: bytecode/test/simple02.m
===================================================================
RCS file: simple02.m
diff -N simple02.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple02.m Thu Feb 8 15:30:49 2001
@@ -0,0 +1,42 @@
+% simple02
+% deconstruct types in switch arms
+
+:- module simple.
+
+:- interface.
+
+:- import_module int, io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- func test(colour) = int.
+:- mode test(in) = out is det.
+
+:- type colour
+ ---> red(int)
+ ; green(int)
+ ; blue(int)
+ ; combo(int, int, int)
+ ; combo(int, int)
+ .
+
+:- implementation.
+
+main -->
+ { ( test(combo(1, 2, 3)) > 3
+ -> Q = 5
+ ; Q = 6
+ )
+ },
+ io__write_int(Q)
+ .
+
+test(X) = R :-
+ ( X = red(Y), R = Y
+ ; X = green(Y), R = Y
+ ; X = blue(Y), R = Y
+ ; X = combo(W,Y,Z), R = W + Y + Z
+ ; X = combo(W,Y), R = W + Y
+ ).
+
Index: bytecode/test/simple03.m
===================================================================
RCS file: simple03.m
diff -N simple03.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple03.m Thu Feb 8 15:30:49 2001
@@ -0,0 +1,32 @@
+% simple03
+% append
+
+:- module simple.
+
+:- interface.
+
+:- import_module list.
+:- import_module int.
+:- import_module io.
+
+:- pred my_append(list(T), list(T), list(T)).
+:- mode my_append(in, in, out) is det.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+
+main -->
+% { my_append([1, 2], [3, 4], List) },
+ { my_append([1, 2, 3], [4, 5, 6, 7, 8], List) },
+ { my_append([1], [2], List2) },
+ io__write(List), io__write_string("\n"),
+ io__write(List2), io__write_string("\n").
+
+my_append([], Y, Y).
+my_append(X, Y, Z) :-
+ X = [H | T],
+ my_append(T, Y, NT),
+ Z = [H | NT].
+
Index: bytecode/test/simple04.m
===================================================================
RCS file: simple04.m
diff -N simple04.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple04.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,33 @@
+% simple04
+% det calls & binop
+
+:- module simple.
+
+:- interface.
+
+:- import_module io.
+:- import_module int.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- pred test(int, int).
+:- mode test(in, out) is det.
+
+:- pred test2(int, int).
+:- mode test2(in, out) is det.
+
+:- implementation.
+
+main -->
+ (
+ { test(1, X) },
+ io__write_string("Hello\n"),
+ io__write_int(X)
+ ).
+
+test2(X, Y) :-
+ Y + 2 = X.
+
+test(X, Y) :-
+ Y = Z*2, test2(X,Z).
Index: bytecode/test/simple05.m
===================================================================
RCS file: simple05.m
diff -N simple05.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple05.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,46 @@
+% simple05
+% If commit switch disjunction, nondet call
+
+:- module simple.
+
+:- interface.
+
+:- import_module io.
+:- import_module int.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- pred test(int, int).
+:- mode test(in, out) is det.
+
+:- pred test2(int, int, int).
+:- mode test2(in, in, out) is nondet.
+
+:- implementation.
+
+main -->
+ (
+ { test(0x404, X) },
+ io__write_int(X)
+ ).
+
+test(X, Y) :-
+ ( (test2(X, 0x3, Q), Q > 0x506)
+ -> R = 0x203
+ ; R = 0x207
+ ),
+ Y = 0x301 * R.
+
+test2(X, R, Y) :-
+ ( X = 0x403, R = 0x3, Y = 0x504
+
+ ; X = 0x404, R = 0x0, Y = 0x507
+
+ ; (X = 0x404, R = 0x3, Y = 0x505, fail)
+ ; X = 0x404, R = 0x3, Y = 0x506
+ ; X = 0x404, R = 0x3, Y = 0x507
+
+ ; X = 0x402, R = 0x3, Y = 0x503
+ ),
+ R > 2.
Index: bytecode/test/simple06.m
===================================================================
RCS file: simple06.m
diff -N simple06.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple06.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,32 @@
+% simple06
+% if ( commit ( disjunct ) )
+:- module simple.
+
+:- interface.
+
+:- import_module io.
+:- import_module int.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- pred test(int).
+:- mode test(out) is multi.
+
+:- implementation.
+
+main -->
+ (
+ { ( test(0x302)
+ -> Y = 0x201
+ ; Y = 0x202
+ )
+ },
+ io__write_int(Y)
+ ).
+
+test(X) :-
+ ( X = 0x301
+ ; X = 0x302
+ ).
+
Index: bytecode/test/simple07.m
===================================================================
RCS file: simple07.m
diff -N simple07.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple07.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,37 @@
+% simple07
+% nested if-then-else
+:- module simple.
+
+:- interface.
+
+:- import_module io.
+:- import_module int.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- pred test(int, int).
+:- mode test(in, out) is det.
+
+
+:- implementation.
+
+main -->
+ (
+ { test(101, Y)
+ },
+ io__write_int(Y)
+ ).
+
+test(X, Y) :-
+ ( X > 311
+ -> ( X > 314
+ -> Y = 401
+ ; Y = 402
+ )
+ ; ( X < 303
+ -> Y = 403
+ ; Y = 404
+ )
+ ).
+
Index: bytecode/test/simple08.m
===================================================================
RCS file: simple08.m
diff -N simple08.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple08.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,39 @@
+% simple08
+% negation
+
+:- module simple.
+
+:- interface.
+
+:- import_module io.
+:- import_module int.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- pred test(int, int).
+:- mode test(in, out) is det.
+
+:- pred test2(int).
+:- mode test2(out) is multi.
+
+:- implementation.
+
+main -->
+ (
+ { test(9, X) },
+ io__write_int(X)
+ ).
+
+test(X, Y) :-
+ ( \+ (test2(X), X > 0)
+ -> Q = 0x203
+ ; Q = 0x208
+ ),
+ Y = Q.
+
+
+test2(0).
+test2(-1).
+test2(-2).
+test2(9).
Index: bytecode/test/simple09.m
===================================================================
RCS file: simple09.m
diff -N simple09.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple09.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,31 @@
+% simple09
+% unary operations
+
+:- module simple.
+
+:- interface.
+
+:- import_module io.
+:- import_module int.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- pred test(int, int).
+:- mode test(in, out) is det.
+
+:- implementation.
+
+main -->
+ (
+ { ( ( test(3, Y), Y = ! true )
+ -> Q = 1
+ ; Q = 3
+ )
+ },
+ io__write_int(Q)
+ ).
+
+test(X, Y) :-
+ Y ! true.
+
Index: bytecode/test/simple10.m
===================================================================
RCS file: simple10.m
diff -N simple10.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple10.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,44 @@
+% simple10
+% semidet
+
+:- module simple.
+
+:- interface.
+
+:- import_module io.
+:- import_module int.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- pred test(int, int).
+:- mode test(in, out) is det.
+
+:- pred semitest(int, int).
+:- mode semitest(in, out) is semidet.
+
+:- implementation.
+
+main -->
+ (
+ { test(9, X) },
+ io__write_int(X)
+ ).
+
+test(X, Y) :-
+ ( semitest(3, X)
+ -> Q = 0x203
+ ; Q = 0x208
+ ),
+ Y = Q.
+
+
+semitest(X, Y) :-
+ ( ( X = 3
+ -> Q = 5
+ ; fail
+ )
+ -> Y = Q
+ ; fail
+ ).
+
Index: bytecode/test/simple11.m
===================================================================
RCS file: simple11.m
diff -N simple11.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple11.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,49 @@
+% simple11
+% fail
+
+% I believe fail actually does a MR_redo
+
+:- module simple.
+
+:- interface.
+
+:- import_module io.
+:- import_module int.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- pred test(int, int).
+:- mode test(in, out) is det.
+
+:- pred semitest(int, int).
+:- mode semitest(in, out) is semidet.
+
+:- implementation.
+
+main -->
+ (
+ { test(9, X) },
+ io__write_int(X)
+ ).
+
+test(X, Y) :-
+ ( ( fail
+ -> R = 9
+ ; ( X > 3
+ -> R = 7
+ ; R = 8
+ )
+ )
+ -> Q = R
+ ; Q = 5
+ ),
+ Y = Q.
+
+
+semitest(X, Y) :-
+ ( X = 3
+ -> fail
+ ; Y = 7
+ ).
+
Index: bytecode/test/simple12.m
===================================================================
RCS file: simple12.m
diff -N simple12.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple12.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,41 @@
+% simple12
+% semidet - does it always try to succeed? - No it branches
+
+:- module simple.
+
+:- interface.
+
+:- import_module io.
+:- import_module int.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- pred test(int).
+:- mode test(out) is det.
+
+:- pred semitest(int, int).
+:- mode semitest(in, out) is semidet.
+
+:- implementation.
+
+main -->
+ (
+ { test(X) },
+ io__write_int(X)
+ ).
+
+test(Y) :-
+ ( R = 3 ; R = 4 ),
+ ( semitest(R, Q)
+ -> Q = 3, Y = Q
+ ; Y = 4
+ ).
+
+
+semitest(X, Y) :-
+ ( X = 3
+ -> fail
+ ; Y = 7
+ ).
+
Index: bytecode/test/simple13.m
===================================================================
RCS file: simple13.m
diff -N simple13.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple13.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,44 @@
+% simple13
+% deconstruct on switch arms
+
+:- module simple.
+
+:- interface.
+
+:- import_module int, io.
+
+:- func mainZ(int) = int.
+:- mode mainZ(in) = out is semidet.
+
+:- pred zebra(int, int, int).
+:- mode zebra(in, in, out) is det.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+
+main -->
+ { ( mainZ(4) > 3
+ -> Q = 5
+ ; Q = 6
+ )
+ },
+ io__write_int(Q)
+ .
+
+zebra(X, Y, Z) :-
+ ( X = Y
+ -> Z = X
+ ; Z = Y
+ ).
+
+mainZ(T) = Z :-
+ (
+ zebra(1,2,Z),
+
+ ( (T = 4)
+ -> (Z = 1)
+ ; (Z = 5)
+ )
+ ).
Index: bytecode/test/simple14.m
===================================================================
RCS file: simple14.m
diff -N simple14.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple14.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,35 @@
+% simple14
+% polymorphism
+
+:- module simple.
+
+:- interface.
+
+:- import_module list.
+:- import_module int.
+:- import_module io.
+
+:- type colour
+ ---> red(int)
+ ; green(int)
+ ; blue(int)
+ ; mix(colour, colour).
+
+:- pred do_stuff(T, T, T).
+:- mode do_stuff(in, in, out) is det.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+
+main -->
+ { do_stuff(red(50), mix(red(50), green(50)), Q)
+ },
+ io__write(Q).
+
+do_stuff(X, Y, Z) :-
+ ( Y = X
+ -> Z = X
+ ; Z = Y
+ ).
Index: bytecode/test/simple15.m
===================================================================
RCS file: simple15.m
diff -N simple15.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple15.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,39 @@
+% simple15
+% higher order calls
+
+:- module simple.
+
+:- interface.
+
+:- import_module list.
+:- import_module int.
+:- import_module io.
+
+:- func add3(int, int, int) = int.
+:- mode add3(in, in, in) = out is det.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- func thefunc = (func(int, int) = int).
+:- mode thefunc = out is det.
+
+:- func addarg(func(int, int) = int) = (func(int) = int).
+:- mode addarg(in) = out is det.
+
+:- implementation.
+
+main -->
+ {
+ Z = thefunc,
+ R = addarg(Z),
+ Q = R(0x11)
+ },
+ io__write_int(Q).
+
+add3(X, Y, Z) = X + Y + Z.
+
+thefunc = add3(0x22).
+
+addarg(X) = (func(A::in) = (B::out) is det
+ :- B = X(0x33, A)).
Index: bytecode/test/simple16.m
===================================================================
RCS file: simple16.m
diff -N simple16.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple16.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,36 @@
+% simple16
+% higher order calls to semidet procs
+
+:- module simple.
+
+:- interface.
+
+:- import_module int.
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- pred dostuff(int, int, int).
+:- mode dostuff(in, out, out) is semidet.
+
+:- func getfunc = (pred(int, int, int)).
+:- mode getfunc = out(pred(in,out,out) is semidet) is det.
+
+:- implementation.
+
+main -->
+ {
+ Func = getfunc,
+ ( Func(0x234, Z, Z)
+ -> X = 3
+ ; X = 4
+ )
+ },
+ io__write_int(X).
+
+getfunc = dostuff.
+
+dostuff(0x234, Q, R) :-
+ Q = R,
+ R = 0x123.
Index: bytecode/test/simple17.m
===================================================================
RCS file: simple17.m
diff -N simple17.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple17.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,40 @@
+% simple17
+% calls & higher order calls with both preds & funcs of same name & arity
+
+:- module simple.
+
+:- interface.
+
+:- import_module int.
+:- import_module io.
+
+:- func hello(int) = int.
+:- mode hello(in) = out is det.
+
+:- pred hello(int, int).
+:- mode hello(in, out) is det.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+
+main -->
+ {
+ A = hello(1),
+ hello(A, B),
+
+ Y = (func(Y1::in) = (Y2::out) is det
+ :- (hello(Y1) = Y2) ),
+ C = Y(1),
+
+ Z = (pred(Y1::in, Y2::out) is det :- hello(Y1, Y2)),
+ Z(C, D)
+ },
+ io__write_int(B),
+ io__write_int(D).
+
+hello(X) = X.
+
+hello(A, B) :-
+ B = A + A.
Index: bytecode/test/simple18.m
===================================================================
RCS file: simple18.m
diff -N simple18.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple18.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,33 @@
+% simple18
+%
+
+:- module simple.
+
+:- interface.
+
+:- import_module int.
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+
+main -->
+ {
+ getnum(X)
+ },
+ io__write_int(X).
+
+
+:- pred getnum(int::out) is det.
+getnum(X) :-
+ ( getmulti(Y), Y \= 4
+ -> X = 1
+ ; X = 0
+ ).
+
+
+:- pred getmulti(int::out) is multi.
+getmulti(4).
+getmulti(5).
Index: bytecode/test/simple19.m
===================================================================
RCS file: simple19.m
diff -N simple19.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple19.m Thu Feb 8 15:30:51 2001
@@ -0,0 +1,44 @@
+% simple19
+% nondet bytecode -> nondet list__member
+
+% --------------------------------------------------------------------------
+:- module simple.
+
+% --------------------------------------------------------------------------
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+% --------------------------------------------------------------------------
+:- implementation.
+
+:- import_module int.
+:- import_module list.
+
+main -->
+ {
+ ( getnum(Y)
+ -> X = Y
+ ; X = 0
+ )
+ },
+ io__write_int(X).
+
+:- pred getnum(int::out) is semidet.
+getnum(Y) :-
+ (
+ multinum(Z),
+ Z > 9
+ ->
+ Y = 2
+ ;
+ Y = 1
+ ).
+
+:- pred multinum(int::out) is nondet.
+multinum(Z) :-
+ member(Z, [1, 3, 5, 7]).
+
Index: bytecode/test/simple20.m
===================================================================
RCS file: simple20.m
diff -N simple20.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple20.m Thu Feb 8 15:30:51 2001
@@ -0,0 +1,43 @@
+% simple20
+% nondet bytecode -> nondet list__member
+
+% --------------------------------------------------------------------------
+:- module simple.
+
+% --------------------------------------------------------------------------
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+% --------------------------------------------------------------------------
+:- implementation.
+
+:- import_module int.
+:- import_module list.
+:- import_module std_util.
+
+main -->
+ {
+ solutions(getnum, X)
+ },
+ io__write(X).
+
+:- pred getnum(int::out) is multi.
+getnum(Y) :-
+ (
+ member(Z, mylist),
+ Z > 6
+ ->
+ Y = Z
+ ;
+ Y = 0
+ ).
+
+:- func mylist = list(int).
+:- mode mylist = out is det.
+mylist = [1, 3, 5, 7, 9, 2, 11].
+
+
Index: bytecode/test/simple21.m
===================================================================
RCS file: simple21.m
diff -N simple21.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple21.m Thu Feb 8 15:30:51 2001
@@ -0,0 +1,51 @@
+% simple21
+% nested submodules
+
+% --------------------------------------------------------------------------
+:- module simple.
+
+% --------------------------------------------------------------------------
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+% --------------------------------------------------------------------------
+:- implementation.
+
+:- import_module simple:simple1.
+
+main -->
+ {
+ simple1__stuff1(X)
+ },
+ io__write(X).
+
+
+ :- module simple1.
+ :- interface.
+ :- pred stuff1(int::out) is det.
+ :- implementation.
+ :- import_module simple:simple1:simple11.
+ stuff1(X) :- simple__simple1__simple11__stuff11(X).
+
+
+ :- module simple11.
+ :- interface.
+ :- pred stuff11(int::out) is det.
+ :- implementation.
+ :- import_module simple:simple1:simple12.
+ stuff11(X) :- simple__simple1__simple12__stuff12(X).
+ :- end_module simple11.
+
+ :- module simple12.
+ :- interface.
+ :- pred stuff12(int::out) is det.
+ :- implementation.
+ stuff12(X) :- X = 4.
+ :- end_module simple12.
+
+
+ :- end_module simple1.
Index: bytecode/test/simple22.m
===================================================================
RCS file: simple22.m
diff -N simple22.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple22.m Tue Feb 13 16:47:17 2001
@@ -0,0 +1,32 @@
+% simple22
+% test
+
+% --------------------------------------------------------------------------
+:- module simple.
+
+% --------------------------------------------------------------------------
+:- interface.
+
+:- import_module io.
+:- import_module int.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+% --------------------------------------------------------------------------
+:- implementation.
+
+:- import_module simple:simple1.
+
+main -->
+ {
+ dothings
+ }.
+
+:- getc = char is det.
+getc = 'a'.
+
+:- pred dothings is det.
+dothings :-
+ getc.
+
Index: bytecode/test/simple50.m
===================================================================
RCS file: simple50.m
diff -N simple50.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple50.m Thu Feb 8 15:30:51 2001
@@ -0,0 +1,58 @@
+% File: rot13_concise.m
+% Main authors: Warwick Harvey <wharvey at cs.monash.edu.au>
+% Fergus Henderson <fjh at cs.mu.oz.au>
+%
+% rot13_concise:
+%
+% Program to read its input, apply the rot13 algorithm, and write it out
+% again.
+%
+% This version is more concise (but less efficient) than its companion,
+% rot13_verbose.
+%
+% Key features:
+% - is independent of character set (e.g. ASCII, EBCDIC)
+% - has proper error handling
+%
+
+:- module simple.
+
+:- interface.
+:- import_module io.
+
+:- pred main(state, state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+:- import_module char, int, string.
+
+% The length of `alphabet' should be a multiple of `cycle'.
+alphabet = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ".
+cycle = 26.
+
+rot_n(N, Char) = RotChar :-
+ char_to_string(Char, CharString),
+ ( if sub_string_search(alphabet, CharString, Index) then
+ NewIndex = (Index + N) mod cycle + cycle * (Index // cycle),
+ index_det(alphabet, NewIndex, RotChar)
+ else
+ RotChar = Char
+ ).
+
+rot13(Char) = rot_n(13, Char).
+
+main -->
+ read_char(Res),
+ ( { Res = ok(Char) },
+ print(rot13(Char)),
+ main
+ ; { Res = eof }
+ ; { Res = error(ErrorCode) },
+ { error_message(ErrorCode, ErrorMessage) },
+ stderr_stream(StdErr),
+ print(StdErr, "rot13: error reading input: "),
+ print(StdErr, ErrorMessage),
+ nl(StdErr)
+ ).
+
+
Index: bytecode/test/simple51.m
===================================================================
RCS file: simple51.m
diff -N simple51.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple51.m Thu Feb 8 15:30:51 2001
@@ -0,0 +1,72 @@
+% I have another version of rot13.
+%
+% Gustavo A. Ospina <g-ospina at uniandes.edu.co>
+%
+% This version reads a line and prints the line "roted". I think it is as
+% declarative as Jurgen's version. Also I handle error and I used predicates
+% on your char library. Maybe my version is slower, but it can be discussed.
+%
+% This source file is hereby placed in the public domain.
+% - Gustavo Ospina
+
+:- module simple.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di,io__state::uo) is det.
+
+:- implementation.
+
+:- import_module char,int,list.
+
+:- pred rot13(char::in,char::out) is det.
+
+rot13(Char,RotChar) :-
+ char__is_upper(Char) ->
+ rot13(Char,0'A,RotChar)
+ ;
+ char__is_lower(Char) ->
+ rot13(Char,0'a,RotChar)
+ ;
+ RotChar = Char.
+
+:- pred rot13(char::in,int::in,char::out) is det.
+
+rot13(Char,CodeLetterA,RotChar) :-
+ char__to_int(Char,CodeChar),
+ RotCode = (CodeChar - CodeLetterA + 13) mod 26 + CodeLetterA,
+ char__to_int(RChar,RotCode) ->
+ RotChar = RChar
+ ;
+ RotChar = '\a'.
+ /* Alert character (Error case. To satisfy mode check) */
+
+:- pred printRotChars(list(char)::in,io__state::di,io__state::uo) is det.
+
+printRotChars([]) -->
+ [].
+
+printRotChars([Ch|Chs]) -->
+ {rot13(Ch,RotCh)},
+ io__write_char(RotCh),
+ printRotChars(Chs).
+
+% Main Program
+
+main -->
+ io__read_line(Result),
+ (
+ {Result = ok(Line)},
+ printRotChars(Line),
+ main
+ ;
+ {Result = eof,
+ true}
+ ;
+ {Result = error(Error),
+ io__error_message(Error,Message)},
+ io__stderr_stream(Stderr),
+ io__write_string(Stderr,Message)
+ ).
Index: bytecode/test/simple52.m
===================================================================
RCS file: simple52.m
diff -N simple52.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple52.m Thu Feb 8 15:30:51 2001
@@ -0,0 +1,48 @@
+%
+% Copyright (C) 1998 Jürgen Stuber <juergen at mpi-sb.mpg.de>
+% This file may only be copied under the terms of the GNU General
+% Public License - see the file COPYING in the Mercury distribution.
+%
+% I couldn't resist:
+% Jürgen Stuber <juergen at mpi-sb.mpg.de>
+% http://www.mpi-sb.mpg.de/~juergen/
+
+:- module simple.
+:- interface.
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+:- import_module char, int, require.
+
+:- pred rot13( char::in, char::out) is det.
+
+main -->
+ io__read_char( Result ),
+ ( { Result = ok( Char ) } ->
+ { rot13( Char, Rot13Char ) },
+ io__write_char( Rot13Char ),
+ main
+
+ ; { Result = eof } ->
+ { true }
+ ;
+ { error( "read failed" ) }
+ ).
+
+rot13( Char, Rot13Char ) :-
+ char__to_int( Char, Code ),
+ ( 0'A =< Code, Code =< 0'Z ->
+ Rot13Code = (Code - 0'A + 13) mod 26 + 0'A
+ ; 0'a =< Code, Code =< 0'z ->
+ Rot13Code = (Code - 0'a + 13) mod 26 + 0'a
+ ;
+ Rot13Code = Code
+ ),
+ ( char__to_int( Ch, Rot13Code ) ->
+ Rot13Char = Ch
+ ;
+ error("too offensive, censored")
+ ).
+
Index: bytecode/test/simple53.m
===================================================================
RCS file: simple53.m
diff -N simple53.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple53.m Thu Feb 8 15:30:51 2001
@@ -0,0 +1,116 @@
+% File: rot13_verbose.m
+% Main author: Warwick Harvey <wharvey at cs.monash.edu.au>
+% Additional input: Fergus Henderson <fjh at cs.mu.oz.au>
+
+%
+% rot13_verbose:
+%
+% Program to read its input, apply the rot13 algorithm, and write it out
+% again.
+%
+% This version is more verbose (and more efficient) than its companion,
+% rot13_concise.
+%
+% Key features:
+% - is independent of character set (e.g. ASCII, EBCDIC)
+% - has proper error handling
+% - reasonably efficient (uses a table to do the rotation)
+%
+
+:- module simple.
+
+:- interface.
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- implementation.
+:- import_module char, int, require.
+
+ % rot13a/2
+ % A table to map the alphabetic characters to their rot13 equivalents
+ % (fails if the input is not alphabetic).
+:- pred rot13a(char, char).
+:- mode rot13a(in, out) is semidet.
+
+rot13a('a', 'n').
+rot13a('b', 'o').
+rot13a('c', 'p').
+rot13a('d', 'q').
+rot13a('e', 'r').
+rot13a('f', 's').
+rot13a('g', 't').
+rot13a('h', 'u').
+rot13a('i', 'v').
+rot13a('j', 'w').
+rot13a('k', 'x').
+rot13a('l', 'y').
+rot13a('m', 'z').
+rot13a('n', 'a').
+rot13a('o', 'b').
+rot13a('p', 'c').
+rot13a('q', 'd').
+rot13a('r', 'e').
+rot13a('s', 'f').
+rot13a('t', 'g').
+rot13a('u', 'h').
+rot13a('v', 'i').
+rot13a('w', 'j').
+rot13a('x', 'k').
+rot13a('y', 'l').
+rot13a('z', 'm').
+rot13a('A', 'N').
+rot13a('B', 'O').
+rot13a('C', 'P').
+rot13a('D', 'Q').
+rot13a('E', 'R').
+rot13a('F', 'S').
+rot13a('G', 'T').
+rot13a('H', 'U').
+rot13a('I', 'V').
+rot13a('J', 'W').
+rot13a('K', 'X').
+rot13a('L', 'Y').
+rot13a('M', 'Z').
+rot13a('N', 'A').
+rot13a('O', 'B').
+rot13a('P', 'C').
+rot13a('Q', 'D').
+rot13a('R', 'E').
+rot13a('S', 'F').
+rot13a('T', 'G').
+rot13a('U', 'H').
+rot13a('V', 'I').
+rot13a('W', 'J').
+rot13a('X', 'K').
+rot13a('Y', 'L').
+rot13a('Z', 'M').
+
+ % rot13/2
+ % Applies the rot13 algorithm to a character.
+:- pred rot13(char, char).
+:- mode rot13(in, out) is det.
+
+rot13(Char, RotChar) :-
+ ( if rot13a(Char, TmpChar) then
+ RotChar = TmpChar
+ else
+ RotChar = Char
+ ).
+
+main -->
+ io__read_char(Res),
+ ( { Res = ok(Char) },
+ { rot13(Char, RotChar) },
+ io__write_char(RotChar),
+ main
+ ; { Res = eof }
+ ; { Res = error(ErrorCode) },
+ { io__error_message(ErrorCode, ErrorMessage) },
+ io__stderr_stream(StdErr),
+ io__write_string(StdErr, "rot13: error reading input: "),
+ io__write_string(StdErr, ErrorMessage),
+ io__nl(StdErr)
+ ).
+
Index: bytecode/test/simple54.m
===================================================================
RCS file: simple54.m
diff -N simple54.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple54.m Thu Feb 8 15:30:51 2001
@@ -0,0 +1,258 @@
+%
+% Short timetabling problem
+% (Could be made nicer, but this was done when I was
+% learning mercury)
+%
+% Requires support for predicate constructs
+% (and solutions/2 to work)
+%
+% ======================================================
+:- module simple.
+
+% ======================================================
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+
+% ======================================================
+:- implementation.
+
+:- import_module int.
+:- import_module list.
+:- import_module std_util.
+:- import_module string.
+
+:- type day
+ ---> sun
+ ; mon
+ ; tue
+ ; wed
+ ; thu
+ ; fri
+ .
+
+:- type timeslot
+ ---> time(day, int, int).
+
+:- type subject == {int, list(stream)}.
+
+:- type stream == list(timeslot).
+
+
+% ------------------------------------------------------
+:- func subjects = list(subject).
+:- mode subjects = out is det.
+subjects = levi_subjects.
+
+% ------------------------------------------------------
+:- func daniel_subjects = list(subject).
+:- mode daniel_subjects = out is det.
+daniel_subjects =
+ [
+ { 433340,
+ [ [ time(mon, 2, 1), time(mon, 3, 1),
+ time(wed, 2, 1), time(wed, 3, 1)
+ ]
+ ]
+ },
+ { 433341,
+ [ [ %time(mon, 1, 1),
+ time(thu, 1, 1),
+ time(fri, 3, 1)
+ ]
+ ]
+ },
+ { 433343,
+ [ [ time(tue, 10, 1),
+ time(tue, 11, 1),
+ time(tue, 12, 1),
+ time(fri, 10, 1),
+ time(fri, 11, 1),
+ time(fri, 12, 1)
+ ]
+ ]
+ },
+ { 620221,
+ [ [ time(mon, 1, 1),
+ time(thu, 12, 1),
+ time(fri, 2, 1)
+ ]
+ ]
+ }
+ ].
+% ------------------------------------------------------
+:- func levi_subjects = list(subject).
+:- mode levi_subjects = out is det.
+levi_subjects =
+ [
+ { 433340,
+ [ [ time(wed, 2, 1), time(wed, 3, 1)
+ ]
+ ]
+ },
+ { 433341,
+ [ [ time(mon, 1, 1),
+ time(thu, 1, 1)
+ ]
+ ]
+ },
+ { 730204,
+ [ [ time(mon, 5, 1), time(mon, 6, 1),
+ time(thu, 5, 1), time(thu, 6, 1)
+ ],
+ [ time(mon, 11, 2), time(mon, 12, 2),
+ time(wed, 4, 2), time(wed, 5, 2)
+ ],
+ [ time(tue, 9, 3), time(tue, 10, 3),
+ time(thu, 9, 3), time(thu, 10, 3)
+ ],
+ [ time(tue, 2, 4), time(tue, 3, 4),
+ time(thu, 2, 4), time(thu, 3, 4)
+ ],
+ [ time(tue, 4, 5), time(tue, 5, 5),
+ time(fri, 9, 5), time(fri, 10, 5)
+ ],
+ [ time(wed, 11, 6), time(wed, 12, 6),
+ time(fri, 11, 6), time(fri, 12, 6)
+ ]
+ ]
+ },
+ { 730102,
+ [
+ [ time(tue, 9, 1), time(tue, 10, 1),
+ time(fri, 9, 1), time(fri, 10, 1)
+ ],
+ [ time(wed, 10, 2), time(wed, 11, 2),
+ time(fri, 11, 2), time(fri, 12, 2)
+ ],
+ [ time(tue, 11, 3), time(tue, 12, 3),
+ time(thu, 10, 3), time(thu, 11, 3)
+ ],
+ [ time(tue, 2, 4), time(tue, 3, 4),
+ time(thu, 2, 4), time(thu, 3, 4)
+ ],
+ [ time(mon, 2, 5), time(mon, 3, 5),
+ time(wed, 2, 5), time(wed, 3, 5)
+ ],
+ [ time(tue, 5, 6), time(tue, 6, 6),
+ time(thu, 5, 6), time(thu, 6, 6)
+ ]
+ ]
+ },
+ { 433330,
+ [ [ time(tue, 1, 1),
+ time(thu, 2, 1)
+ ]
+ ]
+ /* },
+ { 620351,
+ [ [ time(tue, 4, 1),
+ time(wed, 4, 1),
+ time(thu, 4, 1)
+ ]
+ ]*/
+ }
+
+ ].
+
+% ------------------------------------------------------
+:- pred time_not_used(day, int, list(timeslot)).
+:- mode time_not_used(in, in, in) is semidet.
+time_not_used(_Day, _Time, []).
+time_not_used(Day, Time, [time(TSDay, TSTime, TSSubj) | Z]) :-
+ time(Day, Time, TSSubj) \= time(TSDay, TSTime, TSSubj),
+ time_not_used(Day, Time, Z).
+
+
+% ------------------------------------------------------
+:- pred do_stream(int, stream, list(timeslot), list(timeslot)).
+:- mode do_stream(in, in, in, out) is semidet.
+do_stream(_SubjNum, [], X, X).
+do_stream(SubjNum, [time(Day, Hour, _) | T], Xin, Xout) :-
+ time_not_used(Day, Hour, Xin),
+ append([time(Day, Hour, SubjNum)], Xin, X1),
+ do_stream(SubjNum, T, X1, Xout)
+ .
+% ------------------------------------------------------
+:- pred do_subject(subject, list(timeslot), list(timeslot)).
+:- mode do_subject(in, in, out) is nondet.
+do_subject( {SubjNum, [H | T]}, Xin, Xout) :-
+ ( do_stream(SubjNum, H, Xin, Xout)
+ ; do_subject({SubjNum, T}, Xin, Xout)
+ ).
+
+% ------------------------------------------------------
+:- pred do_subjects(list(subject), list(timeslot), list(timeslot)).
+:- mode do_subjects(in, in, out) is nondet.
+do_subjects([], X, X).
+do_subjects([H | T]) -->
+ do_subject(H),
+ do_subjects(T).
+
+% ------------------------------------------------------
+:- func get_subject(list(timeslot), day, int) = string.
+:- mode get_subject(in, in, in) = out is det.
+get_subject([], _Day, _Time)
+ = " ".
+get_subject([ T | Z ], Day, Time) = Str :-
+ (T = time(Day, Time, TSSubj))
+ -> Str = (int_to_string(TSSubj // 1000) ++ "-" ++ int_to_string(TSSubj mod
1000))
+ ; Str = get_subject(Z, Day, Time).
+
+% ------------------------------------------------------
+:- pred print_solution(list(timeslot), int, io__state, io__state).
+:- mode print_solution(in, in, di, uo) is det.
+print_solution(X, Time) -->
+ { (Time >= 8)
+ -> ModTime = Time*100
+ ; ModTime = (Time+12)*100+15 },
+ io__format("%04d %7s %7s %7s %7s %7s",
+ [
+ i(ModTime),
+ s(get_subject(X, mon, Time)),
+ s(get_subject(X, tue, Time)),
+ s(get_subject(X, wed, Time)),
+ s(get_subject(X, thu, Time)),
+ s(get_subject(X, fri, Time))
+ ]).
+
+% ------------------------------------------------------
+:- pred print_solution(list(timeslot), io__state, io__state).
+:- mode print_solution(in, di, uo) is det.
+print_solution(X) -->
+ io__write_string("---------------------------------------------------\n"),
+ io__write_string(" mon tue wed thu fri\n"),
+ print_solution(X, 8), io__write_string("\n"),
+ print_solution(X, 9), io__write_string("\n"),
+ print_solution(X, 10), io__write_string("\n"),
+ print_solution(X, 11), io__write_string("\n"),
+ print_solution(X, 12), io__write_string("\n"),
+ print_solution(X, 1), io__write_string("\n"),
+ print_solution(X, 2), io__write_string("\n"),
+ print_solution(X, 3), io__write_string("\n"),
+ print_solution(X, 4), io__write_string("\n"),
+ print_solution(X, 5), io__write_string("\n"),
+ print_solution(X, 6), io__write_string("\n"),
+ print_solution(X, 7), io__write_string("\n"),
+ io__write_string("---------------------------------------------------\n").
+
+
+% ------------------------------------------------------
+:- pred print_solutions(list(list(timeslot)), io__state, io__state).
+:- mode print_solutions(in, di, uo) is det.
+print_solutions([], X, X).
+print_solutions([H | T]) -->
+ print_solution(H),
+ io__write_string("\n"),
+ print_solutions(T).
+
+% ------------------------------------------------------
+main -->
+ {solutions(do_subjects(subjects, []), Timetables) },
+ print_solutions(Timetables).
+
+
Index: bytecode/test/simple55.m
===================================================================
RCS file: simple55.m
diff -N simple55.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple55.m Thu Feb 8 15:30:51 2001
@@ -0,0 +1,270 @@
+%
+% Short timetabling problem
+% (Could be made nicer, but this was done when I was
+% learning mercury)
+%
+% Requires support for predicate constructs
+% (and solutions/2 to work)
+%
+% ======================================================
+:- module simple.
+
+% ======================================================
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+
+% ======================================================
+:- implementation.
+
+:- import_module int.
+:- import_module list.
+:- import_module std_util.
+:- import_module string.
+
+:- type day
+ ---> sun
+ ; mon
+ ; tue
+ ; wed
+ ; thu
+ ; fri
+ .
+
+:- type timeslot
+ ---> time(day, int, int).
+
+:- type subject == {int, list(stream)}.
+
+:- type stream == list(timeslot).
+
+
+% ------------------------------------------------------
+:- func subjects = list(subject).
+:- mode subjects = out is det.
+subjects = levi_subjects.
+
+% ------------------------------------------------------
+:- func daniel_subjects = list(subject).
+:- mode daniel_subjects = out is det.
+daniel_subjects =
+ [
+ { 433340,
+ [ [ time(mon, 2, 1), time(mon, 3, 1),
+ time(wed, 2, 1), time(wed, 3, 1)
+ ]
+ ]
+ },
+ { 433341,
+ [ [ %time(mon, 1, 1),
+ time(thu, 1, 1),
+ time(fri, 3, 1)
+ ]
+ ]
+ },
+ { 433343,
+ [ [ time(tue, 10, 1),
+ time(tue, 11, 1),
+ time(tue, 12, 1),
+ time(fri, 10, 1),
+ time(fri, 11, 1),
+ time(fri, 12, 1)
+ ]
+ ]
+ },
+ { 620221,
+ [ [ time(mon, 1, 1),
+ time(thu, 12, 1),
+ time(fri, 2, 1)
+ ]
+ ]
+ }
+ ].
+% ------------------------------------------------------
+:- func levi_subjects = list(subject).
+:- mode levi_subjects = out is det.
+levi_subjects =
+ [
+ { 433340,
+ [ [ time(wed, 2, 1), time(wed, 3, 1)
+ ]
+ ]
+ },
+ { 433341,
+ [ [ time(mon, 1, 1),
+ time(thu, 1, 1)
+ ]
+ ]
+ },
+ { 730204,
+ [ [ time(mon, 5, 1), time(mon, 6, 1),
+ time(thu, 5, 1), time(thu, 6, 1)
+ ],
+ [ time(mon, 11, 2), time(mon, 12, 2),
+ time(wed, 4, 2), time(wed, 5, 2)
+ ],
+ [ time(tue, 9, 3), time(tue, 10, 3),
+ time(thu, 9, 3), time(thu, 10, 3)
+ ],
+ [ time(tue, 2, 4), time(tue, 3, 4),
+ time(thu, 2, 4), time(thu, 3, 4)
+ ],
+ [ time(tue, 4, 5), time(tue, 5, 5),
+ time(fri, 9, 5), time(fri, 10, 5)
+ ],
+ [ time(wed, 11, 6), time(wed, 12, 6),
+ time(fri, 11, 6), time(fri, 12, 6)
+ ]
+ ]
+ },
+ { 730102,
+ [
+ [ time(tue, 9, 1), time(tue, 10, 1),
+ time(fri, 9, 1), time(fri, 10, 1)
+ ],
+ [ time(wed, 10, 2), time(wed, 11, 2),
+ time(fri, 11, 2), time(fri, 12, 2)
+ ],
+ [ time(tue, 11, 3), time(tue, 12, 3),
+ time(thu, 10, 3), time(thu, 11, 3)
+ ],
+ [ time(tue, 2, 4), time(tue, 3, 4),
+ time(thu, 2, 4), time(thu, 3, 4)
+ ],
+ [ time(mon, 2, 5), time(mon, 3, 5),
+ time(wed, 2, 5), time(wed, 3, 5)
+ ],
+ [ time(tue, 5, 6), time(tue, 6, 6),
+ time(thu, 5, 6), time(thu, 6, 6)
+ ]
+ ]
+ },
+ { 433330,
+ [ [ time(tue, 1, 1),
+ time(thu, 2, 1)
+ ]
+ ]
+ /* },
+ { 620351,
+ [ [ time(tue, 4, 1),
+ time(wed, 4, 1),
+ time(thu, 4, 1)
+ ]
+ ]*/
+ }
+
+ ].
+
+% ------------------------------------------------------
+:- pred time_not_used(day, int, list(timeslot)).
+:- mode time_not_used(in, in, in) is semidet.
+time_not_used(_Day, _Time, []).
+time_not_used(Day, Time, [time(TSDay, TSTime, TSSubj) | Z]) :-
+ time(Day, Time, TSSubj) \= time(TSDay, TSTime, TSSubj),
+ time_not_used(Day, Time, Z).
+
+
+% ------------------------------------------------------
+:- pred do_stream(int, stream, list(timeslot), list(timeslot)).
+:- mode do_stream(in, in, in, out) is semidet.
+do_stream(_SubjNum, [], X, X).
+do_stream(SubjNum, [time(Day, Hour, _) | T], Xin, Xout) :-
+ time_not_used(Day, Hour, Xin),
+ append([time(Day, Hour, SubjNum)], Xin, X1),
+ do_stream(SubjNum, T, X1, Xout)
+ .
+% ------------------------------------------------------
+:- pred do_subject(subject, list(timeslot), list(timeslot)).
+% BOO
+%:- mode do_subject(in, in, out) is nondet.
+:- mode do_subject(in, in, out) is semidet.
+do_subject( {SubjNum, [H | T]}, Xin, Xout) :-
+% BOO
+% ( do_stream(SubjNum, H, Xin, Xout)
+ ( do_stream(SubjNum, H, Xin, Xout0)
+ -> Xout = Xout0
+
+ ; do_subject({SubjNum, T}, Xin, Xout)
+ ).
+
+% ------------------------------------------------------
+:- pred do_subjects(list(subject), list(timeslot), list(timeslot)).
+%:- mode do_subjects(in, in, out) is nondet. BOO
+:- mode do_subjects(in, in, out) is semidet.
+do_subjects([], X, X).
+do_subjects([H | T]) -->
+ do_subject(H),
+ do_subjects(T).
+
+% ------------------------------------------------------
+:- func get_subject(list(timeslot), day, int) = string.
+:- mode get_subject(in, in, in) = out is det.
+get_subject([], _Day, _Time)
+ = " ".
+get_subject([ T | Z ], Day, Time) = Str :-
+ (T = time(Day, Time, TSSubj))
+ -> Str = (int_to_string(TSSubj // 1000) ++ "-" ++ int_to_string(TSSubj mod
1000))
+ ; Str = get_subject(Z, Day, Time).
+
+% ------------------------------------------------------
+:- pred print_solution(list(timeslot), int, io__state, io__state).
+:- mode print_solution(in, in, di, uo) is det.
+print_solution(X, Time) -->
+ { (Time >= 8)
+ -> ModTime = Time*100
+ ; ModTime = (Time+12)*100+15 },
+ io__format("%04d %7s %7s %7s %7s %7s",
+ [
+ i(ModTime),
+ s(get_subject(X, mon, Time)),
+ s(get_subject(X, tue, Time)),
+ s(get_subject(X, wed, Time)),
+ s(get_subject(X, thu, Time)),
+ s(get_subject(X, fri, Time))
+ ]).
+
+% ------------------------------------------------------
+:- pred print_solution(list(timeslot), io__state, io__state).
+:- mode print_solution(in, di, uo) is det.
+print_solution(X) -->
+ io__write_string("---------------------------------------------------\n"),
+ io__write_string(" mon tue wed thu fri\n"),
+ print_solution(X, 8), io__write_string("\n"),
+ print_solution(X, 9), io__write_string("\n"),
+ print_solution(X, 10), io__write_string("\n"),
+ print_solution(X, 11), io__write_string("\n"),
+ print_solution(X, 12), io__write_string("\n"),
+ print_solution(X, 1), io__write_string("\n"),
+ print_solution(X, 2), io__write_string("\n"),
+ print_solution(X, 3), io__write_string("\n"),
+ print_solution(X, 4), io__write_string("\n"),
+ print_solution(X, 5), io__write_string("\n"),
+ print_solution(X, 6), io__write_string("\n"),
+ print_solution(X, 7), io__write_string("\n"),
+ io__write_string("---------------------------------------------------\n").
+
+
+% ------------------------------------------------------
+:- pred print_solutions(list(list(timeslot)), io__state, io__state).
+:- mode print_solutions(in, di, uo) is det.
+print_solutions([], X, X).
+print_solutions([H | T]) -->
+ print_solution(H),
+ io__write_string("\n"),
+ print_solutions(T).
+
+% ------------------------------------------------------
+main -->
+ %{solutions(do_subjects(subjects, []), Timetables) }, BOO
+ { ( do_subjects(subjects, [], Timetable)
+ -> Timetables = [Timetable]
+ ; Timetables = []
+ )
+ },
+ print_solutions(Timetables).
+
+
Index: bytecode/test/simple99.m
===================================================================
RCS file: simple99.m
diff -N simple99.m
--- /dev/null Thu Mar 30 14:06:13 2000
+++ simple99.m Thu Feb 8 15:30:50 2001
@@ -0,0 +1,47 @@
+% simple99
+
+:- module simple.
+
+:- interface.
+
+:- import_module int, io.
+
+:- pred main(io__state, io__state).
+:- mode main(di, uo) is det.
+
+:- type yesno --->
+ ( yes
+ ; no
+ ).
+
+:- pred temp(int, yesno).
+:- mode temp(in, in) is semidet.
+:- mode temp(in, out) is det.
+
+:- implementation.
+
+main -->
+ {
+ ( temp(Q, Z)
+ -> W = 1
+ ; W = 2
+ ),
+ temp(1, X),
+ (
+ X = yes,
+ Y = 2
+ ;
+ X = no,
+ Y = 1
+ )
+
+ },
+ io__write_int(W),
+ io__write_int(Y).
+
+temp(X, Y) :-
+ ( X = 1
+ -> Y = yes
+ ; Y = no
+ ).
+
Index: compiler/bytecode.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/bytecode.m,v
retrieving revision 1.45
diff -u -r1.45 bytecode.m
--- compiler/bytecode.m 2001/01/20 15:42:41 1.45
+++ compiler/bytecode.m 2001/02/13 06:29:48
@@ -46,7 +46,7 @@
; enter_commit(byte_temp)
; endof_commit(byte_temp)
; assign(byte_var, byte_var)
- ; test(byte_var, byte_var)
+ ; test(byte_var, byte_var, byte_test_id)
; construct(byte_var, byte_cons_id,
list(byte_var))
; deconstruct(byte_var, byte_cons_id,
@@ -113,6 +113,12 @@
; to_none
.
+:- type byte_test_id ---> int_test
+ ; char_test
+ ; string_test
+ ; float_test
+ ; enum_test.
+
:- type byte_module_id == module_name.
:- type byte_pred_id == string.
:- type byte_proc_id == int.
@@ -260,9 +266,10 @@
output_args(assign(Var1, Var2)) -->
output_var(Var1),
output_var(Var2).
-output_args(test(Var1, Var2)) -->
+output_args(test(Var1, Var2, TestId)) -->
output_var(Var1),
- output_var(Var2).
+ output_var(Var2),
+ output_test_id(TestId).
output_args(construct(Var, ConsId, Vars)) -->
output_var(Var),
output_cons_id(ConsId),
@@ -388,9 +395,10 @@
debug_args(assign(Var1, Var2)) -->
debug_var(Var1),
debug_var(Var2).
-debug_args(test(Var1, Var2)) -->
+debug_args(test(Var1, Var2, TestId)) -->
debug_var(Var1),
- debug_var(Var2).
+ debug_var(Var2),
+ debug_test_id(TestId).
debug_args(construct(Var, ConsId, Vars)) -->
debug_var(Var),
debug_cons_id(ConsId),
@@ -664,6 +672,24 @@
%---------------------------------------------------------------------------%
+:- pred output_test_id(byte_test_id, io__state, io__state).
+:- mode output_test_id(in, di, uo) is det.
+output_test_id(int_test) --> output_byte(0).
+output_test_id(char_test) --> output_byte(1).
+output_test_id(string_test) --> output_byte(2).
+output_test_id(float_test) --> output_byte(3).
+output_test_id(enum_test) --> output_byte(4).
+
+:- pred debug_test_id(byte_test_id, io__state, io__state).
+:- mode debug_test_id(in, di, uo) is det.
+debug_test_id(int_test) --> debug_string("int").
+debug_test_id(char_test) --> debug_string("char").
+debug_test_id(string_test) --> debug_string("string").
+debug_test_id(float_test) --> debug_string("float").
+debug_test_id(enum_test) --> debug_string("enum").
+
+
+%---------------------------------------------------------------------------%
:- pred output_module_id(byte_module_id, io__state, io__state).
:- mode output_module_id(in, di, uo) is det.
@@ -918,7 +944,7 @@
byte_code(enter_commit(_), 19).
byte_code(endof_commit(_), 20).
byte_code(assign(_, _), 21).
-byte_code(test(_, _), 22).
+byte_code(test(_, _, _), 22).
byte_code(construct(_, _, _), 23).
byte_code(deconstruct(_, _, _), 24).
byte_code(complex_construct(_, _, _), 25).
@@ -966,7 +992,7 @@
byte_debug(enter_commit(_), "enter_commit").
byte_debug(endof_commit(_), "endof_commit").
byte_debug(assign(_, _), "assign").
-byte_debug(test(_, _), "test").
+byte_debug(test(_, _, _), "test").
byte_debug(construct(_, _, _), "construct").
byte_debug(deconstruct(_, _, _), "deconstruct").
byte_debug(complex_construct(_, _, _), "complex_construct").
Index: compiler/bytecode_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/bytecode_gen.m,v
retrieving revision 1.58
diff -u -r1.58 bytecode_gen.m
--- compiler/bytecode_gen.m 2001/01/18 05:44:24 1.58
+++ compiler/bytecode_gen.m 2001/02/13 06:43:09
@@ -44,6 +44,7 @@
:- import_module type_util, mode_util, goal_util.
:- import_module builtin_ops, code_model, passes_aux.
:- import_module globals, tree.
+:- import_module prog_out.
:- import_module bool, int, string, list, assoc_list, set, map, varset.
:- import_module std_util, require, term.
@@ -508,7 +509,52 @@
bytecode_gen__unify(simple_test(Var1, Var2), _, _, ByteInfo, Code) :-
bytecode_gen__map_var(ByteInfo, Var1, ByteVar1),
bytecode_gen__map_var(ByteInfo, Var2, ByteVar2),
- Code = node([test(ByteVar1, ByteVar2)]).
+ bytecode_gen__get_var_type(ByteInfo, Var1, Var1Type),
+ bytecode_gen__get_var_type(ByteInfo, Var2, Var2Type),
+
+ ( type_to_type_id(Var1Type, TypeId1, _),
+ type_to_type_id(Var2Type, TypeId2, _)
+ -> ( TypeId2 = TypeId1
+ -> true
+ ; error("unexpected simple_test between different types")
+ ),
+ TypeId = TypeId1
+ ; error("failed lookup of type id")
+ ),
+
+ ByteInfo = byte_info(_, _, ModuleInfo, _, _),
+
+ classify_type_id(ModuleInfo, TypeId, BuiltinType),
+
+ ( BuiltinType = int_type,
+ TestId = int_test
+
+ ; BuiltinType = char_type,
+ TestId = char_test
+
+ ; BuiltinType = str_type,
+ TestId = string_test
+
+ ; BuiltinType = float_type,
+ TestId = float_test
+
+ ; BuiltinType = enum_type,
+ TestId = enum_test
+
+ ; BuiltinType = pred_type,
+ error("unexpected pred_type in simple_test")
+
+ ; BuiltinType = tuple_type,
+ error("unexpected tuple_type in simple_test")
+
+ ; BuiltinType = user_type,
+ error("unexpected user_type in simple_test")
+
+ ; BuiltinType = polymorphic_type,
+ error("unexpected polymorphic_type in simple_test")
+
+ ),
+ Code = node([test(ByteVar1, ByteVar2, TestId)]).
bytecode_gen__unify(complicated_unify(_,_,_), _Var, _RHS, _ByteInfo, _Code) :-
error("complicated unifications should have been handled by polymorphism.m").
Index: compiler/code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_gen.m,v
retrieving revision 1.93
diff -u -r1.93 code_gen.m
--- compiler/code_gen.m 2001/02/05 00:46:40 1.93
+++ compiler/code_gen.m 2001/02/13 09:18:56
@@ -1239,8 +1239,7 @@
list(instruction)::out) is det.
code_gen__bytecode_stub(ModuleInfo, PredId, ProcId, BytecodeInstructions) :-
-
-% module_info_name(ModuleInfo, ModuleSymName),
+
module_info_pred_info(ModuleInfo, PredId, PredInfo),
pred_info_module(PredInfo, ModuleSymName),
@@ -1256,10 +1255,7 @@
int_to_string(Arity, ArityStr),
pred_info_get_is_pred_or_func(PredInfo, PredOrFunc),
- CallStructName = "bytecode_call__" ++
- (PredOrFunc = function -> "fn__" ; "") ++
- ModuleName ++ "__" ++ PredName ++ "_" ++ ArityStr ++ "_" ++
- ProcStr,
+ CallStructName = "bytecode_call_info",
append_list([
"\t\tstatic MB_Call ", CallStructName, " = {\n",
Index: compiler/llds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/llds_out.m,v
retrieving revision 1.172
diff -u -r1.172 llds_out.m
--- compiler/llds_out.m 2001/02/05 00:46:42 1.172
+++ compiler/llds_out.m 2001/02/08 04:31:12
@@ -421,7 +421,7 @@
),
globals__io_lookup_bool_option(generate_bytecode, GenBytecode),
( { GenBytecode = yes },
- io__write_string("#include ""mb_interface.h""\n")
+ io__write_string("#include ""mb_interface_stub.h""\n")
; { GenBytecode = no }
).
--------------------------------------------------------------------------
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