[MLton-commit] r4383
Stephen Weeks
MLton@mlton.org
Tue, 28 Mar 2006 14:58:07 -0800
Eliminated vestigial usesCallcc stuff.
----------------------------------------------------------------------
U mlton/trunk/basis-library/arrays-and-vectors/array2.sml
U mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
U mlton/trunk/basis-library/misc/primitive.sml
U mlton/trunk/basis-library/mlton/cont.sml
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/arrays-and-vectors/array2.sml
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/array2.sml 2006-03-28 22:00:23 UTC (rev 4382)
+++ mlton/trunk/basis-library/arrays-and-vectors/array2.sml 2006-03-28 22:58:06 UTC (rev 4383)
@@ -142,72 +142,12 @@
fun modify trv f a = modifyi trv (f o #3) (wholeRegion a)
fun tabulate trv (rows, cols, f) =
- if !Primitive.usesCallcc
- then
- (* All this mess is careful to construct a list representing
- * the array and then convert the list to the array after all
- * the calls to f have been made, in case f uses callcc.
- *)
- let
- val size =
- if Primitive.safe andalso (rows < 0 orelse cols < 0)
- then raise Size
- else rows * cols handle Overflow => raise Size
- val (rows', cols', f) =
- case trv of
- RowMajor => (rows, cols, f)
- | ColMajor => (cols, rows, fn (c, r) => f (r, c))
- fun loopr (r, l) =
- if r >= rows'
- then l
- else
- let
- fun loopc (c, l) =
- if c >= cols'
- then l
- else loopc (c + 1, f (r, c) :: l)
- in loopr (r + 1, loopc (0, l))
- end
- val l = loopr (0, [])
- val a = Primitive.Array.array size
- in case trv of
- RowMajor =>
- (* The list holds the elements in row major order,
- * but reversed.
- *)
- let
- val _ =
- List.foldl (fn (x, i) =>
- (Primitive.Array.update (a, i, x)
- ; i -? 1))
- (size -? 1) l
- in
- ()
- end
- | ColMajor =>
- (* The list holds the elements in column major order,
- * but reversed.
- *)
- let
- val _ =
- List.foldl (fn (x, (spot, r)) =>
- (Primitive.Array.update (a, spot, x)
- ; if r = 0
- then (spot -? 1 +? size -? cols,
- rows -? 1)
- else (spot -? cols, r -? 1)))
- (size -? 1, rows -? 1)
- l
- in
- ()
- end
- ; {rows = rows, cols = cols, array = a}
- end
- else
- let val a = arrayUninit (rows, cols)
- in modifyi trv (fn (r, c, _) => f (r, c)) (wholeRegion a)
- ; a
- end
+ let
+ val a = arrayUninit (rows, cols)
+ val () = modifyi trv (fn (r, c, _) => f (r, c)) (wholeRegion a)
+ in
+ a
+ end
fun copy {src = src as {base, row, col, ...}: 'a region,
dst, dst_row, dst_col} =
Modified: mlton/trunk/basis-library/arrays-and-vectors/sequence.fun
===================================================================
--- mlton/trunk/basis-library/arrays-and-vectors/sequence.fun 2006-03-28 22:00:23 UTC (rev 4382)
+++ mlton/trunk/basis-library/arrays-and-vectors/sequence.fun 2006-03-28 22:58:06 UTC (rev 4383)
@@ -32,6 +32,9 @@
fun seq0 () = fromArray (array 0)
+ (* unfoldi depends on the fact that the runtime system fills in the array
+ * with reasonable bogus values.
+ *)
fun unfoldi (n, b, f) =
let
val a = array n
@@ -45,42 +48,12 @@
in
loop (i +? 1, b')
end
- val _ = loop (0, b)
+ val () = loop (0, b)
in
fromArray a
end
- (* Tabulate depends on the fact that the runtime system fills in the array
- * with reasonable bogus values.
- *)
- fun tabulate (n, f) =
-(*
- if !Primitive.usesCallcc
- then
- (* This code is careful to use a list to accumulate the
- * components of the array in case f uses callcc.
- *)
- let
- fun loop (i, l) =
- if i >= n
- then l
- else loop (i + 1, f i :: l)
- val l = loop (0, [])
- val a = array n
- fun loop (l, i) =
- case l of
- [] => ()
- | x :: l =>
- let val i = i -? 1
- in Array.update (a, i, x)
- ; loop (l, i)
- end
- in loop (l, n)
- ; fromArray a
- end
- else
-*)
- unfoldi (n, (), fn (i, ()) => (f i, ()))
+ fun tabulate (n, f) = unfoldi (n, (), fn (i, ()) => (f i, ()))
fun new (n, x) = tabulate (n, fn _ => x)
Modified: mlton/trunk/basis-library/misc/primitive.sml
===================================================================
--- mlton/trunk/basis-library/misc/primitive.sml 2006-03-28 22:00:23 UTC (rev 4382)
+++ mlton/trunk/basis-library/misc/primitive.sml 2006-03-28 22:58:06 UTC (rev 4383)
@@ -215,7 +215,6 @@
_prim "MLton_installSignalHandler": unit -> unit;
val safe = _command_line_const "MLton.safe": bool = true;
val touch = _prim "MLton_touch": 'a -> unit;
- val usesCallcc: bool ref = ref false;
structure Stdio =
struct
@@ -1293,7 +1292,16 @@
struct
open Real64
- structure Class =
+ structure Class:>
+ sig
+ eqtype t
+
+ val inf: t
+ val nan: t
+ val normal: t
+ val subnormal: t
+ val zero: t
+ end =
struct
type t = int
@@ -1338,7 +1346,7 @@
val == = _prim "Real64_equal": real * real -> bool;
val ?= = _prim "Real64_qequal": real * real -> bool;
val abs = _prim "Real64_abs": real -> real;
- val class = _import "Real64_class": real -> int;
+ val class = _import "Real64_class": real -> Class.t;
val frexp = _import "Real64_frexp": real * int ref -> real;
val gdtoa =
_import "Real64_gdtoa": real * int * int * int ref -> CString.t;
@@ -1412,7 +1420,7 @@
val == = _prim "Real32_equal": real * real -> bool;
val ?= = _prim "Real32_qequal": real * real -> bool;
val abs = _prim "Real32_abs": real -> real;
- val class = _import "Real32_class": real -> int;
+ val class = _import "Real32_class": real -> Real64.Class.t;
fun frexp (r: real, ir: int ref): real =
fromLarge (Real64.frexp (toLarge r, ir))
val gdtoa =
Modified: mlton/trunk/basis-library/mlton/cont.sml
===================================================================
--- mlton/trunk/basis-library/mlton/cont.sml 2006-03-28 22:00:23 UTC (rev 4382)
+++ mlton/trunk/basis-library/mlton/cont.sml 2006-03-28 22:58:06 UTC (rev 4383)
@@ -11,54 +11,44 @@
structure Thread = Primitive.Thread
-(* This mess with dummy is so that if callcc is ever used anywhere in the
- * program, then Primitive.usesCallcc is set to true during basis library
- * evaluation. This relies on the dead code elimination algorithm
- * (core-ml/dead-code.fun), which will keep dummy around only if callcc is used.
- *)
-val dummy =
- (Primitive.usesCallcc := true
- ; fn () => ())
-
type 'a t = (unit -> 'a) -> unit
fun callcc (f: 'a t -> 'a): 'a =
- (dummy ()
- ; if MLtonThread.amInSignalHandler ()
- then die "callcc can not be used in a signal handler\n"
- else
- let
- datatype 'a state =
- Original of 'a t -> 'a
- | Copy of unit -> 'a
- | Clear
- val r: 'a state ref = ref (Original f)
- val _ = Thread.atomicBegin () (* Match 1 *)
- val _ = Thread.copyCurrent ()
- in
- case (!r before r := Clear) of
- Clear => raise Fail "callcc saw Clear"
- | Copy v => (Thread.atomicEnd () (* Match 2 *)
- ; v ())
- | Original f =>
- let
- val t = Thread.savedPre ()
- in
- Thread.atomicEnd () (* Match 1 *)
- ; f (fn v =>
- let
- val _ = Thread.atomicBegin () (* Match 2 *)
- val _ = r := Copy v
- val new = Thread.copy t
- (* The following Thread.atomicBegin ()
- * is matched by Thread.switchTo.
- *)
- val _ = Thread.atomicBegin ()
- in
- Thread.switchTo new
- end)
- end
- end)
+ if MLtonThread.amInSignalHandler () then
+ die "callcc can not be used in a signal handler\n"
+ else
+ let
+ datatype 'a state =
+ Original of 'a t -> 'a
+ | Copy of unit -> 'a
+ | Clear
+ val r: 'a state ref = ref (Original f)
+ val _ = Thread.atomicBegin () (* Match 1 *)
+ val _ = Thread.copyCurrent ()
+ in
+ case (!r before r := Clear) of
+ Clear => raise Fail "callcc saw Clear"
+ | Copy v => (Thread.atomicEnd () (* Match 2 *)
+ ; v ())
+ | Original f =>
+ let
+ val t = Thread.savedPre ()
+ in
+ Thread.atomicEnd () (* Match 1 *)
+ ; f (fn v =>
+ let
+ val _ = Thread.atomicBegin () (* Match 2 *)
+ val _ = r := Copy v
+ val new = Thread.copy t
+ (* The following Thread.atomicBegin ()
+ * is matched by Thread.switchTo.
+ *)
+ val _ = Thread.atomicBegin ()
+ in
+ Thread.switchTo new
+ end)
+ end
+ end
fun ('a, 'b) throw' (k: 'a t, v: unit -> 'a): 'b =
(k v; raise Fail "throw bug")