mlton-commit Mailing List for MLton

Warn about deprecated features.
----------------------------------------------------------------------

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

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

Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun	2010-03-25 21:16:48 UTC (rev 7447)
+++ mlton/trunk/mlton/main/main.fun	2010-03-25 21:20:41 UTC (rev 7448)
@@ -1,4 +1,5 @@
-(* Copyright (C) 1999-2009 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2010 Matthew Fluet.
+ * Copyright (C) 1999-2009 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -288,6 +289,7 @@
                   case cg of
                      Native => if hasNativeCodegen () then SOME "native" else NONE
                    | Explicit cg => if hasCodegen cg
+                                       andalso cg <> Bytecode
                                        then SOME (Control.Codegen.toString cg)
                                     else NONE),
                  "|"),
@@ -1022,6 +1024,12 @@
                                 MLton.Platform.Arch.toString targetArch,
                                 " target"])
          else ()
+      val _ =
+         if !codegen = Bytecode
+            then Out.output
+                 (Out.error,
+                  "Warning: bytecode codegen is deprecated.  Use native or C codegen.\n")
+         else ()
       val () =
          Control.labelsHaveExtra_ := (case targetOS of
                                          Cygwin => true
@@ -1441,6 +1449,10 @@
                                    compile = Compile.compileMLB}
                   fun compileCM (file: File.t) =
                      let
+                        val _ =
+                           Out.output
+                           (Out.error,
+                            "Warning: .cm input files are deprecated.  Use .mlb input files.\n")
                         val files = CM.cm {cmfile = file}
                      in
                         compileSML files

Don't build basis-ffi.sml and basis-ffi.h when building from clean sources.

It is convenient (for cross-compiling and porting) for the runtime to
build without requiring a working mlton.  Since basis-ffi.def changes
rarely, both basis-ffi.sml and basis-ffi.h are kept in the source
repository.  Also keep the gen-basis-ffi.stamp file (used to support
the multiple target Makefile rule) in the source repository.


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

U   mlton/trunk/runtime/Makefile
_U  mlton/trunk/runtime/gen/
U   mlton/trunk/runtime/gen/.ignore
A   mlton/trunk/runtime/gen/gen-basis-ffi.stamp

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

Modified: mlton/trunk/runtime/Makefile
===================================================================
--- mlton/trunk/runtime/Makefile	2010-03-20 01:37:24 UTC (rev 7446)
+++ mlton/trunk/runtime/Makefile	2010-03-25 21:16:48 UTC (rev 7447)
@@ -317,28 +317,34 @@
 	cp $< $@
 ml-types.h: gen/ml-types.h
 	cp $< $@
-gen/c-types.h gen/c-types.sml gen/ml-types.h: gen/gen-types
+gen/c-types.h gen/c-types.sml gen/ml-types.h: gen/gen-types.stamp
 	@touch $@
-gen/gen-types: gen/gen-types.c util.h util.o
+gen/gen-types.stamp: gen/gen-types.c util.h util.o
 	$(CC) $(OPTCFLAGS) $(WARNCFLAGS) -o gen/gen-types gen/gen-types.c util.o
-	rm -f gen/c-types.h gen/c-types.sml gen/ml-types.h
+	rm -f gen/c-types.h gen/c-types.sml gen/ml-types.h gen/gen-types.stamp
 	cd gen && ./gen-types
+	rm -f gen/gen-types$(EXE) gen/gen-types
+	touch $@
 
 basis-ffi.h: gen/basis-ffi.h
 	cp $< $@
-gen/basis-ffi.h gen/basis-ffi.sml: gen/gen-basis-ffi
+gen/basis-ffi.h gen/basis-ffi.sml: gen/gen-basis-ffi.stamp
 	@touch $@
-gen/gen-basis-ffi: gen/gen-basis-ffi.sml gen/basis-ffi.def
+gen/gen-basis-ffi.stamp: gen/gen-basis-ffi.sml gen/basis-ffi.def
 	mlton -output gen/gen-basis-ffi gen/gen-basis-ffi.sml
-	rm -f gen/basis-ffi.h gen/basis-ffi.sml
+	rm -f gen/basis-ffi.h gen/basis-ffi.sml gen/gen-basis-ffi.stamp
 	cd gen && ./gen-basis-ffi
+	rm -f gen/gen-basis-ffi
+	touch $@
 
-gen/sizes: gen/gen-sizes
+gen/sizes: gen/gen-sizes.stamp
 	@touch $@
-gen/gen-sizes: gen/gen-sizes.c libmlton.a $(HFILES)
+gen/gen-sizes.stamp: gen/gen-sizes.c libmlton.a $(HFILES)
 	$(CC) $(OPTCFLAGS) $(WARNCFLAGS) -I. -o gen/gen-sizes gen/gen-sizes.c -L. -lmlton
 	rm -f gen/sizes
 	cd gen && ./gen-sizes
+	rm -f gen/gen-sizes$(EXE) gen/gen-sizes
+	touch $@
 
 platform/$(TARGET_OS)-pic.o: $(PLATFORMCFILES)
 platform/$(TARGET_OS)-gdb.o: $(PLATFORMCFILES)


Property changes on: mlton/trunk/runtime/gen
___________________________________________________________________
Name: svn:ignore
   - c-types.h
c-types.sml
gen-basis-ffi
gen-basis-ffi.exe
gen-sizes
gen-sizes.exe
gen-types
gen-types.exe
ml-types.h
sizes

   + c-types.h
c-types.sml
gen-basis-ffi
gen-basis-ffi.exe
gen-sizes
gen-sizes.exe
gen-sizes.stamp
gen-types
gen-types.exe
gen-types.stamp
ml-types.h
sizes


Modified: mlton/trunk/runtime/gen/.ignore
===================================================================
--- mlton/trunk/runtime/gen/.ignore	2010-03-20 01:37:24 UTC (rev 7446)
+++ mlton/trunk/runtime/gen/.ignore	2010-03-25 21:16:48 UTC (rev 7447)
@@ -4,7 +4,9 @@
 gen-basis-ffi.exe
 gen-sizes
 gen-sizes.exe
+gen-sizes.stamp
 gen-types
 gen-types.exe
+gen-types.stamp
 ml-types.h
 sizes

Added: mlton/trunk/runtime/gen/gen-basis-ffi.stamp
===================================================================

Halve backoff factor after 64 backoffs.

Results in more total backoffs, but faster convergence to maximum
available memory.
----------------------------------------------------------------------

U   mlton/trunk/runtime/gc/heap.c

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

Modified: mlton/trunk/runtime/gc/heap.c
===================================================================
--- mlton/trunk/runtime/gc/heap.c	2010-03-20 01:37:21 UTC (rev 7445)
+++ mlton/trunk/runtime/gc/heap.c	2010-03-20 01:37:24 UTC (rev 7446)
@@ -218,9 +218,11 @@
    * Always try a NULL address last.
    */
   size_t factor = 16;
+  const size_t maxFactor = s->sysvals.pageSize;
   size_t lowSize = minSize;
   size_t highSize = desiredSize;
   newSize = highSize;
+  unsigned int loopCount = 0;
   while (lowSize <= highSize) {
     pointer newStart;
 
@@ -277,6 +279,10 @@
                uintmaxToCommaString (prevSize - newSize),
                uintmaxToCommaString (minSize));
     }
+    if (factor < maxFactor
+        and ++loopCount % 64 == 0) {
+      factor += factor;
+    }
   }
   return FALSE;
 }

After one successful remap, continue with binary search for maximal remap.
----------------------------------------------------------------------

U   mlton/trunk/runtime/gc/heap.c

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

