diff --git a/.fantomasignore b/.fantomasignore index e77f5f342fc..d9ce7276a7e 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -12,7 +12,7 @@ artifacts/ # Explicitly formatted Tests/ subdirectories (with exceptions) !tests/ParallelTypeCheckingTests/ -*/.checkouts/ +*/.fcs_test/ # Explicitly unformatted implementation files diff --git a/FSharp.sln b/FSharp.sln index 8e67ff20a10..20c74ace2fc 100644 --- a/FSharp.sln +++ b/FSharp.sln @@ -107,8 +107,6 @@ Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution src\Compiler\FSComp.txt = src\Compiler\FSComp.txt EndProjectSection EndProject -Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "DiamondTest", "tests\DiamondTest\DiamondTest.fsproj", "{B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}" -EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "ParallelTypeCheckingTests", "tests\ParallelTypeCheckingTests\ParallelTypeCheckingTests.fsproj", "{59C31D40-97E0-4A69-ABD9-D316BD798ED8}" EndProject Global @@ -433,18 +431,6 @@ Global {9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Release|Any CPU.Build.0 = Release|Any CPU {9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Release|x86.ActiveCfg = Release|Any CPU {9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Release|x86.Build.0 = Release|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Debug|Any CPU.ActiveCfg = Debug|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Debug|Any CPU.Build.0 = Debug|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Debug|x86.ActiveCfg = Debug|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Debug|x86.Build.0 = Debug|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Proto|Any CPU.ActiveCfg = Debug|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Proto|Any CPU.Build.0 = Debug|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Proto|x86.ActiveCfg = Debug|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Proto|x86.Build.0 = Debug|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Release|Any CPU.ActiveCfg = Release|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Release|Any CPU.Build.0 = Release|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Release|x86.ActiveCfg = Release|Any CPU - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC}.Release|x86.Build.0 = Release|Any CPU {59C31D40-97E0-4A69-ABD9-D316BD798ED8}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {59C31D40-97E0-4A69-ABD9-D316BD798ED8}.Debug|Any CPU.Build.0 = Debug|Any CPU {59C31D40-97E0-4A69-ABD9-D316BD798ED8}.Debug|x86.ActiveCfg = Debug|Any CPU @@ -489,7 +475,6 @@ Global {209C7D37-8C01-413C-8698-EC25F4C86976} = {B8DDA694-7939-42E3-95E5-265C2217C142} {BEC6E796-7E53-4888-AAFC-B8FD55C425DF} = {CE70D631-C5DC-417E-9CDA-B16097BEF1AC} {9C7523BA-7AB2-4604-A5FD-653E82C2BAD1} = {CE70D631-C5DC-417E-9CDA-B16097BEF1AC} - {B7C957CB-9E64-44CF-BC73-152BFC6E5BCC} = {CFE3259A-2D30-4EB0-80D5-E8B5F3D01449} {59C31D40-97E0-4A69-ABD9-D316BD798ED8} = {CFE3259A-2D30-4EB0-80D5-E8B5F3D01449} EndGlobalSection GlobalSection(ExtensibilityGlobals) = postSolution diff --git a/src/Compiler/Driver/CompilerConfig.fsi b/src/Compiler/Driver/CompilerConfig.fsi index a9246e72e50..f347f6230c4 100644 --- a/src/Compiler/Driver/CompilerConfig.fsi +++ b/src/Compiler/Driver/CompilerConfig.fsi @@ -205,8 +205,11 @@ type ParallelReferenceResolution = [] type TypeCheckingMode = + /// Default mode where all source files are processed sequentially in compilation order. | Sequential + /// Signature files and implementation files without backing files are processed sequentially, then backed implementation files are processed in parallel. | ParallelCheckingOfBackedImplFiles + /// Parallel type-checking that uses automated file-to-file dependency detection to construct a highly-parallelisable file graph. | Graph [] diff --git a/src/Compiler/Driver/CompilerOptions.fs b/src/Compiler/Driver/CompilerOptions.fs index 19b79d4ee38..8b308580b8d 100644 --- a/src/Compiler/Driver/CompilerOptions.fs +++ b/src/Compiler/Driver/CompilerOptions.fs @@ -1392,6 +1392,11 @@ let testFlag tcConfigB = { tcConfigB.typeCheckingConfig with Mode = TypeCheckingMode.ParallelCheckingOfBackedImplFiles } + | "GraphBasedChecking" -> + tcConfigB.typeCheckingConfig <- + { tcConfigB.typeCheckingConfig with + Mode = TypeCheckingMode.Graph + } #if DEBUG | "ShowParserStackOnParseError" -> showParserStackOnParseError <- true #endif diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index 1d2e8e7bca6..4d7c15cd367 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -759,17 +759,31 @@ 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 ((fileName, isLastCompiland), delayLogger) -> + |> ListParallel.map (fun (((idx, fileName), isLastCompiland), delayLogger) -> let directoryName = Path.GetDirectoryName fileName let input = parseInputFileAux (tcConfig, lexResourceManager, fileName, (isLastCompiland, isExe), delayLogger, retryLocked) - (input, directoryName))) + idx, (input, directoryName)) + // Bring back index-based order + |> List.sortBy fst + |> List.map snd + ) let ParseInputFilesSequential (tcConfig: TcConfig, lexResourceManager, sourceFiles, diagnosticsLogger: DiagnosticsLogger, retryLocked) = let isLastCompiland, isExe = sourceFiles |> tcConfig.ComputeCanContainEntryPoint @@ -1729,7 +1743,7 @@ let mutable typeCheckingMode: TypeCheckingMode = TypeCheckingMode.Sequential let CheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, eagerFormat, inputs) = // tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions let results, tcState = - match typeCheckingMode with + match tcConfig.typeCheckingConfig.Mode with | TypeCheckingMode.Sequential -> CheckMultipleInputsSequential(ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) | TypeCheckingMode.ParallelCheckingOfBackedImplFiles -> diff --git a/tests/ParallelTypeCheckingTests/Code/ASTVisit.fs b/tests/ParallelTypeCheckingTests/Code/ASTVisit.fs index 1785d46d7f0..c5af3ec4da9 100644 --- a/tests/ParallelTypeCheckingTests/Code/ASTVisit.fs +++ b/tests/ParallelTypeCheckingTests/Code/ASTVisit.fs @@ -1254,18 +1254,20 @@ module TopModulesExtraction = synAccessOption, range, synModuleOrNamespaceTrivia) -> - if mightHaveAutoOpen synAttributeLists then - // Contents of a module that's potentially AutoOpen are available from its parent without a prefix. - // Stay safe and as soon as the parent module is reachable, consider this module reachable as well - [| LongIdent.Empty |] - else - // 'module A.B' is equivalent to 'namespace A; module B', meaning that 'A' is opened implicitly if - synModuleOrNamespaceKind.IsModule && longId.Length > 1 + mightHaveAutoOpen synAttributeLists && synModuleOrNamespaceKind.IsModule then + // Contents of a module that's potentially AutoOpen are available from its parent without a prefix. + // Stay safe and as soon as the parent module is reachable, consider this module reachable as well [| longId.GetSlice(None, Some <| longId.Length - 2); longId |] else - [| longId |] + // 'module A.B' is equivalent to 'namespace A; module B', meaning that 'A' is opened implicitly + if + synModuleOrNamespaceKind.IsModule && longId.Length > 1 + then + [| longId.GetSlice(None, Some <| longId.Length - 2); longId |] + else + [| longId |] // TODO Temporarily disabled digging into the file's structure to avoid edge cases where another file depends on this file's namespace existing (but nothing else) // synModuleDecls // |> moduleDecls @@ -1307,6 +1309,8 @@ module TopModulesExtraction = synAccessOption, range) -> let idents = + // TODO Fix this by making it similar to what happens in other places where we detect AutoOpen modules + // Currently it doesn't matter, since we don't look within modules. if mightHaveAutoOpen synAttributeLists then // Contents of a module that's potentially AutoOpen are available everywhere, so treat it as if it had no name ('root' module). [| LongIdent.Empty |] @@ -1326,11 +1330,20 @@ module TopModulesExtraction = synAccessOption, range, synModuleOrNamespaceTrivia) -> - if mightHaveAutoOpen synAttributeLists then - // Contents of a module that's potentially AutoOpen are available everywhere, so treat it as if it had no name ('root' module). - [| LongIdent.Empty |] + if + mightHaveAutoOpen synAttributeLists && synModuleOrNamespaceKind.IsModule + then + // Contents of a module that's potentially AutoOpen are available from its parent without a prefix. + // Stay safe and as soon as the parent module is reachable, consider this module reachable as well + [| longId.GetSlice(None, Some <| longId.Length - 2); longId |] else - synModuleDecls |> moduleSigDecls |> combine longId + // 'module A.B' is equivalent to 'namespace A; module B', meaning that 'A' is opened implicitly + if + synModuleOrNamespaceKind.IsModule && longId.Length > 1 + then + [| longId.GetSlice(None, Some <| longId.Length - 2); longId |] + else + [| longId |] and moduleSigDecls (x: SynModuleSigDecl list) : Eit = let emptyState = Eit.Nested [||] diff --git a/tests/ParallelTypeCheckingTests/Code/DependencyResolution.fs b/tests/ParallelTypeCheckingTests/Code/DependencyResolution.fs index 7ea6666b6db..f5ddd7ba559 100644 --- a/tests/ParallelTypeCheckingTests/Code/DependencyResolution.fs +++ b/tests/ParallelTypeCheckingTests/Code/DependencyResolution.fs @@ -260,31 +260,31 @@ module internal DependencyResolution = } /// -/// Calculate and print some stats about the expected parallelism factor of a dependency graph +/// Calculate and print some statistics about the expected parallelism factor of a dependency graph /// let analyseEfficiency (result: DepsResult) : unit = let graph = result.Graph - let totalSize1 = graph |> Seq.sumBy (fun (KeyValue (_k, v)) -> v.Length) - let t = graph |> Graph.transitive - let totalSize2 = t |> Seq.sumBy (fun (KeyValue (_k, v)) -> v.Length) + let edgeCount = graph |> Seq.sumBy (fun (KeyValue (_k, v)) -> v.Length) + let t = graph |> Graph.transitiveOpt + let edgeCountTransitive = t |> Seq.sumBy (fun (KeyValue (_k, v)) -> v.Length) - printfn $"Non-transitive size: {totalSize1}, transitive size: {totalSize2}" + log $"Non-transitive edge count: {edgeCount}, transitive edge count: {edgeCountTransitive}" - let totalFileSize = result.Files |> Array.sumBy (fun file -> int64 (file.CodeSize)) + let fileCount = result.Files.Length - // Use depth-first search to calculate 'depth' of each file + // Use depth-first search to calculate 'depth' of a file let rec depthDfs = Utils.memoize (fun (file: File) -> let deepestChild = match result.Graph[file] with - | [||] -> 0L + | [||] -> 0 | d -> d |> Array.map depthDfs |> Array.max - let depth = int64 (file.CodeSize) + deepestChild + let depth = 1 + deepestChild depth) // Run DFS for every file node, collect the maximum depth found let maxDepth = result.Files |> Array.map (fun f -> depthDfs f.File) |> Array.max log - $"Total file size: {totalFileSize}. Max depth: {maxDepth}. Max Depth/Size = %.1f{100.0 * double (maxDepth) / double (totalFileSize)}%%" + $"File count: {fileCount}. Longest path: {maxDepth}. Longest path/File count (a weak proxy for level of parallelism) = %.1f{100.0 * double maxDepth / double fileCount}%%" diff --git a/tests/ParallelTypeCheckingTests/Code/FileInfoGathering.fs b/tests/ParallelTypeCheckingTests/Code/FileInfoGathering.fs index 2d659666351..2fb3a1978f3 100644 --- a/tests/ParallelTypeCheckingTests/Code/FileInfoGathering.fs +++ b/tests/ParallelTypeCheckingTests/Code/FileInfoGathering.fs @@ -23,7 +23,6 @@ let internal gatherBackingInfo (files: SourceFiles) : Files = { Idx = FileIdx.make i - Code = "no code here" // TODO AST = ASTOrFsix.AST f.AST FsiBacked = fsiBacked }) diff --git a/tests/ParallelTypeCheckingTests/Code/Graph.fs b/tests/ParallelTypeCheckingTests/Code/Graph.fs index 0ac4bae339e..1449c21917c 100644 --- a/tests/ParallelTypeCheckingTests/Code/Graph.fs +++ b/tests/ParallelTypeCheckingTests/Code/Graph.fs @@ -42,6 +42,23 @@ module Graph = graph.Values |> Seq.toArray |> Array.concat |> Array.except graph.Keys addIfMissing missingNodes graph + + /// Create a transitive closure of the graph + let transitiveOpt<'Node when 'Node: equality> (graph: Graph<'Node>) : Graph<'Node> = + let go (node: 'Node) = + let visited = HashSet<'Node>() + let rec dfs (node: 'Node) = + graph[node] + |> Array.filter visited.Add + |> Array.iter dfs + dfs node + visited + |> Seq.toArray + + graph.Keys + |> Seq.toArray + |> Array.Parallel.map (fun node -> node, go node) + |> readOnlyDict /// Create a transitive closure of the graph let transitive<'Node when 'Node: equality> (graph: Graph<'Node>) : Graph<'Node> = diff --git a/tests/ParallelTypeCheckingTests/Code/GraphProcessing.fs b/tests/ParallelTypeCheckingTests/Code/GraphProcessing.fs index 2a4b8837ccb..387371ae3a0 100644 --- a/tests/ParallelTypeCheckingTests/Code/GraphProcessing.fs +++ b/tests/ParallelTypeCheckingTests/Code/GraphProcessing.fs @@ -104,6 +104,7 @@ let combineResults (deps: Node<'Item, 'State, 'Result>[]) (transitiveDeps: Node<'Item, 'State, 'Result>[]) (folder: 'State -> 'Result -> 'State) + (_foldingOrderer: 'Item -> int) : 'State = match deps with | [||] -> emptyState @@ -127,7 +128,8 @@ let combineResults // Sort it by effectively file index. // For some reason this is needed, otherwise gives 'missing namespace' and other errors when using the resulting state. // Does this make sense? Should the results be foldable in any order? - |> Array.sortBy (fun d -> d.Info.Item) + // TODO Use _foldingOrderer + |> Array.sortBy (fun node -> node.Info.Item) |> Array.filter (fun dep -> included.Contains dep.Info.Item = false) |> Array.distinctBy (fun dep -> dep.Info.Item) |> Array.map (fun dep -> dep.Result |> orFail |> snd) @@ -140,11 +142,12 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item: equality a (graph: Graph<'Item>) (doWork: 'Item -> 'State -> 'Result) (folder: 'State -> 'Result -> 'FinalFileResult * 'State) + (foldingOrderer: 'Item -> int) (emptyState: 'State) (includeInFinalState: 'Item -> bool) (parallelism: int) : 'FinalFileResult[] * 'State = - let transitiveDeps = graph |> Graph.transitive + let transitiveDeps = graph |> Graph.transitiveOpt let dependants = graph |> Graph.reverse let makeNode (item: 'Item) : Node<'Item, StateWrapper<'Item, 'State>, ResultWrapper<'Item, 'Result>> = @@ -208,7 +211,7 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item: equality a let folder x y = folder x y |> snd let deps = lookupMany node.Info.Deps let transitiveDeps = lookupMany node.Info.TransitiveDeps - let inputState = combineResults emptyState deps transitiveDeps folder + let inputState = combineResults emptyState deps transitiveDeps folder foldingOrderer node.InputState <- Some inputState let singleRes = doWork node.Info.Item inputState.State diff --git a/tests/ParallelTypeCheckingTests/Code/Parallel.fs b/tests/ParallelTypeCheckingTests/Code/Parallel.fs index baf2dbf2ade..484decf7edc 100644 --- a/tests/ParallelTypeCheckingTests/Code/Parallel.fs +++ b/tests/ParallelTypeCheckingTests/Code/Parallel.fs @@ -4,82 +4,8 @@ open System open System.Collections.Concurrent -open System.Collections.Generic open System.Threading -/// The agent handles two kind of messages - the 'Start' message is sent -/// when the caller wants to start a new work item. The 'Finished' message -/// is sent (by the agent itself) when one work item is completed. -type LimitAgentMessage = - | Start of Async - | Finished - -/// A function that takes the limit - the maximal number of operations it -/// will run in parallel - and returns an agent that accepts new -/// tasks via the 'Start' message -let threadingLimitAgent limit (ct: CancellationToken) = - let act (inbox: MailboxProcessor) = - async { - // Keep number of items running & queue of items to run later - // NOTE: We keep an explicit queue, so that we can e.g. start dropping - // items if there are too many requests (or do something else) - // NOTE: The loop is only accessed from one thread at each time - // so we can just use non-thread-safe queue & mutation - let queue = Queue<_>() - let mutable count = 0 - - while true do - let! msg = inbox.Receive() - // When we receive Start, add the work to the queue - // When we receive Finished, do count-- - match msg with - | Start work -> queue.Enqueue(work) - | Finished -> count <- count + 1 - // After something happened, we check if we can - // start a next task from the queue - if count < limit && queue.Count > 0 then - count <- count + 1 - let work = queue.Dequeue() - // Start it in a thread pool (on background) - Async.Start( - async { - do! work - inbox.Post(Finished) - } - ) - } - - MailboxProcessor.Start(act, ct) - -// TODO Test this version -/// Untested version that uses MailboxProcessor. -/// See http://www.fssnip.net/nX/title/Limit-degree-of-parallelism-using-an-agent for implementation -let processInParallelUsingMailbox - (firstItems: 'Item[]) - (work: 'Item -> Async<'Item[]>) - (parallelism: int) - (notify: int -> unit) - (ct: CancellationToken) - : unit = - let processedCountLock = Object() - let mutable processedCount = 0 - let agent = threadingLimitAgent parallelism ct - - let rec processItem item = - async { - let! toSchedule = work item - - let pc = - lock processedCountLock (fun () -> - processedCount <- processedCount + 1 - processedCount) - - notify pc - toSchedule |> Array.iter (fun x -> agent.Post(Start(processItem x))) - } - - firstItems |> Array.iter (fun x -> agent.Post(Start(processItem x))) - // 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, @@ -88,9 +14,9 @@ let processInParallel (firstItems: 'Item[]) (work: 'Item -> 'Item[]) (parallelism: int) - (stop: int -> bool) + (shouldStop: int -> bool) (ct: CancellationToken) - (_itemToString) + (_itemToString : 'Item -> string) : unit = let bc = new BlockingCollection<'Item>() firstItems |> Array.iter bc.Add @@ -98,15 +24,19 @@ let processInParallel let mutable processedCount = 0 let processItem item = - // printfn $"Processing {itemToString item}" + printfn $"Processing {_itemToString item}" let toSchedule = work item let processedCount = lock processedCountLock (fun () -> processedCount <- processedCount + 1 processedCount) - // printfn $"ToSchedule {toSchedule.Length}" - toSchedule |> Array.iter (fun next -> bc.Add(next)) + let toScheduleString = + toSchedule + |> Array.map _itemToString + |> fun names -> String.Join(", ", names) + printfn $"Scheduling {toSchedule.Length} items: {toScheduleString}" + toSchedule |> Array.iter bc.Add processedCount // TODO Could avoid workers with some semaphores @@ -114,25 +44,8 @@ let processInParallel for node in bc.GetConsumingEnumerable(ct) do if not ct.IsCancellationRequested then // improve let processedCount = processItem node - - if stop processedCount then + if shouldStop processedCount then bc.CompleteAdding() - Array.Parallel.map workerWork (Array.init parallelism (fun _ -> ())) |> ignore // use cancellation - () - -let test () = - // Create an agent that can run at most 2 tasks in parallel - // and send 10 work items that take 1 second to the queue - use cts = new CancellationTokenSource() - let agent = threadingLimitAgent 2 cts.Token - - for i in 0..10 do - agent.Post( - Start( - async { - do! Async.Sleep(1000) - printfn $"Finished: %d{i}" - } - ) - ) + // TODO Do we need to handle cancellation given that workers do it already? + Array.Parallel.map workerWork (Array.init parallelism (fun _ -> ())) |> ignore diff --git a/tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs b/tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs index ea1f88ba3af..b4a037d84ed 100644 --- a/tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs +++ b/tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs @@ -2,6 +2,7 @@ #nowarn "1182" +open System open System.Collections.Concurrent open System.Collections.Generic open System.IO @@ -254,6 +255,8 @@ let CheckMultipleInputsInParallel graph processFile folder + // When combining results, order them by index + (fun file -> file.Idx.Idx) state (fun it -> not <| it.Name.EndsWith(".fsix")) 10 diff --git a/tests/ParallelTypeCheckingTests/Code/SingleTcStateTypeChecking.fs b/tests/ParallelTypeCheckingTests/Code/SingleTcStateTypeChecking.fs deleted file mode 100644 index 46de125d910..00000000000 --- a/tests/ParallelTypeCheckingTests/Code/SingleTcStateTypeChecking.fs +++ /dev/null @@ -1,424 +0,0 @@ -module internal ParallelTypeCheckingTests.SingleTcStateTypeChecking - -#nowarn "1182" - -open FSharp.Compiler -open FSharp.Compiler.CheckBasics -open FSharp.Compiler.CheckDeclarations -open FSharp.Compiler.CompilerConfig -open FSharp.Compiler.CompilerImports -open FSharp.Compiler.DiagnosticsLogger -open FSharp.Compiler.NameResolution -open FSharp.Compiler.ParseAndCheckInputs -open ParallelTypeCheckingTests -open ParallelTypeCheckingTests.Types -open ParallelTypeCheckingTests.Utils -open ParallelTypeCheckingTests.DepResolving -open FSharp.Compiler.Syntax -open FSharp.Compiler.TypedTree -open Internal.Utilities.Collections -open Internal.Utilities.Library -open Internal.Utilities.Library.Extras - -type PartialResult = TcEnv * TopAttribs * CheckedImplFile option * ModuleOrNamespaceType - -type SignaturePairResult = - Import.ImportMap * string list option * ModuleOrNamespaceType * bool * ParsedImplFileInput * TcState * ModuleOrNamespaceType - -[] -type TypeCheckResponse = - | ImplementationFile of topAttrs: TopAttribs * implFile: CheckedImplFile * tcEnvAtEnd: TcEnv * createsGeneratedProvidedTypes: bool - | SignatureFile of tcEnv: TcEnv * sigFileType: ModuleOrNamespaceType * createsGeneratedProvidedTypes: bool * implIdx: int - -type ParallelTypeCheckMsg = - | TypeCheckCompleted of - index: int * - response: TypeCheckResponse * - replyChannel: AsyncReplyChannel array * TcState> - | StartTypeCheck of index: int * replyChannel: AsyncReplyChannel array * TcState> - | Start of - inputFiles: (ParsedInput * DiagnosticsLogger) array * - replyChannel: AsyncReplyChannel array * TcState> - -type ParallelTypeCheckModel = - { - CurrentTcState: TcState - Free: Set - Processing: Set - Input: (ParsedInput * DiagnosticsLogger) array - Results: Choice array - } - -/// Use parallel checking of implementation files that have signature files -let CheckMultipleInputsInParallel - ( - ctok, - checkForErrors, - tcConfig: TcConfig, - tcImports: TcImports, - tcGlobals, - prefixPathOpt, - tcState, - eagerFormat, - inputs - ) = - - let diagnosticsLogger = DiagnosticsThreadStatics.DiagnosticsLogger - - // We create one CapturingDiagnosticLogger for each file we are processing and - // ensure the diagnostics are presented in deterministic order. - // - // eagerFormat is used to format diagnostics as they are emitted, just as they would be in the command-line - // compiler. This is necessary because some formatting of diagnostics is dependent on the - // type inference state at precisely the time the diagnostic is emitted. - UseMultipleDiagnosticLoggers (inputs, diagnosticsLogger, Some eagerFormat) (fun inputsWithLoggers -> - - // Equip loggers to locally filter w.r.t. scope pragmas in each input - let inputsWithLoggers: (ParsedInput * DiagnosticsLogger)[] = - inputsWithLoggers - |> Seq.map (fun (input, oldLogger) -> - let logger = - ParallelTypeChecking.DiagnosticsLoggerForInput(tcConfig, input, oldLogger) - - input, logger) - |> Seq.toArray - - // In the first linear part of parallel checking, we use a 'checkForErrors' that checks either for errors - // somewhere in the files processed prior to each one, or in the processing of this particular file. - let priorErrors = checkForErrors () - - let graph: DepsResult = - let sourceFiles = - inputs - |> List.toArray - |> Array.mapi (fun i inp -> { Idx = FileIdx.make i; AST = inp }: SourceFile) - - DependencyResolution.detectFileDependencies sourceFiles - - do () - - let partialResults, tcState = - let amap = tcImports.GetImportMap() - - let conditionalDefines = - if tcConfig.noConditionalErasure then - None - else - Some tcConfig.conditionalDefines - - let agent = - MailboxProcessor.Start - (fun inbox -> - let rec loop (state: ParallelTypeCheckModel) = - async { - let! msg = inbox.Receive() - - match msg with - | ParallelTypeCheckMsg.TypeCheckCompleted (index, response, channel) -> - let input, _ = inputsWithLoggers.[index] - - let updateTcState = - match response with - | TypeCheckResponse.ImplementationFile (topAttrs, - implFile, - tcEnvAtEnd, - createsGeneratedProvidedTypes) -> - let x = - state.CurrentTcState.CreatesGeneratedProvidedTypes - || createsGeneratedProvidedTypes - - let tcState = state.CurrentTcState.WithCreatesGeneratedProvidedTypes x - - let ccuSigForFile, updateTcState = - AddCheckResultsToTcState - (tcGlobals, - amap, - false, - prefixPathOpt, - TcResultsSink.NoSink, - tcState.TcEnvFromImpls, - input.QualifiedName, - implFile.Signature) - tcState - - state.Results.[index] <- Choice1Of2(tcEnvAtEnd, topAttrs, Some implFile, ccuSigForFile) - updateTcState - | TypeCheckResponse.SignatureFile (tcEnv, sigFileType, createsGeneratedProvidedTypes, implIdx) -> - let qualNameOfFile = input.QualifiedName - let rootSigs = Zmap.add qualNameOfFile sigFileType state.CurrentTcState.TcsRootSigs - - // Add the signature to the signature env (unless it had an explicit signature) - let ccuSigForFile = - TypedTreeOps.CombineCcuContentFragments [ sigFileType; state.CurrentTcState.CcuSig ] - - let tcStateAfterSig = - let creates = - state.CurrentTcState.CreatesGeneratedProvidedTypes - || createsGeneratedProvidedTypes - - state.CurrentTcState.WithStuff tcEnv rootSigs creates - - state.Results.[index] <- Choice1Of2(tcEnv, EmptyTopAttrs, None, ccuSigForFile) - - let implFile = - match fst inputsWithLoggers.[implIdx] with - | ParsedInput.SigFile _ -> failwith "should be an implementation file" - | ParsedInput.ImplFile file -> file - - let qualNameOfFile = input.QualifiedName - let priorErrors = checkForErrors () - - let ccuSigForFile, tcStateAfterImpl = - AddCheckResultsToTcState - (tcGlobals, - amap, - true, - prefixPathOpt, - TcResultsSink.NoSink, - tcStateAfterSig.TcEnvFromImpls, - qualNameOfFile, - sigFileType) - tcStateAfterSig - - state.Results.[implIdx] <- - Choice2Of2( - amap, - conditionalDefines, - sigFileType, - priorErrors, - implFile, - tcStateAfterImpl, - ccuSigForFile - ) - - tcStateAfterImpl - - let allFree = - match response with - | TypeCheckResponse.ImplementationFile _ -> Set.add index state.Free - | TypeCheckResponse.SignatureFile (implIdx = implIdx) -> - state.Free |> Set.add index |> Set.add implIdx - - if allFree.Count = state.Input.Length then - channel.Reply(state.Results, updateTcState) - else - let nextFree = - let alreadyFired = Set.union allFree state.Processing - - graph.Graph - |> Seq.choose (fun (KeyValue (f, deps)) -> - let idx = f.Idx.Idx - - if alreadyFired.Contains idx then - None - elif Seq.forall (fun (dep: File) -> Set.contains dep.Idx.Idx allFree) deps then - Some idx - else - None) - |> Seq.toArray - - Array.iter - (fun freeIndex -> inbox.Post(ParallelTypeCheckMsg.StartTypeCheck(freeIndex, channel))) - nextFree - - return! - loop - { state with - CurrentTcState = updateTcState - Free = allFree - Processing = Set.unionMany [| state.Processing; Set.ofArray nextFree |] - } - - | ParallelTypeCheckMsg.StartTypeCheck (idx, channel) -> - let input, logger = inputsWithLoggers.[idx] - use _ = UseDiagnosticsLogger logger - - let checkForErrors2 () = priorErrors || (logger.ErrorCount > 0) - - match input with - | ParsedInput.SigFile file -> - let m = input.Range - let qualNameOfFile = file.QualifiedName - - // Check if we've seen this top module signature before. - if Zmap.mem qualNameOfFile state.CurrentTcState.TcsRootSigs then - errorR (Error(FSComp.SR.buildSignatureAlreadySpecified qualNameOfFile.Text, m.StartRange)) - - // Check if the implementation came first in compilation order - if Zset.contains qualNameOfFile state.CurrentTcState.TcsRootImpls then - errorR (Error(FSComp.SR.buildImplementationAlreadyGivenDetail (qualNameOfFile.Text), m)) - - let conditionalDefines = - if tcConfig.noConditionalErasure then - None - else - Some tcConfig.conditionalDefines - - // Typecheck the signature file - cancellable { - let! tcEnv, sigFileType, createsGeneratedProvidedTypes = - CheckOneSigFile - (tcGlobals, - amap, - state.CurrentTcState.Ccu, - checkForErrors, - conditionalDefines, - TcResultsSink.NoSink, - tcConfig.internalTestSpanStackReferring) - state.CurrentTcState.TcEnvFromSignatures - file - - let implIndex = - [| idx + 1 .. inputsWithLoggers.Length - 1 |] - |> Array.tryPick (fun idx -> - let f = fst inputsWithLoggers.[idx] - - if f.QualifiedName.Text = qualNameOfFile.Text then - Some idx - else - None) - |> function - | None -> failwith "No signature file" - | Some idx -> idx - - inbox.Post( - ParallelTypeCheckMsg.TypeCheckCompleted( - idx, - TypeCheckResponse.SignatureFile( - tcEnv, - sigFileType, - createsGeneratedProvidedTypes, - implIndex - ), - channel - ) - ) - } - |> Cancellable.toAsync - |> Async.Start - - | ParsedInput.ImplFile file -> - let qualNameOfFile = file.QualifiedName - - // Check if we've already seen an implementation for this fragment - if Zset.contains qualNameOfFile state.CurrentTcState.TcsRootImpls then - errorR (Error(FSComp.SR.buildImplementationAlreadyGiven qualNameOfFile.Text, input.Range)) - - let conditionalDefines = - if tcConfig.noConditionalErasure then - None - else - Some tcConfig.conditionalDefines - - // Typecheck the implementation file - cancellable { - let! topAttrs, implFile, tcEnvAtEnd, createsGeneratedProvidedTypes = - CheckOneImplFile( - tcGlobals, - amap, - state.CurrentTcState.Ccu, - state.CurrentTcState.TcsImplicitOpenDeclarations, - checkForErrors2, - conditionalDefines, - TcResultsSink.NoSink, - tcConfig.internalTestSpanStackReferring, - state.CurrentTcState.TcEnvFromImpls, - None, - file - ) - - inbox.Post( - ParallelTypeCheckMsg.TypeCheckCompleted( - idx, - TypeCheckResponse.ImplementationFile( - topAttrs, - implFile, - tcEnvAtEnd, - createsGeneratedProvidedTypes - ), - channel - ) - ) - } - |> Cancellable.toAsync - |> Async.Start - - return! loop state - - | ParallelTypeCheckMsg.Start (inputFiles, channel) -> - let initialFreeIndexes = - [| - for KeyValue (file, deps) in graph.Graph do - if Array.isEmpty deps then - yield file.Idx.Idx - |] - |> set - - Seq.iter - (fun freeIndex -> inbox.Post(ParallelTypeCheckMsg.StartTypeCheck(freeIndex, channel))) - initialFreeIndexes - - return! - loop - { state with - Processing = initialFreeIndexes - Input = inputFiles - } - } - - loop - { - CurrentTcState = tcState - Free = Set.empty - Processing = Set.empty - Input = Array.empty - Results = Array.zeroCreate graph.Graph.Count - }) - - agent.PostAndReply(fun channel -> ParallelTypeCheckMsg.Start(inputsWithLoggers, channel)) - - // Do the parallel phase, checking all implementation files that did have a signature, in parallel. - let results, createsGeneratedProvidedTypesFlags = - Array.zip partialResults inputsWithLoggers - |> ArrayParallel.map (fun (partialResult, (_, logger)) -> - use _ = UseDiagnosticsLogger logger - use _ = UseBuildPhase BuildPhase.TypeCheck - - RequireCompilationThread ctok - - match partialResult with - | Choice1Of2 result -> result, false - | Choice2Of2 (amap, conditionalDefines, rootSig, priorErrors, file, tcStateForImplFile, ccuSigForFile) -> - - // In the first linear part of parallel checking, we use a 'checkForErrors' that checks either for errors - // somewhere in the files processed prior to this one, including from the first phase, or in the processing - // of this particular file. - let checkForErrors2 () = priorErrors || (logger.ErrorCount > 0) - - let topAttrs, implFile, tcEnvAtEnd, createsGeneratedProvidedTypes = - CheckOneImplFile( - tcGlobals, - amap, - tcStateForImplFile.Ccu, - tcStateForImplFile.TcsImplicitOpenDeclarations, - checkForErrors2, - conditionalDefines, - TcResultsSink.NoSink, - tcConfig.internalTestSpanStackReferring, - tcStateForImplFile.TcEnvFromImpls, - Some rootSig, - file - ) - |> Cancellable.runWithoutCancellation - - let result = (tcEnvAtEnd, topAttrs, Some implFile, ccuSigForFile) - result, createsGeneratedProvidedTypes) - |> Array.toList - |> List.unzip - - let x = - tcState.CreatesGeneratedProvidedTypes - || (createsGeneratedProvidedTypesFlags |> List.exists id) - - let tcState = tcState.WithCreatesGeneratedProvidedTypes x - results, tcState) diff --git a/tests/ParallelTypeCheckingTests/Code/Types.fs b/tests/ParallelTypeCheckingTests/Code/Types.fs index 943e231e025..d846a5b57ac 100644 --- a/tests/ParallelTypeCheckingTests/Code/Types.fs +++ b/tests/ParallelTypeCheckingTests/Code/Types.fs @@ -56,13 +56,13 @@ type File = { /// Order of the file in the project. Files with lower number cannot depend on files with higher number Idx: FileIdx - Code: string AST: ASTOrFsix FsiBacked: bool } member this.Name = this.AST.Name // TODO Use qualified name - member this.CodeSize = this.Code.Length + // TODO Remove + member this.CodeSize = 0 member this.QualifiedName = this.AST.QualifiedName override this.Equals other = @@ -82,7 +82,6 @@ type File = static member FakeFs (idx: FileIdx) (fsi: string) : File = { Idx = idx - Code = "Fake '.fsix' node for dummy .fs state" AST = ASTOrFsix.Fsix fsi FsiBacked = false } diff --git a/tests/ParallelTypeCheckingTests/ParallelTypeCheckingTests.fsproj b/tests/ParallelTypeCheckingTests/ParallelTypeCheckingTests.fsproj index 66cae65ae9e..cb6a1c7ade0 100644 --- a/tests/ParallelTypeCheckingTests/ParallelTypeCheckingTests.fsproj +++ b/tests/ParallelTypeCheckingTests/ParallelTypeCheckingTests.fsproj @@ -37,7 +37,6 @@ - diff --git a/tests/ParallelTypeCheckingTests/Program.fs b/tests/ParallelTypeCheckingTests/Program.fs index d2a9d8140c5..9e0c9dd9617 100644 --- a/tests/ParallelTypeCheckingTests/Program.fs +++ b/tests/ParallelTypeCheckingTests/Program.fs @@ -11,14 +11,14 @@ let _parse (argv: string[]) : Args = | "sequential" -> Method.Sequential | "parallelfs" -> Method.ParallelCheckingOfBackedImplFiles | "graph" -> Method.Graph - | _ -> failwith $"Unrecognised method: {mode}" + | _ -> failwith $"Unrecognised mode: {mode}" let path, mode, workingDir = match argv with | [| path |] -> path, Method.Sequential, None - | [| path; mode |] -> path, parseMode mode, None - | [| path; mode; workingDir |] -> path, parseMode mode, Some workingDir - | _ -> failwith "Invalid args - use 'args_path [fs-parallel]" + | [| path; method |] -> path, parseMode method, None + | [| path; method; workingDir |] -> path, parseMode method, Some workingDir + | _ -> failwith "Invalid args - use 'args_path [method [fs-parallel]]'" { Path = path diff --git a/tests/ParallelTypeCheckingTests/Tests/AssemblySetUp.fs b/tests/ParallelTypeCheckingTests/Tests/AssemblySetUp.fs index 473f23b578a..98e5610bdb9 100644 --- a/tests/ParallelTypeCheckingTests/Tests/AssemblySetUp.fs +++ b/tests/ParallelTypeCheckingTests/Tests/AssemblySetUp.fs @@ -3,13 +3,14 @@ open NUnit.Framework open OpenTelemetry.Trace -/// One-time Otel setup for NUnit tests +/// One-time setup for NUnit tests [] type AssemblySetUp() = let mutable tracerProvider = None [] member this.SetUp() = + FSharp.Compiler.ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParallelTypeCheckingTests.ParallelTypeChecking.CheckMultipleInputsInParallel tracerProvider <- ParallelTypeCheckingTests.TestUtils.setupOtel () |> Some [] diff --git a/tests/ParallelTypeCheckingTests/Tests/TestCompilation.fs b/tests/ParallelTypeCheckingTests/Tests/TestCompilation.fs index 6a60cb651ab..7067646f905 100644 --- a/tests/ParallelTypeCheckingTests/Tests/TestCompilation.fs +++ b/tests/ParallelTypeCheckingTests/Tests/TestCompilation.fs @@ -1,19 +1,17 @@ module ParallelTypeCheckingTests.TestCompilation open FSharp.Test +open FSharp.Test.Compiler open NUnit.Framework open ParallelTypeCheckingTests.TestUtils -type OutputType = - | Exe - | Library - type FProject = { Files: (string * string) list OutputType: CompileOutput } + /// Used for naming test cases in the test explorer override this.ToString() = let names = this.Files @@ -212,23 +210,36 @@ type Case = override this.ToString() = $"{this.Method} - {this.Project}" -let compile (x: Case) = +let methodOptions (method: Method) = + match method with + | Method.Sequential -> [] + | Method.ParallelCheckingOfBackedImplFiles -> ["--test:ParallelCheckingWithSignatureFilesOn"] + | Method.Graph -> ["--test:GraphBasedChecking"] + +let withMethod (method: Method) (cu : CompilationUnit) : CompilationUnit = + match cu with + | CompilationUnit.FS cs -> + FS {cs with Options = cs.Options @ (methodOptions method)} + | cu -> cu + +let compileAValidProject (x: Case) = use _ = - FSharp.Compiler.Diagnostics.Activity.start "Compile codebase" [ "method", x.Method.ToString() ] + global.FSharp.Compiler.Diagnostics.Activity.start "Compile codebase" [ "method", x.Method.ToString() ] - setupCompilationMethod x.Method + printfn $"Method: {x.Method}" makeCompilationUnit x.Project.Files |> Compiler.withOutputType x.Project.OutputType + |> withMethod x.Method |> Compiler.compile |> Compiler.Assertions.shouldSucceed |> ignore let codebases = Codebases.all -[] -let ``Compile graph-based`` (project: FProject) = - compile +[] +let ``Compile a valid project using graph-based type-checking`` (project: FProject) = + compileAValidProject { Method = Method.Graph Project = project @@ -236,9 +247,9 @@ let ``Compile graph-based`` (project: FProject) = /// Compile a project using the original fully sequential type-checking.
/// Useful as a sanity check -[] -let ``Compile sequential`` (project: FProject) = - compile +[] +let ``Compile a valid project using sequential type-checking`` (project: FProject) = + compileAValidProject { Method = Method.Sequential Project = project diff --git a/tests/ParallelTypeCheckingTests/Tests/TestCompilationFromCmdlineArgs.fs b/tests/ParallelTypeCheckingTests/Tests/TestCompilationFromCmdlineArgs.fs index 75673d3d1ae..ba41fdb3240 100644 --- a/tests/ParallelTypeCheckingTests/Tests/TestCompilationFromCmdlineArgs.fs +++ b/tests/ParallelTypeCheckingTests/Tests/TestCompilationFromCmdlineArgs.fs @@ -48,6 +48,15 @@ let internal setupParsed config = setupCompilationMethod method + printfn $"Method: {method}" + let args = + match method with + | Method.Sequential -> args + | Method.ParallelCheckingOfBackedImplFiles -> + Array.append args [|"--test:ParallelCheckingWithSignatureFilesOn"|] + | Method.Graph -> + Array.append args [|"--test:GraphBasedChecking"|] + printfn $"WorkingDir = {workingDir}" workingDir |> Option.iter (fun dir -> Environment.CurrentDirectory <- dir) args @@ -81,13 +90,21 @@ let internal codebaseToConfig code method = } [] -[] -let ``Test graph-based type-checking`` (code: Codebase) = - let config = codebaseToConfig code Method.Graph +[] +let ``1. Test sequential type-checking`` (code: Codebase) = + let config = codebaseToConfig code Method.Sequential TestCompilerFromArgs config +/// Before running this test, you must prepare the codebase by running the script 'FCS.prepare.ps1' [] -[] -let ``Test sequential type-checking`` (code: Codebase) = - let config = codebaseToConfig code Method.Sequential +[] +let ``2. Test parallelfs type-checking`` (code: Codebase) = + let config = codebaseToConfig code Method.ParallelCheckingOfBackedImplFiles TestCompilerFromArgs config + +/// Before running this test, you must prepare the codebase by running the script 'FCS.prepare.ps1' +[] +let ``3. Test graph-based type-checking`` (code: Codebase) = + let config = codebaseToConfig code Method.Graph + TestCompilerFromArgs config + diff --git a/tests/ParallelTypeCheckingTests/Tests/TestDependencyResolution.fs b/tests/ParallelTypeCheckingTests/Tests/TestDependencyResolution.fs index f19883589e8..17980c16d4c 100644 --- a/tests/ParallelTypeCheckingTests/Tests/TestDependencyResolution.fs +++ b/tests/ParallelTypeCheckingTests/Tests/TestDependencyResolution.fs @@ -10,7 +10,6 @@ open ParallelTypeCheckingTests.Types open ParallelTypeCheckingTests.Utils open ParallelTypeCheckingTests.DepResolving open NUnit.Framework -open Newtonsoft.Json let buildFiles (files: (string * string) seq) = files @@ -50,6 +49,106 @@ open A let expectedEdges = [ "B.fs", [ "A.fs" ] ] assertGraphEqual deps expectedEdges + +[] +let ``A top-level module with an attribute, belonging to a namespace, depends on another file that uses the same namespace`` () = + let files = + [| + "A.fsi", """ +namespace A.B.C +type X = X of int +""" + "B.fsi", """ +[] +module public A.B.C.D +val x: X +""" + |] |> buildFiles + + let deps = DependencyResolution.detectFileDependencies files + + let expectedEdges = ["B.fsi", ["A.fsi"]] + assertGraphEqual deps expectedEdges + + +[] +let ``When defining a top-level module, the implicit parent namespace is taken into account when considering references to the file - .fsi pair`` () = + let files = + [| + "A.fsi", """ +module A.B.C1 +type X = X of int +""" + "B.fsi", """ +module A.B.C2 +val x : C1.X -> unit +""" + |] |> buildFiles + + let deps = DependencyResolution.detectFileDependencies files + + let expectedEdges = ["B.fsi", ["A.fsi"]] + assertGraphEqual deps expectedEdges + + +[] +let ``When defining a top-level module, the implicit parent namespace is taken into account when considering references to the file - .fs, .fsi pair`` () = + let files = + [| + "A.fs", """ +module A.B.C1 +type X = X of int +""" + "B.fsi", """ +module A.B.C2 +val x : C1.X -> unit +""" + |] |> buildFiles + + let deps = DependencyResolution.detectFileDependencies files + + let expectedEdges = ["B.fsi", ["A.fs"]] + assertGraphEqual deps expectedEdges + + +[] +let ``When defining a top-level module, the implicit parent namespace is taken into account when considering references to the file - .fsi, .fs pair`` () = + let files = + [| + "A.fsi", """ +module A.B.C1 +type X = X of int +""" + "B.fs", """ +module A.B.C2 +let x : C1.X -> unit = failwith "" +""" + |] |> buildFiles + + let deps = DependencyResolution.detectFileDependencies files + + let expectedEdges = ["B.fs", ["A.fsi"]] + assertGraphEqual deps expectedEdges + +[] +let ``When defining a top-level module, the implicit parent namespace is taken into account when considering references to the file - .fs, .fs pair`` () = + let files = + [| + "A.fs", """ +module A.B.C1 +type X = X of int +""" + "B.fs", """ +module A.B.C2 +let x : C1.X -> unit = failwith "" +""" + |] |> buildFiles + + let deps = DependencyResolution.detectFileDependencies files + + let expectedEdges = ["B.fs", ["A.fs"]] + assertGraphEqual deps expectedEdges + [] let ``With no references there is no dependency`` () = let files = @@ -238,12 +337,26 @@ let analyseResult (result: DepsResult) = v |> Array.map (fun d -> result.Graph[d].Length) |> Array.max) printfn $"TotalDeps: {totalDeps}, topFirstDeps: {topFirstDeps}" +// +// open GiGraph.Dot.Extensions +// open GiGraph.Dot.Output.Options +// let makeDotFile (path : string) (graph : Graph) : unit = +// let g = DotGraph(directed=true) +// g.Layout.Direction <- DotLayoutDirection.LeftToRight +// let name (f : File) = $"{f.QualifiedName}.{Path.GetExtension(f.Name)}" +// graph +// |> Graph.collectEdges +// |> Array.iter (fun (a, b) -> g.Edges.Add(name a, name b) |> ignore) +// let _options = DotFormattingOptions() +// printfn $"{g.Build()}" +// g.SaveToFile(path) [] let ``Analyse hardcoded files`` () = let deps = DependencyResolution.detectFileDependencies sampleFiles printfn "Detected file dependencies:" deps.Graph |> Graph.print + // makeDotFile "graph.dot" deps.Graph let private parseProjectAndGetSourceFiles (projectFile: string) = //let cacheDir = "." @@ -307,3 +420,5 @@ let ``Analyse whole projects and print statistics`` (projectFile: string) = v |> Array.map (fun d -> graph.Graph[d].Length) |> Array.max) printfn $"TotalDeps: {totalDeps}, topFirstDeps: {topFirstDeps}, diff: {totalDeps - topFirstDeps}" + + // makeDotFile "FCS.deps.dot" graph.Graph diff --git a/tests/ParallelTypeCheckingTests/Tests/TestGraphProcessing.fs b/tests/ParallelTypeCheckingTests/Tests/TestGraphProcessing.fs index ac7a83bcbd0..378c7f9e8e5 100644 --- a/tests/ParallelTypeCheckingTests/Tests/TestGraphProcessing.fs +++ b/tests/ParallelTypeCheckingTests/Tests/TestGraphProcessing.fs @@ -24,7 +24,7 @@ module FakeGraphProcessing = let processFileGraph<'Item when 'Item: comparison> (graph: Graph<'Item>) : FinalFileResult[] * State = let parallelism = 4 // cpu count? - GraphProcessing.processGraph graph typeCheckFile folder "" (fun _ -> true) parallelism + GraphProcessing.processGraph graph typeCheckFile folder (fun _item -> _item.ToString().GetHashCode()) "" (fun _ -> true) parallelism let deps: Graph = [| @@ -55,7 +55,6 @@ let a = 3 let a = { Idx = FileIdx.make 1 - Code = code AST = ASTOrFsix.AST <| parseSourceCode ("A.fs", code) FsiBacked = false } @@ -69,7 +68,6 @@ let b = 3 let b = { Idx = FileIdx.make 2 - Code = code AST = ASTOrFsix.AST <| parseSourceCode ("B.fs", code) FsiBacked = false } diff --git a/tests/ParallelTypeCheckingTests/Tests/Utils.fs b/tests/ParallelTypeCheckingTests/Tests/Utils.fs index 2fb6e2f0c37..999d5b14bea 100644 --- a/tests/ParallelTypeCheckingTests/Tests/Utils.fs +++ b/tests/ParallelTypeCheckingTests/Tests/Utils.fs @@ -69,11 +69,9 @@ let internal mapMethod (method: Method) = | Method.ParallelCheckingOfBackedImplFiles -> TypeCheckingMode.ParallelCheckingOfBackedImplFiles | Method.Graph -> TypeCheckingMode.Graph -/// Includes mutation of static config +/// Includes mutation of static config. /// A very hacky way to setup the given type-checking method - mutates static state and returns new args /// TODO Make the method configurable via proper config passed top-down let setupCompilationMethod (method: Method) = - printfn $"Method: {method}" let mode = mapMethod method - ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParallelTypeChecking.CheckMultipleInputsInParallel ParseAndCheckInputs.typeCheckingMode <- mode