[MLton] Bug in optimizations related to ref cells?

[Vesa Karvonen]

The below code passes the MLton typechecker (-stop tc), but fails in a later
optimization pass. Both SML/NJ (110.42) and Hamlet (1.2) appear to evaluate
the code correctly. (The code is part of *unfinished* conversion of SRFI-45
(http://srfi.schemers.org/srfi-45/) to Standard ML.)


$ cat bug-ref-mlton.sml

datatype ('a, 'b) either = LEFT of 'a | RIGHT of 'b

fun eval thunk =
    LEFT (thunk ()) handle e => RIGHT e

datatype 'a status = LAZY of unit -> 'a promise
                   | EAGER of ('a, exn) either
withtype 'a promise = 'a status ref ref

fun lazy exp =
    ref (ref (LAZY exp))

fun delay exp =
    lazy (fn () => ref (ref (EAGER (eval exp))))

fun force promise =
    case !(!promise)
     of EAGER (LEFT x) => x
      | EAGER (RIGHT x) => raise x
      | LAZY exp =>
        let
          val promise' = exp ()
        in
          (case !(!promise)
            of LAZY _ => (!promise := !(!promise') ;
                          promise' := !promise)
             | _ => ())
        ; force promise
        end

exception Assertion

fun check (b, e) = if b then () else raise e
fun verify b = check (b, Assertion)

val () =
    let
      val r = delay (fn () => (print "hi" ; 1))
      val s = lazy (fn () => r)
      val t = lazy (fn () => s)
    in
      verify (1 = force t)
    ; verify (1 = force r)
    end



$ mlton
MLton MLTONVERSION (built Sat Jul 16 16:50:43 2005 on grape)
$ mlton bug-ref-mlton.sml
Type error: SSa2.TypeCheck2.coerce
{from = (status_0 ref), to = status_0}
Type error: analyze raised exception unhandled exception: TypeError

unhandled exception: TypeError



$ mlton
MLton 20041109 (built Tue Nov 09 23:59:39 2004 on debian30)
$ mlton bug-ref-mlton.sml
Type error: TypeCheck.coerce
{from = (status_0 ref), to = status_0}
Type error: analyze raised exception force_0: loopStatement: promise'_0 := x_0:

unhandled exception: TypeError



Standard ML of New Jersey v110.42 [FLINT v1.5], October 16, 2002
- use "bug-ref-mlton.sml";
[opening bug-ref-mlton.sml]
hidatatype ('a,'b) either = LEFT of 'a | RIGHT of 'b
val eval = fn : (unit -> 'a) -> ('a,exn) either
datatype 'a status
  = EAGER of ('a,exn) either | LAZY of unit -> 'a status ref ref
type 'a promise = 'a status ref ref
val lazy = fn : (unit -> 'a promise) -> 'a status ref ref
val delay = fn : (unit -> 'a) -> 'a status ref ref
val force = fn : 'a status ref ref -> 'a
exception Assertion
val check = fn : bool * exn -> unit
val verify = fn : bool -> unit
val it = () : unit



HaMLet 1.2 - To Be Or Not To Be Standard ML
[loading standard basis library]
- use "bug-ref-mlton.sml";
val it = () : unit
[processing /home/vk/work/sml/articles/bug-ref-mlton.sml]
hitype 'a promise = 'a status ref ref
datatype ('a, 'b) either = LEFT of 'a | RIGHT of 'b
datatype 'a status =
  EAGER of ('a, exn) either | LAZY of unit -> 'a status ref ref
exception Assertion
val check = <fn> : bool * exn -> unit
val delay = <fn> : (unit -> 'a) -> 'a status ref ref
val eval = <fn> : (unit -> 'a) -> ('a, exn) either
val force = <fn> : 'a status ref ref -> 'a
val lazy = <fn> : (unit -> 'a status ref ref) -> 'a status ref ref
val verify = <fn> : bool -> unit