Merge pull request #113 from shwestrick/fast-file-io

Primitives for reading a file in parallel

Author: shwestrick

basis-library/build/sources.mlb

@@ -393,6 +393,11 @@ in
    ../mlton/mlton.sig
    ../mlton/mlton.sml
 
+   ../mpl/file.sig
+   ../mpl/file.sml
+   ../mpl/mpl.sig
+   ../mpl/mpl.sml
+
    ../sml-nj/sml-nj.sig
    ../sml-nj/sml-nj.sml
    ../sml-nj/unsafe.sig

basis-library/libs/all.mlb

@@ -12,6 +12,7 @@ local
    ../basis-1997.mlb
    ../basis-none.mlb
    ../mlton.mlb
+   ../mpl.mlb
    ../sml-nj.mlb
    ../unsafe.mlb
    ../c-types.mlb

basis-library/libs/basis-extra/top-level/basis-sigs.sml

@@ -116,3 +116,6 @@ signature MLTON_WORD = MLTON_WORD
 signature MLTON_WORLD = MLTON_WORLD
 signature SML_OF_NJ = SML_OF_NJ
 signature UNSAFE = UNSAFE
+
+signature MPL = MPL
+signature MPL_FILE = MPL_FILE

basis-library/libs/basis-extra/top-level/basis.sig

@@ -327,6 +327,7 @@ signature BASIS_EXTRA =
       structure MLton: MLTON
       structure SMLofNJ: SML_OF_NJ
       structure Unsafe: UNSAFE
+      structure MPL: MPL
 
       sharing type MLton.IntInf.t = IntInf.int
       sharing type MLton.Process.pid = Posix.Process.pid

basis-library/libs/basis-extra/top-level/basis.sml

@@ -5,7 +5,7 @@
  * See the file MLton-LICENSE for details.
  *)
 
-structure BasisExtra :> BASIS_EXTRA = 
+structure BasisExtra :> BASIS_EXTRA =
    struct
       (* Required structures *)
       structure Array = Array
@@ -256,6 +256,7 @@ structure BasisExtra :> BASIS_EXTRA =
       structure MLton = MLton
       structure SMLofNJ = SMLofNJ
       structure Unsafe = Unsafe
+      structure MPL = MPL
 
       open ArrayGlobal
            BoolGlobal

basis-library/libs/basis-extra/top-level/top-level.sml

@@ -12,4 +12,5 @@ in
   structure MLton = MLton
   structure SMLofNJ = SMLofNJ
   structure Unsafe = Unsafe
+  structure MPL = MPL
 end

basis-library/mpl.mlb

