From ee54eb0e9486b22b1a127c24fcb6f7b7b6b9fbb7 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 27 Sep 2021 18:02:18 +0100 Subject: [PATCH 01/14] fix srtp processing related to tasks --- src/fsharp/CheckDeclarations.fs | 21 +- src/fsharp/CheckExpressions.fs | 28 ++- src/fsharp/CheckExpressions.fsi | 3 - src/fsharp/ConstraintSolver.fs | 230 ++++++++++++------ src/fsharp/ConstraintSolver.fsi | 14 +- .../CodeGen/EmittedIL/TaskGeneratedCode.fs | 31 +++ 6 files changed, 221 insertions(+), 106 deletions(-) diff --git a/src/fsharp/CheckDeclarations.fs b/src/fsharp/CheckDeclarations.fs index 14c0aff2831..c123e30e2b2 100644 --- a/src/fsharp/CheckDeclarations.fs +++ b/src/fsharp/CheckDeclarations.fs @@ -5876,6 +5876,14 @@ let TypeCheckOneImplFile let extraAttribs = topAttrs.mainMethodAttrs@topAttrs.netModuleAttrs@topAttrs.assemblyAttrs + // Run any additional checks registered to be run before applying defaults + conditionallySuppressErrorReporting (checkForErrors()) (fun () -> + for check in cenv.css.GetPostInferenceChecksFinal() do + try + check() + with e -> + errorRecovery e m) + conditionallySuppressErrorReporting (checkForErrors()) (fun () -> ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs) @@ -5900,13 +5908,12 @@ let TypeCheckOneImplFile CheckModuleSignature g cenv m denvAtEnd rootSigOpt implFileTypePriorToSig implFileSpecPriorToSig mexpr) // Run any additional checks registered for post-type-inference - do - conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - for check in cenv.postInferenceChecks do - try - check() - with e -> - errorRecovery e m) + conditionallySuppressErrorReporting (checkForErrors()) (fun () -> + for check in cenv.css.GetPostInferenceChecksFinal() do + try + check() + with e -> + errorRecovery e m) // We ALWAYS run the PostTypeCheckSemanticChecks phase, though we if we have already encountered some // errors we turn off error reporting. This is because it performs various fixups over the TAST, e.g. diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index f966e8e5b60..e135995ecaf 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -359,9 +359,6 @@ type TcFileState = /// we infer type parameters mutable recUses: ValMultiMap - /// Checks to run after all inference is complete. - mutable postInferenceChecks: ResizeArray unit> - /// Set to true if this file causes the creation of generated provided types. mutable createsGeneratedProvidedTypes: bool @@ -425,7 +422,6 @@ type TcFileState = { g = g amap = amap recUses = ValMultiMap<_>.Empty - postInferenceChecks = ResizeArray() createsGeneratedProvidedTypes = false topCcu = topCcu isScript = isScript @@ -452,8 +448,14 @@ type cenv = TcFileState let CopyAndFixupTypars m rigid tpsorig = FreshenAndFixupTypars m rigid [] [] tpsorig -let UnifyTypes cenv (env: TcEnv) m actualTy expectedTy = - AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g actualTy) (tryNormalizeMeasureInType cenv.g expectedTy) +let UnifyTypesAux cenv (env: TcEnv) canPostpone m actualTy expectedTy = + AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css canPostpone m (tryNormalizeMeasureInType cenv.g actualTy) (tryNormalizeMeasureInType cenv.g expectedTy) + +let UnifyTypes cenv env m actualTy expectedTy = + UnifyTypesAux cenv env true m actualTy expectedTy + +let UnifyTypesNoPostpone cenv env m actualTy expectedTy = + UnifyTypesAux cenv env false m actualTy expectedTy // If the overall type admits subsumption or type directed conversion, and the original unify would have failed, // then allow subsumption or type directed conversion. @@ -482,8 +484,8 @@ let UnifyOverallType cenv (env: TcEnv) m overallTy actualTy = let reqdTyText, actualTyText, _cxs = NicePrint.minimalStringsOfTwoTypes env.DisplayEnv reqdTy actualTy warning (Error(FSComp.SR.tcSubsumptionImplicitConversionUsed(actualTyText, reqdTyText), m)) else - // report the error - UnifyTypes cenv env m reqdTy actualTy + // Report the error. + UnifyTypesNoPostpone cenv env m reqdTy actualTy | _ -> UnifyTypes cenv env m overallTy.Commit actualTy @@ -616,7 +618,7 @@ let UnifyRefTupleType contextInfo cenv denv m ty ps = | ContextInfo.RecordFields -> ContextInfo.TupleInRecordFields | _ -> contextInfo - AddCxTypeEqualsType contextInfo denv cenv.css m ty (TType_tuple (tupInfoRef, ptys)) + AddCxTypeEqualsType contextInfo denv cenv.css true m ty (TType_tuple (tupInfoRef, ptys)) ptys /// Allow the inference of structness from the known type, e.g. @@ -639,7 +641,7 @@ let UnifyTupleTypeAndInferCharacteristics contextInfo cenv denv m knownTy isExpl | _ -> contextInfo let ty2 = TType_tuple (tupInfo, ptys) - AddCxTypeEqualsType contextInfo denv cenv.css m knownTy ty2 + AddCxTypeEqualsType contextInfo denv cenv.css true m knownTy ty2 tupInfo, ptys // Allow inference of assembly-affinity and structness from the known type - even from another assembly. This is a rule of @@ -662,7 +664,7 @@ let UnifyAnonRecdTypeAndInferCharacteristics contextInfo cenv denv m ty isExplic let anonInfo = AnonRecdTypeInfo.Create(cenv.topCcu, mkTupInfo isExplicitStruct, unsortedNames) anonInfo, NewInferenceTypes (Array.toList anonInfo.SortedNames) let ty2 = TType_anon (anonInfo, ptys) - AddCxTypeEqualsType contextInfo denv cenv.css m ty ty2 + AddCxTypeEqualsType contextInfo denv cenv.css true m ty ty2 anonInfo, ptys @@ -2624,7 +2626,7 @@ let TcValEarlyGeneralizationConsistencyCheck cenv (env: TcEnv) (v: Val, vrec, ti match vrec with | ValInRecScope isComplete when isComplete && not (isNil tinst) -> //printfn "pushing post-inference check for '%s', vty = '%s'" v.DisplayName (DebugPrint.showType vty) - cenv.postInferenceChecks.Add (fun () -> + cenv.css.AddPostInferenceCheck (preDefaults=false, check=fun () -> //printfn "running post-inference check for '%s'" v.DisplayName //printfn "tau = '%s'" (DebugPrint.showType tau) //printfn "vty = '%s'" (DebugPrint.showType vty) @@ -9184,7 +9186,7 @@ and TcMethodApplication CanonicalizePartialInferenceProblem cenv.css denv mItem (unnamedCurriedCallerArgs |> List.collectSquared (fun callerArg -> freeInTypeLeftToRight cenv.g false callerArg.CallerArgumentType)) - let result, errors = ResolveOverloadingForCall denv cenv.css mMethExpr methodName 0 None callerArgs ad postArgumentTypeCheckingCalledMethGroup true (Some returnTy) + let result, errors = ResolveOverloadingForCall denv cenv.css mMethExpr methodName 0 callerArgs ad postArgumentTypeCheckingCalledMethGroup true (Some returnTy) match afterResolution, result with | AfterResolution.DoNothing, _ -> () diff --git a/src/fsharp/CheckExpressions.fsi b/src/fsharp/CheckExpressions.fsi index 765ecd35c93..b64b1dfc853 100644 --- a/src/fsharp/CheckExpressions.fsi +++ b/src/fsharp/CheckExpressions.fsi @@ -180,9 +180,6 @@ type TcFileState = /// we infer type parameters mutable recUses: ValMultiMap - /// Checks to run after all inference is complete. - mutable postInferenceChecks: ResizeArray unit> - /// Set to true if this file causes the creation of generated provided types. mutable createsGeneratedProvidedTypes: bool diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index d178d9b23a2..ae43168037c 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -266,6 +266,13 @@ type ConstraintSolverState = /// each outstanding, unsolved, ungeneralized trait constraint. Constraints are removed from the table and resolved /// each time a solution to an index variable is found. mutable ExtraCxs: HashMultiMap + + /// Checks to run after all inference is complete, but before defaults are applied and internal unknowns solved + PostInferenceChecksPreDefaults: ResizeArray unit> + + /// Checks to run after all inference is complete. + PostInferenceChecksFinal: ResizeArray unit> + } static member New(g, amap, infoReader, tcVal) = @@ -273,7 +280,21 @@ type ConstraintSolverState = amap = amap ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = infoReader - TcVal = tcVal } + TcVal = tcVal + PostInferenceChecksPreDefaults = ResizeArray() + PostInferenceChecksFinal = ResizeArray() } + + member this.AddPostInferenceCheck (preDefaults, check) = + if preDefaults then + this.PostInferenceChecksPreDefaults.Add check + else + this.PostInferenceChecksFinal.Add check + + member this.GetPostInferenceChecksPreDefaults() = + this.PostInferenceChecksPreDefaults.ToArray() :> seq<_> + + member this.GetPostInferenceChecksFinal() = + this.PostInferenceChecksFinal.ToArray() :> seq<_> type ConstraintSolverEnv = { @@ -281,8 +302,13 @@ type ConstraintSolverEnv = eContextInfo: ContextInfo + /// Indicates that when unifying ty1 = ty2, only type variables in ty1 may be solved MatchingOnly: bool + /// Indicates that local throws on unresolved SRTP constraint overloads may be generated. When + /// these are caught they result in postponed constraints. + ThrowOnFailedMemberConstraintResolution: bool + m: range EquivEnv: TypeEquivEnv @@ -302,8 +328,8 @@ let MakeConstraintSolverEnv contextInfo css m denv = { SolverState = css m = m eContextInfo = contextInfo - // Indicates that when unifying ty1 = ty2, only type variables in ty1 may be solved MatchingOnly = false + ThrowOnFailedMemberConstraintResolution = true EquivEnv = TypeEquivEnv.Empty DisplayEnv = denv } @@ -528,12 +554,38 @@ exception NonRigidTypar of displayEnv: DisplayEnv * string option * range * TTyp // However, it seems likely that the abort may result in other processing associated // with an overall constraint being skipped (e.g. the processing related to subsequent elements // of a tuple constraint). -exception AbortForFailedOverloadResolution +exception AbortForFailedMemberConstraintResolution + +/// This is used internally in method overload resolution +let IgnoreFailedMemberConstraintResolution f1 f2 = + TryD + f1 + (function + | AbortForFailedMemberConstraintResolution -> CompleteD + | exn -> f2 exn) /// This is used at (nearly all) entry points into the constraint solver to make sure that the -/// AbortForFailedOverloadResolution is caught and processing continues. -let inline TryD_IgnoreAbortForFailedOverloadResolution f1 f2 = - TryD f1 (function AbortForFailedOverloadResolution -> CompleteD | exn -> f2 exn) +/// AbortForFailedMemberConstraintResolution is caught, recorded as a post-inference check and processing continues. +/// +/// Due to the legacy of the change https://github.com/dotnet/fsharp/pull/1650, some constraint +/// applications must be allowed to "succeed" with partial processing of the unification being +/// left in place, and no error being raised. This happens in cases where SRTP overload +/// resolution has failed. SRTP resolution is delayed and presumably resolved by later type information. +/// +/// Quite a lot of code related to tasks has come to rely on this feature. +/// +/// To ensure soundness, we double-check the constraint at the end of inference +/// with 'ThrowOnFailedMemberConstraintResolution' set to false. +let PostponeConstraintOnFailedMemberConstraintResolution (css: ConstraintSolverState) csenv f1 f2 = + TryD + (fun () -> f1 csenv) + (function + | AbortForFailedMemberConstraintResolution -> + css.AddPostInferenceCheck (preDefaults=true, check = fun () -> + let csenv2 = { csenv with ThrowOnFailedMemberConstraintResolution = false } + f1 csenv2 |> RaiseOperationResult) + CompleteD + | exn -> f2 exn) /// used to provide detail about non matched argument in overload resolution error message exception ArgDoesNotMatchError of error: ErrorsFromAddingSubsumptionConstraint * calledMeth: CalledMeth * calledArg: CalledArg * callerArg: CallerArg @@ -901,12 +953,12 @@ and SolveTyparEqualsTypePart2 (csenv: ConstraintSolverEnv) ndeep m2 (trace: Opti do! RepeatWhileD ndeep (fun ndeep -> SolveRelevantMemberConstraintsForTypar csenv ndeep PermitWeakResolution.No trace r) // Re-solve the other constraints associated with this type variable - return! solveTypMeetsTyparConstraints csenv ndeep m2 trace ty r + return! SolveTypMeetsTyparConstraints csenv ndeep m2 trace ty r } /// Apply the constraints on 'typar' to the type 'ty' -and solveTypMeetsTyparConstraints (csenv: ConstraintSolverEnv) ndeep m2 trace ty (r: Typar) = trackErrors { +and SolveTypMeetsTyparConstraints (csenv: ConstraintSolverEnv) ndeep m2 trace ty (r: Typar) = trackErrors { let g = csenv.g // Propagate compat flex requirements from 'tp' to 'ty' @@ -1235,7 +1287,7 @@ and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 trace ty /// will deal with the problem. /// /// 2. Some additional solutions are forced prior to generalization (permitWeakResolution= Yes or YesDuringCodeGen). See above -and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace traitInfo : OperationResult = trackErrors { +and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemberConstraintResolution permitWeakResolution ndeep m2 trace traitInfo : OperationResult = trackErrors { let (TTrait(tys, nm, memFlags, traitObjAndArgTys, rty, sln)) = traitInfo // Do not re-solve if already solved if sln.Value.IsSome then return true else @@ -1638,8 +1690,12 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! AddMemberConstraint csenv ndeep m2 trace traitInfo support frees match errors with - | ErrorResult (_, UnresolvedOverloading _) when not ignoreUnresolvedOverload && (not (nm = "op_Explicit" || nm = "op_Implicit")) -> - return! ErrorD AbortForFailedOverloadResolution + | ErrorResult (_, UnresolvedOverloading _) + when + not suppressThrowOnFailedMemberConstraintResolution && + csenv.ThrowOnFailedMemberConstraintResolution && + (not (nm = "op_Explicit" || nm = "op_Implicit")) -> + return! ErrorD AbortForFailedMemberConstraintResolution | _ -> return TTraitUnsolved } @@ -2391,7 +2447,7 @@ and CanMemberSigsMatchUpToCheck return Array.reduce TypeDirectedConversionUsed.Combine [| usesTDC1; usesTDC2; usesTDC3; usesTDC4; usesTDC5; usesTDC6; usesTDC7 |] } -// Assert a subtype constraint, and wrap an ErrorsFromAddingSubsumptionConstraint error around any failure +// Wrap an ErrorsFromAddingSubsumptionConstraint error around any failure // to allow us to report the outer types involved in the constraint // // ty1: expected @@ -2399,27 +2455,29 @@ and CanMemberSigsMatchUpToCheck // // "ty2 casts to ty1" // "a value of type ty2 can be used where a value of type ty1 is expected" -and private SolveTypeSubsumesTypeWithWrappedContextualReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 wrapper = - TryD_IgnoreAbortForFailedOverloadResolution +and AddWrappedContextualSubsumptionReport (csenv: ConstraintSolverEnv) ndeep m cxsln ty1 ty2 res wrapper = + match csenv.eContextInfo with + | ContextInfo.RuntimeTypeTest isOperator -> + // test if we can cast other way around + match CollectThenUndo (fun newTrace -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m (OptionalTrace.WithTrace newTrace) cxsln ty2 ty1) with + | OkResult _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.DowncastUsedInsteadOfUpcast isOperator, m))) + | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.NoContext, m))) + | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, csenv.eContextInfo, m))) + +// Assert a subtype constraint +// +// Due to the legacy of the change https://github.com/dotnet/fsharp/pull/1650, +// when doing overload resolution, we ignore failed member constraints and continue. The +// constraint is not recorded for later solution. +and SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 wrapper = + IgnoreFailedMemberConstraintResolution (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m trace cxsln ty1 ty2) - (fun res -> - match csenv.eContextInfo with - | ContextInfo.RuntimeTypeTest isOperator -> - // test if we can cast other way around - match CollectThenUndo (fun newTrace -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m (OptionalTrace.WithTrace newTrace) cxsln ty2 ty1) with - | OkResult _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.DowncastUsedInsteadOfUpcast isOperator, m))) - | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.NoContext, m))) - | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, csenv.eContextInfo, m)))) - -and private SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 = - SolveTypeSubsumesTypeWithWrappedContextualReport csenv ndeep m trace cxsln ty1 ty2 id - + (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) + // ty1: actual // ty2: expected and private SolveTypeEqualsTypeWithReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln actual expected = - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m trace cxsln actual expected) - (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, actual, expected, res, m))) + SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m trace cxsln actual expected and ArgsMustSubsumeOrConvert (csenv: ConstraintSolverEnv) @@ -2443,7 +2501,7 @@ and ArgsMustSubsumeOrConvert match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArg.CallerArgumentType + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArg.CallerArgumentType id if calledArg.IsParamArray && isArray1DTy g calledArgTy && not (isArray1DTy g callerArg.CallerArgumentType) then return! ErrorD(Error(FSComp.SR.csMethodExpectsParams(), m)) else @@ -2474,7 +2532,7 @@ and ArgsMustSubsumeOrConvertWithContextualReport match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithWrappedContextualReport csenv ndeep m trace cxsln calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) return usesTDC } @@ -2486,7 +2544,7 @@ and TypesEquiv csenv ndeep trace cxsln ty1 ty2 = and TypesMustSubsume (csenv: ConstraintSolverEnv) ndeep trace cxsln m calledArgTy callerArgTy = trackErrors { - do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArgTy + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArgTy id return TypeDirectedConversionUsed.No } @@ -2501,7 +2559,7 @@ and ReturnTypesMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep trace match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln reqdTy actualTy + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln reqdTy actualTy id return usesTDC } @@ -3017,9 +3075,9 @@ and ResolveOverloading | None -> None, errors -let ResolveOverloadingForCall denv css m methodName ndeep cx callerArgs ad calledMethGroup permitOptArgs reqdRetTyOpt = +let ResolveOverloadingForCall denv css m methodName ndeep callerArgs ad calledMethGroup permitOptArgs reqdRetTyOpt = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - ResolveOverloading csenv NoTrace methodName ndeep cx callerArgs ad calledMethGroup permitOptArgs reqdRetTyOpt + ResolveOverloading csenv NoTrace methodName ndeep None callerArgs ad calledMethGroup permitOptArgs reqdRetTyOpt /// This is used before analyzing the types of arguments in a single overload resolution let UnifyUniqueOverloading @@ -3083,9 +3141,13 @@ let EliminateConstraintsForGeneralizedTypars denv css m (trace: OptionalTrace) ( // No error recovery here: we do that on a per-expression basis. //------------------------------------------------------------------------- -let AddCxTypeEqualsType contextInfo denv css m actual expected = +let AddCxTypeEqualsType contextInfo denv css canPostpone m actual expected = let csenv = MakeConstraintSolverEnv contextInfo css m denv - SolveTypeEqualsTypeWithReport csenv 0 m NoTrace None actual expected + let csenv = if canPostpone then csenv else { csenv with ThrowOnFailedMemberConstraintResolution = false } + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTypeEqualsTypeWithReport csenv 0 m NoTrace None actual expected) + (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, actual, expected, res, m))) + //SolveTypeEqualsTypeWithReport csenv 0 m NoTrace None actual expected |> RaiseOperationResult let UndoIfFailed f = @@ -3145,13 +3207,15 @@ let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = let csenv = MakeConstraintSolverEnv contextInfo css m denv - SolveTypeSubsumesTypeWithReport csenv 0 m trace None ty1 ty2 + TryD + (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m trace None ty1 ty2) + (fun res -> AddWrappedContextualSubsumptionReport csenv 0 m None ty1 ty2 res id) |> RaiseOperationResult -let AddCxMethodConstraint denv css m trace traitInfo = +let rec AddCxMethodConstraint denv css m trace traitInfo = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> trackErrors { do! SolveMemberConstraint csenv true PermitWeakResolution.No 0 m trace traitInfo @@ -3160,73 +3224,73 @@ let AddCxMethodConstraint denv css m trace traitInfo = (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeMustSupportNull denv css m trace ty = +let rec AddCxTypeMustSupportNull denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTypeSupportsNull csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTypeSupportsNull csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeMustSupportComparison denv css m trace ty = +let rec AddCxTypeMustSupportComparison denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTypeSupportsComparison csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTypeSupportsComparison csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeMustSupportEquality denv css m trace ty = +let rec AddCxTypeMustSupportEquality denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTypeSupportsEquality csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTypeSupportsEquality csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeMustSupportDefaultCtor denv css m trace ty = +let rec AddCxTypeMustSupportDefaultCtor denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTypeRequiresDefaultConstructor csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTypeRequiresDefaultConstructor csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeIsReferenceType denv css m trace ty = +let rec AddCxTypeIsReferenceType denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTypeIsReferenceType csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTypeIsReferenceType csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeIsValueType denv css m trace ty = +let rec AddCxTypeIsValueType denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTypeIsNonNullableValueType csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTypeIsNonNullableValueType csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeIsUnmanaged denv css m trace ty = +let rec AddCxTypeIsUnmanaged denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTypeIsUnmanaged csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTypeIsUnmanaged csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeIsEnum denv css m trace ty underlying = +let rec AddCxTypeIsEnum denv css m trace ty underlying = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTypeIsEnum csenv 0 m trace ty underlying) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTypeIsEnum csenv 0 m trace ty underlying) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeIsDelegate denv css m trace ty aty bty = +let rec AddCxTypeIsDelegate denv css m trace ty aty bty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTypeIsDelegate csenv 0 m trace ty aty bty) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTypeIsDelegate csenv 0 m trace ty aty bty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty = +let rec AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty = let csenv = MakeConstraintSolverEnv ctxtInfo css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> AddConstraint csenv 0 m NoTrace tp (TyparConstraint.DefaultsTo(ridx, ty, m))) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> AddConstraint csenv 0 m NoTrace tp (TyparConstraint.DefaultsTo(ridx, ty, m))) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -3243,8 +3307,8 @@ let ApplyTyparDefaultAtPriority denv css priority (tp: Typar) = let ty1 = mkTyparTy tp if not tp.IsSolved && not (typeEquiv css.g ty1 ty2) then let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTyparEqualsType csenv 0 m NoTrace ty1 ty2) (fun res -> SolveTypeAsError denv css m ty1 @@ -3257,7 +3321,9 @@ let CreateCodegenState tcVal g amap = amap = amap TcVal = tcVal ExtraCxs = HashMultiMap(10, HashIdentity.Structural) - InfoReader = InfoReader(g, amap) } + InfoReader = InfoReader(g, amap) + PostInferenceChecksPreDefaults = ResizeArray() + PostInferenceChecksFinal = ResizeArray() } /// Generate a witness expression if none is otherwise available, e.g. in legacy non-witness-passing code let CodegenWitnessExprForTraitConstraint tcVal g amap m (traitInfo:TraitConstraintInfo) argExprs = trackErrors { @@ -3293,15 +3359,15 @@ let ChooseTyparSolutionAndSolve css denv tp = let amap = css.amap let max, m = ChooseTyparSolutionAndRange g amap tp let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> SolveTyparEqualsType csenv 0 m NoTrace (mkTyparTy tp) max) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> SolveTyparEqualsType csenv 0 m NoTrace (mkTyparTy tp) max) (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult let CheckDeclaredTypars denv css m typars1 typars2 = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> CollectThenUndo (fun trace -> SolveTypeEqualsTypeEqns csenv 0 m (WithTrace trace) None (List.map mkTyparTy typars1) @@ -3313,8 +3379,8 @@ let CheckDeclaredTypars denv css m typars1 typars2 = let CanonicalizePartialInferenceProblem css denv m tps = // Canonicalize constraints prior to generalization let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - TryD_IgnoreAbortForFailedOverloadResolution - (fun () -> CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) + PostponeConstraintOnFailedMemberConstraintResolution css csenv + (fun csenv -> CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -3330,7 +3396,9 @@ let IsApplicableMethApprox g amap m (minfo: MethInfo) availObjTy = amap = amap TcVal = (fun _ -> failwith "should not be called") ExtraCxs = HashMultiMap(10, HashIdentity.Structural) - InfoReader = InfoReader(g, amap) } + InfoReader = InfoReader(g, amap) + PostInferenceChecksPreDefaults = ResizeArray() + PostInferenceChecksFinal = ResizeArray() } let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) let minst = FreshenMethInfo m minfo match minfo.GetObjArgTypes(amap, m, minst) with diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index dee696470e5..3bf22065f3d 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -141,6 +141,15 @@ type TcValF = ValRef -> ValUseFlag -> TType list -> range -> Expr * TType type ConstraintSolverState = static member New: TcGlobals * ImportMap * InfoReader * TcValF -> ConstraintSolverState + /// Add a post-inference check to run at the end of inference + member AddPostInferenceCheck: preDefaults: bool * check: (unit -> unit) -> unit + + /// Get the post-inference checks to run at the end of inference + member GetPostInferenceChecksFinal: unit -> seq unit> + + /// Get the post-inference checks to run at the end of inference but before defaults are applied + member GetPostInferenceChecksPreDefaults: unit -> seq unit> + val BakedInTraitConstraintNames: Set [] @@ -152,7 +161,7 @@ type OptionalTrace = val SimplifyMeasuresInTypeScheme: TcGlobals -> bool -> Typars -> TType -> TyparConstraint list -> Typars -val ResolveOverloadingForCall: DisplayEnv -> ConstraintSolverState -> range -> methodName: string -> ndeep: int -> cx: TraitConstraintInfo option -> callerArgs: CallerArgs -> AccessorDomain -> calledMethGroup: CalledMeth list -> permitOptArgs: bool -> reqdRetTyOpt: OverallTy option -> CalledMeth option * OperationResult +val ResolveOverloadingForCall: DisplayEnv -> ConstraintSolverState -> range -> methodName: string -> ndeep: int -> callerArgs: CallerArgs -> AccessorDomain -> calledMethGroup: CalledMeth list -> permitOptArgs: bool -> reqdRetTyOpt: OverallTy option -> CalledMeth option * OperationResult val UnifyUniqueOverloading: DisplayEnv -> ConstraintSolverState -> range -> int * int -> string -> AccessorDomain -> CalledMeth list -> OverallTy -> OperationResult @@ -161,7 +170,8 @@ val EliminateConstraintsForGeneralizedTypars: DisplayEnv -> ConstraintSolverStat val CheckDeclaredTypars: DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit -val AddCxTypeEqualsType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit +/// Unify the types. +val AddCxTypeEqualsType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> canPostpone: bool -> range -> TType -> TType -> unit val AddCxTypeEqualsTypeUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool diff --git a/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs b/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs index d75e1849213..b6a209b17be 100644 --- a/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs +++ b/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs @@ -1056,6 +1056,37 @@ let testTask() = task { while x > 4 do System.Console.WriteLine("loop") } } """ ]) + + // This tests the exact optimized code generated for the MoveNext for a trivial task - we expect 'MoveNext' to be there + // because state machine compilation succeeds + // + // The code is not perfect - because the MoveNext is generated late - but the JIT does a good job on it. + // + // The try/catch for the task still exists even though there is no chance of an exception + // + // The crucial code for "return 1" is really just + // IL_000e: ldc.i4.1 + // IL_000f: stfld int32 Test/testTask@4::Result + + [] + let ``check compile of SRTP task code ``() = + CompilerAssert.CompileExeAndRunWithOptions [| "/langversion:preview";"/optimize-";"/debug:portable";"/tailcalls-" |] + """ +module Test + +open System.Threading.Tasks + +let myFunction (f: string -> _, i: 'T) = + task { + do! f "" + return () + } + +[] +let main argv = + let myTuple : (string -> Task) * int = (fun (s: string) -> Task.FromResult()), 1 + myFunction myTuple + """ #endif From 63a1b0821a0ac18e49672e5bb87299f2a8e0a5f3 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 01:11:34 +0100 Subject: [PATCH 02/14] fix 12189 - bad codegen for tasks. Also eliminate 'trace' parameter and put it in the constraint solver context instead --- src/fsharp/CheckComputationExpressions.fs | 6 +- src/fsharp/CheckExpressions.fs | 50 +- src/fsharp/ConstraintSolver.fs | 884 +++++++++--------- src/fsharp/ConstraintSolver.fsi | 35 +- src/fsharp/IlxGen.fs | 50 +- .../CodeGen/EmittedIL/TaskGeneratedCode.fs | 264 +++++- .../Language/OpenTypeDeclarationTests.fs | 2 +- tests/fsharp/core/auto-widen/5.0/test.bsl | 22 +- 8 files changed, 778 insertions(+), 535 deletions(-) diff --git a/src/fsharp/CheckComputationExpressions.fs b/src/fsharp/CheckComputationExpressions.fs index 1c9aecdc594..62ed0dfd1d6 100644 --- a/src/fsharp/CheckComputationExpressions.fs +++ b/src/fsharp/CheckComputationExpressions.fs @@ -1666,7 +1666,7 @@ let mkSeqCollect (cenv: cenv) env m enumElemTy genTy lam enumExpr = mkCallSeqCollect cenv.g m enumElemTy genResultTy lam enumExpr let mkSeqUsing (cenv: cenv) (env: TcEnv) m resourceTy genTy resourceExpr lam = - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace cenv.g.system_IDisposable_ty resourceTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m cenv.g.system_IDisposable_ty resourceTy let genResultTy = NewInferenceType () UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) mkCallSeqUsing cenv.g m resourceTy genResultTy resourceExpr lam @@ -1890,7 +1890,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = if not isYield then errorR(Error(FSComp.SR.tcUseYieldBangForMultipleResults(), m)) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace genOuterTy genExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m genOuterTy genExprTy Some(mkCoerceExpr(resultExpr, genOuterTy, m, genExprTy), tpenv) | SynExpr.YieldOrReturn ((isYield, _), yieldExpr, m) -> @@ -1926,7 +1926,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let genResultTy = NewInferenceType () UnifyTypes cenv env m genOuterTy (mkSeqTy cenv.g genResultTy) let exprTy = tyOfExpr cenv.g expr - AddCxTypeMustSubsumeType env.eContextInfo env.DisplayEnv cenv.css m NoTrace genResultTy exprTy + AddCxTypeMustSubsumeType env.eContextInfo env.DisplayEnv cenv.css m genResultTy exprTy let resExpr = mkCallSeqSingleton cenv.g m genResultTy (mkCoerceExpr(expr, genResultTy, m, exprTy)) Choice1Of2 resExpr, tpenv else diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index e135995ecaf..096e7709ad9 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -2231,7 +2231,7 @@ module GeneralizationHelpers = generalizedTypars |> List.iter (SetTyparRigid denv m) // Generalization removes constraints related to generalized type variables - EliminateConstraintsForGeneralizedTypars denv cenv.css m NoTrace generalizedTypars + EliminateConstraintsForGeneralizedTypars denv cenv.css m generalizedTypars generalizedTypars @@ -2871,7 +2871,7 @@ let MakeApplicableExprWithFlex cenv (env: TcEnv) expr = then actualType else let flexibleType = NewInferenceType () - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace actualType flexibleType + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m actualType flexibleType flexibleType) // Create a coercion to represent the expansion of the application @@ -2893,9 +2893,9 @@ let TcRuntimeTypeTest isCast isOperator cenv denv m tgtTy srcTy = if isSealedTy g tgtTy || isTyparTy g tgtTy || not (isInterfaceTy g srcTy) then if isCast then - AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv cenv.css m NoTrace srcTy tgtTy + AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv cenv.css m srcTy tgtTy else - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace srcTy tgtTy + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m srcTy tgtTy if isErasedType g tgtTy then if isCast then @@ -2921,7 +2921,7 @@ let TcStaticUpcast cenv denv m tgtTy srcTy = if typeEquiv cenv.g srcTy tgtTy then warning(UpcastUnnecessary m) - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace tgtTy srcTy + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m tgtTy srcTy let BuildPossiblyConditionalMethodCall cenv env isMutable m isProp minfo valUseFlags minst objArgs args = @@ -3915,7 +3915,7 @@ let GetInstanceMemberThisVariable (vspec: Val, expr) = let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = let checkSimpleConstraint tp m constraintAdder = let tp', tpenv = TcTypar cenv env newOk tpenv tp - constraintAdder env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') + constraintAdder env.DisplayEnv cenv.css m (mkTyparTy tp') tpenv match c with @@ -3930,7 +3930,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = let tp', tpenv = TcTypar cenv env newOk tpenv tp if newOk = NoNewTypars && isSealedTy cenv.g ty' then errorR(Error(FSComp.SR.tcInvalidConstraintTypeSealed(), m)) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp') + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m ty' (mkTyparTy tp') tpenv | SynTypeConstraint.WhereTyparSupportsNull(tp, m) -> checkSimpleConstraint tp m AddCxTypeMustSupportNull @@ -3951,7 +3951,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = match tyargs with | [underlying] -> let underlying', tpenv = TcTypeAndRecover cenv newOk checkCxs ItemOccurence.UseInType env tpenv underlying - AddCxTypeIsEnum env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') underlying' + AddCxTypeIsEnum env.DisplayEnv cenv.css m (mkTyparTy tp') underlying' tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) @@ -3964,7 +3964,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | [a;b] -> let a', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv a let b', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv b - AddCxTypeIsDelegate env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') a' b' + AddCxTypeIsDelegate env.DisplayEnv cenv.css m (mkTyparTy tp') a' b' tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) @@ -3976,13 +3976,13 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | TTrait(objtys, ".ctor", memberFlags, argTys, returnTy, _) when memberFlags.MemberKind = SynMemberKind.Constructor -> match objtys, argTys with | [ty], [] when typeEquiv cenv.g ty (GetFSharpViewOfReturnType cenv.g returnTy) -> - AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m NoTrace ty + AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m ty tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidNewConstraint(), m)) tpenv | _ -> - AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo + AddCxMethodConstraint env.DisplayEnv cenv.css m traitInfo tpenv and TcPseudoMemberSpec cenv newOk env synTypes tpenv memSpfn m = @@ -4348,7 +4348,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv | SynType.HashConstraint(ty, m) -> let tp = TcAnonTypeOrMeasure (Some TyparKind.Type) cenv TyparRigidity.WarnIfNotRigid TyparDynamicReq.Yes newOk m let ty', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp) + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m ty' (mkTyparTy tp) tp.AsType, tpenv | SynType.StaticConstant (c, m) -> @@ -5293,7 +5293,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p (fun _ -> TPat_range(c1, c2, m)), (tpenv, names, takenNames) | SynPat.Null m -> - try AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace ty + try AddCxTypeMustSupportNull env.DisplayEnv cenv.css m ty with e -> errorRecovery e m (fun _ -> TPat_null m), (tpenv, names, takenNames) @@ -5352,7 +5352,7 @@ and TcExprFlex cenv flex compat (desiredTy: TType) (env: TcEnv) tpenv (synExpr: let argty = NewInferenceType () if compat then (destTyparTy cenv.g argty).SetIsCompatFlex(true) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css synExpr.Range NoTrace desiredTy argty + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css synExpr.Range desiredTy argty let expr2, tpenv = TcExprFlex2 cenv argty env false tpenv synExpr let expr3 = mkCoerceIfNeeded cenv.g desiredTy argty expr2 expr3, tpenv @@ -5752,7 +5752,7 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = expr, tpenv | SynExpr.Null m -> - AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace overallTy.Commit + AddCxTypeMustSupportNull env.DisplayEnv cenv.css m overallTy.Commit mkNull m overallTy.Commit, tpenv | SynExpr.Lazy (synInnerExpr, m) -> @@ -6031,7 +6031,7 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = // Subsumption at trait calls if arguments have nominal type prior to unification of any arguments or return type let flexes = argTys |> List.map (isTyparTy cenv.g >> not) let args', tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args - AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo + AddCxMethodConstraint env.DisplayEnv cenv.css m traitInfo Expr.Op (TOp.TraitCall traitInfo, [], args', m), returnTy, tpenv ) @@ -6416,7 +6416,7 @@ and TcNewExpr cenv env tpenv objTy mObjTyOpt superInit arg mWholeExprOrObjTy = // Handle the case 'new 'a()' if (isTyparTy cenv.g objTy) then if superInit then error(Error(FSComp.SR.tcCannotInheritFromVariableType(), mWholeExprOrObjTy)) - AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css mWholeExprOrObjTy NoTrace objTy + AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css mWholeExprOrObjTy objTy match arg with | SynExpr.Const (SynConst.Unit, _) -> () @@ -8402,7 +8402,7 @@ and TcItemThen cenv (overallTy: OverallTy) env tpenv (tinstEnclosing, item, mIte let resultExpr, tpenv = TcDelayed cenv (MustEqual intermediateTy) env tpenv mItem (MakeApplicableExprNoFlex cenv expr) (tyOfExpr g expr) ExprAtomicFlag.NonAtomic delayed1 // Add the constraint after the application arguments have been checked to allow annotations to kick in on rigid type parameters - AddCxMethodConstraint env.DisplayEnv cenv.css mItem NoTrace traitInfo + AddCxMethodConstraint env.DisplayEnv cenv.css mItem traitInfo // Process all remaining arguments after the constraint is asserted let resultExpr2, tpenv2 = TcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprNoFlex cenv resultExpr) intermediateTy ExprAtomicFlag.NonAtomic delayed2 @@ -8708,7 +8708,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela RecdFieldInstanceChecks cenv.g cenv.amap ad mItem rfinfo let tgtTy = rfinfo.DeclaringType let valu = isStructTy cenv.g tgtTy - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem NoTrace tgtTy objExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem tgtTy objExprTy let objExpr = if valu then objExpr else mkCoerceExpr(objExpr, tgtTy, mExprAndItem, objExprTy) let fieldTy = rfinfo.FieldType match delayed with @@ -8729,7 +8729,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela | Item.AnonRecdField (anonInfo, tinst, n, _) -> let tgty = TType_anon (anonInfo, tinst) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem NoTrace tgty objExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem tgty objExprTy let fieldTy = List.item n tinst match delayed with | DelayedSet _ :: _otherDelayed -> @@ -9186,7 +9186,7 @@ and TcMethodApplication CanonicalizePartialInferenceProblem cenv.css denv mItem (unnamedCurriedCallerArgs |> List.collectSquared (fun callerArg -> freeInTypeLeftToRight cenv.g false callerArg.CallerArgumentType)) - let result, errors = ResolveOverloadingForCall denv cenv.css mMethExpr methodName 0 callerArgs ad postArgumentTypeCheckingCalledMethGroup true (Some returnTy) + let result, errors = ResolveOverloadingForCall denv cenv.css mMethExpr methodName callerArgs ad postArgumentTypeCheckingCalledMethGroup true returnTy match afterResolution, result with | AfterResolution.DoNothing, _ -> () @@ -9252,7 +9252,7 @@ and TcMethodApplication typeEquiv cenv.g finalCalledMethInfo.ApparentEnclosingType cenv.g.obj_ty && (finalCalledMethInfo.LogicalName = "GetHashCode" || finalCalledMethInfo.LogicalName = "Equals")) then - objArgs |> List.iter (fun expr -> AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace (tyOfExpr cenv.g expr)) + objArgs |> List.iter (fun expr -> AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr (tyOfExpr cenv.g expr)) // Uses of a Dictionary() constructor without an IEqualityComparer argument imply an equality constraint // on the first type argument. @@ -9263,7 +9263,7 @@ and TcMethodApplication HasHeadType cenv.g cenv.g.tcref_System_Collections_Generic_IEqualityComparer ty)) then match argsOfAppTy cenv.g finalCalledMethInfo.ApparentEnclosingType with - | [dty; _] -> AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace dty + | [dty; _] -> AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr dty | _ -> () end @@ -10135,7 +10135,7 @@ and TcAttributeEx canFail cenv (env: TcEnv) attrTgt attrEx (synAttr: SynAttribut let propNameItem = Item.SetterArg(id, setterItem) CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, propNameItem, emptyTyparInst, ItemOccurence.Use, ad) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace argty argtyv + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m argty argtyv AttribNamedArg(nm, argty, isProp, mkAttribExpr callerArgExpr)) @@ -10320,7 +10320,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (synBinds, synBinds let isDiscarded = match checkedPat2 with TPat_wild _ -> true | _ -> false let allValsDefinedByPattern = if isDiscarded then [patternInputTmp] else allValsDefinedByPattern (allValsDefinedByPattern, (bodyExpr, bodyExprTy)) ||> List.foldBack (fun v (bodyExpr, bodyExprTy) -> - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css v.Range NoTrace cenv.g.system_IDisposable_ty v.Type + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css v.Range cenv.g.system_IDisposable_ty v.Type let cleanupE = BuildDisposableCleanup cenv env m v mkTryFinally cenv.g (bodyExpr, cleanupE, m, bodyExprTy, DebugPointAtTry.Body, DebugPointAtFinally.No), bodyExprTy) else diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index ae43168037c..4fd6db2880b 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -296,11 +296,47 @@ type ConstraintSolverState = member this.GetPostInferenceChecksFinal() = this.PostInferenceChecksFinal.ToArray() :> seq<_> +//------------------------------------------------------------------------- +// Run the constraint solver with undo (used during method overload resolution) + +type Trace = + { mutable actions: ((unit -> unit) * (unit -> unit)) list } + + static member New () = { actions = [] } + + member t.Undo () = List.iter (fun (_, a) -> a ()) t.actions + member t.Push f undo = t.actions <- (f, undo) :: t.actions + +type OptionalTrace = + | NoTrace + | WithTrace of Trace + + member x.HasTrace = match x with NoTrace -> false | WithTrace _ -> true + + member t.Exec f undo = + match t with + | WithTrace trace -> trace.Push f undo; f() + | NoTrace -> f() + + member t.CollectThenUndoOrCommit predicate f = + let newTrace = Trace.New() + let res = f newTrace + match predicate res, t with + | false, _ -> newTrace.Undo() + | true, WithTrace t -> t.actions <- newTrace.actions @ t.actions + | true, NoTrace -> () + res + type ConstraintSolverEnv = { SolverState: ConstraintSolverState - eContextInfo: ContextInfo + ContextInfo: ContextInfo + + Trace: OptionalTrace + + // Is this speculative, with a trace allowing undo, and trial method overload resolution + IsSpeculative: bool /// Indicates that when unifying ty1 = ty2, only type variables in ty1 may be solved MatchingOnly: bool @@ -327,11 +363,13 @@ type ConstraintSolverEnv = let MakeConstraintSolverEnv contextInfo css m denv = { SolverState = css m = m - eContextInfo = contextInfo + ContextInfo = contextInfo MatchingOnly = false ThrowOnFailedMemberConstraintResolution = true EquivEnv = TypeEquivEnv.Empty - DisplayEnv = denv } + DisplayEnv = denv + Trace = NoTrace + IsSpeculative = true } /// Check whether a type variable occurs in the r.h.s. of a type, e.g. to catch /// infinite equations such as @@ -464,43 +502,6 @@ let BakedInTraitConstraintNames = "Pow"; "Atan2" ] |> set -//------------------------------------------------------------------------- -// Run the constraint solver with undo (used during method overload resolution) - -type Trace = - { mutable actions: ((unit -> unit) * (unit -> unit)) list } - - static member New () = { actions = [] } - - member t.Undo () = List.iter (fun (_, a) -> a ()) t.actions - member t.Push f undo = t.actions <- (f, undo) :: t.actions - -type OptionalTrace = - | NoTrace - | WithTrace of Trace - - member x.HasTrace = match x with NoTrace -> false | WithTrace _ -> true - - member t.Exec f undo = - match t with - | WithTrace trace -> trace.Push f undo; f() - | NoTrace -> f() - - member t.AddFromReplay source = - source.actions |> List.rev |> - match t with - | WithTrace trace -> List.iter (fun (action, undo) -> trace.Push action undo; action()) - | NoTrace -> List.iter (fun (action, _ ) -> action()) - - member t.CollectThenUndoOrCommit predicate f = - let newTrace = Trace.New() - let res = f newTrace - match predicate res, t with - | false, _ -> newTrace.Undo() - | true, WithTrace t -> t.actions <- newTrace.actions @ t.actions - | true, NoTrace -> () - res - let CollectThenUndo f = let trace = Trace.New() let res = f trace @@ -515,7 +516,7 @@ let FilterEachThenUndo f meths = trace.Undo() match CheckNoErrorsAndGetWarnings res with | None -> None - | Some (warns, res) -> Some (calledMeth, warns, trace, res)) + | Some (warns, res) -> Some (calledMeth, warns, res)) let ShowAccessDomain ad = match ad with @@ -576,14 +577,16 @@ let IgnoreFailedMemberConstraintResolution f1 f2 = /// /// To ensure soundness, we double-check the constraint at the end of inference /// with 'ThrowOnFailedMemberConstraintResolution' set to false. -let PostponeConstraintOnFailedMemberConstraintResolution (css: ConstraintSolverState) csenv f1 f2 = +let PostponeConstraintOnFailedMemberConstraintResolution (csenv: ConstraintSolverEnv) f1 f2 = TryD (fun () -> f1 csenv) (function | AbortForFailedMemberConstraintResolution -> - css.AddPostInferenceCheck (preDefaults=true, check = fun () -> - let csenv2 = { csenv with ThrowOnFailedMemberConstraintResolution = false } - f1 csenv2 |> RaiseOperationResult) + // Postponed checking of constraints for failed SRTP resolutions is supported from F# 6.0 onwards + if csenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then + csenv.SolverState.AddPostInferenceCheck (preDefaults=true, check = fun () -> + let csenv2 = { csenv with ThrowOnFailedMemberConstraintResolution = false } + f1 csenv2 |> RaiseOperationResult) CompleteD | exn -> f2 exn) @@ -660,21 +663,21 @@ let SubstMeasure (r: Typar) ms = | None -> r.typar_solution <- Some (TType_measure ms) | Some _ -> error(InternalError("already solved", r.Range)) -let rec TransactStaticReq (csenv: ConstraintSolverEnv) (trace: OptionalTrace) (tpr: Typar) req = +let rec TransactStaticReq (csenv: ConstraintSolverEnv) (tpr: Typar) req = let m = csenv.m if tpr.Rigidity.ErrorIfUnified && tpr.StaticReq <> req then ErrorD(ConstraintSolverError(FSComp.SR.csTypeCannotBeResolvedAtCompileTime(tpr.Name), m, m)) else let orig = tpr.StaticReq - trace.Exec (fun () -> tpr.SetStaticReq req) (fun () -> tpr.SetStaticReq orig) + csenv.Trace.Exec (fun () -> tpr.SetStaticReq req) (fun () -> tpr.SetStaticReq orig) CompleteD -and SolveTypStaticReqTypar (csenv: ConstraintSolverEnv) trace req (tpr: Typar) = +and SolveTypStaticReqTypar (csenv: ConstraintSolverEnv) req (tpr: Typar) = let orig = tpr.StaticReq let req2 = JoinTyparStaticReq req orig - if orig <> req2 then TransactStaticReq csenv trace tpr req2 else CompleteD + if orig <> req2 then TransactStaticReq csenv tpr req2 else CompleteD -and SolveTypStaticReq (csenv: ConstraintSolverEnv) trace req ty = +and SolveTypStaticReq (csenv: ConstraintSolverEnv) req ty = match req with | TyparStaticReq.None -> CompleteD | TyparStaticReq.HeadType -> @@ -684,11 +687,11 @@ and SolveTypStaticReq (csenv: ConstraintSolverEnv) trace req ty = let vs = ListMeasureVarOccsWithNonZeroExponents ms trackErrors { for tpr, _ in vs do - return! SolveTypStaticReqTypar csenv trace req tpr + return! SolveTypStaticReqTypar csenv req tpr } | _ -> match tryAnyParTy csenv.g ty with - | ValueSome tpr -> SolveTypStaticReqTypar csenv trace req tpr + | ValueSome tpr -> SolveTypStaticReqTypar csenv req tpr | ValueNone -> CompleteD let TransactDynamicReq (trace: OptionalTrace) (tpr: Typar) req = @@ -696,13 +699,13 @@ let TransactDynamicReq (trace: OptionalTrace) (tpr: Typar) req = trace.Exec (fun () -> tpr.SetDynamicReq req) (fun () -> tpr.SetDynamicReq orig) CompleteD -let SolveTypDynamicReq (csenv: ConstraintSolverEnv) trace req ty = +let SolveTypDynamicReq (csenv: ConstraintSolverEnv) req ty = match req with | TyparDynamicReq.No -> CompleteD | TyparDynamicReq.Yes -> match tryAnyParTy csenv.g ty with | ValueSome tpr when tpr.DynamicReq <> TyparDynamicReq.Yes -> - TransactDynamicReq trace tpr TyparDynamicReq.Yes + TransactDynamicReq csenv.Trace tpr TyparDynamicReq.Yes | _ -> CompleteD let TransactIsCompatFlex (trace: OptionalTrace) (tpr: Typar) req = @@ -710,24 +713,24 @@ let TransactIsCompatFlex (trace: OptionalTrace) (tpr: Typar) req = trace.Exec (fun () -> tpr.SetIsCompatFlex req) (fun () -> tpr.SetIsCompatFlex orig) CompleteD -let SolveTypIsCompatFlex (csenv: ConstraintSolverEnv) trace req ty = +let SolveTypIsCompatFlex (csenv: ConstraintSolverEnv) req ty = if req then match tryAnyParTy csenv.g ty with - | ValueSome tpr when not tpr.IsCompatFlex -> TransactIsCompatFlex trace tpr req + | ValueSome tpr when not tpr.IsCompatFlex -> TransactIsCompatFlex csenv.Trace tpr req | _ -> CompleteD else CompleteD -let SubstMeasureWarnIfRigid (csenv: ConstraintSolverEnv) trace (v: Typar) ms = trackErrors { +let SubstMeasureWarnIfRigid (csenv: ConstraintSolverEnv) (v: Typar) ms = trackErrors { if v.Rigidity.WarnIfUnified && not (isAnyParTy csenv.g (TType_measure ms)) then // NOTE: we grab the name eagerly to make sure the type variable prints as a type variable let tpnmOpt = if v.IsCompilerGenerated then None else Some v.Name - do! SolveTypStaticReq csenv trace v.StaticReq (TType_measure ms) + do! SolveTypStaticReq csenv v.StaticReq (TType_measure ms) SubstMeasure v ms return! WarnD(NonRigidTypar(csenv.DisplayEnv, tpnmOpt, v.Range, TType_measure (Measure.Var v), TType_measure ms, csenv.m)) else // Propagate static requirements from 'tp' to 'ty' - do! SolveTypStaticReq csenv trace v.StaticReq (TType_measure ms) + do! SolveTypStaticReq csenv v.StaticReq (TType_measure ms) SubstMeasure v ms if v.Rigidity = TyparRigidity.Anon && measureEquiv csenv.g ms Measure.One then return! WarnD(Error(FSComp.SR.csCodeLessGeneric(), v.Range)) @@ -741,7 +744,7 @@ let SubstMeasureWarnIfRigid (csenv: ConstraintSolverEnv) trace (v: Typar) ms = t /// - ms contains no non-rigid unit variables, and so cannot be unified with 1 /// - ms has the form v^e * ms' for some non-rigid variable v, non-zero exponent e, and measure expression ms' /// the most general unifier is then simply v := ms' ^ -(1/e) -let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) trace ms = +let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) ms = // Gather the rigid and non-rigid unit variables in this measure expression together with their exponents let rigidVars, nonRigidVars = ListMeasureVarOccsWithNonZeroExponents ms @@ -754,14 +757,14 @@ let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) trace ms = let newms = ProdMeasures (List.map (fun (c, e') -> Measure.RationalPower (Measure.Con c, NegRational (DivRational e' e))) unexpandedCons @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var v, NegRational (DivRational e' e))) (vs @ rigidVars)) - SubstMeasureWarnIfRigid csenv trace v newms + SubstMeasureWarnIfRigid csenv v newms // Otherwise we require ms to be 1 | [] -> if measureEquiv csenv.g ms Measure.One then CompleteD else localAbortD /// Imperatively unify unit-of-measure expression ms1 against ms2 -let UnifyMeasures (csenv: ConstraintSolverEnv) trace ms1 ms2 = - UnifyMeasureWithOne csenv trace (Measure.Prod(ms1, Measure.Inv ms2)) +let UnifyMeasures (csenv: ConstraintSolverEnv) ms1 ms2 = + UnifyMeasureWithOne csenv (Measure.Prod(ms1, Measure.Inv ms2)) /// Simplify a unit-of-measure expression ms that forms part of a type scheme. /// We make substitutions for vars, which are the (remaining) bound variables @@ -930,45 +933,45 @@ let CheckWarnIfRigid (csenv: ConstraintSolverEnv) ty1 (r: Typar) ty = /// Add the constraint "ty1 = ty" to the constraint problem, where ty1 is a type variable. /// Propagate all effects of adding this constraint, e.g. to solve other variables -let rec SolveTyparEqualsTypePart1 (csenv: ConstraintSolverEnv) m2 (trace: OptionalTrace) ty1 r ty = trackErrors { +let rec SolveTyparEqualsTypePart1 (csenv: ConstraintSolverEnv) m2 ty1 r ty = trackErrors { // The types may still be equivalent due to abbreviations, which we are trying not to eliminate if typeEquiv csenv.g ty1 ty then () else // The famous 'occursCheck' check to catch "infinite types" like 'a = list<'a> - see also https://github.com/Microsoft/visualfsharp/issues/1170 - if occursCheck csenv.g r ty then return! ErrorD (ConstraintSolverInfiniteTypes(csenv.DisplayEnv, csenv.eContextInfo, ty1, ty, csenv.m, m2)) else + if occursCheck csenv.g r ty then return! ErrorD (ConstraintSolverInfiniteTypes(csenv.DisplayEnv, csenv.ContextInfo, ty1, ty, csenv.m, m2)) else // Note: warn _and_ continue! do! CheckWarnIfRigid csenv ty1 r ty // Record the solution before we solve the constraints, since // We may need to make use of the equation when solving the constraints. // Record a entry in the undo trace if one is provided - trace.Exec (fun () -> r.typar_solution <- Some ty) (fun () -> r.typar_solution <- None) + csenv.Trace.Exec (fun () -> r.typar_solution <- Some ty) (fun () -> r.typar_solution <- None) } -and SolveTyparEqualsTypePart2 (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) (r: Typar) ty = trackErrors { +and SolveTyparEqualsTypePart2 (csenv: ConstraintSolverEnv) ndeep m2 (r: Typar) ty = trackErrors { // Only solve constraints if this is not an error var if r.IsFromError then () else // Check to see if this type variable is relevant to any trait constraints. // If so, re-solve the relevant constraints. if csenv.SolverState.ExtraCxs.ContainsKey r.Stamp then - do! RepeatWhileD ndeep (fun ndeep -> SolveRelevantMemberConstraintsForTypar csenv ndeep PermitWeakResolution.No trace r) + do! RepeatWhileD ndeep (fun ndeep -> SolveRelevantMemberConstraintsForTypar csenv ndeep PermitWeakResolution.No r) // Re-solve the other constraints associated with this type variable - return! SolveTypMeetsTyparConstraints csenv ndeep m2 trace ty r + return! SolveTypMeetsTyparConstraints csenv ndeep m2 ty r } /// Apply the constraints on 'typar' to the type 'ty' -and SolveTypMeetsTyparConstraints (csenv: ConstraintSolverEnv) ndeep m2 trace ty (r: Typar) = trackErrors { +and SolveTypMeetsTyparConstraints (csenv: ConstraintSolverEnv) ndeep m2 ty (r: Typar) = trackErrors { let g = csenv.g // Propagate compat flex requirements from 'tp' to 'ty' - do! SolveTypIsCompatFlex csenv trace r.IsCompatFlex ty + do! SolveTypIsCompatFlex csenv r.IsCompatFlex ty // Propagate dynamic requirements from 'tp' to 'ty' - do! SolveTypDynamicReq csenv trace r.DynamicReq ty + do! SolveTypDynamicReq csenv r.DynamicReq ty // Propagate static requirements from 'tp' to 'ty' - do! SolveTypStaticReq csenv trace r.StaticReq ty + do! SolveTypStaticReq csenv r.StaticReq ty // Solve constraints on 'tp' w.r.t. 'ty' for e in r.Constraints do @@ -981,43 +984,43 @@ and SolveTypMeetsTyparConstraints (csenv: ConstraintSolverEnv) ndeep m2 trace ty match tryDestTyparTy g ty with | ValueNone -> CompleteD | ValueSome destTypar -> - AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.DefaultsTo(priority, dty, m)) + AddConstraint csenv ndeep m2 destTypar (TyparConstraint.DefaultsTo(priority, dty, m)) - | TyparConstraint.SupportsNull m2 -> SolveTypeSupportsNull csenv ndeep m2 trace ty - | TyparConstraint.IsEnum(underlying, m2) -> SolveTypeIsEnum csenv ndeep m2 trace ty underlying - | TyparConstraint.SupportsComparison(m2) -> SolveTypeSupportsComparison csenv ndeep m2 trace ty - | TyparConstraint.SupportsEquality(m2) -> SolveTypeSupportsEquality csenv ndeep m2 trace ty - | TyparConstraint.IsDelegate(aty, bty, m2) -> SolveTypeIsDelegate csenv ndeep m2 trace ty aty bty - | TyparConstraint.IsNonNullableStruct m2 -> SolveTypeIsNonNullableValueType csenv ndeep m2 trace ty - | TyparConstraint.IsUnmanaged m2 -> SolveTypeIsUnmanaged csenv ndeep m2 trace ty - | TyparConstraint.IsReferenceType m2 -> SolveTypeIsReferenceType csenv ndeep m2 trace ty - | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypeRequiresDefaultConstructor csenv ndeep m2 trace ty - | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypeChoice csenv ndeep m2 trace ty tys - | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 trace None ty2 ty + | TyparConstraint.SupportsNull m2 -> SolveTypeSupportsNull csenv ndeep m2 ty + | TyparConstraint.IsEnum(underlying, m2) -> SolveTypeIsEnum csenv ndeep m2 ty underlying + | TyparConstraint.SupportsComparison(m2) -> SolveTypeSupportsComparison csenv ndeep m2 ty + | TyparConstraint.SupportsEquality(m2) -> SolveTypeSupportsEquality csenv ndeep m2 ty + | TyparConstraint.IsDelegate(aty, bty, m2) -> SolveTypeIsDelegate csenv ndeep m2 ty aty bty + | TyparConstraint.IsNonNullableStruct m2 -> SolveTypeIsNonNullableValueType csenv ndeep m2 ty + | TyparConstraint.IsUnmanaged m2 -> SolveTypeIsUnmanaged csenv ndeep m2 ty + | TyparConstraint.IsReferenceType m2 -> SolveTypeIsReferenceType csenv ndeep m2 ty + | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypeRequiresDefaultConstructor csenv ndeep m2 ty + | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypeChoice csenv ndeep m2 ty tys + | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 None ty2 ty | TyparConstraint.MayResolveMember(traitInfo, m2) -> - SolveMemberConstraint csenv false PermitWeakResolution.No ndeep m2 trace traitInfo |> OperationResult.ignore + SolveMemberConstraint csenv false PermitWeakResolution.No ndeep m2 traitInfo |> OperationResult.ignore } -and SolveTyparEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) ty1 ty = trackErrors { +and SolveTyparEqualsType (csenv: ConstraintSolverEnv) ndeep m2 ty1 ty = trackErrors { let m = csenv.m do! DepthCheck ndeep m match ty1 with | TType_var r | TType_measure (Measure.Var r) -> - do! SolveTyparEqualsTypePart1 csenv m2 trace ty1 r ty - do! SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty + do! SolveTyparEqualsTypePart1 csenv m2 ty1 r ty + do! SolveTyparEqualsTypePart2 csenv ndeep m2 r ty | _ -> failwith "SolveTyparEqualsType" } // Like SolveTyparEqualsType but asserts all typar equalities simultaneously instead of one by one -and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) tptys tys = trackErrors { +and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 tptys tys = trackErrors { do! (tptys, tys) ||> Iterate2D (fun tpty ty -> match tpty with - | TType_var r | TType_measure (Measure.Var r) -> SolveTyparEqualsTypePart1 csenv m2 trace tpty r ty + | TType_var r | TType_measure (Measure.Var r) -> SolveTyparEqualsTypePart1 csenv m2 tpty r ty | _ -> failwith "SolveTyparsEqualTypes") do! (tptys, tys) ||> Iterate2D (fun tpty ty -> match tpty with - | TType_var r | TType_measure (Measure.Var r) -> SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty + | TType_var r | TType_measure (Measure.Var r) -> SolveTyparEqualsTypePart2 csenv ndeep m2 r ty | _ -> failwith "SolveTyparsEqualTypes") } @@ -1060,7 +1063,7 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon /// Add the constraint "ty1 = ty2" to the constraint problem. /// Propagate all effects of adding this constraint, e.g. to solve type variables -and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) (cxsln:(TraitConstraintInfo * TraitConstraintSln) option) ty1 ty2 = +and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (cxsln:(TraitConstraintInfo * TraitConstraintSln) option) ty1 ty2 = let ndeep = ndeep + 1 let aenv = csenv.EquivEnv let g = csenv.g @@ -1068,12 +1071,12 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr match cxsln with | Some (traitInfo, traitSln) when traitInfo.Solution.IsNone -> // If this is an overload resolution at this point it's safe to assume the candidate member being evaluated solves this member constraint. - TransactMemberConstraintSolution traitInfo trace traitSln + TransactMemberConstraintSolution traitInfo csenv.Trace traitSln | _ -> () if ty1 === ty2 then CompleteD else - let canShortcut = not trace.HasTrace + let canShortcut = not csenv.Trace.HasTrace let sty1 = stripTyEqnsA csenv.g canShortcut ty1 let sty2 = stripTyEqnsA csenv.g canShortcut ty2 @@ -1081,50 +1084,63 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr // type vars inside forall-types may be alpha-equivalent | TType_var tp1, TType_var tp2 when typarEq tp1 tp2 || (match aenv.EquivTypars.TryFind tp1 with | Some v when typeEquiv g v ty2 -> true | _ -> false) -> CompleteD - | TType_var tp1, TType_var tp2 when PreferUnifyTypar tp1 tp2 -> SolveTyparEqualsType csenv ndeep m2 trace sty1 ty2 - | TType_var tp1, TType_var tp2 when not csenv.MatchingOnly && PreferUnifyTypar tp2 tp1 -> SolveTyparEqualsType csenv ndeep m2 trace sty2 ty1 + | TType_var tp1, TType_var tp2 when PreferUnifyTypar tp1 tp2 -> SolveTyparEqualsType csenv ndeep m2 sty1 ty2 + | TType_var tp1, TType_var tp2 when not csenv.MatchingOnly && PreferUnifyTypar tp2 tp1 -> SolveTyparEqualsType csenv ndeep m2 sty2 ty1 - | TType_var r, _ when (r.Rigidity <> TyparRigidity.Rigid) -> SolveTyparEqualsType csenv ndeep m2 trace sty1 ty2 - | _, TType_var r when (r.Rigidity <> TyparRigidity.Rigid) && not csenv.MatchingOnly -> SolveTyparEqualsType csenv ndeep m2 trace sty2 ty1 + | TType_var r, _ when (r.Rigidity <> TyparRigidity.Rigid) -> SolveTyparEqualsType csenv ndeep m2 sty1 ty2 + | _, TType_var r when (r.Rigidity <> TyparRigidity.Rigid) && not csenv.MatchingOnly -> SolveTyparEqualsType csenv ndeep m2 sty2 ty1 // Catch float<_>=float<1>, float32<_>=float32<1> and decimal<_>=decimal<1> | _, TType_app (tc2, [ms]) when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsType csenv ndeep m2 trace None ms (TType_measure Measure.One) + -> SolveTypeEqualsType csenv ndeep m2 None ms (TType_measure Measure.One) | TType_app (tc2, [ms]), _ when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty2 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsType csenv ndeep m2 trace None ms (TType_measure Measure.One) + -> SolveTypeEqualsType csenv ndeep m2 None ms (TType_measure Measure.One) - | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 - | TType_app _, TType_app _ -> localAbortD - | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) -> + | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 -> + SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 + + | TType_app _, TType_app _ -> + localAbortD + + | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) -> if evalTupInfoIsStruct tupInfo1 <> evalTupInfoIsStruct tupInfo2 then ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m, m2)) else - SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 - | TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) -> + SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 + + | TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) -> SolveAnonInfoEqualsAnonInfo csenv m2 anonInfo1 anonInfo2 ++ (fun () -> - SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2) - | TType_fun (d1, r1), TType_fun (d2, r2) -> SolveFunTypeEqn csenv ndeep m2 trace None d1 d2 r1 r2 - | TType_measure ms1, TType_measure ms2 -> UnifyMeasures csenv trace ms1 ms2 + SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2) + + | TType_fun (d1, r1), TType_fun (d2, r2) -> + SolveFunTypeEqn csenv ndeep m2 d1 d2 r1 r2 + + | TType_measure ms1, TType_measure ms2 -> + UnifyMeasures csenv ms1 ms2 + | TType_forall(tps1, rty1), TType_forall(tps2, rty2) -> if tps1.Length <> tps2.Length then localAbortD else let aenv = aenv.BindEquivTypars tps1 tps2 let csenv = {csenv with EquivEnv = aenv } if not (typarsAEquiv g aenv tps1 tps2) then localAbortD else - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty1 rty2 + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty1 rty2 + + | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2 -> + SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 - | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2 -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 | _ -> localAbortD -and SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty1 ty2 = SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace None ty1 ty2 +and SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty1 ty2 = + SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 None ty1 ty2 -and private SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ty1 ty2 = +and private SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 cxsln ty1 ty2 = // Back out of expansions of type abbreviations to give improved error messages. // Note: any "normalization" of equations on type variables must respect the trace parameter - TryD (fun () -> SolveTypeEqualsType csenv ndeep m2 trace cxsln ty1 ty2) + TryD (fun () -> SolveTypeEqualsType csenv ndeep m2 cxsln ty1 ty2) (function - | LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInEqualityRelation(csenv.DisplayEnv, ty1, ty2, csenv.m, m2, csenv.eContextInfo)) + | LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInEqualityRelation(csenv.DisplayEnv, ty1, ty2, csenv.m, m2, csenv.ContextInfo)) | err -> ErrorD err) -and SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln origl1 origl2 = +and SolveTypeEqualsTypeEqns csenv ndeep m2 origl1 origl2 = match origl1, origl2 with | [], [] -> CompleteD | _ -> @@ -1133,14 +1149,14 @@ and SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln origl1 origl2 = match l1, l2 with | [], [] -> CompleteD | h1 :: t1, h2 :: t2 -> - SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln h1 h2 ++ (fun () -> loop t1 t2) + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 h1 h2 ++ (fun () -> loop t1 t2) | _ -> ErrorD(ConstraintSolverTupleDiffLengths(csenv.DisplayEnv, origl1, origl2, csenv.m, m2)) loop origl1 origl2 -and SolveFunTypeEqn csenv ndeep m2 trace cxsln d1 d2 r1 r2 = trackErrors { - do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln d1 d2 - return! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln r1 r2 +and SolveFunTypeEqn csenv ndeep m2 d1 d2 r1 r2 = trackErrors { + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 d1 d2 + return! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 r1 r2 } // ty1: expected @@ -1148,12 +1164,12 @@ and SolveFunTypeEqn csenv ndeep m2 trace cxsln d1 d2 r1 r2 = trackErrors { // // "ty2 casts to ty1" // "a value of type ty2 can be used where a value of type ty1 is expected" -and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) cxsln ty1 ty2 = +and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 cxsln ty1 ty2 = // 'a :> obj ---> let ndeep = ndeep + 1 let g = csenv.g if isObjTy g ty1 then CompleteD else - let canShortcut = not trace.HasTrace + let canShortcut = not csenv.Trace.HasTrace let sty1 = stripTyEqnsA csenv.g canShortcut ty1 let sty2 = stripTyEqnsA csenv.g canShortcut ty2 @@ -1164,52 +1180,54 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional match sty1, sty2 with | TType_var tp1, _ -> match aenv.EquivTypars.TryFind tp1 with - | Some v -> SolveTypeSubsumesType csenv ndeep m2 trace cxsln v ty2 + | Some v -> SolveTypeSubsumesType csenv ndeep m2 cxsln v ty2 | _ -> match sty2 with | TType_var r2 when typarEq tp1 r2 -> CompleteD - | TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 trace r ty1 - | _ -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ty1 ty2 + | TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 r ty1 + | _ -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 cxsln ty1 ty2 - | _, TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 trace r ty1 + | _, TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 r ty1 | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) -> if evalTupInfoIsStruct tupInfo1 <> evalTupInfoIsStruct tupInfo2 then ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m, m2)) else - SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 (* nb. can unify since no variance *) + SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 (* nb. can unify since no variance *) | TType_anon (anonInfo1, l1), TType_anon (anonInfo2, l2) -> SolveAnonInfoEqualsAnonInfo csenv m2 anonInfo1 anonInfo2 ++ (fun () -> - SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2) (* nb. can unify since no variance *) + SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2) (* nb. can unify since no variance *) - | TType_fun (d1, r1), TType_fun (d2, r2) -> SolveFunTypeEqn csenv ndeep m2 trace cxsln d1 d2 r1 r2 (* nb. can unify since no variance *) + | TType_fun (d1, r1), TType_fun (d2, r2) -> + SolveFunTypeEqn csenv ndeep m2 d1 d2 r1 r2 (* nb. can unify since no variance *) - | TType_measure ms1, TType_measure ms2 -> UnifyMeasures csenv trace ms1 ms2 + | TType_measure ms1, TType_measure ms2 -> + UnifyMeasures csenv ms1 ms2 // Enforce the identities float=float<1>, float32=float32<1> and decimal=decimal<1> | _, TType_app (tc2, [ms]) when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms (TType_measure Measure.One) + -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 cxsln ms (TType_measure Measure.One) | TType_app (tc2, [ms]), _ when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty2 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms (TType_measure Measure.One) + -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 cxsln ms (TType_measure Measure.One) // Special subsumption rule for byref tags | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 && g.byref2_tcr.CanDeref && tyconRefEq g g.byref2_tcr tc1 -> match l1, l2 with | [ h1; tag1 ], [ h2; tag2 ] -> trackErrors { - do! SolveTypeEqualsType csenv ndeep m2 trace None h1 h2 + do! SolveTypeEqualsType csenv ndeep m2 None h1 h2 match stripTyEqnsA csenv.g canShortcut tag1, stripTyEqnsA csenv.g canShortcut tag2 with | TType_app(tagc1, []), TType_app(tagc2, []) when (tyconRefEq g tagc2 g.byrefkind_InOut_tcr && (tyconRefEq g tagc1 g.byrefkind_In_tcr || tyconRefEq g tagc1 g.byrefkind_Out_tcr) ) -> () - | _ -> return! SolveTypeEqualsType csenv ndeep m2 trace cxsln tag1 tag2 + | _ -> return! SolveTypeEqualsType csenv ndeep m2 None tag1 tag2 } - | _ -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 + | _ -> SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 -> - SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 + SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2 -> - SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 + SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 | _ -> // By now we know the type is not a variable type @@ -1237,7 +1255,7 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional match tinst with | [ty1arg] -> let ty2arg = destArrayTy g ty2 - SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ty1arg ty2arg + SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 cxsln ty1arg ty2arg | _ -> error(InternalError("destArrayTy", m)) | _ -> @@ -1246,11 +1264,11 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional // may feasibly convert to Head. match FindUniqueFeasibleSupertype g amap m ty1 ty2 with | None -> ErrorD(ConstraintSolverTypesNotInSubsumptionRelation(denv, ty1, ty2, m, m2)) - | Some t -> SolveTypeSubsumesType csenv ndeep m2 trace cxsln ty1 t + | Some t -> SolveTypeSubsumesType csenv ndeep m2 cxsln ty1 t -and SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 trace cxsln ty1 ty2 = +and SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 cxsln ty1 ty2 = let denv = csenv.DisplayEnv - TryD (fun () -> SolveTypeSubsumesType csenv ndeep m2 trace cxsln ty1 ty2) + TryD (fun () -> SolveTypeSubsumesType csenv ndeep m2 cxsln ty1 ty2) (function | LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInSubsumptionRelation(denv, ty1, ty2, csenv.m, m2)) | err -> ErrorD err) @@ -1259,23 +1277,23 @@ and SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 trace cxsln ty1 ty2 = // Solve and record non-equality constraints //------------------------------------------------------------------------- -and SolveTyparSubtypeOfType (csenv: ConstraintSolverEnv) ndeep m2 trace tp ty1 = +and SolveTyparSubtypeOfType (csenv: ConstraintSolverEnv) ndeep m2 tp ty1 = let g = csenv.g if isObjTy g ty1 then CompleteD elif typeEquiv g ty1 (mkTyparTy tp) then CompleteD elif isSealedTy g ty1 then - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace (mkTyparTy tp) ty1 + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 (mkTyparTy tp) ty1 else - AddConstraint csenv ndeep m2 trace tp (TyparConstraint.CoercesTo(ty1, csenv.m)) + AddConstraint csenv ndeep m2 tp (TyparConstraint.CoercesTo(ty1, csenv.m)) and DepthCheck ndeep m = if ndeep > 300 then error(Error(FSComp.SR.csTypeInferenceMaxDepth(), m)) else CompleteD // If this is a type that's parameterized on a unit-of-measure (expected to be numeric), unify its measure with 1 -and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 trace ty = +and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 ty = match getMeasureOfType csenv.g ty with | Some (tcref, _) -> - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty (mkAppTy tcref [TType_measure Measure.One]) + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty (mkAppTy tcref [TType_measure Measure.One]) | None -> CompleteD @@ -1287,7 +1305,7 @@ and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 trace ty /// will deal with the problem. /// /// 2. Some additional solutions are forced prior to generalization (permitWeakResolution= Yes or YesDuringCodeGen). See above -and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemberConstraintResolution permitWeakResolution ndeep m2 trace traitInfo : OperationResult = trackErrors { +and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemberConstraintResolution permitWeakResolution ndeep m2 traitInfo : OperationResult = trackErrors { let (TTrait(tys, nm, memFlags, traitObjAndArgTys, rty, sln)) = traitInfo // Do not re-solve if already solved if sln.Value.IsSome then return true else @@ -1309,11 +1327,11 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb // Assert the object type if the constraint is for an instance member if memFlags.IsInstance then match tys, traitObjAndArgTys with - | [ty], h :: _ -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace h ty + | [ty], h :: _ -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 h ty | _ -> do! ErrorD (ConstraintSolverError(FSComp.SR.csExpectedArguments(), m, m2)) // Trait calls are only supported on pseudo type (variables) for e in tys do - do! SolveTypStaticReq csenv trace TyparStaticReq.HeadType e + do! SolveTypStaticReq csenv TyparStaticReq.HeadType e let argtys = if memFlags.IsInstance then List.tail traitObjAndArgTys else traitObjAndArgTys @@ -1364,8 +1382,8 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb match getMeasureOfType g argty1 with | Some (tcref, ms1) -> let ms2 = freshMeasure () - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 (mkAppTy tcref [TType_measure ms2]) - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 (mkAppTy tcref [TType_measure ms2]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) return TTraitBuiltIn | _ -> @@ -1373,14 +1391,14 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb match getMeasureOfType g argty2 with | Some (tcref, ms2) -> let ms1 = freshMeasure () - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty1 (mkAppTy tcref [TType_measure ms1]) - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty1 (mkAppTy tcref [TType_measure ms1]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) return TTraitBuiltIn | _ -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 return TTraitBuiltIn | _, _, false, ("op_Addition" | "op_Subtraction" | "op_Modulus"), [argty1;argty2] @@ -1388,8 +1406,8 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.ApparentEnclosingType ) && ( IsAddSubModType nm g argty1 && IsBinaryOpOtherArgType g permitWeakResolution argty2 || IsAddSubModType nm g argty2 && IsBinaryOpOtherArgType g permitWeakResolution argty1)) -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 return TTraitBuiltIn | _, _, false, ("op_LessThan" | "op_LessThanOrEqual" | "op_GreaterThan" | "op_GreaterThanOrEqual" | "op_Equality" | "op_Inequality" ), [argty1;argty2] @@ -1397,35 +1415,35 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.ApparentEnclosingType ) && ( IsRelationalType g argty1 && IsBinaryOpOtherArgType g permitWeakResolution argty2 || IsRelationalType g argty2 && IsBinaryOpOtherArgType g permitWeakResolution argty1)) -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.bool_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty g.bool_ty return TTraitBuiltIn // We pretend for uniformity that the numeric types have a static property called Zero and One // As with constants, only zero is polymorphic in its units | [], [ty], false, "get_Zero", [] when IsNumericType g ty || isCharTy g ty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty ty return TTraitBuiltIn | [], [ty], false, "get_One", [] when IsNumericType g ty || isCharTy g ty -> - do! SolveDimensionlessNumericType csenv ndeep m2 trace ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ty + do! SolveDimensionlessNumericType csenv ndeep m2 ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty ty return TTraitBuiltIn | [], _, false, "DivideByInt", [argty1;argty2] when isFpTy g argty1 || isDecimalTy g argty1 -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 g.int_ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 g.int_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 return TTraitBuiltIn // We pretend for uniformity that the 'string' and 'array' types have an indexer property called 'Item' | [], [ty], true, "get_Item", [argty1] when isStringTy g ty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty1 g.int_ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.char_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty1 g.int_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty g.char_ty return TTraitBuiltIn | [], [ty], true, "get_Item", argtys @@ -1434,9 +1452,9 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb if rankOfArrayTy g ty <> argtys.Length then do! ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), argtys.Length), m, m2)) for argty in argtys do - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty g.int_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty g.int_ty let ety = destArrayTy g ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ety + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty ety return TTraitBuiltIn | [], [ty], true, "set_Item", argtys @@ -1446,57 +1464,57 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb do! ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), (argtys.Length - 1)), m, m2)) let argtys, ety = List.frontAndBack argtys for argty in argtys do - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty g.int_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty g.int_ty let etys = destArrayTy g ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ety etys + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ety etys return TTraitBuiltIn | [], _, false, ("op_BitwiseAnd" | "op_BitwiseOr" | "op_ExclusiveOr"), [argty1;argty2] when IsBitwiseOpType g argty1 && IsBinaryOpOtherArgType g permitWeakResolution argty2 || IsBitwiseOpType g argty2 && IsBinaryOpOtherArgType g permitWeakResolution argty1 -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 - do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 + do! SolveDimensionlessNumericType csenv ndeep m2 argty1 return TTraitBuiltIn | [], _, false, ("op_LeftShift" | "op_RightShift"), [argty1;argty2] when IsIntegerOrIntegerEnumTy g argty1 -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 g.int_ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 - do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 g.int_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 + do! SolveDimensionlessNumericType csenv ndeep m2 argty1 return TTraitBuiltIn | _, _, false, "op_UnaryPlus", [argty] when IsNumericOrIntegralEnumType g argty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty return TTraitBuiltIn | _, _, false, "op_UnaryNegation", [argty] when isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty return TTraitBuiltIn | _, _, true, "get_Sign", [] when IsSignType g tys.Head -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.int32_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty g.int32_ty return TTraitBuiltIn | _, _, false, ("op_LogicalNot" | "op_OnesComplement"), [argty] when IsIntegerOrIntegerEnumTy g argty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty - do! SolveDimensionlessNumericType csenv ndeep m2 trace argty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty + do! SolveDimensionlessNumericType csenv ndeep m2 argty return TTraitBuiltIn | _, _, false, "Abs", [argty] when isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty return TTraitBuiltIn | _, _, false, "Sqrt", [argty1] @@ -1504,18 +1522,18 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb match getMeasureOfType g argty1 with | Some (tcref, _) -> let ms1 = freshMeasure () - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty1 (mkAppTy tcref [TType_measure (Measure.Prod (ms1, ms1))]) - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure ms1]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty1 (mkAppTy tcref [TType_measure (Measure.Prod (ms1, ms1))]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty (mkAppTy tcref [TType_measure ms1]) return TTraitBuiltIn | None -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 return TTraitBuiltIn | _, _, false, ("Sin" | "Cos" | "Tan" | "Sinh" | "Cosh" | "Tanh" | "Atan" | "Acos" | "Asin" | "Exp" | "Ceiling" | "Floor" | "Round" | "Truncate" | "Log10" | "Log" | "Sqrt"), [argty] when isFpTy g argty -> - do! SolveDimensionlessNumericType csenv ndeep m2 trace argty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty + do! SolveDimensionlessNumericType csenv ndeep m2 argty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty return TTraitBuiltIn | _, _, false, "op_Explicit", [argty] @@ -1542,17 +1560,17 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb | [], _, false, "Pow", [argty1; argty2] when isFpTy g argty1 -> - do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 + do! SolveDimensionlessNumericType csenv ndeep m2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 return TTraitBuiltIn | _, _, false, "Atan2", [argty1; argty2] when isFpTy g argty1 -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 match getMeasureOfType g argty1 with - | None -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 - | Some (tcref, _) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure Measure.One]) + | None -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 + | Some (tcref, _) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty (mkAppTy tcref [TType_measure Measure.One]) return TTraitBuiltIn | _ -> @@ -1643,21 +1661,23 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo, m, AccessibleFromEverywhere, minfo, minst, minst, None, objtys, callerArgs, false, false, None))) let methOverloadResult, errors = - trace.CollectThenUndoOrCommit + csenv.Trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) - (fun trace -> ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) CallerArgs.Empty AccessibleFromEverywhere calledMethGroup false (Some (MustEqual rty))) + (fun newTrace -> + let csenv = { csenv with Trace = WithTrace newTrace } + ResolveOverloading csenv nm ndeep (Some traitInfo) CallerArgs.Empty AccessibleFromEverywhere calledMethGroup false (Some (MustEqual rty))) match anonRecdPropSearch, recdPropSearch, methOverloadResult with | Some (anonInfo, tinst, i), None, None -> // OK, the constraint is solved by a record property. Assert that the return types match. let rty2 = List.item i tinst - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty rty2 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty rty2 return TTraitSolvedAnonRecdProp(anonInfo, tinst, i) | None, Some (rfinfo, isSetProp), None -> // OK, the constraint is solved by a record property. Assert that the return types match. let rty2 = if isSetProp then g.unit_ty else rfinfo.FieldType - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty rty2 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty rty2 return TTraitSolvedRecdProp(rfinfo, isSetProp) | None, None, Some (calledMeth: CalledMeth<_>) -> @@ -1687,7 +1707,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb do! errors // Otherwise re-record the trait waiting for canonicalization else - do! AddMemberConstraint csenv ndeep m2 trace traitInfo support frees + do! AddMemberConstraint csenv ndeep m2 traitInfo support frees match errors with | ErrorResult (_, UnresolvedOverloading _) @@ -1699,7 +1719,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb | _ -> return TTraitUnsolved } - return! RecordMemberConstraintSolution csenv.SolverState m trace traitInfo res + return! RecordMemberConstraintSolution csenv.SolverState m csenv.Trace traitInfo res } /// Record the solution to a member constraint in the mutable reference cell attached to @@ -1841,7 +1861,7 @@ and MemberConstraintSupportIsReadyForDeterminingOverloads csenv traitInfo = /// Re-solve the global constraints involving any of the given type variables. /// Trait constraints can't always be solved using the pessimistic rules. We only canonicalize /// them forcefully (permitWeakResolution=true) prior to generalization. -and SolveRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep permitWeakResolution trace tps = +and SolveRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep permitWeakResolution tps = RepeatWhileD ndeep (fun ndeep -> tps @@ -1850,28 +1870,28 @@ and SolveRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep permitWeak let ty = mkTyparTy tp match tryAnyParTy csenv.g ty with | ValueSome tp -> - SolveRelevantMemberConstraintsForTypar csenv ndeep permitWeakResolution trace tp + SolveRelevantMemberConstraintsForTypar csenv ndeep permitWeakResolution tp | ValueNone -> ResultD false)) -and SolveRelevantMemberConstraintsForTypar (csenv: ConstraintSolverEnv) ndeep permitWeakResolution (trace: OptionalTrace) tp = +and SolveRelevantMemberConstraintsForTypar (csenv: ConstraintSolverEnv) ndeep permitWeakResolution tp = let cxst = csenv.SolverState.ExtraCxs let tpn = tp.Stamp let cxs = cxst.FindAll tpn if isNil cxs then ResultD false else - trace.Exec (fun () -> cxs |> List.iter (fun _ -> cxst.Remove tpn)) (fun () -> cxs |> List.iter (fun cx -> cxst.Add(tpn, cx))) + csenv.Trace.Exec (fun () -> cxs |> List.iter (fun _ -> cxst.Remove tpn)) (fun () -> cxs |> List.iter (fun cx -> cxst.Add(tpn, cx))) assert (isNil (cxst.FindAll tpn)) cxs |> AtLeastOneD (fun (traitInfo, m2) -> let csenv = { csenv with m = m2 } - SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo) + SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 traitInfo) -and CanonicalizeRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep trace tps = - SolveRelevantMemberConstraints csenv ndeep PermitWeakResolution.Yes trace tps +and CanonicalizeRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep tps = + SolveRelevantMemberConstraints csenv ndeep PermitWeakResolution.Yes tps -and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) traitInfo support (frees: Typar list) = +and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 traitInfo support (frees: Typar list) = let g = csenv.g let aenv = csenv.EquivEnv let cxst = csenv.SolverState.ExtraCxs @@ -1887,19 +1907,19 @@ and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr // check the constraint is not already listed for this type variable if not (cxs |> List.exists (fun (traitInfo2, _) -> traitsAEquiv g aenv traitInfo traitInfo2)) then - trace.Exec (fun () -> csenv.SolverState.ExtraCxs.Add (tpn, (traitInfo, m2))) (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) + csenv.Trace.Exec (fun () -> csenv.SolverState.ExtraCxs.Add (tpn, (traitInfo, m2))) (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) ) // Associate the constraint with each type variable in the support, so if the type variable // gets generalized then this constraint is attached at the binding site. trackErrors { for tp in support do - do! AddConstraint csenv ndeep m2 trace tp (TyparConstraint.MayResolveMember(traitInfo, m2)) + do! AddConstraint csenv ndeep m2 tp (TyparConstraint.MayResolveMember(traitInfo, m2)) } /// Record a constraint on an inference type variable. -and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 trace tp newConstraint = +and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 tp newConstraint = let g = csenv.g let aenv = csenv.EquivEnv let amap = csenv.amap @@ -1926,8 +1946,8 @@ and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 trace tp newConstraint let rty1 = GetFSharpViewOfReturnType g rty1 let rty2 = GetFSharpViewOfReturnType g rty2 trackErrors { - do! Iterate2D (SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace) argtys1 argtys2 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty1 rty2 + do! Iterate2D (SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2) argtys1 argtys2 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty1 rty2 () } @@ -1947,17 +1967,17 @@ and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 trace tp newConstraint for ty1Parent in parents1 do for ty2Parent in parents2 do do! if not (HaveSameHeadType g ty1Parent ty2Parent) then CompleteD else - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty1Parent ty2Parent + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty1Parent ty2Parent } | (TyparConstraint.IsEnum (u1, _), TyparConstraint.IsEnum (u2, m2)) -> - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace u1 u2 + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 u1 u2 | (TyparConstraint.IsDelegate (aty1, bty1, _), TyparConstraint.IsDelegate (aty2, bty2, m2)) -> trackErrors { - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace aty1 aty2 - return! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace bty1 bty2 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 aty1 aty2 + return! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 bty1 bty2 } | TyparConstraint.SupportsComparison _, TyparConstraint.IsDelegate _ @@ -2064,18 +2084,18 @@ and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 trace tp newConstraint // Write the constraint into the type variable // Record a entry in the undo trace if one is provided let orig = tp.Constraints - trace.Exec (fun () -> tp.SetConstraints newConstraints) (fun () -> tp.SetConstraints orig) + csenv.Trace.Exec (fun () -> tp.SetConstraints newConstraints) (fun () -> tp.SetConstraints orig) () } -and SolveTypeSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 trace ty = +and SolveTypeSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 ty = 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.SupportsNull m) + AddConstraint csenv ndeep m2 destTypar (TyparConstraint.SupportsNull m) | ValueNone -> if TypeSatisfiesNullConstraint g m ty then CompleteD else match ty with @@ -2084,14 +2104,14 @@ and SolveTypeSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 trace ty = | _ -> ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotHaveNull(NicePrint.minimalStringOfType denv ty), m, m2)) -and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty = +and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 ty = let g = csenv.g let m = csenv.m let amap = csenv.amap let denv = csenv.DisplayEnv match tryDestTyparTy g ty with | ValueSome destTypar -> - AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.SupportsComparison m) + AddConstraint csenv ndeep m2 destTypar (TyparConstraint.SupportsComparison m) | ValueNone -> // Check it isn't ruled out by the user match tryTcrefOfAppTy g ty with @@ -2100,7 +2120,7 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty = | _ -> match ty with | SpecialComparableHeadType g tinst -> - tinst |> IterateD (SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace) + tinst |> IterateD (SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2) | _ -> // Check the basic requirement - IComparable or IStructuralComparable or assumed if ExistsSameHeadTypeInHierarchy g amap m2 ty g.mk_IComparable_ty || @@ -2112,7 +2132,7 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty = // Check the (possibly inferred) structural dependencies (tinst, tcref.TyparsNoRange) ||> Iterate2D (fun ty tp -> if tp.ComparisonConditionalOn then - SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty + SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 ty else CompleteD) | _ -> @@ -2129,13 +2149,13 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty = else ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison2(NicePrint.minimalStringOfType denv ty), m, m2)) -and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty = +and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 ty = 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.SupportsEquality m) + AddConstraint csenv ndeep m2 destTypar (TyparConstraint.SupportsEquality m) | _ -> match tryTcrefOfAppTy g ty with | ValueSome tcref when HasFSharpAttribute g g.attrib_NoEqualityAttribute tcref.Attribs -> @@ -2143,7 +2163,7 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty = | _ -> match ty with | SpecialEquatableHeadType g tinst -> - tinst |> IterateD (SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace) + tinst |> IterateD (SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2) | SpecialNotEquatableHeadType g _ -> ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality2(NicePrint.minimalStringOfType denv ty), m, m2)) | _ -> @@ -2159,56 +2179,56 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty = // Check the (possibly inferred) structural dependencies (tinst, tcref.TyparsNoRange) ||> Iterate2D (fun ty tp -> if tp.EqualityConditionalOn then - SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty + SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 ty else CompleteD) | _ -> CompleteD -and SolveTypeIsEnum (csenv: ConstraintSolverEnv) ndeep m2 trace ty underlying = +and SolveTypeIsEnum (csenv: ConstraintSolverEnv) ndeep m2 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)) + return! AddConstraint csenv ndeep m2 destTypar (TyparConstraint.IsEnum(underlying, m)) | _ -> if isEnumTy g ty then - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace underlying (underlyingTypeOfEnumTy g ty) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 underlying (underlyingTypeOfEnumTy g ty) return! CompleteD else return! ErrorD (ConstraintSolverError(FSComp.SR.csTypeIsNotEnumType(NicePrint.minimalStringOfType denv ty), m, m2)) } -and SolveTypeIsDelegate (csenv: ConstraintSolverEnv) ndeep m2 trace ty aty bty = +and SolveTypeIsDelegate (csenv: ConstraintSolverEnv) ndeep m2 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)) + return! AddConstraint csenv ndeep m2 destTypar (TyparConstraint.IsDelegate(aty, bty, m)) | _ -> if isDelegateTy g ty then match TryDestStandardDelegateType csenv.InfoReader m AccessibleFromSomewhere ty with | Some (tupledArgTy, rty) -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace aty tupledArgTy - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace bty rty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 aty tupledArgTy + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 bty rty | 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)) } -and SolveTypeIsNonNullableValueType (csenv: ConstraintSolverEnv) ndeep m2 trace ty = +and SolveTypeIsNonNullableValueType (csenv: ConstraintSolverEnv) ndeep m2 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) + return! AddConstraint csenv ndeep m2 destTypar (TyparConstraint.IsNonNullableStruct m) | _ -> let underlyingTy = stripTyEqnsAndMeasureEqns g ty if isStructTy g underlyingTy then @@ -2220,13 +2240,13 @@ and SolveTypeIsNonNullableValueType (csenv: ConstraintSolverEnv) ndeep m2 trace return! ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresStructType(NicePrint.minimalStringOfType denv ty), m, m2)) } -and SolveTypeIsUnmanaged (csenv: ConstraintSolverEnv) ndeep m2 trace ty = +and SolveTypeIsUnmanaged (csenv: ConstraintSolverEnv) ndeep m2 ty = 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) + AddConstraint csenv ndeep m2 destTypar (TyparConstraint.IsUnmanaged m) | _ -> if isUnmanagedTy g ty then CompleteD @@ -2234,13 +2254,13 @@ and SolveTypeIsUnmanaged (csenv: ConstraintSolverEnv) ndeep m2 trace ty = ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresUnmanagedType(NicePrint.minimalStringOfType denv ty), m, m2)) -and SolveTypeChoice (csenv: ConstraintSolverEnv) ndeep m2 trace ty tys = +and SolveTypeChoice (csenv: ConstraintSolverEnv) ndeep m2 ty tys = 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.SimpleChoice(tys, m)) + AddConstraint csenv ndeep m2 destTypar (TyparConstraint.SimpleChoice(tys, m)) | _ -> if List.exists (typeEquivAux Erasure.EraseMeasures g ty) tys then CompleteD else @@ -2248,18 +2268,18 @@ and SolveTypeChoice (csenv: ConstraintSolverEnv) ndeep m2 trace ty tys = let tysString = tys |> List.map (NicePrint.prettyStringOfTy denv) |> String.concat "," ErrorD (ConstraintSolverError(FSComp.SR.csTypeNotCompatibleBecauseOfPrintf(tyString, tysString), m, m2)) -and SolveTypeIsReferenceType (csenv: ConstraintSolverEnv) ndeep m2 trace ty = +and SolveTypeIsReferenceType (csenv: ConstraintSolverEnv) ndeep m2 ty = 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.IsReferenceType m) + AddConstraint csenv ndeep m2 destTypar (TyparConstraint.IsReferenceType m) | _ -> if isRefTy g ty then CompleteD else ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresReferenceSemantics(NicePrint.minimalStringOfType denv ty), m, m)) -and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 trace origTy = +and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 origTy = let g = csenv.g let amap = csenv.amap let m = csenv.m @@ -2267,15 +2287,15 @@ and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 tr let ty = stripTyEqnsAndMeasureEqns g origTy match tryDestTyparTy g ty with | ValueSome tp -> - AddConstraint csenv ndeep m2 trace tp (TyparConstraint.RequiresDefaultConstructor m) + AddConstraint csenv ndeep m2 tp (TyparConstraint.RequiresDefaultConstructor m) | _ -> if isStructTy g ty then if isStructTupleTy g ty then - destStructTupleTy g ty |> IterateD (SolveTypeRequiresDefaultValue csenv ndeep m trace) + destStructTupleTy g ty |> IterateD (SolveTypeRequiresDefaultValue csenv ndeep m) elif isStructAnonRecdTy g ty then match tryDestAnonRecdTy g ty with | ValueNone -> CompleteD - | ValueSome (_, ptys) -> ptys |> IterateD (SolveTypeRequiresDefaultValue csenv ndeep m trace) + | ValueSome (_, ptys) -> ptys |> IterateD (SolveTypeRequiresDefaultValue csenv ndeep m) elif TypeHasDefaultValue g m ty then CompleteD else @@ -2303,22 +2323,22 @@ and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 tr // // In the case of type variables, it requires that the type variable already have been pre-established to be either a (non-nullable) struct // or a reference type. -and SolveTypeRequiresDefaultValue (csenv: ConstraintSolverEnv) ndeep m2 trace origTy = +and SolveTypeRequiresDefaultValue (csenv: ConstraintSolverEnv) ndeep m2 origTy = let g = csenv.g let m = csenv.m let ty = stripTyEqnsAndMeasureEqns g origTy if isTyparTy g ty then if isNonNullableStructTyparTy g ty then - SolveTypeRequiresDefaultConstructor csenv ndeep m2 trace ty + SolveTypeRequiresDefaultConstructor csenv ndeep m2 ty elif isReferenceTyparTy g ty then - SolveTypeSupportsNull csenv ndeep m2 trace ty + SolveTypeSupportsNull csenv ndeep m2 ty else ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresStructOrReferenceConstraint(), m, m2)) else if isStructTy g ty then - SolveTypeRequiresDefaultConstructor csenv ndeep m2 trace ty + SolveTypeRequiresDefaultConstructor csenv ndeep m2 ty else - SolveTypeSupportsNull csenv ndeep m2 trace ty + SolveTypeSupportsNull csenv ndeep m2 ty // Parameterized compatibility relation between member signatures. The real work // is done by "equateTypes" and "subsumeTypes" and "subsumeArg" @@ -2456,34 +2476,41 @@ and CanMemberSigsMatchUpToCheck // "ty2 casts to ty1" // "a value of type ty2 can be used where a value of type ty1 is expected" and AddWrappedContextualSubsumptionReport (csenv: ConstraintSolverEnv) ndeep m cxsln ty1 ty2 res wrapper = - match csenv.eContextInfo with + match csenv.ContextInfo with | ContextInfo.RuntimeTypeTest isOperator -> // test if we can cast other way around - match CollectThenUndo (fun newTrace -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m (OptionalTrace.WithTrace newTrace) cxsln ty2 ty1) with + let results = + CollectThenUndo (fun newTrace -> + let csenv = { csenv with Trace = OptionalTrace.WithTrace newTrace } + SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m cxsln ty2 ty1) + match results with | OkResult _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.DowncastUsedInsteadOfUpcast isOperator, m))) | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.NoContext, m))) - | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, csenv.eContextInfo, m))) - -// Assert a subtype constraint -// -// Due to the legacy of the change https://github.com/dotnet/fsharp/pull/1650, -// when doing overload resolution, we ignore failed member constraints and continue. The -// constraint is not recorded for later solution. -and SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 wrapper = - IgnoreFailedMemberConstraintResolution - (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m trace cxsln ty1 ty2) - (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) + | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, csenv.ContextInfo, m))) + +/// Assert a subtype constraint +and SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m cxsln ty1 ty2 wrapper = + // Due to the legacy of the change https://github.com/dotnet/fsharp/pull/1650, + // when doing nested, speculative overload resolution, we ignore failed member constraints and continue. The + // constraint is not recorded for later solution. + if csenv.IsSpeculative then + IgnoreFailedMemberConstraintResolution + (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m cxsln ty1 ty2) + (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) + else + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m cxsln ty1 ty2) + (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) // ty1: actual // ty2: expected -and private SolveTypeEqualsTypeWithReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln actual expected = - SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m trace cxsln actual expected +and private SolveTypeEqualsTypeWithReport (csenv: ConstraintSolverEnv) ndeep m cxsln actual expected = + SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m cxsln actual expected and ArgsMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep - trace cxsln isConstraint enforceNullableOptionalsKnownTypes // use known types from nullable optional args? @@ -2495,13 +2522,13 @@ and ArgsMustSubsumeOrConvert let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint enforceNullableOptionalsKnownTypes calledArg callerArg match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsTypeWithReport csenv ndeep m trace cxsln ty1 ty2 + do! SolveTypeEqualsTypeWithReport csenv ndeep m cxsln ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArg.CallerArgumentType id + do! SolveTypeSubsumesTypeWithReport csenv ndeep m cxsln calledArgTy callerArg.CallerArgumentType id if calledArg.IsParamArray && isArray1DTy g calledArgTy && not (isArray1DTy g callerArg.CallerArgumentType) then return! ErrorD(Error(FSComp.SR.csMethodExpectsParams(), m)) else @@ -2514,7 +2541,6 @@ and ArgsMustSubsumeOrConvertWithContextualReport (csenv: ConstraintSolverEnv) ad ndeep - trace cxsln isConstraint calledMeth @@ -2526,51 +2552,51 @@ and ArgsMustSubsumeOrConvertWithContextualReport let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint true calledArg callerArg match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsType csenv ndeep m trace cxsln ty1 ty2 + do! SolveTypeEqualsType csenv ndeep m cxsln ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) + do! SolveTypeSubsumesTypeWithReport csenv ndeep m cxsln calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) return usesTDC } -and TypesEquiv csenv ndeep trace cxsln ty1 ty2 = +and TypesEquiv csenv ndeep cxsln ty1 ty2 = trackErrors { - do! SolveTypeEqualsTypeWithReport csenv ndeep csenv.m trace cxsln ty1 ty2 + do! SolveTypeEqualsTypeWithReport csenv ndeep csenv.m cxsln ty1 ty2 return TypeDirectedConversionUsed.No } -and TypesMustSubsume (csenv: ConstraintSolverEnv) ndeep trace cxsln m calledArgTy callerArgTy = +and TypesMustSubsume (csenv: ConstraintSolverEnv) ndeep cxsln m calledArgTy callerArgTy = trackErrors { - do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArgTy id + do! SolveTypeSubsumesTypeWithReport csenv ndeep m cxsln calledArgTy callerArgTy id return TypeDirectedConversionUsed.No } -and ReturnTypesMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep trace cxsln isConstraint m isMethodArg reqdTy actualTy = +and ReturnTypesMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep cxsln isConstraint m isMethodArg reqdTy actualTy = trackErrors { let reqdTy, usesTDC, eqn = AdjustRequiredTypeForTypeDirectedConversions csenv.InfoReader ad isMethodArg isConstraint reqdTy actualTy m match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsType csenv ndeep m trace cxsln ty1 ty2 + do! SolveTypeEqualsType csenv ndeep m cxsln ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln reqdTy actualTy id + do! SolveTypeSubsumesTypeWithReport csenv ndeep m cxsln reqdTy actualTy id return usesTDC } -and ArgsEquivOrConvert (csenv: ConstraintSolverEnv) ad ndeep trace cxsln isConstraint calledArg (callerArg: CallerArg<_>) = +and ArgsEquivOrConvert (csenv: ConstraintSolverEnv) ad ndeep cxsln isConstraint calledArg (callerArg: CallerArg<_>) = trackErrors { let callerArgTy = callerArg.CallerArgumentType let m = callerArg.Range let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint true calledArg callerArg match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsType csenv ndeep m trace cxsln ty1 ty2 + do! SolveTypeEqualsType csenv ndeep m cxsln ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with @@ -2708,7 +2734,6 @@ and ReportNoCandidatesErrorSynExpr csenv callerArgCounts methodName ad calledMet // This is used after analyzing the types of arguments and ResolveOverloading (csenv: ConstraintSolverEnv) - trace // The undo trace, if any methodName // The name of the method being called, for error reporting ndeep // Depth of inference cx // We're doing overload resolution as part of constraint solving, where special rules apply for op_Explicit and op_Implicit constraints. @@ -2726,17 +2751,17 @@ and ResolveOverloading let isOpConversion = methodName = "op_Explicit" || methodName = "op_Implicit" // See what candidates we have based on name and arity let candidates = calledMethGroup |> List.filter (fun cmeth -> cmeth.IsCandidate(m, ad)) - let calledMethOpt, errors, calledMethTrace = + let calledMethOpt, errors = match calledMethGroup, candidates with | _, [calledMeth] when not isOpConversion -> - Some calledMeth, CompleteD, NoTrace + Some calledMeth, CompleteD | [], _ when not isOpConversion -> - None, ErrorD (Error (FSComp.SR.csMethodNotFound(methodName), m)), NoTrace + None, ErrorD (Error (FSComp.SR.csMethodNotFound(methodName), m)) | _, [] when not isOpConversion -> - None, ReportNoCandidatesErrorExpr csenv callerArgs.CallerArgCounts methodName ad calledMethGroup, NoTrace + None, ReportNoCandidatesErrorExpr csenv callerArgs.CallerArgCounts methodName ad calledMethGroup | _, _ -> @@ -2751,36 +2776,38 @@ and ResolveOverloading // and exact matches of argument types. let exactMatchCandidates = candidates |> FilterEachThenUndo (fun newTrace calledMeth -> - let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) cx - CanMemberSigsMatchUpToCheck - csenv - permitOptArgs - alwaysCheckReturn - (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) // instantiations equivalent - (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) // return can subsume or convert - (ArgsEquivOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome) // args exact - reqdRetTyOpt - calledMeth) + let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculative = true } + let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) + CanMemberSigsMatchUpToCheck + csenv + permitOptArgs + alwaysCheckReturn + (TypesEquiv csenv ndeep cxsln) // instantiations equivalent + (TypesMustSubsume csenv ndeep cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome m) // return can subsume or convert + (ArgsEquivOrConvert csenv ad ndeep cxsln cx.IsSome) // args exact + reqdRetTyOpt + calledMeth) match exactMatchCandidates with - | [(calledMeth, warns, _, _usesTDC)] -> - Some calledMeth, OkResult (warns, ()), NoTrace + | [(calledMeth, warns, _usesTDC)] -> + Some calledMeth, OkResult (warns, ()) | _ -> // Now determine the applicable methods. // Subsumption on arguments is allowed. let applicable = candidates |> FilterEachThenUndo (fun newTrace candidate -> - let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m candidate.Method candidate.CalledTyArgs)) cx + let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculative = true } + let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m candidate.Method candidate.CalledTyArgs)) CanMemberSigsMatchUpToCheck csenv permitOptArgs alwaysCheckReturn - (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) // instantiations equivalent - (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) // return can subsume or convert - (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome candidate) // args can subsume + (TypesEquiv csenv ndeep cxsln) // instantiations equivalent + (TypesMustSubsume csenv ndeep cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome m) // return can subsume or convert + (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep cxsln cx.IsSome candidate) // args can subsume reqdRetTyOpt candidate) @@ -2806,28 +2833,30 @@ and ResolveOverloading | [] -> // OK, we failed. Collect up the errors from overload resolution and the possible overloads let errors = - candidates - |> List.choose (fun calledMeth -> - match CollectThenUndo (fun newTrace -> - let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) cx - CanMemberSigsMatchUpToCheck - csenv - permitOptArgs - alwaysCheckReturn - (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) - (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) - (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome calledMeth) - reqdRetTyOpt - calledMeth) with - | OkResult _ -> None - | ErrorResult(_warnings, exn) -> - Some {methodSlot = calledMeth; infoReader = infoReader; error = exn }) - - None, ErrorD (failOverloading (NoOverloadsFound (methodName, errors, cx))), NoTrace - - | [(calledMeth, warns, t, _usesTDC)] -> - Some calledMeth, OkResult (warns, ()), WithTrace t + candidates |> List.choose (fun calledMeth -> + let results = + CollectThenUndo (fun newTrace -> + let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculative = true } + let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) + CanMemberSigsMatchUpToCheck + csenv + permitOptArgs + alwaysCheckReturn + (TypesEquiv csenv ndeep cxsln) + (TypesMustSubsume csenv ndeep cxsln m) + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome m) + (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep cxsln cx.IsSome calledMeth) + reqdRetTyOpt + calledMeth) + match results with + | OkResult _ -> None + | ErrorResult(_warnings, exn) -> + Some {methodSlot = calledMeth; infoReader = infoReader; error = exn }) + + None, ErrorD (failOverloading (NoOverloadsFound (methodName, errors, cx))) + + | [(calledMeth, warns, _usesTDC)] -> + Some calledMeth, OkResult (warns, ()) | applicableMeths -> @@ -2876,7 +2905,7 @@ and ResolveOverloading 0 /// Check whether one overload is better than another - let better (candidate: CalledMeth<_>, candidateWarnings, _, usesTDC1) (other: CalledMeth<_>, otherWarnings, _, usesTDC2) = + let better (candidate: CalledMeth<_>, candidateWarnings, usesTDC1) (other: CalledMeth<_>, otherWarnings, usesTDC2) = let candidateWarnCount = List.length candidateWarnings let otherWarnCount = List.length otherWarnings @@ -2997,7 +3026,7 @@ and ResolveOverloading else None) match bestMethods with - | [(calledMeth, warns, t, _usesTDC)] -> Some calledMeth, OkResult (warns, ()), WithTrace t + | [(calledMeth, warns, _usesTDC)] -> Some calledMeth, OkResult (warns, ()) | bestMethods -> let methods = let getMethodSlotsAndErrors methodSlot errors = @@ -3013,12 +3042,12 @@ and ResolveOverloading | [] -> match applicableMeths with | [] -> for methodSlot in candidates do yield getMethodSlotsAndErrors methodSlot [] - | m -> for methodSlot, errors, _, _ in m do yield getMethodSlotsAndErrors methodSlot errors - | m -> for methodSlot, errors, _, _ in m do yield getMethodSlotsAndErrors methodSlot errors ] + | m -> for methodSlot, errors, _ in m do yield getMethodSlotsAndErrors methodSlot errors + | m -> for methodSlot, errors, _ in m do yield getMethodSlotsAndErrors methodSlot errors ] let methods = List.concat methods - None, ErrorD (failOverloading (PossibleCandidates(methodName, methods,cx))), NoTrace + None, ErrorD (failOverloading (PossibleCandidates(methodName, methods,cx))) // If we've got a candidate solution: make the final checks - no undo here! // Allow subsumption on arguments. Include the return type. @@ -3033,51 +3062,28 @@ and ResolveOverloading calledMethOpt, trackErrors { - do! errors - let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) cx - match calledMethTrace with - | NoTrace -> - let! _usesTDC = - CanMemberSigsMatchUpToCheck - csenv - permitOptArgs - true - (TypesEquiv csenv ndeep trace cxsln) // instantiations equal - (TypesMustSubsume csenv ndeep trace cxsln m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep trace cxsln cx.IsSome m) // return can subsume or convert - (ArgsMustSubsumeOrConvert csenv ad ndeep trace cxsln cx.IsSome true) // args can subsume or convert - reqdRetTyOpt - calledMeth - return () - | WithTrace calledMethTrc -> - - // Re-play existing trace - trace.AddFromReplay calledMethTrc - - // Unify return type - match reqdRetTyOpt with - | None -> () - | Some reqdRetTy -> - let actualRetTy = calledMeth.CalledReturnTypeAfterOutArgTupling - if isByrefTy g reqdRetTy.Commit then - return! ErrorD(Error(FSComp.SR.tcByrefReturnImplicitlyDereferenced(), m)) - else - match reqdRetTy with - | MustConvertTo(isMethodArg, reqdRetTy) when g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions -> - let! _usesTDC = ReturnTypesMustSubsumeOrConvert csenv ad ndeep trace cxsln isMethodArg m isMethodArg reqdRetTy actualRetTy - return () - | _ -> - let! _usesTDC = TypesEquiv csenv ndeep trace cxsln reqdRetTy.Commit actualRetTy - return () - + do! errors + let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) + let! _usesTDC = + CanMemberSigsMatchUpToCheck + csenv + permitOptArgs + true + (TypesEquiv csenv ndeep cxsln) // instantiations equal + (TypesMustSubsume csenv ndeep cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome m) // return can subsume or convert + (ArgsMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome true) // args can subsume or convert + reqdRetTyOpt + calledMeth + return () } | None -> None, errors -let ResolveOverloadingForCall denv css m methodName ndeep callerArgs ad calledMethGroup permitOptArgs reqdRetTyOpt = +let ResolveOverloadingForCall denv css m methodName callerArgs ad calledMethGroup permitOptArgs reqdRetTy = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - ResolveOverloading csenv NoTrace methodName ndeep None callerArgs ad calledMethGroup permitOptArgs reqdRetTyOpt + ResolveOverloading csenv methodName 0 None callerArgs ad calledMethGroup permitOptArgs (Some reqdRetTy) /// This is used before analyzing the types of arguments in a single overload resolution let UnifyUniqueOverloading @@ -3103,10 +3109,10 @@ let UnifyUniqueOverloading csenv true // permitOptArgs true // always check return type - (TypesEquiv csenv ndeep NoTrace None) - (TypesMustSubsume csenv ndeep NoTrace None m) - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep NoTrace None false m) - (ArgsMustSubsumeOrConvert csenv ad ndeep NoTrace None false false) + (TypesEquiv csenv ndeep None) + (TypesMustSubsume csenv ndeep None m) + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep None false m) + (ArgsMustSubsumeOrConvert csenv ad ndeep None false false) (Some reqdRetTy) calledMeth return true @@ -3122,14 +3128,14 @@ let UnifyUniqueOverloading ResultD false /// Remove the global constraints where these type variables appear in the support of the constraint -let EliminateConstraintsForGeneralizedTypars denv css m (trace: OptionalTrace) (generalizedTypars: Typars) = +let EliminateConstraintsForGeneralizedTypars denv css m (generalizedTypars: Typars) = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv for tp in generalizedTypars do let tpn = tp.Stamp let cxst = csenv.SolverState.ExtraCxs let cxs = cxst.FindAll tpn for cx in cxs do - trace.Exec + csenv.Trace.Exec (fun () -> cxst.Remove tpn) (fun () -> (csenv.SolverState.ExtraCxs.Add (tpn, cx))) @@ -3144,10 +3150,9 @@ let EliminateConstraintsForGeneralizedTypars denv css m (trace: OptionalTrace) ( let AddCxTypeEqualsType contextInfo denv css canPostpone m actual expected = let csenv = MakeConstraintSolverEnv contextInfo css m denv let csenv = if canPostpone then csenv else { csenv with ThrowOnFailedMemberConstraintResolution = false } - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTypeEqualsTypeWithReport csenv 0 m NoTrace None actual expected) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeEqualsTypeWithReport csenv 0 m None actual expected) (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, actual, expected, res, m))) - //SolveTypeEqualsTypeWithReport csenv 0 m NoTrace None actual expected |> RaiseOperationResult let UndoIfFailed f = @@ -3184,113 +3189,117 @@ let UndoIfFailedOrWarnings f = let AddCxTypeEqualsTypeUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeEqualsTypeKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) + let csenv = { csenv with Trace = WithTrace trace } + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty1 ty2) let AddCxTypeEqualsTypeUndoIfFailedOrWarnings denv css m ty1 ty2 = UndoIfFailedOrWarnings (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeEqualsTypeKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) + let csenv = { csenv with Trace = WithTrace trace } + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty1 ty2) let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = - let csenv = { MakeConstraintSolverEnv ContextInfo.NoContext css m denv with MatchingOnly = true } - UndoIfFailed (fun trace -> SolveTypeEqualsTypeKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) + UndoIfFailed (fun trace -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + let csenv = { csenv with Trace = WithTrace trace; MatchingOnly = true } + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty1 ty2) let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m (WithTrace trace) None ty1 ty2) + let csenv = { csenv with Trace = WithTrace trace } + SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m None ty1 ty2) let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with MatchingOnly = true } - UndoIfFailed (fun trace -> SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m (WithTrace trace) None ty1 ty2) + UndoIfFailed (fun trace -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + let csenv = { csenv with Trace = WithTrace trace; MatchingOnly = true } + SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m None ty1 ty2) -let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = +let AddCxTypeMustSubsumeType contextInfo denv css m ty1 ty2 = let csenv = MakeConstraintSolverEnv contextInfo css m denv - TryD - (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m trace None ty1 ty2) - (fun res -> AddWrappedContextualSubsumptionReport csenv 0 m None ty1 ty2 res id) + SolveTypeSubsumesTypeWithReport csenv 0 m None ty1 ty2 id |> RaiseOperationResult -let rec AddCxMethodConstraint denv css m trace traitInfo = +let rec AddCxMethodConstraint denv css m traitInfo = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv + PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> trackErrors { do! - SolveMemberConstraint csenv true PermitWeakResolution.No 0 m trace traitInfo + SolveMemberConstraint csenv true PermitWeakResolution.No 0 m traitInfo |> OperationResult.ignore }) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeMustSupportNull denv css m trace ty = +let rec AddCxTypeMustSupportNull denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTypeSupportsNull csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeSupportsNull csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeMustSupportComparison denv css m trace ty = +let rec AddCxTypeMustSupportComparison denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTypeSupportsComparison csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeSupportsComparison csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeMustSupportEquality denv css m trace ty = +let rec AddCxTypeMustSupportEquality denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTypeSupportsEquality csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeSupportsEquality csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeMustSupportDefaultCtor denv css m trace ty = +let rec AddCxTypeMustSupportDefaultCtor denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTypeRequiresDefaultConstructor csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeRequiresDefaultConstructor csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeIsReferenceType denv css m trace ty = +let rec AddCxTypeIsReferenceType denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTypeIsReferenceType csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeIsReferenceType csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeIsValueType denv css m trace ty = +let rec AddCxTypeIsValueType denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTypeIsNonNullableValueType csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeIsNonNullableValueType csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeIsUnmanaged denv css m trace ty = +let rec AddCxTypeIsUnmanaged denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTypeIsUnmanaged csenv 0 m trace ty) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeIsUnmanaged csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeIsEnum denv css m trace ty underlying = +let rec AddCxTypeIsEnum denv css m ty underlying = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTypeIsEnum csenv 0 m trace ty underlying) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeIsEnum csenv 0 m ty underlying) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeIsDelegate denv css m trace ty aty bty = +let rec AddCxTypeIsDelegate denv css m ty aty bty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTypeIsDelegate csenv 0 m trace ty aty bty) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeIsDelegate csenv 0 m ty aty bty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let rec AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty = let csenv = MakeConstraintSolverEnv ctxtInfo css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> AddConstraint csenv 0 m NoTrace tp (TyparConstraint.DefaultsTo(ridx, ty, m))) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> AddConstraint csenv 0 m tp (TyparConstraint.DefaultsTo(ridx, ty, m))) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -3298,7 +3307,7 @@ let SolveTypeAsError denv css m ty = let ty2 = NewErrorType () assert (destTyparTy css.g ty2).IsFromError let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeEqualsTypeKeepAbbrevs csenv 0 m NoTrace ty ty2 |> ignore + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty ty2 |> ignore let ApplyTyparDefaultAtPriority denv css priority (tp: Typar) = tp.Constraints |> List.iter (fun tpc -> @@ -3307,9 +3316,9 @@ let ApplyTyparDefaultAtPriority denv css priority (tp: Typar) = let ty1 = mkTyparTy tp if not tp.IsSolved && not (typeEquiv css.g ty1 ty2) then let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv + PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> - SolveTyparEqualsType csenv 0 m NoTrace ty1 ty2) + SolveTyparEqualsType csenv 0 m ty1 ty2) (fun res -> SolveTypeAsError denv css m ty1 ErrorD(ErrorFromApplyingDefault(css.g, denv, tp, ty2, res, m))) @@ -3329,7 +3338,7 @@ let CreateCodegenState tcVal g amap = let CodegenWitnessExprForTraitConstraint tcVal g amap m (traitInfo:TraitConstraintInfo) argExprs = trackErrors { let css = CreateCodegenState tcVal g amap let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) - let! _res = SolveMemberConstraint csenv true PermitWeakResolution.Yes 0 m NoTrace traitInfo + let! _res = SolveMemberConstraint csenv true PermitWeakResolution.Yes 0 m traitInfo return GenWitnessExpr amap g m traitInfo argExprs } @@ -3339,7 +3348,7 @@ let CodegenWitnessesForTyparInst tcVal g amap m typars tyargs = trackErrors { let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) let ftps, _renaming, tinst = FreshenTypeInst m typars let traitInfos = GetTraitConstraintInfosOfTypars g ftps - do! SolveTyparsEqualTypes csenv 0 m NoTrace tinst tyargs + do! SolveTyparsEqualTypes csenv 0 m tinst tyargs return GenWitnessArgs amap g m traitInfos } @@ -3347,7 +3356,7 @@ let CodegenWitnessesForTyparInst tcVal g amap m typars tyargs = trackErrors { let CodegenWitnessArgForTraitConstraint tcVal g amap m traitInfo = trackErrors { let css = CreateCodegenState tcVal g amap let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) - let! _res = SolveMemberConstraint csenv true PermitWeakResolution.Yes 0 m NoTrace traitInfo + let! _res = SolveMemberConstraint csenv true PermitWeakResolution.Yes 0 m traitInfo return GenWitnessExprLambda amap g m traitInfo } @@ -3359,17 +3368,18 @@ let ChooseTyparSolutionAndSolve css denv tp = let amap = css.amap let max, m = ChooseTyparSolutionAndRange g amap tp let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> SolveTyparEqualsType csenv 0 m NoTrace (mkTyparTy tp) max) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTyparEqualsType csenv 0 m (mkTyparTy tp) max) (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult let CheckDeclaredTypars denv css m typars1 typars2 = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv + PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> - CollectThenUndo (fun trace -> - SolveTypeEqualsTypeEqns csenv 0 m (WithTrace trace) None + CollectThenUndo (fun newTrace -> + let csenv = { csenv with Trace = WithTrace newTrace } + SolveTypeEqualsTypeEqns csenv 0 m (List.map mkTyparTy typars1) (List.map mkTyparTy typars2))) (fun res -> @@ -3379,8 +3389,8 @@ let CheckDeclaredTypars denv css m typars1 typars2 = let CanonicalizePartialInferenceProblem css denv m tps = // Canonicalize constraints prior to generalization let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution css csenv - (fun csenv -> CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) + PostponeConstraintOnFailedMemberConstraintResolution csenv + (fun csenv -> CanonicalizeRelevantMemberConstraints csenv 0 tps) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -3404,7 +3414,7 @@ let IsApplicableMethApprox g amap m (minfo: MethInfo) availObjTy = match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> let reqdObjTy = if isByrefTy g reqdObjTy then destByrefTy g reqdObjTy else reqdObjTy // This is to support byref extension methods. - TryD (fun () -> SolveTypeSubsumesType csenv 0 m NoTrace None reqdObjTy availObjTy ++ (fun () -> ResultD true)) + TryD (fun () -> SolveTypeSubsumesType csenv 0 m None reqdObjTy availObjTy ++ (fun () -> ResultD true)) (fun _err -> ResultD false) |> CommitOperationResult | _ -> true diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 3bf22065f3d..adc5a7e2f61 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -152,21 +152,16 @@ type ConstraintSolverState = val BakedInTraitConstraintNames: Set -[] -type Trace - -type OptionalTrace = - | NoTrace - | WithTrace of Trace - val SimplifyMeasuresInTypeScheme: TcGlobals -> bool -> Typars -> TType -> TyparConstraint list -> Typars -val ResolveOverloadingForCall: DisplayEnv -> ConstraintSolverState -> range -> methodName: string -> ndeep: int -> callerArgs: CallerArgs -> AccessorDomain -> calledMethGroup: CalledMeth list -> permitOptArgs: bool -> reqdRetTyOpt: OverallTy option -> CalledMeth option * OperationResult +/// The entry point to resolve the overloading for an entire call +val ResolveOverloadingForCall: DisplayEnv -> ConstraintSolverState -> range -> methodName: string -> callerArgs: CallerArgs -> AccessorDomain -> calledMethGroup: CalledMeth list -> permitOptArgs: bool -> reqdRetTy: OverallTy -> CalledMeth option * OperationResult +/// The entry point to determine if there is a unique good overload that can be eagerly applied val UnifyUniqueOverloading: DisplayEnv -> ConstraintSolverState -> range -> int * int -> string -> AccessorDomain -> CalledMeth list -> OverallTy -> OperationResult /// Remove the global constraints where these type variables appear in the support of the constraint -val EliminateConstraintsForGeneralizedTypars: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> Typars -> unit +val EliminateConstraintsForGeneralizedTypars: DisplayEnv -> ConstraintSolverState -> range -> Typars -> unit val CheckDeclaredTypars: DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit @@ -179,31 +174,31 @@ val AddCxTypeEqualsTypeUndoIfFailedOrWarnings: DisplayEnv -> ConstraintSolverSta val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeMustSubsumeType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit +val AddCxTypeMustSubsumeType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit val AddCxTypeMustSubsumeTypeUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool val AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxMethodConstraint: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TraitConstraintInfo -> unit +val AddCxMethodConstraint: DisplayEnv -> ConstraintSolverState -> range -> TraitConstraintInfo -> unit -val AddCxTypeMustSupportNull: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportNull: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit -val AddCxTypeMustSupportComparison: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportComparison: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit -val AddCxTypeMustSupportEquality: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportEquality: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit -val AddCxTypeMustSupportDefaultCtor: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportDefaultCtor: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit -val AddCxTypeIsReferenceType: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsReferenceType: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit -val AddCxTypeIsValueType: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsValueType: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit -val AddCxTypeIsUnmanaged: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsUnmanaged: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit -val AddCxTypeIsEnum: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit +val AddCxTypeIsEnum: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit -val AddCxTypeIsDelegate: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit +val AddCxTypeIsDelegate: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> TType -> unit val AddCxTyparDefaultsTo: DisplayEnv -> ConstraintSolverState -> range -> ContextInfo -> Typar -> int -> TType -> unit diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 6881f8d43f2..a8c0c0285cd 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -395,13 +395,15 @@ let ComputeTypeAccess (tref: ILTypeRef) hidden = /// Indicates how type parameters are mapped to IL type variables [] -type TypeReprEnv(reprs: Map, count: int, templateReplacement: (TyconRef * ILType * TyparInst) option) = +type TypeReprEnv(reprs: Map, count: int, templateReplacement: (TyconRef * ILTypeRef * Typars * TyparInst) option) = static let empty = TypeReprEnv(count = 0, reprs = Map.empty, templateReplacement = None) + /// Get the template replacement information used when using struct types for state machines based on a "template" struct member __.TemplateReplacement = templateReplacement - member __.WithTemplateReplacement(tcref, ilty, tpinst) = TypeReprEnv(reprs, count, Some (tcref, ilty, tpinst)) + member __.WithTemplateReplacement(tcref, ilCloTyRef, cloFreeTyvars, templateTypeInst) = + TypeReprEnv(reprs, count, Some (tcref, ilCloTyRef, cloFreeTyvars, templateTypeInst)) /// Lookup a type parameter member _.Item (tp: Typar, m: range) = @@ -514,7 +516,10 @@ and GenILTyAppAux amap m tyenv (tref, boxity, ilTypeOpt) tinst = and GenNamedTyAppAux (amap: ImportMap) m (tyenv: TypeReprEnv) ptrsOK tcref tinst = let g = amap.g match tyenv.TemplateReplacement with - | Some (tcref2, ilty, _) when tyconRefEq g tcref tcref2 -> ilty + | Some (tcref2, ilCloTyRef, cloFreeTyvars, _) when tyconRefEq g tcref tcref2 -> + let cloInst = List.map mkTyparTy cloFreeTyvars + let ilTypeInst = GenTypeArgsAux amap m tyenv cloInst + mkILValueTy ilCloTyRef ilTypeInst | _ -> let tinst = DropErasedTyargs tinst // See above note on ptrsOK @@ -685,11 +690,25 @@ let GenFieldSpecForStaticField (isInteractive, g, ilContainerTy, vspec: Val, nm, let GenRecdFieldRef m cenv (tyenv: TypeReprEnv) (rfref: RecdFieldRef) tyargs = // Fixup references to the fields of a struct machine template + // templateStructTy = ResumableStateMachine + // templateTyconRef = ResumableStateMachine<'Data> + // templateTypeArgs = + // templateTypeInst = 'Data -> TaskStateMachineData + // cloFreeTyvars = <'FreeTyVars> + // ilCloTy = clo<'FreeTyVars> w.r.t envinner + // rfref = ResumableStateMachine<'Data>::Result + // rfref.RecdField.FormalType = 'Data match tyenv.TemplateReplacement with - | Some (tcref2, ilty, inst) when tyconRefEq cenv.g rfref.TyconRef tcref2 -> - mkILFieldSpecInTy(ilty, + | Some (tcref2, ilCloTyRef, cloFreeTyvars, templateTypeInst) when tyconRefEq cenv.g rfref.TyconRef tcref2 -> + let ilCloTy = + let cloInst = List.map mkTyparTy cloFreeTyvars + let ilTypeInst = GenTypeArgsAux cenv.amap m tyenv cloInst + mkILValueTy ilCloTyRef ilTypeInst + + let tyenvinner = TypeReprEnv.Empty.ForTypars cloFreeTyvars + mkILFieldSpecInTy(ilCloTy, ComputeFieldName rfref.Tycon rfref.RecdField, - GenType cenv.amap m tyenv (instType inst rfref.RecdField.FormalType)) + GenType cenv.amap m tyenvinner (instType templateTypeInst rfref.RecdField.FormalType)) | _ -> let tyenvinner = TypeReprEnv.Empty.ForTycon rfref.Tycon let ilty = GenTyApp cenv.amap m tyenv rfref.TyconRef.CompiledRepresentation tyargs @@ -1094,8 +1113,8 @@ let AddStorageForVal (g: TcGlobals) (v, s) eenv = let AddStorageForLocalVals g vals eenv = List.foldBack (fun (v, s) acc -> AddStorageForVal g (v, notlazy s) acc) vals eenv -let AddTemplateReplacement eenv (tcref, ilty, inst) = - { eenv with tyenv = eenv.tyenv.WithTemplateReplacement (tcref, ilty, inst) } +let AddTemplateReplacement eenv (tcref, ftyvs, ilty, inst) = + { eenv with tyenv = eenv.tyenv.WithTemplateReplacement (tcref, ftyvs, ilty, inst) } let AddStorageForLocalWitness eenv (w,s) = { eenv with witnessesInScope = eenv.witnessesInScope.SetItem (w, s) } @@ -4833,7 +4852,8 @@ and GenStructStateMachine cenv cgbuf eenvouter (res: LoweredStateMachine) sequel let templateTyconRef, templateTypeArgs = destAppTy g templateStructTy let templateTypeInst = mkTyconRefInst templateTyconRef templateTypeArgs - let eenvinner = AddTemplateReplacement eenvinner (templateTyconRef, ilCloTy, templateTypeInst) + let eenvinner = + AddTemplateReplacement eenvinner (templateTyconRef, ilCloTypeRef, cloinfo.cloFreeTyvars, templateTypeInst) let infoReader = InfoReader.InfoReader(g, cenv.amap) @@ -4949,13 +4969,15 @@ and GenStructStateMachine cenv cgbuf eenvouter (res: LoweredStateMachine) sequel CountClosure() LocalScope "machine" cgbuf (fun scopeMarks -> + let eenvouter = AddTemplateReplacement eenvouter (templateTyconRef, ilCloTypeRef, cloinfo.cloFreeTyvars, templateTypeInst) let ilMachineAddrTy = ILType.Byref ilCloTy // The local for the state machine - let locIdx, realloc, _ = AllocLocal cenv cgbuf eenvinner true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName ("machine", m), ilCloTy, false) scopeMarks + let locIdx, realloc, _ = AllocLocal cenv cgbuf eenvouter true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName ("machine", m), ilCloTy, false) scopeMarks // The local for the state machine address - let locIdx2, _realloc2, _ = AllocLocal cenv cgbuf eenvinner true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName (afterCodeThisVar.DisplayName, m), ilMachineAddrTy, false) scopeMarks + let locIdx2, _realloc2, _ = AllocLocal cenv cgbuf eenvouter true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName (afterCodeThisVar.DisplayName, m), ilMachineAddrTy, false) scopeMarks + let eenvouter = eenvouter |> AddStorageForLocalVals g [(afterCodeThisVar, Local (locIdx2, realloc, None)) ] // Zero-initialize the machine EmitInitLocal cgbuf ilCloTy locIdx @@ -4964,8 +4986,6 @@ and GenStructStateMachine cenv cgbuf eenvouter (res: LoweredStateMachine) sequel CG.EmitInstr cgbuf (pop 0) (Push [ ilMachineAddrTy ]) (I_ldloca (uint16 locIdx) ) CG.EmitInstr cgbuf (pop 1) (Push [ ]) (I_stloc (uint16 locIdx2) ) - let eenvinner = eenvinner |> AddStorageForLocalVals g [(afterCodeThisVar, Local (locIdx2, realloc, None)) ] - // Initialize the closure variables for fv, ilv in Seq.zip cloFreeVars cloinfo.ilCloAllFreeVars do if stateVarsSet.Contains fv then @@ -4980,8 +5000,8 @@ and GenStructStateMachine cenv cgbuf eenvouter (res: LoweredStateMachine) sequel GenGetLocalVal cenv cgbuf eenvouter m fv None CG.EmitInstr cgbuf (pop 2) (Push [ ]) (mkNormalStfld (mkILFieldSpecInTy (ilCloTy, ilv.fvName, ilv.fvType))) - // Generate the start expression - eenvinner is used as it contains the binding for machineAddrVar - GenExpr cenv cgbuf eenvinner SPSuppress afterCodeBody sequel + // Generate the start expression + GenExpr cenv cgbuf eenvouter SPSuppress afterCodeBody sequel ) diff --git a/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs b/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs index b6a209b17be..dcbf6b9e28e 100644 --- a/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs +++ b/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs @@ -1057,36 +1057,266 @@ let testTask() = task { while x > 4 do System.Console.WriteLine("loop") } """ ]) - // This tests the exact optimized code generated for the MoveNext for a trivial task - we expect 'MoveNext' to be there - // because state machine compilation succeeds - // - // The code is not perfect - because the MoveNext is generated late - but the JIT does a good job on it. - // - // The try/catch for the task still exists even though there is no chance of an exception - // - // The crucial code for "return 1" is really just - // IL_000e: ldc.i4.1 - // IL_000f: stfld int32 Test/testTask@4::Result - + // This tests the compilation of a case that hits corner cases in SRTP constraint processing. + // See https://github.com/dotnet/fsharp/issues/12188 [] - let ``check compile of SRTP task code ``() = + let ``check initially ambiguous SRTP task code ``() = CompilerAssert.CompileExeAndRunWithOptions [| "/langversion:preview";"/optimize-";"/debug:portable";"/tailcalls-" |] """ module Test open System.Threading.Tasks -let myFunction (f: string -> _, i: 'T) = +let myFunction (f: string -> _, _i: 'T) = task { do! f "" return () } -[] -let main argv = - let myTuple : (string -> Task) * int = (fun (s: string) -> Task.FromResult()), 1 - myFunction myTuple +let myTuple : (string -> Task) * int = (fun (_s: string) -> Task.FromResult()), 1 +(myFunction myTuple).Wait() + """ + + // Test task code in generic position + [] + let ``check generic task code ``() = + CompilerAssert.CompileExeAndRunWithOptions [| "/langversion:preview";"/optimize-";"/debug:portable";"/tailcalls-" |] + """ +module Test + +open System.Threading.Tasks + +type Generic1InGeneric1<'T>() = + let run (computation: Task<'A>) = + task { return! computation } + + member _.Run() = run (Task.FromResult 3) + +type Generic2InGeneric1<'T1, 'T2>() = + let run (computation: Task<'A>) = + task { return! computation } + + member _.Run() = run (Task.FromResult 3) + +let checkEquals s e a = if e = a then printfn $"test '{s}' passed" else failwith $"test '{s}' failed!, expected {e} got {a}" +Generic1InGeneric1().Run().Result |> checkEquals "cwewe21" 3 +Generic1InGeneric1().Run().Result |> checkEquals "cwewe22" 3 +Generic2InGeneric1().Run().Result |> checkEquals "cwewe23" 3 +Generic2InGeneric1().Run().Result |> checkEquals "cwewe24" 3 +printfn "test passed" + """ + + + [] + let ``check generic task exact code``() = + CompilerAssert.CompileLibraryAndVerifyILWithOptions [| "/langversion:preview";"/optimize-";"/debug:portable";"/tailcalls-" |] + """ +module Test + +open System.Threading.Tasks +type Generic1InGeneric1<'T>() = + let run (computation: Task<'A>) = + task { return! computation } + + member _.Run() = run (Task.FromResult 3) + """ + (fun verifier -> verifier.VerifyIL [ + """ +.method assembly hidebysig instance class [runtime]System.Threading.Tasks.Task`1 + run(class [runtime]System.Threading.Tasks.Task`1 computation) cil managed +{ + .custom instance void [runtime]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + + .maxstack 4 + .locals init (valuetype Test/clo@7 V_0, + valuetype Test/clo@7& V_1) + IL_0000: ldloca.s V_0 + IL_0002: initobj valuetype Test/clo@7 + IL_0008: ldloca.s V_0 + IL_000a: stloc.1 + IL_000b: ldloc.1 + IL_000c: ldarg.1 + IL_000d: stfld class [runtime]System.Threading.Tasks.Task`1 valuetype Test/clo@7::computation + IL_0012: ldloc.1 + IL_0013: ldflda valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1 valuetype Test/clo@7::Data + IL_0018: call valuetype [netstandard]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1 valuetype [netstandard]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1::Create() + IL_001d: stfld valuetype [runtime]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1 valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1::MethodBuilder + IL_0022: ldloc.1 + IL_0023: ldflda valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1 valuetype Test/clo@7::Data + IL_0028: ldflda valuetype [runtime]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1 valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1::MethodBuilder + IL_002d: ldloc.1 + IL_002e: call instance void valuetype [netstandard]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1::Start>(!!0&) + IL_0033: ldloc.1 + IL_0034: ldflda valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1 valuetype Test/clo@7::Data + IL_0039: ldflda valuetype [runtime]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1 valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1::MethodBuilder + IL_003e: call instance class [netstandard]System.Threading.Tasks.Task`1 valuetype [netstandard]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1::get_Task() + IL_0043: ret +} + + """ + """ + .method public strict virtual instance void + MoveNext() cil managed + { + .override [runtime]System.Runtime.CompilerServices.IAsyncStateMachine::MoveNext + + .maxstack 5 + .locals init (int32 V_0, + class [runtime]System.Exception V_1, + bool V_2, + class [runtime]System.Threading.Tasks.Task`1 V_3, + bool V_4, + bool V_5, + !A V_6, + !A V_7, + valuetype [runtime]System.Runtime.CompilerServices.TaskAwaiter`1 V_8, + class [runtime]System.Exception V_9, + class [runtime]System.Exception V_10) + IL_0000: ldarg.0 + IL_0001: ldfld int32 valuetype Test/clo@7::ResumptionPoint + IL_0006: stloc.0 + IL_0007: ldloc.0 + IL_0008: ldc.i4.1 + IL_0009: sub + IL_000a: switch ( + IL_0015) + IL_0013: br.s IL_0018 + + IL_0015: nop + IL_0016: br.s IL_001b + + IL_0018: nop + IL_0019: ldnull + IL_001a: stloc.1 + .try + { + IL_001b: ldloc.0 + IL_001c: ldc.i4.1 + IL_001d: sub + IL_001e: switch ( + IL_0029) + IL_0027: br.s IL_002c + + IL_0029: nop + IL_002a: br.s IL_0055 + + IL_002c: nop + IL_002d: ldarg.0 + IL_002e: ldfld class [runtime]System.Threading.Tasks.Task`1 valuetype Test/clo@7::computation + IL_0033: stloc.3 + IL_0034: ldarg.0 + IL_0035: ldloc.3 + IL_0036: callvirt instance valuetype [netstandard]System.Runtime.CompilerServices.TaskAwaiter`1 class [netstandard]System.Threading.Tasks.Task`1::GetAwaiter() + IL_003b: stfld valuetype [runtime]System.Runtime.CompilerServices.TaskAwaiter`1 valuetype Test/clo@7::awaiter + IL_0040: ldc.i4.1 + IL_0041: stloc.s V_4 + IL_0043: ldarg.0 + IL_0044: ldflda valuetype [runtime]System.Runtime.CompilerServices.TaskAwaiter`1 valuetype Test/clo@7::awaiter + IL_0049: call instance bool valuetype [netstandard]System.Runtime.CompilerServices.TaskAwaiter`1::get_IsCompleted() + IL_004e: brfalse.s IL_0052 + + IL_0050: br.s IL_006b + + IL_0052: ldc.i4.0 + IL_0053: brfalse.s IL_0059 + + IL_0055: ldc.i4.1 + IL_0056: nop + IL_0057: br.s IL_0062 + + IL_0059: ldarg.0 + IL_005a: ldc.i4.1 + IL_005b: stfld int32 valuetype Test/clo@7::ResumptionPoint + IL_0060: ldc.i4.0 + IL_0061: nop + IL_0062: stloc.s V_5 + IL_0064: ldloc.s V_5 + IL_0066: stloc.s V_4 + IL_0068: nop + IL_0069: br.s IL_006c + + IL_006b: nop + IL_006c: ldloc.s V_4 + IL_006e: brfalse.s IL_0092 + + IL_0070: ldarg.0 + IL_0071: ldflda valuetype [runtime]System.Runtime.CompilerServices.TaskAwaiter`1 valuetype Test/clo@7::awaiter + IL_0076: call instance !0 valuetype [netstandard]System.Runtime.CompilerServices.TaskAwaiter`1::GetResult() + IL_007b: stloc.s V_6 + IL_007d: ldloc.s V_6 + IL_007f: stloc.s V_7 + IL_0081: ldarg.0 + IL_0082: ldflda valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1 valuetype Test/clo@7::Data + IL_0087: ldloc.s V_7 + IL_0089: stfld !0 valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1::Result + IL_008e: ldc.i4.1 + IL_008f: nop + IL_0090: br.s IL_00ab + + IL_0092: ldarg.0 + IL_0093: ldflda valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1 valuetype Test/clo@7::Data + IL_0098: ldflda valuetype [runtime]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1 valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1::MethodBuilder + IL_009d: ldarg.0 + IL_009e: ldflda valuetype [runtime]System.Runtime.CompilerServices.TaskAwaiter`1 valuetype Test/clo@7::awaiter + IL_00a3: ldarg.0 + IL_00a4: call instance void valuetype [netstandard]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1::AwaitUnsafeOnCompleted,valuetype Test/clo@7>(!!0&, + !!1&) + IL_00a9: ldc.i4.0 + IL_00aa: nop + IL_00ab: brfalse.s IL_00b9 + + IL_00ad: ldarg.0 + IL_00ae: ldloc.s V_8 + IL_00b0: stfld valuetype [runtime]System.Runtime.CompilerServices.TaskAwaiter`1 valuetype Test/clo@7::awaiter + IL_00b5: ldc.i4.1 + IL_00b6: nop + IL_00b7: br.s IL_00bb + + IL_00b9: ldc.i4.0 + IL_00ba: nop + IL_00bb: stloc.2 + IL_00bc: ldloc.2 + IL_00bd: brfalse.s IL_00dc + + IL_00bf: ldarg.0 + IL_00c0: ldflda valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1 valuetype Test/clo@7::Data + IL_00c5: ldflda valuetype [runtime]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1 valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1::MethodBuilder + IL_00ca: ldarg.0 + IL_00cb: ldflda valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1 valuetype Test/clo@7::Data + IL_00d0: ldfld !0 valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1::Result + IL_00d5: call instance void valuetype [netstandard]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1::SetResult(!0) + IL_00da: leave.s IL_00ea + + IL_00dc: leave.s IL_00ea + + } + catch [runtime]System.Object + { + IL_00de: castclass [runtime]System.Exception + IL_00e3: stloc.s V_9 + IL_00e5: ldloc.s V_9 + IL_00e7: stloc.1 + IL_00e8: leave.s IL_00ea + + } + IL_00ea: ldloc.1 + IL_00eb: stloc.s V_10 + IL_00ed: ldloc.s V_10 + IL_00ef: brtrue.s IL_00f2 + + IL_00f1: ret + + IL_00f2: ldarg.0 + IL_00f3: ldflda valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1 valuetype Test/clo@7::Data + IL_00f8: ldflda valuetype [runtime]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1 valuetype [FSharp.Core]Microsoft.FSharp.Control.TaskStateMachineData`1::MethodBuilder + IL_00fd: ldloc.s V_10 + IL_00ff: call instance void valuetype [netstandard]System.Runtime.CompilerServices.AsyncTaskMethodBuilder`1::SetException(class [netstandard]System.Exception) + IL_0104: ret + } + + """ + ]) #endif diff --git a/tests/fsharp/Compiler/Language/OpenTypeDeclarationTests.fs b/tests/fsharp/Compiler/Language/OpenTypeDeclarationTests.fs index 7d04809e436..39936bb01f1 100644 --- a/tests/fsharp/Compiler/Language/OpenTypeDeclarationTests.fs +++ b/tests/fsharp/Compiler/Language/OpenTypeDeclarationTests.fs @@ -784,7 +784,7 @@ module Test = """ |> withLangVersion50 |> compile - |> withErrorCode 1 + |> withErrorCode 193 |> ignore [] diff --git a/tests/fsharp/core/auto-widen/5.0/test.bsl b/tests/fsharp/core/auto-widen/5.0/test.bsl index 9aac4fe55fb..2c197316bec 100644 --- a/tests/fsharp/core/auto-widen/5.0/test.bsl +++ b/tests/fsharp/core/auto-widen/5.0/test.bsl @@ -9,10 +9,7 @@ test.fsx(14,20,14,41): typecheck error FS0001: This expression was expected to h but here has type 'int' -test.fsx(17,20,17,44): typecheck error FS0001: This expression was expected to have type - 'obj' -but here has type - 'int' +test.fsx(17,20,17,44): typecheck error FS0193: The type 'obj' does not match the type 'int' test.fsx(20,21,20,24): typecheck error FS0001: This expression was expected to have type 'obj' @@ -264,7 +261,7 @@ is not compatible with type 'C' -test.fsx(172,18,172,21): typecheck error FS0001: The type 'Y' is not compatible with the type 'X' +test.fsx(172,18,172,21): typecheck error FS0193: The type 'Y' is not compatible with the type 'X' test.fsx(172,17,172,22): typecheck error FS0193: Type constraint mismatch. The type 'Y' @@ -463,20 +460,11 @@ test.fsx(263,44,263,63): typecheck error FS0001: This expression was expected to but here has type 'string' -test.fsx(266,44,266,68): typecheck error FS0001: This expression was expected to have type - 'IComparable' -but here has type - 'string' +test.fsx(266,44,266,68): typecheck error FS0193: The type 'IComparable' does not match the type 'string' -test.fsx(268,21,268,45): typecheck error FS0001: This expression was expected to have type - 'obj' -but here has type - 'string' +test.fsx(268,21,268,45): typecheck error FS0193: The type 'obj' does not match the type 'string' -test.fsx(270,36,270,60): typecheck error FS0001: This expression was expected to have type - 'IComparable' -but here has type - 'string' +test.fsx(270,36,270,60): typecheck error FS0193: The type 'IComparable' does not match the type 'string' test.fsx(275,35,275,36): typecheck error FS0001: This expression was expected to have type 'obj' From a8e9e18210b17e3a83c325b2e28ffc7e89ce89ef Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 01:22:06 +0100 Subject: [PATCH 03/14] fix 12189 - bad codegen for tasks. Also eliminate 'trace' parameter and put it in the constraint solver context instead --- src/fsharp/CheckDeclarations.fs | 2 +- src/fsharp/ConstraintSolver.fsi | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/fsharp/CheckDeclarations.fs b/src/fsharp/CheckDeclarations.fs index c123e30e2b2..5a9d8612b18 100644 --- a/src/fsharp/CheckDeclarations.fs +++ b/src/fsharp/CheckDeclarations.fs @@ -5878,7 +5878,7 @@ let TypeCheckOneImplFile // Run any additional checks registered to be run before applying defaults conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - for check in cenv.css.GetPostInferenceChecksFinal() do + for check in cenv.css.GetPostInferenceChecksPreDefaults() do try check() with e -> diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index adc5a7e2f61..0aab939ebf0 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -144,12 +144,12 @@ type ConstraintSolverState = /// Add a post-inference check to run at the end of inference member AddPostInferenceCheck: preDefaults: bool * check: (unit -> unit) -> unit + /// Get the post-inference checks to run near the end of inference, but before defaults are applied + member GetPostInferenceChecksPreDefaults: unit -> seq unit> + /// Get the post-inference checks to run at the end of inference member GetPostInferenceChecksFinal: unit -> seq unit> - /// Get the post-inference checks to run at the end of inference but before defaults are applied - member GetPostInferenceChecksPreDefaults: unit -> seq unit> - val BakedInTraitConstraintNames: Set val SimplifyMeasuresInTypeScheme: TcGlobals -> bool -> Typars -> TType -> TyparConstraint list -> Typars From 6b2d55af7a944ada7ed59d52bb992243a782af89 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 01:28:36 +0100 Subject: [PATCH 04/14] fix 12189 - bad codegen for tasks. Also eliminate 'trace' parameter and put it in the constraint solver context instead --- src/fsharp/CheckDeclarations.fs | 12 ++++++------ src/fsharp/CheckExpressions.fs | 16 +++++----------- src/fsharp/ConstraintSolver.fs | 25 +++++++++++++------------ src/fsharp/ConstraintSolver.fsi | 2 +- 4 files changed, 25 insertions(+), 30 deletions(-) diff --git a/src/fsharp/CheckDeclarations.fs b/src/fsharp/CheckDeclarations.fs index 5a9d8612b18..f56486363c9 100644 --- a/src/fsharp/CheckDeclarations.fs +++ b/src/fsharp/CheckDeclarations.fs @@ -5877,12 +5877,12 @@ let TypeCheckOneImplFile let extraAttribs = topAttrs.mainMethodAttrs@topAttrs.netModuleAttrs@topAttrs.assemblyAttrs // Run any additional checks registered to be run before applying defaults - conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - for check in cenv.css.GetPostInferenceChecksPreDefaults() do - try - check() - with e -> - errorRecovery e m) + do + for check in cenv.css.GetPostInferenceChecksPreDefaults() do + try + check() + with e -> + errorRecovery e m conditionallySuppressErrorReporting (checkForErrors()) (fun () -> ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs) diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index 096e7709ad9..146087db583 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -448,14 +448,8 @@ type cenv = TcFileState let CopyAndFixupTypars m rigid tpsorig = FreshenAndFixupTypars m rigid [] [] tpsorig -let UnifyTypesAux cenv (env: TcEnv) canPostpone m actualTy expectedTy = - AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css canPostpone m (tryNormalizeMeasureInType cenv.g actualTy) (tryNormalizeMeasureInType cenv.g expectedTy) - -let UnifyTypes cenv env m actualTy expectedTy = - UnifyTypesAux cenv env true m actualTy expectedTy - -let UnifyTypesNoPostpone cenv env m actualTy expectedTy = - UnifyTypesAux cenv env false m actualTy expectedTy +let UnifyTypes cenv (env: TcEnv) m actualTy expectedTy = + AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g actualTy) (tryNormalizeMeasureInType cenv.g expectedTy) // If the overall type admits subsumption or type directed conversion, and the original unify would have failed, // then allow subsumption or type directed conversion. @@ -618,7 +612,7 @@ let UnifyRefTupleType contextInfo cenv denv m ty ps = | ContextInfo.RecordFields -> ContextInfo.TupleInRecordFields | _ -> contextInfo - AddCxTypeEqualsType contextInfo denv cenv.css true m ty (TType_tuple (tupInfoRef, ptys)) + AddCxTypeEqualsType contextInfo denv cenv.css m ty (TType_tuple (tupInfoRef, ptys)) ptys /// Allow the inference of structness from the known type, e.g. @@ -641,7 +635,7 @@ let UnifyTupleTypeAndInferCharacteristics contextInfo cenv denv m knownTy isExpl | _ -> contextInfo let ty2 = TType_tuple (tupInfo, ptys) - AddCxTypeEqualsType contextInfo denv cenv.css true m knownTy ty2 + AddCxTypeEqualsType contextInfo denv cenv.css m knownTy ty2 tupInfo, ptys // Allow inference of assembly-affinity and structness from the known type - even from another assembly. This is a rule of @@ -664,7 +658,7 @@ let UnifyAnonRecdTypeAndInferCharacteristics contextInfo cenv denv m ty isExplic let anonInfo = AnonRecdTypeInfo.Create(cenv.topCcu, mkTupInfo isExplicitStruct, unsortedNames) anonInfo, NewInferenceTypes (Array.toList anonInfo.SortedNames) let ty2 = TType_anon (anonInfo, ptys) - AddCxTypeEqualsType contextInfo denv cenv.css true m ty ty2 + AddCxTypeEqualsType contextInfo denv cenv.css m ty ty2 anonInfo, ptys diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 4fd6db2880b..731e0d0633c 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -336,7 +336,7 @@ type ConstraintSolverEnv = Trace: OptionalTrace // Is this speculative, with a trace allowing undo, and trial method overload resolution - IsSpeculative: bool + IsSpeculativeForMethodOverloading: bool /// Indicates that when unifying ty1 = ty2, only type variables in ty1 may be solved MatchingOnly: bool @@ -365,11 +365,11 @@ let MakeConstraintSolverEnv contextInfo css m denv = m = m ContextInfo = contextInfo MatchingOnly = false - ThrowOnFailedMemberConstraintResolution = true + ThrowOnFailedMemberConstraintResolution = false EquivEnv = TypeEquivEnv.Empty DisplayEnv = denv Trace = NoTrace - IsSpeculative = true } + IsSpeculativeForMethodOverloading = false } /// Check whether a type variable occurs in the r.h.s. of a type, e.g. to catch /// infinite equations such as @@ -579,14 +579,16 @@ let IgnoreFailedMemberConstraintResolution f1 f2 = /// with 'ThrowOnFailedMemberConstraintResolution' set to false. let PostponeConstraintOnFailedMemberConstraintResolution (csenv: ConstraintSolverEnv) f1 f2 = TryD - (fun () -> f1 csenv) + (fun () -> + let csenv = { csenv with ThrowOnFailedMemberConstraintResolution = true } + f1 csenv) (function | AbortForFailedMemberConstraintResolution -> // Postponed checking of constraints for failed SRTP resolutions is supported from F# 6.0 onwards if csenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then csenv.SolverState.AddPostInferenceCheck (preDefaults=true, check = fun () -> - let csenv2 = { csenv with ThrowOnFailedMemberConstraintResolution = false } - f1 csenv2 |> RaiseOperationResult) + let csenv = { csenv with ThrowOnFailedMemberConstraintResolution = false } + f1 csenv |> RaiseOperationResult) CompleteD | exn -> f2 exn) @@ -2493,7 +2495,7 @@ and SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m cxsln t // Due to the legacy of the change https://github.com/dotnet/fsharp/pull/1650, // when doing nested, speculative overload resolution, we ignore failed member constraints and continue. The // constraint is not recorded for later solution. - if csenv.IsSpeculative then + if csenv.IsSpeculativeForMethodOverloading then IgnoreFailedMemberConstraintResolution (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m cxsln ty1 ty2) (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) @@ -2776,7 +2778,7 @@ and ResolveOverloading // and exact matches of argument types. let exactMatchCandidates = candidates |> FilterEachThenUndo (fun newTrace calledMeth -> - let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculative = true } + let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculativeForMethodOverloading = true } let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) CanMemberSigsMatchUpToCheck csenv @@ -2798,7 +2800,7 @@ and ResolveOverloading // Subsumption on arguments is allowed. let applicable = candidates |> FilterEachThenUndo (fun newTrace candidate -> - let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculative = true } + let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculativeForMethodOverloading = true } let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m candidate.Method candidate.CalledTyArgs)) CanMemberSigsMatchUpToCheck csenv @@ -2836,7 +2838,7 @@ and ResolveOverloading candidates |> List.choose (fun calledMeth -> let results = CollectThenUndo (fun newTrace -> - let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculative = true } + let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculativeForMethodOverloading = true } let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) CanMemberSigsMatchUpToCheck csenv @@ -3147,9 +3149,8 @@ let EliminateConstraintsForGeneralizedTypars denv css m (generalizedTypars: Typa // No error recovery here: we do that on a per-expression basis. //------------------------------------------------------------------------- -let AddCxTypeEqualsType contextInfo denv css canPostpone m actual expected = +let AddCxTypeEqualsType contextInfo denv css m actual expected = let csenv = MakeConstraintSolverEnv contextInfo css m denv - let csenv = if canPostpone then csenv else { csenv with ThrowOnFailedMemberConstraintResolution = false } PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeEqualsTypeWithReport csenv 0 m None actual expected) (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, actual, expected, res, m))) diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 0aab939ebf0..8998a16bf52 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -166,7 +166,7 @@ val EliminateConstraintsForGeneralizedTypars: DisplayEnv -> ConstraintSolverStat val CheckDeclaredTypars: DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit /// Unify the types. -val AddCxTypeEqualsType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> canPostpone: bool -> range -> TType -> TType -> unit +val AddCxTypeEqualsType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit val AddCxTypeEqualsTypeUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool From 91db2699fce3610099e98f01539cd9e92b205021 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 01:48:35 +0100 Subject: [PATCH 05/14] fix 12189 - bad codegen for tasks. Also eliminate 'trace' parameter and put it in the constraint solver context instead --- src/fsharp/CheckExpressions.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index 146087db583..8a8ce89fe17 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -479,7 +479,7 @@ let UnifyOverallType cenv (env: TcEnv) m overallTy actualTy = warning (Error(FSComp.SR.tcSubsumptionImplicitConversionUsed(actualTyText, reqdTyText), m)) else // Report the error. - UnifyTypesNoPostpone cenv env m reqdTy actualTy + UnifyTypes cenv env m reqdTy actualTy | _ -> UnifyTypes cenv env m overallTy.Commit actualTy From 42ee32229d60820144ef13668f5f02da17f9b681 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 11:46:32 +0100 Subject: [PATCH 06/14] cleanup and fix method arg lambda propagation rule --- src/fsharp/ConstraintSolver.fs | 418 +++++++++++++++++---------------- 1 file changed, 214 insertions(+), 204 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 731e0d0633c..c641b915305 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -341,9 +341,9 @@ type ConstraintSolverEnv = /// Indicates that when unifying ty1 = ty2, only type variables in ty1 may be solved MatchingOnly: bool - /// Indicates that local throws on unresolved SRTP constraint overloads may be generated. When + /// Indicates that special errors on unresolved SRTP constraint overloads may be generated. When /// these are caught they result in postponed constraints. - ThrowOnFailedMemberConstraintResolution: bool + ErrorOnFailedMemberConstraintResolution: bool m: range @@ -365,7 +365,7 @@ let MakeConstraintSolverEnv contextInfo css m denv = m = m ContextInfo = contextInfo MatchingOnly = false - ThrowOnFailedMemberConstraintResolution = false + ErrorOnFailedMemberConstraintResolution = false EquivEnv = TypeEquivEnv.Empty DisplayEnv = denv Trace = NoTrace @@ -566,7 +566,8 @@ let IgnoreFailedMemberConstraintResolution f1 f2 = | exn -> f2 exn) /// This is used at (nearly all) entry points into the constraint solver to make sure that the -/// AbortForFailedMemberConstraintResolution is caught, recorded as a post-inference check and processing continues. +/// AbortForFailedMemberConstraintResolution error result is caught, the constraint recorded +/// as a post-inference check and processing continues. /// /// Due to the legacy of the change https://github.com/dotnet/fsharp/pull/1650, some constraint /// applications must be allowed to "succeed" with partial processing of the unification being @@ -576,18 +577,18 @@ let IgnoreFailedMemberConstraintResolution f1 f2 = /// Quite a lot of code related to tasks has come to rely on this feature. /// /// To ensure soundness, we double-check the constraint at the end of inference -/// with 'ThrowOnFailedMemberConstraintResolution' set to false. +/// with 'ErrorOnFailedMemberConstraintResolution' set to false. let PostponeConstraintOnFailedMemberConstraintResolution (csenv: ConstraintSolverEnv) f1 f2 = TryD (fun () -> - let csenv = { csenv with ThrowOnFailedMemberConstraintResolution = true } + let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = true } f1 csenv) (function | AbortForFailedMemberConstraintResolution -> // Postponed checking of constraints for failed SRTP resolutions is supported from F# 6.0 onwards if csenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then csenv.SolverState.AddPostInferenceCheck (preDefaults=true, check = fun () -> - let csenv = { csenv with ThrowOnFailedMemberConstraintResolution = false } + let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = false } f1 csenv |> RaiseOperationResult) CompleteD | exn -> f2 exn) @@ -1307,7 +1308,7 @@ and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 ty = /// will deal with the problem. /// /// 2. Some additional solutions are forced prior to generalization (permitWeakResolution= Yes or YesDuringCodeGen). See above -and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemberConstraintResolution permitWeakResolution ndeep m2 traitInfo : OperationResult = trackErrors { +and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemberConstraintResolution permitWeakResolution ndeep m2 traitInfo : OperationResult = trackErrors { let (TTrait(tys, nm, memFlags, traitObjAndArgTys, rty, sln)) = traitInfo // Do not re-solve if already solved if sln.Value.IsSome then return true else @@ -1714,8 +1715,8 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressThrowOnFailedMemb match errors with | ErrorResult (_, UnresolvedOverloading _) when - not suppressThrowOnFailedMemberConstraintResolution && - csenv.ThrowOnFailedMemberConstraintResolution && + not suppressErrorOnFailedMemberConstraintResolution && + csenv.ErrorOnFailedMemberConstraintResolution && (not (nm = "op_Explicit" || nm = "op_Implicit")) -> return! ErrorD AbortForFailedMemberConstraintResolution | _ -> @@ -2364,7 +2365,7 @@ and CanMemberSigsMatchUpToCheck trackErrors { let g = csenv.g let amap = csenv.amap - let m = csenv.m + let m = csenv.m let minfo = calledMeth.Method let minst = calledMeth.CalledTyArgs @@ -2613,7 +2614,7 @@ and ArgsEquivOrConvert (csenv: ConstraintSolverEnv) ad ndeep cxsln isConstraint and ReportNoCandidatesError (csenv: ConstraintSolverEnv) (nUnnamedCallerArgs, nNamedCallerArgs) methodName ad (calledMethGroup: CalledMeth<_> list) isSequential = let amap = csenv.amap - let m = csenv.m + let m = csenv.m let denv = csenv.DisplayEnv let infoReader = csenv.InfoReader @@ -2732,6 +2733,180 @@ and ReportNoCandidatesErrorSynExpr csenv callerArgCounts methodName ad calledMet let isSequential e = match e with | SynExpr.Sequential _ -> true | _ -> false ReportNoCandidatesError csenv callerArgCounts methodName ad calledMethGroup isSequential +// Note: Relies on 'compare' respecting true > false +and compareCond (p: 'T -> 'T -> bool) x1 x2 = + compare (p x1 x2) (p x2 x1) + +/// Compare types under the feasibly-subsumes ordering +and CompareArgTypesForOverloadingPreference (csenv: ConstraintSolverEnv) ndeep m ty1 ty2 = + (ty1, ty2) ||> compareCond (fun x1 x2 -> TypeFeasiblySubsumesType ndeep csenv.g csenv.amap m x2 CanCoerce x1) + +/// Compare arguments under the feasibly-subsumes ordering and the adhoc Func-is-better-than-other-delegates rule +and CompareArgsForOverloadingPreference (csenv: ConstraintSolverEnv) ndeep m (calledArg1: CalledArg) (calledArg2: CalledArg) = + let g = csenv.g + let c = CompareArgTypesForOverloadingPreference csenv ndeep m calledArg1.CalledArgumentType calledArg2.CalledArgumentType + if c <> 0 then c else + + let c = + (calledArg1.CalledArgumentType, calledArg2.CalledArgumentType) ||> compareCond (fun ty1 ty2 -> + + // Func<_> is always considered better than any other delegate type + match tryTcrefOfAppTy csenv.g ty1 with + | ValueSome tcref1 when + tcref1.DisplayName = "Func" && + (match tcref1.PublicPath with Some p -> p.EnclosingPath = [| "System" |] | _ -> false) && + isDelegateTy g ty1 && + isDelegateTy g ty2 -> true + + // T is always better than inref + | _ when isInByrefTy csenv.g ty2 && typeEquiv csenv.g ty1 (destByrefTy csenv.g ty2) -> + true + + // T is always better than Nullable from F# 5.0 onwards + | _ when g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) && + isNullableTy csenv.g ty2 && + typeEquiv csenv.g ty1 (destNullableTy csenv.g ty2) -> + true + + | _ -> false) + + if c <> 0 then c else + 0 + +/// Check whether one overload is better than another +and CompareMethodsForOverloadingPreference + (csenv: ConstraintSolverEnv) + ndeep // Depth of inference + (candidate: CalledMeth<_>, candidateWarnings, usesTDC1) + (other: CalledMeth<_>, otherWarnings, usesTDC2) = + let g = csenv.g + let m = csenv.m + // Compare two things by the given predicate. + // If the predicate returns true for x1 and false for x2, then x1 > x2 + // If the predicate returns false for x1 and true for x2, then x1 < x2 + // Otherwise x1 = x2 + + let candidateWarnCount = List.length candidateWarnings + let otherWarnCount = List.length otherWarnings + + // Prefer methods that don't use type-directed conversion + let c = compare (match usesTDC1 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) (match usesTDC2 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) + if c <> 0 then c else + + // Prefer methods that don't give "this code is less generic" warnings + // Note: Relies on 'compare' respecting true > false + let c = compare (candidateWarnCount = 0) (otherWarnCount = 0) + if c <> 0 then c else + + // Prefer methods that don't use param array arg + // Note: Relies on 'compare' respecting true > false + let c = compare (not candidate.UsesParamArrayConversion) (not other.UsesParamArrayConversion) + if c <> 0 then c else + + // Prefer methods with more precise param array arg type + let c = + if candidate.UsesParamArrayConversion && other.UsesParamArrayConversion then + CompareArgTypesForOverloadingPreference csenv ndeep m (candidate.GetParamArrayElementType()) (other.GetParamArrayElementType()) + else + 0 + if c <> 0 then c else + + // Prefer methods that don't use out args + // Note: Relies on 'compare' respecting true > false + let c = compare (not candidate.HasOutArgs) (not other.HasOutArgs) + if c <> 0 then c else + + // Prefer methods that don't use optional args + // Note: Relies on 'compare' respecting true > false + let c = compare (not candidate.HasOptArgs) (not other.HasOptArgs) + if c <> 0 then c else + + // Check regular unnamed args. The argument counts will only be different if one is using param args + let c = + if candidate.TotalNumUnnamedCalledArgs = other.TotalNumUnnamedCalledArgs then + // For extension members, we also include the object argument type, if any in the comparison set + // This matches C#, where all extension members are treated and resolved as "static" methods calls + let cs = + (if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then + let objArgTys1 = candidate.CalledObjArgTys(m) + let objArgTys2 = other.CalledObjArgTys(m) + if objArgTys1.Length = objArgTys2.Length then + List.map2 (CompareArgTypesForOverloadingPreference csenv ndeep m) objArgTys1 objArgTys2 + else + [] + else + []) @ + ((candidate.AllUnnamedCalledArgs, other.AllUnnamedCalledArgs) ||> List.map2 (CompareArgsForOverloadingPreference csenv ndeep m)) + // "all args are at least as good, and one argument is actually better" + if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then + 1 + // "all args are at least as bad, and one argument is actually worse" + elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then + -1 + // "argument lists are incomparable" + else + 0 + else + 0 + if c <> 0 then c else + + // Prefer non-extension methods + let c = compare (not candidate.Method.IsExtensionMember) (not other.Method.IsExtensionMember) + if c <> 0 then c else + + // Between extension methods, prefer most recently opened + let c = + if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then + compare candidate.Method.ExtensionMemberPriority other.Method.ExtensionMemberPriority + else + 0 + if c <> 0 then c else + + // Prefer non-generic methods + // Note: Relies on 'compare' respecting true > false + let c = compare candidate.CalledTyArgs.IsEmpty other.CalledTyArgs.IsEmpty + if c <> 0 then c else + + // F# 5.0 rule - prior to F# 5.0 named arguments (on the caller side) were not being taken + // into account when comparing overloads. So adding a name to an argument might mean + // overloads ould no longer be distinguished. We thus look at *all* arguments (whether + // optional or not) as an additional comparison technique. + let c = + if g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) then + let cs = + let args1 = candidate.AllCalledArgs |> List.concat + let args2 = other.AllCalledArgs |> List.concat + if args1.Length = args2.Length then + (args1, args2) ||> List.map2 (CompareArgsForOverloadingPreference csenv ndeep m) + else + [] + // "all args are at least as good, and one argument is actually better" + if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then + 1 + // "all args are at least as bad, and one argument is actually worse" + elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then + -1 + // "argument lists are incomparable" + else + 0 + else + 0 + if c <> 0 then c else + + 0 + +/// Check whether one overload is better than another +and ChooseBestMethodsForOverloading (csenv: ConstraintSolverEnv) ndeep applicableMeths = + let indexedApplicableMeths = applicableMeths |> List.indexed + indexedApplicableMeths |> List.choose (fun (i, candidate) -> + if indexedApplicableMeths |> List.forall (fun (j, other) -> + i = j || + let res = CompareMethodsForOverloadingPreference csenv ndeep candidate other + res > 0) then + Some candidate + else + None) + // Resolve the overloading of a method // This is used after analyzing the types of arguments and ResolveOverloading @@ -2748,7 +2923,7 @@ and ResolveOverloading = let g = csenv.g let infoReader = csenv.InfoReader - let m = csenv.m + let m = csenv.m let denv = csenv.DisplayEnv let isOpConversion = methodName = "op_Explicit" || methodName = "op_Implicit" // See what candidates we have based on name and arity @@ -2862,171 +3037,7 @@ and ResolveOverloading | applicableMeths -> - /// Compare two things by the given predicate. - /// If the predicate returns true for x1 and false for x2, then x1 > x2 - /// If the predicate returns false for x1 and true for x2, then x1 < x2 - /// Otherwise x1 = x2 - - // Note: Relies on 'compare' respecting true > false - let compareCond (p: 'T -> 'T -> bool) x1 x2 = - compare (p x1 x2) (p x2 x1) - - /// Compare types under the feasibly-subsumes ordering - let compareTypes ty1 ty2 = - (ty1, ty2) ||> compareCond (fun x1 x2 -> TypeFeasiblySubsumesType ndeep csenv.g csenv.amap m x2 CanCoerce x1) - - /// Compare arguments under the feasibly-subsumes ordering and the adhoc Func-is-better-than-other-delegates rule - let compareArg (calledArg1: CalledArg) (calledArg2: CalledArg) = - let c = compareTypes calledArg1.CalledArgumentType calledArg2.CalledArgumentType - if c <> 0 then c else - - let c = - (calledArg1.CalledArgumentType, calledArg2.CalledArgumentType) ||> compareCond (fun ty1 ty2 -> - - // Func<_> is always considered better than any other delegate type - match tryTcrefOfAppTy csenv.g ty1 with - | ValueSome tcref1 when - tcref1.DisplayName = "Func" && - (match tcref1.PublicPath with Some p -> p.EnclosingPath = [| "System" |] | _ -> false) && - isDelegateTy g ty1 && - isDelegateTy g ty2 -> true - - // T is always better than inref - | _ when isInByrefTy csenv.g ty2 && typeEquiv csenv.g ty1 (destByrefTy csenv.g ty2) -> - true - - // T is always better than Nullable from F# 5.0 onwards - | _ when g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) && - isNullableTy csenv.g ty2 && - typeEquiv csenv.g ty1 (destNullableTy csenv.g ty2) -> - true - - | _ -> false) - - if c <> 0 then c else - 0 - - /// Check whether one overload is better than another - let better (candidate: CalledMeth<_>, candidateWarnings, usesTDC1) (other: CalledMeth<_>, otherWarnings, usesTDC2) = - let candidateWarnCount = List.length candidateWarnings - let otherWarnCount = List.length otherWarnings - - // Prefer methods that don't use type-directed conversion - let c = compare (match usesTDC1 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) (match usesTDC2 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) - if c <> 0 then c else - - // Prefer methods that don't give "this code is less generic" warnings - // Note: Relies on 'compare' respecting true > false - let c = compare (candidateWarnCount = 0) (otherWarnCount = 0) - if c <> 0 then c else - - // Prefer methods that don't use param array arg - // Note: Relies on 'compare' respecting true > false - let c = compare (not candidate.UsesParamArrayConversion) (not other.UsesParamArrayConversion) - if c <> 0 then c else - - // Prefer methods with more precise param array arg type - let c = - if candidate.UsesParamArrayConversion && other.UsesParamArrayConversion then - compareTypes (candidate.GetParamArrayElementType()) (other.GetParamArrayElementType()) - else - 0 - if c <> 0 then c else - - // Prefer methods that don't use out args - // Note: Relies on 'compare' respecting true > false - let c = compare (not candidate.HasOutArgs) (not other.HasOutArgs) - if c <> 0 then c else - - // Prefer methods that don't use optional args - // Note: Relies on 'compare' respecting true > false - let c = compare (not candidate.HasOptArgs) (not other.HasOptArgs) - if c <> 0 then c else - - // check regular unnamed args. The argument counts will only be different if one is using param args - let c = - if candidate.TotalNumUnnamedCalledArgs = other.TotalNumUnnamedCalledArgs then - // For extension members, we also include the object argument type, if any in the comparison set - // This matches C#, where all extension members are treated and resolved as "static" methods calls - let cs = - (if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then - let objArgTys1 = candidate.CalledObjArgTys(m) - let objArgTys2 = other.CalledObjArgTys(m) - if objArgTys1.Length = objArgTys2.Length then - List.map2 compareTypes objArgTys1 objArgTys2 - else - [] - else - []) @ - ((candidate.AllUnnamedCalledArgs, other.AllUnnamedCalledArgs) ||> List.map2 compareArg) - // "all args are at least as good, and one argument is actually better" - if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then - 1 - // "all args are at least as bad, and one argument is actually worse" - elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then - -1 - // "argument lists are incomparable" - else - 0 - else - 0 - if c <> 0 then c else - - // prefer non-extension methods - let c = compare (not candidate.Method.IsExtensionMember) (not other.Method.IsExtensionMember) - if c <> 0 then c else - - // between extension methods, prefer most recently opened - let c = - if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then - compare candidate.Method.ExtensionMemberPriority other.Method.ExtensionMemberPriority - else - 0 - if c <> 0 then c else - - // Prefer non-generic methods - // Note: Relies on 'compare' respecting true > false - let c = compare candidate.CalledTyArgs.IsEmpty other.CalledTyArgs.IsEmpty - if c <> 0 then c else - - // F# 5.0 rule - prior to F# 5.0 named arguments (on the caller side) were not being taken - // into account when comparing overloads. So adding a name to an argument might mean - // overloads ould no longer be distinguished. We thus look at *all* arguments (whether - // optional or not) as an additional comparison technique. - let c = - if g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) then - let cs = - let args1 = candidate.AllCalledArgs |> List.concat - let args2 = other.AllCalledArgs |> List.concat - if args1.Length = args2.Length then - (args1, args2) ||> List.map2 compareArg - else - [] - // "all args are at least as good, and one argument is actually better" - if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then - 1 - // "all args are at least as bad, and one argument is actually worse" - elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then - -1 - // "argument lists are incomparable" - else - 0 - else - 0 - if c <> 0 then c else - - 0 - - let bestMethods = - let indexedApplicableMeths = applicableMeths |> List.indexed - indexedApplicableMeths |> List.choose (fun (i, candidate) -> - if indexedApplicableMeths |> List.forall (fun (j, other) -> - i = j || - let res = better candidate other - res > 0) then - Some candidate - else - None) + let bestMethods = ChooseBestMethodsForOverloading csenv ndeep applicableMeths match bestMethods with | [(calledMeth, warns, _usesTDC)] -> Some calledMeth, OkResult (warns, ()) | bestMethods -> @@ -3036,7 +3047,6 @@ and ResolveOverloading | [] -> yield { methodSlot = methodSlot; error = Unchecked.defaultof; infoReader = infoReader } | errors -> for error in errors do yield { methodSlot = methodSlot; error = error; infoReader = infoReader } ] - // use the most precise set // - if after filtering bestMethods still contains something - use it // - otherwise use applicableMeths or initial set of candidate methods @@ -3068,15 +3078,15 @@ and ResolveOverloading let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) let! _usesTDC = CanMemberSigsMatchUpToCheck - csenv - permitOptArgs - true - (TypesEquiv csenv ndeep cxsln) // instantiations equal - (TypesMustSubsume csenv ndeep cxsln m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome m) // return can subsume or convert - (ArgsMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome true) // args can subsume or convert - reqdRetTyOpt - calledMeth + csenv + permitOptArgs + true + (TypesEquiv csenv ndeep cxsln) // instantiations equal + (TypesMustSubsume csenv ndeep cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome m) // return can subsume or convert + (ArgsMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome true) // args can subsume or convert + reqdRetTyOpt + calledMeth return () } @@ -3190,31 +3200,31 @@ let UndoIfFailedOrWarnings f = let AddCxTypeEqualsTypeUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with Trace = WithTrace trace } + let csenv = { csenv with Trace = WithTrace trace; ErrorOnFailedMemberConstraintResolution = true } SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty1 ty2) let AddCxTypeEqualsTypeUndoIfFailedOrWarnings denv css m ty1 ty2 = UndoIfFailedOrWarnings (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with Trace = WithTrace trace } + let csenv = { csenv with Trace = WithTrace trace; ErrorOnFailedMemberConstraintResolution = true } SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty1 ty2) let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with Trace = WithTrace trace; MatchingOnly = true } + let csenv = { csenv with Trace = WithTrace trace; MatchingOnly = true; ErrorOnFailedMemberConstraintResolution = true } SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty1 ty2) let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with Trace = WithTrace trace } + let csenv = { csenv with Trace = WithTrace trace; ErrorOnFailedMemberConstraintResolution = true } SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m None ty1 ty2) let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with Trace = WithTrace trace; MatchingOnly = true } + let csenv = { csenv with Trace = WithTrace trace; MatchingOnly = true; ErrorOnFailedMemberConstraintResolution = true } SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m None ty1 ty2) let AddCxTypeMustSubsumeType contextInfo denv css m ty1 ty2 = @@ -3222,7 +3232,7 @@ let AddCxTypeMustSubsumeType contextInfo denv css m ty1 ty2 = SolveTypeSubsumesTypeWithReport csenv 0 m None ty1 ty2 id |> RaiseOperationResult -let rec AddCxMethodConstraint denv css m traitInfo = +let AddCxMethodConstraint denv css m traitInfo = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> @@ -3234,70 +3244,70 @@ let rec AddCxMethodConstraint denv css m traitInfo = (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeMustSupportNull denv css m ty = +let AddCxTypeMustSupportNull denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeSupportsNull csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeMustSupportComparison denv css m ty = +let AddCxTypeMustSupportComparison denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeSupportsComparison csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeMustSupportEquality denv css m ty = +let AddCxTypeMustSupportEquality denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeSupportsEquality csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeMustSupportDefaultCtor denv css m ty = +let AddCxTypeMustSupportDefaultCtor denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeRequiresDefaultConstructor csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeIsReferenceType denv css m ty = +let AddCxTypeIsReferenceType denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeIsReferenceType csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeIsValueType denv css m ty = +let AddCxTypeIsValueType denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeIsNonNullableValueType csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeIsUnmanaged denv css m ty = +let AddCxTypeIsUnmanaged denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeIsUnmanaged csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeIsEnum denv css m ty underlying = +let AddCxTypeIsEnum denv css m ty underlying = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeIsEnum csenv 0 m ty underlying) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTypeIsDelegate denv css m ty aty bty = +let AddCxTypeIsDelegate denv css m ty aty bty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeIsDelegate csenv 0 m ty aty bty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let rec AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty = +let AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty = let csenv = MakeConstraintSolverEnv ctxtInfo css m denv PostponeConstraintOnFailedMemberConstraintResolution csenv (fun csenv -> AddConstraint csenv 0 m tp (TyparConstraint.DefaultsTo(ridx, ty, m))) From 10557ea2eb13ad17b82a94bbecf692f5a3ecb33b Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 13:36:06 +0100 Subject: [PATCH 07/14] fix error messages --- src/fsharp/ConstraintSolver.fs | 243 +++++++++++++++++---------------- 1 file changed, 124 insertions(+), 119 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index c641b915305..f0e652efb1b 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -578,7 +578,7 @@ let IgnoreFailedMemberConstraintResolution f1 f2 = /// /// To ensure soundness, we double-check the constraint at the end of inference /// with 'ErrorOnFailedMemberConstraintResolution' set to false. -let PostponeConstraintOnFailedMemberConstraintResolution (csenv: ConstraintSolverEnv) f1 f2 = +let PostponeOnFailedMemberConstraintResolution (csenv: ConstraintSolverEnv) f1 f2 = TryD (fun () -> let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = true } @@ -999,7 +999,7 @@ and SolveTypMeetsTyparConstraints (csenv: ConstraintSolverEnv) ndeep m2 ty (r: T | TyparConstraint.IsReferenceType m2 -> SolveTypeIsReferenceType csenv ndeep m2 ty | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypeRequiresDefaultConstructor csenv ndeep m2 ty | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypeChoice csenv ndeep m2 ty tys - | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 None ty2 ty + | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 ty2 ty | TyparConstraint.MayResolveMember(traitInfo, m2) -> SolveMemberConstraint csenv false PermitWeakResolution.No ndeep m2 traitInfo |> OperationResult.ignore } @@ -1027,6 +1027,21 @@ and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 tptys tys = trac | _ -> failwith "SolveTyparsEqualTypes") } +and (|Subset|Superset|Overlap|CompletelyDifferent|) (first, second) = + let first = Set first + let second = Set second + let secondOnly = Set.toList (second - first) + let firstOnly = Set.toList (first - second) + + if second.IsSubsetOf first then + Subset firstOnly + elif second.IsSupersetOf first then + Superset secondOnly + elif Set.intersect first second <> Set.empty then + Overlap(firstOnly, secondOnly) + else + CompletelyDifferent(Seq.toList first) + and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: AnonRecdTypeInfo) (anonInfo2: AnonRecdTypeInfo) = if evalTupInfoIsStruct anonInfo1.TupInfo <> evalTupInfoIsStruct anonInfo2.TupInfo then ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m,m2)) else (match anonInfo1.Assembly, anonInfo2.Assembly with @@ -1034,21 +1049,7 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon ) ++ (fun () -> if not (anonInfo1.SortedNames = anonInfo2.SortedNames) then - let (|Subset|Superset|Overlap|CompletelyDifferent|) (first, second) = - let first = Set first - let second = Set second - let secondOnly = Set.toList (second - first) - let firstOnly = Set.toList (first - second) - - if second.IsSubsetOf first then - Subset firstOnly - elif second.IsSupersetOf first then - Superset secondOnly - elif Set.intersect first second <> Set.empty then - Overlap(firstOnly, secondOnly) - else - CompletelyDifferent(Seq.toList first) - + let message = match anonInfo1.SortedNames, anonInfo2.SortedNames with | Subset missingFields -> @@ -1066,17 +1067,11 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon /// Add the constraint "ty1 = ty2" to the constraint problem. /// Propagate all effects of adding this constraint, e.g. to solve type variables -and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (cxsln:(TraitConstraintInfo * TraitConstraintSln) option) ty1 ty2 = +and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 ty1 ty2 = let ndeep = ndeep + 1 let aenv = csenv.EquivEnv let g = csenv.g - match cxsln with - | Some (traitInfo, traitSln) when traitInfo.Solution.IsNone -> - // If this is an overload resolution at this point it's safe to assume the candidate member being evaluated solves this member constraint. - TransactMemberConstraintSolution traitInfo csenv.Trace traitSln - | _ -> () - if ty1 === ty2 then CompleteD else let canShortcut = not csenv.Trace.HasTrace @@ -1095,9 +1090,9 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (cxsln:(TraitConst // Catch float<_>=float<1>, float32<_>=float32<1> and decimal<_>=decimal<1> | _, TType_app (tc2, [ms]) when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsType csenv ndeep m2 None ms (TType_measure Measure.One) + -> SolveTypeEqualsType csenv ndeep m2 ms (TType_measure Measure.One) | TType_app (tc2, [ms]), _ when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty2 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsType csenv ndeep m2 None ms (TType_measure Measure.One) + -> SolveTypeEqualsType csenv ndeep m2 ms (TType_measure Measure.One) | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 -> SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 @@ -1131,14 +1126,10 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (cxsln:(TraitConst | _ -> localAbortD - -and SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty1 ty2 = - SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 None ty1 ty2 - -and private SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 cxsln ty1 ty2 = +and SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty1 ty2 = // Back out of expansions of type abbreviations to give improved error messages. // Note: any "normalization" of equations on type variables must respect the trace parameter - TryD (fun () -> SolveTypeEqualsType csenv ndeep m2 cxsln ty1 ty2) + TryD (fun () -> SolveTypeEqualsType csenv ndeep m2 ty1 ty2) (function | LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInEqualityRelation(csenv.DisplayEnv, ty1, ty2, csenv.m, m2, csenv.ContextInfo)) | err -> ErrorD err) @@ -1167,7 +1158,7 @@ and SolveFunTypeEqn csenv ndeep m2 d1 d2 r1 r2 = trackErrors { // // "ty2 casts to ty1" // "a value of type ty2 can be used where a value of type ty1 is expected" -and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 cxsln ty1 ty2 = +and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 ty1 ty2 = // 'a :> obj ---> let ndeep = ndeep + 1 let g = csenv.g @@ -1183,12 +1174,12 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 cxsln ty1 ty2 = match sty1, sty2 with | TType_var tp1, _ -> match aenv.EquivTypars.TryFind tp1 with - | Some v -> SolveTypeSubsumesType csenv ndeep m2 cxsln v ty2 + | Some v -> SolveTypeSubsumesType csenv ndeep m2 v ty2 | _ -> match sty2 with | TType_var r2 when typarEq tp1 r2 -> CompleteD | TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 r ty1 - | _ -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 cxsln ty1 ty2 + | _ -> SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty1 ty2 | _, TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 r ty1 @@ -1208,21 +1199,21 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 cxsln ty1 ty2 = // Enforce the identities float=float<1>, float32=float32<1> and decimal=decimal<1> | _, TType_app (tc2, [ms]) when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 cxsln ms (TType_measure Measure.One) + -> SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ms (TType_measure Measure.One) | TType_app (tc2, [ms]), _ when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty2 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 cxsln ms (TType_measure Measure.One) + -> SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ms (TType_measure Measure.One) // Special subsumption rule for byref tags | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 && g.byref2_tcr.CanDeref && tyconRefEq g g.byref2_tcr tc1 -> match l1, l2 with | [ h1; tag1 ], [ h2; tag2 ] -> trackErrors { - do! SolveTypeEqualsType csenv ndeep m2 None h1 h2 + do! SolveTypeEqualsType csenv ndeep m2 h1 h2 match stripTyEqnsA csenv.g canShortcut tag1, stripTyEqnsA csenv.g canShortcut tag2 with | TType_app(tagc1, []), TType_app(tagc2, []) when (tyconRefEq g tagc2 g.byrefkind_InOut_tcr && (tyconRefEq g tagc1 g.byrefkind_In_tcr || tyconRefEq g tagc1 g.byrefkind_Out_tcr) ) -> () - | _ -> return! SolveTypeEqualsType csenv ndeep m2 None tag1 tag2 + | _ -> return! SolveTypeEqualsType csenv ndeep m2 tag1 tag2 } | _ -> SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 @@ -1258,7 +1249,7 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 cxsln ty1 ty2 = match tinst with | [ty1arg] -> let ty2arg = destArrayTy g ty2 - SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 cxsln ty1arg ty2arg + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty1arg ty2arg | _ -> error(InternalError("destArrayTy", m)) | _ -> @@ -1267,11 +1258,11 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 cxsln ty1 ty2 = // may feasibly convert to Head. match FindUniqueFeasibleSupertype g amap m ty1 ty2 with | None -> ErrorD(ConstraintSolverTypesNotInSubsumptionRelation(denv, ty1, ty2, m, m2)) - | Some t -> SolveTypeSubsumesType csenv ndeep m2 cxsln ty1 t + | Some t -> SolveTypeSubsumesType csenv ndeep m2 ty1 t -and SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 cxsln ty1 ty2 = +and SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 ty1 ty2 = let denv = csenv.DisplayEnv - TryD (fun () -> SolveTypeSubsumesType csenv ndeep m2 cxsln ty1 ty2) + TryD (fun () -> SolveTypeSubsumesType csenv ndeep m2 ty1 ty2) (function | LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInSubsumptionRelation(denv, ty1, ty2, csenv.m, m2)) | err -> ErrorD err) @@ -2478,43 +2469,44 @@ and CanMemberSigsMatchUpToCheck // // "ty2 casts to ty1" // "a value of type ty2 can be used where a value of type ty1 is expected" -and AddWrappedContextualSubsumptionReport (csenv: ConstraintSolverEnv) ndeep m cxsln ty1 ty2 res wrapper = +and AddWrappedContextualSubsumptionReport (csenv: ConstraintSolverEnv) ndeep m ty1 ty2 res wrapper = match csenv.ContextInfo with | ContextInfo.RuntimeTypeTest isOperator -> // test if we can cast other way around let results = CollectThenUndo (fun newTrace -> let csenv = { csenv with Trace = OptionalTrace.WithTrace newTrace } - SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m cxsln ty2 ty1) + SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m ty2 ty1) match results with | OkResult _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.DowncastUsedInsteadOfUpcast isOperator, m))) | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.NoContext, m))) | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, csenv.ContextInfo, m))) /// Assert a subtype constraint -and SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m cxsln ty1 ty2 wrapper = +and SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m ty1 ty2 wrapper = // Due to the legacy of the change https://github.com/dotnet/fsharp/pull/1650, // when doing nested, speculative overload resolution, we ignore failed member constraints and continue. The // constraint is not recorded for later solution. if csenv.IsSpeculativeForMethodOverloading then IgnoreFailedMemberConstraintResolution - (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m cxsln ty1 ty2) - (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) + (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m ty1 ty2) + (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m ty1 ty2 res wrapper) else - PostponeConstraintOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m cxsln ty1 ty2) - (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) + PostponeOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m ty1 ty2) + (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m ty1 ty2 res wrapper) // ty1: actual // ty2: expected -and private SolveTypeEqualsTypeWithReport (csenv: ConstraintSolverEnv) ndeep m cxsln actual expected = - SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m cxsln actual expected +and private SolveTypeEqualsTypeWithReport (csenv: ConstraintSolverEnv) ndeep m actual expected = + TryD + (fun () -> SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m actual expected) + (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, actual, expected, res, m))) and ArgsMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep - cxsln isConstraint enforceNullableOptionalsKnownTypes // use known types from nullable optional args? (calledArg: CalledArg) @@ -2525,13 +2517,13 @@ and ArgsMustSubsumeOrConvert let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint enforceNullableOptionalsKnownTypes calledArg callerArg match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsTypeWithReport csenv ndeep m cxsln ty1 ty2 + do! SolveTypeEqualsTypeWithReport csenv ndeep m ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m cxsln calledArgTy callerArg.CallerArgumentType id + do! SolveTypeSubsumesTypeWithReport csenv ndeep m calledArgTy callerArg.CallerArgumentType id if calledArg.IsParamArray && isArray1DTy g calledArgTy && not (isArray1DTy g callerArg.CallerArgumentType) then return! ErrorD(Error(FSComp.SR.csMethodExpectsParams(), m)) else @@ -2544,7 +2536,6 @@ and ArgsMustSubsumeOrConvertWithContextualReport (csenv: ConstraintSolverEnv) ad ndeep - cxsln isConstraint calledMeth calledArg @@ -2555,51 +2546,51 @@ and ArgsMustSubsumeOrConvertWithContextualReport let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint true calledArg callerArg match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsType csenv ndeep m cxsln ty1 ty2 + do! SolveTypeEqualsType csenv ndeep m ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m cxsln calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) + do! SolveTypeSubsumesTypeWithReport csenv ndeep m calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) return usesTDC } -and TypesEquiv csenv ndeep cxsln ty1 ty2 = +and TypesEquiv csenv ndeep ty1 ty2 = trackErrors { - do! SolveTypeEqualsTypeWithReport csenv ndeep csenv.m cxsln ty1 ty2 + do! SolveTypeEqualsTypeWithReport csenv ndeep csenv.m ty1 ty2 return TypeDirectedConversionUsed.No } -and TypesMustSubsume (csenv: ConstraintSolverEnv) ndeep cxsln m calledArgTy callerArgTy = +and TypesMustSubsume (csenv: ConstraintSolverEnv) ndeep m calledArgTy callerArgTy = trackErrors { - do! SolveTypeSubsumesTypeWithReport csenv ndeep m cxsln calledArgTy callerArgTy id + do! SolveTypeSubsumesTypeWithReport csenv ndeep m calledArgTy callerArgTy id return TypeDirectedConversionUsed.No } -and ReturnTypesMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep cxsln isConstraint m isMethodArg reqdTy actualTy = +and ReturnTypesMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep isConstraint m isMethodArg reqdTy actualTy = trackErrors { let reqdTy, usesTDC, eqn = AdjustRequiredTypeForTypeDirectedConversions csenv.InfoReader ad isMethodArg isConstraint reqdTy actualTy m match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsType csenv ndeep m cxsln ty1 ty2 + do! SolveTypeEqualsType csenv ndeep m ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m cxsln reqdTy actualTy id + do! SolveTypeSubsumesTypeWithReport csenv ndeep m reqdTy actualTy id return usesTDC } -and ArgsEquivOrConvert (csenv: ConstraintSolverEnv) ad ndeep cxsln isConstraint calledArg (callerArg: CallerArg<_>) = +and ArgsEquivOrConvert (csenv: ConstraintSolverEnv) ad ndeep isConstraint calledArg (callerArg: CallerArg<_>) = trackErrors { let callerArgTy = callerArg.CallerArgumentType let m = callerArg.Range let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint true calledArg callerArg match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsType csenv ndeep m cxsln ty1 ty2 + do! SolveTypeEqualsType csenv ndeep m ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with @@ -2907,6 +2898,17 @@ and ChooseBestMethodsForOverloading (csenv: ConstraintSolverEnv) ndeep applicabl else None) +/// When checking whether a method solves a trait constraint, we can assume the trait is solved +/// by that method for the purposes of further type checking (just as we assume a type equation +/// for the purposes of checking constraints arising from that type equation). +and AssumeMethodSolvesTrait (csenv: ConstraintSolverEnv) (cx: TraitConstraintInfo option) m (calledMeth: CalledMeth<_>) = + match cx with + | Some traitInfo when traitInfo.Solution.IsNone -> + let traitSln = MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs + // If this is an overload resolution at this point it's safe to assume the candidate member being evaluated solves this member constraint. + TransactMemberConstraintSolution traitInfo csenv.Trace traitSln + | _ -> () + // Resolve the overloading of a method // This is used after analyzing the types of arguments and ResolveOverloading @@ -2954,15 +2956,15 @@ and ResolveOverloading let exactMatchCandidates = candidates |> FilterEachThenUndo (fun newTrace calledMeth -> let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculativeForMethodOverloading = true } - let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) + AssumeMethodSolvesTrait csenv cx m calledMeth CanMemberSigsMatchUpToCheck csenv permitOptArgs alwaysCheckReturn - (TypesEquiv csenv ndeep cxsln) // instantiations equivalent - (TypesMustSubsume csenv ndeep cxsln m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome m) // return can subsume or convert - (ArgsEquivOrConvert csenv ad ndeep cxsln cx.IsSome) // args exact + (TypesEquiv csenv ndeep) // instantiations equivalent + (TypesMustSubsume csenv ndeep m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cx.IsSome m) // return can subsume or convert + (ArgsEquivOrConvert csenv ad ndeep cx.IsSome) // args exact reqdRetTyOpt calledMeth) @@ -2976,15 +2978,15 @@ and ResolveOverloading let applicable = candidates |> FilterEachThenUndo (fun newTrace candidate -> let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculativeForMethodOverloading = true } - let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m candidate.Method candidate.CalledTyArgs)) + AssumeMethodSolvesTrait csenv cx m candidate CanMemberSigsMatchUpToCheck csenv permitOptArgs alwaysCheckReturn - (TypesEquiv csenv ndeep cxsln) // instantiations equivalent - (TypesMustSubsume csenv ndeep cxsln m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome m) // return can subsume or convert - (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep cxsln cx.IsSome candidate) // args can subsume + (TypesEquiv csenv ndeep) // instantiations equivalent + (TypesMustSubsume csenv ndeep m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cx.IsSome m) // return can subsume or convert + (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep cx.IsSome candidate) // args can subsume reqdRetTyOpt candidate) @@ -3014,15 +3016,15 @@ and ResolveOverloading let results = CollectThenUndo (fun newTrace -> let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculativeForMethodOverloading = true } - let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) + AssumeMethodSolvesTrait csenv cx m calledMeth CanMemberSigsMatchUpToCheck csenv permitOptArgs alwaysCheckReturn - (TypesEquiv csenv ndeep cxsln) - (TypesMustSubsume csenv ndeep cxsln m) - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome m) - (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep cxsln cx.IsSome calledMeth) + (TypesEquiv csenv ndeep) + (TypesMustSubsume csenv ndeep m) + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cx.IsSome m) + (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep cx.IsSome calledMeth) reqdRetTyOpt calledMeth) match results with @@ -3075,19 +3077,25 @@ and ResolveOverloading calledMethOpt, trackErrors { do! errors - let cxsln = cx |> Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) + AssumeMethodSolvesTrait csenv cx m calledMeth let! _usesTDC = CanMemberSigsMatchUpToCheck csenv permitOptArgs true - (TypesEquiv csenv ndeep cxsln) // instantiations equal - (TypesMustSubsume csenv ndeep cxsln m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome m) // return can subsume or convert - (ArgsMustSubsumeOrConvert csenv ad ndeep cxsln cx.IsSome true) // args can subsume or convert + (TypesEquiv csenv ndeep) // instantiations equal + (TypesMustSubsume csenv ndeep m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cx.IsSome m) // return can subsume or convert + (ArgsMustSubsumeOrConvert csenv ad ndeep cx.IsSome true) // args can subsume or convert reqdRetTyOpt calledMeth - return () + + // Adhoc additional check on method calls + match reqdRetTyOpt with + | Some reqdRetTy when isByrefTy g reqdRetTy.Commit -> + return! ErrorD(Error(FSComp.SR.tcByrefReturnImplicitlyDereferenced(), m)) + | _ -> + return () } | None -> @@ -3121,10 +3129,10 @@ let UnifyUniqueOverloading csenv true // permitOptArgs true // always check return type - (TypesEquiv csenv ndeep None) - (TypesMustSubsume csenv ndeep None m) - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep None false m) - (ArgsMustSubsumeOrConvert csenv ad ndeep None false false) + (TypesEquiv csenv ndeep) + (TypesMustSubsume csenv ndeep m) + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep false m) + (ArgsMustSubsumeOrConvert csenv ad ndeep false false) (Some reqdRetTy) calledMeth return true @@ -3153,17 +3161,14 @@ let EliminateConstraintsForGeneralizedTypars denv css m (generalizedTypars: Typa //------------------------------------------------------------------------- -// Main entry points to constraint solver (some backdoors are used for -// some constructs) -// -// No error recovery here: we do that on a per-expression basis. +// Main entry points to constraint solver //------------------------------------------------------------------------- let AddCxTypeEqualsType contextInfo denv css m actual expected = let csenv = MakeConstraintSolverEnv contextInfo css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeEqualsTypeWithReport csenv 0 m None actual expected) - (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, actual, expected, res, m))) + PostponeOnFailedMemberConstraintResolution csenv + (fun csenv -> SolveTypeEqualsTypeWithReport csenv 0 m actual expected) + ErrorD |> RaiseOperationResult let UndoIfFailed f = @@ -3219,22 +3224,22 @@ let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv let csenv = { csenv with Trace = WithTrace trace; ErrorOnFailedMemberConstraintResolution = true } - SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m None ty1 ty2) + SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m ty1 ty2) let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv let csenv = { csenv with Trace = WithTrace trace; MatchingOnly = true; ErrorOnFailedMemberConstraintResolution = true } - SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m None ty1 ty2) + SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m ty1 ty2) let AddCxTypeMustSubsumeType contextInfo denv css m ty1 ty2 = let csenv = MakeConstraintSolverEnv contextInfo css m denv - SolveTypeSubsumesTypeWithReport csenv 0 m None ty1 ty2 id + SolveTypeSubsumesTypeWithReport csenv 0 m ty1 ty2 id |> RaiseOperationResult let AddCxMethodConstraint denv css m traitInfo = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> trackErrors { do! @@ -3246,70 +3251,70 @@ let AddCxMethodConstraint denv css m traitInfo = let AddCxTypeMustSupportNull denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeSupportsNull csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportComparison denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeSupportsComparison csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportEquality denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeSupportsEquality csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportDefaultCtor denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeRequiresDefaultConstructor csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsReferenceType denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeIsReferenceType csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsValueType denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeIsNonNullableValueType csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsUnmanaged denv css m ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeIsUnmanaged csenv 0 m ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsEnum denv css m ty underlying = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeIsEnum csenv 0 m ty underlying) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsDelegate denv css m ty aty bty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTypeIsDelegate csenv 0 m ty aty bty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty = let csenv = MakeConstraintSolverEnv ctxtInfo css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> AddConstraint csenv 0 m tp (TyparConstraint.DefaultsTo(ridx, ty, m))) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -3327,7 +3332,7 @@ let ApplyTyparDefaultAtPriority denv css priority (tp: Typar) = let ty1 = mkTyparTy tp if not tp.IsSolved && not (typeEquiv css.g ty1 ty2) then let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTyparEqualsType csenv 0 m ty1 ty2) (fun res -> @@ -3379,14 +3384,14 @@ let ChooseTyparSolutionAndSolve css denv tp = let amap = css.amap let max, m = ChooseTyparSolutionAndRange g amap tp let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> SolveTyparEqualsType csenv 0 m (mkTyparTy tp) max) (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult let CheckDeclaredTypars denv css m typars1 typars2 = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> CollectThenUndo (fun newTrace -> let csenv = { csenv with Trace = WithTrace newTrace } @@ -3400,7 +3405,7 @@ let CheckDeclaredTypars denv css m typars1 typars2 = let CanonicalizePartialInferenceProblem css denv m tps = // Canonicalize constraints prior to generalization let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeConstraintOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> CanonicalizeRelevantMemberConstraints csenv 0 tps) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -3425,7 +3430,7 @@ let IsApplicableMethApprox g amap m (minfo: MethInfo) availObjTy = match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> let reqdObjTy = if isByrefTy g reqdObjTy then destByrefTy g reqdObjTy else reqdObjTy // This is to support byref extension methods. - TryD (fun () -> SolveTypeSubsumesType csenv 0 m None reqdObjTy availObjTy ++ (fun () -> ResultD true)) + TryD (fun () -> SolveTypeSubsumesType csenv 0 m reqdObjTy availObjTy ++ (fun () -> ResultD true)) (fun _err -> ResultD false) |> CommitOperationResult | _ -> true From 9091eba95ac963128382d20c658efaa60c94c4da Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 13:37:34 +0100 Subject: [PATCH 08/14] fix error messages --- tests/fsharp/core/auto-widen/5.0/test.bsl | 24 +++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/tests/fsharp/core/auto-widen/5.0/test.bsl b/tests/fsharp/core/auto-widen/5.0/test.bsl index 2c197316bec..644978843dc 100644 --- a/tests/fsharp/core/auto-widen/5.0/test.bsl +++ b/tests/fsharp/core/auto-widen/5.0/test.bsl @@ -9,7 +9,10 @@ test.fsx(14,20,14,41): typecheck error FS0001: This expression was expected to h but here has type 'int' -test.fsx(17,20,17,44): typecheck error FS0193: The type 'obj' does not match the type 'int' +test.fsx(17,20,17,44): typecheck error FS0001: This expression was expected to have type + 'obj' +but here has type + 'int' test.fsx(20,21,20,24): typecheck error FS0001: This expression was expected to have type 'obj' @@ -261,7 +264,7 @@ is not compatible with type 'C' -test.fsx(172,18,172,21): typecheck error FS0193: The type 'Y' is not compatible with the type 'X' +test.fsx(172,18,172,21): typecheck error FS0001: The type 'Y' is not compatible with the type 'X' test.fsx(172,17,172,22): typecheck error FS0193: Type constraint mismatch. The type 'Y' @@ -460,11 +463,20 @@ test.fsx(263,44,263,63): typecheck error FS0001: This expression was expected to but here has type 'string' -test.fsx(266,44,266,68): typecheck error FS0193: The type 'IComparable' does not match the type 'string' +test.fsx(266,44,266,68): typecheck error FS0001: This expression was expected to have type + 'IComparable' +but here has type + 'string' -test.fsx(268,21,268,45): typecheck error FS0193: The type 'obj' does not match the type 'string' +test.fsx(268,21,268,45): typecheck error FS0001: This expression was expected to have type + 'obj' +but here has type + 'string' -test.fsx(270,36,270,60): typecheck error FS0193: The type 'IComparable' does not match the type 'string' +test.fsx(270,36,270,60): typecheck error FS0001: This expression was expected to have type + 'IComparable' +but here has type + 'string' test.fsx(275,35,275,36): typecheck error FS0001: This expression was expected to have type 'obj' @@ -864,4 +876,4 @@ but here has type test.fsx(454,46,454,47): typecheck error FS0001: This expression was expected to have type 'int64' but here has type - 'int' + 'int' \ No newline at end of file From 26a07dfa5aa0fa2d240baf7e5d602b39341f9f60 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 13:37:59 +0100 Subject: [PATCH 09/14] fix error messages --- tests/fsharp/Compiler/Language/OpenTypeDeclarationTests.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/fsharp/Compiler/Language/OpenTypeDeclarationTests.fs b/tests/fsharp/Compiler/Language/OpenTypeDeclarationTests.fs index 39936bb01f1..7d04809e436 100644 --- a/tests/fsharp/Compiler/Language/OpenTypeDeclarationTests.fs +++ b/tests/fsharp/Compiler/Language/OpenTypeDeclarationTests.fs @@ -784,7 +784,7 @@ module Test = """ |> withLangVersion50 |> compile - |> withErrorCode 193 + |> withErrorCode 1 |> ignore [] From c8909495b11fd2df103f9e9d499fb25e02cad1c8 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 13:38:12 +0100 Subject: [PATCH 10/14] fix error messages --- tests/fsharp/core/auto-widen/5.0/test.bsl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/fsharp/core/auto-widen/5.0/test.bsl b/tests/fsharp/core/auto-widen/5.0/test.bsl index 644978843dc..9aac4fe55fb 100644 --- a/tests/fsharp/core/auto-widen/5.0/test.bsl +++ b/tests/fsharp/core/auto-widen/5.0/test.bsl @@ -876,4 +876,4 @@ but here has type test.fsx(454,46,454,47): typecheck error FS0001: This expression was expected to have type 'int64' but here has type - 'int' \ No newline at end of file + 'int' From 8cd695a614f390e5409f81ec40f0336cc5331701 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 18:30:46 +0100 Subject: [PATCH 11/14] simplify diff --- src/fsharp/CheckComputationExpressions.fs | 6 +- src/fsharp/CheckExpressions.fs | 48 +- src/fsharp/CompilerDiagnostics.fs | 10 - src/fsharp/ConstraintSolver.fs | 1139 +++++++++-------- src/fsharp/ConstraintSolver.fsi | 32 +- .../CodeGen/EmittedIL/TaskGeneratedCode.fs | 5 + .../fsharp/typecheck/sigs/neg_issue_3752.bsl | 2 + 7 files changed, 629 insertions(+), 613 deletions(-) diff --git a/src/fsharp/CheckComputationExpressions.fs b/src/fsharp/CheckComputationExpressions.fs index 62ed0dfd1d6..bf2891bc96c 100644 --- a/src/fsharp/CheckComputationExpressions.fs +++ b/src/fsharp/CheckComputationExpressions.fs @@ -1666,7 +1666,7 @@ let mkSeqCollect (cenv: cenv) env m enumElemTy genTy lam enumExpr = mkCallSeqCollect cenv.g m enumElemTy genResultTy lam enumExpr let mkSeqUsing (cenv: cenv) (env: TcEnv) m resourceTy genTy resourceExpr lam = - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m cenv.g.system_IDisposable_ty resourceTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace cenv.g.system_IDisposable_ty resourceTy let genResultTy = NewInferenceType () UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) mkCallSeqUsing cenv.g m resourceTy genResultTy resourceExpr lam @@ -1890,7 +1890,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = if not isYield then errorR(Error(FSComp.SR.tcUseYieldBangForMultipleResults(), m)) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m genOuterTy genExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace genOuterTy genExprTy Some(mkCoerceExpr(resultExpr, genOuterTy, m, genExprTy), tpenv) | SynExpr.YieldOrReturn ((isYield, _), yieldExpr, m) -> @@ -1926,7 +1926,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let genResultTy = NewInferenceType () UnifyTypes cenv env m genOuterTy (mkSeqTy cenv.g genResultTy) let exprTy = tyOfExpr cenv.g expr - AddCxTypeMustSubsumeType env.eContextInfo env.DisplayEnv cenv.css m genResultTy exprTy + AddCxTypeMustSubsumeType env.eContextInfo env.DisplayEnv cenv.css m NoTrace genResultTy exprTy let resExpr = mkCallSeqSingleton cenv.g m genResultTy (mkCoerceExpr(expr, genResultTy, m, exprTy)) Choice1Of2 resExpr, tpenv else diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index 8a8ce89fe17..7667cad81eb 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -2225,7 +2225,7 @@ module GeneralizationHelpers = generalizedTypars |> List.iter (SetTyparRigid denv m) // Generalization removes constraints related to generalized type variables - EliminateConstraintsForGeneralizedTypars denv cenv.css m generalizedTypars + EliminateConstraintsForGeneralizedTypars denv cenv.css m NoTrace generalizedTypars generalizedTypars @@ -2865,7 +2865,7 @@ let MakeApplicableExprWithFlex cenv (env: TcEnv) expr = then actualType else let flexibleType = NewInferenceType () - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m actualType flexibleType + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace actualType flexibleType flexibleType) // Create a coercion to represent the expansion of the application @@ -2887,9 +2887,9 @@ let TcRuntimeTypeTest isCast isOperator cenv denv m tgtTy srcTy = if isSealedTy g tgtTy || isTyparTy g tgtTy || not (isInterfaceTy g srcTy) then if isCast then - AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv cenv.css m srcTy tgtTy + AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv cenv.css m NoTrace srcTy tgtTy else - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m srcTy tgtTy + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace srcTy tgtTy if isErasedType g tgtTy then if isCast then @@ -2915,7 +2915,7 @@ let TcStaticUpcast cenv denv m tgtTy srcTy = if typeEquiv cenv.g srcTy tgtTy then warning(UpcastUnnecessary m) - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m tgtTy srcTy + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace tgtTy srcTy let BuildPossiblyConditionalMethodCall cenv env isMutable m isProp minfo valUseFlags minst objArgs args = @@ -3909,7 +3909,7 @@ let GetInstanceMemberThisVariable (vspec: Val, expr) = let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = let checkSimpleConstraint tp m constraintAdder = let tp', tpenv = TcTypar cenv env newOk tpenv tp - constraintAdder env.DisplayEnv cenv.css m (mkTyparTy tp') + constraintAdder env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') tpenv match c with @@ -3924,7 +3924,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = let tp', tpenv = TcTypar cenv env newOk tpenv tp if newOk = NoNewTypars && isSealedTy cenv.g ty' then errorR(Error(FSComp.SR.tcInvalidConstraintTypeSealed(), m)) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m ty' (mkTyparTy tp') + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp') tpenv | SynTypeConstraint.WhereTyparSupportsNull(tp, m) -> checkSimpleConstraint tp m AddCxTypeMustSupportNull @@ -3945,7 +3945,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = match tyargs with | [underlying] -> let underlying', tpenv = TcTypeAndRecover cenv newOk checkCxs ItemOccurence.UseInType env tpenv underlying - AddCxTypeIsEnum env.DisplayEnv cenv.css m (mkTyparTy tp') underlying' + AddCxTypeIsEnum env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') underlying' tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) @@ -3958,7 +3958,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | [a;b] -> let a', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv a let b', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv b - AddCxTypeIsDelegate env.DisplayEnv cenv.css m (mkTyparTy tp') a' b' + AddCxTypeIsDelegate env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') a' b' tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) @@ -3970,13 +3970,13 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | TTrait(objtys, ".ctor", memberFlags, argTys, returnTy, _) when memberFlags.MemberKind = SynMemberKind.Constructor -> match objtys, argTys with | [ty], [] when typeEquiv cenv.g ty (GetFSharpViewOfReturnType cenv.g returnTy) -> - AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m ty + AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m NoTrace ty tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidNewConstraint(), m)) tpenv | _ -> - AddCxMethodConstraint env.DisplayEnv cenv.css m traitInfo + AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo tpenv and TcPseudoMemberSpec cenv newOk env synTypes tpenv memSpfn m = @@ -4342,7 +4342,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv | SynType.HashConstraint(ty, m) -> let tp = TcAnonTypeOrMeasure (Some TyparKind.Type) cenv TyparRigidity.WarnIfNotRigid TyparDynamicReq.Yes newOk m let ty', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m ty' (mkTyparTy tp) + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp) tp.AsType, tpenv | SynType.StaticConstant (c, m) -> @@ -5287,7 +5287,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p (fun _ -> TPat_range(c1, c2, m)), (tpenv, names, takenNames) | SynPat.Null m -> - try AddCxTypeMustSupportNull env.DisplayEnv cenv.css m ty + try AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace ty with e -> errorRecovery e m (fun _ -> TPat_null m), (tpenv, names, takenNames) @@ -5346,7 +5346,7 @@ and TcExprFlex cenv flex compat (desiredTy: TType) (env: TcEnv) tpenv (synExpr: let argty = NewInferenceType () if compat then (destTyparTy cenv.g argty).SetIsCompatFlex(true) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css synExpr.Range desiredTy argty + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css synExpr.Range NoTrace desiredTy argty let expr2, tpenv = TcExprFlex2 cenv argty env false tpenv synExpr let expr3 = mkCoerceIfNeeded cenv.g desiredTy argty expr2 expr3, tpenv @@ -5746,7 +5746,7 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = expr, tpenv | SynExpr.Null m -> - AddCxTypeMustSupportNull env.DisplayEnv cenv.css m overallTy.Commit + AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace overallTy.Commit mkNull m overallTy.Commit, tpenv | SynExpr.Lazy (synInnerExpr, m) -> @@ -6025,7 +6025,7 @@ and TcExprUndelayed cenv (overallTy: OverallTy) env tpenv (synExpr: SynExpr) = // Subsumption at trait calls if arguments have nominal type prior to unification of any arguments or return type let flexes = argTys |> List.map (isTyparTy cenv.g >> not) let args', tpenv = TcExprsWithFlexes cenv env m tpenv flexes argTys args - AddCxMethodConstraint env.DisplayEnv cenv.css m traitInfo + AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo Expr.Op (TOp.TraitCall traitInfo, [], args', m), returnTy, tpenv ) @@ -6410,7 +6410,7 @@ and TcNewExpr cenv env tpenv objTy mObjTyOpt superInit arg mWholeExprOrObjTy = // Handle the case 'new 'a()' if (isTyparTy cenv.g objTy) then if superInit then error(Error(FSComp.SR.tcCannotInheritFromVariableType(), mWholeExprOrObjTy)) - AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css mWholeExprOrObjTy objTy + AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css mWholeExprOrObjTy NoTrace objTy match arg with | SynExpr.Const (SynConst.Unit, _) -> () @@ -8396,7 +8396,7 @@ and TcItemThen cenv (overallTy: OverallTy) env tpenv (tinstEnclosing, item, mIte let resultExpr, tpenv = TcDelayed cenv (MustEqual intermediateTy) env tpenv mItem (MakeApplicableExprNoFlex cenv expr) (tyOfExpr g expr) ExprAtomicFlag.NonAtomic delayed1 // Add the constraint after the application arguments have been checked to allow annotations to kick in on rigid type parameters - AddCxMethodConstraint env.DisplayEnv cenv.css mItem traitInfo + AddCxMethodConstraint env.DisplayEnv cenv.css mItem NoTrace traitInfo // Process all remaining arguments after the constraint is asserted let resultExpr2, tpenv2 = TcDelayed cenv overallTy env tpenv mItem (MakeApplicableExprNoFlex cenv resultExpr) intermediateTy ExprAtomicFlag.NonAtomic delayed2 @@ -8702,7 +8702,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela RecdFieldInstanceChecks cenv.g cenv.amap ad mItem rfinfo let tgtTy = rfinfo.DeclaringType let valu = isStructTy cenv.g tgtTy - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem tgtTy objExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem NoTrace tgtTy objExprTy let objExpr = if valu then objExpr else mkCoerceExpr(objExpr, tgtTy, mExprAndItem, objExprTy) let fieldTy = rfinfo.FieldType match delayed with @@ -8723,7 +8723,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela | Item.AnonRecdField (anonInfo, tinst, n, _) -> let tgty = TType_anon (anonInfo, tinst) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem tgty objExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem NoTrace tgty objExprTy let fieldTy = List.item n tinst match delayed with | DelayedSet _ :: _otherDelayed -> @@ -9246,7 +9246,7 @@ and TcMethodApplication typeEquiv cenv.g finalCalledMethInfo.ApparentEnclosingType cenv.g.obj_ty && (finalCalledMethInfo.LogicalName = "GetHashCode" || finalCalledMethInfo.LogicalName = "Equals")) then - objArgs |> List.iter (fun expr -> AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr (tyOfExpr cenv.g expr)) + objArgs |> List.iter (fun expr -> AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace (tyOfExpr cenv.g expr)) // Uses of a Dictionary() constructor without an IEqualityComparer argument imply an equality constraint // on the first type argument. @@ -9257,7 +9257,7 @@ and TcMethodApplication HasHeadType cenv.g cenv.g.tcref_System_Collections_Generic_IEqualityComparer ty)) then match argsOfAppTy cenv.g finalCalledMethInfo.ApparentEnclosingType with - | [dty; _] -> AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr dty + | [dty; _] -> AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace dty | _ -> () end @@ -10129,7 +10129,7 @@ and TcAttributeEx canFail cenv (env: TcEnv) attrTgt attrEx (synAttr: SynAttribut let propNameItem = Item.SetterArg(id, setterItem) CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, propNameItem, emptyTyparInst, ItemOccurence.Use, ad) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m argty argtyv + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace argty argtyv AttribNamedArg(nm, argty, isProp, mkAttribExpr callerArgExpr)) @@ -10314,7 +10314,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (synBinds, synBinds let isDiscarded = match checkedPat2 with TPat_wild _ -> true | _ -> false let allValsDefinedByPattern = if isDiscarded then [patternInputTmp] else allValsDefinedByPattern (allValsDefinedByPattern, (bodyExpr, bodyExprTy)) ||> List.foldBack (fun v (bodyExpr, bodyExprTy) -> - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css v.Range cenv.g.system_IDisposable_ty v.Type + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css v.Range NoTrace cenv.g.system_IDisposable_ty v.Type let cleanupE = BuildDisposableCleanup cenv env m v mkTryFinally cenv.g (bodyExpr, cleanupE, m, bodyExprTy, DebugPointAtTry.Body, DebugPointAtFinally.No), bodyExprTy) else diff --git a/src/fsharp/CompilerDiagnostics.fs b/src/fsharp/CompilerDiagnostics.fs index d0f80e1da0e..77ff9ed1acf 100644 --- a/src/fsharp/CompilerDiagnostics.fs +++ b/src/fsharp/CompilerDiagnostics.fs @@ -175,7 +175,6 @@ let GetRangeOfDiagnostic(err: PhasedDiagnostic) = | ConstraintSolverTypesNotInEqualityRelation(_, _, _, m, _, _) | ConstraintSolverError(_, m, _) | ConstraintSolverTypesNotInSubsumptionRelation(_, _, _, m, _) - | ConstraintSolverRelatedInformation(_, m, _) | SelfRefObjCtor(_, m) -> Some m @@ -385,9 +384,6 @@ let IsWarningOrInfoEnabled (err, severity) n level specificWarnOn = let SplitRelatedDiagnostics(err: PhasedDiagnostic) : PhasedDiagnostic * PhasedDiagnostic list = let ToPhased e = {Exception=e; Phase = err.Phase} let rec SplitRelatedException = function - | ConstraintSolverRelatedInformation(fopt, m2, e) -> - let e, related = SplitRelatedException e - ConstraintSolverRelatedInformation(fopt, m2, e.Exception)|>ToPhased, related | ErrorFromAddingTypeEquation(g, denv, t1, t2, e, m) -> let e, related = SplitRelatedException e ErrorFromAddingTypeEquation(g, denv, t1, t2, e.Exception, m)|>ToPhased, related @@ -664,12 +660,6 @@ let OutputPhasedErrorR (os: StringBuilder) (err: PhasedDiagnostic) (canSuggestNa if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m2)) |> ignore - | ConstraintSolverRelatedInformation(fopt, _, e) -> - match e with - | ConstraintSolverError _ -> OutputExceptionR os e - | _ -> () - fopt |> Option.iter (Printf.bprintf os " %s") - | ErrorFromAddingTypeEquation(g, denv, t1, t2, ConstraintSolverTypesNotInEqualityRelation(_, t1', t2', m, _, contextInfo), _) when typeEquiv g t1 t1' && typeEquiv g t2 t2' -> diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index f0e652efb1b..f1291cdf371 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -234,8 +234,6 @@ exception ConstraintSolverMissingConstraint of displayEnv: DisplayEnv * Typar * exception ConstraintSolverError of string * range * range -exception ConstraintSolverRelatedInformation of string option * range * exn - exception ErrorFromApplyingDefault of tcGlobals: TcGlobals * displayEnv: DisplayEnv * Typar * TType * exn * range exception ErrorFromAddingTypeEquation of tcGlobals: TcGlobals * displayEnv: DisplayEnv * actualTy: TType * expectedTy: TType * exn * range @@ -296,44 +294,11 @@ type ConstraintSolverState = member this.GetPostInferenceChecksFinal() = this.PostInferenceChecksFinal.ToArray() :> seq<_> -//------------------------------------------------------------------------- -// Run the constraint solver with undo (used during method overload resolution) - -type Trace = - { mutable actions: ((unit -> unit) * (unit -> unit)) list } - - static member New () = { actions = [] } - - member t.Undo () = List.iter (fun (_, a) -> a ()) t.actions - member t.Push f undo = t.actions <- (f, undo) :: t.actions - -type OptionalTrace = - | NoTrace - | WithTrace of Trace - - member x.HasTrace = match x with NoTrace -> false | WithTrace _ -> true - - member t.Exec f undo = - match t with - | WithTrace trace -> trace.Push f undo; f() - | NoTrace -> f() - - member t.CollectThenUndoOrCommit predicate f = - let newTrace = Trace.New() - let res = f newTrace - match predicate res, t with - | false, _ -> newTrace.Undo() - | true, WithTrace t -> t.actions <- newTrace.actions @ t.actions - | true, NoTrace -> () - res - type ConstraintSolverEnv = { SolverState: ConstraintSolverState - ContextInfo: ContextInfo - - Trace: OptionalTrace + eContextInfo: ContextInfo // Is this speculative, with a trace allowing undo, and trial method overload resolution IsSpeculativeForMethodOverloading: bool @@ -363,12 +328,11 @@ type ConstraintSolverEnv = let MakeConstraintSolverEnv contextInfo css m denv = { SolverState = css m = m - ContextInfo = contextInfo + eContextInfo = contextInfo MatchingOnly = false ErrorOnFailedMemberConstraintResolution = false EquivEnv = TypeEquivEnv.Empty DisplayEnv = denv - Trace = NoTrace IsSpeculativeForMethodOverloading = false } /// Check whether a type variable occurs in the r.h.s. of a type, e.g. to catch @@ -502,6 +466,37 @@ let BakedInTraitConstraintNames = "Pow"; "Atan2" ] |> set +//------------------------------------------------------------------------- +// Run the constraint solver with undo (used during method overload resolution) + +type Trace = + { mutable actions: ((unit -> unit) * (unit -> unit)) list } + + static member New () = { actions = [] } + + member t.Undo () = List.iter (fun (_, a) -> a ()) t.actions + member t.Push f undo = t.actions <- (f, undo) :: t.actions + +type OptionalTrace = + | NoTrace + | WithTrace of Trace + + member x.HasTrace = match x with NoTrace -> false | WithTrace _ -> true + + member t.Exec f undo = + match t with + | WithTrace trace -> trace.Push f undo; f() + | NoTrace -> f() + + member t.CollectThenUndoOrCommit predicate f = + let newTrace = Trace.New() + let res = f newTrace + match predicate res, t with + | false, _ -> newTrace.Undo() + | true, WithTrace t -> t.actions <- newTrace.actions @ t.actions + | true, NoTrace -> () + res + let CollectThenUndo f = let trace = Trace.New() let res = f trace @@ -666,21 +661,21 @@ let SubstMeasure (r: Typar) ms = | None -> r.typar_solution <- Some (TType_measure ms) | Some _ -> error(InternalError("already solved", r.Range)) -let rec TransactStaticReq (csenv: ConstraintSolverEnv) (tpr: Typar) req = +let rec TransactStaticReq (csenv: ConstraintSolverEnv) (trace: OptionalTrace) (tpr: Typar) req = let m = csenv.m if tpr.Rigidity.ErrorIfUnified && tpr.StaticReq <> req then ErrorD(ConstraintSolverError(FSComp.SR.csTypeCannotBeResolvedAtCompileTime(tpr.Name), m, m)) else let orig = tpr.StaticReq - csenv.Trace.Exec (fun () -> tpr.SetStaticReq req) (fun () -> tpr.SetStaticReq orig) + trace.Exec (fun () -> tpr.SetStaticReq req) (fun () -> tpr.SetStaticReq orig) CompleteD -and SolveTypStaticReqTypar (csenv: ConstraintSolverEnv) req (tpr: Typar) = +and SolveTypStaticReqTypar (csenv: ConstraintSolverEnv) trace req (tpr: Typar) = let orig = tpr.StaticReq let req2 = JoinTyparStaticReq req orig - if orig <> req2 then TransactStaticReq csenv tpr req2 else CompleteD + if orig <> req2 then TransactStaticReq csenv trace tpr req2 else CompleteD -and SolveTypStaticReq (csenv: ConstraintSolverEnv) req ty = +and SolveTypStaticReq (csenv: ConstraintSolverEnv) trace req ty = match req with | TyparStaticReq.None -> CompleteD | TyparStaticReq.HeadType -> @@ -690,11 +685,11 @@ and SolveTypStaticReq (csenv: ConstraintSolverEnv) req ty = let vs = ListMeasureVarOccsWithNonZeroExponents ms trackErrors { for tpr, _ in vs do - return! SolveTypStaticReqTypar csenv req tpr + return! SolveTypStaticReqTypar csenv trace req tpr } | _ -> match tryAnyParTy csenv.g ty with - | ValueSome tpr -> SolveTypStaticReqTypar csenv req tpr + | ValueSome tpr -> SolveTypStaticReqTypar csenv trace req tpr | ValueNone -> CompleteD let TransactDynamicReq (trace: OptionalTrace) (tpr: Typar) req = @@ -702,13 +697,13 @@ let TransactDynamicReq (trace: OptionalTrace) (tpr: Typar) req = trace.Exec (fun () -> tpr.SetDynamicReq req) (fun () -> tpr.SetDynamicReq orig) CompleteD -let SolveTypDynamicReq (csenv: ConstraintSolverEnv) req ty = +let SolveTypDynamicReq (csenv: ConstraintSolverEnv) trace req ty = match req with | TyparDynamicReq.No -> CompleteD | TyparDynamicReq.Yes -> match tryAnyParTy csenv.g ty with | ValueSome tpr when tpr.DynamicReq <> TyparDynamicReq.Yes -> - TransactDynamicReq csenv.Trace tpr TyparDynamicReq.Yes + TransactDynamicReq trace tpr TyparDynamicReq.Yes | _ -> CompleteD let TransactIsCompatFlex (trace: OptionalTrace) (tpr: Typar) req = @@ -716,24 +711,24 @@ let TransactIsCompatFlex (trace: OptionalTrace) (tpr: Typar) req = trace.Exec (fun () -> tpr.SetIsCompatFlex req) (fun () -> tpr.SetIsCompatFlex orig) CompleteD -let SolveTypIsCompatFlex (csenv: ConstraintSolverEnv) req ty = +let SolveTypIsCompatFlex (csenv: ConstraintSolverEnv) trace req ty = if req then match tryAnyParTy csenv.g ty with - | ValueSome tpr when not tpr.IsCompatFlex -> TransactIsCompatFlex csenv.Trace tpr req + | ValueSome tpr when not tpr.IsCompatFlex -> TransactIsCompatFlex trace tpr req | _ -> CompleteD else CompleteD -let SubstMeasureWarnIfRigid (csenv: ConstraintSolverEnv) (v: Typar) ms = trackErrors { +let SubstMeasureWarnIfRigid (csenv: ConstraintSolverEnv) trace (v: Typar) ms = trackErrors { if v.Rigidity.WarnIfUnified && not (isAnyParTy csenv.g (TType_measure ms)) then // NOTE: we grab the name eagerly to make sure the type variable prints as a type variable let tpnmOpt = if v.IsCompilerGenerated then None else Some v.Name - do! SolveTypStaticReq csenv v.StaticReq (TType_measure ms) + do! SolveTypStaticReq csenv trace v.StaticReq (TType_measure ms) SubstMeasure v ms return! WarnD(NonRigidTypar(csenv.DisplayEnv, tpnmOpt, v.Range, TType_measure (Measure.Var v), TType_measure ms, csenv.m)) else // Propagate static requirements from 'tp' to 'ty' - do! SolveTypStaticReq csenv v.StaticReq (TType_measure ms) + do! SolveTypStaticReq csenv trace v.StaticReq (TType_measure ms) SubstMeasure v ms if v.Rigidity = TyparRigidity.Anon && measureEquiv csenv.g ms Measure.One then return! WarnD(Error(FSComp.SR.csCodeLessGeneric(), v.Range)) @@ -747,7 +742,7 @@ let SubstMeasureWarnIfRigid (csenv: ConstraintSolverEnv) (v: Typar) ms = trackEr /// - ms contains no non-rigid unit variables, and so cannot be unified with 1 /// - ms has the form v^e * ms' for some non-rigid variable v, non-zero exponent e, and measure expression ms' /// the most general unifier is then simply v := ms' ^ -(1/e) -let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) ms = +let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) trace ms = // Gather the rigid and non-rigid unit variables in this measure expression together with their exponents let rigidVars, nonRigidVars = ListMeasureVarOccsWithNonZeroExponents ms @@ -760,14 +755,14 @@ let UnifyMeasureWithOne (csenv: ConstraintSolverEnv) ms = let newms = ProdMeasures (List.map (fun (c, e') -> Measure.RationalPower (Measure.Con c, NegRational (DivRational e' e))) unexpandedCons @ List.map (fun (v, e') -> Measure.RationalPower (Measure.Var v, NegRational (DivRational e' e))) (vs @ rigidVars)) - SubstMeasureWarnIfRigid csenv v newms + SubstMeasureWarnIfRigid csenv trace v newms // Otherwise we require ms to be 1 | [] -> if measureEquiv csenv.g ms Measure.One then CompleteD else localAbortD /// Imperatively unify unit-of-measure expression ms1 against ms2 -let UnifyMeasures (csenv: ConstraintSolverEnv) ms1 ms2 = - UnifyMeasureWithOne csenv (Measure.Prod(ms1, Measure.Inv ms2)) +let UnifyMeasures (csenv: ConstraintSolverEnv) trace ms1 ms2 = + UnifyMeasureWithOne csenv trace (Measure.Prod(ms1, Measure.Inv ms2)) /// Simplify a unit-of-measure expression ms that forms part of a type scheme. /// We make substitutions for vars, which are the (remaining) bound variables @@ -936,45 +931,45 @@ let CheckWarnIfRigid (csenv: ConstraintSolverEnv) ty1 (r: Typar) ty = /// Add the constraint "ty1 = ty" to the constraint problem, where ty1 is a type variable. /// Propagate all effects of adding this constraint, e.g. to solve other variables -let rec SolveTyparEqualsTypePart1 (csenv: ConstraintSolverEnv) m2 ty1 r ty = trackErrors { +let rec SolveTyparEqualsTypePart1 (csenv: ConstraintSolverEnv) m2 (trace: OptionalTrace) ty1 r ty = trackErrors { // The types may still be equivalent due to abbreviations, which we are trying not to eliminate if typeEquiv csenv.g ty1 ty then () else // The famous 'occursCheck' check to catch "infinite types" like 'a = list<'a> - see also https://github.com/Microsoft/visualfsharp/issues/1170 - if occursCheck csenv.g r ty then return! ErrorD (ConstraintSolverInfiniteTypes(csenv.DisplayEnv, csenv.ContextInfo, ty1, ty, csenv.m, m2)) else + if occursCheck csenv.g r ty then return! ErrorD (ConstraintSolverInfiniteTypes(csenv.DisplayEnv, csenv.eContextInfo, ty1, ty, csenv.m, m2)) else // Note: warn _and_ continue! do! CheckWarnIfRigid csenv ty1 r ty // Record the solution before we solve the constraints, since // We may need to make use of the equation when solving the constraints. // Record a entry in the undo trace if one is provided - csenv.Trace.Exec (fun () -> r.typar_solution <- Some ty) (fun () -> r.typar_solution <- None) + trace.Exec (fun () -> r.typar_solution <- Some ty) (fun () -> r.typar_solution <- None) } -and SolveTyparEqualsTypePart2 (csenv: ConstraintSolverEnv) ndeep m2 (r: Typar) ty = trackErrors { +and SolveTyparEqualsTypePart2 (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) (r: Typar) ty = trackErrors { // Only solve constraints if this is not an error var if r.IsFromError then () else // Check to see if this type variable is relevant to any trait constraints. // If so, re-solve the relevant constraints. if csenv.SolverState.ExtraCxs.ContainsKey r.Stamp then - do! RepeatWhileD ndeep (fun ndeep -> SolveRelevantMemberConstraintsForTypar csenv ndeep PermitWeakResolution.No r) + do! RepeatWhileD ndeep (fun ndeep -> SolveRelevantMemberConstraintsForTypar csenv ndeep PermitWeakResolution.No trace r) // Re-solve the other constraints associated with this type variable - return! SolveTypMeetsTyparConstraints csenv ndeep m2 ty r + return! solveTypMeetsTyparConstraints csenv ndeep m2 trace ty r } /// Apply the constraints on 'typar' to the type 'ty' -and SolveTypMeetsTyparConstraints (csenv: ConstraintSolverEnv) ndeep m2 ty (r: Typar) = trackErrors { +and solveTypMeetsTyparConstraints (csenv: ConstraintSolverEnv) ndeep m2 trace ty (r: Typar) = trackErrors { let g = csenv.g // Propagate compat flex requirements from 'tp' to 'ty' - do! SolveTypIsCompatFlex csenv r.IsCompatFlex ty + do! SolveTypIsCompatFlex csenv trace r.IsCompatFlex ty // Propagate dynamic requirements from 'tp' to 'ty' - do! SolveTypDynamicReq csenv r.DynamicReq ty + do! SolveTypDynamicReq csenv trace r.DynamicReq ty // Propagate static requirements from 'tp' to 'ty' - do! SolveTypStaticReq csenv r.StaticReq ty + do! SolveTypStaticReq csenv trace r.StaticReq ty // Solve constraints on 'tp' w.r.t. 'ty' for e in r.Constraints do @@ -987,61 +982,46 @@ and SolveTypMeetsTyparConstraints (csenv: ConstraintSolverEnv) ndeep m2 ty (r: T match tryDestTyparTy g ty with | ValueNone -> CompleteD | ValueSome destTypar -> - AddConstraint csenv ndeep m2 destTypar (TyparConstraint.DefaultsTo(priority, dty, m)) + AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.DefaultsTo(priority, dty, m)) - | TyparConstraint.SupportsNull m2 -> SolveTypeSupportsNull csenv ndeep m2 ty - | TyparConstraint.IsEnum(underlying, m2) -> SolveTypeIsEnum csenv ndeep m2 ty underlying - | TyparConstraint.SupportsComparison(m2) -> SolveTypeSupportsComparison csenv ndeep m2 ty - | TyparConstraint.SupportsEquality(m2) -> SolveTypeSupportsEquality csenv ndeep m2 ty - | TyparConstraint.IsDelegate(aty, bty, m2) -> SolveTypeIsDelegate csenv ndeep m2 ty aty bty - | TyparConstraint.IsNonNullableStruct m2 -> SolveTypeIsNonNullableValueType csenv ndeep m2 ty - | TyparConstraint.IsUnmanaged m2 -> SolveTypeIsUnmanaged csenv ndeep m2 ty - | TyparConstraint.IsReferenceType m2 -> SolveTypeIsReferenceType csenv ndeep m2 ty - | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypeRequiresDefaultConstructor csenv ndeep m2 ty - | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypeChoice csenv ndeep m2 ty tys - | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 ty2 ty + | TyparConstraint.SupportsNull m2 -> SolveTypeSupportsNull csenv ndeep m2 trace ty + | TyparConstraint.IsEnum(underlying, m2) -> SolveTypeIsEnum csenv ndeep m2 trace ty underlying + | TyparConstraint.SupportsComparison(m2) -> SolveTypeSupportsComparison csenv ndeep m2 trace ty + | TyparConstraint.SupportsEquality(m2) -> SolveTypeSupportsEquality csenv ndeep m2 trace ty + | TyparConstraint.IsDelegate(aty, bty, m2) -> SolveTypeIsDelegate csenv ndeep m2 trace ty aty bty + | TyparConstraint.IsNonNullableStruct m2 -> SolveTypeIsNonNullableValueType csenv ndeep m2 trace ty + | TyparConstraint.IsUnmanaged m2 -> SolveTypeIsUnmanaged csenv ndeep m2 trace ty + | TyparConstraint.IsReferenceType m2 -> SolveTypeIsReferenceType csenv ndeep m2 trace ty + | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypeRequiresDefaultConstructor csenv ndeep m2 trace ty + | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypeChoice csenv ndeep m2 trace ty tys + | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 trace None ty2 ty | TyparConstraint.MayResolveMember(traitInfo, m2) -> - SolveMemberConstraint csenv false PermitWeakResolution.No ndeep m2 traitInfo |> OperationResult.ignore + SolveMemberConstraint csenv false PermitWeakResolution.No ndeep m2 trace traitInfo |> OperationResult.ignore } -and SolveTyparEqualsType (csenv: ConstraintSolverEnv) ndeep m2 ty1 ty = trackErrors { +and SolveTyparEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) ty1 ty = trackErrors { let m = csenv.m do! DepthCheck ndeep m match ty1 with | TType_var r | TType_measure (Measure.Var r) -> - do! SolveTyparEqualsTypePart1 csenv m2 ty1 r ty - do! SolveTyparEqualsTypePart2 csenv ndeep m2 r ty + do! SolveTyparEqualsTypePart1 csenv m2 trace ty1 r ty + do! SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty | _ -> failwith "SolveTyparEqualsType" } // Like SolveTyparEqualsType but asserts all typar equalities simultaneously instead of one by one -and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 tptys tys = trackErrors { +and SolveTyparsEqualTypes (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) tptys tys = trackErrors { do! (tptys, tys) ||> Iterate2D (fun tpty ty -> match tpty with - | TType_var r | TType_measure (Measure.Var r) -> SolveTyparEqualsTypePart1 csenv m2 tpty r ty + | TType_var r | TType_measure (Measure.Var r) -> SolveTyparEqualsTypePart1 csenv m2 trace tpty r ty | _ -> failwith "SolveTyparsEqualTypes") do! (tptys, tys) ||> Iterate2D (fun tpty ty -> match tpty with - | TType_var r | TType_measure (Measure.Var r) -> SolveTyparEqualsTypePart2 csenv ndeep m2 r ty + | TType_var r | TType_measure (Measure.Var r) -> SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty | _ -> failwith "SolveTyparsEqualTypes") } -and (|Subset|Superset|Overlap|CompletelyDifferent|) (first, second) = - let first = Set first - let second = Set second - let secondOnly = Set.toList (second - first) - let firstOnly = Set.toList (first - second) - - if second.IsSubsetOf first then - Subset firstOnly - elif second.IsSupersetOf first then - Superset secondOnly - elif Set.intersect first second <> Set.empty then - Overlap(firstOnly, secondOnly) - else - CompletelyDifferent(Seq.toList first) - and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: AnonRecdTypeInfo) (anonInfo2: AnonRecdTypeInfo) = if evalTupInfoIsStruct anonInfo1.TupInfo <> evalTupInfoIsStruct anonInfo2.TupInfo then ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m,m2)) else (match anonInfo1.Assembly, anonInfo2.Assembly with @@ -1050,6 +1030,21 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon if not (anonInfo1.SortedNames = anonInfo2.SortedNames) then + let (|Subset|Superset|Overlap|CompletelyDifferent|) (first, second) = + let first = Set first + let second = Set second + let secondOnly = Set.toList (second - first) + let firstOnly = Set.toList (first - second) + + if second.IsSubsetOf first then + Subset firstOnly + elif second.IsSupersetOf first then + Superset secondOnly + elif Set.intersect first second <> Set.empty then + Overlap(firstOnly, secondOnly) + else + CompletelyDifferent(Seq.toList first) + let message = match anonInfo1.SortedNames, anonInfo2.SortedNames with | Subset missingFields -> @@ -1067,14 +1062,22 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon /// Add the constraint "ty1 = ty2" to the constraint problem. /// Propagate all effects of adding this constraint, e.g. to solve type variables -and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 ty1 ty2 = +and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) (cxsln:(TraitConstraintInfo * TraitConstraintSln) option) ty1 ty2 = let ndeep = ndeep + 1 let aenv = csenv.EquivEnv let g = csenv.g + // Pre F# 6.0 we asssert the trait solution here + if csenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then + match cxsln with + | Some (traitInfo, traitSln) when traitInfo.Solution.IsNone -> + // If this is an overload resolution at this point it's safe to assume the candidate member being evaluated solves this member constraint. + TransactMemberConstraintSolution traitInfo trace traitSln + | _ -> () + if ty1 === ty2 then CompleteD else - let canShortcut = not csenv.Trace.HasTrace + let canShortcut = not trace.HasTrace let sty1 = stripTyEqnsA csenv.g canShortcut ty1 let sty2 = stripTyEqnsA csenv.g canShortcut ty2 @@ -1082,59 +1085,53 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 ty1 ty2 = // type vars inside forall-types may be alpha-equivalent | TType_var tp1, TType_var tp2 when typarEq tp1 tp2 || (match aenv.EquivTypars.TryFind tp1 with | Some v when typeEquiv g v ty2 -> true | _ -> false) -> CompleteD - | TType_var tp1, TType_var tp2 when PreferUnifyTypar tp1 tp2 -> SolveTyparEqualsType csenv ndeep m2 sty1 ty2 - | TType_var tp1, TType_var tp2 when not csenv.MatchingOnly && PreferUnifyTypar tp2 tp1 -> SolveTyparEqualsType csenv ndeep m2 sty2 ty1 + | TType_var tp1, TType_var tp2 when PreferUnifyTypar tp1 tp2 -> SolveTyparEqualsType csenv ndeep m2 trace sty1 ty2 + | TType_var tp1, TType_var tp2 when not csenv.MatchingOnly && PreferUnifyTypar tp2 tp1 -> SolveTyparEqualsType csenv ndeep m2 trace sty2 ty1 - | TType_var r, _ when (r.Rigidity <> TyparRigidity.Rigid) -> SolveTyparEqualsType csenv ndeep m2 sty1 ty2 - | _, TType_var r when (r.Rigidity <> TyparRigidity.Rigid) && not csenv.MatchingOnly -> SolveTyparEqualsType csenv ndeep m2 sty2 ty1 + | TType_var r, _ when (r.Rigidity <> TyparRigidity.Rigid) -> SolveTyparEqualsType csenv ndeep m2 trace sty1 ty2 + | _, TType_var r when (r.Rigidity <> TyparRigidity.Rigid) && not csenv.MatchingOnly -> SolveTyparEqualsType csenv ndeep m2 trace sty2 ty1 // Catch float<_>=float<1>, float32<_>=float32<1> and decimal<_>=decimal<1> | _, TType_app (tc2, [ms]) when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsType csenv ndeep m2 ms (TType_measure Measure.One) + -> SolveTypeEqualsType csenv ndeep m2 trace None ms (TType_measure Measure.One) | TType_app (tc2, [ms]), _ when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty2 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsType csenv ndeep m2 ms (TType_measure Measure.One) - - | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 -> - SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 + -> SolveTypeEqualsType csenv ndeep m2 trace None ms (TType_measure Measure.One) - | TType_app _, TType_app _ -> - localAbortD - - | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) -> + | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 + | TType_app _, TType_app _ -> localAbortD + | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) -> if evalTupInfoIsStruct tupInfo1 <> evalTupInfoIsStruct tupInfo2 then ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m, m2)) else - SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 + SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 | TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) -> SolveAnonInfoEqualsAnonInfo csenv m2 anonInfo1 anonInfo2 ++ (fun () -> - SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2) - - | TType_fun (d1, r1), TType_fun (d2, r2) -> - SolveFunTypeEqn csenv ndeep m2 d1 d2 r1 r2 - - | TType_measure ms1, TType_measure ms2 -> - UnifyMeasures csenv ms1 ms2 + SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2) + | TType_fun (d1, r1), TType_fun (d2, r2) -> SolveFunTypeEqn csenv ndeep m2 trace None d1 d2 r1 r2 + | TType_measure ms1, TType_measure ms2 -> UnifyMeasures csenv trace ms1 ms2 | TType_forall(tps1, rty1), TType_forall(tps2, rty2) -> if tps1.Length <> tps2.Length then localAbortD else let aenv = aenv.BindEquivTypars tps1 tps2 let csenv = {csenv with EquivEnv = aenv } if not (typarsAEquiv g aenv tps1 tps2) then localAbortD else - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty1 rty2 + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty1 rty2 - | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2 -> - SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 + | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2 -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 + | _ -> localAbortD | _ -> localAbortD -and SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty1 ty2 = +and SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty1 ty2 = SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace None ty1 ty2 + +and SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ty1 ty2 = // Back out of expansions of type abbreviations to give improved error messages. // Note: any "normalization" of equations on type variables must respect the trace parameter - TryD (fun () -> SolveTypeEqualsType csenv ndeep m2 ty1 ty2) + TryD (fun () -> SolveTypeEqualsType csenv ndeep m2 trace cxsln ty1 ty2) (function - | LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInEqualityRelation(csenv.DisplayEnv, ty1, ty2, csenv.m, m2, csenv.ContextInfo)) + | LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInEqualityRelation(csenv.DisplayEnv, ty1, ty2, csenv.m, m2, csenv.eContextInfo)) | err -> ErrorD err) -and SolveTypeEqualsTypeEqns csenv ndeep m2 origl1 origl2 = +and SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln origl1 origl2 = match origl1, origl2 with | [], [] -> CompleteD | _ -> @@ -1143,14 +1140,14 @@ and SolveTypeEqualsTypeEqns csenv ndeep m2 origl1 origl2 = match l1, l2 with | [], [] -> CompleteD | h1 :: t1, h2 :: t2 -> - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 h1 h2 ++ (fun () -> loop t1 t2) + SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln h1 h2 ++ (fun () -> loop t1 t2) | _ -> ErrorD(ConstraintSolverTupleDiffLengths(csenv.DisplayEnv, origl1, origl2, csenv.m, m2)) loop origl1 origl2 -and SolveFunTypeEqn csenv ndeep m2 d1 d2 r1 r2 = trackErrors { - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 d1 d2 - return! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 r1 r2 +and SolveFunTypeEqn csenv ndeep m2 trace cxsln d1 d2 r1 r2 = trackErrors { + do! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln d1 d2 + return! SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln r1 r2 } // ty1: expected @@ -1158,12 +1155,12 @@ and SolveFunTypeEqn csenv ndeep m2 d1 d2 r1 r2 = trackErrors { // // "ty2 casts to ty1" // "a value of type ty2 can be used where a value of type ty1 is expected" -and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 ty1 ty2 = +and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) cxsln ty1 ty2 = // 'a :> obj ---> let ndeep = ndeep + 1 let g = csenv.g if isObjTy g ty1 then CompleteD else - let canShortcut = not csenv.Trace.HasTrace + let canShortcut = not trace.HasTrace let sty1 = stripTyEqnsA csenv.g canShortcut ty1 let sty2 = stripTyEqnsA csenv.g canShortcut ty2 @@ -1174,54 +1171,54 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 ty1 ty2 = match sty1, sty2 with | TType_var tp1, _ -> match aenv.EquivTypars.TryFind tp1 with - | Some v -> SolveTypeSubsumesType csenv ndeep m2 v ty2 + | Some v -> SolveTypeSubsumesType csenv ndeep m2 trace cxsln v ty2 | _ -> match sty2 with | TType_var r2 when typarEq tp1 r2 -> CompleteD - | TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 r ty1 - | _ -> SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty1 ty2 + | TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 trace r ty1 + | _ -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ty1 ty2 - | _, TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 r ty1 + | _, TType_var r when not csenv.MatchingOnly -> SolveTyparSubtypeOfType csenv ndeep m2 trace r ty1 | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) -> if evalTupInfoIsStruct tupInfo1 <> evalTupInfoIsStruct tupInfo2 then ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m, m2)) else - SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 (* nb. can unify since no variance *) + SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 (* nb. can unify since no variance *) | TType_anon (anonInfo1, l1), TType_anon (anonInfo2, l2) -> SolveAnonInfoEqualsAnonInfo csenv m2 anonInfo1 anonInfo2 ++ (fun () -> - SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2) (* nb. can unify since no variance *) + SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2) (* nb. can unify since no variance *) | TType_fun (d1, r1), TType_fun (d2, r2) -> - SolveFunTypeEqn csenv ndeep m2 d1 d2 r1 r2 (* nb. can unify since no variance *) + SolveFunTypeEqn csenv ndeep m2 trace cxsln d1 d2 r1 r2 (* nb. can unify since no variance *) | TType_measure ms1, TType_measure ms2 -> - UnifyMeasures csenv ms1 ms2 + UnifyMeasures csenv trace ms1 ms2 // Enforce the identities float=float<1>, float32=float32<1> and decimal=decimal<1> | _, TType_app (tc2, [ms]) when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ms (TType_measure Measure.One) + -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms (TType_measure Measure.One) | TType_app (tc2, [ms]), _ when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty2 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) - -> SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ms (TType_measure Measure.One) + -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ms (TType_measure Measure.One) // Special subsumption rule for byref tags | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 && g.byref2_tcr.CanDeref && tyconRefEq g g.byref2_tcr tc1 -> match l1, l2 with | [ h1; tag1 ], [ h2; tag2 ] -> trackErrors { - do! SolveTypeEqualsType csenv ndeep m2 h1 h2 + do! SolveTypeEqualsType csenv ndeep m2 trace cxsln h1 h2 match stripTyEqnsA csenv.g canShortcut tag1, stripTyEqnsA csenv.g canShortcut tag2 with | TType_app(tagc1, []), TType_app(tagc2, []) when (tyconRefEq g tagc2 g.byrefkind_InOut_tcr && (tyconRefEq g tagc1 g.byrefkind_In_tcr || tyconRefEq g tagc1 g.byrefkind_Out_tcr) ) -> () - | _ -> return! SolveTypeEqualsType csenv ndeep m2 tag1 tag2 + | _ -> return! SolveTypeEqualsType csenv ndeep m2 trace cxsln tag1 tag2 } - | _ -> SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 + | _ -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 -> - SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 + SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2 -> - SolveTypeEqualsTypeEqns csenv ndeep m2 l1 l2 + SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2 | _ -> // By now we know the type is not a variable type @@ -1249,7 +1246,7 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 ty1 ty2 = match tinst with | [ty1arg] -> let ty2arg = destArrayTy g ty2 - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty1arg ty2arg + SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ty1arg ty2arg | _ -> error(InternalError("destArrayTy", m)) | _ -> @@ -1258,11 +1255,11 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 ty1 ty2 = // may feasibly convert to Head. match FindUniqueFeasibleSupertype g amap m ty1 ty2 with | None -> ErrorD(ConstraintSolverTypesNotInSubsumptionRelation(denv, ty1, ty2, m, m2)) - | Some t -> SolveTypeSubsumesType csenv ndeep m2 ty1 t + | Some t -> SolveTypeSubsumesType csenv ndeep m2 trace cxsln ty1 t -and SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 ty1 ty2 = +and SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 trace cxsln ty1 ty2 = let denv = csenv.DisplayEnv - TryD (fun () -> SolveTypeSubsumesType csenv ndeep m2 ty1 ty2) + TryD (fun () -> SolveTypeSubsumesType csenv ndeep m2 trace cxsln ty1 ty2) (function | LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInSubsumptionRelation(denv, ty1, ty2, csenv.m, m2)) | err -> ErrorD err) @@ -1271,23 +1268,23 @@ and SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m2 ty1 ty2 = // Solve and record non-equality constraints //------------------------------------------------------------------------- -and SolveTyparSubtypeOfType (csenv: ConstraintSolverEnv) ndeep m2 tp ty1 = +and SolveTyparSubtypeOfType (csenv: ConstraintSolverEnv) ndeep m2 trace tp ty1 = let g = csenv.g if isObjTy g ty1 then CompleteD elif typeEquiv g ty1 (mkTyparTy tp) then CompleteD elif isSealedTy g ty1 then - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 (mkTyparTy tp) ty1 + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace (mkTyparTy tp) ty1 else - AddConstraint csenv ndeep m2 tp (TyparConstraint.CoercesTo(ty1, csenv.m)) + AddConstraint csenv ndeep m2 trace tp (TyparConstraint.CoercesTo(ty1, csenv.m)) and DepthCheck ndeep m = if ndeep > 300 then error(Error(FSComp.SR.csTypeInferenceMaxDepth(), m)) else CompleteD // If this is a type that's parameterized on a unit-of-measure (expected to be numeric), unify its measure with 1 -and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 ty = +and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 trace ty = match getMeasureOfType csenv.g ty with | Some (tcref, _) -> - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty (mkAppTy tcref [TType_measure Measure.One]) + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty (mkAppTy tcref [TType_measure Measure.One]) | None -> CompleteD @@ -1299,7 +1296,7 @@ and SolveDimensionlessNumericType (csenv: ConstraintSolverEnv) ndeep m2 ty = /// will deal with the problem. /// /// 2. Some additional solutions are forced prior to generalization (permitWeakResolution= Yes or YesDuringCodeGen). See above -and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemberConstraintResolution permitWeakResolution ndeep m2 traitInfo : OperationResult = trackErrors { +and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace traitInfo : OperationResult = trackErrors { let (TTrait(tys, nm, memFlags, traitObjAndArgTys, rty, sln)) = traitInfo // Do not re-solve if already solved if sln.Value.IsSome then return true else @@ -1321,11 +1318,11 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb // Assert the object type if the constraint is for an instance member if memFlags.IsInstance then match tys, traitObjAndArgTys with - | [ty], h :: _ -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 h ty + | [ty], h :: _ -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace h ty | _ -> do! ErrorD (ConstraintSolverError(FSComp.SR.csExpectedArguments(), m, m2)) // Trait calls are only supported on pseudo type (variables) for e in tys do - do! SolveTypStaticReq csenv TyparStaticReq.HeadType e + do! SolveTypStaticReq csenv trace TyparStaticReq.HeadType e let argtys = if memFlags.IsInstance then List.tail traitObjAndArgTys else traitObjAndArgTys @@ -1376,8 +1373,8 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb match getMeasureOfType g argty1 with | Some (tcref, ms1) -> let ms2 = freshMeasure () - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 (mkAppTy tcref [TType_measure ms2]) - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 (mkAppTy tcref [TType_measure ms2]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) return TTraitBuiltIn | _ -> @@ -1385,14 +1382,14 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb match getMeasureOfType g argty2 with | Some (tcref, ms2) -> let ms1 = freshMeasure () - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty1 (mkAppTy tcref [TType_measure ms1]) - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty1 (mkAppTy tcref [TType_measure ms1]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) return TTraitBuiltIn | _ -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn | _, _, false, ("op_Addition" | "op_Subtraction" | "op_Modulus"), [argty1;argty2] @@ -1400,8 +1397,8 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.ApparentEnclosingType ) && ( IsAddSubModType nm g argty1 && IsBinaryOpOtherArgType g permitWeakResolution argty2 || IsAddSubModType nm g argty2 && IsBinaryOpOtherArgType g permitWeakResolution argty1)) -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn | _, _, false, ("op_LessThan" | "op_LessThanOrEqual" | "op_GreaterThan" | "op_GreaterThanOrEqual" | "op_Equality" | "op_Inequality" ), [argty1;argty2] @@ -1409,35 +1406,35 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.ApparentEnclosingType ) && ( IsRelationalType g argty1 && IsBinaryOpOtherArgType g permitWeakResolution argty2 || IsRelationalType g argty2 && IsBinaryOpOtherArgType g permitWeakResolution argty1)) -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty g.bool_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.bool_ty return TTraitBuiltIn // We pretend for uniformity that the numeric types have a static property called Zero and One // As with constants, only zero is polymorphic in its units | [], [ty], false, "get_Zero", [] when IsNumericType g ty || isCharTy g ty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ty return TTraitBuiltIn | [], [ty], false, "get_One", [] when IsNumericType g ty || isCharTy g ty -> - do! SolveDimensionlessNumericType csenv ndeep m2 ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty ty + do! SolveDimensionlessNumericType csenv ndeep m2 trace ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ty return TTraitBuiltIn | [], _, false, "DivideByInt", [argty1;argty2] when isFpTy g argty1 || isDecimalTy g argty1 -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 g.int_ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 g.int_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn // We pretend for uniformity that the 'string' and 'array' types have an indexer property called 'Item' | [], [ty], true, "get_Item", [argty1] when isStringTy g ty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty1 g.int_ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty g.char_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty1 g.int_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.char_ty return TTraitBuiltIn | [], [ty], true, "get_Item", argtys @@ -1446,9 +1443,9 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb if rankOfArrayTy g ty <> argtys.Length then do! ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), argtys.Length), m, m2)) for argty in argtys do - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty g.int_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty g.int_ty let ety = destArrayTy g ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty ety + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ety return TTraitBuiltIn | [], [ty], true, "set_Item", argtys @@ -1458,57 +1455,57 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb do! ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), (argtys.Length - 1)), m, m2)) let argtys, ety = List.frontAndBack argtys for argty in argtys do - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty g.int_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty g.int_ty let etys = destArrayTy g ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ety etys + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ety etys return TTraitBuiltIn | [], _, false, ("op_BitwiseAnd" | "op_BitwiseOr" | "op_ExclusiveOr"), [argty1;argty2] when IsBitwiseOpType g argty1 && IsBinaryOpOtherArgType g permitWeakResolution argty2 || IsBitwiseOpType g argty2 && IsBinaryOpOtherArgType g permitWeakResolution argty1 -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 - do! SolveDimensionlessNumericType csenv ndeep m2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 + do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 return TTraitBuiltIn | [], _, false, ("op_LeftShift" | "op_RightShift"), [argty1;argty2] when IsIntegerOrIntegerEnumTy g argty1 -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 g.int_ty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 - do! SolveDimensionlessNumericType csenv ndeep m2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 g.int_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 + do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 return TTraitBuiltIn | _, _, false, "op_UnaryPlus", [argty] when IsNumericOrIntegralEnumType g argty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn | _, _, false, "op_UnaryNegation", [argty] when isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn | _, _, true, "get_Sign", [] when IsSignType g tys.Head -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty g.int32_ty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.int32_ty return TTraitBuiltIn | _, _, false, ("op_LogicalNot" | "op_OnesComplement"), [argty] when IsIntegerOrIntegerEnumTy g argty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty - do! SolveDimensionlessNumericType csenv ndeep m2 argty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty + do! SolveDimensionlessNumericType csenv ndeep m2 trace argty return TTraitBuiltIn | _, _, false, "Abs", [argty] when isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn | _, _, false, "Sqrt", [argty1] @@ -1516,18 +1513,18 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb match getMeasureOfType g argty1 with | Some (tcref, _) -> let ms1 = freshMeasure () - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty1 (mkAppTy tcref [TType_measure (Measure.Prod (ms1, ms1))]) - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty (mkAppTy tcref [TType_measure ms1]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty1 (mkAppTy tcref [TType_measure (Measure.Prod (ms1, ms1))]) + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure ms1]) return TTraitBuiltIn | None -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn | _, _, false, ("Sin" | "Cos" | "Tan" | "Sinh" | "Cosh" | "Tanh" | "Atan" | "Acos" | "Asin" | "Exp" | "Ceiling" | "Floor" | "Round" | "Truncate" | "Log10" | "Log" | "Sqrt"), [argty] when isFpTy g argty -> - do! SolveDimensionlessNumericType csenv ndeep m2 argty - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty + do! SolveDimensionlessNumericType csenv ndeep m2 trace argty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn | _, _, false, "op_Explicit", [argty] @@ -1554,17 +1551,17 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb | [], _, false, "Pow", [argty1; argty2] when isFpTy g argty1 -> - do! SolveDimensionlessNumericType csenv ndeep m2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 + do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn | _, _, false, "Atan2", [argty1; argty2] when isFpTy g argty1 -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 argty2 argty1 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 match getMeasureOfType g argty1 with - | None -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty argty1 - | Some (tcref, _) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty (mkAppTy tcref [TType_measure Measure.One]) + | None -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 + | Some (tcref, _) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure Measure.One]) return TTraitBuiltIn | _ -> @@ -1655,23 +1652,22 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo, m, AccessibleFromEverywhere, minfo, minst, minst, None, objtys, callerArgs, false, false, None))) let methOverloadResult, errors = - csenv.Trace.CollectThenUndoOrCommit + trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) (fun newTrace -> - let csenv = { csenv with Trace = WithTrace newTrace } - ResolveOverloading csenv nm ndeep (Some traitInfo) CallerArgs.Empty AccessibleFromEverywhere calledMethGroup false (Some (MustEqual rty))) + ResolveOverloading csenv (WithTrace newTrace) nm ndeep (Some traitInfo) CallerArgs.Empty AccessibleFromEverywhere calledMethGroup false (Some (MustEqual rty))) match anonRecdPropSearch, recdPropSearch, methOverloadResult with | Some (anonInfo, tinst, i), None, None -> // OK, the constraint is solved by a record property. Assert that the return types match. let rty2 = List.item i tinst - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty rty2 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty rty2 return TTraitSolvedAnonRecdProp(anonInfo, tinst, i) | None, Some (rfinfo, isSetProp), None -> // OK, the constraint is solved by a record property. Assert that the return types match. let rty2 = if isSetProp then g.unit_ty else rfinfo.FieldType - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty rty2 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty rty2 return TTraitSolvedRecdProp(rfinfo, isSetProp) | None, None, Some (calledMeth: CalledMeth<_>) -> @@ -1701,19 +1697,19 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) suppressErrorOnFailedMemb do! errors // Otherwise re-record the trait waiting for canonicalization else - do! AddMemberConstraint csenv ndeep m2 traitInfo support frees + do! AddMemberConstraint csenv ndeep m2 trace traitInfo support frees match errors with | ErrorResult (_, UnresolvedOverloading _) when - not suppressErrorOnFailedMemberConstraintResolution && + not ignoreUnresolvedOverload && csenv.ErrorOnFailedMemberConstraintResolution && (not (nm = "op_Explicit" || nm = "op_Implicit")) -> return! ErrorD AbortForFailedMemberConstraintResolution | _ -> return TTraitUnsolved } - return! RecordMemberConstraintSolution csenv.SolverState m csenv.Trace traitInfo res + return! RecordMemberConstraintSolution csenv.SolverState m trace traitInfo res } /// Record the solution to a member constraint in the mutable reference cell attached to @@ -1855,7 +1851,7 @@ and MemberConstraintSupportIsReadyForDeterminingOverloads csenv traitInfo = /// Re-solve the global constraints involving any of the given type variables. /// Trait constraints can't always be solved using the pessimistic rules. We only canonicalize /// them forcefully (permitWeakResolution=true) prior to generalization. -and SolveRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep permitWeakResolution tps = +and SolveRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep permitWeakResolution trace tps = RepeatWhileD ndeep (fun ndeep -> tps @@ -1864,28 +1860,28 @@ and SolveRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep permitWeak let ty = mkTyparTy tp match tryAnyParTy csenv.g ty with | ValueSome tp -> - SolveRelevantMemberConstraintsForTypar csenv ndeep permitWeakResolution tp + SolveRelevantMemberConstraintsForTypar csenv ndeep permitWeakResolution trace tp | ValueNone -> ResultD false)) -and SolveRelevantMemberConstraintsForTypar (csenv: ConstraintSolverEnv) ndeep permitWeakResolution tp = +and SolveRelevantMemberConstraintsForTypar (csenv: ConstraintSolverEnv) ndeep permitWeakResolution (trace: OptionalTrace) tp = let cxst = csenv.SolverState.ExtraCxs let tpn = tp.Stamp let cxs = cxst.FindAll tpn if isNil cxs then ResultD false else - csenv.Trace.Exec (fun () -> cxs |> List.iter (fun _ -> cxst.Remove tpn)) (fun () -> cxs |> List.iter (fun cx -> cxst.Add(tpn, cx))) + trace.Exec (fun () -> cxs |> List.iter (fun _ -> cxst.Remove tpn)) (fun () -> cxs |> List.iter (fun cx -> cxst.Add(tpn, cx))) assert (isNil (cxst.FindAll tpn)) cxs |> AtLeastOneD (fun (traitInfo, m2) -> let csenv = { csenv with m = m2 } - SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 traitInfo) + SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo) and CanonicalizeRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep tps = SolveRelevantMemberConstraints csenv ndeep PermitWeakResolution.Yes tps -and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 traitInfo support (frees: Typar list) = +and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 trace traitInfo support (frees: Typar list) = let g = csenv.g let aenv = csenv.EquivEnv let cxst = csenv.SolverState.ExtraCxs @@ -1901,19 +1897,19 @@ and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 traitInfo support // check the constraint is not already listed for this type variable if not (cxs |> List.exists (fun (traitInfo2, _) -> traitsAEquiv g aenv traitInfo traitInfo2)) then - csenv.Trace.Exec (fun () -> csenv.SolverState.ExtraCxs.Add (tpn, (traitInfo, m2))) (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) + trace.Exec (fun () -> csenv.SolverState.ExtraCxs.Add (tpn, (traitInfo, m2))) (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) ) // Associate the constraint with each type variable in the support, so if the type variable // gets generalized then this constraint is attached at the binding site. trackErrors { for tp in support do - do! AddConstraint csenv ndeep m2 tp (TyparConstraint.MayResolveMember(traitInfo, m2)) + do! AddConstraint csenv ndeep m2 trace tp (TyparConstraint.MayResolveMember(traitInfo, m2)) } /// Record a constraint on an inference type variable. -and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 tp newConstraint = +and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 trace tp newConstraint = let g = csenv.g let aenv = csenv.EquivEnv let amap = csenv.amap @@ -1940,8 +1936,8 @@ and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 tp newConstraint = let rty1 = GetFSharpViewOfReturnType g rty1 let rty2 = GetFSharpViewOfReturnType g rty2 trackErrors { - do! Iterate2D (SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2) argtys1 argtys2 - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 rty1 rty2 + do! Iterate2D (SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace) argtys1 argtys2 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty1 rty2 () } @@ -1961,17 +1957,17 @@ and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 tp newConstraint = for ty1Parent in parents1 do for ty2Parent in parents2 do do! if not (HaveSameHeadType g ty1Parent ty2Parent) then CompleteD else - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 ty1Parent ty2Parent + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty1Parent ty2Parent } | (TyparConstraint.IsEnum (u1, _), TyparConstraint.IsEnum (u2, m2)) -> - SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 u1 u2 + SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace u1 u2 | (TyparConstraint.IsDelegate (aty1, bty1, _), TyparConstraint.IsDelegate (aty2, bty2, m2)) -> trackErrors { - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 aty1 aty2 - return! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 bty1 bty2 + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace aty1 aty2 + return! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace bty1 bty2 } | TyparConstraint.SupportsComparison _, TyparConstraint.IsDelegate _ @@ -2078,18 +2074,17 @@ and AddConstraint (csenv: ConstraintSolverEnv) ndeep m2 tp newConstraint = // Write the constraint into the type variable // Record a entry in the undo trace if one is provided let orig = tp.Constraints - csenv.Trace.Exec (fun () -> tp.SetConstraints newConstraints) (fun () -> tp.SetConstraints orig) + trace.Exec (fun () -> tp.SetConstraints newConstraints) (fun () -> tp.SetConstraints orig) () } - -and SolveTypeSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 ty = +and SolveTypeSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 trace ty = let g = csenv.g let m = csenv.m let denv = csenv.DisplayEnv match tryDestTyparTy g ty with | ValueSome destTypar -> - AddConstraint csenv ndeep m2 destTypar (TyparConstraint.SupportsNull m) + AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.SupportsNull m) | ValueNone -> if TypeSatisfiesNullConstraint g m ty then CompleteD else match ty with @@ -2098,14 +2093,14 @@ and SolveTypeSupportsNull (csenv: ConstraintSolverEnv) ndeep m2 ty = | _ -> ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotHaveNull(NicePrint.minimalStringOfType denv ty), m, m2)) -and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 ty = +and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty = let g = csenv.g let m = csenv.m let amap = csenv.amap let denv = csenv.DisplayEnv match tryDestTyparTy g ty with | ValueSome destTypar -> - AddConstraint csenv ndeep m2 destTypar (TyparConstraint.SupportsComparison m) + AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.SupportsComparison m) | ValueNone -> // Check it isn't ruled out by the user match tryTcrefOfAppTy g ty with @@ -2114,7 +2109,7 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 ty = | _ -> match ty with | SpecialComparableHeadType g tinst -> - tinst |> IterateD (SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2) + tinst |> IterateD (SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace) | _ -> // Check the basic requirement - IComparable or IStructuralComparable or assumed if ExistsSameHeadTypeInHierarchy g amap m2 ty g.mk_IComparable_ty || @@ -2126,7 +2121,7 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 ty = // Check the (possibly inferred) structural dependencies (tinst, tcref.TyparsNoRange) ||> Iterate2D (fun ty tp -> if tp.ComparisonConditionalOn then - SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 ty + SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty else CompleteD) | _ -> @@ -2143,13 +2138,13 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 ty = else ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison2(NicePrint.minimalStringOfType denv ty), m, m2)) -and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 ty = +and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty = let g = csenv.g let m = csenv.m let denv = csenv.DisplayEnv match tryDestTyparTy g ty with | ValueSome destTypar -> - AddConstraint csenv ndeep m2 destTypar (TyparConstraint.SupportsEquality m) + AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.SupportsEquality m) | _ -> match tryTcrefOfAppTy g ty with | ValueSome tcref when HasFSharpAttribute g g.attrib_NoEqualityAttribute tcref.Attribs -> @@ -2157,7 +2152,7 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 ty = | _ -> match ty with | SpecialEquatableHeadType g tinst -> - tinst |> IterateD (SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2) + tinst |> IterateD (SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace) | SpecialNotEquatableHeadType g _ -> ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality2(NicePrint.minimalStringOfType denv ty), m, m2)) | _ -> @@ -2173,56 +2168,56 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 ty = // Check the (possibly inferred) structural dependencies (tinst, tcref.TyparsNoRange) ||> Iterate2D (fun ty tp -> if tp.EqualityConditionalOn then - SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 ty + SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty else CompleteD) | _ -> CompleteD -and SolveTypeIsEnum (csenv: ConstraintSolverEnv) ndeep m2 ty underlying = +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 destTypar (TyparConstraint.IsEnum(underlying, m)) + return! AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsEnum(underlying, m)) | _ -> if isEnumTy g ty then - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 underlying (underlyingTypeOfEnumTy g ty) + 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)) } -and SolveTypeIsDelegate (csenv: ConstraintSolverEnv) ndeep m2 ty aty bty = +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 destTypar (TyparConstraint.IsDelegate(aty, bty, m)) + 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, rty) -> - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 aty tupledArgTy - do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 bty rty + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace aty tupledArgTy + do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace bty rty | 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)) } -and SolveTypeIsNonNullableValueType (csenv: ConstraintSolverEnv) ndeep m2 ty = +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 destTypar (TyparConstraint.IsNonNullableStruct m) + return! AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsNonNullableStruct m) | _ -> let underlyingTy = stripTyEqnsAndMeasureEqns g ty if isStructTy g underlyingTy then @@ -2234,13 +2229,13 @@ and SolveTypeIsNonNullableValueType (csenv: ConstraintSolverEnv) ndeep m2 ty = return! ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresStructType(NicePrint.minimalStringOfType denv ty), m, m2)) } -and SolveTypeIsUnmanaged (csenv: ConstraintSolverEnv) ndeep m2 ty = +and SolveTypeIsUnmanaged (csenv: ConstraintSolverEnv) ndeep m2 trace ty = let g = csenv.g let m = csenv.m let denv = csenv.DisplayEnv match tryDestTyparTy g ty with | ValueSome destTypar -> - AddConstraint csenv ndeep m2 destTypar (TyparConstraint.IsUnmanaged m) + AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsUnmanaged m) | _ -> if isUnmanagedTy g ty then CompleteD @@ -2248,13 +2243,13 @@ and SolveTypeIsUnmanaged (csenv: ConstraintSolverEnv) ndeep m2 ty = ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresUnmanagedType(NicePrint.minimalStringOfType denv ty), m, m2)) -and SolveTypeChoice (csenv: ConstraintSolverEnv) ndeep m2 ty tys = +and SolveTypeChoice (csenv: ConstraintSolverEnv) ndeep m2 trace ty tys = let g = csenv.g let m = csenv.m let denv = csenv.DisplayEnv match tryDestTyparTy g ty with | ValueSome destTypar -> - AddConstraint csenv ndeep m2 destTypar (TyparConstraint.SimpleChoice(tys, m)) + AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.SimpleChoice(tys, m)) | _ -> if List.exists (typeEquivAux Erasure.EraseMeasures g ty) tys then CompleteD else @@ -2262,18 +2257,18 @@ and SolveTypeChoice (csenv: ConstraintSolverEnv) ndeep m2 ty tys = let tysString = tys |> List.map (NicePrint.prettyStringOfTy denv) |> String.concat "," ErrorD (ConstraintSolverError(FSComp.SR.csTypeNotCompatibleBecauseOfPrintf(tyString, tysString), m, m2)) -and SolveTypeIsReferenceType (csenv: ConstraintSolverEnv) ndeep m2 ty = +and SolveTypeIsReferenceType (csenv: ConstraintSolverEnv) ndeep m2 trace ty = let g = csenv.g let m = csenv.m let denv = csenv.DisplayEnv match tryDestTyparTy g ty with | ValueSome destTypar -> - AddConstraint csenv ndeep m2 destTypar (TyparConstraint.IsReferenceType m) + AddConstraint csenv ndeep m2 trace destTypar (TyparConstraint.IsReferenceType m) | _ -> if isRefTy g ty then CompleteD else ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresReferenceSemantics(NicePrint.minimalStringOfType denv ty), m, m)) -and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 origTy = +and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 trace origTy = let g = csenv.g let amap = csenv.amap let m = csenv.m @@ -2281,15 +2276,15 @@ and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 or let ty = stripTyEqnsAndMeasureEqns g origTy match tryDestTyparTy g ty with | ValueSome tp -> - AddConstraint csenv ndeep m2 tp (TyparConstraint.RequiresDefaultConstructor m) + AddConstraint csenv ndeep m2 trace tp (TyparConstraint.RequiresDefaultConstructor m) | _ -> if isStructTy g ty then if isStructTupleTy g ty then - destStructTupleTy g ty |> IterateD (SolveTypeRequiresDefaultValue csenv ndeep m) + destStructTupleTy g ty |> IterateD (SolveTypeRequiresDefaultValue csenv ndeep m trace) elif isStructAnonRecdTy g ty then match tryDestAnonRecdTy g ty with | ValueNone -> CompleteD - | ValueSome (_, ptys) -> ptys |> IterateD (SolveTypeRequiresDefaultValue csenv ndeep m) + | ValueSome (_, ptys) -> ptys |> IterateD (SolveTypeRequiresDefaultValue csenv ndeep m trace) elif TypeHasDefaultValue g m ty then CompleteD else @@ -2317,22 +2312,22 @@ and SolveTypeRequiresDefaultConstructor (csenv: ConstraintSolverEnv) ndeep m2 or // // In the case of type variables, it requires that the type variable already have been pre-established to be either a (non-nullable) struct // or a reference type. -and SolveTypeRequiresDefaultValue (csenv: ConstraintSolverEnv) ndeep m2 origTy = +and SolveTypeRequiresDefaultValue (csenv: ConstraintSolverEnv) ndeep m2 trace origTy = let g = csenv.g let m = csenv.m let ty = stripTyEqnsAndMeasureEqns g origTy if isTyparTy g ty then if isNonNullableStructTyparTy g ty then - SolveTypeRequiresDefaultConstructor csenv ndeep m2 ty + SolveTypeRequiresDefaultConstructor csenv ndeep m2 trace ty elif isReferenceTyparTy g ty then - SolveTypeSupportsNull csenv ndeep m2 ty + SolveTypeSupportsNull csenv ndeep m2 trace ty else ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresStructOrReferenceConstraint(), m, m2)) else if isStructTy g ty then - SolveTypeRequiresDefaultConstructor csenv ndeep m2 ty + SolveTypeRequiresDefaultConstructor csenv ndeep m2 trace ty else - SolveTypeSupportsNull csenv ndeep m2 ty + SolveTypeSupportsNull csenv ndeep m2 trace ty // Parameterized compatibility relation between member signatures. The real work // is done by "equateTypes" and "subsumeTypes" and "subsumeArg" @@ -2371,6 +2366,7 @@ and CanMemberSigsMatchUpToCheck return! ErrorD(Error(FSComp.SR.csTypeInstantiationLengthMismatch(), m)) else let! usesTDC1 = MapCombineTDC2D unifyTypes minst uminst + printfn "break" let! usesTDC2 = trackErrors { if not (permitOptArgs || isNil unnamedCalledOptArgs) then @@ -2389,6 +2385,7 @@ and CanMemberSigsMatchUpToCheck return! MapCombineTDC2D subsumeTypes calledObjArgTys callerObjArgTys } + printfn "break" let! usesTDC3 = calledMeth.ArgSets |> MapCombineTDCD (fun argSet -> trackErrors { if argSet.UnnamedCalledArgs.Length <> argSet.UnnamedCallerArgs.Length then @@ -2397,6 +2394,7 @@ and CanMemberSigsMatchUpToCheck return! MapCombineTDC2D subsumeOrConvertArg argSet.UnnamedCalledArgs argSet.UnnamedCallerArgs }) + printfn "break" let! usesTDC4 = match calledMeth.ParamArrayCalledArgOpt with | Some calledArg -> @@ -2415,6 +2413,7 @@ and CanMemberSigsMatchUpToCheck ResultD TypeDirectedConversionUsed.No | _ -> ResultD TypeDirectedConversionUsed.No + printfn "break" let! usesTDC5 = calledMeth.ArgSets |> MapCombineTDCD (fun argSet -> argSet.AssignedNamedArgs |> MapCombineTDCD (fun arg -> @@ -2422,6 +2421,7 @@ and CanMemberSigsMatchUpToCheck ) ) + printfn "break" let! usesTDC6 = assignedItemSetters |> MapCombineTDCD (fun (AssignedItemSetter(_, item, caller)) -> let name, calledArgTy = @@ -2441,11 +2441,10 @@ and CanMemberSigsMatchUpToCheck subsumeOrConvertArg (CalledArg((-1, 0), false, NotOptional, NoCallerInfo, false, false, Some (mkSynId m name), ReflectedArgInfo.None, calledArgTy)) caller ) - - // - Always take the return type into account for resolving overloading of - // -- op_Explicit, op_Implicit - // -- methods using tupling of unfilled out args - // - Never take into account return type information for constructors + printfn "break" + // Always take the return type into account for resolving overloading of + // -- op_Explicit, op_Implicit + // -- methods using tupling of unfilled out args let! usesTDC7 = match reqdRetTyOpt with | Some _ when ( (* minfo.IsConstructor || *) not alwaysCheckReturn && isNil unnamedCalledOutArgs) -> @@ -2458,6 +2457,7 @@ and CanMemberSigsMatchUpToCheck unifyTypes reqdRetTy.Commit methodRetTy | _ -> ResultD TypeDirectedConversionUsed.No + printfn "break" return Array.reduce TypeDirectedConversionUsed.Combine [| usesTDC1; usesTDC2; usesTDC3; usesTDC4; usesTDC5; usesTDC6; usesTDC7 |] } @@ -2469,44 +2469,50 @@ and CanMemberSigsMatchUpToCheck // // "ty2 casts to ty1" // "a value of type ty2 can be used where a value of type ty1 is expected" -and AddWrappedContextualSubsumptionReport (csenv: ConstraintSolverEnv) ndeep m ty1 ty2 res wrapper = - match csenv.ContextInfo with +and AddWrappedContextualSubsumptionReport (csenv: ConstraintSolverEnv) ndeep m cxsln ty1 ty2 res wrapper = + match csenv.eContextInfo with | ContextInfo.RuntimeTypeTest isOperator -> // test if we can cast other way around let results = CollectThenUndo (fun newTrace -> - let csenv = { csenv with Trace = OptionalTrace.WithTrace newTrace } - SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m ty2 ty1) + SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m (WithTrace newTrace) cxsln ty2 ty1) match results with | OkResult _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.DowncastUsedInsteadOfUpcast isOperator, m))) | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, ContextInfo.NoContext, m))) - | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, csenv.ContextInfo, m))) + | _ -> ErrorD (wrapper (ErrorsFromAddingSubsumptionConstraint(csenv.g, csenv.DisplayEnv, ty1, ty2, res, csenv.eContextInfo, m))) /// Assert a subtype constraint -and SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m ty1 ty2 wrapper = +and SolveTypeSubsumesTypeWithWrappedContextualReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 wrapper = // Due to the legacy of the change https://github.com/dotnet/fsharp/pull/1650, // when doing nested, speculative overload resolution, we ignore failed member constraints and continue. The // constraint is not recorded for later solution. if csenv.IsSpeculativeForMethodOverloading then IgnoreFailedMemberConstraintResolution - (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m ty1 ty2) - (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m ty1 ty2 res wrapper) + (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m trace cxsln ty1 ty2) + (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) else PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m ty1 ty2) - (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m ty1 ty2 res wrapper) + (fun csenv -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m trace cxsln ty1 ty2) + (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) +and SolveTypeSubsumesTypeWithReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln ty1 ty2 = + SolveTypeSubsumesTypeWithWrappedContextualReport csenv ndeep m trace cxsln ty1 ty2 id + // ty1: actual // ty2: expected -and private SolveTypeEqualsTypeWithReport (csenv: ConstraintSolverEnv) ndeep m actual expected = +and private SolveTypeEqualsTypeWithReport (csenv: ConstraintSolverEnv) ndeep m trace cxsln actual expected = TryD - (fun () -> SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m actual expected) - (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, actual, expected, res, m))) + (fun () -> SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m trace cxsln actual expected) + (function + | AbortForFailedMemberConstraintResolution as err -> ErrorD err + | res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g, csenv.DisplayEnv, actual, expected, res, m))) and ArgsMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep + trace + cxsln isConstraint enforceNullableOptionalsKnownTypes // use known types from nullable optional args? (calledArg: CalledArg) @@ -2517,13 +2523,13 @@ and ArgsMustSubsumeOrConvert let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint enforceNullableOptionalsKnownTypes calledArg callerArg match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsTypeWithReport csenv ndeep m ty1 ty2 + do! SolveTypeEqualsTypeWithReport csenv ndeep m trace cxsln ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m calledArgTy callerArg.CallerArgumentType id + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArg.CallerArgumentType if calledArg.IsParamArray && isArray1DTy g calledArgTy && not (isArray1DTy g callerArg.CallerArgumentType) then return! ErrorD(Error(FSComp.SR.csMethodExpectsParams(), m)) else @@ -2536,6 +2542,8 @@ and ArgsMustSubsumeOrConvertWithContextualReport (csenv: ConstraintSolverEnv) ad ndeep + trace + cxsln isConstraint calledMeth calledArg @@ -2546,51 +2554,51 @@ and ArgsMustSubsumeOrConvertWithContextualReport let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint true calledArg callerArg match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsType csenv ndeep m ty1 ty2 + do! SolveTypeEqualsType csenv ndeep m trace cxsln ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) + do! SolveTypeSubsumesTypeWithWrappedContextualReport csenv ndeep m trace cxsln calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) return usesTDC } -and TypesEquiv csenv ndeep ty1 ty2 = +and TypesEquiv csenv ndeep trace cxsln ty1 ty2 = trackErrors { - do! SolveTypeEqualsTypeWithReport csenv ndeep csenv.m ty1 ty2 + do! SolveTypeEqualsTypeWithReport csenv ndeep csenv.m trace cxsln ty1 ty2 return TypeDirectedConversionUsed.No } -and TypesMustSubsume (csenv: ConstraintSolverEnv) ndeep m calledArgTy callerArgTy = +and TypesMustSubsume (csenv: ConstraintSolverEnv) ndeep trace cxsln m calledArgTy callerArgTy = trackErrors { - do! SolveTypeSubsumesTypeWithReport csenv ndeep m calledArgTy callerArgTy id + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArgTy return TypeDirectedConversionUsed.No } -and ReturnTypesMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep isConstraint m isMethodArg reqdTy actualTy = +and ReturnTypesMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep trace cxsln isConstraint m isMethodArg reqdTy actualTy = trackErrors { let reqdTy, usesTDC, eqn = AdjustRequiredTypeForTypeDirectedConversions csenv.InfoReader ad isMethodArg isConstraint reqdTy actualTy m match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsType csenv ndeep m ty1 ty2 + do! SolveTypeEqualsType csenv ndeep m trace cxsln ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m reqdTy actualTy id + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln reqdTy actualTy return usesTDC } -and ArgsEquivOrConvert (csenv: ConstraintSolverEnv) ad ndeep isConstraint calledArg (callerArg: CallerArg<_>) = +and ArgsEquivOrConvert (csenv: ConstraintSolverEnv) ad ndeep trace cxsln isConstraint calledArg (callerArg: CallerArg<_>) = trackErrors { let callerArgTy = callerArg.CallerArgumentType let m = callerArg.Range let calledArgTy, usesTDC, eqn = AdjustCalledArgType csenv.InfoReader ad isConstraint true calledArg callerArg match eqn with | Some (ty1, ty2, msg) -> - do! SolveTypeEqualsType csenv ndeep m ty1 ty2 + do! SolveTypeEqualsType csenv ndeep m trace cxsln ty1 ty2 msg csenv.DisplayEnv | None -> () match usesTDC with @@ -2605,7 +2613,7 @@ and ArgsEquivOrConvert (csenv: ConstraintSolverEnv) ad ndeep isConstraint called and ReportNoCandidatesError (csenv: ConstraintSolverEnv) (nUnnamedCallerArgs, nNamedCallerArgs) methodName ad (calledMethGroup: CalledMeth<_> list) isSequential = let amap = csenv.amap - let m = csenv.m + let m = csenv.m let denv = csenv.DisplayEnv let infoReader = csenv.InfoReader @@ -2724,195 +2732,32 @@ and ReportNoCandidatesErrorSynExpr csenv callerArgCounts methodName ad calledMet let isSequential e = match e with | SynExpr.Sequential _ -> true | _ -> false ReportNoCandidatesError csenv callerArgCounts methodName ad calledMethGroup isSequential -// Note: Relies on 'compare' respecting true > false -and compareCond (p: 'T -> 'T -> bool) x1 x2 = - compare (p x1 x2) (p x2 x1) - -/// Compare types under the feasibly-subsumes ordering -and CompareArgTypesForOverloadingPreference (csenv: ConstraintSolverEnv) ndeep m ty1 ty2 = - (ty1, ty2) ||> compareCond (fun x1 x2 -> TypeFeasiblySubsumesType ndeep csenv.g csenv.amap m x2 CanCoerce x1) - -/// Compare arguments under the feasibly-subsumes ordering and the adhoc Func-is-better-than-other-delegates rule -and CompareArgsForOverloadingPreference (csenv: ConstraintSolverEnv) ndeep m (calledArg1: CalledArg) (calledArg2: CalledArg) = - let g = csenv.g - let c = CompareArgTypesForOverloadingPreference csenv ndeep m calledArg1.CalledArgumentType calledArg2.CalledArgumentType - if c <> 0 then c else - - let c = - (calledArg1.CalledArgumentType, calledArg2.CalledArgumentType) ||> compareCond (fun ty1 ty2 -> - - // Func<_> is always considered better than any other delegate type - match tryTcrefOfAppTy csenv.g ty1 with - | ValueSome tcref1 when - tcref1.DisplayName = "Func" && - (match tcref1.PublicPath with Some p -> p.EnclosingPath = [| "System" |] | _ -> false) && - isDelegateTy g ty1 && - isDelegateTy g ty2 -> true - - // T is always better than inref - | _ when isInByrefTy csenv.g ty2 && typeEquiv csenv.g ty1 (destByrefTy csenv.g ty2) -> - true - - // T is always better than Nullable from F# 5.0 onwards - | _ when g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) && - isNullableTy csenv.g ty2 && - typeEquiv csenv.g ty1 (destNullableTy csenv.g ty2) -> - true - - | _ -> false) - - if c <> 0 then c else - 0 - -/// Check whether one overload is better than another -and CompareMethodsForOverloadingPreference - (csenv: ConstraintSolverEnv) - ndeep // Depth of inference - (candidate: CalledMeth<_>, candidateWarnings, usesTDC1) - (other: CalledMeth<_>, otherWarnings, usesTDC2) = - let g = csenv.g - let m = csenv.m - // Compare two things by the given predicate. - // If the predicate returns true for x1 and false for x2, then x1 > x2 - // If the predicate returns false for x1 and true for x2, then x1 < x2 - // Otherwise x1 = x2 - - let candidateWarnCount = List.length candidateWarnings - let otherWarnCount = List.length otherWarnings - - // Prefer methods that don't use type-directed conversion - let c = compare (match usesTDC1 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) (match usesTDC2 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) - if c <> 0 then c else - - // Prefer methods that don't give "this code is less generic" warnings - // Note: Relies on 'compare' respecting true > false - let c = compare (candidateWarnCount = 0) (otherWarnCount = 0) - if c <> 0 then c else - - // Prefer methods that don't use param array arg - // Note: Relies on 'compare' respecting true > false - let c = compare (not candidate.UsesParamArrayConversion) (not other.UsesParamArrayConversion) - if c <> 0 then c else - - // Prefer methods with more precise param array arg type - let c = - if candidate.UsesParamArrayConversion && other.UsesParamArrayConversion then - CompareArgTypesForOverloadingPreference csenv ndeep m (candidate.GetParamArrayElementType()) (other.GetParamArrayElementType()) - else - 0 - if c <> 0 then c else - - // Prefer methods that don't use out args - // Note: Relies on 'compare' respecting true > false - let c = compare (not candidate.HasOutArgs) (not other.HasOutArgs) - if c <> 0 then c else - - // Prefer methods that don't use optional args - // Note: Relies on 'compare' respecting true > false - let c = compare (not candidate.HasOptArgs) (not other.HasOptArgs) - if c <> 0 then c else - - // Check regular unnamed args. The argument counts will only be different if one is using param args - let c = - if candidate.TotalNumUnnamedCalledArgs = other.TotalNumUnnamedCalledArgs then - // For extension members, we also include the object argument type, if any in the comparison set - // This matches C#, where all extension members are treated and resolved as "static" methods calls - let cs = - (if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then - let objArgTys1 = candidate.CalledObjArgTys(m) - let objArgTys2 = other.CalledObjArgTys(m) - if objArgTys1.Length = objArgTys2.Length then - List.map2 (CompareArgTypesForOverloadingPreference csenv ndeep m) objArgTys1 objArgTys2 - else - [] - else - []) @ - ((candidate.AllUnnamedCalledArgs, other.AllUnnamedCalledArgs) ||> List.map2 (CompareArgsForOverloadingPreference csenv ndeep m)) - // "all args are at least as good, and one argument is actually better" - if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then - 1 - // "all args are at least as bad, and one argument is actually worse" - elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then - -1 - // "argument lists are incomparable" - else - 0 - else - 0 - if c <> 0 then c else - - // Prefer non-extension methods - let c = compare (not candidate.Method.IsExtensionMember) (not other.Method.IsExtensionMember) - if c <> 0 then c else - - // Between extension methods, prefer most recently opened - let c = - if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then - compare candidate.Method.ExtensionMemberPriority other.Method.ExtensionMemberPriority - else - 0 - if c <> 0 then c else - - // Prefer non-generic methods - // Note: Relies on 'compare' respecting true > false - let c = compare candidate.CalledTyArgs.IsEmpty other.CalledTyArgs.IsEmpty - if c <> 0 then c else - - // F# 5.0 rule - prior to F# 5.0 named arguments (on the caller side) were not being taken - // into account when comparing overloads. So adding a name to an argument might mean - // overloads ould no longer be distinguished. We thus look at *all* arguments (whether - // optional or not) as an additional comparison technique. - let c = - if g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) then - let cs = - let args1 = candidate.AllCalledArgs |> List.concat - let args2 = other.AllCalledArgs |> List.concat - if args1.Length = args2.Length then - (args1, args2) ||> List.map2 (CompareArgsForOverloadingPreference csenv ndeep m) - else - [] - // "all args are at least as good, and one argument is actually better" - if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then - 1 - // "all args are at least as bad, and one argument is actually worse" - elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then - -1 - // "argument lists are incomparable" - else - 0 - else - 0 - if c <> 0 then c else - - 0 - -/// Check whether one overload is better than another -and ChooseBestMethodsForOverloading (csenv: ConstraintSolverEnv) ndeep applicableMeths = - let indexedApplicableMeths = applicableMeths |> List.indexed - indexedApplicableMeths |> List.choose (fun (i, candidate) -> - if indexedApplicableMeths |> List.forall (fun (j, other) -> - i = j || - let res = CompareMethodsForOverloadingPreference csenv ndeep candidate other - res > 0) then - Some candidate - else - None) - /// When checking whether a method solves a trait constraint, we can assume the trait is solved /// by that method for the purposes of further type checking (just as we assume a type equation /// for the purposes of checking constraints arising from that type equation). -and AssumeMethodSolvesTrait (csenv: ConstraintSolverEnv) (cx: TraitConstraintInfo option) m (calledMeth: CalledMeth<_>) = +/// +/// In F# 5.0 we assert this late by passing the cxsln parameter around. However this +/// relies on not checking return types for SRTP constraints eagerly +/// +/// In F# 6.0 we assert this early and add a proper check that return types match for SRTP constraint solving +/// (see alwaysCheckReturn) +and AssumeMethodSolvesTrait (csenv: ConstraintSolverEnv) (cx: TraitConstraintInfo option) m trace (calledMeth: CalledMeth<_>) = match cx with | Some traitInfo when traitInfo.Solution.IsNone -> let traitSln = MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs - // If this is an overload resolution at this point it's safe to assume the candidate member being evaluated solves this member constraint. - TransactMemberConstraintSolution traitInfo csenv.Trace traitSln - | _ -> () + if csenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then + TransactMemberConstraintSolution traitInfo trace traitSln + None + else + Some (traitInfo, traitSln) + | _ -> + None // Resolve the overloading of a method // This is used after analyzing the types of arguments and ResolveOverloading (csenv: ConstraintSolverEnv) + trace // The undo trace, if any methodName // The name of the method being called, for error reporting ndeep // Depth of inference cx // We're doing overload resolution as part of constraint solving, where special rules apply for op_Explicit and op_Implicit constraints. @@ -2925,7 +2770,7 @@ and ResolveOverloading = let g = csenv.g let infoReader = csenv.InfoReader - let m = csenv.m + let m = csenv.m let denv = csenv.DisplayEnv let isOpConversion = methodName = "op_Explicit" || methodName = "op_Implicit" // See what candidates we have based on name and arity @@ -2944,10 +2789,14 @@ and ResolveOverloading | _, _ -> - // - Always take the return type into account for - // -- op_Explicit, op_Implicit - // -- candidate method sets that potentially use tupling of unfilled out args - let alwaysCheckReturn = isOpConversion || candidates |> List.exists (fun cmeth -> cmeth.HasOutArgs) + // Always take the return type into account for + // -- op_Explicit, op_Implicit + // -- candidate method sets that potentially use tupling of unfilled out args + /// -- in F# 6.0, also check return types for SRTP constraints + let alwaysCheckReturn = + isOpConversion || + candidates |> List.exists (fun cmeth -> cmeth.HasOutArgs) || + (csenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions && cx.IsSome) // Exact match rule. // @@ -2955,18 +2804,18 @@ and ResolveOverloading // and exact matches of argument types. let exactMatchCandidates = candidates |> FilterEachThenUndo (fun newTrace calledMeth -> - let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculativeForMethodOverloading = true } - AssumeMethodSolvesTrait csenv cx m calledMeth - CanMemberSigsMatchUpToCheck - csenv - permitOptArgs - alwaysCheckReturn - (TypesEquiv csenv ndeep) // instantiations equivalent - (TypesMustSubsume csenv ndeep m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cx.IsSome m) // return can subsume or convert - (ArgsEquivOrConvert csenv ad ndeep cx.IsSome) // args exact - reqdRetTyOpt - calledMeth) + let csenv = { csenv with IsSpeculativeForMethodOverloading = true } + let cxsln = AssumeMethodSolvesTrait csenv cx m (WithTrace newTrace) calledMeth + CanMemberSigsMatchUpToCheck + csenv + permitOptArgs + alwaysCheckReturn + (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) // instantiations equivalent + (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) // return can subsume or convert + (ArgsEquivOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome) // args exact + reqdRetTyOpt + calledMeth) match exactMatchCandidates with | [(calledMeth, warns, _usesTDC)] -> @@ -2977,16 +2826,16 @@ and ResolveOverloading // Subsumption on arguments is allowed. let applicable = candidates |> FilterEachThenUndo (fun newTrace candidate -> - let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculativeForMethodOverloading = true } - AssumeMethodSolvesTrait csenv cx m candidate + let csenv = { csenv with IsSpeculativeForMethodOverloading = true } + let cxsln = AssumeMethodSolvesTrait csenv cx m (WithTrace newTrace) candidate CanMemberSigsMatchUpToCheck csenv permitOptArgs alwaysCheckReturn - (TypesEquiv csenv ndeep) // instantiations equivalent - (TypesMustSubsume csenv ndeep m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cx.IsSome m) // return can subsume or convert - (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep cx.IsSome candidate) // args can subsume + (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) // instantiations equivalent + (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) // return can subsume or convert + (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome candidate) // args can subsume reqdRetTyOpt candidate) @@ -3015,16 +2864,16 @@ and ResolveOverloading candidates |> List.choose (fun calledMeth -> let results = CollectThenUndo (fun newTrace -> - let csenv = { csenv with Trace = WithTrace newTrace; IsSpeculativeForMethodOverloading = true } - AssumeMethodSolvesTrait csenv cx m calledMeth + let csenv = { csenv with IsSpeculativeForMethodOverloading = true } + let cxsln = AssumeMethodSolvesTrait csenv cx m (WithTrace newTrace) calledMeth CanMemberSigsMatchUpToCheck csenv permitOptArgs alwaysCheckReturn - (TypesEquiv csenv ndeep) - (TypesMustSubsume csenv ndeep m) - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cx.IsSome m) - (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep cx.IsSome calledMeth) + (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) + (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) + (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome calledMeth) reqdRetTyOpt calledMeth) match results with @@ -3039,7 +2888,171 @@ and ResolveOverloading | applicableMeths -> - let bestMethods = ChooseBestMethodsForOverloading csenv ndeep applicableMeths + /// Compare two things by the given predicate. + /// If the predicate returns true for x1 and false for x2, then x1 > x2 + /// If the predicate returns false for x1 and true for x2, then x1 < x2 + /// Otherwise x1 = x2 + + // Note: Relies on 'compare' respecting true > false + let compareCond (p: 'T -> 'T -> bool) x1 x2 = + compare (p x1 x2) (p x2 x1) + + /// Compare types under the feasibly-subsumes ordering + let compareTypes ty1 ty2 = + (ty1, ty2) ||> compareCond (fun x1 x2 -> TypeFeasiblySubsumesType ndeep csenv.g csenv.amap m x2 CanCoerce x1) + + /// Compare arguments under the feasibly-subsumes ordering and the adhoc Func-is-better-than-other-delegates rule + let compareArg (calledArg1: CalledArg) (calledArg2: CalledArg) = + let c = compareTypes calledArg1.CalledArgumentType calledArg2.CalledArgumentType + if c <> 0 then c else + + let c = + (calledArg1.CalledArgumentType, calledArg2.CalledArgumentType) ||> compareCond (fun ty1 ty2 -> + + // Func<_> is always considered better than any other delegate type + match tryTcrefOfAppTy csenv.g ty1 with + | ValueSome tcref1 when + tcref1.DisplayName = "Func" && + (match tcref1.PublicPath with Some p -> p.EnclosingPath = [| "System" |] | _ -> false) && + isDelegateTy g ty1 && + isDelegateTy g ty2 -> true + + // T is always better than inref + | _ when isInByrefTy csenv.g ty2 && typeEquiv csenv.g ty1 (destByrefTy csenv.g ty2) -> + true + + // T is always better than Nullable from F# 5.0 onwards + | _ when g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) && + isNullableTy csenv.g ty2 && + typeEquiv csenv.g ty1 (destNullableTy csenv.g ty2) -> + true + + | _ -> false) + + if c <> 0 then c else + 0 + + /// Check whether one overload is better than another + let better (candidate: CalledMeth<_>, candidateWarnings, usesTDC1) (other: CalledMeth<_>, otherWarnings, usesTDC2) = + let candidateWarnCount = List.length candidateWarnings + let otherWarnCount = List.length otherWarnings + + // Prefer methods that don't use type-directed conversion + let c = compare (match usesTDC1 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) (match usesTDC2 with TypeDirectedConversionUsed.No -> 1 | _ -> 0) + if c <> 0 then c else + + // Prefer methods that don't give "this code is less generic" warnings + // Note: Relies on 'compare' respecting true > false + let c = compare (candidateWarnCount = 0) (otherWarnCount = 0) + if c <> 0 then c else + + // Prefer methods that don't use param array arg + // Note: Relies on 'compare' respecting true > false + let c = compare (not candidate.UsesParamArrayConversion) (not other.UsesParamArrayConversion) + if c <> 0 then c else + + // Prefer methods with more precise param array arg type + let c = + if candidate.UsesParamArrayConversion && other.UsesParamArrayConversion then + compareTypes (candidate.GetParamArrayElementType()) (other.GetParamArrayElementType()) + else + 0 + if c <> 0 then c else + + // Prefer methods that don't use out args + // Note: Relies on 'compare' respecting true > false + let c = compare (not candidate.HasOutArgs) (not other.HasOutArgs) + if c <> 0 then c else + + // Prefer methods that don't use optional args + // Note: Relies on 'compare' respecting true > false + let c = compare (not candidate.HasOptArgs) (not other.HasOptArgs) + if c <> 0 then c else + + // check regular unnamed args. The argument counts will only be different if one is using param args + let c = + if candidate.TotalNumUnnamedCalledArgs = other.TotalNumUnnamedCalledArgs then + // For extension members, we also include the object argument type, if any in the comparison set + // This matches C#, where all extension members are treated and resolved as "static" methods calls + let cs = + (if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then + let objArgTys1 = candidate.CalledObjArgTys(m) + let objArgTys2 = other.CalledObjArgTys(m) + if objArgTys1.Length = objArgTys2.Length then + List.map2 compareTypes objArgTys1 objArgTys2 + else + [] + else + []) @ + ((candidate.AllUnnamedCalledArgs, other.AllUnnamedCalledArgs) ||> List.map2 compareArg) + // "all args are at least as good, and one argument is actually better" + if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then + 1 + // "all args are at least as bad, and one argument is actually worse" + elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then + -1 + // "argument lists are incomparable" + else + 0 + else + 0 + if c <> 0 then c else + + // prefer non-extension methods + let c = compare (not candidate.Method.IsExtensionMember) (not other.Method.IsExtensionMember) + if c <> 0 then c else + + // between extension methods, prefer most recently opened + let c = + if candidate.Method.IsExtensionMember && other.Method.IsExtensionMember then + compare candidate.Method.ExtensionMemberPriority other.Method.ExtensionMemberPriority + else + 0 + if c <> 0 then c else + + // Prefer non-generic methods + // Note: Relies on 'compare' respecting true > false + let c = compare candidate.CalledTyArgs.IsEmpty other.CalledTyArgs.IsEmpty + if c <> 0 then c else + + // F# 5.0 rule - prior to F# 5.0 named arguments (on the caller side) were not being taken + // into account when comparing overloads. So adding a name to an argument might mean + // overloads ould no longer be distinguished. We thus look at *all* arguments (whether + // optional or not) as an additional comparison technique. + let c = + if g.langVersion.SupportsFeature(LanguageFeature.NullableOptionalInterop) then + let cs = + let args1 = candidate.AllCalledArgs |> List.concat + let args2 = other.AllCalledArgs |> List.concat + if args1.Length = args2.Length then + (args1, args2) ||> List.map2 compareArg + else + [] + // "all args are at least as good, and one argument is actually better" + if cs |> List.forall (fun x -> x >= 0) && cs |> List.exists (fun x -> x > 0) then + 1 + // "all args are at least as bad, and one argument is actually worse" + elif cs |> List.forall (fun x -> x <= 0) && cs |> List.exists (fun x -> x < 0) then + -1 + // "argument lists are incomparable" + else + 0 + else + 0 + if c <> 0 then c else + + 0 + + let bestMethods = + let indexedApplicableMeths = applicableMeths |> List.indexed + indexedApplicableMeths |> List.choose (fun (i, candidate) -> + if indexedApplicableMeths |> List.forall (fun (j, other) -> + i = j || + let res = better candidate other + res > 0) then + Some candidate + else + None) match bestMethods with | [(calledMeth, warns, _usesTDC)] -> Some calledMeth, OkResult (warns, ()) | bestMethods -> @@ -3077,16 +3090,16 @@ and ResolveOverloading calledMethOpt, trackErrors { do! errors - AssumeMethodSolvesTrait csenv cx m calledMeth + let cxsln = AssumeMethodSolvesTrait csenv cx m trace calledMeth let! _usesTDC = CanMemberSigsMatchUpToCheck csenv permitOptArgs true - (TypesEquiv csenv ndeep) // instantiations equal - (TypesMustSubsume csenv ndeep m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep cx.IsSome m) // return can subsume or convert - (ArgsMustSubsumeOrConvert csenv ad ndeep cx.IsSome true) // args can subsume or convert + (TypesEquiv csenv ndeep trace cxsln) // instantiations equal + (TypesMustSubsume csenv ndeep trace cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep trace cxsln cx.IsSome m) // return can subsume or convert + (ArgsMustSubsumeOrConvert csenv ad ndeep trace cxsln cx.IsSome true) // args can subsume or convert reqdRetTyOpt calledMeth @@ -3103,7 +3116,7 @@ and ResolveOverloading let ResolveOverloadingForCall denv css m methodName callerArgs ad calledMethGroup permitOptArgs reqdRetTy = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - ResolveOverloading csenv methodName 0 None callerArgs ad calledMethGroup permitOptArgs (Some reqdRetTy) + ResolveOverloading csenv NoTrace methodName 0 None callerArgs ad calledMethGroup permitOptArgs (Some reqdRetTy) /// This is used before analyzing the types of arguments in a single overload resolution let UnifyUniqueOverloading @@ -3129,10 +3142,10 @@ let UnifyUniqueOverloading csenv true // permitOptArgs true // always check return type - (TypesEquiv csenv ndeep) - (TypesMustSubsume csenv ndeep m) - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep false m) - (ArgsMustSubsumeOrConvert csenv ad ndeep false false) + (TypesEquiv csenv ndeep NoTrace None) + (TypesMustSubsume csenv ndeep NoTrace None m) + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep NoTrace None false m) + (ArgsMustSubsumeOrConvert csenv ad ndeep NoTrace None false false) (Some reqdRetTy) calledMeth return true @@ -3148,14 +3161,14 @@ let UnifyUniqueOverloading ResultD false /// Remove the global constraints where these type variables appear in the support of the constraint -let EliminateConstraintsForGeneralizedTypars denv css m (generalizedTypars: Typars) = +let EliminateConstraintsForGeneralizedTypars denv css m (trace: OptionalTrace) (generalizedTypars: Typars) = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv for tp in generalizedTypars do let tpn = tp.Stamp let cxst = csenv.SolverState.ExtraCxs let cxs = cxst.FindAll tpn for cx in cxs do - csenv.Trace.Exec + trace.Exec (fun () -> cxst.Remove tpn) (fun () -> (csenv.SolverState.ExtraCxs.Add (tpn, cx))) @@ -3167,7 +3180,7 @@ let EliminateConstraintsForGeneralizedTypars denv css m (generalizedTypars: Typa let AddCxTypeEqualsType contextInfo denv css m actual expected = let csenv = MakeConstraintSolverEnv contextInfo css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeEqualsTypeWithReport csenv 0 m actual expected) + (fun csenv -> SolveTypeEqualsTypeWithReport csenv 0 m NoTrace None actual expected) ErrorD |> RaiseOperationResult @@ -3205,117 +3218,117 @@ let UndoIfFailedOrWarnings f = let AddCxTypeEqualsTypeUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with Trace = WithTrace trace; ErrorOnFailedMemberConstraintResolution = true } - SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty1 ty2) + let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = true } + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) let AddCxTypeEqualsTypeUndoIfFailedOrWarnings denv css m ty1 ty2 = UndoIfFailedOrWarnings (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with Trace = WithTrace trace; ErrorOnFailedMemberConstraintResolution = true } - SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty1 ty2) + let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = true } + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with Trace = WithTrace trace; MatchingOnly = true; ErrorOnFailedMemberConstraintResolution = true } - SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty1 ty2) + let csenv = { csenv with MatchingOnly = true; ErrorOnFailedMemberConstraintResolution = true } + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with Trace = WithTrace trace; ErrorOnFailedMemberConstraintResolution = true } - SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m ty1 ty2) + let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = true } + SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m (WithTrace trace) None ty1 ty2) let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = UndoIfFailed (fun trace -> let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - let csenv = { csenv with Trace = WithTrace trace; MatchingOnly = true; ErrorOnFailedMemberConstraintResolution = true } - SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m ty1 ty2) + let csenv = { csenv with MatchingOnly = true; ErrorOnFailedMemberConstraintResolution = true } + SolveTypeSubsumesTypeKeepAbbrevs csenv 0 m (WithTrace trace) None ty1 ty2) -let AddCxTypeMustSubsumeType contextInfo denv css m ty1 ty2 = +let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = let csenv = MakeConstraintSolverEnv contextInfo css m denv - SolveTypeSubsumesTypeWithReport csenv 0 m ty1 ty2 id + SolveTypeSubsumesTypeWithReport csenv 0 m trace None ty1 ty2 |> RaiseOperationResult -let AddCxMethodConstraint denv css m traitInfo = +let AddCxMethodConstraint denv css m trace traitInfo = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> trackErrors { do! - SolveMemberConstraint csenv true PermitWeakResolution.No 0 m traitInfo + SolveMemberConstraint csenv true PermitWeakResolution.No 0 m trace traitInfo |> OperationResult.ignore }) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeMustSupportNull denv css m ty = +let AddCxTypeMustSupportNull denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeSupportsNull csenv 0 m ty) + (fun csenv -> SolveTypeSupportsNull csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeMustSupportComparison denv css m ty = +let AddCxTypeMustSupportComparison denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeSupportsComparison csenv 0 m ty) + (fun csenv -> SolveTypeSupportsComparison csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeMustSupportEquality denv css m ty = +let AddCxTypeMustSupportEquality denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeSupportsEquality csenv 0 m ty) + (fun csenv -> SolveTypeSupportsEquality csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeMustSupportDefaultCtor denv css m ty = +let AddCxTypeMustSupportDefaultCtor denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeRequiresDefaultConstructor csenv 0 m ty) + (fun csenv -> SolveTypeRequiresDefaultConstructor csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeIsReferenceType denv css m ty = +let AddCxTypeIsReferenceType denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeIsReferenceType csenv 0 m ty) + (fun csenv -> SolveTypeIsReferenceType csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeIsValueType denv css m ty = +let AddCxTypeIsValueType denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeIsNonNullableValueType csenv 0 m ty) + (fun csenv -> SolveTypeIsNonNullableValueType csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeIsUnmanaged denv css m ty = +let AddCxTypeIsUnmanaged denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeIsUnmanaged csenv 0 m ty) + (fun csenv -> SolveTypeIsUnmanaged csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeIsEnum denv css m ty underlying = +let AddCxTypeIsEnum denv css m trace ty underlying = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeIsEnum csenv 0 m ty underlying) + (fun csenv -> SolveTypeIsEnum csenv 0 m trace ty underlying) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult -let AddCxTypeIsDelegate denv css m ty aty bty = +let AddCxTypeIsDelegate denv css m trace ty aty bty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTypeIsDelegate csenv 0 m ty aty bty) + (fun csenv -> SolveTypeIsDelegate csenv 0 m trace ty aty bty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty = let csenv = MakeConstraintSolverEnv ctxtInfo css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> AddConstraint csenv 0 m tp (TyparConstraint.DefaultsTo(ridx, ty, m))) + (fun csenv -> AddConstraint csenv 0 m NoTrace tp (TyparConstraint.DefaultsTo(ridx, ty, m))) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -3323,7 +3336,7 @@ let SolveTypeAsError denv css m ty = let ty2 = NewErrorType () assert (destTyparTy css.g ty2).IsFromError let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - SolveTypeEqualsTypeKeepAbbrevs csenv 0 m ty ty2 |> ignore + SolveTypeEqualsTypeKeepAbbrevs csenv 0 m NoTrace ty ty2 |> ignore let ApplyTyparDefaultAtPriority denv css priority (tp: Typar) = tp.Constraints |> List.iter (fun tpc -> @@ -3334,7 +3347,7 @@ let ApplyTyparDefaultAtPriority denv css priority (tp: Typar) = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> - SolveTyparEqualsType csenv 0 m ty1 ty2) + SolveTyparEqualsType csenv 0 m NoTrace ty1 ty2) (fun res -> SolveTypeAsError denv css m ty1 ErrorD(ErrorFromApplyingDefault(css.g, denv, tp, ty2, res, m))) @@ -3354,7 +3367,7 @@ let CreateCodegenState tcVal g amap = let CodegenWitnessExprForTraitConstraint tcVal g amap m (traitInfo:TraitConstraintInfo) argExprs = trackErrors { let css = CreateCodegenState tcVal g amap let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) - let! _res = SolveMemberConstraint csenv true PermitWeakResolution.Yes 0 m traitInfo + let! _res = SolveMemberConstraint csenv true PermitWeakResolution.Yes 0 m NoTrace traitInfo return GenWitnessExpr amap g m traitInfo argExprs } @@ -3364,7 +3377,7 @@ let CodegenWitnessesForTyparInst tcVal g amap m typars tyargs = trackErrors { let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) let ftps, _renaming, tinst = FreshenTypeInst m typars let traitInfos = GetTraitConstraintInfosOfTypars g ftps - do! SolveTyparsEqualTypes csenv 0 m tinst tyargs + do! SolveTyparsEqualTypes csenv 0 m NoTrace tinst tyargs return GenWitnessArgs amap g m traitInfos } @@ -3372,7 +3385,7 @@ let CodegenWitnessesForTyparInst tcVal g amap m typars tyargs = trackErrors { let CodegenWitnessArgForTraitConstraint tcVal g amap m traitInfo = trackErrors { let css = CreateCodegenState tcVal g amap let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) - let! _res = SolveMemberConstraint csenv true PermitWeakResolution.Yes 0 m traitInfo + let! _res = SolveMemberConstraint csenv true PermitWeakResolution.Yes 0 m NoTrace traitInfo return GenWitnessExprLambda amap g m traitInfo } @@ -3385,7 +3398,7 @@ let ChooseTyparSolutionAndSolve css denv tp = let max, m = ChooseTyparSolutionAndRange g amap tp let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> SolveTyparEqualsType csenv 0 m (mkTyparTy tp) max) + (fun csenv -> SolveTyparEqualsType csenv 0 m NoTrace (mkTyparTy tp) max) (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult @@ -3394,8 +3407,7 @@ let CheckDeclaredTypars denv css m typars1 typars2 = PostponeOnFailedMemberConstraintResolution csenv (fun csenv -> CollectThenUndo (fun newTrace -> - let csenv = { csenv with Trace = WithTrace newTrace } - SolveTypeEqualsTypeEqns csenv 0 m + SolveTypeEqualsTypeEqns csenv 0 m (WithTrace newTrace) None (List.map mkTyparTy typars1) (List.map mkTyparTy typars2))) (fun res -> @@ -3405,8 +3417,9 @@ let CheckDeclaredTypars denv css m typars1 typars2 = let CanonicalizePartialInferenceProblem css denv m tps = // Canonicalize constraints prior to generalization let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv - (fun csenv -> CanonicalizeRelevantMemberConstraints csenv 0 tps) + let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = true } + IgnoreFailedMemberConstraintResolution + (fun () -> CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -3430,7 +3443,7 @@ let IsApplicableMethApprox g amap m (minfo: MethInfo) availObjTy = match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> let reqdObjTy = if isByrefTy g reqdObjTy then destByrefTy g reqdObjTy else reqdObjTy // This is to support byref extension methods. - TryD (fun () -> SolveTypeSubsumesType csenv 0 m reqdObjTy availObjTy ++ (fun () -> ResultD true)) + TryD (fun () -> SolveTypeSubsumesType csenv 0 m NoTrace None reqdObjTy availObjTy ++ (fun () -> ResultD true)) (fun _err -> ResultD false) |> CommitOperationResult | _ -> true diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 8998a16bf52..74be7b21d90 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -123,7 +123,6 @@ exception ConstraintSolverTypesNotInEqualityRelation of displayEnv: DisplayEn exception ConstraintSolverTypesNotInSubsumptionRelation of displayEnv: DisplayEnv * argTy: TType * paramTy: TType * callRange: range * parameterRange: range exception ConstraintSolverMissingConstraint of displayEnv: DisplayEnv * Typar * TyparConstraint * range * range exception ConstraintSolverError of string * range * range -exception ConstraintSolverRelatedInformation of string option * range * exn exception ErrorFromApplyingDefault of tcGlobals: TcGlobals * displayEnv: DisplayEnv * Typar * TType * exn * range exception ErrorFromAddingTypeEquation of tcGlobals: TcGlobals * displayEnv: DisplayEnv * actualTy: TType * expectedTy: TType * exn * range @@ -150,6 +149,13 @@ type ConstraintSolverState = /// Get the post-inference checks to run at the end of inference member GetPostInferenceChecksFinal: unit -> seq unit> +[] +type Trace + +type OptionalTrace = + | NoTrace + | WithTrace of Trace + val BakedInTraitConstraintNames: Set val SimplifyMeasuresInTypeScheme: TcGlobals -> bool -> Typars -> TType -> TyparConstraint list -> Typars @@ -161,7 +167,7 @@ val ResolveOverloadingForCall: DisplayEnv -> ConstraintSolverState -> range -> m val UnifyUniqueOverloading: DisplayEnv -> ConstraintSolverState -> range -> int * int -> string -> AccessorDomain -> CalledMeth list -> OverallTy -> OperationResult /// Remove the global constraints where these type variables appear in the support of the constraint -val EliminateConstraintsForGeneralizedTypars: DisplayEnv -> ConstraintSolverState -> range -> Typars -> unit +val EliminateConstraintsForGeneralizedTypars: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> Typars -> unit val CheckDeclaredTypars: DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit @@ -174,31 +180,31 @@ val AddCxTypeEqualsTypeUndoIfFailedOrWarnings: DisplayEnv -> ConstraintSolverSta val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeMustSubsumeType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit +val AddCxTypeMustSubsumeType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit val AddCxTypeMustSubsumeTypeUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool val AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxMethodConstraint: DisplayEnv -> ConstraintSolverState -> range -> TraitConstraintInfo -> unit +val AddCxMethodConstraint: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TraitConstraintInfo -> unit -val AddCxTypeMustSupportNull: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit +val AddCxTypeMustSupportNull: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportComparison: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit +val AddCxTypeMustSupportComparison: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportEquality: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit +val AddCxTypeMustSupportEquality: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportDefaultCtor: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit +val AddCxTypeMustSupportDefaultCtor: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsReferenceType: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit +val AddCxTypeIsReferenceType: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsValueType: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit +val AddCxTypeIsValueType: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsUnmanaged: DisplayEnv -> ConstraintSolverState -> range -> TType -> unit +val AddCxTypeIsUnmanaged: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsEnum: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit +val AddCxTypeIsEnum: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit -val AddCxTypeIsDelegate: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> TType -> unit +val AddCxTypeIsDelegate: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit val AddCxTyparDefaultsTo: DisplayEnv -> ConstraintSolverState -> range -> ContextInfo -> Typar -> int -> TType -> unit diff --git a/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs b/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs index dcbf6b9e28e..b956480ef58 100644 --- a/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs +++ b/tests/fsharp/Compiler/CodeGen/EmittedIL/TaskGeneratedCode.fs @@ -1056,7 +1056,10 @@ let testTask() = task { while x > 4 do System.Console.WriteLine("loop") } } """ ]) +#endif + +module TaskTypeInference = // This tests the compilation of a case that hits corner cases in SRTP constraint processing. // See https://github.com/dotnet/fsharp/issues/12188 [] @@ -1108,6 +1111,8 @@ printfn "test passed" """ +#if !DEBUG + [] let ``check generic task exact code``() = CompilerAssert.CompileLibraryAndVerifyILWithOptions [| "/langversion:preview";"/optimize-";"/debug:portable";"/tailcalls-" |] diff --git a/tests/fsharp/typecheck/sigs/neg_issue_3752.bsl b/tests/fsharp/typecheck/sigs/neg_issue_3752.bsl index 2f18f739a0a..bec7773d5c6 100644 --- a/tests/fsharp/typecheck/sigs/neg_issue_3752.bsl +++ b/tests/fsharp/typecheck/sigs/neg_issue_3752.bsl @@ -1,2 +1,4 @@ neg_issue_3752.fs(4,19,4,46): typecheck error FS0064: This construct causes code to be less generic than indicated by the type annotations. The type variable 'a has been constrained to be type 'string'. + +neg_issue_3752.fs(4,19,4,46): typecheck error FS0064: This construct causes code to be less generic than indicated by the type annotations. The type variable 'a has been constrained to be type 'string'. From 13f5102e3eeb45c647b9ec895dc9b10c916b5eba Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 28 Sep 2021 18:43:39 +0100 Subject: [PATCH 12/14] simplify diff --- src/fsharp/ConstraintSolver.fs | 189 +++++++++++++++++---------------- 1 file changed, 99 insertions(+), 90 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index f1291cdf371..e0a6f86e310 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -471,7 +471,7 @@ let BakedInTraitConstraintNames = type Trace = { mutable actions: ((unit -> unit) * (unit -> unit)) list } - + static member New () = { actions = [] } member t.Undo () = List.iter (fun (_, a) -> a ()) t.actions @@ -488,6 +488,12 @@ type OptionalTrace = | WithTrace trace -> trace.Push f undo; f() | NoTrace -> f() + member t.AddFromReplay source = + source.actions |> List.rev |> + match t with + | WithTrace trace -> List.iter (fun (action, undo) -> trace.Push action undo; action()) + | NoTrace -> List.iter (fun (action, _ ) -> action()) + member t.CollectThenUndoOrCommit predicate f = let newTrace = Trace.New() let res = f newTrace @@ -511,7 +517,7 @@ let FilterEachThenUndo f meths = trace.Undo() match CheckNoErrorsAndGetWarnings res with | None -> None - | Some (warns, res) -> Some (calledMeth, warns, res)) + | Some (warns, res) -> Some (calledMeth, warns, trace, res)) let ShowAccessDomain ad = match ad with @@ -1005,7 +1011,7 @@ and SolveTyparEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalT do! DepthCheck ndeep m match ty1 with | TType_var r | TType_measure (Measure.Var r) -> - do! SolveTyparEqualsTypePart1 csenv m2 trace ty1 r ty + do! SolveTyparEqualsTypePart1 csenv m2 trace ty1 r ty do! SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty | _ -> failwith "SolveTyparEqualsType" } @@ -1029,7 +1035,6 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon ) ++ (fun () -> if not (anonInfo1.SortedNames = anonInfo2.SortedNames) then - let (|Subset|Superset|Overlap|CompletelyDifferent|) (first, second) = let first = Set first let second = Set second @@ -1044,7 +1049,7 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon Overlap(firstOnly, secondOnly) else CompletelyDifferent(Seq.toList first) - + let message = match anonInfo1.SortedNames, anonInfo2.SortedNames with | Subset missingFields -> @@ -1103,12 +1108,11 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr if evalTupInfoIsStruct tupInfo1 <> evalTupInfoIsStruct tupInfo2 then ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m, m2)) else SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 - | TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) -> + | TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) -> SolveAnonInfoEqualsAnonInfo csenv m2 anonInfo1 anonInfo2 ++ (fun () -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2) | TType_fun (d1, r1), TType_fun (d2, r2) -> SolveFunTypeEqn csenv ndeep m2 trace None d1 d2 r1 r2 | TType_measure ms1, TType_measure ms2 -> UnifyMeasures csenv trace ms1 ms2 - | TType_forall(tps1, rty1), TType_forall(tps2, rty2) -> if tps1.Length <> tps2.Length then localAbortD else let aenv = aenv.BindEquivTypars tps1 tps2 @@ -1119,11 +1123,9 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2 -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2 | _ -> localAbortD - | _ -> localAbortD - and SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty1 ty2 = SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace None ty1 ty2 -and SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ty1 ty2 = +and private SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ty1 ty2 = // Back out of expansions of type abbreviations to give improved error messages. // Note: any "normalization" of equations on type variables must respect the trace parameter TryD (fun () -> SolveTypeEqualsType csenv ndeep m2 trace cxsln ty1 ty2) @@ -1188,11 +1190,9 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional SolveAnonInfoEqualsAnonInfo csenv m2 anonInfo1 anonInfo2 ++ (fun () -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2) (* nb. can unify since no variance *) - | TType_fun (d1, r1), TType_fun (d2, r2) -> - SolveFunTypeEqn csenv ndeep m2 trace cxsln d1 d2 r1 r2 (* nb. can unify since no variance *) + | TType_fun (d1, r1), TType_fun (d2, r2) -> SolveFunTypeEqn csenv ndeep m2 trace cxsln d1 d2 r1 r2 (* nb. can unify since no variance *) - | TType_measure ms1, TType_measure ms2 -> - UnifyMeasures csenv trace ms1 ms2 + | TType_measure ms1, TType_measure ms2 -> UnifyMeasures csenv trace ms1 ms2 // Enforce the identities float=float<1>, float32=float32<1> and decimal=decimal<1> | _, TType_app (tc2, [ms]) when (tc2.IsMeasureableReprTycon && typeEquiv csenv.g sty1 (reduceTyconRefMeasureableOrProvided csenv.g tc2 [ms])) @@ -1205,7 +1205,7 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2 && g.byref2_tcr.CanDeref && tyconRefEq g g.byref2_tcr tc1 -> match l1, l2 with | [ h1; tag1 ], [ h2; tag2 ] -> trackErrors { - do! SolveTypeEqualsType csenv ndeep m2 trace cxsln h1 h2 + do! SolveTypeEqualsType csenv ndeep m2 trace None h1 h2 match stripTyEqnsA csenv.g canShortcut tag1, stripTyEqnsA csenv.g canShortcut tag2 with | TType_app(tagc1, []), TType_app(tagc2, []) when (tyconRefEq g tagc2 g.byrefkind_InOut_tcr && @@ -1654,8 +1654,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload let methOverloadResult, errors = trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) - (fun newTrace -> - ResolveOverloading csenv (WithTrace newTrace) nm ndeep (Some traitInfo) CallerArgs.Empty AccessibleFromEverywhere calledMethGroup false (Some (MustEqual rty))) + (fun trace -> ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) CallerArgs.Empty AccessibleFromEverywhere calledMethGroup false (Some (MustEqual rty))) match anonRecdPropSearch, recdPropSearch, methOverloadResult with | Some (anonInfo, tinst, i), None, None -> @@ -1878,10 +1877,10 @@ and SolveRelevantMemberConstraintsForTypar (csenv: ConstraintSolverEnv) ndeep pe let csenv = { csenv with m = m2 } SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo) -and CanonicalizeRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep tps = - SolveRelevantMemberConstraints csenv ndeep PermitWeakResolution.Yes tps +and CanonicalizeRelevantMemberConstraints (csenv: ConstraintSolverEnv) ndeep trace tps = + SolveRelevantMemberConstraints csenv ndeep PermitWeakResolution.Yes trace tps -and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 trace traitInfo support (frees: Typar list) = +and AddMemberConstraint (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) traitInfo support (frees: Typar list) = let g = csenv.g let aenv = csenv.EquivEnv let cxst = csenv.SolverState.ExtraCxs @@ -2168,7 +2167,7 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty = // Check the (possibly inferred) structural dependencies (tinst, tcref.TyparsNoRange) ||> Iterate2D (fun ty tp -> if tp.EqualityConditionalOn then - SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty + SolveTypeSupportsEquality csenv ndeep m2 trace ty else CompleteD) | _ -> @@ -2351,7 +2350,7 @@ and CanMemberSigsMatchUpToCheck trackErrors { let g = csenv.g let amap = csenv.amap - let m = csenv.m + let m = csenv.m let minfo = calledMeth.Method let minst = calledMeth.CalledTyArgs @@ -2366,7 +2365,6 @@ and CanMemberSigsMatchUpToCheck return! ErrorD(Error(FSComp.SR.csTypeInstantiationLengthMismatch(), m)) else let! usesTDC1 = MapCombineTDC2D unifyTypes minst uminst - printfn "break" let! usesTDC2 = trackErrors { if not (permitOptArgs || isNil unnamedCalledOptArgs) then @@ -2385,7 +2383,6 @@ and CanMemberSigsMatchUpToCheck return! MapCombineTDC2D subsumeTypes calledObjArgTys callerObjArgTys } - printfn "break" let! usesTDC3 = calledMeth.ArgSets |> MapCombineTDCD (fun argSet -> trackErrors { if argSet.UnnamedCalledArgs.Length <> argSet.UnnamedCallerArgs.Length then @@ -2394,7 +2391,6 @@ and CanMemberSigsMatchUpToCheck return! MapCombineTDC2D subsumeOrConvertArg argSet.UnnamedCalledArgs argSet.UnnamedCallerArgs }) - printfn "break" let! usesTDC4 = match calledMeth.ParamArrayCalledArgOpt with | Some calledArg -> @@ -2413,7 +2409,6 @@ and CanMemberSigsMatchUpToCheck ResultD TypeDirectedConversionUsed.No | _ -> ResultD TypeDirectedConversionUsed.No - printfn "break" let! usesTDC5 = calledMeth.ArgSets |> MapCombineTDCD (fun argSet -> argSet.AssignedNamedArgs |> MapCombineTDCD (fun arg -> @@ -2421,7 +2416,6 @@ and CanMemberSigsMatchUpToCheck ) ) - printfn "break" let! usesTDC6 = assignedItemSetters |> MapCombineTDCD (fun (AssignedItemSetter(_, item, caller)) -> let name, calledArgTy = @@ -2441,10 +2435,10 @@ and CanMemberSigsMatchUpToCheck subsumeOrConvertArg (CalledArg((-1, 0), false, NotOptional, NoCallerInfo, false, false, Some (mkSynId m name), ReflectedArgInfo.None, calledArgTy)) caller ) - printfn "break" - // Always take the return type into account for resolving overloading of - // -- op_Explicit, op_Implicit - // -- methods using tupling of unfilled out args + // - Always take the return type into account for resolving overloading of + // -- op_Explicit, op_Implicit + // -- methods using tupling of unfilled out args + // - Never take into account return type information for constructors let! usesTDC7 = match reqdRetTyOpt with | Some _ when ( (* minfo.IsConstructor || *) not alwaysCheckReturn && isNil unnamedCalledOutArgs) -> @@ -2457,7 +2451,6 @@ and CanMemberSigsMatchUpToCheck unifyTypes reqdRetTy.Commit methodRetTy | _ -> ResultD TypeDirectedConversionUsed.No - printfn "break" return Array.reduce TypeDirectedConversionUsed.Combine [| usesTDC1; usesTDC2; usesTDC3; usesTDC4; usesTDC5; usesTDC6; usesTDC7 |] } @@ -2560,7 +2553,7 @@ and ArgsMustSubsumeOrConvertWithContextualReport match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithWrappedContextualReport csenv ndeep m trace cxsln calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) + do! SolveTypeSubsumesTypeWithWrappedContextualReport csenv ndeep m trace cxsln calledArgTy callerArgTy (fun e -> ArgDoesNotMatchError(e :?> _, calledMeth, calledArg, callerArg)) return usesTDC } @@ -2572,7 +2565,7 @@ and TypesEquiv csenv ndeep trace cxsln ty1 ty2 = and TypesMustSubsume (csenv: ConstraintSolverEnv) ndeep trace cxsln m calledArgTy callerArgTy = trackErrors { - do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArgTy + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln calledArgTy callerArgTy return TypeDirectedConversionUsed.No } @@ -2587,7 +2580,7 @@ and ReturnTypesMustSubsumeOrConvert (csenv: ConstraintSolverEnv) ad ndeep trace match usesTDC with | TypeDirectedConversionUsed.Yes warn -> do! WarnD(warn csenv.DisplayEnv) | TypeDirectedConversionUsed.No -> () - do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln reqdTy actualTy + do! SolveTypeSubsumesTypeWithReport csenv ndeep m trace cxsln reqdTy actualTy return usesTDC } @@ -2775,17 +2768,17 @@ and ResolveOverloading let isOpConversion = methodName = "op_Explicit" || methodName = "op_Implicit" // See what candidates we have based on name and arity let candidates = calledMethGroup |> List.filter (fun cmeth -> cmeth.IsCandidate(m, ad)) - let calledMethOpt, errors = + let calledMethOpt, errors, calledMethTrace = match calledMethGroup, candidates with | _, [calledMeth] when not isOpConversion -> - Some calledMeth, CompleteD + Some calledMeth, CompleteD, NoTrace | [], _ when not isOpConversion -> - None, ErrorD (Error (FSComp.SR.csMethodNotFound(methodName), m)) + None, ErrorD (Error (FSComp.SR.csMethodNotFound(methodName), m)), NoTrace | _, [] when not isOpConversion -> - None, ReportNoCandidatesErrorExpr csenv callerArgs.CallerArgCounts methodName ad calledMethGroup + None, ReportNoCandidatesErrorExpr csenv callerArgs.CallerArgCounts methodName ad calledMethGroup, NoTrace | _, _ -> @@ -2818,8 +2811,8 @@ and ResolveOverloading calledMeth) match exactMatchCandidates with - | [(calledMeth, warns, _usesTDC)] -> - Some calledMeth, OkResult (warns, ()) + | [(calledMeth, warns, _, _usesTDC)] -> + Some calledMeth, OkResult (warns, ()), NoTrace | _ -> // Now determine the applicable methods. @@ -2861,30 +2854,29 @@ and ResolveOverloading | [] -> // OK, we failed. Collect up the errors from overload resolution and the possible overloads let errors = - candidates |> List.choose (fun calledMeth -> - let results = - CollectThenUndo (fun newTrace -> - let csenv = { csenv with IsSpeculativeForMethodOverloading = true } - let cxsln = AssumeMethodSolvesTrait csenv cx m (WithTrace newTrace) calledMeth - CanMemberSigsMatchUpToCheck - csenv - permitOptArgs - alwaysCheckReturn - (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) - (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) - (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome calledMeth) - reqdRetTyOpt - calledMeth) - match results with - | OkResult _ -> None - | ErrorResult(_warnings, exn) -> - Some {methodSlot = calledMeth; infoReader = infoReader; error = exn }) - - None, ErrorD (failOverloading (NoOverloadsFound (methodName, errors, cx))) - - | [(calledMeth, warns, _usesTDC)] -> - Some calledMeth, OkResult (warns, ()) + candidates + |> List.choose (fun calledMeth -> + match CollectThenUndo (fun newTrace -> + let csenv = { csenv with IsSpeculativeForMethodOverloading = true } + let cxsln = AssumeMethodSolvesTrait csenv cx m (WithTrace newTrace) calledMeth + CanMemberSigsMatchUpToCheck + csenv + permitOptArgs + alwaysCheckReturn + (TypesEquiv csenv ndeep (WithTrace newTrace) cxsln) + (TypesMustSubsume csenv ndeep (WithTrace newTrace) cxsln m) + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) + (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome calledMeth) + reqdRetTyOpt + calledMeth) with + | OkResult _ -> None + | ErrorResult(_warnings, exn) -> + Some {methodSlot = calledMeth; infoReader = infoReader; error = exn }) + + None, ErrorD (failOverloading (NoOverloadsFound (methodName, errors, cx))), NoTrace + + | [(calledMeth, warns, t, _usesTDC)] -> + Some calledMeth, OkResult (warns, ()), WithTrace t | applicableMeths -> @@ -2933,7 +2925,7 @@ and ResolveOverloading 0 /// Check whether one overload is better than another - let better (candidate: CalledMeth<_>, candidateWarnings, usesTDC1) (other: CalledMeth<_>, otherWarnings, usesTDC2) = + let better (candidate: CalledMeth<_>, candidateWarnings, _, usesTDC1) (other: CalledMeth<_>, otherWarnings, _, usesTDC2) = let candidateWarnCount = List.length candidateWarnings let otherWarnCount = List.length otherWarnings @@ -3054,7 +3046,7 @@ and ResolveOverloading else None) match bestMethods with - | [(calledMeth, warns, _usesTDC)] -> Some calledMeth, OkResult (warns, ()) + | [(calledMeth, warns, t, _usesTDC)] -> Some calledMeth, OkResult (warns, ()), WithTrace t | bestMethods -> let methods = let getMethodSlotsAndErrors methodSlot errors = @@ -3069,12 +3061,12 @@ and ResolveOverloading | [] -> match applicableMeths with | [] -> for methodSlot in candidates do yield getMethodSlotsAndErrors methodSlot [] - | m -> for methodSlot, errors, _ in m do yield getMethodSlotsAndErrors methodSlot errors - | m -> for methodSlot, errors, _ in m do yield getMethodSlotsAndErrors methodSlot errors ] + | m -> for methodSlot, errors, _, _ in m do yield getMethodSlotsAndErrors methodSlot errors + | m -> for methodSlot, errors, _, _ in m do yield getMethodSlotsAndErrors methodSlot errors ] let methods = List.concat methods - None, ErrorD (failOverloading (PossibleCandidates(methodName, methods,cx))) + None, ErrorD (failOverloading (PossibleCandidates(methodName, methods,cx))), NoTrace // If we've got a candidate solution: make the final checks - no undo here! // Allow subsumption on arguments. Include the return type. @@ -3089,26 +3081,43 @@ and ResolveOverloading calledMethOpt, trackErrors { - do! errors - let cxsln = AssumeMethodSolvesTrait csenv cx m trace calledMeth - let! _usesTDC = - CanMemberSigsMatchUpToCheck - csenv - permitOptArgs - true - (TypesEquiv csenv ndeep trace cxsln) // instantiations equal - (TypesMustSubsume csenv ndeep trace cxsln m) // obj can subsume - (ReturnTypesMustSubsumeOrConvert csenv ad ndeep trace cxsln cx.IsSome m) // return can subsume or convert - (ArgsMustSubsumeOrConvert csenv ad ndeep trace cxsln cx.IsSome true) // args can subsume or convert - reqdRetTyOpt - calledMeth - - // Adhoc additional check on method calls - match reqdRetTyOpt with - | Some reqdRetTy when isByrefTy g reqdRetTy.Commit -> - return! ErrorD(Error(FSComp.SR.tcByrefReturnImplicitlyDereferenced(), m)) - | _ -> - return () + do! errors + let cxsln = AssumeMethodSolvesTrait csenv cx m trace calledMeth + match calledMethTrace with + | NoTrace -> + let! _usesTDC = + CanMemberSigsMatchUpToCheck + csenv + permitOptArgs + true + (TypesEquiv csenv ndeep trace cxsln) // instantiations equal + (TypesMustSubsume csenv ndeep trace cxsln m) // obj can subsume + (ReturnTypesMustSubsumeOrConvert csenv ad ndeep trace cxsln cx.IsSome m) // return can subsume or convert + (ArgsMustSubsumeOrConvert csenv ad ndeep trace cxsln cx.IsSome true) // args can subsume or convert + reqdRetTyOpt + calledMeth + return () + | WithTrace calledMethTrc -> + + // Re-play existing trace + trace.AddFromReplay calledMethTrc + + // Unify return type + match reqdRetTyOpt with + | None -> () + | Some reqdRetTy -> + let actualRetTy = calledMeth.CalledReturnTypeAfterOutArgTupling + if isByrefTy g reqdRetTy.Commit then + return! ErrorD(Error(FSComp.SR.tcByrefReturnImplicitlyDereferenced(), m)) + else + match reqdRetTy with + | MustConvertTo(isMethodArg, reqdRetTy) when g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions -> + let! _usesTDC = ReturnTypesMustSubsumeOrConvert csenv ad ndeep trace cxsln isMethodArg m isMethodArg reqdRetTy actualRetTy + return () + | _ -> + let! _usesTDC = TypesEquiv csenv ndeep trace cxsln reqdRetTy.Commit actualRetTy + return () + } | None -> From 1ce52f3daefb9ed6ccac48d4ffb938c7c84b9a5f Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 29 Sep 2021 00:48:53 +0100 Subject: [PATCH 13/14] reduce diff and fix errors --- src/fsharp/CheckComputationExpressions.fs | 2 +- src/fsharp/CheckDeclarations.fs | 14 +++--- src/fsharp/CheckExpressions.fs | 2 +- src/fsharp/CompilerDiagnostics.fs | 1 + src/fsharp/ConstraintSolver.fs | 48 ++++++++++++------- src/fsharp/ConstraintSolver.fsi | 6 +-- .../fsharp/typecheck/sigs/neg_issue_3752.bsl | 2 - 7 files changed, 43 insertions(+), 32 deletions(-) diff --git a/src/fsharp/CheckComputationExpressions.fs b/src/fsharp/CheckComputationExpressions.fs index bf2891bc96c..1c9aecdc594 100644 --- a/src/fsharp/CheckComputationExpressions.fs +++ b/src/fsharp/CheckComputationExpressions.fs @@ -1926,7 +1926,7 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m = let genResultTy = NewInferenceType () UnifyTypes cenv env m genOuterTy (mkSeqTy cenv.g genResultTy) let exprTy = tyOfExpr cenv.g expr - AddCxTypeMustSubsumeType env.eContextInfo env.DisplayEnv cenv.css m NoTrace genResultTy exprTy + AddCxTypeMustSubsumeType env.eContextInfo env.DisplayEnv cenv.css m NoTrace genResultTy exprTy let resExpr = mkCallSeqSingleton cenv.g m genResultTy (mkCoerceExpr(expr, genResultTy, m, exprTy)) Choice1Of2 resExpr, tpenv else diff --git a/src/fsharp/CheckDeclarations.fs b/src/fsharp/CheckDeclarations.fs index f56486363c9..37f563c8b41 100644 --- a/src/fsharp/CheckDeclarations.fs +++ b/src/fsharp/CheckDeclarations.fs @@ -5907,13 +5907,13 @@ let TypeCheckOneImplFile conditionallySuppressErrorReporting (checkForErrors()) (fun () -> CheckModuleSignature g cenv m denvAtEnd rootSigOpt implFileTypePriorToSig implFileSpecPriorToSig mexpr) - // Run any additional checks registered for post-type-inference - conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - for check in cenv.css.GetPostInferenceChecksFinal() do - try - check() - with e -> - errorRecovery e m) + do + conditionallySuppressErrorReporting (checkForErrors()) (fun () -> + for check in cenv.css.GetPostInferenceChecksFinal() do + try + check() + with e -> + errorRecovery e m) // We ALWAYS run the PostTypeCheckSemanticChecks phase, though we if we have already encountered some // errors we turn off error reporting. This is because it performs various fixups over the TAST, e.g. diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index 7667cad81eb..faacc362256 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -478,7 +478,7 @@ let UnifyOverallType cenv (env: TcEnv) m overallTy actualTy = let reqdTyText, actualTyText, _cxs = NicePrint.minimalStringsOfTwoTypes env.DisplayEnv reqdTy actualTy warning (Error(FSComp.SR.tcSubsumptionImplicitConversionUsed(actualTyText, reqdTyText), m)) else - // Report the error. + // report the error UnifyTypes cenv env m reqdTy actualTy | _ -> UnifyTypes cenv env m overallTy.Commit actualTy diff --git a/src/fsharp/CompilerDiagnostics.fs b/src/fsharp/CompilerDiagnostics.fs index 77ff9ed1acf..d368392468a 100644 --- a/src/fsharp/CompilerDiagnostics.fs +++ b/src/fsharp/CompilerDiagnostics.fs @@ -372,6 +372,7 @@ let IsWarningOrInfoEnabled (err, severity) n level specificWarnOn = match n with | 1182 -> false // chkUnusedValue - off by default | 3180 -> false // abImplicitHeapAllocation - off by default + | 3186 -> false // pickleMissingDefinition - off by default | 3366 -> false //tcIndexNotationDeprecated - currently off by default | 3517 -> false // optFailedToInlineSuggestedValue - off by default | 3388 -> false // tcSubsumptionImplicitConversionUsed - off by default diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index e0a6f86e310..306f6ff775b 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -587,7 +587,10 @@ let PostponeOnFailedMemberConstraintResolution (csenv: ConstraintSolverEnv) f1 f (function | AbortForFailedMemberConstraintResolution -> // Postponed checking of constraints for failed SRTP resolutions is supported from F# 6.0 onwards - if csenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then + // and is required for the "tasks" (aka ResumableStateMachines) feature. + // + // See https://github.com/dotnet/fsharp/issues/12188 + if csenv.g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines then csenv.SolverState.AddPostInferenceCheck (preDefaults=true, check = fun () -> let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = false } f1 csenv |> RaiseOperationResult) @@ -1011,7 +1014,7 @@ and SolveTyparEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalT do! DepthCheck ndeep m match ty1 with | TType_var r | TType_measure (Measure.Var r) -> - do! SolveTyparEqualsTypePart1 csenv m2 trace ty1 r ty + do! SolveTyparEqualsTypePart1 csenv m2 trace ty1 r ty do! SolveTyparEqualsTypePart2 csenv ndeep m2 trace r ty | _ -> failwith "SolveTyparEqualsType" } @@ -1073,12 +1076,14 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr let g = csenv.g // Pre F# 6.0 we asssert the trait solution here - if csenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then - match cxsln with - | Some (traitInfo, traitSln) when traitInfo.Solution.IsNone -> - // If this is an overload resolution at this point it's safe to assume the candidate member being evaluated solves this member constraint. - TransactMemberConstraintSolution traitInfo trace traitSln - | _ -> () +#if TRAIT_CONSTRAINT_CORRECTIONS + if not (csenv.g.langVersion.SupportsFeature LanguageFeature.TraitConstraintCorrections) then +#endif + match cxsln with + | Some (traitInfo, traitSln) when traitInfo.Solution.IsNone -> + // If this is an overload resolution at this point it's safe to assume the candidate member being evaluated solves this member constraint. + TransactMemberConstraintSolution traitInfo trace traitSln + | _ -> () if ty1 === ty2 then CompleteD else @@ -2729,20 +2734,24 @@ and ReportNoCandidatesErrorSynExpr csenv callerArgCounts methodName ad calledMet /// by that method for the purposes of further type checking (just as we assume a type equation /// for the purposes of checking constraints arising from that type equation). /// -/// In F# 5.0 we assert this late by passing the cxsln parameter around. However this +/// In F# 5.0 and 6.0 we assert this late by passing the cxsln parameter around. However this /// relies on not checking return types for SRTP constraints eagerly /// -/// In F# 6.0 we assert this early and add a proper check that return types match for SRTP constraint solving +/// Post F# 6.0 (TraitConstraintCorrections) we will assert this early and add a proper check that return types match for SRTP constraint solving /// (see alwaysCheckReturn) and AssumeMethodSolvesTrait (csenv: ConstraintSolverEnv) (cx: TraitConstraintInfo option) m trace (calledMeth: CalledMeth<_>) = match cx with | Some traitInfo when traitInfo.Solution.IsNone -> let traitSln = MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs - if csenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then +#if TRAIT_CONSTRAINT_CORRECTIONS + if csenv.g.langVersion.SupportsFeature LanguageFeature.TraitConstraintCorrections then TransactMemberConstraintSolution traitInfo trace traitSln None else - Some (traitInfo, traitSln) +#else + ignore trace +#endif + Some (traitInfo, traitSln) | _ -> None @@ -2785,11 +2794,13 @@ and ResolveOverloading // Always take the return type into account for // -- op_Explicit, op_Implicit // -- candidate method sets that potentially use tupling of unfilled out args - /// -- in F# 6.0, also check return types for SRTP constraints + /// -- if TraitConstraintCorrections is enabled, also check return types for SRTP constraints let alwaysCheckReturn = isOpConversion || - candidates |> List.exists (fun cmeth -> cmeth.HasOutArgs) || - (csenv.g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions && cx.IsSome) + candidates |> List.exists (fun cmeth -> cmeth.HasOutArgs) +#if TRAIT_CONSTRAINT_CORRECTIONS + || (csenv.g.langVersion.SupportsFeature LanguageFeature.TraitConstraintCorrections && cx.IsSome) +#endif // Exact match rule. // @@ -2868,7 +2879,7 @@ and ResolveOverloading (ReturnTypesMustSubsumeOrConvert csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome m) (ArgsMustSubsumeOrConvertWithContextualReport csenv ad ndeep (WithTrace newTrace) cxsln cx.IsSome calledMeth) reqdRetTyOpt - calledMeth) with + calledMeth) with | OkResult _ -> None | ErrorResult(_warnings, exn) -> Some {methodSlot = calledMeth; infoReader = infoReader; error = exn }) @@ -3183,7 +3194,10 @@ let EliminateConstraintsForGeneralizedTypars denv css m (trace: OptionalTrace) ( //------------------------------------------------------------------------- -// Main entry points to constraint solver +// Main entry points to constraint solver (some backdoors are used for +// some constructs) +// +// No error recovery here: we do that on a per-expression basis. //------------------------------------------------------------------------- let AddCxTypeEqualsType contextInfo denv css m actual expected = diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 74be7b21d90..9339ebb8cdb 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -149,6 +149,8 @@ type ConstraintSolverState = /// Get the post-inference checks to run at the end of inference member GetPostInferenceChecksFinal: unit -> seq unit> +val BakedInTraitConstraintNames: Set + [] type Trace @@ -156,14 +158,11 @@ type OptionalTrace = | NoTrace | WithTrace of Trace -val BakedInTraitConstraintNames: Set - val SimplifyMeasuresInTypeScheme: TcGlobals -> bool -> Typars -> TType -> TyparConstraint list -> Typars /// The entry point to resolve the overloading for an entire call val ResolveOverloadingForCall: DisplayEnv -> ConstraintSolverState -> range -> methodName: string -> callerArgs: CallerArgs -> AccessorDomain -> calledMethGroup: CalledMeth list -> permitOptArgs: bool -> reqdRetTy: OverallTy -> CalledMeth option * OperationResult -/// The entry point to determine if there is a unique good overload that can be eagerly applied val UnifyUniqueOverloading: DisplayEnv -> ConstraintSolverState -> range -> int * int -> string -> AccessorDomain -> CalledMeth list -> OverallTy -> OperationResult /// Remove the global constraints where these type variables appear in the support of the constraint @@ -171,7 +170,6 @@ val EliminateConstraintsForGeneralizedTypars: DisplayEnv -> ConstraintSolverStat val CheckDeclaredTypars: DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit -/// Unify the types. val AddCxTypeEqualsType: ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit val AddCxTypeEqualsTypeUndoIfFailed: DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool diff --git a/tests/fsharp/typecheck/sigs/neg_issue_3752.bsl b/tests/fsharp/typecheck/sigs/neg_issue_3752.bsl index bec7773d5c6..2f18f739a0a 100644 --- a/tests/fsharp/typecheck/sigs/neg_issue_3752.bsl +++ b/tests/fsharp/typecheck/sigs/neg_issue_3752.bsl @@ -1,4 +1,2 @@ neg_issue_3752.fs(4,19,4,46): typecheck error FS0064: This construct causes code to be less generic than indicated by the type annotations. The type variable 'a has been constrained to be type 'string'. - -neg_issue_3752.fs(4,19,4,46): typecheck error FS0064: This construct causes code to be less generic than indicated by the type annotations. The type variable 'a has been constrained to be type 'string'. From 739b336f47f43f768218a1c271a1587877357062 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 29 Sep 2021 21:05:02 +0100 Subject: [PATCH 14/14] reduce diff and fix errors --- src/fsharp/CheckExpressions.fs | 2 +- src/fsharp/ConstraintSolver.fs | 53 ++++++++++++++++++++------------- src/fsharp/ConstraintSolver.fsi | 2 +- 3 files changed, 34 insertions(+), 23 deletions(-) diff --git a/src/fsharp/CheckExpressions.fs b/src/fsharp/CheckExpressions.fs index faacc362256..325217e52af 100644 --- a/src/fsharp/CheckExpressions.fs +++ b/src/fsharp/CheckExpressions.fs @@ -2620,7 +2620,7 @@ let TcValEarlyGeneralizationConsistencyCheck cenv (env: TcEnv) (v: Val, vrec, ti match vrec with | ValInRecScope isComplete when isComplete && not (isNil tinst) -> //printfn "pushing post-inference check for '%s', vty = '%s'" v.DisplayName (DebugPrint.showType vty) - cenv.css.AddPostInferenceCheck (preDefaults=false, check=fun () -> + cenv.css.PushPostInferenceCheck (preDefaults=false, check=fun () -> //printfn "running post-inference check for '%s'" v.DisplayName //printfn "tau = '%s'" (DebugPrint.showType tau) //printfn "vty = '%s'" (DebugPrint.showType vty) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 306f6ff775b..a1ee59fa26e 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -282,12 +282,18 @@ type ConstraintSolverState = PostInferenceChecksPreDefaults = ResizeArray() PostInferenceChecksFinal = ResizeArray() } - member this.AddPostInferenceCheck (preDefaults, check) = + member this.PushPostInferenceCheck (preDefaults, check) = if preDefaults then this.PostInferenceChecksPreDefaults.Add check else this.PostInferenceChecksFinal.Add check + member this.PopPostInferenceCheck (preDefaults) = + if preDefaults then + this.PostInferenceChecksPreDefaults.RemoveAt(this.PostInferenceChecksPreDefaults.Count-1) + else + this.PostInferenceChecksFinal.RemoveAt(this.PostInferenceChecksPreDefaults.Count-1) + member this.GetPostInferenceChecksPreDefaults() = this.PostInferenceChecksPreDefaults.ToArray() :> seq<_> @@ -579,7 +585,7 @@ let IgnoreFailedMemberConstraintResolution f1 f2 = /// /// To ensure soundness, we double-check the constraint at the end of inference /// with 'ErrorOnFailedMemberConstraintResolution' set to false. -let PostponeOnFailedMemberConstraintResolution (csenv: ConstraintSolverEnv) f1 f2 = +let PostponeOnFailedMemberConstraintResolution (csenv: ConstraintSolverEnv) (trace: OptionalTrace) f1 f2 = TryD (fun () -> let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = true } @@ -591,9 +597,14 @@ let PostponeOnFailedMemberConstraintResolution (csenv: ConstraintSolverEnv) f1 f // // See https://github.com/dotnet/fsharp/issues/12188 if csenv.g.langVersion.SupportsFeature LanguageFeature.ResumableStateMachines then - csenv.SolverState.AddPostInferenceCheck (preDefaults=true, check = fun () -> - let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = false } - f1 csenv |> RaiseOperationResult) + trace.Exec + (fun () -> + csenv.SolverState.PushPostInferenceCheck (preDefaults=true, check = fun () -> + let csenv = { csenv with ErrorOnFailedMemberConstraintResolution = false } + f1 csenv |> RaiseOperationResult)) + (fun () -> + csenv.SolverState.PopPostInferenceCheck (preDefaults=true)) + CompleteD | exn -> f2 exn) @@ -2489,7 +2500,7 @@ and SolveTypeSubsumesTypeWithWrappedContextualReport (csenv: ConstraintSolverEnv (fun () -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m trace cxsln ty1 ty2) (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) else - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> SolveTypeSubsumesTypeKeepAbbrevs csenv ndeep m trace cxsln ty1 ty2) (fun res -> AddWrappedContextualSubsumptionReport csenv ndeep m cxsln ty1 ty2 res wrapper) @@ -3202,7 +3213,7 @@ let EliminateConstraintsForGeneralizedTypars denv css m (trace: OptionalTrace) ( let AddCxTypeEqualsType contextInfo denv css m actual expected = let csenv = MakeConstraintSolverEnv contextInfo css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv NoTrace (fun csenv -> SolveTypeEqualsTypeWithReport csenv 0 m NoTrace None actual expected) ErrorD |> RaiseOperationResult @@ -3275,7 +3286,7 @@ let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = let AddCxMethodConstraint denv css m trace traitInfo = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> trackErrors { do! @@ -3287,70 +3298,70 @@ let AddCxMethodConstraint denv css m trace traitInfo = let AddCxTypeMustSupportNull denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> SolveTypeSupportsNull csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportComparison denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> SolveTypeSupportsComparison csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportEquality denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> SolveTypeSupportsEquality csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportDefaultCtor denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> SolveTypeRequiresDefaultConstructor csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsReferenceType denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> SolveTypeIsReferenceType csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsValueType denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> SolveTypeIsNonNullableValueType csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsUnmanaged denv css m trace ty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> SolveTypeIsUnmanaged csenv 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsEnum denv css m trace ty underlying = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> SolveTypeIsEnum csenv 0 m trace ty underlying) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsDelegate denv css m trace ty aty bty = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv trace (fun csenv -> SolveTypeIsDelegate csenv 0 m trace ty aty bty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTyparDefaultsTo denv css m ctxtInfo tp ridx ty = let csenv = MakeConstraintSolverEnv ctxtInfo css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv NoTrace (fun csenv -> AddConstraint csenv 0 m NoTrace tp (TyparConstraint.DefaultsTo(ridx, ty, m))) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult @@ -3368,7 +3379,7 @@ let ApplyTyparDefaultAtPriority denv css priority (tp: Typar) = let ty1 = mkTyparTy tp if not tp.IsSolved && not (typeEquiv css.g ty1 ty2) then let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv NoTrace (fun csenv -> SolveTyparEqualsType csenv 0 m NoTrace ty1 ty2) (fun res -> @@ -3420,14 +3431,14 @@ let ChooseTyparSolutionAndSolve css denv tp = let amap = css.amap let max, m = ChooseTyparSolutionAndRange g amap tp let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv NoTrace (fun csenv -> SolveTyparEqualsType csenv 0 m NoTrace (mkTyparTy tp) max) (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult let CheckDeclaredTypars denv css m typars1 typars2 = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv - PostponeOnFailedMemberConstraintResolution csenv + PostponeOnFailedMemberConstraintResolution csenv NoTrace (fun csenv -> CollectThenUndo (fun newTrace -> SolveTypeEqualsTypeEqns csenv 0 m (WithTrace newTrace) None diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 9339ebb8cdb..e960daa8f6e 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -141,7 +141,7 @@ type ConstraintSolverState = static member New: TcGlobals * ImportMap * InfoReader * TcValF -> ConstraintSolverState /// Add a post-inference check to run at the end of inference - member AddPostInferenceCheck: preDefaults: bool * check: (unit -> unit) -> unit + member PushPostInferenceCheck: preDefaults: bool * check: (unit -> unit) -> unit /// Get the post-inference checks to run near the end of inference, but before defaults are applied member GetPostInferenceChecksPreDefaults: unit -> seq unit>