Changes - FCS type-checking now broken - hangs early on...

Author: safesparrow

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

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 *

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

tests/ParallelTypeCheckingTests/Code/Graph.fs

@@ -16,21 +16,28 @@ 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 =
             graph.Values
             |> 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:"

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,14 +240,15 @@ 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> =
         nodesArray
         |> 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)

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,16 +81,18 @@ let processInParallel
     (parallelism : int)
     (stop : int -> bool)
     (ct : CancellationToken)
+    (itemToString)
     : unit
     =
     let bc = new BlockingCollection<'Item>()
     firstItems |> Array.iter bc.Add
     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)

tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs

@@ -138,14 +138,15 @@ 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)
 
             let tcSink = TcResultsSink.NoSink
 
             match file.AST with
             | ASTOrX.AST _ ->
-                printfn $"Processing AST {file.ToString()}"
+                // printfn $"Processing AST {file.ToString()}"
                 let! f = CheckOneInput'(
                     checkForErrors2,
                     tcConfig,
@@ -161,19 +162,19 @@ 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
 
                         let hasErrors = logger.ErrorCount > 0
                         // 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
                     )
         }

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 =
 
 [<EntryPoint>]
 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

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

tests/ParallelTypeCheckingTests/Tests/TestCompilationFromCmdlineArgs.fs

@@ -17,35 +17,20 @@ 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 =
         System.IO.File.ReadAllLines(path |> replacePaths)
         |> 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
+    }
+
 [<TestCaseSource(nameof(codebases))>]
 [<Explicit("Before running these tests, you must prepare the codebase by running FCS.prepare.ps1")>]
 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
 
 [<TestCaseSource(nameof(codebases))>]
 [<Explicit("Before running these tests, you must prepare the codebase by running FCS.prepare.ps1")>]
 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