[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