[MLton-commit] r6311

Matthew Fluet fluet at mlton.org
Wed Jan 9 13:54:32 PST 2008


Extend MLton_equal to be a structural equality on all types, including
real and -> types.
For real types, the equality is bitwise equality.
For -> types, the equality is structural equality of the closures.  In
general, only closures arising from the same syntactic lambda will be
judged equal.

The equality is exported to the Basis Library as
  val MLton.equal : 'a * 'a -> bool.


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

U   mlton/trunk/basis-library/mlton/mlton.sig
U   mlton/trunk/basis-library/mlton/mlton.sml
U   mlton/trunk/basis-library/primitive/prim-mlton.sml
U   mlton/trunk/mlton/closure-convert/closure-convert.fun
U   mlton/trunk/mlton/ssa/poly-equal.fun

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

Modified: mlton/trunk/basis-library/mlton/mlton.sig
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sig	2008-01-09 21:50:01 UTC (rev 6310)
+++ mlton/trunk/basis-library/mlton/mlton.sig	2008-01-09 21:54:31 UTC (rev 6311)
@@ -15,6 +15,11 @@
        * semantics.
        *)
       val eq: 'a * 'a -> bool
+      (* Structural equality.  Equivalent to SML's polymorphic
+       * equality on equality types and a conservative approximation
+       * of equivalence other types.
+       *)
+      val equal: 'a * 'a -> bool
 (*      val errno: unit -> int *) (* the value of the C errno global *)
       val isMLton: bool
       val safe: bool

Modified: mlton/trunk/basis-library/mlton/mlton.sml
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sml	2008-01-09 21:50:01 UTC (rev 6310)
+++ mlton/trunk/basis-library/mlton/mlton.sml	2008-01-09 21:54:31 UTC (rev 6311)
@@ -30,7 +30,7 @@
    let
       val refOverhead =
          Int.div (HeaderWord.wordSize + ObjptrWord.wordSize, 8)
-   in 
+   in
       C_Size.toInt (Primitive.MLton.size (ref x)) - refOverhead
    end
 
@@ -38,6 +38,7 @@
 
 val debug = Primitive.Controls.debug
 val eq = Primitive.MLton.eq
