From 9beca102c8e8ee4e28070871b368551cdce4150f Mon Sep 17 00:00:00 2001 From: janusz Date: Tue, 8 Nov 2022 03:38:44 +0000 Subject: [PATCH] Changes - FCS type-checking now broken - hangs early on... --- src/Compiler/Driver/ParseAndCheckInputs.fs | 20 +++++---- src/Compiler/Driver/ParseAndCheckInputs.fsi | 2 + src/Compiler/Utilities/Activity.fs | 2 +- tests/ParallelTypeCheckingTests/Code/Graph.fs | 25 +++++++---- .../Code/GraphProcessing.fs | 6 ++- .../Code/Parallel.fs | 6 ++- .../Code/ParallelTypeChecking.fs | 13 +++--- tests/ParallelTypeCheckingTests/Program.fs | 27 +++-------- .../Tests/TestCompilation.fs | 2 +- .../Tests/TestCompilationFromCmdlineArgs.fs | 45 ++++++------------- .../ParallelTypeCheckingTests/Tests/Utils.fs | 28 ++++++------ 11 files changed, 81 insertions(+), 95 deletions(-) diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index edc08a9b9be..e29b48e45a8 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -1189,7 +1189,7 @@ let AddCheckResultsToTcState singles <- singles + 1 // TODO Thread-safety total <- total + sw.Elapsed - printfn $"[{Threading.Thread.CurrentThread.ManagedThreadId}] [{singles}] single add took {sw.ElapsedMilliseconds}ms, total so far: {total.TotalMilliseconds}ms" + // printfn $"[{Threading.Thread.CurrentThread.ManagedThreadId}] [{singles}] single add took {sw.ElapsedMilliseconds}ms, total so far: {total.TotalMilliseconds}ms" ccuSigForFile, tcState @@ -1465,9 +1465,9 @@ let CheckOneInputAux' printfn $"[{Thread.CurrentThread.ManagedThreadId}] Saving fsiBackedInfos for {file.FileName}" fsiBackedInfos[file.FileName] <- sigFileType - printfn $"Finished Processing Sig {file.FileName}" + // printfn $"Finished Processing Sig {file.FileName}" return fun tcState -> - printfn $"Applying Sig {file.FileName}" + // printfn $"Applying Sig {file.FileName}" let fsiPartialResult, tcState = let rootSigs = Zmap.add qualNameOfFile sigFileType tcState.tcsRootSigs @@ -1488,7 +1488,7 @@ let CheckOneInputAux' fsiPartialResult, tcState | ParsedInput.ImplFile file -> - printfn $"Processing Impl {file.FileName}" + // printfn $"Processing Impl {file.FileName}" let qualNameOfFile = file.QualifiedName // Check if we've got an interface for this fragment @@ -1515,10 +1515,10 @@ let CheckOneInputAux' file ) - printfn $"Finished Processing Impl {file.FileName}" + // printfn $"Finished Processing Impl {file.FileName}" return fun tcState -> - let backed = rootSigOpt.IsSome - printfn $"Applying Impl Backed={backed} {file.FileName}" + // let backed = rootSigOpt.IsSome + // printfn $"Applying Impl Backed={backed} {file.FileName}" let ccuSigForFile, fsTcState = AddCheckResultsToTcState @@ -1535,7 +1535,7 @@ let CheckOneInputAux' tcsCreatesGeneratedProvidedTypes = fsTcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes } - printfn $"Finished applying Impl {file.FileName}" + // printfn $"Finished applying Impl {file.FileName}" partialResult, tcState with e -> @@ -1733,10 +1733,12 @@ let mutable CheckMultipleInputsUsingGraphMode : CheckArgs -> (PartialResult list = fun _ -> failwith $"Graph-based type-checking function not set - set CheckMultipleInputsUsingGraphMode before using this mode" +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 tcConfig.typeCheckingConfig.Mode with + match typeCheckingMode with | TypeCheckingMode.Sequential -> CheckMultipleInputsSequential(ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs) | TypeCheckingMode.ParallelCheckingOfBackedImplFiles -> diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fsi b/src/Compiler/Driver/ParseAndCheckInputs.fsi index f62cf23d257..ba11b81095d 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fsi +++ b/src/Compiler/Driver/ParseAndCheckInputs.fsi @@ -200,6 +200,8 @@ val CheckMultipleInputsFinish: /// Finish the checking of a closed set of inputs val CheckClosedInputSetFinish: CheckedImplFile list * TcState -> TcState * CheckedImplFile list * ModuleOrNamespace +val mutable typeCheckingMode : TypeCheckingMode + /// Check a closed set of inputs val CheckClosedInputSet: ctok: CompilationThreadToken * diff --git a/src/Compiler/Utilities/Activity.fs b/src/Compiler/Utilities/Activity.fs index 4c690217a4b..9c99d931b83 100644 --- a/src/Compiler/Utilities/Activity.fs +++ b/src/Compiler/Utilities/Activity.fs @@ -12,7 +12,7 @@ module Activity = let private activitySource = new ActivitySource(activitySourceName) let start (name: string) (tags: (string * string) seq) : IDisposable = - printfn $"Activity.start {name} %+A{tags}" + // printfn $"Activity.start {name} %+A{tags}" let activity = activitySource.StartActivity(name) match activity with diff --git a/tests/ParallelTypeCheckingTests/Code/Graph.fs b/tests/ParallelTypeCheckingTests/Code/Graph.fs index cf51577b813..b1b3b586549 100644 --- a/tests/ParallelTypeCheckingTests/Code/Graph.fs +++ b/tests/ParallelTypeCheckingTests/Code/Graph.fs @@ -16,6 +16,19 @@ module Graph = |> Seq.collect (fun (KeyValue(node, deps)) -> deps |> Array.map (fun dep -> node, dep)) |> Seq.toArray + let addIfMissing<'Node when 'Node : equality> (nodes : 'Node seq) (graph : Graph<'Node>) : Graph<'Node> = + nodes + |> Seq.except (graph.Keys |> Seq.toArray) + |> fun missing -> + let toAdd = + missing + |> Seq.map (fun n -> KeyValuePair(n, [||])) + |> Seq.toArray + + let x = Array.append (graph |> Seq.toArray) toAdd + x + |> Dictionary<_,_> |> fun x -> x :> IReadOnlyDictionary<_,_> + /// Create entries for nodes that don't have any dependencies but are mentioned as dependencies themselves let fillEmptyNodes<'Node when 'Node : equality> (graph : Graph<'Node>) : Graph<'Node> = let missingNodes = @@ -23,14 +36,8 @@ module Graph = |> Seq.toArray |> Array.concat |> Array.except graph.Keys - - let toAdd = - missingNodes - |> Array.map (fun n -> KeyValuePair(n, [||])) - - let x = Array.append (graph |> Seq.toArray) toAdd - x - |> Dictionary<_,_> |> fun x -> x :> IReadOnlyDictionary<_,_> + + addIfMissing missingNodes graph /// Create a transitive closure of the graph let transitive<'Node when 'Node : equality> (graph : Graph<'Node>) : Graph<'Node> = @@ -61,7 +68,7 @@ module Graph = // Construct reversed graph |> Seq.map (fun (dep, edges) -> dep, edges |> Seq.map fst |> Seq.toArray) |> readOnlyDict - |> fillEmptyNodes + |> addIfMissing originalGraph.Keys let printCustom (graph : Graph<'Node>) (printer : 'Node -> string) : unit = printfn "Graph:" diff --git a/tests/ParallelTypeCheckingTests/Code/GraphProcessing.fs b/tests/ParallelTypeCheckingTests/Code/GraphProcessing.fs index e0cb9d79249..b9c2e916d33 100644 --- a/tests/ParallelTypeCheckingTests/Code/GraphProcessing.fs +++ b/tests/ParallelTypeCheckingTests/Code/GraphProcessing.fs @@ -160,6 +160,9 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item : equality let dependants = graph |> Graph.reverse let makeNode (item : 'Item) : Node<'Item, StateWrapper<'Item, 'State>, ResultWrapper<'Item, 'Result>> = let info = + let exists = graph.ContainsKey item + if not exists || not (transitiveDeps.ContainsKey item) || not (dependants.ContainsKey item) then + printfn $"WHAT {item}" { Item = item Deps = graph[item] @@ -237,6 +240,7 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item : equality parallelism (fun processedCount -> processedCount = nodes.Count) cts.Token + (fun x -> x.Info.Item.ToString()) let nodesArray = nodes.Values |> Seq.toArray let finals, {State = state}: 'FinalFileResult[] * StateWrapper<'Item, 'State> = @@ -244,7 +248,7 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item : equality |> Array.filter (fun node -> includeInFinalState node.Info.Item) |> Array.sortBy (fun node -> node.Info.Item) |> fun nodes -> - printfn $"%+A{nodes |> Array.map (fun n -> n.Info.Item.ToString())}" + // printfn $"%+A{nodes |> Array.map (fun n -> n.Info.Item.ToString())}" nodes |> Array.fold (fun (fileResults, state) node -> let fileResult, state = folder state (node.Result.Value |> snd) diff --git a/tests/ParallelTypeCheckingTests/Code/Parallel.fs b/tests/ParallelTypeCheckingTests/Code/Parallel.fs index 2235f64991b..4449d2098d9 100644 --- a/tests/ParallelTypeCheckingTests/Code/Parallel.fs +++ b/tests/ParallelTypeCheckingTests/Code/Parallel.fs @@ -70,7 +70,7 @@ let processInParallelUsingMailbox 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, @@ -81,6 +81,7 @@ let processInParallel (parallelism : int) (stop : int -> bool) (ct : CancellationToken) + (itemToString) : unit = let bc = new BlockingCollection<'Item>() @@ -88,9 +89,10 @@ let processInParallel let processedCountLock = Object() let mutable processedCount = 0 let processItem item = - // printfn $"Processing {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) diff --git a/tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs b/tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs index ac12e690467..49eb413b221 100644 --- a/tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs +++ b/tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs @@ -138,6 +138,7 @@ let CheckMultipleInputsInParallel : State -> PartialResult * State = cancellable { use _ = UseDiagnosticsLogger logger + // printfn $"Processing AST {file.ToString()}" // Is it OK that we don't update 'priorErrors' after processing batches? let checkForErrors2 () = priorErrors || (logger.ErrorCount > 0) @@ -145,7 +146,7 @@ let CheckMultipleInputsInParallel match file.AST with | ASTOrX.AST _ -> - printfn $"Processing AST {file.ToString()}" + // printfn $"Processing AST {file.ToString()}" let! f = CheckOneInput'( checkForErrors2, tcConfig, @@ -161,7 +162,7 @@ let CheckMultipleInputsInParallel printfn $"Finished Processing AST {file.ToString()}" return (fun (state : State) -> - printfn $"Applying {file.ToString()}" + // printfn $"Applying {file.ToString()}" let tcState, priorErrors = state let (partialResult : PartialResult, tcState) = f tcState @@ -169,11 +170,11 @@ let CheckMultipleInputsInParallel // TODO Should we use local _priorErrors or global priorErrors? let priorOrCurrentErrors = priorErrors || hasErrors let state : State = tcState, priorOrCurrentErrors - printfn $"Finished applying {file.ToString()}" + // printfn $"Finished applying {file.ToString()}" partialResult, state ) | ASTOrX.X fsi -> - printfn $"Processing X {file.ToString()}" + // printfn $"Processing X {file.ToString()}" let hadSig = true // Add dummy .fs results @@ -191,7 +192,7 @@ let CheckMultipleInputsInParallel return (fun (state : State) -> // (tcState.TcEnvFromImpls, EmptyTopAttrs, None, ccuSigForFile), state - printfn $"Applying X state {file}" + // printfn $"Applying X state {file}" let tcState, priorErrors = state // (tcState.TcEnvFromImpls, EmptyTopAttrs, None, ccuSigForFile), state @@ -205,7 +206,7 @@ let CheckMultipleInputsInParallel // TODO Should we use local _priorErrors or global priorErrors? let priorOrCurrentErrors = priorErrors || hasErrors let state : State = tcState, priorOrCurrentErrors - printfn $"Finished applying X state {file}" + // printfn $"Finished applying X state {file}" partialResult, state ) } diff --git a/tests/ParallelTypeCheckingTests/Program.fs b/tests/ParallelTypeCheckingTests/Program.fs index 1e23cef3f33..4152199c86f 100644 --- a/tests/ParallelTypeCheckingTests/Program.fs +++ b/tests/ParallelTypeCheckingTests/Program.fs @@ -6,15 +6,15 @@ open ParallelTypeCheckingTests.TestUtils let _parse (argv: string[]): Args = let parseMode (mode : string) = match mode.ToLower() with - | "sequential" -> TypeCheckingMode.Sequential - | "parallelfs" -> TypeCheckingMode.ParallelCheckingOfBackedImplFiles - | "graph" -> TypeCheckingMode.Graph + | "sequential" -> Method.Sequential + | "parallelfs" -> Method.ParallelCheckingOfBackedImplFiles + | "graph" -> Method.Graph | _ -> failwith $"Unrecognised method: {mode}" let path, mode, workingDir = match argv with | [|path|] -> - path, TypeCheckingMode.Sequential, None + path, Method.Sequential, None | [|path; mode|] -> path, parseMode mode, None | [|path; mode; workingDir|] -> @@ -30,20 +30,7 @@ let _parse (argv: string[]): Args = [] let main _argv = - let c = - { - Method = Method.Graph - Project = TestCompilation.Codebases.fsFsi - } : TestCompilation.Case - - TestCompilation.compile c - // let workDir, path, lineLimit = TestCompilationFromCmdlineArgs.codebases[2] - // let stuff = - // { - // Path = path - // LineLimit = lineLimit - // WorkingDir = Some workDir - // Mode = Method.Nojaf - // } - // TestCompilationFromCmdlineArgs.TestCompilerFromArgs stuff + let args = _parse _argv + let args = {args with LineLimit = Some 219} + TestCompilationFromCmdlineArgs.TestCompilerFromArgs args 0 \ No newline at end of file diff --git a/tests/ParallelTypeCheckingTests/Tests/TestCompilation.fs b/tests/ParallelTypeCheckingTests/Tests/TestCompilation.fs index 222ab2548c3..67bbc8e8551 100644 --- a/tests/ParallelTypeCheckingTests/Tests/TestCompilation.fs +++ b/tests/ParallelTypeCheckingTests/Tests/TestCompilation.fs @@ -134,9 +134,9 @@ type Case = let compile (x : Case) = use _ = FSharp.Compiler.Diagnostics.Activity.start "Compile codebase" ["method", x.Method.ToString()] + setupCompilationMethod x.Method makeCompilationUnit x.Project.Files |> Compiler.withOutputType x.Project.OutputType - |> setupCompilationMethod x.Method |> Compiler.compile |> Compiler.Assertions.shouldSucceed |> ignore diff --git a/tests/ParallelTypeCheckingTests/Tests/TestCompilationFromCmdlineArgs.fs b/tests/ParallelTypeCheckingTests/Tests/TestCompilationFromCmdlineArgs.fs index de17db6f4fe..690b263d0dc 100644 --- a/tests/ParallelTypeCheckingTests/Tests/TestCompilationFromCmdlineArgs.fs +++ b/tests/ParallelTypeCheckingTests/Tests/TestCompilationFromCmdlineArgs.fs @@ -17,26 +17,10 @@ type Codebase = let codebases = [| - { WorkDir = $@"{__SOURCE_DIRECTORY__}\.checkouts\fcs\src\compiler"; Path = $@"{__SOURCE_DIRECTORY__}\FCS.args.txt"; Limit = None } + { WorkDir = $@"{__SOURCE_DIRECTORY__}\.checkouts\fcs\src\compiler"; Path = $@"{__SOURCE_DIRECTORY__}\FCS.args.txt"; Limit = Some 237 } { WorkDir = $@"{__SOURCE_DIRECTORY__}\.checkouts\fcs\tests\FSharp.Compiler.ComponentTests"; Path = $@"{__SOURCE_DIRECTORY__}\ComponentTests.args.txt"; Limit = None } |] -/// 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 internal setupArgsMethod (method: TypeCheckingMode) (args: string[]): string[] = - printfn $"Method: {method}" - match method with - | TypeCheckingMode.Sequential -> - // Restore default - ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParseAndCheckInputs.CheckMultipleInputsInParallel - args - | TypeCheckingMode.ParallelCheckingOfBackedImplFiles -> - ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParseAndCheckInputs.CheckMultipleInputsInParallel - Array.append args [|"--test:ParallelCheckingWithSignatureFilesOn"|] - | TypeCheckingMode.Graph -> - ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParallelTypeChecking.CheckMultipleInputsInParallel - Array.append args [|"--test:ParallelCheckingWithSignatureFilesOn"|] - let internal setupParsed config = let {Path = path; LineLimit = lineLimit; Method = method; WorkingDir = workingDir} = config let args = @@ -44,8 +28,9 @@ let internal setupParsed config = |> fun lines -> match lineLimit with Some limit -> Array.take (Math.Min(limit, lines.Length)) lines | None -> lines |> Array.map replacePaths + setupCompilationMethod method + printfn $"WorkingDir = {workingDir}" - let args = setupArgsMethod method args workingDir |> Option.iter (fun dir -> Environment.CurrentDirectory <- replaceCodeRoot dir) args @@ -67,26 +52,22 @@ let internal TestCompilerFromArgs (config : Args) : unit = finally Environment.CurrentDirectory <- oldWorkDir +let internal codebaseToConfig code method = + { + Path = code.Path + LineLimit = code.Limit + Method = method + WorkingDir = Some code.WorkDir + } + [] [] let ``Test graph-based type-checking`` (code : Codebase) = - let config = - { - Path = code.Path - LineLimit = code.Limit - Method = TypeCheckingMode.Graph - WorkingDir = Some code.WorkDir - } + let config = codebaseToConfig code Method.Graph TestCompilerFromArgs config [] [] let ``Test sequential type-checking`` (code : Codebase) = - let config = - { - Path = code.Path - LineLimit = code.Limit - Method = TypeCheckingMode.Graph - WorkingDir = Some code.WorkDir - } + let config = codebaseToConfig code Method.Sequential TestCompilerFromArgs config \ No newline at end of file diff --git a/tests/ParallelTypeCheckingTests/Tests/Utils.fs b/tests/ParallelTypeCheckingTests/Tests/Utils.fs index 88b62f3e652..34015163cb7 100644 --- a/tests/ParallelTypeCheckingTests/Tests/Utils.fs +++ b/tests/ParallelTypeCheckingTests/Tests/Utils.fs @@ -25,7 +25,7 @@ let replacePaths (s : string) = [] type Method = | Sequential - | ParallelFs + | ParallelCheckingOfBackedImplFiles | Graph let methods = @@ -55,7 +55,7 @@ type internal Args = { Path : string LineLimit : int option - Method : TypeCheckingMode + Method : Method WorkingDir : string option } @@ -68,17 +68,17 @@ let makeCompilationUnit (files : (string * string) list) : CompilationUnit = f |> withAdditionalSourceFiles rest +let internal mapMethod (method : Method) = + match method with + | Method.Sequential -> TypeCheckingMode.Sequential + | Method.ParallelCheckingOfBackedImplFiles -> TypeCheckingMode.ParallelCheckingOfBackedImplFiles + | Method.Graph -> TypeCheckingMode.Graph + /// Includes mutation of static config -let setupCompilationMethod (method: Method) (x: CompilationUnit): CompilationUnit = +/// 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}" - match method with - | Method.Sequential -> - x - | Method.ParallelFs -> - ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParseAndCheckInputs.CheckMultipleInputsInParallel - x - |> withOptions [ "--test:ParallelCheckingWithSignatureFilesOn" ] - | Method.Graph -> - ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParallelTypeChecking.CheckMultipleInputsInParallel - x - |> withOptions [ "--test:ParallelCheckingWithSignatureFilesOn" ] + let mode = mapMethod method + ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParallelTypeChecking.CheckMultipleInputsInParallel + ParseAndCheckInputs.typeCheckingMode <- mode