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, array_slice_offset: int} -> char -> unit
+  val writeWord8s : {file: t, file_offset: int, array_slice_offset: int} -> Word8.word ArraySlice.slice -> unit
+
 end

basis-library/mpl/file.sml

@@ -34,6 +34,20 @@ struct
       (ptr, size, ref true)
     end
 
+  fun openFileWriteable path final_size =
+    let
+      open Posix.FileSys
+      val file = createf (path, O_RDWR, O.append, S.flags [S.irusr, S.iwusr, S.irgrp, S.iroth])
+      val fileSize = Position.toInt (ST.size (fstat file))
+      val size = final_size + fileSize
+      val fd = C_Int.fromInt (SysWord.toInt (fdToWord file))
+      val _ = ftruncate (file, Position.fromInt size)
+      val ptr = mmapFileWriteable (fd, C_Size.fromInt size)
+    in
+      Posix.IO.close file;
+      {file = (ptr, size, ref true), file_size = fileSize}
+    end
+
   fun closeFile (ptr, size, stillOpen) =
     if !stillOpen then
       (release (ptr, C_Size.fromInt size); stillOpen := false)
@@ -88,4 +102,25 @@ struct
         raise Closed
     end
 
+    fun writeChar {file = (ptr, size, stillOpen), file_offset = fileSize, array_slice_offset = i} c =
+      if !stillOpen andalso i >= 0 andalso i < size then
+        MLton.Pointer.setWord8 (ptr, i + fileSize, Primitive.Char8.idToWord8 c)
+      else if i < 0 orelse i >= size then
+        raise Subscript
+      else
+        raise Closed
+
+    fun writeWord8s {file = (ptr, size, stillOpen), file_offset = file_offset, array_slice_offset = i} slice =
+      let
+        val (arr, j, n) = ArraySlice.base slice
+        val start = MLtonPointer.add (ptr, Word.fromInt file_offset)
+      in
+        if !stillOpen andalso i >= 0 andalso file_offset + (n - i) <= size then
+          copyWord8sFromBuffer (start, arr, C_Size.fromInt (i + j), C_Size.fromInt (n - i))
+        else if i < 0 orelse i + n > size then
+          raise Subscript
+        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, array_slice_offset = 0} (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);
 }