Merge pull request #146 from shwestrick/runtime-options

Forward #145 to ec-fast branch

basis-library/mlton/thread.sig

@@ -81,6 +81,8 @@ signature MLTON_THREAD =
         sig
           type thread = Basic.t
 
+          val decheckMaxDepth: unit -> int option
+
           (* fork the current thread ID, returning the two child IDs *)
           val decheckFork : unit -> Word64.word * Word64.word
 

basis-library/mlton/thread.sml

@@ -96,6 +96,16 @@ structure Disentanglement =
 struct
   type thread = Basic.t
 
+  fun decheckMaxDepth () =
+    let
+      val r = ref 0w0
+    in
+      if Prim.decheckMaxDepth r then
+        SOME (Word32.toIntX (!r))
+      else
+        NONE
+    end
+
   fun decheckFork () =
     let
       val left = ref (0w0: Word64.word)

basis-library/primitive/prim-mlton.sml

@@ -456,6 +456,11 @@ structure Thread =
       val copySyncDepthsFromThread = _import "GC_HH_copySyncDepthsFromThread"
         runtime private: GCState.t * thread * Word32.word -> unit;
 
+      (** If returns true, then writes result to the input ref. Otherwise, the
+        * runtime is not detecting entanglement, and the ref is not modified.
+        *)
+      val decheckMaxDepth = _import "GC_HH_decheckMaxDepth" runtime private: Word32.word ref -> bool;
+
       val moveNewThreadToDepth = _import "GC_HH_moveNewThreadToDepth" runtime private: thread * Word32.word -> unit;
       val checkFinishedCCReadyToJoin = _import "GC_HH_checkFinishedCCReadyToJoin" runtime private: GCState.t -> bool;
    end

basis-library/schedulers/shh/Scheduler.sml

@@ -29,8 +29,19 @@ struct
   | GCTask of gctask_data
 
   structure DE = MLton.Thread.Disentanglement
-  (** See MAX_FORK_DEPTH in runtime/gc/decheck.c *)
-  val maxDisetanglementCheckDepth = 31
+
+  local
+    (** See MAX_FORK_DEPTH in runtime/gc/decheck.c *)
+    val maxDisetanglementCheckDepth = DE.decheckMaxDepth ()
+  in
+  fun depthOkayForDECheck depth =
+    case maxDisetanglementCheckDepth of
+      (* in this case, there is no entanglement detection, so no problem *)
+      NONE => true
+
+      (* entanglement checks are active, and the max depth is m *)
+    | SOME m => depth < m
+  end
 
   val P = MLton.Parallel.numberOfProcessors
   val internalGCThresh = Real.toInt IEEEReal.TO_POSINF
@@ -417,8 +428,7 @@ struct
         (* if ccOkayAtThisDepth andalso depth = 1 then *)
         if ccOkayAtThisDepth andalso depth >= 1 andalso depth <= 3 then
           forkGC thread depth (f, g)
