Skip to content

Commit 2ec476d

Browse files
safesparrowsafesparrow
committed
changes
1 parent 39e59df commit 2ec476d

9 files changed

Lines changed: 235 additions & 287 deletions

File tree

‎tests/FSharp.Compiler.Service.Tests2/FSharp.Compiler.Service.Tests2.fsproj‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -31,16 +31,18 @@
3131
<Compile Include="TestASTVisit.fs" />
3232
<Compile Include="DepResolving.fs" />
3333
<Compile Include="TestDepResolving.fs" />
34-
<Compile Include="FileGraph.fs" />
34+
<Compile Include="Graph.fs" />
3535
<Compile Include="RunCompiler.fs" />
3636
<None Include="Big.fs">
3737
<CopyToOutputDirectory>PreserveNewest</CopyToOutputDirectory>
3838
</None>
39-
<Content Include="Docs.md" />
39+
<Compile Include="Types.fs" />
4040
<Compile Include="Program.fs" />
4141
<Compile Include="Parallel.fs" />
42-
<Compile Include="code2.fs" />
4342
<Compile Include="GraphProcessing.fs" />
43+
<Compile Include="FileInfoGathering.fs" />
44+
<Compile Include="code2.fs" />
45+
<Content Include="Docs.md" />
4446
</ItemGroup>
4547

4648
<ItemGroup>

‎tests/FSharp.Compiler.Service.Tests2/FileInfoGathering.fs‎

Lines changed: 68 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
/// Allows extracting necessary data from a sequence of project source files
2+
module FSharp.Compiler.Service.Tests.FileInfoGathering
3+
4+
open System.Collections.Generic
5+
open FSharp.Compiler.Service.Tests.Types
6+
open FSharp.Compiler.Service.Tests.Utils
7+
open FSharp.Compiler.Service.Tests2
8+
open FSharp.Compiler.Syntax
9+
10+
let private gatherBackingInfo (files : SourceFiles) : Files =
11+
let seenSigFiles = HashSet<string>()
12+
files
13+
|> Array.mapi (fun i f ->
14+
let fsiBacked =
15+
match f.AST with
16+
| ParsedInput.SigFile _ ->
17+
false
18+
| ParsedInput.ImplFile _ ->
19+
let fsiName = System.IO.Path.ChangeExtension(f.Name, "fsi")
20+
let fsiBacked = seenSigFiles.Contains fsiName
21+
fsiBacked
22+
{
23+
Name = f.Name
24+
Idx = FileIdx.make i
25+
Code = f.Code
26+
AST = f.AST
27+
FsiBacked = fsiBacked
28+
}
29+
)
30+
31+
type ExtractedData =
32+
{
33+
ModuleRefs : LongIdent[]
34+
Tops : LongIdent[]
35+
ContainsModuleAbbreviations : bool
36+
}
37+
38+
type FileData =
39+
{
40+
File : File
41+
Data : ExtractedData
42+
}
43+
44+
let private gatherFileData (file : File) : ExtractedData =
45+
let moduleRefs, containsModuleAbbreviations = ASTVisit.findModuleRefs file.AST
46+
let tops = ASTVisit.topModuleOrNamespaces file.AST
47+
// TODO As a perf optimisation we can skip top-level ids scanning for FsiBacked .fs files
48+
// However, it is unlikely to give a noticable speedup due to parallelism (citation needed)
49+
{
50+
ModuleRefs = moduleRefs
51+
Tops = tops
52+
ContainsModuleAbbreviations = containsModuleAbbreviations
53+
}
54+
55+
/// Extract necessary information from all files in parallel - top-level items and all (partial) module references
56+
let gatherForAllFiles (files : SourceFiles) =
57+
let files = gatherBackingInfo files
58+
let nodes =
59+
files
60+
// TODO Proper async with cancellation
61+
|> Array.Parallel.map (fun f ->
62+
let data = gatherFileData f
63+
{
64+
File = f
65+
Data = data
66+
}
67+
)
68+
nodes

