Skip to content

Commit 9deabfa

Browse files
safesparrowsafesparrow
committed
Start cleaning up graph processing
1 parent e98948d commit 9deabfa

File tree

7 files changed

+141
-172
lines changed

7 files changed

+141
-172
lines changed

‎tests/ParallelTypeCheckingTests/Code/GraphProcessing.fs‎

Lines changed: 25 additions & 138 deletions
Original file line numberDiff line numberDiff line change
@@ -13,89 +13,23 @@ type NodeInfo<'Item> =
1313
Dependants: 'Item[]
1414
}
1515

16-
type StateMeta<'Item> =
17-
{
18-
Contributors: 'Item[]
19-
}
20-
21-
static member Empty() = { Contributors = [||] }
22-
23-
type StateWrapper<'Item, 'State> =
24-
{
25-
Meta: StateMeta<'Item>
26-
State: 'State
27-
}
28-
29-
type ResultWrapper<'Item, 'Result> = { Item: 'Item; Result: 'Result }
30-
31-
type Node<'Item, 'State, 'Result> =
16+
type Node<'Item, 'Result> =
3217
{
3318
Info: NodeInfo<'Item>
3419
mutable ProcessedDepsCount: int
35-
mutable Result: ('State * 'Result) option
36-
mutable InputState: 'State option
20+
mutable Result: 'Result option
3721
}
3822

