mlton-commit — [MLton-commit] Code commits

[MLton-commit] r4065

[Matthew F. <fl...@ml...>]

Added models target to check all models.
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile

----------------------------------------------------------------------

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile	2005-09-05 03:19:05 UTC (rev 4064)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile	2005-09-05 11:29:12 UTC (rev 4065)
@@ -21,10 +21,12 @@
 else
 FLAGS += -malign-loops=2 -malign-jumps=2 -malign-functions=5
 endif
+MODELS = A
 endif
 
 ifeq ($(TARGET_ARCH), amd64)
 FLAGS += -mtune=opteron
+MODELS = A AX B BX C CX G
 endif
 
 ifeq ($(TARGET_ARCH), sparc)
@@ -103,6 +105,14 @@
 		done;							\
 	) > gc.h
 
+.PHONY: models
+models: gc.c gc.h
+	(								\
+		for m in $(MODELS); do					\
+			$(CC) $(CFLAGS) -DGC_MODEL_$$m -c -o gc.$$m.o gc.c;	\
+		done;							\
+	)
+
 .PHONY: clean
 clean:
 	../bin/clean

[MLton-commit] r4064

[Matthew F. <fl...@ml...>]

More progress on refactoring GC.
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/align.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/array.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/array.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/assumptions.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/foreach.c
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/heap.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/mltongc.txt
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.c
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/pointer.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/pointer.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/thread.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h

----------------------------------------------------------------------

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile	2005-09-05 03:19:05 UTC (rev 4064)
@@ -48,18 +48,27 @@
 CFLAGS = -O2 -Wall -I. -D_FILE_OFFSET_BITS=64 $(FLAGS)
 DEBUGFLAGS = $(CFLAGS) -gstabs+ -g2
 
+## Order matters, as these are concatenated together to form "gc.c".
 CFILES = 								\
 	gc_prefix.c							\
 	debug.c								\
+	pointer.c							\
+	align.c								\
+	model.c								\
 	object.c							\
-	model.c								\
+	array.c								\
+	foreach.c							\
+	assumptions.c							\
 	gc_suffix.c
 
+## Order matters, as these are concatenated together to form "gc.h".
 HFILES = 								\
 	gc_prefix.h							\
 	util.h								\
+	pointer.h							\
 	model.h								\
 	object.h							\
+	array.h								\
 	stack.h								\
 	frame.h								\
 	thread.h							\

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO	2005-09-05 03:19:05 UTC (rev 4064)
@@ -9,3 +9,5 @@
         choosing the representation for Weaks based on the model and
         the alignment; also, the GC will need to bump the pointer to
         the word after the header to get GC_weak to overlay properly.
+* what type should be used for the size field in GC_heap?  I'm using
+        size_t currently, since that is the type needed by malloc.

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/align.c (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.c)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.c	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/align.c	2005-09-05 03:19:05 UTC (rev 4064)
@@ -0,0 +1,71 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+static inline uintptr_t align (uintptr_t a, uintptr_t b) {
+  assert (a >= 0);
+  assert (b >= 1);
+  a += b - 1;
+  a -= a % b;
+  return a;       
+}
+
+/*
+static inline W64 w64align (W64 a, uint b) {
+        W64 res;
+
+        assert (a >= 0);
+        assert (b >= 1);
+        res = a + b - 1;
+        res = res - res % b;
+        if (FALSE)
+                fprintf (stderr, "%llu = w64Align (%llu, %u)\n", res, a, b);
+        return res;
+}
+*/
+
+static bool isAligned (uintptr_t a, size_t b) {
+  return 0 == a % b;
+}
+
+#if ASSERT
+static bool isAlignedFrontier (GC_state s, pointer p) {
+  return isAligned ((uintptr_t)p + GC_NORMAL_HEADER_SIZE, s->alignment);
+}
+
+/*
+static bool isAlignedReserved (GC_state s, uint r) {
+  return isAligned (STACK_HEADER_SIZE + sizeof (struct GC_stack) + r, 
+                    s->alignment);
+}
+*/
+#endif
+
+static inline size_t pad (GC_state s, size_t bytes, size_t extra) {
+  return align (bytes + extra, s->alignment) - extra;
+}
+
+/*
+static inline pointer alignFrontier (GC_state s, pointer p) {
+  return (pointer) pad (s, (uintptr_t)p, GC_NORMAL_HEADER_SIZE);
+}
+
+pointer GC_alignFrontier (GC_state s, pointer p) {
+  return alignFrontier (s, p);
+}
+
+static inline uint stackReserved (GC_state s, uint r) {
+  uint res;
+  
+  res = pad (s, r, STACK_HEADER_SIZE + sizeof (struct GC_stack));
+  if (DEBUG_STACKS)
+    fprintf (stderr, "%s = stackReserved (%s)\n",
+             uintToCommaString (res),
+             uintToCommaString (r));
+  return res;
+}
+*/

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/array.c (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.c)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.c	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/array.c	2005-09-05 03:19:05 UTC (rev 4064)
@@ -0,0 +1,53 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+#if ASSERT
+static pointer arrayPointer (GC_state s, 
+                             pointer a, 
+                             uint32_t arrayIndex, 
+                             uint32_t pointerIndex) {
+  bool hasIdentity;
+  GC_header header;
+  uint16_t numNonObjptrs;
+  uint16_t numObjptrs;
+  GC_objectTypeTag tag;
+  
+  header = GC_getHeader (a);
+  SPLIT_HEADER();
+  assert (tag == ARRAY_TAG);
+
+  size_t bytesPerElement = 
+    numNonObjptrsToBytes(numNonObjptrs, ARRAY_TAG) 
+    + (numObjptrs * OBJPTR_SIZE);
+
+  return a
+    + arrayIndex * bytesPerElement
+    + numNonObjptrsToBytes(numNonObjptrs, tag) 
+    + pointerIndex * OBJPTR_SIZE;
+}
+#endif
+
+/* The number of bytes in an array, not including the header. */
+static inline size_t arrayNumBytes (GC_state s,
+                                    pointer p, 
+                                    uint16_t numObjptrs,
+                                    uint16_t numNonObjptrs) {
+  size_t bytesPerElement;
+  GC_arrayLength numElements;
+  size_t result;
+        
+  numElements = GC_arrayNumElements (p);
+  bytesPerElement = 
+    numNonObjptrsToBytes(numNonObjptrs, ARRAY_TAG) 
+    + (numObjptrs * OBJPTR_SIZE);
+  result = numElements * bytesPerElement;
+  /* Empty arrays have OBJPTR_SIZE bytes for the forwarding pointer. */
+  if (0 == result) 
+    result = OBJPTR_SIZE;
+  return pad (s, result, GC_ARRAY_HEADER_SIZE);
+}

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/array.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/array.h	2005-09-05 03:19:05 UTC (rev 4064)
@@ -0,0 +1,34 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/*
+ * Array objects have the following layout:
+ * 
+ * counter word32 :: 
+ * length word32 :: 
+ * header word32 :: 
+ * ( (non heap-pointers)* :: (heap pointers)* )*
+ *
+ * The counter word is used by mark compact GC.  The length word is
+ * the number of elements in the array.  Array elements have the same
+ * individual layout as normal objects, omitting the header word.
+ */
+typedef uint32_t GC_arrayLength;
+enum {
+  GC_ARRAY_LENGTH_SIZE =  sizeof(GC_arrayLength),
+  GC_ARRAY_COUNTER_SIZE = GC_ARRAY_LENGTH_SIZE,
+  GC_ARRAY_HEADER_SIZE =  GC_ARRAY_COUNTER_SIZE + GC_ARRAY_LENGTH_SIZE + GC_HEADER_SIZE,
+};
+
+static inline GC_arrayLength* GC_arrayNumElementsp (pointer a) {
+  return (GC_arrayLength*)(a - GC_HEADER_SIZE - GC_ARRAY_LENGTH_SIZE);
+}
+
+static inline GC_arrayLength GC_arrayNumElements (pointer a) {
+  return *(GC_arrayNumElementsp (a));
+}

Added: mlton/branches/on-20050822-x86_64-branch/runtime/gc/assumptions.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/assumptions.c	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/assumptions.c	2005-09-05 03:19:05 UTC (rev 4064)
@@ -0,0 +1,17 @@
+/* Copyright (C) 2005-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/*
+ * Various assumptions about the underlying C translator.  This is the
+ * place for characteristics that are not dictated by the C standard,
+ * but which are reasonable to assume on a wide variety of target
+ * platforms.  Working around these assumptions would be difficult.
+ */
+void checkAssumptions () {
+  assert(CHAR_BIT == 8);
+  /* assert(repof(uintptr_t) == TWOS); */
+}

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/foreach.c (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.c)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.c	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/foreach.c	2005-09-05 03:19:05 UTC (rev 4064)
@@ -0,0 +1,209 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+typedef void (*GC_pointerFun) (GC_state s, objptr *pp);
+
+static inline void maybeCall (GC_pointerFun f, GC_state s, objptr *pp) {
+  if (GC_isObjptr (*pp))
+    f (s, pp);
+}
+
+/* foreachGlobal (s, f)
+ * 
+ * Apply f to each global object pointer into the heap. 
+ */
+static inline void foreachGlobal (GC_state s, GC_pointerFun f) {
+  for (int i = 0; i < s->globalsSize; ++i) {
+    if (DEBUG_DETAILED)
+      fprintf (stderr, "foreachGlobal %u\n", i);
+    maybeCall (f, s, &s->globals [i]);
+  }
+  if (DEBUG_DETAILED)
+    fprintf (stderr, "foreachGlobal threads\n");
+  maybeCall (f, s, &s->callFromCHandler);
+  maybeCall (f, s, &s->currentThread);
+  maybeCall (f, s, &s->savedThread);
+  maybeCall (f, s, &s->signalHandler);
+}
+
+
+/* foreachPointerInObject (s, p, skipWeaks, f) 
+ * 
+ * Applies f to each object pointer in the object pointed to by p.
+ * Returns pointer to the end of object, i.e. just past object.
+ *
+ * If skipWeaks, then the object pointer in weak objects is skipped.
+ */
+static inline pointer foreachPointerInObject (GC_state s, 
+                                              pointer p,
+                                              bool skipWeaks,
+                                              GC_pointerFun f) {
+  bool hasIdentity;
+  GC_header header;
+  uint16_t numNonObjptrs;
+  uint16_t numObjptrs;
+  GC_objectTypeTag tag;
+
+  header = GC_getHeader (p);
+  SPLIT_HEADER();
+  if (DEBUG_DETAILED)
+    fprintf (stderr, 
+             "foreachPointerInObject ("FMTPTR")"
+             "  header = "FMTHDR
+             "  tag = %s"
+             "  numNonObjptrs = %d"
+             "  numObjptrs = %d\n", 
+             (intptr_t)p, header, tagToString (tag), 
+             numNonObjptrs, numObjptrs);
+  if (NORMAL_TAG == tag) {
+    p += numNonObjptrsToBytes(numNonObjptrs, NORMAL_TAG);
+    pointer max = p + (numObjptrs * OBJPTR_SIZE);
+    /* Apply f to all internal pointers. */
+    for ( ; p < max; p += OBJPTR_SIZE) {
+      if (DEBUG_DETAILED)
+        fprintf (stderr, 
+                 "p = "FMTPTR"  *p = "FMTOBJPTR"\n",
+                 (intptr_t)p, *(objptr*)p);
+      maybeCall (f, s, (objptr*)p);
+    }
+  } else if (WEAK_TAG == tag) {
+    p += numNonObjptrsToBytes(numNonObjptrs, NORMAL_TAG);
+    if (not skipWeaks and 1 == numObjptrs) {
+      maybeCall (f, s, (objptr*)p);
+      p += OBJPTR_SIZE;
+    }
+  } else if (ARRAY_TAG == tag) {
+    size_t bytesPerElement;
+    size_t dataBytes;
+    pointer max;
+    GC_arrayLength numElements;
+    
+    numElements = GC_arrayNumElements (p);
+    bytesPerElement = 
+      numNonObjptrsToBytes(numNonObjptrs, ARRAY_TAG) 
+      + (numObjptrs * OBJPTR_SIZE);
+    dataBytes = numElements * bytesPerElement;
+    /* Must check 0 == dataBytes before 0 == numPointers to correctly
+     * handle arrays when both are true.
+     */
+    if (0 == dataBytes)
+      /* Empty arrays have space for forwarding pointer. */
+      dataBytes = OBJPTR_SIZE;
+    else if (0 == numObjptrs)
+      /* No pointers to process. */
+      ;
+    else {
+      max = p + dataBytes;
+      if (0 == numNonObjptrs)
+        /* Array with only pointers. */
+        for (; p < max; p += OBJPTR_SIZE)
+          maybeCall (f, s, (objptr*)p);
+      else {
+        /* Array with a mix of pointers and non-pointers. */
+        size_t nonObjptrBytes;
+        size_t objptrBytes;
+        
+        nonObjptrBytes = numNonObjptrsToBytes(numNonObjptrs, ARRAY_TAG);
+        objptrBytes = numObjptrs * OBJPTR_SIZE;
+
+        /* For each array element. */
+        while (p < max) {
+          pointer max2;
+          
+          /* Skip the non-pointers. */
+          p += nonObjptrBytes;
+          max2 = p + objptrBytes;
+          /* For each internal pointer. */
+          for ( ; p < max2; p += OBJPTR_SIZE) 
+            maybeCall (f, s, (objptr*)p);
+        }
+      }
+      assert (p == max);
+      p -= dataBytes;
+    }
+    p += pad (s, dataBytes, GC_ARRAY_HEADER_SIZE);
+  } else { /* stack */
+/*     GC_stack stack; */
+/*     pointer top, bottom; */
+/*     int i; */
+/*     word returnAddress; */
+/*     GC_frameLayout *layout; */
+/*     GC_offsets frameOffsets; */
+    
+/*     assert (STACK_TAG == tag); */
+/*     stack = (GC_stack)p; */
+/*     bottom = stackBottom (s, stack); */
+/*     top = stackTop (s, stack); */
+/*     assert (stack->used <= stack->reserved); */
+/*     while (top > bottom) { */
+/*       /\* Invariant: top points just past a "return address". *\/ */
+/*       returnAddress = *(word*) (top - WORD_SIZE); */
+/*       if (DEBUG) { */
+/*         fprintf (stderr, "  top = %d  return address = ", */
+/*                  top - bottom); */
+/*         fprintf (stderr, "0x%08x.\n", returnAddress); */
+/*       } */
+/*       layout = getFrameLayout (s, returnAddress);  */
+/*       frameOffsets = layout->offsets; */
+/*       top -= layout->numBytes; */
+/*       for (i = 0 ; i < frameOffsets[0] ; ++i) { */
+/*         if (DEBUG) */
+/*           fprintf(stderr,  */
+/*                   "    offset %u  address 0x%08x\n",  */
+/*                   frameOffsets[i + 1], */
+/*                   (uint)(*(pointer*)(top + frameOffsets[i + 1]))); */
+/*         maybeCall(f, s,  */
+/*                   (pointer*) */
+/*                   (top + frameOffsets[i + 1])); */
+/*       } */
+/*     } */
+/*     assert(top == bottom); */
+/*     p += sizeof (struct GC_stack) + stack->reserved; */
+  }
+  return p;
+}
+
+/* foreachPointerInRange (s, front, back, skipWeaks, f)
+ *
+ * Apply f to each pointer between front and *back, which should be a
+ * contiguous sequence of objects, where front points at the beginning
+ * of the first object and *back points just past the end of the last
+ * object.  f may increase *back (for example, this is done by
+ * forward).  foreachPointerInRange returns a pointer to the end of
+ * the last object it visits.
+ *
+ * If skipWeaks, then the object pointer in weak objects is skipped.
+ */
+
+static inline pointer foreachPointerInRange (GC_state s, 
+                                             pointer front, 
+                                             pointer *back,
+                                             bool skipWeaks,
+                                             GC_pointerFun f) {
+  pointer b;
+
+  assert (isAlignedFrontier (s, front));
+  if (DEBUG_DETAILED)
+    fprintf (stderr, 
+             "foreachPointerInRange  front = "FMTPTR"  *back = "FMTPTR"\n",
+             (intptr_t)front, (intptr_t)(*back));
+  b = *back;
+  assert (front <= b);
+  while (front < b) {
+    while (front < b) {
+      assert (isAligned ((uintptr_t)front, GC_MODEL_MINALIGN));
+      if (DEBUG_DETAILED)
+        fprintf (stderr, 
+                 "front = "FMTPTR"  *back = "FMTPTR"\n",
+                 (intptr_t)front, (intptr_t)(*back));
+      front = foreachPointerInObject (s, toData (s, front), skipWeaks, f);
+    }
+    b = *back;
+  }
+  return front;
+}

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h	2005-09-05 03:19:05 UTC (rev 4064)
@@ -1,8 +1,18 @@
 
 typedef struct GC_state {
+  size_t alignment; /* */
+  objptr callFromCHandler; /* Handler for exported C calls (in heap). */
+  objptr currentThread; /* Currently executing thread (in heap). */
+  objptr *globals;
+  uint32_t globalsSize;
   struct GC_heap heap;
-  struct GC_heap secondaryHeap; /* Used for major copying collection. */
   GC_objectType *objectTypes; /* Array of object types. */
   uint32_t objectTypesSize; /* Cardinality of objectTypes array. */
+  objptr savedThread; /* Result of GC_copyCurrentThread.
+                       * Thread interrupted by arrival of signal.
+                       */
+  struct GC_heap secondaryHeap; /* Used for major copying collection. */
+  objptr signalHandler; /* Handler for signals (in heap). */
+  /*Bool*/bool summary; /* Print a summary of gc info when program exits. */
   GC_weak weaks; /* Linked list of (live) weak pointers */
 } *GC_state;

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/heap.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/heap.h	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/heap.h	2005-09-05 03:19:05 UTC (rev 4064)
@@ -18,6 +18,6 @@
 */
 
 typedef struct GC_heap {
-  uint32_t size;
+  size_t size;
   pointer start;          /* start of memory area */
 } *GC_heap;

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/mltongc.txt
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/mltongc.txt	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/mltongc.txt	2005-09-05 03:19:05 UTC (rev 4064)
@@ -284,7 +284,7 @@
    programs compiled on 64-bit architectures are essentially the same
    as those compiled on 32-bit architectures.  In particular, 2^19
    object types should remain viable for some time to come.  Likewise,