tests/FSharp.Compiler.Service.Tests2/FileGraph.fs renamed to tests/FSharp.Compiler.Service.Tests2/Graph.fs

File renamed without changes.

‎tests/FSharp.Compiler.Service.Tests2/GraphProcessing.fs‎

Lines changed: 55 additions & 79 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,9 @@
1-
module FSharp.Compiler.Service.Tests.GraphProcessing
1+
/// Parallel processing of graph of work items with dependencies
2+
module FSharp.Compiler.Service.Tests.GraphProcessing
23

3-
open System
4-
open System.Collections.Concurrent
54
open System.Collections.Generic
65
open System.Threading
6+
open FSharp.Compiler.Service.Tests.Graph
77

88
/// Used for processing
99
type NodeInfo<'Item> =
@@ -12,12 +12,12 @@ type NodeInfo<'Item> =
1212
Deps : 'Item[]
1313
TransitiveDeps : 'Item[]
1414
Dependants : 'Item[]
15-
ProcessedDepsCount : int
1615
}
1716
type Node<'Item, 'State, 'Result> =
1817
{
1918
Info : NodeInfo<'Item>
20-
Result : ('State * 'Result) option
19+
mutable ProcessedDepsCount : int
20+
mutable Result : ('State * 'Result) option
2121
}
2222

2323
// TODO Do we need to suppress some error logging if we
@@ -66,98 +66,74 @@ let combineResults
6666
let state = Array.fold folder firstState resultsToAdd
6767
state
6868

