mlton-commit Mailing List for MLton

Make Real*.toManExp, split and gdtoa thread (and signal) safe using the
One structure.


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

U   mlton/trunk/basis-library/real/real.fun

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

Modified: mlton/trunk/basis-library/real/real.fun
===================================================================
--- mlton/trunk/basis-library/real/real.fun	2006-08-08 02:49:11 UTC (rev 4691)
+++ mlton/trunk/basis-library/real/real.fun	2006-08-25 16:16:45 UTC (rev 4692)
@@ -88,7 +88,7 @@
                 | SOME (_, c) => c
             end
       end
-   
+
       val abs =
          if MLton.Codegen.isNative
             then abs
@@ -98,7 +98,7 @@
                INF => posInf
              | NAN => x
              | _ => if signBit x then ~x else x
-         
+
       fun isFinite r =
          case class r of
             INF => false
@@ -175,7 +175,7 @@
              | I.LESS => G.LESS
              | I.UNORDERED => raise IEEEReal.Unordered
       end
-   
+
       fun unordered (x, y) = isNan x orelse isNan y
 
       val nextAfter: real * real -> real =
@@ -202,22 +202,23 @@
                         then doit (r, t)
                      else ~ (doit (~r, ~t))
                   end
-                         
+
       val toManExp =
          let
-            val r: int ref = ref 0
+            val one = One.make (fn () => ref 0)
          in
             fn x =>
             case class x of
                INF => {exp = 0, man = x}
              | NAN => {exp = 0, man = nan}
              | ZERO => {exp = 0, man = x}
-             | _ => 
-                  let
-                     val man = Prim.frexp (x, r)
-                  in
-                     {exp = !r, man = man}
-                  end
+             | _ =>
+                  One.use (one, fn r =>
+                     let
+                        val man = Prim.frexp (x, r)
+                     in
+                        {exp = !r, man = man}
+                     end)
          end
 
       fun fromManExp {exp, man} = Prim.ldexp (man, exp)
@@ -234,17 +235,17 @@
              | _ => fromManExp {exp = exp, man = man}
 
       local
-         val int = ref zero
+         val one = One.make (fn () => ref zero)
       in
          fun split x =
             case class x of
                INF => {frac = if x > zero then zero else ~zero,
                        whole = x}
              | NAN => {frac = nan, whole = nan}
-             | _ => 
+             | _ =>
                   let
-                     val frac = Prim.modf (x, int)
-                     val whole = !int
+                     val (frac, whole) = One.use (one, fn int =>
+                                            (Prim.modf (x, int), ! int))
                      (* Some platforms' C libraries don't get sign of zero right.
                       *)
                      fun fix y =
@@ -259,7 +260,7 @@
       end
 
       val realMod = #frac o split
-         
+
       fun checkFloat x =
          case class x of
             INF => raise Overflow
@@ -274,7 +275,7 @@
          TO_NEAREST
          (IEEEReal.withRoundingMode (m, fn () =>
                                      (Primitive.Real64.round (toLarge x))))
-         
+
       fun toInt mode x =
          case class x of
             INF => raise Overflow
@@ -305,7 +306,7 @@
                                       then raise Overflow
                                    else Int.minInt')
                     else raise Overflow
-      
+
       val floor = toInt TO_NEGINF
       val ceil = toInt TO_POSINF
       val trunc = toInt TO_ZERO
@@ -391,7 +392,7 @@
       (* toDecimal, fmt, toString: binary -> decimal conversions. *)
       datatype mode = Fix | Gen | Sci
       local
-         val decpt: int ref = ref 0
+         val one = One.make (fn () => ref 0)
       in
          fun gdtoa (x: real, mode: mode, ndig: int) =
             let
@@ -400,12 +401,12 @@
                      Fix => 3
                    | Gen => 0
                    | Sci => 2
-               val cs = Prim.gdtoa (x, mode, ndig, decpt)
             in
-               (cs, !decpt)
+               One.use (one, fn decpt =>
+                  (Prim.gdtoa (x, mode, ndig, decpt), !decpt))
             end
       end
-   
+
       fun toDecimal (x: real): IEEEReal.decimal_approx =
          case class x of
             INF => {class = INF,
@@ -420,7 +421,7 @@
                      digits = [],
                      exp = 0,
                      sign = signBit x}
-          | c => 
+          | c =>
                let
                   val (cs, exp) = gdtoa (x, Gen, 0)
                   fun loop (i, ac) =
@@ -441,7 +442,7 @@
       datatype realfmt = datatype StringCvt.realfmt
 
       fun add1 n = Int.+ (n, 1)
-         
+
       local
          fun fix (sign: string, cs: C.CS.t, decpt: int, ndig: int): string =
             let
@@ -457,7 +458,7 @@
                                                 decpt),
                                          #"0")]
                else
-                  let 
+                  let
                      val whole =
                         if decpt = 0
                            then "0"
@@ -522,7 +523,7 @@
             case class x of
                INF => if x > zero then "inf" else "~inf"
              | NAN => "nan"
-             | _ => 
+             | _ =>
                   let
                      val (prefix, x) =
                         if x < zero
@@ -618,7 +619,7 @@
                 | _ => doit x
             end
       end
-   
+
       val toString = fmt (StringCvt.GEN NONE)
 
       val fromLargeInt: LargeInt.int -> real =
@@ -633,9 +634,9 @@
                val x = Prim.strto (NullString.fromString
                                    (concat [LargeInt.toString i, "\000"]))
             in
-               if sign then ~ x else x             
+               if sign then ~ x else x
             end
-         
+
       val toLargeInt: IEEEReal.rounding_mode -> real -> LargeInt.int =
          fn mode => fn x =>
          case class x of
