Interfaces for writing to files using mmap

basis-library/mpl/file.sig

@@ -11,6 +11,7 @@ sig
   exception Closed
 
   val openFile: string -> t
+  val openFileWriteable: string -> int -> {file : t, file_size: int}
   val closeFile: t -> unit
   val size: t -> int
 
@@ -21,4 +22,7 @@ sig
 
   val readChars: t -> int -> char ArraySlice.slice -> unit
   val readWord8s: t -> int -> Word8.word ArraySlice.slice -> unit
+  val writeChar : {file: t, file_offset: int} -> char -> unit
+  val writeWord8s : {file: t, file_offset: int} -> Word8.word ArraySlice.slice -> unit
+
 end

basis-library/mpl/file.sml

@@ -13,14 +13,19 @@ struct
   structure C_Int = C_Int
   end
 
-  type t = MLton.Pointer.t * int * bool ref
+  datatype FileState = OpenRead | OpenReadWrite | FileClosed
+
+  type t = MLton.Pointer.t * int * FileState ref
 
   exception Closed
+  exception WrongFilePermission
+  exception MappingFailed of string
+  exception OpenFailed of string
 
   open Primitive.MPL.File
 
   fun size (ptr, sz, stillOpen) =
-    if !stillOpen then sz else raise Closed
+    if !stillOpen = OpenRead orelse !stillOpen = OpenReadWrite then sz else raise Closed
 
   fun openFile path =
     let
@@ -29,14 +34,36 @@ struct
       val size = Position.toInt (ST.size (fstat file))
       val fd = C_Int.fromInt (SysWord.toInt (fdToWord file))
       val ptr = mmapFileReadable (fd, C_Size.fromInt size)
+      val _ = if ptr = Primitive.MLton.Pointer.null orelse ptr = Primitive.MLton.Pointer.fromWord(C_Size.fromInt (~1)) then
+                raise (MappingFailed "Failed to map file readable")
+              else
+                ()
     in
       Posix.IO.close file;
-      (ptr, size, ref true)
+      (ptr, size, ref OpenRead)
+    end
+
+  fun openFileWriteable path buffer_size =
+    let
+      open Posix.FileSys
+      val file = createf (path, O_RDWR, O.append, S.flags [S.irusr, S.iwusr, S.irgrp, S.iroth])
+      val original_size = Position.toInt (ST.size (fstat file))
+      val final_size = buffer_size + original_size
+      val fd = C_Int.fromInt (SysWord.toInt (fdToWord file))
+      val _ = ftruncate (file, Position.fromInt final_size)
+      val ptr = mmapFileWriteable (fd, C_Size.fromInt final_size)
+      val _ = if ptr = Primitive.MLton.Pointer.null orelse ptr = Primitive.MLton.Pointer.fromWord(C_Size.fromInt (~1)) then
+                raise (MappingFailed "Failed to map file writeable")
+              else
+                ()
+    in
+      Posix.IO.close file;
+      {file = (ptr, final_size, ref OpenReadWrite), file_size = original_size}
     end
 
   fun closeFile (ptr, size, stillOpen) =
-    if !stillOpen then
-      (release (ptr, C_Size.fromInt size); stillOpen := false)
+    if !stillOpen = OpenRead orelse !stillOpen = OpenReadWrite then
+      (release (ptr, C_Size.fromInt size); stillOpen := FileClosed)
     else
       raise Closed
 
@@ -47,15 +74,15 @@ struct
     Char.chr (Word8.toInt (MLton.Pointer.getWord8 (ptr, i)))
 
   fun readChar (ptr, size, stillOpen) (i: int) =
-    if !stillOpen andalso i >= 0 andalso i < size then
+    if (!stillOpen = OpenRead orelse !stillOpen = OpenReadWrite) andalso i >= 0 andalso i < size then
       unsafeReadChar (ptr, size, stillOpen) i
     else if i < 0 orelse i >= size then
       raise Subscript
     else
       raise Closed
 
   fun readWord8 (ptr, size, stillOpen) (i: int) =
-    if !stillOpen andalso i >= 0 andalso i < size then
+    if (!stillOpen = OpenRead orelse !stillOpen = OpenReadWrite) andalso i >= 0 andalso i < size then
       unsafeReadWord8 (ptr, size, stillOpen) i
     else if i < 0 orelse i >= size then
       raise Subscript
@@ -67,7 +94,7 @@ struct
       val (arr, j, n) = ArraySlice.base slice
       val start = MLtonPointer.add (ptr, Word.fromInt i)
     in
-      if !stillOpen andalso i >= 0 andalso i+n <= size then
+      if (!stillOpen = OpenRead orelse !stillOpen = OpenReadWrite) andalso i >= 0 andalso i+n <= size then
         copyCharsToBuffer (start, arr, C_Size.fromInt j, C_Size.fromInt n)
       else if i < 0 orelse i+n > size then
         raise Subscript
@@ -80,12 +107,37 @@ struct
       val (arr, j, n) = ArraySlice.base slice
       val start = MLtonPointer.add (ptr, Word.fromInt i)
     in
-      if !stillOpen andalso i >= 0 andalso i+n <= size then
+      if (!stillOpen = OpenRead orelse !stillOpen = OpenReadWrite) andalso i >= 0 andalso i+n <= size then
         copyWord8sToBuffer (start, arr, C_Size.fromInt j, C_Size.fromInt n)
       else if i < 0 orelse i+n > size then
         raise Subscript
       else
         raise Closed
     end
 
