[MLton-commit] r4429
Matthew Fluet
MLton@mlton.org
Sun, 30 Apr 2006 14:32:16 -0700
Refactoring MLton (partial)
----------------------------------------------------------------------
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/call-stack.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/exit.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/exn.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/gc.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/pointer.sig
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/pointer.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/process.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/rusage.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/signal.sml
U mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/thread.sml
----------------------------------------------------------------------
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/build/sources.mlb 2006-04-30 21:32:15 UTC (rev 4429)
@@ -262,22 +262,22 @@
../general/sml90.sml
../mlton/pointer.sig
- (* ../mlton/pointer.sml *)
- (* ../mlton/call-stack.sig *)
- (* ../mlton/call-stack.sml *)
- (* ../mlton/exit.sml *)
- (* ../mlton/exn.sig *)
- (* ../mlton/exn.sml *)
- (* ../mlton/thread.sig *)
- (* ../mlton/thread.sml *)
- (* ../mlton/signal.sig *)
- (* ../mlton/signal.sml *)
- (* ../mlton/process.sig *)
- (* ../mlton/process.sml *)
- (* ../mlton/gc.sig *)
- (* ../mlton/gc.sml *)
- (* ../mlton/rusage.sig *)
- (* ../mlton/rusage.sml *)
+ ../mlton/pointer.sml
+ ../mlton/call-stack.sig
+ ../mlton/call-stack.sml
+ ../mlton/exit.sml
+ ../mlton/exn.sig
+ ../mlton/exn.sml
+ ../mlton/thread.sig
+ ../mlton/thread.sml
+ ../mlton/signal.sig
+ ../mlton/signal.sml
+ ../mlton/process.sig
+ ../mlton/process.sml
+ ../mlton/gc.sig
+ ../mlton/gc.sml
+ ../mlton/rusage.sig
+ ../mlton/rusage.sml
(*
../../system/process.sig
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/call-stack.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/call-stack.sml 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/call-stack.sml 2006-04-30 21:32:15 UTC (rev 4429)
@@ -7,18 +7,18 @@
structure MLtonCallStack =
struct
- open Primitive.CallStack
+ open Primitive.MLton.CallStack
- val gcState = Primitive.GCState.gcState
+ val gcState = Primitive.MLton.GCState.gcState
structure Pointer = MLtonPointer
val current: unit -> t =
fn () =>
if not keep
- then T (Array.array (0, 0))
+ then T (Array.array (0, 0wx0))
else
let
- val a = Array.array (numStackFrames gcState, ~1)
+ val a = Array.arrayUninit (Word32.toInt (numStackFrames gcState))
val () = callStack (gcState, a)
in
T a
@@ -39,13 +39,12 @@
else
let
val p = frameIndexSourceSeq (gcState, frameIndex)
- val max = Pointer.getInt32 (p, 0)
+ val max = Int32.toInt (Pointer.getInt32 (p, 0))
fun loop (j, ac) =
if j > max
then ac
else loop (j + 1,
- COld.CS.toString (sourceName
- (gcState, Pointer.getInt32 (p, j)))
+ CUtil.C_String.toString (sourceName (gcState, Pointer.getWord32 (p, j)))
:: ac)
in
loop (1, ac)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/exit.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/exit.sml 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/exit.sml 2006-04-30 21:32:15 UTC (rev 4429)
@@ -33,7 +33,7 @@
in
if 0 <= i andalso i < 256
then (let open Cleaner in clean atExit end
- ; Primitive.halt status
+ ; Primitive.MLton.halt status
; raise Fail "exit")
else raise Fail (concat ["exit must have 0 <= status < 256: saw ",
Int.toString i])
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/exn.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/exn.sml 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/exn.sml 2006-04-30 21:32:15 UTC (rev 4429)
@@ -7,7 +7,7 @@
structure MLtonExn =
struct
- open Primitive.Exn
+ open Primitive.MLton.Exn
type t = exn
@@ -42,7 +42,7 @@
else fn _ => []
local
- val message = Primitive.Stdio.print
+ val message = PrimitiveFFI.Stdio.print
in
fun 'a topLevelHandler (exn: exn): 'a =
(message (concat ["unhandled exception: ", exnMessage exn, "\n"])
@@ -54,7 +54,7 @@
l)))
; Exit.exit Exit.Status.failure)
handle _ => (message "Toplevel handler raised exception.\n"
- ; Primitive.halt Exit.Status.failure
+ ; Primitive.MLton.halt Exit.Status.failure
(* The following raise is unreachable, but must be there
* so that the expression is of type 'a.
*)
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/gc.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/gc.sml 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/gc.sml 2006-04-30 21:32:15 UTC (rev 4429)
@@ -8,9 +8,9 @@
structure MLtonGC =
struct
- open Primitive.GC
+ open Primitive.MLton.GC
- val gcState = Primitive.GCState.gcState
+ val gcState = Primitive.MLton.GCState.gcState
val pack : unit -> unit =
fn () => pack gcState
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/pointer.sig
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/pointer.sig 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/pointer.sig 2006-04-30 21:32:15 UTC (rev 4429)
@@ -12,7 +12,7 @@
val add: t * word -> t
val compare: t * t -> order
val diff: t * t -> word
-(* val free: t -> unit *)
+ (* val free: t -> unit *)
val getInt8: t * int -> Int8.int
val getInt16: t * int -> Int16.int
val getInt32: t * int -> Int32.int
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/pointer.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/pointer.sml 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/pointer.sml 2006-04-30 21:32:15 UTC (rev 4429)
@@ -8,11 +8,45 @@
structure MLtonPointer: MLTON_POINTER =
struct
-open Primitive.Pointer
+open Primitive.MLton.Pointer
-fun add (p, t) = fromWord (Word.+ (toWord p, t))
-fun compare (p, p') = Word.compare (toWord p, toWord p')
-fun diff (p, p') = Word.- (toWord p, toWord p')
-fun sub (p, t) = fromWord (Word.- (toWord p, t))
-
+fun add (p, t) = fromWord (C_Pointer.+ (toWord p, C_Pointer.fromWord t))
+fun compare (p, p') = C_Pointer.compare (toWord p, toWord p')
+fun diff (p, p') = C_Pointer.toWord (C_Pointer.- (toWord p, toWord p'))
+fun sub (p, t) = fromWord (C_Pointer.- (toWord p, C_Pointer.fromWord t))
+
+local
+ fun wrap f (p, i) =
+ f (p, C_Ptrdiff.fromInt i)
+in
+ val getInt8 = wrap getInt8
+ val getInt16 = wrap getInt16
+ val getInt32 = wrap getInt32
+ val getInt64 = wrap getInt64
+ val getPointer = wrap getPointer
+ val getReal32 = wrap getReal32
+ val getReal64 = wrap getReal64
+ val getWord8 = wrap getWord8
+ val getWord16 = wrap getWord16
+ val getWord32 = wrap getWord32
+ val getWord64 = wrap getWord64
end
+
+local
+ fun wrap f (p, i, x) =
+ f (p, C_Ptrdiff.fromInt i, x)
+in
+ val setInt8 = wrap setInt8
+ val setInt16 = wrap setInt16
+ val setInt32 = wrap setInt32
+ val setInt64 = wrap setInt64
+ val setPointer = wrap setPointer
+ val setReal32 = wrap setReal32
+ val setReal64 = wrap setReal64
+ val setWord8 = wrap setWord8
+ val setWord16 = wrap setWord16
+ val setWord32 = wrap setWord32
+ val setWord64 = wrap setWord64
+end
+
+end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/process.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/process.sml 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/process.sml 2006-04-30 21:32:15 UTC (rev 4429)
@@ -20,7 +20,7 @@
structure Mask = MLtonSignal.Mask
structure SysCall = PosixError.SysCall
- type pid = Pid.t
+ type pid = C_PId.t
exception MisuseOfForget
exception DoublyRedirected
@@ -254,9 +254,10 @@
dquote]
fun create (cmd, args, env, stdin, stdout, stderr) =
- SysCall.syscall
- (fn () =>
+ SysCall.simpleResult'
+ ({errVal = C_PId.fromInt ~1}, fn () =>
let
+(*
val cmd =
let
open MLton.Platform.OS
@@ -266,12 +267,10 @@
| MinGW => cmd
| _ => raise Fail "create"
end
- val p =
- PrimitiveFFI.Windows.Process.create
- (NullString.nullTerm cmd, args, env, stdin, stdout, stderr)
- val p' = Pid.toInt p
+*)
in
- (p', fn () => p)
+ PrimitiveFFI.Windows.Process.create
+ (NullString.nullTerm cmd, args, env, stdin, stdout, stderr)
end)
fun launchWithCreate (path, args, env, stdin, stdout, stderr) =
@@ -322,14 +321,12 @@
then
let
val path = NullString.nullTerm path
- val args = COld.CSS.fromList args
- val env = COld.CSS.fromList env
+ val args = CUtil.C_StringArray.fromList args
+ val env = CUtil.C_StringArray.fromList env
in
- SysCall.syscall
- (fn () =>
- let val pid = Prim.spawne (path, args, env)
- in (Pid.toInt pid, fn () => pid)
- end)
+ SysCall.simpleResult'
+ ({errVal = C_PId.fromInt ~1}, fn () =>
+ Prim.spawne (path, args, env))
end
else
case Posix.Process.fork () of
@@ -346,13 +343,11 @@
then
let
val file = NullString.nullTerm file
- val args = COld.CSS.fromList args
+ val args = CUtil.C_StringArray.fromList args
in
- SysCall.syscall
- (fn () =>
- let val pid = Prim.spawnp (file, args)
- in (Pid.toInt pid, fn () => pid)
- end)
+ SysCall.simpleResult'
+ ({errVal = C_PId.fromInt ~1}, fn () =>
+ Prim.spawnp (file, args))
end
else
case Posix.Process.fork () of
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/rusage.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/rusage.sml 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/rusage.sml 2006-04-30 21:32:15 UTC (rev 4429)
@@ -17,9 +17,9 @@
fun toTime (sec, usec) =
let
val time_sec =
- Time.fromSeconds (LargeInt.fromInt (sec ()))
+ Time.fromSeconds (C_Time.toLarge (sec ()))
val time_usec =
- Time.fromMicroseconds (LargeInt.fromInt (usec ()))
+ Time.fromMicroseconds (C_SUSeconds.toLarge (usec ()))
in
Time.+ (time_sec, time_usec)
end
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/signal.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/signal.sml 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/signal.sml 2006-04-30 21:32:15 UTC (rev 4429)
@@ -18,8 +18,6 @@
type t = signal
type how = C_Int.t
-
-(* val toString = SysWord.toString o toWord *)
fun raiseInval () =
let
@@ -30,8 +28,8 @@
val validSignals =
Array.tabulate
- (Prim.NSIG, fn i =>
- Prim.sigismember(fromInt i) <> ~1)
+ (C_Int.toInt Prim.NSIG, fn i =>
+ (C_Errno.check (Prim.sigismember(fromInt i))) <> (C_Int.fromInt ~1))
structure Mask =
struct
@@ -50,9 +48,9 @@
(Array.foldri
(fn (i, b, sigs) =>
if b
- then if (Prim.sigismember(fromInt i)) = 1
- then (fromInt i)::sigs
- else sigs
+ then if (C_Errno.check (Prim.sigismember(fromInt i))) = (C_Int.fromInt ~1)
+ then sigs
+ else (fromInt i)::sigs
else sigs)
[]
validSignals)
@@ -103,7 +101,7 @@
val r = ref false
in
fun initHandler (s: signal): Handler.t =
- if 0 = Prim.isDefault (s, r)
+ if C_Errno.check (Prim.isDefault (s, r)) = C_Int.fromInt 0
then if !r
then Default
else Ignore
@@ -112,7 +110,7 @@
val (getHandler, setHandler, handlers) =
let
- val handlers = Array.tabulate (Prim.NSIG, initHandler o fromInt)
+ val handlers = Array.tabulate (C_Int.toInt Prim.NSIG, initHandler o fromInt)
val _ =
Cleaner.addNew
(Cleaner.atLoadWorld, fn () =>
Modified: mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/thread.sml
===================================================================
--- mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/thread.sml 2006-04-30 20:08:35 UTC (rev 4428)
+++ mlton/branches/on-20050822-x86_64-branch/basis-library.refactor/mlton/thread.sml 2006-04-30 21:32:15 UTC (rev 4429)
@@ -8,10 +8,17 @@
structure MLtonThread:> MLTON_THREAD_EXTRA =
struct
-structure Prim = Primitive.Thread
+structure Prim = Primitive.MLton.Thread
-val gcState = Primitive.GCState.gcState
+fun die (s: string): 'a =
+ (PrimitiveFFI.Stdio.print s
+ ; PrimitiveFFI.Posix.Process.exit 1
+ ; let exception DieFailed
+ in raise DieFailed
+ end)
+val gcState = Primitive.MLton.GCState.gcState
+
structure AtomicState =
struct
datatype t = NonAtomic | Atomic of int
@@ -24,8 +31,8 @@
val atomicEnd = atomicEnd
val atomicState = fn () =>
case canHandle () of
- 0 => AtomicState.NonAtomic
- | n => AtomicState.Atomic n
+ 0wx0 => AtomicState.NonAtomic
+ | w => AtomicState.Atomic (Word32.toInt w)
end
fun atomically f =
@@ -167,7 +174,7 @@
fun setSignalHandler (f: Runnable.t -> Runnable.t): unit =
let
- val _ = Primitive.installSignalHandler ()
+ val _ = Primitive.MLton.installSignalHandler ()
fun loop (): unit =
let
(* Atomic 1 *)
@@ -217,8 +224,9 @@
in
val register: int * (unit -> unit) -> unit =
let
- val exports = Array.array (Primitive.FFI.numExports, fn () =>
- raise Fail "undefined export")
+ val exports =
+ Array.array (Int32.toInt (Primitive.MLton.FFI.numExports),
+ fn () => raise Fail "undefined export")
fun loop (): unit =
let
(* Atomic 2 *)
@@ -228,7 +236,7 @@
(* Atomic 1 *)
val _ =
(* atomicEnd() after getting args *)
- (Array.sub (exports, Primitive.FFI.getOp ()) ())
+ (Array.sub (exports, Int32.toInt (Primitive.MLton.FFI.getOp ())) ())
handle e =>
(TextIO.output
(TextIO.stdErr, "Call from C to SML raised exception.\n")