69-
70-
// TODO Test this version
71-
/// Untested version that uses MailboxProcessor.
72-
/// See http://www.fssnip.net/nX/title/Limit-degree-of-parallelism-using-an-agent for implementation
73-
let processInParallelUsingMailbox
74-
(firstItems : 'Item[])
75-
(work : 'Item -> Async<'Item[]>)
76-
(parallelism : int)
77-
(notify : int -> unit)
78-
(ct : CancellationToken)
79-
: unit
80-
=
81-
let processedCountLock = Object()
82-
let mutable processedCount = 0
83-
let agent = Parallel.threadingLimitAgent 10 ct
84-
let rec processItem item =
85-
async {
86-
let! toSchedule = work item
87-
let pc = lock processedCountLock (fun () -> processedCount <- processedCount + 1; processedCount)
88-
notify pc
89-
toSchedule |> Array.iter (fun x -> agent.Post(Parallel.Start(processItem x)))
90-
}
91-
firstItems |> Array.iter (fun x -> agent.Post(Parallel.Start(processItem x)))
92-
()
93-
94-
// TODO Could replace with MailboxProcessor+Tasks/Asyncs instead of BlockingCollection + Threads
95-
// See http://www.fssnip.net/nX/title/Limit-degree-of-parallelism-using-an-agent
96-
let processInParallel
97-
(firstItems : 'Item[])
98-
(work : 'Item -> 'Item[])
99-
(parallelism : int)
100-
(stop : int -> bool)
101-
(ct : CancellationToken)
102-
: unit
103-
=
104-
let bc = new BlockingCollection<'Item>()
105-
firstItems |> Array.iter bc.Add
106-
let processedCountLock = Object()
107-
let mutable processedCount = 0
108-
let processItem item =
109-
let toSchedule = work item
110-
let processedCount = lock processedCountLock (fun () -> processedCount <- processedCount + 1; processedCount)
111-
toSchedule |> Array.iter bc.Add
112-
processedCount
113-
114-
// TODO Could avoid workers with some semaphores
115-
let workerWork () : unit =
116-
for node in bc.GetConsumingEnumerable(ct) do
117-
if not ct.IsCancellationRequested then // improve
118-
let processedCount = processItem node
119-
if stop processedCount then
120-
bc.CompleteAdding()
121-
122-
Array.Parallel.map workerWork |> ignore // use cancellation
123-
()
124-
125-
let processGraph
126-
(graph : FileGraph)
127-
(doWork : 'Item -> 'State -> 'Result * 'State)
69+
// TODO Could be replaced with a simpler recursive approach with memoised per-item results
70+
let processGraph<'Item, 'State, 'Result when 'Item : equality>
71+
(graph : Graph<'Item>)
72+
(doWork : 'Item -> 'State -> 'State * 'Result)
12873
(folder : 'State -> 'Result -> 'State)
12974
(parallelism : int)
13075
: 'State
13176
=
132-
let transitiveDeps = graph |> calcTransitiveGraph
133-
let dependants = graph |> reverseGraph
134-
let nodes = graph.Keys |> Seq.map ...
135-
let leaves = nodes |> Seq.filter ...
77+
let transitiveDeps = graph |> Graph.transitive
78+
let dependants = graph |> Graph.reverse
79+
let makeNode (item : 'Item) : Node<'Item,'State,'Result> =
80+
let info =
81+
{
82+
Item = item
83+
Deps = graph[item]
84+
TransitiveDeps = transitiveDeps[item]
85+
Dependants = dependants[item]
86+
}
87+
{
88+
Info = info
89+
Result = None
90+
ProcessedDepsCount = 0
91+
}
92+
93+
let nodes =
94+
graph.Keys
95+
|> Seq.map (fun item -> item, makeNode item)
96+
|> readOnlyDict
97+
let lookup item = nodes[item]
98+
let lookupMany items = items |> Array.map lookup
99+
100+
let leaves =
101+
nodes.Values
102+
|> Seq.filter (fun n -> n.Info.Deps.Length = 0)
103+
|> Seq.toArray
104+
136105
let work
137106
(node : Node<'Item, 'State, 'Result>)
138107
: Node<'Item, 'State, 'Result>[]
139108
=
140-
let inputState = combineResults node.Deps node.TransitiveDeps folder
141-
let res = doWork node.Info.Item
142-
node.Result <- res
109+
let deps = lookupMany node.Info.Deps
110+
let transitiveDeps = lookupMany node.Info.TransitiveDeps
111+
let inputState = combineResults deps transitiveDeps folder
112+
let res = doWork node.Info.Item inputState
113+
node.Result <- Some res
114+
// Need to double-check that only one dependency schedules this dependant
143115
let unblocked =
144116
node.Info.Dependants
117+
|> lookupMany
145118
|> Array.filter (fun x ->
146119
let pdc =
147120
lock x (fun () ->
148-
x.Info.ProcessedDepsCount++
149-
x.Info.PrcessedDepsCount
150-
)
121+
x.ProcessedDepsCount <- x.ProcessedDepsCount + 1
122+
x.ProcessedDepsCount
123+
)
151124
pdc = node.Info.Deps.Length
152125
)
153-
|> Array.map (fun x -> nodes[x])
154-
unblocked
126+
unblocked
127+
128+
use cts = new CancellationTokenSource()
155129

156-
processInParallel
130+
Parallel.processInParallel
157131
leaves
158132
work
159133
parallelism
160-
(fun processedCount -> processedCount = nodes.Length)
134+
(fun processedCount -> processedCount = nodes.Count)
135+
cts.Token
161136

162-
let state = combineResults nodes nodes addCheckResultsToTcState
137+
let nodesArray = nodes.Values |> Seq.toArray
138+
let state = combineResults nodesArray nodesArray folder
163139
state

‎tests/FSharp.Compiler.Service.Tests2/Parallel.fs‎

Lines changed: 59 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
11
module FSharp.Compiler.Service.Tests.Parallel
22

3+
open System
4+
open System.Collections.Concurrent
35
open System.Collections.Generic
46
open System.Threading
57

@@ -46,6 +48,63 @@ let threadingLimitAgent limit (ct : CancellationToken) =
4648
}
4749
MailboxProcessor.Start(act, ct)
4850

51+
// TODO Test this version
52+
/// Untested version that uses MailboxProcessor.
53+
/// See http://www.fssnip.net/nX/title/Limit-degree-of-parallelism-using-an-agent for implementation
54+
let processInParallelUsingMailbox
55+
(firstItems : 'Item[])
56+
(work : 'Item -> Async<'Item[]>)
57+
(parallelism : int)
58+
(notify : int -> unit)
59+
(ct : CancellationToken)
60+
: unit
61+
=
62+
let processedCountLock = Object()
63+
let mutable processedCount = 0
64+
let agent = Parallel.threadingLimitAgent 10 ct
65+
let rec processItem item =
66+
async {
67+
let! toSchedule = work item
68+
let pc = lock processedCountLock (fun () -> processedCount <- processedCount + 1; processedCount)
69+
notify pc
70+
toSchedule |> Array.iter (fun x -> agent.Post(Parallel.Start(processItem x)))
71+
}
72+
firstItems |> Array.iter (fun x -> agent.Post(Parallel.Start(processItem x)))
73+
()
74+
75+
// TODO Could replace with MailboxProcessor+Tasks/Asyncs instead of BlockingCollection + Threads
76+
// See http://www.fssnip.net/nX/title/Limit-degree-of-parallelism-using-an-agent
77+
/// Process items in parallel, allow more work to be scheduled as a result of finished work,
78+
/// limit parallelisation to 'parallelism' threads
79+
let processInParallel
80+
(firstItems : 'Item[])
81+
(work : 'Item -> 'Item[])
82+
(parallelism : int)
83+
(stop : int -> bool)
84+
(ct : CancellationToken)
85+
: unit
86+
=
87+
let bc = new BlockingCollection<'Item>()
88+
firstItems |> Array.iter bc.Add
89+
let processedCountLock = Object()
90+
let mutable processedCount = 0
91+
let processItem item =
92+
let toSchedule = work item
93+
let processedCount = lock processedCountLock (fun () -> processedCount <- processedCount + 1; processedCount)
94+
toSchedule |> Array.iter bc.Add
95+
processedCount
96+
97+
// TODO Could avoid workers with some semaphores
98+
let workerWork () : unit =
99+
for node in bc.GetConsumingEnumerable(ct) do
100+
if not ct.IsCancellationRequested then // improve
101+
let processedCount = processItem node
102+
if stop processedCount then
103+
bc.CompleteAdding()
104+
105+
Array.Parallel.map workerWork |> ignore // use cancellation
106+
()
107+
49108
let test () =
50109
// Create an agent that can run at most 2 tasks in parallel
51110
// and send 10 work items that take 1 second to the queue

‎tests/FSharp.Compiler.Service.Tests2/Types.fs‎

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,38 @@
1+
module FSharp.Compiler.Service.Tests.Types
2+
3+
open FSharp.Compiler.Service.Tests.Utils
4+
type AST = FSharp.Compiler.Syntax.ParsedInput
5+
6+
/// Input from the compiler after parsing
7+
[<CustomEquality; NoComparison>]
8+
type SourceFile =
9+
{
10+
Name : string
11+
Idx : FileIdx
12+
Code : string
13+
AST : AST
14+
}
15+
override this.Equals other =
16+
match other with
17+
| :? SourceFile as p -> p.Name.Equals this.Name
18+
| _ -> false
19+
override this.GetHashCode () = this.Name.GetHashCode()
20+
21+
type SourceFiles = SourceFile[]
22+
23+
[<CustomEquality; NoComparison>]
24+
type File =
25+
{
26+
Name : string
27+
Idx : FileIdx
28+
Code : string
29+
AST : AST
30+
FsiBacked : bool
31+
}
32+
override this.Equals other =
33+
match other with
34+
| :? File as f -> f.Name.Equals this.Name
35+
| _ -> false
36+
override this.GetHashCode () = this.Name.GetHashCode()
37+
38+
type Files = File[]

‎tests/FSharp.Compiler.Service.Tests2/Utils.fs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,6 @@
33
#nowarn "40"
44

55
open System.Collections.Concurrent
6-
open System.Collections.Generic
76

87
let memoize<'a, 'b when 'a : equality> f : ('a -> 'b) =
98
let y = HashIdentity.Structural<'a>

0 commit comments

Comments
 (0)