Ajout du mini-GC.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@69 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
author: Xavier Leroy <xavier.leroy@inria.fr> 1995-07-07 12:11:38 +0000
committer: Xavier Leroy <xavier.leroy@inria.fr> 1995-07-07 12:11:38 +0000
commit: fd755dcfaa7677b7ca875f285054b64372c32956 (patch)
tree: 72d3aba4772a06b7be2ba1363cd38f5658de02d1
parent: 88c9b7656e073ed3ed922179db3497b835095392 (diff)
5 files changed, 539 insertions, 0 deletions
diff --git a/asmrun/compare.c b/asmrun/compare.c
new file mode 100644
index 000000000..2b10ccf4a
--- /dev/null
+++ b/asmrun/compare.c
@@ -0,0 +1,65 @@
+#include <stdio.h>
+#include "mlvalues.h"
+
+value equal(v1, v2)
+     value v1, v2;
+{
+  header_t hdr1, hdr2;
+  long size, i;
+
+ tailcall:
+  if (v1 == v2) return Val_true;
+  if (v1 & 1) return Val_false;
+  if (v1 & 1) return Val_false;
+  hdr1 = Header_val(v1) & ~Modified_mask;
+  hdr2 = Header_val(v2) & ~Modified_mask;
+  switch(Tag_header(hdr1)) {
+  case Closure_tag:
+  case Infix_tag:
+    fprintf(stderr, "equal between functions\n");
+    exit(2);
+  case String_tag:
+    if (hdr1 != hdr2) return Val_false;
+    size = Size_header(hdr1);
+    for (i = 0; i < size; i++)
+      if (Field(v1, i) != Field(v2, i)) return Val_false;
+    return Val_true;
+  case Double_tag:
+    if (Double_val(v1) == Double_val(v2))
+      return Val_true;
+    else
+      return Val_false;
+  case Abstract_tag:
+  case Finalized_tag:
+    fprintf(stderr, "equal between abstract types\n");
+    exit(2);
+  default:
+    if (hdr1 != hdr2) return Val_false;
+    size = Size_header(hdr1);
+    for (i = 0; i < size-1; i++)
+      if (equal(Field(v1, i), Field(v2, i)) == Val_false) return Val_false;
+    v1 = Field(v1, i);
+    v2 = Field(v2, i);
+    goto tailcall;
+  }
+}
+
+value notequal(v1, v2)
+     value v1, v2;
+{
+  return (4 - equal(v1, v2));
+}
+
+#define COMPARISON(name) \
+value name(v1, v2) \
+     value v1, v2; \
+{ \
+  fprintf(stderr, "%s not implemented.\n", #name); \
+  exit(2); \
+}
+
+COMPARISON(greaterequal)
+COMPARISON(lessequal)
+COMPARISON(greaterthan)
+COMPARISON(lessthan)
+
diff --git a/asmrun/debug.c b/asmrun/debug.c
new file mode 100644
index 000000000..ef22b0893
--- /dev/null
+++ b/asmrun/debug.c
@@ -0,0 +1,135 @@
+#include <stdio.h>
+#include "misc.h"
+#include "mlvalues.h"
+
+char * young_start, * young_ptr, * young_end;
+char * old_start, * old_ptr, * old_end;
+value ** remembered_start, ** remembered_ptr, ** remembered_end;
+
+void failed_assert(file, line)
+     char * file;
+     int line;
+{
+  fprintf(stderr, "Failed assertion, file %s, line %d\n", file, line);
+  exit(2);
+}
+
+extern unsigned long _etext;
+long current_break;
+
+/* Check that an object is (reasonably) well-formed */
+
+#define MAX_SIZE 63
+#define MAX_TAG 1
+
+void check_field(v)
+     value v;
+{
+  if (Is_int(v)) return;
+  Assert((v & (sizeof(value) - 1)) == 0);
+  Assert(v >= (long) &_etext && v <= (long) current_break);
+  if ((char *)v > young_start && (char *)v <= young_end) {
+    Assert((char *)v > young_ptr);
+  }
+}
+
+void check_value(v)
+     value v;
+{
+  header_t hdr, sz;
+  int i;
+
+  if (Is_int(v)) return;
+  check_field(v);
+  hdr = Header_val(v);
+  sz = Size_val(v);
+  Assert((hdr & 0x300) == 0);
+  switch(Tag_header(hdr)) {
+  case Double_tag:
+    Assert(sz == sizeof(double) / sizeof(value));
+    break;
+  case String_tag:
+    i = ((char *)v)[sz * sizeof(value) - 1];
+    Assert(i >= 0 && i < sizeof(value));
+    Assert(((char *)v)[sz * sizeof(value) - 1 - i] == 0);
+    break;
+  case Abstract_tag:
+  case Finalized_tag:
+    Assert(0);
+    break;
+  case Infix_tag:
+    v -= sz * sizeof(value);
+    Assert(Header_val(v) == Closure_tag);
+    check_value(v);
+    break;
+  case Closure_tag:
+    Assert(Field(v, 0) < (long)&_etext);
+    if (Field(v, 1) == Val_int(1)) {
+      i = 2;
+    } else {
+      Assert(Is_int(Field(v, 1)));
+      Assert(Field(v, 2) < (long)&_etext);
+      i = 3;
+    }
+    while(1) {
+      hdr = (header_t) Field(v, i);
+      if (Tag_header(hdr) != Infix_tag) break;
+      i++;
+      Assert(Size_header(hdr) == i);
+      Assert(Field(v, i) < (long)&_etext);
+      i++;
+      if (Field(v, i) == Val_int(1)) {
+        i++;
+      } else {
+        Assert(Is_int(Field(v, i)));
+        i++;
+        Assert(Field(v, i) < (long)&_etext);
+        i++;
+      }
+    }
+    for (/*nothing*/; i < sz; i++) check_field(Field(v, i));
+    break;
+  default:
+#ifdef MAX_SIZE
+    Assert(sz <= MAX_SIZE);
+#endif
+#ifdef MAX_TAG
+    Assert(Tag_header(hdr) <= MAX_TAG);
+#endif
+    for (i = 0; i < sz; i++) check_field(Field(v, i));
+    break;
+  }
+}
+
+/* Check that a heap chunk is well-formed */
+
+void check_heap(start, end)
+     char * start;
+     char * end;
+{
+  char * p;
+  value v;
+
+  current_break = sbrk(0);
+  p = start;
+  while (p < end) {
+    v = (value)(p + sizeof(header_t));
+    check_value(v);
+    p += sizeof(header_t) + Size_val(v) * sizeof(value);
+  }
+  Assert(p == end);
+}
+
+/* Check the globals */
+
+extern value * caml_globals[];
+
+void check_globals()
+{
+  int i;
+  current_break = sbrk(0);
+  for (i = 0; caml_globals[i] != 0; i++) {
+    value v = *(caml_globals[i]);
+    if (v != 0) check_value(v);
+  }
+}
diff --git a/asmrun/gc.c b/asmrun/gc.c
new file mode 100644
index 000000000..f1775ef61
--- /dev/null
+++ b/asmrun/gc.c
@@ -0,0 +1,298 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include "misc.h"
+#include "mlvalues.h"
+
+char * young_start, * young_ptr, * young_end;
+char * old_start, * old_ptr, * old_end;
+value ** remembered_start, ** remembered_ptr, ** remembered_end;
+
+/* Heap initialization */
+
+int young_size = 32 * sizeof(value) * 1024; /* 128K / 256K */
+int old_size = 256 * sizeof(value) * 1024;  /* 1M / 2M */
+int remembered_size = 4096;
+
+void init_heap()
+{
+  young_start = malloc(young_size);
+  old_start = malloc(old_size);
+  remembered_start =
+    (value **) malloc(remembered_size * sizeof(value *));
+  if (young_start == NULL ||
+      old_start == NULL ||
+      remembered_start == NULL) {
+    fprintf(stderr, "Cannot allocate initial heap\n");
+    exit(2);
+  }
+  young_end = young_start + young_size;
+  young_ptr = young_end;
+  old_end = old_start + old_size;
+  old_ptr = old_start;
+  remembered_end = remembered_start + remembered_size;
+  remembered_ptr = remembered_start;
+}
+
+/* The hashtable of frame descriptors */
+
+typedef struct {
+  unsigned long retaddr;
+  short frame_size;
+  short num_live;
+  short live_ofs[1];
+} frame_descr;
+
+static frame_descr ** frame_descriptors = NULL;
+static int frame_descriptors_mask;
+
+#define Hash_retaddr(addr) \
+  (((unsigned long)(addr) >> 2) & frame_descriptors_mask)
+
+extern long * caml_frametable[];
+
+static void init_frame_descriptors()
+{
+  long num_descr, tblsize, i, j, len;
+  long * tbl;
+  frame_descr * d;
+  unsigned long h;
+
+  /* Count the frame descriptors */
+  num_descr = 0;
+  for (i = 0; caml_frametable[i] != 0; i++)
+    num_descr += *(caml_frametable[i]);
+
+  /* The size of the hashtable is a power of 2 greater or equal to
+     4 times the number of descriptors */
+  tblsize = 4;
+  while (tblsize < 4 * num_descr) tblsize *= 2;
+
+  /* Allocate the hash table */
+  frame_descriptors =
+    (frame_descr **) malloc(tblsize * sizeof(frame_descr *));
+  for (i = 0; i < tblsize; i++) frame_descriptors[i] = NULL;
+  frame_descriptors_mask = tblsize - 1;
+
+  /* Fill the hash table */
+  for (i = 0; caml_frametable[i] != 0; i++) {
+    tbl = caml_frametable[i];
+    len = *tbl;
+    d = (frame_descr *)(tbl + 1);
+    for (j = 0; j < len; j++) {
+      h = Hash_retaddr(d->retaddr);
+      while (frame_descriptors[h] != NULL) {
+        h = (h+1) & frame_descriptors_mask;
+      }
+      frame_descriptors[h] = d;
+      d = (frame_descr *)
+        (((unsigned long)d +
+          sizeof(char *) + sizeof(short) + sizeof(short) +
+          sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
+         & -sizeof(frame_descr *));
+    }
+  }
+}
+
+/* Copy an object (but not its descendents) and overwrite it with
+   its new location */
+
+#define Forward_mask 0x100
+
+#if defined(__GNUC__) && !defined(DEBUG)
+static inline
+#else
+static
+#endif
+void copy_obj(addr)
+     value * addr;
+{
+  value v, res;
+  header_t hdr, size, ofs, i;
+
+  v = *addr;
+  if (Is_int(v) || (char *) v <= young_start || (char *) v > young_end)
+    return;
+  hdr = Header_val(v);
+  if (hdr & Forward_mask) {     /* Already copied? */
+    res = Field(v, 0);          /* Forwarding pointer is in field 0 */
+  } else if (Tag_header(hdr) != Infix_tag) {
+    size = Size_header(hdr);
+    res = (value) (old_ptr + sizeof(header_t));
+    old_ptr += sizeof(header_t) + size * sizeof(value);
+    Header_val(res) = hdr & ~Modified_mask;
+    for (i = 0; i < size; i++)
+      Field(res, i) = Field(v, i);
+    Header_val(v) = hdr | Forward_mask; /* Set forward mark */
+    Field(v, 0) = res;                  /* Store forwarding pointer */
+  } else {
+    ofs = Size_header(hdr) * sizeof(value);
+    v -= ofs;
+    hdr = Header_val(v);
+    if (hdr & Forward_mask) {
+      res = Field(v, 0);
+    } else {
+      size = Size_header(hdr);
+      res = (value) (old_ptr + sizeof(header_t));
+      Header_val(res) = hdr & ~Modified_mask;
+      old_ptr += sizeof(header_t) + size * sizeof(value);
+      for (i = 0; i < size; i++)
+        Field(res, i) = Field(v, i);
+      Header_val(v) = hdr | Forward_mask;
+      Field(v, 0) = res;
+    }
+    res += ofs;
+  }
+  *addr = res;
+}
+
+/* Machine-dependent stack frame accesses */
+
+#ifdef __alpha__
+#define Saved_return_address(sp) *((long *)(sp - 8))
+#if 0
+#define Already_scanned(sp, retaddr) (retaddr & 1)
+#define Mark_scanned(sp, retaddr) (*((long *)(sp - 8)) = retaddr | 1)
+#else
+#define Already_scanned(sp, retaddr) 0
+#define Mark_scanned(sp, retaddr)
+#endif
+#endif
+
+extern value * caml_globals[];
+extern char * caml_bottom_of_stack, * caml_top_of_stack;
+extern unsigned long caml_last_return_address;
+extern value gc_entry_regs[];
+
+/* Copy everything in the minor heap */
+
+static void minor_collection()
+{
+  char * scan_ptr, * sp;
+  unsigned long retaddr;
+  frame_descr * d;
+  unsigned long h;
+  int i, n, ofs;
+  short * p;
+  value v;
+  header_t hdr, size;
+  value * root, ** rem;
+
+  scan_ptr = old_ptr;
+
+  /* Copy the global values */
+  for (i = 0; caml_globals[i] != 0; i++) copy_obj(caml_globals[i]);
+
+  /* Stack roots */
+  if (frame_descriptors == NULL) init_frame_descriptors();
+  sp = caml_bottom_of_stack;
+  retaddr = caml_last_return_address;
+
+  while (sp < caml_top_of_stack) {
+    /* Find the descriptor corresponding to the return address */
+    h = Hash_retaddr(retaddr);
+    while(1) {
+      d = frame_descriptors[h];
+      if (d->retaddr == retaddr) break;
+      h = (h+1) & frame_descriptors_mask;
+    }
+    /* Scan the roots in this frame */
+    for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) {
+      ofs = *p;
+      if (ofs >= 0) {
+        Assert(ofs < d->frame_size);
+        root = (value *)(sp + ofs);
+      } else {
+        Assert(ofs >= -32);
+        root = &gc_entry_regs[-ofs-1];
+      }
+      copy_obj(root);
+    }
+    /* Move to next frame */
+    sp += d->frame_size;
+    retaddr = Saved_return_address(sp);
+    /* Stop here if already scanned */
+    if (Already_scanned(sp, retaddr)) break;
+    /* Mark frame as already scanned */
+    Mark_scanned(sp, retaddr);
+  }
+
+  /* Scan the remembered set */
+  for (rem = remembered_start; rem < remembered_ptr; rem++) {
+    v = **rem;
+    hdr = Header_val(v);
+    if (hdr < No_scan_tag) {
+      size = Size_header(hdr);
+      for (i = 0; i < size; i++) copy_obj(&Field(v, i));
+    }
+    Header_val(v) &= ~Modified_mask;
+  }
+
+  /* Finish the copying */
+
+  while (scan_ptr < old_ptr) {
+    v = (value) (scan_ptr + sizeof(header_t));
+    hdr = Header_val(v);
+    size = Size_header(hdr);
+    if (Tag_header(hdr) < No_scan_tag) {
+      for (i = 0; i < size; i++) copy_obj(&Field(v, i));
+    }
+    scan_ptr += sizeof(header_t) + size * sizeof(value);
+  }
+
+  /* Reset allocation pointers */
+  young_ptr = young_end;
+  remembered_ptr = remembered_start;
+}
+
+/* Garbage collection */
+
+void garbage_collection(request)
+     unsigned long request;
+{
+  char * initial_old_ptr;
+
+  fprintf(stderr, "<"); fflush(stderr);
+#ifdef DEBUG
+  Assert(young_ptr <= young_end);
+  Assert(young_ptr < young_start);
+  Assert(young_ptr + request >= young_start);
+  check_globals();
+  check_heap(young_ptr + request, young_end);
+  check_heap(old_start, old_ptr);
+#endif
+  if (old_end - old_ptr < young_size) {
+    fprintf(stderr, "reallocating old generation "); fflush(stderr);
+    old_start = malloc(old_size);
+    if (old_start == NULL) {
+      fprintf(stderr, "Cannot extend heap\n");
+      exit(2);
+    }
+    old_end = old_start + old_size;
+    old_ptr = old_start;
+  }
+  initial_old_ptr = old_ptr;
+  minor_collection();
+#ifdef DEBUG
+  check_globals();
+  check_heap(old_start, old_ptr);
+#endif
+  young_ptr -= request;
+  fprintf(stderr, "%d%%>", ((old_ptr - initial_old_ptr) * 100) / young_size);
+  fflush(stderr);
+}
+
+/* Reallocate remembered set */
+
+void realloc_remembered()
+{
+  int used = remembered_ptr - remembered_start;
+  remembered_size *= 2;
+  remembered_start =
+    (value **) realloc(remembered_start, remembered_size);
+  if (remembered_start == NULL) {
+    fprintf(stderr, "Cannot reallocate remembered set\n");
+    exit(2);
+  }
+  remembered_end = remembered_start + remembered_size;
+  remembered_ptr = remembered_start + used;
+}
diff --git a/asmrun/misc.h b/asmrun/misc.h
new file mode 100644
index 000000000..edead293c
--- /dev/null
+++ b/asmrun/misc.h
@@ -0,0 +1,5 @@
+#ifdef DEBUG
+#define Assert(x) if(!(x)) failed_assert(__FILE__, __LINE__)
+#else
+#define Assert(x)
+#endif
diff --git a/asmrun/mlvalues.h b/asmrun/mlvalues.h
new file mode 100644
index 000000000..b05a134ac
--- /dev/null
+++ b/asmrun/mlvalues.h
@@ -0,0 +1,36 @@
+typedef long value;
+
+#define Long_val(v) ((v) >> 1)
+#define Val_long(n) (((long)(n) << 1) + 1)
+#define Int_val(v) ((v) >> 1)
+#define Val_int(n) (((n) << 1) + 1)
+
+#define Is_int(v) ((v) & 1)
+#define Is_block(v) (((v) & 1) == 0)
+
+typedef unsigned long header_t;
+
+#define Header_val(v) *((header_t *)(v) - 1)
+#define Tag_header(h) ((h) & 0xFF)
+#define Size_header(h) ((h) >> 11)
+#define Tag_val(v) Tag_header(Header_val(v))
+#define Size_val(v) Size_header(Header_val(v))
+
+#define Field(v, n) (((value *)(v))[n])
+
+#define Double_val(v) *((double *)(v))
+
+#define No_scan_tag 0xFB
+
+#define Closure_tag 0xFA
+#define Double_tag 0xFB
+#define String_tag 0xFC
+#define Abstract_tag 0xFD
+#define Finalized_tag 0xFE
+#define Infix_tag 0xFF
+
+#define Modified_mask 0x400
+
+#define Val_false 1
+#define Val_true 3
+#define Val_unit 1
author	Xavier Leroy <xavier.leroy@inria.fr>	1995-07-07 12:11:38 +0000
committer	Xavier Leroy <xavier.leroy@inria.fr>	1995-07-07 12:11:38 +0000
commit	fd755dcfaa7677b7ca875f285054b64372c32956 (patch)
tree	72d3aba4772a06b7be2ba1363cd38f5658de02d1
parent	88c9b7656e073ed3ed922179db3497b835095392 (diff)