diff --git a/src/fsharp/CompilerConfig.fs b/src/fsharp/CompilerConfig.fs index 042df6f95a8..21af02c5ec1 100644 --- a/src/fsharp/CompilerConfig.fs +++ b/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 diff --git a/src/fsharp/CompilerConfig.fsi b/src/fsharp/CompilerConfig.fsi index 5442a723133..3239c9c528f 100644 --- a/src/fsharp/CompilerConfig.fsi +++ b/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 diff --git a/src/fsharp/CompilerOptions.fs b/src/fsharp/CompilerOptions.fs index 9262b958825..bbd23702972 100644 --- a/src/fsharp/CompilerOptions.fs +++ b/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 diff --git a/src/fsharp/ParseAndCheckInputs.fs b/src/fsharp/ParseAndCheckInputs.fs index a0667246250..92e45f30a31 100644 --- a/src/fsharp/ParseAndCheckInputs.fs +++ b/src/fsharp/ParseAndCheckInputs.fs @@ -393,31 +393,88 @@ 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 results = + try + 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) + ) + finally + delayedErrorLoggers + |> Array.iter (fun delayedErrorLogger -> + delayedErrorLogger.CommitDelayedDiagnostics errorLogger + ) + with + | StopProcessing -> + exiter.Exit exitCode + + 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, diff --git a/src/fsharp/ParseAndCheckInputs.fsi b/src/fsharp/ParseAndCheckInputs.fsi index fe74f7ede2b..c7a68dd894a 100644 --- a/src/fsharp/ParseAndCheckInputs.fsi +++ b/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. diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs index 3c2dce50b12..09b71d8835d 100644 --- a/src/fsharp/fsc.fs +++ b/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) -> diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index 692046b92e5..12f9574c65f 100755 --- a/src/fsharp/lib.fs +++ b/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,31 @@ 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. +/// Will flatten aggregate exceptions that contain one exception. +[] +module ArrayParallel = + + let inline iteri f (arr: 'T []) = + let parallelOptions = ParallelOptions(MaxDegreeOfParallelism = max (min Environment.ProcessorCount arr.Length) 1) + try + Parallel.For(0, arr.Length, parallelOptions, fun i -> + f i arr.[i] + ) |> ignore + with + | :? AggregateException as ex when ex.InnerExceptions.Count = 1 -> + raise(ex.InnerExceptions.[0]) + + 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) + \ No newline at end of file diff --git a/src/fsharp/lib.fsi b/src/fsharp/lib.fsi index ceea83cf55b..08cdc407424 100644 --- a/src/fsharp/lib.fsi +++ b/src/fsharp/lib.fsi @@ -288,3 +288,13 @@ 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. +/// Will flatten aggregate exceptions that contain one exception. +[] +module ArrayParallel = + + val inline map : ('T -> 'U) -> 'T [] -> 'U [] + + val inline mapi : (int -> 'T -> 'U) -> 'T [] -> 'U [] \ No newline at end of file