diff --git a/src/Compiler/Checking/AttributeChecking.fs b/src/Compiler/Checking/AttributeChecking.fs index 9abaac840c3..2f02f794e8b 100644 --- a/src/Compiler/Checking/AttributeChecking.fs +++ b/src/Compiler/Checking/AttributeChecking.fs @@ -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, _, _, _)) -> @@ -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) ], _, _, _, _)) -> @@ -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 @@ -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)) @@ -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) @@ -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'. diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs index 755961dd0cb..d54f7c59883 100644 --- a/src/Compiler/Checking/ConstraintSolver.fs +++ b/src/Compiler/Checking/ConstraintSolver.fs @@ -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 } | _ -> match tryAnyParTy csenv.g ty with @@ -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) = @@ -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 { @@ -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 diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fs b/src/Compiler/Facilities/DiagnosticsLogger.fs index f7a15577c64..a16c8bc083b 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fs +++ b/src/Compiler/Facilities/DiagnosticsLogger.fs @@ -644,13 +644,13 @@ 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 @@ -658,7 +658,7 @@ let CheckNoErrorsAndGetWarnings res = | ErrorResult _ -> None [] -let bind f res = +let inline bind f res = match res with | OkResult ([], res) -> (* tailcall *) f res | OkResult (warns, res) -> @@ -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() diff --git a/src/Compiler/Facilities/DiagnosticsLogger.fsi b/src/Compiler/Facilities/DiagnosticsLogger.fsi index 98833e5b473..1f39261a668 100644 --- a/src/Compiler/Facilities/DiagnosticsLogger.fsi +++ b/src/Compiler/Facilities/DiagnosticsLogger.fsi @@ -343,19 +343,19 @@ val CommitOperationResult: res: OperationResult<'T> -> 'T val RaiseOperationResult: res: OperationResult -> unit -val ErrorD: err: exn -> OperationResult<'T> +val inline ErrorD: err: exn -> OperationResult<'T> -val WarnD: err: exn -> OperationResult +val inline WarnD: err: exn -> OperationResult val CompleteD: OperationResult -val ResultD: x: 'T -> OperationResult<'T> +val inline ResultD: x: 'T -> OperationResult<'T> val CheckNoErrorsAndGetWarnings: res: OperationResult<'T> -> (exn list * 'T) option /// The bind in the monad. Stop on first error. Accumulate warnings and continue. /// Not meant for direct usage. Used in other inlined functions -val bind: f: ('T -> OperationResult<'b>) -> res: OperationResult<'T> -> OperationResult<'b> +val inline bind: f: ('T -> OperationResult<'b>) -> res: OperationResult<'T> -> OperationResult<'b> /// Stop on first error. Accumulate warnings and continue. val IterateD: f: ('T -> OperationResult) -> xs: 'T list -> OperationResult @@ -368,23 +368,23 @@ type TrackErrorsBuilder = new: unit -> TrackErrorsBuilder - member Bind: res: OperationResult<'h> * k: ('h -> OperationResult<'i>) -> OperationResult<'i> + member inline Bind: res: OperationResult<'h> * k: ('h -> OperationResult<'i>) -> OperationResult<'i> - member Combine: expr1: OperationResult<'c> * expr2: ('c -> OperationResult<'d>) -> OperationResult<'d> + member inline Combine: expr1: OperationResult<'c> * expr2: ('c -> OperationResult<'d>) -> OperationResult<'d> - member Delay: fn: (unit -> 'b) -> (unit -> 'b) + member inline Delay: fn: (unit -> 'b) -> (unit -> 'b) - member For: seq: 'e list * k: ('e -> OperationResult) -> OperationResult + member inline For: seq: 'e list * k: ('e -> OperationResult) -> OperationResult - member Return: res: 'g -> OperationResult<'g> + member inline Return: res: 'g -> OperationResult<'g> - member ReturnFrom: res: 'f -> 'f + member inline ReturnFrom: res: 'f -> 'f - member Run: fn: (unit -> 'T) -> 'T + member inline Run: fn: (unit -> 'T) -> 'T - member While: gd: (unit -> bool) * k: (unit -> OperationResult) -> OperationResult + member inline While: gd: (unit -> bool) * k: (unit -> OperationResult) -> OperationResult - member Zero: unit -> OperationResult + member inline Zero: unit -> OperationResult val trackErrors: TrackErrorsBuilder