-        else if depth < Queue.capacity andalso
-                depth < maxDisetanglementCheckDepth then
+        else if depth < Queue.capacity andalso depthOkayForDECheck depth then
           parfork thread depth (f, g)
         else
           (* don't let us hit an error, just sequentialize instead *)
@@ -484,7 +494,7 @@ struct
       fun afterReturnToSched () =
         case getGCTask myId of
           NONE => (*dbgmsg' (fn _ => "back in sched; no GC task")*) ()
-        | SOME (thread, hh) => 
+        | SOME (thread, hh) =>
             ( (*dbgmsg' (fn _ => "back in sched; found GC task")
             ;*) setGCTask myId NONE
             ; HH.collectThreadRoot (thread, !hh)

examples/Makefile

@@ -2,6 +2,7 @@ MPL=../build/bin/mpl
 FLAGS=-default-type int64 -default-type word64
 DBG_FLAGS=-debug true -debug-runtime true -keep g
 TRACE_FLAGS=-trace true -trace-runtime true
+DETECT_FLAGS=-detect-entanglement true
 
 PROGRAMS= \
 	fib \
@@ -20,12 +21,15 @@ PROGRAMS= \
 
 TRACE_PROGRAMS := $(addsuffix .trace,$(PROGRAMS))
 DBG_PROGRAMS := $(addsuffix .dbg,$(PROGRAMS))
+DETECT_PROGRAMS := $(addsuffix .detect,$(PROGRAMS))
 SYSMPL_PROGRAMS := $(addsuffix .sysmpl,$(PROGRAMS))
 
 all: $(PROGRAMS)
 
 all-dbg: $(DBG_PROGRAMS)
 
+all-detect: $(DETECT_PROGRAMS)
+
 all-sysmpl: $(SYSMPL_PROGRAMS)
 
 $(PROGRAMS): %: phony
@@ -43,6 +47,11 @@ $(TRACE_PROGRAMS): %.trace: phony
 	$(MPL) $(FLAGS) $(TRACE_FLAGS) -output bin/$*.trace src/$*/sources.mlb
 	@echo "successfully built bin/$*.trace"
 
+$(DETECT_PROGRAMS): %.detect: phony
+	@mkdir -p bin
+	$(MPL) $(FLAGS) $(DETECT_FLAGS) -output bin/$*.detect src/$*/sources.mlb
+	@echo "successfully built bin/$*.detect"
+
 $(SYSMPL_PROGRAMS): %.sysmpl: phony
 	@mkdir -p bin
 	mpl $(FLAGS) -output bin/$*.sysmpl src/$*/sources.mlb

mlton/backend/rep-type.fun

@@ -476,15 +476,23 @@ structure ObjectType =
 
       val thread = fn () =>
          let
+            fun zeroIfNotDetectEntanglementRuntime x =
+               if !Control.detectEntanglementRuntime then
+                  x
+               else
+                  Bytes.zero
+
             (* see in runtime/gc/thread.h:
              * #define DECHECK_DEPTHS_LEN 32
              *)
             val numDecheckSyncDepths = 32
 
             val bytesDecheckSyncDepths =
-               Bytes.fromIntInf (IntInf.*
-                 (numDecheckSyncDepths,
-                  Bytes.toIntInf (Bits.toBytes (Type.width Type.word32))))
+               zeroIfNotDetectEntanglementRuntime (
+                  Bytes.fromIntInf (IntInf.*
+                    (numDecheckSyncDepths,
+                     Bytes.toIntInf (Bits.toBytes (Type.width Type.word32))))
+               )
 
             val padding =
                let
@@ -505,7 +513,8 @@ structure ObjectType =
                   val bytesDisentangledDepth =
                      Bits.toBytes (Type.width Type.word32)
                   val bytesDecheckState =
-                     Bits.toBytes (Type.width Type.word64)
+                     zeroIfNotDetectEntanglementRuntime
+                        (Bits.toBytes (Type.width Type.word64))
                   val bytesMinLocalCollectionDepth =
                      Bits.toBytes (Type.width Type.word32)
                   val bytesAllocatedSinceLastCollection =
@@ -547,20 +556,26 @@ structure ObjectType =
                   Type.bits (Bytes.toBits bytesPad)
                end
             val components =
-               Vector.fromList
+               Vector.fromList (
                   [Type.word32,
                    Type.csize (),
                    Type.exnStack (),
                    Type.word32,
-                   Type.word32,
-                   Type.word64,
-                   Type.bits (Bytes.toBits bytesDecheckSyncDepths),
-                   Type.word32,
+                   Type.word32]
+                  @
+                  (if !Control.detectEntanglementRuntime then
+                     [Type.word64,
+                      Type.bits (Bytes.toBits bytesDecheckSyncDepths)]
+                   else
+                     [])
+                  @
+                  [Type.word32,
                    Type.csize (),
                    Type.csize (),
                    Type.cpointer (),
                    Type.cpointer (),
                    Type.stack ()]
+               )
             val components =
                Vector.map (components, fn ty => {elt = ty, isMutable = true})
             val components =

mlton/control/control-flags.sig

@@ -109,6 +109,7 @@ signature CONTROL_FLAGS =
       val defaultWord: string ref
 
       val detectEntanglement: bool ref
+      val detectEntanglementRuntime: bool ref
 
       (* List of pass names to keep diagnostic info on. *)
       val diagPasses: Regexp.Compiled.t list ref

mlton/control/control-flags.sml

@@ -295,6 +295,11 @@ val detectEntanglement =
            default = false,
            toString = Bool.toString}
 
+val detectEntanglementRuntime =
+  control {name = "detect-entanglement-runtime",
+           default = false,
+           toString = Bool.toString}
+
 val diagPasses =
    control {name = "diag passes",
             default = [],

mlton/main/main.fun

@@ -74,7 +74,7 @@ val llvm_optOpts: {opt: string, pred: OptPred.t} list ref = ref []
 
 val debugRuntime: bool ref = ref false
 val traceRuntime: bool ref = ref false
-val ltoRuntime: bool ref = ref false
+val detectEntanglementRuntime: bool ref = ref false
 val expert: bool ref = ref false
 val explicitAlign: Control.align option ref = ref NONE
 val explicitChunkify: Control.Chunkify.t option ref = ref NONE
@@ -343,11 +343,13 @@ fun makeOptions {usage} =
        end,
        (Normal, "detect-entanglement", " {false|true}",
         "detect entanglement dynamically during execution",
-        Bool (fn b => detectEntanglement := b)),
+        Bool (fn b => (detectEntanglement := b
+                       ; detectEntanglementRuntime := b))),
+       (Expert, "detect-entanglement-runtime", " {false|true}",
+        "link with detect-entanglement runtime",
+        Bool (fn b => detectEntanglementRuntime := b)),
        (Expert, "trace-runtime", " {false|true}", "produce executable with tracing",
         boolRef traceRuntime),
-       (Expert, "lto-runtime", " {false|true}", "perform C-level whole-program optimization",
-        boolRef ltoRuntime),
        (Normal, "default-type", " '<ty><N>'", "set default type",
         SpaceString
         (fn s => (case s of
@@ -1089,6 +1091,10 @@ fun commandLine (args: string list): unit =
                          | _ => usage "can't use '-profile-stack true' without '-profile {alloc,count,time}'")
                   else ()
 
+      val () = if !detectEntanglement andalso not (!detectEntanglementRuntime)
+                  then usage "can't use '-detect-entanglement true' with '-detect-entanglement-runtime false'"
+                  else ()
+
       val () =
          Control.setCommandLineConst
          {name = "CallStack.keep",
@@ -1121,7 +1127,8 @@ fun commandLine (args: string list): unit =
          fun addMD s =
             if !debugRuntime then s ^ "-dbg" else
             if !traceRuntime then s ^ "-trace" else
-            if !ltoRuntime then s ^ "-lto" else s
+            if !detectEntanglementRuntime then s ^ "-detect" else
+            s
          fun addPI s =
             s ^ (Control.PositionIndependentStyle.toSuffix positionIndependentStyle)
       in
@@ -1145,7 +1152,6 @@ fun commandLine (args: string list): unit =
       val asOpts = addTargetOpts asOpts
       val ccOpts = addTargetOpts ccOpts
       val linkOpts = addTargetOpts linkOpts
-      val linkOpts = if !ltoRuntime then "-O3" :: "-flto" :: linkOpts else linkOpts
       val linkOpts =
          List.map (["mlton", "gdtoa"], fn lib => "-l" ^ mkLibName lib)
          @ [!mathLinkOpt, !gmpLinkOpt]
@@ -1459,10 +1465,10 @@ fun commandLine (args: string list): unit =
                              then [] else [ "-DLIBNAME=" ^ !libname ],
                              Control.PositionIndependentStyle.ccOpts
                              positionIndependentStyle,
-                             if !ltoRuntime
-                             then ["-O3", "-flto"] else [],
                              if !traceRuntime
                              then ["-DENABLE_TRACING=1"] else [],
+                             if !detectEntanglementRuntime
+                             then ["-DDETECT_ENTANGLEMENT=1"] else [],
                              [ "-I" ^ targetIncDir ],
                              ccOpts,
                              ["-o", output],

runtime/Makefile

@@ -20,13 +20,13 @@ endif
 
 EXE :=
 
-MDVARIANTS := OPT DBG TRACE LTO
+MDVARIANTS := OPT DBG TRACE DETECT
 PIVARIANTS := DPI NPI PIC PIE
 
 OPTSUFFIX :=
 DBGSUFFIX := -dbg
 TRACESUFFIX := -trace
-LTOSUFFIX := -lto
+DETECTSUFFIX := -detect
 DPISUFFIX :=
 NPISUFFIX := -npi
 PICSUFFIX := -pic
@@ -35,7 +35,7 @@ PIESUFFIX := -pie
 WITH_OPT_RUNTIME := true
 WITH_DBG_RUNTIME := true
 WITH_TRACE_RUNTIME := true
-WITH_LTO_RUNTIME := true
+WITH_DETECT_RUNTIME := true
 WITH_DPI_RUNTIME := true
 WITH_NPI_RUNTIME := $(or $(findstring true,$(RELEASE) $(WITH_ALL_RUNTIME)),false)
 WITH_PIC_RUNTIME := $(or $(findstring true,$(RELEASE) $(WITH_ALL_RUNTIME)),false)
@@ -55,7 +55,7 @@ XCFLAGS := -fno-common -pedantic -Wall -Wextra
 OPTXCFLAGS := -Wdisabled-optimization -O2
 DBGXCFLAGS := -g -DASSERT=1 -Wno-uninitialized -O0
 TRACEXCFLAGS := -DENABLE_TRACING $(OPTXCFLAGS)
-LTOXCFLAGS := -flto $(OPTXCFLAGS)
+DETECTXCFLAGS := -DDETECT_ENTANGLEMENT $(OPTXCFLAGS)
 DPIXCFLAGS :=
 NPIXCFLAGS := -fno-pic -fno-pie
 PICXCFLAGS := -fPIC

runtime/gc.c

@@ -20,6 +20,14 @@
 #define LOCAL_USED_FOR_ASSERT  __attribute__ ((unused))
 #endif
 
+#ifdef DETECT_ENTANGLEMENT
+#define ARG_USED_FOR_DETECT_ENTANGLEMENT
+#define LOCAL_USED_FOR_DETECT_ENTANGLEMENT
+#else
+#define ARG_USED_FOR_DETECT_ENTANGLEMENT  __attribute__ ((unused))
+#define LOCAL_USED_FOR_DETECT_ENTANGLEMENT  __attribute__ ((unused))
+#endif
+
 #ifdef ENABLE_TRACING
 #define ARG_USED_FOR_TRACING
 #define LOCAL_USED_FOR_TRACING