Skip to content
体验新版
项目
组织
正在加载...
登录
切换导航
打开侧边栏
dotNET Platform
fsharp
提交
f25ff0cf
F
fsharp
项目概览
dotNET Platform
/
fsharp
12 个月 前同步成功
通知
0
Star
1
Fork
0
代码
文件
提交
分支
Tags
贡献者
分支图
Diff
Issue
0
列表
看板
标记
里程碑
合并请求
0
DevOps
流水线
流水线任务
计划
Wiki
0
Wiki
分析
仓库
DevOps
项目成员
Pages
F
fsharp
项目概览
项目概览
详情
发布
仓库
仓库
文件
提交
分支
标签
贡献者
分支图
比较
Issue
0
Issue
0
列表
看板
标记
里程碑
合并请求
0
合并请求
0
Pages
DevOps
DevOps
流水线
流水线任务
计划
分析
分析
仓库分析
DevOps
Wiki
0
Wiki
成员
成员
收起侧边栏
关闭侧边栏
动态
分支图
创建新Issue
流水线任务
提交
Issue看板
体验新版 GitCode,发现更多精彩内容 >>
未验证
提交
f25ff0cf
编写于
12月 15, 2022
作者:
D
dotnet bot
提交者:
GitHub
12月 15, 2022
浏览文件
操作
浏览文件
下载
差异文件
Merge pull request #14469 from dotnet/merges/main-to-release/dev17.5
Merge main to release/dev17.5
上级
3130e06c
15462579
变更
13
隐藏空白更改
内联
并排
Showing
13 changed file
with
337 addition
and
70 deletion
+337
-70
FSharpBuild.Directory.Build.props
FSharpBuild.Directory.Build.props
+1
-0
src/Compiler/Checking/CheckDeclarations.fs
src/Compiler/Checking/CheckDeclarations.fs
+4
-4
src/Compiler/Driver/CompilerConfig.fs
src/Compiler/Driver/CompilerConfig.fs
+3
-0
src/Compiler/Driver/CompilerConfig.fsi
src/Compiler/Driver/CompilerConfig.fsi
+4
-0
src/Compiler/Driver/CompilerOptions.fs
src/Compiler/Driver/CompilerOptions.fs
+59
-26
src/Compiler/Driver/ParseAndCheckInputs.fs
src/Compiler/Driver/ParseAndCheckInputs.fs
+1
-1
src/Compiler/Driver/fsc.fs
src/Compiler/Driver/fsc.fs
+11
-0
src/Compiler/Service/FSharpCheckerResults.fs
src/Compiler/Service/FSharpCheckerResults.fs
+9
-2
src/Compiler/Service/IncrementalBuild.fs
src/Compiler/Service/IncrementalBuild.fs
+4
-4
src/Compiler/Service/service.fs
src/Compiler/Service/service.fs
+68
-33
src/Compiler/Utilities/Activity.fs
src/Compiler/Utilities/Activity.fs
+110
-0
src/Compiler/Utilities/Activity.fsi
src/Compiler/Utilities/Activity.fsi
+18
-0
tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsc/times/times.fs
...ompiler.ComponentTests/CompilerOptions/fsc/times/times.fs
+45
-0
未找到文件。
FSharpBuild.Directory.Build.props
浏览文件 @
f25ff0cf
...
...
@@ -27,6 +27,7 @@
<OtherFlags>$(OtherFlags) --nowarn:3384</OtherFlags>
<OtherFlags>$(OtherFlags) --times --nowarn:75</OtherFlags>
<OtherFlags Condition="$(ParallelCheckingWithSignatureFilesOn) == 'true'">$(OtherFlags) --test:ParallelCheckingWithSignatureFilesOn</OtherFlags>
<OtherFlags Condition="$(AdditionalFscCmdFlags) != ''">$(OtherFlags) $(AdditionalFscCmdFlags)</OtherFlags>
</PropertyGroup>
<!-- nuget -->
...
...
src/Compiler/Checking/CheckDeclarations.fs
浏览文件 @
f25ff0cf
...
...
@@ -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
...
...
src/Compiler/Driver/CompilerConfig.fs
浏览文件 @
f25ff0cf
...
...
@@ -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
...
...
src/Compiler/Driver/CompilerConfig.fsi
浏览文件 @
f25ff0cf
...
...
@@ -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
...
...
src/Compiler/Driver/CompilerOptions.fs
浏览文件 @
f25ff0cf
...
...
@@ -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 <enter> 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
=
...
...
src/Compiler/Driver/ParseAndCheckInputs.fs
浏览文件 @
f25ff0cf
...
...
@@ -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
...
...
src/Compiler/Driver/fsc.fs
浏览文件 @
f25ff0cf
...
...
@@ -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.
...
...
src/Compiler/Service/FSharpCheckerResults.fs
浏览文件 @
f25ff0cf
...
...
@@ -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
...
...
src/Compiler/Service/IncrementalBuild.fs
浏览文件 @
f25ff0cf
...
...
@@ -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
<
struct
(
pos
*
pos
)>
with
...
...
@@ -1043,7 +1043,7 @@ module IncrementalBuilderStateHelpers =
let
rec
createFinalizeBoundModelGraphNode
(
initialState
:
IncrementalBuilderInitialState
)
(
boundModels
:
ImmutableArray
<
GraphNode
<
BoundModel
>>.
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
=
...
...
src/Compiler/Service/service.fs
浏览文件 @
f25ff0cf
...
...
@@ -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
<
FSharpProjectOptions
>,
_
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
()
...
...
src/Compiler/Utilities/Activity.fs
浏览文件 @
f25ff0cf
...
...
@@ -4,10 +4,42 @@ namespace FSharp.Compiler.Diagnostics
open
System
open
System
.
Diagnostics
open
System
.
IO
open
System
.
Text
[<
RequireQualifiedAccess
>]
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
<
string
>.
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
}
src/Compiler/Utilities/Activity.fsi
浏览文件 @
f25ff0cf
...
...
@@ -9,6 +9,24 @@ open System
[<
RequireQualifiedAccess
>]
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
tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsc/times/times.fs
浏览文件 @
f25ff0cf
...
...
@@ -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
[<
Theory
;
Directory
(__
SOURCE_DIRECTORY__
,
Includes
=[|
"error_01.fs"
|])>]
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
<
CompilationResult
>
let
consoleContents
=
sw
.
ToString
()
Assert
.
Contains
(
"Parse inputs"
,
consoleContents
)
Assert
.
Contains
(
"Typecheck"
,
consoleContents
)
Assert
.
Contains
(
"Mem"
,
consoleContents
)
Assert
.
Contains
(
"Realdelta"
,
consoleContents
)
[<
Theory
;
Directory
(__
SOURCE_DIRECTORY__
,
Includes
=[|
"error_01.fs"
|])>]
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
<
CompilationResult
>
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"
))
编辑
预览
Markdown
is supported
0%
请重试
或
添加新附件
.
添加附件
取消
You are about to add
0
people
to the discussion. Proceed with caution.
先完成此消息的编辑!
取消
想要评论请
注册
或
登录