Some cleanup. FCS checking failing for unknown reason

Author: safesparrow

.fantomasignore

@@ -12,7 +12,7 @@ artifacts/
 
 # Explicitly formatted Tests/ subdirectories (with exceptions)
 !tests/ParallelTypeCheckingTests/
-*/.checkouts/
+*/.fcs_test/
 
 # Explicitly unformatted implementation files
 

src/Compiler/Driver/CompilerConfig.fsi

@@ -205,8 +205,11 @@ type ParallelReferenceResolution =
 
 [<RequireQualifiedAccess>]
 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
 
 [<RequireQualifiedAccess>]

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

src/Compiler/Driver/ParseAndCheckInputs.fs

@@ -1729,7 +1729,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 ->

tests/ParallelTypeCheckingTests/Code/DependencyResolution.fs

@@ -260,31 +260,31 @@ module internal DependencyResolution =
         }
 
 /// <summary>
-/// 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
 /// </summary>
 let analyseEfficiency (result: DepsResult) : unit =
     let graph = result.Graph
-    let totalSize1 = graph |> Seq.sumBy (fun (KeyValue (_k, v)) -> v.Length)
+    let edgeCount = 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 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}%%"

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

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<unit>
-    | 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<LimitAgentMessage>) =
-        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,51 +14,38 @@ 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
     let processedCountLock = Object()
     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
     let workerWork () : unit =
         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