Parallel parsing - 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

@@ -393,31 +393,95 @@ 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) =
+    // 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)
 
+/// 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
         EmptyParsedInput(filename, isLastCompiland) 
 
+/// Parse multiple input files from disk
+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 directoryName = Path.GetDirectoryName filename
+                        let input = parseInputFileAux(tcConfig, lexResourceManager, conditionalCompilationDefines, filename, (isLastCompiland, isExe), delayedErrorLogger, retryLocked)
+                        (input, directoryName)
+                    )
+                with
+                | StopProcessing ->
+                    commitDelayedErrorLoggers ()
+                    exiter.Exit exitCode
+
+                | _ ->
+                    commitDelayedErrorLoggers ()
+                    reraise()
+
+            commitDelayedErrorLoggers ()
+
+            results
+            |> List.ofArray
+        else
+            sourceFiles
+            |> Array.map (fun (filename, isLastCompiland) ->
+                let directoryName = Path.GetDirectoryName filename
+                let input = ParseOneInputFile(tcConfig, lexResourceManager, conditionalCompilationDefines, filename, (isLastCompiland, isExe), errorLogger, retryLocked)
+                (input, directoryName))
+            |> List.ofArray
+
+    with e ->
+        errorRecoveryNoRange e
+        exiter.Exit 1
+
 let ProcessMetaCommandsFromInput
      (nowarnF: 'state -> range * string -> 'state,
       hashReferenceF: 'state -> range * string * Directive -> 'state,

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
+val ParseOneInputFile: TcConfig * Lexhelp.LexResourceManager * conditionalCompilationDefines: string list * string * isLastCompiland: (bool * bool) * ErrorLogger * retryLocked: bool -> ParsedInput
+
+/// Parse multiple input files from disk
+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.

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
@@ -513,22 +514,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.map (fun (sourceFile, isLastCompiland) -> 
-
-                let sourceFileDirectory = Path.GetDirectoryName sourceFile
-
-                let input = ParseOneInputFile(tcConfig, lexResourceManager, ["COMPILED"], sourceFile, (isLastCompiland, isExe), errorLogger, (*retryLocked*)false)
-                (input, sourceFileDirectory)) 
-
-        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,12 @@ 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 map : ('T -> 'U) -> 'T [] -> 'U []
+
+    val inline mapi : (int -> 'T -> 'U) -> 'T [] -> 'U []