Skip to content

Commit 9beca10

Browse files
safesparrowsafesparrow
committed
Changes - FCS type-checking now broken - hangs early on...
1 parent 39d723b commit 9beca10

11 files changed

Lines changed: 81 additions & 95 deletions

File tree

‎src/Compiler/Driver/ParseAndCheckInputs.fs‎

Lines changed: 11 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1189,7 +1189,7 @@ let AddCheckResultsToTcState
11891189
singles <- singles + 1
11901190
// TODO Thread-safety
11911191
total <- total + sw.Elapsed
1192-
printfn $"[{Threading.Thread.CurrentThread.ManagedThreadId}] [{singles}] single add took {sw.ElapsedMilliseconds}ms, total so far: {total.TotalMilliseconds}ms"
1192+
// printfn $"[{Threading.Thread.CurrentThread.ManagedThreadId}] [{singles}] single add took {sw.ElapsedMilliseconds}ms, total so far: {total.TotalMilliseconds}ms"
11931193

11941194
ccuSigForFile, tcState
11951195

@@ -1465,9 +1465,9 @@ let CheckOneInputAux'
14651465
printfn $"[{Thread.CurrentThread.ManagedThreadId}] Saving fsiBackedInfos for {file.FileName}"
14661466
fsiBackedInfos[file.FileName] <- sigFileType
14671467

1468-
printfn $"Finished Processing Sig {file.FileName}"
1468+
// printfn $"Finished Processing Sig {file.FileName}"
14691469
return fun tcState ->
1470-
printfn $"Applying Sig {file.FileName}"
1470+
// printfn $"Applying Sig {file.FileName}"
14711471
let fsiPartialResult, tcState =
14721472
let rootSigs = Zmap.add qualNameOfFile sigFileType tcState.tcsRootSigs
14731473

@@ -1488,7 +1488,7 @@ let CheckOneInputAux'
14881488
fsiPartialResult, tcState
14891489

14901490
| ParsedInput.ImplFile file ->
1491-
printfn $"Processing Impl {file.FileName}"
1491+
// printfn $"Processing Impl {file.FileName}"
14921492
let qualNameOfFile = file.QualifiedName
14931493

14941494
// Check if we've got an interface for this fragment
@@ -1515,10 +1515,10 @@ let CheckOneInputAux'
15151515
file
15161516
)
15171517

1518-
printfn $"Finished Processing Impl {file.FileName}"
1518+
// printfn $"Finished Processing Impl {file.FileName}"
15191519
return fun tcState ->
1520-
let backed = rootSigOpt.IsSome
1521-
printfn $"Applying Impl Backed={backed} {file.FileName}"
1520+
// let backed = rootSigOpt.IsSome
1521+
// printfn $"Applying Impl Backed={backed} {file.FileName}"
15221522

15231523
let ccuSigForFile, fsTcState =
15241524
AddCheckResultsToTcState
@@ -1535,7 +1535,7 @@ let CheckOneInputAux'
15351535
tcsCreatesGeneratedProvidedTypes = fsTcState.tcsCreatesGeneratedProvidedTypes || createsGeneratedProvidedTypes
15361536
}
15371537

1538-
printfn $"Finished applying Impl {file.FileName}"
1538+
// printfn $"Finished applying Impl {file.FileName}"
15391539
partialResult, tcState
15401540

