[WIP] Parallel type checking for impl files with backing sig files - fsc.exe

src/fsharp/CompilerConfig.fs

@@ -425,6 +425,7 @@ type TcConfigBuilder =
       mutable optSettings: Optimizer.OptimizationSettings 
       mutable emitTailcalls: bool
       mutable deterministic: bool
+      mutable concurrentBuild: bool
       mutable preferredUiLang: string option
       mutable lcid: int option
       mutable productNameForBannerText: string
@@ -625,6 +626,7 @@ type TcConfigBuilder =
           optSettings = Optimizer.OptimizationSettings.Defaults
           emitTailcalls = true
           deterministic = false
+          concurrentBuild = true
           preferredUiLang = None
           lcid = None
           productNameForBannerText = FSharpProductName
@@ -1001,6 +1003,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) =
     member x.optSettings = data.optSettings
     member x.emitTailcalls = data.emitTailcalls
     member x.deterministic = data.deterministic
+    member x.concurrentBuild = data.concurrentBuild
     member x.pathMap = data.pathMap
     member x.langVersion = data.langVersion
     member x.preferredUiLang = data.preferredUiLang

src/fsharp/CompilerConfig.fsi

@@ -232,6 +232,7 @@ type TcConfigBuilder =
       mutable optSettings  : Optimizer.OptimizationSettings 
       mutable emitTailcalls: bool
       mutable deterministic: bool
+      mutable concurrentBuild: bool
       mutable preferredUiLang: string option
       mutable lcid        : int option
       mutable productNameForBannerText: string
@@ -417,6 +418,7 @@ type TcConfig =
     member optSettings  : Optimizer.OptimizationSettings 
     member emitTailcalls: bool
     member deterministic: bool
+    member concurrentBuild: bool
     member pathMap: PathMap
     member preferredUiLang: string option
     member optsOn       : bool 

src/fsharp/CompilerOptions.fs

@@ -1036,6 +1036,7 @@ let testFlag tcConfigB =
                 | "DumpDebugInfo"    -> tcConfigB.dumpDebugInfo <- true
                 | "ShowLoadedAssemblies" -> tcConfigB.showLoadedAssemblies <- true
                 | "ContinueAfterParseFailure" -> tcConfigB.continueAfterParseFailure <- true
+                | "ParallelOff" -> tcConfigB.concurrentBuild <- false
 #if DEBUG
                 | "ShowParserStackOnParseError" -> showParserStackOnParseError <- true
 #endif

src/fsharp/ParseAndCheckInputs.fs