-   the 20 counter bits in the header word (used to implement the mark
+   the 10 counter bits in the header word (used to implement the mark
    stack) should continue to be sufficient for the number of heap
    pointers in a normal heap object.  Finally, 16-bits for the
    numNonPointers and numPointers fields of a GC_ObjectType will

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c	2005-09-05 03:19:05 UTC (rev 4064)
@@ -6,17 +6,20 @@
  */
 
 static inline pointer objptrToPointer (objptr O, pointer B) {
-  intptr_t O_ = (intptr_t)O;
-  intptr_t B_;
+  uintptr_t O_ = (uintptr_t)O;
+  uintptr_t B_;
+  unsigned int S_ = GC_MODEL_SHIFT;
+  uintptr_t P_;
   pointer P;
 
   if GC_MODEL_USEBASE {
-    B_ = (intptr_t)B;
+    B_ = (uintptr_t)B;
   } else {
     B_ = 0;
   }
 
-  P = (pointer)((O_ << GC_MODEL_SHIFT) + B_);
+  P_ = ((O_ << S_) + B_);
+  P = (pointer)P_;
   if (DEBUG_DETAILED) 
     fprintf (stderr, "objptrToPointer ("FMTOBJPTR") = "FMTPTR"\n", O, (intptr_t)P);
   
@@ -24,19 +27,52 @@
 }
 
 static inline objptr pointerToObjptr (pointer P, pointer B) {
-  intptr_t P_ = (intptr_t)P;
-  intptr_t B_;
+  uintptr_t P_ = (uintptr_t)P;
+  uintptr_t B_;
+  unsigned int S_ = GC_MODEL_SHIFT;
+  uintptr_t O_;
   objptr O;
 
   if GC_MODEL_USEBASE {
-    B_ = (intptr_t)B;
+    B_ = (uintptr_t)B;
   } else {
     B_ = 0;
   }
 
-  O = (objptr)((P_ - B_) >> GC_MODEL_SHIFT);
+  O_ = ((P_ - B_) >> S_);
+  O = (objptr)O_;
   if (DEBUG_DETAILED) 
     fprintf (stderr, "pointerToObjptr ("FMTPTR") = "FMTOBJPTR"\n", (intptr_t)P, O);
 
   return O;
 }
+
+/* GC_isObjptr returns true if p looks like an object pointer. */
+static inline bool GC_isObjptr (objptr p) {
+  if GC_MODEL_NONPTR {
+    unsigned int shift = GC_MODEL_MINALIGN_SHIFT - GC_MODEL_SHIFT;
+    objptr mask = ~((~((objptr)0)) << shift);
+    return (0 == (p & mask));
+  } else {
+    return TRUE;
+  }
+}
+
+/*
+ * Note that by indirectly fetching and storing object pointers, the
+ * following functions admit implementations that behave according to
+ * model characteristics determined at runtime.  Hence, by making
+ * exclusive use of these functions (and adding a GC_state->model
+ * field set by the compiled program), we may be able to implement the
+ * runtime in a manner which is agnostic to the actual objptr
+ * representation.
+ */
+static inline pointer fetchObjptrToPointer (pointer OP, pointer B) {
+  return objptrToPointer (*((objptr*)OP), B);
+}
+static inline void storeObjptrFromPointer (pointer OP, pointer P, pointer B) {
+  *((objptr*)OP) = pointerToObjptr (P, B);
+}
+static inline size_t objptrSize () {
+  return OBJPTR_SIZE;
+}

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h	2005-09-05 03:19:05 UTC (rev 4064)
@@ -28,7 +28,7 @@
 D       32      slow     16     4
 E       32      slow     32     8
 F       40      slow    256     4
-G       64      fast     4G     8
+G       64      fast     4G     4
 
 Each of the (A-F) has a variant (AX-FX) in which pointers are added to
 some constant base address.  This gives access to any region in the
@@ -139,35 +139,74 @@
 
 #if (defined (GC_MODEL_A))
 #define GC_MODEL_BITSIZE  32
-#define GC_MODEL_SHIFT  0
+#define GC_MODEL_SHIFT    0
 #define GC_MODEL_USEBASE  FALSE
+#define GC_MODEL_MINALIGN_SHIFT 2
 #elif (defined (GC_MODEL_AX))
-#define GC_MODEL_BITSIZE  32
-#define GC_MODEL_SHIFT  0
-#define GC_MODEL_USEBASE  TRUE
+#define GC_MODEL_BITSIZE 32
+#define GC_MODEL_SHIFT   0
+#define GC_MODEL_USEBASE TRUE
+#define GC_MODEL_MINALIGN_SHIFT 2
 #elif (defined (GC_MODEL_B))
-#define GC_MODEL_BITSIZE  32
-#define GC_MODEL_SHIFT  1
-#define GC_MODEL_USEBASE  FALSE
+#define GC_MODEL_BITSIZE 32
+#define GC_MODEL_SHIFT   1
+#define GC_MODEL_USEBASE FALSE
+#define GC_MODEL_MINALIGN_SHIFT 2
 #elif (defined (GC_MODEL_BX))
-#define GC_MODEL_BITSIZE  32
-#define GC_MODEL_SHIFT  1
-#define GC_MODEL_USEBASE  TRUE
+#define GC_MODEL_BITSIZE 32
+#define GC_MODEL_SHIFT   1
+#define GC_MODEL_USEBASE TRUE
+#define GC_MODEL_MINALIGN_SHIFT 2
 #elif (defined (GC_MODEL_C))
-#define GC_MODEL_BITSIZE  32
-#define GC_MODEL_SHIFT  2
-#define GC_MODEL_USEBASE  FALSE
+#define GC_MODEL_BITSIZE 32
+#define GC_MODEL_SHIFT   2
+#define GC_MODEL_USEBASE FALSE
+#define GC_MODEL_MINALIGN_SHIFT 3
 #elif (defined (GC_MODEL_CX))
+#define GC_MODEL_BITSIZE 32
+#define GC_MODEL_SHIFT   2
+#define GC_MODEL_USEBASE TRUE
+#define GC_MODEL_MINALIGN_SHIFT 3
+#elif (defined (GC_MODEL_D))
+#define GC_MODEL_BITSIZE 32
+#define GC_MODEL_SHIFT   2
+#define GC_MODEL_USEBASE FALSE
+#define GC_MODEL_MINALIGN_SHIFT 2
+#elif (defined (GC_MODEL_DX))
+#define GC_MODEL_BITSIZE 32
+#define GC_MODEL_SHIFT   2
+#define GC_MODEL_USEBASE TRUE
+#define GC_MODEL_MINALIGN_SHIFT 2
+#elif (defined (GC_MODEL_E))
+#define GC_MODEL_BITSIZE 32
+#define GC_MODEL_SHIFT   3
+#define GC_MODEL_USEBASE FALSE
+#define GC_MODEL_MINALIGN_SHIFT 3
+#elif (defined (GC_MODEL_EX))
 #define GC_MODEL_BITSIZE  32
-#define GC_MODEL_SHIFT  2
+#define GC_MODEL_SHIFT    3
 #define GC_MODEL_USEBASE  TRUE
+#define GC_MODEL_MINALIGN_SHIFT 3
+#elif (defined (GC_MODEL_F))
+#define GC_MODEL_BITSIZE  40
+#define GC_MODEL_SHIFT    0
+#define GC_MODEL_USEBASE  FALSE
+#define GC_MODEL_MINALIGN_SHIFT 2
+#elif (defined (GC_MODEL_EX))
+#define GC_MODEL_BITSIZE  40
+#define GC_MODEL_SHIFT    0
+#define GC_MODEL_USEBASE  TRUE
+#define GC_MODEL_MINALIGN_SHIFT 2
 #elif (defined (GC_MODEL_G))
 #define GC_MODEL_BITSIZE  64
-#define GC_MODEL_SHIFT  0
+#define GC_MODEL_SHIFT    0
 #define GC_MODEL_USEBASE  FALSE
+#define GC_MODEL_MINALIGN_SHIFT 2
 #else 
-#error gc model undefined
+#error gc model unknown
 #endif
+#define GC_MODEL_NONPTR ((GC_MODEL_MINALIGN_SHIFT - GC_MODEL_SHIFT) > 0)
+#define GC_MODEL_MINALIGN TWOPOWER(GC_MODEL_MINALIGN_SHIFT)
 
 #define OBJPTR_TYPE__(z) uint ## z ## _t
 #define OBJPTR_TYPE_(z) OBJPTR_TYPE__(z)
@@ -178,3 +217,9 @@
 #define PRIxOBJPTR_(z) PRIxOBJPTR__(z)
 #define PRIxOBJPTR PRIxOBJPTR_(GC_MODEL_BITSIZE)
 #define FMTOBJPTR "0x%016"PRIxOBJPTR
+
+#if GC_MODEL_NONPTR
+#define BOGUS_OBJPTR 0x1
+#else
+#error gc model does not admit bogus object pointer
+#endif

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.c	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.c	2005-09-05 03:19:05 UTC (rev 4064)
@@ -32,17 +32,17 @@
     t = &s->objectTypes [objectTypeIndex];                                      \
     tag = t->tag;                                                               \
     hasIdentity = t->hasIdentity;                                               \
-    numNonPointers = t->numNonPointers;                                         \
-    numPointers = t->numPointers;                                               \
+    numNonObjptrs = t->numNonObjptrs;                                           \
+    numObjptrs = t->numObjptrs;                                                 \
     if (DEBUG_DETAILED)                                                         \
       fprintf (stderr,                                                          \
                "SPLIT_HEADER ("FMTHDR")"                                        \
                "  tag = %s"                                                     \
                "  hasIdentity = %u"                                             \
-               "  numNonPointers = %"PRIu16                                     \
-               "  numPointers = %"PRIu16"\n",                                   \
+               "  numNonObjptrs = %"PRIu16                                      \
+               "  numObjptrs = %"PRIu16"\n",                                    \
                header,                                                          \
-               tagToString(tag), hasIdenity, numNonPointers, numPointers);      \
+               tagToString(tag), hasIdentity, numNonObjptrs, numObjptrs);       \
   } while (0)
 
 static char* tagToString (GC_objectTypeTag tag) {
@@ -59,3 +59,36 @@
     die ("bad tag %u", tag);
   }
 }
+
+/* If p points at the beginning of an object, then toData p returns a
+ * pointer to the start of the object data.
+ */
+static inline pointer toData (GC_state s, pointer p) {
+  GC_header header;
+  pointer res;
+
+  assert (isAlignedFrontier (s, p));
+  header = *(GC_header*)p;
+  if (0 == header)
+    /* Looking at the counter word in an array. */
+    res = p + GC_ARRAY_HEADER_SIZE;
+  else
+    /* Looking at a header word. */
+    res = p + GC_NORMAL_HEADER_SIZE;
+  assert (isAligned ((uintptr_t)res, s->alignment));
+  return res;
+}
+
+static inline size_t numNonObjptrsToBytes (uint16_t numNonObjptrs, 
+                                           GC_objectTypeTag tag) {
+  switch (tag) {
+  case ARRAY_TAG:
+    return (size_t)(numNonObjptrs);
+  case NORMAL_TAG:
+    return (size_t)(numNonObjptrs) * 4;
+  case WEAK_TAG:
+    return (size_t)(numNonObjptrs) * 4;
+  default:
+    die ("bad tag %u", tag);
+  }
+}

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h	2005-09-05 03:19:05 UTC (rev 4064)
@@ -42,6 +42,22 @@
   MARK_SHIFT =       31
 };
 
