summaryrefslogtreecommitdiff
path: root/byterun
diff options
context:
space:
mode:
Diffstat (limited to 'byterun')
-rw-r--r--byterun/compare.c2
-rw-r--r--byterun/extern.c3
-rw-r--r--byterun/hash.c7
-rw-r--r--byterun/major_gc.c6
-rw-r--r--byterun/major_gc.h3
-rw-r--r--byterun/minor_gc.c31
-rw-r--r--byterun/minor_gc.h3
-rw-r--r--byterun/misc.c3
-rw-r--r--byterun/misc.h6
-rw-r--r--byterun/mlvalues.h21
-rw-r--r--byterun/obj.c6
11 files changed, 69 insertions, 22 deletions
diff --git a/byterun/compare.c b/byterun/compare.c
index 6b95269144..14bec7b4f1 100644
--- a/byterun/compare.c
+++ b/byterun/compare.c
@@ -84,6 +84,8 @@ static long compare_val(value v1, value v2)
sp = compare_stack;
while (1) {
+ while (Is_block (v1) && Tag_val (v1) == Forward_tag) v1 = Forward_val (v1);
+ while (Is_block (v2) && Tag_val (v2) == Forward_tag) v2 = Forward_val (v2);
if (v1 == v2) goto next_item;
if (Is_long(v1)) {
if (Is_long(v2))
diff --git a/byterun/extern.c b/byterun/extern.c
index eae5530aa6..c03e1ea955 100644
--- a/byterun/extern.c
+++ b/byterun/extern.c
@@ -317,6 +317,9 @@ static void extern_rec(value v)
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec(v - Infix_offset_hd(hd));
break;
+ case Forward_tag:
+ v = Forward_val (v);
+ goto tailcall;
case Object_tag:
extern_invalid_argument("output_value: object value");
break;
diff --git a/byterun/hash.c b/byterun/hash.c
index 0138669734..24cd96df12 100644
--- a/byterun/hash.c
+++ b/byterun/hash.c
@@ -49,6 +49,7 @@ static void hash_aux(value obj)
hash_univ_limit--;
if (hash_univ_count < 0 || hash_univ_limit < 0) return;
+ again:
if (Is_long(obj)) {
hash_univ_count--;
Combine(Long_val(obj));
@@ -57,7 +58,8 @@ static void hash_aux(value obj)
/* Pointers into the heap are well-structured blocks. So are atoms.
We can inspect the block contents. */
-
+
+ Assert (Is_block (obj));
if (Is_atom(obj) || Is_young(obj) || Is_in_heap(obj)) {
tag = Tag_val(obj);
switch (tag) {
@@ -104,6 +106,9 @@ static void hash_aux(value obj)
case Infix_tag:
hash_aux(obj - Infix_offset_val(obj));
break;
+ case Forward_tag:
+ obj = Forward_val (obj);
+ goto again;
case Object_tag:
hash_univ_count--;
Combine(Oid_val(obj));
diff --git a/byterun/major_gc.c b/byterun/major_gc.c
index 8196eb0cd1..8cb65eb322 100644
--- a/byterun/major_gc.c
+++ b/byterun/major_gc.c
@@ -119,8 +119,14 @@ static void mark_slice (long work)
if (Tag_hd (hd) < No_scan_tag){
for (i = 0; i < size; i++){
child = Field (v, i);
+ again:
if (Is_block (child) && Is_in_heap (child)) {
hd = Hd_val(child);
+ if (Tag_hd (hd) == Forward_tag){
+ child = Forward_val (child);
+ Field (v, i) = child;
+ goto again;
+ }
if (Tag_hd(hd) == Infix_tag) {
child -= Infix_offset_val(child);
hd = Hd_val(child);
diff --git a/byterun/major_gc.h b/byterun/major_gc.h
index 69142e4c78..2d516ca270 100644
--- a/byterun/major_gc.h
+++ b/byterun/major_gc.h
@@ -58,7 +58,8 @@ extern char *gc_sweep_hp;
#define Not_in_heap 0
#define Page(p) ((unsigned long) (p) >> Page_log)
#define Is_in_heap(p) \
- ((addr)(p) >= (addr)heap_start && (addr)(p) < (addr)heap_end \
+ (Assert (Is_block (p)), \
+ (addr)(p) >= (addr)heap_start && (addr)(p) < (addr)heap_end \
&& page_table [Page (p)])
void init_major_heap (asize_t);
diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c
index 915053c08e..d04dcd6c34 100644
--- a/byterun/minor_gc.c
+++ b/byterun/minor_gc.c
@@ -69,6 +69,9 @@ void set_minor_heap_size (asize_t size)
static value oldify_todo_list = NULL;
+/* Note that the tests on the tag depend on the fact that Infix_tag,
+ Forward_tag, and No_scan_tag are contiguous. */
+
void oldify_one (value v, value *p)
{
value result, field0;
@@ -84,18 +87,7 @@ void oldify_one (value v, value *p)
*p = Field (v, 0); /* then forward pointer is first field. */
}else{
tag = Tag_hd (hd);
- if (tag >= No_scan_tag){
- sz = Wosize_hd (hd);
- result = alloc_shr (sz, tag);
- for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
- Hd_val (v) = 0; /* Set forward flag */
- Field (v, 0) = result; /* and forward pointer. */
- *p = result;
- }else if (tag == Infix_tag){
- mlsize_t offset = Infix_offset_hd (hd);
- oldify_one (v - offset, p); /* This cannot recurse deeper than 1. */
- *p += offset;
- }else{
+ if (tag < Infix_tag){
sz = Wosize_hd (hd);
result = alloc_shr (sz, tag);
*p = result;
@@ -112,6 +104,21 @@ void oldify_one (value v, value *p)
v = field0;
goto tail_call;
}
+ }else if (tag >= No_scan_tag){
+ sz = Wosize_hd (hd);
+ result = alloc_shr (sz, tag);
+ for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
+ Hd_val (v) = 0; /* Set forward flag */
+ Field (v, 0) = result; /* and forward pointer. */
+ *p = result;
+ }else if (tag == Infix_tag){
+ mlsize_t offset = Infix_offset_hd (hd);
+ oldify_one (v - offset, p); /* This cannot recurse deeper than 1. */
+ *p += offset;
+ }else{
+ Assert (tag == Forward_tag);
+ v = Forward_val (v); /* Follow the forwarding */
+ goto tail_call; /* then oldify. */
}
}
}else{
diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h
index d520d98c72..7e7d894ac1 100644
--- a/byterun/minor_gc.h
+++ b/byterun/minor_gc.h
@@ -25,7 +25,8 @@ extern asize_t minor_heap_size;
extern int in_minor_collection;
#define Is_young(val) \
- ((addr)(val) < (addr)young_end && (addr)(val) > (addr)young_start)
+ (Assert (Is_block (val)), \
+ (addr)(val) < (addr)young_end && (addr)(val) > (addr)young_start)
extern void set_minor_heap_size (asize_t);
extern void empty_minor_heap (void);
diff --git a/byterun/misc.c b/byterun/misc.c
index c73c9b5f05..536bd1b4a8 100644
--- a/byterun/misc.c
+++ b/byterun/misc.c
@@ -23,12 +23,13 @@
#ifdef DEBUG
-void caml_failed_assert (char * expr, char * file, int line)
+int caml_failed_assert (char * expr, char * file, int line)
{
fprintf (stderr, "file %s; line %d ### Assertion failed: %s\n",
file, line, expr);
fflush (stderr);
exit (100);
+ return 1; /* not reached */
}
#endif
diff --git a/byterun/misc.h b/byterun/misc.h
index 139abe7619..37bc31a864 100644
--- a/byterun/misc.h
+++ b/byterun/misc.h
@@ -62,10 +62,10 @@ typedef char * addr;
/* Assertions */
#ifdef DEBUG
-#define CAMLassert(x) if (!(x)) caml_failed_assert ( #x , __FILE__, __LINE__)
-void caml_failed_assert (char *, char *, int) Noreturn;
+#define CAMLassert(x) ((x) ? 0 : caml_failed_assert ( #x , __FILE__, __LINE__))
+int caml_failed_assert (char *, char *, int) Noreturn;
#else
-#define CAMLassert(x)
+#define CAMLassert(x) 0
#endif
void fatal_error (char *msg) Noreturn;
diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h
index 5e61035694..2c3b6a0ac7 100644
--- a/byterun/mlvalues.h
+++ b/byterun/mlvalues.h
@@ -158,10 +158,17 @@ bits 63 10 9 8 7 0
typedef int32 opcode_t;
typedef opcode_t * code_t;
-/* Special case of tuples of fields: closures */
+/* NOTE: [Forward_tag] and [Infix_tag] must be just under
+ [No_scan_tag], with [Infix_tag] the lower one.
+ See [oldify_one] in minor_gc.c for more details.
-#define Closure_tag 250
-#define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */
+ NOTE: Update stdlib/obj.ml whenever you change the tags.
+ */
+
+/* Forward_tag: forwarding pointer that the GC may silently shortcut.
+ See stdlib/lazy.ml. */
+#define Forward_tag 250
+#define Forward_val(v) Field(v, 0)
/* If tag == Infix_tag : an infix header inside a closure */
/* Infix_tag must be odd so that the infix header is scanned as an integer */
@@ -177,6 +184,14 @@ typedef opcode_t * code_t;
#define Class_val(val) Field((val), 0)
#define Oid_val(val) Long_val(Field((val), 1))
+/* Special case of tuples of fields: closures */
+#define Closure_tag 247
+#define Code_val(val) (((code_t *) (val)) [0]) /* Also an l-value. */
+
+/* This tag is not special for the runtime, but it must not be used
+ for any constructor. See stdlib/lazy.ml. */
+#define Lazy_tag 246
+
/* Another special case: variants */
CAMLextern value hash_variant(char * tag);
diff --git a/byterun/obj.c b/byterun/obj.c
index 8b531f0d0f..d7ce07f641 100644
--- a/byterun/obj.c
+++ b/byterun/obj.c
@@ -51,6 +51,12 @@ CAMLprim value obj_tag(value arg)
return Val_int(Tag_val(arg));
}
+CAMLprim value obj_set_tag (value arg, value new_tag)
+{
+ Tag_val (arg) = Int_val (new_tag);
+ return Val_unit;
+}
+
CAMLprim value obj_block(value tag, value size)
{
value res;
View Lorry Controller Status