Parallelisation of 3 optimization phases (affects release builds only)

src/Compiler/Driver/OptimizeInputs.fsi

@@ -12,6 +12,8 @@ open FSharp.Compiler.Import
 open FSharp.Compiler.Optimizer
 open FSharp.Compiler.TcGlobals
 open FSharp.Compiler.TypedTree
+open System.Collections.Generic
+open FSharp.Compiler.Service.Driver.OptimizeTypes
 
 val GetGeneratedILModuleName: CompilerTarget -> string -> string
 
@@ -49,3 +51,14 @@ val GenerateIlxCode:
 val NormalizeAssemblyRefs: CompilationThreadToken * ILGlobals * TcImports -> (ILScopeRef -> ILScopeRef)
 
 val GetGeneratedILModuleName: CompilerTarget -> string -> string
+
+type FilePhaseFuncs = Phase1Fun * Phase2Fun * Phase3Fun   
+type Goer = IReadOnlyDictionary<int, int[]> -> IncrementalOptimizationEnv -> FilePhaseFuncs -> CheckedImplFile[] -> CollectorOutputs
+val mutable goer: Goer option
+
+type OptimizerMode =
+    | Sequential
+    | PartiallyParallel
+    | GraphBased
+
+val mutable optimizerMode: OptimizerMode

src/Compiler/Driver/OptimizeTypes.fs

@@ -0,0 +1,92 @@
+module internal FSharp.Compiler.Service.Driver.OptimizeTypes
+
+open FSharp.Compiler
+open FSharp.Compiler.Optimizer
+open FSharp.Compiler.TcGlobals
+open FSharp.Compiler.TypedTree
+open FSharp.Compiler.TypedTreeOps
+
+type DeltaAndFull<'a> =
+    {
+        Delta: 'a
+        Full: 'a
+    }
+
+type OptimizeDuringCodeGen = bool -> Expr -> Expr
+type OptimizeRes =
+    (DeltaAndFull<IncrementalOptimizationEnv> * CheckedImplFile * ImplFileOptimizationInfo * DeltaAndFull<SignatureHidingInfo>) * OptimizeDuringCodeGen
+
+type Optimize =
+    OptimizationSettings *
+    CcuThunk *
+    TcGlobals *
+    ConstraintSolver.TcValF *
+    Import.ImportMap *
+    IncrementalOptimizationEnv *
+    bool *
+    bool *
+    bool *
+    SignatureHidingInfo *
+    CheckedImplFile ->
+        OptimizeRes
+
+type PhaseInputs = IncrementalOptimizationEnv * SignatureHidingInfo * CheckedImplFile
+
+type Phase1Inputs = PhaseInputs
+type Phase1Res = OptimizeRes
+type Phase1Fun = Phase1Inputs -> Phase1Res
+
+type Phase2Inputs = PhaseInputs
+type Phase2Res = DeltaAndFull<IncrementalOptimizationEnv> * CheckedImplFile
+type Phase2Fun = Phase2Inputs -> Phase2Res
+
+type Phase3Inputs = PhaseInputs
+type Phase3Res = DeltaAndFull<IncrementalOptimizationEnv> * CheckedImplFile
+type Phase3Fun = Phase3Inputs -> Phase3Res
+
+type Phase =
+    | Phase1
+    | Phase2
+    | Phase3
+module Phase =
+    let all = [|Phase1; Phase2; Phase3|]
+    let prev (phase: Phase) =
+        match phase with
+        | Phase1 -> None
+        | Phase2 -> Some Phase1
+        | Phase3 -> Some Phase2
+    let next (phase: Phase) =
+        match phase with
+        | Phase1 -> Some Phase2
+        | Phase2 -> Some Phase3
+        | Phase3 -> None
+
+type PhaseRes =
+    | Phase1 of Phase1Res
+    | Phase2 of Phase2Res
+    | Phase3 of Phase3Res
+    with
+        member x.Which =
+            match x with
+            | Phase1 _ -> Phase.Phase1
+            | Phase2 _ -> Phase.Phase2
+            | Phase3 _ -> Phase.Phase3
+        member x.Get1() =
+            match x with
+            | Phase1 x -> x
+            | Phase2 _
+            | Phase3 _ -> failwith $"Called {nameof(x.Get1)} but this is {x.Which}"
+        member x.Get2() =
+            match x with
+            | Phase2 x -> x
+            | Phase1 _
+            | Phase3 _ -> failwith $"Called {nameof(x.Get2)} but this is {x.Which}"
+
+type FileResultsComplete =
+    {
+        Phase1: Phase1Res
+        Phase2: Phase2Res
+        Phase3: Phase3Res
+    }
+type CollectorInputs = FileResultsComplete[]
+type CollectorOutputs = (CheckedImplFileAfterOptimization * ImplFileOptimizationInfo)[] * IncrementalOptimizationEnv