+/* GC_getHeaderp (p)
+ *
+ * Returns a pointer to the header for the object pointed to by p.
+ */
+static inline GC_header* GC_getHeaderp (pointer p) {
+  return (GC_header*)(p - GC_HEADER_SIZE);
+}
+
+/* GC_getHeader (p) 
+ *
+ * Returns the header for the object pointed to by p. 
+ */
+static inline GC_header GC_getHeader (pointer p) {
+  return *(GC_getHeaderp(p));
+}
+
 /*
  * Normal objects have the following layout:
  *
@@ -60,23 +76,7 @@
   GC_NORMAL_HEADER_SIZE = GC_HEADER_SIZE,
 };
 
-/*
- * Array objects have the following layout:
- * 
- * counter word32 :: 
- * length word32 :: 
- * header word32 :: 
- * ( (non heap-pointers)* :: (heap pointers)* )*
- *
- * The counter word is used by mark compact GC.  The length word is
- * the number of elements in the array.  Array elements have the same
- * individual layout as normal objects, omitting the header word.
- */
-enum {
-  GC_ARRAY_LENGTH_SIZE =  4,
-  GC_ARRAY_COUNTER_SIZE = GC_ARRAY_LENGTH_SIZE,
-  GC_ARRAY_HEADER_SIZE =  GC_ARRAY_COUNTER_SIZE + GC_ARRAY_LENGTH_SIZE + GC_HEADER_SIZE,
-};
+/* Array objects are described in "array.h" */
 
 /* Stack objects are described in "stack.h" */
 
@@ -94,22 +94,22 @@
  * of object types that is emitted for each compiled program.  The
  * hasIdentity field indicates whether or not the object has mutable
  * fields, in which case it may not be hash-cons-ed.  In a normal
- * object, the numNonPointers field indicates the number of 32-bit
- * words of non heap-pointer data, while the numPointers field
+ * object, the numNonObjptrs field indicates the number of 32-bit
+ * words of non heap-pointer data, while the numObjptrs field
  * indicates the number of heap pointers.  In an array object, the
