Skip to content

Optimize trackErrors usage #15864

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
vzarytovskii merged 3 commits into from
Aug 27, 2023
Merged

Optimize trackErrors usage #15864

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
aacb405
Optimize trackErrors usage
kerams Aug 25, 2023
ba6a3f9
Inline
kerams Aug 25, 2023
7e8f165
Fix
kerams Aug 25, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
28 changes: 14 additions & 14 deletions src/Compiler/Checking/AttributeChecking.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -281,7 +281,7 @@ let CheckFSharpAttributes (g:TcGlobals) attribs m =
| Some _ ->
do! WarnD(ObsoleteWarning("", m))
| None ->
do! CompleteD
()

match TryFindFSharpAttribute g g.attrib_CompilerMessageAttribute attribs with
| Some(Attrib(_, _, [ AttribStringArg s ; AttribInt32Arg n ], namedArgs, _, _, _)) ->
Expand All @@ -292,11 +292,14 @@ let CheckFSharpAttributes (g:TcGlobals) attribs m =
| _ -> false
// If we are using a compiler that supports nameof then error 3501 is always suppressed.
// See attribute on FSharp.Core 'nameof'
if n = 3501 then do! CompleteD
elif isError && (not g.compilingFSharpCore || n <> 1204) then do! ErrorD msg
else do! WarnD msg
if n = 3501 then
()
elif isError && (not g.compilingFSharpCore || n <> 1204) then
do! ErrorD msg
else
do! WarnD msg
| _ ->
do! CompleteD
()

match TryFindFSharpAttribute g g.attrib_ExperimentalAttribute attribs with
| Some(Attrib(_, _, [ AttribStringArg(s) ], _, _, _, _)) ->
Expand All @@ -305,20 +308,18 @@ let CheckFSharpAttributes (g:TcGlobals) attribs m =
true
else
g.langVersion.IsPreviewEnabled && (s.IndexOf(langVersionPrefix, StringComparison.OrdinalIgnoreCase) >= 0)
if isExperimentalAttributeDisabled s then
do! CompleteD
else
if not (isExperimentalAttributeDisabled s) then
do! WarnD(Experimental(s, m))
| Some _ ->
do! WarnD(Experimental(FSComp.SR.experimentalConstruct (), m))
| _ ->
do! CompleteD
()

match TryFindFSharpAttribute g g.attrib_UnverifiableAttribute attribs with
| Some _ ->
do! WarnD(PossibleUnverifiableCode(m))
| _ ->
do! CompleteD
()
}

#if !NO_TYPEPROVIDERS
Expand Down Expand Up @@ -418,7 +419,8 @@ let CheckMethInfoAttributes g m tyargsOpt (minfo: MethInfo) =
trackErrors {
match stripTyEqns g minfo.ApparentEnclosingAppType with
| TType_app(tcref, _, _) -> do! CheckEntityAttributes g tcref m
| _ -> do! CompleteD
| _ -> ()

let search =
BindMethInfoAttributes m minfo
(fun ilAttribs -> Some(CheckILAttributes g false ilAttribs m))
Expand All @@ -428,8 +430,6 @@ let CheckMethInfoAttributes g m tyargsOpt (minfo: MethInfo) =
do! CheckFSharpAttributes g fsAttribs m
if Option.isNone tyargsOpt && HasFSharpAttribute g g.attrib_RequiresExplicitTypeArgumentsAttribute fsAttribs then
do! ErrorD(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(minfo.LogicalName), m))
else
do! CompleteD
}

Some res)
Expand All @@ -440,7 +440,7 @@ let CheckMethInfoAttributes g m tyargsOpt (minfo: MethInfo) =
#endif
match search with
| Some res -> do! res
| None -> do! CompleteD // no attribute = no errors
| None -> () // no attribute = no errors
}