39-
// TODO Do we need to suppress some error logging if we
40-
// TODO apply the same partial results multiple times?
41-
// TODO Maybe we can enable logging only for the final fold
42-
/// <summary>
43-
/// Combine results of dependencies needed to type-check a 'higher' node in the graph
44-
/// </summary>
45-
/// <param name="deps">Direct dependencies of a node</param>
46-
/// <param name="transitiveDeps">Transitive dependencies of a node</param>
47-
/// <param name="folder">A way to fold a single result into existing state</param>
48-
let combineResults
49-
(emptyState: 'State)
50-
(deps: Node<'Item, 'State, 'Result>[])
51-
(transitiveDeps: Node<'Item, 'State, 'Result>[])
52-
(folder: 'State -> 'Result -> 'State)
53-
: 'State =
54-
match deps with
55-
| [||] -> emptyState
56-
| _ ->
57-
let biggestDep =
58-
let sizeMetric node =
59-
node.Info.TransitiveDeps.Length
60-
deps
61-
|> Array.maxBy sizeMetric
62-
63-
let orFail value =
64-
value |> Option.defaultWith (fun () -> failwith "Unexpected lack of result")
65-
66-
let firstState = biggestDep.Result |> orFail |> fst
67-
68-
// TODO Potential perf optimisation: Keep transDeps in a HashSet from the start,
69-
// avoiding reconstructing the HashSet here
70-
71-
// Add single-file results of remaining transitive deps one-by-one using folder
72-
// Note: Good to preserve order here so that folding happens in file order
73-
let included =
74-
let set = HashSet(biggestDep.Info.TransitiveDeps)
75-
set.Add biggestDep.Info.Item |> ignore
76-
set
77-
78-
let resultsToAdd =
79-
transitiveDeps
80-
|> Array.filter (fun dep -> included.Contains dep.Info.Item = false)
81-
|> Array.distinctBy (fun dep -> dep.Info.Item)
82-
|> Array.map (fun dep -> dep.Result |> orFail |> snd)
83-
84-
let state = Array.fold folder firstState resultsToAdd
85-
state
86-
87-
// TODO Could be replaced with a simpler recursive approach with memoised per-item results
88-
let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item: equality and 'Item: comparison>
23+
let processGraphSimple<'Item, 'Result when 'Item: equality and 'Item: comparison>
8924
(graph: Graph<'Item>)
90-
(doWork: 'Item -> 'State -> 'Result)
91-
(folder: bool -> 'State -> 'Result -> 'FinalFileResult * 'State)
92-
(emptyState: 'State)
25+
(doWork: IReadOnlyDictionary<'Item, Node<'Item, 'Result>> -> Node<'Item, 'Result> -> 'Result)
9326
(parallelism: int)
94-
: 'FinalFileResult[] * 'State =
27+
: 'Result[] // Results in order defined in 'graph'
28+
=
9529
let transitiveDeps = graph |> Graph.transitiveOpt
9630
let dependants = graph |> Graph.reverse
9731

98-
let makeNode (item: 'Item) : Node<'Item, StateWrapper<'Item, 'State>, ResultWrapper<'Item, 'Result>> =
32+
let makeNode (item: 'Item) : Node<'Item, 'Result> =
9933
let info =
10034
let exists = graph.ContainsKey item
10135

@@ -104,7 +38,7 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item: equality a
10438
|| not (transitiveDeps.ContainsKey item)
10539
|| not (dependants.ContainsKey item)
10640
then
107-
printfn $"WHAT {item}"
41+
printfn $"Unexpected inconsistent state of the graph for item '{item}'"
10842

10943
{
11044
Item = item
@@ -117,56 +51,26 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item: equality a
11751
Info = info
11852
Result = None
11953
ProcessedDepsCount = 0
120-
InputState = None
12154
}
12255

123-
let nodes = graph.Keys |> Seq.map (fun item -> item, makeNode item) |> readOnlyDict
56+
let nodes =
57+
graph.Keys
58+
|> Seq.map (fun item -> item, makeNode item)
59+
|> readOnlyDict
12460
let lookup item = nodes[item]
12561
let lookupMany items = items |> Array.map lookup
126-
12762
let leaves =
128-
nodes.Values |> Seq.filter (fun n -> n.Info.Deps.Length = 0) |> Seq.toArray
129-
130-
let emptyState =
131-
{
132-
Meta = StateMeta.Empty<'Item>()
133-
State = emptyState
134-
}
135-
136-
let folder (isFinalFold: bool) { Meta = meta; State = state } { Item = item; Result = result } =
137-
let finalFileResult, state = folder isFinalFold state result
138-
139-
let state =
140-
{
141-
Meta =
142-
{
143-
Contributors = Array.append meta.Contributors [| item |]
144-
}
145-
State = state
146-
}
147-
148-
finalFileResult, state
63+
nodes.Values
64+
|> Seq.filter (fun n -> n.Info.Deps.Length = 0)
65+
|> Seq.toArray
14966

15067
printfn $"Node count: {nodes.Count}"
15168

15269
let work
153-
(node: Node<'Item, StateWrapper<'Item, 'State>, ResultWrapper<'Item, 'Result>>)
154-
: Node<'Item, StateWrapper<'Item, 'State>, ResultWrapper<'Item, 'Result>>[] =
155-
let folder x y = folder false x y |> snd
156-
let deps = lookupMany node.Info.Deps
157-
let transitiveDeps = lookupMany node.Info.TransitiveDeps
158-
let inputState = combineResults emptyState deps transitiveDeps folder
159-
node.InputState <- Some inputState
160-
let singleRes = doWork node.Info.Item inputState.State
161-
162-
let singleRes =
163-
{
164-
Item = node.Info.Item
165-
Result = singleRes
166-
}
167-
168-
let state = folder inputState singleRes
169-
node.Result <- Some(state, singleRes)
70+
(node: Node<'Item, 'Result>)
71+
: Node<'Item, 'Result>[] =
72+
let singleRes = doWork nodes node
73+
node.Result <- Some singleRes
17074
// Need to double-check that only one dependency schedules this dependant
17175
let unblocked =
17276
node.Info.Dependants
@@ -177,18 +81,7 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item: equality a
17781
lock x (fun () ->
17882
x.ProcessedDepsCount <- x.ProcessedDepsCount + 1
17983
x.ProcessedDepsCount)
180-
18184
pdc = x.Info.Deps.Length)
182-
// printfn $"State after {node.Info.Item}"
183-
// nodes
184-
// |> Seq.map (fun (KeyValue(_, v)) ->
185-
// let x = v.Info.Deps.Length - v.ProcessedDepsCount
186-
// $"{v.Info.Item} - {x} deps left"
187-
// )
188-
// |> Seq.iter (fun x -> printfn $"{x}")
189-
// let c = cnt
190-
// cnt <- cnt+1
191-
// printfn $"Finished processing node. {unblocked.Length} nodes unblocked"
19285
unblocked
19386

19487
use cts = new CancellationTokenSource()
@@ -201,15 +94,9 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item: equality a
20194
cts.Token
20295
(fun x -> x.Info.Item.ToString())
20396

204-
let nodesArray = nodes.Values |> Seq.toArray
205-
206-
let finals, { State = state }: 'FinalFileResult[] * StateWrapper<'Item, 'State> =
207-
nodesArray
208-
|> Array.sortBy (fun node -> node.Info.Item)
209-
|> Array.fold
210-
(fun (fileResults, state) node ->
211-
let fileResult, state = folder true state (node.Result.Value |> snd)
212-
Array.append fileResults [| fileResult |], state)
213-
([||], emptyState)
214-
215-
finals, state
97+
nodes.Values
98+
|> Seq.map (fun node ->
99+
node.Result
100+
|> Option.defaultWith (fun () -> failwith $"Unexpected lack of result for item '{node.Info.Item}'")
101+
)
102+
|> Seq.toArray

‎tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -140,7 +140,7 @@ let CheckMultipleInputsInParallel
140140
let state: State = tcState, priorErrors
141141

142142
let partialResults, (tcState, _) =
143-
GraphProcessing.processGraph<int, State, SingleResult, FinalFileResult>
143+
TypeCheckingGraphProcessing.processGraph<int, State, SingleResult, FinalFileResult>
144144
graph
145145
processFile
146146
folder

‎tests/ParallelTypeCheckingTests/Code/TypeCheckingGraphProcessing.fs‎

Lines changed: 92 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,92 @@
1+
/// Parallel processing of graph of work items with dependencies
2+
module ParallelTypeCheckingTests.TypeCheckingGraphProcessing
3+
4+
open ParallelTypeCheckingTests.GraphProcessing
5+
open System.Collections.Generic
6+
open System.Threading
7+
8+
// TODO Do we need to suppress some error logging if we
9+
// TODO apply the same partial results multiple times?
10+
// TODO Maybe we can enable logging only for the final fold
11+
/// <summary>
12+
/// Combine results of dependencies needed to type-check a 'higher' node in the graph
13+
/// </summary>
14+
/// <param name="deps">Direct dependencies of a node</param>
15+
/// <param name="transitiveDeps">Transitive dependencies of a node</param>
16+
/// <param name="folder">A way to fold a single result into existing state</param>
17+
let private combineResults
18+
(emptyState: 'State)
19+
(deps: Node<'Item, 'State * 'Result>[])
20+
(transitiveDeps: Node<'Item, 'State * 'Result>[])
21+
(folder: 'State -> 'Result -> 'State)
22+
: 'State =
23+
match deps with
24+
| [||] -> emptyState
25+
| _ ->
26+
let biggestDep =
27+
let sizeMetric (node: Node<_,_>) =
28+
node.Info.TransitiveDeps.Length
29+
deps
30+
|> Array.maxBy sizeMetric
31+
32+
let orFail value =
33+
value |> Option.defaultWith (fun () -> failwith "Unexpected lack of result")
34+
35+
let firstState = biggestDep.Result |> orFail |> fst
36+
37+
// TODO Potential perf optimisation: Keep transDeps in a HashSet from the start,
38+
// avoiding reconstructing the HashSet here
39+
40+
// Add single-file results of remaining transitive deps one-by-one using folder
41+
// Note: Good to preserve order here so that folding happens in file order
42+
let included =
43+
let set = HashSet(biggestDep.Info.TransitiveDeps)
44+
set.Add biggestDep.Info.Item |> ignore
45+
set
46+
47+
let resultsToAdd =
48+
transitiveDeps
49+
|> Array.filter (fun dep -> included.Contains dep.Info.Item = false)
50+
|> Array.distinctBy (fun dep -> dep.Info.Item)
51+
|> Array.map (fun dep -> dep.Result |> orFail |> snd)
52+
53+
let state = Array.fold folder firstState resultsToAdd
54+
state
55+
56+
let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item: equality and 'Item: comparison>
57+
(graph: Graph<'Item>)
58+
(doWork: 'Item -> 'State -> 'Result)
59+
(folder: bool -> 'State -> 'Result -> 'FinalFileResult * 'State)
60+
(emptyState: 'State)
61+
(parallelism: int)
62+
: 'FinalFileResult[] * 'State =
63+
64+
let work
65+
(dict: IReadOnlyDictionary<'Item, Node<'Item, 'State * 'Result>>)
66+
(node: Node<'Item, 'State * 'Result>)
67+
: 'State * 'Result =
68+
let folder x y = folder false x y |> snd
69+
let deps = node.Info.Deps |> Array.map (fun node -> dict[node])
70+
let transitiveDeps = node.Info.TransitiveDeps |> Array.map (fun node -> dict[node])
71+
let inputState = combineResults emptyState deps transitiveDeps folder
72+
let singleRes = doWork node.Info.Item inputState
73+
let state = folder inputState singleRes
74+
state, singleRes
75+
76+
use cts = new CancellationTokenSource()
77+
78+
let results =
79+
processGraphSimple
80+
graph
81+
work
82+
parallelism
83+
84+
let finals, state: 'FinalFileResult[] * 'State =
85+
results
86+
|> Array.fold
87+
(fun (fileResults, state) (_, itemRes) ->
88+
let fileResult, state = folder true state itemRes
89+
Array.append fileResults [| fileResult |], state)
90+
([||], emptyState)
91+
92+
finals, state

‎tests/ParallelTypeCheckingTests/ParallelTypeCheckingTests.fsproj‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@
3636
<Compile Include="Code\DependencyResolution.fs" />
3737
<Compile Include="Code\Parallel.fs" />
3838
<Compile Include="Code\GraphProcessing.fs" />
39+
<Compile Include="Code\TypeCheckingGraphProcessing.fs" />
3940
<Compile Include="Code\ParallelTypeChecking.fs" />
4041
<Compile Include="Tests\Utils.fs" />
4142
<Compile Include="Tests\AssemblySetUp.fs" />

‎tests/ParallelTypeCheckingTests/Program.fs‎

Lines changed: 22 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -2,30 +2,29 @@
22

33
#nowarn "1182"
44

5-
open FSharp.Compiler.CompilerConfig
5+
open System
66
open ParallelTypeCheckingTests.TestUtils
77

8-
// let _parse (argv: string[]) : Args =
9-
// let parseMode (mode: string) =
10-
// match mode.ToLower() with
11-
// | "sequential" -> Method.Sequential
12-
// | "parallelfs" -> Method.ParallelCheckingOfBackedImplFiles
13-
// | "graph" -> Method.Graph
14-
// | _ -> failwith $"Unrecognised mode: {mode}"
15-
//
16-
// let path, mode, workingDir =
17-
// match argv with
18-
// | [| path |] -> path, Method.Sequential, None
19-
// | [| path; method |] -> path, parseMode method, None
20-
// | [| path; method; workingDir |] -> path, parseMode method, Some workingDir
21-
// | _ -> failwith "Invalid args - use 'args_path [method [fs-parallel]]'"
22-
//
23-
// {
24-
// Path = path
25-
// LineLimit = None
26-
// Method = mode
27-
// WorkingDir = workingDir
28-
// }
8+
let parseMethod (method: string) =
9+
match method.ToLower() with
10+
| "sequential" -> Method.Sequential
11+
| "parallelfs" -> Method.ParallelCheckingOfBackedImplFiles
12+
| "graph" -> Method.Graph
13+
| _ -> failwith $"Unrecognised mode: {method}"
14+
15+
let parse (argv: string[]) : Args =
16+
match argv with
17+
| [| codebaseNr; method |] ->
18+
let codebaseNr = Int32.Parse codebaseNr
19+
let code = TestCompilationFromCmdlineArgs.codebases[codebaseNr]
20+
let method = parseMethod method
21+
TestCompilationFromCmdlineArgs.codebaseToConfig code method
22+
| _ -> failwith "Invalid args - use 'args_path [method [fs-parallel]]'"
2923

3024
[<EntryPoint>]
31-
let main _argv = 0
25+
let main argv =
26+
FSharp.Compiler.ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <-
27+
ParallelTypeChecking.CheckMultipleInputsInParallel
28+
let args = parse argv
29+
TestCompilationFromCmdlineArgs.TestCompilerFromArgs args
30+
0

0 commit comments

Comments
 (0)