- * numNonPointers field indicates the number of bytes of non
- * heap-pointer data, while the numPointers field indicates the number
- * of heap pointers.  In a stack object, the numNonPointers and
- * numPointers fields are irrelevant.  In a weak object, the
- * numNonPointers and numPointers fields are interpreted as in a
- * normal object (and, hence, must be (0,1) or (0,0)).
+ * numNonObjptrs field indicates the number of bytes of non
+ * heap-pointer data, while the numObjptrs field indicates the number
+ * of heap pointers.  In a stack object, the numNonObjptrs and
+ * numObjptrs fields are irrelevant.  In a weak object, the
+ * numNonObjptrs and numObjptrs fields are interpreted as in a normal
+ * object (and, hence, must be (2,1) or (3,0)).
 */
 typedef struct {
         /* Keep tag first, at zero offset, since it is referenced most often. */
         GC_objectTypeTag tag;
         bool hasIdentity;
-        uint16_t numNonPointers;
-        uint16_t numPointers;
+        uint16_t numNonObjptrs;
+        uint16_t numObjptrs;
 } GC_objectType;
 enum {
   /* The type indices here must agree with those in backend/rep-type.fun. */

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/pointer.c (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/pointer.c	2005-09-05 03:19:05 UTC (rev 4064)
@@ -0,0 +1,13 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/* GC_isPointer returns true if p looks like a pointer. */
+static inline bool GC_isPointer (pointer p) {
+  uintptr_t mask = ~((~((uintptr_t)0)) << GC_MODEL_MINALIGN_SHIFT);
+  return (0 == ((uintptr_t)p & mask));
+}

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/pointer.h (from rev 4063, mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/pointer.h	2005-09-05 03:19:05 UTC (rev 4064)
@@ -0,0 +1,11 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+typedef unsigned char* pointer;
+#define FMTPTR "0x%016"PRIxPTR
+#define BOGUS_POINTER 0x1

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.h	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.h	2005-09-05 03:19:05 UTC (rev 4064)
@@ -27,7 +27,7 @@
   /* markTop and markIndex are only used during marking.  They record
    * the current pointer in the stack that is being followed.  markTop
    * points to the top of the stack frame containing the pointer and
-   * markI is the index in that frames frameOffsets of the pointer
+   * markIndex is the index in that frames frameOffsets of the pointer
    * slot.  So, when the GC pointer reversal gets back to the stack,
    * it can continue with the next pointer (either in the current
    * frame or the next frame).

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/thread.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/thread.h	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/thread.h	2005-09-05 03:19:05 UTC (rev 4064)
@@ -21,3 +21,5 @@
                           */
   objptr stack;          /* The stack for this thread. */
 } *GC_thread;
+
+#define BOGUS_THREAD (GC_thread)BOGUS_POINTER

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h	2005-09-04 11:56:31 UTC (rev 4063)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h	2005-09-05 03:19:05 UTC (rev 4064)
@@ -5,10 +5,6 @@
  * MLton is released under a BSD-style license.
  * See the file MLton-LICENSE for details.
  */
-
-#ifndef _UTIL_H_
-#define _UTIL_H_
-
 #define _ISOC99_SOURCE
 #define _BSD_SOURCE
 
@@ -26,6 +22,8 @@
 #include <stdio.h>
 #include <stdint.h>
 #include <inttypes.h>
+#include <stdlib.h>
+#include <limits.h>
 
 #include "../assert.h"
 
@@ -47,8 +45,3 @@
 extern void diee (char *fmt, ...)
                         __attribute__ ((format(printf, 1, 2)))
                         __attribute__ ((noreturn));
-
-typedef void* pointer;
-#define FMTPTR "0x%016"PRIxPTR
-
-#endif /* _UTIL_H_ */

[MLton-commit] r4063

[Matthew F. <fl...@ml...>]

Better mnemonics for model.
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h

----------------------------------------------------------------------

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c	2005-09-04 11:44:16 UTC (rev 4062)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c	2005-09-04 11:56:31 UTC (rev 4063)
@@ -10,13 +10,13 @@
   intptr_t B_;
   pointer P;
 
-  if GC_MODEL_B {
+  if GC_MODEL_USEBASE {
     B_ = (intptr_t)B;
   } else {
     B_ = 0;
   }
 
-  P = (pointer)((O_ << GC_MODEL_S) + B_);
+  P = (pointer)((O_ << GC_MODEL_SHIFT) + B_);
   if (DEBUG_DETAILED) 
     fprintf (stderr, "objptrToPointer ("FMTOBJPTR") = "FMTPTR"\n", O, (intptr_t)P);
   
@@ -28,13 +28,13 @@
   intptr_t B_;
   objptr O;
 
-  if GC_MODEL_B {
+  if GC_MODEL_USEBASE {
     B_ = (intptr_t)B;
   } else {
     B_ = 0;
   }
 
-  O = (objptr)((P_ - B_) >> GC_MODEL_S);
+  O = (objptr)((P_ - B_) >> GC_MODEL_SHIFT);
   if (DEBUG_DETAILED) 
     fprintf (stderr, "pointerToObjptr ("FMTPTR") = "FMTOBJPTR"\n", (intptr_t)P, O);
 

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h	2005-09-04 11:44:16 UTC (rev 4062)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h	2005-09-04 11:56:31 UTC (rev 4063)
@@ -135,16 +135,46 @@
 manageable set for users.
 */
 
-#define GC_MODEL_Z  32
-#define GC_MODEL_S  1
-#define GC_MODEL_B  TRUE
+#define GC_MODEL_G
 
+#if (defined (GC_MODEL_A))
+#define GC_MODEL_BITSIZE  32
+#define GC_MODEL_SHIFT  0
+#define GC_MODEL_USEBASE  FALSE
+#elif (defined (GC_MODEL_AX))
+#define GC_MODEL_BITSIZE  32
+#define GC_MODEL_SHIFT  0
+#define GC_MODEL_USEBASE  TRUE
+#elif (defined (GC_MODEL_B))
+#define GC_MODEL_BITSIZE  32
+#define GC_MODEL_SHIFT  1
+#define GC_MODEL_USEBASE  FALSE
+#elif (defined (GC_MODEL_BX))
+#define GC_MODEL_BITSIZE  32
+#define GC_MODEL_SHIFT  1
+#define GC_MODEL_USEBASE  TRUE
+#elif (defined (GC_MODEL_C))
+#define GC_MODEL_BITSIZE  32
+#define GC_MODEL_SHIFT  2
+#define GC_MODEL_USEBASE  FALSE
+#elif (defined (GC_MODEL_CX))
+#define GC_MODEL_BITSIZE  32
+#define GC_MODEL_SHIFT  2
+#define GC_MODEL_USEBASE  TRUE
+#elif (defined (GC_MODEL_G))
+#define GC_MODEL_BITSIZE  64
+#define GC_MODEL_SHIFT  0
+#define GC_MODEL_USEBASE  FALSE
+#else 
+#error gc model undefined
+#endif
+
 #define OBJPTR_TYPE__(z) uint ## z ## _t
 #define OBJPTR_TYPE_(z) OBJPTR_TYPE__(z)
-#define OBJPTR_TYPE OBJPTR_TYPE_(GC_MODEL_Z)
+#define OBJPTR_TYPE OBJPTR_TYPE_(GC_MODEL_BITSIZE)
 typedef OBJPTR_TYPE objptr;
 #define OBJPTR_SIZE sizeof(objptr)
 #define PRIxOBJPTR__(z) PRIx ## z
 #define PRIxOBJPTR_(z) PRIxOBJPTR__(z)
-#define PRIxOBJPTR PRIxOBJPTR_(GC_MODEL_Z)
+#define PRIxOBJPTR PRIxOBJPTR_(GC_MODEL_BITSIZE)
 #define FMTOBJPTR "0x%016"PRIxOBJPTR

[MLton-commit] r4062

[Matthew F. <fl...@ml...>]

#define-s for formatting and debugging
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h

----------------------------------------------------------------------

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile	2005-09-04 02:08:38 UTC (rev 4061)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile	2005-09-04 11:44:16 UTC (rev 4062)
@@ -24,7 +24,7 @@
 endif
 
 ifeq ($(TARGET_ARCH), amd64)
-FLAGS += -mtune=opteron -m32
+FLAGS += -mtune=opteron
 endif
 
 ifeq ($(TARGET_ARCH), sparc)

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c	2005-09-04 02:08:38 UTC (rev 4061)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c	2005-09-04 11:44:16 UTC (rev 4062)
@@ -8,22 +8,35 @@
 static inline pointer objptrToPointer (objptr O, pointer B) {
   intptr_t O_ = (intptr_t)O;
   intptr_t B_;
+  pointer P;
+
   if GC_MODEL_B {
     B_ = (intptr_t)B;
   } else {
     B_ = 0;
   }
-  return (pointer)((O_ << GC_MODEL_S) + B_);
+
+  P = (pointer)((O_ << GC_MODEL_S) + B_);
+  if (DEBUG_DETAILED) 
+    fprintf (stderr, "objptrToPointer ("FMTOBJPTR") = "FMTPTR"\n", O, (intptr_t)P);
+  
+  return P;
 }
 
 static inline objptr pointerToObjptr (pointer P, pointer B) {
   intptr_t P_ = (intptr_t)P;
   intptr_t B_;
+  objptr O;
 
   if GC_MODEL_B {
     B_ = (intptr_t)B;
   } else {
     B_ = 0;
   }
-  return (objptr)((P_ - B_) >> GC_MODEL_S);
+
+  O = (objptr)((P_ - B_) >> GC_MODEL_S);
+  if (DEBUG_DETAILED) 
+    fprintf (stderr, "pointerToObjptr ("FMTPTR") = "FMTOBJPTR"\n", (intptr_t)P, O);
+
+  return O;
 }

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h	2005-09-04 02:08:38 UTC (rev 4061)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h	2005-09-04 11:44:16 UTC (rev 4062)
@@ -14,8 +14,8 @@
 C. 32 bits, with bottom bit zero, shift left by two.
 D. 32 bits, shift left by two.
 E. 32 bits, shift left by three.
-F. 40 bits.
-G. 64 bits.
+F. 40 bits, with bottom two bits zero.
+G. 64 bits, with bottom two bits zero.
 
 These schemes vary in the number of bits to represent a pointer in an
 object, the time to load a pointer from memory into a register, the
@@ -51,9 +51,9 @@
 
                              =================================      E
 
-                         ========================================   F
+                         ======================================00   F
 
- ================================================================   G
+ ==============================================================00   G
 
 Algorithmically, we can compute the native pointer (P) from the object
 pointer (O) (with bitsize Z), given a shift (S) and a base (B):
@@ -126,7 +126,6 @@
 (G) costs the most in space, but has the fastest load time for
 pointers of the schemes that allow access to 4G of memory.
 
-
 A reasonable tradeoff in implementation complexity vs allowing our
 users enough flexibility might be to provide:
 
@@ -139,8 +138,13 @@
 #define GC_MODEL_Z  32
 #define GC_MODEL_S  1
 #define GC_MODEL_B  TRUE
+
 #define OBJPTR_TYPE__(z) uint ## z ## _t
 #define OBJPTR_TYPE_(z) OBJPTR_TYPE__(z)
 #define OBJPTR_TYPE OBJPTR_TYPE_(GC_MODEL_Z)
 typedef OBJPTR_TYPE objptr;
 #define OBJPTR_SIZE sizeof(objptr)
+#define PRIxOBJPTR__(z) PRIx ## z
+#define PRIxOBJPTR_(z) PRIxOBJPTR__(z)
+#define PRIxOBJPTR PRIxOBJPTR_(GC_MODEL_Z)
+#define FMTOBJPTR "0x%016"PRIxOBJPTR

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h	2005-09-04 02:08:38 UTC (rev 4061)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h	2005-09-04 11:44:16 UTC (rev 4062)
@@ -49,6 +49,6 @@
                         __attribute__ ((noreturn));
 
 typedef void* pointer;
-#define FMTPTR "0x%08"PRIxPTR
+#define FMTPTR "0x%016"PRIxPTR
 
 #endif /* _UTIL_H_ */

[MLton-commit] r4061

[Matthew F. <fl...@ml...>]

More framework
----------------------------------------------------------------------

U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/cheney-copy.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/frame.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h
U   mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/thread.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/weak.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/weak.h

----------------------------------------------------------------------

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile	2005-09-04 00:58:04 UTC (rev 4060)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile	2005-09-04 02:08:38 UTC (rev 4061)
@@ -58,8 +58,12 @@
 HFILES = 								\
 	gc_prefix.h							\
 	util.h								\
+	model.h								\
 	object.h							\
-	model.h								\
+	stack.h								\
+	frame.h								\
+	thread.h							\
+	weak.h								\
 	heap.h								\
 	gc_state.h							\
 	gc_suffix.h

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO	2005-09-04 00:58:04 UTC (rev 4060)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO	2005-09-04 02:08:38 UTC (rev 4061)
@@ -3,4 +3,9 @@
 * eliminate STRING_TYPE_INDEX, STRING_TYPE_HEADER in favor or WORD8.
 * fix semantics of numNonPointers for normal objects to mean bytes of
         non-pointer data, rather than number of 32-bit words of
-        non-pointer data.
+        non-pointer data.  Rename to sizeNonPointers.
+* the unused field in GC_weak appears to be for alignment; is there a
+        way to have it work well with 64-bits?  Yes -- it requires
+        choosing the representation for Weaks based on the model and
+        the alignment; also, the GC will need to bump the pointer to
+        the word after the header to get GC_weak to overlay properly.

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/cheney-copy.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/cheney-copy.c	2005-09-04 00:58:04 UTC (rev 4060)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/cheney-copy.c	2005-09-04 02:08:38 UTC (rev 4061)
@@ -152,12 +152,12 @@
 }
 
 static void swapSemis (GC_state s) {
-        struct GC_heap h;
-
-        h = s->heap2;
-        s->heap2 = s->heap;
-        s->heap = h;
-        setCardMapForMutator (s);
+  struct GC_heap tempHeap;
+  
+  tempHeap = s->secondaryHeap;
+  s->secondaryHeap = s->heap;
+  s->heap = tempHeap;
+  setCardMapForMutator (s);
 }
 
 static inline bool detailedGCTime (GC_state s) {
@@ -172,8 +172,8 @@
         if (detailedGCTime (s))
                 startTiming (&ru_start);
         s->numCopyingGCs++;
-        s->toSpace = s->heap2.start;
-        s->toLimit = s->heap2.start + s->heap2.size;
+        s->toSpace = s->secondaryHeap.start;
+        s->toLimit = s->secondaryHeap.start + s->secondaryHeap.size;
         if (DEBUG or s->messages) {
                 fprintf (stderr, "Major copying GC.\n");
                 fprintf (stderr, "fromSpace = 0x%08x of size %s\n", 

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/frame.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/frame.h	2005-09-04 02:08:38 UTC (rev 4061)
@@ -0,0 +1,39 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/*
+ * The "... reserved bytes ..." of a stack object constitute a linear
+ * sequence of frames.  For the purposes of garbage collection, we
+ * must be able to recover the size and offsets of live heap-pointers
+ * for each frame.  This data is declared as follows:
+ *
+ *  GC_frameLayout *frameLayouts;
+ * 
+ * The frameLayouts pointer is initialized to point to a static array
+ * of frame layouts that is emitted for each compiled program.  The
+ * isC field identified whether or not the frame is for a C
+ * call. (Note: The ML stack is distinct from the system stack.  A C
+ * call executes on the system stack.  The frame left on the ML stack
+ * is just a marker.)  The numBytes field indicates the size of the
+ * frame, including space for the return address.  The offsets field
+ * points to an array (the zeroeth element recording the size of the
+ * array) whose elements record byte offsets from the bottom of the
+ * frame at which live heap pointers are located.
+ */
+typedef uint16_t *GC_offsets;
+
+typedef struct GC_frameLayout {
+  /* Identifies whether or not the frame is for a C call.  */
+  bool isC;
+  /* Number of bytes in frame, including space for return address. */
+  uint16_t numBytes;
+  /* Offsets from stackTop pointing at bottom of frame at which
+   * pointers are located.
+   */
+  GC_offsets offsets;
+} GC_frameLayout;

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h	2005-09-04 00:58:04 UTC (rev 4060)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h	2005-09-04 02:08:38 UTC (rev 4061)
@@ -4,4 +4,5 @@
   struct GC_heap secondaryHeap; /* Used for major copying collection. */
   GC_objectType *objectTypes; /* Array of object types. */
   uint32_t objectTypesSize; /* Cardinality of objectTypes array. */
+  GC_weak weaks; /* Linked list of (live) weak pointers */
 } *GC_state;

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h	2005-09-04 00:58:04 UTC (rev 4060)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h	2005-09-04 02:08:38 UTC (rev 4061)
@@ -143,4 +143,4 @@
 #define OBJPTR_TYPE_(z) OBJPTR_TYPE__(z)
 #define OBJPTR_TYPE OBJPTR_TYPE_(GC_MODEL_Z)
 typedef OBJPTR_TYPE objptr;
-#define OBJPTR_SIZE (sizeof(objptr) / 4)
+#define OBJPTR_SIZE sizeof(objptr)

Modified: mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h	2005-09-04 00:58:04 UTC (rev 4060)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h	2005-09-04 02:08:38 UTC (rev 4061)
@@ -30,7 +30,7 @@
 #define PRIxHDR PRIx32
 #define FMTHDR "0x%08"PRIxHDR
 enum {
-  GC_HEADER_SIZE =   4,
+  GC_HEADER_SIZE =   sizeof(GC_header),
   TYPE_INDEX_BITS =  19,
   TYPE_INDEX_MASK =  0x000FFFFE,
   TYPE_INDEX_SHIFT = 1,
@@ -78,9 +78,9 @@
   GC_ARRAY_HEADER_SIZE =  GC_ARRAY_COUNTER_SIZE + GC_ARRAY_LENGTH_SIZE + GC_HEADER_SIZE,
 };
 
-/* Stack objects are described in stack.h */
+/* Stack objects are described in "stack.h" */
 
-/* Weak objects are described in weak.h */
+/* Weak objects are described in "weak.h" */
 
 
 /* 

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/stack.h	2005-09-04 02:08:38 UTC (rev 4061)
@@ -0,0 +1,48 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/*
+ * Stack objects have the following layout:
+ * 
+ * header word ::
+ * markTop pointer ::
+ * markIndex word ::
+ * reserved word ::
+ * used word ::
+ * ... reserved bytes ...
+ *
+ * The markTop pointer and markIndex word are used by mark compact GC.
+ * The reserved word gives the number of bytes for the stack (before
+ * the next ML object).  The used word gives the number of bytes
+ * currently used by the stack.  The sequence of reserved bytes
+ * correspond to ML stack frames, which will be discussed in more
+ * detail in "frame.h".
+*/
+typedef struct GC_stack {       
+  /* markTop and markIndex are only used during marking.  They record
+   * the current pointer in the stack that is being followed.  markTop
+   * points to the top of the stack frame containing the pointer and
+   * markI is the index in that frames frameOffsets of the pointer
+   * slot.  So, when the GC pointer reversal gets back to the stack,
+   * it can continue with the next pointer (either in the current
+   * frame or the next frame).
+   */
+  pointer markTop;
+  uint32_t markIndex;
+  /* reserved is the number of bytes reserved for stack, 
+   * i.e. its maximum size.
+   */
+  uint32_t reserved;
+  /* used is the number of bytes used by the stack.  
+   * Stacks with used == reserved are continuations.
+   */
+  uint32_t used;      
+  /* The next address is the bottom of the stack, and the following
+   * reserved bytes hold space for the stack.
+   */
+} *GC_stack;

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/thread.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/thread.h	2005-09-04 02:08:38 UTC (rev 4061)
@@ -0,0 +1,23 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+typedef struct GC_thread {
+  /* The order of these fields is important.  The nonpointer fields
+   * must be first, because this object must appear to be a normal
+   * heap object.
+   * Furthermore, the exnStack field must be first, because the native
+   * codegen depends on this (which is bad and should be fixed).
+   */
+  uint32_t exnStack;     /* An offset added to stackBottom that specifies 
+                          * where the top of the exnStack is.
+                          */
+  uint32_t bytesNeeded;  /* The number of bytes needed when returning
+                          * to this thread.
+                          */
+  objptr stack;          /* The stack for this thread. */
+} *GC_thread;

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/weak.c (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.c)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.c	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/weak.c	2005-09-04 02:08:38 UTC (rev 4061)
@@ -0,0 +1,40 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+
+bool GC_weakCanGet (pointer p) {
+        Bool res;
+
+        res = WEAK_GONE_HEADER != GC_getHeader (p);
+        if (DEBUG_WEAK)
+                fprintf (stderr, "%s = GC_weakCanGet (0x%08x)\n",
+                                boolToString (res), (uint)p);
+        return res;
+}
+
+Pointer GC_weakGet (Pointer p) {
+        pointer res;
+
+        res = ((GC_weak)p)->object;
+        if (DEBUG_WEAK)
+                fprintf (stderr, "0x%08x = GC_weakGet (0x%08x)\n",
+                                (uint)res, (uint)p);
+        return res;
+}
+
+Pointer GC_weakNew (GC_state s, Word32 header, Pointer p) {
+        pointer res;
+
+        res = object (s, header, GC_NORMAL_HEADER_SIZE + 3 * WORD_SIZE, 
+                        FALSE, FALSE);
+        ((GC_weak)res)->object = p;
+        if (DEBUG_WEAK)
+                fprintf (stderr, "0x%08x = GC_weakNew (0x%08x, 0x%08x)\n",
+                                (uint)res, (uint)header, (uint)p);
+        return res;
+}

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/weak.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/weak.h	2005-09-04 02:08:38 UTC (rev 4061)
@@ -0,0 +1,33 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/*
+ * Weak objects have the following layout:
+ * 
+ * header word ::
+ * unused word ::
+ * link word ::
+ * heap-pointer
+ *
+ * The object type indexed by the header determines whether the weak
+ * is valid or not.  If the type has numPointers == 1, then the weak
+ * pointer is valid.  Otherwise, the type has numPointers == 0 and the
+ * weak pointer is not valid.
+ *
+ * The first word is unused; present for alignment purposes
+ *
+ * The second word is used to chain the live weaks together during a copying gc
+ * and is otherwise unused.
+ *
+ * The third word is the weak pointer.
+ */ 
+typedef struct GC_weak {
+  uint32_t unused;
+  struct GC_weak *link;
+  objptr object;
+} *GC_weak;

[MLton-commit] r4060

[Matthew F. <fl...@ml...>]

Starting to build up a modularized GC, 
taking sizes and memory model into account.

----------------------------------------------------------------------

_U  mlton/branches/on-20050822-x86_64-branch/runtime/gc/
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/.ignore
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/cheney-copy.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/cheney-copy.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_prefix.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_prefix.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_suffix.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_suffix.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/heap.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/mark-sweep.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/mark-sweep.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.c
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h
A   mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h

----------------------------------------------------------------------


Property changes on: mlton/branches/on-20050822-x86_64-branch/runtime/gc
___________________________________________________________________
Name: svn:ignore
   + gc.h
gc.c


Added: mlton/branches/on-20050822-x86_64-branch/runtime/gc/.ignore
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/.ignore	2005-09-01 21:50:41 UTC (rev 4059)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/.ignore	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,2 @@
+gc.h
+gc.c

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/Makefile)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/Makefile	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/Makefile	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,95 @@
+## Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ #    Jagannathan, and Stephen Weeks.
+ # Copyright (C) 1997-2000 NEC Research Institute.
+ #
+ # MLton is released under a BSD-style license.
+ # See the file MLton-LICENSE for details.
+ ##
+
+PATH = ../../bin:$(shell echo $$PATH)
+
+TARGET = self
+TARGET_ARCH = $(shell ../../bin/host-arch)
+TARGET_OS = $(shell ../../bin/host-os)
+GCC_VERSION = $(shell gcc -v 2>&1 | grep 'gcc version' | sed 's/.*gcc version \(.\).*/\1/')
+
+FLAGS = -fomit-frame-pointer
+
+ifeq ($(TARGET_ARCH), x86)
+ifneq ($(findstring $(GCC_VERSION), 3 4),)
+FLAGS += -falign-loops=2 -falign-jumps=2 -falign-functions=5
+else
+FLAGS += -malign-loops=2 -malign-jumps=2 -malign-functions=5
+endif
+endif
+
+ifeq ($(TARGET_ARCH), amd64)
+FLAGS += -mtune=opteron -m32
+endif
+
+ifeq ($(TARGET_ARCH), sparc)
+FLAGS += -mv8 -m32
+endif
+
+ifeq ($(TARGET_OS), solaris)
+FLAGS += -Wa,-xarch=v8plusa -fcall-used-g5 -fcall-used-g7 -funroll-all-loops -mcpu=ultrasparc
+endif
+
+ifeq ($(TARGET), self)
+AR = ar rc
+RANLIB = ranlib
+else
+AR = $(TARGET)-ar rc
+RANLIB = $(TARGET)-ranlib
+FLAGS += -b $(TARGET)
+endif
+
+CC = gcc -std=gnu99
+CFLAGS = -O2 -Wall -I. -D_FILE_OFFSET_BITS=64 $(FLAGS)
+DEBUGFLAGS = $(CFLAGS) -gstabs+ -g2
+
+CFILES = 								\
+	gc_prefix.c							\
+	debug.c								\
+	object.c							\
+	model.c								\
+	gc_suffix.c
+
+HFILES = 								\
+	gc_prefix.h							\
+	util.h								\
+	object.h							\
+	model.h								\
+	heap.h								\
+	gc_state.h							\
+	gc_suffix.h
+
+all: gc.o gc-gdb.o
+
+gc-gdb.o: gc.c gc.h
+	$(CC) $(DEBUGFLAGS) -O1 -DASSERT=1 -c -o $@ gc.c
+
+gc.o: gc.c gc.h
+	$(CC) $(CFLAGS) -c -o $@ gc.c
+
+gc.c: $(CFILES)
+	rm -f gc.c
+	(								\
+		for f in $(CFILES); do					\
+			echo "#line 1 \"$$f\"";				\
+			cat $$f;					\
+		done;							\
+	) > gc.c
+
+gc.h: $(HFILES)
+	rm -f gc.h
+	(								\
+		for f in $(HFILES); do					\
+			echo "#line 1 \"$$f\"";				\
+			cat $$f;					\
+		done;							\
+	) > gc.h
+
+.PHONY: clean
+clean:
+	../bin/clean

Added: mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO	2005-09-01 21:50:41 UTC (rev 4059)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/TODO	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,6 @@
+
+* reorder ZZZ_TYPE_INDEX
+* eliminate STRING_TYPE_INDEX, STRING_TYPE_HEADER in favor or WORD8.
+* fix semantics of numNonPointers for normal objects to mean bytes of
+        non-pointer data, rather than number of 32-bit words of
+        non-pointer data.

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/cheney-copy.c (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.c)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.c	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/cheney-copy.c	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,209 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/* ---------------------------------------------------------------- */
+/*                    Cheney Copying Collection                     */
+/* ---------------------------------------------------------------- */
+
+/* forward (s, pp) forwards the object pointed to by *pp and updates *pp to 
+ * point to the new object. 
+ * It also updates the crossMap.
+ */
+static inline void forward (GC_state s, pointer *pp) {
+  pointer p;
+  GC_ObjectHeader header;
+  GC_ObjectTypeTag tag;
+
+  if (DEBUG_DETAILED)
+    fprintf (stderr, 
+             "forward  pp = 0x"PRIxPTR"  *pp = 0x"PRIxPTR"\n", 
+             pp, *pp);
+  assert (isInFromSpace (s, *pp));
+  p = *pp;
+  header = GC_getHeader (p);
+        if (DEBUG_DETAILED and FORWARDED == header)
+                fprintf (stderr, "already FORWARDED\n");
+        if (header != FORWARDED) { /* forward the object */
+                Bool hasIdentity;
+                uint headerBytes, objectBytes, size, skip;
+                uint numPointers, numNonPointers;
+
+                /* Compute the space taken by the header and object body. */
+                SPLIT_HEADER();
+                if (NORMAL_TAG == tag) { /* Fixed size object. */
+                        headerBytes = GC_NORMAL_HEADER_SIZE;
+                        objectBytes = toBytes (numPointers + numNonPointers);
+                        skip = 0;
+                } else if (ARRAY_TAG == tag) {
+                        headerBytes = GC_ARRAY_HEADER_SIZE;
+                        objectBytes = arrayNumBytes (s, p, numPointers,
+                                                        numNonPointers);
+                        skip = 0;
+                } else if (WEAK_TAG == tag) {
+                        headerBytes = GC_NORMAL_HEADER_SIZE;
+                        objectBytes = sizeof (struct GC_weak);
+                        skip = 0;
+                } else { /* Stack. */
+                        GC_stack stack;
+
+                        assert (STACK_TAG == tag);
+                        headerBytes = STACK_HEADER_SIZE;
+                        stack = (GC_stack)p;
+
+                        if (s->currentThread->stack == stack) {
+                                /* Shrink stacks that don't use a lot 
+                                 * of their reserved space;
+                                 * but don't violate the stack invariant.
+                                 */
+                                if (stack->used <= stack->reserved / 4) {
+                                        uint new = stackReserved (s, max (stack->reserved / 2,
+                                                                                stackNeedsReserved (s, stack)));
+                                        /* It's possible that new > stack->reserved if
+                                         * the stack invariant is violated. In that case, 
+                                         * we want to leave the stack alone, because some 
+                                         * other part of the gc will grow the stack.  We 
+                                         * cannot do any growing here because we may run 
+                                         * out of to space.
+                                         */
+                                        if (new <= stack->reserved) {
+                                                stack->reserved = new;
+                                                if (DEBUG_STACKS)
+                                                        fprintf (stderr, "Shrinking stack to size %s.\n",
+                                                                        uintToCommaString (stack->reserved));
+                                        }
+                                }
+                        } else {
+                                /* Shrink heap stacks.
+                                 */
+                                stack->reserved = stackReserved (s, max(s->threadShrinkRatio * stack->reserved, 
+                                                                        stack->used));
+                                if (DEBUG_STACKS)
+                                        fprintf (stderr, "Shrinking stack to size %s.\n",
+                                                        uintToCommaString (stack->reserved));
+                        }
+                        objectBytes = sizeof (struct GC_stack) + stack->used;
+                        skip = stack->reserved - stack->used;
+                }
+                size = headerBytes + objectBytes;
+                assert (s->back + size + skip <= s->toLimit);
+                /* Copy the object. */
+                copy (p - headerBytes, s->back, size);
+                /* If the object has a valid weak pointer, link it into the weaks
+                 * for update after the copying GC is done.
+                 */
+                if (WEAK_TAG == tag and 1 == numPointers) {
+                        GC_weak w;
+
+                        w = (GC_weak)(s->back + GC_NORMAL_HEADER_SIZE);
+                        if (DEBUG_WEAK)
+                                fprintf (stderr, "forwarding weak 0x%08x ",
+                                                (uint)w);
+                        if (GC_isPointer (w->object)
+                                and (not s->amInMinorGC
+                                        or isInNursery (s, w->object))) {
+                                if (DEBUG_WEAK)
+                                        fprintf (stderr, "linking\n");
+                                w->link = s->weaks;
+                                s->weaks = w;
+                        } else {
+                                if (DEBUG_WEAK)
+                                        fprintf (stderr, "not linking\n");
+                        }
+                }
+                /* Store the forwarding pointer in the old object. */
+                *(word*)(p - WORD_SIZE) = FORWARDED;
+                *(pointer*)p = s->back + headerBytes;
+                /* Update the back of the queue. */
+                s->back += size + skip;
+                assert (isAligned ((uint)s->back + GC_NORMAL_HEADER_SIZE,
+                                        s->alignment));
+        }
+        *pp = *(pointer*)p;
+        assert (isInToSpace (s, *pp));
+}
+
+static void updateWeaks (GC_state s) {
+        GC_weak w;
+
+        for (w = s->weaks; w != NULL; w = w->link) {
+                assert ((pointer)BOGUS_POINTER != w->object);
+
+                if (DEBUG_WEAK)
+                        fprintf (stderr, "updateWeaks  w = 0x%08x  ", (uint)w);
+                if (FORWARDED == GC_getHeader ((pointer)w->object)) {
+                        if (DEBUG_WEAK)
+                                fprintf (stderr, "forwarded from 0x%08x to 0x%08x\n",
+                                                (uint)w->object,
+                                                (uint)*(pointer*)w->object);
+                        w->object = *(pointer*)w->object;
+                } else {
+                        if (DEBUG_WEAK)
+                                fprintf (stderr, "cleared\n");
+                        *(GC_getHeaderp((pointer)w)) = WEAK_GONE_HEADER;
+                        w->object = (pointer)BOGUS_POINTER;
+                }
+        }
+        s->weaks = NULL;
+}
+
+static void swapSemis (GC_state s) {
+        struct GC_heap h;
+
+        h = s->heap2;
+        s->heap2 = s->heap;
+        s->heap = h;
+        setCardMapForMutator (s);
+}
+
+static inline bool detailedGCTime (GC_state s) {
+        return s->summary;
+}
+
+static void cheneyCopy (GC_state s) {
+        struct rusage ru_start;
+        pointer toStart;
+
+        assert (s->heap2.size >= s->oldGenSize);
+        if (detailedGCTime (s))
+                startTiming (&ru_start);
+        s->numCopyingGCs++;
+        s->toSpace = s->heap2.start;
+        s->toLimit = s->heap2.start + s->heap2.size;
+        if (DEBUG or s->messages) {
+                fprintf (stderr, "Major copying GC.\n");
+                fprintf (stderr, "fromSpace = 0x%08x of size %s\n", 
+                                (uint) s->heap.start,
+                                uintToCommaString (s->heap.size));
+                fprintf (stderr, "toSpace = 0x%08x of size %s\n",
+                                (uint) s->heap2.start,
+                                uintToCommaString (s->heap2.size));
+        }
+        assert (s->heap2.start != (void*)NULL);
+        /* The next assert ensures there is enough space for the copy to succeed.
+         * It does not assert (s->heap2.size >= s->heap.size) because that
+         * is too strong.
+         */
+        assert (s->heap2.size >= s->oldGenSize);
+        toStart = alignFrontier (s, s->heap2.start);
+        s->back = toStart;
+        foreachGlobal (s, forward);
+        foreachPointerInRange (s, toStart, &s->back, TRUE, forward);
+        updateWeaks (s);
+        s->oldGenSize = s->back - s->heap2.start;
+        s->bytesCopied += s->oldGenSize;
+        if (DEBUG)
+                fprintf (stderr, "%s bytes live.\n", 
+                                uintToCommaString (s->oldGenSize));
+        swapSemis (s);
+        clearCrossMap (s);
+        s->lastMajor = GC_COPYING;
+        if (detailedGCTime (s))
+                stopTiming (&ru_start, &s->ru_gcCopy);          
+        if (DEBUG or s->messages)
+                fprintf (stderr, "Major copying GC done.\n");
+}

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/cheney-copy.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/cheney-copy.h	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,7 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.c (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.c)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.c	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/debug.c	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,29 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+#ifndef DEBUG
+#define DEBUG FALSE
+#endif
+
+enum {
+        DEBUG_ARRAY = FALSE,
+        DEBUG_CALL_STACK = FALSE,
+        DEBUG_CARD_MARKING = FALSE,
+        DEBUG_DETAILED = FALSE,
+        DEBUG_ENTER_LEAVE = FALSE,
+        DEBUG_GENERATIONAL = FALSE,
+        DEBUG_MARK_COMPACT = FALSE,
+        DEBUG_PROFILE = FALSE,
+        DEBUG_RESIZING = FALSE,
+        DEBUG_SHARE = FALSE,
+        DEBUG_SIZE = FALSE,
+        DEBUG_STACKS = FALSE,
+        DEBUG_THREADS = FALSE,
+        DEBUG_WEAK = FALSE,
+        DEBUG_WORLD = FALSE,
+};

Added: mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_prefix.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_prefix.c	2005-09-01 21:50:41 UTC (rev 4059)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_prefix.c	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1 @@
+#include "gc.h"

Added: mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_prefix.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_prefix.h	2005-09-01 21:50:41 UTC (rev 4059)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_prefix.h	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,2 @@
+#ifndef _MLTON_GC_H_
+#define _MLTON_GC_H_

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_state.h	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,7 @@
+
+typedef struct GC_state {
+  struct GC_heap heap;
+  struct GC_heap secondaryHeap; /* Used for major copying collection. */
+  GC_objectType *objectTypes; /* Array of object types. */
+  uint32_t objectTypesSize; /* Cardinality of objectTypes array. */
+} *GC_state;

Added: mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_suffix.c
===================================================================

Added: mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_suffix.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_suffix.h	2005-09-01 21:50:41 UTC (rev 4059)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/gc_suffix.h	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1 @@
+#endif /* _MLTON_GC_H_ */

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/heap.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/heap.h	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,23 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/*
+ * All ML objects (including ML execution stacks) are allocated in a
+ * contiguous heap.  The heap has the following general layout:
+ * 
+ * ---------------------------------------------------
+ * |                                                 |
+ * ---------------------------------------------------
+ * ^
+ * start
+*/
+
+typedef struct GC_heap {
+  uint32_t size;
+  pointer start;          /* start of memory area */
+} *GC_heap;

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/mark-sweep.c (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.c)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.c	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/mark-sweep.c	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,7 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/mark-sweep.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/mark-sweep.h	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,7 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */

Added: mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c	2005-09-01 21:50:41 UTC (rev 4059)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.c	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,29 @@
+/* Copyright (C) 2005-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+static inline pointer objptrToPointer (objptr O, pointer B) {
+  intptr_t O_ = (intptr_t)O;
+  intptr_t B_;
+  if GC_MODEL_B {
+    B_ = (intptr_t)B;
+  } else {
+    B_ = 0;
+  }
+  return (pointer)((O_ << GC_MODEL_S) + B_);
+}
+
+static inline objptr pointerToObjptr (pointer P, pointer B) {
+  intptr_t P_ = (intptr_t)P;
+  intptr_t B_;
+
+  if GC_MODEL_B {
+    B_ = (intptr_t)B;
+  } else {
+    B_ = 0;
+  }
+  return (objptr)((P_ - B_) >> GC_MODEL_S);
+}

Added: mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h	2005-09-01 21:50:41 UTC (rev 4059)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/model.h	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,146 @@
+/* Copyright (C) 2005-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/*
+Consider the following schemes for representing object pointers and
+mapping them to 64-bit native pointers.
+
+A. 32 bits, with bottom two bits zero.
+B. 32 bits, with bottom bit zero, shift left by one.
+C. 32 bits, with bottom bit zero, shift left by two.
+D. 32 bits, shift left by two.
+E. 32 bits, shift left by three.
+F. 40 bits.
+G. 64 bits.
+
+These schemes vary in the number of bits to represent a pointer in an
+object, the time to load a pointer from memory into a register, the
+amount of addressable memory, and the object alignment.
+
+        bits    time    mem(G)  align
+A       32      fast      4     4
+B       32      slow      8     4
+C       32      slow     16     8
+D       32      slow     16     4
+E       32      slow     32     8
+F       40      slow    256     4
+G       64      fast     4G     8
+
+Each of the (A-F) has a variant (AX-FX) in which pointers are added to
+some constant base address.  This gives access to any region in the
+virtual address space instead of just the low addresses.
+
+The following diagram demonstrates what portion of the native pointer
+to which the object pointer corresponds.
+
+64                              32                              0
+|                               |                               |
+-----------------------------------------------------------------
+
+                                 ==============================00   A
+
+                                ===============================0    B
+
+                               ===============================0     C
+
+                               ================================     D
+
+                             =================================      E
+
+                         ========================================   F
+
+ ================================================================   G
+
+Algorithmically, we can compute the native pointer (P) from the object
+pointer (O) (with bitsize Z), given a shift (S) and a base (B):
+
+P = %add64(%shl64(%zxZ_64(O),S),B)
+
+Likewise, we can compute the object pointer (O) from the native
+pointer (P), given a shift (S) and a base (B):
+
+O = %lobits64_Z(%shr64(%sub64(P,B),S))
+
+Hence, each of the schemes may be characterized by the size Z of the
+object pointer, the shift S, and whether or not the base B is zero.
+Noting that
+ %zx64_64(x) = x
+ %shl64(x, 0) = x
+ %add64(x, 0) = x
+ %lobits64_64(x) = x
+ %shr64(x, 0) = x
+ %sub64(x, 0) = x
+it is easy to compute the number of ALU operations required by each
+scheme:
+
+A  :: Z = 32, S == 0, B == 0   ops = 1
+AX :: Z = 32, S == 0, B != 0   ops = 2
+B  :: Z = 32, S == 1, B == 0   ops = 2
+BX :: Z = 32, S == 1, B != 0   ops = 3
+C  :: Z = 32, S == 2, B == 0   ops = 2
+CX :: Z = 32, S == 2, B != 0   ops = 3
+D  :: Z = 32, S == 2, B == 0   ops = 2
+DX :: Z = 32, S == 2, B != 0   ops = 3
+E  :: Z = 32, S == 3, B == 0   ops = 2
+EX :: Z = 32, S == 3, B != 0   ops = 3
+F  :: Z = 40, S == 0, B == 0   ops = 1 (#)
+FX :: Z = 40, S == 0, B != 0   ops = 2 (#)
+G  :: Z = 64, S == 0, B == 0   ops = 0
+
+#: In schemes F and FX, the conversion from object pointer to native
+pointer requires logical-shift-right, rather than zero-extend, since
+the object pointer would be fetched from memory as a 64-bit value.
+The cost may actually be higher, as storing an object pointer in
+memory requires some care so as not to overwrite neighboring data.
+
+It is not clear that any of the thirteen schemes dominates another.
+Here are some thoughts.
+
+(A) This is is what we have now, but is still useful on 64-bit
+machines where the bottom 4G may be less cluttered than on a 32-bit
+machine.
+
+(AX) seems like a nice cost/benefit tradeoff for a program that only
+needs 4G of memory, since the base can be used to find a contiguous 4G
+somewhere in the address space.
+
+(B) and (C) are similar, the tradeoff being to increase object
+alignment requirements in order to allow more memory.  Importantly,
+pointers having a bottom zero bit means that we can still set the
+bottom bit to one to represent small values in sum types.
+
+(D) and (E) are problematic because they leave no room to represent 
+small objects in sum types with pointers.  I think that really rules
+them out. 
+
+(F) costs some in object alignment because a sequence of pointers in
+an object may have to be padded to meet 4-byte alignment.  Loading a
+pointer from memory into a register may be slightly faster than in
+(B) or (C) because we don't have to shift, but I wonder if that
+matters.
+
+(G) costs the most in space, but has the fastest load time for
+pointers of the schemes that allow access to 4G of memory.
+
+
+A reasonable tradeoff in implementation complexity vs allowing our
+users enough flexibility might be to provide:
+
+        A, AX, B, BX, C, CX, G
+
+After some experiments on those, we might be able to find a more
+manageable set for users.
+*/
+
+#define GC_MODEL_Z  32
+#define GC_MODEL_S  1
+#define GC_MODEL_B  TRUE
+#define OBJPTR_TYPE__(z) uint ## z ## _t
+#define OBJPTR_TYPE_(z) OBJPTR_TYPE__(z)
+#define OBJPTR_TYPE OBJPTR_TYPE_(GC_MODEL_Z)
+typedef OBJPTR_TYPE objptr;
+#define OBJPTR_SIZE (sizeof(objptr) / 4)

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.c (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.c)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.c	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.c	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,61 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/*
+ * Build the header for an object, given the index to its type info.
+ */
+static inline GC_header GC_objectHeader (uint32_t t) {
+        assert (t < TWOPOWER (TYPE_INDEX_BITS));
+        return 1 | (t << 1);
+}
+
+#define STACK_HEADER GC_objectHeader (STACK_TYPE_INDEX)
+#define STRING_HEADER GC_objectHeader (STRING_TYPE_INDEX)
+#define THREAD_HEADER GC_objectHeader (THREAD_TYPE_INDEX)
+#define WEAK_GONE_HEADER GC_objectHeader (WEAK_GONE_TYPE_INDEX)
+#define WORD8_VECTOR_HEADER GC_objectHeader (WORD8_TYPE_INDEX)
+
+#define SPLIT_HEADER()                                                          \
+  do {                                                                          \
+    int objectTypeIndex;                                                        \
+    GC_objectType *t;                                                           \
+                                                                                \
+    assert (1 == (header & 1));                                                 \
+    objectTypeIndex = (header & TYPE_INDEX_MASK) >> TYPE_INDEX_SHIFT;           \
+    assert (0 <= objectTypeIndex                                                \
+            and objectTypeIndex < s->objectTypesSize);                          \
+    t = &s->objectTypes [objectTypeIndex];                                      \
+    tag = t->tag;                                                               \
+    hasIdentity = t->hasIdentity;                                               \
+    numNonPointers = t->numNonPointers;                                         \
+    numPointers = t->numPointers;                                               \
+    if (DEBUG_DETAILED)                                                         \
+      fprintf (stderr,                                                          \
+               "SPLIT_HEADER ("FMTHDR")"                                        \
+               "  tag = %s"                                                     \
+               "  hasIdentity = %u"                                             \
+               "  numNonPointers = %"PRIu16                                     \
+               "  numPointers = %"PRIu16"\n",                                   \
+               header,                                                          \
+               tagToString(tag), hasIdenity, numNonPointers, numPointers);      \
+  } while (0)
+
+static char* tagToString (GC_objectTypeTag tag) {
+  switch (tag) {
+  case ARRAY_TAG:
+    return "ARRAY";
+  case NORMAL_TAG:
+    return "NORMAL";
+  case STACK_TAG:
+    return "STACK";
+  case WEAK_TAG:
+    return "WEAK";
+  default:
+    die ("bad tag %u", tag);
+  }
+}

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/gc.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/gc.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/object.h	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,123 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+/* 
+ * There are four kinds of ML objects: 
+ *   array, normal (fixed size), stack, and weak.
+ */
+typedef enum { 
+        ARRAY_TAG,
+        NORMAL_TAG,
+        STACK_TAG,
+        WEAK_TAG,
+} GC_objectTypeTag;
+
+/*
+ * Each object has a header, which immediately precedes the object data.
+ * A header has the following bit layout:
+ * 
+ * 00        : 1
+ * 01 - 19   : type index bits, index into GC_state->objectTypes.
+ * 20 - 30   : counter bits, used by mark compact GC (initially 0)
+ *      31   : mark bit, used by mark compact GC (initially 0)
+ */
+typedef uint32_t GC_header;
+#define PRIxHDR PRIx32
+#define FMTHDR "0x%08"PRIxHDR
+enum {
+  GC_HEADER_SIZE =   4,
+  TYPE_INDEX_BITS =  19,
+  TYPE_INDEX_MASK =  0x000FFFFE,
+  TYPE_INDEX_SHIFT = 1,
+  COUNTER_BITS =     10,
+  COUNTER_MASK =     0x7FF00000,
+  COUNTER_SHIFT =    20,
+  MARK_BITS =        1,
+  MARK_MASK =        0x80000000,
+  MARK_SHIFT =       31
+};
+
+/*
+ * Normal objects have the following layout:
+ *
+ * header word32 :: 
+ * (non heap-pointers)* :: 
+ * (heap pointers)*
+ *
+ * Note that the non heap-pointers denote a sequence of primitive data
+ * values.  These data values need not map directly to values of the
+ * native word size.  MLton's aggressive representation strategies may
+ * pack multiple primitive values into the same native word.
+ * Likewise, a primitive value may span multiple native words (e.g.,
+ * Word64.word).
+*/
+enum {
+  GC_NORMAL_HEADER_SIZE = GC_HEADER_SIZE,
+};
+
+/*
+ * Array objects have the following layout:
+ * 
+ * counter word32 :: 
+ * length word32 :: 
+ * header word32 :: 
+ * ( (non heap-pointers)* :: (heap pointers)* )*
+ *
+ * The counter word is used by mark compact GC.  The length word is
+ * the number of elements in the array.  Array elements have the same
+ * individual layout as normal objects, omitting the header word.
+ */
+enum {
+  GC_ARRAY_LENGTH_SIZE =  4,
+  GC_ARRAY_COUNTER_SIZE = GC_ARRAY_LENGTH_SIZE,
+  GC_ARRAY_HEADER_SIZE =  GC_ARRAY_COUNTER_SIZE + GC_ARRAY_LENGTH_SIZE + GC_HEADER_SIZE,
+};
+
+/* Stack objects are described in stack.h */
+
+/* Weak objects are described in weak.h */
+
+
+/* 
+ * The type index of a header is an index into an array of object
+ * types, where each element describes the layout of an object.  The
+ * object types array is declared as:
+ *
+ *  GC_objectType *objectTypes;
+ *
+ * The objectTypes pointer is initialized to point to a static array
+ * of object types that is emitted for each compiled program.  The
+ * hasIdentity field indicates whether or not the object has mutable
+ * fields, in which case it may not be hash-cons-ed.  In a normal
+ * object, the numNonPointers field indicates the number of 32-bit
+ * words of non heap-pointer data, while the numPointers field
+ * indicates the number of heap pointers.  In an array object, the
+ * numNonPointers field indicates the number of bytes of non
+ * heap-pointer data, while the numPointers field indicates the number
+ * of heap pointers.  In a stack object, the numNonPointers and
+ * numPointers fields are irrelevant.  In a weak object, the
+ * numNonPointers and numPointers fields are interpreted as in a
+ * normal object (and, hence, must be (0,1) or (0,0)).
+*/
+typedef struct {
+        /* Keep tag first, at zero offset, since it is referenced most often. */
+        GC_objectTypeTag tag;
+        bool hasIdentity;
+        uint16_t numNonPointers;
+        uint16_t numPointers;
+} GC_objectType;
+enum {
+  /* The type indices here must agree with those in backend/rep-type.fun. */
+  STACK_TYPE_INDEX =         0,
+  STRING_TYPE_INDEX =        1,
+  THREAD_TYPE_INDEX =        2,
+  WEAK_GONE_TYPE_INDEX =     3,
+  WORD8_VECTOR_TYPE_INDEX =  STRING_TYPE_INDEX,
+  WORD32_VECTOR_TYPE_INDEX = 4,
+  WORD16_VECTOR_TYPE_INDEX = 5,
+};

Copied: mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h (from rev 4025, mlton/branches/on-20050822-x86_64-branch/runtime/platform.h)
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/runtime/platform.h	2005-08-22 22:48:34 UTC (rev 4025)
+++ mlton/branches/on-20050822-x86_64-branch/runtime/gc/util.h	2005-09-04 00:58:04 UTC (rev 4060)
@@ -0,0 +1,54 @@
+/* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ */
+
+#ifndef _UTIL_H_
+#define _UTIL_H_
+
+#define _ISOC99_SOURCE
+#define _BSD_SOURCE
+
+/* Only enable _POSIX_C_SOURCE on platforms that don't have broken system
+ * headers.
+ */
+#if (defined (__linux__))
+#define _POSIX_C_SOURCE 200112L
+#endif
+
+/* C99-specific headers */
+#include <stddef.h>
+#include <stdbool.h>
+#include <iso646.h>
+#include <stdio.h>
+#include <stdint.h>
+#include <inttypes.h>
+
+#include "../assert.h"
+
+#define TWOPOWER(n) (1 << (n))
+
+#ifndef TRUE
+#define TRUE    (0 == 0)
+#endif
+#ifndef FALSE
+#define FALSE   (not TRUE)
+#endif
+#define unless(p)       if (not (p))
+
+/* issue error message and exit */
+extern void die (char *fmt, ...)
+                        __attribute__ ((format(printf, 1, 2)))
+                        __attribute__ ((noreturn));
+/* issue error message and exit.  Also print strerror(errno). */
+extern void diee (char *fmt, ...)
+                        __attribute__ ((format(printf, 1, 2)))
+                        __attribute__ ((noreturn));
+
+typedef void* pointer;
+#define FMTPTR "0x%08"PRIxPTR
+
+#endif /* _UTIL_H_ */

[MLton-commit] r4059

[Vesa K. <ve...@ml...>]

Fixed (embarrassing) bug: "w" and "W" were missing from alphanumeric-chars.

----------------------------------------------------------------------

U   mlton/trunk/ide/emacs/esml-gen.el

----------------------------------------------------------------------

Modified: mlton/trunk/ide/emacs/esml-gen.el
===================================================================
--- mlton/trunk/ide/emacs/esml-gen.el	2005-09-01 17:45:00 UTC (rev 4058)
+++ mlton/trunk/ide/emacs/esml-gen.el	2005-09-01 21:50:41 UTC (rev 4059)
@@ -33,7 +33,7 @@
 2.4 of the Definition.")
 
 (defconst esml-sml-alphanumeric-chars
-  "abcdefghijklmnopqrstuvxyzABCDEFGHIJKLMNOPQRSTUVXYZ0123456789'_"
+  "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789'_"
   "A string of all Standard ML alphanumeric characters as defined in
 section 2.4 of the Definition.")
 

[MLton-commit] r4058

[Stephen W. <sw...@ml...>]

Uploaded Debian pacakge 20050901.

----------------------------------------------------------------------

U   mlton/trunk/package/debian/changelog

----------------------------------------------------------------------

Modified: mlton/trunk/package/debian/changelog
===================================================================
--- mlton/trunk/package/debian/changelog	2005-09-01 04:01:31 UTC (rev 4057)
+++ mlton/trunk/package/debian/changelog	2005-09-01 17:45:00 UTC (rev 4058)
@@ -1,10 +1,10 @@
-mlton (20050827-1) unstable; urgency=low
+mlton (20050901-1) unstable; urgency=low
 
   * remaking package, linking normally with libgmp.  Thus, the package
     will depend on libgmp3c2, but that is OK for unstable.
-  * Fixed postinst script. closes: #324859
+  * Fixed postinst script. closes: #325850
 
- -- Stephen Weeks <sw...@sw...>  Fri, 26 Aug 2005 20:13:00 -0700
+ -- Stephen Weeks <sw...@sw...>  Thu, 01 Sep 2005 00:20:20 -0700
 
 mlton (20050826-1) unstable; urgency=low
 

[MLton-commit] r4057

[Stephen W. <sw...@ml...>]

Updated comment.

----------------------------------------------------------------------

U   mlton/trunk/runtime/gc.h

----------------------------------------------------------------------

Modified: mlton/trunk/runtime/gc.h
===================================================================
--- mlton/trunk/runtime/gc.h	2005-09-01 00:24:04 UTC (rev 4056)
+++ mlton/trunk/runtime/gc.h	2005-09-01 04:01:31 UTC (rev 4057)
@@ -47,8 +47,8 @@
  * of all nonpointer data followed by all pointer data.  
  *
  * 19 bits means that there are only 2^19 different different object layouts,
- * which appears to be plenty, since there were < 128 different types required
- * for a self-compile.
+ * which appears to be plenty, since there were < 10,000 different types 
+ * required for a self-compile.
  */
 
 /* Sizes are (almost) always measured in bytes. */

[MLton-commit] r4056

[Stephen W. <sw...@ml...>]

Cleaned up code for reporting annotation errors.  Fixed missing
newline in warning message.

----------------------------------------------------------------------

U   mlton/trunk/mlton/main/main.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun	2005-09-01 00:08:35 UTC (rev 4055)
+++ mlton/trunk/mlton/main/main.fun	2005-09-01 00:24:04 UTC (rev 4056)
@@ -122,6 +122,16 @@
 fun makeOptions {usage} = 
    let
       val usage = fn s => (ignore (usage s); raise Fail "unreachable")
+      fun reportAnnotation (s, flag, e) =
+         case e of
+            Control.Elaborate.Bad => 
+               usage (concat ["invalid -", flag, " flag: ", s])
+          | Control.Elaborate.Deprecated ids =>
+               Out.output 
+               (Out.error,
+                concat ["Warning: ", "deprecated annotation: ", s, ".  Use ",
+                        List.toString Control.Elaborate.Id.name ids, ".\n"])
+          | Control.Elaborate.Good () => ()
       open Control Popt
       fun push r = SpaceString (fn s => List.push (r, s))
       datatype z = datatype MLton.Platform.Arch.t
@@ -175,18 +185,14 @@
         boolRef contifyIntoMain),
        (Expert, "debug", " {false|true}", "produce executable with debug info",
         boolRef debug),
-       (Normal, "default-ann", " <ann>", "set annotation default for mlb files",
-        SpaceString 
-        (fn s =>
-         (case Control.Elaborate.processDefault s of
-             Control.Elaborate.Bad => 
-                usage (concat ["invalid -default-ann flag: ", s])
-           | Control.Elaborate.Deprecated ids =>
-                Out.output 
-                (Out.error,
-                 concat ["Warning: ", "deprecated annotation: ", s, ", use ",
-                         List.toString Control.Elaborate.Id.name ids, "."])
-           | Control.Elaborate.Good () => ()))),
+       let
+          val flag = "default-ann"
+       in
+          (Normal, flag, " <ann>", "set annotation default for mlb files",
+           SpaceString
+           (fn s => reportAnnotation (s, flag,
+                                      Control.Elaborate.processDefault s)))
+       end,
        (Expert, "diag-pass", " <pass>", "keep diagnostic info for pass",
         SpaceString 
         (fn s =>
@@ -197,18 +203,15 @@
                                ; List.push (keepPasses, re)
                             end
            | NONE => usage (concat ["invalid -diag-pass flag: ", s])))),
-       (Normal, "disable-ann", " <ann>", "disable annotation in mlb files",
-        SpaceString 
-        (fn s =>
-         (case Control.Elaborate.processEnabled (s, false) of
-             Control.Elaborate.Bad => 
-                usage (concat ["invalid -disable-ann flag: ", s])
-           | Control.Elaborate.Deprecated ids =>
-                Out.output 
-                (Out.error,
-                 concat ["Warning: ", "deprecated annotation: ", s, ", use ",
-                         List.toString Control.Elaborate.Id.name ids, "."])
-           | Control.Elaborate.Good () => ()))),
+       let
+          val flag = "disable-ann"
+       in
+          (Normal, flag, " <ann>", "disable annotation in mlb files",
+           SpaceString 
+           (fn s =>
+            reportAnnotation (s, flag,
+                              Control.Elaborate.processEnabled (s, false))))
+       end,
        (Expert, "drop-pass", " <pass>", "omit optimization pass",
         SpaceString
         (fn s => (case Regexp.fromString s of
@@ -216,18 +219,15 @@
                                     in List.push (dropPasses, re)
                                     end
                    | NONE => usage (concat ["invalid -drop-pass flag: ", s])))),
-       (Expert, "enable-ann", " <ann>", "globally enable annotation",
-        SpaceString 
-        (fn s =>
-         (case Control.Elaborate.processEnabled (s, true) of
-             Control.Elaborate.Bad => 
-                usage (concat ["invalid -enable-ann flag: ", s])
-           | Control.Elaborate.Deprecated ids =>
-                Out.output 
-                (Out.error,
-                 concat ["Warning: ", "deprecated annotation: ", s, ", use ",
-                         List.toString Control.Elaborate.Id.name ids, "."])
-           | Control.Elaborate.Good () => ()))),
+       let
+          val flag = "enable-ann"
+       in
+          (Expert, flag, " <ann>", "globally enable annotation",
+           SpaceString 
+           (fn s =>
+            reportAnnotation (s, flag,
+                              Control.Elaborate.processEnabled (s, true))))
+       end,
        (Expert, "error-threshhold", " 20", "error threshhold",
         intRef errorThreshhold),
        (Expert, "expert", " {false|true}", "enable expert status",

[MLton-commit] r4055

[Stephen W. <sw...@ml...>]

Fixed bug stemming from recent mllex file-position change, which
caused column numbers on the first line to be off by two.


----------------------------------------------------------------------

U   mlton/trunk/mlton/control/source.sml

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/control/source.sml
===================================================================
--- mlton/trunk/mlton/control/source.sml	2005-08-31 18:13:54 UTC (rev 4054)
+++ mlton/trunk/mlton/control/source.sml	2005-09-01 00:08:35 UTC (rev 4055)
@@ -29,7 +29,12 @@
                       
 fun new file = T {file = ref file,
                   lineNum = ref 1,
-                  lineStart = ref 1}
+                  (* mllex file positions start at zero, while we report errors
+                   * starting in column 1, so we need to pretend the first line
+                   * starts at position ~1, which will translate position 0 to
+                   * column 1.
+                   *)
+                  lineStart = ref ~1}
 
 fun newline (T {lineStart, lineNum, ...}, n) =
    (Int.inc lineNum

[MLton-commit] r4054

[Stephen W. <sw...@ml...>]

Fixed alignment on HPPA.

----------------------------------------------------------------------

U   mlton/trunk/mlton/main/main.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun	2005-08-31 17:59:25 UTC (rev 4053)
+++ mlton/trunk/mlton/main/main.fun	2005-08-31 18:13:54 UTC (rev 4054)
@@ -98,6 +98,7 @@
             ; targetOS := os
             ; (case arch of
                   Sparc => (align := Align8; codegen := CCodegen)
+                | HPPA => (align := Align8; codegen := CCodegen)
                 | X86 => codegen := Native
                 | AMD64 => codegen := Native
                 | _ => codegen := CCodegen)

[MLton-commit] r4053

[Stephen W. <sw...@ml...>]

Fixed Debian postinst script.

----------------------------------------------------------------------

U   mlton/trunk/package/debian/changelog
U   mlton/trunk/package/debian/mlton.postinst

----------------------------------------------------------------------

Modified: mlton/trunk/package/debian/changelog
===================================================================
--- mlton/trunk/package/debian/changelog	2005-08-30 20:31:20 UTC (rev 4052)
+++ mlton/trunk/package/debian/changelog	2005-08-31 17:59:25 UTC (rev 4053)
@@ -2,6 +2,7 @@
 
   * remaking package, linking normally with libgmp.  Thus, the package
     will depend on libgmp3c2, but that is OK for unstable.
+  * Fixed postinst script. closes: #324859
 
  -- Stephen Weeks <sw...@sw...>  Fri, 26 Aug 2005 20:13:00 -0700
 

Modified: mlton/trunk/package/debian/mlton.postinst
===================================================================
--- mlton/trunk/package/debian/mlton.postinst	2005-08-30 20:31:20 UTC (rev 4052)
+++ mlton/trunk/package/debian/mlton.postinst	2005-08-31 17:59:25 UTC (rev 4053)
@@ -3,7 +3,7 @@
 set -e
 
 if [ "$1" = configure ] && which install-docs >/dev/null 2>&1; then
-	for f in mllex mlton mlyacc; do
+	for f in mllex mlyacc; do
 		install-docs -i /usr/share/doc-base/$f
 	done
 fi

[MLton-commit] r4052

[Stephen W. <sw...@ml...>]

Fixed bug in -show-basis, which was mistakenly outputting "where
datatype" instead of "where type".

----------------------------------------------------------------------

U   mlton/trunk/mlton/elaborate/elaborate-env.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2005-08-30 06:08:03 UTC (rev 4051)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2005-08-30 20:31:20 UTC (rev 4052)
@@ -876,20 +876,20 @@
                                             ", "))),
                                str " "]
                      val t =