/// Indicate if a method has 'Obsolete', 'CompilerMessageAttribute' or 'TypeProviderEditorHideMethodsAttribute'.
Expand Down
172 changes: 80 additions & 92 deletions src/Compiler/Checking/ConstraintSolver.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -695,7 +695,7 @@ and SolveTypStaticReq (csenv: ConstraintSolverEnv) trace req ty =
let vs = ListMeasureVarOccsWithNonZeroExponents ms
trackErrors {
for tpr, _ in vs do
return! SolveTypStaticReqTypar csenv trace req tpr
do! SolveTypStaticReqTypar csenv trace req tpr
Comment on lines 696 to +698
Copy link
Contributor Author

@kerams kerams Aug 25, 2023

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm pretty sure this doesn't cause an early return on the first item in the loop, so do! should be clearer.

}
| _ ->
match tryAnyParTy csenv.g ty with
Expand Down Expand Up @@ -1065,8 +1065,6 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon
trackErrors {
if not (ccuEq anonInfo1.Assembly anonInfo2.Assembly) then
do! ErrorD (ConstraintSolverError(FSComp.SR.tcAnonRecdCcuMismatch(anonInfo1.Assembly.AssemblyName, anonInfo2.Assembly.AssemblyName), csenv.m,m2))
else
do! ResultD()

if not (anonInfo1.SortedNames = anonInfo2.SortedNames) then
let (|Subset|Superset|Overlap|CompletelyDifferent|) (first, second) =
Expand Down Expand Up @@ -2406,87 +2404,79 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty =
CompleteD

and SolveTypeIsEnum (csenv: ConstraintSolverEnv) ndeep m2 trace ty underlying =
trackErrors {
let g = csenv.g
let m = csenv.m
let denv = csenv.DisplayEnv
match tryDestTyparTy g ty with
| ValueSome destTypar ->
return! AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsEnum(underlying, m))
| _ ->
if isEnumTy g ty then
do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace underlying (underlyingTypeOfEnumTy g ty)
return! CompleteD
else
return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeIsNotEnumType(NicePrint.minimalStringOfType denv ty), m, m2))
}
let g = csenv.g
let m = csenv.m
let denv = csenv.DisplayEnv
match tryDestTyparTy g ty with
| ValueSome destTypar ->
AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsEnum(underlying, m))
| _ ->
if isEnumTy g ty then
SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace underlying (underlyingTypeOfEnumTy g ty)
else
ErrorD (ConstraintSolverError(FSComp.SR.csTypeIsNotEnumType(NicePrint.minimalStringOfType denv ty), m, m2))

and SolveTypeIsDelegate (csenv: ConstraintSolverEnv) ndeep m2 trace ty aty bty =
trackErrors {
let g = csenv.g
let m = csenv.m
let denv = csenv.DisplayEnv
match tryDestTyparTy g ty with
| ValueSome destTypar ->
return! AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsDelegate(aty, bty, m))
| _ ->
if isDelegateTy g ty then
match TryDestStandardDelegateType csenv.InfoReader m AccessibleFromSomewhere ty with
| Some (tupledArgTy, retTy) ->
let g = csenv.g
let m = csenv.m
let denv = csenv.DisplayEnv
match tryDestTyparTy g ty with
| ValueSome destTypar ->
AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsDelegate(aty, bty, m))
| _ ->
if isDelegateTy g ty then
match TryDestStandardDelegateType csenv.InfoReader m AccessibleFromSomewhere ty with
| Some (tupledArgTy, retTy) ->
trackErrors {
do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace aty tupledArgTy
do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace bty retTy
| None ->
return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeHasNonStandardDelegateType(NicePrint.minimalStringOfType denv ty), m, m2))
else
return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeIsNotDelegateType(NicePrint.minimalStringOfType denv ty), m, m2))
}
}
| None ->
ErrorD (ConstraintSolverError(FSComp.SR.csTypeHasNonStandardDelegateType(NicePrint.minimalStringOfType denv ty), m, m2))
else
ErrorD (ConstraintSolverError(FSComp.SR.csTypeIsNotDelegateType(NicePrint.minimalStringOfType denv ty), m, m2))