@@ -368,31 +368,106 @@ let ParseOneInputLexbuf (tcConfig: TcConfig, lexResourceManager, conditionalComp
 
 let ValidSuffixes = FSharpSigFileSuffixes@FSharpImplFileSuffixes
 
-/// Parse an input from disk
-let ParseOneInputFile (tcConfig: TcConfig, lexResourceManager, conditionalCompilationDefines, filename, isLastCompiland, errorLogger, retryLocked) =
-    try 
-       let lower = String.lowercase filename
-
-       if List.exists (Filename.checkSuffix lower) ValidSuffixes then  
+let checkInputFile (tcConfig: TcConfig) filename =
+    let lower = String.lowercase filename
 
-            if not(FileSystem.SafeExists filename) then
-                error(Error(FSComp.SR.buildCouldNotFindSourceFile filename, rangeStartup))
+    if List.exists (Filename.checkSuffix lower) ValidSuffixes then 
+        if not(FileSystem.SafeExists filename) then
+            error(Error(FSComp.SR.buildCouldNotFindSourceFile filename, rangeStartup))
+    else
+        error(Error(FSComp.SR.buildInvalidSourceFileExtension(SanitizeFileName filename tcConfig.implicitIncludeDir), rangeStartup))
 
-            // Get a stream reader for the file
-            use reader = File.OpenReaderAndRetry (filename, tcConfig.inputCodePage, retryLocked)
+let parseInputFileAux (tcConfig: TcConfig, lexResourceManager, conditionalCompilationDefines, filename, isLastCompiland, errorLogger, retryLocked) =
+    try
+        // Get a stream reader for the file
+        use reader = File.OpenReaderAndRetry (filename, tcConfig.inputCodePage, retryLocked)
 
-            // Set up the LexBuffer for the file
-            let lexbuf = UnicodeLexing.StreamReaderAsLexbuf(tcConfig.langVersion.SupportsFeature, reader)
+        // Set up the LexBuffer for the file
+        let lexbuf = UnicodeLexing.StreamReaderAsLexbuf(tcConfig.langVersion.SupportsFeature, reader)
 
-            // Parse the file drawing tokens from the lexbuf
-            ParseOneInputLexbuf(tcConfig, lexResourceManager, conditionalCompilationDefines, lexbuf, filename, isLastCompiland, errorLogger)
-       else
-           error(Error(FSComp.SR.buildInvalidSourceFileExtension(SanitizeFileName filename tcConfig.implicitIncludeDir), rangeStartup))
+        // Parse the file drawing tokens from the lexbuf
+        ParseOneInputLexbuf(tcConfig, lexResourceManager, conditionalCompilationDefines, lexbuf, filename, isLastCompiland, errorLogger)
+    with e -> 
+        errorRecovery e rangeStartup
+        None 
 
+/// Parse an input from disk
+let ParseOneInputFile (tcConfig: TcConfig, lexResourceManager, conditionalCompilationDefines, filename, isLastCompiland, errorLogger, retryLocked) =
+    try 
+       checkInputFile tcConfig filename
+       parseInputFileAux(tcConfig, lexResourceManager, conditionalCompilationDefines, filename, isLastCompiland, errorLogger, retryLocked)
     with e -> 
         errorRecovery e rangeStartup
         None 
 
+/// Parse multiple input files
+let ParseInputFiles (tcConfig: TcConfig, lexResourceManager, conditionalCompilationDefines, sourceFiles, errorLogger: ErrorLogger, exiter: Exiter, createErrorLogger: (Exiter -> CapturingErrorLogger), retryLocked) =
+    try
+        let isLastCompiland, isExe = sourceFiles |> tcConfig.ComputeCanContainEntryPoint
+        let sourceFiles = isLastCompiland |> List.zip sourceFiles |> Array.ofSeq
+
+        if tcConfig.concurrentBuild then
+            let mutable exitCode = 0
+            let delayedExiter = 
+                { new Exiter with
+                        member this.Exit n = exitCode <- n; raise StopProcessing }
+
+            // Check input files and create delayed error loggers before we try to parallel parse.
+            let delayedErrorLoggers =
+                sourceFiles
+                |> Array.map (fun (filename, _) ->
+                    checkInputFile tcConfig filename
+                    createErrorLogger(delayedExiter)
+                )
+
+            let commitDelayedErrorLoggers () =
+                delayedErrorLoggers
+                |> Array.iter (fun delayedErrorLogger ->
+                    delayedErrorLogger.CommitDelayedDiagnostics errorLogger
+                )
+
+            let results =
+                try
+                    sourceFiles 
+                    |> ArrayParallel.mapi (fun i (filename, isLastCompiland) ->
+                        let delayedErrorLogger = delayedErrorLoggers.[i]
+
+                        let result =
+                            let directoryName = Path.GetDirectoryName filename
+                            match parseInputFileAux(tcConfig, lexResourceManager, conditionalCompilationDefines, filename, (isLastCompiland, isExe), errorLogger, retryLocked) with
+                            | Some input -> Some (input, directoryName)
+                            | None -> None
+
+                        delayedErrorLogger, result
+                    )
+                with
+                | StopProcessing ->
+                    commitDelayedErrorLoggers ()
+                    exiter.Exit exitCode
+
+                | _ ->
+                    commitDelayedErrorLoggers ()
+                    reraise()
+
+            results
+            |> Array.choose (fun (delayedErrorLogger, result) -> 
+                delayedErrorLogger.CommitDelayedDiagnostics errorLogger
+                result
+            )
+            |> List.ofArray
+        else
+            sourceFiles
+            |> Array.choose (fun (filename, isLastCompiland) ->
+                let directoryName = Path.GetDirectoryName filename
+                match ParseOneInputFile(tcConfig, lexResourceManager, conditionalCompilationDefines, filename, (isLastCompiland, isExe), errorLogger, retryLocked) with
+                | Some input -> Some (input, directoryName)
+                | None -> None)
+            |> List.ofArray
+
+    with e ->
+        errorRecoveryNoRange e
+        exiter.Exit 1
+
 let ProcessMetaCommandsFromInput
      (nowarnF: 'state -> range * string -> 'state,
       hashReferenceF: 'state -> range * string * Directive -> 'state,
@@ -628,6 +703,9 @@ type TcState =
         { x with tcsTcSigEnv = tcEnvAtEndOfLastInput
                  tcsTcImplEnv = tcEnvAtEndOfLastInput }
 
+    member x.RemoveImpl qualifiedNameOfFile =
+        { x with tcsRootImpls = x.tcsRootImpls.Remove(qualifiedNameOfFile) }
+
 
 /// Create the initial type checking state for compiling an assembly
 let GetInitialTcState(m, ccuName, tcConfig: TcConfig, tcGlobals, tcImports: TcImports, niceNameGen, tcEnv0) =
@@ -804,6 +882,14 @@ let TypeCheckOneInput (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, pre
     TypeCheckOneInputEventually (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, TcResultsSink.NoSink, tcState, inp, false) 
         |> Eventually.force ctok
 
+/// Typecheck a single file (or interactive entry into F# Interactive)
+let TypeCheckOneInputSkipImpl (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt) tcState inp =
+    // 'use' ensures that the warning handler is restored at the end
+    use unwindEL = PushErrorLoggerPhaseUntilUnwind(fun oldLogger -> GetErrorLoggerFilteringByScopedPragmas(false, GetScopedPragmasForInput inp, oldLogger) )
+    use unwindBP = PushThreadBuildPhaseUntilUnwind BuildPhase.TypeCheck
+    TypeCheckOneInputEventually (checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, TcResultsSink.NoSink, tcState, inp, true) 
+        |> Eventually.force ctok
+
 /// Finish checking multiple files (or one interactive entry into F# Interactive)
 let TypeCheckMultipleInputsFinish(results, tcState: TcState) =
     let tcEnvsAtEndFile, topAttrs, implFiles, ccuSigsForFiles = List.unzip4 results
@@ -833,9 +919,39 @@ let TypeCheckClosedInputSetFinish (declaredImpls: TypedImplFile list, tcState) =
 
     tcState, declaredImpls
 
-let TypeCheckClosedInputSet (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) =
+let TypeCheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) =
     // tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions 
-    let results, tcState = (tcState, inputs) ||> List.mapFold (TypeCheckOneInput (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt)) 
+    let results, tcState =
+        if tcConfig.concurrentBuild then
+            let results, tcState = (tcState, inputs) ||> List.mapFold (TypeCheckOneInputSkipImpl (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt)) 
+
+            let inputs = Array.ofList inputs
+            let newResults = Array.ofList results
+            let results = Array.ofList results
+
+            (inputs, results) 
+            ||> Array.zip
+            |> Array.mapi (fun i (input, (_, _, implOpt, _)) ->
+                match implOpt with
+                | None -> None
+                | Some impl ->
+                    match impl with
+                    | TypedImplFile.TImplFile(qualifiedNameOfFile=qualifiedNameOfFile;implementationExpressionWithSignature=ModuleOrNamespaceExprWithSig.ModuleOrNamespaceExprWithSig(contents=ModuleOrNamespaceExpr.TMDefs [])) ->
+                        Some(i, input, qualifiedNameOfFile)
+                    | _ ->
+                        None
+            )
+            |> Array.choose id
+            |> ArrayParallel.iter (fun (i, input, qualifiedNameOfFile) ->
+                let tcState = tcState.RemoveImpl(qualifiedNameOfFile)
+                let result, _ = TypeCheckOneInput (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt) tcState input
+                newResults.[i] <- result
+            )
+
+            newResults |> List.ofArray, tcState
+        else
+            (tcState, inputs) ||> List.mapFold (TypeCheckOneInputSkipImpl (ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt)) 
+
     let (tcEnvAtEndOfLastFile, topAttrs, implFiles, _), tcState = TypeCheckMultipleInputsFinish(results, tcState)
     let tcState, declaredImpls = TypeCheckClosedInputSetFinish (implFiles, tcState)
     tcState, topAttrs, declaredImpls, tcEnvAtEndOfLastFile

src/fsharp/ParseAndCheckInputs.fsi

@@ -47,7 +47,10 @@ val ApplyMetaCommandsFromInputToTcConfig: TcConfig * ParsedInput * string * Depe
 val ApplyNoWarnsToTcConfig: TcConfig * ParsedInput * string -> TcConfig
 
 /// Parse one input file
-val ParseOneInputFile: TcConfig * Lexhelp.LexResourceManager * string list * string * isLastCompiland: (bool * bool) * ErrorLogger * (*retryLocked*) bool -> ParsedInput option
+val ParseOneInputFile: TcConfig * Lexhelp.LexResourceManager * conditionalCompilationDefines: string list * string * isLastCompiland: (bool * bool) * ErrorLogger * retryLocked: bool -> ParsedInput option
+
+/// Parse multiple input files
+val ParseInputFiles: TcConfig * Lexhelp.LexResourceManager * conditionalCompilationDefines: string list * string list * ErrorLogger * Exiter * createErrorLogger: (Exiter -> CapturingErrorLogger) * retryLocked: bool ->  (ParsedInput * string) list
 
 /// Get the initial type checking environment including the loading of mscorlib/System.Core, FSharp.Core
 /// applying the InternalsVisibleTo in referenced assemblies and opening 'Checked' if requested.
@@ -75,6 +78,8 @@ type TcState =
 
     member CreatesGeneratedProvidedTypes: bool
 
+    member RemoveImpl: QualifiedNameOfFile -> TcState
+
 /// Get the initial type checking state for a set of inputs
 val GetInitialTcState: 
     range * string * TcConfig * TcGlobals * TcImports * NiceNameGenerator * TcEnv -> TcState

src/fsharp/fsc.fs

@@ -19,6 +19,7 @@ open System.IO
 open System.Reflection
 open System.Text
 open System.Threading
+open System.Threading.Tasks
 
 open Internal.Utilities
 open Internal.Utilities.Filename
@@ -543,23 +544,8 @@ let main1(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted,
     ReportTime tcConfig "Parse inputs"
     use unwindParsePhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse
 
-    let inputs =
-        try
-            let isLastCompiland, isExe = sourceFiles |> tcConfig.ComputeCanContainEntryPoint 
-
-            List.zip sourceFiles isLastCompiland
-            // PERF: consider making this parallel, once uses of global state relevant to parsing are cleaned up 
-            |> List.choose (fun (sourceFile, isLastCompiland) -> 
-
-                let sourceFileDirectory = Path.GetDirectoryName sourceFile
-
-                match ParseOneInputFile(tcConfig, lexResourceManager, ["COMPILED"], sourceFile, (isLastCompiland, isExe), errorLogger, (*retryLocked*)false) with
-                | Some input -> Some (input, sourceFileDirectory)
-                | None -> None) 
-
-        with e -> 
-            errorRecoveryNoRange e
-            exiter.Exit 1
+    let createErrorLogger = (fun exiter -> errorLoggerProvider.CreateDelayAndForwardLogger(exiter) :> CapturingErrorLogger)
+    let inputs = ParseInputFiles(tcConfig, lexResourceManager, ["COMPILED"], sourceFiles, errorLogger, exiter, createErrorLogger, (*retryLocked*)false)
 
     let inputs, _ =
         (Map.empty, inputs) ||> List.mapFold (fun state (input, x) ->

src/fsharp/lib.fs

@@ -5,6 +5,7 @@ module internal Internal.Utilities.Library.Extras
 open System
 open System.IO
 open System.Collections.Generic
+open System.Threading.Tasks
 open System.Runtime.InteropServices
 open Internal.Utilities
 open Internal.Utilities.Collections
@@ -594,3 +595,26 @@ type DisposablesTracker() =
             items.Clear()
             for i in l do 
                 try i.Dispose() with _ -> ()
+
+/// Specialized parallel functions for an array.
+/// Different from Array.Parallel as it will try to minimize the max degree of parallelism.
+[<RequireQualifiedAccess>]
+module ArrayParallel =
+
+    let inline iteri f (arr: 'T []) =
+        let parallelOptions = ParallelOptions(MaxDegreeOfParallelism = max (min Environment.ProcessorCount arr.Length) 1)
+        Parallel.For(0, arr.Length, parallelOptions, fun i ->
+            f i arr.[i]
+        ) |> ignore
+
+    let inline iter f (arr: 'T []) =
+        arr |> iteri (fun _ item -> f item)
+
+    let inline mapi f (arr: 'T []) =
+        let mapped = Array.zeroCreate arr.Length
+        arr |> iteri (fun i item -> mapped.[i] <- f i item)
+        mapped
+
+    let inline map f (arr: 'T []) =
+        arr |> mapi (fun _ item -> f item)
+

src/fsharp/lib.fsi

@@ -288,3 +288,16 @@ type DisposablesTracker =
     member Register: i:System.IDisposable -> unit
 
     interface System.IDisposable
+
+/// Specialized parallel functions for an array.
+/// Different from Array.Parallel as it will try to minimize the max degree of parallelism.
+[<RequireQualifiedAccess>]
+module ArrayParallel =
+
+    val inline iter : ('T -> unit) -> 'T [] -> unit
+
+    val inline iteri : (int -> 'T -> unit) -> 'T [] -> unit
+
+    val inline map : ('T -> 'U) -> 'T [] -> 'U []
+
+    val inline mapi : (int -> 'T -> 'U) -> 'T [] -> 'U []