[MLton] Bug in defunctorize(?)

[Matthew Fluet]

On Wed, 19 Sep 2007, Vesa Karvonen wrote:
> Running the
>
>  ./Test.sh
>
> script in the mltonlib (rev 6035) directory
>
>  com/ssh/generic/unstable
>
> produces the following output:
>
> [snipped]
> + mlton -mlb-path-map generated/mlb-path-map -prefer-abs-paths true
> -show-def-use generated/test.du -output generated/test -const
> 'Exn.keepHistory true' -type-check true -verbose 2 test.mlb
> MLton starting
> MLton MLTONVERSION (built Mon Sep 17 20:44:45 2007 on grape)
>  created this file on Wed Sep 19 16:03:22 2007.
> Do not edit this file.
> Flag settings:
>   [snipped]
>   Compile SML starting
>      pre codegen starting
>         parseAndElaborate starting
>         parseAndElaborate finished in 7.32 + 4.82 (40% GC)
>         deadCode starting
>         deadCode finished in 0.08 + 0.00 (0% GC)
>         defunctorize starting
>         defunctorize finished in 1.40 + 0.97 (41% GC)
>         typeCheck starting
>            typeCheck starting
[snipped]
>            typeCheck raised in 0.53 + 1.04 (66% GC)
>         typeCheck raised in 0.53 + 1.04 (66% GC)
>      pre codegen raised in 11.98 + 6.83 (36% GC)
>   Compile SML raised in 11.98 + 6.83 (36% GC)
> MLton raised in 11.98 + 6.83 (36% GC)
> unhandled exception: TypeError

I've checked in an apparent fix; the 'TypeError' exception is no longer 
raised.  However, I wasn't able to cut the code down to a smaller 
test case, and I don't quite fully understand what is going wrong.

Here's what I did discover:
* Replacing the opaque signature match in detail/generic.sml with a
   transparent signature match makes the 'TypeError' exception go away.
* Leaving the opaque signature match in detail/generic.sml and adding
   'val mapPrinterZZZ = Generic.Pretty.mapPrinter' to the end of
   detail/generic.sml causes the 'TypeError' exception, but the XML IL
   fragment makes it clear that the error is due to the
   'val mapPrinterZZZ = ...' binding.

* Replacing the opaque signature match with a transparent signature match
   and adding
     val mapPrinterZZZ : 'a Generic.Pretty.t UnOp.t -> ('a, 'x) Generic.PrettyRep.t UnOp.t = Generic.Pretty.mapPrinter'
   makes the 'TypeError' exception go away.  However, if one looks at the
   .core-ml at the end of the parseAndElaborate pass,  we see this:

 	  val ('x, 'a) mapPrinterZZZ: ...[really big type]... =
 	     mapPrinter_0 ('a WithArbitrary.t
 			   * ((unit -> 'a) * ('a WithPickle.t * 'x)),
 			   'a)

   That's kind of odd.  We're rebinding 'Generic.Pretty.mapPrinter' to its
   type declared in the signature of 'Generic'.  There is no reason to
   re-generalize at a different type; we should just have the equivalent of
   a type-level eta-expansion.

That seemed to suggest that there was something amiss with transparent 
signature matching.  In particular, that a polymorphic value matched 
against a more specific instance wasn't being properly rebound to a new 
instantiation.

That led to the following change to the 
<src>/mlton/elaborate/elaborate-env.fun:transparentCut function:

       fun cut (S, I, strids): Structure.t =
          let
             val seen = get S
          in
             case List.peek (!seen, fn (I', _) => Interface.equals (I, I')) of
                NONE =>
                   let
                      fun really () = reallyCut (S, I, strids)
                      val S =
                         case Structure.interface S of
                            NONE => really ()
                          | SOME I' =>
+                             if Interface.equals (I, I')
+                                then S
+                             else really ()
-                             let
-                                val origI = Interface.original I
-                                val origI' = Interface.original I'
-                             in
-                                if Interface.equals (origI, origI')
-                                   then (checkMatch
-                                         (Interface.flexibleTycons origI,
-                                          S, I, strids)
-                                         ; S)
-                                else really ()
-                             end
                      val _ = List.push (seen, (I, S))
                   in
                      S
                   end
              | SOME (_, S) => S
          end
       and reallyCut (S, I, strids) =

As I understand it, the check for equivalence between the principal 
signature of the structure and the signature being matched is an 
optimization to avoid doing the coercive rebinding (affected by 
'reallyCut').  However, I don't understand what an 'original' interface 
is, and why the equivalence of original interfaces implies the equivalence 
of the actual interfaces.

The conditions under which two 'original' signatures are judged equal when 
the they should not be must be fairly subtle; Vesa's been working on the 
generic code for a while, and it seems that even small modifications to 
the source code leave things in such a way that this bug isn't triggered.