@@ -651,14 +652,14 @@
                in
                   case class x of
                      INF => raise Overflow
-                   | _ => 
+                   | _ =>
                         if minInt <= x andalso x <= maxInt
                            then LargeInt.fromInt (Prim.toInt x)
                         else
                            valOf
                            (LargeInt.fromString (fmt (StringCvt.FIX (SOME 0)) x))
                end
-         
+
       structure Math =
          struct
             open Prim.Math
@@ -666,7 +667,7 @@
             (* Patch functions to handle out-of-range args.  Many C math
              * libraries do not do what the SML Basis Spec requires.
              *)
-               
+
             local
                fun patch f x =
                   if x < ~one orelse x > one
@@ -761,13 +762,13 @@
                   INF => x
                 | ZERO => one
                 | _ => R.Math.cosh x
-                     
+
             fun sinh x =
                case class x of
                   INF => x
                 | ZERO => x
                 | _ => R.Math.sinh x
-                     
+
             fun tanh x =
                case class x of
                   INF => if x > zero then one else negOne

Simplified "profile" target.

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

U   mlton/branches/on-20050822-x86_64-branch/Makefile

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

Modified: mlton/branches/on-20050822-x86_64-branch/Makefile
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/Makefile	2006-08-04 05:48:22 UTC (rev 4690)
+++ mlton/branches/on-20050822-x86_64-branch/Makefile	2006-08-08 02:49:11 UTC (rev 4691)
@@ -244,21 +244,17 @@
 
 .PHONY: profiled
 profiled:
-	$(MAKE) -C "$(COMP)" "AOUT=$(AOUT).alloc" COMPILE_ARGS="-profile alloc"
-	$(CP) "$(COMP)/$(AOUT).alloc" "$(LIB)/"
-	$(MAKE) -C "$(COMP)" "AOUT=$(AOUT).count" COMPILE_ARGS="-profile count"
-	$(CP) "$(COMP)/$(AOUT).count" "$(LIB)/"
-	$(MAKE) -C "$(COMP)" "AOUT=$(AOUT).time" COMPILE_ARGS="-profile time"
-	$(CP) "$(COMP)/$(AOUT).time" "$(LIB)/"
-	"$(LIB)/$(AOUT).alloc" @MLton -- "$(LIB)/world.alloc"
-	"$(LIB)/$(AOUT).count" @MLton -- "$(LIB)/world.count"
-	"$(LIB)/$(AOUT).time" @MLton -- "$(LIB)/world.time"
-	sed 's/mlton-compile/mlton-compile.alloc/' < "$(MLTON)" | sed 's/world.mlton/world.alloc.mlton/' > "$(MLTON).alloc"
-	sed 's/mlton-compile/mlton-compile.count/' < "$(MLTON)" | sed 's/world.mlton/world.count.mlton/' > "$(MLTON).count"
-	sed 's/mlton-compile/mlton-compile.time/' < "$(MLTON)" | sed 's/world.mlton/world.time.mlton/' > "$(MLTON).time"
-	chmod a+x "$(MLTON).alloc"
-	chmod a+x "$(MLTON).count"
-	chmod a+x "$(MLTON).time"
+	for t in alloc count time; do 					\
+ 		$(MAKE) -C "$(COMP)" "AOUT=$(AOUT).$$t" 		\
+			COMPILE_ARGS="-profile $$t";			\
+		$(CP) "$(COMP)/$(AOUT).$$t" "$(LIB)/";			\
+		"$(LIB)/$(AOUT).$$t" @MLton -- "$(LIB)/world.$$t";	\
+		sed "s/mlton-compile/mlton-compile.$$t/" 		\
+			<"$(MLTON)" | 					\
+			sed "s/world.mlton/world.$$t.mlton/" 		\
+			>"$(MLTON).$$t";				\
+		chmod a+x "$(MLTON).$$t";				\
+	done
 
 TOPDIR = 'TOPDIR-unset'
 SOURCEDIR = $(TOPDIR)/SOURCES/mlton-$(VERSION)

Fixed bug in the "useless" SSA optimization pass, caused by calling an
imported C function and then ignoring the result.  The useless pass
eliminated the result, which changed the return type of the call, and
led to a type error.  The fix was simply to force FFI arguments and
results to be useful.


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

U   mlton/trunk/doc/changelog
U   mlton/trunk/mlton/ssa/useless.fun

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

Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog	2006-07-19 02:50:56 UTC (rev 4689)
+++ mlton/trunk/doc/changelog	2006-08-04 05:48:22 UTC (rev 4690)
@@ -1,5 +1,9 @@
 Here are the changes since version 20051202.
 
+* 2006-08-03
+   - Fixed a bug in the "useless" SSA optimization, caused by calling
+     an imported C function and then ignoring the result.
+
 * 2006-06-24
    - Fixed a bug in pass to flatten data structures.  Thanks to Joe Hurd
      for the bug report.

Modified: mlton/trunk/mlton/ssa/useless.fun
===================================================================
--- mlton/trunk/mlton/ssa/useless.fun	2006-07-19 02:50:56 UTC (rev 4689)
+++ mlton/trunk/mlton/ssa/useless.fun	2006-08-04 05:48:22 UTC (rev 4690)
@@ -520,6 +520,9 @@
                                (unify (l, l'); unifySlot (e, e'))
                            | _ => Error.bug "Useless.primApp: Array_toVector")
                    | Array_update => update ()
+                   | FFI _ =>
+                        (Vector.foreach (args, deepMakeUseful);
+                         deepMakeUseful result)
                    | MLton_equal => Vector.foreach (args, deepMakeUseful)
                    | Ref_assign => coerce {from = arg 1, to = deref (arg 0)}
                    | Ref_deref => return (deref (arg 0))