and SolveTypeIsNonNullableValueType (csenv: ConstraintSolverEnv) ndeep m2 trace ty =
trackErrors {
let g = csenv.g
let m = csenv.m
let denv = csenv.DisplayEnv
match tryDestTyparTy g ty with
| ValueSome destTypar ->
return! AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsNonNullableStruct m)
| _ ->
let underlyingTy = stripTyEqnsAndMeasureEqns g ty
if isStructTy g underlyingTy then
if isNullableTy g underlyingTy then
return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeParameterCannotBeNullable(), m, m))
else
return! CompleteD
let g = csenv.g
let m = csenv.m
let denv = csenv.DisplayEnv
match tryDestTyparTy g ty with
| ValueSome destTypar ->
AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsNonNullableStruct m)
| _ ->
let underlyingTy = stripTyEqnsAndMeasureEqns g ty
if isStructTy g underlyingTy then
if isNullableTy g underlyingTy then
ErrorD (ConstraintSolverError(FSComp.SR.csTypeParameterCannotBeNullable(), m, m))
else
return! ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresStructType(NicePrint.minimalStringOfType denv ty), m, m2))
}
CompleteD
else
ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresStructType(NicePrint.minimalStringOfType denv ty), m, m2))

and SolveTypeIsUnmanaged (csenv: ConstraintSolverEnv) ndeep m2 trace ty =
trackErrors {
let g = csenv.g
let m = csenv.m
let denv = csenv.DisplayEnv
match tryDestTyparTy g ty with
| ValueSome destTypar ->
return! AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsUnmanaged m)
| _ ->
if isStructAnonRecdTy g ty then
return! destStructAnonRecdTy g ty |> IterateD (SolveTypeIsUnmanaged csenv (ndeep + 1) m2 trace)
else if isStructTupleTy g ty then
return! destStructTupleTy g ty |> IterateD (SolveTypeIsUnmanaged csenv (ndeep + 1) m2 trace)
else if isStructUnionTy g ty then
let tcref = tryTcrefOfAppTy g ty |> ValueOption.get
let tinst = mkInstForAppTy g ty
return!
tcref.UnionCasesAsRefList
|> List.collect (actualTysOfUnionCaseFields tinst)
|> IterateD (SolveTypeIsUnmanaged csenv (ndeep + 1) m2 trace)
let g = csenv.g
let m = csenv.m
let denv = csenv.DisplayEnv
match tryDestTyparTy g ty with
| ValueSome destTypar ->
AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsUnmanaged m)
| _ ->
if isStructAnonRecdTy g ty then
destStructAnonRecdTy g ty |> IterateD (SolveTypeIsUnmanaged csenv (ndeep + 1) m2 trace)
else if isStructTupleTy g ty then
destStructTupleTy g ty |> IterateD (SolveTypeIsUnmanaged csenv (ndeep + 1) m2 trace)
else if isStructUnionTy g ty then
let tcref = tryTcrefOfAppTy g ty |> ValueOption.get
let tinst = mkInstForAppTy g ty

tcref.UnionCasesAsRefList
|> List.collect (actualTysOfUnionCaseFields tinst)
|> IterateD (SolveTypeIsUnmanaged csenv (ndeep + 1) m2 trace)
else
if isUnmanagedTy g ty then
CompleteD
else
if isUnmanagedTy g ty then
return! CompleteD
else
return! ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresUnmanagedType(NicePrint.minimalStringOfType denv ty), m, m2))
}

ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresUnmanagedType(NicePrint.minimalStringOfType denv ty), m, m2))