+    fun writeChar {file = (ptr, size, stillOpen), file_offset = file_offset} c =
+      if !stillOpen = OpenReadWrite andalso file_offset >= 0 andalso file_offset < size then
+        MLton.Pointer.setWord8 (ptr, file_offset, Primitive.Char8.idToWord8 c)
+      else if file_offset < 0 orelse file_offset >= size then
+        raise Subscript
+      else if !stillOpen = OpenRead then
+           raise WrongFilePermission
+        else
+          raise Closed
+
+      fun writeWord8s {file = (ptr, size, stillOpen), file_offset} slice =
+        let
+          val (arr, j, n) = ArraySlice.base slice
+          val start = MLtonPointer.add (ptr, Word.fromInt file_offset)
+        in
+          if !stillOpen = OpenReadWrite andalso file_offset >= 0 andalso file_offset + n <= size then
+            copyWord8sFromBuffer (start, arr, C_Size.fromInt j, C_Size.fromInt n)
+          else if file_offset < 0 orelse file_offset + n > size then
+            raise Subscript
+          else if !stillOpen = OpenRead then
+            raise WrongFilePermission
+          else
+            raise Closed
+        end
+
 end

basis-library/primitive/prim-mpl.sml

@@ -16,8 +16,12 @@ struct
       Pointer.t * Char8.t array * C_Size.word * C_Size.word -> unit;
     val copyWord8sToBuffer = _import "GC_memcpyToBuffer" runtime private:
       Pointer.t * Word8.word array * C_Size.word * C_Size.word -> unit;
+    val copyWord8sFromBuffer = _import "GC_memcpyFromBuffer" runtime private:
+       Pointer.t * Word8.word array * C_Size.word * C_Size.word -> unit;
     val mmapFileReadable = _import "GC_mmapFileReadable" runtime private:
       C_Int.int * C_Size.word -> Pointer.t;
+    val mmapFileWriteable = _import "GC_mmapFileWriteable" runtime private:
+      C_Int.int * C_Size.word -> Pointer.t;
     val release = _import "GC_release" runtime private:
       Pointer.t * C_Size.word -> unit;
   end

examples/lib/WriteFile.sml

@@ -0,0 +1,24 @@
+structure WriteFile:
+sig
+  val writeBinSeq: {filename: string, content: Word8.word Seq.t} -> unit
+end =
+struct
+
+  fun writeBinSeq {filename, content} =
+    let
+      val n = Seq.length content
+      val {file, file_size = oldSize} = MPL.File.openFileWriteable filename n
+      val k = 10000
+      val m = 1 + (n-1) div k
+    in
+      ForkJoin.parfor 1 (0, m) (fn i =>
+        let 
+          val lo = i*k
+          val hi = Int.min ((i+1)*k, n)
+        in
+          MPL.File.writeWord8s { file = file , file_offset = oldSize + lo} (Seq.subseq content (lo, hi-lo))
+        end
+        );
+      MPL.File.closeFile file
+    end
+end

runtime/gc/virtual-memory.c

@@ -36,6 +36,11 @@ void GC_memcpyToBuffer(pointer src, pointer buffer, size_t offset, size_t length
   GC_memcpy(src, buffer + offset, length);
 }
 
+void GC_memcpyFromBuffer(pointer des, pointer buffer, size_t offset, size_t length) {
+  GC_memcpy(buffer + offset, des, length);
+}
+
+
 static inline void GC_memmove (pointer src, pointer dst, size_t size) {
   if (DEBUG_DETAILED)
     fprintf (stderr, "GC_memmove ("FMTPTR", "FMTPTR", %"PRIuMAX")\n",

runtime/platform.h

@@ -127,6 +127,7 @@ PRIVATE __attribute__ ((noreturn)) void MLton_heapCheckTooLarge (void);
 PRIVATE void GC_displayMem (void);
 
 PRIVATE void GC_memcpyToBuffer(pointer src, pointer buffer, size_t offset, size_t length);
+PRIVATE void GC_memcpyFromBuffer(pointer des, pointer buffer, size_t offset, size_t length);
 
 PRIVATE void *GC_mmapFileReadable (int fd, size_t size);
 PRIVATE void *GC_mmapAnon (void *start, size_t length);

runtime/platform/mmap.c

@@ -2,6 +2,10 @@ static inline void *mmapFileReadable (int fd, size_t size) {
   return mmap (0, size, PROT_READ, MAP_PRIVATE, fd, 0);
 }
 
+static inline void *mmapFileWriteable (int fd, size_t size) {
+  return mmap (0, size, PROT_WRITE, MAP_SHARED, fd, 0);
+}
+
 static inline void *mmapAnonFlags (void *start, size_t length, int flags) {
         return mmap (start, length, PROT_READ | PROT_WRITE,
                         MAP_PRIVATE | MAP_ANON | flags, -1, 0);

runtime/platform/use-mmap.c

@@ -8,6 +8,10 @@ void *GC_mmapFileReadable (int fd, size_t size) {
   return mmapFileReadable(fd, size);
 }
 
+void *GC_mmapFileWriteable (int fd, size_t size) {
+  return mmapFileWriteable(fd, size);
+}
+
 void *GC_mmapAnon (void *start, size_t length) {
         return mmapAnon (start, length);
 }