[Experimental] [WIP] Transparent Compiler

src/Compiler/Driver/GraphChecking/Graph.fs

@@ -27,26 +27,39 @@ module internal Graph =
         |> Array.map (fun (KeyValue (k, v)) -> k, v)
         |> readOnlyDict
 
-    let transitive<'Node when 'Node: equality> (graph: Graph<'Node>) : Graph<'Node> =
-        /// Find transitive dependencies of a single node.
-        let transitiveDeps (node: 'Node) =
-            let visited = HashSet<'Node>()
+    /// Find transitive dependencies of a single node.
+    let transitiveDeps (node: 'Node) (graph: Graph<'Node>) =
+        let visited = HashSet<'Node>()
 
-            let rec dfs (node: 'Node) =
-                graph[node]
-                // Add direct dependencies.
-                // Use HashSet.Add return value semantics to filter out those that were added previously.
-                |> Array.filter visited.Add
-                |> Array.iter dfs
+        let rec dfs (node: 'Node) =
+            graph[node]
+            // Add direct dependencies.
+            // Use HashSet.Add return value semantics to filter out those that were added previously.
+            |> Array.filter visited.Add
+            |> Array.iter dfs
 
-            dfs node
-            visited |> Seq.toArray
+        dfs node
+        visited |> Seq.toArray
 
+    let transitive<'Node when 'Node: equality> (graph: Graph<'Node>) : Graph<'Node> =
         graph.Keys
         |> Seq.toArray
-        |> Array.Parallel.map (fun node -> node, transitiveDeps node)
+        |> Array.Parallel.map (fun node -> node, graph |> transitiveDeps node)
         |> readOnlyDict
 
+    /// Get subgraph of the given graph that contains only nodes that are reachable from the given node.
+    let subGraphFor node graph =
+        let allDeps = graph |> transitiveDeps node
+        let relevant n = n = node || allDeps |> Array.contains n
+
+        graph
+        |> Seq.choose (fun (KeyValue (src, deps)) ->
+            if relevant src then
+                Some(src, deps |> Array.filter relevant)
+            else
+                None)
+        |> make
+
     /// Create a reverse of the graph
     let reverse (originalGraph: Graph<'Node>) : Graph<'Node> =
         originalGraph
@@ -59,6 +72,48 @@ module internal Graph =
         |> readOnlyDict
         |> addIfMissing originalGraph.Keys
 
+    /// Returns leaves of the graph and the remaining graph without the leaves.
+    let cutLeaves (graph: Graph<'Node>) =
+        let notLeaves =
+            set
+                [
+                    for (KeyValue (node, deps)) in graph do
+                        if deps.Length > 0 then
+                            node
+                ]
+
+        let leaves =
+            set
+                [
+                    for (KeyValue (node, deps)) in graph do
+                        if deps.Length = 0 then
+                            node
+
+                        yield! deps |> Array.filter (notLeaves.Contains >> not)
+                ]
+
+        leaves,
+        seq {
+            for (KeyValue (node, deps)) in graph do
+                if deps.Length > 0 then
+                    node, deps |> Array.filter (leaves.Contains >> not)
+        }
+        |> make
+
+    /// Returns layers of leaves repeatedly removed from the graph until there's nothing left
+    let leafSequence (graph: Graph<'Node>) =
+        let rec loop (graph: Graph<'Node>) acc =
+            match graph |> cutLeaves with
+            | leaves, _ when leaves.IsEmpty -> acc
+            | leaves, graph ->
+                seq {
+                    yield! acc
+                    leaves
+                }
+                |> loop graph
+
+        loop graph Seq.empty
+
     let printCustom (graph: Graph<'Node>) (nodePrinter: 'Node -> string) : unit =
         printfn "Graph:"
         let join (xs: string[]) = System.String.Join(", ", xs)

src/Compiler/Driver/GraphChecking/Graph.fsi

@@ -13,8 +13,12 @@ module internal Graph =
     /// Create a transitive closure of the graph in O(n^2) time (but parallelize it).
     /// The resulting graph contains edge A -> C iff the input graph contains a (directed) non-zero length path from A to C.
     val transitive<'Node when 'Node: equality> : graph: Graph<'Node> -> Graph<'Node>
+    /// Get a sub-graph of the graph containing only the nodes reachable from the given node.
+    val subGraphFor: node: 'Node -> graph: Graph<'Node> -> Graph<'Node> when 'Node: equality
     /// Create a reverse of the graph.
     val reverse<'Node when 'Node: equality> : originalGraph: Graph<'Node> -> Graph<'Node>
+    /// Returns layers of leaves repeatedly removed from the graph until there's nothing left
+    val leafSequence: graph: Graph<'Node> -> Set<'Node> seq
     /// Print the contents of the graph to the standard output.
     val print: graph: Graph<'Node> -> unit
     /// Create a simple Mermaid graph and save it under the path specified.

src/Compiler/Driver/ParseAndCheckInputs.fs

@@ -1467,14 +1467,14 @@ let CheckOneInputWithCallback
       prefixPathOpt,
       tcSink,
       tcState: TcState,
-      inp: ParsedInput,
+      input: ParsedInput,
       _skipImplIfSigExists: bool): (unit -> bool) * TcConfig * TcImports * TcGlobals * LongIdent option * TcResultsSink * TcState * ParsedInput * bool)
     : Cancellable<Finisher<TcState, PartialResult>> =
     cancellable {
         try
             CheckSimulateException tcConfig
 
-            let m = inp.Range
+            let m = input.Range
             let amap = tcImports.GetImportMap()
 
             let conditionalDefines =
@@ -1483,7 +1483,7 @@ let CheckOneInputWithCallback
                 else
                     Some tcConfig.conditionalDefines
 
-            match inp with
+            match input with
             | ParsedInput.SigFile file ->
                 let qualNameOfFile = file.QualifiedName
 

src/Compiler/FSharp.Compiler.Service.fsproj

@@ -153,6 +153,7 @@
     <Compile Include="Facilities\CompilerLocation.fs" />
     <Compile Include="Facilities\BuildGraph.fsi" />
     <Compile Include="Facilities\BuildGraph.fs" />
+    <Compile Include="Facilities\AsyncMemoize.fs" />
     <FsLex Include="AbstractIL\illex.fsl">
       <OtherFlags>--unicode --lexlib Internal.Utilities.Text.Lexing</OtherFlags>
       <Link>AbstractIL\illex.fsl</Link>
@@ -467,7 +468,9 @@
     <Compile Include="Service\QuickParse.fsi" />
     <Compile Include="Service\QuickParse.fs" />
     <Compile Include="Service\FSharpCheckerResults.fsi" />
-    <Compile Include="Service\FSharpCheckerResults.fs" />
+	  <Compile Include="Service\FSharpCheckerResults.fs" />
+	  <Compile Include="Service\BackgroundCompiler.fs" />
+	  <Compile Include="service\TransparentCompiler.fs" />
     <Compile Include="Service\service.fsi" />
     <Compile Include="Service\service.fs" />
     <Compile Include="Service\ServiceInterfaceStubGenerator.fsi" />

src/Compiler/Facilities/AsyncMemoize.fs

@@ -0,0 +1,136 @@
+namespace Internal.Utilities.Collections
+
+open FSharp.Compiler.BuildGraph
+open System.Threading
+open System.Collections.Generic
+open FSharp.Compiler.Diagnostics
+
+type internal Action<'TKey, 'TValue> =
+    | GetOrCompute of ('TKey -> NodeCode<'TValue>) * CancellationToken
+    | CancelRequest
+    | JobCompleted
+
+type MemoizeRequest<'TKey, 'TValue> = 'TKey * Action<'TKey, 'TValue> * AsyncReplyChannel<NodeCode<'TValue>>
+
+type internal Job<'TValue> =
+    | Running of NodeCode<'TValue> * CancellationTokenSource
+    | Completed of NodeCode<'TValue>
+
+type internal JobEvent<'TKey> =
+    | Started of 'TKey
+    | Finished of 'TKey
+    | Canceled of 'TKey
+
+    member this.Key =
+        match this with
+        | Started key -> key
+        | Finished key -> key
+        | Canceled key -> key
+
+type internal AsyncMemoize<'TKey, 'TValue when 'TKey: equality>(?logEvent: (JobEvent<'TKey> -> unit), ?name: string) =
+
+    let tok = obj ()
+
+    let name = name |> Option.defaultValue "Unnamed"
+
+    let cache =
+        MruCache<_, 'TKey, Job<'TValue>>(keepStrongly = 10, areSame = (fun (x, y) -> x = y))
+
+    let requestCounts = Dictionary<'TKey, int>()
+
+    let incrRequestCount key =
+        requestCounts.[key] <-
+            if requestCounts.ContainsKey key then
+                requestCounts.[key] + 1
+            else
+                1
+
+    let sendAsync (inbox: MailboxProcessor<_>) key msg =
+        inbox.PostAndAsyncReply(fun rc -> key, msg, rc) |> Async.Ignore |> Async.Start
+
+    let log event =
+        logEvent |> Option.iter ((|>) event)
+
+    let agent =
+        MailboxProcessor.Start(fun (inbox: MailboxProcessor<MemoizeRequest<_, _>>) ->
+
+            let post = sendAsync inbox
+
+            async {
+                while true do
+
+                    let! key, action, replyChannel = inbox.Receive()
+
+                    match action, cache.TryGet(tok, key) with
+                    | GetOrCompute _, Some (Completed job) -> replyChannel.Reply job
+                    | GetOrCompute (_, ct), Some (Running (job, _)) ->
+
+                        incrRequestCount key
+                        replyChannel.Reply job
+                        ct.Register(fun _ -> post key CancelRequest) |> ignore
+
+                    | GetOrCompute (computation, ct), None ->
+
+                        let cts = new CancellationTokenSource()
+
+                        let startedComputation =
+                            Async.StartAsTask(
+                                Async.AwaitNodeCode(
+                                    node {
+                                        use _ = Activity.start $"AsyncMemoize.{name}" [| |]
+
+                                        let! result = computation key
+                                        post key JobCompleted
+                                        return result
+                                    }
+                                ),
+                                cancellationToken = cts.Token
+                            )
+
+                        log (Started key)
+
+                        let job = NodeCode.AwaitTask startedComputation
+
+                        cache.Set(tok, key, (Running(job, cts)))
+
+                        incrRequestCount key
+
+                        ct.Register(fun _ -> post key CancelRequest) |> ignore
+
+                        replyChannel.Reply job
+
+                    | CancelRequest, Some (Running (_, cts)) ->
+                        let requestCount = requestCounts.TryGetValue key |> snd
+
+                        if requestCount > 1 then
+                            requestCounts.[key] <- requestCount - 1
+
+                        else
+                            cts.Cancel()
+                            cache.RemoveAnySimilar(tok, key)
+                            requestCounts.Remove key |> ignore
+                            log (Canceled key)
+
+                    | CancelRequest, None
+                    | CancelRequest, Some (Completed _) -> ()
+
+                    | JobCompleted, Some (Running (job, _)) ->
+                        // TODO: should we re-wrap the result?
+                        cache.Set(tok, key, (Completed job))
+                        requestCounts.Remove key |> ignore
+                        log (Finished key)
+
+                    | JobCompleted, _ -> failwith "If this happens there's a bug"
+
+            })
+
+    member _.Get(key, computation) =
+        node {
+            let! ct = NodeCode.CancellationToken
+
+            let! job =
+                agent.PostAndAsyncReply(fun rc -> key, (GetOrCompute(computation, ct)), rc)
+                |> NodeCode.AwaitAsync
+
+            return! job
+        }