15411541
with e ->
@@ -1733,10 +1733,12 @@ let mutable CheckMultipleInputsUsingGraphMode : CheckArgs -> (PartialResult list
17331733
=
17341734
fun _ -> failwith $"Graph-based type-checking function not set - set CheckMultipleInputsUsingGraphMode before using this mode"
17351735

1736+
let mutable typeCheckingMode : TypeCheckingMode = TypeCheckingMode.Sequential
1737+
17361738
let CheckClosedInputSet (ctok, checkForErrors, tcConfig: TcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, eagerFormat, inputs) =
17371739
// tcEnvAtEndOfLastFile is the environment required by fsi.exe when incrementally adding definitions
17381740
let results, tcState =
1739-
match tcConfig.typeCheckingConfig.Mode with
1741+
match typeCheckingMode with
17401742
| TypeCheckingMode.Sequential ->
17411743
CheckMultipleInputsSequential(ctok, checkForErrors, tcConfig, tcImports, tcGlobals, prefixPathOpt, tcState, inputs)
17421744
| TypeCheckingMode.ParallelCheckingOfBackedImplFiles ->

‎src/Compiler/Driver/ParseAndCheckInputs.fsi‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -200,6 +200,8 @@ val CheckMultipleInputsFinish:
200200
/// Finish the checking of a closed set of inputs
201201
val CheckClosedInputSetFinish: CheckedImplFile list * TcState -> TcState * CheckedImplFile list * ModuleOrNamespace
202202

203+
val mutable typeCheckingMode : TypeCheckingMode
204+
203205
/// Check a closed set of inputs
204206
val CheckClosedInputSet:
205207
ctok: CompilationThreadToken *

‎src/Compiler/Utilities/Activity.fs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -12,7 +12,7 @@ module Activity =
1212
let private activitySource = new ActivitySource(activitySourceName)
1313

1414
let start (name: string) (tags: (string * string) seq) : IDisposable =
15-
printfn $"Activity.start {name} %+A{tags}"
15+
// printfn $"Activity.start {name} %+A{tags}"
1616
let activity = activitySource.StartActivity(name)
1717

1818
match activity with

‎tests/ParallelTypeCheckingTests/Code/Graph.fs‎

Lines changed: 16 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -16,21 +16,28 @@ module Graph =
1616
|> Seq.collect (fun (KeyValue(node, deps)) -> deps |> Array.map (fun dep -> node, dep))
1717
|> Seq.toArray
1818

19+
let addIfMissing<'Node when 'Node : equality> (nodes : 'Node seq) (graph : Graph<'Node>) : Graph<'Node> =
20+
nodes
21+
|> Seq.except (graph.Keys |> Seq.toArray)
22+
|> fun missing ->
23+
let toAdd =
24+
missing
25+
|> Seq.map (fun n -> KeyValuePair(n, [||]))
26+
|> Seq.toArray
27+
28+
let x = Array.append (graph |> Seq.toArray) toAdd
29+
x
30+
|> Dictionary<_,_> |> fun x -> x :> IReadOnlyDictionary<_,_>
31+
1932
/// Create entries for nodes that don't have any dependencies but are mentioned as dependencies themselves
2033
let fillEmptyNodes<'Node when 'Node : equality> (graph : Graph<'Node>) : Graph<'Node> =
2134
let missingNodes =
2235
graph.Values
2336
|> Seq.toArray
2437
|> Array.concat
2538
|> Array.except graph.Keys
26-
27-
let toAdd =
28-
missingNodes
29-
|> Array.map (fun n -> KeyValuePair(n, [||]))
30-
31-
let x = Array.append (graph |> Seq.toArray) toAdd
32-
x
33-
|> Dictionary<_,_> |> fun x -> x :> IReadOnlyDictionary<_,_>
39+
40+
addIfMissing missingNodes graph
3441

3542
/// Create a transitive closure of the graph
3643
let transitive<'Node when 'Node : equality> (graph : Graph<'Node>) : Graph<'Node> =
@@ -61,7 +68,7 @@ module Graph =
6168
// Construct reversed graph
6269
|> Seq.map (fun (dep, edges) -> dep, edges |> Seq.map fst |> Seq.toArray)
6370
|> readOnlyDict
64-
|> fillEmptyNodes
71+
|> addIfMissing originalGraph.Keys
6572

6673
let printCustom (graph : Graph<'Node>) (printer : 'Node -> string) : unit =
6774
printfn "Graph:"

‎tests/ParallelTypeCheckingTests/Code/GraphProcessing.fs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -160,6 +160,9 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item : equality
160160
let dependants = graph |> Graph.reverse
161161
let makeNode (item : 'Item) : Node<'Item, StateWrapper<'Item, 'State>, ResultWrapper<'Item, 'Result>> =
162162
let info =
163+
let exists = graph.ContainsKey item
164+
if not exists || not (transitiveDeps.ContainsKey item) || not (dependants.ContainsKey item) then
165+
printfn $"WHAT {item}"
163166
{
164167
Item = item
165168
Deps = graph[item]
@@ -237,14 +240,15 @@ let processGraph<'Item, 'State, 'Result, 'FinalFileResult when 'Item : equality
237240
parallelism
238241
(fun processedCount -> processedCount = nodes.Count)
239242
cts.Token
243+
(fun x -> x.Info.Item.ToString())
240244

241245
let nodesArray = nodes.Values |> Seq.toArray
242246
let finals, {State = state}: 'FinalFileResult[] * StateWrapper<'Item, 'State> =
243247
nodesArray
244248
|> Array.filter (fun node -> includeInFinalState node.Info.Item)
245249
|> Array.sortBy (fun node -> node.Info.Item)
246250
|> fun nodes ->
247-
printfn $"%+A{nodes |> Array.map (fun n -> n.Info.Item.ToString())}"
251+
// printfn $"%+A{nodes |> Array.map (fun n -> n.Info.Item.ToString())}"
248252
nodes
249253
|> Array.fold (fun (fileResults, state) node ->
250254
let fileResult, state = folder state (node.Result.Value |> snd)

‎tests/ParallelTypeCheckingTests/Code/Parallel.fs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -70,7 +70,7 @@ let processInParallelUsingMailbox
7070
toSchedule |> Array.iter (fun x -> agent.Post(Start(processItem x)))
7171
}
7272
firstItems |> Array.iter (fun x -> agent.Post(Start(processItem x)))
73-
73+
7474
// TODO Could replace with MailboxProcessor+Tasks/Asyncs instead of BlockingCollection + Threads
7575
// See http://www.fssnip.net/nX/title/Limit-degree-of-parallelism-using-an-agent
7676
/// Process items in parallel, allow more work to be scheduled as a result of finished work,
@@ -81,16 +81,18 @@ let processInParallel
8181
(parallelism : int)
8282
(stop : int -> bool)
8383
(ct : CancellationToken)
84+
(itemToString)
8485
: unit
8586
=
8687
let bc = new BlockingCollection<'Item>()
8788
firstItems |> Array.iter bc.Add
8889
let processedCountLock = Object()
8990
let mutable processedCount = 0
9091
let processItem item =
91-
// printfn $"Processing {item}"
92+
printfn $"Processing {itemToString item}"
9293
let toSchedule = work item
9394
let processedCount = lock processedCountLock (fun () -> processedCount <- processedCount + 1; processedCount)
95+
printfn $"ToSchedule {toSchedule.Length}"
9496
toSchedule
9597
|> Array.iter (
9698
fun next -> bc.Add(next)

‎tests/ParallelTypeCheckingTests/Code/ParallelTypeChecking.fs‎

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -138,14 +138,15 @@ let CheckMultipleInputsInParallel
138138
: State -> PartialResult * State =
139139
cancellable {
140140
use _ = UseDiagnosticsLogger logger
141+
// printfn $"Processing AST {file.ToString()}"
141142
// Is it OK that we don't update 'priorErrors' after processing batches?
142143
let checkForErrors2 () = priorErrors || (logger.ErrorCount > 0)
143144

144145
let tcSink = TcResultsSink.NoSink
145146

146147
match file.AST with
147148
| ASTOrX.AST _ ->
148-
printfn $"Processing AST {file.ToString()}"
149+
// printfn $"Processing AST {file.ToString()}"
149150
let! f = CheckOneInput'(
150151
checkForErrors2,
151152
tcConfig,
@@ -161,19 +162,19 @@ let CheckMultipleInputsInParallel
161162
printfn $"Finished Processing AST {file.ToString()}"
162163
return
163164
(fun (state : State) ->
164-
printfn $"Applying {file.ToString()}"
165+
// printfn $"Applying {file.ToString()}"
165166
let tcState, priorErrors = state
166167
let (partialResult : PartialResult, tcState) = f tcState
167168

168169
let hasErrors = logger.ErrorCount > 0
169170
// TODO Should we use local _priorErrors or global priorErrors?
170171
let priorOrCurrentErrors = priorErrors || hasErrors
171172
let state : State = tcState, priorOrCurrentErrors
172-
printfn $"Finished applying {file.ToString()}"
173+
// printfn $"Finished applying {file.ToString()}"
173174
partialResult, state
174175
)
175176
| ASTOrX.X fsi ->
176-
printfn $"Processing X {file.ToString()}"
177+
// printfn $"Processing X {file.ToString()}"
177178

178179
let hadSig = true
179180
// Add dummy .fs results
@@ -191,7 +192,7 @@ let CheckMultipleInputsInParallel
191192
return
192193
(fun (state : State) ->
193194
// (tcState.TcEnvFromImpls, EmptyTopAttrs, None, ccuSigForFile), state
194-
printfn $"Applying X state {file}"
195+
// printfn $"Applying X state {file}"
195196
let tcState, priorErrors = state
196197
// (tcState.TcEnvFromImpls, EmptyTopAttrs, None, ccuSigForFile), state
197198

@@ -205,7 +206,7 @@ let CheckMultipleInputsInParallel
205206
// TODO Should we use local _priorErrors or global priorErrors?
206207
let priorOrCurrentErrors = priorErrors || hasErrors
207208
let state : State = tcState, priorOrCurrentErrors
208-
printfn $"Finished applying X state {file}"
209+
// printfn $"Finished applying X state {file}"
209210
partialResult, state
210211
)
211212
}

‎tests/ParallelTypeCheckingTests/Program.fs‎

Lines changed: 7 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -6,15 +6,15 @@ open ParallelTypeCheckingTests.TestUtils
66
let _parse (argv: string[]): Args =
77
let parseMode (mode : string) =
88
match mode.ToLower() with
9-
| "sequential" -> TypeCheckingMode.Sequential
10-
| "parallelfs" -> TypeCheckingMode.ParallelCheckingOfBackedImplFiles
11-
| "graph" -> TypeCheckingMode.Graph
9+
| "sequential" -> Method.Sequential
10+
| "parallelfs" -> Method.ParallelCheckingOfBackedImplFiles
11+
| "graph" -> Method.Graph
1212
| _ -> failwith $"Unrecognised method: {mode}"
1313

1414
let path, mode, workingDir =
1515
match argv with
1616
| [|path|] ->
17-
path, TypeCheckingMode.Sequential, None
17+
path, Method.Sequential, None
1818
| [|path; mode|] ->
1919
path, parseMode mode, None
2020
| [|path; mode; workingDir|] ->
@@ -30,20 +30,7 @@ let _parse (argv: string[]): Args =
3030

3131
[<EntryPoint>]
3232
let main _argv =
33-
let c =
34-
{
35-
Method = Method.Graph
36-
Project = TestCompilation.Codebases.fsFsi
37-
} : TestCompilation.Case
38-
39-
TestCompilation.compile c
40-
// let workDir, path, lineLimit = TestCompilationFromCmdlineArgs.codebases[2]
41-
// let stuff =
42-
// {
43-
// Path = path
44-
// LineLimit = lineLimit
45-
// WorkingDir = Some workDir
46-
// Mode = Method.Nojaf
47-
// }
48-
// TestCompilationFromCmdlineArgs.TestCompilerFromArgs stuff
33+
let args = _parse _argv
34+
let args = {args with LineLimit = Some 219}
35+
TestCompilationFromCmdlineArgs.TestCompilerFromArgs args
4936
0

‎tests/ParallelTypeCheckingTests/Tests/TestCompilation.fs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -134,9 +134,9 @@ type Case =
134134

135135
let compile (x : Case) =
136136
use _ = FSharp.Compiler.Diagnostics.Activity.start "Compile codebase" ["method", x.Method.ToString()]
137+
setupCompilationMethod x.Method
137138
makeCompilationUnit x.Project.Files
138139
|> Compiler.withOutputType x.Project.OutputType
139-
|> setupCompilationMethod x.Method
140140
|> Compiler.compile
141141
|> Compiler.Assertions.shouldSucceed
142142
|> ignore

‎tests/ParallelTypeCheckingTests/Tests/TestCompilationFromCmdlineArgs.fs‎

Lines changed: 13 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -17,35 +17,20 @@ type Codebase =
1717

1818
let codebases =
1919
[|
20-
{ WorkDir = $@"{__SOURCE_DIRECTORY__}\.checkouts\fcs\src\compiler"; Path = $@"{__SOURCE_DIRECTORY__}\FCS.args.txt"; Limit = None }
20+
{ WorkDir = $@"{__SOURCE_DIRECTORY__}\.checkouts\fcs\src\compiler"; Path = $@"{__SOURCE_DIRECTORY__}\FCS.args.txt"; Limit = Some 237 }
2121
{ WorkDir = $@"{__SOURCE_DIRECTORY__}\.checkouts\fcs\tests\FSharp.Compiler.ComponentTests"; Path = $@"{__SOURCE_DIRECTORY__}\ComponentTests.args.txt"; Limit = None }
2222
|]
2323

24-
/// A very hacky way to setup the given type-checking method - mutates static state and returns new args
25-
/// TODO Make the method configurable via proper config passed top-down
26-
let internal setupArgsMethod (method: TypeCheckingMode) (args: string[]): string[] =
27-
printfn $"Method: {method}"
28-
match method with
29-
| TypeCheckingMode.Sequential ->
30-
// Restore default
31-
ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParseAndCheckInputs.CheckMultipleInputsInParallel
32-
args
33-
| TypeCheckingMode.ParallelCheckingOfBackedImplFiles ->
34-
ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParseAndCheckInputs.CheckMultipleInputsInParallel
35-
Array.append args [|"--test:ParallelCheckingWithSignatureFilesOn"|]
36-
| TypeCheckingMode.Graph ->
37-
ParseAndCheckInputs.CheckMultipleInputsUsingGraphMode <- ParallelTypeChecking.CheckMultipleInputsInParallel
38-
Array.append args [|"--test:ParallelCheckingWithSignatureFilesOn"|]
39-
4024
let internal setupParsed config =
4125
let {Path = path; LineLimit = lineLimit; Method = method; WorkingDir = workingDir} = config
4226
let args =
4327
System.IO.File.ReadAllLines(path |> replacePaths)
4428
|> fun lines -> match lineLimit with Some limit -> Array.take (Math.Min(limit, lines.Length)) lines | None -> lines
4529
|> Array.map replacePaths
4630

31+
setupCompilationMethod method
32+
4733
printfn $"WorkingDir = {workingDir}"
48-
let args = setupArgsMethod method args
4934
workingDir |> Option.iter (fun dir -> Environment.CurrentDirectory <- replaceCodeRoot dir)
5035
args
5136

@@ -67,26 +52,22 @@ let internal TestCompilerFromArgs (config : Args) : unit =
6752
finally
6853
Environment.CurrentDirectory <- oldWorkDir
6954

55+
let internal codebaseToConfig code method =
56+
{
57+
Path = code.Path
58+
LineLimit = code.Limit
59+
Method = method
60+
WorkingDir = Some code.WorkDir
61+
}
62+
7063
[<TestCaseSource(nameof(codebases))>]
7164
[<Explicit("Before running these tests, you must prepare the codebase by running FCS.prepare.ps1")>]
7265
let ``Test graph-based type-checking`` (code : Codebase) =
73-
let config =
74-
{
75-
Path = code.Path
76-
LineLimit = code.Limit
77-
Method = TypeCheckingMode.Graph
78-
WorkingDir = Some code.WorkDir
79-
}
66+
let config = codebaseToConfig code Method.Graph
8067
TestCompilerFromArgs config
8168

8269
[<TestCaseSource(nameof(codebases))>]
8370
[<Explicit("Before running these tests, you must prepare the codebase by running FCS.prepare.ps1")>]
8471
let ``Test sequential type-checking`` (code : Codebase) =
85-
let config =
86-
{
87-
Path = code.Path
88-
LineLimit = code.Limit
89-
Method = TypeCheckingMode.Graph
90-
WorkingDir = Some code.WorkDir
91-
}
72+
let config = codebaseToConfig code Method.Sequential
9273
TestCompilerFromArgs config

0 commit comments

Comments
 (0)