src/Compiler/Driver/Parallel.fs

@@ -0,0 +1,54 @@
+module ParallelTypeCheckingTests.Parallel
+
+#nowarn "1182"
+
+open System
+open System.Collections.Concurrent
+open System.Threading
+
+// TODO Could replace with MailboxProcessor+Tasks/Asyncs instead of BlockingCollection + Threads
+// See http://www.fssnip.net/nX/title/Limit-degree-of-parallelism-using-an-agent
+/// Process items in parallel, allow more work to be scheduled as a result of finished work,
+/// limit parallelisation to 'parallelism' threads
+let processInParallel
+    (firstItems: 'Item[])
+    (work: 'Item -> 'Item[])
+    (parallelism: int)
+    (shouldStop: int -> bool)
+    (ct: CancellationToken)
+    (_itemToString: 'Item -> string)
+    : unit =
+    let bc = new BlockingCollection<'Item>()
+    firstItems |> Array.iter bc.Add
+    let processedCountLock = Object()
+    let mutable processedCount = 0
+
+    let processItem item =
+        printfn $"[{Thread.CurrentThread.ManagedThreadId}] Processing {_itemToString item}"
+        let toSchedule = work item
+        printfn $"[{Thread.CurrentThread.ManagedThreadId}] Finished {_itemToString item}"
+
+        let processedCount =
+            lock processedCountLock (fun () ->
+                processedCount <- processedCount + 1
+                processedCount)
+
+        let toScheduleString =
+            toSchedule |> Array.map _itemToString |> (fun names -> String.Join(", ", names))
+
+        printfn $"[{Thread.CurrentThread.ManagedThreadId}] Scheduling {toSchedule.Length} items: {toScheduleString}"
+        toSchedule |> Array.iter bc.Add
+        processedCount
+
+    // TODO Could avoid workers with some semaphores
+    let workerWork () : unit =
+        for node in bc.GetConsumingEnumerable(ct) do
+            if not ct.IsCancellationRequested then // improve
+                let processedCount = processItem node
+
+                if shouldStop processedCount then
+                    bc.CompleteAdding()
+
+    // TODO Do we need to handle cancellation given that workers do it already?
+    Array.Parallel.map workerWork (Array.init parallelism (fun _ -> ())) |> ignore
+

src/Compiler/Driver/ParseAndCheckInputs.fs

@@ -759,29 +759,17 @@ let ParseInputFilesInParallel (tcConfig: TcConfig, lexResourceManager, sourceFil
     for fileName in sourceFiles do
         checkInputFile tcConfig fileName
 
-    // Order files to be parsed by size (descending). The idea is to process big files first,
-    // so that near the end when only some nodes are still processing items, it's the smallest items,
-    // which should reduce the period of time where only some nodes are busy.
-    // This requires some empirical evidence.
-    let sourceFiles =
-        sourceFiles
-        |> List.mapi (fun i f -> i, f)
-        |> List.sortBy (fun (_i, f) -> -FileInfo(f).Length)
-
     let sourceFiles = List.zip sourceFiles isLastCompiland
 
     UseMultipleDiagnosticLoggers (sourceFiles, delayLogger, None) (fun sourceFilesWithDelayLoggers ->
         sourceFilesWithDelayLoggers
-        |> ListParallel.map (fun (((idx, fileName), isLastCompiland), delayLogger) ->
+        |> ListParallel.map (fun ((fileName, isLastCompiland), delayLogger) ->
             let directoryName = Path.GetDirectoryName fileName
 
             let input =
                 parseInputFileAux (tcConfig, lexResourceManager, fileName, (isLastCompiland, isExe), delayLogger, retryLocked)
 
-            idx, (input, directoryName))
-        // Bring back index-based order
-        |> List.sortBy fst
-        |> List.map snd)
+            (input, directoryName)))
 
 let ParseInputFilesSequential (tcConfig: TcConfig, lexResourceManager, sourceFiles, diagnosticsLogger: DiagnosticsLogger, retryLocked) =
     let isLastCompiland, isExe = sourceFiles |> tcConfig.ComputeCanContainEntryPoint
@@ -1767,3 +1755,5 @@ let CheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tc
 
     tcState.Ccu.Deref.Contents <- ccuContents
     tcState, topAttrs, declaredImpls, tcEnvAtEndOfLastFile
+
+let mutable graph: System.Collections.Generic.IReadOnlyDictionary<int, int[]> = null

src/Compiler/Driver/ParseAndCheckInputs.fsi

@@ -228,3 +228,5 @@ val CheckOneInputAndFinish:
     tcState: TcState *
     input: ParsedInput ->
         Cancellable<(TcEnv * TopAttribs * CheckedImplFile list * ModuleOrNamespaceType list) * TcState>
+
+val mutable graph: System.Collections.Generic.IReadOnlyDictionary<int, int[]>

src/Compiler/Driver/fsc.fs

@@ -20,6 +20,7 @@ open System.Reflection
 open System.Text
 open System.Threading
 
+open System.Threading.Tasks
 open Internal.Utilities
 open Internal.Utilities.Library
 open Internal.Utilities.Library.Extras
@@ -823,49 +824,67 @@ let main3
     ReportTime tcConfig "Encode Interface Data"
     let exportRemapping = MakeExportRemapping generatedCcu generatedCcu.Contents
 
-    let sigDataAttributes, sigDataResources =
-        try
-            EncodeSignatureData(tcConfig, tcGlobals, exportRemapping, generatedCcu, outfile, false)
-        with e ->
-            errorRecoveryNoRange e
-            exiter.Exit 1
-
     let metadataVersion =
         match tcConfig.metadataVersion with
         | Some v -> v
         | _ ->
             match frameworkTcImports.DllTable.TryFind tcConfig.primaryAssembly.Name with
             | Some ib -> ib.RawMetadata.TryGetILModuleDef().Value.MetadataVersion
             | _ -> ""
+
+    let (sigDataAttributes, sigDataResources), optimizedImpls, optDataResources =
+        let mutable sigDataAttributes: ILAttribute list = []
+        let mutable sigDataResources : ILResource list = []
+        let a1 =
+            async {
+                try
+                    let sigDataAttributes2, sigDataResources2 = EncodeSignatureData(tcConfig, tcGlobals, exportRemapping, generatedCcu, outfile, false)
+                    sigDataAttributes <- sigDataAttributes2
+                    sigDataResources <- sigDataResources2
+                with e ->
+                    errorRecoveryNoRange e
+                    exiter.Exit 1
+            }
 
-    let optimizedImpls, optDataResources =
-        // Perform optimization
-        use _ = UseBuildPhase BuildPhase.Optimize
-
-        let optEnv0 = GetInitialOptimizationEnv(tcImports, tcGlobals)
-
-        let importMap = tcImports.GetImportMap()
-
-        let optimizedImpls, optimizationData, _ =
-            ApplyAllOptimizations(
-                tcConfig,
-                tcGlobals,
-                (LightweightTcValForUsingInBuildMethodCall tcGlobals),
-                outfile,
-                importMap,
-                false,
-                optEnv0,
-                generatedCcu,
-                typedImplFiles
-            )
-
-        AbortOnError(diagnosticsLogger, exiter)
+        let mutable optimizedImpls2 : CheckedAssemblyAfterOptimization option = None
+        let mutable optDataResources : ILResource list = []
+        let a2 =
+            async {
+                // Perform optimization
+                use _ = UseBuildPhase BuildPhase.Optimize
+
+                let optEnv0 = GetInitialOptimizationEnv(tcImports, tcGlobals)
+
+                let importMap = tcImports.GetImportMap()
+
+                let optimizedImpls, optimizationData, _ =
+                    ApplyAllOptimizations(
+                        tcConfig,
+                        tcGlobals,
+                        (LightweightTcValForUsingInBuildMethodCall tcGlobals),
+                        outfile,
+                        importMap,
+                        false,
+                        optEnv0,
+                        generatedCcu,
+                        typedImplFiles
+                    )
 
-        // Encode the optimization data
-        ReportTime tcConfig ("Encoding OptData")
+                AbortOnError(diagnosticsLogger, exiter)
 
-        optimizedImpls, EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData), false)
+                // Encode the optimization data
+                ReportTime tcConfig ("Encoding OptData")
 
+                optimizedImpls2 <- Some optimizedImpls
+                optDataResources <- EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData), false)
+            }
+
+        let t1 = a1 |> Async.StartAsTask
+        let t2 = a2 |> Async.StartAsTask
+        t1.Wait()
+        t2.Wait()
+        (sigDataAttributes, sigDataResources), optimizedImpls2.Value, optDataResources
+
     // Pass on only the minimum information required for the next phase
     Args(
         ctok,

src/Compiler/FSharp.Compiler.Service.fsproj

@@ -387,6 +387,8 @@
     <Compile Include="Driver\ScriptClosure.fs" />
     <Compile Include="Driver\CompilerOptions.fsi" />
     <Compile Include="Driver\CompilerOptions.fs" />
+    <Compile Include="Driver\Parallel.fs" />
+    <Compile Include="Driver\OptimizeTypes.fs" />
     <Compile Include="Driver\OptimizeInputs.fsi" />
     <Compile Include="Driver\OptimizeInputs.fs" />
     <Compile Include="Driver\XmlDocFileWriter.fsi" />