-                        case TypeStr.node s of
-                           TypeStr.Datatype _ => "datatype"
-                         | _ =>
-                              if isWhere
-                                 then "type"
-                              else
-                                 let
-                                    datatype z = datatype AdmitsEquality.t
-                                 in
-                                    case TypeStr.admitsEquality s of
-                                       Always => "eqtype"
-                                     | Never => "type"
-                                     | Sometimes => "eqtype"   
-                                 end
+                        if isWhere then
+                           "type"
+                        else
+                           (case TypeStr.node s of
+                               TypeStr.Datatype _ => "datatype"
+                             | _ =>
+                                  let
+                                     datatype z = datatype AdmitsEquality.t
+                                  in
+                                     case TypeStr.admitsEquality s of
+                                        Always => "eqtype"
+                                      | Never => "type"
+                                      | Sometimes => "eqtype"   
+                                  end)
                      val def = seq [str t, str " ", args, name, str " = "]
                      val res = 
                         case TypeStr.node s of

[MLton-commit] r4051

[Stephen W. <sw...@ml...>]

Change QuickSort.sortArray to return unit instead of an array, since
it really just side effects the array, not creating a new one.

----------------------------------------------------------------------

U   mlton/trunk/lib/mlton/basic/quick-sort.sig
U   mlton/trunk/lib/mlton/basic/quick-sort.sml
U   mlton/trunk/mlton/backend/allocate-registers.fun
U   mlton/trunk/mlton/backend/machine.fun
U   mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun
U   mlton/trunk/mlton/elaborate/elaborate-env.fun
U   mlton/trunk/mlton/elaborate/type-env.fun