Modified: mlton/trunk/runtime/gc/heap.c
===================================================================
--- mlton/trunk/runtime/gc/heap.c	2010-03-20 01:37:19 UTC (rev 7444)
+++ mlton/trunk/runtime/gc/heap.c	2010-03-20 01:37:21 UTC (rev 7445)
@@ -304,12 +304,14 @@
 bool remapHeap (GC_state s, GC_heap h,
                 size_t desiredSize,
                 size_t minSize) {
+#if not HAS_REMAP
+  return FALSE;
+#endif
+
   size_t newSize;
   size_t newWithMapsSize;
+  int result;
 
-#if not HAS_REMAP
-  return FALSE;
-#endif
   if (DEBUG_MEM)
     fprintf (stderr, "remapHeap  desired size = %s  min size = %s\n",
              uintmaxToCommaString(desiredSize),
@@ -322,9 +324,11 @@
   /* Biased binary search (between minSize and desiredSize) for a
    * successful mremap.
    */
+  size_t factor = 16;
   size_t lowSize = minSize;
   size_t highSize = desiredSize;
   newSize = highSize;
+  result = FALSE;
   while (lowSize <= highSize) {
     pointer newStart;
 
@@ -333,7 +337,7 @@
     assert (isAligned (newWithMapsSize, s->sysvals.pageSize));
 
     newStart = GC_mremap (h->start, h->withMapsSize, newWithMapsSize);
-    unless ((void*)-1 == newStart) {
+    if ((void*)-1 != newStart) {
       pointer origStart = h->start;
       size_t origSize = h->size;
       size_t origWithMapsSize = h->withMapsSize;
@@ -355,30 +359,38 @@
                  uintmaxToCommaString(h->size),
                  uintmaxToCommaString(h->withMapsSize - h->size));
       }
-      return TRUE;
+      lowSize = newSize + s->sysvals.pageSize;
+      newSize = align((factor-1) * (highSize / factor) + (lowSize / factor), s->sysvals.pageSize);
+      result = TRUE;
+    } else {
+      size_t prevSize = newSize;
+      size_t prevWithMapsSize = newWithMapsSize;
+      highSize = newSize - s->sysvals.pageSize;
+      newSize = align((factor-1) * (highSize / factor) + (lowSize / factor), s->sysvals.pageSize);
+      if (s->controls.messages) {
+        fprintf (stderr,
+                 "[GC: Remapping heap at "FMTPTR" of size %s bytes (+ %s bytes card/cross map)]\n",
+                 (uintptr_t)(h->start),
+                 uintmaxToCommaString (h->size),
+                 uintmaxToCommaString (h->withMapsSize - h->size));
+        fprintf (stderr,
+                 "[GC:\tto heap of size %s bytes (+ %s bytes card/cross map) cannot be satisfied,]\n",
+                 uintmaxToCommaString (prevSize),
+                 uintmaxToCommaString (prevWithMapsSize - prevSize));
+        if (result) {
+          fprintf (stderr,
+                   "[GC:\tbacking off by %s bytes.]\n",
+                   uintmaxToCommaString (prevSize - newSize));
+        } else {
+          fprintf (stderr,
+                   "[GC:\tbacking off by %s bytes with minimum size of %s bytes.]\n",
+                   uintmaxToCommaString (prevSize - newSize),
+                   uintmaxToCommaString (minSize));
+        }
+      }
     }
-    size_t prevSize = newSize;
-    size_t prevWithMapsSize = newWithMapsSize;
-    highSize = newSize - s->sysvals.pageSize;
-    const size_t factor = 16;
-    newSize = align((factor-1) * (highSize / factor) + (lowSize / factor), s->sysvals.pageSize);
-    if (s->controls.messages) {
-      fprintf (stderr,
-               "[GC: Remapping heap at "FMTPTR" of size %s bytes (+ %s bytes card/cross map)]\n",
-               (uintptr_t)(h->start),
-               uintmaxToCommaString (h->size),
-               uintmaxToCommaString (h->withMapsSize - h->size));
-      fprintf (stderr,
-               "[GC:\tto heap of size %s bytes (+ %s bytes card/cross map) cannot be satisfied,]\n",
-               uintmaxToCommaString (prevSize),
-               uintmaxToCommaString (prevWithMapsSize - prevSize));
-      fprintf (stderr,
-               "[GC:\tbacking off by %s bytes with minimum size of %s bytes.]\n",
-               uintmaxToCommaString (prevSize - newSize),
-               uintmaxToCommaString (minSize));
-    }
   }
-  return FALSE;
+  return result;
 }
 
 enum {

Rename variables associated with address scan.
----------------------------------------------------------------------

U   mlton/trunk/runtime/gc/heap.c

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

Modified: mlton/trunk/runtime/gc/heap.c
===================================================================
--- mlton/trunk/runtime/gc/heap.c	2010-03-20 01:37:16 UTC (rev 7443)
+++ mlton/trunk/runtime/gc/heap.c	2010-03-20 01:37:19 UTC (rev 7444)
@@ -217,6 +217,7 @@
    * heaps.
    * Always try a NULL address last.
    */
+  size_t factor = 16;
   size_t lowSize = minSize;
   size_t highSize = desiredSize;
   newSize = highSize;
@@ -227,26 +228,26 @@
 
     assert (isAligned (newWithMapsSize, s->sysvals.pageSize));
 
-    const unsigned int countLog2 = 5;
-    const unsigned int count = 0x1 << countLog2;
-    const size_t step = (size_t)0x1 << (ADDRESS_BITS - countLog2);
+    const unsigned int addressCountLog2 = 5;
+    const unsigned int addressCount = 0x1 << addressCountLog2;
+    const size_t addressStep = (size_t)0x1 << (ADDRESS_BITS - addressCountLog2);
 #if ADDRESS_BITS == POINTER_BITS
-    const size_t address_end = 0;
+    const size_t addressHigh = 0;
 #else
-    const size_t address_end = (size_t)0x1 << ADDRESS_BITS;
+    const size_t addressHigh = (size_t)0x1 << ADDRESS_BITS;
 #endif
-    static bool direction = TRUE;
-    for (unsigned int i = 1; i <= count; i++) {
-      size_t address = (size_t)i * step;
-      if (direction)
-        address = address_end - address;
+    static bool addressScanDir = TRUE;
+    for (unsigned int i = 1; i <= addressCount; i++) {
+      size_t address = (size_t)i * addressStep;
+      if (addressScanDir)
+        address = addressHigh - address;
       /* Always use 0 in the last step. */
-      if (i == count)
+      if (i == addressCount)
         address = 0;
 
       newStart = GC_mmapAnon ((pointer)address, newWithMapsSize);
       unless ((void*)-1 == newStart) {
-        direction = not direction;
+        addressScanDir = not addressScanDir;
         h->start = newStart;
         h->size = newSize;
         h->withMapsSize = newWithMapsSize;
@@ -265,7 +266,6 @@
     size_t prevSize = newSize;
     size_t prevWithMapsSize = newWithMapsSize;
     highSize = newSize - s->sysvals.pageSize;
-    const size_t factor = 16;
     newSize = align((factor-1) * (highSize / factor) + (lowSize / factor), s->sysvals.pageSize);
     if (s->controls.messages) {
       fprintf (stderr,

Ensure that minSize is page aligned.

Avoids assertions with sizeofCardMapAndCrossMap.
----------------------------------------------------------------------

U   mlton/trunk/runtime/gc/heap.c

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

Modified: mlton/trunk/runtime/gc/heap.c
===================================================================
--- mlton/trunk/runtime/gc/heap.c	2010-03-17 20:57:30 UTC (rev 7442)
+++ mlton/trunk/runtime/gc/heap.c	2010-03-20 01:37:16 UTC (rev 7443)
@@ -134,6 +134,7 @@
            uintmaxToCommaString(s->controls.maxHeap));
   }
   resSize = invertSizeofCardMapAndCrossMap (s, resWithMapsSize);
+  assert (isAligned (resSize, s->sysvals.pageSize));
   if (DEBUG_RESIZING)
     fprintf (stderr, "%s = sizeofHeapDesired (%s, %s)\n",
              uintmaxToCommaString(resSize),
@@ -395,6 +396,8 @@
   pointer origStart;
   size_t liveSize;
 
+  assert (isAligned (desiredSize, s->sysvals.pageSize));
+  assert (isAligned (minSize, s->sysvals.pageSize));
   assert (desiredSize >= s->heap.size);
   if (DEBUG_RESIZING or s->controls.messages) {
     fprintf (stderr,
@@ -516,7 +519,9 @@
              uintmaxToCommaString(minSize),
              uintmaxToCommaString(s->heap.size));
   desiredSize = sizeofHeapDesired (s, minSize, s->heap.size);
+  assert (isAligned (desiredSize, s->sysvals.pageSize));
   assert (minSize <= desiredSize);
+  minSize = align (minSize, s->sysvals.pageSize);
   if (desiredSize <= s->heap.size) {
     shrinkHeap (s, &s->heap, desiredSize);
   } else {

More tweaks to GC messages.
----------------------------------------------------------------------

U   mlton/trunk/runtime/gc/garbage-collection.c
U   mlton/trunk/runtime/gc/translate.c

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

Modified: mlton/trunk/runtime/gc/garbage-collection.c
===================================================================
--- mlton/trunk/runtime/gc/garbage-collection.c	2010-03-17 20:57:27 UTC (rev 7441)
+++ mlton/trunk/runtime/gc/garbage-collection.c	2010-03-17 20:57:30 UTC (rev 7442)
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009 Matthew Fluet.
+/* Copyright (C) 2009-2010 Matthew Fluet.
  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -117,14 +117,14 @@
              uintmaxToCommaString(s->heap.size),
              uintmaxToCommaString(s->heap.withMapsSize - s->heap.size));
     fprintf (stderr, 
-             "[GC:\twith nursery of size %s bytes (%.1f%% of heap),]\n",
+             "[GC:\twith old-gen of size %s bytes (%.1f%% of heap),]\n",
+             uintmaxToCommaString(s->heap.oldGenSize),
+             100.0 * ((double)(s->heap.oldGenSize) / (double)(s->heap.size)));
+    fprintf (stderr,
+             "[GC:\tand nursery of size %s bytes (%.1f%% of heap),]\n",
              uintmaxToCommaString(nurserySize),
              100.0 * ((double)(nurserySize) / (double)(s->heap.size)));
-    fprintf (stderr, 
-             "[GC:\tand old-gen of size %s bytes (%.1f%% of heap),]\n",
-             uintmaxToCommaString(s->heap.oldGenSize),
-             100.0 * ((double)(s->heap.oldGenSize) / (double)(s->heap.size)));
-    fprintf (stderr, 
+    fprintf (stderr,
              "[GC:\tand nursery using %s bytes (%.1f%% of heap, %.1f%% of nursery).]\n",
              uintmaxToCommaString(nurseryUsed),
              100.0 * ((double)(nurseryUsed) / (double)(s->heap.size)),
@@ -171,13 +171,13 @@
              uintmaxToCommaString(s->heap.size),
              uintmaxToCommaString(s->heap.withMapsSize - s->heap.size));
     fprintf (stderr, 
-             "[GC:\twith nursery of size %s bytes (%.1f%% of heap),]\n",
+             "[GC:\twith old-gen of size %s bytes (%.1f%% of heap),]\n",
+             uintmaxToCommaString(s->heap.oldGenSize),
+             100.0 * ((double)(s->heap.oldGenSize) / (double)(s->heap.size)));
+    fprintf (stderr,
+             "[GC:\tand nursery of size %s bytes (%.1f%% of heap).]\n",
              uintmaxToCommaString(nurserySize),
              100.0 * ((double)(nurserySize) / (double)(s->heap.size)));
-    fprintf (stderr, 
-             "[GC:\tand old-gen of size %s bytes (%.1f%% of heap).]\n",
-             uintmaxToCommaString(s->heap.oldGenSize),
-             100.0 * ((double)(s->heap.oldGenSize) / (double)(s->heap.size)));
   }
   /* Send a GC signal. */
   if (s->signalsInfo.gcSignalHandled

Modified: mlton/trunk/runtime/gc/translate.c
===================================================================
--- mlton/trunk/runtime/gc/translate.c	2010-03-17 20:57:27 UTC (rev 7441)
+++ mlton/trunk/runtime/gc/translate.c	2010-03-17 20:57:30 UTC (rev 7442)
@@ -1,4 +1,5 @@
-/* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+/* Copyright (C) 2010 Matthew Fluet.
+ * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -32,9 +33,9 @@
 
   if (DEBUG or s->controls.messages)
     fprintf (stderr, 
-             "[GC: Translating heap at "FMTPTR" of size %s bytes from "FMTPTR".]\n",
+             "[GC: Translating old-gen of size %s bytes of heap at "FMTPTR" from "FMTPTR".]\n",
+             uintmaxToCommaString(size),
              (uintptr_t)to,
-             uintmaxToCommaString(size),
              (uintptr_t)from);
   s->translateState.from = from;
   s->translateState.to = to;

Fixes and updates to GC messages.
----------------------------------------------------------------------

U   mlton/trunk/runtime/gc/heap.c

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

Modified: mlton/trunk/runtime/gc/heap.c
===================================================================
--- mlton/trunk/runtime/gc/heap.c	2010-03-17 20:57:25 UTC (rev 7440)
+++ mlton/trunk/runtime/gc/heap.c	2010-03-17 20:57:27 UTC (rev 7441)
@@ -170,7 +170,7 @@
     keepWithMapsSize = keepSize + sizeofCardMapAndCrossMap (s, keepSize);
     if (DEBUG or s->controls.messages) {
       fprintf (stderr,
-               "[GC: Shrinking heap at "FMTPTR" of size %s bytes (+ %s bytes card/cross map),]\n",
+               "[GC: Shrinking heap at "FMTPTR" of size %s bytes (+ %s bytes card/cross map)]\n",
                (uintptr_t)(h->start),
                uintmaxToCommaString(h->size),
                uintmaxToCommaString(h->withMapsSize - h->size));
@@ -179,6 +179,7 @@
                uintmaxToCommaString(keepSize),
                uintmaxToCommaString(keepWithMapsSize - keepSize));
     }
+    assert (isAligned (keepWithMapsSize, s->sysvals.pageSize));
     assert (keepWithMapsSize <= h->withMapsSize);
     GC_release (h->start + keepWithMapsSize, h->withMapsSize - keepWithMapsSize);
     h->size = keepSize;
@@ -261,17 +262,18 @@
       }
     }
     size_t prevSize = newSize;
+    size_t prevWithMapsSize = newWithMapsSize;
     highSize = newSize - s->sysvals.pageSize;
     const size_t factor = 16;
     newSize = align((factor-1) * (highSize / factor) + (lowSize / factor), s->sysvals.pageSize);
     if (s->controls.messages) {
       fprintf (stderr,
                "[GC: Creating heap of size %s bytes (+ %s bytes card/cross map) cannot be satisfied,]\n",
-               uintmaxToCommaString (newSize),
-               uintmaxToCommaString (newWithMapsSize - newSize));
+               uintmaxToCommaString (prevSize),
+               uintmaxToCommaString (prevWithMapsSize - prevSize));
       fprintf (stderr,
                "[GC:\tbacking off by %s bytes with minimum size of %s bytes.]\n",
-               uintmaxToCommaString (newSize - prevSize),
+               uintmaxToCommaString (prevSize - newSize),
                uintmaxToCommaString (minSize));
     }
   }
@@ -331,32 +333,47 @@
 
     newStart = GC_mremap (h->start, h->withMapsSize, newWithMapsSize);
     unless ((void*)-1 == newStart) {
+      pointer origStart = h->start;
+      size_t origSize = h->size;
+      size_t origWithMapsSize = h->withMapsSize;
       h->start = newStart;
       h->size = newSize;
       h->withMapsSize = newWithMapsSize;
       if (h->size > s->cumulativeStatistics.maxHeapSize)
         s->cumulativeStatistics.maxHeapSize = h->size;
       assert (minSize <= h->size and h->size <= desiredSize);
-      if (DEBUG or s->controls.messages)
+      if (DEBUG or s->controls.messages) {
         fprintf (stderr,
-                 "[GC: Remapped heap at "FMTPTR" to size %s bytes (+ %s bytes card/cross map).]\n",
+                 "[GC: Remapped heap at "FMTPTR" of size %s bytes (+ %s bytes card/cross map)]\n",
+                 (uintptr_t)origStart,
+                 uintmaxToCommaString(origSize),
+                 uintmaxToCommaString(origWithMapsSize - origSize));
+        fprintf (stderr,
+                 "[GC:\tto heap at "FMTPTR" of size %s bytes (+ %s bytes card/cross map).]\n",
                  (uintptr_t)(h->start),
                  uintmaxToCommaString(h->size),
                  uintmaxToCommaString(h->withMapsSize - h->size));
+      }
       return TRUE;
     }
     size_t prevSize = newSize;
+    size_t prevWithMapsSize = newWithMapsSize;
     highSize = newSize - s->sysvals.pageSize;
     const size_t factor = 16;
     newSize = align((factor-1) * (highSize / factor) + (lowSize / factor), s->sysvals.pageSize);
     if (s->controls.messages) {
       fprintf (stderr,
-               "[GC: Remapping heap to size %s bytes (+ %s bytes card/cross map) cannot be satisfied,]\n",
-               uintmaxToCommaString (newSize),
-               uintmaxToCommaString (newWithMapsSize - newSize));
+               "[GC: Remapping heap at "FMTPTR" of size %s bytes (+ %s bytes card/cross map)]\n",
+               (uintptr_t)(h->start),
+               uintmaxToCommaString (h->size),
+               uintmaxToCommaString (h->withMapsSize - h->size));
       fprintf (stderr,
+               "[GC:\tto heap of size %s bytes (+ %s bytes card/cross map) cannot be satisfied,]\n",
+               uintmaxToCommaString (prevSize),
+               uintmaxToCommaString (prevWithMapsSize - prevSize));
+      fprintf (stderr,
                "[GC:\tbacking off by %s bytes with minimum size of %s bytes.]\n",
-               uintmaxToCommaString (newSize - prevSize),
+               uintmaxToCommaString (prevSize - newSize),
                uintmaxToCommaString (minSize));
     }
   }
@@ -386,9 +403,13 @@
              uintmaxToCommaString(s->heap.size),
              uintmaxToCommaString(s->heap.withMapsSize - s->heap.size));
     fprintf (stderr,
-             "[GC:\tto desired size of %s bytes and minimum size of %s bytes.]\n",
+             "[GC:\tto desired size of %s bytes (+ %s bytes card/cross map)]\n",
              uintmaxToCommaString(desiredSize),
-             uintmaxToCommaString(minSize));
+             uintmaxToCommaString(sizeofCardMapAndCrossMap (s, desiredSize)));
+    fprintf (stderr,
+             "[GC:\tand minimum size of %s bytes (+ %s bytes card/cross map).]\n",
+             uintmaxToCommaString(minSize),
+             uintmaxToCommaString(sizeofCardMapAndCrossMap (s, minSize)));
   }
   if (minSize <= s->heap.size) {
     useCurrent = TRUE;
@@ -450,18 +471,18 @@
 
     if (DEBUG or s->controls.messages) {
       fprintf (stderr,
-               "[GC: Writing %s bytes of heap at "FMTPTR" to disk.]\n",
-               uintmaxToCommaString(liveSize),
-               (uintptr_t)curHeapp->start);
+               "[GC: Writing heap at "FMTPTR" of size %s bytes to disk.]\n",
+               (uintptr_t)curHeapp->start,
+               uintmaxToCommaString(liveSize));
     }
     data = GC_diskBack_write (curHeapp->start, liveSize);
     releaseHeap (s, curHeapp);
     if (createHeap (s, curHeapp, desiredSize, minSize)) {
       if (DEBUG or s->controls.messages) {
         fprintf (stderr,
-                 "[GC: Reading %s bytes of heap to "FMTPTR" from disk.]\n",
-                 uintmaxToCommaString(liveSize),
-                 (uintptr_t)(curHeapp->start));
+                 "[GC: Reading heap to "FMTPTR" of size %s bytes from disk.]\n",
+                 (uintptr_t)(curHeapp->start),
+                 uintmaxToCommaString(liveSize));
       }
       GC_diskBack_read (data, curHeapp->start, liveSize);
       GC_diskBack_close (data);

Adaptive backoff doesn't require significant growth.
----------------------------------------------------------------------

U   mlton/trunk/runtime/gc/heap.c

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

Modified: mlton/trunk/runtime/gc/heap.c
===================================================================
--- mlton/trunk/runtime/gc/heap.c	2010-03-17 20:57:22 UTC (rev 7439)
+++ mlton/trunk/runtime/gc/heap.c	2010-03-17 20:57:25 UTC (rev 7440)
@@ -392,8 +392,8 @@
   }
   if (minSize <= s->heap.size) {
     useCurrent = TRUE;
-    /* Demand real growth from remapHeap and/or createHeap. */
-    minSize = (desiredSize / 2) + (s->heap.size / 2);
+    /* Demand proper growth from remapHeap and/or createHeap. */
+    minSize = s->heap.size + s->sysvals.pageSize;
   } else {
     useCurrent = FALSE;
   }

Simplify backoff scheme with a biased binary search.
----------------------------------------------------------------------

U   mlton/trunk/runtime/gc/heap.c

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

Modified: mlton/trunk/runtime/gc/heap.c
===================================================================
--- mlton/trunk/runtime/gc/heap.c	2010-03-16 02:39:17 UTC (rev 7438)
+++ mlton/trunk/runtime/gc/heap.c	2010-03-17 20:57:22 UTC (rev 7439)
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009 Matthew Fluet.
+/* Copyright (C) 2009-2010 Matthew Fluet.
  * Copyright (C) 2005-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  *
@@ -203,19 +203,28 @@
     fprintf (stderr, "createHeap  desired size = %s  min size = %s\n",
              uintmaxToCommaString(desiredSize),
              uintmaxToCommaString(minSize));
-  assert (isHeapInit (h));
   if (desiredSize < minSize)
     desiredSize = minSize;
   minSize = align (minSize, s->sysvals.pageSize);
   desiredSize = align (desiredSize, s->sysvals.pageSize);
-  assert (0 == h->size and NULL == h->start);
-  /* mmap toggling back and forth between high and low addresses to
-   * decrease the chance of virtual memory fragmentation causing an mmap
-   * to fail.  This is important for large heaps.
-   * Note that the loop always trys a NULL address last.
+  assert (isHeapInit (h) and NULL == h->start);
+  /* Biased binary search (between minSize and desiredSize) for a
+   * successful mmap.
+   * Toggle back and forth between high and low addresses to decrease
+   * the chance of virtual memory fragmentation; important for large
+   * heaps.
+   * Always try a NULL address last.
    */
-  newSize = desiredSize;
-  do {
+  size_t lowSize = minSize;
+  size_t highSize = desiredSize;
+  newSize = highSize;
+  while (lowSize <= highSize) {
+    pointer newStart;
+
+    newWithMapsSize = newSize + sizeofCardMapAndCrossMap (s, newSize);
+
+    assert (isAligned (newWithMapsSize, s->sysvals.pageSize));
+
     const unsigned int countLog2 = 5;
     const unsigned int count = 0x1 << countLog2;
     const size_t step = (size_t)0x1 << (ADDRESS_BITS - countLog2);
@@ -224,19 +233,9 @@
 #else
     const size_t address_end = (size_t)0x1 << ADDRESS_BITS;
 #endif
-
     static bool direction = TRUE;
-    unsigned int i;
-
-    newWithMapsSize = newSize + sizeofCardMapAndCrossMap (s, newSize);
-
-    assert (isAligned (newWithMapsSize, s->sysvals.pageSize));
-
-    for (i = 1; i <= count; i++) {
-      size_t address;
-      pointer newStart;
-
-      address = (size_t)i * step;
+    for (unsigned int i = 1; i <= count; i++) {
+      size_t address = (size_t)i * step;
       if (direction)
         address = address_end - address;
       /* Always use 0 in the last step. */
@@ -261,11 +260,10 @@
         return TRUE;
       }
     }
-    size_t backoff;
-    backoff = (newSize - minSize) / 16;
-    if (0 == backoff)
-      backoff = 1;
-    backoff = align (backoff, s->sysvals.pageSize);
+    size_t prevSize = newSize;
+    highSize = newSize - s->sysvals.pageSize;
+    const size_t factor = 16;
+    newSize = align((factor-1) * (highSize / factor) + (lowSize / factor), s->sysvals.pageSize);
     if (s->controls.messages) {
       fprintf (stderr,
                "[GC: Creating heap of size %s bytes (+ %s bytes card/cross map) cannot be satisfied,]\n",
@@ -273,16 +271,10 @@
                uintmaxToCommaString (newWithMapsSize - newSize));
       fprintf (stderr,
                "[GC:\tbacking off by %s bytes with minimum size of %s bytes.]\n",
-               uintmaxToCommaString (backoff),
+               uintmaxToCommaString (newSize - prevSize),
                uintmaxToCommaString (minSize));
     }
-    size_t nextSize = newSize - backoff;
-    if (nextSize < minSize and minSize < newSize) {
-      newSize = minSize;
-    } else {
-      newSize = nextSize;
-    }
-  } while (newSize >= minSize);
+  }
   return FALSE;
 }
 
@@ -311,8 +303,6 @@
                 size_t minSize) {
   size_t newSize;
   size_t newWithMapsSize;
-  size_t origSize;
-  size_t origWithMapsSize;
 
 #if not HAS_REMAP
   return FALSE;
@@ -325,17 +315,21 @@
   assert (desiredSize >= h->size);
   minSize = align (minSize, s->sysvals.pageSize);
   desiredSize = align (desiredSize, s->sysvals.pageSize);
-  origSize = h->size;
-  origWithMapsSize = origSize + sizeofCardMapAndCrossMap (s, origSize);
-  newSize = desiredSize;
-  do {
+
+  /* Biased binary search (between minSize and desiredSize) for a
+   * successful mremap.
+   */
+  size_t lowSize = minSize;
+  size_t highSize = desiredSize;
+  newSize = highSize;
+  while (lowSize <= highSize) {
     pointer newStart;
 
     newWithMapsSize = newSize + sizeofCardMapAndCrossMap (s, newSize);
 
     assert (isAligned (newWithMapsSize, s->sysvals.pageSize));
 
-    newStart = GC_mremap (h->start, origWithMapsSize, newWithMapsSize);
+    newStart = GC_mremap (h->start, h->withMapsSize, newWithMapsSize);
     unless ((void*)-1 == newStart) {
       h->start = newStart;
       h->size = newSize;
@@ -351,11 +345,10 @@
                  uintmaxToCommaString(h->withMapsSize - h->size));
       return TRUE;
     }
-    size_t backoff;
-    backoff = (newSize - minSize) / 16;
-    if (0 == backoff)
-      backoff = 1;
-    backoff = align (backoff, s->sysvals.pageSize);
+    size_t prevSize = newSize;
+    highSize = newSize - s->sysvals.pageSize;
+    const size_t factor = 16;
+    newSize = align((factor-1) * (highSize / factor) + (lowSize / factor), s->sysvals.pageSize);
     if (s->controls.messages) {
       fprintf (stderr,
                "[GC: Remapping heap to size %s bytes (+ %s bytes card/cross map) cannot be satisfied,]\n",
@@ -363,16 +356,10 @@
                uintmaxToCommaString (newWithMapsSize - newSize));
       fprintf (stderr,
                "[GC:\tbacking off by %s bytes with minimum size of %s bytes.]\n",
-               uintmaxToCommaString (backoff),
+               uintmaxToCommaString (newSize - prevSize),
                uintmaxToCommaString (minSize));
     }
-    size_t nextSize = newSize - backoff;
-    if (nextSize < minSize and minSize < newSize) {
-      newSize = minSize;
-    } else {
-      newSize = nextSize;
-    }
-  } while (newSize >= minSize);
+  }
   return FALSE;
 }
 

Update hash function documentation.
----------------------------------------------------------------------

U   mlton/trunk/mlton/ssa/poly-hash.fun

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

Modified: mlton/trunk/mlton/ssa/poly-hash.fun
===================================================================
--- mlton/trunk/mlton/ssa/poly-hash.fun	2010-03-16 02:39:12 UTC (rev 7437)
+++ mlton/trunk/mlton/ssa/poly-hash.fun	2010-03-16 02:39:17 UTC (rev 7438)
@@ -50,7 +50,6 @@
       in
          val add = mk Prim.wordAdd
          val andb = mk Prim.wordAndb
-         val lshift = mk Prim.wordLshift
          val rshift = mk (fn s => Prim.wordRshift (s, {signed = false}))
          val xorb = mk Prim.wordXorb
       end
@@ -163,17 +162,17 @@
             wordBytes
          end
 
-      (* Jenkins One-at-a-time hash
-       * http://en.wikipedia.org/wiki/Hash_table
-       *) 
 (*
+      (* Jenkins hash function
+       * http://en.wikipedia.org/wiki/Jenkins_hash_function  (20100315)
+       *) 
       val {stateTy, init, wordBytes, fini} =
          let
             val stateWordSize = resWordSize
             val stateTy = Type.word stateWordSize
             val workWordSize = resWordSize
             val workTy = Type.word workWordSize
-               
+
             local
                fun mk prim =
                   fn (w1, w2) => prim (w1, w2, stateWordSize)
@@ -246,8 +245,9 @@
              fini = fini}
          end
 *)
-      (* Modifed FNV
-       * http://home.comcast.net/~bretm/hash/6.html
+
+      (* FNV-1a hash function
+       * http://en.wikipedia.org/wiki/Fowler-Noll-Vo_hash_function  (20100315)
        *)
       val {stateTy, init, wordBytes, fini} =
          let
@@ -260,14 +260,14 @@
                fun mk prim =
                   fn (w1, w2) => prim (w1, w2, stateWordSize)
             in
-               val add = mk Dexp.add
-               val lshift = mk Dexp.lshift
                val mul = mk (fn (w1,w2,s) => Dexp.mul (w1,w2,s,{signed = false}))
-               val rshift = mk Dexp.rshift
                val xorb = mk Dexp.xorb
             end
 
-            fun init () = Dexp.word (WordX.fromIntInf (2166136261, stateWordSize))
+            val fnv_prime = WordX.fromIntInf (16777619, stateWordSize)
+            val fnv_offset_bias = WordX.fromIntInf (2166136261, stateWordSize)
+
+            fun init () = Dexp.word fnv_offset_bias
             fun combByte (hexp, wexp) =
                let
                   val h0 = Var.newNoname ()
@@ -287,7 +287,7 @@
                let
                   val h0 = Var.newNoname ()
                   val dh0 = Dexp.var (h0, stateTy)
-                  val p = Dexp.word (WordX.fromIntInf (16777619, stateWordSize))
+                  val p = Dexp.word fnv_prime
                   val h1 = Var.newNoname ()
                   val dh1 = Dexp.var (h1, stateTy)
                in
@@ -302,30 +302,7 @@
                 workWordSize = workWordSize,
                 combByte = combByte,
                 mix = mix}
-            fun fini hexp =
-               let
-                  val h0 = Var.newNoname ()
-                  val dh0 = Dexp.var (h0, stateTy)
-                  val h1 = Var.newNoname ()
-                  val dh1 = Dexp.var (h1, stateTy)
-                  val h2 = Var.newNoname ()
-                  val dh2 = Dexp.var (h2, stateTy)
-                  val h3 = Var.newNoname ()
-                  val dh3 = Dexp.var (h3, stateTy)
-                  val h4 = Var.newNoname ()
-                  val dh4 = Dexp.var (h4, stateTy)
-                  val h5 = Var.newNoname ()
-                  val dh5 = Dexp.var (h5, stateTy)
-               in
-                  Dexp.lett
-                  {decs = [{var = h0, exp = hexp},
-                           {var = h1, exp = add (dh0, lshift (dh0, Dexp.shiftInt 13))},
-                           {var = h2, exp = xorb (dh1, rshift (dh1, Dexp.shiftInt 7))},
-                           {var = h3, exp = add (dh2, lshift (dh2, Dexp.shiftInt 3))},
-                           {var = h4, exp = xorb (dh3, rshift (dh3, Dexp.shiftInt 17))},
-                           {var = h5, exp = add (dh4, lshift (dh4, Dexp.shiftInt 5))}],
-                   body = dh5}
-               end
+            fun fini hexp = hexp
          in
             {stateTy = stateTy,
              init = init,

Make MLton.hash a complete (linear time) hash.
----------------------------------------------------------------------

U   mlton/trunk/basis-library/mlton/mlton.sml
U   mlton/trunk/basis-library/primitive/prim-mlton.sml
U   mlton/trunk/mlton/atoms/prim.fun
U   mlton/trunk/mlton/ssa/poly-hash.fun

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

Modified: mlton/trunk/basis-library/mlton/mlton.sml
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sml	2010-03-13 12:09:26 UTC (rev 7436)
+++ mlton/trunk/basis-library/mlton/mlton.sml	2010-03-16 02:39:12 UTC (rev 7437)
@@ -1,4 +1,5 @@
-(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2010 Matthew Fluet.
+ * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -39,14 +40,7 @@
 val debug = Primitive.Controls.debug
 val eq = Primitive.MLton.eq
 val equal = Primitive.MLton.equal
-local
-   fun hash_param depth x = 
-      if Int.< (depth, 0)
-         then raise Domain
-      else Primitive.MLton.hash (SeqIndex.fromInt depth, x)
-in
-   fun hash x = hash_param 0xF x
-end
+val hash = Primitive.MLton.hash
 (* val errno = Primitive.errno *)
 val safe = Primitive.Controls.safe
 

Modified: mlton/trunk/basis-library/primitive/prim-mlton.sml
===================================================================
--- mlton/trunk/basis-library/primitive/prim-mlton.sml	2010-03-13 12:09:26 UTC (rev 7436)
+++ mlton/trunk/basis-library/primitive/prim-mlton.sml	2010-03-16 02:39:12 UTC (rev 7437)
@@ -19,7 +19,7 @@
 val equal = _prim "MLton_equal": 'a * 'a -> bool;
 (* val deserialize = _prim "MLton_deserialize": Word8Vector.vector -> 'a ref; *)
 val halt = _prim "MLton_halt": C_Status.t -> unit;
-val hash = _prim "MLton_hash": SeqIndex.int * 'a -> Word32.word;
+val hash = _prim "MLton_hash": 'a -> Word32.word;
 (* val serialize = _prim "MLton_serialize": 'a ref -> Word8Vector.vector; *)
 val share = _prim "MLton_share": 'a -> unit;
 val size = _prim "MLton_size": 'a ref -> C_Size.t;

Modified: mlton/trunk/mlton/atoms/prim.fun
===================================================================
--- mlton/trunk/mlton/atoms/prim.fun	2010-03-13 12:09:26 UTC (rev 7436)
+++ mlton/trunk/mlton/atoms/prim.fun	2010-03-16 02:39:12 UTC (rev 7437)
@@ -1285,7 +1285,7 @@
        | MLton_eq => oneTarg (fn t => (twoArgs (t, t), bool))
        | MLton_equal => oneTarg (fn t => (twoArgs (t, t), bool))
        | MLton_halt => noTargs (fn () => (oneArg cint, unit))
-       | MLton_hash => oneTarg (fn t => (twoArgs (seqIndex, t), word32))
+       | MLton_hash => oneTarg (fn t => (oneArg t, word32))
        | MLton_handlesSignals => noTargs (fn () => (noArgs, bool))
        | MLton_installSignalHandler => noTargs (fn () => (noArgs, unit))
        | MLton_serialize => oneTarg (fn t => (oneArg t, word8Vector))
@@ -1418,7 +1418,7 @@
        | MLton_deserialize => one result
        | MLton_eq => one (arg 0)
        | MLton_equal => one (arg 0)
-       | MLton_hash => one (arg 1)
+       | MLton_hash => one (arg 0)
        | MLton_serialize => one (arg 0)
        | MLton_share => one (arg 0)
        | MLton_size => one (arg 0)

Modified: mlton/trunk/mlton/ssa/poly-hash.fun
===================================================================
--- mlton/trunk/mlton/ssa/poly-hash.fun	2010-03-13 12:09:26 UTC (rev 7436)
+++ mlton/trunk/mlton/ssa/poly-hash.fun	2010-03-16 02:39:12 UTC (rev 7437)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009-2010 Matthew Fluet.
  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -52,7 +52,6 @@
          val andb = mk Prim.wordAndb
          val lshift = mk Prim.wordLshift
          val rshift = mk (fn s => Prim.wordRshift (s, {signed = false}))
-         val sub = mk Prim.wordSub
          val xorb = mk Prim.wordXorb
       end
       local
@@ -64,7 +63,6 @@
                      ty = Type.word s}
       in
          val mul = mk Prim.wordMul
-         val quot = mk Prim.wordQuot
       end
 
       fun wordEqual (e1: t, e2: t, s): t =
@@ -72,11 +70,6 @@
                   targs = Vector.new0 (),
                   args = Vector.new2 (e1, e2),
                   ty = Type.bool}
-      fun wordLt (e1: t, e2: t, s, sg): t =
-         primApp {prim = Prim.wordLt (s, {signed = sg}),
-                  targs = Vector.new0 (),
-                  args = Vector.new2 (e1, e2),
-                  ty = Type.bool}
 end
 
 structure Hash =
@@ -386,45 +379,35 @@
                   val _ = setTyconHashFunc (tycon, SOME name)
                   val ty = Type.datatypee tycon
                   val st = (Var.newNoname (), Hash.stateTy)
-                  val dep = (Var.newNoname (), seqIndexTy)
                   val x = (Var.newNoname (), ty)
-                  val args = Vector.new3 (st, dep, x)
+                  val args = Vector.new2 (st, x)
                   val dst = Dexp.var st
-                  val ddep = Dexp.var dep
                   val dx = Dexp.var x
                   val cons = tyconCons tycon
-                  val dep' = Var.newNoname ()
-                  val ddep' = Dexp.var (dep', seqIndexTy)
                   val body =
-                     Dexp.lett
-                     {decs = [{var = dep', exp =
-                               Dexp.sub (ddep, 
-                                         Dexp.word (WordX.one seqIndexWordSize), 
-                                         seqIndexWordSize)}],
-                      body =
-                      Dexp.casee
-                      {test = dx,
-                       ty = Hash.stateTy,
-                       default = NONE,
-                       cases =
-                       (Dexp.Con o Vector.map)
-                       (cons, fn {con, args} =>
-                        let
-                           val xs =
-                              Vector.map 
-                              (args, fn ty =>
-                               (Var.newNoname (), ty))
-                        in
-                           {con = con,
-                            args = xs,
-                            body = 
-                            Vector.fold
-                            (xs, 
-                             Hash.wordBytesFromWord
-                             (dst, Con.hash con, WordSize.word32),
-                             fn ((x,ty), dstate) => 
-                             hashExp (dstate, ddep', Dexp.var (x, ty), ty))}
-                        end)}}
+                     Dexp.casee
+                     {test = dx,
+                      ty = Hash.stateTy,
+                      default = NONE,
+                      cases =
+                      (Dexp.Con o Vector.map)
+                      (cons, fn {con, args} =>
+                       let
+                          val xs =
+                             Vector.map
+                             (args, fn ty =>
+                              (Var.newNoname (), ty))
+                       in
+                          {con = con,
+                           args = xs,
+                           body =
+                           Vector.fold
+                           (xs,
+                            Hash.wordBytesFromWord
+                            (dst, Con.hash con, WordSize.word32),
+                            fn ((x,ty), dstate) =>
+                            hashExp (dstate, Dexp.var (x, ty), ty))}
+                       end)}
                   val (start, blocks) = Dexp.linearize (body, Handler.Caller)
                   val blocks = Vector.fromList blocks
                   val _ =
@@ -452,71 +435,25 @@
                   val vty = Type.vector ty
                   local
                      val st = (Var.newNoname (), Hash.stateTy)
-                     val dep = (Var.newNoname (), seqIndexTy)
                      val vec = (Var.newNoname (), vty)
-                     val args = Vector.new3 (st, dep, vec)
+                     val args = Vector.new2 (st, vec)
                      val dst = Dexp.var st
-                     val ddep = Dexp.var dep
                      val dvec = Dexp.var vec
                      val len = (Var.newNoname (), seqIndexTy)
                      val dlen = Dexp.var len
-                     val maxstepTy = Type.tuple (Vector.new2 (seqIndexTy, seqIndexTy)) 
-                     val maxstep = (Var.newNoname (), maxstepTy)
-                     val dmaxstep = Dexp.var maxstep
                      val body =
                         Dexp.lett
                         {decs = [{var = #1 len, exp = 
                                   Dexp.primApp {prim = Prim.vectorLength,
                                                 targs = Vector.new1 ty,
                                                 args = Vector.new1 dvec,
-                                                ty = seqIndexTy}},
-                                 {var = #1 maxstep, exp =
-                                  Dexp.casee
-                                  {test = Dexp.wordLt (dlen, ddep, seqIndexWordSize, true),
-                                   ty = maxstepTy,
-                                   default = NONE,
-                                   cases =
-                                   (Dexp.Con o Vector.new2)
-                                   ({con = Con.truee,
-                                     args = Vector.new0 (),
-                                     body = 
-                                     Dexp.tuple
-                                     {exps = Vector.new2 
-                                             (dlen, 
-                                              Dexp.word (WordX.one seqIndexWordSize)),
-                                      ty = maxstepTy}},
-                                    {con = Con.falsee,
-                                     args = Vector.new0 (),
-                                     body = 
-                                     let
-                                        val step = (Var.newNoname (), seqIndexTy)
-                                        val dstep = Dexp.var step
-                                        val max = (Var.newNoname (), seqIndexTy)
-                                        val dmax = Dexp.var max
-                                     in
-                                        Dexp.lett
-                                        {decs = [{var = #1 step, exp =
-                                                  Dexp.quot (dlen,
-                                                             ddep,
-                                                             seqIndexWordSize,
-                                                             {signed = true})},
-                                                 {var = #1 max, exp = 
-                                                  Dexp.mul (dstep,
-                                                            ddep,
-                                                            seqIndexWordSize,
-                                                            {signed = true})}],
-                                         body = Dexp.tuple {exps = Vector.new2 (dmax, dstep),
-                                                            ty = maxstepTy}}
-                                     end})}}],
+                                                ty = seqIndexTy}}],
                          body =
                          Dexp.call
                          {func = loop,
-                          args = (Vector.new6
+                          args = (Vector.new4
                                   (Hash.wordBytes (dst, dlen, seqIndexWordSize),
-                                   ddep, dvec, 
-                                   Dexp.select {offset = 0, tuple = dmaxstep, ty = seqIndexTy},
-                                   Dexp.select {offset = 1, tuple = dmaxstep, ty = seqIndexTy},
-                                   Dexp.word (WordX.zero seqIndexWordSize))),
+                                   dvec, dlen, Dexp.word (WordX.zero seqIndexWordSize))),
                           ty = Hash.stateTy}}
                      val (start, blocks) = Dexp.linearize (body, Handler.Caller)
                      val blocks = Vector.fromList blocks
@@ -532,43 +469,34 @@
                   end
                   local
                      val st = (Var.newNoname (), Hash.stateTy)
-                     val dep = (Var.newNoname (), seqIndexTy)
                      val vec = (Var.newNoname (), vty)
-                     val max = (Var.newNoname (), seqIndexTy)
-                     val step = (Var.newNoname (), seqIndexTy)
+                     val len = (Var.newNoname (), seqIndexTy)
                      val i = (Var.newNoname (), seqIndexTy)
-                     val args = Vector.new6 (st, dep, vec, max, step, i)
+                     val args = Vector.new4 (st, vec, len, i)
                      val dst = Dexp.var st
-                     val ddep = Dexp.var dep
                      val dvec = Dexp.var vec
-                     val dmax = Dexp.var max
-                     val dstep = Dexp.var step
+                     val dlen = Dexp.var len
                      val di = Dexp.var i
                      val body =
                         let
                            val args =
-                              Vector.new6
+                              Vector.new4
                               (hashExp 
                                (dst, 
-                                Dexp.sub (ddep, 
-                                          Dexp.word (WordX.one seqIndexWordSize), 
-                                          seqIndexWordSize), 
                                 Dexp.primApp {prim = Prim.vectorSub,
                                               targs = Vector.new1 ty,
                                               args = Vector.new2 (dvec, di),
                                               ty = ty},
                                 ty),
-                               ddep,
                                dvec, 
-                               dmax,
-                               dstep,
+                               dlen,
                                Dexp.add (di, 
-                                         dstep,
+                                         Dexp.word (WordX.one seqIndexWordSize),
                                          seqIndexWordSize))
                         in
                            Dexp.casee
                            {test = Dexp.wordEqual
-                                   (di, dmax, seqIndexWordSize),
+                                   (di, dlen, seqIndexWordSize),
                             ty = Hash.stateTy,
                             default = NONE,
                             cases = (Dexp.Con o Vector.new2)
@@ -596,14 +524,12 @@
                in
                   name
                end
-      and hashExp (st: Dexp.t, dep: Dexp.t, x: Dexp.t, ty: Type.t): Dexp.t =
+      and hashExp (st: Dexp.t, x: Dexp.t, ty: Type.t): Dexp.t =
          Dexp.name (st, fn st =>
-         Dexp.name (dep, fn dep =>
-         Dexp.name (x, fn x => hash (st, dep, x, ty))))
-      and hash (st: Var.t, dep: Var.t, x: Var.t, ty: Type.t): Dexp.t =
+         Dexp.name (x, fn x => hash (st, x, ty)))
+      and hash (st: Var.t, x: Var.t, ty: Type.t): Dexp.t =
          let
             val dst = Dexp.var (st, Hash.stateTy)
-            val ddep = Dexp.var (dep, seqIndexTy)
             val dx = Dexp.var (x, ty)
             fun stateful () =
                Hash.wordBytesFromWord
@@ -626,7 +552,7 @@
                      end
                 | Type.Datatype tycon =>
                      Dexp.call {func = hashTyconFunc tycon,
-                                args = Vector.new3 (dst, ddep, dx),
+                                args = Vector.new2 (dst, dx),
                                 ty = Hash.stateTy}
                 | Type.IntInf => 
                      let
@@ -664,7 +590,7 @@
                             args = Vector.new0 (),
                             body = 
                             Dexp.call {func = vectorHashFunc (Type.word bws),
-                                       args = Vector.new3 (dst, ddep, toVector),
+                                       args = Vector.new2 (dst, toVector),
                                        ty = Hash.stateTy}})}}
                      end
                 | Type.Real rs =>
