[MLton] cvs commit: integrated Wesley Terpstra's patch for MLton.Process.create.
Stephen Weeks
sweeks@mlton.org
Wed, 24 Nov 2004 17:35:51 -0800
sweeks 04/11/24 17:35:50
Modified: basis-library/misc primitive.sml
basis-library/mlton process.sig process.sml
basis-library/posix io.sml primitive.sml process.sig
process.sml
basis-library/system process.sig process.sml unix.sml
doc changelog
lib/mlton-stubs mlton.sig mlton.sml pointer.sig process.sig
sources.cm
runtime gc.c platform.h
runtime/platform cygwin.c cygwin.h darwin.c freebsd.c
linux.c mingw.c mingw.h netbsd.c openbsd.c
solaris.c
Added: lib/mlton-stubs call-stack.sig
runtime/platform create.c mmap.c release.virtual.c
setbintext.c use-mmap.c virtualAlloc.c
Log:
MAIL integrated Wesley Terpstra's patch for MLton.Process.create.
Reorganized how the various platforms implement mmapAnon, either via
an underlying mmap or VirtualAlloc. This was to clean up some #if's
from gc.c and, more importantly, to make it easier to add the runtime
switch use-mmap. This switch, whhich is only meaningful on Cygwin,
controls whether a Cygwin executable uses mmap or VirtualAlloc for
memory allocation. If an executable uses mmap, then fork is enabled
and Process.create will use the usual Unixish stuff. On the other
hand, if an executable uses VirtualAlloc, then fork is disabled and
Process.create will use the underlying windows CreateProcess.
Revision Changes Path
1.131 +17 -2 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.130
retrieving revision 1.131
diff -u -r1.130 -r1.131
--- primitive.sml 12 Nov 2004 23:48:05 -0000 1.130
+++ primitive.sml 25 Nov 2004 01:35:47 -0000 1.131
@@ -901,15 +901,30 @@
| "netbsd" => NetBSD
| "openbsd" => OpenBSD
| "solaris" => Solaris
- | _ => raise Fail "strange MLton_Platform_OS_Host"
+ | _ => raise Fail "strange MLton_Platform_OS_host"
+
+ local
+ val cygwinUseMmap =
+ _import "MLton_Platform_CygwinUseMmap": bool;
+ in
+ val useWindowsProcess: bool =
+ case host of
+ Cygwin => not cygwinUseMmap
+ | MinGW => true
+ | _ => false
+ end
end
end
structure Process =
struct
+ val create =
+ _import "MLton_Process_create"
+ : NullString.t * NullString.t * int * int * int -> Pid.t;
val spawne =
_import "MLton_Process_spawne"
- : NullString.t * NullString.t array * NullString.t array -> Pid.t;
+ : (NullString.t * NullString.t array * NullString.t array
+ -> Pid.t);
val spawnp =
_import "MLton_Process_spawnp"
: NullString.t * NullString.t array -> Pid.t;
1.7 +62 -2 mlton/basis-library/mlton/process.sig
Index: process.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/process.sig,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- process.sig 11 Feb 2004 19:16:11 -0000 1.6
+++ process.sig 25 Nov 2004 01:35:48 -0000 1.7
@@ -2,7 +2,67 @@
sig
type pid
- val spawn: {path: string, args: string list} -> pid
- val spawne: {path: string, args: string list, env: string list} -> pid
+ (* Process handle *)
+ type ('stdin, 'stdout, 'stderr) t
+
+ (* is the io 'dir input or output *)
+ type input
+ type output
+
+ (* to what use can the stdio channel be put *)
+ type none (* it's not connected to a pipe *)
+ type chain (* connect one child to another *)
+ type any (* any use is allowed -- dangerous *)
+
+ exception MisuseOfForget (* you avoided the type safety and broke it *)
+ exception DoublyRedirected (* you tried to reuse a Param.child *)
+
+ structure Child:
+ sig
+ type ('use, 'dir) t
+
+ val binIn: (BinIO.instream, input) t -> BinIO.instream
+ val binOut: (BinIO.outstream, output) t -> BinIO.outstream
+ (* not necessarily available on all systems; may raise an exception *)
+ val fd: (Posix.FileSys.file_desc, 'dir) t -> Posix.FileSys.file_desc
+ (* used for situations where 'forget' was needed for arbitrary redir *)
+ val remember: (any, 'dir) t -> ('use, 'dir) t
+ val textIn: (TextIO.instream, input) t -> TextIO.instream
+ val textOut: (TextIO.outstream, output) t -> TextIO.outstream
+ end
+
+ structure Param:
+ sig
+ type ('use, 'dir) t
+
+ (* {child,fd} close their parameter when create is called.
+ * therefore they may only be used once!
+ *)
+ val child: (chain, 'dir) Child.t -> (none, 'dir) t
+ (* Not necessarily available on all systems; may raise an exception *)
+ val fd: Posix.FileSys.file_desc -> (none, 'dir) t
+ val file: string -> (none, 'dir) t
+ (* used if you want to return two posibilities; use with care *)
+ val forget: ('use, 'dir) t -> (any, 'dir) t
+ val null: (none, 'dir) t
+ val pipe: ('use, 'dir) t
+ val self: (none, 'dir) t
+ end
+
+ val create:
+ {args: string list,
+ env: string list option,
+ path: string,
+ stderr: ('stderr, output) Param.t,
+ stdin: ('stdin, input) Param.t,
+ stdout: ('stdout, output) Param.t}
+ -> ('stdin, 'stdout, 'stderr) t
+ val getStderr: ('stdin, 'stdout, 'stderr) t -> ('stderr, input) Child.t
+ val getStdin: ('stdin, 'stdout, 'stderr) t -> ('stdin, output) Child.t
+ val getStdout: ('stdin, 'stdout, 'stderr) t -> ('stdout, input) Child.t
+ val kill: ('stdin, 'stdout, 'stderr) t * Posix.Signal.signal -> unit
+ val reap: ('stdin, 'stdout, 'stderr) t -> Posix.Process.exit_status
+ val spawn: {args: string list, path: string} -> pid
+ val spawne: {args: string list, env: string list, path: string} -> pid
val spawnp: {file: string, args: string list} -> pid
end
1.16 +290 -5 mlton/basis-library/mlton/process.sml
Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/process.sml,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- process.sml 24 Nov 2004 16:38:55 -0000 1.15
+++ process.sml 25 Nov 2004 01:35:48 -0000 1.16
@@ -1,12 +1,295 @@
structure MLtonProcess =
struct
structure Prim = Primitive.MLton.Process
- structure Error = PosixError
- structure SysCall = Error.SysCall
structure MLton = Primitive.MLton
+ local
+ open Posix
+ in
+ structure FileSys = FileSys
+ structure IO = IO
+ structure ProcEnv = ProcEnv
+ structure Process = Posix.Process
+ end
+ structure Mask = MLtonSignal.Mask
+ structure SysCall = PosixError.SysCall
+ datatype z = datatype PosixPrimitive.file_desc
+
type pid = Pid.t
+ exception MisuseOfForget
+ exception DoublyRedirected
+
+ type input = unit
+ type output = unit
+
+ type none = unit
+ type chain = unit
+ type any = unit
+
+ val useCreate = MLton.Platform.OS.useWindowsProcess
+
+ val readWrite =
+ let
+ open FileSys.S
+ in
+ flags [irusr, iwusr, irgrp, iwgrp, iroth, iwoth]
+ end
+
+ structure Child =
+ struct
+ datatype 'use childt =
+ FileDesc of FileSys.file_desc
+ | Stream of 'use * ('use -> unit)
+ | Term
+ type ('use, 'dir) t = 'use childt ref
+
+ (* This is _not_ the identity; by rebuilding it we get type
+ * ('a, 'b) t -> ('c, 'd) t
+ *)
+ fun remember x =
+ case !x of
+ FileDesc f =>
+ (x := Stream ((), fn () => ())
+ ; ref (FileDesc f))
+ | Stream _ => raise MisuseOfForget (* remember twice = bad *)
+ | Term => ref Term
+
+ local
+ fun convert (new, close) p =
+ case !p of
+ FileDesc fd =>
+ let
+ val str = new (fd, "<process>")
+ val () = p := Stream (str, close)
+ in
+ str
+ end
+ | Stream (str, _) => str
+ | Term => raise MisuseOfForget
+ in
+ val binIn = convert (BinIO.newIn, BinIO.closeIn)
+ val binOut = convert (BinIO.newOut, BinIO.closeOut)
+ val textIn = convert (TextIO.newIn, TextIO.closeIn)
+ val textOut = convert (TextIO.newOut, TextIO.closeOut)
+ end
+
+ fun fd p =
+ case !p of
+ FileDesc fd => fd
+ | _ => raise MisuseOfForget
+
+ fun close ch =
+ case ch of
+ FileDesc fd => IO.close fd
+ | Stream (str, close) => close str
+ | Term => ()
+
+ val close =
+ fn (stdin, stdout, stderr) =>
+ (close stdin; close stdout; close stderr)
+ end
+
+ structure Param =
+ struct
+ datatype ('use, 'dir) t =
+ File of string
+ | FileDesc of FileSys.file_desc
+ | Pipe
+ | Self
+
+ (* This is _not_ the identity; by rebuilding it we get type
+ * ('a, 'b) t -> ('c, 'd) t
+ *)
+ val forget = fn
+ File x => File x
+ | FileDesc f => FileDesc f
+ | Pipe => Pipe
+ | Self => Self
+
+ val pipe = Pipe
+ local
+ val null = if useCreate then "nul" else "/dev/null"
+ in
+ val null = File null
+ end
+ val self = Self
+ fun file f = File f
+ fun fd f = FileDesc f
+
+ fun child c =
+ FileDesc
+ (case !c of
+ Child.FileDesc f => (c := Child.Stream ((), fn () => ()); f)
+ | Child.Stream _ => raise DoublyRedirected
+ | Child.Term => raise MisuseOfForget)
+
+ fun setCloseExec fd =
+ if useCreate
+ then ()
+ else IO.setfd (fd, IO.FD.flags [IO.FD.cloexec])
+
+ fun openOut std p =
+ case p of
+ File s => (FileSys.creat (s, readWrite), Child.Term)
+ | FileDesc f => (f, Child.Term)
+ | Pipe =>
+ let
+ val {infd, outfd} = IO.pipe ()
+ val () = setCloseExec infd
+ in
+ (outfd, Child.FileDesc infd)
+ end
+ | Self => (std, Child.Term)
+
+ fun openStdin p =
+ case p of
+ File s =>
+ (FileSys.openf (s, FileSys.O_RDONLY, FileSys.O.flags []),
+ Child.Term)
+ | FileDesc f => (f, Child.Term)
+ | Pipe =>
+ let
+ val {infd, outfd} = IO.pipe ()
+ val () = setCloseExec outfd
+ in
+ (infd, Child.FileDesc outfd)
+ end
+ | Self => (FileSys.stdin, Child.Term)
+
+ fun close p fd =
+ case p of
+ File _ => IO.close fd
+ | FileDesc _ => IO.close fd
+ | Pipe => IO.close fd
+ | _ => ()
+ end
+
+ datatype ('stdin, 'stdout, 'stderr) t =
+ T of {pid: Process.pid,
+ status: Posix.Process.exit_status option ref,
+ stderr: ('stderr, input) Child.t,
+ stdin: ('stdin, output) Child.t,
+ stdout: ('stdout, input) Child.t}
+
+ local
+ fun make f (T r) = f r
+ in
+ val getStderr = fn z => make #stderr z
+ val getStdin = fn z => make #stdin z
+ val getStdout = fn z => make #stdout z
+ end
+
+ fun ('a, 'b) protect (f: 'a -> 'b) (x: 'a): 'b =
+ let
+ val () = Mask.block Mask.all
+ in
+ DynamicWind.wind (fn () => f x, fn () => Mask.unblock Mask.all)
+ end
+
+ fun reap (T {pid, status, stderr, stdin, stdout}) =
+ case !status of
+ NONE =>
+ let
+ val _ = Child.close (!stdin, !stdout, !stderr)
+ (* protect is probably too much; typically, one
+ * would only mask SIGINT, SIGQUIT and SIGHUP
+ *)
+ val (_, st) = protect Process.waitpid (Process.W_CHILD pid, [])
+ val () = status := SOME st
+ in
+ st
+ end
+ | SOME status => status
+
+ fun kill (p as T {pid, status, ...}, signal) =
+ case !status of
+ NONE =>
+ let
+ val () = Process.kill (Process.K_PROC pid, signal)
+ in
+ ignore (reap p)
+ end
+ | SOME _ => ()
+
+ fun launchWithFork (path, args, env, stdin, stdout, stderr) =
+ case protect Process.fork () of
+ NONE => (* child *)
+ let
+ val base =
+ Substring.string
+ (Substring.taker (fn c => c <> #"/") (Substring.full path))
+ fun dup2 (old, new) =
+ if old = new
+ then ()
+ else (IO.dup2 {old = old, new = new}; IO.close old)
+ in
+ dup2 (stdin, FileSys.stdin)
+ ; dup2 (stdout, FileSys.stdout)
+ ; dup2 (stderr, FileSys.stderr)
+ ; Process.exece (path, base :: args, env)
+ ; Process.exit 0w1 (* just in case *)
+ end
+ | SOME pid => pid (* parent *)
+
+ val dquote = "\""
+ fun cmdEscape y =
+ concat [dquote,
+ String.translate
+ (fn #"\"" => "\\\"" | #"\\" => "\\\\" | x => String.str x) y,
+ dquote]
+
+ fun create (cmd, env, FD stdin, FD stdout, FD stderr) =
+ SysCall.syscall
+ (fn () =>
+ let
+ val p = Prim.create (cmd, env, stdin, stdout, stderr)
+ val p' = Pid.toInt p
+ in
+ (p', fn () => p)
+ end)
+
+ fun launchWithCreate (path, args, env, stdin, stdout, stderr) =
+ create
+ (NullString.nullTerm (String.concatWith " "
+ (List.map cmdEscape (path :: args))),
+ NullString.nullTerm (String.concatWith "\000" env ^ "\000"),
+ stdin, stdout, stderr)
+
+ val launch =
+ fn z => (if useCreate then launchWithCreate else launchWithFork) z
+
+ fun create {args, env, path, stderr, stdin, stdout} =
+ if not (FileSys.access (path, [FileSys.A_EXEC]))
+ then PosixError.raiseSys PosixError.noent
+ else
+ let
+ val () = TextIO.flushOut TextIO.stdOut
+ val env =
+ case env of
+ NONE => ProcEnv.environ ()
+ | SOME x => x
+ val (fstdin, cstdin) = Param.openStdin stdin
+ val (fstdout, cstdout) = Param.openOut FileSys.stdout stdout
+ val (fstderr, cstderr) = Param.openOut FileSys.stderr stderr
+ val closeStdio =
+ fn () => (Param.close stdin fstdin
+ ; Param.close stdout fstdout
+ ; Param.close stderr fstderr)
+ val pid =
+ launch (path, args, env, fstdin, fstdout, fstderr)
+ handle ex => (closeStdio ()
+ ; Child.close (cstdin, cstdout, cstderr)
+ ; raise ex)
+ val () = closeStdio ()
+ in
+ T {pid = pid,
+ status = ref NONE,
+ stderr = ref cstderr,
+ stdin = ref cstdin,
+ stdout = ref cstdout}
+ end
+
val useSpawn =
let
open MLton.Platform.OS
@@ -36,10 +319,12 @@
NONE => Posix.Process.exece (path, args, env)
| SOME pid => pid
- fun spawn {path, args} =
- spawne {path = path, args = args, env = Posix.ProcEnv.environ ()}
+ fun spawn {args, path}=
+ spawne {args = args,
+ env = ProcEnv.environ (),
+ path = path}
- fun spawnp {file, args} =
+ fun spawnp {args, file} =
if useSpawn
then
let
1.19 +344 -327 mlton/basis-library/posix/io.sml
Index: io.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/io.sml,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- io.sml 27 Aug 2004 00:50:41 -0000 1.18
+++ io.sml 25 Nov 2004 01:35:48 -0000 1.19
@@ -1,379 +1,396 @@
-(* Copyright (C) 1999-2002 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2004 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-1999 NEC Research Institute.
*
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-structure PosixIO: POSIX_IO =
- struct
- structure Prim = PosixPrimitive.IO
- open Prim
- structure Error = PosixError
- structure SysCall = Error.SysCall
- structure FS = PosixFileSys
- datatype file_desc = datatype Prim.file_desc
- type pid = Pid.t
+structure PosixIO: POSIX_IO =
+struct
- local
- val a: PosixPrimitive.fd array = Array.array (2, 0)
- in
- fun pipe () =
- SysCall.syscall
- (fn () =>
- (Prim.pipe a,
- fn () => {infd = FD (Array.sub (a, 0)),
- outfd = FD (Array.sub (a, 1))}))
- end
+structure Prim = PosixPrimitive.IO
+open Prim
+structure Error = PosixError
+structure SysCall = Error.SysCall
+structure FS = PosixFileSys
+
+datatype file_desc = datatype Prim.file_desc
+type pid = Pid.t
+
+local
+ val a: PosixPrimitive.fd array = Array.array (2, 0)
+in
+ fun pipe () =
+ SysCall.syscall
+ (fn () =>
+ (Prim.pipe a,
+ fn () => {infd = FD (Array.sub (a, 0)),
+ outfd = FD (Array.sub (a, 1))}))
+end
- fun dup (FD fd) = FD (SysCall.simpleResult (fn () => Prim.dup fd))
+fun dup (FD fd) = FD (SysCall.simpleResult (fn () => Prim.dup fd))
- fun dup2 {old = FD old, new = FD new} =
- SysCall.simple (fn () => Prim.dup2 (old, new))
+fun dup2 {old = FD old, new = FD new} =
+ SysCall.simple (fn () => Prim.dup2 (old, new))
- fun close (FD fd) = SysCall.simpleRestart (fn () => Prim.close fd)
+fun close (FD fd) = SysCall.simpleRestart (fn () => Prim.close fd)
- local
- fun make {fromVector, read, toArraySlice, toVectorSlice,
- vectorLength, write, writeVec} =
- let
- fun readArr (FD fd, sl): int =
- let
- val (buf, i, sz) = ArraySlice.base (toArraySlice sl)
- in
- SysCall.simpleResultRestart
- (fn () => read (fd, buf, i, sz))
- end
- fun readVec (FD fd, n) =
- let
- val a = Primitive.Array.array n
- val bytesRead =
- SysCall.simpleResultRestart
- (fn () => read (fd, a, 0, n))
- in
- fromVector
- (if n = bytesRead
- then Vector.fromArray a
- else ArraySlice.vector (ArraySlice.slice
- (a, 0, SOME bytesRead)))
- end
- fun writeArr (FD fd, sl) =
- let
- val (buf, i, sz) = ArraySlice.base (toArraySlice sl)
- in
- SysCall.simpleResultRestart
- (fn () => write (fd, buf, i, sz))
- end
- val writeVec =
- fn (FD fd, sl) =>
- let
- val (buf, i, sz) = VectorSlice.base (toVectorSlice sl)
- in
- SysCall.simpleResultRestart
- (fn () => writeVec (fd, buf, i, sz))
- end
- in
- {readArr = readArr, readVec = readVec,
- vectorLength = vectorLength,
- writeVec = writeVec, writeArr = writeArr}
- end
- in
- val rwChar = make {fromVector = fn v => v,
- read = readChar,
- toArraySlice = CharArraySlice.toPoly,
- toVectorSlice = CharVectorSlice.toPoly,
- vectorLength = CharVector.length,
- write = writeChar,
- writeVec = writeCharVec}
- val rwWord8 = make {fromVector = Word8Vector.fromPoly,
- read = readWord8,
- toArraySlice = Word8ArraySlice.toPoly,
- toVectorSlice = Word8VectorSlice.toPoly,
- vectorLength = Word8Vector.length,
- write = writeWord8,
- writeVec = writeWord8Vec}
- end
- val {readArr, readVec, writeVec, writeArr, ...} = rwWord8
-
- structure FD =
- struct
- open FD BitFlags
- end
+structure FD =
+ struct
+ open FD BitFlags
+ end
- structure O = PosixFileSys.O
+structure O = PosixFileSys.O
- datatype open_mode = datatype PosixFileSys.open_mode
+datatype open_mode = datatype PosixFileSys.open_mode
- fun dupfd {old = FD old, base = FD base} =
- FD (SysCall.simpleResultRestart
- (fn () => Prim.fcntl3 (old, F_DUPFD, base)))
-
- fun getfd (FD fd) =
- Word.fromInt (SysCall.simpleResultRestart
- (fn () => Prim.fcntl2 (fd, F_GETFD)))
-
- fun setfd (FD fd, flags): unit =
- SysCall.simpleRestart
- (fn () => Prim.fcntl3 (fd, F_SETFD, Word.toIntX flags))
+fun dupfd {old = FD old, base = FD base} =
+ FD (SysCall.simpleResultRestart
+ (fn () => Prim.fcntl3 (old, F_DUPFD, base)))
+
+fun getfd (FD fd) =
+ Word.fromInt (SysCall.simpleResultRestart
+ (fn () => Prim.fcntl2 (fd, F_GETFD)))
+
+fun setfd (FD fd, flags): unit =
+ SysCall.simpleRestart
+ (fn () => Prim.fcntl3 (fd, F_SETFD, Word.toIntX flags))
- fun getfl (FD fd): O.flags * open_mode =
- let
- val n =
- SysCall.simpleResultRestart (fn () => Prim.fcntl2 (fd, F_GETFL))
- val w = Word.fromInt n
- val flags = Word.andb (w, Word.notb O_ACCMODE)
- val mode = Word.andb (w, O_ACCMODE)
- in (flags, PosixFileSys.wordToOpenMode mode)
- end
+fun getfl (FD fd): O.flags * open_mode =
+ let
+ val n =
+ SysCall.simpleResultRestart (fn () => Prim.fcntl2 (fd, F_GETFL))
+ val w = Word.fromInt n
+ val flags = Word.andb (w, Word.notb O_ACCMODE)
+ val mode = Word.andb (w, O_ACCMODE)
+ in (flags, PosixFileSys.wordToOpenMode mode)
+ end
- fun setfl (FD fd, flags: O.flags): unit =
- SysCall.simpleRestart
- (fn () => Prim.fcntl3 (fd, F_SETFL, Word.toIntX flags))
+fun setfl (FD fd, flags: O.flags): unit =
+ SysCall.simpleRestart
+ (fn () => Prim.fcntl3 (fd, F_SETFL, Word.toIntX flags))
- datatype whence = SEEK_SET | SEEK_CUR | SEEK_END
+datatype whence = SEEK_SET | SEEK_CUR | SEEK_END
- val whenceToInt =
- fn SEEK_SET => Prim.SEEK_SET
- | SEEK_CUR => Prim.SEEK_CUR
- | SEEK_END => Prim.SEEK_END
-
- fun intToWhence n =
- if n = Prim.SEEK_SET
- then SEEK_SET
- else if n = Prim.SEEK_CUR
- then SEEK_CUR
- else if n = Prim.SEEK_END
- then SEEK_END
- else raise Fail "Posix.IO.intToWhence"
+val whenceToInt =
+ fn SEEK_SET => Prim.SEEK_SET
+ | SEEK_CUR => Prim.SEEK_CUR
+ | SEEK_END => Prim.SEEK_END
+
+fun intToWhence n =
+ if n = Prim.SEEK_SET
+ then SEEK_SET
+ else if n = Prim.SEEK_CUR
+ then SEEK_CUR
+ else if n = Prim.SEEK_END
+ then SEEK_END
+ else raise Fail "Posix.IO.intToWhence"
- fun lseek (FD fd, n: Position.int, w: whence): Position.int =
- SysCall.syscall
- (fn () =>
- let val n = Prim.lseek (fd, n, whenceToInt w)
- in (if n = ~1 then ~1 else 0, fn () => n)
- end)
+fun lseek (FD fd, n: Position.int, w: whence): Position.int =
+ SysCall.syscall
+ (fn () =>
+ let val n = Prim.lseek (fd, n, whenceToInt w)
+ in (if n = ~1 then ~1 else 0, fn () => n)
+ end)
- fun fsync (FD fd): unit = SysCall.simple (fn () => Prim.fsync fd)
+fun fsync (FD fd): unit = SysCall.simple (fn () => Prim.fsync fd)
- datatype lock_type =
- F_RDLCK
- | F_WRLCK
- | F_UNLCK
-
- val lockTypeToInt =
- fn F_RDLCK => Prim.F_RDLCK
- | F_WRLCK => Prim.F_WRLCK
- | F_UNLCK => Prim.F_UNLCK
-
- fun intToLockType n =
- if n = Prim.F_RDLCK
- then F_RDLCK
- else if n = Prim.F_WRLCK
- then F_WRLCK
- else if n = Prim.F_UNLCK
- then F_UNLCK
- else raise Fail "Posix.IO.intToLockType"
+datatype lock_type =
+ F_RDLCK
+ | F_WRLCK
+ | F_UNLCK
+
+val lockTypeToInt =
+ fn F_RDLCK => Prim.F_RDLCK
+ | F_WRLCK => Prim.F_WRLCK
+ | F_UNLCK => Prim.F_UNLCK
+
+fun intToLockType n =
+ if n = Prim.F_RDLCK
+ then F_RDLCK
+ else if n = Prim.F_WRLCK
+ then F_WRLCK
+ else if n = Prim.F_UNLCK
+ then F_UNLCK
+ else raise Fail "Posix.IO.intToLockType"
- structure FLock =
- struct
- type flock = {ltype: lock_type,
- whence: whence,
- start: Position.int,
- len: Position.int,
- pid: pid option}
+structure FLock =
+ struct
+ type flock = {ltype: lock_type,
+ whence: whence,
+ start: Position.int,
+ len: Position.int,
+ pid: pid option}
- fun flock l = l
- val ltype: flock -> lock_type = #ltype
- val whence: flock -> whence = #whence
- val start: flock -> Position.int = #start
- val len: flock -> Position.int = #len
- val pid: flock -> pid option = #pid
- end
-
- local
- structure P = Prim.FLock
- fun make
- (cmd, usepid)
- (FD fd, {ltype, whence, start, len, ...}: FLock.flock)
- : FLock.flock =
- SysCall.syscallRestart
- (fn () =>
- ((P.setType (lockTypeToInt ltype)
- ; P.setWhence (whenceToInt whence)
- ; P.setStart start
- ; P.setLen len
- ; P.fcntl (fd, cmd)), fn () =>
- {ltype = intToLockType (P.typ ()),
- whence = intToWhence (P.whence ()),
- start = P.start (),
- len = P.len (),
- pid = if usepid then SOME (P.pid ()) else NONE}))
- in
- val getlk = make (F_GETLK, true)
- val setlk = make (F_SETLK, false)
- val setlkw = make (F_SETLKW, false)
- end
+ fun flock l = l
+ val ltype: flock -> lock_type = #ltype
+ val whence: flock -> whence = #whence
+ val start: flock -> Position.int = #start
+ val len: flock -> Position.int = #len
+ val pid: flock -> pid option = #pid
+ end
+
+local
+ structure P = Prim.FLock
+ fun make
+ (cmd, usepid)
+ (FD fd, {ltype, whence, start, len, ...}: FLock.flock)
+ : FLock.flock =
+ SysCall.syscallRestart
+ (fn () =>
+ ((P.setType (lockTypeToInt ltype)
+ ; P.setWhence (whenceToInt whence)
+ ; P.setStart start
+ ; P.setLen len
+ ; P.fcntl (fd, cmd)), fn () =>
+ {ltype = intToLockType (P.typ ()),
+ whence = intToWhence (P.whence ()),
+ start = P.start (),
+ len = P.len (),
+ pid = if usepid then SOME (P.pid ()) else NONE}))
+in
+ val getlk = make (F_GETLK, true)
+ val setlk = make (F_SETLK, false)
+ val setlkw = make (F_SETLKW, false)
+end
- (* Adapted from SML/NJ sources. *)
- (* posix-bin-prim-io.sml
- *
- * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
- *
- * This implements the UNIX version of the OS specific binary primitive
- * IO structure. The Text IO version is implemented by a trivial translation
- * of these operations (see posix-text-prim-io.sml).
- *
- *)
- local
- val pos0 = Position.fromInt 0
- fun isReg fd = FS.ST.isReg(FS.fstat fd)
- fun posFns (closed, fd) =
- if (isReg fd)
- then let
- val pos = ref pos0
- fun getPos () = !pos
- fun setPos p = (if !closed
+(* Adapted from SML/NJ sources. *)
+(* posix-bin-prim-io.sml
+ *
+ * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
+ *
+ * This implements the UNIX version of the OS specific binary primitive
+ * IO structure. The Text IO version is implemented by a trivial translation
+ * of these operations (see posix-text-prim-io.sml).
+ *
+ *)
+local
+ val pos0 = Position.fromInt 0
+ fun isReg fd = FS.ST.isReg(FS.fstat fd)
+ fun posFns (closed, fd) =
+ if (isReg fd)
+ then let
+ val pos = ref pos0
+ fun getPos () = !pos
+ fun setPos p = (if !closed
+ then raise IO.ClosedStream
+ else ();
+ pos := lseek(fd,p,SEEK_SET))
+ fun endPos () = (if !closed
then raise IO.ClosedStream
- else ();
- pos := lseek(fd,p,SEEK_SET))
- fun endPos () = (if !closed
- then raise IO.ClosedStream
- else ();
- FS.ST.size(FS.fstat fd))
- fun verifyPos () = let
- val curPos = lseek(fd, pos0, SEEK_CUR)
- in
- pos := curPos; curPos
- end
- val _ = verifyPos ()
- in
- {pos = pos,
- getPos = SOME getPos,
- setPos = SOME setPos,
- endPos = SOME endPos,
- verifyPos = SOME verifyPos}
- end
- else {pos = ref pos0,
- getPos = NONE,
- setPos = NONE,
- endPos = NONE,
- verifyPos = NONE}
-
- fun make {readArr, readVec, vectorLength, writeVec, writeArr} (RD, WR) =
- let
- fun mkReader {fd, name, initBlkMode} =
- let
- val closed = ref false
- val {pos, getPos, setPos, endPos, verifyPos} =
- posFns (closed, fd)
- val blocking = ref initBlkMode
- fun blockingOn () =
+ else ();
+ FS.ST.size(FS.fstat fd))
+ fun verifyPos () = let
+ val curPos = lseek(fd, pos0, SEEK_CUR)
+ in
+ pos := curPos; curPos
+ end
+ val _ = verifyPos ()
+ in
+ {pos = pos,
+ getPos = SOME getPos,
+ setPos = SOME setPos,
+ endPos = SOME endPos,
+ verifyPos = SOME verifyPos}
+ end
+ else {pos = ref pos0,
+ getPos = NONE,
+ setPos = NONE,
+ endPos = NONE,
+ verifyPos = NONE}
+
+ fun fdToInt (FD fd) = fd
+
+ fun make {RD, WR, fromVector, read, setMode, toArraySlice, toVectorSlice,
+ vectorLength, write, writeVec} =
+ let
+ val setMode =
+ fn fd =>
+ if let
+ open Primitive.MLton.Platform.OS
+ in
+ case host of
+ Cygwin => true
+ | MinGW => true
+ | _ => false
+ end
+ then setMode (fd, Primitive.MLton.Platform.OS.useWindowsProcess)
+ else ()
+ fun readArr (FD fd, sl): int =
+ let
+ val (buf, i, sz) = ArraySlice.base (toArraySlice sl)
+ in
+ SysCall.simpleResultRestart
+ (fn () => read (fd, buf, i, sz))
+ end
+ fun readVec (FD fd, n) =
+ let
+ val a = Primitive.Array.array n
+ val bytesRead =
+ SysCall.simpleResultRestart
+ (fn () => read (fd, a, 0, n))
+ in
+ fromVector
+ (if n = bytesRead
+ then Vector.fromArray a
+ else ArraySlice.vector (ArraySlice.slice
+ (a, 0, SOME bytesRead)))
+ end
+ fun writeArr (FD fd, sl) =
+ let
+ val (buf, i, sz) = ArraySlice.base (toArraySlice sl)
+ in
+ SysCall.simpleResultRestart
+ (fn () => write (fd, buf, i, sz))
+ end
+ val writeVec =
+ fn (FD fd, sl) =>
+ let
+ val (buf, i, sz) = VectorSlice.base (toVectorSlice sl)
+ in
+ SysCall.simpleResultRestart
+ (fn () => writeVec (fd, buf, i, sz))
+ end
+ fun mkReader {fd, name, initBlkMode} =
+ let
+ val closed = ref false
+ val {pos, getPos, setPos, endPos, verifyPos} =
+ posFns (closed, fd)
+ val blocking = ref initBlkMode
+ fun blockingOn () =
(setfl(fd, O.flags[]); blocking := true)
- fun blockingOff () =
+ fun blockingOff () =
(setfl(fd, O.nonblock); blocking := false)
- fun ensureOpen () =
+ fun ensureOpen () =
if !closed then raise IO.ClosedStream else ()
- fun incPos k = pos := Position.+ (!pos, Position.fromInt k)
- val readVec = fn n =>
+ fun incPos k = pos := Position.+ (!pos, Position.fromInt k)
+ val readVec = fn n =>
let val v = readVec (fd, n)
in incPos (vectorLength v); v
end
- val readArr = fn x =>
+ val readArr = fn x =>
let val k = readArr (fd, x)
in incPos k; k
end
- fun blockWrap f x =
+ fun blockWrap f x =
(ensureOpen ();
if !blocking then () else blockingOn ();
- f x)
- fun noBlockWrap f x =
+ f x)
+ fun noBlockWrap f x =
(ensureOpen ();
if !blocking then blockingOff () else ();
- (SOME (f x)
- handle (e as PosixError.SysErr (_, SOME cause)) =>
- if cause = PosixError.again then NONE else raise e))
- val close =
+ (SOME (f x)
+ handle (e as PosixError.SysErr (_, SOME cause)) =>
+ if cause = PosixError.again then NONE else raise e))
+ val close =
fn () => if !closed then () else (closed := true; close fd)
- val avail =
+ val avail =
if isReg fd
- then fn () => if !closed
- then SOME 0
- else SOME (Position.toInt
- (Position.-
- (FS.ST.size (FS.fstat fd),
- !pos)))
- else fn () => if !closed then SOME 0 else NONE
- in
- RD {avail = avail,
- block = NONE,
- canInput = NONE,
- chunkSize = Primitive.TextIO.bufSize,
- close = close,
- endPos = endPos,
- getPos = getPos,
- ioDesc = SOME (FS.fdToIOD fd),
- name = name,
- readArr = SOME (blockWrap readArr),
- readArrNB = SOME (noBlockWrap readArr),
- readVec = SOME (blockWrap readVec),
- readVecNB = SOME (noBlockWrap readVec),
- setPos = setPos,
- verifyPos = verifyPos}
- end
- fun mkWriter {fd, name, initBlkMode, appendMode, chunkSize} =
- let
- val closed = ref false
- val {pos, getPos, setPos, endPos, verifyPos} =
- posFns (closed, fd)
- fun incPos k = (pos := Position.+ (!pos, Position.fromInt k); k)
- val blocking = ref initBlkMode
- val appendFlgs = O.flags(if appendMode then [O.append] else [])
- fun updateStatus () =
+ then fn () => if !closed
+ then SOME 0
+ else SOME (Position.toInt
+ (Position.-
+ (FS.ST.size (FS.fstat fd),
+ !pos)))
+ else fn () => if !closed then SOME 0 else NONE
+ val () = setMode (fdToInt fd)
+ in
+ RD {avail = avail,
+ block = NONE,
+ canInput = NONE,
+ chunkSize = Primitive.TextIO.bufSize,
+ close = close,
+ endPos = endPos,
+ getPos = getPos,
+ ioDesc = SOME (FS.fdToIOD fd),
+ name = name,
+ readArr = SOME (blockWrap readArr),
+ readArrNB = SOME (noBlockWrap readArr),
+ readVec = SOME (blockWrap readVec),
+ readVecNB = SOME (noBlockWrap readVec),
+ setPos = setPos,
+ verifyPos = verifyPos}
+ end
+ fun mkWriter {fd, name, initBlkMode, appendMode, chunkSize} =
+ let
+ val closed = ref false
+ val {pos, getPos, setPos, endPos, verifyPos} =
+ posFns (closed, fd)
+ fun incPos k = (pos := Position.+ (!pos, Position.fromInt k); k)
+ val blocking = ref initBlkMode
+ val appendFlgs = O.flags(if appendMode then [O.append] else [])
+ fun updateStatus () =
let
- val flgs = if !blocking
- then appendFlgs
- else O.flags [O.nonblock, appendFlgs]
+ val flgs = if !blocking
+ then appendFlgs
+ else O.flags [O.nonblock, appendFlgs]
in
- setfl(fd, flgs)
+ setfl(fd, flgs)
end
- fun ensureOpen () =
+ fun ensureOpen () =
if !closed then raise IO.ClosedStream else ()
- fun ensureBlock x =
+ fun ensureBlock x =
if !blocking then () else (blocking := x; updateStatus ())
- fun putV x = incPos (writeVec x)
- fun putA x = incPos (writeArr x)
- fun write (put, block) arg =
+ fun putV x = incPos (writeVec x)
+ fun putA x = incPos (writeArr x)
+ fun write (put, block) arg =
(ensureOpen (); ensureBlock block; put (fd, arg))
- fun handleBlock writer arg =
+ fun handleBlock writer arg =
SOME(writer arg)
handle (e as PosixError.SysErr (_, SOME cause)) =>
- if cause = PosixError.again then NONE else raise e
- val close =
+ if cause = PosixError.again then NONE else raise e
+ val close =
fn () => if !closed then () else (closed := true; close fd)
- in
- WR {block = NONE,
- canOutput = NONE,
- chunkSize = chunkSize,
- close = close,
- endPos = endPos,
- getPos = getPos,
- ioDesc = SOME (FS.fdToIOD fd),
- name = name,
- setPos = setPos,
- verifyPos = verifyPos,
- writeArr = SOME (write (putA, true)),
- writeArrNB = SOME (handleBlock (write (putA, false))),
- writeVec = SOME (write (putV, true)),
- writeVecNB = SOME (handleBlock (write (putV, false)))}
- end
- in
- {mkReader = mkReader, mkWriter = mkWriter}
- end
+ val () = setMode (fdToInt fd)
+ in
+ WR {block = NONE,
+ canOutput = NONE,
+ chunkSize = chunkSize,
+ close = close,
+ endPos = endPos,
+ getPos = getPos,
+ ioDesc = SOME (FS.fdToIOD fd),
+ name = name,
+ setPos = setPos,
+ verifyPos = verifyPos,
+ writeArr = SOME (write (putA, true)),
+ writeArrNB = SOME (handleBlock (write (putA, false))),
+ writeVec = SOME (write (putV, true)),
+ writeVecNB = SOME (handleBlock (write (putV, false)))}
+ end
in
- val {mkReader = mkBinReader, mkWriter = mkBinWriter} =
- make rwWord8 (BinPrimIO.RD, BinPrimIO.WR)
- val {mkReader = mkTextReader, mkWriter = mkTextWriter} =
- make rwChar (TextPrimIO.RD, TextPrimIO.WR)
+ {mkReader = mkReader,
+ mkWriter = mkWriter,
+ readArr = readArr,
+ readVec = readVec,
+ writeArr = writeArr,
+ writeVec = writeVec}
end
- end
+in
+ val {mkReader = mkBinReader, mkWriter = mkBinWriter,
+ readArr, readVec, writeArr, writeVec} =
+ make {RD = BinPrimIO.RD,
+ WR = BinPrimIO.WR,
+ fromVector = Word8Vector.fromPoly,
+ read = readWord8,
+ setMode = Prim.setbin,
+ toArraySlice = Word8ArraySlice.toPoly,
+ toVectorSlice = Word8VectorSlice.toPoly,
+ vectorLength = Word8Vector.length,
+ write = writeWord8,
+ writeVec = writeWord8Vec}
+ val {mkReader = mkTextReader, mkWriter = mkTextWriter, ...} =
+ make {RD = TextPrimIO.RD,
+ WR = TextPrimIO.WR,
+ fromVector = fn v => v,
+ read = readChar,
+ setMode = Prim.settext,
+ toArraySlice = CharArraySlice.toPoly,
+ toVectorSlice = CharVectorSlice.toPoly,
+ vectorLength = CharVector.length,
+ write = writeChar,
+ writeVec = writeCharVec}
+end
+
+end
1.29 +14 -12 mlton/basis-library/posix/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/primitive.sml,v
retrieving revision 1.28
retrieving revision 1.29
diff -u -r1.28 -r1.29
--- primitive.sml 27 Aug 2004 00:50:41 -0000 1.28
+++ primitive.sml 25 Nov 2004 01:35:48 -0000 1.29
@@ -540,18 +540,20 @@
val lseek =
_import "Posix_IO_lseek": fd * Position.int * int -> Position.int;
val pipe = _import "Posix_IO_pipe": fd array -> int;
- val readChar = _import "Posix_IO_read":
- fd * char array * int * size -> ssize;
- val writeChar = _import "Posix_IO_write":
- fd * char array * int * size -> ssize;
- val writeCharVec = _import "Posix_IO_write":
- fd * char vector * int * size -> ssize;
- val readWord8 = _import "Posix_IO_read":
- fd * word8 array * int * size -> ssize;
- val writeWord8 = _import "Posix_IO_write":
- fd * word8 array * int * size -> ssize;
- val writeWord8Vec = _import "Posix_IO_write":
- fd * word8 vector * int * size -> ssize;
+ val readChar =
+ _import "Posix_IO_read": fd * char array * int * size -> ssize;
+ val setbin = _import "Posix_IO_setbin": fd * bool -> unit;
+ val settext = _import "Posix_IO_settext": fd * bool -> unit;
+ val writeChar =
+ _import "Posix_IO_write": fd * char array * int * size -> ssize;
+ val writeCharVec =
+ _import "Posix_IO_write": fd * char vector * int * size -> ssize;
+ val readWord8 =
+ _import "Posix_IO_read": fd * word8 array * int * size -> ssize;
+ val writeWord8 =
+ _import "Posix_IO_write": fd * word8 array * int * size -> ssize;
+ val writeWord8Vec =
+ _import "Posix_IO_write": fd * word8 vector * int * size -> ssize;
end
structure SysDB =
1.4 +24 -27 mlton/basis-library/posix/process.sig
Index: process.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/process.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- process.sig 18 Mar 2004 00:32:44 -0000 1.3
+++ process.sig 25 Nov 2004 01:35:48 -0000 1.4
@@ -3,18 +3,11 @@
eqtype signal
eqtype pid
- val wordToPid: SysWord.word -> pid
- val pidToWord: pid -> SysWord.word
- val fork: unit -> pid option
- val exec: string * string list -> 'a
- val exece: string * string list * string list -> 'a
- val execp: string * string list -> 'a
-
- datatype waitpid_arg =
- W_ANY_CHILD
- | W_CHILD of pid
- | W_SAME_GROUP
- | W_GROUP of pid
+ structure W:
+ sig
+ include BIT_FLAGS
+ val untraced: flags
+ end
datatype exit_status =
W_EXITED
@@ -22,28 +15,32 @@
| W_SIGNALED of signal
| W_STOPPED of signal
- val fromStatus: OS.Process.status -> exit_status
-
- structure W :
- sig
- include BIT_FLAGS
- val untraced: flags
- end
-
- val wait: unit -> pid * exit_status
- val waitpid: waitpid_arg * W.flags list -> pid * exit_status
- val waitpid_nh: waitpid_arg * W.flags list -> (pid * exit_status) option
- val exit: Word8.word -> 'a
-
- datatype killpid_arg =
+ datatype killpid_arg =
K_PROC of pid
| K_SAME_GROUP
| K_GROUP of pid
- val kill: killpid_arg * signal -> unit
+ datatype waitpid_arg =
+ W_ANY_CHILD
+ | W_CHILD of pid
+ | W_SAME_GROUP
+ | W_GROUP of pid
+
val alarm: Time.time -> Time.time
+ val exec: string * string list -> 'a
+ val exece: string * string list * string list -> 'a
+ val execp: string * string list -> 'a
+ val exit: Word8.word -> 'a
+ val fork: unit -> pid option
+ val fromStatus: OS.Process.status -> exit_status
+ val kill: killpid_arg * signal -> unit
val pause: unit -> unit
+ val pidToWord: pid -> SysWord.word
val sleep: Time.time -> Time.time
+ val wait: unit -> pid * exit_status
+ val waitpid: waitpid_arg * W.flags list -> pid * exit_status
+ val waitpid_nh: waitpid_arg * W.flags list -> (pid * exit_status) option
+ val wordToPid: SysWord.word -> pid
end
signature POSIX_PROCESS_EXTRA =
1.26 +1 -10 mlton/basis-library/posix/process.sml
Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/process.sml,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -r1.25 -r1.26
--- process.sml 27 Aug 2004 00:50:41 -0000 1.25
+++ process.sml 25 Nov 2004 01:35:48 -0000 1.26
@@ -18,8 +18,6 @@
val wordToPid = Pid.fromInt o SysWord.toInt
val pidToWord = SysWord.fromInt o Pid.toInt
- structure MLton = Primitive.MLton
-
fun fork () =
SysCall.syscall
(fn () =>
@@ -30,14 +28,7 @@
end)
val fork =
- if let
- open MLton.Platform.OS
- in
- case host of
- Cygwin => true
- | MinGW => true
- | _ => false
- end
+ if Primitive.MLton.Platform.OS.useWindowsProcess
then (fn () => Error.raiseSys Error.nosys)
else fork
1.4 +8 -0 mlton/basis-library/system/process.sig
Index: process.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/process.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- process.sig 3 Jul 2003 17:10:07 -0000 1.3
+++ process.sig 25 Nov 2004 01:35:48 -0000 1.4
@@ -17,5 +17,13 @@
sig
include OS_PROCESS
+ structure Status:
+ sig
+ type t
+
+ val fromInt: int -> t
+ val fromPosix: Posix.Process.exit_status -> t
+ end
+
val wait: Posix.Process.pid -> status
end
1.14 +19 -9 mlton/basis-library/system/process.sml
Index: process.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/process.sml,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -r1.13 -r1.14
--- process.sml 13 Feb 2004 17:05:55 -0000 1.13
+++ process.sml 25 Nov 2004 01:35:48 -0000 1.14
@@ -15,23 +15,33 @@
struct
open Posix.Process
- structure Status = Primitive.Status
-
structure Signal = MLtonSignal
+ structure Status =
+ struct
+ open Primitive.Status
+
+ val fromPosix =
+ fn es =>
+ let
+ datatype z = datatype Posix.Process.exit_status
+ in
+ case es of
+ W_EXITED => success
+ | W_EXITSTATUS w => fromInt (Word8.toInt w)
+ | W_SIGNALED _ => failure
+ | W_STOPPED _ => failure
+ end
+ end
+
type status = Status.t
val failure = Status.failure
val success = Status.success
-
fun isSuccess st = st = success
-
+
fun wait (pid: Pid.t): Status.t =
- case #2 (waitpid (W_CHILD pid, [])) of
- W_EXITED => success
- | W_EXITSTATUS w => Status.fromInt (Word8.toInt w)
- | W_SIGNALED _ => failure
- | W_STOPPED _ => failure
+ Status.fromPosix (#2 (waitpid (W_CHILD pid, [])))
fun system cmd =
let
1.9 +52 -151 mlton/basis-library/system/unix.sml
Index: unix.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/system/unix.sml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- unix.sml 19 Nov 2004 02:47:56 -0000 1.8
+++ unix.sml 25 Nov 2004 01:35:48 -0000 1.9
@@ -1,158 +1,59 @@
-(* Modified from SML/NJ sources by sweeks@research.nj.nec.com on 1998-9-4.
- * changed 1. signals
- * 2. IO
- * Further modified by sweeks@acm.org on 1999-12-10.
- * 1. Put back support for Signals
- * Further modified by fluet@cs.cornell.edu on 2002-10-15.
- * 1. Adapted for new Basis Library specification.
- *)
-
-(* unix.sml
- *
- * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
+(* Copyright (C) 2004 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
*
+ * MLton is released under the GNU General Public License (GPL).
+ * Please see the file MLton-LICENSE for license information.
+ *
+ * Rewritten by wesley@terpstra.ca on 2004-11-23 to use MLtonProcess for the
+ * implementation.
*)
structure Unix: UNIX =
- struct
- open Posix
+struct
- structure Status = Primitive.Status
+structure Status = OS_Process.Status
+structure Process = MLtonProcess
+local
+ open Process
+in
+ structure Child = Child
+ structure Param = Param
+end
+
+type signal = Posix.Signal.signal
+datatype exit_status = datatype Posix.Process.exit_status
+
+val fromStatus = Posix.Process.fromStatus
+
+type ('in, 'out) proc = ('out, 'in, Process.none) Process.t
- type signal = Signal.signal
- datatype exit_status = datatype Process.exit_status
- val fromStatus = Process.fromStatus
-
- structure Mask = MLtonSignal.Mask
-
- fun ('a, 'b) protect (f: 'a -> 'b) (x: 'a): 'b =
- let
- val _ = Mask.block Mask.all
- in
- DynamicWind.wind (fn () => f x, fn () => Mask.unblock Mask.all)
- end
-
- datatype 'a str =
- FD of FileSys.file_desc
- | STR of 'a * ('a -> unit)
-
- fun close str =
- case str of
- FD fd => IO.close fd
- | STR (str, close) => close str
+local
+ fun create {args, env, path} =
+ Process.create {args = args,
+ env = env,
+ path = path,
+ stderr = Param.self,
+ stdin = Param.pipe,
+ stdout = Param.pipe}
+in
+ fun execute (path, args) =
+ create {args = args, env = NONE, path = path}
+ fun executeInEnv (path, args, env) =
+ create {args = args, env = SOME env, path = path}
+end
- datatype ('a, 'b) proc =
- PROC of {ins: 'a str ref,
- outs: 'b str ref,
- pid: Process.pid,
- status: OS.Process.status option ref}
-
- fun executeInEnv (cmd, argv, env) =
- if not (FileSys.access (cmd, [FileSys.A_EXEC]))
- then PosixError.raiseSys PosixError.noent
- else
- let
- val p1 = IO.pipe ()
- val p2 = IO.pipe ()
- fun closep () =
- (IO.close (#outfd p1)
- ; IO.close (#infd p1)
- ; IO.close (#outfd p2)
- ; IO.close (#infd p2))
- val base =
- Substring.string (Substring.taker (fn c => c <> #"/")
- (Substring.full cmd))
- fun startChild () =
- case protect Process.fork () of
- SOME pid => pid (* parent *)
- | NONE =>
- let
- val oldin = #infd p1
- val oldout = #outfd p2
- val newin = FileSys.stdin
- val newout = FileSys.stdout
- in
- IO.close (#outfd p1)
- ; IO.close (#infd p2)
- ; if oldin = newin
- then ()
- else (IO.dup2{old = oldin, new = newin}
- ; IO.close oldin)
- ; if oldout = newout
- then ()
- else (IO.dup2{old = oldout, new = newout}
- ; IO.close oldout)
- ; Process.exece (cmd, base :: argv, env)
- end
- val _ = TextIO.flushOut TextIO.stdOut
- val pid = (startChild ()) handle ex => (closep(); raise ex)
- fun cloexec fd = IO.setfd (fd, IO.FD.flags [IO.FD.cloexec])
- in
- IO.close (#outfd p2)
- ; IO.close (#infd p1)
- ; cloexec (#infd p2)
- ; cloexec (#outfd p1)
- ; PROC {ins = ref (FD (#infd p2)),
- outs = ref (FD (#outfd p1)),
- pid = pid,
- status = ref NONE}
- end
-
- fun execute (cmd, argv) = executeInEnv (cmd, argv, ProcEnv.environ ())
-
- local
- fun mkInstreamOf (newIn, closeIn) (PROC {ins, ...}) =
- case !ins of
- FD fd =>
- let
- val str = newIn (fd, "<process>")
- val () = ins := STR (str, closeIn)
- in
- str
- end
- | STR (str, _) => str
- fun mkOutstreamOf (newOut, closeOut) (PROC {outs, ...}) =
- case !outs of
- FD fd =>
- let
- val str = newOut (fd, "<process>")
- val () = outs := STR (str, closeOut)
- in
- str
- end
- | STR (str, _) => str
- in
- fun textInstreamOf proc =
- mkInstreamOf (TextIO.newIn, TextIO.closeIn) proc
- fun textOutstreamOf proc =
- mkOutstreamOf (TextIO.newOut, TextIO.closeOut) proc
- fun binInstreamOf proc =
- mkInstreamOf (BinIO.newIn, BinIO.closeIn) proc
- fun binOutstreamOf proc =
- mkOutstreamOf (BinIO.newOut, BinIO.closeOut) proc
- end
-
- fun streamsOf pr = (textInstreamOf pr, textOutstreamOf pr)
-
- fun reap (PROC {pid, status, ins, outs}) =
- case !status of
- NONE =>
- let
- val _ = close (!ins)
- val _ = close (!outs)
- (* protect is probably too much; typically, one
- * would only mask SIGINT, SIGQUIT and SIGHUP
- *)
- val st = protect OS.Process.wait pid
- val _ = status := SOME st
- in
- st
- end
- | SOME status => status
-
- fun kill (PROC {pid, ...}, signal) =
- Process.kill (Process.K_PROC pid, signal)
-
- fun exit (w: Word8.word): 'a =
- OS.Process.exit (Status.fromInt (Word8.toInt w))
- end
+fun binInstreamOf proc = Child.binIn (Process.getStdout proc)
+fun binOutstreamOf proc = Child.binOut (Process.getStdin proc)
+fun textInstreamOf proc = Child.textIn (Process.getStdout proc)
+fun textOutstreamOf proc = Child.textOut (Process.getStdin proc)
+
+fun streamsOf pr = (textInstreamOf pr, textOutstreamOf pr)
+
+val kill = Process.kill
+
+fun reap z = Status.fromPosix (Process.reap z)
+
+fun exit (w: Word8.word): 'a =
+ OS.Process.exit (Status.fromInt (Word8.toInt w))
+
+end
1.140 +9 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.139
retrieving revision 1.140
diff -u -r1.139 -r1.140
--- changelog 10 Nov 2004 21:30:39 -0000 1.139
+++ changelog 25 Nov 2004 01:35:48 -0000 1.140
@@ -1,3 +1,12 @@
+Here are the changes since version 20041109.
+
+* 2004-11-24
+ - Added support for MLton.Process.create, which works on all
+ platforms (including Windows-based ones like Cygwin and MinGW) and
+ allows better control over std{in,out,err} for child process.
+
+--------------------------------------------------------------------------------
+
Here are the changes from version 20040227 to 20041109.
Summary:
1.22 +1 -0 mlton/lib/mlton-stubs/mlton.sig
Index: mlton.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sig,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -r1.21 -r1.22
--- mlton.sig 27 Sep 2004 22:52:09 -0000 1.21
+++ mlton.sig 25 Nov 2004 01:35:48 -0000 1.22
@@ -24,6 +24,7 @@
structure Array: MLTON_ARRAY
structure BinIO: MLTON_BIN_IO
+ structure CallStack: MLTON_CALL_STACK
structure Cont: MLTON_CONT
structure Exn: MLTON_EXN
structure Finalizable: MLTON_FINALIZABLE
1.39 +52 -0 mlton/lib/mlton-stubs/mlton.sml
Index: mlton.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/mlton.sml,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -r1.38 -r1.39
--- mlton.sml 27 Sep 2004 22:52:09 -0000 1.38
+++ mlton.sml 25 Nov 2004 01:35:48 -0000 1.39
@@ -83,6 +83,15 @@
fun setIn _ = raise Fail "setIn"
end
+ structure CallStack =
+ struct
+ type t = unit
+
+ val keep = false
+ fun current () = ()
+ fun toStrings () = []
+ end
+
structure Cont =
struct
type 'a t = unit
@@ -214,6 +223,7 @@
val add = fn _ => raise Fail "Pointer.add"
val compare = fn _ => raise Fail "Pointer.compare"
val diff = fn _ => raise Fail "Pointer.diff"
+ val free = fn _ => raise Fail "Pointer.free"
val getInt8 = fn _ => raise Fail "Pointer.getInt8"
val getInt16 = fn _ => raise Fail "Pointer.getInt16"
val getInt32 = fn _ => raise Fail "Pointer.getInt32"
@@ -248,6 +258,48 @@
structure Process =
struct
+ type ('stdin, 'stdout, 'stderr) t = unit
+ type input = unit
+ type output = unit
+ type none = unit
+ type chain = unit
+ type any = unit
+
+ exception MisuseOfForget
+ exception DoublyRedirected
+
+ structure Child =
+ struct
+ type ('use, 'dir) t = unit
+
+ val binIOin = fn _ => raise Fail "Child.binIOin"
+ val binIOout = fn _ => raise Fail "Child.binIOout"
+ val fd = fn _ => raise Fail "Child.fd"
+ val remember = fn _ => raise Fail "Child.remember"
+ val textIOin = fn _ => raise Fail "Child.textIOin"
+ val textIOout = fn _ => raise Fail "Child.textIOout"
+ end
+
+ structure Param =
+ struct
+ type ('use, 'dir) t = unit
+
+ val child = fn _ => raise Fail "Param.child"
+ val fd = fn _ => raise Fail "Param.fd"
+ val file = fn _ => raise Fail "Param.file"
+ val forget = fn _ => raise Fail "Param.forget"
+ val null = ()
+ val pipe = ()
+ val self = ()
+ end
+
+ val create = fn _ => raise Fail "Process.create"
+ val getStderr = fn _ => raise Fail "Process.getStderr"
+ val getStdin = fn _ => raise Fail "Process.getStdin"
+ val getStdout = fn _ => raise Fail "Process.getStdout"
+ val kill = fn _ => raise Fail "Process.kill"
+ val reap = fn _ => raise Fail "Process.reap"
+
type pid = Posix.Process.pid
val atExit = OS.Process.atExit
1.4 +1 -0 mlton/lib/mlton-stubs/pointer.sig
Index: pointer.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/pointer.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- pointer.sig 27 Sep 2004 22:52:09 -0000 1.3
+++ pointer.sig 25 Nov 2004 01:35:48 -0000 1.4
@@ -5,6 +5,7 @@
val add: t * word -> t
val compare: t * t -> order
val diff: t * t -> word
+ val free: t -> unit
val getInt8: t * int -> Int8.int
val getInt16: t * int -> Int16.int
val getInt32: t * int -> Int32.int
1.6 +62 -2 mlton/lib/mlton-stubs/process.sig
Index: process.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/process.sig,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- process.sig 28 Feb 2004 01:55:14 -0000 1.5
+++ process.sig 25 Nov 2004 01:35:48 -0000 1.6
@@ -2,7 +2,67 @@
sig
type pid
- val spawn: {path: string, args: string list} -> pid
- val spawne: {path: string, args: string list, env: string list} -> pid
+ (* Process handle *)
+ type ('stdin, 'stdout, 'stderr) t
+
+ (* is the io 'dir input or output *)
+ type input
+ type output
+
+ (* to what use can the stdio channel be put *)
+ type none (* it's not connected to a pipe *)
+ type chain (* connect one child to another *)
+ type any (* any use is allowed -- dangerous *)
+
+ exception MisuseOfForget (* you avoided the type safety and broke it *)
+ exception DoublyRedirected (* you tried to reuse a Param.child *)
+
+ structure Child:
+ sig
+ type ('use, 'dir) t
+
+ val binIn: (BinIO.instream, input) t -> BinIO.instream
+ val binOut: (BinIO.outstream, output) t -> BinIO.outstream
+ (* not necessarily available on all systems; may raise an exception *)
+ val fd: (Posix.FileSys.file_desc, 'dir) t -> Posix.FileSys.file_desc
+ (* used for situations where 'forget' was needed for arbitrary redir *)
+ val remember: (any, 'dir) t -> ('use, 'dir) t
+ val textIn: (TextIO.instream, input) t -> TextIO.instream
+ val textOut: (TextIO.outstream, output) t -> TextIO.outstream
+ end
+
+ structure Param:
+ sig
+ type ('use, 'dir) t
+
+ (* {child,fd} close their parameter when create is called.
+ * therefore they may only be used once!
+ *)
+ val child: (chain, 'dir) Child.t -> (none, 'dir) t
+ (* Not necessarily available on all systems; may raise an exception *)
+ val fd: Posix.FileSys.file_desc -> (none, 'dir) t
+ val file: string -> (none, 'dir) t
+ (* used if you want to return two posibilities; use with care *)
+ val forget: ('use, 'dir) t -> (any, 'dir) t
+ val null: (none, 'dir) t
+ val pipe: ('use, 'dir) t
+ val self: (none, 'dir) t
+ end
+
+ val create:
+ {args: string list,
+ env: string list option,
+ path: string,
+ stderr: ('stderr, output) Param.t,
+ stdin: ('stdin, input) Param.t,
+ stdout: ('stdout, output) Param.t}
+ -> ('stdin, 'stdout, 'stderr) t
+ val getStderr: ('stdin, 'stdout, 'stderr) t -> ('stderr, input) Child.t
+ val getStdin: ('stdin, 'stdout, 'stderr) t -> ('stdin, output) Child.t
+ val getStdout: ('stdin, 'stdout, 'stderr) t -> ('stdout, input) Child.t
+ val kill: ('stdin, 'stdout, 'stderr) t * Posix.Signal.signal -> unit
+ val reap: ('stdin, 'stdout, 'stderr) t -> Posix.Process.exit_status
+ val spawn: {args: string list, path: string} -> pid
+ val spawne: {args: string list, env: string list, path: string} -> pid
val spawnp: {file: string, args: string list} -> pid
end
1.19 +1 -0 mlton/lib/mlton-stubs/sources.cm
Index: sources.cm
===================================================================
RCS file: /cvsroot/mlton/mlton/lib/mlton-stubs/sources.cm,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -r1.18 -r1.19
--- sources.cm 4 Apr 2004 05:45:31 -0000 1.18
+++ sources.cm 25 Nov 2004 01:35:48 -0000 1.19
@@ -63,6 +63,7 @@
../mlton-stubs-in-smlnj/sources.cm
+call-stack.sig
thread.sig
thread.sml
world.sig
1.1 mlton/lib/mlton-stubs/call-stack.sig
Index: call-stack.sig
===================================================================
signature MLTON_CALL_STACK =
sig
type t
val keep: bool
val current: unit -> t
val toStrings: t -> string list
end
1.231 +21 -63 mlton/runtime/gc.c
Index: gc.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/gc.c,v
retrieving revision 1.230
retrieving revision 1.231
diff -u -r1.230 -r1.231
--- gc.c 12 Nov 2004 23:48:12 -0000 1.230
+++ gc.c 25 Nov 2004 01:35:49 -0000 1.231
@@ -38,7 +38,6 @@
DEBUG_ENTER_LEAVE = FALSE,
DEBUG_GENERATIONAL = FALSE,
DEBUG_MARK_COMPACT = FALSE,
- DEBUG_MEM = FALSE,
DEBUG_RESIZING = FALSE,
DEBUG_SHARE = FALSE,
DEBUG_SIZE = FALSE,
@@ -185,42 +184,22 @@
/* Virtual Memory Management */
/* ---------------------------------------------------------------- */
-static void *mmapAnon (void *start, size_t length) {
-#if USE_MMAP
- static int fd = -1;
- int flags;
-#endif
- void *result;
+static inline void *GC_mmapAnon (void *start, size_t length) {
+ void *res;
-#if USE_VIRTUAL_ALLOC
- result = VirtualAlloc ((LPVOID)start, length, MEM_COMMIT,
- PAGE_READWRITE);
- if (NULL == result)
- result = (void*)-1;
-#elif USE_MMAP
- flags = MAP_PRIVATE | MAP_ANON;
-#if (defined (__sun__))
- /* On Solaris 5.7, MAP_ANON causes EINVAL and mmap requires a file
- * descriptor.
- */
- flags &= ~MAP_ANON;
- if (-1 == fd)
- fd = open ("/dev/zero", O_RDONLY);
-#endif
- result = mmap (start, length, PROT_READ | PROT_WRITE, flags, fd, 0);
-#endif
+ res = mmapAnon (start, length);
if (DEBUG_MEM)
fprintf (stderr, "0x%08x = mmapAnon (0x%08x, %s)\n",
- (uint)result,
+ (uint)res,
(uint)start,
uintToCommaString (length));
- return result;
+ return res;
}
void *smmap (size_t length) {
void *result;
- result = mmapAnon (NULL, length);
+ result = GC_mmapAnon (NULL, length);
if ((void*)-1 == result) {
showMem ();
die ("Out of memory.");
@@ -228,44 +207,18 @@
return result;
}
-#if USE_MMAP
-static void smunmap (void *base, size_t length) {
- if (DEBUG_MEM)
- fprintf (stderr, "smunmap (0x%08x, %s)\n",
- (uint)base,
- uintToCommaString (length));
- assert (base != NULL);
- if (0 == length)
- return;
- if (0 != munmap (base, length))
- diee ("munmap failed");
-}
-#endif
-
-static void release (void *base, size_t length) {
+static inline void GC_release (void *base, size_t length) {
if (DEBUG_MEM)
fprintf (stderr, "release (0x%08x, %s)\n",
(uint)base, uintToCommaString (length));
-#if USE_VIRTUAL_ALLOC
- if (0 == VirtualFree (base, 0, MEM_RELEASE))
- die ("VirtualFree release failed");
-#elif USE_MMAP
- smunmap (base, length);
-#endif
+ release (base, length);
}
-static void decommit (void *base, size_t length) {
+static inline void GC_decommit (void *base, size_t length) {
if (DEBUG_MEM)
fprintf (stderr, "decommit (0x%08x, %s)\n",
(uint)base, uintToCommaString (length));
-#if USE_VIRTUAL_ALLOC
- if (0 == VirtualFree (base, length, MEM_DECOMMIT))
- die ("VirtualFree decommit failed");
-#elif USE_MMAP
- smunmap (base, length);
-#else
-#error decommit not defined
-#endif
+ decommit (base, length);
}
static inline void copy (pointer src, pointer dst, uint size) {
@@ -1185,7 +1138,7 @@
fprintf (stderr, "Releasing heap at 0x%08x of size %s.\n",
(uint)h->start,
uintToCommaString (h->size));
- release (h->start, h->size);
+ GC_release (h->start, h->size);
heapInit (h);
}
@@ -1203,7 +1156,7 @@
(uint)h->start,
uintToCommaString (h->size),
uintToCommaString (keep));
- decommit (h->start + keep, h->size - keep);
+ GC_decommit (h->start + keep, h->size - keep);
h->size = keep;
}
}
@@ -1370,11 +1323,11 @@
address = 0;
i = 31;
#endif
- h->start = mmapAnon ((void*)address, h->size);
+ h->start = GC_mmapAnon ((void*)address, h->size);
if ((void*)-1 == h->start)
h->start = (void*)NULL;
unless ((void*)NULL == h->start) {
- direction = (direction==0);
+ direction = (0 == direction);
if (h->size > s->maxHeapSizeSeen)
s->maxHeapSizeSeen = h->size;
if (DEBUG or s->messages)
@@ -1665,7 +1618,7 @@
}
for (i = 0; i < cardIndex; ++i)
assert (m[i] == s->crossMap[i]);
- release (m, s->crossMapSize);
+ GC_release (m, s->crossMapSize);
return TRUE;
}
@@ -2957,7 +2910,7 @@
min (s->crossMapSize, oldCrossMapSize));
if (DEBUG_MEM)
fprintf (stderr, "Releasing card/cross map.\n");
- release (oldCardMap, oldCardMapSize + oldCrossMapSize);
+ GC_release (oldCardMap, oldCardMapSize + oldCrossMapSize);
}
}
@@ -4383,6 +4336,8 @@
/* GC_init */
/* ---------------------------------------------------------------- */
+Bool MLton_Platform_CygwinUseMmap;
+
static int processAtMLton (GC_state s, int argc, char **argv,
string *worldFile) {
int i;
@@ -4505,6 +4460,8 @@
die ("@MLton thread-shrink-ratio missing argument.");
s->threadShrinkRatio =
stringToFloat (argv[i++]);
+ } else if (0 == strcmp (arg, "use-mmap")) {
+ MLton_Platform_CygwinUseMmap = TRUE;
} else if (0 == strcmp (arg, "--")) {
++i;
done = TRUE;
@@ -4526,6 +4483,7 @@
s->alignment));
assert (isAligned (GC_NORMAL_HEADER_SIZE + sizeof (struct GC_weak),
s->alignment));
+ MLton_Platform_CygwinUseMmap = FALSE;
s->amInGC = TRUE;
s->amInMinorGC = FALSE;
s->bytesAllocated = 0;
1.10 +10 -0 mlton/runtime/platform.h
Index: platform.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform.h,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- platform.h 18 Oct 2004 17:03:51 -0000 1.9
+++ platform.h 25 Nov 2004 01:35:49 -0000 1.10
@@ -153,6 +153,7 @@
#endif
enum {
+ DEBUG_MEM = FALSE,
DEBUG_SIGNALS = FALSE,
};
@@ -182,7 +183,10 @@
Word32 totalRam (GC_state s);
string boolToString (bool b);
+void decommit (void *base, size_t length);
string intToCommaString (int n);
+void *mmapAnon (void *start, size_t length);
+void release (void *base, size_t length);
void *scalloc (size_t nmemb, size_t size);
void sclose (int fd);
void sfclose (FILE *file);
@@ -370,6 +374,8 @@
#error MLton_Platform_Arch_host not defined
#endif
+extern Bool MLton_Platform_CygwinUseMmap;
+
/* ---------------------------------- */
/* MLton.Profile */
/* ---------------------------------- */
@@ -386,6 +392,8 @@
/* MLton.Process */
/* ---------------------------------- */
+Pid MLton_Process_create (NullString cmds, NullString envs,
+ Fd in, Fd out, Fd err);
Int MLton_Process_spawne (NullString p, Pointer a, Pointer e);
Int MLton_Process_spawnp (NullString p, Pointer a);
@@ -695,6 +703,8 @@
Position Posix_IO_lseek (Fd f, Position i, Int j);
Int Posix_IO_pipe (Pointer fds);
Ssize Posix_IO_read (Fd fd, Pointer b, Int i, Size s);
+void Posix_IO_setbin (Fd fd, Bool useWindows);
+void Posix_IO_settext (Fd fd, Bool useWindows);
Ssize Posix_IO_write (Fd fd, Pointer b, Int i, Size s);
/* ---------------------------------- */
1.4 +25 -0 mlton/runtime/platform/cygwin.c
Index: cygwin.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/cygwin.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- cygwin.c 8 Oct 2004 18:10:33 -0000 1.3
+++ cygwin.c 25 Nov 2004 01:35:49 -0000 1.4
@@ -1,6 +1,31 @@
#include "platform.h"
+#include "create.c"
#include "getrusage.c"
#include "mkdir2.c"
+#include "mmap.c"
+#include "setbintext.c"
#include "showMem.win32.c"
#include "totalRam.sysconf.c"
+#include "virtualAlloc.c"
+
+void decommit (void *base, size_t length) {
+ if (MLton_Platform_CygwinUseMmap)
+ smunmap (base, length);
+ else
+ decommitVirtual (base, length);
+}
+
+void *mmapAnon (void *start, size_t length) {
+ if (MLton_Platform_CygwinUseMmap)
+ return mmapAnonMmap (start, length);
+ else
+ return mmapAnonVirtual (start, length);
+}
+
+void release (void *base, size_t length) {
+ if (MLton_Platform_CygwinUseMmap)
+ smunmap (base, length);
+ else
+ releaseVirtual (base);
+}
1.6 +3 -0 mlton/runtime/platform/cygwin.h
Index: cygwin.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/cygwin.h,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- cygwin.h 27 Sep 2004 22:52:13 -0000 1.5
+++ cygwin.h 25 Nov 2004 01:35:49 -0000 1.6
@@ -18,6 +18,7 @@
#include <syslog.h>
#include <termios.h>
#include <windows.h>
+#include <io.h>
#include "gmp.h"
@@ -51,3 +52,5 @@
struct sockaddr_in6 {};
+int _setmode (int, int);
+HANDLE _get_osfhandle (int fd);
1.4 +2 -3 mlton/runtime/platform/darwin.c
Index: darwin.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/darwin.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- darwin.c 8 Oct 2004 18:10:33 -0000 1.3
+++ darwin.c 25 Nov 2004 01:35:49 -0000 1.4
@@ -6,6 +6,8 @@
#include "getrusage.c"
#include "mkdir2.c"
+#include "ssmmap.c"
+#include "use-mmap.c"
void *getTextEnd () {
return (void*)(get_etext ());
@@ -23,14 +25,11 @@
void showMem () {
/* FIXME: this won't actually work. */
-
static char buffer[256];
sprintf (buffer, "/bin/cat /proc/%d/map\n", (int)getpid ());
(void)system (buffer);
}
-
-#include "ssmmap.c"
W32 totalRam (GC_state s) {
int mem;
1.5 +2 -2 mlton/runtime/platform/freebsd.c
Index: freebsd.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/freebsd.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- freebsd.c 8 Oct 2004 18:10:33 -0000 1.4
+++ freebsd.c 25 Nov 2004 01:35:49 -0000 1.5
@@ -3,6 +3,8 @@
#include "getrusage.c"
#include "getText.c"
#include "mkdir2.c"
+#include "ssmmap.c"
+#include "use-mmap.c"
void showMem () {
static char buffer[256];
@@ -10,8 +12,6 @@
sprintf (buffer, "/bin/cat /proc/%d/map\n", (int)getpid ());
(void)system (buffer);
}
-
-#include "ssmmap.c"
W32 totalRam (GC_state s) {
int mem, len;
1.5 +1 -0 mlton/runtime/platform/linux.c
Index: linux.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/linux.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- linux.c 8 Oct 2004 18:10:33 -0000 1.4
+++ linux.c 25 Nov 2004 01:35:49 -0000 1.5
@@ -5,6 +5,7 @@
#include "showMem.linux.c"
#include "ssmmap.c"
#include "totalRam.sysconf.c"
+#include "use-mmap.c"
/* Work around Linux kernel bugs associated with the user and system times. */
1.7 +67 -4 mlton/runtime/platform/mingw.c
Index: mingw.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/mingw.c,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- mingw.c 8 Oct 2004 18:10:33 -0000 1.6
+++ mingw.c 25 Nov 2004 01:35:49 -0000 1.7
@@ -1,6 +1,13 @@
#include "platform.h"
+#include "create.c"
+#include "setbintext.c"
#include "showMem.win32.c"
+#include "virtualAlloc.c"
+
+void decommit (void *base, size_t length) {
+ decommitVirtual (base, length);
+}
int getpagesize (void) {
SYSTEM_INFO sysinfo;
@@ -23,6 +30,14 @@
return _open (file_name, _O_CREAT | _O_RDWR, _S_IREAD | _S_IWRITE);
}
+void *mmapAnon (void *start, size_t length) {
+ return mmapAnonVirtual (start, length);
+}
+
+void release (void *base, size_t length) {
+ releaseVirtual (base);
+}
+
Word32 totalRam (GC_state s) {
MEMORYSTATUS memStat;
@@ -235,7 +250,35 @@
}
int pipe (int filedes[2]) {
- die ("pipe not implemented");
+ HANDLE read;
+ HANDLE write;
+
+ /* We pass no security attributes (0), so the current policy gets
+ * inherited. The pipe is set to NOT stay open in child processes.
+ * This will be corrected using DuplicateHandle in create()
+ * The 4k buffersize is choosen b/c that's what linux uses.
+ */
+ if (!CreatePipe(&read, &write, 0, 4096)) {
+ errno = ENOMEM; /* fake errno: out of resources */
+ return -1;
+ }
+ /* This requires Win98+
+ * Choosing text/binary mode is defered till a later setbin/text call
+ */
+ filedes[0] = _open_osfhandle((long)read, _O_RDONLY);
+ filedes[1] = _open_osfhandle((long)write, _O_WRONLY);
+ if (filedes[0] == -1 || filedes[1] == -1) {
+ if (filedes[0] == -1)
+ CloseHandle(read);
+ else close(filedes[0]);
+ if (filedes[1] == -1)
+ CloseHandle(write);
+ else close(filedes[1]);
+
+ errno = ENFILE;
+ return -1;
+ }
+ return 0;
}
/* ------------------------------------------------- */
@@ -281,6 +324,9 @@
int setgid (gid_t gid) {
die ("setgid not implemented");
}
+int setpgid (pid_t pid, pid_t pgid) {
+ die ("setpgid not implemented");
+}
pid_t setsid (void) {
die ("setsid not implemented");
}
@@ -381,7 +427,19 @@
}
int kill (pid_t pid, int sig) {
- die ("kill not implemented");
+ HANDLE h;
+
+ h = (HANDLE)pid;
+ /* We terminate with 'sig' for the _return_ code + 0x80
+ * Then in the basis library I test for this to decide W_SIGNALED.
+ * Perhaps not the best choice, but I have no better idea.
+ */
+ if (!TerminateProcess(h, sig | 0x80)) {
+ errno = ECHILD;
+ return -1;
+ }
+
+ return 0;
}
int pause (void) {
@@ -389,7 +447,8 @@
}
unsigned int sleep (unsigned int seconds) {
- die ("int not implemented");
+ Sleep (seconds * 1000);
+ return 0;
}
pid_t wait (int *status) {
@@ -397,7 +456,11 @@
}
pid_t waitpid (pid_t pid, int *status, int options) {
- return _cwait (status, pid, options);
+ HANDLE h;
+
+ h = (HANDLE)pid;
+ /* -1 on error, the casts here are due to bad types on both sides */
+ return _cwait(status, (_pid_t)h, 0);
}
/* ------------------------------------------------- */
1.9 +1 -0 mlton/runtime/platform/mingw.h
Index: mingw.h
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/mingw.h,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- mingw.h 8 Oct 2004 18:10:33 -0000 1.8
+++ mingw.h 25 Nov 2004 01:35:49 -0000 1.9
@@ -260,6 +260,7 @@
uid_t getuid (void);
int setenv (const char *name, const char *value, int overwrite);
int setgid (gid_t gid);
+int setpgid (pid_t pid, pid_t pgid);
pid_t setsid (void);
int setuid (uid_t uid);
long sysconf (int name);
1.5 +1 -0 mlton/runtime/platform/netbsd.c
Index: netbsd.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/netbsd.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- netbsd.c 8 Oct 2004 18:10:33 -0000 1.4
+++ netbsd.c 25 Nov 2004 01:35:49 -0000 1.5
@@ -6,3 +6,4 @@
#include "showMem.linux.c"
#include "ssmmap.c"
#include "totalRam.sysctl.c"
+#include "use-mmap.c"
1.5 +1 -0 mlton/runtime/platform/openbsd.c
Index: openbsd.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/openbsd.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- openbsd.c 8 Oct 2004 18:10:33 -0000 1.4
+++ openbsd.c 25 Nov 2004 01:35:49 -0000 1.5
@@ -6,3 +6,4 @@
#include "showMem.linux.c"
#include "ssmmap.c"
#include "totalRam.sysctl.c"
+#include "use-mmap.c"
1.5 +18 -0 mlton/runtime/platform/solaris.c
Index: solaris.c
===================================================================
RCS file: /cvsroot/mlton/mlton/runtime/platform/solaris.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- solaris.c 8 Oct 2004 18:10:33 -0000 1.4
+++ solaris.c 25 Nov 2004 01:35:49 -0000 1.5
@@ -3,8 +3,26 @@
#include "getrusage.c"
#include "getText.c"
#include "mkdir2.c"
+#include "mmap.c"
#include "ssmmap.c"
#include "totalRam.sysconf.c"
+
+void decommit (void *base, size_t length) {
+ smunmap (base, length);
+}
+
+/* On Solaris 5.7, MAP_ANON causes EINVAL and mmap requires a file descriptor. */
+void *mmapAnon (void *start, size_t length) {
+ static int fd = -1;
+
+ if (-1 == fd)
+ fd = open ("/dev/zero", O_RDONLY);
+ return mmap (start, length, PROT_READ | PROT_WRITE, MAP_PRIVATE, fd, 0);
+}
+
+void release (void *base, size_t length) {
+ smunmap (base, length);
+}
/* This implementation of setenv has a space leak, but I don't see how to avoid
* it, since the specification of putenv is that it uses the memory for its arg.
1.1 mlton/runtime/platform/create.c
Index: create.c
===================================================================
static HANDLE dupHandle (int fd) {
HANDLE raw, dupd;
raw = (HANDLE)_get_osfhandle (fd);
if (raw == (HANDLE)-1 || raw == 0) {
errno = EBADF;
return 0;
}
/* 'Inspired' by http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dllproc/base/creating_a_child_process_with_redirected_input_and_output.asp
* It's interesting that you can open files for/from other processes...
*/
unless (DuplicateHandle (
GetCurrentProcess(), /* source process */
raw, /* source handle */
GetCurrentProcess(), /* target process */
&dupd, /* target handle - valid in target proc */
0, /* ignored b/c DUPLICATE_SAME_ACCESS used */
TRUE, /* this can be inherited by children */
DUPLICATE_SAME_ACCESS))/* keep the same permissions */
{
errno = ENOMEM;
return 0;
}
return dupd;
}
Pid MLton_Process_create (NullString cmds, NullString envs,
Fd in, Fd out, Fd err) {
char *cmd;
char *env;
int result;
STARTUPINFO si;
PROCESS_INFORMATION proc;
cmd = (char*)cmds;
env = (char*)envs;
memset (&proc, 0, sizeof (proc));
memset (&si, 0, sizeof (si));
si.cb = sizeof(si);
si.hStdInput = dupHandle (in);
si.hStdOutput = dupHandle (out);
si.hStdError = dupHandle (err);
si.dwFlags = STARTF_USESTDHANDLES; /* use the above */
if (!si.hStdInput or !si.hStdOutput or !si.hStdError) {
if (si.hStdInput) CloseHandle (si.hStdInput);
if (si.hStdOutput) CloseHandle (si.hStdOutput);
if (si.hStdError) CloseHandle (si.hStdError);
/* errno already faked by create_dup_handle */
return -1;
}
result = CreateProcess (
0, /* Obtain command from cmdline */
cmd, /* Command-line as a string */
0, /* Process inherits security params */
0, /* Initial thread inherits security params */
TRUE, /* Inherit HANDLEs set as inherit */
0, /* Normal priority + no special flags */
env, /* Environment as a string {n=v\0}\0 */
0, /* Current directory = parent's */
&si, /* Start info from above */
&proc); /* returned handle */
if (0 == result) {
errno = ENOENT; /* probably does not exist (aka ENOFILE)*/
result = -1;
} else {
/* Process created successfully */
/* We will return the process handle for the 'pid'.
* This way we can TerminateProcess (kill) it and
* _cwait (waitpid) for it.
* The thread handle is not needed, so clean it.
*/
CloseHandle (proc.hThread);
result = (int)proc.hProcess;
}
CloseHandle (si.hStdInput);
CloseHandle (si.hStdOutput);
CloseHandle (si.hStdError);
return result;
}
1.1 mlton/runtime/platform/mmap.c
Index: mmap.c
===================================================================
static inline void *mmapAnonMmap (void *start, size_t length) {
return mmap (start, length, PROT_READ | PROT_WRITE,
MAP_PRIVATE | MAP_ANON, -1, 0);
}
static void smunmap (void *base, size_t length) {
if (DEBUG_MEM)
fprintf (stderr, "smunmap (0x%08x, %s)\n",
(uint)base,
uintToCommaString (length));
assert (base != NULL);
if (0 == length)
return;
if (0 != munmap (base, length))
diee ("munmap failed");
}
1.1 mlton/runtime/platform/release.virtual.c
Index: release.virtual.c
===================================================================
static inline void releaseVirtual (void *base) {
if (0 == VirtualFree (base, 0, MEM_RELEASE))
die ("VirtualFree release failed");
}
1.1 mlton/runtime/platform/setbintext.c
Index: setbintext.c
===================================================================
void Posix_IO_setbin (Fd fd, Bool useWindows) {
if (useWindows)
_setmode(fd, _O_BINARY);
else
/* cygwin has a different method for working with its fds */
setmode(fd, O_BINARY);
}
void Posix_IO_settext (Fd fd, Bool useWindows) {
if (useWindows)
_setmode (fd, _O_TEXT);
else
/* cygwin has a different method for working with its fds */
setmode (fd, O_TEXT);
}
1.1 mlton/runtime/platform/use-mmap.c
Index: use-mmap.c
===================================================================
#include "mmap.c"
void decommit (void *base, size_t length) {
smunmap (base, length);
}
void release (void *base, size_t length) {
smunmap (base, length);
}
void *mmapAnon (void *start, size_t length) {
return mmapAnonMmap (start, length);
}
1.1 mlton/runtime/platform/virtualAlloc.c
Index: virtualAlloc.c
===================================================================
static inline void releaseVirtual (void *base) {
if (0 == VirtualFree (base, 0, MEM_RELEASE))
die ("VirtualFree release failed");
}
static inline void decommitVirtual (void *base, size_t length) {
if (0 == VirtualFree (base, length, MEM_DECOMMIT))
die ("VirtualFree decommit failed");
}
static inline void *mmapAnonVirtual (void *start, size_t length) {
void *res;
res = VirtualAlloc ((LPVOID)start, length, MEM_COMMIT, PAGE_READWRITE);
if (NULL == res)
res = (void*)-1;
return res;
}