1+ module FSharp.Compiler.Service.Tests.code
2+
3+ open System.Collections .Generic
4+ open FSharp.Compiler .Service .Tests .Graph
5+ open FSharp.Compiler .Syntax
6+ type AST = FSharp.Compiler.Syntax.ParsedInput
7+
8+ type FileName = FileName of string
9+ with member this.FileName = match this with FileName fileName -> fileName
10+
11+ /// Input from the compiler after parsing
12+ [<CustomEquality; NoComparison>]
13+ type SourceFile =
14+ {
15+ Name : string
16+ AST : AST
17+ }
18+ // custom check - compare against CustomerId only
19+ override this.Equals other =
20+ match other with
21+ | :? SourceFile as p -> p.Name.Equals this.Name
22+ | _ -> false
23+ // custom hash check
24+ override this.GetHashCode () = this.Name.GetHashCode()
25+
26+ type SourceFiles = SourceFile[]
27+ type FsiInfo =
28+ | FsiBacked
29+ | NotBacked
30+ with member this.IsFsiBacked =
31+ match this with
32+ | FsiBacked -> true
33+ | NotBacked -> false
34+
35+ type File =
36+ {
37+ File : SourceFile
38+ FsiInfo : FsiInfo
39+ }
40+ type Files = File[]
41+ type FileGraph = Graph< File>
42+
43+ let gatherBackingInfo ( files : SourceFiles ) : Files =
44+ let seenSigFiles = HashSet< string>()
45+ files
46+ |> Array.map ( fun f ->
47+ let fsiInfo =
48+ match f.AST with
49+ | ParsedInput.SigFile _ ->
50+ NotBacked
51+ | ParsedInput.ImplFile _ ->
52+ let fsiName = System.IO.Path.ChangeExtension( f.Name, " fsi" )
53+ match seenSigFiles.Contains fsiName with
54+ | true -> FsiBacked
55+ | false -> NotBacked
56+ {
57+ File = f
58+ FsiInfo = fsiInfo
59+ }
60+ )
61+
62+ type EdgeTrimmer = File -> File -> bool
63+
64+ type FileData =
65+ {
66+ ModuleRefs : ModuleRef []
67+ Structure : FileStructure
68+ }
69+
70+ let gatherFileData ( file : File ) =
71+
72+ let calcFileGraph ( files : SourceFiles ) : FileGraph =
73+ let fsFsiTrimmer =
74+ let files =
75+ gatherBackingInfo files
76+ ... to dict
77+ fun file dep -> not files[ dep]. FsiInfo.IsFsiBacked
78+ let
79+
80+ /// Used for processing
81+ type NodeInfo<'Item> =
82+ {
83+ Item : 'Item
84+ Deps : 'Item []
85+ TransitiveDeps : 'Item []
86+ Dependants : 'Item []
87+ ProcessedDepsCount : int
88+ }
89+ type Node < 'Item , 'State , 'Result > =
90+ {
91+ Info : NodeInfo < 'Item >
92+ Result : ( 'State * 'Result ) option
93+ }
94+
95+ // Do we need to suppress some error logging if we
96+ // apply the same partial results multiple times?
97+ // Maybe we can enable logging only for the final fold
98+ let combineResults
99+ ( deps : Node < _ , _ , _ >[])
100+ ( transitiveDeps : Node < _ , _ , _ >[])
101+ ( folder : 'State -> 'Result -> 'State )
102+ : 'State
103+ =
104+ let biggestDep =
105+ let sizeMetric node =
106+ // Could also use eg. total file size/AST size
107+ node.Info.TransitiveDeps.Length
108+ deps
109+ |> Array.maxBy sizeMetrix
110+ let firstState = snd biggestDep.Result
111+ // Perf: Keep transDeps in a HashSet from the start
112+ let included = HashSet( firstState.Info.TransitiveDeps)
113+ let toAdd =
114+ transitiveDeps
115+ |> Array.filter ( fun dep -> included.Add dep)
116+ let state = Array.fold folder firstState toAdd
117+ state
118+
119+ let processInParallel
120+ ( firstItems : 'Item [])
121+ ( work : 'Item -> 'Item [])
122+ ( parallelism : int )
123+ ( stop : int -> bool )
124+ ( ct )
125+ : unit async
126+ =
127+ let bc = BlockingCollection( firstItems)
128+ let mutable processedCount = 0
129+ let processItem item =
130+ let toSchedule = work item
131+ lock processedCount ( fun () -> ++)
132+ toSchedule |> Array.iter bc.Add
133+ // Could avoid workers with some semaphores
134+ let workerWork () =
135+ for node in bc.Get... do
136+ if not ct.Cancelled then // improve
137+ processNode node
138+ if stop () then
139+ bc.CompleteAdding() // avoid doing multiple times?
140+
141+ Array.Parallel.map
142+ parallelism workerWork // use cancellation
143+
144+ let processGraph
145+ ( graph : FileGraph )
146+ ( doWork : 'Item -> 'State -> 'Result * 'State )
147+ ( folder : 'State -> 'Result -> 'State )
148+ ( parallelism : int )
149+ : 'State
150+ =
151+ let transitiveDeps = graph |> calcTransitiveGraph
152+ let dependants = graph |> reverseGraph
153+ let nodes = graph.Keys |> Seq.map ...
154+ let leaves = nodes |> Seq.filter ...
155+ let work
156+ ( node : Node < 'Item , 'State , 'Result >)
157+ : Node < 'Item , 'State , 'Result >[]
158+ =
159+ let inputState = combineResults node.Deps node.TransitiveDeps folder
160+ let res = doWork node.Info.Item
161+ node.Result <- res
162+ let unblocked =
163+ node.Info.Dependants
164+ |> Array.filter ( fun x ->
165+ let pdc =
166+ lock x ( fun () ->
167+ x.Info.ProcessedDepsCount++
168+ x.Info.PrcessedDepsCount
169+ )
170+ pdc = node.Info.Deps.Length
171+ )
172+ |> Array.map ( fun x -> nodes[ x])
173+ unblocked
174+
175+ processInParallel
176+ leaves
177+ work
178+ parallelism
179+ ( fun processedCount -> processedCount = nodes.Length)
180+
181+ let state = combineResults nodes nodes addCheckResultsToTcState
182+ state
183+
184+ type TcState
185+ type SingleResult
186+
187+ let typeCheckFile ( file : File ) ( state : TcState )
188+ : SingleResult * TcState
189+ =
190+ ...
191+
192+ let typeCheckGraph ( graph : FileGraph ) : TcState =
193+ let parallelism = 4 // cpu count?
194+ let state =
195+ processGraph
196+ graph
197+ typeCheckFile
198+ addCheckResultsToTcState
199+ parallelism
200+ state
201+
202+ let typeCheck ( files : SourceFiles ) : TcState =
203+ let graph = calcFileGraph files
204+ let state = typeCheckGraph graph
205+ state
0 commit comments