@@ -684,7 +610,7 @@
                 | Type.Tuple tys =>
                      let
                         val max = Vector.length tys - 1
-                        (* test components i, i+1, ... *)
+                        (* hash components i, i+1, ... *)
                         fun loop (i: int, dst): Dexp.t =
                            if i > max
                               then dst
@@ -697,32 +623,19 @@
                                 in
                                    loop
                                    (i + 1,
-                                    hashExp (dst, ddep, select, ty))
+                                    hashExp (dst, select, ty))
                                 end
                      in
                         loop (0, dst)
                      end
                 | Type.Vector ty =>
                      Dexp.call {func = vectorHashFunc ty,
-                                args = Vector.new3 (dst, ddep, dx),
+                                args = Vector.new2 (dst, dx),
                                 ty = Hash.stateTy}
                 | Type.Weak _ => stateful ()
                 | Type.Word ws => Hash.wordBytes (dst, dx, ws)
          in
-            Dexp.casee
-            {test = Dexp.wordEqual (ddep,
-                                    Dexp.word (WordX.zero seqIndexWordSize),
-                                    seqIndexWordSize),
-             ty = Hash.stateTy,
-             default = NONE,
-             cases =
-             (Dexp.Con o Vector.new2)
-             ({con = Con.truee,
-               args = Vector.new0 (),
-               body = dst},
-              {con = Con.falsee,
-               args = Vector.new0 (),
-               body = body})}
+            body
          end
       fun hashFunc (ty: Type.t): Func.t =
          case getHashFunc ty of