----------------------------------------------------------------------

Modified: mlton/trunk/lib/mlton/basic/quick-sort.sig
===================================================================
--- mlton/trunk/lib/mlton/basic/quick-sort.sig	2005-08-28 02:34:22 UTC (rev 4050)
+++ mlton/trunk/lib/mlton/basic/quick-sort.sig	2005-08-30 06:08:03 UTC (rev 4051)
@@ -12,7 +12,7 @@
        * This is necessary to handle duplicate elements.
        *)
       (* sortArray mutates the array it is passed and returns the same array *)
-      val sortArray: 'a array * ('a * 'a -> bool) -> 'a array
+      val sortArray: 'a array * ('a * 'a -> bool) -> unit
       val sortList: 'a list * ('a * 'a -> bool) -> 'a list
       val sortVector: 'a vector * ('a * 'a -> bool) -> 'a vector
    end

Modified: mlton/trunk/lib/mlton/basic/quick-sort.sml
===================================================================
--- mlton/trunk/lib/mlton/basic/quick-sort.sml	2005-08-28 02:34:22 UTC (rev 4050)
+++ mlton/trunk/lib/mlton/basic/quick-sort.sml	2005-08-30 06:08:03 UTC (rev 4051)
@@ -21,9 +21,9 @@
  * Then, it does an insertion sort over the whole array to fix up the unsorted
  * segments.
  *)
-fun 'a sortArray (a: 'a array, op <= : 'a * 'a -> bool): 'a array =
+fun 'a sortArray (a: 'a array, op <= : 'a * 'a -> bool): unit =
    if 0 = Array.length a
-      then a
+      then ()
    else
       let
          fun x i = sub (a, i)
@@ -41,7 +41,7 @@
                then ()
             else
                let
-                  val _ = swap (l, randInt (l, u))
+                  val () = swap (l, randInt (l, u))
                   val t = x l
                   (* Partition based on page 115. *)
                   fun loop (i, j) =
@@ -86,16 +86,23 @@
              else (i, xi))
          val last = length a - 1
          val () = swap (m, last)
-         val _ = qsort (0, last - 1)
-         val _ = InsertionSort.sort (a, op <=)
+         val () = qsort (0, last - 1)
+         val () = InsertionSort.sort (a, op <=)
       in
-         a
+         ()
       end
 
-fun sortList (l, f) =
-   Array.toList (sortArray (Array.fromList l, f))
-
-fun sortVector (v, f) =
-   Array.toVector (sortArray (Array.fromVector v, f))
+local
+   fun make (from, to) (l, f) =
+      let
+         val a = from l
+         val () = sortArray (a, f)
+      in
+         to a
+      end
+in
+   val sortList = fn z => make (Array.fromList, Array.toList) z
+   val sortVector = fn z => make (Array.fromVector, Array.toVector) z
+end
    
 end

Modified: mlton/trunk/mlton/backend/allocate-registers.fun
===================================================================
--- mlton/trunk/mlton/backend/allocate-registers.fun	2005-08-28 02:34:22 UTC (rev 4050)
+++ mlton/trunk/mlton/backend/allocate-registers.fun	2005-08-30 06:08:03 UTC (rev 4051)
@@ -80,13 +80,19 @@
                      end
 
           fun new (alloc): t =
-             T (Array.toList
-                (QuickSort.sortArray
-                 (Array.fromListMap (alloc, fn StackOffset.T {offset, ty} =>
-                                     {offset = offset,
-                                      size = Type.bytes ty}),
-                  fn (r, r') => Bytes.<= (#offset r, #offset r'))))
+             let
+                val a =
+                   Array.fromListMap (alloc, fn StackOffset.T {offset, ty} =>
+                                      {offset = offset,
+                                       size = Type.bytes ty})
+                val () =
+                   QuickSort.sortArray
+                   (a, fn (r, r') => Bytes.<= (#offset r, #offset r'))
 
+             in
+                T (Array.toList a)
+             end
+
           fun get (T alloc, ty) =
              let
                 val slotSize = Type.bytes ty
