diff --git a/FSharpBuild.Directory.Build.props b/FSharpBuild.Directory.Build.props index 0c8d9cef75c..21e531409e8 100644 --- a/FSharpBuild.Directory.Build.props +++ b/FSharpBuild.Directory.Build.props @@ -27,6 +27,7 @@ $(OtherFlags) --nowarn:3384 $(OtherFlags) --times --nowarn:75 $(OtherFlags) --test:ParallelCheckingWithSignatureFilesOn + $(OtherFlags) $(AdditionalFscCmdFlags) diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index 7ea1c4b3429..4f74ce59c61 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5316,8 +5316,8 @@ let CheckOneImplFile use _ = Activity.start "CheckDeclarations.CheckOneImplFile" [| - "fileName", fileName - "qualifiedNameOfFile", qualNameOfFile.Text + Activity.Tags.fileName, fileName + Activity.Tags.qualifiedNameOfFile, qualNameOfFile.Text |] let cenv = cenv.Create (g, isScript, amap, thisCcu, false, Option.isSome rootSigOpt, @@ -5450,8 +5450,8 @@ let CheckOneSigFile (g, amap, thisCcu, checkForErrors, conditionalDefines, tcSin use _ = Activity.start "CheckDeclarations.CheckOneSigFile" [| - "fileName", sigFile.FileName - "qualifiedNameOfFile", sigFile.QualifiedName.Text + Activity.Tags.fileName, sigFile.FileName + Activity.Tags.qualifiedNameOfFile, sigFile.QualifiedName.Text |] let cenv = cenv.Create diff --git a/src/Compiler/Driver/CompilerConfig.fs b/src/Compiler/Driver/CompilerConfig.fs index 91a2e9fde3d..54e45ead3cc 100644 --- a/src/Compiler/Driver/CompilerConfig.fs +++ b/src/Compiler/Driver/CompilerConfig.fs @@ -517,6 +517,7 @@ type TcConfigBuilder = /// show times between passes? mutable showTimes: bool + mutable writeTimesToFile: string option mutable showLoadedAssemblies: bool mutable continueAfterParseFailure: bool @@ -740,6 +741,7 @@ type TcConfigBuilder = productNameForBannerText = FSharpProductName showBanner = true showTimes = false + writeTimesToFile = None showLoadedAssemblies = false continueAfterParseFailure = false #if !NO_TYPEPROVIDERS @@ -1296,6 +1298,7 @@ type TcConfig private (data: TcConfigBuilder, validate: bool) = member _.productNameForBannerText = data.productNameForBannerText member _.showBanner = data.showBanner member _.showTimes = data.showTimes + member _.writeTimesToFile = data.writeTimesToFile member _.showLoadedAssemblies = data.showLoadedAssemblies member _.continueAfterParseFailure = data.continueAfterParseFailure #if !NO_TYPEPROVIDERS diff --git a/src/Compiler/Driver/CompilerConfig.fsi b/src/Compiler/Driver/CompilerConfig.fsi index 70abf7beb63..95e26b637ef 100644 --- a/src/Compiler/Driver/CompilerConfig.fsi +++ b/src/Compiler/Driver/CompilerConfig.fsi @@ -426,6 +426,8 @@ type TcConfigBuilder = mutable showTimes: bool + mutable writeTimesToFile: string option + mutable showLoadedAssemblies: bool mutable continueAfterParseFailure: bool @@ -748,6 +750,8 @@ type TcConfig = member showTimes: bool + member writeTimesToFile: string option + member showLoadedAssemblies: bool member continueAfterParseFailure: bool diff --git a/src/Compiler/Driver/CompilerOptions.fs b/src/Compiler/Driver/CompilerOptions.fs index 0881e8c9179..5d800416450 100644 --- a/src/Compiler/Driver/CompilerOptions.fs +++ b/src/Compiler/Driver/CompilerOptions.fs @@ -1741,6 +1741,15 @@ let internalFlags (tcConfigB: TcConfigBuilder) = None ) + // "Write timing profiles for compilation to a file" + CompilerOption( + "times", + tagFile, + OptionString(fun s -> tcConfigB.writeTimesToFile <- Some s), + Some(InternalCommandLineOption("times", rangeCmdArgs)), + None + ) + #if !NO_TYPEPROVIDERS // "Display information about extension type resolution") CompilerOption( @@ -2339,39 +2348,40 @@ let PrintWholeAssemblyImplementation (tcConfig: TcConfig) outfile header expr = let mutable tPrev: (DateTime * DateTime * float * int[]) option = None let mutable nPrev: (string * IDisposable) option = None +let private SimulateException simulateConfig = + match simulateConfig with + | Some ("fsc-oom") -> raise (OutOfMemoryException()) + | Some ("fsc-an") -> raise (ArgumentNullException("simulated")) + | Some ("fsc-invop") -> raise (InvalidOperationException()) + | Some ("fsc-av") -> raise (AccessViolationException()) + | Some ("fsc-aor") -> raise (ArgumentOutOfRangeException()) + | Some ("fsc-dv0") -> raise (DivideByZeroException()) + | Some ("fsc-nfn") -> raise (NotFiniteNumberException()) + | Some ("fsc-oe") -> raise (OverflowException()) + | Some ("fsc-atmm") -> raise (ArrayTypeMismatchException()) + | Some ("fsc-bif") -> raise (BadImageFormatException()) + | Some ("fsc-knf") -> raise (System.Collections.Generic.KeyNotFoundException()) + | Some ("fsc-ior") -> raise (IndexOutOfRangeException()) + | Some ("fsc-ic") -> raise (InvalidCastException()) + | Some ("fsc-ip") -> raise (InvalidProgramException()) + | Some ("fsc-ma") -> raise (MemberAccessException()) + | Some ("fsc-ni") -> raise (NotImplementedException()) + | Some ("fsc-nr") -> raise (NullReferenceException()) + | Some ("fsc-oc") -> raise (OperationCanceledException()) + | Some ("fsc-fail") -> failwith "simulated" + | _ -> () + let ReportTime (tcConfig: TcConfig) descr = match nPrev with | None -> () - | Some (prevDescr, prevActivity) -> - use _ = prevActivity // Finish the previous diagnostics activity by .Dispose() at the end of this block - + | Some (prevDescr, _) -> if tcConfig.pause then dprintf "[done '%s', entering '%s'] press to continue... " prevDescr descr Console.ReadLine() |> ignore // Intentionally putting this right after the pause so a debugger can be attached. - match tcConfig.simulateException with - | Some ("fsc-oom") -> raise (OutOfMemoryException()) - | Some ("fsc-an") -> raise (ArgumentNullException("simulated")) - | Some ("fsc-invop") -> raise (InvalidOperationException()) - | Some ("fsc-av") -> raise (AccessViolationException()) - | Some ("fsc-aor") -> raise (ArgumentOutOfRangeException()) - | Some ("fsc-dv0") -> raise (DivideByZeroException()) - | Some ("fsc-nfn") -> raise (NotFiniteNumberException()) - | Some ("fsc-oe") -> raise (OverflowException()) - | Some ("fsc-atmm") -> raise (ArrayTypeMismatchException()) - | Some ("fsc-bif") -> raise (BadImageFormatException()) - | Some ("fsc-knf") -> raise (System.Collections.Generic.KeyNotFoundException()) - | Some ("fsc-ior") -> raise (IndexOutOfRangeException()) - | Some ("fsc-ic") -> raise (InvalidCastException()) - | Some ("fsc-ip") -> raise (InvalidProgramException()) - | Some ("fsc-ma") -> raise (MemberAccessException()) - | Some ("fsc-ni") -> raise (NotImplementedException()) - | Some ("fsc-nr") -> raise (NullReferenceException()) - | Some ("fsc-oc") -> raise (OperationCanceledException()) - | Some ("fsc-fail") -> failwith "simulated" - | _ -> () + SimulateException tcConfig.simulateException - if (tcConfig.showTimes || verbose) then + if (tcConfig.showTimes || verbose || tcConfig.writeTimesToFile.IsSome) then // Note that timing calls are relatively expensive on the startup path so we don't // make this call unless showTimes has been turned on. let p = Process.GetCurrentProcess() @@ -2383,12 +2393,30 @@ let ReportTime (tcConfig: TcConfig) descr = let tStart = match tPrev, nPrev with - | Some (tStart, tPrev, utPrev, gcPrev), Some (prevDescr, _) -> + | Some (tStart, tPrev, utPrev, gcPrev), Some (prevDescr, prevActivity) -> let spanGC = [| for i in 0..maxGen -> GC.CollectionCount i - gcPrev[i] |] let t = tNow - tStart let tDelta = tNow - tPrev let utDelta = utNow - utPrev + match prevActivity with + | :? System.Diagnostics.Activity as a when isNotNull a -> + // Yes, there is duplicity of code between the console reporting and Activity collection right now. + // If current --times behaviour can be changed (=breaking change to the layout etc.), the GC and CPU time collecting logic can move to Activity + // (if a special Tag is set for an activity, the listener itself could evaluate CPU and GC info and set it + a.AddTag(Activity.Tags.gc0, spanGC[Operators.min 0 maxGen]) |> ignore + a.AddTag(Activity.Tags.gc1, spanGC[Operators.min 1 maxGen]) |> ignore + a.AddTag(Activity.Tags.gc2, spanGC[Operators.min 2 maxGen]) |> ignore + + a.AddTag(Activity.Tags.outputDllFile, tcConfig.outputFile |> Option.defaultValue String.Empty) + |> ignore + + a.AddTag(Activity.Tags.cpuDelta, utDelta.ToString("000.000")) |> ignore + + a.AddTag(Activity.Tags.realDelta, tDelta.TotalSeconds.ToString("000.000")) + |> ignore + | _ -> () + printf "Real: %4.1f Realdelta: %4.1f Cpu: %4.1f Cpudelta: %4.1f Mem: %3d" t.TotalSeconds @@ -2410,6 +2438,11 @@ let ReportTime (tcConfig: TcConfig) descr = tPrev <- Some(tStart, tNow, utNow, gcNow) + nPrev + |> Option.iter (fun (_, act) -> + if isNotNull act then + act.Dispose()) + nPrev <- Some(descr, Activity.startNoTags descr) let ignoreFailureOnMono1_1_16 f = diff --git a/src/Compiler/Driver/ParseAndCheckInputs.fs b/src/Compiler/Driver/ParseAndCheckInputs.fs index ac36b76477c..b384a93bf9e 100644 --- a/src/Compiler/Driver/ParseAndCheckInputs.fs +++ b/src/Compiler/Driver/ParseAndCheckInputs.fs @@ -1205,7 +1205,7 @@ let CheckOneInputAux cancellable { try use _ = - Activity.start "ParseAndCheckInputs.CheckOneInput" [| "fileName", inp.FileName |] + Activity.start "ParseAndCheckInputs.CheckOneInput" [| Activity.Tags.fileName, inp.FileName |] CheckSimulateException tcConfig diff --git a/src/Compiler/Driver/fsc.fs b/src/Compiler/Driver/fsc.fs index e8ec56fa5a5..705d6bb3832 100644 --- a/src/Compiler/Driver/fsc.fs +++ b/src/Compiler/Driver/fsc.fs @@ -576,6 +576,17 @@ let main1 delayForFlagsLogger.CommitDelayedDiagnostics(diagnosticsLoggerProvider, tcConfigB, exiter) exiter.Exit 1 + tcConfig.writeTimesToFile + |> Option.iter (fun f -> + Activity.addCsvFileListener f |> disposables.Register + + Activity.start + "FSC compilation" + [ + Activity.Tags.outputDllFile, tcConfig.outputFile |> Option.defaultValue String.Empty + ] + |> disposables.Register) + let diagnosticsLogger = diagnosticsLoggerProvider.CreateLogger(tcConfigB, exiter) // Install the global error logger and never remove it. This logger does have all command-line flags considered. diff --git a/src/Compiler/Service/FSharpCheckerResults.fs b/src/Compiler/Service/FSharpCheckerResults.fs index 25c94ca5c5c..f2b88684b5c 100644 --- a/src/Compiler/Service/FSharpCheckerResults.fs +++ b/src/Compiler/Service/FSharpCheckerResults.fs @@ -2347,7 +2347,9 @@ module internal ParseAndCheckFile = let parseFile (sourceText: ISourceText, fileName, options: FSharpParsingOptions, userOpName: string, suggestNamesForErrors: bool) = Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "parseFile", fileName) - use act = Activity.start "ParseAndCheckFile.parseFile" [| "fileName", fileName |] + + use act = + Activity.start "ParseAndCheckFile.parseFile" [| Activity.Tags.fileName, fileName |] let errHandler = DiagnosticsHandler(true, fileName, options.DiagnosticOptions, sourceText, suggestNamesForErrors) @@ -2504,7 +2506,12 @@ module internal ParseAndCheckFile = cancellable { use _ = - Activity.start "ParseAndCheckFile.CheckOneFile" [| "fileName", mainInputFileName; "length", sourceText.Length.ToString() |] + Activity.start + "ParseAndCheckFile.CheckOneFile" + [| + Activity.Tags.fileName, mainInputFileName + Activity.Tags.length, sourceText.Length.ToString() + |] let parsedMainInput = parseResults.ParseTree diff --git a/src/Compiler/Service/IncrementalBuild.fs b/src/Compiler/Service/IncrementalBuild.fs index 578eb5558f0..b62585266c7 100644 --- a/src/Compiler/Service/IncrementalBuild.fs +++ b/src/Compiler/Service/IncrementalBuild.fs @@ -127,7 +127,7 @@ module IncrementalBuildSyntaxTree = use act = Activity.start "IncrementalBuildSyntaxTree.parse" [| - "fileName", source.FilePath + Activity.Tags.fileName, source.FilePath "buildPhase", BuildPhase.Parse.ToString() "canSkip", canSkip.ToString() |] @@ -475,7 +475,7 @@ type BoundModel private (tcConfig: TcConfig, let! res = defaultTypeCheck () return res | Some syntaxTree -> - use _ = Activity.start "BoundModel.TypeCheck" [|"fileName", syntaxTree.FileName|] + use _ = Activity.start "BoundModel.TypeCheck" [|Activity.Tags.fileName, syntaxTree.FileName|] let sigNameOpt = if partialCheck then this.BackingSignature @@ -538,7 +538,7 @@ type BoundModel private (tcConfig: TcConfig, // Build symbol keys let itemKeyStore, semanticClassification = if enableBackgroundItemKeyStoreAndSemanticClassification then - use _ = Activity.start "IncrementalBuild.CreateItemKeyStoreAndSemanticClassification" [|"fileName", fileName|] + use _ = Activity.start "IncrementalBuild.CreateItemKeyStoreAndSemanticClassification" [|Activity.Tags.fileName, fileName|] let sResolutions = sink.GetResolutions() let builder = ItemKeyStoreBuilder() let preventDuplicates = HashSet({ new IEqualityComparer with @@ -1043,7 +1043,7 @@ module IncrementalBuilderStateHelpers = let rec createFinalizeBoundModelGraphNode (initialState: IncrementalBuilderInitialState) (boundModels: ImmutableArray>.Builder) = GraphNode(node { - use _ = Activity.start "GetCheckResultsAndImplementationsForProject" [|"projectOutFile", initialState.outfile|] + use _ = Activity.start "GetCheckResultsAndImplementationsForProject" [|Activity.Tags.outputDllFile, initialState.outfile|] // Compute last bound model then get all the evaluated models. let! _ = boundModels[boundModels.Count - 1].GetOrComputeValue() let boundModels = diff --git a/src/Compiler/Service/service.fs b/src/Compiler/Service/service.fs index 07c1f518725..9af88d75880 100644 --- a/src/Compiler/Service/service.fs +++ b/src/Compiler/Service/service.fs @@ -287,7 +287,7 @@ type BackgroundCompiler let CreateOneIncrementalBuilder (options: FSharpProjectOptions, userOpName) = node { use _ = - Activity.start "BackgroundCompiler.CreateOneIncrementalBuilder" [| "project", options.ProjectFileName |] + Activity.start "BackgroundCompiler.CreateOneIncrementalBuilder" [| Activity.Tags.project, options.ProjectFileName |] Trace.TraceInformation("FCS: {0}.{1} ({2})", userOpName, "CreateOneIncrementalBuilder", options.ProjectFileName) let projectReferences = getProjectReferences options userOpName @@ -479,7 +479,13 @@ type BackgroundCompiler member _.ParseFile(fileName: string, sourceText: ISourceText, options: FSharpParsingOptions, cache: bool, userOpName: string) = async { use _ = - Activity.start "BackgroundCompiler.ParseFile" [| "fileName", fileName; "userOpName", userOpName; "cache", cache.ToString() |] + Activity.start + "BackgroundCompiler.ParseFile" + [| + Activity.Tags.fileName, fileName + Activity.Tags.userOpName, userOpName + Activity.Tags.cache, cache.ToString() + |] if cache then let hash = sourceText.GetHashCode() |> int64 @@ -506,7 +512,9 @@ type BackgroundCompiler member _.GetBackgroundParseResultsForFileInProject(fileName, options, userOpName) = node { use _ = - Activity.start "BackgroundCompiler.GetBackgroundParseResultsForFileInProject" [| "fileName", fileName; "userOpName", userOpName |] + Activity.start + "BackgroundCompiler.GetBackgroundParseResultsForFileInProject" + [| Activity.Tags.fileName, fileName; Activity.Tags.userOpName, userOpName |] let! builderOpt, creationDiags = getOrCreateBuilder (options, userOpName) @@ -535,7 +543,9 @@ type BackgroundCompiler member _.GetCachedCheckFileResult(builder: IncrementalBuilder, fileName, sourceText: ISourceText, options) = node { - use _ = Activity.start "BackgroundCompiler.GetCachedCheckFileResult" [| "fileName", fileName |] + use _ = + Activity.start "BackgroundCompiler.GetCachedCheckFileResult" [| Activity.Tags.fileName, fileName |] + let hash = sourceText.GetHashCode() |> int64 let key = (fileName, hash, options) let cachedResultsOpt = parseCacheLock.AcquireLock(fun ltok -> checkFileInProjectCache.TryGet(ltok, key)) @@ -642,9 +652,9 @@ type BackgroundCompiler Activity.start "BackgroundCompiler.CheckFileInProjectAllowingStaleCachedResults" [| - "project", options.ProjectFileName - "fileName", fileName - "userOpName", userOpName + Activity.Tags.project, options.ProjectFileName + Activity.Tags.fileName, fileName + Activity.Tags.userOpName, userOpName |] let! cachedResults = @@ -684,9 +694,9 @@ type BackgroundCompiler Activity.start "BackgroundCompiler.CheckFileInProject" [| - "project", options.ProjectFileName - "fileName", fileName - "userOpName", userOpName + Activity.Tags.project, options.ProjectFileName + Activity.Tags.fileName, fileName + Activity.Tags.userOpName, userOpName |] let! builderOpt, creationDiags = getOrCreateBuilder (options, userOpName) @@ -712,9 +722,9 @@ type BackgroundCompiler Activity.start "BackgroundCompiler.ParseAndCheckFileInProject" [| - "project", options.ProjectFileName - "fileName", fileName - "userOpName", userOpName + Activity.Tags.project, options.ProjectFileName + Activity.Tags.fileName, fileName + Activity.Tags.userOpName, userOpName |] let! builderOpt, creationDiags = getOrCreateBuilder (options, userOpName) @@ -758,9 +768,9 @@ type BackgroundCompiler Activity.start "BackgroundCompiler.ParseAndCheckFileInProject" [| - "project", options.ProjectFileName - "fileName", fileName - "userOpName", userOpName + Activity.Tags.project, options.ProjectFileName + Activity.Tags.fileName, fileName + Activity.Tags.userOpName, userOpName |] let! builderOpt, creationDiags = getOrCreateBuilder (options, userOpName) @@ -850,9 +860,9 @@ type BackgroundCompiler Activity.start "BackgroundCompiler.FindReferencesInFile" [| - "project", options.ProjectFileName - "fileName", fileName - "userOpName", userOpName + Activity.Tags.project, options.ProjectFileName + Activity.Tags.fileName, fileName + Activity.Tags.userOpName, userOpName "symbol", symbol.FullName |] @@ -878,9 +888,9 @@ type BackgroundCompiler Activity.start "BackgroundCompiler.GetSemanticClassificationForFile" [| - "project", options.ProjectFileName - "fileName", fileName - "userOpName", userOpName + Activity.Tags.project, options.ProjectFileName + Activity.Tags.fileName, fileName + Activity.Tags.userOpName, userOpName |] let! builderOpt, _ = getOrCreateBuilder (options, userOpName) @@ -902,9 +912,9 @@ type BackgroundCompiler Activity.start "BackgroundCompiler.GetSemanticClassificationForFile" [| - "project", options.ProjectFileName - "fileName", fileName - "userOpName", _userOpName + Activity.Tags.project, options.ProjectFileName + Activity.Tags.fileName, fileName + Activity.Tags.userOpName, _userOpName |] match sourceText with @@ -980,7 +990,12 @@ type BackgroundCompiler member _.GetAssemblyData(options, userOpName) = node { use _ = - Activity.start "BackgroundCompiler.GetAssemblyData" [| "project", options.ProjectFileName; "userOpName", userOpName |] + Activity.start + "BackgroundCompiler.GetAssemblyData" + [| + Activity.Tags.project, options.ProjectFileName + Activity.Tags.userOpName, userOpName + |] let! builderOpt, _ = getOrCreateBuilder (options, userOpName) @@ -1003,7 +1018,12 @@ type BackgroundCompiler /// Parse and typecheck the whole project. member bc.ParseAndCheckProject(options, userOpName) = use _ = - Activity.start "BackgroundCompiler.ParseAndCheckProject" [| "project", options.ProjectFileName; "userOpName", userOpName |] + Activity.start + "BackgroundCompiler.ParseAndCheckProject" + [| + Activity.Tags.project, options.ProjectFileName + Activity.Tags.userOpName, userOpName + |] bc.ParseAndCheckProjectImpl(options, userOpName) @@ -1022,7 +1042,9 @@ type BackgroundCompiler _userOpName ) = use _ = - Activity.start "BackgroundCompiler.GetProjectOptionsFromScript" [| "fileName", fileName; "userOpName", _userOpName |] + Activity.start + "BackgroundCompiler.GetProjectOptionsFromScript" + [| Activity.Tags.fileName, fileName; Activity.Tags.userOpName, _userOpName |] cancellable { use diagnostics = new DiagnosticsScope() @@ -1109,7 +1131,12 @@ type BackgroundCompiler member bc.InvalidateConfiguration(options: FSharpProjectOptions, userOpName) = use _ = - Activity.start "BackgroundCompiler.InvalidateConfiguration" [| "project", options.ProjectFileName; "userOpName", userOpName |] + Activity.start + "BackgroundCompiler.InvalidateConfiguration" + [| + Activity.Tags.project, options.ProjectFileName + Activity.Tags.userOpName, userOpName + |] if incrementalBuildersCache.ContainsSimilarKey(AnyCallerThread, options) then parseCacheLock.AcquireLock(fun ltok -> @@ -1120,7 +1147,7 @@ type BackgroundCompiler () member bc.ClearCache(options: seq, _userOpName) = - use _ = Activity.start "BackgroundCompiler.ClearCache" [| "userOpName", _userOpName |] + use _ = Activity.start "BackgroundCompiler.ClearCache" [| Activity.Tags.userOpName, _userOpName |] lock gate (fun () -> options @@ -1128,7 +1155,12 @@ type BackgroundCompiler member _.NotifyProjectCleaned(options: FSharpProjectOptions, userOpName) = use _ = - Activity.start "BackgroundCompiler.NotifyProjectCleaned" [| "project", options.ProjectFileName; "userOpName", userOpName |] + Activity.start + "BackgroundCompiler.NotifyProjectCleaned" + [| + Activity.Tags.project, options.ProjectFileName + Activity.Tags.userOpName, userOpName + |] async { let! ct = Async.CancellationToken @@ -1296,7 +1328,10 @@ type FSharpChecker member _.MatchBraces(fileName, sourceText: ISourceText, options: FSharpParsingOptions, ?userOpName: string) = let userOpName = defaultArg userOpName "Unknown" - use _ = Activity.start "FSharpChecker.MatchBraces" [| "fileName", fileName; "userOpName", userOpName |] + + use _ = + Activity.start "FSharpChecker.MatchBraces" [| Activity.Tags.fileName, fileName; Activity.Tags.userOpName, userOpName |] + let hash = sourceText.GetHashCode() |> int64 async { @@ -1348,7 +1383,7 @@ type FSharpChecker member _.Compile(argv: string[], ?userOpName: string) = let _userOpName = defaultArg userOpName "Unknown" - use _ = Activity.start "FSharpChecker.Compile" [| "userOpName", _userOpName |] + use _ = Activity.start "FSharpChecker.Compile" [| Activity.Tags.userOpName, _userOpName |] async { let ctok = CompilationThreadToken() diff --git a/src/Compiler/Utilities/Activity.fs b/src/Compiler/Utilities/Activity.fs index 2ae87433ce5..f352d81ea1e 100644 --- a/src/Compiler/Utilities/Activity.fs +++ b/src/Compiler/Utilities/Activity.fs @@ -4,10 +4,42 @@ namespace FSharp.Compiler.Diagnostics open System open System.Diagnostics +open System.IO +open System.Text [] module Activity = + module Tags = + let fileName = "fileName" + let project = "project" + let qualifiedNameOfFile = "qualifiedNameOfFile" + let userOpName = "userOpName" + let length = "length" + let cache = "cache" + let cpuDelta = "cpuDelta(s)" + let realDelta = "realDelta(s)" + let gc0 = "gc0" + let gc1 = "gc1" + let gc2 = "gc2" + let outputDllFile = "outputDllFile" + + let AllKnownTags = + [| + fileName + project + qualifiedNameOfFile + userOpName + length + cache + cpuDelta + realDelta + gc0 + gc1 + gc2 + outputDllFile + |] + let private activitySourceName = "fsc" let private activitySource = new ActivitySource(activitySourceName) @@ -23,3 +55,81 @@ module Activity = activity let startNoTags (name: string) : IDisposable = activitySource.StartActivity(name) + + let private escapeStringForCsv (o: obj) = + if isNull o then + "" + else + let mutable txtVal = o.ToString() + let hasComma = txtVal.IndexOf(',') > -1 + let hasQuote = txtVal.IndexOf('"') > -1 + + if hasQuote then + txtVal <- txtVal.Replace("\"", "\\\"") + + if hasQuote || hasComma then + "\"" + txtVal + "\"" + else + txtVal + + let private createCsvRow (a: Activity) = + let sb = new StringBuilder(128) + + let appendWithLeadingComma (s: string) = + sb.Append(',') |> ignore + sb.Append(s) |> ignore + + // "Name,StartTime,EndTime,Duration,Id,ParentId" + sb.Append(a.DisplayName) |> ignore + appendWithLeadingComma (a.StartTimeUtc.ToString("HH-mm-ss.ffff")) + appendWithLeadingComma ((a.StartTimeUtc + a.Duration).ToString("HH-mm-ss.ffff")) + appendWithLeadingComma (a.Duration.TotalSeconds.ToString("000.0000", System.Globalization.CultureInfo.InvariantCulture)) + appendWithLeadingComma (a.Id) + appendWithLeadingComma (a.ParentId) + + let rec rootID (act: Activity) = + if isNull act.ParentId then act.Id else rootID act.Parent + + appendWithLeadingComma (rootID a) + + Tags.AllKnownTags + |> Array.iter (fun t -> a.GetTagItem(t) |> escapeStringForCsv |> appendWithLeadingComma) + + sb.ToString() + + let addCsvFileListener pathToFile = + if pathToFile |> File.Exists |> not then + File.WriteAllLines( + pathToFile, + [ + "Name,StartTime,EndTime,Duration(s),Id,ParentId,RootId," + + String.concat "," Tags.AllKnownTags + ] + ) + + let sw = new StreamWriter(path = pathToFile, append = true) + + let msgQueue = + MailboxProcessor.Start + (fun inbox -> + async { + while true do + let! msg = inbox.Receive() + do! sw.WriteLineAsync(msg) |> Async.AwaitTask + }) + + let l = + new ActivityListener( + ShouldListenTo = (fun a -> a.Name = activitySourceName), + Sample = (fun _ -> ActivitySamplingResult.AllData), + ActivityStopped = (fun a -> msgQueue.Post(createCsvRow a)) + ) + + ActivitySource.AddActivityListener(l) + + { new IDisposable with + member this.Dispose() = + l.Dispose() // Unregister from listening new activities first + (msgQueue :> IDisposable).Dispose() // Wait for the msg queue to be written out + sw.Dispose() // Only then flush the messages and close the file + } diff --git a/src/Compiler/Utilities/Activity.fsi b/src/Compiler/Utilities/Activity.fsi index edf0d890c19..0b9ccd0a4a7 100644 --- a/src/Compiler/Utilities/Activity.fsi +++ b/src/Compiler/Utilities/Activity.fsi @@ -9,6 +9,24 @@ open System [] module internal Activity = + module Tags = + val fileName: string + val qualifiedNameOfFile: string + val project: string + val userOpName: string + val length: string + val cache: string + val cpuDelta: string + val realDelta: string + val gc0: string + val gc1: string + val gc2: string + val outputDllFile: string + + val AllKnownTags: string[] + val startNoTags: name: string -> IDisposable val start: name: string -> tags: (string * string) seq -> IDisposable + + val addCsvFileListener: pathToFile: string -> IDisposable diff --git a/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsc/times/times.fs b/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsc/times/times.fs index dcdd57b4000..6bc77d45a8e 100644 --- a/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsc/times/times.fs +++ b/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsc/times/times.fs @@ -5,6 +5,8 @@ namespace FSharp.Compiler.ComponentTests.CompilerOptions.fsc open Xunit open FSharp.Test open FSharp.Test.Compiler +open System +open System.IO module times = @@ -47,3 +49,46 @@ module times = |> withDiagnosticMessageMatches "Unrecognized option: '--times\+'" |> ignore + [] + let ``times - to console`` compilation = + let oldConsole = Console.Out + let sw = new StringWriter() + Console.SetOut(sw) + use _ = {new IDisposable with + member this.Dispose() = Console.SetOut(oldConsole) } + + compilation + |> asFsx + |> withOptions ["--times"] + |> ignoreWarnings + |> compile + |> shouldSucceed + |> ignore + + let consoleContents = sw.ToString() + Assert.Contains("Parse inputs",consoleContents) + Assert.Contains("Typecheck",consoleContents) + Assert.Contains("Mem",consoleContents) + Assert.Contains("Realdelta",consoleContents) + + + [] + let ``times - to csv file`` compilation = + let tempPath = Path.Combine(Path.GetTempPath(),Guid.NewGuid().ToString() + ".csv") + use _ = {new IDisposable with + member this.Dispose() = File.Delete(tempPath) } + + compilation + |> asFsx + |> withOptions ["--times:"+tempPath] + |> ignoreWarnings + |> compile + |> shouldSucceed + |> ignore + + let csvContents = File.ReadAllLines(tempPath) + + Assert.Contains("Name,StartTime,EndTime,Duration(s),Id,ParentId,RootId",csvContents[0]) + Assert.Contains(csvContents, fun row -> row.Contains("Typecheck")) + Assert.Contains(csvContents, fun row -> row.Contains("Parse inputs")) +