@@ -731,12 +644,10 @@
                let
                   val name = Func.newString "hash"
                   val _ = setHashFunc (ty, SOME name)
-                  val dep = (Var.newNoname (), seqIndexTy)
                   val x = (Var.newNoname (), ty)
-                  val args = Vector.new2 (dep, x)
+                  val args = Vector.new1 x
                   val sti = Var.newNoname ()
                   val dsti = Dexp.var (sti, Hash.stateTy)
-                  val ddep = Dexp.var dep
                   val dx = Dexp.var x
                   val stf = Var.newNoname ()
                   val dstf = Dexp.var (stf, Hash.stateTy)
@@ -745,7 +656,7 @@
                   val body = 
                      Dexp.lett
                      {decs = [{var = sti, exp = Hash.init ()},
-                              {var = stf, exp = hashExp (dsti, ddep, dx, ty)},
+                              {var = stf, exp = hashExp (dsti, dx, ty)},
                               {var = w, exp = Hash.fini dstf}],
                       body = dw}
                   val (start, blocks) = Dexp.linearize (body, Handler.Caller)
@@ -823,13 +734,12 @@
                                    (Prim.Name.MLton_hash, 1) =>
                                       let
                                          val ty = Vector.sub (targs, 0)
-                                         val dep = Vector.sub (args, 0)
-                                         val x = Vector.sub (args, 1)
+                                         val x = Vector.sub (args, 0)
                                          val l = Label.newNoname ()
                                       in
                                         (finish 
                                          (las, 
-                                          Call {args = Vector.new2 (dep, x),
+                                          Call {args = Vector.new1 x,
                                                 func = hashFunc ty,
                                                 return = Return.NonTail 
                                                          {cont = l,

Output for withtype regression tests.
----------------------------------------------------------------------

A   mlton/trunk/regression/withtype2.ok
A   mlton/trunk/regression/withtype3.ok
A   mlton/trunk/regression/withtype4.ok
A   mlton/trunk/regression/withtype5.ok

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

Copied: mlton/trunk/regression/withtype2.ok (from rev 7435, mlton/trunk/regression/withtype.ok)

Copied: mlton/trunk/regression/withtype3.ok (from rev 7435, mlton/trunk/regression/withtype.ok)

Copied: mlton/trunk/regression/withtype4.ok (from rev 7435, mlton/trunk/regression/withtype.ok)

Copied: mlton/trunk/regression/withtype5.ok (from rev 7435, mlton/trunk/regression/withtype.ok)

Unify the elaboration of datatype specifications and datatype declarations.
----------------------------------------------------------------------

U   mlton/trunk/mlton/elaborate/elaborate-core.fun
U   mlton/trunk/mlton/elaborate/elaborate-sigexp.fun

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

Modified: mlton/trunk/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-core.fun	2010-03-12 21:33:05 UTC (rev 7434)
+++ mlton/trunk/mlton/elaborate/elaborate-core.fun	2010-03-12 21:33:10 UTC (rev 7435)
@@ -1657,6 +1657,7 @@
                                                   {con = con, name = name}))
                 in
                    {cons = cons,
+                    kind = kind,
                     makeCons = makeCons,
                     name = name,
                     tycon = tycon,
@@ -1666,7 +1667,7 @@
             val (dbs, strs) =
                (Vector.unzip o Vector.map)
                (datatypes,
-                fn {cons, makeCons, name, tycon, tyvars} =>
+                fn {cons, kind, makeCons, name, tycon, tyvars} =>
                 let
                    val resultType: Type.t =
                       Type.con (tycon, Vector.map (tyvars, Type.var))
@@ -1692,9 +1693,7 @@
                            (scheme, {arg = arg, con = con})
                         end))
                    val typeStr =
-                      TypeStr.data (tycon,
-                                    Kind.Arity (Vector.length tyvars),
-                                    makeCons schemes)
+                      TypeStr.data (tycon, kind, makeCons schemes)
                 in
                    ({cons = datatypeCons,
                      tycon = tycon,
@@ -1723,7 +1722,7 @@
                           | Never => ()
                           | Sometimes =>
                                if Vector.forall
-                                  (cons, fn {arg, con, ...} =>
+                                  (cons, fn {arg, ...} =>
                                    case arg of
                                       NONE => true
                                     | SOME ty =>

Modified: mlton/trunk/mlton/elaborate/elaborate-sigexp.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-sigexp.fun	2010-03-12 21:33:05 UTC (rev 7434)
+++ mlton/trunk/mlton/elaborate/elaborate-sigexp.fun	2010-03-12 21:33:10 UTC (rev 7435)
@@ -1,4 +1,5 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2010 Matthew Fluet.
+ * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -183,28 +184,31 @@
 fun elaborateDatBind (datBind: DatBind.t, E): unit =
    let
       val DatBind.T {datatypes, ...} = DatBind.node datBind
-      val change = ref false
       (* Build enough of an interface so that that the constructor argument
        * types can be elaborated.
        *)
-      val tycons =
+      val datatypes =
          Vector.map
-         (datatypes, fn {tycon = name, tyvars, ...} =>
+         (datatypes, fn {cons, tycon = name, tyvars} =>
           let
              val kind = Kind.Arity (Vector.length tyvars)
              val tycon = Tycon.make {hasCons = true, kind = kind}
              val _ =
-                Env.extendTycon (E, name, TypeStr.data (tycon, kind, Cons.empty))
+                Env.extendTycon (E, name, TypeStr.tycon (tycon, kind))
           in
-             tycon
+             {cons = cons,
+              kind = kind,
+              name = name,
+              tycon = tycon,
+              tyvars = tyvars}
           end)
-      fun elabAll (): unit =
-         Vector.foreach2
-         (tycons, datatypes, fn (tycon, {cons, tycon = astTycon, tyvars, ...}) =>
+      val datatypes =
+         Vector.map
+         (datatypes, fn {cons, kind, name, tycon, tyvars, ...} =>
           let
              val resultType: Atype.t =
-                Atype.con (astTycon, Vector.map (tyvars, Atype.var))
-             val (cons, conArgs) =
+                Atype.con (name, Vector.map (tyvars, Atype.var))
+             val (consSchemes, consArgs) =
                 Vector.unzip
                 (Vector.map
                  (cons, fn (name, arg) =>
@@ -213,16 +217,46 @@
                         case arg of
                            NONE => (fn _ => NONE, resultType)
                          | SOME t =>
-                              (fn s =>
-                               SOME (#1 (Type.deArrow (Scheme.ty s))),
-                               Atype.arrow (t, resultType))
+                           (fn s => SOME (#1 (Type.deArrow (Scheme.ty s))),
+                            Atype.arrow (t, resultType))
                      val scheme = elaborateScheme (tyvars, ty, E)
                   in
                      ({name = name,
                        scheme = scheme},
-                      makeArg scheme)
+                      {con = name,
+                       arg = makeArg scheme})
                   end))
+          in
+             {consArgs = consArgs,
+              consSchemes = consSchemes,
+              kind = kind,
+              name = name,
+              tycon = tycon,
+              tyvars = tyvars}
+          end)
+      val _ = Env.allowDuplicates := true
+      val _ =
+         Vector.foreach
+         (datatypes, fn {consSchemes, kind, name, tycon, ...} =>
+          let
              val _ =
+                Vector.foreach
+                (consSchemes, fn {name, scheme} =>
+                 Env.extendCon (E, name, scheme))
+             val _ =
+                Env.extendTycon
+                (E, name, TypeStr.data (tycon, kind, Cons.T consSchemes))
+          in
+             ()
+          end)
+      val _ = Env.allowDuplicates := false
+      (* Maximize equality *)
+      val change = ref false
+      fun loop () =
+         let
+            val _ =
+               Vector.foreach
+               (datatypes, fn {consArgs, tycon, tyvars, ...} =>
                 let
                    val r = Tycon.admitsEquality tycon
                    datatype z = datatype AdmitsEquality.t
@@ -232,7 +266,7 @@
                     | Never => ()
                     | Sometimes =>
                          if Vector.forall
-                            (conArgs, fn arg =>
+                            (consArgs, fn {arg, ...} =>
                              case arg of
                                 NONE => true
                               | SOME ty =>
@@ -240,33 +274,13 @@
                                    (Scheme.make (tyvars, ty)))
                             then ()
                          else (r := Never; change := true)
-                end
-             val _ = Vector.foreach (cons, fn {name, scheme} =>
-                                     Env.extendCon (E, name, scheme))
-             val _ = Env.allowDuplicates := true
-             val _ =
-                Env.extendTycon
-                (E, astTycon,
-                 TypeStr.data (tycon, Kind.Arity (Vector.length tyvars),
-                               Cons.T cons))
-          in
-             ()
-          end) 
-      (* We don't want to re-elaborate the datatypes if there has been a type
-       * error, because that will cause duplicate error messages.
-       *)
-     val numErrors = !Control.numErrors
-      (* Maximize equality. *)
-      fun loop (): unit =
-         let
-            val _ = elabAll ()
+                end)
          in
-            if !change andalso numErrors = !Control.numErrors
+            if !change
                then (change := false; loop ())
             else ()
          end
       val _ = loop ()
-      val _ = Env.allowDuplicates := false
    in
       ()
    end

Fix bug with type checking of datatype declarations with withtype bindings.

The type checking and elaboration of datatype declarations had been
implemented by repeatedly elaborating the withtype bindings (in the
scope of the datatype type constructors) followed by the datatype
bindings (constructors) until the equality status of the datatype
tycons stabilized.

This implementation, however, has a problem with the following:
  type u = real ;
  datatype t = A of v | B of u
  withtype u = int and v = u ;

This should elaborate as:
  type u = real;
  datatype t = A of real | B of int ;
  type u = int and v = real ;
where the tycon t does not have equality status.

It was mistakenly elaborating as:
  type u = real ;
  datatype t = A of int | B of int ;
  type u = int and v = int ;
where the tycon t does not have equality status.  This was due to the
fact that after the first round of elaboration, the tycon t changed
from having equality status to not having equality status.  This
triggered a second round of elaboration, but in an environment where
"type u = int and v = real".  Thus, in the second round of
elaboration, the withtype bindings elaborate to
"type u = int and v = int" and the constructors elaborate to
"A of int" and "B of int".  However, the monotonicity of equality
status changes meant that the tycon t remained as not having equality
status.

To implement proper type checking of datatype declarations with
withtype bindings, elaborate the bindings exactly once and make the
determination of equality status from a tycon application "lazy", and
therefore sensitive to the changes in the equality status of the
tycon.
----------------------------------------------------------------------

U   mlton/trunk/doc/changelog
U   mlton/trunk/mlton/elaborate/elaborate-core.fun
U   mlton/trunk/mlton/elaborate/elaborate-env.fun
U   mlton/trunk/mlton/elaborate/type-env.fun

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

Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog	2010-03-12 21:33:03 UTC (rev 7433)
+++ mlton/trunk/doc/changelog	2010-03-12 21:33:05 UTC (rev 7434)
@@ -62,6 +62,10 @@
     * Eliminated top-level 'type int = Int.int' in output.
     * Include (*#line line:col "file.grm" *) directives in output.
 
+* 2010-03-12
+  - Fixed bug in elaboration of datatype declarations with withtype
+    bindings.
+
 * 2009-12-11
   - Fixed performance bug in ref flatten SSA2 optimization.
 

Modified: mlton/trunk/mlton/elaborate/elaborate-core.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-core.fun	2010-03-12 21:33:03 UTC (rev 7433)
+++ mlton/trunk/mlton/elaborate/elaborate-core.fun	2010-03-12 21:33:05 UTC (rev 7434)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009-2010 Matthew Fluet.
  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -1662,85 +1662,84 @@
                     tycon = tycon,
                     tyvars = tyvars}
                 end)
-            val change = ref false
-            fun elabAll () =
-               (elabTypBind withtypes
-                ; (Vector.map
-                   (datatypes,
-                    fn {cons, makeCons, name, tycon, tyvars} =>
-                    let
-                       val resultType: Type.t =
-                          Type.con (tycon, Vector.map (tyvars, Type.var))
-                       val (schemes, datatypeCons) =
-                          Vector.unzip
-                          (Vector.map
-                           (cons, fn {arg, con, ...} =>
-                            let
-                               val (arg, ty) =
-                                  case arg of
-                                     NONE => (NONE, resultType)
-                                   | SOME t =>
-                                        let
-                                           val t = elabType t
-                                        in
-                                           (SOME t, Type.arrow (t, resultType))
-                                        end
-                               val scheme =
-                                  Scheme.make {canGeneralize = true,
-                                               ty = ty,
-                                               tyvars = tyvars}
-                            in
-                               (scheme, {arg = arg, con = con})
-                            end))
-                       val _ =
-                          let
-                             val r = TypeEnv.tyconAdmitsEquality tycon
-                             datatype z = datatype AdmitsEquality.t
-                          in
-                             case !r of
-                                Always => Error.bug "ElaborateCore.elaborateDec.elabDatBind: Always"
-                              | Never => ()
-                              | Sometimes =>
-                                   if Vector.forall
-                                      (datatypeCons, fn {arg, ...} =>
-                                       case arg of
-                                          NONE => true
-                                        | SOME ty =>
-                                             Scheme.admitsEquality
-                                             (Scheme.make {canGeneralize = true,
-                                                           ty = ty,
-                                                           tyvars = tyvars}))
-                                      then ()
-                                   else (r := Never; change := true)
-                          end
-                    val typeStr =
-                       TypeStr.data (tycon,
-                                     Kind.Arity (Vector.length tyvars),
-                                     makeCons schemes)
-                    val _ =
-                       Env.extendTycon (E, name, typeStr,
-                                        {forceUsed = false, isRebind = true})
-                 in
-                    ({cons = datatypeCons,
-                      tycon = tycon,
-                      tyvars = tyvars},
-                     {tycon = name,
-                      typeStr = typeStr})
-                 end)))
-            (* We don't want to re-elaborate the datatypes if there has been a
-             * type error, because that will cause duplicate error messages.
-             *)
-            val numErrors = !Control.numErrors
+            val _ = elabTypBind withtypes
+            val (dbs, strs) =
+               (Vector.unzip o Vector.map)
+               (datatypes,
+                fn {cons, makeCons, name, tycon, tyvars} =>
+                let
+                   val resultType: Type.t =
+                      Type.con (tycon, Vector.map (tyvars, Type.var))
+                   val (schemes, datatypeCons) =
+                      Vector.unzip
+                      (Vector.map
+                       (cons, fn {arg, con, ...} =>
+                        let
+                           val (arg, ty) =
+                              case arg of
+                                 NONE => (NONE, resultType)
+                               | SOME t =>
+                                    let
+                                       val t = elabType t
+                                    in
+                                       (SOME t, Type.arrow (t, resultType))
+                                    end
+                           val scheme =
+                              Scheme.make {canGeneralize = true,
+                                           ty = ty,
+                                           tyvars = tyvars}
+                        in
+                           (scheme, {arg = arg, con = con})
+                        end))
+                   val typeStr =
+                      TypeStr.data (tycon,
+                                    Kind.Arity (Vector.length tyvars),
+                                    makeCons schemes)
+                in
+                   ({cons = datatypeCons,
+                     tycon = tycon,
+                     tyvars = tyvars},
+                    {tycon = name,
+                     typeStr = typeStr})
+                end)
+            val _ =
+               Vector.map
+               (strs, fn {tycon, typeStr} =>
+                Env.extendTycon (E, tycon, typeStr,
+                                 {forceUsed = false, isRebind = true}))
             (* Maximize equality. *)
+            val change = ref false
             fun loop () =
                let
-                  val res = elabAll ()
+                  val _ =
+                     Vector.foreach
+                     (dbs, fn {cons, tycon, tyvars} =>
+                      let
+                         val r = TypeEnv.tyconAdmitsEquality tycon
+                         datatype z = datatype AdmitsEquality.t
+                      in
+                         case !r of
+                            Always => Error.bug "ElaborateCore.elaborateDec.elabDatBind: Always"
+                          | Never => ()
+                          | Sometimes =>
+                               if Vector.forall
+                                  (cons, fn {arg, con, ...} =>
+                                   case arg of
+                                      NONE => true
+                                    | SOME ty =>
+                                         Scheme.admitsEquality
+                                         (Scheme.make {canGeneralize = true,
+                                                       ty = ty,
+                                                       tyvars = tyvars}))
+                                  then ()
+                               else (r := Never; change := true)
+                      end)
                in
-                  if !change andalso numErrors = !Control.numErrors
+                  if !change
                      then (change := false; loop ())
-                  else res
+                  else ()
                end
-            val (dbs, strs) = Vector.unzip (loop ())
+            val _ = loop ()
          in
             (Decs.single (Cdec.Datatype dbs), strs)
          end

Modified: mlton/trunk/mlton/elaborate/elaborate-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/elaborate-env.fun	2010-03-12 21:33:03 UTC (rev 7433)
+++ mlton/trunk/mlton/elaborate/elaborate-env.fun	2010-03-12 21:33:05 UTC (rev 7434)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009-2010 Matthew Fluet.
  * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -2039,7 +2039,7 @@
                case uses of
                   New => newUses ()
                 | Old u => u
-                | Rebind => Error.bug "ElaborateEnv.extend.rebind.new"
+                | Rebind => Error.bug "ElaborateEnv.extend.rebind.new: Rebind"
          in
             {domain = domain,
              range = range,

Modified: mlton/trunk/mlton/elaborate/type-env.fun
===================================================================
--- mlton/trunk/mlton/elaborate/type-env.fun	2010-03-12 21:33:03 UTC (rev 7433)
+++ mlton/trunk/mlton/elaborate/type-env.fun	2010-03-12 21:33:05 UTC (rev 7434)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009-2010 Matthew Fluet.
  * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
@@ -146,6 +146,7 @@
        | Unknown of {whenKnown: (bool -> bool) list ref}
       datatype t =
          False
+       | Lazy of unit -> t
        | Maybe of maybe ref
        | True
 
@@ -154,6 +155,7 @@
       fun set (e: t, b: bool): bool =
          case e of
             False => b = false
+          | Lazy th => set (th (), b)
           | Maybe r =>
                (case !r of
                    Known b' => b = b'
@@ -164,6 +166,7 @@
       fun when (e: t, f: bool -> bool): bool =
          case e of
             False => f false
+          | Lazy th => when (th (), f)
           | Maybe r =>
                (case !r of
                    Known b => f b
@@ -180,6 +183,8 @@
           | (_, False) => False
           | (True, _) => e'
           | (_, True) => e
+          | (Lazy th, e') => Lazy (fn () => and2 (th (), e'))
+          | (e, Lazy th') => Lazy (fn () => and2 (e, th' ()))
           | (Maybe r, Maybe r') =>
                (case (!r, !r') of
                    (Known false, _) => False
@@ -220,6 +225,7 @@
       fun toBoolOpt (e: t): bool option =
          case e of
             False => SOME false
+          | Lazy th => toBoolOpt (th ())
           | Maybe r =>
                (case !r of
                    Known b => SOME b
@@ -235,7 +241,20 @@
          in
             case !(tyconAdmitsEquality c) of
                Always => truee
-             | Sometimes => andd es
+             | Sometimes =>
+                  let
+                     val e = andd es
+                  in
+                     case e of
+                        False => falsee
+                      | _ =>
+                           Lazy
+                           (fn () =>
+                            case !(tyconAdmitsEquality c) of
+                               Always => Error.bug "TypeEnv.Equality.applyTycon: Always"
+                             | Sometimes => e
+                             | Never => falsee)
+                  end
              | Never => falsee
          end
 
@@ -1589,6 +1608,10 @@
             Type.unknown {canGeneralize = canGeneralize,
                           equality = Equality.truee})))
 
+      val admitsEquality =
+         Trace.trace ("TypeEnv.Scheme.admitsEquality", layout, Bool.layout)
+         admitsEquality
+
       fun haveFrees (v: t vector): bool vector =
          let
             fun con (_, _, bs) = Vector.exists (bs, fn b => b)

Additional withtype regression tests.
----------------------------------------------------------------------

A   mlton/trunk/regression/withtype2.sml
A   mlton/trunk/regression/withtype3.sml
A   mlton/trunk/regression/withtype4.sml
A   mlton/trunk/regression/withtype5.sml

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

Added: mlton/trunk/regression/withtype2.sml
===================================================================
--- mlton/trunk/regression/withtype2.sml	2010-03-12 21:33:01 UTC (rev 7432)
+++ mlton/trunk/regression/withtype2.sml	2010-03-12 21:33:03 UTC (rev 7433)
@@ -0,0 +1,17 @@
+(* withtype2.sml *)
+
+(* Checks scoping rules of withtype *)
+
+type u = real
+
+datatype t = A of v | B of u
+withtype u = int
+and v = u
+
+val a = A 1.0
+val b = B 1
+
+val x : v = 1.0
+val y : u = 1
+
+fun uEq (a: u, b: u) = a = b

Added: mlton/trunk/regression/withtype3.sml
===================================================================
--- mlton/trunk/regression/withtype3.sml	2010-03-12 21:33:01 UTC (rev 7432)
+++ mlton/trunk/regression/withtype3.sml	2010-03-12 21:33:03 UTC (rev 7433)
@@ -0,0 +1,16 @@
+(* withtype3.sml *)
+
+(* Checks scoping rules of withtype *)
+
+type u = real
+
+datatype t = T of u * v
+withtype u = int
+and v = u
+
+val z = T (1, 1.0)
+
+val x : v = 1.0
+val y : u = 1
+
+fun uEq (a: u, b: u) = a = b

Added: mlton/trunk/regression/withtype4.sml
===================================================================
--- mlton/trunk/regression/withtype4.sml	2010-03-12 21:33:01 UTC (rev 7432)
+++ mlton/trunk/regression/withtype4.sml	2010-03-12 21:33:03 UTC (rev 7433)
@@ -0,0 +1,13 @@
+(* withtype4.sml *)
+
+(* Checks scoping rules of withtype *)
+
+type u = real
+
+datatype t = T of u * v
+withtype u = int
+and      v = u
+
+val x = T(1, 1.0);
+
+fun uEq (a: u, b: u) = a = b

Added: mlton/trunk/regression/withtype5.sml
===================================================================
--- mlton/trunk/regression/withtype5.sml	2010-03-12 21:33:01 UTC (rev 7432)
+++ mlton/trunk/regression/withtype5.sml	2010-03-12 21:33:03 UTC (rev 7433)
@@ -0,0 +1,17 @@
+(* withtype.sml *)
+
+(* Checks scoping rules of withtype *)
+
+type u = int
+
+datatype t = T of u * v
+withtype u = bool
+and      v = u
+
+val z = T(true, 6)
+val y : u = true
+val x : v = 1
+
+fun tEq (a: t, b: t) = a = b
+fun uEq (a: u, b: u) = a = b
+fun vEq (a: v, b: v) = a = b

Update copyright date in license.
----------------------------------------------------------------------

U   mlton/trunk/doc/license/MLton-LICENSE

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

Modified: mlton/trunk/doc/license/MLton-LICENSE
===================================================================
--- mlton/trunk/doc/license/MLton-LICENSE	2010-03-01 14:29:12 UTC (rev 7431)
+++ mlton/trunk/doc/license/MLton-LICENSE	2010-03-12 21:33:01 UTC (rev 7432)
@@ -4,7 +4,7 @@
 
 MLton COPYRIGHT NOTICE, LICENSE AND DISCLAIMER.
 
-Copyright (C) 1999-2009 Henry Cejtin, Matthew Fluet, Suresh
+Copyright (C) 1999-2010 Henry Cejtin, Matthew Fluet, Suresh
    Jagannathan, and Stephen Weeks.
 Copyright (C) 1997-2000 by the NEC Research Institute
 

Fix the type cast warnings.
Casting through void* is legitimate as it prevent alias analysis.


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

U   mlton/trunk/runtime/platform/mingw.c

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

Modified: mlton/trunk/runtime/platform/mingw.c
===================================================================
--- mlton/trunk/runtime/platform/mingw.c	2010-02-19 14:35:13 UTC (rev 7430)
+++ mlton/trunk/runtime/platform/mingw.c	2010-03-01 14:29:12 UTC (rev 7431)
@@ -774,8 +774,9 @@
         /* Call GetNativeSystemInfo if supported or GetSystemInfo otherwise. */
         SYSTEM_INFO si;
         void (WINAPI *pGNSI)(LPSYSTEM_INFO);
-        pGNSI = (PVOID) GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
-                                       "GetNativeSystemInfo");
+        pGNSI = (void(WINAPI *)(LPSYSTEM_INFO))
+                GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
+                               "GetNativeSystemInfo");
         if (NULL != pGNSI)
           pGNSI(&si);
         else
@@ -785,10 +786,10 @@
         osv.dwOSVersionInfoSize = sizeof (osv);
         /* Try to get extended information in order to be able to match the O.S. more
            precisely using osv.wProductType */
-        if (! GetVersionEx ((OSVERSIONINFO *) &osv)) {
+        if (! GetVersionEx ((OSVERSIONINFO *)(void*) &osv)) {
           ZeroMemory(&osv, sizeof(OSVERSIONINFOEX));
           osv.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
-          GetVersionEx((OSVERSIONINFO *) &osv);
+          GetVersionEx((OSVERSIONINFO *)(void*) &osv);
         }
         switch (osv.dwPlatformId) {
         case VER_PLATFORM_WIN32_NT: