Merge pull request #172 from shwestrick/fix-real-to-string

Update `gdtoa` to be thread-safe; fixes #171
MPLLang · Apr 30, 2023 · 11373d1 · 11373d1
2 parents 0a1b9a9 + 308019a
commit 11373d1
Show file tree

Hide file tree

Showing 18 changed files with 91 additions and 9 deletions.
diff --git a/basis-library/primitive/basis-ffi.sml b/basis-library/primitive/basis-ffi.sml
@@ -918,6 +918,7 @@ val equal = _import "Real32_equal" private inline : Real32.t * Real32.t -> Bool.
 val fetch = _import "Real32_fetch" private inline : (Real32.t) ref -> Real32.t;
 val frexp = _import "Real32_frexp" private inline : Real32.t * (C_Int.t) ref -> Real32.t;
 val gdtoa = _import "Real32_gdtoa" private : Real32.t * C_Int.t * C_Int.t * C_Int.t * (C_Int.t) ref -> C_String.t;
+val gdtoa_free = _import "Real32_gdtoa_free" private : C_String.t -> unit;
 val ldexp = _import "Real32_ldexp" private inline : Real32.t * C_Int.t -> Real32.t;
 val le = _import "Real32_le" private inline : Real32.t * Real32.t -> Bool.t;
 val lt = _import "Real32_lt" private inline : Real32.t * Real32.t -> Bool.t;
@@ -974,6 +975,7 @@ val equal = _import "Real64_equal" private inline : Real64.t * Real64.t -> Bool.
 val fetch = _import "Real64_fetch" private inline : (Real64.t) ref -> Real64.t;
 val frexp = _import "Real64_frexp" private inline : Real64.t * (C_Int.t) ref -> Real64.t;
 val gdtoa = _import "Real64_gdtoa" private : Real64.t * C_Int.t * C_Int.t * C_Int.t * (C_Int.t) ref -> C_String.t;
+val gdtoa_free = _import "Real64_gdtoa_free" private : C_String.t -> unit;
 val ldexp = _import "Real64_ldexp" private inline : Real64.t * C_Int.t -> Real64.t;
 val le = _import "Real64_le" private inline : Real64.t * Real64.t -> Bool.t;
 val lt = _import "Real64_lt" private inline : Real64.t * Real64.t -> Bool.t;

diff --git a/basis-library/primitive/prim-real.sml b/basis-library/primitive/prim-real.sml
@@ -56,6 +56,7 @@ signature PRIM_REAL =
       val abs: real -> real
       val frexp: real * C_Int.t ref -> real
       val gdtoa: real * C_Int.t * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t
+      val gdtoa_free: C_String.t -> unit
       val ldexp: real * C_Int.t -> real
       val modf: real * real ref -> real
       val round: real -> real

diff --git a/basis-library/real/real.sig b/basis-library/real/real.sig
@@ -38,6 +38,7 @@ signature PRE_REAL =
       val realTrunc: real -> real
 
       val gdtoa: real * C_Int.t * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t
+      val gdtoa_free: C_String.t -> unit
       val strtor: Primitive.NullString8.t * C_Int.t -> real
 
       val fromInt8Unsafe: Primitive.Int8.int -> real

diff --git a/basis-library/real/real.sml b/basis-library/real/real.sml
@@ -419,7 +419,13 @@ functor Real (structure W: WORD_EXTRA
       (* toDecimal, fmt, toString: binary -> decimal conversions. *)
       datatype mode = Fix | Gen | Sci
       local
-         val decpt = ref (0: C_Int.int)
+         (* SAM_NOTE: the following shared ref was not safe for concurrency,
+          * so I commented it out and switched to doing one ref allocation per
+          * call to gdtoa. Of course, an alternative would be to separately
+          * pre-allocate a collection of refs, one per processor. Might want to
+          * consider that in the future.
+          *)
+         (* val decpt = ref (0: C_Int.int) *)
       in
          fun gdtoa (x: real, mode: mode, ndig: int,
                     rounding_mode: IEEEReal.rounding_mode) =
@@ -437,12 +443,19 @@ functor Real (structure W: WORD_EXTRA
                    | TO_POSINF => 2
                    | TO_ZERO => 0
                val _ = Primitive.MLton.Thread.atomicBegin ()
+
+               fun do_gdtoa_ffi () =
+                  let
+                     val decpt = ref (0: C_Int.int)
+                     val cstr = Prim.gdtoa (x, mode, ndig, rounding, decpt)
+                     val str = CUtil.C_String.toString cstr
+                   in
+                     Prim.gdtoa_free cstr;
+                     (str, C_Int.toInt (!decpt))
+                   end
             in
                DynamicWind.wind
-               (fn () =>
-                (CUtil.C_String.toString
-                 (Prim.gdtoa (x, mode, ndig, rounding, decpt)),
-                 C_Int.toInt (!decpt)),
+               (do_gdtoa_ffi,
                 Primitive.MLton.Thread.atomicEnd)
             end
       end

diff --git a/runtime/Makefile b/runtime/Makefile
@@ -295,7 +295,7 @@ GDTOA_CFILES := $(patsubst %,gdtoa/%,$(GDTOA_CFILES))
 
 GDTOA_OBJS := $(patsubst %.c,%.o,$(GDTOA_CFILES))
 
-$(foreach F,$(GDTOA_CFILES), $(eval $(F)_XCFLAGS := -w -DINFNAN_CHECK))
+$(foreach F,$(GDTOA_CFILES), $(eval $(F)_XCFLAGS := -w -DINFNAN_CHECK -DMULTIPLE_THREADS))
 
 ifneq ($(MAKECMDGOALS),clean)
 -include $(patsubst %.o,%.d,$(GDTOA_OBJS))

diff --git a/runtime/basis-ffi.h b/runtime/basis-ffi.h
@@ -755,6 +755,7 @@ PRIVATE INLINE Bool_t Real32_equal(Real32_t,Real32_t);
 PRIVATE INLINE Real32_t Real32_fetch(Ref(Real32_t));
 PRIVATE INLINE Real32_t Real32_frexp(Real32_t,Ref(C_Int_t));
 PRIVATE C_String_t Real32_gdtoa(Real32_t,C_Int_t,C_Int_t,C_Int_t,Ref(C_Int_t));
+PRIVATE void Real32_gdtoa_free(C_String_t);
 PRIVATE INLINE Real32_t Real32_ldexp(Real32_t,C_Int_t);
 PRIVATE INLINE Bool_t Real32_le(Real32_t,Real32_t);
 PRIVATE INLINE Bool_t Real32_lt(Real32_t,Real32_t);
@@ -804,6 +805,7 @@ PRIVATE INLINE Bool_t Real64_equal(Real64_t,Real64_t);
 PRIVATE INLINE Real64_t Real64_fetch(Ref(Real64_t));
 PRIVATE INLINE Real64_t Real64_frexp(Real64_t,Ref(C_Int_t));
 PRIVATE C_String_t Real64_gdtoa(Real64_t,C_Int_t,C_Int_t,C_Int_t,Ref(C_Int_t));
+PRIVATE void Real64_gdtoa_free(C_String_t);
 PRIVATE INLINE Real64_t Real64_ldexp(Real64_t,C_Int_t);
 PRIVATE INLINE Bool_t Real64_le(Real64_t,Real64_t);
 PRIVATE INLINE Bool_t Real64_lt(Real64_t,Real64_t);

diff --git a/runtime/basis/Real/gdtoa.c b/runtime/basis/Real/gdtoa.c
@@ -21,6 +21,10 @@ C_String_t Real32_gdtoa (Real32_t f, C_Int_t mode, C_Int_t ndig,
   return (C_String_t)result;
 }
 
+void Real32_gdtoa_free(C_String_t s) {
+  gdtoa__freedtoa((char*)s);
+}
+
 /* This code is patterned on g_dfmt from the gdtoa sources. */
 C_String_t Real64_gdtoa (Real64_t d, C_Int_t mode, C_Int_t ndig, 
                          C_Int_t rounding, Ref(C_Int_t) decpt) {
@@ -49,3 +53,7 @@ C_String_t Real64_gdtoa (Real64_t d, C_Int_t mode, C_Int_t ndig,
   result = gdtoa__gdtoa (&fpi, ex, bits, &i, mode, ndig, (int*)decpt, NULL);
   return (C_String_t)result;
 }
+
+void Real64_gdtoa_free(C_String_t s) {
+  gdtoa__freedtoa((char*)s);
+}
diff --git a/runtime/gc.c b/runtime/gc.c
@@ -44,6 +44,8 @@
 /* used to look up per-processor state */
 extern C_Pthread_Key_t gcstate_key;
 
+#include "gc/gdtoa-multiple-threads-defs.c"
+
 #include "gc/assign.c"
 #include "gc/atomic.c"
 #include "gc/block-allocator.c"

diff --git a/runtime/gc.h b/runtime/gc.h
@@ -24,6 +24,7 @@ typedef GC_state GCState_t;
 #error POINTER_BITS not defined
 #endif
 
+#include "gc/gdtoa-multiple-threads-defs.h"
 
 #include "gc/debug.h"
 #include "gc/logger.h"

diff --git a/runtime/gc/gdtoa-multiple-threads-defs.c b/runtime/gc/gdtoa-multiple-threads-defs.c
@@ -0,0 +1,35 @@
+
+pthread_mutex_t GLOBAL_GDTOA_LOCK_0 = PTHREAD_MUTEX_INITIALIZER;
+pthread_mutex_t GLOBAL_GDTOA_LOCK_1 = PTHREAD_MUTEX_INITIALIZER;
+
+void ACQUIRE_DTOA_LOCK(int n) {
+  if (n == 0) {
+    pthread_mutex_lock(&GLOBAL_GDTOA_LOCK_0);
+  }
+  else if (n == 1) {
+    pthread_mutex_lock(&GLOBAL_GDTOA_LOCK_1);
+  }
+  else {
+    DIE("ACQUIRE_DTOA_LOCK: bad lock identifier");
+  }
+}
+
+void FREE_DTOA_LOCK(int n) {
+  if (n == 0) {
+    pthread_mutex_unlock(&GLOBAL_GDTOA_LOCK_0);
+  }
+  else if (n == 1) {
+    pthread_mutex_unlock(&GLOBAL_GDTOA_LOCK_1);
+  }
+  else {
+    DIE("ACQUIRE_DTOA_LOCK: bad lock identifier");
+  }
+}
+
+unsigned int dtoa_get_threadno(void) {
+  GC_state s = pthread_getspecific(gcstate_key);
+  if (NULL != s) {
+    return (unsigned int)(s->procNumber);
+  }
+  return 0;
+}
diff --git a/runtime/gc/gdtoa-multiple-threads-defs.h b/runtime/gc/gdtoa-multiple-threads-defs.h
@@ -0,0 +1,9 @@
+#ifndef GDTOA_MULTIPLE_THREADS_DEFS_
+#define GDTOA_MULTIPLE_THREADS_DEFS_
+
+extern void set_max_gdtoa_threads(unsigned int n);
+void ACQUIRE_DTOA_LOCK(int n);
+void FREE_DTOA_LOCK(int n);
+unsigned int dtoa_get_threadno(void);
+
+#endif
diff --git a/runtime/gc/init.c b/runtime/gc/init.c
@@ -610,6 +610,8 @@ void GC_lateInit(GC_state s) {
 
   s->nextChunkAllocSize = s->controls->allocChunkSize;
 
+  set_max_gdtoa_threads(s->numberOfProcs);
+
   /* Initialize profiling.  This must occur after processing
    * command-line arguments, because those may just be doing a
    * show-sources, in which case we don't want to initialize the

diff --git a/runtime/gen/basis-ffi.def b/runtime/gen/basis-ffi.def
@@ -852,6 +852,7 @@ Real32.equal = _import INLINE : Real32.t * Real32.t -> Bool.t
 Real32.fetch = _import INLINE : Real32.t ref -> Real32.t
 Real32.frexp = _import INLINE : Real32.t * C_Int.t ref -> Real32.t
 Real32.gdtoa = _import : Real32.t * C_Int.t * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t
+Real32.gdtoa_free = _import : C_String.t -> unit
 Real32.ldexp = _import INLINE : Real32.t * C_Int.t -> Real32.t
 Real32.le = _import INLINE : Real32.t * Real32.t -> Bool.t
 Real32.lt = _import INLINE : Real32.t * Real32.t -> Bool.t
@@ -901,6 +902,7 @@ Real64.equal = _import INLINE : Real64.t * Real64.t -> Bool.t
 Real64.fetch = _import INLINE : Real64.t ref -> Real64.t
 Real64.frexp = _import INLINE : Real64.t * C_Int.t ref -> Real64.t
 Real64.gdtoa = _import : Real64.t * C_Int.t * C_Int.t * C_Int.t * C_Int.t ref -> C_String.t
+Real64.gdtoa_free = _import : C_String.t -> unit
 Real64.ldexp = _import INLINE : Real64.t * C_Int.t -> Real64.t
 Real64.le = _import INLINE : Real64.t * Real64.t -> Bool.t
 Real64.lt = _import INLINE : Real64.t * Real64.t -> Bool.t

diff --git a/runtime/gen/basis-ffi.h b/runtime/gen/basis-ffi.h
@@ -755,6 +755,7 @@ PRIVATE INLINE Bool_t Real32_equal(Real32_t,Real32_t);
 PRIVATE INLINE Real32_t Real32_fetch(Ref(Real32_t));
 PRIVATE INLINE Real32_t Real32_frexp(Real32_t,Ref(C_Int_t));
 PRIVATE C_String_t Real32_gdtoa(Real32_t,C_Int_t,C_Int_t,C_Int_t,Ref(C_Int_t));
+PRIVATE void Real32_gdtoa_free(C_String_t);
 PRIVATE INLINE Real32_t Real32_ldexp(Real32_t,C_Int_t);
 PRIVATE INLINE Bool_t Real32_le(Real32_t,Real32_t);
 PRIVATE INLINE Bool_t Real32_lt(Real32_t,Real32_t);
@@ -804,6 +805,7 @@ PRIVATE INLINE Bool_t Real64_equal(Real64_t,Real64_t);
 PRIVATE INLINE Real64_t Real64_fetch(Ref(Real64_t));
 PRIVATE INLINE Real64_t Real64_frexp(Real64_t,Ref(C_Int_t));
 PRIVATE C_String_t Real64_gdtoa(Real64_t,C_Int_t,C_Int_t,C_Int_t,Ref(C_Int_t));
+PRIVATE void Real64_gdtoa_free(C_String_t);
 PRIVATE INLINE Real64_t Real64_ldexp(Real64_t,C_Int_t);
 PRIVATE INLINE Bool_t Real64_le(Real64_t,Real64_t);
 PRIVATE INLINE Bool_t Real64_lt(Real64_t,Real64_t);

diff --git a/runtime/gen/basis-ffi.h.chk b/runtime/gen/basis-ffi.h.chk
@@ -1 +1 @@
-e170fea0dbe347548aa4032effbd485a1d93b790
+1276d591e8e38dacd91962c79e765101435fadfc
diff --git a/runtime/gen/basis-ffi.sml b/runtime/gen/basis-ffi.sml
@@ -918,6 +918,7 @@ val equal = _import "Real32_equal" private inline : Real32.t * Real32.t -> Bool.
 val fetch = _import "Real32_fetch" private inline : (Real32.t) ref -> Real32.t;
 val frexp = _import "Real32_frexp" private inline : Real32.t * (C_Int.t) ref -> Real32.t;
 val gdtoa = _import "Real32_gdtoa" private : Real32.t * C_Int.t * C_Int.t * C_Int.t * (C_Int.t) ref -> C_String.t;
+val gdtoa_free = _import "Real32_gdtoa_free" private : C_String.t -> unit;
 val ldexp = _import "Real32_ldexp" private inline : Real32.t * C_Int.t -> Real32.t;
 val le = _import "Real32_le" private inline : Real32.t * Real32.t -> Bool.t;
 val lt = _import "Real32_lt" private inline : Real32.t * Real32.t -> Bool.t;
@@ -974,6 +975,7 @@ val equal = _import "Real64_equal" private inline : Real64.t * Real64.t -> Bool.
 val fetch = _import "Real64_fetch" private inline : (Real64.t) ref -> Real64.t;
 val frexp = _import "Real64_frexp" private inline : Real64.t * (C_Int.t) ref -> Real64.t;
 val gdtoa = _import "Real64_gdtoa" private : Real64.t * C_Int.t * C_Int.t * C_Int.t * (C_Int.t) ref -> C_String.t;
+val gdtoa_free = _import "Real64_gdtoa_free" private : C_String.t -> unit;
 val ldexp = _import "Real64_ldexp" private inline : Real64.t * C_Int.t -> Real64.t;
 val le = _import "Real64_le" private inline : Real64.t * Real64.t -> Bool.t;
 val lt = _import "Real64_lt" private inline : Real64.t * Real64.t -> Bool.t;

diff --git a/runtime/gen/basis-ffi.sml.chk b/runtime/gen/basis-ffi.sml.chk
@@ -1 +1 @@
-6fd3ac5265579968f762d42492e4102988c96389
+02ef705fb757d57053447fbdcc28cf9894f40c5f
diff --git a/runtime/gen/gen-basis-ffi-consts.c.chk b/runtime/gen/gen-basis-ffi-consts.c.chk
@@ -1 +1 @@
-739cfa75685e3d6e6193f899d9ec6e97d8f78a9c
+a0f2e632f508a924fd4c3461ed96c54bd6c7dd1c