@@ -205,10 +211,9 @@
                           (compress
                            {next = 0,
                             alloc =
-                            Array.toList
-                            (QuickSort.sortArray
-                             (Array.fromList rs, fn (r, r') =>
-                              Register.index r <= Register.index r'))})))
+                            QuickSort.sortList
+                            (rs, fn (r, r') =>
+                             Register.index r <= Register.index r')})))
              end
 
           fun get (T f, ty: Type.t) =

Modified: mlton/trunk/mlton/backend/machine.fun
===================================================================
--- mlton/trunk/mlton/backend/machine.fun	2005-08-28 02:34:22 UTC (rev 4050)
+++ mlton/trunk/mlton/backend/machine.fun	2005-08-30 06:08:03 UTC (rev 4051)
@@ -1141,10 +1141,9 @@
                                          then offset :: liveOffsets
                                       else liveOffsets
                                  | _ => raise No)
-                            val liveOffsets =
-                               Vector.fromArray
-                               (QuickSort.sortArray
-                                (Array.fromList liveOffsets, Bytes.<=))
+                            val liveOffsets = Array.fromList liveOffsets
+                            val () = QuickSort.sortArray (liveOffsets, Bytes.<=)
+                            val liveOffsets = Vector.fromArray liveOffsets
                             val liveOffsets' =
                                Vector.sub (frameOffsets, frameOffsetsIndex)
                                handle Subscript => raise No

Modified: mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun
===================================================================
--- mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun	2005-08-28 02:34:22 UTC (rev 4050)
+++ mlton/trunk/mlton/codegen/c-codegen/c-codegen.fun	2005-08-30 06:08:03 UTC (rev 4051)
@@ -529,12 +529,9 @@
                                     layedOut = ref false,
                                     status = ref None})
            end))
-      val entryLabels =
-         Vector.map
-         (Vector.fromArray
-          (QuickSort.sortArray
-           (Array.fromList (!entryLabels), fn ((_, i), (_, i')) => i <= i')),
-          #1)
+      val a = Array.fromList (!entryLabels)
+      val () = QuickSort.sortArray (a, fn ((_, i), (_, i')) => i <= i')
+      val entryLabels = Vector.map (Vector.fromArray a, #1)
       val labelChunk = #chunkLabel o labelInfo
       val {get = chunkLabelIndex: ChunkLabel.t -> int, ...} =
          Property.getSet (ChunkLabel.plist,

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2005-08-28 02:34:22 UTC (rev 4050)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2005-08-30 06:08:03 UTC (rev 4051)
@@ -1181,10 +1181,10 @@
                                    uses = uses}
                                end)
                val _ = current := old
-               val a =
+               val a = Array.fromList elts
+               val () =
                   QuickSort.sortArray
-                  (Array.fromList elts,
-                   fn ({domain = d, ...}, {domain = d', ...}) =>
+                  (a, fn ({domain = d, ...}, {domain = d', ...}) =>
                    Symbol.<= (toSymbol d, toSymbol d'))
             in
                Info.T a
@@ -1383,12 +1383,17 @@
                                    types = doit types,
                                    vals = doit vals})
       fun ('a, 'b) finish (r, toSymbol: 'a -> Symbol.t) =
-         QuickSort.sortArray
-         (Array.fromList (!r),
-          fn ({domain = d, time = t, ...}: ('a, 'b) Values.value,
-              {domain = d', time = t',...}: ('a, 'b) Values.value) =>
-          le ({domain = toSymbol d, time = t},
-              {domain = toSymbol d', time = t'}))
+         let
+            val a = Array.fromList (!r)
+            val () =
+               QuickSort.sortArray
+               (a, fn ({domain = d, time = t, ...}: ('a, 'b) Values.value,
+                       {domain = d', time = t',...}: ('a, 'b) Values.value) =>
+                le ({domain = toSymbol d, time = t},
+                    {domain = toSymbol d', time = t'}))
+         in
+            a
+         end
    in
       {bass = finish (bass, Basid.toSymbol),
        fcts = finish (fcts, Fctid.toSymbol),

Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun	2005-08-28 02:34:22 UTC (rev 4050)
+++ mlton/trunk/mlton/elaborate/type-env.fun	2005-08-30 06:08:03 UTC (rev 4051)
@@ -1301,10 +1301,14 @@
             val unit = con (unit, Tycon.tuple, Vector.new0 ())
             val unknown = unit
             fun sortFields (fields: (Field.t * 'a) list) =
-               Array.toVector
-               (QuickSort.sortArray
-                (Array.fromList fields, fn ((f, _), (f', _)) =>
-                 Field.<= (f, f')))
+               let
+                  val a = Array.fromList fields
+                  val () =
+                     QuickSort.sortArray (a, fn ((f, _), (f', _)) =>
+                                          Field.<= (f, f'))
+               in
+                  Array.toVector a
+               end
             fun unsorted (t, fields: (Field.t *  'a) list) =
                let
                   val v = sortFields fields

[MLton-commit] r4050

[Stephen W. <sw...@ml...>]

Made clean remove svn-commit.* files.

----------------------------------------------------------------------

U   mlton/trunk/bin/clean

----------------------------------------------------------------------

Modified: mlton/trunk/bin/clean
===================================================================
--- mlton/trunk/bin/clean	2005-08-28 00:33:33 UTC (rev 4049)
+++ mlton/trunk/bin/clean	2005-08-28 02:34:22 UTC (rev 4050)
@@ -17,7 +17,7 @@
 
 ignore='.ignore'
 doit () {
-        rm -rf '.#'* .*~ *~ *.a *.o .cm core mlmon.out
+        rm -rf '.#'* .*~ *~ *.a *.o .cm core mlmon.out svn-commit.*
         if [ -r $ignore ]; then
                 for f in `cat $ignore`; do rm -rf $f; done
         fi

[MLton-commit] r4049

[Stephen W. <sw...@ml...>]

Fixed bug in implementation of MLton_touch.  It wasn't quite correct
to drop it during SsaToRssa even when it is applied to unit, because
it is also used to ensure that code stays around for exn history
info.  The previous bugfix tickled the exnHistory.sml regression.
This commit fixes that, by keeping MLton_touch to the end of the RSSA
pipeline in all cases.


----------------------------------------------------------------------

U   mlton/trunk/mlton/backend/ssa-to-rssa.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/backend/ssa-to-rssa.fun
===================================================================
--- mlton/trunk/mlton/backend/ssa-to-rssa.fun	2005-08-27 20:40:49 UTC (rev 4048)
+++ mlton/trunk/mlton/backend/ssa-to-rssa.fun	2005-08-28 00:33:33 UTC (rev 4049)
@@ -1190,9 +1190,17 @@
                                     simpleCCall
                                     (CFunction.size (Operand.ty (a 0)))
                                | MLton_touch =>
-                                    if isSome (toRtype (varType (arg 0))) then
-                                       primApp prim
-                                    else none ()
+                                    let
+                                       val a = arg 0
+                                       val args = 
+                                          if isSome (toRtype (varType a))
+                                             then Vector.new1 (varOp a)
+                                          else Vector.new0 ()
+                                    in
+                                       add (PrimApp {args = args,
+                                                     dst = NONE,
+                                                     prim = prim})
+                                    end
                                | Pointer_getPointer => pointerGet ()
                                | Pointer_getReal _ => pointerGet ()
                                | Pointer_getWord _ => pointerGet ()

[MLton-commit] r4048

[Stephen W. <sw...@ml...>]

Added another MLton.finalizable regression.


----------------------------------------------------------------------

A   mlton/trunk/regression/finalize.5.ok
A   mlton/trunk/regression/finalize.5.sml

----------------------------------------------------------------------

Added: mlton/trunk/regression/finalize.5.ok
===================================================================
--- mlton/trunk/regression/finalize.5.ok	2005-08-27 04:28:23 UTC (rev 4047)
+++ mlton/trunk/regression/finalize.5.ok	2005-08-27 20:40:49 UTC (rev 4048)
@@ -0,0 +1,6 @@
+before test 6
+before GC 6
+after GC 6
+before GC 6a
+test 6: finalizer
+after GC 6a

Added: mlton/trunk/regression/finalize.5.sml
===================================================================
--- mlton/trunk/regression/finalize.5.sml	2005-08-27 04:28:23 UTC (rev 4047)
+++ mlton/trunk/regression/finalize.5.sml	2005-08-27 20:40:49 UTC (rev 4048)
@@ -0,0 +1,18 @@
+fun test (str : string) =
+    let open MLton.Finalizable
+        val x = new str
+        exception Exit
+    in addFinalizer (x, fn s => print (s ^ ": finalizer\n"));
+       withValue (x, fn s =>
+                        (print "before GC 6\n";
+                         MLton.GC.collect ();
+                         print "after GC 6\n";
+                         raise Exit))
+       handle Exit => ()
+    end
+
+val _ = (print "before test 6\n";
+         test "test 6";
+         print "before GC 6a\n";
+         MLton.GC.collect ();
+         print "after GC 6a\n")

[MLton-commit] r4047

[Stephen W. <sw...@ml...>]

Added MLton.Finalizable regression sent by Florian Weimer.


----------------------------------------------------------------------

A   mlton/trunk/regression/finalize.4.ok
A   mlton/trunk/regression/finalize.4.sml

----------------------------------------------------------------------

Added: mlton/trunk/regression/finalize.4.ok
===================================================================
--- mlton/trunk/regression/finalize.4.ok	2005-08-27 04:18:12 UTC (rev 4046)
+++ mlton/trunk/regression/finalize.4.ok	2005-08-27 04:28:23 UTC (rev 4047)
@@ -0,0 +1,11 @@
+before test 5
+before GC 5
+after GC 5
+before GC 5a
+after GC 5a
+invoking touch
+before GC 5b
+test 5: finalizer
+after GC 5b
+before GC 5c
+after GC 5c

Added: mlton/trunk/regression/finalize.4.sml
===================================================================
--- mlton/trunk/regression/finalize.4.sml	2005-08-27 04:18:12 UTC (rev 4046)
+++ mlton/trunk/regression/finalize.4.sml	2005-08-27 04:28:23 UTC (rev 4047)
@@ -0,0 +1,24 @@
+fun test (str : string) =
+    let open MLton.Finalizable
+        val x = new str
+    in addFinalizer (x, fn s => print (s ^ ": finalizer\n"));
+       withValue (x, fn s =>
+                        (print "before GC 5\n";
+                         MLton.GC.collect ();
+                         print "after GC 5\n";
+                         (fn () => (print "invoking touch\n"; touch x))))
+    end
+
+val _ = (print "before test 5\n";
+         let val t = test "test 5"
+         in print "before GC 5a\n";
+            MLton.GC.collect ();
+            print "after GC 5a\n";
+            t ();
+            print "before GC 5b\n";
+            MLton.GC.collect ();
+            print "after GC 5b\n"
+         end;
+         print "before GC 5c\n";
+         MLton.GC.collect ();
+         print "after GC 5c\n")

[MLton-commit] r4046

[Stephen W. <sw...@ml...>]

Rebuilding Debian package, this time linking normally with libgmp.

----------------------------------------------------------------------

U   mlton/trunk/package/debian/changelog

----------------------------------------------------------------------

Modified: mlton/trunk/package/debian/changelog
===================================================================
--- mlton/trunk/package/debian/changelog	2005-08-27 04:17:31 UTC (rev 4045)
+++ mlton/trunk/package/debian/changelog	2005-08-27 04:18:12 UTC (rev 4046)
@@ -1,3 +1,10 @@
+mlton (20050827-1) unstable; urgency=low
+
+  * remaking package, linking normally with libgmp.  Thus, the package
+    will depend on libgmp3c2, but that is OK for unstable.
+
+ -- Stephen Weeks <sw...@sw...>  Fri, 26 Aug 2005 20:13:00 -0700
+
 mlton (20050826-1) unstable; urgency=low
 
   * new upstream version

[MLton-commit] r4045

[Stephen W. <sw...@ml...>]

Fixed bug that was recently introduced with the change in
implementation of MLton_touch.  The problem was that with -profile
count, MLton_touch is used on an argument of type unit, which has no
representation, and so triggered an unhandled Option exception during
SSA to RSSA translation.  The fix was simply to drop "MLton_touch ()"
when going from SSA to RSSA.


----------------------------------------------------------------------

U   mlton/trunk/mlton/backend/ssa-to-rssa.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/backend/ssa-to-rssa.fun
===================================================================
--- mlton/trunk/mlton/backend/ssa-to-rssa.fun	2005-08-27 04:01:21 UTC (rev 4044)
+++ mlton/trunk/mlton/backend/ssa-to-rssa.fun	2005-08-27 04:17:31 UTC (rev 4045)
@@ -1189,7 +1189,10 @@
                                | MLton_size =>
                                     simpleCCall
                                     (CFunction.size (Operand.ty (a 0)))
-                               | MLton_touch => primApp prim
+                               | MLton_touch =>
+                                    if isSome (toRtype (varType (arg 0))) then
+                                       primApp prim
+                                    else none ()
                                | Pointer_getPointer => pointerGet ()
                                | Pointer_getReal _ => pointerGet ()
                                | Pointer_getWord _ => pointerGet ()

[MLton-commit] r4044

[Stephen W. <sw...@ml...>]

Fixed version target, which wasn't correctly updating the version in
the compiler sources, since it had moved files.

----------------------------------------------------------------------

U   mlton/trunk/Makefile

----------------------------------------------------------------------

Modified: mlton/trunk/Makefile
===================================================================
--- mlton/trunk/Makefile	2005-08-26 17:51:06 UTC (rev 4043)
+++ mlton/trunk/Makefile	2005-08-27 04:01:21 UTC (rev 4044)
@@ -316,7 +316,7 @@
 		package/debian/changelog				\
 		package/rpm/mlton.spec					\
 		package/freebsd/Makefile				\
-		mlton/control/control.sml; 				\
+		mlton/control/control-flags.sml;			\
 	do								\
 		sed "s/\(.*\)MLTONVERSION\(.*\)/\1$(VERSION)\2/" <$$f >z && \
 		mv z $$f;						\

[MLton-commit] r4043

[Stephen W. <sw...@ml...>]

Degian changelog for 20050826 upload.

----------------------------------------------------------------------

U   mlton/trunk/package/debian/changelog

----------------------------------------------------------------------

Modified: mlton/trunk/package/debian/changelog
===================================================================
--- mlton/trunk/package/debian/changelog	2005-08-26 17:50:18 UTC (rev 4042)
+++ mlton/trunk/package/debian/changelog	2005-08-26 17:51:06 UTC (rev 4043)
@@ -1,4 +1,4 @@
-mlton (20050825-2) unstable; urgency=low
+mlton (20050826-1) unstable; urgency=low
 
   * new upstream version
   * Fixed broken $lib in mlton script.  The previous package didn't

[MLton-commit] r4042

[Stephen W. <sw...@ml...>]

Added mlnlffigen to Debian binary-arch target.

----------------------------------------------------------------------

U   mlton/trunk/package/debian/rules

----------------------------------------------------------------------

Modified: mlton/trunk/package/debian/rules
===================================================================
--- mlton/trunk/package/debian/rules	2005-08-26 14:29:37 UTC (rev 4041)
+++ mlton/trunk/package/debian/rules	2005-08-26 17:50:18 UTC (rev 4042)
@@ -42,6 +42,7 @@
 	# dh_shlibdeps
 	dpkg-shlibdeps \
 		-e$(BUILDDIR)/usr/bin/mllex \
+		-e$(BUILDDIR)/usr/bin/mlnlffigen \
 		-e$(BUILDDIR)/usr/bin/mlprof \
 		-e$(BUILDDIR)/usr/bin/mlyacc \
 		-e$(BUILDDIR)/usr/lib/mlton/mlton-compile 

[MLton-commit] r4041

[Matthew F. <fl...@ml...>]

Style violation
----------------------------------------------------------------------

U   mlton/trunk/mlton/backend/ssa-to-rssa.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/backend/ssa-to-rssa.fun
===================================================================
--- mlton/trunk/mlton/backend/ssa-to-rssa.fun	2005-08-25 21:14:12 UTC (rev 4040)
+++ mlton/trunk/mlton/backend/ssa-to-rssa.fun	2005-08-26 14:29:37 UTC (rev 4041)
@@ -1189,8 +1189,8 @@
                                | MLton_size =>
                                     simpleCCall
                                     (CFunction.size (Operand.ty (a 0)))
+                               | MLton_touch => primApp prim
                                | Pointer_getPointer => pointerGet ()
-                               | MLton_touch => primApp prim
                                | Pointer_getReal _ => pointerGet ()
                                | Pointer_getWord _ => pointerGet ()
                                | Pointer_setPointer => pointerSet ()