+val equal = Primitive.MLton.equal
 (* 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	2008-01-09 21:50:01 UTC (rev 6310)
+++ mlton/trunk/basis-library/primitive/prim-mlton.sml	2008-01-09 21:54:31 UTC (rev 6311)
@@ -15,6 +15,7 @@
 structure MLton = struct
 
 val eq = _prim "MLton_eq": 'a * 'a -> bool;
+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 serialize = _prim "MLton_serialize": 'a ref -> Word8Vector.vector; *)

Modified: mlton/trunk/mlton/closure-convert/closure-convert.fun
===================================================================
--- mlton/trunk/mlton/closure-convert/closure-convert.fun	2008-01-09 21:50:01 UTC (rev 6310)
+++ mlton/trunk/mlton/closure-convert/closure-convert.fun	2008-01-09 21:54:31 UTC (rev 6311)
@@ -946,6 +946,23 @@
                                            else Dexp.falsee
                                       | _ => doit ()
                                   end
+                             | MLton_equal =>
+                                  let
+                                     val a0 = varExpInfo (arg 0)
+                                     val a1 = varExpInfo (arg 1)
+                                     fun doit () =
+                                        primApp (v1 (valueType (VarInfo.value a0)),
+                                                 v2 (convertVarInfo a0,
+                                                     convertVarInfo a1))
+                                  in
+                                     case (Value.dest (VarInfo.value a0),
+                                           Value.dest (VarInfo.value a1)) of
+                                        (Value.Lambdas l, Value.Lambdas l') =>
+                                           if Lambdas.equals (l, l')
+                                              then doit () 
+                                           else Dexp.falsee
+                                      | _ => doit ()
+                                  end
                              | MLton_handlesSignals =>
                                   if handlesSignals
                                      then Dexp.truee

Modified: mlton/trunk/mlton/ssa/poly-equal.fun
===================================================================
--- mlton/trunk/mlton/ssa/poly-equal.fun	2008-01-09 21:50:01 UTC (rev 6310)
+++ mlton/trunk/mlton/ssa/poly-equal.fun	2008-01-09 21:54:31 UTC (rev 6311)
@@ -31,10 +31,12 @@
  *  - For datatype tycons that are enumerations, do not build a case dispatch,
  *    just use eq, since you know the backend will represent these as ints.
  *  - Deep equality always does an eq test first.
- *  - If one argument to = is a constant int and the type will get translated
- *    to an IntOrPointer, then just use eq instead of the full equality.  This
- *    is important for implementing code like the following efficiently:
+ *  - If one argument to = is a constant and the type will get translated to
+ *    an IntOrPointer, then just use eq instead of the full equality.  This is
+ *    important for implementing code like the following efficiently:
  *       if x = 0  ...    (where x is an IntInf.int)
+ *
+ * Also convert pointer equality on scalar types to type specific primitives.
  *)
 
 open Exp Transfer
@@ -283,11 +285,12 @@
          let
             val dx1 = Dexp.var (x1, ty)
             val dx2 = Dexp.var (x2, ty)
-            fun prim (p, targs) =
+            fun primWithArgs (p, targs, dx1, dx2) =
                Dexp.primApp {prim = p,
                              targs = targs, 
                              args = Vector.new2 (dx1, dx2),
                              ty = Type.bool}
+            fun prim (p, targs) = primWithArgs (p, targs, dx1, dx2)
             fun eq () = prim (Prim.eq, Vector.new1 ty)
             fun hasConstArg () = #isConst (varInfo x1) orelse #isConst (varInfo x2)
          in
@@ -303,7 +306,21 @@
              | Type.IntInf => if hasConstArg ()
                                  then eq ()
                               else prim (Prim.intInfEqual, Vector.new0 ())
+             | Type.Real rs =>
+                  let
+                     val ws = WordSize.fromBits (RealSize.bits rs)
+                     fun toWord dx =
+                        Dexp.primApp
+                        {prim = Prim.realCastToWord (rs, ws),
+                         targs = Vector.new0 (),
+                         args = Vector.new1 dx,
+                         ty = Type.word ws}
+                  in
+                     primWithArgs (Prim.wordEqual ws, Vector.new0 (),
+                                   toWord dx1, toWord dx2)
+                  end
              | Type.Ref _ => eq ()
+             | Type.Thread => eq ()
              | Type.Tuple tys =>
                   let
                      val max = Vector.length tys - 1
@@ -329,8 +346,8 @@
                   Dexp.call {func = vectorEqualFunc ty,
                              args = Vector.new2 (dx1, dx2),
                              ty = Type.bool}
-             | Type.Word s => prim (Prim.wordEqual s, Vector.new0 ())
-             | _ => Error.bug "PolyEqual.equal: strange type"
+             | Type.Weak _ => eq ()
+             | Type.Word ws => prim (Prim.wordEqual ws, Vector.new0 ())
          end
       fun loopBind (Statement.T {exp, var, ...}) =
          let
@@ -377,11 +394,77 @@
                                           {label = label,
                                            args = args,
                                            statements = stmt::statements})
+                         fun adds ss = (blocks,
+                                        {label = label,
+                                         args = args,
+                                         statements = ss @ statements})
                        in
                          case exp of
                             PrimApp {prim, targs, args, ...} =>
                                (case (Prim.name prim, Vector.length targs) of
-                                   (Prim.Name.MLton_equal, 1) =>
+                                   (Prim.Name.MLton_eq, 1) =>
+                                      (case Type.dest (Vector.sub (targs, 0)) of
+                                          Type.CPointer => 
+                                             let
+                                                val cp0 = Vector.sub (args, 0)
+                                                val cp1 = Vector.sub (args, 1)
+                                                val cpointerEqStmt =
+                                                   Statement.T
+                                                   {var = var,
+                                                    ty = Type.bool,
+                                                    exp = Exp.PrimApp
+                                                          {prim = Prim.cpointerEqual,
+                                                           targs = Vector.new0 (),
+                                                           args = Vector.new2 (cp0,cp1)}}
+                                             in
+                                                adds [cpointerEqStmt]
+                                             end
+                                        | Type.Real rs =>
+                                             let
+                                                val ws = WordSize.fromBits (RealSize.bits rs)
+                                                val wt = Type.word ws
+                                                val r0 = Vector.sub (args, 0)
+                                                val r1 = Vector.sub (args, 1)
+                                                val w0 = Var.newNoname ()
+                                                val w1 = Var.newNoname ()
+                                                fun realCastToWordStmt (r, w) =
+                                                   Statement.T
+                                                   {var = SOME w,
+                                                    ty = wt,
+                                                    exp = Exp.PrimApp
+                                                          {prim = Prim.realCastToWord (rs, ws),
+                                                           targs = Vector.new0 (),
+                                                           args = Vector.new1 r}}
+                                                val wordEqStmt =
+                                                   Statement.T
+                                                   {var = var,
+                                                    ty = Type.bool,
+                                                    exp = Exp.PrimApp
+                                                          {prim = Prim.wordEqual ws,
+                                                           targs = Vector.new0 (),
+                                                           args = Vector.new2 (w0,w1)}}
+                                             in
+                                                adds [wordEqStmt, 
+                                                      realCastToWordStmt (r1, w1),
+                                                      realCastToWordStmt (r0, w0)]
+                                             end
+                                        | Type.Word ws =>
+                                             let
+                                                val w0 = Vector.sub (args, 0)
+                                                val w1 = Vector.sub (args, 1)
+                                                val wordEqStmt =
+                                                   Statement.T
+                                                   {var = var,
+                                                    ty = Type.bool,
+                                                    exp = Exp.PrimApp
+                                                          {prim = Prim.wordEqual ws,
+                                                           targs = Vector.new0 (),
+                                                           args = Vector.new2 (w0,w1)}}
+                                             in
+                                                adds [wordEqStmt]
+                                             end
+                                        | _ => normal ())
+                                 | (Prim.Name.MLton_equal, 1) =>
                                       let
                                          val ty = Vector.sub (targs, 0)
                                          fun arg i = Vector.sub (args, i)




More information about the MLton-commit mailing list