@@ -0,0 +1,21 @@
+(* Copyright (C) 2020 Sam Westrick.
+ *
+ * MLton is released under a HPND-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+ann
+   "deadCode true"
+   "nonexhaustiveBind warn" "nonexhaustiveMatch warn"
+   "redundantBind warn" "redundantMatch warn"
+   "sequenceNonUnit warn"
+   "warnUnused true" "forceUsed"
+in
+   local
+      libs/basis-extra/basis-extra.mlb
+   in
+      signature MPL_FILE
+      signature MPL
+      structure MPL
+   end
+end

basis-library/mpl/file.sig

@@ -0,0 +1,24 @@
+(* Copyright (C) 2020 Sam Westrick.
+ *
+ * MLton is released under a HPND-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+signature MPL_FILE =
+sig
+  type t
+
+  exception Closed
+
+  val openFile: string -> t
+  val closeFile: t -> unit
+  val size: t -> int
+
+  val readChar: t -> int -> char
+  val readWord8: t -> int -> Word8.word
+  val unsafeReadChar: t -> int -> char
+  val unsafeReadWord8: t -> int -> Word8.word
+
+  val readChars: t -> int -> char ArraySlice.slice -> unit
+  val readWord8s: t -> int -> Word8.word ArraySlice.slice -> unit
+end

basis-library/mpl/file.sml

@@ -0,0 +1,91 @@
+(* Copyright (C) 2020 Sam Westrick.
+ *
+ * MLton is released under a HPND-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+structure MPLFile :> MPL_FILE =
+struct
+  local
+    open Primitive.MLton.Pointer
+  in
+  structure C_Size = C_Size
+  structure C_Int = C_Int
+  end
+
+  type t = MLton.Pointer.t * int * bool ref
+
+  exception Closed
+
+  open Primitive.MPL.File
+
+  fun size (ptr, sz, stillOpen) =
+    if !stillOpen then sz else raise Closed
+
+  fun openFile path =
+    let
+      open Posix.FileSys
+      val file = openf (path, O_RDONLY, O.fromWord 0w0)
+      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)
+    in
+      Posix.IO.close file;
+      (ptr, size, ref true)
+    end
+
+  fun closeFile (ptr, size, stillOpen) =
+    if !stillOpen then
+      (release (ptr, C_Size.fromInt size); stillOpen := false)
+    else
+      raise Closed
+
+  fun unsafeReadWord8 (ptr, _, _) i =
+    MLton.Pointer.getWord8 (ptr, i)
+
+  fun unsafeReadChar (ptr, _, _) i =
+    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
+      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
+      unsafeReadWord8 (ptr, size, stillOpen) i
+    else if i < 0 orelse i >= size then
+      raise Subscript
+    else
+      raise Closed
+
+  fun readChars (ptr, size, stillOpen) i slice =
+    let
+      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
+        copyCharsToBuffer (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 readWord8s (ptr, size, stillOpen) i slice =
+    let
+      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
+        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
+
+end

basis-library/mpl/mpl.sig

@@ -0,0 +1,10 @@
+(* Copyright (C) 2020 Sam Westrick.
+ *
+ * MLton is released under a HPND-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+signature MPL =
+sig
+  structure File: MPL_FILE
+end

basis-library/mpl/mpl.sml

@@ -0,0 +1,10 @@
+(* Copyright (C) 2020 Sam Westrick.
+ *
+ * MLton is released under a HPND-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+structure MPL :> MPL =
+struct
+  structure File = MPLFile
+end

basis-library/primitive/prim-mpl.sml

@@ -0,0 +1,27 @@
+(* Copyright (C) 2020 Sam Westrick.
+ *
+ * MLton is released under a HPND-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+structure Primitive = struct
+open Primitive
+
+structure MPL =
+struct
+
+  structure File =
+  struct
+    val copyCharsToBuffer = _import "GC_memcpyToBuffer" runtime private:
+      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 mmapFileReadable = _import "GC_mmapFileReadable" runtime private:
+      C_Int.int * C_Size.word -> Pointer.t;
+    val release = _import "GC_release" runtime private:
+      Pointer.t * C_Size.word -> unit;
+  end
+
+end
+
+end

basis-library/primitive/primitive.mlb

@@ -70,6 +70,7 @@ in
    prim-pack-real.sml
 
    prim-mlton.sml
+   prim-mpl.sml
 
    basis-ffi.sml
    prim2.sml

runtime/gc/virtual-memory.c

@@ -32,6 +32,10 @@ static inline void GC_memcpy (pointer src, pointer dst, size_t size) {
   memcpy (dst, src, size);
 }
 
+void GC_memcpyToBuffer(pointer src, pointer buffer, size_t offset, size_t length) {
+  GC_memcpy(src, buffer + offset, 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

@@ -122,6 +122,9 @@ 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_mmapFileReadable (int fd, size_t size);
 PRIVATE void *GC_mmapAnon (void *start, size_t length);
 PRIVATE void *GC_mmapAnonFlags (void *start, size_t length, int flags);
 PRIVATE void *GC_mmapAnon_safe (void *start, size_t length);

runtime/platform/mmap.c

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

runtime/platform/use-mmap.c

@@ -4,6 +4,10 @@ void GC_release (void *base, size_t length) {
         munmap_safe (base, length);
 }
 
+void *GC_mmapFileReadable (int fd, size_t size) {
+  return mmapFileReadable(fd, size);
+}
+
 void *GC_mmapAnon (void *start, size_t length) {
         return mmapAnon (start, length);
 }