and SolveTypeChoice (csenv: ConstraintSolverEnv) ndeep m2 trace ty choiceTys =
trackErrors {
Expand Down Expand Up @@ -2617,30 +2607,28 @@ and CanMemberSigsMatchUpToCheck
else
let! usesTDC1 = MapCombineTDC2D unifyTypes minst uminst
let! usesTDC2 =
trackErrors {
if not (permitOptArgs || isNil unnamedCalledOptArgs) then
return! ErrorD(Error(FSComp.SR.csOptionalArgumentNotPermittedHere(), m))
else
let calledObjArgTys = calledMeth.CalledObjArgTys(m)

// Check all the argument types.
if not (permitOptArgs || isNil unnamedCalledOptArgs) then
ErrorD(Error(FSComp.SR.csOptionalArgumentNotPermittedHere(), m))
else
let calledObjArgTys = calledMeth.CalledObjArgTys(m)

if calledObjArgTys.Length <> callerObjArgTys.Length then
if calledObjArgTys.Length <> 0 then
return! ErrorD(Error (FSComp.SR.csMemberIsNotStatic(minfo.LogicalName), m))
else
return! ErrorD(Error (FSComp.SR.csMemberIsNotInstance(minfo.LogicalName), m))
// Check all the argument types.

if calledObjArgTys.Length <> callerObjArgTys.Length then
if calledObjArgTys.Length <> 0 then
ErrorD(Error (FSComp.SR.csMemberIsNotStatic(minfo.LogicalName), m))
else
return! MapCombineTDC2D subsumeTypes calledObjArgTys callerObjArgTys
}
ErrorD(Error (FSComp.SR.csMemberIsNotInstance(minfo.LogicalName), m))
else
MapCombineTDC2D subsumeTypes calledObjArgTys callerObjArgTys

let! usesTDC3 =
calledMeth.ArgSets |> MapCombineTDCD (fun argSet -> trackErrors {
calledMeth.ArgSets |> MapCombineTDCD (fun argSet ->
if argSet.UnnamedCalledArgs.Length <> argSet.UnnamedCallerArgs.Length then
return! ErrorD(Error(FSComp.SR.csArgumentLengthMismatch(), m))
ErrorD(Error(FSComp.SR.csArgumentLengthMismatch(), m))
else
return! MapCombineTDC2D subsumeOrConvertArg argSet.UnnamedCalledArgs argSet.UnnamedCallerArgs
})
MapCombineTDC2D subsumeOrConvertArg argSet.UnnamedCalledArgs argSet.UnnamedCallerArgs
)

let! usesTDC4 =
match calledMeth.ParamArrayCalledArgOpt with
Expand Down
26 changes: 13 additions & 13 deletions src/Compiler/Facilities/DiagnosticsLogger.fs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -644,21 +644,21 @@ let CommitOperationResult res =

let RaiseOperationResult res : unit = CommitOperationResult res

let ErrorD err = ErrorResult([], err)
let inline ErrorD err = ErrorResult([], err)

let WarnD err = OkResult([ err ], ())
let inline WarnD err = OkResult([ err ], ())

let CompleteD = OkResult([], ())

let ResultD x = OkResult([], x)
let inline ResultD x = OkResult([], x)

let CheckNoErrorsAndGetWarnings res =
match res with
| OkResult (warns, res2) -> Some(warns, res2)
| ErrorResult _ -> None

[<DebuggerHidden; DebuggerStepThrough>]
let bind f res =
let inline bind f res =
match res with
| OkResult ([], res) -> (* tailcall *) f res
| OkResult (warns, res) ->
Expand Down Expand Up @@ -691,15 +691,15 @@ let rec MapD_loop f acc xs =
let MapD f xs = MapD_loop f [] xs

type TrackErrorsBuilder() =
member x.Bind(res, k) = bind k res
member x.Return res = ResultD res
member x.ReturnFrom res = res
member x.For(seq, k) = IterateD k seq
member x.Combine(expr1, expr2) = bind expr2 expr1
member x.While(gd, k) = WhileD gd k
member x.Zero() = CompleteD
member x.Delay fn = fun () -> fn ()
member x.Run fn = fn ()
member inline x.Bind(res, k) = bind k res
member inline x.Return res = ResultD res
member inline x.ReturnFrom res = res
member inline x.For(seq, k) = IterateD k seq
member inline x.Combine(expr1, expr2) = bind expr2 expr1
member inline x.While(gd, k) = WhileD gd k
member inline x.Zero() = CompleteD
member inline x.Delay(fn: unit -> _) = fn
member inline x.Run fn = fn ()

let trackErrors = TrackErrorsBuilder()

Expand Down
Loading