diff --git a/src/Compiler/Driver/GraphChecking/TypeCheckingGraphProcessing.fs b/src/Compiler/Driver/GraphChecking/TypeCheckingGraphProcessing.fs deleted file mode 100644 index 7f184a58880..00000000000 --- a/src/Compiler/Driver/GraphChecking/TypeCheckingGraphProcessing.fs +++ /dev/null @@ -1,104 +0,0 @@ -module internal FSharp.Compiler.GraphChecking.TypeCheckingGraphProcessing - -open GraphProcessing -open System.Collections.Generic -open System.Threading - -// TODO Do we need to suppress some error logging if we -// TODO apply the same partial results multiple times? -// TODO Maybe we can enable logging only for the final fold -/// -/// Combine type-checking results of dependencies needed to type-check a 'higher' node in the graph -/// -/// Initial state -/// Direct dependencies of a node -/// Transitive dependencies of a node -/// A way to fold a single result into existing state -/// -/// Similar to 'processFileGraph', this function is generic yet specific to the type-checking process. -/// -let combineResults - (emptyState: 'State) - (deps: ProcessedNode<'Item, 'State * Finisher<'State, 'FinalFileResult>>[]) - (transitiveDeps: ProcessedNode<'Item, 'State * Finisher<'State, 'FinalFileResult>>[]) - (folder: 'State -> Finisher<'State, 'FinalFileResult> -> 'State) - : 'State = - match deps with - | [||] -> emptyState - | _ -> - // Instead of starting with empty state, - // reuse state produced by the dependency with the biggest number of transitive dependencies. - // This is to reduce the number of folds required to achieve the final state. - let biggestDependency = - let sizeMetric (node: ProcessedNode<_, _>) = node.Info.TransitiveDeps.Length - deps |> Array.maxBy sizeMetric - - let firstState = biggestDependency.Result |> fst - - // Find items not already included in the state. - // Note: Ordering is not preserved due to reusing results of the biggest child - // rather than starting with empty state - let itemsPresent = - set - [| - yield! biggestDependency.Info.TransitiveDeps - yield biggestDependency.Info.Item - |] - - let resultsToAdd = - transitiveDeps - |> Array.filter (fun dep -> itemsPresent.Contains dep.Info.Item = false) - |> Array.distinctBy (fun dep -> dep.Info.Item) - |> Array.map (fun dep -> dep.Result |> snd) - - // Fold results not already included and produce the final state - let state = Array.fold folder firstState resultsToAdd - state - -// TODO This function and its parameters are quite specific to type-checking despite using generic types. -// Perhaps we should make it either more specific and remove type parameters, or more generic. -/// -/// Process a graph of items. -/// A version of 'GraphProcessing.processGraph' with a signature slightly specific to type-checking. -/// -let processTypeCheckingGraph<'Item, 'ChosenItem, 'State, 'FinalFileResult when 'Item: equality and 'Item: comparison> - (graph: Graph<'Item>) - (work: 'Item -> 'State -> Finisher<'State, 'FinalFileResult>) - (folder: 'State -> Finisher<'State, 'FinalFileResult> -> 'FinalFileResult * 'State) - // Decides whether a result for an item should be included in the final state, and how to map the item if it should. - (finalStateChooser: 'Item -> 'ChosenItem option) - (emptyState: 'State) - (ct: CancellationToken) - : ('ChosenItem * 'FinalFileResult) list * 'State = - - let workWrapper - (getProcessedNode: 'Item -> ProcessedNode<'Item, 'State * Finisher<'State, 'FinalFileResult>>) - (node: NodeInfo<'Item>) - : 'State * Finisher<'State, 'FinalFileResult> = - let folder x y = folder x y |> snd - let deps = node.Deps |> Array.except [| node.Item |] |> Array.map getProcessedNode - - let transitiveDeps = - node.TransitiveDeps - |> Array.except [| node.Item |] - |> Array.map getProcessedNode - - let inputState = combineResults emptyState deps transitiveDeps folder - let singleRes = work node.Item inputState - let state = folder inputState singleRes - state, singleRes - - let results = processGraph graph workWrapper ct - - let finalFileResults, state: ('ChosenItem * 'FinalFileResult) list * 'State = - (([], emptyState), - results - |> Array.choose (fun (item, res) -> - match finalStateChooser item with - | Some item -> Some(item, res) - | None -> None)) - ||> Array.fold (fun (fileResults, state) (item, (_, itemRes)) -> - let fileResult, state = folder state itemRes - (item, fileResult) :: fileResults, state) - - finalFileResults, state diff --git a/src/Compiler/Driver/GraphChecking/TypeCheckingGraphProcessing.fsi b/src/Compiler/Driver/GraphChecking/TypeCheckingGraphProcessing.fsi deleted file mode 100644 index 5db01dc3307..00000000000 --- a/src/Compiler/Driver/GraphChecking/TypeCheckingGraphProcessing.fsi +++ /dev/null @@ -1,17 +0,0 @@ -/// Parallel processing of a type-checking file graph. -module internal FSharp.Compiler.GraphChecking.TypeCheckingGraphProcessing - -open System.Threading - -/// -/// Process a graph of items. -/// A version of 'GraphProcessing.processGraph' with a signature slightly specific to type-checking. -/// -val processTypeCheckingGraph<'Item, 'ChosenItem, 'State, 'FinalFileResult when 'Item: equality and 'Item: comparison> : - graph: Graph<'Item> -> - work: ('Item -> 'State -> Finisher<'State, 'FinalFileResult>) -> - folder: ('State -> Finisher<'State, 'FinalFileResult> -> 'FinalFileResult * 'State) -> - finalStateChooser: ('Item -> 'ChosenItem option) -> - emptyState: 'State -> - ct: CancellationToken -> - ('ChosenItem * 'FinalFileResult) list * 'State diff --git a/src/Compiler/Driver/GraphChecking/Types.fs b/src/Compiler/Driver/GraphChecking/Types.fs index c0e8e0f84b1..04359519b95 100644 --- a/src/Compiler/Driver/GraphChecking/Types.fs +++ b/src/Compiler/Driver/GraphChecking/Types.fs @@ -167,4 +167,4 @@ type internal FilePairMap(files: FileInProject array) = member x.IsSignature(index: FileIndex) = Map.containsKey index sigToImpl /// Callback that returns a previously calculated 'Result and updates 'State accordingly. -type internal Finisher<'State, 'Result> = delegate of 'State -> 'Result * 'State +type internal Finisher<'Node, 'State, 'Result> = Finisher of node: 'Node * finisher: ('State -> 'Result * 'State) diff --git a/src/Compiler/Driver/GraphChecking/Types.fsi b/src/Compiler/Driver/GraphChecking/Types.fsi index 7d0ba9bbdd5..67403d51d98 100644 --- a/src/Compiler/Driver/GraphChecking/Types.fsi +++ b/src/Compiler/Driver/GraphChecking/Types.fsi @@ -114,4 +114,4 @@ type internal FilePairMap = member IsSignature: index: FileIndex -> bool /// Callback that returns a previously calculated 'Result and updates 'State accordingly. -type internal Finisher<'State, 'Result> = delegate of 'State -> 'Result * 'State +type internal Finisher<'Node, 'State, 'Result> = Finisher of node: 'Node * finisher: ('State -> 'Result * 'State) diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index dfdbdf682d4..a731cc2e05a 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -1472,11 +1472,10 @@ type NodeToTypeCheck = /// Even though the actual implementation file was not type-checked. | ArtificialImplFile of signatureFileIndex: FileIndex -let folder (state: State) (finisher: Finisher) : FinalFileResult * State = finisher.Invoke(state) - /// Typecheck a single file (or interactive entry into F# Interactive) /// a callback functions that takes a `TcState` and will add the checked result to it. let CheckOneInputWithCallback + (node: NodeToTypeCheck) ((checkForErrors, tcConfig: TcConfig, tcImports: TcImports, @@ -1486,7 +1485,7 @@ let CheckOneInputWithCallback tcState: TcState, inp: ParsedInput, _skipImplIfSigExists: bool): (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * bool) - : Cancellable> = + : Cancellable> = cancellable { try CheckSimulateException tcConfig @@ -1535,25 +1534,29 @@ let CheckOneInputWithCallback TcOpenModuleOrNamespaceDecl tcSink tcGlobals amap m tcEnv (prefixPath, m) return - Finisher(fun tcState -> - let rootSigs = Zmap.add qualNameOfFile sigFileType tcState.tcsRootSigs + Finisher( + node, + (fun tcState -> + let rootSigs = Zmap.add qualNameOfFile sigFileType tcState.tcsRootSigs - let tcSigEnv = - AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcState.tcsTcSigEnv sigFileType + let tcSigEnv = + AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcState.tcsTcSigEnv sigFileType - // Add the signature to the signature env (unless it had an explicit signature) - let ccuSigForFile = CombineCcuContentFragments [ sigFileType; tcState.tcsCcuSig ] + // Add the signature to the signature env (unless it had an explicit signature) + let ccuSigForFile = CombineCcuContentFragments [ sigFileType; tcState.tcsCcuSig ] - let partialResult = tcEnv, EmptyTopAttrs, None, ccuSigForFile + let partialResult = tcEnv, EmptyTopAttrs, None, ccuSigForFile - let tcState = - { tcState with - tcsTcSigEnv = tcSigEnv - tcsRootSigs = rootSigs - tcsCreatesGeneratedProvidedTypes = tcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes - } + let tcState = + { tcState with + tcsTcSigEnv = tcSigEnv + tcsRootSigs = rootSigs + tcsCreatesGeneratedProvidedTypes = + tcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes + } - partialResult, tcState) + partialResult, tcState) + ) | ParsedInput.ImplFile file -> let qualNameOfFile = file.QualifiedName @@ -1579,29 +1582,32 @@ let CheckOneInputWithCallback ) return - Finisher(fun tcState -> - // Check if we've already seen an implementation for this fragment - if Zset.contains qualNameOfFile tcState.tcsRootImpls then - errorR (Error(FSComp.SR.buildImplementationAlreadyGiven (qualNameOfFile.Text), m)) - - let ccuSigForFile, fsTcState = - AddCheckResultsToTcState - (tcGlobals, amap, false, prefixPathOpt, tcSink, tcState.tcsTcImplEnv, qualNameOfFile, implFile.Signature) - tcState - - let partialResult = tcEnvAtEnd, topAttrs, Some implFile, ccuSigForFile - - let tcState = - { fsTcState with - tcsCreatesGeneratedProvidedTypes = - fsTcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes - } - - partialResult, tcState) + Finisher( + node, + (fun tcState -> + // Check if we've already seen an implementation for this fragment + if Zset.contains qualNameOfFile tcState.tcsRootImpls then + errorR (Error(FSComp.SR.buildImplementationAlreadyGiven (qualNameOfFile.Text), m)) + + let ccuSigForFile, fsTcState = + AddCheckResultsToTcState + (tcGlobals, amap, false, prefixPathOpt, tcSink, tcState.tcsTcImplEnv, qualNameOfFile, implFile.Signature) + tcState + + let partialResult = tcEnvAtEnd, topAttrs, Some implFile, ccuSigForFile + + let tcState = + { fsTcState with + tcsCreatesGeneratedProvidedTypes = + fsTcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes + } + + partialResult, tcState) + ) with e -> errorRecovery e range0 - return Finisher(fun tcState -> (tcState.TcEnvFromSignatures, EmptyTopAttrs, None, tcState.tcsCcuSig), tcState) + return Finisher(node, (fun tcState -> (tcState.TcEnvFromSignatures, EmptyTopAttrs, None, tcState.tcsCcuSig), tcState)) } let AddSignatureResultToTcImplEnv (tcImports: TcImports, tcGlobals, prefixPathOpt, tcSink, tcState, input: ParsedInput) = @@ -1626,6 +1632,106 @@ let AddSignatureResultToTcImplEnv (tcImports: TcImports, tcGlobals, prefixPathOp partialResult, tcState +module private TypeCheckingGraphProcessing = + open FSharp.Compiler.GraphChecking.GraphProcessing + + // TODO Do we need to suppress some error logging if we + // TODO apply the same partial results multiple times? + // TODO Maybe we can enable logging only for the final fold + /// + /// Combine type-checking results of dependencies needed to type-check a 'higher' node in the graph + /// + /// Initial state + /// Direct dependencies of a node + /// Transitive dependencies of a node + /// A way to fold a single result into existing state + let private combineResults + (emptyState: State) + (deps: ProcessedNode> array) + (transitiveDeps: ProcessedNode> array) + (folder: State -> Finisher -> State) + : State = + match deps with + | [||] -> emptyState + | _ -> + // Instead of starting with empty state, + // reuse state produced by the dependency with the biggest number of transitive dependencies. + // This is to reduce the number of folds required to achieve the final state. + let biggestDependency = + let sizeMetric (node: ProcessedNode<_, _>) = node.Info.TransitiveDeps.Length + deps |> Array.maxBy sizeMetric + + let firstState = biggestDependency.Result |> fst + + // Find items not already included in the state. + let itemsPresent = + set + [| + yield! biggestDependency.Info.TransitiveDeps + yield biggestDependency.Info.Item + |] + + let resultsToAdd = + transitiveDeps + |> Array.filter (fun dep -> itemsPresent.Contains dep.Info.Item = false) + |> Array.distinctBy (fun dep -> dep.Info.Item) + |> Array.sortWith (fun a b -> + // We preserve the order in which items are folded to the state. + match a.Info.Item, b.Info.Item with + | NodeToTypeCheck.PhysicalFile aIdx, NodeToTypeCheck.PhysicalFile bIdx + | NodeToTypeCheck.ArtificialImplFile aIdx, NodeToTypeCheck.ArtificialImplFile bIdx -> aIdx.CompareTo bIdx + | NodeToTypeCheck.PhysicalFile _, NodeToTypeCheck.ArtificialImplFile _ -> -1 + | NodeToTypeCheck.ArtificialImplFile _, NodeToTypeCheck.PhysicalFile _ -> 1) + |> Array.map (fun dep -> dep.Result |> snd) + + // Fold results not already included and produce the final state + let state = Array.fold folder firstState resultsToAdd + state + + /// + /// Process a graph of items. + /// A version of 'GraphProcessing.processGraph' with a signature specific to type-checking. + /// + let processTypeCheckingGraph + (graph: Graph) + (work: NodeToTypeCheck -> State -> Finisher) + (emptyState: State) + (ct: CancellationToken) + : (int * FinalFileResult) list * State = + + let workWrapper + (getProcessedNode: NodeToTypeCheck -> ProcessedNode>) + (node: NodeInfo) + : State * Finisher = + let folder (state: State) (Finisher (finisher = finisher)) : State = finisher state |> snd + let deps = node.Deps |> Array.except [| node.Item |] |> Array.map getProcessedNode + + let transitiveDeps = + node.TransitiveDeps + |> Array.except [| node.Item |] + |> Array.map getProcessedNode + + let inputState = combineResults emptyState deps transitiveDeps folder + + let singleRes = work node.Item inputState + let state = folder inputState singleRes + state, singleRes + + let results = processGraph graph workWrapper ct + + let finalFileResults, state: (int * FinalFileResult) list * State = + (([], emptyState), + results + |> Array.choose (fun (item, res) -> + match item with + | NodeToTypeCheck.ArtificialImplFile _ -> None + | NodeToTypeCheck.PhysicalFile file -> Some(file, res))) + ||> Array.fold (fun (fileResults, state) (item, (_, Finisher (finisher = finisher))) -> + let fileResult, state = finisher state + (item, fileResult) :: fileResults, state) + + finalFileResults, state + /// Constructs a file dependency graph and type-checks the files in parallel where possible. let CheckMultipleInputsUsingGraphMode ((ctok, checkForErrors, tcConfig: TcConfig, tcImports: TcImports, tcGlobals, prefixPathOpt, tcState, eagerFormat, inputs): 'a * (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcState * (PhasedDiagnostic -> PhasedDiagnostic) * ParsedInput list) @@ -1711,38 +1817,51 @@ let CheckMultipleInputsUsingGraphMode // somewhere in the files processed prior to each one, or in the processing of this particular file. let priorErrors = checkForErrors () - let processArtificialImplFile (input: ParsedInput) ((currentTcState, _currentPriorErrors): State) : Finisher = - Finisher(fun (state: State) -> - let tcState, currentPriorErrors = state - - let f = - // Retrieve the type-checked signature information and add it to the TcEnvFromImpls. - AddSignatureResultToTcImplEnv(tcImports, tcGlobals, prefixPathOpt, TcResultsSink.NoSink, currentTcState, input) - - // The `partialResult` will be excluded at the end of `GraphProcessing.processGraph`. - // The important thing is that `nextTcState` will populated the necessary information to TcEnvFromImpls. - let partialResult, nextTcState = f tcState - partialResult, (nextTcState, currentPriorErrors)) + let processArtificialImplFile + (node: NodeToTypeCheck) + (input: ParsedInput) + ((currentTcState, _currentPriorErrors): State) + : Finisher = + Finisher( + node, + (fun (state: State) -> + let tcState, currentPriorErrors = state + + let f = + // Retrieve the type-checked signature information and add it to the TcEnvFromImpls. + AddSignatureResultToTcImplEnv(tcImports, tcGlobals, prefixPathOpt, TcResultsSink.NoSink, currentTcState, input) + + // The `partialResult` will be excluded at the end of `GraphProcessing.processGraph`. + // The important thing is that `nextTcState` will populated the necessary information to TcEnvFromImpls. + let partialResult, nextTcState = f tcState + partialResult, (nextTcState, currentPriorErrors)) + ) let processFile + (node: NodeToTypeCheck) ((input, logger): ParsedInput * DiagnosticsLogger) ((currentTcState, _currentPriorErrors): State) - : Finisher = + : Finisher = use _ = UseDiagnosticsLogger logger let checkForErrors2 () = priorErrors || (logger.ErrorCount > 0) let tcSink = TcResultsSink.NoSink - let finisher = - CheckOneInputWithCallback(checkForErrors2, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, currentTcState, input, false) + let (Finisher (finisher = finisher)) = + CheckOneInputWithCallback + node + (checkForErrors2, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcSink, currentTcState, input, false) |> Cancellable.runWithoutCancellation - Finisher(fun (state: State) -> - let tcState, priorErrors = state - let (partialResult: PartialResult, tcState) = finisher.Invoke(tcState) - let hasErrors = logger.ErrorCount > 0 - let priorOrCurrentErrors = priorErrors || hasErrors - let state: State = tcState, priorOrCurrentErrors - partialResult, state) + Finisher( + node, + (fun (state: State) -> + let tcState, priorErrors = state + let (partialResult: PartialResult, tcState) = finisher tcState + let hasErrors = logger.ErrorCount > 0 + let priorOrCurrentErrors = priorErrors || hasErrors + let state: State = tcState, priorOrCurrentErrors + partialResult, state) + ) UseMultipleDiagnosticLoggers (inputs, diagnosticsLogger, Some eagerFormat) (fun inputsWithLoggers -> // Equip loggers to locally filter w.r.t. scope pragmas in each input @@ -1753,30 +1872,19 @@ let CheckMultipleInputsUsingGraphMode let logger = DiagnosticsLoggerForInput(tcConfig, input, oldLogger) input, logger) - let processFile (node: NodeToTypeCheck) (state: State) : Finisher = + let processFile (node: NodeToTypeCheck) (state: State) : Finisher = match node with | NodeToTypeCheck.ArtificialImplFile idx -> let parsedInput, _ = inputsWithLoggers[idx] - processArtificialImplFile parsedInput state + processArtificialImplFile node parsedInput state | NodeToTypeCheck.PhysicalFile idx -> let parsedInput, logger = inputsWithLoggers[idx] - processFile (parsedInput, logger) state + processFile node (parsedInput, logger) state let state: State = tcState, priorErrors - let finalStateItemChooser node = - match node with - | NodeToTypeCheck.ArtificialImplFile _ -> None - | NodeToTypeCheck.PhysicalFile file -> Some file - let partialResults, (tcState, _) = - TypeCheckingGraphProcessing.processTypeCheckingGraph - nodeGraph - processFile - folder - finalStateItemChooser - state - cts.Token + TypeCheckingGraphProcessing.processTypeCheckingGraph nodeGraph processFile state cts.Token let partialResults = partialResults diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index ecf060a63ef..4e061b6724d 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -415,8 +415,6 @@ - -