From 7822a13610b981c9cd548dcae9ad57f4f93c1e0c Mon Sep 17 00:00:00 2001 From: Lab User Date: Thu, 17 Aug 2017 17:35:49 +0100 Subject: [PATCH 01/40] First attempt --- src/fsharp/ConstraintSolver.fs | 120 ++++++++++------- src/fsharp/ConstraintSolver.fsi | 39 +++--- src/fsharp/Fsc/Fsc.fsproj | 45 +++---- src/fsharp/InfoReader.fs | 4 +- src/fsharp/NameResolution.fsi | 10 +- src/fsharp/TastOps.fs | 5 +- src/fsharp/TastOps.fsi | 5 + src/fsharp/TypeChecker.fs | 219 +++++++++++++++++--------------- 8 files changed, 244 insertions(+), 203 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 4c477bc9554..b26d3244115 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -32,7 +32,8 @@ module internal Microsoft.FSharp.Compiler.ConstraintSolver open Internal.Utilities.Collections -open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -192,19 +193,21 @@ type ConstraintSolverEnv = m: range EquivEnv: TypeEquivEnv DisplayEnv : DisplayEnv + NameResolutionEnv : NameResolutionEnv } member csenv.InfoReader = csenv.SolverState.InfoReader member csenv.g = csenv.SolverState.g member csenv.amap = csenv.SolverState.amap -let MakeConstraintSolverEnv contextInfo css m denv = +let MakeConstraintSolverEnv contextInfo css m denv nres = { SolverState = css m = m eContextInfo = contextInfo // Indicates that when unifiying ty1 = ty2, only type variables in ty1 may be solved MatchingOnly = false EquivEnv = TypeEquivEnv.Empty - DisplayEnv = denv } + DisplayEnv = denv + NameResolutionEnv = nres } //------------------------------------------------------------------------- @@ -973,7 +976,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p let argtys = if memFlags.IsInstance then List.tail argtys else argtys let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo - + match minfos,tys,memFlags.IsInstance,nm,argtys with | _,_,false,("op_Division" | "op_Multiply"),[argty1;argty2] when @@ -1269,7 +1272,6 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p let minst = FreshenMethInfo m minfo let objtys = minfo.GetObjArgTypes(amap, m, minst) Some(CalledMeth(csenv.InfoReader,None,false,FreshenMethInfo,m,AccessibleFromEverywhere,minfo,minst,minst,None,objtys,[(callerArgs,[])],false,false,None))) - let methOverloadResult,errors = trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) (fun trace -> ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) (0,0) AccessibleFromEverywhere calledMethGroup false (Some rty)) @@ -1391,7 +1393,31 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution | MemberKind.Constructor -> tys |> List.map (GetIntrinsicConstructorInfosOfType csenv.SolverState.InfoReader m) | _ -> - tys |> List.map (GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm,AccessibleFromSomeFSharpCode,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m) + let extMemberToMethInfo (_ : TType) extnMember = + match extnMember with + | FSExtMem (valRef, priority) -> + if valRef.LogicalName = nm then + Some <| FSMeth(csenv.g, valRef.Type, valRef, Some priority) + else + None + | ILExtMem(_, methInfo, _) -> + if methInfo.LogicalName = nm then + Some <| methInfo + else + None + let getExtMInfos (t : TType) : MethInfo list = + if nm = "TestMethod" then + List.iter (printfn "%A") csenv.NameResolutionEnv.eTyconsByAccessNames.Values + csenv.NameResolutionEnv.eIndexedExtensionMembers.Contents.Contents.Values + |> List.concat + |> List.choose (extMemberToMethInfo t) + let getRelevantMethods t = + let x = getExtMInfos t + let y = GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm,AccessibleFromSomeFSharpCode,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m t + + printfn "t : %A , x : %A, y : %A" t x y + y + tys |> List.map getRelevantMethods /// Merge the sets so we don't get the same minfo from each side /// We merge based on whether minfos use identical metadata or not. @@ -1403,6 +1429,7 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution minfos else [] + // The trait name "op_Explicit" also covers "op_Implicit", so look for that one too. if nm = "op_Explicit" then results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys,"op_Implicit",memFlags,argtys,rty,soln)) @@ -2410,8 +2437,9 @@ and ResolveOverloading match calledMethOpt with | Some calledMeth -> calledMethOpt, - errors ++ (fun () -> - let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) cx + errors ++ (fun () -> + let ofTraitInfo traitInfo = (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs) + let cxsln = Option.map ofTraitInfo cx match calledMethTrace with | NoTrace -> @@ -2501,8 +2529,8 @@ let EliminateConstraintsForGeneralizedTypars csenv (trace:OptionalTrace) (genera // No error recovery here : we do that on a per-expression basis. //------------------------------------------------------------------------- -let AddCxTypeEqualsType contextInfo denv css m ty1 ty2 = - SolveTypEqualsTypWithReport (MakeConstraintSolverEnv contextInfo css m denv) 0 m NoTrace None ty1 ty2 +let AddCxTypeEqualsType contextInfo denv nenv css m ty1 ty2 = + SolveTypEqualsTypWithReport (MakeConstraintSolverEnv contextInfo css m denv nenv) 0 m NoTrace None ty1 ty2 |> RaiseOperationResult let UndoIfFailed f = @@ -2522,72 +2550,72 @@ let UndoIfFailed f = ReportWarnings warns true -let AddCxTypeEqualsTypeUndoIfFailed denv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) ty1 ty2) +let AddCxTypeEqualsTypeUndoIfFailed denv nenv css m ty1 ty2 = + UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m (WithTrace trace) ty1 ty2) -let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = - let csenv = { MakeConstraintSolverEnv ContextInfo.NoContext css m denv with MatchingOnly = true } +let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv nenv css m ty1 ty2 = + let csenv = { MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) -let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) None ty1 ty2) +let AddCxTypeMustSubsumeTypeUndoIfFailed denv nenv css m ty1 ty2 = + UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m (WithTrace trace) None ty1 ty2) -let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv +let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv nenv css m ty1 ty2 = + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv let csenv = { csenv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs csenv 0 m (WithTrace trace) None ty1 ty2) -let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = - SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv contextInfo css m denv) 0 m trace None ty1 ty2 +let AddCxTypeMustSubsumeType contextInfo denv nenv css m trace ty1 ty2 = + SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv contextInfo css m denv nenv) 0 m trace None ty1 ty2 |> RaiseOperationResult -let AddCxMethodConstraint denv css m trace traitInfo = - TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) true false 0 m trace traitInfo ++ (fun _ -> CompleteD)) +let AddCxMethodConstraint denv nenv css m trace traitInfo = + TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) true false 0 m trace traitInfo ++ (fun _ -> CompleteD)) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportNull denv css m trace ty = - TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) +let AddCxTypeMustSupportNull denv nenv css m trace ty = + TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportComparison denv css m trace ty = - TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) +let AddCxTypeMustSupportComparison denv nenv css m trace ty = + TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportEquality denv css m trace ty = - TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) +let AddCxTypeMustSupportEquality denv nenv css m trace ty = + TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportDefaultCtor denv css m trace ty = - TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) +let AddCxTypeMustSupportDefaultCtor denv nenv css m trace ty = + TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsReferenceType denv css m trace ty = - TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) +let AddCxTypeIsReferenceType denv nenv css m trace ty = + TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsValueType denv css m trace ty = - TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) +let AddCxTypeIsValueType denv nenv css m trace ty = + TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsUnmanaged denv css m trace ty = - TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) +let AddCxTypeIsUnmanaged denv nenv css m trace ty = + TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsEnum denv css m trace ty underlying = - TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty underlying) +let AddCxTypeIsEnum denv nenv css m trace ty underlying = + TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty underlying) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsDelegate denv css m trace ty aty bty = - TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty aty bty) +let AddCxTypeIsDelegate denv nenv css m trace ty aty bty = + TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty aty bty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult @@ -2599,7 +2627,7 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = new InfoReader(g,amap) } - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) (NameResolutionEnv.Empty g) SolveMemberConstraint csenv true true 0 m NoTrace traitInfo ++ (fun _res -> let sln = match traitInfo.Solution with @@ -2683,20 +2711,20 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait | Choice4Of4 () -> ResultD None) -let ChooseTyparSolutionAndSolve css denv tp = +let ChooseTyparSolutionAndSolve css denv nenv tp = let g = css.g let amap = css.amap let max,m = ChooseTyparSolutionAndRange g amap tp - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv TryD (fun () -> SolveTyparEqualsTyp 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 CheckDeclaredTypars denv nenv css m typars1 typars2 = TryD (fun () -> CollectThenUndo (fun trace -> - SolveTypEqualsTypEqns (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) None + SolveTypEqualsTypEqns (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m (WithTrace trace) None (List.map mkTyparTy typars1) (List.map mkTyparTy typars2))) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) @@ -2715,7 +2743,7 @@ let IsApplicableMethApprox g amap m (minfo:MethInfo) availObjTy = TcVal = (fun _ -> failwith "should not be called") ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = new InfoReader(g,amap) } - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) (NameResolutionEnv.Empty g) let minst = FreshenMethInfo m minfo match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index d4175f98bc7..5715cdc786e 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -9,6 +9,7 @@ open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger @@ -105,7 +106,7 @@ type ConstraintSolverEnv val BakedInTraitConstraintNames : Set -val MakeConstraintSolverEnv : ContextInfo -> ConstraintSolverState -> range -> DisplayEnv -> ConstraintSolverEnv +val MakeConstraintSolverEnv : ContextInfo -> ConstraintSolverState -> range -> DisplayEnv -> NameResolutionEnv -> ConstraintSolverEnv [] type Trace @@ -122,28 +123,28 @@ val ResolveOverloading : ConstraintSolverEnv -> OptionalTr val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> CalledMeth list -> TType -> OperationResult val EliminateConstraintsForGeneralizedTypars : ConstraintSolverEnv -> OptionalTrace -> Typars -> unit -val CheckDeclaredTypars : DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit +val CheckDeclaredTypars : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit val AddConstraint : ConstraintSolverEnv -> int -> Range.range -> OptionalTrace -> Typar -> TyparConstraint -> OperationResult -val AddCxTypeEqualsType : ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit -val AddCxTypeEqualsTypeUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -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 -> OptionalTrace -> TraitConstraintInfo -> unit -val AddCxTypeMustSupportNull : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportComparison : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportEquality : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportDefaultCtor : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsReferenceType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsValueType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsUnmanaged : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsEnum : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit -val AddCxTypeIsDelegate : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit +val AddCxTypeEqualsType : ContextInfo -> DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> unit +val AddCxTypeEqualsTypeUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool +val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool +val AddCxTypeMustSubsumeType : ContextInfo -> DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit +val AddCxTypeMustSubsumeTypeUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool +val AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool +val AddCxMethodConstraint : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TraitConstraintInfo -> unit +val AddCxTypeMustSupportNull : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportComparison : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportEquality : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportDefaultCtor : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsReferenceType : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsValueType : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsUnmanaged : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsEnum : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit +val AddCxTypeIsDelegate : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit val CodegenWitnessThatTypSupportsTraitConstraint : TcValF -> TcGlobals -> ImportMap -> range -> TraitConstraintInfo -> Expr list -> OperationResult -val ChooseTyparSolutionAndSolve : ConstraintSolverState -> DisplayEnv -> Typar -> unit +val ChooseTyparSolutionAndSolve : ConstraintSolverState -> DisplayEnv -> NameResolutionEnv -> Typar -> unit val IsApplicableMethApprox : TcGlobals -> ImportMap -> range -> MethInfo -> TType -> bool diff --git a/src/fsharp/Fsc/Fsc.fsproj b/src/fsharp/Fsc/Fsc.fsproj index 164625e9e4f..532acd9f4ad 100644 --- a/src/fsharp/Fsc/Fsc.fsproj +++ b/src/fsharp/Fsc/Fsc.fsproj @@ -1,7 +1,6 @@ - $(MSBuildProjectDirectory)\..\.. @@ -23,6 +22,21 @@ true $(OtherFlags) --warnon:1182 + + fsharptest.fs + C:\Users\labuser\visualfsharp\testfiles + + + + + + + + Microsoft + StrongName + + + $(FSharpSourcesRoot)\..\loc\lcl\{Lang}\$(AssemblyName).exe.lcl @@ -30,9 +44,6 @@ false false - - - Resources/assemblyinfo.fsc.exe.fs @@ -48,19 +59,11 @@ default.win32manifest PreserveNewest + - - - - - + - - - - - {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3} FSharp.Compiler.Private @@ -70,16 +73,4 @@ FSharp.Core - - - - - - - Microsoft - StrongName - - - - - + \ No newline at end of file diff --git a/src/fsharp/InfoReader.fs b/src/fsharp/InfoReader.fs index ffcbd54f10e..2bb096c6dc3 100644 --- a/src/fsharp/InfoReader.fs +++ b/src/fsharp/InfoReader.fs @@ -8,7 +8,7 @@ open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.AttributeChecking @@ -20,7 +20,7 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.TcGlobals /// Use the given function to select some of the member values from the members of an F# type -let private SelectImmediateMemberVals g optFilter f (tcref:TyconRef) = +let SelectImmediateMemberVals g optFilter f (tcref:TyconRef) = let chooser (vref:ValRef) = match vref.MemberInfo with // The 'when' condition is a workaround for the fact that values providing diff --git a/src/fsharp/NameResolution.fsi b/src/fsharp/NameResolution.fsi index b50fc99db76..bbe0a27e9f1 100755 --- a/src/fsharp/NameResolution.fsi +++ b/src/fsharp/NameResolution.fsi @@ -133,8 +133,14 @@ val ItemWithNoInst : Item -> ItemWithInst type FieldResolution = FieldResolution of RecdFieldRef * bool /// Information about an extension member held in the name resolution environment -[] -type ExtensionMember +type ExtensionMember = + /// F#-style Extrinsic extension member, defined in F# code + | FSExtMem of ValRef * ExtensionMethodPriority + + /// ILExtMem(declaringTyconRef, ilMetadata, pri) + /// + /// IL-style extension member, backed by some kind of method with an [] attribute + | ILExtMem of TyconRef * MethInfo * ExtensionMethodPriority /// The environment of information used to resolve names [] diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 41f37d00969..6d864bdc187 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -57,7 +57,7 @@ type TyconRefMap<'T>(imap: StampMap<'T>) = member m.Add (v: TyconRef) x = TyconRefMap (imap.Add (v.Stamp,x)) member m.Remove (v: TyconRef) = TyconRefMap (imap.Remove v.Stamp) member m.IsEmpty = imap.IsEmpty - + member m.Contents = imap static member Empty : TyconRefMap<'T> = TyconRefMap Map.empty static member OfList vs = (vs, TyconRefMap<'T>.Empty) ||> List.foldBack (fun (x,y) acc -> acc.Add x y) @@ -1301,6 +1301,7 @@ type TyconRefMultiMap<'T>(contents: TyconRefMap<'T list>) = | _ -> [] member m.Add (v, x) = TyconRefMultiMap<'T>(contents.Add v (x :: m.Find v)) + member m.Contents = contents static member Empty = TyconRefMultiMap<'T>(TyconRefMap<_>.Empty) static member OfList vs = (vs, TyconRefMultiMap<'T>.Empty) ||> List.foldBack (fun (x,y) acc -> acc.Add (x, y)) @@ -1518,7 +1519,7 @@ let isVoidTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> t let isILAppTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tcref.IsILTycon | _ -> false) let isNativePtrTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tyconRefEq g g.nativeptr_tcr tcref | _ -> false) let isByrefTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tyconRefEq g g.byref_tcr tcref | _ -> false) -let isByrefLikeTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> isByrefLikeTyconRef g tcref | _ -> false) +let isByrefLikeTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> isByrefLikeTyconRef g tcref | _ -> false) #if EXTENSIONTYPING let extensionInfoOfTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tcref.TypeReprInfo | _ -> TNoRepr) #endif diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index ff7907cacea..d6c0875064c 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -298,6 +298,7 @@ type TyconRefMap<'T> = member Add : TyconRef -> 'T -> TyconRefMap<'T> member Remove : TyconRef -> TyconRefMap<'T> member IsEmpty : bool + member Contents : StampMap<'T> static member Empty : TyconRefMap<'T> static member OfList : (TyconRef * 'T) list -> TyconRefMap<'T> @@ -306,6 +307,7 @@ type TyconRefMap<'T> = type TyconRefMultiMap<'T> = member Find : TyconRef -> 'T list member Add : TyconRef * 'T -> TyconRefMultiMap<'T> + member Contents : TyconRefMap<'T list> static member Empty : TyconRefMultiMap<'T> static member OfList : (TyconRef * 'T) list -> TyconRefMultiMap<'T> @@ -998,6 +1000,9 @@ type TypeDefMetadata = #endif val metadataOfTycon : Tycon -> TypeDefMetadata +#if EXTENSIONTYPING +val extensionInfoOfTy : TcGlobals -> TType -> TyconRepresentation +#endif val metadataOfTy : TcGlobals -> TType -> TypeDefMetadata val isStringTy : TcGlobals -> TType -> bool diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 9ca319dfbfd..2731ac19d13 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -594,7 +594,7 @@ let CopyAndFixupTypars m rigid tpsorig = ConstraintSolver.FreshenAndFixupTypars m rigid [] [] tpsorig let UnifyTypes cenv (env: TcEnv) m expectedTy actualTy = - ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g expectedTy) (tryNormalizeMeasureInType cenv.g actualTy) + ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv env.NameEnv cenv.css m (tryNormalizeMeasureInType cenv.g expectedTy) (tryNormalizeMeasureInType cenv.g actualTy) //------------------------------------------------------------------------- // Generate references to the module being generated - used for @@ -702,7 +702,7 @@ let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath env = /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyRefTupleType contextInfo cenv denv m ty ps = +let UnifyRefTupleType contextInfo cenv denv nenv m ty ps = let ptys = if isRefTupleTy cenv.g ty then let ptys = destRefTupleTy cenv.g ty @@ -715,30 +715,30 @@ 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 nenv cenv.css m ty (TType_tuple (tupInfoRef, ptys)) ptys /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyStructTupleType contextInfo cenv denv m ty ps = +let UnifyStructTupleType contextInfo cenv denv nenv m ty ps = let ptys = if isStructTupleTy cenv.g ty then let ptys = destStructTupleTy cenv.g ty if List.length ps = List.length ptys then ptys else NewInferenceTypes ps else NewInferenceTypes ps - AddCxTypeEqualsType contextInfo denv cenv.css m ty (TType_tuple (tupInfoStruct, ptys)) + AddCxTypeEqualsType contextInfo denv nenv cenv.css m ty (TType_tuple (tupInfoStruct, ptys)) ptys /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyFunctionTypeUndoIfFailed cenv denv m ty = +let UnifyFunctionTypeUndoIfFailed cenv denv nenv m ty = match tryDestFunTy cenv.g ty with | None -> let domainTy = NewInferenceType () let resultTy = NewInferenceType () - if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty (domainTy --> resultTy) then + if AddCxTypeEqualsTypeUndoIfFailed denv nenv cenv.css m ty (domainTy --> resultTy) then Some(domainTy,resultTy) else None @@ -746,8 +746,8 @@ let UnifyFunctionTypeUndoIfFailed cenv denv m ty = /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyFunctionType extraInfo cenv denv mFunExpr ty = - match UnifyFunctionTypeUndoIfFailed cenv denv mFunExpr ty with +let UnifyFunctionType extraInfo cenv denv nenv mFunExpr ty = + match UnifyFunctionTypeUndoIfFailed cenv denv nenv mFunExpr ty with | Some res -> res | None -> match extraInfo with @@ -793,13 +793,13 @@ let ReportImplicitlyIgnoredBoolExpression denv m ty expr = | Some expr -> checkExpr m expr | _ -> UnitTypeExpected (denv,ty,m) -let UnifyUnitType cenv denv m ty exprOpt = - if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty cenv.g.unit_ty then +let UnifyUnitType cenv denv nenv m ty exprOpt = + if AddCxTypeEqualsTypeUndoIfFailed denv nenv cenv.css m ty cenv.g.unit_ty then true else let domainTy = NewInferenceType () let resultTy = NewInferenceType () - if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty (domainTy --> resultTy) then + if AddCxTypeEqualsTypeUndoIfFailed denv nenv cenv.css m ty (domainTy --> resultTy) then warning (FunctionValueUnexpected(denv,ty,m)) else if not (typeEquiv cenv.g cenv.g.bool_ty ty) then @@ -2179,7 +2179,7 @@ module GeneralizationHelpers = TrimUngeneralizableTypars genConstrainedTyparFlag inlineFlag generalizedTypars freeInEnv /// Condense type variables in positive position - let CondenseTypars (cenv, denv:DisplayEnv, generalizedTypars: Typars, tauTy, m) = + let CondenseTypars (cenv, denv:DisplayEnv, generalizedTypars: Typars, tauTy, m, nenv:NameResolutionEnv) = // The type of the value is ty11 * ... * ty1N -> ... -> tyM1 * ... * tyMM -> retTy // This is computed REGARDLESS of the arity of the expression. @@ -2231,18 +2231,19 @@ module GeneralizationHelpers = // Condensation solves type variables eagerly and removes them from the generalization set condensationTypars |> List.iter (fun tp -> - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp) + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv nenv tp) generalizedTypars - let CanonicalizePartialInferenceProblem (cenv,denv,m) tps = + let CanonicalizePartialInferenceProblem (cenv,denv,nenv,m) tps = // Canonicalize constraints prior to generalization - let csenv = (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) + let csenv = (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv nenv) TryD (fun () -> ConstraintSolver.CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let ComputeAndGeneralizeGenericTypars (cenv, denv:DisplayEnv, + nenv:NameResolutionEnv, m, freeInEnv:FreeTypars, canInferTypars, @@ -2269,7 +2270,7 @@ module GeneralizationHelpers = let ty = mkTyparTy tp error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty),m))) - let generalizedTypars = CondenseTypars(cenv, denv, generalizedTypars, tauTy, m) + let generalizedTypars = CondenseTypars(cenv, denv, generalizedTypars, tauTy, m, nenv) let generalizedTypars = if canInferTypars then generalizedTypars @@ -2283,7 +2284,7 @@ module GeneralizationHelpers = generalizedTypars |> List.iter (SetTyparRigid cenv.g denv m) // Generalization removes constraints related to generalized type variables - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv nenv EliminateConstraintsForGeneralizedTypars csenv NoTrace generalizedTypars generalizedTypars @@ -2680,7 +2681,7 @@ let TcValEarlyGeneralizationConsistencyCheck cenv (env:TcEnv) (v:Val, vrec, tins let tpsorig = NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g tpsorig let tau3 = instType (mkTyparInst tpsorig tinst) tau2 //printfn "tau3 = '%s'" (DebugPrint.showType tau3) - if not (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m tau tau3) then + if not (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m tau tau3) then let txt = bufs (fun buf -> NicePrint.outputQualifiedValSpec env.DisplayEnv buf v) error(Error(FSComp.SR.tcInferredGenericTypeGivesRiseToInconsistency(v.DisplayName, txt),m))) | _ -> () @@ -2910,7 +2911,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 env.NameEnv cenv.css m NoTrace actualType flexibleType; flexibleType) // Create a coercion to represent the expansion of the application @@ -2919,7 +2920,7 @@ let MakeApplicableExprWithFlex cenv (env: TcEnv) expr = /// Checks, warnings and constraint assertions for downcasts -let TcRuntimeTypeTest isCast isOperator cenv denv m tgty srcTy = +let TcRuntimeTypeTest isCast isOperator cenv denv nenv m tgty srcTy = if TypeDefinitelySubsumesTypeNoCoercion 0 cenv.g cenv.amap m tgty srcTy then warning(TypeTestUnnecessary(m)) @@ -2931,9 +2932,9 @@ let TcRuntimeTypeTest isCast isOperator cenv denv m tgty srcTy = if isSealedTy cenv.g tgty || isTyparTy cenv.g tgty || not (isInterfaceTy cenv.g srcTy) then if isCast then - AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv cenv.css m NoTrace srcTy tgty + AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv nenv cenv.css m NoTrace srcTy tgty else - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace srcTy tgty + AddCxTypeMustSubsumeType ContextInfo.NoContext denv nenv cenv.css m NoTrace srcTy tgty if isErasedType cenv.g tgty then if isCast then @@ -2947,7 +2948,7 @@ let TcRuntimeTypeTest isCast isOperator cenv denv m tgty srcTy = else warning(Error(FSComp.SR.tcTypeTestLossy(NicePrint.minimalStringOfType denv ety, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll cenv.g ety)),m))) /// Checks, warnings and constraint assertions for upcasts -let TcStaticUpcast cenv denv m tgty srcTy = +let TcStaticUpcast cenv denv nenv m tgty srcTy = if isTyparTy cenv.g tgty then error(IndeterminateStaticCoercion(denv,srcTy,tgty,m)) @@ -2957,7 +2958,7 @@ let TcStaticUpcast cenv denv m tgty srcTy = if typeEquiv cenv.g srcTy tgty then warning(UpcastUnnecessary(m)) - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace tgty srcTy + AddCxTypeMustSubsumeType ContextInfo.NoContext denv nenv cenv.css m NoTrace tgty srcTy @@ -3328,7 +3329,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> let probe ty = - if (AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m ty exprty) then + if (AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m ty exprty) then match tryType (mkCoerceExpr(expr,ty,expr.Range,exprty),ty) with | Result res -> Some res | Exception e -> @@ -3355,7 +3356,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr let ConvertArbitraryExprToEnumerable cenv ty (env: TcEnv) (expr:Expr) = let m = expr.Range let enumElemTy = NewInferenceType () - if AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m ( mkSeqTy cenv.g enumElemTy) ty then + if AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m ( mkSeqTy cenv.g enumElemTy) ty then expr,enumElemTy else let enumerableVar,enumerableExpr = mkCompGenLocal m "inputSequence" ty @@ -3383,7 +3384,7 @@ let mkSeqCollect cenv env m enumElemTy genTy lam enumExpr = mkCallSeqCollect cenv.g m enumElemTy genResultTy lam enumExpr let mkSeqUsing cenv (env: TcEnv) m resourceTy genTy resourceExpr lam = - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace cenv.g.system_IDisposable_typ resourceTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace cenv.g.system_IDisposable_typ resourceTy let genResultTy = NewInferenceType () UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) mkCallSeqUsing cenv.g m resourceTy genResultTy resourceExpr lam @@ -4147,14 +4148,14 @@ let GetInstanceMemberThisVariable (v:Val,x) = 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 env.NameEnv cenv.css m NoTrace (mkTyparTy tp') tpenv match c with | WhereTyparDefaultsToType(tp,ty,m) -> let ty',tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty let tp',tpenv = TcTypar cenv env newOk tpenv tp - let csenv = MakeConstraintSolverEnv env.eContextInfo cenv.css m env.DisplayEnv + let csenv = MakeConstraintSolverEnv env.eContextInfo cenv.css m env.DisplayEnv env.NameEnv AddConstraint csenv 0 m NoTrace tp' (TyparConstraint.DefaultsTo(ridx,ty',m)) |> CommitOperationResult tpenv @@ -4163,7 +4164,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 env.NameEnv cenv.css m NoTrace ty' (mkTyparTy tp') tpenv | WhereTyparSupportsNull(tp,m) -> checkSimpleConstraint tp m AddCxTypeMustSupportNull @@ -4184,7 +4185,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 env.NameEnv cenv.css m NoTrace (mkTyparTy tp') underlying' tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(),m)) @@ -4197,7 +4198,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 env.NameEnv cenv.css m NoTrace (mkTyparTy tp') a' b' tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(),m)) @@ -4209,13 +4210,13 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | TTrait(objtys,".ctor",memberFlags,argtys,returnTy,_) when memberFlags.MemberKind = MemberKind.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 env.NameEnv cenv.css m NoTrace ty tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidNewConstraint(),m)) tpenv | _ -> - AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo + AddCxMethodConstraint env.DisplayEnv env.NameEnv cenv.css m NoTrace traitInfo tpenv and TcPseudoMemberSpec cenv newOk env synTypes tpenv memSpfn m = @@ -4563,7 +4564,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped | 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 env.NameEnv cenv.css m NoTrace ty' (mkTyparTy tp) tp.AsType, tpenv | SynType.StaticConstant (c, m) -> @@ -5014,7 +5015,7 @@ and TcSimplePats cenv optArgsOK checkCxs ty env (tpenv,names,takenNames:Set<_>) [v],(tpenv,names,takenNames) | SynSimplePats.SimplePats (ps,m) -> - let ptys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv m ty ps + let ptys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv env.NameEnv m ty ps let ps',(tpenv,names,takenNames) = List.mapFold (fun tpenv (ty,e) -> TcSimplePat optArgsOK checkCxs cenv ty env tpenv e) (tpenv,names,takenNames) (List.zip ptys ps) ps',(tpenv,names,takenNames) @@ -5101,7 +5102,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat | SynPat.Named (SynPat.IsInst(cty,m),_,_,_,_) -> let srcTy = ty let tgty,tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurence.UseInType env tpenv cty - TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv env.NameEnv m tgty srcTy match pat with | SynPat.IsInst(_,m) -> (fun _ -> TPat_isinst (srcTy,tgty,None,m)),(tpenv,names,takenNames) @@ -5388,7 +5389,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat (fun _ -> TPat_range(c1,c2,m)),(tpenv,names,takenNames) | SynPat.Null m -> - AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace ty + AddCxTypeMustSupportNull env.DisplayEnv env.NameEnv cenv.css m NoTrace ty (fun _ -> TPat_null m),(tpenv,names,takenNames) | SynPat.InstanceMember (_,_,_,_,m) -> @@ -5402,10 +5403,10 @@ and TcPatterns warnOnUpper cenv env vFlags s argtys args = List.mapFold (fun s (ty,pat) -> TcPat warnOnUpper cenv env None vFlags s ty pat) s (List.zip argtys args) -and solveTypAsError cenv denv m ty = +and solveTypAsError cenv denv nenv m ty = let ty2 = NewErrorType () assert((destTyparTy cenv.g ty2).IsFromError) - SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) 0 m NoTrace ty ty2 |> ignore + SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv nenv) 0 m NoTrace ty ty2 |> ignore and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv expr = // This function is motivated by cases like @@ -5453,7 +5454,7 @@ and TcExprOfUnknownType cenv env tpenv expr = and TcExprFlex cenv flex ty (env: TcEnv) tpenv (e: SynExpr) = if flex then let argty = NewInferenceType () - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css e.Range NoTrace ty argty + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css e.Range NoTrace ty argty let e',tpenv = TcExpr cenv argty env tpenv e let e' = mkCoerceIfNeeded cenv.g ty argty e' e',tpenv @@ -5472,7 +5473,7 @@ and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) = // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error errorRecovery e m - solveTypAsError cenv env.DisplayEnv m ty + solveTypAsError cenv env.DisplayEnv env.NameEnv m ty mkThrow m ty (mkOne cenv.g m), tpenv and TcExprNoRecover cenv ty (env: TcEnv) tpenv (expr: SynExpr) = @@ -5497,7 +5498,7 @@ and TcExprOfUnknownTypeThen cenv env tpenv expr delayed = with e -> let m = expr.Range errorRecovery e m - solveTypAsError cenv env.DisplayEnv m exprty + solveTypAsError cenv env.DisplayEnv env.NameEnv m exprty mkThrow m exprty (mkOne cenv.g m), tpenv expr',exprty,tpenv @@ -5527,7 +5528,7 @@ and TcStmtThatCantBeCtorBody cenv env tpenv expr = and TcStmt cenv env tpenv synExpr = let expr,ty,tpenv = TcExprOfUnknownType cenv env tpenv synExpr let m = synExpr.Range - let wasUnit = UnifyUnitType cenv env.DisplayEnv m ty (Some expr) + let wasUnit = UnifyUnitType cenv env.DisplayEnv env.NameEnv m ty (Some expr) if wasUnit then expr,tpenv else @@ -5640,7 +5641,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.MatchLambda (isExnMatch,argm,clauses,spMatch,m) -> // (spMatch,x,matches,isExnMatch,m) -> - let domainTy,resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy + let domainTy,resultTy = UnifyFunctionType None cenv env.DisplayEnv env.NameEnv m overallTy let idv1,idve1 = mkCompGenLocal argm (cenv.synArgNameGenerator.New()) domainTy let envinner = ExitFamilyRegion env let idv2,matchExpr, tpenv = TcAndPatternCompileMatchClauses m argm (if isExnMatch then Throw else ThrowIncompleteMatchException) cenv domainTy resultTy envinner tpenv clauses @@ -5665,7 +5666,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = let e',srcTy,tpenv = TcExprOfUnknownType cenv env tpenv e UnifyTypes cenv env m overallTy cenv.g.bool_ty let tgty,tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgty - TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv env.NameEnv m tgty srcTy let e' = mkCallTypeTest cenv.g m tgty e' e', tpenv @@ -5686,7 +5687,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.InferredUpcast _ -> overallTy,tpenv | _ -> failwith "upcast" - TcStaticUpcast cenv env.DisplayEnv m tgty srcTy + TcStaticUpcast cenv env.DisplayEnv env.NameEnv m tgty srcTy mkCoerceExpr(e',tgty,m,srcTy),tpenv | SynExpr.Downcast(e,_,m) | SynExpr.InferredDowncast (e,m) -> @@ -5699,7 +5700,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = tgty,tpenv,true | SynExpr.InferredDowncast _ -> overallTy,tpenv,false | _ -> failwith "downcast" - TcRuntimeTypeTest (*isCast*)true isOperator cenv env.DisplayEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)true isOperator cenv env.DisplayEnv env.NameEnv m tgty srcTy // TcRuntimeTypeTest ensures tgty is a nominal type. Hence we can insert a check here // based on the nullness semantics of the nominal type. @@ -5707,7 +5708,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = e',tpenv | SynExpr.Null m -> - AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace overallTy + AddCxTypeMustSupportNull env.DisplayEnv env.NameEnv cenv.css m NoTrace overallTy mkNull m overallTy,tpenv | SynExpr.Lazy (e,m) -> @@ -5717,14 +5718,14 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = mkLazyDelayed cenv.g m ety (mkUnitDelayLambda cenv.g m e'), tpenv | SynExpr.Tuple (args,_,m) -> - let argtys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv m overallTy args + let argtys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv env.NameEnv m overallTy args // No subsumption at tuple construction let flexes = argtys |> List.map (fun _ -> false) let args',tpenv = TcExprs cenv env m tpenv flexes argtys args mkRefTupled cenv.g m args' argtys, tpenv | SynExpr.StructTuple (args,_,m) -> - let argtys = UnifyStructTupleType env.eContextInfo cenv env.DisplayEnv m overallTy args + let argtys = UnifyStructTupleType env.eContextInfo cenv env.DisplayEnv env.NameEnv m overallTy args // No subsumption at tuple construction let flexes = argtys |> List.map (fun _ -> false) let args',tpenv = TcExprs cenv env m tpenv flexes argtys args @@ -5838,7 +5839,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = UnifyTypes cenv env m overallTy genCollTy let exprty = NewInferenceType () let genEnumTy = mkSeqTy cenv.g genCollElemTy - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace genEnumTy exprty + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace genEnumTy exprty let expr,tpenv = TcExpr cenv exprty env tpenv comp let expr = mkCoerceIfNeeded cenv.g genEnumTy (tyOfExpr cenv.g expr) expr (if isArray then mkCallSeqToArray else mkCallSeqToList) cenv.g m genCollElemTy @@ -5983,7 +5984,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: 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 = TcExprs cenv env m tpenv flexes argtys args - AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo + AddCxMethodConstraint env.DisplayEnv env.NameEnv cenv.css m NoTrace traitInfo UnifyTypes cenv env m overallTy returnTy Expr.Op(TOp.TraitCall(traitInfo), [], args', m), tpenv @@ -6045,7 +6046,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = and TcIteratedLambdas cenv isFirst (env: TcEnv) overallTy takenNames tpenv e = match e with | SynExpr.Lambda (isMember,isSubsequent,spats,bodyExpr,m) when isMember || isFirst || isSubsequent -> - let domainTy,resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy + let domainTy,resultTy = UnifyFunctionType None cenv env.DisplayEnv env.NameEnv m overallTy let vs, (tpenv,names,takenNames) = TcSimplePats cenv isMember CheckCxs domainTy env (tpenv,Map.empty,takenNames) spats let envinner,_,vspecMap = MakeAndPublishSimpleVals cenv env m names true let byrefs = vspecMap |> Map.map (fun _ v -> isByrefTy cenv.g v.Type, v) @@ -6142,7 +6143,7 @@ and TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv wholeExpr e1 indexArg | Some (path,functionName,indexArgs) -> let operPath = mkSynLidGet mDot path (CompileOpName functionName) let f,fty,tpenv = TcExprOfUnknownType cenv env tpenv operPath - let domainTy,resultTy = UnifyFunctionType (Some mWholeExpr) cenv env.DisplayEnv mWholeExpr fty + let domainTy,resultTy = UnifyFunctionType (Some mWholeExpr) cenv env.DisplayEnv env.NameEnv mWholeExpr fty UnifyTypes cenv env mWholeExpr domainTy e1ty let f' = buildApp cenv (MakeApplicableExprNoFlex cenv f) fty e1' mWholeExpr let delayed = List.foldBack (fun idx acc -> DelayedApp(ExprAtomicFlag.Atomic,idx,mWholeExpr) :: acc) indexArgs delayed // atomic, otherwise no ar.[1] <- xyz @@ -6185,7 +6186,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 env.NameEnv cenv.css mWholeExprOrObjTy NoTrace objTy match arg with | SynExpr.Const (SynConst.Unit,_) -> () @@ -6463,6 +6464,7 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo,bind) = match NameMap.range nameToPrelimValSchemeMap with | [PrelimValScheme1(id,_,_,_,_,_,_,_,_,_,_)] -> let denv = env.DisplayEnv + let nenv = env.NameEnv let declaredTypars = match absSlotInfo with @@ -6471,11 +6473,11 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo,bind) = | _ -> declaredTypars // Canonicalize constraints prior to generalization - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,m) declaredTypars + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,nenv,m) declaredTypars let freeInEnv = GeneralizationHelpers.ComputeUngeneralizableTypars env - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv,denv,m,freeInEnv,false,CanGeneralizeConstrainedTypars,inlineFlag,Some(rhsExpr),declaredTypars,[],bindingTy,false) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv,denv,nenv,m,freeInEnv,false,CanGeneralizeConstrainedTypars,inlineFlag,Some(rhsExpr),declaredTypars,[],bindingTy,false) let declaredTypars = ChooseCanonicalDeclaredTyparsAfterInference cenv.g env.DisplayEnv declaredTypars m let generalizedTypars = PlaceTyparsInDeclarationOrder declaredTypars generalizedTypars @@ -6693,7 +6695,7 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy,argopt,binds,extraImpls,mNew /// Check a constant string expression. It might be a 'printf' format string and TcConstStringExpr cenv overallTy env m tpenv s = - if (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy cenv.g.string_ty) then + if (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m overallTy cenv.g.string_ty) then mkString cenv.g m s,tpenv else let aty = NewInferenceType () @@ -6702,7 +6704,7 @@ and TcConstStringExpr cenv overallTy env m tpenv s = let dty = NewInferenceType () let ety = NewInferenceType () let ty' = mkPrintfFormatTy cenv.g aty bty cty dty ety - if (not (isObjTy cenv.g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy ty') then + if (not (isObjTy cenv.g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m overallTy ty') then // Parse the format string to work out the phantom types let source = match cenv.tcSink.CurrentSink with None -> None | Some sink -> sink.CurrentSource let normalizedString = (s.Replace("\r\n", "\n").Replace("\r", "\n")) @@ -8194,7 +8196,7 @@ and TcSequenceExpression cenv env tpenv comp 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 env.NameEnv cenv.css m NoTrace genOuterTy genExprTy Some(mkCoerceExpr(resultExpr,genOuterTy,m,genExprTy), tpenv) | SynExpr.YieldOrReturn((isYield,_),yieldExpr,m) -> @@ -8254,7 +8256,8 @@ and Propagate cenv overallTy env tpenv (expr: ApplicableExpr) exprty delayed = | DelayedApp (_, arg, mExprAndArg) :: delayedList' -> let denv = env.DisplayEnv - match UnifyFunctionTypeUndoIfFailed cenv denv mExpr exprty with + let nenv = env.NameEnv + match UnifyFunctionTypeUndoIfFailed cenv denv nenv mExpr exprty with | Some (_,resultTy) -> propagate delayedList' mExprAndArg resultTy | None -> @@ -8332,11 +8335,12 @@ and delayRest rest mPrior delayed = and TcFunctionApplicationThen cenv overallTy env tpenv mExprAndArg expr exprty (synArg: SynExpr) atomicFlag delayed = let denv = env.DisplayEnv + let nenv = env.NameEnv let mArg = synArg.Range let mFunExpr = expr.Range // If the type of 'synArg' unifies as a function type, then this is a function application, otherwise // it is an error or a computation expression - match UnifyFunctionTypeUndoIfFailed cenv denv mFunExpr exprty with + match UnifyFunctionTypeUndoIfFailed cenv denv nenv mFunExpr exprty with | Some (domainTy,resultTy) -> // Notice the special case 'seq { ... }'. In this case 'seq' is actually a function in the F# library. @@ -8772,7 +8776,7 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterResolution) delaye let resultExpr, tpenv = TcDelayed cenv intermediateTy env tpenv mItem (MakeApplicableExprNoFlex cenv expr) (tyOfExpr cenv.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 env.NameEnv 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 @@ -8980,7 +8984,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela // Canonicalize inference problem prior to '.' lookup on variable types if isTyparTy cenv.g objExprTy then - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,env.DisplayEnv,mExprAndLongId) (freeInTypeLeftToRight cenv.g false objExprTy) + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,env.DisplayEnv,env.NameEnv,mExprAndLongId) (freeInTypeLeftToRight cenv.g false objExprTy) let item,mItem,rest,afterResolution = ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver mExprAndLongId ad env.eNameResEnv objExprTy longId findFlag false let mExprAndItem = unionRanges mObjExpr mItem @@ -9045,7 +9049,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela RecdFieldInstanceChecks cenv.g cenv.amap ad mItem rfinfo let tgty = rfinfo.EnclosingType let valu = isStructTy cenv.g tgty - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem NoTrace tgty objExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css mItem NoTrace tgty objExprTy let objExpr = if valu then objExpr else mkCoerceExpr(objExpr,tgty,mExprAndItem,objExprTy) let fieldTy = rfinfo.FieldType match delayed with @@ -9218,6 +9222,7 @@ and TcMethodApplication = let denv = env.DisplayEnv + let nenv = env.NameEnv let isSimpleFormalArg (isParamArrayArg, isOutArg, optArgInfo: OptionalArgInfo, callerInfoInfo: CallerInfoInfo, _reflArgInfo: ReflectedArgInfo) = not isParamArrayArg && not isOutArg && not optArgInfo.IsOptional && callerInfoInfo = NoCallerInfo @@ -9336,7 +9341,7 @@ and TcMethodApplication let curriedArgTys = GenerateMatchingSimpleArgumentTypes calledMeth let returnTy = (exprTy,curriedArgTys) ||> List.fold (fun exprTy argTys -> - let domainTy,resultTy = UnifyFunctionType None cenv denv mMethExpr exprTy + let domainTy,resultTy = UnifyFunctionType None cenv denv nenv mMethExpr exprTy UnifyTypes cenv env mMethExpr domainTy (mkRefTupledTy cenv.g argTys) resultTy) curriedArgTys,returnTy @@ -9375,7 +9380,7 @@ and TcMethodApplication // type we assume the number of arguments is just "1". | None,_ -> - let domainTy,returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy + let domainTy,returnTy = UnifyFunctionType None cenv denv nenv mMethExpr exprTy let argTys = if isUnitTy cenv.g domainTy then [] else tryDestRefTupleTy cenv.g domainTy // Only apply this rule if a candidate method exists with this number of arguments let argTys = @@ -9411,8 +9416,8 @@ and TcMethodApplication if meth.UsesParamArrayConversion then yield makeOneCalledMeth (minfo,pinfoOpt,false) ] - let uniquelyResolved = - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv + let uniquelyResolved = + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv nenv let res = UnifyUniqueOverloading csenv callerArgCounts methodName ad preArgumentTypeCheckingCalledMethGroup returnTy match res with @@ -9446,7 +9451,7 @@ and TcMethodApplication | [calledMeth] -> UnifyMatchingSimpleArgumentTypes exprTy calledMeth | _ -> - let domainTy,returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy + let domainTy,returnTy = UnifyFunctionType None cenv denv nenv mMethExpr exprTy let argTys = if isUnitTy cenv.g domainTy then [] else tryDestRefTupleTy cenv.g domainTy // Only apply this rule if a candidate method exists with this number of arguments let argTys = @@ -9475,7 +9480,7 @@ and TcMethodApplication match ExamineMethodForLambdaPropagation meth with | Some (unnamedInfo, namedInfo) -> let calledObjArgTys = meth.CalledObjArgTys(mMethExpr) - if (calledObjArgTys, callerObjArgTys) ||> Seq.forall2 (fun calledTy callerTy -> AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv cenv.css mMethExpr calledTy callerTy) then + if (calledObjArgTys, callerObjArgTys) ||> Seq.forall2 (fun calledTy callerTy -> AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv nenv cenv.css mMethExpr calledTy callerTy) then yield (List.toArraySquared unnamedInfo, List.toArraySquared namedInfo) | None -> () |] else @@ -9504,12 +9509,12 @@ and TcMethodApplication CalledMeth(cenv.infoReader,Some(env.NameEnv),isCheckingAttributeCall,FreshenMethInfo, mMethExpr,ad,minfo,minst,callerTyArgs,pinfoOpt,callerObjArgTys,callerArgs,usesParamArrayConversion,true,objTyOpt)) let callerArgCounts = (unnamedCurriedCallerArgs.Length, namedCurriedCallerArgs.Length) - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv nenv // Commit unassociated constraints prior to member overload resolution where there is ambiguity // about the possible target of the call. if not uniquelyResolved then - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,mItem) + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,nenv,mItem) (//freeInTypeLeftToRight cenv.g false returnTy @ (unnamedCurriedCallerArgs |> List.collectSquared (fun callerArg -> freeInTypeLeftToRight cenv.g false callerArg.Type))) @@ -9590,7 +9595,7 @@ and TcMethodApplication typeEquiv cenv.g finalCalledMethInfo.EnclosingType cenv.g.obj_ty && (finalCalledMethInfo.LogicalName = "GetHashCode" || finalCalledMethInfo.LogicalName = "Equals")) then - objArgs |> List.iter (fun expr -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace (tyOfExpr cenv.g expr)) + objArgs |> List.iter (fun expr -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv env.NameEnv 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. @@ -9601,7 +9606,7 @@ and TcMethodApplication HasHeadType cenv.g cenv.g.tcref_System_Collections_Generic_IEqualityComparer ty)) then match argsOfAppTy cenv.g finalCalledMethInfo.EnclosingType with - | [dty; _] -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace dty + | [dty; _] -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv env.NameEnv cenv.css mMethExpr NoTrace dty | _ -> () end @@ -10004,9 +10009,9 @@ and TcMethodArg cenv env (lambdaPropagationInfo,tpenv) (lambdaPropagationInfoF if col |> ListSet.setify (typeEquiv cenv.g) |> isSingleton then let calledLambdaArgTy = col.[0] // Force the caller to be a function type. - match UnifyFunctionTypeUndoIfFailed cenv env.DisplayEnv mArg callerLambdaTy with + match UnifyFunctionTypeUndoIfFailed cenv env.DisplayEnv env.NameEnv mArg callerLambdaTy with | Some (callerLambdaDomainTy,callerLambdaRangeTy) -> - if AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css mArg calledLambdaArgTy callerLambdaDomainTy then + if AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css mArg calledLambdaArgTy callerLambdaDomainTy then loop callerLambdaRangeTy (lambdaVarNum + 1) | None -> () loop argTy 0 @@ -10024,7 +10029,7 @@ and TcMethodArg cenv env (lambdaPropagationInfo,tpenv) (lambdaPropagationInfoF | NoInfo | CallerLambdaHasArgTypes _ -> yield info | CalledArgMatchesType adjustedCalledTy -> - if AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed env.DisplayEnv cenv.css mArg adjustedCalledTy argTy then + if AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed env.DisplayEnv env.NameEnv cenv.css mArg adjustedCalledTy argTy then yield info |] CallerArg(argTy,mArg,isOpt,e'),(lambdaPropagationInfo,tpenv) @@ -10370,7 +10375,7 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt else TcExprThatCantBeCtorBody cenv overallExprTy envinner tpenv rhsExpr) if bkind = StandaloneExpression && not cenv.isScript then - UnifyUnitType cenv env.DisplayEnv mBinding overallPatTy (Some rhsExprChecked) |> ignore + UnifyUnitType cenv env.DisplayEnv env.NameEnv mBinding overallPatTy (Some rhsExprChecked) |> ignore // Fix up the r.h.s. expression for 'fixed' let rhsExprChecked = @@ -10585,7 +10590,7 @@ and TcAttribute canFail cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = let propNameItem = Item.SetterArg(id, setterItem) CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,propNameItem,propNameItem,emptyTyparInst,ItemOccurence.Use,env.DisplayEnv,ad) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace argty argtyv + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace argty argtyv AttribNamedArg(nm,argty,isProp,mkAttribExpr callerArgExpr)) @@ -10651,13 +10656,14 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope // Canonicalize constraints prior to generalization let denv = env.DisplayEnv - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,bindsm) + let nenv = env.NameEnv + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,nenv,bindsm) (binds' |> List.collect (fun tbinfo -> let (CheckedBindingInfo(_,_,_,_,flex,_,_,_,tauTy,_,_,_,_,_)) = tbinfo let (ExplicitTyparInfo(_,declaredTypars,_)) = flex let maxInferredTypars = (freeInTypeLeftToRight cenv.g false tauTy) declaredTypars @ maxInferredTypars)) - + let nenv = env.NameEnv let lazyFreeInEnv = lazy (GeneralizationHelpers.ComputeUngeneralizableTypars env) // Generalize the bindings... @@ -10676,7 +10682,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope [] else let freeInEnv = lazyFreeInEnv.Force() - GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv,denv, m, freeInEnv, canInferTypars, GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl(declKind), inlineFlag, Some rhsExpr, allDeclaredTypars, maxInferredTypars,tauTy,false) + GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv,denv, nenv,m, freeInEnv, canInferTypars, GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl(declKind), inlineFlag, Some rhsExpr, allDeclaredTypars, maxInferredTypars,tauTy,false) let prelimValSchemes2 = GeneralizeVals cenv denv enclosingDeclaredTypars generalizedTypars nameToPrelimValSchemeMap @@ -10738,7 +10744,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope let mkCleanup (bodyExpr,bodyExprTy) = if isUse && not isFixed then (allValsDefinedByPattern,(bodyExpr,bodyExprTy)) ||> List.foldBack (fun v (bodyExpr,bodyExprTy) -> - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css v.Range NoTrace cenv.g.system_IDisposable_typ v.Type + AddCxTypeMustSubsumeType ContextInfo.NoContext denv nenv cenv.css v.Range NoTrace cenv.g.system_IDisposable_typ v.Type let cleanupE = BuildDisposableCleanup cenv env m v mkTryFinally cenv.g (bodyExpr,cleanupE,m,bodyExprTy,SequencePointInBodyOfTry,NoSequencePointAtFinally),bodyExprTy) else @@ -10798,7 +10804,7 @@ and ApplyTypesFromArgumentPatterns (cenv, env, optArgsOK, ty, m, tpenv, Normaliz | _ -> () | pushedPat :: morePushedPats -> - let domainTy,resultTy = UnifyFunctionType None cenv env.DisplayEnv m ty + let domainTy,resultTy = UnifyFunctionType None cenv env.DisplayEnv env.NameEnv m ty // We apply the type information from the patterns by type checking the // "simple" patterns against 'domainTy'. They get re-typechecked later. ignore (TcSimplePats cenv optArgsOK CheckCxs domainTy env (tpenv,Map.empty,Set.empty) pushedPat) @@ -11316,7 +11322,7 @@ and TcLetrecBinding reqdThisValTy, (mkAppTy enclosingTyconRef (List.map mkTyparTy enclosingDeclaredTypars)), vspec.Range | Some thisVal -> reqdThisValTy, thisVal.Type, thisVal.Range - if not (AddCxTypeEqualsTypeUndoIfFailed envRec.DisplayEnv cenv.css rangeForCheck actualThisValTy reqdThisValTy) then + if not (AddCxTypeEqualsTypeUndoIfFailed envRec.DisplayEnv envRec.NameEnv cenv.css rangeForCheck actualThisValTy reqdThisValTy) then errorR (Error(FSComp.SR.tcNonUniformMemberUse vspec.DisplayName,vspec.Range)) let preGeneralizationRecBind = @@ -11344,6 +11350,7 @@ and TcIncrementalLetRecGeneralization cenv scopem uncheckedRecBindsTable : Map) = let denv = envNonRec.DisplayEnv + let nenv = envNonRec.NameEnv // recompute the free-in-environment in case any type variables have been instantiated let freeInEnv = GeneralizationHelpers.ComputeUngeneralizableTypars envNonRec @@ -11487,9 +11494,9 @@ and TcIncrementalLetRecGeneralization cenv scopem else let supportForBindings = newGeneralizableBindings |> List.collect (TcLetrecComputeSupportForBinding cenv) - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,scopem) supportForBindings + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,nenv,scopem) supportForBindings - let generalizedTyparsL = newGeneralizableBindings |> List.map (TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv) + let generalizedTyparsL = newGeneralizableBindings |> List.map (TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv envNonRec.NameEnv) // Generalize the bindings. let newGeneralizedRecBinds = (generalizedTyparsL,newGeneralizableBindings) ||> List.map2 (TcLetrecGeneralizeBinding cenv denv ) @@ -11509,7 +11516,7 @@ and TcIncrementalLetRecGeneralization cenv scopem //------------------------------------------------------------------------- /// Compute the type variables which may be generalized and perform the generalization -and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgrbind : PreGeneralizationRecursiveBinding) = +and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (nenv : NameResolutionEnv) (pgrbind : PreGeneralizationRecursiveBinding) = let freeInEnv = Zset.diff freeInEnv (Zset.ofList typarOrder (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) @@ -11524,7 +11531,7 @@ and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgr // two declared type variables. So we now check that, for each binding, the declared // type variables can be unified with a rigid version of the same and undo the results // of this unification. - ConstraintSolver.CheckDeclaredTypars denv cenv.css m rigidCopyOfDeclaredTypars declaredTypars + ConstraintSolver.CheckDeclaredTypars denv nenv cenv.css m rigidCopyOfDeclaredTypars declaredTypars let memFlagsOpt = vspec.MemberInfo |> Option.map (fun memInfo -> memInfo.MemberFlags) let isCtor = (match memFlagsOpt with None -> false | Some memberFlags -> memberFlags.MemberKind = MemberKind.Constructor) @@ -11536,7 +11543,7 @@ and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgr let maxInferredTypars = freeInTypeLeftToRight cenv.g false tau let canGeneralizeConstrained = GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl rbinfo.DeclKind - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars (cenv,denv,m,freeInEnv,canInferTypars,canGeneralizeConstrained,inlineFlag, Some(expr), allDeclaredTypars, maxInferredTypars,tau,isCtor) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars (cenv,denv,nenv,m,freeInEnv,canInferTypars,canGeneralizeConstrained,inlineFlag, Some(expr), allDeclaredTypars, maxInferredTypars,tau,isCtor) generalizedTypars /// Compute the type variables which may have member constraints that need to be canonicalized prior to generalization @@ -11765,6 +11772,7 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF let valinfos, tpenv = TcValSpec cenv env declKind newOk containerInfo memFlagsOpt None tpenv valSpfn attrs let denv = env.DisplayEnv + let nenv = env.NameEnv (tpenv, valinfos) ||> List.mapFold (fun tpenv valSpecResult -> @@ -11778,7 +11786,7 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF let flex = ExplicitTyparInfo(declaredTypars,declaredTypars,synCanInferTypars) - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv,denv,id.idRange,emptyFreeTypars,canInferTypars,CanGeneralizeConstrainedTypars,inlineFlag,None,allDeclaredTypars,freeInType,ty,false) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv,denv,nenv,id.idRange,emptyFreeTypars,canInferTypars,CanGeneralizeConstrainedTypars,inlineFlag,None,allDeclaredTypars,freeInType,ty,false) let valscheme1 = PrelimValScheme1(id,flex,ty,Some(partialValReprInfo),memberInfoOpt,mutableFlag,inlineFlag,NormalVal,noArgOrRetAttribs,vis,false) @@ -13584,6 +13592,7 @@ module MutRecBindingChecking = let TcMutRecDefns_Phase2_Bindings cenv envInitial tpenv bindsm scopem mutRecNSInfo (envMutRecPrelimWithReprs: TcEnv) (mutRecDefns: MutRecDefnsPhase2Info) = let g = cenv.g let denv = envMutRecPrelimWithReprs.DisplayEnv + let nenv = envMutRecPrelimWithReprs.NameEnv // Phase2A: create member prelimRecValues for "recursive" items, i.e. ctor val and member vals // Phase2A: also processes their arg patterns - collecting type assertions @@ -13692,7 +13701,7 @@ module MutRecBindingChecking = for tp in unsolvedTyparsForRecursiveBlockInvolvingGeneralizedVariables do //printfn "solving unsolvedTyparsInvolvingGeneralizedVariable : %s #%d" tp.DisplayName tp.Stamp if (tp.Rigidity <> TyparRigidity.Rigid) && not tp.IsSolved then - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv nenv tp // Now that we know what we've generalized we can adjust the recursive references let defnsCs = TcMutRecBindings_Phase2C_FixupRecursiveReferences cenv (denv, defnsBs, generalizedTyparsForRecursiveBlock, generalizedRecBinds, scopem) @@ -16885,11 +16894,11 @@ let rec IterTyconsOfModuleOrNamespaceType f (mty:ModuleOrNamespaceType) = // Defaults get applied before the module signature is checked and before the implementation conditions on virtuals/overrides. // Defaults get applied in priority order. Defaults listed last get priority 0 (lowest), 2nd last priority 1 etc. -let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs = +let ApplyDefaults cenv g denvAtEnd nenvAtEnd m mexpr extraAttribs = try let unsolved = Microsoft.FSharp.Compiler.FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd (mexpr,extraAttribs) - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denvAtEnd,m) unsolved + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denvAtEnd,nenvAtEnd,m) unsolved let applyDefaults priority = unsolved |> List.iter (fun tp -> @@ -16901,9 +16910,9 @@ let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs = | TyparConstraint.DefaultsTo(priority2,ty2,m) when priority2 = priority -> let ty1 = mkTyparTy tp if not tp.IsSolved && not (typeEquiv cenv.g ty1 ty2) then - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denvAtEnd + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denvAtEnd nenvAtEnd TryD (fun () -> ConstraintSolver.SolveTyparEqualsTyp csenv 0 m NoTrace ty1 ty2) - (fun e -> solveTypAsError cenv denvAtEnd m ty1 + (fun e -> solveTypAsError cenv denvAtEnd nenvAtEnd m ty1 ErrorD(ErrorFromApplyingDefault(g,denvAtEnd,tp,ty2,e,m))) |> RaiseOperationResult | _ -> ())) @@ -16915,7 +16924,7 @@ let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs = unsolved |> List.iter (fun tp -> if not tp.IsSolved then if (tp.StaticReq <> NoStaticReq) then - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp) + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd nenvAtEnd tp) with e -> errorRecovery e m let CheckValueRestriction denvAtEnd rootSigOpt implFileTypePriorToSig m = @@ -16938,12 +16947,12 @@ let CheckValueRestriction denvAtEnd rootSigOpt implFileTypePriorToSig m = try check implFileTypePriorToSig with e -> errorRecovery e m -let SolveInternalUnknowns g cenv denvAtEnd mexpr extraAttribs = +let SolveInternalUnknowns g cenv denvAtEnd nenv mexpr extraAttribs = let unsolved = Microsoft.FSharp.Compiler.FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd (mexpr,extraAttribs) unsolved |> List.iter (fun tp -> if (tp.Rigidity <> TyparRigidity.Rigid) && not tp.IsSolved then - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp) + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd nenv tp) let CheckModuleSignature g cenv m denvAtEnd rootSigOpt implFileTypePriorToSig implFileSpecPriorToSig mexpr = match rootSigOpt with @@ -16989,7 +16998,6 @@ let TypeCheckOneImplFile env (rootSigOpt : ModuleOrNamespaceType option) (ParsedImplFileInput(_,isScript,qualNameOfFile,scopedPragmas,_,implFileFrags,isLastCompiland)) = - eventually { let cenv = cenv.Create (g, isScript, niceNameGen, amap, topCcu, false, Option.isSome rootSigOpt, conditionalDefines, tcSink, (LightweightTcValForUsingInBuildMethodCall g)) @@ -17009,6 +17017,7 @@ let TypeCheckOneImplFile netModuleAttrs = List.map snd netModuleAttrs assemblyAttrs = List.map snd assemblyAttrs} let denvAtEnd = envAtEnd.DisplayEnv + let nenvAtEnd = envAtEnd.NameEnv let m = qualNameOfFile.Range // This is a fake module spec @@ -17017,7 +17026,7 @@ let TypeCheckOneImplFile let extraAttribs = topAttrs.mainMethodAttrs@topAttrs.netModuleAttrs@topAttrs.assemblyAttrs conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs) + ApplyDefaults cenv g denvAtEnd nenvAtEnd m mexpr extraAttribs) // Check completion of all classes defined across this file. // NOTE: this is not a great technique if inner signatures are permitted to hide @@ -17032,7 +17041,7 @@ let TypeCheckOneImplFile // Solve unsolved internal type variables conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - SolveInternalUnknowns g cenv denvAtEnd mexpr extraAttribs) + SolveInternalUnknowns g cenv denvAtEnd nenvAtEnd mexpr extraAttribs) // Check the module matches the signature let implFileExprAfterSig = From f977d3fc05e859702ed0826de48e57c8f27672ee Mon Sep 17 00:00:00 2001 From: Toby Shaw Date: Fri, 18 Aug 2017 22:15:42 +0100 Subject: [PATCH 02/40] add testfile --- testfiles/test.fs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) create mode 100644 testfiles/test.fs diff --git a/testfiles/test.fs b/testfiles/test.fs new file mode 100644 index 00000000000..ed56f1023b2 --- /dev/null +++ b/testfiles/test.fs @@ -0,0 +1,16 @@ +type System.Int32 with + static member Add(a : System.Int32, b : System.Int32) = a + b + +type MyType = + | MyType of int + static member Add(MyType x, MyType y) = MyType (x + y) + +let inline addGeneric< ^A when ^A : (static member Add : ^A * ^A -> ^A) > (a,b) : ^A = + (^A : (static member Add : ^A * ^A -> ^A) (a,b)) + +let inline (+++) a b = addGeneric(a,b) + +[] +let main args = + MyType(1) +++ MyType(2) |> ignore + 1 +++ 1 \ No newline at end of file From 898d97b610c65d0c787236c63fbf62c18b8ba10b Mon Sep 17 00:00:00 2001 From: labuser Date: Thu, 14 Sep 2017 16:21:17 +0100 Subject: [PATCH 03/40] First draft, messy solution --- src/fsharp/CompileOptions.fs | 13 ++-- src/fsharp/CompileOptions.fsi | 4 +- src/fsharp/ConstraintSolver.fs | 102 ++++++++++++++++-------------- src/fsharp/ConstraintSolver.fsi | 2 +- src/fsharp/IlxGen.fs | 8 ++- src/fsharp/IlxGen.fsi | 2 +- src/fsharp/NicePrint.fs | 6 +- src/fsharp/Optimizer.fs | 6 +- src/fsharp/Optimizer.fsi | 2 +- src/fsharp/PostInferenceChecks.fs | 4 +- src/fsharp/TastOps.fs | 15 +++-- src/fsharp/TastOps.fsi | 1 + src/fsharp/TastPickle.fs | 4 +- src/fsharp/TypeRelations.fs | 2 +- src/fsharp/fsc.fs | 24 +++---- src/fsharp/fsi/fsi.fs | 5 +- src/fsharp/infos.fs | 4 +- src/fsharp/symbols/Symbols.fs | 2 +- src/fsharp/tast.fs | 2 +- 19 files changed, 112 insertions(+), 96 deletions(-) diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index 753a85e3e43..1489a943ffe 100644 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -1229,7 +1229,7 @@ let GetInitialOptimizationEnv (tcImports:TcImports, tcGlobals:TcGlobals) = let optEnv = List.fold (AddExternalCcuToOpimizationEnv tcGlobals) optEnv ccuinfos optEnv -let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importMap, isIncrementalFragment, optEnv, ccu:CcuThunk, implFiles) = +let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importMap, isIncrementalFragment, optEnv, ccu:CcuThunk, implFiles, nenv) = // NOTE: optEnv - threads through // // Always optimize once - the results of this step give the x-module optimization @@ -1248,13 +1248,12 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let optSettings = tcConfig.optSettings let optSettings = { optSettings with abstractBigTargets = tcConfig.doTLR } let optSettings = { optSettings with reportingPhase = true } - let results,(optEnvFirstLoop,_,_,_) = ((optEnv0,optEnv0,optEnv0,SignatureHidingInfo.Empty),implFiles) ||> List.mapFold (fun (optEnvFirstLoop,optEnvExtraLoop,optEnvFinalSimplify,hidden) implFile -> //ReportTime tcConfig ("Initial simplify") let (optEnvFirstLoop,implFile,implFileOptData,hidden), optimizeDuringCodeGen = - Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal,importMap,optEnvFirstLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile) + Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal,importMap,optEnvFirstLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile,nenv) let implFile = AutoBox.TransformImplFile tcGlobals importMap implFile @@ -1267,7 +1266,7 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let implFile,optEnvExtraLoop = if tcConfig.extraOptimizationIterations > 0 then //ReportTime tcConfig ("Extra simplification loop") - let (optEnvExtraLoop,implFile, _, _), _ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvExtraLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile) + let (optEnvExtraLoop,implFile, _, _), _ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvExtraLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile,nenv) //PrintWholeAssemblyImplementation tcConfig outfile (sprintf "extra-loop-%d" n) implFile implFile,optEnvExtraLoop else @@ -1292,7 +1291,7 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let implFile,optEnvFinalSimplify = if tcConfig.doFinalSimplify then //ReportTime tcConfig ("Final simplify pass") - let (optEnvFinalSimplify,implFile, _, _),_ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFinalSimplify,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile) + let (optEnvFinalSimplify,implFile, _, _),_ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFinalSimplify,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile,nenv) //PrintWholeAssemblyImplementation tcConfig outfile "post-rec-opt" implFile implFile,optEnvFinalSimplify else @@ -1319,7 +1318,7 @@ let CreateIlxAssemblyGenerator (_tcConfig:TcConfig,tcImports:TcImports,tcGlobals ilxGenerator.AddExternalCcus ccus ilxGenerator -let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcConfig:TcConfig, topAttrs, optimizedImpls, fragName, ilxGenerator : IlxAssemblyGenerator) = +let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcConfig:TcConfig, topAttrs, optimizedImpls, fragName, ilxGenerator : IlxAssemblyGenerator, nenv) = if !progress then dprintf "Generating ILX code...\n" let ilxGenOpts : IlxGenOptions = { generateFilterBlocks = tcConfig.generateFilterBlocks @@ -1335,7 +1334,7 @@ let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcCon isInteractiveItExpr = isInteractiveItExpr alwaysCallVirt = tcConfig.alwaysCallVirt } - ilxGenerator.GenerateCode (ilxGenOpts, optimizedImpls, topAttrs.assemblyAttrs,topAttrs.netModuleAttrs) + ilxGenerator.GenerateCode (ilxGenOpts, optimizedImpls, topAttrs.assemblyAttrs,topAttrs.netModuleAttrs,nenv) //---------------------------------------------------------------------------- // Assembly ref normalization: make sure all assemblies are referred to diff --git a/src/fsharp/CompileOptions.fsi b/src/fsharp/CompileOptions.fsi index bfd374a38e6..0abe5341b1e 100644 --- a/src/fsharp/CompileOptions.fsi +++ b/src/fsharp/CompileOptions.fsi @@ -80,11 +80,11 @@ val GetGeneratedILModuleName : CompilerTarget -> string -> string val GetInitialOptimizationEnv : TcImports * TcGlobals -> IncrementalOptimizationEnv val AddExternalCcuToOpimizationEnv : TcGlobals -> IncrementalOptimizationEnv -> ImportedAssembly -> IncrementalOptimizationEnv -val ApplyAllOptimizations : TcConfig * TcGlobals * ConstraintSolver.TcValF * string * ImportMap * bool * IncrementalOptimizationEnv * CcuThunk * TypedImplFile list -> TypedAssemblyAfterOptimization * Optimizer.LazyModuleInfo * IncrementalOptimizationEnv +val ApplyAllOptimizations : TcConfig * TcGlobals * ConstraintSolver.TcValF * string * ImportMap * bool * IncrementalOptimizationEnv * CcuThunk * TypedImplFile list * NameResolution.NameResolutionEnv -> TypedAssemblyAfterOptimization * Optimizer.LazyModuleInfo * IncrementalOptimizationEnv val CreateIlxAssemblyGenerator : TcConfig * TcImports * TcGlobals * ConstraintSolver.TcValF * CcuThunk -> IlxGen.IlxAssemblyGenerator -val GenerateIlxCode : IlxGen.IlxGenBackend * isInteractiveItExpr:bool * isInteractiveOnMono:bool * TcConfig * TypeChecker.TopAttribs * TypedAssemblyAfterOptimization * fragName:string * IlxGen.IlxAssemblyGenerator -> IlxGen.IlxGenResults +val GenerateIlxCode : IlxGen.IlxGenBackend * isInteractiveItExpr:bool * isInteractiveOnMono:bool * TcConfig * TypeChecker.TopAttribs * TypedAssemblyAfterOptimization * fragName:string * IlxGen.IlxAssemblyGenerator * NameResolution.NameResolutionEnv -> IlxGen.IlxGenResults // Used during static linking val NormalizeAssemblyRefs : CompilationThreadToken * TcImports -> (AbstractIL.IL.ILScopeRef -> AbstractIL.IL.ILScopeRef) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index b26d3244115..b629b03b475 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -752,8 +752,8 @@ and solveTypMeetsTyparConstraints (csenv:ConstraintSolverEnv) ndeep m2 trace ty | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypRequiresDefaultConstructor csenv ndeep m2 trace ty | TyparConstraint.SimpleChoice(tys,m2) -> SolveTypChoice csenv ndeep m2 trace ty tys | TyparConstraint.CoercesTo(ty2,m2) -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m2 trace None ty2 ty - | TyparConstraint.MayResolveMember(traitInfo,m2) -> - SolveMemberConstraint csenv false false ndeep m2 trace traitInfo ++ (fun _ -> CompleteD) + | TyparConstraint.MayResolveMember(traitInfo,m2,extTys) -> + SolveMemberConstraint csenv false false ndeep m2 trace traitInfo extTys ++ (fun _ -> CompleteD) ))) @@ -945,7 +945,7 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty /// We pretend int and other types support a number of operators. In the actual IL for mscorlib they /// don't, however the type-directed static optimization rules in the library code that makes use of this /// will deal with the problem. -and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace (TTrait(tys,nm,memFlags,argtys,rty,sln)) : OperationResult = +and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace (TTrait(tys,nm,memFlags,argtys,rty,sln)) exts : OperationResult = // Do not re-solve if already solved if sln.Value.IsSome then ResultD true else let g = csenv.g @@ -974,8 +974,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p tys |> IterateD (SolveTypStaticReq csenv trace HeadTypeStaticReq)) ++ (fun () -> let argtys = if memFlags.IsInstance then List.tail argtys else argtys - - let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo + let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo exts match minfos,tys,memFlags.IsInstance,nm,argtys with | _,_,false,("op_Division" | "op_Multiply"),[argty1;argty2] @@ -1284,7 +1283,6 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p | None, Some (calledMeth:CalledMeth<_>) -> // OK, the constraint is solved. let minfo = calledMeth.Method - errors ++ (fun () -> let isInstance = minfo.IsInstance if isInstance <> memFlags.IsInstance then @@ -1303,7 +1301,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // If there's nothing left to learn then raise the errors (if (permitWeakResolution && isNil support) || isNil frees then errors // Otherwise re-record the trait waiting for canonicalization - else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees) ++ (fun () -> + else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees exts) ++ (fun () -> match errors with | ErrorResult (_,UnresolvedOverloading _) when not ignoreUnresolvedOverload && (not (nm = "op_Explicit" || nm = "op_Implicit")) -> ErrorD LocallyAbortOperationThatFailsToResolveOverload | _ -> ResultD TTraitUnsolved) @@ -1384,7 +1382,15 @@ and TransactMemberConstraintSolution traitInfo (trace:OptionalTrace) sln = /// Only consider overload resolution if canonicalizing or all the types are now nominal. /// That is, don't perform resolution if more nominal information may influence the set of available overloads -and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys,_,memFlags,argtys,rty,soln) as traitInfo) : MethInfo list = +and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys,_,memFlags,argtys,rty,soln) as traitInfo) exts : MethInfo list = + let rec eqTyps typ1 typ2 = + let g = csenv.g + match stripTyEqns g typ1, stripTyEqns g typ2 with + | TType_app(tcref1,pars1),TType_app(tcref2,pars2) -> + tyconRefEq g tcref1 tcref2 + && pars1.Length = pars2.Length + && List.forall2 eqTyps pars1 pars2 + | _ -> false let results = if permitWeakResolution || isNil (GetSupportOfMemberConstraint csenv traitInfo) then let m = csenv.m @@ -1393,30 +1399,10 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution | MemberKind.Constructor -> tys |> List.map (GetIntrinsicConstructorInfosOfType csenv.SolverState.InfoReader m) | _ -> - let extMemberToMethInfo (_ : TType) extnMember = - match extnMember with - | FSExtMem (valRef, priority) -> - if valRef.LogicalName = nm then - Some <| FSMeth(csenv.g, valRef.Type, valRef, Some priority) - else - None - | ILExtMem(_, methInfo, _) -> - if methInfo.LogicalName = nm then - Some <| methInfo - else - None - let getExtMInfos (t : TType) : MethInfo list = - if nm = "TestMethod" then - List.iter (printfn "%A") csenv.NameResolutionEnv.eTyconsByAccessNames.Values - csenv.NameResolutionEnv.eIndexedExtensionMembers.Contents.Contents.Values - |> List.concat - |> List.choose (extMemberToMethInfo t) + let getRelevantMethods t = - let x = getExtMInfos t - let y = GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm,AccessibleFromSomeFSharpCode,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m t + GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm,AccessibleFromSomeFSharpCode,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m t - printfn "t : %A , x : %A, y : %A" t x y - y tys |> List.map getRelevantMethods /// Merge the sets so we don't get the same minfo from each side /// We merge based on whether minfos use identical metadata or not. @@ -1426,13 +1412,18 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution /// to a generic instantiation for an operator based on the right hand type. let minfos = List.reduce (ListSet.unionFavourLeft MethInfo.MethInfosUseIdenticalDefinitions) minfos - minfos + let extMemberToMethInfo t (valRef : ValRef) = + FSMeth(csenv.g, t, valRef, Some 1uL) // TODO + let extMInfos : MethInfo list = + let allCombos = List.allPairs tys exts + List.map (fun (a,b) -> extMemberToMethInfo a b) allCombos + minfos @ extMInfos else [] // The trait name "op_Explicit" also covers "op_Implicit", so look for that one too. if nm = "op_Explicit" then - results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys,"op_Implicit",memFlags,argtys,rty,soln)) + results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys,"op_Implicit",memFlags,argtys,rty,soln)) exts else results @@ -1468,17 +1459,19 @@ and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep per 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))) - assert (isNil (cxst.FindAll tpn)) + 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 trace traitInfo []) and CanonicalizeRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep trace tps = SolveRelevantMemberConstraints csenv ndeep true trace tps -and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo support frees = +and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo support frees extTys = let g = csenv.g let aenv = csenv.EquivEnv let cxst = csenv.SolverState.ExtraCxs @@ -1499,7 +1492,7 @@ and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo sup // 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. - support |> IterateD (fun tp -> AddConstraint csenv ndeep m2 trace tp (TyparConstraint.MayResolveMember(traitInfo,m2))) + support |> IterateD (fun tp -> AddConstraint csenv ndeep m2 trace tp (TyparConstraint.MayResolveMember(traitInfo,m2,extTys))) /// Record a constraint on an inference type variable. @@ -1517,8 +1510,8 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint = // may require type annotations. See FSharp 1.0 bug 6477. let consistent tpc1 tpc2 = match tpc1,tpc2 with - | (TyparConstraint.MayResolveMember(TTrait(tys1,nm1,memFlags1,argtys1,rty1,_),_), - TyparConstraint.MayResolveMember(TTrait(tys2,nm2,memFlags2,argtys2,rty2,_),_)) + | (TyparConstraint.MayResolveMember(TTrait(tys1,nm1,memFlags1,argtys1,rty1,_),_,_), + TyparConstraint.MayResolveMember(TTrait(tys2,nm2,memFlags2,argtys2,rty2,_),_,_)) when (memFlags1 = memFlags2 && nm1 = nm2 && // Multiple op_Explicit and op_Implicit constraints can exist for the same type variable. @@ -1584,8 +1577,8 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint = // T2 = ty2 let implies tpc1 tpc2 = match tpc1,tpc2 with - | TyparConstraint.MayResolveMember(trait1,_), - TyparConstraint.MayResolveMember(trait2,_) -> + | TyparConstraint.MayResolveMember(trait1,_,_), + TyparConstraint.MayResolveMember(trait2,_,_) -> traitsAEquiv g aenv trait1 trait2 | TyparConstraint.CoercesTo(ty1,_), TyparConstraint.CoercesTo(ty2,_) -> @@ -2569,8 +2562,17 @@ let AddCxTypeMustSubsumeType contextInfo denv nenv css m trace ty1 ty2 = SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv contextInfo css m denv nenv) 0 m trace None ty1 ty2 |> RaiseOperationResult -let AddCxMethodConstraint denv nenv css m trace traitInfo = - TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) true false 0 m trace traitInfo ++ (fun _ -> CompleteD)) +let AddCxMethodConstraint denv nenv css m trace (traitInfo : TraitConstraintInfo) = + let extTys : ValRef list = + let extMemberToValRef = function + | FSExtMem (v,_) -> v + | ILExtMem (_,_,_) -> failwith "" + nenv.eIndexedExtensionMembers.Contents.Contents.Values + |> fun x -> x + |> List.concat + |> List.map extMemberToValRef + |> List.filter (fun v -> v.LogicalName = traitInfo.MemberName) + TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) true false 0 m trace traitInfo extTys ++ (fun _ -> CompleteD)) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult @@ -2619,16 +2621,24 @@ let AddCxTypeIsDelegate denv nenv css m trace ty aty bty = (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:TraitConstraintInfo) argExprs = +let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:TraitConstraintInfo) argExprs nenv = let css = { g = g amap = amap TcVal = tcVal ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = new InfoReader(g,amap) } - - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) (NameResolutionEnv.Empty g) - SolveMemberConstraint csenv true true 0 m NoTrace traitInfo ++ (fun _res -> + let extTys : ValRef list = + let extMemberToValRef = function + | FSExtMem (v,_) -> v + | ILExtMem (_,_,_) -> failwith "" + nenv.eIndexedExtensionMembers.Contents.Contents.Values + |> fun x -> x + |> List.concat + |> List.map extMemberToValRef + |> List.filter (fun v -> v.LogicalName = traitInfo.MemberName) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) nenv + SolveMemberConstraint csenv true true 0 m NoTrace traitInfo extTys ++ (fun _res -> let sln = match traitInfo.Solution with | None -> Choice4Of4() diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 5715cdc786e..3eecf01ea8a 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -143,7 +143,7 @@ val AddCxTypeIsUnmanaged : DisplayEnv -> NameResolutionEnv val AddCxTypeIsEnum : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit val AddCxTypeIsDelegate : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit -val CodegenWitnessThatTypSupportsTraitConstraint : TcValF -> TcGlobals -> ImportMap -> range -> TraitConstraintInfo -> Expr list -> OperationResult +val CodegenWitnessThatTypSupportsTraitConstraint : TcValF -> TcGlobals -> ImportMap -> range -> TraitConstraintInfo -> Expr list -> NameResolutionEnv -> OperationResult val ChooseTyparSolutionAndSolve : ConstraintSolverState -> DisplayEnv -> NameResolutionEnv -> Typar -> unit diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 64fcbf478a1..8285e3b3932 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -186,7 +186,8 @@ type cenv = amap: ImportMap intraAssemblyInfo : IlxGenIntraAssemblyInfo /// Cache methods with SecurityAttribute applied to them, to prevent unnecessary calls to ExistsInEntireHierarchyOfType - casApplied : Dictionary + casApplied : Dictionary + nenv : NameResolution.NameResolutionEnv /// Used to apply forced inlining optimizations to witnesses generated late during codegen mutable optimizeDuringCodeGen : (Expr -> Expr) } @@ -3278,7 +3279,7 @@ and CommitCallSequel cenv eenv m cloc cgbuf mustGenerateUnitAfterCall sequel = and GenTraitCall cenv cgbuf eenv (traitInfo, argExprs, m) expr sequel = - let minfoOpt = CommitOperationResult (ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo argExprs) + let minfoOpt = CommitOperationResult (ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo argExprs cenv.nenv) match minfoOpt with | None -> let replacementExpr = @@ -7044,7 +7045,7 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal : Constra ilxGenEnv <- AddIncrementalLocalAssemblyFragmentToIlxGenEnv (amap, isIncrementalFragment, tcGlobals, ccu, fragName, intraAssemblyInfo, ilxGenEnv, typedImplFiles) /// Generate ILX code for an assembly fragment - member __.GenerateCode (codeGenOpts, typedAssembly, assemAttribs, moduleAttribs) = + member __.GenerateCode (codeGenOpts, typedAssembly, assemAttribs, moduleAttribs, nenv) = let cenv : cenv = { g=tcGlobals TcVal = tcVal @@ -7054,6 +7055,7 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal : Constra casApplied = casApplied intraAssemblyInfo = intraAssemblyInfo opts = codeGenOpts + nenv = nenv optimizeDuringCodeGen = (fun x -> x) } GenerateCode (cenv, ilxGenEnv, typedAssembly, assemAttribs, moduleAttribs) diff --git a/src/fsharp/IlxGen.fsi b/src/fsharp/IlxGen.fsi index 94cccee587f..1614209f60b 100644 --- a/src/fsharp/IlxGen.fsi +++ b/src/fsharp/IlxGen.fsi @@ -69,7 +69,7 @@ type public IlxAssemblyGenerator = member AddIncrementalLocalAssemblyFragment : isIncrementalFragment: bool * fragName:string * typedImplFiles: TypedImplFile list -> unit /// Generate ILX code for an assembly fragment - member GenerateCode : IlxGenOptions * TypedAssemblyAfterOptimization * Attribs * Attribs -> IlxGenResults + member GenerateCode : IlxGenOptions * TypedAssemblyAfterOptimization * Attribs * Attribs * NameResolution.NameResolutionEnv -> IlxGenResults /// Create the CAS permission sets for an assembly fragment member CreatePermissionSets : Attrib list -> ILPermission list diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 4095ab0195c..075386f528c 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -789,8 +789,8 @@ module private PrintTypes = cxs |> ListSet.setify (fun (_,cx1) (_,cx2) -> match cx1,cx2 with - | TyparConstraint.MayResolveMember(traitInfo1,_), - TyparConstraint.MayResolveMember(traitInfo2,_) -> traitsAEquiv denv.g TypeEquivEnv.Empty traitInfo1 traitInfo2 + | TyparConstraint.MayResolveMember(traitInfo1,_,_), + TyparConstraint.MayResolveMember(traitInfo2,_,_) -> traitsAEquiv denv.g TypeEquivEnv.Empty traitInfo1 traitInfo2 | _ -> false) let cxsL = List.collect (layoutConstraintWithInfo denv env) cxs @@ -810,7 +810,7 @@ module private PrintTypes = match tpc with | TyparConstraint.CoercesTo(tpct,_) -> [layoutTyparRefWithInfo denv env tp ^^ wordL (tagOperator ":>") --- layoutTypeWithInfo denv env tpct] - | TyparConstraint.MayResolveMember(traitInfo,_) -> + | TyparConstraint.MayResolveMember(traitInfo,_,_) -> [layoutTraitWithInfo denv env traitInfo] | TyparConstraint.DefaultsTo(_,ty,_) -> if denv.showTyparDefaultConstraints then [wordL (tagKeyword "default") ^^ layoutTyparRefWithInfo denv env tp ^^ WordL.colon ^^ layoutTypeWithInfo denv env ty] diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index cf1871bb9bb..0ddbbb3c886 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -321,6 +321,7 @@ type cenv = localInternalVals: System.Collections.Generic.Dictionary settings: OptimizationSettings emitTailcalls: bool + nenv : NameResolution.NameResolutionEnv // cache methods with SecurityAttribute applied to them, to prevent unnecessary calls to ExistsInEntireHierarchyOfType casApplied : Dictionary} @@ -2167,7 +2168,7 @@ and OptimizeWhileLoop cenv env (spWhile,marker,e1,e2,m) = and OptimizeTraitCall cenv env (traitInfo, args, m) = // Resolve the static overloading early (during the compulsory rewrite phase) so we can inline. - match ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo args with + match ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo args cenv.nenv with | OkResult (_,Some expr) -> OptimizeExpr cenv env expr @@ -3180,7 +3181,7 @@ and OptimizeImplFileInternal cenv env isIncrementalFragment hidden (TImplFile(qn // Entry point //------------------------------------------------------------------------- -let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementalFragment,emitTailcalls,hidden,mimpls) = +let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementalFragment,emitTailcalls,hidden,mimpls,nenv) = let cenv = { settings=settings scope=ccu @@ -3190,6 +3191,7 @@ let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementa optimizing=true localInternalVals=Dictionary(10000) emitTailcalls=emitTailcalls + nenv=nenv casApplied=new Dictionary() } let (optEnvNew,_,_,_ as results) = OptimizeImplFileInternal cenv optEnv isIncrementalFragment hidden mimpls let optimizeDuringCodeGen expr = OptimizeExpr cenv optEnvNew expr |> fst diff --git a/src/fsharp/Optimizer.fsi b/src/fsharp/Optimizer.fsi index d1f773904e0..f78c0757957 100644 --- a/src/fsharp/Optimizer.fsi +++ b/src/fsharp/Optimizer.fsi @@ -42,7 +42,7 @@ type IncrementalOptimizationEnv = val internal BindCcu : CcuThunk -> CcuOptimizationInfo -> IncrementalOptimizationEnv -> TcGlobals -> IncrementalOptimizationEnv /// Optimize one implementation file in the given environment -val internal OptimizeImplFile : OptimizationSettings * CcuThunk * TcGlobals * ConstraintSolver.TcValF * Import.ImportMap * IncrementalOptimizationEnv * isIncrementalFragment: bool * emitTaicalls: bool * SignatureHidingInfo * TypedImplFile -> (IncrementalOptimizationEnv * TypedImplFile * ImplFileOptimizationInfo * SignatureHidingInfo) * (Expr -> Expr) +val internal OptimizeImplFile : OptimizationSettings * CcuThunk * TcGlobals * ConstraintSolver.TcValF * Import.ImportMap * IncrementalOptimizationEnv * isIncrementalFragment: bool * emitTaicalls: bool * SignatureHidingInfo * TypedImplFile * NameResolution.NameResolutionEnv -> (IncrementalOptimizationEnv * TypedImplFile * ImplFileOptimizationInfo * SignatureHidingInfo) * (Expr -> Expr) #if DEBUG /// Displaying optimization data diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 58e0aa26736..3dbc1972e63 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -213,7 +213,7 @@ let rec CheckTypeDeep ((visitTyp,visitTyconRefOpt,visitAppTyOpt,visitTraitSoluti | TType_var tp when tp.Solution.IsSome -> tp.Constraints |> List.iter (fun cx -> match cx with - | TyparConstraint.MayResolveMember((TTrait(_,_,_,_,_,soln)),_) -> + | TyparConstraint.MayResolveMember((TTrait(_,_,_,_,_,soln)),_,_) -> match visitTraitSolutionOpt, !soln with | Some visitTraitSolution, Some sln -> visitTraitSolution sln | _ -> () @@ -254,7 +254,7 @@ and CheckTypesDeep f g env tys = List.iter (CheckTypeDeep f g env) tys and CheckTypeConstraintDeep f g env x = match x with | TyparConstraint.CoercesTo(ty,_) -> CheckTypeDeep f g env ty - | TyparConstraint.MayResolveMember(traitInfo,_) -> CheckTraitInfoDeep f g env traitInfo + | TyparConstraint.MayResolveMember(traitInfo,_,_) -> CheckTraitInfoDeep f g env traitInfo | TyparConstraint.DefaultsTo(_,ty,_) -> CheckTypeDeep f g env ty | TyparConstraint.SimpleChoice(tys,_) -> CheckTypesDeep f g env tys | TyparConstraint.IsEnum(uty,_) -> CheckTypeDeep f g env uty diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 6d864bdc187..3fe9c6e4491 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -228,8 +228,8 @@ and remapTyparConstraintsAux tyenv cs = match x with | TyparConstraint.CoercesTo(ty,m) -> Some(TyparConstraint.CoercesTo (remapTypeAux tyenv ty,m)) - | TyparConstraint.MayResolveMember(traitInfo,m) -> - Some(TyparConstraint.MayResolveMember (remapTraitAux tyenv traitInfo,m)) + | TyparConstraint.MayResolveMember(traitInfo,m,extTys) -> + Some(TyparConstraint.MayResolveMember (remapTraitAux tyenv traitInfo,m,List.map (remapValRef tyenv) extTys)) | TyparConstraint.DefaultsTo(priority,ty,m) -> Some(TyparConstraint.DefaultsTo(priority,remapTypeAux tyenv ty,m)) | TyparConstraint.IsEnum(uty,m) -> Some(TyparConstraint.IsEnum(remapTypeAux tyenv uty,m)) @@ -370,6 +370,7 @@ let mkInstRemap tpinst = let instType tpinst x = if isNil tpinst then x else remapTypeAux (mkInstRemap tpinst) x let instTypes tpinst x = if isNil tpinst then x else remapTypesAux (mkInstRemap tpinst) x let instTrait tpinst x = if isNil tpinst then x else remapTraitAux (mkInstRemap tpinst) x +let instValRef tpinst x = if isNil tpinst then x else remapValRef (mkInstRemap tpinst) x let instTyparConstraints tpinst x = if isNil tpinst then x else remapTyparConstraintsAux (mkInstRemap tpinst) x let instSlotSig tpinst ss = remapSlotSig (fun _ -> []) (mkInstRemap tpinst) ss let copySlotSig ss = remapSlotSig (fun _ -> []) Remap.Empty ss @@ -822,8 +823,8 @@ and typarConstraintsAEquivAux erasureFlag g aenv tpc1 tpc2 = TyparConstraint.CoercesTo(fcty,_) -> typeAEquivAux erasureFlag g aenv acty fcty - | TyparConstraint.MayResolveMember(trait1,_), - TyparConstraint.MayResolveMember(trait2,_) -> + | TyparConstraint.MayResolveMember(trait1,_,_), + TyparConstraint.MayResolveMember(trait2,_,_) -> traitsAEquivAux erasureFlag g aenv trait1 trait2 | TyparConstraint.DefaultsTo(_,acty,_), @@ -1888,7 +1889,7 @@ and accFreeInTyparConstraints opts cxs acc = and accFreeInTyparConstraint opts tpc acc = match tpc with | TyparConstraint.CoercesTo(typ,_) -> accFreeInType opts typ acc - | TyparConstraint.MayResolveMember (traitInfo,_) -> accFreeInTrait opts traitInfo acc + | TyparConstraint.MayResolveMember (traitInfo,_,_) -> accFreeInTrait opts traitInfo acc | TyparConstraint.DefaultsTo(_,rty,_) -> accFreeInType opts rty acc | TyparConstraint.SimpleChoice(tys,_) -> accFreeInTypes opts tys acc | TyparConstraint.IsEnum(uty,_) -> accFreeInType opts uty acc @@ -1993,7 +1994,7 @@ and accFreeInTyparConstraintsLeftToRight g cxFlag thruFlag acc cxs = and accFreeInTyparConstraintLeftToRight g cxFlag thruFlag acc tpc = match tpc with | TyparConstraint.CoercesTo(typ,_) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc typ - | TyparConstraint.MayResolveMember (traitInfo,_) -> accFreeInTraitLeftToRight g cxFlag thruFlag acc traitInfo + | TyparConstraint.MayResolveMember (traitInfo,_,_) -> accFreeInTraitLeftToRight g cxFlag thruFlag acc traitInfo | TyparConstraint.DefaultsTo(_,rty,_) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc rty | TyparConstraint.SimpleChoice(tys,_) -> accFreeInTypesLeftToRight g cxFlag thruFlag acc tys | TyparConstraint.IsEnum(uty,_) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc uty @@ -3151,7 +3152,7 @@ module DebugPrint = begin match tpc with | TyparConstraint.CoercesTo(typarConstrTyp,_) -> auxTypar2L env tp ^^ wordL (tagText ":>") --- auxTyparConstraintTypL env typarConstrTyp - | TyparConstraint.MayResolveMember(traitInfo,_) -> + | TyparConstraint.MayResolveMember(traitInfo,_,_) -> auxTypar2L env tp ^^ wordL (tagText ":") --- auxTraitL env traitInfo | TyparConstraint.DefaultsTo(_,ty,_) -> wordL (tagText "default") ^^ auxTypar2L env tp ^^ wordL (tagText ":") ^^ auxTypeL env ty diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index d6c0875064c..63da1ed3782 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -358,6 +358,7 @@ val instType : TyparInst -> TType -> TType val instTypes : TyparInst -> TypeInst -> TypeInst val instTyparConstraints : TyparInst -> TyparConstraint list -> TyparConstraint list val instTrait : TyparInst -> TraitConstraintInfo -> TraitConstraintInfo +val instValRef : TyparInst -> ValRef -> ValRef //------------------------------------------------------------------------- // From typars to types diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index 336a10268a8..e406414f5f2 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -1417,7 +1417,7 @@ let rec u_measure_expr st = let p_typar_constraint x st = match x with | TyparConstraint.CoercesTo (a,_) -> p_byte 0 st; p_typ a st - | TyparConstraint.MayResolveMember(traitInfo,_) -> p_byte 1 st; p_trait traitInfo st + | TyparConstraint.MayResolveMember(traitInfo,_,_) -> p_byte 1 st; p_trait traitInfo st | TyparConstraint.DefaultsTo(_,rty,_) -> p_byte 2 st; p_typ rty st | TyparConstraint.SupportsNull _ -> p_byte 3 st | TyparConstraint.IsNonNullableStruct _ -> p_byte 4 st @@ -1435,7 +1435,7 @@ let u_typar_constraint st = let tag = u_byte st match tag with | 0 -> u_typ st |> (fun a _ -> TyparConstraint.CoercesTo (a,range0) ) - | 1 -> u_trait st |> (fun a _ -> TyparConstraint.MayResolveMember(a,range0)) + | 1 -> u_trait st |> (fun a _ -> TyparConstraint.MayResolveMember(a,range0,[])) | 2 -> u_typ st |> (fun a ridx -> TyparConstraint.DefaultsTo(ridx,a,range0)) | 3 -> (fun _ -> TyparConstraint.SupportsNull range0) | 4 -> (fun _ -> TyparConstraint.IsNonNullableStruct range0) diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index da7ccae5f9c..1aab29416d6 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -143,7 +143,7 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = match tpc with | TyparConstraint.CoercesTo(x,m) -> join m x,m - | TyparConstraint.MayResolveMember(TTrait(_,nm,_,_,_,_),m) -> + | TyparConstraint.MayResolveMember(TTrait(_,nm,_,_,_,_),m,_) -> errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInOverloadedOperator(DemangleOperatorName nm),m)) maxSoFar,m | TyparConstraint.SimpleChoice(_,m) -> diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs index 4f13c65b140..fe2ced2fac2 100644 --- a/src/fsharp/fsc.fs +++ b/src/fsharp/fsc.fs @@ -1791,15 +1791,15 @@ let main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinarie // Type check the inputs let inputs = inputs |> List.map fst - let tcState, topAttrs, typedAssembly, _tcEnvAtEnd = + let tcState, topAttrs, typedAssembly, tcEnvAtEnd = TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, inputs, exiter) AbortOnError(errorLogger, exiter) ReportTime tcConfig "Typechecked" - Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter) + Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter, tcEnvAtEnd.NameEnv) -let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter)) = +let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter, nenv)) = if tcConfig.typeCheckOnly then exiter.Exit 0 @@ -1845,7 +1845,7 @@ let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, gener end // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter) + Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter, nenv) // set up typecheck for given AST without parsing any command line parameters @@ -1895,7 +1895,7 @@ let main1OfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyNam use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck) let tcEnv0 = GetInitialTcEnv (assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals) - let tcState,topAttrs,typedAssembly,_tcEnvAtEnd = + let tcState,topAttrs,typedAssembly,tcEnvAtEnd = TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, inputs,exiter) let generatedCcu = tcState.Ccu @@ -1915,11 +1915,11 @@ let main1OfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyNam // Pass on only the minimum information required for the next phase to ensure GC kicks in. // In principle the JIT should be able to do good liveness analysis to clean things up, but the // data structures involved here are so large we can't take the risk. - Args(ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedAssembly, topAttrs, pdbFile, assemblyName, assemVerFromAttrib, signingInfo ,exiter) + Args(ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedAssembly, topAttrs, pdbFile, assemblyName, assemVerFromAttrib, signingInfo ,exiter, tcEnvAtEnd.NameEnv) /// Phase 2a: encode signature data, optimize, encode optimization data -let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, errorLogger: ErrorLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter)) = +let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, errorLogger: ErrorLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter, nenv)) = // Encode the signature data ReportTime tcConfig ("Encode Interface Data") @@ -1936,13 +1936,13 @@ let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlo use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Optimize let optEnv0 = GetInitialOptimizationEnv (tcImports, tcGlobals) - + let importMap = tcImports.GetImportMap() let metadataVersion = match tcConfig.metadataVersion with | Some v -> v | _ -> match (frameworkTcImports.DllTable.TryFind tcConfig.primaryAssembly.Name) with | Some ib -> ib.RawMetadata.TryGetRawILModule().Value.MetadataVersion | _ -> "" - let optimizedImpls, optimizationData, _ = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, generatedCcu, typedImplFiles) + let optimizedImpls, optimizationData, _ = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, generatedCcu, typedImplFiles, nenv) AbortOnError(errorLogger, exiter) @@ -1951,10 +1951,10 @@ let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlo let optDataResources = EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData), false) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, (sigDataAttributes, sigDataResources), optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter) + Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, (sigDataAttributes, sigDataResources), optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter, nenv) /// Phase 2b: IL code generation -let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, idata, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter)) = +let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, idata, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter, nenv)) = match tcImportsCapture with | None -> () @@ -1974,7 +1974,7 @@ let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcCo // Check if System.SerializableAttribute exists in mscorlib.dll, // so that make sure the compiler only emits "serializable" bit into IL metadata when it is available. // Note that SerializableAttribute may be relocated in the future but now resides in mscorlib. - let codegenResults = GenerateIlxCode ((if Option.isSome dynamicAssemblyCreator then IlReflectBackend else IlWriteBackend), Option.isSome dynamicAssemblyCreator, false, tcConfig, topAttrs, optimizedImpls, generatedCcu.AssemblyName, ilxGenerator) + let codegenResults = GenerateIlxCode ((if Option.isSome dynamicAssemblyCreator then IlReflectBackend else IlWriteBackend), Option.isSome dynamicAssemblyCreator, false, tcConfig, topAttrs, optimizedImpls, generatedCcu.AssemblyName, ilxGenerator, nenv) let casApplied = new Dictionary() let securityAttrs, topAssemblyAttrs = topAttrs.assemblyAttrs |> List.partition (fun a -> TypeChecker.IsSecurityAttribute tcGlobals (tcImports.GetImportMap()) casApplied a rangeStartup) // remove any security attributes from the top-level assembly attribute list diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs index c69038c4ae0..2ded6349837 100644 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -1015,6 +1015,7 @@ type internal FsiDynamicCompiler let optEnv = istate.optEnv let emEnv = istate.emEnv let tcState = istate.tcState + let nenv = tcState.TcEnvFromImpls.NameEnv let ilxGenerator = istate.ilxGenerator let tcConfig = TcConfig.Create(tcConfigB,validate=false) @@ -1036,11 +1037,11 @@ type internal FsiDynamicCompiler let importMap = tcImports.GetImportMap() // optimize: note we collect the incremental optimization environment - let optimizedImpls, _optData, optEnv = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, isIncrementalFragment, optEnv, tcState.Ccu, declaredImpls) + let optimizedImpls, _optData, optEnv = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, isIncrementalFragment, optEnv, tcState.Ccu, declaredImpls, nenv) errorLogger.AbortOnError(fsiConsoleOutput); let fragName = textOfLid prefixPath - let codegenResults = GenerateIlxCode (IlReflectBackend, isInteractiveItExpr, runningOnMono, tcConfig, topCustomAttrs, optimizedImpls, fragName, ilxGenerator) + let codegenResults = GenerateIlxCode (IlReflectBackend, isInteractiveItExpr, runningOnMono, tcConfig, topCustomAttrs, optimizedImpls, fragName, ilxGenerator, nenv) errorLogger.AbortOnError(fsiConsoleOutput); // Each input is like a small separately compiled extension to a single source file. diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 85d749dfe0c..95305f44ea3 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -332,8 +332,8 @@ let CopyTyparConstraints m tprefInst (tporig:Typar) = TyparConstraint.SimpleChoice (List.map (instType tprefInst) tys,m) | TyparConstraint.RequiresDefaultConstructor _ -> TyparConstraint.RequiresDefaultConstructor m - | TyparConstraint.MayResolveMember(traitInfo,_) -> - TyparConstraint.MayResolveMember (instTrait tprefInst traitInfo,m)) + | TyparConstraint.MayResolveMember(traitInfo,_,extTys) -> + TyparConstraint.MayResolveMember (instTrait tprefInst traitInfo,m,List.map (instValRef tprefInst) extTys)) /// The constraints for each typar copied from another typar can only be fixed up once /// we have generated all the new constraints, e.g. f List, B :> List> ... diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index 3e40754b00a..4e439bbb45b 100644 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -1088,7 +1088,7 @@ and FSharpGenericParameterConstraint(cenv, cx : TyparConstraint) = member __.MemberConstraintData = match cx with - | TyparConstraint.MayResolveMember(info, _) -> FSharpGenericParameterMemberConstraint(cenv, info) + | TyparConstraint.MayResolveMember(info, _,_) -> FSharpGenericParameterMemberConstraint(cenv, info) | _ -> invalidOp "not a member constraint" member __.IsNonNullableValueTypeConstraint = diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index a224fb705f3..317ce4540a6 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -2042,7 +2042,7 @@ and | SupportsNull of range /// Indicates a constraint that a type has a member with the given signature - | MayResolveMember of TraitConstraintInfo * range + | MayResolveMember of TraitConstraintInfo * range * ValRef list /// Indicates a constraint that a type is a non-Nullable value type /// These are part of .NET's model of generic constraints, and in order to From 9efe7ef37b57f7bd5dac99660e9c0c929892e9ca Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 25 Sep 2017 15:55:37 +0100 Subject: [PATCH 04/40] merge with master --- src/fsharp/ConstraintSolver.fs | 10 ---------- src/fsharp/TypeChecker.fs | 2 +- 2 files changed, 1 insertion(+), 11 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index eca06ff7f31..2c76fc6ade8 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -2723,13 +2723,8 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait let ChooseTyparSolutionAndSolve css denv nenv tp = let g = css.g let amap = css.amap -<<<<<<< HEAD - let max, m = ChooseTyparSolutionAndRange g amap tp - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv -======= let max,m = ChooseTyparSolutionAndRange g amap tp let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv ->>>>>>> 888f1cf75e729e4145ac425cfdd63133baab2a30 TryD (fun () -> SolveTyparEqualsTyp csenv 0 m NoTrace (mkTyparTy tp) max) (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult @@ -2756,13 +2751,8 @@ let IsApplicableMethApprox g amap m (minfo:MethInfo) availObjTy = amap = amap TcVal = (fun _ -> failwith "should not be called") ExtraCxs = HashMultiMap(10, HashIdentity.Structural) -<<<<<<< HEAD InfoReader = new InfoReader(g, amap) } - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) -======= - InfoReader = new InfoReader(g,amap) } let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) (NameResolutionEnv.Empty g) ->>>>>>> 888f1cf75e729e4145ac425cfdd63133baab2a30 let minst = FreshenMethInfo m minfo match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 7ea15f64085..5b28c01934b 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2251,7 +2251,7 @@ module GeneralizationHelpers = inlineFlag, exprOpt, allDeclaredTypars:Typars, - maxInferredTypars:ypars, + maxInferredTypars:Typars, tauTy, resultFirst) = From 7121bc3927129e65b9f9abff9abf87c60dac3108 Mon Sep 17 00:00:00 2001 From: dsyme Date: Mon, 25 Sep 2017 18:14:40 +0100 Subject: [PATCH 05/40] work towards freshening things correctly --- src/fsharp/CompileOptions.fs | 13 +- src/fsharp/CompileOptions.fsi | 4 +- src/fsharp/ConstraintSolver.fs | 214 ++++++++++--------- src/fsharp/ConstraintSolver.fsi | 107 +++++----- src/fsharp/IlxGen.fs | 8 +- src/fsharp/IlxGen.fsi | 2 +- src/fsharp/InfoReader.fs | 4 +- src/fsharp/NameResolution.fs | 27 ++- src/fsharp/NameResolution.fsi | 82 ++++++-- src/fsharp/NicePrint.fs | 6 +- src/fsharp/Optimizer.fs | 10 +- src/fsharp/Optimizer.fsi | 2 +- src/fsharp/PostInferenceChecks.fs | 4 +- src/fsharp/TastOps.fs | 36 ++-- src/fsharp/TastOps.fsi | 6 + src/fsharp/TastPickle.fs | 4 +- src/fsharp/TypeChecker.fs | 327 +++++++++++++++--------------- src/fsharp/TypeRelations.fs | 2 +- src/fsharp/fsc.fs | 24 +-- src/fsharp/fsi/fsi.fs | 5 +- src/fsharp/infos.fs | 21 +- src/fsharp/symbols/Symbols.fs | 2 +- src/fsharp/tast.fs | 5 +- 23 files changed, 524 insertions(+), 391 deletions(-) diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index 892914d0391..61f3b8f1672 100644 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -1229,7 +1229,7 @@ let GetInitialOptimizationEnv (tcImports:TcImports, tcGlobals:TcGlobals) = let optEnv = List.fold (AddExternalCcuToOpimizationEnv tcGlobals) optEnv ccuinfos optEnv -let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importMap, isIncrementalFragment, optEnv, ccu:CcuThunk, implFiles) = +let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importMap, isIncrementalFragment, optEnv, ccu:CcuThunk, implFiles, nenv) = // NOTE: optEnv - threads through // // Always optimize once - the results of this step give the x-module optimization @@ -1248,13 +1248,12 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let optSettings = tcConfig.optSettings let optSettings = { optSettings with abstractBigTargets = tcConfig.doTLR } let optSettings = { optSettings with reportingPhase = true } - let results,(optEnvFirstLoop,_,_,_) = ((optEnv0,optEnv0,optEnv0,SignatureHidingInfo.Empty),implFiles) ||> List.mapFold (fun (optEnvFirstLoop,optEnvExtraLoop,optEnvFinalSimplify,hidden) implFile -> //ReportTime tcConfig ("Initial simplify") let (optEnvFirstLoop,implFile,implFileOptData,hidden), optimizeDuringCodeGen = - Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal,importMap,optEnvFirstLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile) + Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal,importMap,optEnvFirstLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile,nenv) let implFile = AutoBox.TransformImplFile tcGlobals importMap implFile @@ -1267,7 +1266,7 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let implFile,optEnvExtraLoop = if tcConfig.extraOptimizationIterations > 0 then //ReportTime tcConfig ("Extra simplification loop") - let (optEnvExtraLoop,implFile, _, _), _ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvExtraLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile) + let (optEnvExtraLoop,implFile, _, _), _ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvExtraLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile,nenv) //PrintWholeAssemblyImplementation tcConfig outfile (sprintf "extra-loop-%d" n) implFile implFile,optEnvExtraLoop else @@ -1292,7 +1291,7 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let implFile,optEnvFinalSimplify = if tcConfig.doFinalSimplify then //ReportTime tcConfig ("Final simplify pass") - let (optEnvFinalSimplify,implFile, _, _),_ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFinalSimplify,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile) + let (optEnvFinalSimplify,implFile, _, _),_ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFinalSimplify,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile,nenv) //PrintWholeAssemblyImplementation tcConfig outfile "post-rec-opt" implFile implFile,optEnvFinalSimplify else @@ -1319,7 +1318,7 @@ let CreateIlxAssemblyGenerator (_tcConfig:TcConfig,tcImports:TcImports,tcGlobals ilxGenerator.AddExternalCcus ccus ilxGenerator -let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcConfig:TcConfig, topAttrs, optimizedImpls, fragName, ilxGenerator : IlxAssemblyGenerator) = +let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcConfig:TcConfig, topAttrs, optimizedImpls, fragName, ilxGenerator : IlxAssemblyGenerator, nenv) = if !progress then dprintf "Generating ILX code...\n" let ilxGenOpts : IlxGenOptions = { generateFilterBlocks = tcConfig.generateFilterBlocks @@ -1335,7 +1334,7 @@ let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcCon isInteractiveItExpr = isInteractiveItExpr alwaysCallVirt = tcConfig.alwaysCallVirt } - ilxGenerator.GenerateCode (ilxGenOpts, optimizedImpls, topAttrs.assemblyAttrs,topAttrs.netModuleAttrs) + ilxGenerator.GenerateCode (ilxGenOpts, optimizedImpls, topAttrs.assemblyAttrs,topAttrs.netModuleAttrs,nenv) //---------------------------------------------------------------------------- // Assembly ref normalization: make sure all assemblies are referred to diff --git a/src/fsharp/CompileOptions.fsi b/src/fsharp/CompileOptions.fsi index 2626f1ebe22..ade8737223a 100644 --- a/src/fsharp/CompileOptions.fsi +++ b/src/fsharp/CompileOptions.fsi @@ -80,11 +80,11 @@ val GetGeneratedILModuleName : CompilerTarget -> string -> string val GetInitialOptimizationEnv : TcImports * TcGlobals -> IncrementalOptimizationEnv val AddExternalCcuToOpimizationEnv : TcGlobals -> IncrementalOptimizationEnv -> ImportedAssembly -> IncrementalOptimizationEnv -val ApplyAllOptimizations : TcConfig * TcGlobals * ConstraintSolver.TcValF * string * ImportMap * bool * IncrementalOptimizationEnv * CcuThunk * TypedImplFile list -> TypedAssemblyAfterOptimization * Optimizer.LazyModuleInfo * IncrementalOptimizationEnv +val ApplyAllOptimizations : TcConfig * TcGlobals * ConstraintSolver.TcValF * string * ImportMap * bool * IncrementalOptimizationEnv * CcuThunk * TypedImplFile list * NameResolution.NameResolutionEnv -> TypedAssemblyAfterOptimization * Optimizer.LazyModuleInfo * IncrementalOptimizationEnv val CreateIlxAssemblyGenerator : TcConfig * TcImports * TcGlobals * ConstraintSolver.TcValF * CcuThunk -> IlxGen.IlxAssemblyGenerator -val GenerateIlxCode : IlxGen.IlxGenBackend * isInteractiveItExpr:bool * isInteractiveOnMono:bool * TcConfig * TypeChecker.TopAttribs * TypedAssemblyAfterOptimization * fragName:string * IlxGen.IlxAssemblyGenerator -> IlxGen.IlxGenResults +val GenerateIlxCode : IlxGen.IlxGenBackend * isInteractiveItExpr:bool * isInteractiveOnMono:bool * TcConfig * TypeChecker.TopAttribs * TypedAssemblyAfterOptimization * fragName:string * IlxGen.IlxAssemblyGenerator * NameResolution.NameResolutionEnv -> IlxGen.IlxGenResults // Used during static linking val NormalizeAssemblyRefs : CompilationThreadToken * TcImports -> (AbstractIL.IL.ILScopeRef -> AbstractIL.IL.ILScopeRef) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 7a88d2e5604..bc717392e87 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -32,7 +32,8 @@ module internal Microsoft.FSharp.Compiler.ConstraintSolver open Internal.Utilities.Collections -open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -86,24 +87,24 @@ let NewInferenceTypes l = l |> List.map (fun _ -> NewInferenceType ()) // abstract generic method slot. But we later check the generalization // condition anyway, so we could get away with a non-rigid typar. This // would sort of be cleaner, though give errors later. -let FreshenAndFixupTypars m rigid fctps tinst tpsorig = +let FreshenAndFixupTypars getExtSlnsOpt m rigid fctps tinst tpsorig = let copy_tyvar (tp:Typar) = NewCompGenTypar (tp.Kind, rigid, tp.StaticReq, (if rigid=TyparRigidity.Rigid then TyparDynamicReq.Yes else TyparDynamicReq.No), false) let tps = tpsorig |> List.map copy_tyvar - let renaming, tinst = FixupNewTypars m fctps tinst tpsorig tps + let renaming, tinst = FixupNewTypars getExtSlnsOpt m fctps tinst tpsorig tps tps, renaming, tinst -let FreshenTypeInst m tpsorig = FreshenAndFixupTypars m TyparRigidity.Flexible [] [] tpsorig -let FreshMethInst m fctps tinst tpsorig = FreshenAndFixupTypars m TyparRigidity.Flexible fctps tinst tpsorig +let FreshenTypeInst getExtSlnsOpt m tpsorig = FreshenAndFixupTypars getExtSlnsOpt m TyparRigidity.Flexible [] [] tpsorig +let FreshenMethInst getExtSlnsOpt m fctps tinst tpsorig = FreshenAndFixupTypars getExtSlnsOpt m TyparRigidity.Flexible fctps tinst tpsorig -let FreshenTypars m tpsorig = +let FreshenTypars getExtSlnsOpt m tpsorig = match tpsorig with | [] -> [] | _ -> - let _, _, tptys = FreshenTypeInst m tpsorig + let _, _, tptys = FreshenTypeInst getExtSlnsOpt m tpsorig tptys -let FreshenMethInfo m (minfo:MethInfo) = - let _, _, tptys = FreshMethInst m (minfo.GetFormalTyparsOfDeclaringType m) minfo.DeclaringTypeInst minfo.FormalMethodTypars +let FreshenMethInfo getExtSlnsOpt m (minfo:MethInfo) = + let _, _, tptys = FreshenMethInst getExtSlnsOpt m (minfo.GetFormalTyparsOfDeclaringType m) minfo.DeclaringTypeInst minfo.FormalMethodTypars tptys @@ -173,7 +174,7 @@ type ConstraintSolverState = /// That is, there will be one entry in this table for each free type variable in /// 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 + mutable ExtraCxs: HashMultiMap } static member New(g, amap, infoReader, tcVal) = @@ -191,20 +192,22 @@ type ConstraintSolverEnv = MatchingOnly: bool m: range EquivEnv: TypeEquivEnv - DisplayEnv: DisplayEnv + DisplayEnv : DisplayEnv + NameResolutionEnv : NameResolutionEnv } member csenv.InfoReader = csenv.SolverState.InfoReader member csenv.g = csenv.SolverState.g member csenv.amap = csenv.SolverState.amap -let MakeConstraintSolverEnv contextInfo css m denv = +let MakeConstraintSolverEnv contextInfo css m denv nres = { SolverState = css m = m eContextInfo = contextInfo // Indicates that when unifiying ty1 = ty2, only type variables in ty1 may be solved MatchingOnly = false EquivEnv = TypeEquivEnv.Empty - DisplayEnv = denv } + DisplayEnv = denv + NameResolutionEnv = nres } //------------------------------------------------------------------------- @@ -749,8 +752,8 @@ and solveTypMeetsTyparConstraints (csenv:ConstraintSolverEnv) ndeep m2 trace ty | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypRequiresDefaultConstructor csenv ndeep m2 trace ty | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypChoice csenv ndeep m2 trace ty tys | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m2 trace None ty2 ty - | TyparConstraint.MayResolveMember(traitInfo, m2) -> - SolveMemberConstraint csenv false false ndeep m2 trace traitInfo ++ (fun _ -> CompleteD) + | TyparConstraint.MayResolveMember(traitInfo,m2,extVals) -> + SolveMemberConstraint csenv false false ndeep m2 trace traitInfo extVals ++ (fun _ -> CompleteD) ))) @@ -942,7 +945,7 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty /// We pretend int and other types support a number of operators. In the actual IL for mscorlib they /// don't, however the type-directed static optimization rules in the library code that makes use of this /// will deal with the problem. -and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace (TTrait(tys, nm, memFlags, argtys, rty, sln)): OperationResult = +and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace (TTrait(tys, nm, memFlags, argtys, rty, sln)) extVals : OperationResult = // Do not re-solve if already solved if sln.Value.IsSome then ResultD true else let g = csenv.g @@ -971,8 +974,8 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p tys |> IterateD (SolveTypStaticReq csenv trace HeadTypeStaticReq)) ++ (fun () -> let argtys = if memFlags.IsInstance then List.tail argtys else argtys + let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo extVals - let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo match minfos, tys, memFlags.IsInstance, nm, argtys with | _, _, false, ("op_Division" | "op_Multiply"), [argty1;argty2] @@ -1266,9 +1269,9 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p |> List.choose (fun minfo -> if minfo.IsCurried then None else let callerArgs = argtys |> List.map (fun argty -> CallerArg(argty, m, false, dummyExpr)) - let minst = FreshenMethInfo m minfo + let minst = FreshenMethInfo None m minfo let objtys = minfo.GetObjArgTypes(amap, m, minst) - Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo, m, AccessibleFromEverywhere, minfo, minst, minst, None, objtys, [(callerArgs, [])], false, false, None))) + Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo None, m, AccessibleFromEverywhere, minfo, minst, minst, None, objtys, [(callerArgs, [])], false, false, None))) let methOverloadResult, errors = trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) (fun trace -> ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) (0, 0) AccessibleFromEverywhere calledMethGroup false (Some rty)) @@ -1282,7 +1285,6 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p | None, Some (calledMeth:CalledMeth<_>) -> // OK, the constraint is solved. let minfo = calledMeth.Method - errors ++ (fun () -> let isInstance = minfo.IsInstance if isInstance <> memFlags.IsInstance then @@ -1301,7 +1303,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // If there's nothing left to learn then raise the errors (if (permitWeakResolution && isNil support) || isNil frees then errors // Otherwise re-record the trait waiting for canonicalization - else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees) ++ (fun () -> + else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees extVals) ++ (fun () -> match errors with | ErrorResult (_, UnresolvedOverloading _) when not ignoreUnresolvedOverload && (not (nm = "op_Explicit" || nm = "op_Implicit")) -> ErrorD LocallyAbortOperationThatFailsToResolveOverload | _ -> ResultD TTraitUnsolved) @@ -1380,9 +1382,13 @@ and TransactMemberConstraintSolution traitInfo (trace:OptionalTrace) sln = let prev = traitInfo.Solution trace.Exec (fun () -> traitInfo.Solution <- Some sln) (fun () -> traitInfo.Solution <- prev) +and GetRelevantExtensionMethodsForTrait g (TTrait(tys, _, _, _, _, _)) extVals = + // TODO: check the use of 'allPairs' - not all these extensions apply to each type variable. + (tys,extVals) ||> List.allPairs |> List.map (fun (t,vref) -> FSMeth(g, t, vref, Some 1uL) ) + /// Only consider overload resolution if canonicalizing or all the types are now nominal. /// That is, don't perform resolution if more nominal information may influence the set of available overloads -and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys, _, memFlags, argtys, rty, soln) as traitInfo): MethInfo list = +and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys, _, memFlags, argtys, rty, soln) as traitInfo) extVals : MethInfo list = let results = if permitWeakResolution || isNil (GetSupportOfMemberConstraint csenv traitInfo) then let m = csenv.m @@ -1391,21 +1397,28 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution | MemberKind.Constructor -> tys |> List.map (GetIntrinsicConstructorInfosOfType csenv.SolverState.InfoReader m) | _ -> - tys |> List.map (GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm, AccessibleFromSomeFSharpCode, AllowMultiIntfInstantiations.Yes) IgnoreOverrides m) + let getRelevantMethods t = + GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm, AccessibleFromSomeFSharpCode, AllowMultiIntfInstantiations.Yes) IgnoreOverrides m t + + tys |> List.map getRelevantMethods /// Merge the sets so we don't get the same minfo from each side /// We merge based on whether minfos use identical metadata or not. /// REVIEW: Consider the pathological cases where this may cause a loss of distinction /// between potential overloads because a generic instantiation derived from the left hand type differs /// to a generic instantiation for an operator based on the right hand type. - let minfos = List.reduce (ListSet.unionFavourLeft MethInfo.MethInfosUseIdenticalDefinitions) minfos - minfos + + // Get the extension method that may be relevant to solving the constraint as MethInfo objects. + let extMInfos = GetRelevantExtensionMethodsForTrait csenv.g traitInfo extVals + + minfos @ extMInfos else [] + // The trait name "op_Explicit" also covers "op_Implicit", so look for that one too. if nm = "op_Explicit" then - results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln)) + results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln)) extVals else results @@ -1434,6 +1447,15 @@ and SolveRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep permitWeakR | None -> ResultD false)) +and GetRelevantPossibleExtensionSolutionsToConstraint (nenv: NameResolutionEnv) (traitInfo: TraitConstraintInfo) = + NameMultiMap.find traitInfo.MemberName nenv.eExtensionMembersByName + |> List.choose (function + | FSExtMem (v,_) -> + if v.LogicalName = traitInfo.MemberName then Some v + else None + // TODO: allow .NET-defined extension members to solve trait constraints + | ILExtMem (_,_,_) -> None) + and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep permitWeakResolution (trace:OptionalTrace) tp = let cxst = csenv.SolverState.ExtraCxs let tpn = tp.Stamp @@ -1444,14 +1466,14 @@ and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep per assert (isNil (cxst.FindAll tpn)) cxs - |> AtLeastOneD (fun (traitInfo, m2) -> + |> AtLeastOneD (fun (traitInfo, extVals, m2) -> let csenv = { csenv with m = m2 } - SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo) + SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo extVals) and CanonicalizeRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep trace tps = SolveRelevantMemberConstraints csenv ndeep true trace tps -and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo support frees = +and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo support frees extVals = let g = csenv.g let aenv = csenv.EquivEnv let cxst = csenv.SolverState.ExtraCxs @@ -1466,13 +1488,15 @@ and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo sup let cxs = cxst.FindAll tpn // 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) + // + // TODO: conside whether we need to consider equality over _valRefs as well + if not (cxs |> List.exists (fun (traitInfo2, _valRefs, _) -> traitsAEquiv g aenv traitInfo traitInfo2)) then + trace.Exec (fun () -> csenv.SolverState.ExtraCxs.Add (tpn, (traitInfo, extVals, 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. - support |> IterateD (fun tp -> AddConstraint csenv ndeep m2 trace tp (TyparConstraint.MayResolveMember(traitInfo, m2))) + support |> IterateD (fun tp -> AddConstraint csenv ndeep m2 trace tp (TyparConstraint.MayResolveMember(traitInfo, m2, extVals))) /// Record a constraint on an inference type variable. @@ -1490,8 +1514,8 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint = // may require type annotations. See FSharp 1.0 bug 6477. let consistent tpc1 tpc2 = match tpc1, tpc2 with - | (TyparConstraint.MayResolveMember(TTrait(tys1, nm1, memFlags1, argtys1, rty1, _), _), - TyparConstraint.MayResolveMember(TTrait(tys2, nm2, memFlags2, argtys2, rty2, _), _)) + | (TyparConstraint.MayResolveMember(TTrait(tys1, nm1, memFlags1, argtys1, rty1, _), _, _), + TyparConstraint.MayResolveMember(TTrait(tys2, nm2, memFlags2, argtys2, rty2, _), _, _)) when (memFlags1 = memFlags2 && nm1 = nm2 && // Multiple op_Explicit and op_Implicit constraints can exist for the same type variable. @@ -1556,9 +1580,9 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint = // If it does occur, e.g. at instantiation T2, then the check above will have enforced that // T2 = ty2 let implies tpc1 tpc2 = - match tpc1, tpc2 with - | TyparConstraint.MayResolveMember(trait1, _), - TyparConstraint.MayResolveMember(trait2, _) -> + match tpc1,tpc2 with + | TyparConstraint.MayResolveMember(trait1, _, _), + TyparConstraint.MayResolveMember(trait2, _, _) -> traitsAEquiv g aenv trait1 trait2 | TyparConstraint.CoercesTo(ty1, _), TyparConstraint.CoercesTo(ty2, _) -> @@ -2409,9 +2433,10 @@ and ResolveOverloading // Unify return types. match calledMethOpt with | Some calledMeth -> - calledMethOpt, - errors ++ (fun () -> - let cxsln = Option.map (fun traitInfo -> (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs)) cx + calledMethOpt, + errors ++ (fun () -> + let ofTraitInfo traitInfo = (traitInfo, MemberConstraintSolutionOfMethInfo csenv.SolverState m calledMeth.Method calledMeth.CalledTyArgs) + let cxsln = Option.map ofTraitInfo cx match calledMethTrace with | NoTrace -> @@ -2501,8 +2526,8 @@ let EliminateConstraintsForGeneralizedTypars csenv (trace:OptionalTrace) (genera // No error recovery here: we do that on a per-expression basis. //------------------------------------------------------------------------- -let AddCxTypeEqualsType contextInfo denv css m ty1 ty2 = - SolveTypEqualsTypWithReport (MakeConstraintSolverEnv contextInfo css m denv) 0 m NoTrace None ty1 ty2 +let AddCxTypeEqualsType contextInfo denv nenv css m ty1 ty2 = + SolveTypEqualsTypWithReport (MakeConstraintSolverEnv contextInfo css m denv nenv) 0 m NoTrace None ty1 ty2 |> RaiseOperationResult let UndoIfFailed f = @@ -2522,85 +2547,86 @@ let UndoIfFailed f = ReportWarnings warns true -let AddCxTypeEqualsTypeUndoIfFailed denv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) ty1 ty2) +let AddCxTypeEqualsTypeUndoIfFailed denv nenv css m ty1 ty2 = + UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m (WithTrace trace) ty1 ty2) -let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = - let csenv = { MakeConstraintSolverEnv ContextInfo.NoContext css m denv with MatchingOnly = true } +let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv nenv css m ty1 ty2 = + let csenv = { MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) -let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) None ty1 ty2) +let AddCxTypeMustSubsumeTypeUndoIfFailed denv nenv css m ty1 ty2 = + UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m (WithTrace trace) None ty1 ty2) -let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv +let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv nenv css m ty1 ty2 = + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv let csenv = { csenv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs csenv 0 m (WithTrace trace) None ty1 ty2) -let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = - SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv contextInfo css m denv) 0 m trace None ty1 ty2 +let AddCxTypeMustSubsumeType contextInfo denv nenv css m trace ty1 ty2 = + SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv contextInfo css m denv nenv) 0 m trace None ty1 ty2 |> RaiseOperationResult -let AddCxMethodConstraint denv css m trace traitInfo = - TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) true false 0 m trace traitInfo ++ (fun _ -> CompleteD)) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) +let AddCxMethodConstraint denv nenv css m trace (traitInfo : TraitConstraintInfo) = + let extVals = GetRelevantPossibleExtensionSolutionsToConstraint nenv traitInfo + TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) true false 0 m trace traitInfo extVals ++ (fun _ -> CompleteD)) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportNull denv css m trace ty = - TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) +let AddCxTypeMustSupportNull denv nenv css m trace ty = + TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportComparison denv css m trace ty = - TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) +let AddCxTypeMustSupportComparison denv nenv css m trace ty = + TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportEquality denv css m trace ty = - TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) +let AddCxTypeMustSupportEquality denv nenv css m trace ty = + TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportDefaultCtor denv css m trace ty = - TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) +let AddCxTypeMustSupportDefaultCtor denv nenv css m trace ty = + TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsReferenceType denv css m trace ty = - TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) +let AddCxTypeIsReferenceType denv nenv css m trace ty = + TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsValueType denv css m trace ty = - TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) +let AddCxTypeIsValueType denv nenv css m trace ty = + TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsUnmanaged denv css m trace ty = - TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) +let AddCxTypeIsUnmanaged denv nenv css m trace ty = + TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsEnum denv css m trace ty underlying = - TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty underlying) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) +let AddCxTypeIsEnum denv nenv css m trace ty underlying = + TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty underlying) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsDelegate denv css m trace ty aty bty = - TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty aty bty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) +let AddCxTypeIsDelegate denv nenv css m trace ty aty bty = + TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty aty bty) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:TraitConstraintInfo) argExprs = +let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:TraitConstraintInfo) argExprs nenv = let css = { g = g amap = amap TcVal = tcVal ExtraCxs = HashMultiMap(10, HashIdentity.Structural) - InfoReader = new InfoReader(g, amap) } - - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) - SolveMemberConstraint csenv true true 0 m NoTrace traitInfo ++ (fun _res -> + InfoReader = new InfoReader(g,amap) } + let extVals = GetRelevantPossibleExtensionSolutionsToConstraint nenv traitInfo + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) nenv + SolveMemberConstraint csenv true true 0 m NoTrace traitInfo extVals ++ (fun _res -> let sln = match traitInfo.Solution with | None -> Choice4Of4() @@ -2683,20 +2709,20 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait | Choice4Of4 () -> ResultD None) -let ChooseTyparSolutionAndSolve css denv tp = +let ChooseTyparSolutionAndSolve css denv nenv tp = let g = css.g let amap = css.amap - let max, m = ChooseTyparSolutionAndRange g amap tp - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv + let max,m = ChooseTyparSolutionAndRange g amap tp + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv TryD (fun () -> SolveTyparEqualsTyp 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 CheckDeclaredTypars denv nenv css m typars1 typars2 = TryD (fun () -> CollectThenUndo (fun trace -> - SolveTypEqualsTypEqns (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) None + SolveTypEqualsTypEqns (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m (WithTrace trace) None (List.map mkTyparTy typars1) (List.map mkTyparTy typars2))) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) @@ -2715,8 +2741,8 @@ let IsApplicableMethApprox g amap m (minfo:MethInfo) availObjTy = TcVal = (fun _ -> failwith "should not be called") ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = new InfoReader(g, amap) } - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) - let minst = FreshenMethInfo m minfo + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) (NameResolutionEnv.Empty g) + let minst = FreshenMethInfo None m minfo match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> TryD (fun () -> SolveTypSubsumesTyp csenv 0 m NoTrace None reqdObjTy availObjTy ++ (fun () -> ResultD true)) diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index b2837078737..efd1e9668ff 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -9,6 +9,7 @@ open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger @@ -39,43 +40,45 @@ val NewInferenceTypes : 'a list -> TType list /// Given a set of formal type parameters and their constraints, make new inference type variables for /// each and ensure that the constraints on the new type variables are adjusted to refer to these. -val FreshenAndFixupTypars : range -> TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInst * TType list +val FreshenAndFixupTypars : (TraitConstraintInfo -> PossibleExtensionMemberSolutions) option -> range -> TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInst * TType list -val FreshenTypeInst : range -> Typars -> Typars * TyparInst * TType list +val FreshenTypeInst : (TraitConstraintInfo -> PossibleExtensionMemberSolutions) option -> range -> Typars -> Typars * TyparInst * TType list -val FreshenTypars : range -> Typars -> TType list +val FreshenTypars : (TraitConstraintInfo -> PossibleExtensionMemberSolutions) option -> range -> Typars -> TType list -val FreshenMethInfo : range -> MethInfo -> TType list +val FreshenMethInfo : (TraitConstraintInfo -> PossibleExtensionMemberSolutions) option -> range -> MethInfo -> TType list + +val GetRelevantPossibleExtensionSolutionsToConstraint : NameResolutionEnv -> TraitConstraintInfo -> PossibleExtensionMemberSolutions [] /// Information about the context of a type equation. type ContextInfo = -/// No context was given. -| NoContext -/// The type equation comes from an IF expression. -| IfExpression of range -/// The type equation comes from an omitted else branch. -| OmittedElseBranch of range -/// The type equation comes from a type check of the result of an else branch. -| ElseBranchResult of range -/// The type equation comes from the verification of record fields. -| RecordFields -/// The type equation comes from the verification of a tuple in record fields. -| TupleInRecordFields -/// The type equation comes from a list or array constructor -| CollectionElement of bool * range -/// The type equation comes from a return in a computation expression. -| ReturnInComputationExpression -/// The type equation comes from a yield in a computation expression. -| YieldInComputationExpression -/// The type equation comes from a runtime type test. -| RuntimeTypeTest of bool -/// The type equation comes from an downcast where a upcast could be used. -| DowncastUsedInsteadOfUpcast of bool -/// The type equation comes from a return type of a pattern match clause (not the first clause). -| FollowingPatternMatchClause of range -/// The type equation comes from a pattern match guard. -| PatternMatchGuard of range + /// No context was given. + | NoContext + /// The type equation comes from an IF expression. + | IfExpression of range + /// The type equation comes from an omitted else branch. + | OmittedElseBranch of range + /// The type equation comes from a type check of the result of an else branch. + | ElseBranchResult of range + /// The type equation comes from the verification of record fields. + | RecordFields + /// The type equation comes from the verification of a tuple in record fields. + | TupleInRecordFields + /// The type equation comes from a list or array constructor + | CollectionElement of bool * range + /// The type equation comes from a return in a computation expression. + | ReturnInComputationExpression + /// The type equation comes from a yield in a computation expression. + | YieldInComputationExpression + /// The type equation comes from a runtime type test. + | RuntimeTypeTest of bool + /// The type equation comes from an downcast where a upcast could be used. + | DowncastUsedInsteadOfUpcast of bool + /// The type equation comes from a return type of a pattern match clause (not the first clause). + | FollowingPatternMatchClause of range + /// The type equation comes from a pattern match guard. + | PatternMatchGuard of range exception ConstraintSolverTupleDiffLengths of DisplayEnv * TType list * TType list * range * range @@ -105,7 +108,7 @@ type ConstraintSolverEnv val BakedInTraitConstraintNames : Set -val MakeConstraintSolverEnv : ContextInfo -> ConstraintSolverState -> range -> DisplayEnv -> ConstraintSolverEnv +val MakeConstraintSolverEnv : ContextInfo -> ConstraintSolverState -> range -> DisplayEnv -> NameResolutionEnv -> ConstraintSolverEnv [] type Trace @@ -122,28 +125,28 @@ val ResolveOverloading : ConstraintSolverEnv -> OptionalTr val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> CalledMeth list -> TType -> OperationResult val EliminateConstraintsForGeneralizedTypars : ConstraintSolverEnv -> OptionalTrace -> Typars -> unit -val CheckDeclaredTypars : DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit +val CheckDeclaredTypars : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit val AddConstraint : ConstraintSolverEnv -> int -> Range.range -> OptionalTrace -> Typar -> TyparConstraint -> OperationResult -val AddCxTypeEqualsType : ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit -val AddCxTypeEqualsTypeUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -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 -> OptionalTrace -> TraitConstraintInfo -> unit -val AddCxTypeMustSupportNull : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportComparison : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportEquality : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportDefaultCtor : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsReferenceType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsValueType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsUnmanaged : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsEnum : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit -val AddCxTypeIsDelegate : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit - -val CodegenWitnessThatTypSupportsTraitConstraint : TcValF -> TcGlobals -> ImportMap -> range -> TraitConstraintInfo -> Expr list -> OperationResult - -val ChooseTyparSolutionAndSolve : ConstraintSolverState -> DisplayEnv -> Typar -> unit +val AddCxTypeEqualsType : ContextInfo -> DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> unit +val AddCxTypeEqualsTypeUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool +val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool +val AddCxTypeMustSubsumeType : ContextInfo -> DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit +val AddCxTypeMustSubsumeTypeUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool +val AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool +val AddCxMethodConstraint : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TraitConstraintInfo -> unit +val AddCxTypeMustSupportNull : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportComparison : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportEquality : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportDefaultCtor : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsReferenceType : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsValueType : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsUnmanaged : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsEnum : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit +val AddCxTypeIsDelegate : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit + +val CodegenWitnessThatTypSupportsTraitConstraint : TcValF -> TcGlobals -> ImportMap -> range -> TraitConstraintInfo -> Expr list -> NameResolutionEnv -> OperationResult + +val ChooseTyparSolutionAndSolve : ConstraintSolverState -> DisplayEnv -> NameResolutionEnv -> Typar -> unit val IsApplicableMethApprox : TcGlobals -> ImportMap -> range -> MethInfo -> TType -> bool diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 4fafb20040c..1503a0b19f5 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -186,7 +186,8 @@ type cenv = amap: ImportMap intraAssemblyInfo : IlxGenIntraAssemblyInfo /// Cache methods with SecurityAttribute applied to them, to prevent unnecessary calls to ExistsInEntireHierarchyOfType - casApplied : Dictionary + casApplied : Dictionary + nenv : NameResolution.NameResolutionEnv /// Used to apply forced inlining optimizations to witnesses generated late during codegen mutable optimizeDuringCodeGen : (Expr -> Expr) } @@ -3326,7 +3327,7 @@ and CommitCallSequel cenv eenv m cloc cgbuf mustGenerateUnitAfterCall sequel = and GenTraitCall cenv cgbuf eenv (traitInfo, argExprs, m) expr sequel = - let minfoOpt = CommitOperationResult (ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo argExprs) + let minfoOpt = CommitOperationResult (ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo argExprs cenv.nenv) match minfoOpt with | None -> let replacementExpr = @@ -7109,7 +7110,7 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal : Constra ilxGenEnv <- AddIncrementalLocalAssemblyFragmentToIlxGenEnv (amap, isIncrementalFragment, tcGlobals, ccu, fragName, intraAssemblyInfo, ilxGenEnv, typedImplFiles) /// Generate ILX code for an assembly fragment - member __.GenerateCode (codeGenOpts, typedAssembly, assemAttribs, moduleAttribs) = + member __.GenerateCode (codeGenOpts, typedAssembly, assemAttribs, moduleAttribs, nenv) = let cenv : cenv = { g=tcGlobals TcVal = tcVal @@ -7119,6 +7120,7 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal : Constra casApplied = casApplied intraAssemblyInfo = intraAssemblyInfo opts = codeGenOpts + nenv = nenv optimizeDuringCodeGen = (fun x -> x) } GenerateCode (cenv, ilxGenEnv, typedAssembly, assemAttribs, moduleAttribs) diff --git a/src/fsharp/IlxGen.fsi b/src/fsharp/IlxGen.fsi index bd01f941284..5b647762d9e 100644 --- a/src/fsharp/IlxGen.fsi +++ b/src/fsharp/IlxGen.fsi @@ -69,7 +69,7 @@ type public IlxAssemblyGenerator = member AddIncrementalLocalAssemblyFragment : isIncrementalFragment: bool * fragName:string * typedImplFiles: TypedImplFile list -> unit /// Generate ILX code for an assembly fragment - member GenerateCode : IlxGenOptions * TypedAssemblyAfterOptimization * Attribs * Attribs -> IlxGenResults + member GenerateCode : IlxGenOptions * TypedAssemblyAfterOptimization * Attribs * Attribs * NameResolution.NameResolutionEnv -> IlxGenResults /// Create the CAS permission sets for an assembly fragment member CreatePermissionSets : Attrib list -> ILPermission list diff --git a/src/fsharp/InfoReader.fs b/src/fsharp/InfoReader.fs index 375571f1afe..43a90c793d8 100644 --- a/src/fsharp/InfoReader.fs +++ b/src/fsharp/InfoReader.fs @@ -8,7 +8,7 @@ open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.AttributeChecking @@ -20,7 +20,7 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.TcGlobals /// Use the given function to select some of the member values from the members of an F# type -let private SelectImmediateMemberVals g optFilter f (tcref:TyconRef) = +let SelectImmediateMemberVals g optFilter f (tcref:TyconRef) = let chooser (vref:ValRef) = match vref.MemberInfo with // The 'when' condition is a workaround for the fact that values providing diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index cc50d5bb15d..4a09ca0e437 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -303,6 +303,11 @@ type ExtensionMember = match x with | FSExtMem (_,pri) -> pri | ILExtMem (_,_,pri) -> pri + + member x.LogicalName = + match x with + | FSExtMem (vref,_) -> vref.LogicalName + | ILExtMem (_,minfo,_) -> minfo.LogicalName type FullyQualifiedFlag = /// Only resolve full paths @@ -363,6 +368,9 @@ type NameResolutionEnv = /// Extension members by type and name eIndexedExtensionMembers: TyconRefMultiMap + /// Extension members by name + eExtensionMembersByName: NameMultiMap + /// Other extension members unindexed by type eUnindexedExtensionMembers: ExtensionMember list @@ -385,6 +393,7 @@ type NameResolutionEnv = eFullyQualifiedTyconsByAccessNames = LayeredMultiMap.Empty eFullyQualifiedTyconsByDemangledNameAndArity = LayeredMap.Empty eIndexedExtensionMembers = TyconRefMultiMap<_>.Empty + eExtensionMembersByName = NameMultiMap<_>.Empty eUnindexedExtensionMembers = [] eTypars = Map.empty } @@ -523,6 +532,13 @@ let AddValRefToExtensionMembers pri (eIndexedExtensionMembers: TyconRefMultiMap< else eIndexedExtensionMembers +/// Add an F# value to the table of available extension members, if necessary, as an FSharp-style extension member +let AddValRefToExtensionMembersByName pri (eExtensionMembersByName: NameMultiMap<_>) (vref:ValRef) = + if vref.IsMember && vref.IsExtensionMember then + NameMultiMap.add vref.CompiledName (FSExtMem (vref,pri)) eExtensionMembersByName + else + eExtensionMembersByName + /// This entrypoint is used to add some extra items to the environment for Visual Studio, e.g. static members let AddFakeNamedValRefToNameEnv nm nenv vref = @@ -553,6 +569,7 @@ let AddValRefsToNameEnvWithPriority bulkAddMode pri nenv (vrefs: ValRef []) = { nenv with eUnqualifiedItems = AddValRefsToItems bulkAddMode nenv.eUnqualifiedItems vrefs eIndexedExtensionMembers = (nenv.eIndexedExtensionMembers,vrefs) ||> Array.fold (AddValRefToExtensionMembers pri) + eExtensionMembersByName = (nenv.eExtensionMembersByName,vrefs) ||> Array.fold (AddValRefToExtensionMembersByName pri) ePatItems = (nenv.ePatItems,vrefs) ||> Array.fold AddValRefsToActivePatternsNameEnv } /// Add a single F# value to the environment. @@ -565,6 +582,7 @@ let AddValRefToNameEnv nenv (vref:ValRef) = else nenv.eUnqualifiedItems eIndexedExtensionMembers = AddValRefToExtensionMembers pri nenv.eIndexedExtensionMembers vref + eExtensionMembersByName = AddValRefToExtensionMembersByName pri nenv.eExtensionMembersByName vref ePatItems = AddValRefsToActivePatternsNameEnv nenv.ePatItems vref } @@ -635,12 +653,12 @@ let private AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition (g:TcGlobals) let ucrefs = if isIL then [] else tcref.UnionCasesAsList |> List.map tcref.MakeNestedUnionCaseRef let flds = if isIL then [| |] else tcref.AllFieldsArray - let eIndexedExtensionMembers, eUnindexedExtensionMembers = + let eIndexedExtensionMembers, eExtensionMembersByName, eUnindexedExtensionMembers = let ilStyleExtensionMeths = GetCSharpStyleIndexedExtensionMembersForTyconRef amap m tcref - ((nenv.eIndexedExtensionMembers,nenv.eUnindexedExtensionMembers),ilStyleExtensionMeths) ||> List.fold (fun (tab1,tab2) extMemInfo -> + ((nenv.eIndexedExtensionMembers, nenv.eExtensionMembersByName, nenv.eUnindexedExtensionMembers),ilStyleExtensionMeths) ||> List.fold (fun (tab1,tab2,tab3) extMemInfo -> match extMemInfo with - | Choice1Of2 (tcref,extMemInfo) -> tab1.Add (tcref, extMemInfo), tab2 - | Choice2Of2 extMemInfo -> tab1, extMemInfo :: tab2) + | Choice1Of2 (tcref,extMemInfo) -> tab1.Add (tcref, extMemInfo), NameMultiMap.add extMemInfo.LogicalName extMemInfo tab2, tab3 + | Choice2Of2 extMemInfo -> tab1, NameMultiMap.add extMemInfo.LogicalName extMemInfo tab2, extMemInfo :: tab3) let isILOrRequiredQualifiedAccess = isIL || (not ownDefinition && HasFSharpAttribute g g.attrib_RequireQualifiedAccessAttribute tcref.Attribs) let eFieldLabels = @@ -693,6 +711,7 @@ let private AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition (g:TcGlobals) eUnqualifiedItems = eUnqualifiedItems ePatItems = ePatItems eIndexedExtensionMembers = eIndexedExtensionMembers + eExtensionMembersByName = eExtensionMembersByName eUnindexedExtensionMembers = eUnindexedExtensionMembers } let TryFindPatternByName name {ePatItems = patternMap} = diff --git a/src/fsharp/NameResolution.fsi b/src/fsharp/NameResolution.fsi index 60ea7a0e660..3e4488ac7b2 100755 --- a/src/fsharp/NameResolution.fsi +++ b/src/fsharp/NameResolution.fsi @@ -133,25 +133,77 @@ val ItemWithNoInst : Item -> ItemWithInst type FieldResolution = FieldResolution of RecdFieldRef * bool /// Information about an extension member held in the name resolution environment -[] -type ExtensionMember +type ExtensionMember = + /// F#-style Extrinsic extension member, defined in F# code + | FSExtMem of ValRef * ExtensionMethodPriority + + /// ILExtMem(declaringTyconRef, ilMetadata, pri) + /// + /// IL-style extension member, backed by some kind of method with an [] attribute + | ILExtMem of TyconRef * MethInfo * ExtensionMethodPriority /// The environment of information used to resolve names [] type NameResolutionEnv = - {eDisplayEnv: DisplayEnv - eUnqualifiedItems: LayeredMap - ePatItems: NameMap - eModulesAndNamespaces: NameMultiMap - eFullyQualifiedModulesAndNamespaces: NameMultiMap - eFieldLabels: NameMultiMap - eTyconsByAccessNames: LayeredMultiMap - eFullyQualifiedTyconsByAccessNames: LayeredMultiMap - eTyconsByDemangledNameAndArity: LayeredMap - eFullyQualifiedTyconsByDemangledNameAndArity: LayeredMap - eIndexedExtensionMembers: TyconRefMultiMap - eUnindexedExtensionMembers: ExtensionMember list - eTypars: NameMap } + { /// Display environment information for output + eDisplayEnv: DisplayEnv + + /// Values and Data Tags available by unqualified name + eUnqualifiedItems: LayeredMap + + /// Data Tags and Active Pattern Tags available by unqualified name + ePatItems: NameMap + + /// Modules accessible via "." notation. Note this is a multi-map. + /// Adding a module abbreviation adds it a local entry to this List.map. + /// Likewise adding a ccu or opening a path adds entries to this List.map. + + + /// REVIEW (old comment) + /// "The boolean flag is means the namespace or module entry shouldn't 'really' be in the + /// map, and if it is ever used to resolve a name then we give a warning. + /// This is used to give warnings on unqualified namespace accesses, e.g. + /// open System + /// open Collections <--- give a warning + /// let v = new Collections.Generic.List() <--- give a warning" + + eModulesAndNamespaces: NameMultiMap + + /// Fully qualified modules and namespaces. 'open' does not change this. + eFullyQualifiedModulesAndNamespaces: NameMultiMap + + /// RecdField labels in scope. RecdField labels are those where type are inferred + /// by label rather than by known type annotation. + /// Bools indicate if from a record, where no warning is given on indeterminate lookup + eFieldLabels: NameMultiMap + + /// Tycons indexed by the various names that may be used to access them, e.g. + /// "List" --> multiple TyconRef's for the various tycons accessible by this name. + /// "List`1" --> TyconRef + eTyconsByAccessNames: LayeredMultiMap + + eFullyQualifiedTyconsByAccessNames: LayeredMultiMap + + /// Tycons available by unqualified, demangled names (i.e. (List,1) --> TyconRef) + eTyconsByDemangledNameAndArity: LayeredMap + + /// Tycons available by unqualified, demangled names (i.e. (List,1) --> TyconRef) + eFullyQualifiedTyconsByDemangledNameAndArity: LayeredMap + + /// Extension members by type and name + eIndexedExtensionMembers: TyconRefMultiMap + + /// Extension members by name + eExtensionMembersByName: NameMultiMap + + /// Other extension members unindexed by type + eUnindexedExtensionMembers: ExtensionMember list + + /// Typars (always available by unqualified names). Further typars can be + /// in the tpenv, a structure folded through each top-level definition. + eTypars: NameMap + + } static member Empty : g:TcGlobals -> NameResolutionEnv member DisplayEnv : DisplayEnv member FindUnqualifiedItem : string -> Item diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index bf05dcadab2..dda05a42423 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -789,8 +789,8 @@ module private PrintTypes = cxs |> ListSet.setify (fun (_,cx1) (_,cx2) -> match cx1,cx2 with - | TyparConstraint.MayResolveMember(traitInfo1,_), - TyparConstraint.MayResolveMember(traitInfo2,_) -> traitsAEquiv denv.g TypeEquivEnv.Empty traitInfo1 traitInfo2 + | TyparConstraint.MayResolveMember(traitInfo1,_,_), + TyparConstraint.MayResolveMember(traitInfo2,_,_) -> traitsAEquiv denv.g TypeEquivEnv.Empty traitInfo1 traitInfo2 | _ -> false) let cxsL = List.collect (layoutConstraintWithInfo denv env) cxs @@ -810,7 +810,7 @@ module private PrintTypes = match tpc with | TyparConstraint.CoercesTo(tpct,_) -> [layoutTyparRefWithInfo denv env tp ^^ wordL (tagOperator ":>") --- layoutTypeWithInfo denv env tpct] - | TyparConstraint.MayResolveMember(traitInfo,_) -> + | TyparConstraint.MayResolveMember(traitInfo,_,_) -> [layoutTraitWithInfo denv env traitInfo] | TyparConstraint.DefaultsTo(_,ty,_) -> if denv.showTyparDefaultConstraints then [wordL (tagKeyword "default") ^^ layoutTyparRefWithInfo denv env tp ^^ WordL.colon ^^ layoutTypeWithInfo denv env ty] diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 3ea19645b6b..61c337af245 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -321,6 +321,7 @@ type cenv = localInternalVals: System.Collections.Generic.Dictionary settings: OptimizationSettings emitTailcalls: bool + nenv : NameResolution.NameResolutionEnv // cache methods with SecurityAttribute applied to them, to prevent unnecessary calls to ExistsInEntireHierarchyOfType casApplied : Dictionary} @@ -2167,7 +2168,7 @@ and OptimizeWhileLoop cenv env (spWhile, marker, e1, e2, m) = and OptimizeTraitCall cenv env (traitInfo, args, m) = // Resolve the static overloading early (during the compulsory rewrite phase) so we can inline. - match ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo args with + match ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo args cenv.nenv with | OkResult (_, Some expr) -> OptimizeExpr cenv env expr @@ -3180,7 +3181,7 @@ and OptimizeImplFileInternal cenv env isIncrementalFragment hidden (TImplFile(qn // Entry point //------------------------------------------------------------------------- -let OptimizeImplFile(settings, ccu, tcGlobals, tcVal, importMap, optEnv, isIncrementalFragment, emitTailcalls, hidden, mimpls) = +let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementalFragment,emitTailcalls,hidden,mimpls,nenv) = let cenv = { settings=settings scope=ccu @@ -3190,8 +3191,9 @@ let OptimizeImplFile(settings, ccu, tcGlobals, tcVal, importMap, optEnv, isIncre optimizing=true localInternalVals=Dictionary(10000) emitTailcalls=emitTailcalls - casApplied=new Dictionary() } - let (optEnvNew, _, _, _ as results) = OptimizeImplFileInternal cenv optEnv isIncrementalFragment hidden mimpls + nenv=nenv + casApplied=new Dictionary() } + let (optEnvNew,_,_,_ as results) = OptimizeImplFileInternal cenv optEnv isIncrementalFragment hidden mimpls let optimizeDuringCodeGen expr = OptimizeExpr cenv optEnvNew expr |> fst results, optimizeDuringCodeGen diff --git a/src/fsharp/Optimizer.fsi b/src/fsharp/Optimizer.fsi index cbdf1a9c803..fa8aeea231a 100644 --- a/src/fsharp/Optimizer.fsi +++ b/src/fsharp/Optimizer.fsi @@ -42,7 +42,7 @@ type IncrementalOptimizationEnv = val internal BindCcu : CcuThunk -> CcuOptimizationInfo -> IncrementalOptimizationEnv -> TcGlobals -> IncrementalOptimizationEnv /// Optimize one implementation file in the given environment -val internal OptimizeImplFile : OptimizationSettings * CcuThunk * TcGlobals * ConstraintSolver.TcValF * Import.ImportMap * IncrementalOptimizationEnv * isIncrementalFragment: bool * emitTaicalls: bool * SignatureHidingInfo * TypedImplFile -> (IncrementalOptimizationEnv * TypedImplFile * ImplFileOptimizationInfo * SignatureHidingInfo) * (Expr -> Expr) +val internal OptimizeImplFile : OptimizationSettings * CcuThunk * TcGlobals * ConstraintSolver.TcValF * Import.ImportMap * IncrementalOptimizationEnv * isIncrementalFragment: bool * emitTaicalls: bool * SignatureHidingInfo * TypedImplFile * NameResolution.NameResolutionEnv -> (IncrementalOptimizationEnv * TypedImplFile * ImplFileOptimizationInfo * SignatureHidingInfo) * (Expr -> Expr) #if DEBUG /// Displaying optimization data diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 029de52c39f..3d4da30974f 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -213,7 +213,7 @@ let rec CheckTypeDeep ((visitTyp,visitTyconRefOpt,visitAppTyOpt,visitTraitSoluti | TType_var tp when tp.Solution.IsSome -> tp.Constraints |> List.iter (fun cx -> match cx with - | TyparConstraint.MayResolveMember((TTrait(_,_,_,_,_,soln)),_) -> + | TyparConstraint.MayResolveMember((TTrait(_,_,_,_,_,soln)),_,_) -> match visitTraitSolutionOpt, !soln with | Some visitTraitSolution, Some sln -> visitTraitSolution sln | _ -> () @@ -254,7 +254,7 @@ and CheckTypesDeep f g env tys = List.iter (CheckTypeDeep f g env) tys and CheckTypeConstraintDeep f g env x = match x with | TyparConstraint.CoercesTo(ty,_) -> CheckTypeDeep f g env ty - | TyparConstraint.MayResolveMember(traitInfo,_) -> CheckTraitInfoDeep f g env traitInfo + | TyparConstraint.MayResolveMember(traitInfo,_,_) -> CheckTraitInfoDeep f g env traitInfo | TyparConstraint.DefaultsTo(_,ty,_) -> CheckTypeDeep f g env ty | TyparConstraint.SimpleChoice(tys,_) -> CheckTypesDeep f g env tys | TyparConstraint.IsEnum(uty,_) -> CheckTypeDeep f g env uty diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 5b0c0eaf0aa..7388fd28b74 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -57,7 +57,7 @@ type TyconRefMap<'T>(imap: StampMap<'T>) = member m.Add (v: TyconRef) x = TyconRefMap (imap.Add (v.Stamp, x)) member m.Remove (v: TyconRef) = TyconRefMap (imap.Remove v.Stamp) member m.IsEmpty = imap.IsEmpty - + member m.Contents = imap static member Empty : TyconRefMap<'T> = TyconRefMap Map.empty static member OfList vs = (vs, TyconRefMap<'T>.Empty) ||> List.foldBack (fun (x, y) acc -> acc.Add x y) @@ -226,16 +226,16 @@ and remapTypesAux tyenv types = List.mapq (remapTypeAux tyenv) types and remapTyparConstraintsAux tyenv cs = cs |> List.choose (fun x -> match x with - | TyparConstraint.CoercesTo(ty, m) -> - Some(TyparConstraint.CoercesTo (remapTypeAux tyenv ty, m)) - | TyparConstraint.MayResolveMember(traitInfo, m) -> - Some(TyparConstraint.MayResolveMember (remapTraitAux tyenv traitInfo, m)) - | TyparConstraint.DefaultsTo(priority, ty, m) -> Some(TyparConstraint.DefaultsTo(priority, remapTypeAux tyenv ty, m)) - | TyparConstraint.IsEnum(uty, m) -> - Some(TyparConstraint.IsEnum(remapTypeAux tyenv uty, m)) - | TyparConstraint.IsDelegate(uty1, uty2, m) -> - Some(TyparConstraint.IsDelegate(remapTypeAux tyenv uty1, remapTypeAux tyenv uty2, m)) - | TyparConstraint.SimpleChoice(tys, m) -> Some(TyparConstraint.SimpleChoice(remapTypesAux tyenv tys, m)) + | TyparConstraint.CoercesTo(ty,m) -> + Some(TyparConstraint.CoercesTo (remapTypeAux tyenv ty,m)) + | TyparConstraint.MayResolveMember(traitInfo,m,extVals) -> + Some(TyparConstraint.MayResolveMember (remapTraitAux tyenv traitInfo,m,List.map (remapValRef tyenv) extVals)) + | TyparConstraint.DefaultsTo(priority,ty,m) -> Some(TyparConstraint.DefaultsTo(priority,remapTypeAux tyenv ty,m)) + | TyparConstraint.IsEnum(uty,m) -> + Some(TyparConstraint.IsEnum(remapTypeAux tyenv uty,m)) + | TyparConstraint.IsDelegate(uty1,uty2,m) -> + Some(TyparConstraint.IsDelegate(remapTypeAux tyenv uty1,remapTypeAux tyenv uty2,m)) + | TyparConstraint.SimpleChoice(tys,m) -> Some(TyparConstraint.SimpleChoice(remapTypesAux tyenv tys,m)) | TyparConstraint.SupportsComparison _ | TyparConstraint.SupportsEquality _ | TyparConstraint.SupportsNull _ @@ -370,6 +370,7 @@ let mkInstRemap tpinst = let instType tpinst x = if isNil tpinst then x else remapTypeAux (mkInstRemap tpinst) x let instTypes tpinst x = if isNil tpinst then x else remapTypesAux (mkInstRemap tpinst) x let instTrait tpinst x = if isNil tpinst then x else remapTraitAux (mkInstRemap tpinst) x +let instValRef tpinst x = if isNil tpinst then x else remapValRef (mkInstRemap tpinst) x let instTyparConstraints tpinst x = if isNil tpinst then x else remapTyparConstraintsAux (mkInstRemap tpinst) x let instSlotSig tpinst ss = remapSlotSig (fun _ -> []) (mkInstRemap tpinst) ss let copySlotSig ss = remapSlotSig (fun _ -> []) Remap.Empty ss @@ -822,8 +823,8 @@ and typarConstraintsAEquivAux erasureFlag g aenv tpc1 tpc2 = TyparConstraint.CoercesTo(fcty, _) -> typeAEquivAux erasureFlag g aenv acty fcty - | TyparConstraint.MayResolveMember(trait1, _), - TyparConstraint.MayResolveMember(trait2, _) -> + | TyparConstraint.MayResolveMember(trait1,_,_), + TyparConstraint.MayResolveMember(trait2,_,_) -> traitsAEquivAux erasureFlag g aenv trait1 trait2 | TyparConstraint.DefaultsTo(_, acty, _), @@ -1298,6 +1299,7 @@ type TyconRefMultiMap<'T>(contents: TyconRefMap<'T list>) = | _ -> [] member m.Add (v, x) = TyconRefMultiMap<'T>(contents.Add v (x :: m.Find v)) + member m.Contents = contents static member Empty = TyconRefMultiMap<'T>(TyconRefMap<_>.Empty) static member OfList vs = (vs, TyconRefMultiMap<'T>.Empty) ||> List.foldBack (fun (x, y) acc -> acc.Add (x, y)) @@ -1515,7 +1517,7 @@ let isVoidTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> let isILAppTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> tcref.IsILTycon | _ -> false) let isNativePtrTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> tyconRefEq g g.nativeptr_tcr tcref | _ -> false) let isByrefTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> tyconRefEq g g.byref_tcr tcref | _ -> false) -let isByrefLikeTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> isByrefLikeTyconRef g tcref | _ -> false) +let isByrefLikeTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> isByrefLikeTyconRef g tcref | _ -> false) #if EXTENSIONTYPING let extensionInfoOfTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref, _) -> tcref.TypeReprInfo | _ -> TNoRepr) #endif @@ -1884,7 +1886,7 @@ and accFreeInTyparConstraints opts cxs acc = and accFreeInTyparConstraint opts tpc acc = match tpc with | TyparConstraint.CoercesTo(typ, _) -> accFreeInType opts typ acc - | TyparConstraint.MayResolveMember (traitInfo, _) -> accFreeInTrait opts traitInfo acc + | TyparConstraint.MayResolveMember (traitInfo, _, _) -> accFreeInTrait opts traitInfo acc | TyparConstraint.DefaultsTo(_, rty, _) -> accFreeInType opts rty acc | TyparConstraint.SimpleChoice(tys, _) -> accFreeInTypes opts tys acc | TyparConstraint.IsEnum(uty, _) -> accFreeInType opts uty acc @@ -1989,7 +1991,7 @@ and accFreeInTyparConstraintsLeftToRight g cxFlag thruFlag acc cxs = and accFreeInTyparConstraintLeftToRight g cxFlag thruFlag acc tpc = match tpc with | TyparConstraint.CoercesTo(typ, _) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc typ - | TyparConstraint.MayResolveMember (traitInfo, _) -> accFreeInTraitLeftToRight g cxFlag thruFlag acc traitInfo + | TyparConstraint.MayResolveMember (traitInfo, _, _) -> accFreeInTraitLeftToRight g cxFlag thruFlag acc traitInfo | TyparConstraint.DefaultsTo(_, rty, _) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc rty | TyparConstraint.SimpleChoice(tys, _) -> accFreeInTypesLeftToRight g cxFlag thruFlag acc tys | TyparConstraint.IsEnum(uty, _) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc uty @@ -3147,7 +3149,7 @@ module DebugPrint = begin match tpc with | TyparConstraint.CoercesTo(typarConstrTyp, _) -> auxTypar2L env tp ^^ wordL (tagText ":>") --- auxTyparConstraintTypL env typarConstrTyp - | TyparConstraint.MayResolveMember(traitInfo, _) -> + | TyparConstraint.MayResolveMember(traitInfo, _, _) -> auxTypar2L env tp ^^ wordL (tagText ":") --- auxTraitL env traitInfo | TyparConstraint.DefaultsTo(_, ty, _) -> wordL (tagText "default") ^^ auxTypar2L env tp ^^ wordL (tagText ":") ^^ auxTypeL env ty diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 38220852ecc..88085981e0d 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -298,6 +298,7 @@ type TyconRefMap<'T> = member Add : TyconRef -> 'T -> TyconRefMap<'T> member Remove : TyconRef -> TyconRefMap<'T> member IsEmpty : bool + member Contents : StampMap<'T> static member Empty : TyconRefMap<'T> static member OfList : (TyconRef * 'T) list -> TyconRefMap<'T> @@ -306,6 +307,7 @@ type TyconRefMap<'T> = type TyconRefMultiMap<'T> = member Find : TyconRef -> 'T list member Add : TyconRef * 'T -> TyconRefMultiMap<'T> + member Contents : TyconRefMap<'T list> static member Empty : TyconRefMultiMap<'T> static member OfList : (TyconRef * 'T) list -> TyconRefMultiMap<'T> @@ -356,6 +358,7 @@ val instType : TyparInst -> TType -> TType val instTypes : TyparInst -> TypeInst -> TypeInst val instTyparConstraints : TyparInst -> TyparConstraint list -> TyparConstraint list val instTrait : TyparInst -> TraitConstraintInfo -> TraitConstraintInfo +val instValRef : TyparInst -> ValRef -> ValRef //------------------------------------------------------------------------- // From typars to types @@ -998,6 +1001,9 @@ type TypeDefMetadata = #endif val metadataOfTycon : Tycon -> TypeDefMetadata +#if EXTENSIONTYPING +val extensionInfoOfTy : TcGlobals -> TType -> TyconRepresentation +#endif val metadataOfTy : TcGlobals -> TType -> TypeDefMetadata val isStringTy : TcGlobals -> TType -> bool diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index bacef03b435..7d19a83e62b 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -1417,7 +1417,7 @@ let rec u_measure_expr st = let p_typar_constraint x st = match x with | TyparConstraint.CoercesTo (a,_) -> p_byte 0 st; p_typ a st - | TyparConstraint.MayResolveMember(traitInfo,_) -> p_byte 1 st; p_trait traitInfo st + | TyparConstraint.MayResolveMember(traitInfo,_,_) -> p_byte 1 st; p_trait traitInfo st | TyparConstraint.DefaultsTo(_,rty,_) -> p_byte 2 st; p_typ rty st | TyparConstraint.SupportsNull _ -> p_byte 3 st | TyparConstraint.IsNonNullableStruct _ -> p_byte 4 st @@ -1435,7 +1435,7 @@ let u_typar_constraint st = let tag = u_byte st match tag with | 0 -> u_typ st |> (fun a _ -> TyparConstraint.CoercesTo (a,range0) ) - | 1 -> u_trait st |> (fun a _ -> TyparConstraint.MayResolveMember(a,range0)) + | 1 -> u_trait st |> (fun a _ -> TyparConstraint.MayResolveMember(a,range0,[])) | 2 -> u_typ st |> (fun a ridx -> TyparConstraint.DefaultsTo(ridx,a,range0)) | 3 -> (fun _ -> TyparConstraint.SupportsNull range0) | 4 -> (fun _ -> TyparConstraint.IsNonNullableStruct range0) diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 95c4b119d95..8565d6d7e91 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -287,6 +287,7 @@ type TcEnv = member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv member tenv.NameEnv = tenv.eNameResEnv member tenv.AccessRights = tenv.eAccessRights + member tenv.GetExtSlns = Some (GetRelevantPossibleExtensionSolutionsToConstraint tenv.NameEnv) /// Compute the value of this computed, cached field let computeAccessRights eAccessPath eInternalsVisibleCompPaths eFamilyType = @@ -570,7 +571,7 @@ type cenv = static member Create (g, isScript, niceNameGen, amap, topCcu, isSig, haveSig, conditionalDefines, tcSink, tcVal) = let infoReader = new InfoReader(g, amap) - let instantiationGenerator m tpsorig = ConstraintSolver.FreshenTypars m tpsorig + let instantiationGenerator m tpsorig = ConstraintSolver.FreshenTypars None m tpsorig // TODO: check 'None' here for env.GetExtSlns let nameResolver = new NameResolver(g, amap, infoReader, instantiationGenerator) { g = g amap = amap @@ -590,11 +591,11 @@ type cenv = compilingCanonicalFslibModuleType = (isSig || not haveSig) && g.compilingFslib conditionalDefines = conditionalDefines } -let CopyAndFixupTypars m rigid tpsorig = - ConstraintSolver.FreshenAndFixupTypars m rigid [] [] tpsorig +let CopyAndFixupTypars getExtSlnsOpt m rigid tpsorig = + ConstraintSolver.FreshenAndFixupTypars getExtSlnsOpt m rigid [] [] tpsorig let UnifyTypes cenv (env: TcEnv) m expectedTy actualTy = - ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g expectedTy) (tryNormalizeMeasureInType cenv.g actualTy) + ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv env.NameEnv cenv.css m (tryNormalizeMeasureInType cenv.g expectedTy) (tryNormalizeMeasureInType cenv.g actualTy) //------------------------------------------------------------------------- // Generate references to the module being generated - used for @@ -702,7 +703,7 @@ let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath env = /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyRefTupleType contextInfo cenv denv m ty ps = +let UnifyRefTupleType contextInfo cenv denv nenv m ty ps = let ptys = if isRefTupleTy cenv.g ty then let ptys = destRefTupleTy cenv.g ty @@ -715,30 +716,30 @@ 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 nenv cenv.css m ty (TType_tuple (tupInfoRef, ptys)) ptys /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyStructTupleType contextInfo cenv denv m ty ps = +let UnifyStructTupleType contextInfo cenv denv nenv m ty ps = let ptys = if isStructTupleTy cenv.g ty then let ptys = destStructTupleTy cenv.g ty if List.length ps = List.length ptys then ptys else NewInferenceTypes ps else NewInferenceTypes ps - AddCxTypeEqualsType contextInfo denv cenv.css m ty (TType_tuple (tupInfoStruct, ptys)) + AddCxTypeEqualsType contextInfo denv nenv cenv.css m ty (TType_tuple (tupInfoStruct, ptys)) ptys /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyFunctionTypeUndoIfFailed cenv denv m ty = +let UnifyFunctionTypeUndoIfFailed cenv denv nenv m ty = match tryDestFunTy cenv.g ty with | None -> let domainTy = NewInferenceType () let resultTy = NewInferenceType () - if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty (domainTy --> resultTy) then + if AddCxTypeEqualsTypeUndoIfFailed denv nenv cenv.css m ty (domainTy --> resultTy) then Some(domainTy, resultTy) else None @@ -746,8 +747,8 @@ let UnifyFunctionTypeUndoIfFailed cenv denv m ty = /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyFunctionType extraInfo cenv denv mFunExpr ty = - match UnifyFunctionTypeUndoIfFailed cenv denv mFunExpr ty with +let UnifyFunctionType extraInfo cenv denv nenv mFunExpr ty = + match UnifyFunctionTypeUndoIfFailed cenv denv nenv mFunExpr ty with | Some res -> res | None -> match extraInfo with @@ -793,13 +794,13 @@ let ReportImplicitlyIgnoredBoolExpression denv m ty expr = | Some expr -> checkExpr m expr | _ -> UnitTypeExpected (denv, ty, m) -let UnifyUnitType cenv denv m ty exprOpt = - if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty cenv.g.unit_ty then +let UnifyUnitType cenv denv nenv m ty exprOpt = + if AddCxTypeEqualsTypeUndoIfFailed denv nenv cenv.css m ty cenv.g.unit_ty then true else let domainTy = NewInferenceType () let resultTy = NewInferenceType () - if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty (domainTy --> resultTy) then + if AddCxTypeEqualsTypeUndoIfFailed denv nenv cenv.css m ty (domainTy --> resultTy) then warning (FunctionValueUnexpected(denv, ty, m)) else if not (typeEquiv cenv.g cenv.g.bool_ty ty) then @@ -1870,33 +1871,33 @@ let MakeAndPublishSimpleVals cenv env m names mergeNamesInOneNameresEnv = // to C<_> occurs then generate C for a fresh type inference variable ?ty. //------------------------------------------------------------------------- -let FreshenTyconRef m rigid (tcref:TyconRef) declaredTyconTypars = +let FreshenTyconRef getExtSlnsOpt m rigid (tcref:TyconRef) declaredTyconTypars = let tpsorig = declaredTyconTypars let tps = copyTypars tpsorig if rigid <> TyparRigidity.Rigid then tps |> List.iter (fun tp -> tp.SetRigidity rigid) - let renaming, tinst = FixupNewTypars m [] [] tpsorig tps + let renaming, tinst = FixupNewTypars getExtSlnsOpt m [] [] tpsorig tps (TType_app(tcref, List.map mkTyparTy tpsorig), tps, renaming, TType_app(tcref, tinst)) -let FreshenPossibleForallTy g m rigid ty = +let FreshenPossibleForallTy getExtSlnsOpt g m rigid ty = let tpsorig, tau = tryDestForallTy g ty if isNil tpsorig then [], [], [], tau else // tps may be have been equated to other tps in equi-recursive type inference and units-of-measure type inference. Normalize them here let tpsorig = NormalizeDeclaredTyparsForEquiRecursiveInference g tpsorig - let tps, renaming, tinst = CopyAndFixupTypars m rigid tpsorig + let tps, renaming, tinst = CopyAndFixupTypars getExtSlnsOpt m rigid tpsorig tpsorig, tps, tinst, instType renaming tau -let infoOfTyconRef m (tcref:TyconRef) = - let tps, renaming, tinst = FreshenTypeInst m (tcref.Typars m) +let FreshenTyconRef2 getExtSlnsOpt m (tcref:TyconRef) = + let tps, renaming, tinst = FreshenTypeInst getExtSlnsOpt m (tcref.Typars m) tps, renaming, tinst, TType_app (tcref, tinst) /// Given a abstract method, which may be a generic method, freshen the type in preparation /// to apply it as a constraint to the method that implements the abstract slot -let FreshenAbstractSlot g amap m synTyparDecls absMethInfo = +let FreshenAbstractSlot getExtSlnsOpt g amap m synTyparDecls absMethInfo = // Work out if an explicit instantiation has been given. If so then the explicit type // parameters will be made rigid and checked for generalization. If not then auto-generalize @@ -1918,7 +1919,7 @@ let FreshenAbstractSlot g amap m synTyparDecls absMethInfo = let ttps = absMethInfo.GetFormalTyparsOfDeclaringType m let ttinst = argsOfAppTy g absMethInfo.EnclosingType let rigid = if typarsFromAbsSlotAreRigid then TyparRigidity.Rigid else TyparRigidity.Flexible - ConstraintSolver.FreshenAndFixupTypars m rigid ttps ttinst fmtps + ConstraintSolver.FreshenAndFixupTypars getExtSlnsOpt m rigid ttps ttinst fmtps // Work out the required type of the member let argTysFromAbsSlot = argtys |> List.mapSquared (instType typarInstFromAbsSlot) @@ -2179,7 +2180,7 @@ module GeneralizationHelpers = TrimUngeneralizableTypars genConstrainedTyparFlag inlineFlag generalizedTypars freeInEnv /// Condense type variables in positive position - let CondenseTypars (cenv, denv:DisplayEnv, generalizedTypars: Typars, tauTy, m) = + let CondenseTypars (cenv, denv:DisplayEnv, generalizedTypars: Typars, tauTy, m, nenv:NameResolutionEnv) = // The type of the value is ty11 * ... * ty1N -> ... -> tyM1 * ... * tyMM -> retTy // This is computed REGARDLESS of the arity of the expression. @@ -2231,27 +2232,28 @@ module GeneralizationHelpers = // Condensation solves type variables eagerly and removes them from the generalization set condensationTypars |> List.iter (fun tp -> - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp) + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv nenv tp) generalizedTypars - let CanonicalizePartialInferenceProblem (cenv, denv, m) tps = + let CanonicalizePartialInferenceProblem (cenv, denv, nenv ,m) tps = // Canonicalize constraints prior to generalization - let csenv = (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) + let csenv = (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv nenv) TryD (fun () -> ConstraintSolver.CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult - let ComputeAndGeneralizeGenericTypars (cenv, - denv:DisplayEnv, - m, - freeInEnv:FreeTypars, - canInferTypars, - genConstrainedTyparFlag, - inlineFlag, - exprOpt, - allDeclaredTypars: Typars, - maxInferredTypars: Typars, - tauTy, + let ComputeAndGeneralizeGenericTypars (cenv, + denv:DisplayEnv, + nenv:NameResolutionEnv, + m, + freeInEnv:FreeTypars, + canInferTypars, + genConstrainedTyparFlag, + inlineFlag, + exprOpt, + allDeclaredTypars:Typars, + maxInferredTypars:Typars, + tauTy, resultFirst) = let allDeclaredTypars = NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g allDeclaredTypars @@ -2269,7 +2271,7 @@ module GeneralizationHelpers = let ty = mkTyparTy tp error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty), m))) - let generalizedTypars = CondenseTypars(cenv, denv, generalizedTypars, tauTy, m) + let generalizedTypars = CondenseTypars(cenv, denv, generalizedTypars, tauTy, m, nenv) let generalizedTypars = if canInferTypars then generalizedTypars @@ -2283,7 +2285,7 @@ module GeneralizationHelpers = generalizedTypars |> List.iter (SetTyparRigid cenv.g denv m) // Generalization removes constraints related to generalized type variables - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv nenv EliminateConstraintsForGeneralizedTypars csenv NoTrace generalizedTypars generalizedTypars @@ -2627,11 +2629,11 @@ module EventDeclarationNormalization = /// Make a copy of the "this" type for a generic object type, e.g. List<'T> --> List<'?> for a fresh inference variable. /// Also adjust the "this" type to take into account whether the type is a struct. -let FreshenObjectArgType cenv m rigid tcref isExtrinsic declaredTyconTypars = +let FreshenObjectArgType cenv getExtSlnsOpt m rigid tcref isExtrinsic declaredTyconTypars = #if EXTENDED_EXTENSION_MEMBERS // indicates if extension members can add additional constraints to type parameters let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy = FreshenTyconRef m (if isExtrinsic then TyparRigidity.Flexible else rigid) tcref declaredTyconTypars #else - let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy = FreshenTyconRef m rigid tcref declaredTyconTypars + let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy = FreshenTyconRef getExtSlnsOpt m rigid tcref declaredTyconTypars #endif // Struct members have a byref 'this' type (unless they are extrinsic extension members) let thisTy = @@ -2680,7 +2682,7 @@ let TcValEarlyGeneralizationConsistencyCheck cenv (env:TcEnv) (v:Val, vrec, tins let tpsorig = NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g tpsorig let tau3 = instType (mkTyparInst tpsorig tinst) tau2 //printfn "tau3 = '%s'" (DebugPrint.showType tau3) - if not (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m tau tau3) then + if not (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m tau tau3) then let txt = bufs (fun buf -> NicePrint.outputQualifiedValSpec env.DisplayEnv buf v) error(Error(FSComp.SR.tcInferredGenericTypeGivesRiseToInconsistency(v.DisplayName, txt), m))) | _ -> () @@ -2698,7 +2700,7 @@ let TcValEarlyGeneralizationConsistencyCheck cenv (env:TcEnv) (v:Val, vrec, tins /// | CtorValUsedAsSuperInit "inherit Panel()" /// | CtorValUsedAsSelfInit "new() = new OwnType(3)" /// | VSlotDirectCall "base.OnClick(eventArgs)" -let TcVal checkAttributes cenv env tpenv (vref:ValRef) optInst optAfterResolution m = +let TcVal getExtSlnsOpt checkAttributes cenv env tpenv (vref:ValRef) optInst optAfterResolution m = let (tpsorig, _, _, _, tinst, _) as res = let v = vref.Deref let vrec = v.RecursiveValInfo @@ -2719,7 +2721,7 @@ let TcVal checkAttributes cenv env tpenv (vref:ValRef) optInst optAfterResolutio // The value may still be generic, e.g. // [] // let Null = null - let tpsorig, _, tinst, tau = FreshenPossibleForallTy cenv.g m TyparRigidity.Flexible vty + let tpsorig, _, tinst, tau = FreshenPossibleForallTy getExtSlnsOpt cenv.g m TyparRigidity.Flexible vty tpsorig, Expr.Const(c, m, tau), isSpecial, tau, tinst, tpenv | None -> @@ -2749,7 +2751,7 @@ let TcVal checkAttributes cenv env tpenv (vref:ValRef) optInst optAfterResolutio tpsorig, NormalValUse, tinst, tau, tpenv | ValInRecScope true | ValNotInRecScope -> - let tpsorig, _, tinst, tau = FreshenPossibleForallTy cenv.g m TyparRigidity.Flexible vty + let tpsorig, _, tinst, tau = FreshenPossibleForallTy getExtSlnsOpt cenv.g m TyparRigidity.Flexible vty tpsorig, NormalValUse, tinst, tau, tpenv // If we have got an explicit instantiation then use that @@ -2770,7 +2772,7 @@ let TcVal checkAttributes cenv env tpenv (vref:ValRef) optInst optAfterResolutio tpsorig, vrefFlags, tinst, tau2, tpenv | ValInRecScope true | ValNotInRecScope -> - let tpsorig, tps, tptys, tau = FreshenPossibleForallTy cenv.g m TyparRigidity.Flexible vty + let tpsorig, tps, tptys, tau = FreshenPossibleForallTy getExtSlnsOpt cenv.g m TyparRigidity.Flexible vty //dprintfn "After Freshen: tau = %s" (Layout.showL (typeL tau)) let (tinst:TypeInst), tpenv = checkTys tpenv (tps |> List.map (fun tp -> tp.Kind)) checkInst tinst @@ -2809,13 +2811,13 @@ let LightweightTcValForUsingInBuildMethodCall g (vref:ValRef) vrefFlags (vrefTyp else match v.LiteralValue with | Some c -> - let _, _, _, tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vty + let _, _, _, tau = FreshenPossibleForallTy None g m TyparRigidity.Flexible vty Expr.Const(c, m, tau), tau | None -> // Instantiate the value let tau = // If we have got an explicit instantiation then use that - let _, tps, tptys, tau = FreshenPossibleForallTy g m TyparRigidity.Flexible vty + let _, tps, tptys, tau = FreshenPossibleForallTy None g m TyparRigidity.Flexible vty if tptys.Length <> vrefTypeInst.Length then error(Error(FSComp.SR.tcTypeParameterArityMismatch(tps.Length, vrefTypeInst.Length), m)); instType (mkTyparInst tps vrefTypeInst) tau @@ -2910,7 +2912,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 env.NameEnv cenv.css m NoTrace actualType flexibleType; flexibleType) // Create a coercion to represent the expansion of the application @@ -2919,7 +2921,7 @@ let MakeApplicableExprWithFlex cenv (env: TcEnv) expr = /// Checks, warnings and constraint assertions for downcasts -let TcRuntimeTypeTest isCast isOperator cenv denv m tgty srcTy = +let TcRuntimeTypeTest isCast isOperator cenv denv nenv m tgty srcTy = if TypeDefinitelySubsumesTypeNoCoercion 0 cenv.g cenv.amap m tgty srcTy then warning(TypeTestUnnecessary(m)) @@ -2931,9 +2933,9 @@ let TcRuntimeTypeTest isCast isOperator cenv denv m tgty srcTy = if isSealedTy cenv.g tgty || isTyparTy cenv.g tgty || not (isInterfaceTy cenv.g srcTy) then if isCast then - AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv cenv.css m NoTrace srcTy tgty + AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv nenv cenv.css m NoTrace srcTy tgty else - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace srcTy tgty + AddCxTypeMustSubsumeType ContextInfo.NoContext denv nenv cenv.css m NoTrace srcTy tgty if isErasedType cenv.g tgty then if isCast then @@ -2947,7 +2949,7 @@ let TcRuntimeTypeTest isCast isOperator cenv denv m tgty srcTy = else warning(Error(FSComp.SR.tcTypeTestLossy(NicePrint.minimalStringOfType denv ety, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll cenv.g ety)), m))) /// Checks, warnings and constraint assertions for upcasts -let TcStaticUpcast cenv denv m tgty srcTy = +let TcStaticUpcast cenv denv nenv m tgty srcTy = if isTyparTy cenv.g tgty then error(IndeterminateStaticCoercion(denv, srcTy, tgty, m)) @@ -2957,7 +2959,7 @@ let TcStaticUpcast cenv denv m tgty srcTy = if typeEquiv cenv.g srcTy tgty then warning(UpcastUnnecessary(m)) - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace tgty srcTy + AddCxTypeMustSubsumeType ContextInfo.NoContext denv nenv cenv.css m NoTrace tgty srcTy @@ -2988,7 +2990,7 @@ let BuildPossiblyConditionalMethodCall cenv env isMutable m isProp minfo valUseF | _ -> #endif let tcVal valref valUse ttypes m = - let _, a, _, b, _, _ = TcVal true cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) None m + let _, a, _, b, _, _ = TcVal env.GetExtSlns true cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) None m a, b BuildMethodCall tcVal cenv.g cenv.amap isMutable m isProp minfo valUseFlags minst objArgs args @@ -3230,7 +3232,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> Exception e | Result getEnumerator_minfo -> - let getEnumerator_minst = FreshenMethInfo m getEnumerator_minfo + let getEnumerator_minst = FreshenMethInfo env.GetExtSlns m getEnumerator_minfo let retTypeOfGetEnumerator = getEnumerator_minfo.GetFSharpReturnTy(cenv.amap, m, getEnumerator_minst) if hasArgs getEnumerator_minfo getEnumerator_minst then err true tyToSearchForGetEnumeratorAndItem else @@ -3238,7 +3240,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> Exception e | Result moveNext_minfo -> - let moveNext_minst = FreshenMethInfo m moveNext_minfo + let moveNext_minst = FreshenMethInfo env.GetExtSlns m moveNext_minfo let retTypeOfMoveNext = moveNext_minfo.GetFSharpReturnTy(cenv.amap, m, moveNext_minst) if not (typeEquiv cenv.g cenv.g.bool_ty retTypeOfMoveNext) then err false retTypeOfGetEnumerator else if hasArgs moveNext_minfo moveNext_minst then err false retTypeOfGetEnumerator else @@ -3247,7 +3249,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> Exception e | Result get_Current_minfo -> - let get_Current_minst = FreshenMethInfo m get_Current_minfo + let get_Current_minst = FreshenMethInfo env.GetExtSlns m get_Current_minfo if hasArgs get_Current_minfo get_Current_minst then err false retTypeOfGetEnumerator else let enumElemTy = get_Current_minfo.GetFSharpReturnTy(cenv.amap, m, get_Current_minst) @@ -3328,7 +3330,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> let probe ty = - if (AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m ty exprty) then + if (AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m ty exprty) then match tryType (mkCoerceExpr(expr, ty, expr.Range, exprty), ty) with | Result res -> Some res | Exception e -> @@ -3355,7 +3357,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr let ConvertArbitraryExprToEnumerable cenv ty (env: TcEnv) (expr:Expr) = let m = expr.Range let enumElemTy = NewInferenceType () - if AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m ( mkSeqTy cenv.g enumElemTy) ty then + if AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m ( mkSeqTy cenv.g enumElemTy) ty then expr, enumElemTy else let enumerableVar, enumerableExpr = mkCompGenLocal m "inputSequence" ty @@ -3383,7 +3385,7 @@ let mkSeqCollect cenv env m enumElemTy genTy lam enumExpr = mkCallSeqCollect cenv.g m enumElemTy genResultTy lam enumExpr let mkSeqUsing cenv (env: TcEnv) m resourceTy genTy resourceExpr lam = - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace cenv.g.system_IDisposable_typ resourceTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace cenv.g.system_IDisposable_typ resourceTy let genResultTy = NewInferenceType () UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) mkCallSeqUsing cenv.g m resourceTy genResultTy resourceExpr lam @@ -4147,14 +4149,14 @@ let GetInstanceMemberThisVariable (v:Val, x) = 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 env.NameEnv cenv.css m NoTrace (mkTyparTy tp') tpenv match c with | WhereTyparDefaultsToType(tp, ty, m) -> let ty', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty let tp', tpenv = TcTypar cenv env newOk tpenv tp - let csenv = MakeConstraintSolverEnv env.eContextInfo cenv.css m env.DisplayEnv + let csenv = MakeConstraintSolverEnv env.eContextInfo cenv.css m env.DisplayEnv env.NameEnv AddConstraint csenv 0 m NoTrace tp' (TyparConstraint.DefaultsTo(ridx, ty', m)) |> CommitOperationResult tpenv @@ -4163,7 +4165,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 env.NameEnv cenv.css m NoTrace ty' (mkTyparTy tp') tpenv | WhereTyparSupportsNull(tp, m) -> checkSimpleConstraint tp m AddCxTypeMustSupportNull @@ -4184,7 +4186,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 env.NameEnv cenv.css m NoTrace (mkTyparTy tp') underlying' tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) @@ -4197,7 +4199,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 env.NameEnv cenv.css m NoTrace (mkTyparTy tp') a' b' tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) @@ -4209,13 +4211,13 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | TTrait(objtys, ".ctor", memberFlags, argtys, returnTy, _) when memberFlags.MemberKind = MemberKind.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 env.NameEnv cenv.css m NoTrace ty tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidNewConstraint(), m)) tpenv | _ -> - AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo + AddCxMethodConstraint env.DisplayEnv env.NameEnv cenv.css m NoTrace traitInfo tpenv and TcPseudoMemberSpec cenv newOk env synTypes tpenv memSpfn m = @@ -4256,7 +4258,7 @@ and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv match tcrefContainerInfo with | Some(MemberOrValContainerInfo(tcref, _, _, _, declaredTyconTypars)) -> let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let _, enclosingDeclaredTypars, _, _, thisTy = FreshenObjectArgType cenv m TyparRigidity.Rigid tcref isExtrinsic declaredTyconTypars + let _, enclosingDeclaredTypars, _, _, thisTy = FreshenObjectArgType cenv env.GetExtSlns m TyparRigidity.Rigid tcref isExtrinsic declaredTyconTypars // An implemented interface type is in terms of the type's type parameters. // We need a signature in terms of the values' type parameters. // let optIntfSlotTy = Option.map (instType renaming) optIntfSlotTy in @@ -4563,7 +4565,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped | 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 env.NameEnv cenv.css m NoTrace ty' (mkTyparTy tp) tp.AsType, tpenv | SynType.StaticConstant (c, m) -> @@ -4873,7 +4875,7 @@ and TcTypeApp cenv newOk checkCxs occ env tpenv m tcref pathTypeArgs (synArgTys: if tcref.Deref.IsProvided then TcProvidedTypeApp cenv env tpenv tcref synArgTys m else #endif - let tps, _, tinst, _ = infoOfTyconRef m tcref + let tps, _, tinst, _ = FreshenTyconRef2 env.GetExtSlns m tcref // If we're not checking constraints, i.e. when we first assert the super/interfaces of a type definition, then just // clear the constraint lists of the freshly generated type variables. A little ugly but fairly localized. @@ -5014,7 +5016,7 @@ and TcSimplePats cenv optArgsOK checkCxs ty env (tpenv, names, takenNames:Set<_ [v], (tpenv, names, takenNames) | SynSimplePats.SimplePats (ps, m) -> - let ptys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv m ty ps + let ptys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv env.NameEnv m ty ps let ps', (tpenv, names, takenNames) = List.mapFold (fun tpenv (ty, e) -> TcSimplePat optArgsOK checkCxs cenv ty env tpenv e) (tpenv, names, takenNames) (List.zip ptys ps) ps', (tpenv, names, takenNames) @@ -5101,7 +5103,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | SynPat.Named (SynPat.IsInst(cty, m), _, _, _, _) -> let srcTy = ty let tgty, tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurence.UseInType env tpenv cty - TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv env.NameEnv m tgty srcTy match pat with | SynPat.IsInst(_, m) -> (fun _ -> TPat_isinst (srcTy, tgty, None, m)), (tpenv, names, takenNames) @@ -5170,7 +5172,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | Item.ActivePatternCase(APElemRef(apinfo, vref, idx)) as item -> let args = match args with SynConstructorArgs.Pats args -> args | _ -> error(Error(FSComp.SR.tcNamedActivePattern(apinfo.ActiveTags.[idx]), m)) // TOTAL/PARTIAL ACTIVE PATTERNS - let _, vexp, _, _, tinst, _ = TcVal true cenv env tpenv vref None None m + let _, vexp, _, _, tinst, _ = TcVal env.GetExtSlns true cenv env tpenv vref None None m let vexp = MakeApplicableExprWithFlex cenv env vexp let vexpty = vexp.Type @@ -5334,7 +5336,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p match vref.LiteralValue with | None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m)) | Some lit -> - let _, _, _, vexpty, _, _ = TcVal true cenv env tpenv vref None None m + let _, _, _, vexpty, _, _ = TcVal env.GetExtSlns true cenv env tpenv vref None None m CheckValAccessible m env.eAccessRights vref CheckFSharpAttributes cenv.g vref.Attribs m |> CommitOperationResult checkNoArgsForLiteral() @@ -5374,7 +5376,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | SynPat.Record (flds, m) -> let tcref, fldsmap, _fldsList = BuildFieldMap cenv env true ty flds m // REVIEW: use _fldsList to type check pattern in code order not field defn order - let _, inst, tinst, gtyp = infoOfTyconRef m tcref + let _, inst, tinst, gtyp = FreshenTyconRef2 env.GetExtSlns m tcref UnifyTypes cenv env m ty gtyp let fields = tcref.TrueInstanceFieldsAsList let ftys = fields |> List.map (fun fsp -> actualTyOfRecdField inst fsp, fsp) @@ -5392,12 +5394,13 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p (fun _ -> TPat_range(c1, c2, m)), (tpenv, names, takenNames) | SynPat.Null m -> - AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace ty + AddCxTypeMustSupportNull env.DisplayEnv env.NameEnv cenv.css m NoTrace ty (fun _ -> TPat_null m), (tpenv, names, takenNames) | SynPat.InstanceMember (_, _, _, _, m) -> errorR(Error(FSComp.SR.tcIllegalPattern(), pat.Range)) (fun _ -> TPat_wild m), (tpenv, names, takenNames) + | SynPat.FromParseError (pat, _) -> suppressErrorReporting (fun () -> TcPatAndRecover warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) (NewErrorType()) pat) @@ -5406,10 +5409,10 @@ and TcPatterns warnOnUpper cenv env vFlags s argtys args = List.mapFold (fun s (ty, pat) -> TcPat warnOnUpper cenv env None vFlags s ty pat) s (List.zip argtys args) -and solveTypAsError cenv denv m ty = +and solveTypAsError cenv denv nenv m ty = let ty2 = NewErrorType () assert((destTyparTy cenv.g ty2).IsFromError) - SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) 0 m NoTrace ty ty2 |> ignore + SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv nenv) 0 m NoTrace ty ty2 |> ignore and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv expr = // This function is motivated by cases like @@ -5457,7 +5460,7 @@ and TcExprOfUnknownType cenv env tpenv expr = and TcExprFlex cenv flex ty (env: TcEnv) tpenv (e: SynExpr) = if flex then let argty = NewInferenceType () - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css e.Range NoTrace ty argty + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css e.Range NoTrace ty argty let e', tpenv = TcExpr cenv argty env tpenv e let e' = mkCoerceIfNeeded cenv.g ty argty e' e', tpenv @@ -5476,7 +5479,7 @@ and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) = // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error errorRecovery e m - solveTypAsError cenv env.DisplayEnv m ty + solveTypAsError cenv env.DisplayEnv env.NameEnv m ty mkThrow m ty (mkOne cenv.g m), tpenv and TcExprNoRecover cenv ty (env: TcEnv) tpenv (expr: SynExpr) = @@ -5501,7 +5504,7 @@ and TcExprOfUnknownTypeThen cenv env tpenv expr delayed = with e -> let m = expr.Range errorRecovery e m - solveTypAsError cenv env.DisplayEnv m exprty + solveTypAsError cenv env.DisplayEnv env.NameEnv m exprty mkThrow m exprty (mkOne cenv.g m), tpenv expr', exprty, tpenv @@ -5531,7 +5534,7 @@ and TcStmtThatCantBeCtorBody cenv env tpenv expr = and TcStmt cenv env tpenv synExpr = let expr, ty, tpenv = TcExprOfUnknownType cenv env tpenv synExpr let m = synExpr.Range - let wasUnit = UnifyUnitType cenv env.DisplayEnv m ty (Some expr) + let wasUnit = UnifyUnitType cenv env.DisplayEnv env.NameEnv m ty (Some expr) if wasUnit then expr, tpenv else @@ -5644,7 +5647,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.MatchLambda (isExnMatch, argm, clauses, spMatch, m) -> // (spMatch, x, matches, isExnMatch, m) -> - let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy + let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv env.NameEnv m overallTy let idv1, idve1 = mkCompGenLocal argm (cenv.synArgNameGenerator.New()) domainTy let envinner = ExitFamilyRegion env let idv2, matchExpr, tpenv = TcAndPatternCompileMatchClauses m argm (if isExnMatch then Throw else ThrowIncompleteMatchException) cenv domainTy resultTy envinner tpenv clauses @@ -5669,7 +5672,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = let e', srcTy, tpenv = TcExprOfUnknownType cenv env tpenv e UnifyTypes cenv env m overallTy cenv.g.bool_ty let tgty, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgty - TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv env.NameEnv m tgty srcTy let e' = mkCallTypeTest cenv.g m tgty e' e', tpenv @@ -5690,8 +5693,8 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.InferredUpcast _ -> overallTy, tpenv | _ -> failwith "upcast" - TcStaticUpcast cenv env.DisplayEnv m tgty srcTy - mkCoerceExpr(e', tgty, m, srcTy), tpenv + TcStaticUpcast cenv env.DisplayEnv env.NameEnv m tgty srcTy + mkCoerceExpr(e', tgty, m, srcTy),tpenv | SynExpr.Downcast(e, _, m) | SynExpr.InferredDowncast (e, m) -> let e', srcTy, tpenv = TcExprOfUnknownType cenv env tpenv e @@ -5703,7 +5706,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = tgty, tpenv, true | SynExpr.InferredDowncast _ -> overallTy, tpenv, false | _ -> failwith "downcast" - TcRuntimeTypeTest (*isCast*)true isOperator cenv env.DisplayEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)true isOperator cenv env.DisplayEnv env.NameEnv m tgty srcTy // TcRuntimeTypeTest ensures tgty is a nominal type. Hence we can insert a check here // based on the nullness semantics of the nominal type. @@ -5711,7 +5714,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = e', tpenv | SynExpr.Null m -> - AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace overallTy + AddCxTypeMustSupportNull env.DisplayEnv env.NameEnv cenv.css m NoTrace overallTy mkNull m overallTy, tpenv | SynExpr.Lazy (e, m) -> @@ -5721,14 +5724,14 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = mkLazyDelayed cenv.g m ety (mkUnitDelayLambda cenv.g m e'), tpenv | SynExpr.Tuple (args, _, m) -> - let argtys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv m overallTy args + let argtys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv env.NameEnv m overallTy args // No subsumption at tuple construction let flexes = argtys |> List.map (fun _ -> false) let args', tpenv = TcExprs cenv env m tpenv flexes argtys args mkRefTupled cenv.g m args' argtys, tpenv | SynExpr.StructTuple (args, _, m) -> - let argtys = UnifyStructTupleType env.eContextInfo cenv env.DisplayEnv m overallTy args + let argtys = UnifyStructTupleType env.eContextInfo cenv env.DisplayEnv env.NameEnv m overallTy args // No subsumption at tuple construction let flexes = argtys |> List.map (fun _ -> false) let args', tpenv = TcExprs cenv env m tpenv flexes argtys args @@ -5842,7 +5845,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = UnifyTypes cenv env m overallTy genCollTy let exprty = NewInferenceType () let genEnumTy = mkSeqTy cenv.g genCollElemTy - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace genEnumTy exprty + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace genEnumTy exprty let expr, tpenv = TcExpr cenv exprty env tpenv comp let expr = mkCoerceIfNeeded cenv.g genEnumTy (tyOfExpr cenv.g expr) expr (if isArray then mkCallSeqToArray else mkCallSeqToList) cenv.g m genCollElemTy @@ -5987,7 +5990,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: 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 = TcExprs cenv env m tpenv flexes argtys args - AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo + AddCxMethodConstraint env.DisplayEnv env.NameEnv cenv.css m NoTrace traitInfo UnifyTypes cenv env m overallTy returnTy Expr.Op(TOp.TraitCall(traitInfo), [], args', m), tpenv @@ -6049,7 +6052,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = and TcIteratedLambdas cenv isFirst (env: TcEnv) overallTy takenNames tpenv e = match e with | SynExpr.Lambda (isMember, isSubsequent, spats, bodyExpr, m) when isMember || isFirst || isSubsequent -> - let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy + let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv env.NameEnv m overallTy let vs, (tpenv, names, takenNames) = TcSimplePats cenv isMember CheckCxs domainTy env (tpenv, Map.empty, takenNames) spats let envinner, _, vspecMap = MakeAndPublishSimpleVals cenv env m names true let byrefs = vspecMap |> Map.map (fun _ v -> isByrefTy cenv.g v.Type, v) @@ -6146,7 +6149,7 @@ and TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv wholeExpr e1 indexArg | Some (path, functionName, indexArgs) -> let operPath = mkSynLidGet mDot path (CompileOpName functionName) let f, fty, tpenv = TcExprOfUnknownType cenv env tpenv operPath - let domainTy, resultTy = UnifyFunctionType (Some mWholeExpr) cenv env.DisplayEnv mWholeExpr fty + let domainTy, resultTy = UnifyFunctionType (Some mWholeExpr) cenv env.DisplayEnv env.NameEnv mWholeExpr fty UnifyTypes cenv env mWholeExpr domainTy e1ty let f' = buildApp cenv (MakeApplicableExprNoFlex cenv f) fty e1' mWholeExpr let delayed = List.foldBack (fun idx acc -> DelayedApp(ExprAtomicFlag.Atomic, idx, mWholeExpr) :: acc) indexArgs delayed // atomic, otherwise no ar.[1] <- xyz @@ -6189,7 +6192,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 env.NameEnv cenv.css mWholeExprOrObjTy NoTrace objTy match arg with | SynExpr.Const (SynConst.Unit, _) -> () @@ -6413,8 +6416,7 @@ and FreshenObjExprAbstractSlot cenv (env: TcEnv) (implty:TType) virtNameAndArity | [(_, absSlot)] -> - let typarsFromAbsSlotAreRigid, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot - = FreshenAbstractSlot cenv.g cenv.amap mBinding synTyparDecls absSlot + let typarsFromAbsSlotAreRigid, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot = FreshenAbstractSlot env.GetExtSlns cenv.g cenv.amap mBinding synTyparDecls absSlot // Work out the required type of the member let bindingTy = implty --> (mkMethodTy cenv.g argTysFromAbsSlot retTyFromAbsSlot) @@ -6467,6 +6469,7 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo, bind) = match NameMap.range nameToPrelimValSchemeMap with | [PrelimValScheme1(id, _, _, _, _, _, _, _, _, _, _)] -> let denv = env.DisplayEnv + let nenv = env.NameEnv let declaredTypars = match absSlotInfo with @@ -6475,11 +6478,11 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo, bind) = | _ -> declaredTypars // Canonicalize constraints prior to generalization - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, m) declaredTypars + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, nenv, m) declaredTypars let freeInEnv = GeneralizationHelpers.ComputeUngeneralizableTypars env - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, m, freeInEnv, false, CanGeneralizeConstrainedTypars, inlineFlag, Some(rhsExpr), declaredTypars, [], bindingTy, false) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, nenv, m, freeInEnv, false, CanGeneralizeConstrainedTypars, inlineFlag, Some(rhsExpr), declaredTypars, [], bindingTy, false) let declaredTypars = ChooseCanonicalDeclaredTyparsAfterInference cenv.g env.DisplayEnv declaredTypars m let generalizedTypars = PlaceTyparsInDeclarationOrder declaredTypars generalizedTypars @@ -6697,7 +6700,7 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, /// Check a constant string expression. It might be a 'printf' format string and TcConstStringExpr cenv overallTy env m tpenv s = - if (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy cenv.g.string_ty) then + if (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m overallTy cenv.g.string_ty) then mkString cenv.g m s, tpenv else let aty = NewInferenceType () @@ -6706,7 +6709,7 @@ and TcConstStringExpr cenv overallTy env m tpenv s = let dty = NewInferenceType () let ety = NewInferenceType () let ty' = mkPrintfFormatTy cenv.g aty bty cty dty ety - if (not (isObjTy cenv.g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy ty') then + if (not (isObjTy cenv.g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m overallTy ty') then // Parse the format string to work out the phantom types let source = match cenv.tcSink.CurrentSink with None -> None | Some sink -> sink.CurrentSource let normalizedString = (s.Replace("\r\n", "\n").Replace("\r", "\n")) @@ -6833,7 +6836,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr | [] -> [] | _ -> let tcref, _, fldsList = BuildFieldMap cenv env hasOrigExpr overallTy flds mWholeExpr - let _, _, _, gtyp = infoOfTyconRef mWholeExpr tcref + let _, _, _, gtyp = FreshenTyconRef2 env.GetExtSlns mWholeExpr tcref UnifyTypes cenv env mWholeExpr overallTy gtyp [ for n, v in fldsList do @@ -8198,7 +8201,7 @@ and TcSequenceExpression cenv env tpenv comp 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 env.NameEnv cenv.css m NoTrace genOuterTy genExprTy Some(mkCoerceExpr(resultExpr, genOuterTy, m, genExprTy), tpenv) | SynExpr.YieldOrReturn((isYield, _), yieldExpr, m) -> @@ -8258,7 +8261,8 @@ and Propagate cenv overallTy env tpenv (expr: ApplicableExpr) exprty delayed = | DelayedApp (_, arg, mExprAndArg) :: delayedList' -> let denv = env.DisplayEnv - match UnifyFunctionTypeUndoIfFailed cenv denv mExpr exprty with + let nenv = env.NameEnv + match UnifyFunctionTypeUndoIfFailed cenv denv nenv mExpr exprty with | Some (_, resultTy) -> propagate delayedList' mExprAndArg resultTy | None -> @@ -8336,11 +8340,12 @@ and delayRest rest mPrior delayed = and TcFunctionApplicationThen cenv overallTy env tpenv mExprAndArg expr exprty (synArg: SynExpr) atomicFlag delayed = let denv = env.DisplayEnv + let nenv = env.NameEnv let mArg = synArg.Range let mFunExpr = expr.Range // If the type of 'synArg' unifies as a function type, then this is a function application, otherwise // it is an error or a computation expression - match UnifyFunctionTypeUndoIfFailed cenv denv mFunExpr exprty with + match UnifyFunctionTypeUndoIfFailed cenv denv nenv mFunExpr exprty with | Some (domainTy, resultTy) -> // Notice the special case 'seq { ... }'. In this case 'seq' is actually a function in the F# library. @@ -8415,7 +8420,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del mkConstrApp, [ucaseAppTy], [ for (s, m) in apinfo.ActiveTagsWithRanges -> mkSynId m s ] | _ -> let ucref = mkChoiceCaseRef cenv.g mItem aparity n - let _, _, tinst, _ = infoOfTyconRef mItem ucref.TyconRef + let _, _, tinst, _ = FreshenTyconRef2 env.GetExtSlns mItem ucref.TyconRef let ucinfo = UnionCaseInfo(tinst, ucref) ApplyUnionCaseOrExnTypes mItem cenv env ucaseAppTy (Item.UnionCase(ucinfo, false)) | _ -> @@ -8776,7 +8781,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del let resultExpr, tpenv = TcDelayed cenv intermediateTy env tpenv mItem (MakeApplicableExprNoFlex cenv expr) (tyOfExpr cenv.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 env.NameEnv 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 @@ -8831,7 +8836,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // - it isn't a CtorValUsedAsSelfInit // - it isn't a VSlotDirectCall (uses of base values do not take type arguments let checkTys tpenv kinds = TcTypesOrMeasures (Some kinds) cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tys mItem - let _, vexp, isSpecial, _, _, tpenv = TcVal true cenv env tpenv vref (Some (NormalValUse, checkTys)) (Some afterResolution) mItem + let _, vexp, isSpecial, _, _, tpenv = TcVal env.GetExtSlns true cenv env tpenv vref (Some (NormalValUse, checkTys)) (Some afterResolution) mItem let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vexp else MakeApplicableExprWithFlex cenv env vexp) // We need to eventually record the type resolution for an expression, but this is done // inside PropagateThenTcDelayed, so we don't have to explicitly call 'CallExprHasTypeSink' here @@ -8839,7 +8844,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // Value get | _ -> - let _, vexp, isSpecial, _, _, tpenv = TcVal true cenv env tpenv vref None (Some afterResolution) mItem + let _, vexp, isSpecial, _, _, tpenv = TcVal env.GetExtSlns true cenv env tpenv vref None (Some afterResolution) mItem let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vexp else MakeApplicableExprWithFlex cenv env vexp) PropagateThenTcDelayed cenv overallTy env tpenv mItem vexpFlex vexpFlex.Type ExprAtomicFlag.Atomic delayed @@ -8984,7 +8989,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela // Canonicalize inference problem prior to '.' lookup on variable types if isTyparTy cenv.g objExprTy then - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, env.DisplayEnv, mExprAndLongId) (freeInTypeLeftToRight cenv.g false objExprTy) + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, env.DisplayEnv, env.NameEnv, mExprAndLongId) (freeInTypeLeftToRight cenv.g false objExprTy) let item, mItem, rest, afterResolution = ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver mExprAndLongId ad env.eNameResEnv objExprTy longId findFlag false let mExprAndItem = unionRanges mObjExpr mItem @@ -9049,7 +9054,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela RecdFieldInstanceChecks cenv.g cenv.amap ad mItem rfinfo let tgty = rfinfo.EnclosingType let valu = isStructTy cenv.g tgty - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem NoTrace tgty objExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css mItem NoTrace tgty objExprTy let objExpr = if valu then objExpr else mkCoerceExpr(objExpr, tgty, mExprAndItem, objExprTy) let fieldTy = rfinfo.FieldType match delayed with @@ -9222,6 +9227,7 @@ and TcMethodApplication = let denv = env.DisplayEnv + let nenv = env.NameEnv let isSimpleFormalArg (isParamArrayArg, isOutArg, optArgInfo: OptionalArgInfo, callerInfoInfo: CallerInfoInfo, _reflArgInfo: ReflectedArgInfo) = not isParamArrayArg && not isOutArg && not optArgInfo.IsOptional && callerInfoInfo = NoCallerInfo @@ -9340,7 +9346,7 @@ and TcMethodApplication let curriedArgTys = GenerateMatchingSimpleArgumentTypes calledMeth let returnTy = (exprTy, curriedArgTys) ||> List.fold (fun exprTy argTys -> - let domainTy, resultTy = UnifyFunctionType None cenv denv mMethExpr exprTy + let domainTy, resultTy = UnifyFunctionType None cenv denv nenv mMethExpr exprTy UnifyTypes cenv env mMethExpr domainTy (mkRefTupledTy cenv.g argTys) resultTy) curriedArgTys, returnTy @@ -9379,7 +9385,7 @@ and TcMethodApplication // type we assume the number of arguments is just "1". | None, _ -> - let domainTy, returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy + let domainTy, returnTy = UnifyFunctionType None cenv denv nenv mMethExpr exprTy let argTys = if isUnitTy cenv.g domainTy then [] else tryDestRefTupleTy cenv.g domainTy // Only apply this rule if a candidate method exists with this number of arguments let argTys = @@ -9401,12 +9407,12 @@ and TcMethodApplication let callerArgs = List.zip unnamedCurriedCallerArgs namedCurriedCallerArgs let makeOneCalledMeth (minfo, pinfoOpt, usesParamArrayConversion) = - let minst = FreshenMethInfo mItem minfo + let minst = FreshenMethInfo env.GetExtSlns mItem minfo let callerTyArgs = match tyargsOpt with | Some tyargs -> minfo.AdjustUserTypeInstForFSharpStyleIndexedExtensionMembers(tyargs) | None -> minst - CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt) + CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo env.GetExtSlns, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt) let preArgumentTypeCheckingCalledMethGroup = [ for (minfo, pinfoOpt) in candidateMethsAndProps do @@ -9415,8 +9421,8 @@ and TcMethodApplication if meth.UsesParamArrayConversion then yield makeOneCalledMeth (minfo, pinfoOpt, false) ] - let uniquelyResolved = - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv + let uniquelyResolved = + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv nenv let res = UnifyUniqueOverloading csenv callerArgCounts methodName ad preArgumentTypeCheckingCalledMethGroup returnTy match res with @@ -9450,7 +9456,7 @@ and TcMethodApplication | [calledMeth] -> UnifyMatchingSimpleArgumentTypes exprTy calledMeth | _ -> - let domainTy, returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy + let domainTy, returnTy = UnifyFunctionType None cenv denv nenv mMethExpr exprTy let argTys = if isUnitTy cenv.g domainTy then [] else tryDestRefTupleTy cenv.g domainTy // Only apply this rule if a candidate method exists with this number of arguments let argTys = @@ -9479,7 +9485,7 @@ and TcMethodApplication match ExamineMethodForLambdaPropagation meth with | Some (unnamedInfo, namedInfo) -> let calledObjArgTys = meth.CalledObjArgTys(mMethExpr) - if (calledObjArgTys, callerObjArgTys) ||> Seq.forall2 (fun calledTy callerTy -> AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv cenv.css mMethExpr calledTy callerTy) then + if (calledObjArgTys, callerObjArgTys) ||> Seq.forall2 (fun calledTy callerTy -> AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv nenv cenv.css mMethExpr calledTy callerTy) then yield (List.toArraySquared unnamedInfo, List.toArraySquared namedInfo) | None -> () |] else @@ -9505,15 +9511,15 @@ and TcMethodApplication match tyargsOpt with | Some tyargs -> minfo.AdjustUserTypeInstForFSharpStyleIndexedExtensionMembers(tyargs) | None -> minst - CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt)) + CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo env.GetExtSlns, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt)) let callerArgCounts = (unnamedCurriedCallerArgs.Length, namedCurriedCallerArgs.Length) - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv nenv // Commit unassociated constraints prior to member overload resolution where there is ambiguity // about the possible target of the call. if not uniquelyResolved then - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, mItem) + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, nenv, mItem) (//freeInTypeLeftToRight cenv.g false returnTy @ (unnamedCurriedCallerArgs |> List.collectSquared (fun callerArg -> freeInTypeLeftToRight cenv.g false callerArg.Type))) @@ -9594,7 +9600,7 @@ and TcMethodApplication typeEquiv cenv.g finalCalledMethInfo.EnclosingType cenv.g.obj_ty && (finalCalledMethInfo.LogicalName = "GetHashCode" || finalCalledMethInfo.LogicalName = "Equals")) then - objArgs |> List.iter (fun expr -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace (tyOfExpr cenv.g expr)) + objArgs |> List.iter (fun expr -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv env.NameEnv 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. @@ -9605,7 +9611,7 @@ and TcMethodApplication HasHeadType cenv.g cenv.g.tcref_System_Collections_Generic_IEqualityComparer ty)) then match argsOfAppTy cenv.g finalCalledMethInfo.EnclosingType with - | [dty; _] -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace dty + | [dty; _] -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv env.NameEnv cenv.css mMethExpr NoTrace dty | _ -> () end @@ -10008,9 +10014,9 @@ and TcMethodArg cenv env (lambdaPropagationInfo, tpenv) (lambdaPropagationInfo if col |> ListSet.setify (typeEquiv cenv.g) |> isSingleton then let calledLambdaArgTy = col.[0] // Force the caller to be a function type. - match UnifyFunctionTypeUndoIfFailed cenv env.DisplayEnv mArg callerLambdaTy with + match UnifyFunctionTypeUndoIfFailed cenv env.DisplayEnv env.NameEnv mArg callerLambdaTy with | Some (callerLambdaDomainTy, callerLambdaRangeTy) -> - if AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css mArg calledLambdaArgTy callerLambdaDomainTy then + if AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css mArg calledLambdaArgTy callerLambdaDomainTy then loop callerLambdaRangeTy (lambdaVarNum + 1) | None -> () loop argTy 0 @@ -10028,7 +10034,7 @@ and TcMethodArg cenv env (lambdaPropagationInfo, tpenv) (lambdaPropagationInfo | NoInfo | CallerLambdaHasArgTypes _ -> yield info | CalledArgMatchesType adjustedCalledTy -> - if AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed env.DisplayEnv cenv.css mArg adjustedCalledTy argTy then + if AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed env.DisplayEnv env.NameEnv cenv.css mArg adjustedCalledTy argTy then yield info |] CallerArg(argTy, mArg, isOpt, e'), (lambdaPropagationInfo, tpenv) @@ -10374,7 +10380,7 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt else TcExprThatCantBeCtorBody cenv overallExprTy envinner tpenv rhsExpr) if bkind = StandaloneExpression && not cenv.isScript then - UnifyUnitType cenv env.DisplayEnv mBinding overallPatTy (Some rhsExprChecked) |> ignore + UnifyUnitType cenv env.DisplayEnv env.NameEnv mBinding overallPatTy (Some rhsExprChecked) |> ignore // Fix up the r.h.s. expression for 'fixed' let rhsExprChecked = @@ -10589,7 +10595,7 @@ and TcAttribute canFail cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = let propNameItem = Item.SetterArg(id, setterItem) CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, propNameItem, propNameItem, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, ad) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace argty argtyv + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace argty argtyv AttribNamedArg(nm, argty, isProp, mkAttribExpr callerArgExpr)) @@ -10655,13 +10661,14 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds, bindsm, sco // Canonicalize constraints prior to generalization let denv = env.DisplayEnv - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, bindsm) + let nenv = env.NameEnv + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, nenv, bindsm) (binds' |> List.collect (fun tbinfo -> let (CheckedBindingInfo(_, _, _, _, flex, _, _, _, tauTy, _, _, _, _, _)) = tbinfo let (ExplicitTyparInfo(_, declaredTypars, _)) = flex let maxInferredTypars = (freeInTypeLeftToRight cenv.g false tauTy) declaredTypars @ maxInferredTypars)) - + let nenv = env.NameEnv let lazyFreeInEnv = lazy (GeneralizationHelpers.ComputeUngeneralizableTypars env) // Generalize the bindings... @@ -10680,7 +10687,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds, bindsm, sco [] else let freeInEnv = lazyFreeInEnv.Force() - GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, m, freeInEnv, canInferTypars, GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl(declKind), inlineFlag, Some rhsExpr, allDeclaredTypars, maxInferredTypars, tauTy, false) + GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, nenv, m, freeInEnv, canInferTypars, GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl(declKind), inlineFlag, Some rhsExpr, allDeclaredTypars, maxInferredTypars, tauTy, false) let prelimValSchemes2 = GeneralizeVals cenv denv enclosingDeclaredTypars generalizedTypars nameToPrelimValSchemeMap @@ -10742,7 +10749,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds, bindsm, sco let mkCleanup (bodyExpr, bodyExprTy) = if isUse && not isFixed then (allValsDefinedByPattern, (bodyExpr, bodyExprTy)) ||> List.foldBack (fun v (bodyExpr, bodyExprTy) -> - AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css v.Range NoTrace cenv.g.system_IDisposable_typ v.Type + AddCxTypeMustSubsumeType ContextInfo.NoContext denv nenv cenv.css v.Range NoTrace cenv.g.system_IDisposable_typ v.Type let cleanupE = BuildDisposableCleanup cenv env m v mkTryFinally cenv.g (bodyExpr, cleanupE, m, bodyExprTy, SequencePointInBodyOfTry, NoSequencePointAtFinally), bodyExprTy) else @@ -10802,7 +10809,7 @@ and ApplyTypesFromArgumentPatterns (cenv, env, optArgsOK, ty, m, tpenv, Normaliz | _ -> () | pushedPat :: morePushedPats -> - let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m ty + let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv env.NameEnv m ty // We apply the type information from the patterns by type checking the // "simple" patterns against 'domainTy'. They get re-typechecked later. ignore (TcSimplePats cenv optArgsOK CheckCxs domainTy env (tpenv, Map.empty, Set.empty) pushedPat) @@ -10874,7 +10881,7 @@ and ApplyAbstractSlotInference (cenv:cenv) (envinner:TcEnv) (bindingTy, m, synTy let uniqueAbstractMeth = uniqueAbstractMeth.Instantiate(cenv.amap, m, renaming) let typarsFromAbsSlotAreRigid, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot = - FreshenAbstractSlot cenv.g cenv.amap m synTyparDecls uniqueAbstractMeth + FreshenAbstractSlot None cenv.g cenv.amap m synTyparDecls uniqueAbstractMeth let declaredTypars = (if typarsFromAbsSlotAreRigid then typarsFromAbsSlot else declaredTypars) @@ -10931,7 +10938,7 @@ and ApplyAbstractSlotInference (cenv:cenv) (envinner:TcEnv) (bindingTy, m, synTy let uniqueAbstractMeth = uniqueAbstractMeth.Instantiate(cenv.amap, m, renaming) let _, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot = - FreshenAbstractSlot cenv.g cenv.amap m synTyparDecls uniqueAbstractMeth + FreshenAbstractSlot None cenv.g cenv.amap m synTyparDecls uniqueAbstractMeth if not (isNil typarsFromAbsSlot) then errorR(InternalError("Unexpected generic property", memberId.idRange)) @@ -10999,7 +11006,7 @@ and AnalyzeRecursiveStaticMemberOrValDecl (cenv, envinner: TcEnv, tpenv, declKin error(Error(FSComp.SR.tcConstructorsDisallowedInExceptionAugmentation(), id.idRange)) let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let _, enclosingDeclaredTypars, _, objTy, thisTy = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars + let _, enclosingDeclaredTypars, _, objTy, thisTy = FreshenObjectArgType cenv None mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars let envinner = AddDeclaredTypars CheckForDuplicateTypars enclosingDeclaredTypars envinner let envinner = MakeInnerEnvForTyconRef cenv envinner tcref isExtrinsic @@ -11064,7 +11071,7 @@ and AnalyzeRecursiveInstanceMemberDecl (cenv, envinner: TcEnv, tpenv, declKind, // The type being augmented tells us the type of 'this' let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy, thisTy = FreshenObjectArgType cenv mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars + let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy, thisTy = FreshenObjectArgType cenv None mBinding TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars let envinner = AddDeclaredTypars CheckForDuplicateTypars enclosingDeclaredTypars envinner @@ -11320,7 +11327,7 @@ and TcLetrecBinding reqdThisValTy, (mkAppTy enclosingTyconRef (List.map mkTyparTy enclosingDeclaredTypars)), vspec.Range | Some thisVal -> reqdThisValTy, thisVal.Type, thisVal.Range - if not (AddCxTypeEqualsTypeUndoIfFailed envRec.DisplayEnv cenv.css rangeForCheck actualThisValTy reqdThisValTy) then + if not (AddCxTypeEqualsTypeUndoIfFailed envRec.DisplayEnv envRec.NameEnv cenv.css rangeForCheck actualThisValTy reqdThisValTy) then errorR (Error(FSComp.SR.tcNonUniformMemberUse vspec.DisplayName, vspec.Range)) let preGeneralizationRecBind = @@ -11348,6 +11355,7 @@ and TcIncrementalLetRecGeneralization cenv scopem uncheckedRecBindsTable : Map) = let denv = envNonRec.DisplayEnv + let nenv = envNonRec.NameEnv // recompute the free-in-environment in case any type variables have been instantiated let freeInEnv = GeneralizationHelpers.ComputeUngeneralizableTypars envNonRec @@ -11491,9 +11499,9 @@ and TcIncrementalLetRecGeneralization cenv scopem else let supportForBindings = newGeneralizableBindings |> List.collect (TcLetrecComputeSupportForBinding cenv) - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, scopem) supportForBindings + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, nenv, scopem) supportForBindings - let generalizedTyparsL = newGeneralizableBindings |> List.map (TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv) + let generalizedTyparsL = newGeneralizableBindings |> List.map (TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv envNonRec.NameEnv) // Generalize the bindings. let newGeneralizedRecBinds = (generalizedTyparsL, newGeneralizableBindings) ||> List.map2 (TcLetrecGeneralizeBinding cenv denv ) @@ -11513,7 +11521,7 @@ and TcIncrementalLetRecGeneralization cenv scopem //------------------------------------------------------------------------- /// Compute the type variables which may be generalized and perform the generalization -and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgrbind : PreGeneralizationRecursiveBinding) = +and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (nenv : NameResolutionEnv) (pgrbind : PreGeneralizationRecursiveBinding) = let freeInEnv = Zset.diff freeInEnv (Zset.ofList typarOrder (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) @@ -11528,7 +11536,7 @@ and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgr // two declared type variables. So we now check that, for each binding, the declared // type variables can be unified with a rigid version of the same and undo the results // of this unification. - ConstraintSolver.CheckDeclaredTypars denv cenv.css m rigidCopyOfDeclaredTypars declaredTypars + ConstraintSolver.CheckDeclaredTypars denv nenv cenv.css m rigidCopyOfDeclaredTypars declaredTypars let memFlagsOpt = vspec.MemberInfo |> Option.map (fun memInfo -> memInfo.MemberFlags) let isCtor = (match memFlagsOpt with None -> false | Some memberFlags -> memberFlags.MemberKind = MemberKind.Constructor) @@ -11540,7 +11548,7 @@ and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgr let maxInferredTypars = freeInTypeLeftToRight cenv.g false tau let canGeneralizeConstrained = GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl rbinfo.DeclKind - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars (cenv, denv, m, freeInEnv, canInferTypars, canGeneralizeConstrained, inlineFlag, Some(expr), allDeclaredTypars, maxInferredTypars, tau, isCtor) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars (cenv, denv, nenv, m, freeInEnv, canInferTypars, canGeneralizeConstrained, inlineFlag, Some(expr), allDeclaredTypars, maxInferredTypars,tau,isCtor) generalizedTypars /// Compute the type variables which may have member constraints that need to be canonicalized prior to generalization @@ -11769,6 +11777,7 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF let valinfos, tpenv = TcValSpec cenv env declKind newOk containerInfo memFlagsOpt None tpenv valSpfn attrs let denv = env.DisplayEnv + let nenv = env.NameEnv (tpenv, valinfos) ||> List.mapFold (fun tpenv valSpecResult -> @@ -11782,7 +11791,7 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF let flex = ExplicitTyparInfo(declaredTypars, declaredTypars, synCanInferTypars) - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, id.idRange, emptyFreeTypars, canInferTypars, CanGeneralizeConstrainedTypars, inlineFlag, None, allDeclaredTypars, freeInType, ty, false) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, nenv, id.idRange, emptyFreeTypars, canInferTypars, CanGeneralizeConstrainedTypars, inlineFlag, None, allDeclaredTypars,freeInType, ty, false) let valscheme1 = PrelimValScheme1(id, flex, ty, Some(partialValReprInfo), memberInfoOpt, mutableFlag, inlineFlag, NormalVal, noArgOrRetAttribs, vis, false) @@ -12979,7 +12988,7 @@ module MutRecBindingChecking = AddLocalTyconRefs true cenv.g cenv.amap tcref.Range [tcref] innitalEnvForTycon // Make fresh version of the class type for type checking the members and lets * - let _, copyOfTyconTypars, _, objTy, thisTy = FreshenObjectArgType cenv tcref.Range TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars + let _, copyOfTyconTypars, _, objTy, thisTy = FreshenObjectArgType cenv None tcref.Range TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars // The basic iteration over the declarations in a single type definition @@ -13588,6 +13597,7 @@ module MutRecBindingChecking = let TcMutRecDefns_Phase2_Bindings cenv envInitial tpenv bindsm scopem mutRecNSInfo (envMutRecPrelimWithReprs: TcEnv) (mutRecDefns: MutRecDefnsPhase2Info) = let g = cenv.g let denv = envMutRecPrelimWithReprs.DisplayEnv + let nenv = envMutRecPrelimWithReprs.NameEnv // Phase2A: create member prelimRecValues for "recursive" items, i.e. ctor val and member vals // Phase2A: also processes their arg patterns - collecting type assertions @@ -13696,7 +13706,7 @@ module MutRecBindingChecking = for tp in unsolvedTyparsForRecursiveBlockInvolvingGeneralizedVariables do //printfn "solving unsolvedTyparsInvolvingGeneralizedVariable : %s #%d" tp.DisplayName tp.Stamp if (tp.Rigidity <> TyparRigidity.Rigid) && not tp.IsSolved then - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv nenv tp // Now that we know what we've generalized we can adjust the recursive references let defnsCs = TcMutRecBindings_Phase2C_FixupRecursiveReferences cenv (denv, defnsBs, generalizedTyparsForRecursiveBlock, generalizedRecBinds, scopem) @@ -16891,11 +16901,11 @@ let rec IterTyconsOfModuleOrNamespaceType f (mty:ModuleOrNamespaceType) = // Defaults get applied before the module signature is checked and before the implementation conditions on virtuals/overrides. // Defaults get applied in priority order. Defaults listed last get priority 0 (lowest), 2nd last priority 1 etc. -let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs = +let ApplyDefaults cenv g denvAtEnd nenvAtEnd m mexpr extraAttribs = try let unsolved = Microsoft.FSharp.Compiler.FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd (mexpr, extraAttribs) - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denvAtEnd, m) unsolved + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denvAtEnd, nenvAtEnd, m) unsolved let applyDefaults priority = unsolved |> List.iter (fun tp -> @@ -16907,9 +16917,9 @@ let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs = | TyparConstraint.DefaultsTo(priority2, ty2, m) when priority2 = priority -> let ty1 = mkTyparTy tp if not tp.IsSolved && not (typeEquiv cenv.g ty1 ty2) then - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denvAtEnd + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denvAtEnd nenvAtEnd TryD (fun () -> ConstraintSolver.SolveTyparEqualsTyp csenv 0 m NoTrace ty1 ty2) - (fun e -> solveTypAsError cenv denvAtEnd m ty1 + (fun e -> solveTypAsError cenv denvAtEnd nenvAtEnd m ty1 ErrorD(ErrorFromApplyingDefault(g, denvAtEnd, tp, ty2, e, m))) |> RaiseOperationResult | _ -> ())) @@ -16921,7 +16931,7 @@ let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs = unsolved |> List.iter (fun tp -> if not tp.IsSolved then if (tp.StaticReq <> NoStaticReq) then - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp) + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd nenvAtEnd tp) with e -> errorRecovery e m let CheckValueRestriction denvAtEnd rootSigOpt implFileTypePriorToSig m = @@ -16944,12 +16954,12 @@ let CheckValueRestriction denvAtEnd rootSigOpt implFileTypePriorToSig m = try check implFileTypePriorToSig with e -> errorRecovery e m -let SolveInternalUnknowns g cenv denvAtEnd mexpr extraAttribs = +let SolveInternalUnknowns g cenv denvAtEnd nenv mexpr extraAttribs = let unsolved = Microsoft.FSharp.Compiler.FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd (mexpr, extraAttribs) unsolved |> List.iter (fun tp -> if (tp.Rigidity <> TyparRigidity.Rigid) && not tp.IsSolved then - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp) + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd nenv tp) let CheckModuleSignature g cenv m denvAtEnd rootSigOpt implFileTypePriorToSig implFileSpecPriorToSig mexpr = match rootSigOpt with @@ -17015,6 +17025,7 @@ let TypeCheckOneImplFile netModuleAttrs = List.map snd netModuleAttrs assemblyAttrs = List.map snd assemblyAttrs} let denvAtEnd = envAtEnd.DisplayEnv + let nenvAtEnd = envAtEnd.NameEnv let m = qualNameOfFile.Range // This is a fake module spec @@ -17023,7 +17034,7 @@ let TypeCheckOneImplFile let extraAttribs = topAttrs.mainMethodAttrs@topAttrs.netModuleAttrs@topAttrs.assemblyAttrs conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs) + ApplyDefaults cenv g denvAtEnd nenvAtEnd m mexpr extraAttribs) // Check completion of all classes defined across this file. // NOTE: this is not a great technique if inner signatures are permitted to hide @@ -17038,7 +17049,7 @@ let TypeCheckOneImplFile // Solve unsolved internal type variables conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - SolveInternalUnknowns g cenv denvAtEnd mexpr extraAttribs) + SolveInternalUnknowns g cenv denvAtEnd nenvAtEnd mexpr extraAttribs) // Check the module matches the signature let implFileExprAfterSig = diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index ceb8ca810b0..12edd73a927 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -143,7 +143,7 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = match tpc with | TyparConstraint.CoercesTo(x,m) -> join m x,m - | TyparConstraint.MayResolveMember(TTrait(_,nm,_,_,_,_),m) -> + | TyparConstraint.MayResolveMember(TTrait(_,nm,_,_,_,_),m,_) -> errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInOverloadedOperator(DemangleOperatorName nm),m)) maxSoFar,m | TyparConstraint.SimpleChoice(_,m) -> diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs index 5984d6ef1bc..e7fcdf5c8f0 100644 --- a/src/fsharp/fsc.fs +++ b/src/fsharp/fsc.fs @@ -1791,15 +1791,15 @@ let main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinarie // Type check the inputs let inputs = inputs |> List.map fst - let tcState, topAttrs, typedAssembly, _tcEnvAtEnd = + let tcState, topAttrs, typedAssembly, tcEnvAtEnd = TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, inputs, exiter) AbortOnError(errorLogger, exiter) ReportTime tcConfig "Typechecked" - Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter) + Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter, tcEnvAtEnd.NameEnv) -let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter)) = +let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter, nenv)) = if tcConfig.typeCheckOnly then exiter.Exit 0 @@ -1845,7 +1845,7 @@ let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, gener end // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter) + Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter, nenv) // set up typecheck for given AST without parsing any command line parameters @@ -1895,7 +1895,7 @@ let main1OfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyNam use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck) let tcEnv0 = GetInitialTcEnv (assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals) - let tcState,topAttrs,typedAssembly,_tcEnvAtEnd = + let tcState,topAttrs,typedAssembly,tcEnvAtEnd = TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, inputs,exiter) let generatedCcu = tcState.Ccu @@ -1915,11 +1915,11 @@ let main1OfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyNam // Pass on only the minimum information required for the next phase to ensure GC kicks in. // In principle the JIT should be able to do good liveness analysis to clean things up, but the // data structures involved here are so large we can't take the risk. - Args(ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedAssembly, topAttrs, pdbFile, assemblyName, assemVerFromAttrib, signingInfo ,exiter) + Args(ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedAssembly, topAttrs, pdbFile, assemblyName, assemVerFromAttrib, signingInfo ,exiter, tcEnvAtEnd.NameEnv) /// Phase 2a: encode signature data, optimize, encode optimization data -let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, errorLogger: ErrorLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter)) = +let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, errorLogger: ErrorLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter, nenv)) = // Encode the signature data ReportTime tcConfig ("Encode Interface Data") @@ -1936,13 +1936,13 @@ let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlo use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Optimize let optEnv0 = GetInitialOptimizationEnv (tcImports, tcGlobals) - + let importMap = tcImports.GetImportMap() let metadataVersion = match tcConfig.metadataVersion with | Some v -> v | _ -> match (frameworkTcImports.DllTable.TryFind tcConfig.primaryAssembly.Name) with | Some ib -> ib.RawMetadata.TryGetRawILModule().Value.MetadataVersion | _ -> "" - let optimizedImpls, optimizationData, _ = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, generatedCcu, typedImplFiles) + let optimizedImpls, optimizationData, _ = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, generatedCcu, typedImplFiles, nenv) AbortOnError(errorLogger, exiter) @@ -1951,10 +1951,10 @@ let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlo let optDataResources = EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData), false) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, (sigDataAttributes, sigDataResources), optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter) + Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, (sigDataAttributes, sigDataResources), optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter, nenv) /// Phase 2b: IL code generation -let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, idata, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter)) = +let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, idata, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter, nenv)) = match tcImportsCapture with | None -> () @@ -1974,7 +1974,7 @@ let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcCo // Check if System.SerializableAttribute exists in mscorlib.dll, // so that make sure the compiler only emits "serializable" bit into IL metadata when it is available. // Note that SerializableAttribute may be relocated in the future but now resides in mscorlib. - let codegenResults = GenerateIlxCode ((if Option.isSome dynamicAssemblyCreator then IlReflectBackend else IlWriteBackend), Option.isSome dynamicAssemblyCreator, false, tcConfig, topAttrs, optimizedImpls, generatedCcu.AssemblyName, ilxGenerator) + let codegenResults = GenerateIlxCode ((if Option.isSome dynamicAssemblyCreator then IlReflectBackend else IlWriteBackend), Option.isSome dynamicAssemblyCreator, false, tcConfig, topAttrs, optimizedImpls, generatedCcu.AssemblyName, ilxGenerator, nenv) let casApplied = new Dictionary() let securityAttrs, topAssemblyAttrs = topAttrs.assemblyAttrs |> List.partition (fun a -> TypeChecker.IsSecurityAttribute tcGlobals (tcImports.GetImportMap()) casApplied a rangeStartup) // remove any security attributes from the top-level assembly attribute list diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs index b9331351ffe..f89cda50455 100644 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -1010,6 +1010,7 @@ type internal FsiDynamicCompiler let optEnv = istate.optEnv let emEnv = istate.emEnv let tcState = istate.tcState + let nenv = tcState.TcEnvFromImpls.NameEnv let ilxGenerator = istate.ilxGenerator let tcConfig = TcConfig.Create(tcConfigB,validate=false) @@ -1031,11 +1032,11 @@ type internal FsiDynamicCompiler let importMap = tcImports.GetImportMap() // optimize: note we collect the incremental optimization environment - let optimizedImpls, _optData, optEnv = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, isIncrementalFragment, optEnv, tcState.Ccu, declaredImpls) + let optimizedImpls, _optData, optEnv = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, isIncrementalFragment, optEnv, tcState.Ccu, declaredImpls, nenv) errorLogger.AbortOnError(fsiConsoleOutput); let fragName = textOfLid prefixPath - let codegenResults = GenerateIlxCode (IlReflectBackend, isInteractiveItExpr, runningOnMono, tcConfig, topCustomAttrs, optimizedImpls, fragName, ilxGenerator) + let codegenResults = GenerateIlxCode (IlReflectBackend, isInteractiveItExpr, runningOnMono, tcConfig, topCustomAttrs, optimizedImpls, fragName, ilxGenerator, nenv) errorLogger.AbortOnError(fsiConsoleOutput); // Each input is like a small separately compiled extension to a single source file. diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 96d8ec9aba8..5e8f3a3b498 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -304,7 +304,7 @@ let ImportReturnTypeFromMetaData amap m ty scoref tinst minst = /// /// Note: this now looks identical to constraint instantiation. -let CopyTyparConstraints m tprefInst (tporig:Typar) = +let CopyTyparConstraints getExtSlnsOpt m tprefInst (tporig:Typar) = tporig.Constraints |> List.map (fun tpc -> match tpc with @@ -332,12 +332,19 @@ let CopyTyparConstraints m tprefInst (tporig:Typar) = TyparConstraint.SimpleChoice (List.map (instType tprefInst) tys,m) | TyparConstraint.RequiresDefaultConstructor _ -> TyparConstraint.RequiresDefaultConstructor m - | TyparConstraint.MayResolveMember(traitInfo,_) -> - TyparConstraint.MayResolveMember (instTrait tprefInst traitInfo,m)) + | TyparConstraint.MayResolveMember(traitInfo, _, extVals) -> + // Search for the relevant extension values again if a name resolution environment is provided + // Basically, if you use a generic thing, then the extension members in scope at the point of _use_ + // are the ones available to solve the constraint + let extVals2 = + match getExtSlnsOpt with + | None -> extVals + | Some f -> f traitInfo + TyparConstraint.MayResolveMember (instTrait tprefInst traitInfo,m,List.map (instValRef tprefInst) extVals2)) /// The constraints for each typar copied from another typar can only be fixed up once /// we have generated all the new constraints, e.g. f List, B :> List> ... -let FixupNewTypars m (formalEnclosingTypars:Typars) (tinst: TType list) (tpsorig: Typars) (tps: Typars) = +let FixupNewTypars getExtSlnsOpt m (formalEnclosingTypars:Typars) (tinst: TType list) (tpsorig: Typars) (tps: Typars) = // Checks.. These are defensive programming against early reported errors. let n0 = formalEnclosingTypars.Length let n1 = tinst.Length @@ -349,7 +356,7 @@ let FixupNewTypars m (formalEnclosingTypars:Typars) (tinst: TType list) (tpsorig // The real code.. let renaming,tptys = mkTyparToTyparRenaming tpsorig tps let tprefInst = mkTyparInst formalEnclosingTypars tinst @ renaming - (tpsorig,tps) ||> List.iter2 (fun tporig tp -> tp.FixupConstraints (CopyTyparConstraints m tprefInst tporig)) + (tpsorig,tps) ||> List.iter2 (fun tporig tp -> tp.FixupConstraints (CopyTyparConstraints getExtSlnsOpt m tprefInst tporig)) renaming,tptys @@ -1455,9 +1462,9 @@ type MethInfo = let tcref = tcrefOfAppTy g x.EnclosingType let formalEnclosingTyparsOrig = tcref.Typars(m) let formalEnclosingTypars = copyTypars formalEnclosingTyparsOrig - let _,formalEnclosingTyparTys = FixupNewTypars m [] [] formalEnclosingTyparsOrig formalEnclosingTypars + let _,formalEnclosingTyparTys = FixupNewTypars None m [] [] formalEnclosingTyparsOrig formalEnclosingTypars let formalMethTypars = copyTypars x.FormalMethodTypars - let _,formalMethTyparTys = FixupNewTypars m formalEnclosingTypars formalEnclosingTyparTys x.FormalMethodTypars formalMethTypars + let _,formalMethTyparTys = FixupNewTypars None m formalEnclosingTypars formalEnclosingTyparTys x.FormalMethodTypars formalMethTypars let formalRetTy, formalParams = match x with | ILMeth(_,ilminfo,_) -> diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index db5f96b3d17..928243a7a94 100644 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -1087,7 +1087,7 @@ and FSharpGenericParameterConstraint(cenv, cx: TyparConstraint) = member __.MemberConstraintData = match cx with - | TyparConstraint.MayResolveMember(info, _) -> FSharpGenericParameterMemberConstraint(cenv, info) + | TyparConstraint.MayResolveMember(info, _, _) -> FSharpGenericParameterMemberConstraint(cenv, info) | _ -> invalidOp "not a member constraint" member __.IsNonNullableValueTypeConstraint = diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 26a4c1178d8..d10223ae72b 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -2029,6 +2029,8 @@ and override x.ToString() = x.Name +and PossibleExtensionMemberSolutions = ValRef list + and [] TyparConstraint = @@ -2042,7 +2044,8 @@ and | SupportsNull of range /// Indicates a constraint that a type has a member with the given signature - | MayResolveMember of TraitConstraintInfo * range + // TODO: allow .NET-defined extension members to solve trait constraints. Currently only ValRefs indicating possible solutions are stored + | MayResolveMember of TraitConstraintInfo * range * possibleExtensionMemberSolutions: PossibleExtensionMemberSolutions /// Indicates a constraint that a type is a non-Nullable value type /// These are part of .NET's model of generic constraints, and in order to From bdfa7b3223636e3c433e081f6782b481919087e8 Mon Sep 17 00:00:00 2001 From: dsyme Date: Mon, 25 Sep 2017 18:26:13 +0100 Subject: [PATCH 06/40] fix build --- src/fsharp/CheckFormatStrings.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/fsharp/CheckFormatStrings.fs b/src/fsharp/CheckFormatStrings.fs index 3ca134907c4..fa0002f8706 100644 --- a/src/fsharp/CheckFormatStrings.fs +++ b/src/fsharp/CheckFormatStrings.fs @@ -15,7 +15,7 @@ open Microsoft.FSharp.Compiler.ConstraintSolver type FormatItem = Simple of TType | FuncAndVal let copyAndFixupFormatTypar m tp = - let _,_,tinst = FreshenAndFixupTypars m TyparRigidity.Flexible [] [] [tp] + let _,_,tinst = FreshenAndFixupTypars None m TyparRigidity.Flexible [] [] [tp] List.head tinst let lowestDefaultPriority = 0 (* See comment on TyparConstraint.DefaultsTo *) From 1fa232633b84568802a347f2b05999610b32279d Mon Sep 17 00:00:00 2001 From: dsyme Date: Mon, 25 Sep 2017 18:32:33 +0100 Subject: [PATCH 07/40] prototype for extension solutions to trait constraints --- testfiles/test.fs | 48 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) create mode 100644 testfiles/test.fs diff --git a/testfiles/test.fs b/testfiles/test.fs new file mode 100644 index 00000000000..5786e5de305 --- /dev/null +++ b/testfiles/test.fs @@ -0,0 +1,48 @@ + + + +type System.Int32 with + static member Add(a : System.Int32, b : System.Int32) = a + b + +type MyType = + | MyType of int + +[] +module Extensions = + type MyType with + static member Add(MyType x, MyType y) = MyType (x + y) + +let inline addGeneric< ^A when ^A : (static member Add : ^A * ^A -> ^A) > (a,b) : ^A = + (^A : (static member Add : ^A * ^A -> ^A) (a,b)) + +//let inline (+++) a b = addGeneric(a,b) + +let inline addGeneric2 (a,b) : ^A when ^A : (static member Add : ^A * ^A -> ^A) = + (^A : (static member Add : ^A * ^A -> ^A) (a,b)) + +//let inline (++++) a b = addGeneric2(a,b) + + +let f () = + let v1 = addGeneric (MyType(1), MyType(2)) + let v2 = addGeneric (1,1) + () + +(* +let f2 () = + let v1 = MyType(1) +++ MyType(2) + let v2 = 1 +++ 1 + 1 +*) + +let f3 () = + let v1 = addGeneric2 (MyType(1), MyType(2)) + let v2 = addGeneric2 (1,1) + () + +(* +let f4 () = + let v1 = MyType(1) ++++ MyType(2) + let v2 = 1 ++++ 1 + () +*) \ No newline at end of file From b8c95f4aa79af6e77f12399672160f38d3c0b825 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 27 Sep 2017 13:30:31 +0100 Subject: [PATCH 08/40] resolve and merge --- src/fsharp/symbols/Symbols.fs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index a38ea96c32a..928243a7a94 100644 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -1087,11 +1087,7 @@ and FSharpGenericParameterConstraint(cenv, cx: TyparConstraint) = member __.MemberConstraintData = match cx with -<<<<<<< HEAD - | TyparConstraint.MayResolveMember(info, _,_) -> FSharpGenericParameterMemberConstraint(cenv, info) -======= | TyparConstraint.MayResolveMember(info, _, _) -> FSharpGenericParameterMemberConstraint(cenv, info) ->>>>>>> 7121bc3927129e65b9f9abff9abf87c60dac3108 | _ -> invalidOp "not a member constraint" member __.IsNonNullableValueTypeConstraint = From f75a2abd42d49950f0228ede0068485f5ebcc3e5 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 27 Sep 2017 13:31:35 +0100 Subject: [PATCH 09/40] resolve and merge --- src/fsharp/ConstraintSolver.fs | 55 ---------------------------------- 1 file changed, 55 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 5550fe4c2a2..bc717392e87 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -1408,29 +1408,17 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution /// between potential overloads because a generic instantiation derived from the left hand type differs /// to a generic instantiation for an operator based on the right hand type. let minfos = List.reduce (ListSet.unionFavourLeft MethInfo.MethInfosUseIdenticalDefinitions) minfos -<<<<<<< HEAD - let extMemberToMethInfo t (valRef : ValRef) = - FSMeth(csenv.g, t, valRef, Some 1uL) // TODO - let extMInfos : MethInfo list = - let allCombos = List.allPairs tys exts - List.map (fun (a,b) -> extMemberToMethInfo a b) allCombos -======= // Get the extension method that may be relevant to solving the constraint as MethInfo objects. let extMInfos = GetRelevantExtensionMethodsForTrait csenv.g traitInfo extVals ->>>>>>> 7121bc3927129e65b9f9abff9abf87c60dac3108 minfos @ extMInfos else [] // The trait name "op_Explicit" also covers "op_Implicit", so look for that one too. if nm = "op_Explicit" then -<<<<<<< HEAD - results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln)) exts -======= results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln)) extVals ->>>>>>> 7121bc3927129e65b9f9abff9abf87c60dac3108 else results @@ -1480,20 +1468,12 @@ and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep per cxs |> AtLeastOneD (fun (traitInfo, extVals, m2) -> let csenv = { csenv with m = m2 } -<<<<<<< HEAD - SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo []) -======= SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo extVals) ->>>>>>> 7121bc3927129e65b9f9abff9abf87c60dac3108 and CanonicalizeRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep trace tps = SolveRelevantMemberConstraints csenv ndeep true trace tps -<<<<<<< HEAD -and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo support frees extTys = -======= and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo support frees extVals = ->>>>>>> 7121bc3927129e65b9f9abff9abf87c60dac3108 let g = csenv.g let aenv = csenv.EquivEnv let cxst = csenv.SolverState.ExtraCxs @@ -1516,11 +1496,7 @@ and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo sup // 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. -<<<<<<< HEAD - support |> IterateD (fun tp -> AddConstraint csenv ndeep m2 trace tp (TyparConstraint.MayResolveMember(traitInfo, m2, extTys))) -======= support |> IterateD (fun tp -> AddConstraint csenv ndeep m2 trace tp (TyparConstraint.MayResolveMember(traitInfo, m2, extVals))) ->>>>>>> 7121bc3927129e65b9f9abff9abf87c60dac3108 /// Record a constraint on an inference type variable. @@ -2591,21 +2567,8 @@ let AddCxTypeMustSubsumeType contextInfo denv nenv css m trace ty1 ty2 = |> RaiseOperationResult let AddCxMethodConstraint denv nenv css m trace (traitInfo : TraitConstraintInfo) = -<<<<<<< HEAD - let extTys : ValRef list = - let extMemberToValRef = function - | FSExtMem (v,_) -> v - | ILExtMem (_,_,_) -> failwith "" - nenv.eIndexedExtensionMembers.Contents.Contents.Values - |> fun x -> x - |> List.concat - |> List.map extMemberToValRef - |> List.filter (fun v -> v.LogicalName = traitInfo.MemberName) - TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) true false 0 m trace traitInfo extTys ++ (fun _ -> CompleteD)) -======= let extVals = GetRelevantPossibleExtensionSolutionsToConstraint nenv traitInfo TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) true false 0 m trace traitInfo extVals ++ (fun _ -> CompleteD)) ->>>>>>> 7121bc3927129e65b9f9abff9abf87c60dac3108 (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult @@ -2661,23 +2624,9 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait TcVal = tcVal ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = new InfoReader(g,amap) } -<<<<<<< HEAD - let extTys : ValRef list = - let extMemberToValRef = function - | FSExtMem (v,_) -> v - | ILExtMem (_,_,_) -> failwith "" - nenv.eIndexedExtensionMembers.Contents.Contents.Values - |> fun x -> x - |> List.concat - |> List.map extMemberToValRef - |> List.filter (fun v -> v.LogicalName = traitInfo.MemberName) - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) nenv - SolveMemberConstraint csenv true true 0 m NoTrace traitInfo extTys ++ (fun _res -> -======= let extVals = GetRelevantPossibleExtensionSolutionsToConstraint nenv traitInfo let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) nenv SolveMemberConstraint csenv true true 0 m NoTrace traitInfo extVals ++ (fun _res -> ->>>>>>> 7121bc3927129e65b9f9abff9abf87c60dac3108 let sln = match traitInfo.Solution with | None -> Choice4Of4() @@ -2793,11 +2742,7 @@ let IsApplicableMethApprox g amap m (minfo:MethInfo) availObjTy = ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = new InfoReader(g, amap) } let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) (NameResolutionEnv.Empty g) -<<<<<<< HEAD - let minst = FreshenMethInfo m minfo -======= let minst = FreshenMethInfo None m minfo ->>>>>>> 7121bc3927129e65b9f9abff9abf87c60dac3108 match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> TryD (fun () -> SolveTypSubsumesTyp csenv 0 m NoTrace None reqdObjTy availObjTy ++ (fun () -> ResultD true)) From 072cbbbec0938eea4a59425318f182c698c43ceb Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 27 Sep 2017 14:44:52 +0100 Subject: [PATCH 10/40] minor cleanup --- src/fsharp/CheckFormatStrings.fs | 2 +- src/fsharp/ConstraintSolver.fs | 41 +++++++++++++++++--------------- src/fsharp/ConstraintSolver.fsi | 3 +++ testfiles/test.fs | 14 ++++++++--- 4 files changed, 37 insertions(+), 23 deletions(-) diff --git a/src/fsharp/CheckFormatStrings.fs b/src/fsharp/CheckFormatStrings.fs index 3ca134907c4..fa0002f8706 100644 --- a/src/fsharp/CheckFormatStrings.fs +++ b/src/fsharp/CheckFormatStrings.fs @@ -15,7 +15,7 @@ open Microsoft.FSharp.Compiler.ConstraintSolver type FormatItem = Simple of TType | FuncAndVal let copyAndFixupFormatTypar m tp = - let _,_,tinst = FreshenAndFixupTypars m TyparRigidity.Flexible [] [] [tp] + let _,_,tinst = FreshenAndFixupTypars None m TyparRigidity.Flexible [] [] [tp] List.head tinst let lowestDefaultPriority = 0 (* See comment on TyparConstraint.DefaultsTo *) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index bc717392e87..e556c851e85 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -712,7 +712,7 @@ let rec SolveTyparEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace:Optional // 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 - RepeatWhileD ndeep (fun ndeep -> SolveRelevantMemberConstraintsForTypar csenv ndeep false trace r) + RepeatWhileD ndeep (fun ndeep -> SolveRelevantMemberConstraintsForTypar csenv ndeep (*permitWeakResolution*)false trace r) else CompleteD) ++ (fun _ -> @@ -753,7 +753,7 @@ and solveTypMeetsTyparConstraints (csenv:ConstraintSolverEnv) ndeep m2 trace ty | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypChoice csenv ndeep m2 trace ty tys | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m2 trace None ty2 ty | TyparConstraint.MayResolveMember(traitInfo,m2,extVals) -> - SolveMemberConstraint csenv false false ndeep m2 trace traitInfo extVals ++ (fun _ -> CompleteD) + SolveMemberConstraint csenv false (*permitWeakResolution*)false ndeep m2 trace traitInfo extVals ++ (fun _ -> CompleteD) ))) @@ -793,7 +793,7 @@ and SolveTypEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace -> SolveTypEqualsTyp csenv ndeep m2 trace None ms (TType_measure Measure.One) | TType_app (tc1, l1) , TType_app (tc2, l2) when tyconRefEq g tc1 tc2 -> SolveTypEqualsTypEqns csenv ndeep m2 trace None l1 l2 - | TType_app (_, _) , TType_app (_, _) -> localAbortD + | 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 SolveTypEqualsTypEqns csenv ndeep m2 trace None l1 l2 @@ -945,8 +945,9 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty /// We pretend int and other types support a number of operators. In the actual IL for mscorlib they /// don't, however the type-directed static optimization rules in the library code that makes use of this /// will deal with the problem. -and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace (TTrait(tys, nm, memFlags, argtys, rty, sln)) extVals : OperationResult = +and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace traitInfo extVals : OperationResult = // Do not re-solve if already solved + let (TTrait(tys, nm, memFlags, argtys, rty, sln)) = traitInfo if sln.Value.IsSome then ResultD true else let g = csenv.g let m = csenv.m @@ -975,7 +976,6 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p let argtys = if memFlags.IsInstance then List.tail argtys else argtys let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo extVals - match minfos, tys, memFlags.IsInstance, nm, argtys with | _, _, false, ("op_Division" | "op_Multiply"), [argty1;argty2] @@ -1390,29 +1390,32 @@ and GetRelevantExtensionMethodsForTrait g (TTrait(tys, _, _, _, _, _)) extVals = /// That is, don't perform resolution if more nominal information may influence the set of available overloads and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys, _, memFlags, argtys, rty, soln) as traitInfo) extVals : MethInfo list = let results = - if permitWeakResolution || isNil (GetSupportOfMemberConstraint csenv traitInfo) then + let strongResolution = isNil (GetSupportOfMemberConstraint csenv traitInfo) + if permitWeakResolution || strongResolution then let m = csenv.m let minfos = match memFlags.MemberKind with | MemberKind.Constructor -> tys |> List.map (GetIntrinsicConstructorInfosOfType csenv.SolverState.InfoReader m) | _ -> - let getRelevantMethods t = - GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm, AccessibleFromSomeFSharpCode, AllowMultiIntfInstantiations.Yes) IgnoreOverrides m t + tys |> List.map (GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm, AccessibleFromSomeFSharpCode, AllowMultiIntfInstantiations.Yes) IgnoreOverrides m) - tys |> List.map getRelevantMethods /// Merge the sets so we don't get the same minfo from each side /// We merge based on whether minfos use identical metadata or not. - - /// REVIEW: Consider the pathological cases where this may cause a loss of distinction - /// between potential overloads because a generic instantiation derived from the left hand type differs - /// to a generic instantiation for an operator based on the right hand type. - let minfos = List.reduce (ListSet.unionFavourLeft MethInfo.MethInfosUseIdenticalDefinitions) minfos + let minfos = minfos |> List.reduce (ListSet.unionFavourLeft MethInfo.MethInfosUseIdenticalDefinitions) // Get the extension method that may be relevant to solving the constraint as MethInfo objects. - let extMInfos = GetRelevantExtensionMethodsForTrait csenv.g traitInfo extVals + // Extension members are not used when canonicalizing prior to generalization (permitWeakResolution=true) + let extMInfos = + if strongResolution then GetRelevantExtensionMethodsForTrait csenv.g traitInfo extVals + else [] + + let extMInfos = extMInfos |> ListSet.setify MethInfo.MethInfosUseIdenticalDefinitions + + let minfos = minfos @ extMInfos + + minfos - minfos @ extMInfos else [] @@ -1471,7 +1474,7 @@ and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep per SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo extVals) and CanonicalizeRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep trace tps = - SolveRelevantMemberConstraints csenv ndeep true trace tps + SolveRelevantMemberConstraints csenv ndeep (*permitWeakResolution*)true trace tps and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo support frees extVals = let g = csenv.g @@ -2568,7 +2571,7 @@ let AddCxTypeMustSubsumeType contextInfo denv nenv css m trace ty1 ty2 = let AddCxMethodConstraint denv nenv css m trace (traitInfo : TraitConstraintInfo) = let extVals = GetRelevantPossibleExtensionSolutionsToConstraint nenv traitInfo - TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) true false 0 m trace traitInfo extVals ++ (fun _ -> CompleteD)) + TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) true (*permitWeakResolution*)false 0 m trace traitInfo extVals ++ (fun _ -> CompleteD)) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult @@ -2626,7 +2629,7 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait InfoReader = new InfoReader(g,amap) } let extVals = GetRelevantPossibleExtensionSolutionsToConstraint nenv traitInfo let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) nenv - SolveMemberConstraint csenv true true 0 m NoTrace traitInfo extVals ++ (fun _res -> + SolveMemberConstraint csenv true (*permitWeakResolution*)true 0 m NoTrace traitInfo extVals ++ (fun _res -> let sln = match traitInfo.Solution with | None -> Choice4Of4() diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index efd1e9668ff..8ce64986bf9 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -120,7 +120,10 @@ type OptionalTrace = val SimplifyMeasuresInTypeScheme : TcGlobals -> bool -> Typars -> TType -> TyparConstraint list -> Typars val SolveTyparEqualsTyp : ConstraintSolverEnv -> int -> range -> OptionalTrace -> TType -> TType -> OperationResult val SolveTypEqualsTypKeepAbbrevs : ConstraintSolverEnv -> int -> range -> OptionalTrace -> TType -> TType -> OperationResult + +/// Canonicalize constraints prior to generalization val CanonicalizeRelevantMemberConstraints : ConstraintSolverEnv -> int -> OptionalTrace -> Typars -> OperationResult + val ResolveOverloading : ConstraintSolverEnv -> OptionalTrace -> string -> ndeep: int -> TraitConstraintInfo option -> int * int -> AccessorDomain -> CalledMeth list -> bool -> TType option -> CalledMeth option * OperationResult val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> CalledMeth list -> TType -> OperationResult val EliminateConstraintsForGeneralizedTypars : ConstraintSolverEnv -> OptionalTrace -> Typars -> unit diff --git a/testfiles/test.fs b/testfiles/test.fs index ed56f1023b2..6e1667d9061 100644 --- a/testfiles/test.fs +++ b/testfiles/test.fs @@ -1,16 +1,24 @@ +module Test + type System.Int32 with static member Add(a : System.Int32, b : System.Int32) = a + b type MyType = | MyType of int - static member Add(MyType x, MyType y) = MyType (x + y) + +[] +module M = + type MyType with + static member Add(MyType x, MyType y) = MyType (x + y) let inline addGeneric< ^A when ^A : (static member Add : ^A * ^A -> ^A) > (a,b) : ^A = (^A : (static member Add : ^A * ^A -> ^A) (a,b)) let inline (+++) a b = addGeneric(a,b) -[] -let main args = +//[] +//let main args = + +let f () = MyType(1) +++ MyType(2) |> ignore 1 +++ 1 \ No newline at end of file From 9bdfb2128908e23f073a639ae836c6ed6c34565e Mon Sep 17 00:00:00 2001 From: dsyme Date: Wed, 27 Sep 2017 20:18:38 +0100 Subject: [PATCH 11/40] it works --- src/fsharp/NameResolution.fs | 10 +++++++--- src/fsharp/tast.fs | 3 ++- testfiles/test.fs | 16 +++++++++------- 3 files changed, 18 insertions(+), 11 deletions(-) diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index 4a09ca0e437..f956c7c277d 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -532,10 +532,14 @@ let AddValRefToExtensionMembers pri (eIndexedExtensionMembers: TyconRefMultiMap< else eIndexedExtensionMembers +/// Add an F# value to the table of available extension members, if necessary, as an FSharp-style extension member +let AddValRefToExtensionMembersByNameTable logicalName (eExtensionMembersByName: NameMultiMap<_>) extMemInfo = + NameMultiMap.add logicalName extMemInfo eExtensionMembersByName + /// Add an F# value to the table of available extension members, if necessary, as an FSharp-style extension member let AddValRefToExtensionMembersByName pri (eExtensionMembersByName: NameMultiMap<_>) (vref:ValRef) = if vref.IsMember && vref.IsExtensionMember then - NameMultiMap.add vref.CompiledName (FSExtMem (vref,pri)) eExtensionMembersByName + AddValRefToExtensionMembersByNameTable vref.LogicalName eExtensionMembersByName (FSExtMem (vref,pri)) else eExtensionMembersByName @@ -657,8 +661,8 @@ let private AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition (g:TcGlobals) let ilStyleExtensionMeths = GetCSharpStyleIndexedExtensionMembersForTyconRef amap m tcref ((nenv.eIndexedExtensionMembers, nenv.eExtensionMembersByName, nenv.eUnindexedExtensionMembers),ilStyleExtensionMeths) ||> List.fold (fun (tab1,tab2,tab3) extMemInfo -> match extMemInfo with - | Choice1Of2 (tcref,extMemInfo) -> tab1.Add (tcref, extMemInfo), NameMultiMap.add extMemInfo.LogicalName extMemInfo tab2, tab3 - | Choice2Of2 extMemInfo -> tab1, NameMultiMap.add extMemInfo.LogicalName extMemInfo tab2, extMemInfo :: tab3) + | Choice1Of2 (tcref,extMemInfo) -> tab1.Add (tcref, extMemInfo), AddValRefToExtensionMembersByNameTable extMemInfo.LogicalName tab2 extMemInfo, tab3 + | Choice2Of2 extMemInfo -> tab1, AddValRefToExtensionMembersByNameTable extMemInfo.LogicalName tab2 extMemInfo, extMemInfo :: tab3) let isILOrRequiredQualifiedAccess = isIL || (not ownDefinition && HasFSharpAttribute g g.attrib_RequireQualifiedAccessAttribute tcref.Attribs) let eFieldLabels = diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index d10223ae72b..76d2a1eea38 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -2095,6 +2095,7 @@ and member x.Solution with get() = (let (TTrait(_,_,_,_,_,sln)) = x in sln.Value) and set v = (let (TTrait(_,_,_,_,_,sln)) = x in sln.Value <- v) + override x.ToString() = "trait " + x.MemberName and [] @@ -3534,7 +3535,7 @@ and + String.concat "," (List.map string tinst) + ")" | TType_fun (d,r) -> "(" + string d + " -> " + string r + ")" | TType_ucase (uc,tinst) -> "union case type " + uc.CaseName + (match tinst with [] -> "" | tys -> "<" + String.concat "," (List.map string tys) + ">") - | TType_var tp -> tp.DisplayName + | TType_var tp -> match tp.Solution with None -> tp.DisplayName | Some sln -> "£"+sln.ToString() | TType_measure ms -> sprintf "%A" ms /// For now, used only as a discriminant in error message. diff --git a/testfiles/test.fs b/testfiles/test.fs index 29fdf31eb7d..6bb80f333a0 100644 --- a/testfiles/test.fs +++ b/testfiles/test.fs @@ -1,7 +1,13 @@ module Test type System.Int32 with - static member Add(a : System.Int32, b : System.Int32) = a + b + static member (++)(a: int, b: int) = a + +1 ++ 2 + + +type System.Int32 with + static member Add(a: int, b: int) = a type MyType = | MyType of int @@ -14,12 +20,12 @@ module Extensions = let inline addGeneric< ^A when ^A : (static member Add : ^A * ^A -> ^A) > (a,b) : ^A = (^A : (static member Add : ^A * ^A -> ^A) (a,b)) -//let inline (+++) a b = addGeneric(a,b) +let inline (+++) a b = addGeneric(a,b) let inline addGeneric2 (a,b) : ^A when ^A : (static member Add : ^A * ^A -> ^A) = (^A : (static member Add : ^A * ^A -> ^A) (a,b)) -//let inline (++++) a b = addGeneric2(a,b) +let inline (++++) a b = addGeneric2(a,b) let f () = @@ -27,21 +33,17 @@ let f () = let v2 = addGeneric (1,1) () -(* let f2 () = let v1 = MyType(1) +++ MyType(2) let v2 = 1 +++ 1 1 -*) let f3 () = let v1 = addGeneric2 (MyType(1), MyType(2)) let v2 = addGeneric2 (1,1) () -(* let f4 () = let v1 = MyType(1) ++++ MyType(2) let v2 = 1 ++++ 1 () -*) From 96502eada34a4a958333fb8bb62ce6e30501d359 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 27 Sep 2017 23:34:24 +0100 Subject: [PATCH 12/40] minor cleanup --- testfiles/test.fs | 76 +++++++++++++++++++++++++++-------------------- 1 file changed, 43 insertions(+), 33 deletions(-) diff --git a/testfiles/test.fs b/testfiles/test.fs index 6bb80f333a0..6bbc677c57e 100644 --- a/testfiles/test.fs +++ b/testfiles/test.fs @@ -1,49 +1,59 @@ module Test -type System.Int32 with - static member (++)(a: int, b: int) = a +module Example1 = + type System.Int32 with + static member (++)(a: int, b: int) = a -1 ++ 2 + let result = 1 ++ 2 -type System.Int32 with - static member Add(a: int, b: int) = a +module Example2 = + type System.Int32 with + static member Add(a: int, b: int) = a -type MyType = - | MyType of int + type MyType = + | MyType of int -[] -module Extensions = - type MyType with - static member Add(MyType x, MyType y) = MyType (x + y) + [] + module Extensions = + type MyType with + static member Add(MyType x, MyType y) = MyType (x + y) -let inline addGeneric< ^A when ^A : (static member Add : ^A * ^A -> ^A) > (a,b) : ^A = - (^A : (static member Add : ^A * ^A -> ^A) (a,b)) + let inline addGeneric< ^A when ^A : (static member Add : ^A * ^A -> ^A) > (a,b) : ^A = + (^A : (static member Add : ^A * ^A -> ^A) (a,b)) -let inline (+++) a b = addGeneric(a,b) + let inline (+++) a b = addGeneric(a,b) -let inline addGeneric2 (a,b) : ^A when ^A : (static member Add : ^A * ^A -> ^A) = - (^A : (static member Add : ^A * ^A -> ^A) (a,b)) + let inline addGeneric2 (a,b) : ^A when ^A : (static member Add : ^A * ^A -> ^A) = + (^A : (static member Add : ^A * ^A -> ^A) (a,b)) -let inline (++++) a b = addGeneric2(a,b) + let inline (++++) a b = addGeneric2(a,b) -let f () = - let v1 = addGeneric (MyType(1), MyType(2)) - let v2 = addGeneric (1,1) - () + let f () = + let v1 = addGeneric (MyType(1), MyType(2)) + let v2 = addGeneric (1,1) + () -let f2 () = - let v1 = MyType(1) +++ MyType(2) - let v2 = 1 +++ 1 - 1 + let f2 () = + let v1 = MyType(1) +++ MyType(2) + let v2 = 1 +++ 1 + 1 -let f3 () = - let v1 = addGeneric2 (MyType(1), MyType(2)) - let v2 = addGeneric2 (1,1) - () + let f3 () = + let v1 = addGeneric2 (MyType(1), MyType(2)) + let v2 = addGeneric2 (1,1) + () + + let f4 () = + let v1 = MyType(1) ++++ MyType(2) + let v2 = 1 ++++ 1 + () + + +module Example3 = + type List<'T> with + member x.Count = x.Length + + [3].Count -let f4 () = - let v1 = MyType(1) ++++ MyType(2) - let v2 = 1 ++++ 1 - () From f287f20413f62e4cf65f0d9423e68c17b0c938b1 Mon Sep 17 00:00:00 2001 From: dsyme Date: Fri, 29 Sep 2017 21:19:55 +0100 Subject: [PATCH 13/40] various fixes --- src/fsharp/CompileOptions.fs | 12 +- src/fsharp/CompileOptions.fsi | 4 +- src/fsharp/ConstraintSolver.fs | 188 +++++++------- src/fsharp/ConstraintSolver.fsi | 47 ++-- src/fsharp/FSComp.txt | 2 +- src/fsharp/FindUnsolved.fs | 2 +- src/fsharp/IlxGen.fs | 6 +- src/fsharp/IlxGen.fsi | 2 +- src/fsharp/MethodCalls.fs | 5 +- src/fsharp/NicePrint.fs | 8 +- src/fsharp/Optimizer.fs | 14 +- src/fsharp/Optimizer.fsi | 2 +- src/fsharp/PostInferenceChecks.fs | 7 +- src/fsharp/TastOps.fs | 135 +++++++--- src/fsharp/TastOps.fsi | 17 +- src/fsharp/TastPickle.fs | 30 +-- src/fsharp/TypeChecker.fs | 233 +++++++++--------- src/fsharp/TypeRelations.fs | 2 +- src/fsharp/fsc.fs | 22 +- src/fsharp/fsi/fsi.fs | 5 +- src/fsharp/infos.fs | 31 ++- src/fsharp/symbols/Exprs.fs | 2 +- src/fsharp/symbols/Symbols.fs | 5 +- src/fsharp/tast.fs | 17 +- testfiles/test.fs | 24 +- .../basic/E_ExtensionOperator01.fs | 20 +- 26 files changed, 467 insertions(+), 375 deletions(-) diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index 61f3b8f1672..2a12b781f74 100644 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -1229,7 +1229,7 @@ let GetInitialOptimizationEnv (tcImports:TcImports, tcGlobals:TcGlobals) = let optEnv = List.fold (AddExternalCcuToOpimizationEnv tcGlobals) optEnv ccuinfos optEnv -let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importMap, isIncrementalFragment, optEnv, ccu:CcuThunk, implFiles, nenv) = +let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importMap, isIncrementalFragment, optEnv, ccu:CcuThunk, implFiles) = // NOTE: optEnv - threads through // // Always optimize once - the results of this step give the x-module optimization @@ -1253,7 +1253,7 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM //ReportTime tcConfig ("Initial simplify") let (optEnvFirstLoop,implFile,implFileOptData,hidden), optimizeDuringCodeGen = - Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal,importMap,optEnvFirstLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile,nenv) + Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal,importMap,optEnvFirstLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile) let implFile = AutoBox.TransformImplFile tcGlobals importMap implFile @@ -1266,7 +1266,7 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let implFile,optEnvExtraLoop = if tcConfig.extraOptimizationIterations > 0 then //ReportTime tcConfig ("Extra simplification loop") - let (optEnvExtraLoop,implFile, _, _), _ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvExtraLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile,nenv) + let (optEnvExtraLoop,implFile, _, _), _ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvExtraLoop,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile) //PrintWholeAssemblyImplementation tcConfig outfile (sprintf "extra-loop-%d" n) implFile implFile,optEnvExtraLoop else @@ -1291,7 +1291,7 @@ let ApplyAllOptimizations (tcConfig:TcConfig, tcGlobals, tcVal, outfile, importM let implFile,optEnvFinalSimplify = if tcConfig.doFinalSimplify then //ReportTime tcConfig ("Final simplify pass") - let (optEnvFinalSimplify,implFile, _, _),_ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFinalSimplify,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile,nenv) + let (optEnvFinalSimplify,implFile, _, _),_ = Optimizer.OptimizeImplFile(optSettings,ccu,tcGlobals,tcVal, importMap,optEnvFinalSimplify,isIncrementalFragment,tcConfig.emitTailcalls,hidden,implFile) //PrintWholeAssemblyImplementation tcConfig outfile "post-rec-opt" implFile implFile,optEnvFinalSimplify else @@ -1318,7 +1318,7 @@ let CreateIlxAssemblyGenerator (_tcConfig:TcConfig,tcImports:TcImports,tcGlobals ilxGenerator.AddExternalCcus ccus ilxGenerator -let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcConfig:TcConfig, topAttrs, optimizedImpls, fragName, ilxGenerator : IlxAssemblyGenerator, nenv) = +let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcConfig:TcConfig, topAttrs, optimizedImpls, fragName, ilxGenerator : IlxAssemblyGenerator) = if !progress then dprintf "Generating ILX code...\n" let ilxGenOpts : IlxGenOptions = { generateFilterBlocks = tcConfig.generateFilterBlocks @@ -1334,7 +1334,7 @@ let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcCon isInteractiveItExpr = isInteractiveItExpr alwaysCallVirt = tcConfig.alwaysCallVirt } - ilxGenerator.GenerateCode (ilxGenOpts, optimizedImpls, topAttrs.assemblyAttrs,topAttrs.netModuleAttrs,nenv) + ilxGenerator.GenerateCode (ilxGenOpts, optimizedImpls, topAttrs.assemblyAttrs, topAttrs.netModuleAttrs) //---------------------------------------------------------------------------- // Assembly ref normalization: make sure all assemblies are referred to diff --git a/src/fsharp/CompileOptions.fsi b/src/fsharp/CompileOptions.fsi index ade8737223a..2626f1ebe22 100644 --- a/src/fsharp/CompileOptions.fsi +++ b/src/fsharp/CompileOptions.fsi @@ -80,11 +80,11 @@ val GetGeneratedILModuleName : CompilerTarget -> string -> string val GetInitialOptimizationEnv : TcImports * TcGlobals -> IncrementalOptimizationEnv val AddExternalCcuToOpimizationEnv : TcGlobals -> IncrementalOptimizationEnv -> ImportedAssembly -> IncrementalOptimizationEnv -val ApplyAllOptimizations : TcConfig * TcGlobals * ConstraintSolver.TcValF * string * ImportMap * bool * IncrementalOptimizationEnv * CcuThunk * TypedImplFile list * NameResolution.NameResolutionEnv -> TypedAssemblyAfterOptimization * Optimizer.LazyModuleInfo * IncrementalOptimizationEnv +val ApplyAllOptimizations : TcConfig * TcGlobals * ConstraintSolver.TcValF * string * ImportMap * bool * IncrementalOptimizationEnv * CcuThunk * TypedImplFile list -> TypedAssemblyAfterOptimization * Optimizer.LazyModuleInfo * IncrementalOptimizationEnv val CreateIlxAssemblyGenerator : TcConfig * TcImports * TcGlobals * ConstraintSolver.TcValF * CcuThunk -> IlxGen.IlxAssemblyGenerator -val GenerateIlxCode : IlxGen.IlxGenBackend * isInteractiveItExpr:bool * isInteractiveOnMono:bool * TcConfig * TypeChecker.TopAttribs * TypedAssemblyAfterOptimization * fragName:string * IlxGen.IlxAssemblyGenerator * NameResolution.NameResolutionEnv -> IlxGen.IlxGenResults +val GenerateIlxCode : IlxGen.IlxGenBackend * isInteractiveItExpr:bool * isInteractiveOnMono:bool * TcConfig * TypeChecker.TopAttribs * TypedAssemblyAfterOptimization * fragName:string * IlxGen.IlxAssemblyGenerator -> IlxGen.IlxGenResults // Used during static linking val NormalizeAssemblyRefs : CompilationThreadToken * TcImports -> (AbstractIL.IL.ILScopeRef -> AbstractIL.IL.ILScopeRef) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index e556c851e85..7d0fcd0eb83 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -116,32 +116,32 @@ let FreshenMethInfo getExtSlnsOpt m (minfo:MethInfo) = [] /// Information about the context of a type equation. type ContextInfo = -/// No context was given. -| NoContext -/// The type equation comes from an IF expression. -| IfExpression of range -/// The type equation comes from an omitted else branch. -| OmittedElseBranch of range -/// The type equation comes from a type check of the result of an else branch. -| ElseBranchResult of range -/// The type equation comes from the verification of record fields. -| RecordFields -/// The type equation comes from the verification of a tuple in record fields. -| TupleInRecordFields -/// The type equation comes from a list or array constructor -| CollectionElement of bool * range -/// The type equation comes from a return in a computation expression. -| ReturnInComputationExpression -/// The type equation comes from a yield in a computation expression. -| YieldInComputationExpression -/// The type equation comes from a runtime type test. -| RuntimeTypeTest of bool -/// The type equation comes from an downcast where a upcast could be used. -| DowncastUsedInsteadOfUpcast of bool -/// The type equation comes from a return type of a pattern match clause (not the first clause). -| FollowingPatternMatchClause of range -/// The type equation comes from a pattern match guard. -| PatternMatchGuard of range + /// No context was given. + | NoContext + /// The type equation comes from an IF expression. + | IfExpression of range + /// The type equation comes from an omitted else branch. + | OmittedElseBranch of range + /// The type equation comes from a type check of the result of an else branch. + | ElseBranchResult of range + /// The type equation comes from the verification of record fields. + | RecordFields + /// The type equation comes from the verification of a tuple in record fields. + | TupleInRecordFields + /// The type equation comes from a list or array constructor + | CollectionElement of bool * range + /// The type equation comes from a return in a computation expression. + | ReturnInComputationExpression + /// The type equation comes from a yield in a computation expression. + | YieldInComputationExpression + /// The type equation comes from a runtime type test. + | RuntimeTypeTest of bool + /// The type equation comes from an downcast where a upcast could be used. + | DowncastUsedInsteadOfUpcast of bool + /// The type equation comes from a return type of a pattern match clause (not the first clause). + | FollowingPatternMatchClause of range + /// The type equation comes from a pattern match guard. + | PatternMatchGuard of range exception ConstraintSolverTupleDiffLengths of DisplayEnv * TType list * TType list * range * range exception ConstraintSolverInfiniteTypes of ContextInfo * DisplayEnv * TType * TType * range * range @@ -174,7 +174,7 @@ type ConstraintSolverState = /// That is, there will be one entry in this table for each free type variable in /// 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 + mutable ExtraCxs: HashMultiMap } static member New(g, amap, infoReader, tcVal) = @@ -193,21 +193,19 @@ type ConstraintSolverEnv = m: range EquivEnv: TypeEquivEnv DisplayEnv : DisplayEnv - NameResolutionEnv : NameResolutionEnv } member csenv.InfoReader = csenv.SolverState.InfoReader member csenv.g = csenv.SolverState.g member csenv.amap = csenv.SolverState.amap -let MakeConstraintSolverEnv contextInfo css m denv nres = +let MakeConstraintSolverEnv contextInfo css m denv = { SolverState = css m = m eContextInfo = contextInfo // Indicates that when unifiying ty1 = ty2, only type variables in ty1 may be solved MatchingOnly = false EquivEnv = TypeEquivEnv.Empty - DisplayEnv = denv - NameResolutionEnv = nres } + DisplayEnv = denv } //------------------------------------------------------------------------- @@ -752,8 +750,8 @@ and solveTypMeetsTyparConstraints (csenv:ConstraintSolverEnv) ndeep m2 trace ty | TyparConstraint.RequiresDefaultConstructor m2 -> SolveTypRequiresDefaultConstructor csenv ndeep m2 trace ty | TyparConstraint.SimpleChoice(tys, m2) -> SolveTypChoice csenv ndeep m2 trace ty tys | TyparConstraint.CoercesTo(ty2, m2) -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m2 trace None ty2 ty - | TyparConstraint.MayResolveMember(traitInfo,m2,extVals) -> - SolveMemberConstraint csenv false (*permitWeakResolution*)false ndeep m2 trace traitInfo extVals ++ (fun _ -> CompleteD) + | TyparConstraint.MayResolveMember(traitInfo, m2) -> + SolveMemberConstraint csenv false (*permitWeakResolution*)false ndeep m2 trace traitInfo ++ (fun _ -> CompleteD) ))) @@ -945,9 +943,9 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty /// We pretend int and other types support a number of operators. In the actual IL for mscorlib they /// don't, however the type-directed static optimization rules in the library code that makes use of this /// will deal with the problem. -and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace traitInfo extVals : OperationResult = +and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace traitInfo : OperationResult = // Do not re-solve if already solved - let (TTrait(tys, nm, memFlags, argtys, rty, sln)) = traitInfo + let (TTrait(tys, nm, memFlags, argtys, rty, sln, extVals)) = traitInfo if sln.Value.IsSome then ResultD true else let g = csenv.g let m = csenv.m @@ -960,7 +958,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // Remove duplicates from the set of types in the support let tys = ListSet.setify (typeAEquiv g aenv) tys // Rebuild the trait info after removing duplicates - let traitInfo = TTrait(tys, nm, memFlags, argtys, rty, sln) + let traitInfo = TTrait(tys, nm, memFlags, argtys, rty, sln, extVals) let rty = GetFSharpViewOfReturnType g rty // Assert the object type if the constraint is for an instance member @@ -975,7 +973,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p tys |> IterateD (SolveTypStaticReq csenv trace HeadTypeStaticReq)) ++ (fun () -> let argtys = if memFlags.IsInstance then List.tail argtys else argtys - let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo extVals + let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo match minfos, tys, memFlags.IsInstance, nm, argtys with | _, _, false, ("op_Division" | "op_Multiply"), [argty1;argty2] @@ -1303,7 +1301,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // If there's nothing left to learn then raise the errors (if (permitWeakResolution && isNil support) || isNil frees then errors // Otherwise re-record the trait waiting for canonicalization - else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees extVals) ++ (fun () -> + else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees) ++ (fun () -> match errors with | ErrorResult (_, UnresolvedOverloading _) when not ignoreUnresolvedOverload && (not (nm = "op_Explicit" || nm = "op_Implicit")) -> ErrorD LocallyAbortOperationThatFailsToResolveOverload | _ -> ResultD TTraitUnsolved) @@ -1382,13 +1380,13 @@ and TransactMemberConstraintSolution traitInfo (trace:OptionalTrace) sln = let prev = traitInfo.Solution trace.Exec (fun () -> traitInfo.Solution <- Some sln) (fun () -> traitInfo.Solution <- prev) -and GetRelevantExtensionMethodsForTrait g (TTrait(tys, _, _, _, _, _)) extVals = +and GetRelevantExtensionMethodsForTrait g (TTrait(tys, _, _, _, _, _, extVals)) = // TODO: check the use of 'allPairs' - not all these extensions apply to each type variable. (tys,extVals) ||> List.allPairs |> List.map (fun (t,vref) -> FSMeth(g, t, vref, Some 1uL) ) /// Only consider overload resolution if canonicalizing or all the types are now nominal. /// That is, don't perform resolution if more nominal information may influence the set of available overloads -and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys, _, memFlags, argtys, rty, soln) as traitInfo) extVals : MethInfo list = +and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys, _, memFlags, argtys, rty, soln, extVals) as traitInfo) : MethInfo list = let results = let strongResolution = isNil (GetSupportOfMemberConstraint csenv traitInfo) if permitWeakResolution || strongResolution then @@ -1407,7 +1405,7 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution // Get the extension method that may be relevant to solving the constraint as MethInfo objects. // Extension members are not used when canonicalizing prior to generalization (permitWeakResolution=true) let extMInfos = - if strongResolution then GetRelevantExtensionMethodsForTrait csenv.g traitInfo extVals + if strongResolution then GetRelevantExtensionMethodsForTrait csenv.g traitInfo else [] let extMInfos = extMInfos |> ListSet.setify MethInfo.MethInfosUseIdenticalDefinitions @@ -1421,17 +1419,17 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution // The trait name "op_Explicit" also covers "op_Implicit", so look for that one too. if nm = "op_Explicit" then - results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln)) extVals + results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln, extVals)) else results /// The nominal support of the member constraint -and GetSupportOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _)) = +and GetSupportOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _, _)) = tys |> List.choose (tryAnyParTy csenv.g) /// All the typars relevant to the member constraint *) -and GetFreeTyparsOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, argtys, rty, _)) = +and GetFreeTyparsOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, argtys, rty, _, _)) = freeInTypesLeftToRightSkippingConstraints csenv.g (tys@argtys@ Option.toList rty) /// Re-solve the global constraints involving any of the given type variables. @@ -1469,14 +1467,14 @@ and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep per assert (isNil (cxst.FindAll tpn)) cxs - |> AtLeastOneD (fun (traitInfo, extVals, m2) -> + |> AtLeastOneD (fun (traitInfo, m2) -> let csenv = { csenv with m = m2 } - SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo extVals) + SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo) and CanonicalizeRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep trace tps = SolveRelevantMemberConstraints csenv ndeep (*permitWeakResolution*)true trace tps -and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo support frees extVals = +and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo support frees = let g = csenv.g let aenv = csenv.EquivEnv let cxst = csenv.SolverState.ExtraCxs @@ -1493,13 +1491,13 @@ and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo sup // check the constraint is not already listed for this type variable // // TODO: conside whether we need to consider equality over _valRefs as well - if not (cxs |> List.exists (fun (traitInfo2, _valRefs, _) -> traitsAEquiv g aenv traitInfo traitInfo2)) then - trace.Exec (fun () -> csenv.SolverState.ExtraCxs.Add (tpn, (traitInfo, extVals, m2))) (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) + if not (cxs |> List.exists (fun (traitInfo2, _valRefs) -> traitsAEquiv g aenv traitInfo traitInfo2)) then + 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. - support |> IterateD (fun tp -> AddConstraint csenv ndeep m2 trace tp (TyparConstraint.MayResolveMember(traitInfo, m2, extVals))) + support |> IterateD (fun tp -> AddConstraint csenv ndeep m2 trace tp (TyparConstraint.MayResolveMember(traitInfo, m2))) /// Record a constraint on an inference type variable. @@ -1517,8 +1515,8 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint = // may require type annotations. See FSharp 1.0 bug 6477. let consistent tpc1 tpc2 = match tpc1, tpc2 with - | (TyparConstraint.MayResolveMember(TTrait(tys1, nm1, memFlags1, argtys1, rty1, _), _, _), - TyparConstraint.MayResolveMember(TTrait(tys2, nm2, memFlags2, argtys2, rty2, _), _, _)) + | (TyparConstraint.MayResolveMember(TTrait(tys1, nm1, memFlags1, argtys1, rty1, _, _), _), + TyparConstraint.MayResolveMember(TTrait(tys2, nm2, memFlags2, argtys2, rty2, _, _), _)) when (memFlags1 = memFlags2 && nm1 = nm2 && // Multiple op_Explicit and op_Implicit constraints can exist for the same type variable. @@ -1584,8 +1582,8 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint = // T2 = ty2 let implies tpc1 tpc2 = match tpc1,tpc2 with - | TyparConstraint.MayResolveMember(trait1, _, _), - TyparConstraint.MayResolveMember(trait2, _, _) -> + | TyparConstraint.MayResolveMember(trait1, _), + TyparConstraint.MayResolveMember(trait2, _) -> traitsAEquiv g aenv trait1 trait2 | TyparConstraint.CoercesTo(ty1, _), TyparConstraint.CoercesTo(ty2, _) -> @@ -2529,8 +2527,8 @@ let EliminateConstraintsForGeneralizedTypars csenv (trace:OptionalTrace) (genera // No error recovery here: we do that on a per-expression basis. //------------------------------------------------------------------------- -let AddCxTypeEqualsType contextInfo denv nenv css m ty1 ty2 = - SolveTypEqualsTypWithReport (MakeConstraintSolverEnv contextInfo css m denv nenv) 0 m NoTrace None ty1 ty2 +let AddCxTypeEqualsType contextInfo denv css m ty1 ty2 = + SolveTypEqualsTypWithReport (MakeConstraintSolverEnv contextInfo css m denv) 0 m NoTrace None ty1 ty2 |> RaiseOperationResult let UndoIfFailed f = @@ -2550,86 +2548,84 @@ let UndoIfFailed f = ReportWarnings warns true -let AddCxTypeEqualsTypeUndoIfFailed denv nenv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m (WithTrace trace) ty1 ty2) +let AddCxTypeEqualsTypeUndoIfFailed denv css m ty1 ty2 = + UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) ty1 ty2) -let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv nenv css m ty1 ty2 = - let csenv = { MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv with MatchingOnly = true } +let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = + let csenv = { MakeConstraintSolverEnv ContextInfo.NoContext css m denv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs csenv 0 m (WithTrace trace) ty1 ty2) -let AddCxTypeMustSubsumeTypeUndoIfFailed denv nenv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m (WithTrace trace) None ty1 ty2) +let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 = + UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) None ty1 ty2) -let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv nenv css m ty1 ty2 = - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv +let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv let csenv = { csenv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs csenv 0 m (WithTrace trace) None ty1 ty2) -let AddCxTypeMustSubsumeType contextInfo denv nenv css m trace ty1 ty2 = - SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv contextInfo css m denv nenv) 0 m trace None ty1 ty2 +let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = + SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv contextInfo css m denv) 0 m trace None ty1 ty2 |> RaiseOperationResult -let AddCxMethodConstraint denv nenv css m trace (traitInfo : TraitConstraintInfo) = - let extVals = GetRelevantPossibleExtensionSolutionsToConstraint nenv traitInfo - TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) true (*permitWeakResolution*)false 0 m trace traitInfo extVals ++ (fun _ -> CompleteD)) +let AddCxMethodConstraint denv css m trace (traitInfo : TraitConstraintInfo) = + TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) true (*permitWeakResolution*)false 0 m trace traitInfo ++ (fun _ -> CompleteD)) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportNull denv nenv css m trace ty = - TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) +let AddCxTypeMustSupportNull denv css m trace ty = + TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportComparison denv nenv css m trace ty = - TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) +let AddCxTypeMustSupportComparison denv css m trace ty = + TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportEquality denv nenv css m trace ty = - TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) +let AddCxTypeMustSupportEquality denv css m trace ty = + TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeMustSupportDefaultCtor denv nenv css m trace ty = - TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) +let AddCxTypeMustSupportDefaultCtor denv css m trace ty = + TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsReferenceType denv nenv css m trace ty = - TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) +let AddCxTypeIsReferenceType denv css m trace ty = + TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsValueType denv nenv css m trace ty = - TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) +let AddCxTypeIsValueType denv css m trace ty = + TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsUnmanaged denv nenv css m trace ty = - TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty) +let AddCxTypeIsUnmanaged denv css m trace ty = + TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsEnum denv nenv css m trace ty underlying = - TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty underlying) +let AddCxTypeIsEnum denv css m trace ty underlying = + TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty underlying) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let AddCxTypeIsDelegate denv nenv css m trace ty aty bty = - TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m trace ty aty bty) +let AddCxTypeIsDelegate denv css m trace ty aty bty = + TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty aty bty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult -let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:TraitConstraintInfo) argExprs nenv = +let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:TraitConstraintInfo) argExprs = let css = { g = g amap = amap TcVal = tcVal ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = new InfoReader(g,amap) } - let extVals = GetRelevantPossibleExtensionSolutionsToConstraint nenv traitInfo - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) nenv - SolveMemberConstraint csenv true (*permitWeakResolution*)true 0 m NoTrace traitInfo extVals ++ (fun _res -> + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) + SolveMemberConstraint csenv true (*permitWeakResolution*)true 0 m NoTrace traitInfo ++ (fun _res -> let sln = match traitInfo.Solution with | None -> Choice4Of4() @@ -2712,20 +2708,20 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait | Choice4Of4 () -> ResultD None) -let ChooseTyparSolutionAndSolve css denv nenv tp = +let ChooseTyparSolutionAndSolve css denv tp = let g = css.g let amap = css.amap let max,m = ChooseTyparSolutionAndRange g amap tp - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv TryD (fun () -> SolveTyparEqualsTyp csenv 0 m NoTrace (mkTyparTy tp) max) (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) |> RaiseOperationResult -let CheckDeclaredTypars denv nenv css m typars1 typars2 = +let CheckDeclaredTypars denv css m typars1 typars2 = TryD (fun () -> CollectThenUndo (fun trace -> - SolveTypEqualsTypEqns (MakeConstraintSolverEnv ContextInfo.NoContext css m denv nenv) 0 m (WithTrace trace) None + SolveTypEqualsTypEqns (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace trace) None (List.map mkTyparTy typars1) (List.map mkTyparTy typars2))) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) @@ -2744,7 +2740,7 @@ let IsApplicableMethApprox g amap m (minfo:MethInfo) availObjTy = TcVal = (fun _ -> failwith "should not be called") ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = new InfoReader(g, amap) } - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) (NameResolutionEnv.Empty g) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) let minst = FreshenMethInfo None m minfo match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 8ce64986bf9..66462506c87 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -108,7 +108,7 @@ type ConstraintSolverEnv val BakedInTraitConstraintNames : Set -val MakeConstraintSolverEnv : ContextInfo -> ConstraintSolverState -> range -> DisplayEnv -> NameResolutionEnv -> ConstraintSolverEnv +val MakeConstraintSolverEnv : ContextInfo -> ConstraintSolverState -> range -> DisplayEnv -> ConstraintSolverEnv [] type Trace @@ -128,28 +128,31 @@ val ResolveOverloading : ConstraintSolverEnv -> OptionalTr val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> CalledMeth list -> TType -> OperationResult val EliminateConstraintsForGeneralizedTypars : ConstraintSolverEnv -> OptionalTrace -> Typars -> unit -val CheckDeclaredTypars : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit +val CheckDeclaredTypars : DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit val AddConstraint : ConstraintSolverEnv -> int -> Range.range -> OptionalTrace -> Typar -> TyparConstraint -> OperationResult -val AddCxTypeEqualsType : ContextInfo -> DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> unit -val AddCxTypeEqualsTypeUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeMustSubsumeType : ContextInfo -> DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit -val AddCxTypeMustSubsumeTypeUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxMethodConstraint : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TraitConstraintInfo -> unit -val AddCxTypeMustSupportNull : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportComparison : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportEquality : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeMustSupportDefaultCtor : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsReferenceType : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsValueType : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsUnmanaged : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit -val AddCxTypeIsEnum : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit -val AddCxTypeIsDelegate : DisplayEnv -> NameResolutionEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit - -val CodegenWitnessThatTypSupportsTraitConstraint : TcValF -> TcGlobals -> ImportMap -> range -> TraitConstraintInfo -> Expr list -> NameResolutionEnv -> OperationResult - -val ChooseTyparSolutionAndSolve : ConstraintSolverState -> DisplayEnv -> NameResolutionEnv -> Typar -> unit +val AddCxTypeEqualsType : ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit +val AddCxTypeEqualsTypeUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool +val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool +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 -> OptionalTrace -> TraitConstraintInfo -> unit +val AddCxTypeMustSupportNull : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportComparison : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportEquality : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeMustSupportDefaultCtor : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsReferenceType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsValueType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsUnmanaged : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> unit +val AddCxTypeIsEnum : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit +val AddCxTypeIsDelegate : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> TType -> unit + +val CodegenWitnessThatTypSupportsTraitConstraint : TcValF -> TcGlobals -> ImportMap -> range -> traitInfo: TraitConstraintInfo -> argExprs: Expr list -> OperationResult + +val ChooseTyparSolutionAndSolve : ConstraintSolverState -> DisplayEnv -> Typar -> unit + +/// Get the type variables that may help provide solutions to a statically resolved member trait constraint +val GetSupportOfMemberConstraint : ConstraintSolverEnv -> TraitConstraintInfo -> Typar list val IsApplicableMethApprox : TcGlobals -> ImportMap -> range -> MethInfo -> TType -> bool diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index c99328e8534..b4f86d86cf6 100644 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -1071,7 +1071,7 @@ lexIndentOffForML,"Consider using a file with extension '.ml' or '.mli' instead" 1212,tcOptionalArgsMustComeAfterNonOptionalArgs,"Optional arguments must come at the end of the argument list, after any non-optional arguments" 1213,tcConditionalAttributeUsage,"Attribute 'System.Diagnostics.ConditionalAttribute' is only valid on methods or attribute classes" #1214,monoRegistryBugWorkaround,"Could not determine highest installed .NET framework version from Registry keys, using version 2.0" -1215,tcMemberOperatorDefinitionInExtrinsic,"Extension members cannot provide operator overloads. Consider defining the operator as part of the type definition instead." +#1215,tcMemberOperatorDefinitionInExtrinsic,"Extension members cannot provide operator overloads. Consider defining the operator as part of the type definition instead." 1216,ilwriteMDBFileNameCannotBeChangedWarning,"The name of the MDB file must be .mdb. The --pdb option will be ignored." 1217,ilwriteMDBMemberMissing,"MDB generation failed. Could not find compatible member %s" 1218,ilwriteErrorCreatingMdb,"Cannot generate MDB debug information. Failed to load the 'MonoSymbolWriter' type from the 'Mono.CompilerServices.SymbolWriter.dll' assembly." diff --git a/src/fsharp/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index 484c9af1024..a6434a4e4e1 100644 --- a/src/fsharp/FindUnsolved.fs +++ b/src/fsharp/FindUnsolved.fs @@ -114,7 +114,7 @@ and accOp cenv env (op,tyargs,args,_m) = accTypeInst cenv env enclTypeArgs accTypeInst cenv env methTypeArgs accTypeInst cenv env tys - | TOp.TraitCall(TTrait(tys,_nm,_,argtys,rty,_sln)) -> + | TOp.TraitCall(TTrait(tys, _nm, _, argtys, rty, _sln, _extSlns)) -> argtys |> accTypeInst cenv env rty |> Option.iter (accTy cenv env) tys |> List.iter (accTy cenv env) diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 9a0be0e26c9..e054e9d6d50 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -187,7 +187,6 @@ type cenv = intraAssemblyInfo : IlxGenIntraAssemblyInfo /// Cache methods with SecurityAttribute applied to them, to prevent unnecessary calls to ExistsInEntireHierarchyOfType casApplied : Dictionary - nenv : NameResolution.NameResolutionEnv /// Used to apply forced inlining optimizations to witnesses generated late during codegen mutable optimizeDuringCodeGen : (Expr -> Expr) } @@ -3334,7 +3333,7 @@ and CommitCallSequel cenv eenv m cloc cgbuf mustGenerateUnitAfterCall sequel = and GenTraitCall cenv cgbuf eenv (traitInfo, argExprs, m) expr sequel = - let minfoOpt = CommitOperationResult (ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo argExprs cenv.nenv) + let minfoOpt = CommitOperationResult (ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo argExprs) match minfoOpt with | None -> let replacementExpr = @@ -7117,7 +7116,7 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal : Constra ilxGenEnv <- AddIncrementalLocalAssemblyFragmentToIlxGenEnv (amap, isIncrementalFragment, tcGlobals, ccu, fragName, intraAssemblyInfo, ilxGenEnv, typedImplFiles) /// Generate ILX code for an assembly fragment - member __.GenerateCode (codeGenOpts, typedAssembly, assemAttribs, moduleAttribs, nenv) = + member __.GenerateCode (codeGenOpts, typedAssembly, assemAttribs, moduleAttribs) = let cenv : cenv = { g=tcGlobals TcVal = tcVal @@ -7127,7 +7126,6 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal : Constra casApplied = casApplied intraAssemblyInfo = intraAssemblyInfo opts = codeGenOpts - nenv = nenv optimizeDuringCodeGen = (fun x -> x) } GenerateCode (cenv, ilxGenEnv, typedAssembly, assemAttribs, moduleAttribs) diff --git a/src/fsharp/IlxGen.fsi b/src/fsharp/IlxGen.fsi index 5b647762d9e..bd01f941284 100644 --- a/src/fsharp/IlxGen.fsi +++ b/src/fsharp/IlxGen.fsi @@ -69,7 +69,7 @@ type public IlxAssemblyGenerator = member AddIncrementalLocalAssemblyFragment : isIncrementalFragment: bool * fragName:string * typedImplFiles: TypedImplFile list -> unit /// Generate ILX code for an assembly fragment - member GenerateCode : IlxGenOptions * TypedAssemblyAfterOptimization * Attribs * Attribs * NameResolution.NameResolutionEnv -> IlxGenResults + member GenerateCode : IlxGenOptions * TypedAssemblyAfterOptimization * Attribs * Attribs -> IlxGenResults /// Create the CAS permission sets for an assembly fragment member CreatePermissionSets : Attrib list -> ILPermission list diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index ab6d2c0c762..aae55a83121 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -452,6 +452,9 @@ type CalledMeth<'T> member x.TotalNumUnnamedCallerArgs = x.ArgSets |> List.sumBy (fun x -> x.NumUnnamedCallerArgs) member x.TotalNumAssignedNamedArgs = x.ArgSets |> List.sumBy (fun x -> x.NumAssignedNamedArgs) + override x.ToString() = "call to " + minfo.ToString() + + let NamesOfCalledArgs (calledArgs: CalledArg list) = calledArgs |> List.choose (fun x -> x.NameOpt) @@ -634,7 +637,7 @@ let BuildFSharpMethodCall g m (typ,vref:ValRef) valUseFlags minst args = let vexp = Expr.Val (vref,valUseFlags,m) let vexpty = vref.Type let tpsorig,tau = vref.TypeScheme - let vtinst = argsOfAppTy g typ @ minst + let vtinst = (if vref.IsExtensionMember then [] else argsOfAppTy g typ) @ minst if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected List.length mismatch",m)) let expr = mkTyAppExpr m (vexp,vexpty) vtinst let exprty = instType (mkTyparInst tpsorig vtinst) tau diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index dda05a42423..0e49e7eff72 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -789,8 +789,8 @@ module private PrintTypes = cxs |> ListSet.setify (fun (_,cx1) (_,cx2) -> match cx1,cx2 with - | TyparConstraint.MayResolveMember(traitInfo1,_,_), - TyparConstraint.MayResolveMember(traitInfo2,_,_) -> traitsAEquiv denv.g TypeEquivEnv.Empty traitInfo1 traitInfo2 + | TyparConstraint.MayResolveMember(traitInfo1, _), + TyparConstraint.MayResolveMember(traitInfo2, _) -> traitsAEquiv denv.g TypeEquivEnv.Empty traitInfo1 traitInfo2 | _ -> false) let cxsL = List.collect (layoutConstraintWithInfo denv env) cxs @@ -810,7 +810,7 @@ module private PrintTypes = match tpc with | TyparConstraint.CoercesTo(tpct,_) -> [layoutTyparRefWithInfo denv env tp ^^ wordL (tagOperator ":>") --- layoutTypeWithInfo denv env tpct] - | TyparConstraint.MayResolveMember(traitInfo,_,_) -> + | TyparConstraint.MayResolveMember(traitInfo, _) -> [layoutTraitWithInfo denv env traitInfo] | TyparConstraint.DefaultsTo(_,ty,_) -> if denv.showTyparDefaultConstraints then [wordL (tagKeyword "default") ^^ layoutTyparRefWithInfo denv env tp ^^ WordL.colon ^^ layoutTypeWithInfo denv env ty] @@ -865,7 +865,7 @@ module private PrintTypes = WordL.arrow ^^ (layoutTyparRefWithInfo denv env tp)) |> longConstraintPrefix] - and private layoutTraitWithInfo denv env (TTrait(tys,nm,memFlags,argtys,rty,_)) = + and private layoutTraitWithInfo denv env (TTrait(tys, nm, memFlags, argtys, rty, _, _)) = let nm = DemangleOperatorName nm if denv.shortConstraints then WordL.keywordMember ^^ wordL (tagMember nm) diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 61c337af245..978a7529c00 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -321,7 +321,6 @@ type cenv = localInternalVals: System.Collections.Generic.Dictionary settings: OptimizationSettings emitTailcalls: bool - nenv : NameResolution.NameResolutionEnv // cache methods with SecurityAttribute applied to them, to prevent unnecessary calls to ExistsInEntireHierarchyOfType casApplied : Dictionary} @@ -1003,6 +1002,12 @@ let AbstractLazyModulInfoByHiding isAssemblyBoundary mhi = Zset.exists hiddenRecdField fvs.FreeRecdFields || Zset.exists hiddenUnionCase fvs.FreeUnionCases ) -> UnknownValue + + // TODO: consider what happens when the expression refers to extSlns that have become hidden + // At the moment it feels like this may lead to remap failures, where the optimization information + // for a module contains dangling references to extSlns that are no longer needed (because they have been solved). + // However, we don't save extSlns into actual pickled optimization information, so maybe this is not a problem. + // Check for escape in constant | ConstValue(_, ty) when (let ftyvs = freeInType CollectAll ty @@ -2165,10 +2170,10 @@ and OptimizeWhileLoop cenv env (spWhile, marker, e1, e2, m) = //------------------------------------------------------------------------- -and OptimizeTraitCall cenv env (traitInfo, args, m) = +and OptimizeTraitCall cenv env (traitInfo, args, m) = // Resolve the static overloading early (during the compulsory rewrite phase) so we can inline. - match ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo args cenv.nenv with + match ConstraintSolver.CodegenWitnessThatTypSupportsTraitConstraint cenv.TcVal cenv.g cenv.amap m traitInfo args with | OkResult (_, Some expr) -> OptimizeExpr cenv env expr @@ -3181,7 +3186,7 @@ and OptimizeImplFileInternal cenv env isIncrementalFragment hidden (TImplFile(qn // Entry point //------------------------------------------------------------------------- -let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementalFragment,emitTailcalls,hidden,mimpls,nenv) = +let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementalFragment,emitTailcalls,hidden,mimpls) = let cenv = { settings=settings scope=ccu @@ -3191,7 +3196,6 @@ let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementa optimizing=true localInternalVals=Dictionary(10000) emitTailcalls=emitTailcalls - nenv=nenv casApplied=new Dictionary() } let (optEnvNew,_,_,_ as results) = OptimizeImplFileInternal cenv optEnv isIncrementalFragment hidden mimpls let optimizeDuringCodeGen expr = OptimizeExpr cenv optEnvNew expr |> fst diff --git a/src/fsharp/Optimizer.fsi b/src/fsharp/Optimizer.fsi index fa8aeea231a..cbdf1a9c803 100644 --- a/src/fsharp/Optimizer.fsi +++ b/src/fsharp/Optimizer.fsi @@ -42,7 +42,7 @@ type IncrementalOptimizationEnv = val internal BindCcu : CcuThunk -> CcuOptimizationInfo -> IncrementalOptimizationEnv -> TcGlobals -> IncrementalOptimizationEnv /// Optimize one implementation file in the given environment -val internal OptimizeImplFile : OptimizationSettings * CcuThunk * TcGlobals * ConstraintSolver.TcValF * Import.ImportMap * IncrementalOptimizationEnv * isIncrementalFragment: bool * emitTaicalls: bool * SignatureHidingInfo * TypedImplFile * NameResolution.NameResolutionEnv -> (IncrementalOptimizationEnv * TypedImplFile * ImplFileOptimizationInfo * SignatureHidingInfo) * (Expr -> Expr) +val internal OptimizeImplFile : OptimizationSettings * CcuThunk * TcGlobals * ConstraintSolver.TcValF * Import.ImportMap * IncrementalOptimizationEnv * isIncrementalFragment: bool * emitTaicalls: bool * SignatureHidingInfo * TypedImplFile -> (IncrementalOptimizationEnv * TypedImplFile * ImplFileOptimizationInfo * SignatureHidingInfo) * (Expr -> Expr) #if DEBUG /// Displaying optimization data diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 3d4da30974f..3995ebc468e 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -213,7 +213,7 @@ let rec CheckTypeDeep ((visitTyp,visitTyconRefOpt,visitAppTyOpt,visitTraitSoluti | TType_var tp when tp.Solution.IsSome -> tp.Constraints |> List.iter (fun cx -> match cx with - | TyparConstraint.MayResolveMember((TTrait(_,_,_,_,_,soln)),_,_) -> + | TyparConstraint.MayResolveMember((TTrait(_, _, _, _, _, soln, _)), _) -> match visitTraitSolutionOpt, !soln with | Some visitTraitSolution, Some sln -> visitTraitSolution sln | _ -> () @@ -254,7 +254,7 @@ and CheckTypesDeep f g env tys = List.iter (CheckTypeDeep f g env) tys and CheckTypeConstraintDeep f g env x = match x with | TyparConstraint.CoercesTo(ty,_) -> CheckTypeDeep f g env ty - | TyparConstraint.MayResolveMember(traitInfo,_,_) -> CheckTraitInfoDeep f g env traitInfo + | TyparConstraint.MayResolveMember(traitInfo, _) -> CheckTraitInfoDeep f g env traitInfo | TyparConstraint.DefaultsTo(_,ty,_) -> CheckTypeDeep f g env ty | TyparConstraint.SimpleChoice(tys,_) -> CheckTypesDeep f g env tys | TyparConstraint.IsEnum(uty,_) -> CheckTypeDeep f g env uty @@ -266,7 +266,8 @@ and CheckTypeConstraintDeep f g env x = | TyparConstraint.IsUnmanaged _ | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> () -and CheckTraitInfoDeep ((_,_,_,visitTraitSolutionOpt,_) as f) g env (TTrait(typs,_,_,argtys,rty,soln)) = + +and CheckTraitInfoDeep ((_,_,_,visitTraitSolutionOpt,_) as f) g env (TTrait(typs, _, _, argtys, rty, soln, _extSlns)) = CheckTypesDeep f g env typs CheckTypesDeep f g env argtys Option.iter (CheckTypeDeep f g env) rty diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 7388fd28b74..01220650150 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -90,15 +90,25 @@ let emptyTyparInst = ([] : TyparInst) [] type Remap = { tpinst : TyparInst + + /// Values to remap valRemap: ValRemap + + /// TyconRefs to remap tyconRefRemap : TyconRefRemap - removeTraitSolutions: bool } + + /// Remove existing trait solutions? + removeTraitSolutions: bool + + /// A map indicating how to fill in extSlns for traits as we copy an expression. Indexed by the member name of the trait + extSlnsMap: Map } let emptyRemap = { tpinst = emptyTyparInst; tyconRefRemap = emptyTyconRefRemap valRemap = ValMap.Empty - removeTraitSolutions = false } + removeTraitSolutions = false + extSlnsMap = Map.empty } type Remap with static member Empty = emptyRemap @@ -228,8 +238,8 @@ and remapTyparConstraintsAux tyenv cs = match x with | TyparConstraint.CoercesTo(ty,m) -> Some(TyparConstraint.CoercesTo (remapTypeAux tyenv ty,m)) - | TyparConstraint.MayResolveMember(traitInfo,m,extVals) -> - Some(TyparConstraint.MayResolveMember (remapTraitAux tyenv traitInfo,m,List.map (remapValRef tyenv) extVals)) + | TyparConstraint.MayResolveMember(traitInfo, m) -> + Some(TyparConstraint.MayResolveMember (remapTraitAux tyenv traitInfo,m)) | TyparConstraint.DefaultsTo(priority,ty,m) -> Some(TyparConstraint.DefaultsTo(priority,remapTypeAux tyenv ty,m)) | TyparConstraint.IsEnum(uty,m) -> Some(TyparConstraint.IsEnum(remapTypeAux tyenv uty,m)) @@ -244,7 +254,7 @@ and remapTyparConstraintsAux tyenv cs = | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> Some(x)) -and remapTraitAux tyenv (TTrait(typs, nm, mf, argtys, rty, slnCell)) = +and remapTraitAux tyenv (TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns)) = let slnCell = match !slnCell with | None -> None @@ -263,7 +273,14 @@ and remapTraitAux tyenv (TTrait(typs, nm, mf, argtys, rty, slnCell)) = | ClosedExprSln e -> ClosedExprSln e // no need to remap because it is a closed expression, referring only to external types Some sln - // Note: we reallocate a new solution cell on every traversal of a trait constraint + + let extSlnsNew = + if tyenv.extSlnsMap.ContainsKey nm then + tyenv.extSlnsMap.[nm] + else + List.map (remapValRef tyenv) extSlns + + // Note: we reallocate a new solution cell (though keep existing solutions unless 'removeTraitSolutions'=true) on every traversal of a trait constraint // This feels incorrect for trait constraints that are quantified: it seems we should have // formal binders for trait constraints when they are quantified, just as // we have formal binders for type variables. @@ -271,7 +288,7 @@ and remapTraitAux tyenv (TTrait(typs, nm, mf, argtys, rty, slnCell)) = // The danger here is that a solution for one syntactic occurrence of a trait constraint won't // be propagated to other, "linked" solutions. However trait constraints don't appear in any algebra // in the same way as types - TTrait(remapTypesAux tyenv typs, nm, mf, remapTypesAux tyenv argtys, Option.map (remapTypeAux tyenv) rty, ref slnCell) + TTrait(remapTypesAux tyenv typs, nm, mf, remapTypesAux tyenv argtys, Option.map (remapTypeAux tyenv) rty, ref slnCell, extSlnsNew) and bindTypars tps tyargs tpinst = match tps with @@ -364,7 +381,8 @@ let mkInstRemap tpinst = { tyconRefRemap = emptyTyconRefRemap tpinst = tpinst valRemap = ValMap.Empty - removeTraitSolutions = false } + removeTraitSolutions = false + extSlnsMap = Map.empty } // entry points for "typar -> TType" instantiation let instType tpinst x = if isNil tpinst then x else remapTypeAux (mkInstRemap tpinst) x @@ -803,7 +821,7 @@ type TypeEquivEnv with static member FromEquivTypars tps1 tps2 = TypeEquivEnv.Empty.BindEquivTypars tps1 tps2 -let rec traitsAEquivAux erasureFlag g aenv (TTrait(typs1, nm, mf1, argtys, rty, _)) (TTrait(typs2, nm2, mf2, argtys2, rty2, _)) = +let rec traitsAEquivAux erasureFlag g aenv (TTrait(typs1, nm, mf1, argtys, rty, _, _)) (TTrait(typs2, nm2, mf2, argtys2, rty2, _, _)) = mf1 = mf2 && nm = nm2 && ListSet.equals (typeAEquivAux erasureFlag g aenv) typs1 typs2 && @@ -823,8 +841,8 @@ and typarConstraintsAEquivAux erasureFlag g aenv tpc1 tpc2 = TyparConstraint.CoercesTo(fcty, _) -> typeAEquivAux erasureFlag g aenv acty fcty - | TyparConstraint.MayResolveMember(trait1,_,_), - TyparConstraint.MayResolveMember(trait2,_,_) -> + | TyparConstraint.MayResolveMember(trait1, _), + TyparConstraint.MayResolveMember(trait2, _) -> traitsAEquivAux erasureFlag g aenv trait1 trait2 | TyparConstraint.DefaultsTo(_, acty, _), @@ -1886,7 +1904,7 @@ and accFreeInTyparConstraints opts cxs acc = and accFreeInTyparConstraint opts tpc acc = match tpc with | TyparConstraint.CoercesTo(typ, _) -> accFreeInType opts typ acc - | TyparConstraint.MayResolveMember (traitInfo, _, _) -> accFreeInTrait opts traitInfo acc + | TyparConstraint.MayResolveMember (traitInfo, _) -> accFreeInTrait opts traitInfo acc | TyparConstraint.DefaultsTo(_, rty, _) -> accFreeInType opts rty acc | TyparConstraint.SimpleChoice(tys, _) -> accFreeInTypes opts tys acc | TyparConstraint.IsEnum(uty, _) -> accFreeInType opts uty acc @@ -1899,7 +1917,7 @@ and accFreeInTyparConstraint opts tpc acc = | TyparConstraint.IsUnmanaged _ | TyparConstraint.RequiresDefaultConstructor _ -> acc -and accFreeInTrait opts (TTrait(typs, _, _, argtys, rty, sln)) acc = +and accFreeInTrait opts (TTrait(typs, _, _, argtys, rty, sln, _)) acc = Option.foldBack (accFreeInTraitSln opts) sln.Value (accFreeInTypes opts typs (accFreeInTypes opts argtys @@ -1991,7 +2009,7 @@ and accFreeInTyparConstraintsLeftToRight g cxFlag thruFlag acc cxs = and accFreeInTyparConstraintLeftToRight g cxFlag thruFlag acc tpc = match tpc with | TyparConstraint.CoercesTo(typ, _) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc typ - | TyparConstraint.MayResolveMember (traitInfo, _, _) -> accFreeInTraitLeftToRight g cxFlag thruFlag acc traitInfo + | TyparConstraint.MayResolveMember (traitInfo, _) -> accFreeInTraitLeftToRight g cxFlag thruFlag acc traitInfo | TyparConstraint.DefaultsTo(_, rty, _) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc rty | TyparConstraint.SimpleChoice(tys, _) -> accFreeInTypesLeftToRight g cxFlag thruFlag acc tys | TyparConstraint.IsEnum(uty, _) -> accFreeInTypeLeftToRight g cxFlag thruFlag acc uty @@ -2004,10 +2022,11 @@ and accFreeInTyparConstraintLeftToRight g cxFlag thruFlag acc tpc = | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> acc -and accFreeInTraitLeftToRight g cxFlag thruFlag acc (TTrait(typs, _, _, argtys, rty, _)) = +and accFreeInTraitLeftToRight g cxFlag thruFlag acc (TTrait(typs, _, _, argtys, rty, _, _extSlns)) = let acc = accFreeInTypesLeftToRight g cxFlag thruFlag acc typs let acc = accFreeInTypesLeftToRight g cxFlag thruFlag acc argtys let acc = Option.fold (accFreeInTypeLeftToRight g cxFlag thruFlag) acc rty + // Note, the _extSlns are _not_ considered free. acc and accFreeTyparRefLeftToRight g cxFlag thruFlag acc (tp:Typar) = @@ -2021,7 +2040,6 @@ and accFreeTyparRefLeftToRight g cxFlag thruFlag acc (tp:Typar) = acc and accFreeInTypeLeftToRight g cxFlag thruFlag acc ty = - if verbose then dprintf "--> accFreeInTypeLeftToRight \n" match (if thruFlag then stripTyEqns g ty else stripTyparEqns ty) with | TType_tuple (tupInfo, l) -> let acc = accFreeInTupInfoLeftToRight g cxFlag thruFlag acc tupInfo @@ -2049,6 +2067,51 @@ let freeInTypesLeftToRightSkippingConstraints g ty = accFreeInTypesLeftToRight g let valOfBind (b:Binding) = b.Var let valsOfBinds (binds:Bindings) = binds |> List.map (fun b -> b.Var) +//-------------------------------------------------------------------------- +// Collect extSlns. This is done prior to beta reduction of type parameters when inlining. We take the (solved) +// type arguments and strip them for extSlns, and record those extSlns in the remapped/copied/instantiated body +// of the implementation. +//-------------------------------------------------------------------------- + +let rec accExtSlnsInTyparConstraints acc cxs = + List.fold accExtSlnsInTyparConstraint acc cxs + +and accExtSlnsInTyparConstraint acc tpc = + match tpc with + | TyparConstraint.MayResolveMember (traitInfo, _) -> accExtSlnsInTrait acc traitInfo + | _ -> acc + +and accExtSlnsInTrait acc (TTrait(_typs, nm, _, _argtys, _rty, _, extSlns)) = + // We don't traverse the contents of traits, that wouldn't terminate and is not necessary since the type variables individiaull contain the extSlns we need + //let acc = accExtSlnsInTypes g acc typs + //let acc = accExtSlnsInTypes g acc argtys + //let acc = Option.fold (accExtSlnsInType g) acc rty + // Only record the extSlns if they have been solved in a useful way + if isNil extSlns then acc else + Map.add nm extSlns acc + +and accExtSlnsTyparRef acc (tp:Typar) = + let acc = accExtSlnsInTyparConstraints acc tp.Constraints + match tp.Solution with + | None -> acc + | Some sln -> accExtSlnsInType acc sln + +and accExtSlnsInType acc ty = + // NOTE: Unlike almost everywhere else, we do NOT strip ANY equations here. + // We _must_ traverse the solved typar containing the new extSlns for the grounded typar constraint, that's the whole point + match ty with + | TType_tuple (_tupInfo, l) -> accExtSlnsInTypes acc l + | TType_app (_, tinst) -> accExtSlnsInTypes acc tinst + | TType_ucase (_, tinst) -> accExtSlnsInTypes acc tinst + | TType_fun (d, r) -> accExtSlnsInType (accExtSlnsInType acc d) r + | TType_var r -> accExtSlnsTyparRef acc r + | TType_forall (_tps, r) -> accExtSlnsInType acc r + | TType_measure unt -> List.foldBack (fun (tp, _) acc -> accExtSlnsTyparRef acc tp) (ListMeasureVarOccsWithNonZeroExponents unt) acc + +and accExtSlnsInTypes acc tys = (acc, tys) ||> List.fold accExtSlnsInType + +let extSlnsInTypes tys = accExtSlnsInTypes Map.empty tys + //-------------------------------------------------------------------------- // Values representing member functions on F# types //-------------------------------------------------------------------------- @@ -2322,8 +2385,6 @@ module PrettyTypes = computeKeep keep (tp :: change) rest let keep, change = computeKeep [] [] ftps - // change |> List.iter (fun tp -> dprintf "change typar: %s %s %d\n" tp.Name (tp.DisplayName) (stamp_of_typar tp)); - // keep |> List.iter (fun tp -> dprintf "keep typar: %s %s %d\n" tp.Name (tp.DisplayName) (stamp_of_typar tp)); let alreadyInUse = keep |> List.map (fun x -> x.Name) let names = PrettyTyparNames (fun x -> List.memq x change) alreadyInUse ftps @@ -2337,7 +2398,6 @@ module PrettyTypes = let tauThings = mapTys getTauStayTau things let prettyThings = mapTys (instType renaming) tauThings - // niceTypars |> List.iter (fun tp -> dprintf "nice typar: %d\n" (stamp_of_typar tp)); * let tpconstraints = niceTypars |> List.collect (fun tpnice -> List.map (fun tpc -> tpnice, tpc) tpnice.Constraints) prettyThings, tpconstraints @@ -3129,7 +3189,7 @@ module DebugPrint = begin and auxTraitL env (ttrait: TraitConstraintInfo) = #if DEBUG - let (TTrait(tys, nm, memFlags, argtys, rty, _)) = ttrait + let (TTrait(tys, nm, memFlags, argtys, rty, _, _extSlns)) = ttrait match !global_g with | None -> wordL (tagText "") | Some g -> @@ -3149,7 +3209,7 @@ module DebugPrint = begin match tpc with | TyparConstraint.CoercesTo(typarConstrTyp, _) -> auxTypar2L env tp ^^ wordL (tagText ":>") --- auxTyparConstraintTypL env typarConstrTyp - | TyparConstraint.MayResolveMember(traitInfo, _, _) -> + | TyparConstraint.MayResolveMember(traitInfo, _) -> auxTypar2L env tp ^^ wordL (tagText ":") --- auxTraitL env traitInfo | TyparConstraint.DefaultsTo(_, ty, _) -> wordL (tagText "default") ^^ auxTypar2L env tp ^^ wordL (tagText ":") ^^ auxTypeL env ty @@ -3701,7 +3761,8 @@ let mkRepackageRemapping mrpi = { valRemap = ValMap.OfList (mrpi.mrpiVals |> List.map (fun (vref, x) -> vref.Deref, x)); tpinst = emptyTyparInst; tyconRefRemap = TyconRefMap.OfList mrpi.mrpiEntities - removeTraitSolutions = false } + removeTraitSolutions = false + extSlnsMap = Map.empty } //-------------------------------------------------------------------------- // Compute instances of the above for mty -> mty @@ -3777,7 +3838,6 @@ let accValRemap g aenv (msigty:ModuleOrNamespaceType) (implVal:Val) (mrpi, mhi) let vref = mkLocalValRef implVal match sigValOpt with | None -> - if verbose then dprintf "accValRemap, hide = %s#%d\n" implVal.LogicalName implVal.Stamp let mhi = { mhi with mhiVals = Zset.add implVal mhi.mhiVals } (mrpi, mhi) | Some (sigVal:Val) -> @@ -3801,7 +3861,6 @@ let rec accValRemapFromModuleOrNamespaceType g aenv (mty:ModuleOrNamespaceType) acc let ComputeRemappingFromInferredSignatureToExplicitSignature g mty msigty = - // dprintf "ComputeRemappingFromInferredSignatureToExplicitSignature, \nmty = %s\nmmsigty=%s\n" (showL(entityTypeL mty)) (showL(entityTypeL msigty)); let ((mrpi, _) as entityRemap) = accEntityRemapFromModuleOrNamespaceType mty msigty (SignatureRepackageInfo.Empty, SignatureHidingInfo.Empty) let aenv = mrpi.ImplToSigMapping let valAndEntityRemap = accValRemapFromModuleOrNamespaceType g aenv mty msigty entityRemap @@ -3862,7 +3921,6 @@ and accValRemapFromModuleOrNamespaceBind g aenv msigty x acc = and accValRemapFromModuleOrNamespaceDefs g aenv msigty mdefs acc = List.foldBack (accValRemapFromModuleOrNamespace g aenv msigty) mdefs acc let ComputeRemappingFromImplementationToSignature g mdef msigty = - //if verbose then dprintf "ComputeRemappingFromImplementationToSignature, \nmdefs = %s\nmsigty=%s\n" (showL(DebugPrint.mdefL mdef)) (showL(DebugPrint.entityTypeL msigty)); let ((mrpi, _) as entityRemap) = accEntityRemapFromModuleOrNamespace msigty mdef (SignatureRepackageInfo.Empty, SignatureHidingInfo.Empty) let aenv = mrpi.ImplToSigMapping @@ -3920,16 +3978,14 @@ let rec accModuleOrNamespaceHidingInfoAtAssemblyBoundary mty acc = acc let ComputeHidingInfoAtAssemblyBoundary mty acc = -// dprintf "ComputeRemappingFromInferredSignatureToExplicitSignature, \nmty = %s\nmmsigty=%s\n" (showL(entityTypeL mty)) (showL(entityTypeL msigty)); accModuleOrNamespaceHidingInfoAtAssemblyBoundary mty acc //-------------------------------------------------------------------------- // Compute instances of the above for mexpr -> mty //-------------------------------------------------------------------------- -let IsHidden setF accessF remapF debugF = +let IsHidden setF accessF remapF = let rec check mrmi x = - if verbose then dprintf "IsHidden %s ??\n" (showL (debugF x)); // Internal/private? not (canAccessFromEverywhere (accessF x)) || (match mrmi with @@ -3940,14 +3996,12 @@ let IsHidden setF accessF remapF debugF = // Recurse... check rest (remapF rpi x)) fun mrmi x -> - let res = check mrmi x - if verbose then dprintf "IsHidden, #mrmi = %d, %s = %b\n" mrmi.Length (showL (debugF x)) res; - res + check mrmi x -let IsHiddenTycon mrmi x = IsHidden (fun mhi -> mhi.mhiTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x -let IsHiddenTyconRepr mrmi x = IsHidden (fun mhi -> mhi.mhiTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) DebugPrint.tyconL mrmi x -let IsHiddenVal mrmi x = IsHidden (fun mhi -> mhi.mhiVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) DebugPrint.valL mrmi x -let IsHiddenRecdField mrmi x = IsHidden (fun mhi -> mhi.mhiRecdFields) (fun rfref -> rfref.RecdField.Accessibility) (fun rpi x -> remapRecdFieldRef rpi.tyconRefRemap x) DebugPrint.recdFieldRefL mrmi x +let IsHiddenTycon mrmi x = IsHidden (fun mhi -> mhi.mhiTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) mrmi x +let IsHiddenTyconRepr mrmi x = IsHidden (fun mhi -> mhi.mhiTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) mrmi x +let IsHiddenVal mrmi x = IsHidden (fun mhi -> mhi.mhiVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) mrmi x +let IsHiddenRecdField mrmi x = IsHidden (fun mhi -> mhi.mhiRecdFields) (fun rfref -> rfref.RecdField.Accessibility) (fun rpi x -> remapRecdFieldRef rpi.tyconRefRemap x) mrmi x //-------------------------------------------------------------------------- @@ -4295,7 +4349,7 @@ and accFreeInOp opts op acc = | TOp.ILAsm (_, tys) -> accFreeVarsInTys opts tys acc | TOp.Reraise -> accUsesRethrow true acc - | TOp.TraitCall(TTrait(tys, _, _, argtys, rty, sln)) -> + | TOp.TraitCall(TTrait(tys, _, _, argtys, rty, sln, _extSlns)) -> Option.foldBack (accFreeVarsInTraitSln opts) sln.Value (accFreeVarsInTys opts tys (accFreeVarsInTys opts argtys @@ -5107,7 +5161,10 @@ let copyModuleOrNamespaceType g compgen mtyp = copyAndRemapAndBindModTy g co let copyExpr g compgen e = remapExpr g compgen Remap.Empty e let copyImplFile g compgen e = remapImplFile g compgen Remap.Empty e |> fst -let instExpr g tpinst e = remapExpr g CloneAll (mkInstRemap tpinst) e +/// Copy an expression applying a type instantiation. +let instExpr g tpinst e = + let extSlnsMap = extSlnsInTypes (List.map snd tpinst) + remapExpr g CloneAll { mkInstRemap tpinst with extSlnsMap = extSlnsMap } e //-------------------------------------------------------------------------- // Replace Marks - adjust debugging marks when a lambda gets @@ -5281,7 +5338,7 @@ let rec tyOfExpr g e = | TOp.LValueOp (LByrefGet, v) -> destByrefTy g v.Type | TOp.LValueOp (LGetAddr, v) -> mkByrefTy g v.Type | TOp.RefAddrGet -> (match tinst with [ty] -> mkByrefTy g ty | _ -> failwith "bad TOp.RefAddrGet node") - | TOp.TraitCall (TTrait(_, _, _, _, ty, _)) -> GetFSharpViewOfReturnType g ty + | TOp.TraitCall (TTrait(_, _, _, _, ty, _, _)) -> GetFSharpViewOfReturnType g ty | TOp.Reraise -> (match tinst with [rtn_ty] -> rtn_ty | _ -> failwith "bad TOp.Reraise node") | TOp.Goto _ | TOp.Label _ | TOp.Return -> //assert false; @@ -6476,7 +6533,6 @@ let MultiLambdaToTupledLambdaIfNeeded g (vs, arg) body = //------------------------------------------------------------------------ let rec MakeApplicationAndBetaReduceAux g (f, fty, tyargsl : TType list list, argsl: Expr list, m) = - (* let verbose = true in *) match f with | Expr.Let(bind, body, mlet, _) -> // Lift bindings out, i.e. (let x = e in f) y --> let x = e in f y @@ -6996,7 +7052,6 @@ let typarEnc _g (gtpsType, gtpsMethod) typar = "``0" // REVIEW: this should be ERROR not WARNING? let rec typeEnc g (gtpsType, gtpsMethod) ty = - if verbose then dprintf "--> typeEnc" let stripped = stripTyEqnsAndMeasureEqns g ty match stripped with | TType_forall _ -> diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 88085981e0d..2213fb5565b 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -339,10 +339,19 @@ type ValRemap = ValMap [] type Remap = - { tpinst : TyparInst; - valRemap: ValRemap; - tyconRefRemap : TyconRefRemap; - removeTraitSolutions: bool } + { tpinst : TyparInst + + /// Values to remap + valRemap: ValRemap + + /// TyconRefs to remap + tyconRefRemap : TyconRefRemap + + /// Remove existing trait solutions? + removeTraitSolutions: bool + + /// A map indicating how to fill in extSlns for traits as we copy an expression. Indexed by the member name of the trait + extSlnsMap: Map } static member Empty : Remap diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index 7d19a83e62b..aa2137f12bb 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -1320,7 +1320,8 @@ let p_trait_sln sln st = | FSRecdFieldSln(a,b,c) -> p_byte 4 st; p_tup3 p_typs p_rfref p_bool (a,b,c) st -let p_trait (TTrait(a,b,c,d,e,f)) st = +let p_trait (TTrait(a, b, c, d, e, f, _extSlns)) st = + // The _extSlns do not get pickled. We are assuming this is a generic or solved constraint p_tup6 p_typs p_string p_MemberFlags p_typs (p_option p_typ) (p_option p_trait_sln) (a,b,c,d,e,!f) st // We have to store trait solutions since they can occur in optimization data @@ -1344,7 +1345,8 @@ let u_trait_sln st = let u_trait st = let a,b,c,d,e,f = u_tup6 u_typs u_string u_MemberFlags u_typs (u_option u_typ) (u_option u_trait_sln) st - TTrait (a,b,c,d,e,ref f) + // extSlns starts empty. TODO: check the ramifications of this + TTrait (a, b, c, d, e, ref f, []) let p_rational q st = p_int32 (GetNumerator q) st; p_int32 (GetDenominator q) st @@ -1417,25 +1419,25 @@ let rec u_measure_expr st = let p_typar_constraint x st = match x with | TyparConstraint.CoercesTo (a,_) -> p_byte 0 st; p_typ a st - | TyparConstraint.MayResolveMember(traitInfo,_,_) -> p_byte 1 st; p_trait traitInfo st + | TyparConstraint.MayResolveMember(traitInfo,_) -> p_byte 1 st; p_trait traitInfo st | TyparConstraint.DefaultsTo(_,rty,_) -> p_byte 2 st; p_typ rty st - | TyparConstraint.SupportsNull _ -> p_byte 3 st - | TyparConstraint.IsNonNullableStruct _ -> p_byte 4 st - | TyparConstraint.IsReferenceType _ -> p_byte 5 st - | TyparConstraint.RequiresDefaultConstructor _ -> p_byte 6 st - | TyparConstraint.SimpleChoice(tys,_) -> p_byte 7 st; p_typs tys st - | TyparConstraint.IsEnum(ty,_) -> p_byte 8 st; p_typ ty st - | TyparConstraint.IsDelegate(aty,bty,_) -> p_byte 9 st; p_typ aty st; p_typ bty st - | TyparConstraint.SupportsComparison _ -> p_byte 10 st - | TyparConstraint.SupportsEquality _ -> p_byte 11 st - | TyparConstraint.IsUnmanaged _ -> p_byte 12 st + | TyparConstraint.SupportsNull _ -> p_byte 3 st + | TyparConstraint.IsNonNullableStruct _ -> p_byte 4 st + | TyparConstraint.IsReferenceType _ -> p_byte 5 st + | TyparConstraint.RequiresDefaultConstructor _ -> p_byte 6 st + | TyparConstraint.SimpleChoice(tys,_) -> p_byte 7 st; p_typs tys st + | TyparConstraint.IsEnum(ty,_) -> p_byte 8 st; p_typ ty st + | TyparConstraint.IsDelegate(aty,bty,_) -> p_byte 9 st; p_typ aty st; p_typ bty st + | TyparConstraint.SupportsComparison _ -> p_byte 10 st + | TyparConstraint.SupportsEquality _ -> p_byte 11 st + | TyparConstraint.IsUnmanaged _ -> p_byte 12 st let p_typar_constraints = (p_list p_typar_constraint) let u_typar_constraint st = let tag = u_byte st match tag with | 0 -> u_typ st |> (fun a _ -> TyparConstraint.CoercesTo (a,range0) ) - | 1 -> u_trait st |> (fun a _ -> TyparConstraint.MayResolveMember(a,range0,[])) + | 1 -> u_trait st |> (fun a _ -> TyparConstraint.MayResolveMember(a,range0)) | 2 -> u_typ st |> (fun a ridx -> TyparConstraint.DefaultsTo(ridx,a,range0)) | 3 -> (fun _ -> TyparConstraint.SupportsNull range0) | 4 -> (fun _ -> TyparConstraint.IsNonNullableStruct range0) diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 8565d6d7e91..22c5d66e208 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -595,7 +595,7 @@ let CopyAndFixupTypars getExtSlnsOpt m rigid tpsorig = ConstraintSolver.FreshenAndFixupTypars getExtSlnsOpt m rigid [] [] tpsorig let UnifyTypes cenv (env: TcEnv) m expectedTy actualTy = - ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv env.NameEnv cenv.css m (tryNormalizeMeasureInType cenv.g expectedTy) (tryNormalizeMeasureInType cenv.g actualTy) + ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g expectedTy) (tryNormalizeMeasureInType cenv.g actualTy) //------------------------------------------------------------------------- // Generate references to the module being generated - used for @@ -703,7 +703,7 @@ let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath env = /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyRefTupleType contextInfo cenv denv nenv m ty ps = +let UnifyRefTupleType contextInfo cenv denv m ty ps = let ptys = if isRefTupleTy cenv.g ty then let ptys = destRefTupleTy cenv.g ty @@ -716,30 +716,30 @@ let UnifyRefTupleType contextInfo cenv denv nenv m ty ps = | ContextInfo.RecordFields -> ContextInfo.TupleInRecordFields | _ -> contextInfo - AddCxTypeEqualsType contextInfo denv nenv cenv.css m ty (TType_tuple (tupInfoRef, ptys)) + AddCxTypeEqualsType contextInfo denv cenv.css m ty (TType_tuple (tupInfoRef, ptys)) ptys /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyStructTupleType contextInfo cenv denv nenv m ty ps = +let UnifyStructTupleType contextInfo cenv denv m ty ps = let ptys = if isStructTupleTy cenv.g ty then let ptys = destStructTupleTy cenv.g ty if List.length ps = List.length ptys then ptys else NewInferenceTypes ps else NewInferenceTypes ps - AddCxTypeEqualsType contextInfo denv nenv cenv.css m ty (TType_tuple (tupInfoStruct, ptys)) + AddCxTypeEqualsType contextInfo denv cenv.css m ty (TType_tuple (tupInfoStruct, ptys)) ptys /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyFunctionTypeUndoIfFailed cenv denv nenv m ty = +let UnifyFunctionTypeUndoIfFailed cenv denv m ty = match tryDestFunTy cenv.g ty with | None -> let domainTy = NewInferenceType () let resultTy = NewInferenceType () - if AddCxTypeEqualsTypeUndoIfFailed denv nenv cenv.css m ty (domainTy --> resultTy) then + if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty (domainTy --> resultTy) then Some(domainTy, resultTy) else None @@ -747,8 +747,8 @@ let UnifyFunctionTypeUndoIfFailed cenv denv nenv m ty = /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyFunctionType extraInfo cenv denv nenv mFunExpr ty = - match UnifyFunctionTypeUndoIfFailed cenv denv nenv mFunExpr ty with +let UnifyFunctionType extraInfo cenv denv mFunExpr ty = + match UnifyFunctionTypeUndoIfFailed cenv denv mFunExpr ty with | Some res -> res | None -> match extraInfo with @@ -794,13 +794,13 @@ let ReportImplicitlyIgnoredBoolExpression denv m ty expr = | Some expr -> checkExpr m expr | _ -> UnitTypeExpected (denv, ty, m) -let UnifyUnitType cenv denv nenv m ty exprOpt = - if AddCxTypeEqualsTypeUndoIfFailed denv nenv cenv.css m ty cenv.g.unit_ty then +let UnifyUnitType cenv denv m ty exprOpt = + if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty cenv.g.unit_ty then true else let domainTy = NewInferenceType () let resultTy = NewInferenceType () - if AddCxTypeEqualsTypeUndoIfFailed denv nenv cenv.css m ty (domainTy --> resultTy) then + if AddCxTypeEqualsTypeUndoIfFailed denv cenv.css m ty (domainTy --> resultTy) then warning (FunctionValueUnexpected(denv, ty, m)) else if not (typeEquiv cenv.g cenv.g.bool_ty ty) then @@ -1046,9 +1046,6 @@ let MakeMemberDataAndMangledNameForMemberVal(g, tcref, isExtrinsic, attrs, optIm if n<>3 && opTakesThreeArgs then warning(Error(FSComp.SR.memberOperatorDefinitionWithNonTripleArgument(name, n), m)) if not (isNil otherArgs) then warning(Error(FSComp.SR.memberOperatorDefinitionWithCurriedArguments(name), m)) - if isExtrinsic && IsMangledOpName id.idText then - warning(Error(FSComp.SR.tcMemberOperatorDefinitionInExtrinsic(), id.idRange)) - ValMemberInfoTransient(memberInfo, logicalName, compiledName) @@ -2180,7 +2177,7 @@ module GeneralizationHelpers = TrimUngeneralizableTypars genConstrainedTyparFlag inlineFlag generalizedTypars freeInEnv /// Condense type variables in positive position - let CondenseTypars (cenv, denv:DisplayEnv, generalizedTypars: Typars, tauTy, m, nenv:NameResolutionEnv) = + let CondenseTypars (cenv, denv:DisplayEnv, generalizedTypars: Typars, tauTy, m) = // The type of the value is ty11 * ... * ty1N -> ... -> tyM1 * ... * tyMM -> retTy // This is computed REGARDLESS of the arity of the expression. @@ -2232,19 +2229,18 @@ module GeneralizationHelpers = // Condensation solves type variables eagerly and removes them from the generalization set condensationTypars |> List.iter (fun tp -> - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv nenv tp) + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp) generalizedTypars - let CanonicalizePartialInferenceProblem (cenv, denv, nenv ,m) tps = + let CanonicalizePartialInferenceProblem (cenv, denv, m) tps = // Canonicalize constraints prior to generalization - let csenv = (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv nenv) + let csenv = (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) TryD (fun () -> ConstraintSolver.CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let ComputeAndGeneralizeGenericTypars (cenv, denv:DisplayEnv, - nenv:NameResolutionEnv, m, freeInEnv:FreeTypars, canInferTypars, @@ -2271,7 +2267,7 @@ module GeneralizationHelpers = let ty = mkTyparTy tp error(Error(FSComp.SR.tcNotSufficientlyGenericBecauseOfScope(NicePrint.prettyStringOfTy denv ty), m))) - let generalizedTypars = CondenseTypars(cenv, denv, generalizedTypars, tauTy, m, nenv) + let generalizedTypars = CondenseTypars(cenv, denv, generalizedTypars, tauTy, m) let generalizedTypars = if canInferTypars then generalizedTypars @@ -2285,7 +2281,7 @@ module GeneralizationHelpers = generalizedTypars |> List.iter (SetTyparRigid cenv.g denv m) // Generalization removes constraints related to generalized type variables - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv nenv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv EliminateConstraintsForGeneralizedTypars csenv NoTrace generalizedTypars generalizedTypars @@ -2682,7 +2678,7 @@ let TcValEarlyGeneralizationConsistencyCheck cenv (env:TcEnv) (v:Val, vrec, tins let tpsorig = NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g tpsorig let tau3 = instType (mkTyparInst tpsorig tinst) tau2 //printfn "tau3 = '%s'" (DebugPrint.showType tau3) - if not (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m tau tau3) then + if not (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m tau tau3) then let txt = bufs (fun buf -> NicePrint.outputQualifiedValSpec env.DisplayEnv buf v) error(Error(FSComp.SR.tcInferredGenericTypeGivesRiseToInconsistency(v.DisplayName, txt), m))) | _ -> () @@ -2912,7 +2908,7 @@ let MakeApplicableExprWithFlex cenv (env: TcEnv) expr = then actualType else let flexibleType = NewInferenceType () - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace actualType flexibleType; + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace actualType flexibleType; flexibleType) // Create a coercion to represent the expansion of the application @@ -2921,7 +2917,7 @@ let MakeApplicableExprWithFlex cenv (env: TcEnv) expr = /// Checks, warnings and constraint assertions for downcasts -let TcRuntimeTypeTest isCast isOperator cenv denv nenv m tgty srcTy = +let TcRuntimeTypeTest isCast isOperator cenv denv m tgty srcTy = if TypeDefinitelySubsumesTypeNoCoercion 0 cenv.g cenv.amap m tgty srcTy then warning(TypeTestUnnecessary(m)) @@ -2933,9 +2929,9 @@ let TcRuntimeTypeTest isCast isOperator cenv denv nenv m tgty srcTy = if isSealedTy cenv.g tgty || isTyparTy cenv.g tgty || not (isInterfaceTy cenv.g srcTy) then if isCast then - AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv nenv cenv.css m NoTrace srcTy tgty + AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv cenv.css m NoTrace srcTy tgty else - AddCxTypeMustSubsumeType ContextInfo.NoContext denv nenv cenv.css m NoTrace srcTy tgty + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace srcTy tgty if isErasedType cenv.g tgty then if isCast then @@ -2949,7 +2945,7 @@ let TcRuntimeTypeTest isCast isOperator cenv denv nenv m tgty srcTy = else warning(Error(FSComp.SR.tcTypeTestLossy(NicePrint.minimalStringOfType denv ety, NicePrint.minimalStringOfType denv (stripTyEqnsWrtErasure EraseAll cenv.g ety)), m))) /// Checks, warnings and constraint assertions for upcasts -let TcStaticUpcast cenv denv nenv m tgty srcTy = +let TcStaticUpcast cenv denv m tgty srcTy = if isTyparTy cenv.g tgty then error(IndeterminateStaticCoercion(denv, srcTy, tgty, m)) @@ -2959,7 +2955,7 @@ let TcStaticUpcast cenv denv nenv m tgty srcTy = if typeEquiv cenv.g srcTy tgty then warning(UpcastUnnecessary(m)) - AddCxTypeMustSubsumeType ContextInfo.NoContext denv nenv cenv.css m NoTrace tgty srcTy + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace tgty srcTy @@ -3330,7 +3326,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> let probe ty = - if (AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m ty exprty) then + if (AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m ty exprty) then match tryType (mkCoerceExpr(expr, ty, expr.Range, exprty), ty) with | Result res -> Some res | Exception e -> @@ -3357,7 +3353,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr let ConvertArbitraryExprToEnumerable cenv ty (env: TcEnv) (expr:Expr) = let m = expr.Range let enumElemTy = NewInferenceType () - if AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m ( mkSeqTy cenv.g enumElemTy) ty then + if AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m ( mkSeqTy cenv.g enumElemTy) ty then expr, enumElemTy else let enumerableVar, enumerableExpr = mkCompGenLocal m "inputSequence" ty @@ -3385,7 +3381,7 @@ let mkSeqCollect cenv env m enumElemTy genTy lam enumExpr = mkCallSeqCollect cenv.g m enumElemTy genResultTy lam enumExpr let mkSeqUsing cenv (env: TcEnv) m resourceTy genTy resourceExpr lam = - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace cenv.g.system_IDisposable_typ resourceTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace cenv.g.system_IDisposable_typ resourceTy let genResultTy = NewInferenceType () UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) mkCallSeqUsing cenv.g m resourceTy genResultTy resourceExpr lam @@ -4149,14 +4145,14 @@ let GetInstanceMemberThisVariable (v:Val, x) = 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 env.NameEnv cenv.css m NoTrace (mkTyparTy tp') + constraintAdder env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') tpenv match c with | WhereTyparDefaultsToType(tp, ty, m) -> let ty', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty let tp', tpenv = TcTypar cenv env newOk tpenv tp - let csenv = MakeConstraintSolverEnv env.eContextInfo cenv.css m env.DisplayEnv env.NameEnv + let csenv = MakeConstraintSolverEnv env.eContextInfo cenv.css m env.DisplayEnv AddConstraint csenv 0 m NoTrace tp' (TyparConstraint.DefaultsTo(ridx, ty', m)) |> CommitOperationResult tpenv @@ -4165,7 +4161,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 env.NameEnv cenv.css m NoTrace ty' (mkTyparTy tp') + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp') tpenv | WhereTyparSupportsNull(tp, m) -> checkSimpleConstraint tp m AddCxTypeMustSupportNull @@ -4186,7 +4182,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 env.NameEnv cenv.css m NoTrace (mkTyparTy tp') underlying' + AddCxTypeIsEnum env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') underlying' tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) @@ -4199,7 +4195,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 env.NameEnv cenv.css m NoTrace (mkTyparTy tp') a' b' + AddCxTypeIsDelegate env.DisplayEnv cenv.css m NoTrace (mkTyparTy tp') a' b' tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidEnumConstraint(), m)) @@ -4208,16 +4204,16 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | WhereTyparSupportsMember(tps, memSpfn, m) -> let traitInfo, tpenv = TcPseudoMemberSpec cenv newOk env tps tpenv memSpfn m match traitInfo with - | TTrait(objtys, ".ctor", memberFlags, argtys, returnTy, _) when memberFlags.MemberKind = MemberKind.Constructor -> + | TTrait(objtys, ".ctor", memberFlags, argtys, returnTy, _, _) when memberFlags.MemberKind = MemberKind.Constructor -> match objtys, argtys with | [ty], [] when typeEquiv cenv.g ty (GetFSharpViewOfReturnType cenv.g returnTy) -> - AddCxTypeMustSupportDefaultCtor env.DisplayEnv env.NameEnv cenv.css m NoTrace ty + AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m NoTrace ty tpenv | _ -> errorR(Error(FSComp.SR.tcInvalidNewConstraint(), m)) tpenv | _ -> - AddCxMethodConstraint env.DisplayEnv env.NameEnv cenv.css m NoTrace traitInfo + AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo tpenv and TcPseudoMemberSpec cenv newOk env synTypes tpenv memSpfn m = @@ -4244,8 +4240,11 @@ and TcPseudoMemberSpec cenv newOk env synTypes tpenv memSpfn m = let item = Item.ArgName (id, memberConstraintTy, None) CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) - TTrait(tys, logicalCompiledName, memberFlags, argtys, returnTy, ref None), tpenv + // extSlns starts off empty because the trait has some support + TTrait(tys, logicalCompiledName, memberFlags, argtys, returnTy, ref None, []), tpenv + | _ -> error(Error(FSComp.SR.tcInvalidConstraint(), m)) + | _ -> error(Error(FSComp.SR.tcInvalidConstraint(), m)) @@ -4565,7 +4564,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped | 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 env.NameEnv cenv.css m NoTrace ty' (mkTyparTy tp) + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp) tp.AsType, tpenv | SynType.StaticConstant (c, m) -> @@ -5016,7 +5015,7 @@ and TcSimplePats cenv optArgsOK checkCxs ty env (tpenv, names, takenNames:Set<_ [v], (tpenv, names, takenNames) | SynSimplePats.SimplePats (ps, m) -> - let ptys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv env.NameEnv m ty ps + let ptys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv m ty ps let ps', (tpenv, names, takenNames) = List.mapFold (fun tpenv (ty, e) -> TcSimplePat optArgsOK checkCxs cenv ty env tpenv e) (tpenv, names, takenNames) (List.zip ptys ps) ps', (tpenv, names, takenNames) @@ -5103,7 +5102,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | SynPat.Named (SynPat.IsInst(cty, m), _, _, _, _) -> let srcTy = ty let tgty, tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurence.UseInType env tpenv cty - TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv env.NameEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv m tgty srcTy match pat with | SynPat.IsInst(_, m) -> (fun _ -> TPat_isinst (srcTy, tgty, None, m)), (tpenv, names, takenNames) @@ -5394,7 +5393,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 -> - AddCxTypeMustSupportNull env.DisplayEnv env.NameEnv cenv.css m NoTrace ty + AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace ty (fun _ -> TPat_null m), (tpenv, names, takenNames) | SynPat.InstanceMember (_, _, _, _, m) -> @@ -5409,10 +5408,10 @@ and TcPatterns warnOnUpper cenv env vFlags s argtys args = List.mapFold (fun s (ty, pat) -> TcPat warnOnUpper cenv env None vFlags s ty pat) s (List.zip argtys args) -and solveTypAsError cenv denv nenv m ty = +and solveTypAsError cenv denv m ty = let ty2 = NewErrorType () assert((destTyparTy cenv.g ty2).IsFromError) - SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv nenv) 0 m NoTrace ty ty2 |> ignore + SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) 0 m NoTrace ty ty2 |> ignore and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv expr = // This function is motivated by cases like @@ -5460,7 +5459,7 @@ and TcExprOfUnknownType cenv env tpenv expr = and TcExprFlex cenv flex ty (env: TcEnv) tpenv (e: SynExpr) = if flex then let argty = NewInferenceType () - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css e.Range NoTrace ty argty + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css e.Range NoTrace ty argty let e', tpenv = TcExpr cenv argty env tpenv e let e' = mkCoerceIfNeeded cenv.g ty argty e' e', tpenv @@ -5479,7 +5478,7 @@ and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) = // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error errorRecovery e m - solveTypAsError cenv env.DisplayEnv env.NameEnv m ty + solveTypAsError cenv env.DisplayEnv m ty mkThrow m ty (mkOne cenv.g m), tpenv and TcExprNoRecover cenv ty (env: TcEnv) tpenv (expr: SynExpr) = @@ -5504,7 +5503,7 @@ and TcExprOfUnknownTypeThen cenv env tpenv expr delayed = with e -> let m = expr.Range errorRecovery e m - solveTypAsError cenv env.DisplayEnv env.NameEnv m exprty + solveTypAsError cenv env.DisplayEnv m exprty mkThrow m exprty (mkOne cenv.g m), tpenv expr', exprty, tpenv @@ -5534,7 +5533,7 @@ and TcStmtThatCantBeCtorBody cenv env tpenv expr = and TcStmt cenv env tpenv synExpr = let expr, ty, tpenv = TcExprOfUnknownType cenv env tpenv synExpr let m = synExpr.Range - let wasUnit = UnifyUnitType cenv env.DisplayEnv env.NameEnv m ty (Some expr) + let wasUnit = UnifyUnitType cenv env.DisplayEnv m ty (Some expr) if wasUnit then expr, tpenv else @@ -5647,7 +5646,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.MatchLambda (isExnMatch, argm, clauses, spMatch, m) -> // (spMatch, x, matches, isExnMatch, m) -> - let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv env.NameEnv m overallTy + let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy let idv1, idve1 = mkCompGenLocal argm (cenv.synArgNameGenerator.New()) domainTy let envinner = ExitFamilyRegion env let idv2, matchExpr, tpenv = TcAndPatternCompileMatchClauses m argm (if isExnMatch then Throw else ThrowIncompleteMatchException) cenv domainTy resultTy envinner tpenv clauses @@ -5672,7 +5671,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = let e', srcTy, tpenv = TcExprOfUnknownType cenv env tpenv e UnifyTypes cenv env m overallTy cenv.g.bool_ty let tgty, tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgty - TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv env.NameEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv m tgty srcTy let e' = mkCallTypeTest cenv.g m tgty e' e', tpenv @@ -5693,7 +5692,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.InferredUpcast _ -> overallTy, tpenv | _ -> failwith "upcast" - TcStaticUpcast cenv env.DisplayEnv env.NameEnv m tgty srcTy + TcStaticUpcast cenv env.DisplayEnv m tgty srcTy mkCoerceExpr(e', tgty, m, srcTy),tpenv | SynExpr.Downcast(e, _, m) | SynExpr.InferredDowncast (e, m) -> @@ -5706,7 +5705,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = tgty, tpenv, true | SynExpr.InferredDowncast _ -> overallTy, tpenv, false | _ -> failwith "downcast" - TcRuntimeTypeTest (*isCast*)true isOperator cenv env.DisplayEnv env.NameEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)true isOperator cenv env.DisplayEnv m tgty srcTy // TcRuntimeTypeTest ensures tgty is a nominal type. Hence we can insert a check here // based on the nullness semantics of the nominal type. @@ -5714,7 +5713,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = e', tpenv | SynExpr.Null m -> - AddCxTypeMustSupportNull env.DisplayEnv env.NameEnv cenv.css m NoTrace overallTy + AddCxTypeMustSupportNull env.DisplayEnv cenv.css m NoTrace overallTy mkNull m overallTy, tpenv | SynExpr.Lazy (e, m) -> @@ -5724,14 +5723,14 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = mkLazyDelayed cenv.g m ety (mkUnitDelayLambda cenv.g m e'), tpenv | SynExpr.Tuple (args, _, m) -> - let argtys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv env.NameEnv m overallTy args + let argtys = UnifyRefTupleType env.eContextInfo cenv env.DisplayEnv m overallTy args // No subsumption at tuple construction let flexes = argtys |> List.map (fun _ -> false) let args', tpenv = TcExprs cenv env m tpenv flexes argtys args mkRefTupled cenv.g m args' argtys, tpenv | SynExpr.StructTuple (args, _, m) -> - let argtys = UnifyStructTupleType env.eContextInfo cenv env.DisplayEnv env.NameEnv m overallTy args + let argtys = UnifyStructTupleType env.eContextInfo cenv env.DisplayEnv m overallTy args // No subsumption at tuple construction let flexes = argtys |> List.map (fun _ -> false) let args', tpenv = TcExprs cenv env m tpenv flexes argtys args @@ -5845,7 +5844,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = UnifyTypes cenv env m overallTy genCollTy let exprty = NewInferenceType () let genEnumTy = mkSeqTy cenv.g genCollElemTy - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace genEnumTy exprty + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace genEnumTy exprty let expr, tpenv = TcExpr cenv exprty env tpenv comp let expr = mkCoerceIfNeeded cenv.g genEnumTy (tyOfExpr cenv.g expr) expr (if isArray then mkCallSeqToArray else mkCallSeqToList) cenv.g m genCollElemTy @@ -5980,7 +5979,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.TraitCall(tps, memSpfn, arg, m) -> let synTypes = tps |> List.map (fun tp -> SynType.Var(tp, m)) - let (TTrait(_, logicalCompiledName, _, argtys, returnTy, _) as traitInfo), tpenv = TcPseudoMemberSpec cenv NewTyparsOK env synTypes tpenv memSpfn m + let (TTrait(_, logicalCompiledName, _, argtys, returnTy, _, _) as traitInfo), tpenv = TcPseudoMemberSpec cenv NewTyparsOK env synTypes tpenv memSpfn m if BakedInTraitConstraintNames.Contains logicalCompiledName then warning(BakedInMemberConstraintName(logicalCompiledName, m)) @@ -5990,7 +5989,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: 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 = TcExprs cenv env m tpenv flexes argtys args - AddCxMethodConstraint env.DisplayEnv env.NameEnv cenv.css m NoTrace traitInfo + AddCxMethodConstraint env.DisplayEnv cenv.css m NoTrace traitInfo UnifyTypes cenv env m overallTy returnTy Expr.Op(TOp.TraitCall(traitInfo), [], args', m), tpenv @@ -6052,7 +6051,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = and TcIteratedLambdas cenv isFirst (env: TcEnv) overallTy takenNames tpenv e = match e with | SynExpr.Lambda (isMember, isSubsequent, spats, bodyExpr, m) when isMember || isFirst || isSubsequent -> - let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv env.NameEnv m overallTy + let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m overallTy let vs, (tpenv, names, takenNames) = TcSimplePats cenv isMember CheckCxs domainTy env (tpenv, Map.empty, takenNames) spats let envinner, _, vspecMap = MakeAndPublishSimpleVals cenv env m names true let byrefs = vspecMap |> Map.map (fun _ v -> isByrefTy cenv.g v.Type, v) @@ -6149,7 +6148,7 @@ and TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv wholeExpr e1 indexArg | Some (path, functionName, indexArgs) -> let operPath = mkSynLidGet mDot path (CompileOpName functionName) let f, fty, tpenv = TcExprOfUnknownType cenv env tpenv operPath - let domainTy, resultTy = UnifyFunctionType (Some mWholeExpr) cenv env.DisplayEnv env.NameEnv mWholeExpr fty + let domainTy, resultTy = UnifyFunctionType (Some mWholeExpr) cenv env.DisplayEnv mWholeExpr fty UnifyTypes cenv env mWholeExpr domainTy e1ty let f' = buildApp cenv (MakeApplicableExprNoFlex cenv f) fty e1' mWholeExpr let delayed = List.foldBack (fun idx acc -> DelayedApp(ExprAtomicFlag.Atomic, idx, mWholeExpr) :: acc) indexArgs delayed // atomic, otherwise no ar.[1] <- xyz @@ -6192,7 +6191,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 env.NameEnv cenv.css mWholeExprOrObjTy NoTrace objTy + AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css mWholeExprOrObjTy NoTrace objTy match arg with | SynExpr.Const (SynConst.Unit, _) -> () @@ -6469,7 +6468,6 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo, bind) = match NameMap.range nameToPrelimValSchemeMap with | [PrelimValScheme1(id, _, _, _, _, _, _, _, _, _, _)] -> let denv = env.DisplayEnv - let nenv = env.NameEnv let declaredTypars = match absSlotInfo with @@ -6478,11 +6476,11 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo, bind) = | _ -> declaredTypars // Canonicalize constraints prior to generalization - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, nenv, m) declaredTypars + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, m) declaredTypars let freeInEnv = GeneralizationHelpers.ComputeUngeneralizableTypars env - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, nenv, m, freeInEnv, false, CanGeneralizeConstrainedTypars, inlineFlag, Some(rhsExpr), declaredTypars, [], bindingTy, false) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, m, freeInEnv, false, CanGeneralizeConstrainedTypars, inlineFlag, Some(rhsExpr), declaredTypars, [], bindingTy, false) let declaredTypars = ChooseCanonicalDeclaredTyparsAfterInference cenv.g env.DisplayEnv declaredTypars m let generalizedTypars = PlaceTyparsInDeclarationOrder declaredTypars generalizedTypars @@ -6700,7 +6698,7 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, /// Check a constant string expression. It might be a 'printf' format string and TcConstStringExpr cenv overallTy env m tpenv s = - if (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m overallTy cenv.g.string_ty) then + if (AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy cenv.g.string_ty) then mkString cenv.g m s, tpenv else let aty = NewInferenceType () @@ -6709,7 +6707,7 @@ and TcConstStringExpr cenv overallTy env m tpenv s = let dty = NewInferenceType () let ety = NewInferenceType () let ty' = mkPrintfFormatTy cenv.g aty bty cty dty ety - if (not (isObjTy cenv.g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css m overallTy ty') then + if (not (isObjTy cenv.g overallTy) && AddCxTypeMustSubsumeTypeUndoIfFailed env.DisplayEnv cenv.css m overallTy ty') then // Parse the format string to work out the phantom types let source = match cenv.tcSink.CurrentSink with None -> None | Some sink -> sink.CurrentSource let normalizedString = (s.Replace("\r\n", "\n").Replace("\r", "\n")) @@ -8201,7 +8199,7 @@ and TcSequenceExpression cenv env tpenv comp overallTy m = if not isYield then errorR(Error(FSComp.SR.tcUseYieldBangForMultipleResults(), m)) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace 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) -> @@ -8261,8 +8259,7 @@ and Propagate cenv overallTy env tpenv (expr: ApplicableExpr) exprty delayed = | DelayedApp (_, arg, mExprAndArg) :: delayedList' -> let denv = env.DisplayEnv - let nenv = env.NameEnv - match UnifyFunctionTypeUndoIfFailed cenv denv nenv mExpr exprty with + match UnifyFunctionTypeUndoIfFailed cenv denv mExpr exprty with | Some (_, resultTy) -> propagate delayedList' mExprAndArg resultTy | None -> @@ -8340,12 +8337,11 @@ and delayRest rest mPrior delayed = and TcFunctionApplicationThen cenv overallTy env tpenv mExprAndArg expr exprty (synArg: SynExpr) atomicFlag delayed = let denv = env.DisplayEnv - let nenv = env.NameEnv let mArg = synArg.Range let mFunExpr = expr.Range // If the type of 'synArg' unifies as a function type, then this is a function application, otherwise // it is an error or a computation expression - match UnifyFunctionTypeUndoIfFailed cenv denv nenv mFunExpr exprty with + match UnifyFunctionTypeUndoIfFailed cenv denv mFunExpr exprty with | Some (domainTy, resultTy) -> // Notice the special case 'seq { ... }'. In this case 'seq' is actually a function in the F# library. @@ -8672,6 +8668,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del | Item.FakeInterfaceCtor _ -> error(Error(FSComp.SR.tcInvalidUseOfInterfaceType(), mItem)) + | Item.ImplicitOp(id, sln) -> let isPrefix = PrettyNaming.IsPrefixOperator id.idText @@ -8698,7 +8695,9 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del let memberFlags = StaticMemberFlags MemberKind.Member let logicalCompiledName = ComputeLogicalName id memberFlags - let traitInfo = TTrait(argTys, logicalCompiledName, memberFlags, argTys, Some retTy, sln) + + let traitInfo = TTrait(argTys, logicalCompiledName, memberFlags, argTys, Some retTy, sln, []) + let traitInfo = FillInExtSlnsForConstraint env.GetExtSlns traitInfo let expr = Expr.Op(TOp.TraitCall(traitInfo), [], ves, mItem) let expr = mkLambdas mItem [] vs (expr, retTy) @@ -8781,7 +8780,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del let resultExpr, tpenv = TcDelayed cenv intermediateTy env tpenv mItem (MakeApplicableExprNoFlex cenv expr) (tyOfExpr cenv.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 env.NameEnv cenv.css mItem NoTrace 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 @@ -8989,7 +8988,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela // Canonicalize inference problem prior to '.' lookup on variable types if isTyparTy cenv.g objExprTy then - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, env.DisplayEnv, env.NameEnv, mExprAndLongId) (freeInTypeLeftToRight cenv.g false objExprTy) + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, env.DisplayEnv, mExprAndLongId) (freeInTypeLeftToRight cenv.g false objExprTy) let item, mItem, rest, afterResolution = ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver mExprAndLongId ad env.eNameResEnv objExprTy longId findFlag false let mExprAndItem = unionRanges mObjExpr mItem @@ -9054,7 +9053,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela RecdFieldInstanceChecks cenv.g cenv.amap ad mItem rfinfo let tgty = rfinfo.EnclosingType let valu = isStructTy cenv.g tgty - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css mItem NoTrace tgty objExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem NoTrace tgty objExprTy let objExpr = if valu then objExpr else mkCoerceExpr(objExpr, tgty, mExprAndItem, objExprTy) let fieldTy = rfinfo.FieldType match delayed with @@ -9227,7 +9226,6 @@ and TcMethodApplication = let denv = env.DisplayEnv - let nenv = env.NameEnv let isSimpleFormalArg (isParamArrayArg, isOutArg, optArgInfo: OptionalArgInfo, callerInfoInfo: CallerInfoInfo, _reflArgInfo: ReflectedArgInfo) = not isParamArrayArg && not isOutArg && not optArgInfo.IsOptional && callerInfoInfo = NoCallerInfo @@ -9346,7 +9344,7 @@ and TcMethodApplication let curriedArgTys = GenerateMatchingSimpleArgumentTypes calledMeth let returnTy = (exprTy, curriedArgTys) ||> List.fold (fun exprTy argTys -> - let domainTy, resultTy = UnifyFunctionType None cenv denv nenv mMethExpr exprTy + let domainTy, resultTy = UnifyFunctionType None cenv denv mMethExpr exprTy UnifyTypes cenv env mMethExpr domainTy (mkRefTupledTy cenv.g argTys) resultTy) curriedArgTys, returnTy @@ -9385,7 +9383,7 @@ and TcMethodApplication // type we assume the number of arguments is just "1". | None, _ -> - let domainTy, returnTy = UnifyFunctionType None cenv denv nenv mMethExpr exprTy + let domainTy, returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy let argTys = if isUnitTy cenv.g domainTy then [] else tryDestRefTupleTy cenv.g domainTy // Only apply this rule if a candidate method exists with this number of arguments let argTys = @@ -9422,7 +9420,7 @@ and TcMethodApplication yield makeOneCalledMeth (minfo, pinfoOpt, false) ] let uniquelyResolved = - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv nenv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv let res = UnifyUniqueOverloading csenv callerArgCounts methodName ad preArgumentTypeCheckingCalledMethGroup returnTy match res with @@ -9456,7 +9454,7 @@ and TcMethodApplication | [calledMeth] -> UnifyMatchingSimpleArgumentTypes exprTy calledMeth | _ -> - let domainTy, returnTy = UnifyFunctionType None cenv denv nenv mMethExpr exprTy + let domainTy, returnTy = UnifyFunctionType None cenv denv mMethExpr exprTy let argTys = if isUnitTy cenv.g domainTy then [] else tryDestRefTupleTy cenv.g domainTy // Only apply this rule if a candidate method exists with this number of arguments let argTys = @@ -9485,7 +9483,7 @@ and TcMethodApplication match ExamineMethodForLambdaPropagation meth with | Some (unnamedInfo, namedInfo) -> let calledObjArgTys = meth.CalledObjArgTys(mMethExpr) - if (calledObjArgTys, callerObjArgTys) ||> Seq.forall2 (fun calledTy callerTy -> AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv nenv cenv.css mMethExpr calledTy callerTy) then + if (calledObjArgTys, callerObjArgTys) ||> Seq.forall2 (fun calledTy callerTy -> AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv cenv.css mMethExpr calledTy callerTy) then yield (List.toArraySquared unnamedInfo, List.toArraySquared namedInfo) | None -> () |] else @@ -9514,12 +9512,12 @@ and TcMethodApplication CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo env.GetExtSlns, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt)) let callerArgCounts = (unnamedCurriedCallerArgs.Length, namedCurriedCallerArgs.Length) - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv nenv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv // Commit unassociated constraints prior to member overload resolution where there is ambiguity // about the possible target of the call. if not uniquelyResolved then - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, nenv, mItem) + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, mItem) (//freeInTypeLeftToRight cenv.g false returnTy @ (unnamedCurriedCallerArgs |> List.collectSquared (fun callerArg -> freeInTypeLeftToRight cenv.g false callerArg.Type))) @@ -9600,7 +9598,7 @@ and TcMethodApplication typeEquiv cenv.g finalCalledMethInfo.EnclosingType cenv.g.obj_ty && (finalCalledMethInfo.LogicalName = "GetHashCode" || finalCalledMethInfo.LogicalName = "Equals")) then - objArgs |> List.iter (fun expr -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv env.NameEnv cenv.css mMethExpr NoTrace (tyOfExpr cenv.g expr)) + objArgs |> List.iter (fun expr -> ConstraintSolver.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. @@ -9611,7 +9609,7 @@ and TcMethodApplication HasHeadType cenv.g cenv.g.tcref_System_Collections_Generic_IEqualityComparer ty)) then match argsOfAppTy cenv.g finalCalledMethInfo.EnclosingType with - | [dty; _] -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv env.NameEnv cenv.css mMethExpr NoTrace dty + | [dty; _] -> ConstraintSolver.AddCxTypeMustSupportEquality env.DisplayEnv cenv.css mMethExpr NoTrace dty | _ -> () end @@ -10014,9 +10012,9 @@ and TcMethodArg cenv env (lambdaPropagationInfo, tpenv) (lambdaPropagationInfo if col |> ListSet.setify (typeEquiv cenv.g) |> isSingleton then let calledLambdaArgTy = col.[0] // Force the caller to be a function type. - match UnifyFunctionTypeUndoIfFailed cenv env.DisplayEnv env.NameEnv mArg callerLambdaTy with + match UnifyFunctionTypeUndoIfFailed cenv env.DisplayEnv mArg callerLambdaTy with | Some (callerLambdaDomainTy, callerLambdaRangeTy) -> - if AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv env.NameEnv cenv.css mArg calledLambdaArgTy callerLambdaDomainTy then + if AddCxTypeEqualsTypeUndoIfFailed env.DisplayEnv cenv.css mArg calledLambdaArgTy callerLambdaDomainTy then loop callerLambdaRangeTy (lambdaVarNum + 1) | None -> () loop argTy 0 @@ -10034,7 +10032,7 @@ and TcMethodArg cenv env (lambdaPropagationInfo, tpenv) (lambdaPropagationInfo | NoInfo | CallerLambdaHasArgTypes _ -> yield info | CalledArgMatchesType adjustedCalledTy -> - if AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed env.DisplayEnv env.NameEnv cenv.css mArg adjustedCalledTy argTy then + if AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed env.DisplayEnv cenv.css mArg adjustedCalledTy argTy then yield info |] CallerArg(argTy, mArg, isOpt, e'), (lambdaPropagationInfo, tpenv) @@ -10380,7 +10378,7 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt else TcExprThatCantBeCtorBody cenv overallExprTy envinner tpenv rhsExpr) if bkind = StandaloneExpression && not cenv.isScript then - UnifyUnitType cenv env.DisplayEnv env.NameEnv mBinding overallPatTy (Some rhsExprChecked) |> ignore + UnifyUnitType cenv env.DisplayEnv mBinding overallPatTy (Some rhsExprChecked) |> ignore // Fix up the r.h.s. expression for 'fixed' let rhsExprChecked = @@ -10595,7 +10593,7 @@ and TcAttribute canFail cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = let propNameItem = Item.SetterArg(id, setterItem) CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, propNameItem, propNameItem, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, ad) - AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv env.NameEnv cenv.css m NoTrace argty argtyv + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace argty argtyv AttribNamedArg(nm, argty, isProp, mkAttribExpr callerArgExpr)) @@ -10661,14 +10659,13 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds, bindsm, sco // Canonicalize constraints prior to generalization let denv = env.DisplayEnv - let nenv = env.NameEnv - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, nenv, bindsm) + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, bindsm) (binds' |> List.collect (fun tbinfo -> let (CheckedBindingInfo(_, _, _, _, flex, _, _, _, tauTy, _, _, _, _, _)) = tbinfo let (ExplicitTyparInfo(_, declaredTypars, _)) = flex let maxInferredTypars = (freeInTypeLeftToRight cenv.g false tauTy) declaredTypars @ maxInferredTypars)) - let nenv = env.NameEnv + let lazyFreeInEnv = lazy (GeneralizationHelpers.ComputeUngeneralizableTypars env) // Generalize the bindings... @@ -10687,7 +10684,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds, bindsm, sco [] else let freeInEnv = lazyFreeInEnv.Force() - GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, nenv, m, freeInEnv, canInferTypars, GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl(declKind), inlineFlag, Some rhsExpr, allDeclaredTypars, maxInferredTypars, tauTy, false) + GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, m, freeInEnv, canInferTypars, GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl(declKind), inlineFlag, Some rhsExpr, allDeclaredTypars, maxInferredTypars, tauTy, false) let prelimValSchemes2 = GeneralizeVals cenv denv enclosingDeclaredTypars generalizedTypars nameToPrelimValSchemeMap @@ -10749,7 +10746,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds, bindsm, sco let mkCleanup (bodyExpr, bodyExprTy) = if isUse && not isFixed then (allValsDefinedByPattern, (bodyExpr, bodyExprTy)) ||> List.foldBack (fun v (bodyExpr, bodyExprTy) -> - AddCxTypeMustSubsumeType ContextInfo.NoContext denv nenv cenv.css v.Range NoTrace cenv.g.system_IDisposable_typ v.Type + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css v.Range NoTrace cenv.g.system_IDisposable_typ v.Type let cleanupE = BuildDisposableCleanup cenv env m v mkTryFinally cenv.g (bodyExpr, cleanupE, m, bodyExprTy, SequencePointInBodyOfTry, NoSequencePointAtFinally), bodyExprTy) else @@ -10809,7 +10806,7 @@ and ApplyTypesFromArgumentPatterns (cenv, env, optArgsOK, ty, m, tpenv, Normaliz | _ -> () | pushedPat :: morePushedPats -> - let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv env.NameEnv m ty + let domainTy, resultTy = UnifyFunctionType None cenv env.DisplayEnv m ty // We apply the type information from the patterns by type checking the // "simple" patterns against 'domainTy'. They get re-typechecked later. ignore (TcSimplePats cenv optArgsOK CheckCxs domainTy env (tpenv, Map.empty, Set.empty) pushedPat) @@ -11327,7 +11324,7 @@ and TcLetrecBinding reqdThisValTy, (mkAppTy enclosingTyconRef (List.map mkTyparTy enclosingDeclaredTypars)), vspec.Range | Some thisVal -> reqdThisValTy, thisVal.Type, thisVal.Range - if not (AddCxTypeEqualsTypeUndoIfFailed envRec.DisplayEnv envRec.NameEnv cenv.css rangeForCheck actualThisValTy reqdThisValTy) then + if not (AddCxTypeEqualsTypeUndoIfFailed envRec.DisplayEnv cenv.css rangeForCheck actualThisValTy reqdThisValTy) then errorR (Error(FSComp.SR.tcNonUniformMemberUse vspec.DisplayName, vspec.Range)) let preGeneralizationRecBind = @@ -11355,7 +11352,6 @@ and TcIncrementalLetRecGeneralization cenv scopem uncheckedRecBindsTable : Map) = let denv = envNonRec.DisplayEnv - let nenv = envNonRec.NameEnv // recompute the free-in-environment in case any type variables have been instantiated let freeInEnv = GeneralizationHelpers.ComputeUngeneralizableTypars envNonRec @@ -11499,9 +11495,9 @@ and TcIncrementalLetRecGeneralization cenv scopem else let supportForBindings = newGeneralizableBindings |> List.collect (TcLetrecComputeSupportForBinding cenv) - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, nenv, scopem) supportForBindings + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denv, scopem) supportForBindings - let generalizedTyparsL = newGeneralizableBindings |> List.map (TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv envNonRec.NameEnv) + let generalizedTyparsL = newGeneralizableBindings |> List.map (TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv) // Generalize the bindings. let newGeneralizedRecBinds = (generalizedTyparsL, newGeneralizableBindings) ||> List.map2 (TcLetrecGeneralizeBinding cenv denv ) @@ -11521,7 +11517,7 @@ and TcIncrementalLetRecGeneralization cenv scopem //------------------------------------------------------------------------- /// Compute the type variables which may be generalized and perform the generalization -and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (nenv : NameResolutionEnv) (pgrbind : PreGeneralizationRecursiveBinding) = +and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgrbind : PreGeneralizationRecursiveBinding) = let freeInEnv = Zset.diff freeInEnv (Zset.ofList typarOrder (NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g pgrbind.ExtraGeneralizableTypars)) @@ -11536,7 +11532,7 @@ and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (nen // two declared type variables. So we now check that, for each binding, the declared // type variables can be unified with a rigid version of the same and undo the results // of this unification. - ConstraintSolver.CheckDeclaredTypars denv nenv cenv.css m rigidCopyOfDeclaredTypars declaredTypars + ConstraintSolver.CheckDeclaredTypars denv cenv.css m rigidCopyOfDeclaredTypars declaredTypars let memFlagsOpt = vspec.MemberInfo |> Option.map (fun memInfo -> memInfo.MemberFlags) let isCtor = (match memFlagsOpt with None -> false | Some memberFlags -> memberFlags.MemberKind = MemberKind.Constructor) @@ -11548,7 +11544,7 @@ and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (nen let maxInferredTypars = freeInTypeLeftToRight cenv.g false tau let canGeneralizeConstrained = GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl rbinfo.DeclKind - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars (cenv, denv, nenv, m, freeInEnv, canInferTypars, canGeneralizeConstrained, inlineFlag, Some(expr), allDeclaredTypars, maxInferredTypars,tau,isCtor) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars (cenv, denv, m, freeInEnv, canInferTypars, canGeneralizeConstrained, inlineFlag, Some(expr), allDeclaredTypars, maxInferredTypars,tau,isCtor) generalizedTypars /// Compute the type variables which may have member constraints that need to be canonicalized prior to generalization @@ -11777,7 +11773,6 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF let valinfos, tpenv = TcValSpec cenv env declKind newOk containerInfo memFlagsOpt None tpenv valSpfn attrs let denv = env.DisplayEnv - let nenv = env.NameEnv (tpenv, valinfos) ||> List.mapFold (fun tpenv valSpecResult -> @@ -11791,7 +11786,7 @@ let TcAndPublishValSpec (cenv, env, containerInfo: ContainerInfo, declKind, memF let flex = ExplicitTyparInfo(declaredTypars, declaredTypars, synCanInferTypars) - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, nenv, id.idRange, emptyFreeTypars, canInferTypars, CanGeneralizeConstrainedTypars, inlineFlag, None, allDeclaredTypars,freeInType, ty, false) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv, denv, id.idRange, emptyFreeTypars, canInferTypars, CanGeneralizeConstrainedTypars, inlineFlag, None, allDeclaredTypars,freeInType, ty, false) let valscheme1 = PrelimValScheme1(id, flex, ty, Some(partialValReprInfo), memberInfoOpt, mutableFlag, inlineFlag, NormalVal, noArgOrRetAttribs, vis, false) @@ -13597,7 +13592,6 @@ module MutRecBindingChecking = let TcMutRecDefns_Phase2_Bindings cenv envInitial tpenv bindsm scopem mutRecNSInfo (envMutRecPrelimWithReprs: TcEnv) (mutRecDefns: MutRecDefnsPhase2Info) = let g = cenv.g let denv = envMutRecPrelimWithReprs.DisplayEnv - let nenv = envMutRecPrelimWithReprs.NameEnv // Phase2A: create member prelimRecValues for "recursive" items, i.e. ctor val and member vals // Phase2A: also processes their arg patterns - collecting type assertions @@ -13706,7 +13700,7 @@ module MutRecBindingChecking = for tp in unsolvedTyparsForRecursiveBlockInvolvingGeneralizedVariables do //printfn "solving unsolvedTyparsInvolvingGeneralizedVariable : %s #%d" tp.DisplayName tp.Stamp if (tp.Rigidity <> TyparRigidity.Rigid) && not tp.IsSolved then - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv nenv tp + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp // Now that we know what we've generalized we can adjust the recursive references let defnsCs = TcMutRecBindings_Phase2C_FixupRecursiveReferences cenv (denv, defnsBs, generalizedTyparsForRecursiveBlock, generalizedRecBinds, scopem) @@ -16901,11 +16895,11 @@ let rec IterTyconsOfModuleOrNamespaceType f (mty:ModuleOrNamespaceType) = // Defaults get applied before the module signature is checked and before the implementation conditions on virtuals/overrides. // Defaults get applied in priority order. Defaults listed last get priority 0 (lowest), 2nd last priority 1 etc. -let ApplyDefaults cenv g denvAtEnd nenvAtEnd m mexpr extraAttribs = +let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs = try let unsolved = Microsoft.FSharp.Compiler.FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd (mexpr, extraAttribs) - GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denvAtEnd, nenvAtEnd, m) unsolved + GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, denvAtEnd, m) unsolved let applyDefaults priority = unsolved |> List.iter (fun tp -> @@ -16917,9 +16911,9 @@ let ApplyDefaults cenv g denvAtEnd nenvAtEnd m mexpr extraAttribs = | TyparConstraint.DefaultsTo(priority2, ty2, m) when priority2 = priority -> let ty1 = mkTyparTy tp if not tp.IsSolved && not (typeEquiv cenv.g ty1 ty2) then - let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denvAtEnd nenvAtEnd + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denvAtEnd TryD (fun () -> ConstraintSolver.SolveTyparEqualsTyp csenv 0 m NoTrace ty1 ty2) - (fun e -> solveTypAsError cenv denvAtEnd nenvAtEnd m ty1 + (fun e -> solveTypAsError cenv denvAtEnd m ty1 ErrorD(ErrorFromApplyingDefault(g, denvAtEnd, tp, ty2, e, m))) |> RaiseOperationResult | _ -> ())) @@ -16931,7 +16925,7 @@ let ApplyDefaults cenv g denvAtEnd nenvAtEnd m mexpr extraAttribs = unsolved |> List.iter (fun tp -> if not tp.IsSolved then if (tp.StaticReq <> NoStaticReq) then - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd nenvAtEnd tp) + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp) with e -> errorRecovery e m let CheckValueRestriction denvAtEnd rootSigOpt implFileTypePriorToSig m = @@ -16954,12 +16948,12 @@ let CheckValueRestriction denvAtEnd rootSigOpt implFileTypePriorToSig m = try check implFileTypePriorToSig with e -> errorRecovery e m -let SolveInternalUnknowns g cenv denvAtEnd nenv mexpr extraAttribs = +let SolveInternalUnknowns g cenv denvAtEnd mexpr extraAttribs = let unsolved = Microsoft.FSharp.Compiler.FindUnsolved.UnsolvedTyparsOfModuleDef g cenv.amap denvAtEnd (mexpr, extraAttribs) unsolved |> List.iter (fun tp -> if (tp.Rigidity <> TyparRigidity.Rigid) && not tp.IsSolved then - ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd nenv tp) + ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denvAtEnd tp) let CheckModuleSignature g cenv m denvAtEnd rootSigOpt implFileTypePriorToSig implFileSpecPriorToSig mexpr = match rootSigOpt with @@ -17025,7 +17019,6 @@ let TypeCheckOneImplFile netModuleAttrs = List.map snd netModuleAttrs assemblyAttrs = List.map snd assemblyAttrs} let denvAtEnd = envAtEnd.DisplayEnv - let nenvAtEnd = envAtEnd.NameEnv let m = qualNameOfFile.Range // This is a fake module spec @@ -17034,7 +17027,7 @@ let TypeCheckOneImplFile let extraAttribs = topAttrs.mainMethodAttrs@topAttrs.netModuleAttrs@topAttrs.assemblyAttrs conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - ApplyDefaults cenv g denvAtEnd nenvAtEnd m mexpr extraAttribs) + ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs) // Check completion of all classes defined across this file. // NOTE: this is not a great technique if inner signatures are permitted to hide @@ -17049,7 +17042,7 @@ let TypeCheckOneImplFile // Solve unsolved internal type variables conditionallySuppressErrorReporting (checkForErrors()) (fun () -> - SolveInternalUnknowns g cenv denvAtEnd nenvAtEnd mexpr extraAttribs) + SolveInternalUnknowns g cenv denvAtEnd mexpr extraAttribs) // Check the module matches the signature let implFileExprAfterSig = diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index 12edd73a927..8ef6eee6c95 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -143,7 +143,7 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = match tpc with | TyparConstraint.CoercesTo(x,m) -> join m x,m - | TyparConstraint.MayResolveMember(TTrait(_,nm,_,_,_,_),m,_) -> + | TyparConstraint.MayResolveMember(TTrait(_, nm, _, _, _, _, _), m) -> errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInOverloadedOperator(DemangleOperatorName nm),m)) maxSoFar,m | TyparConstraint.SimpleChoice(_,m) -> diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs index e7fcdf5c8f0..4a1134ddfb4 100644 --- a/src/fsharp/fsc.fs +++ b/src/fsharp/fsc.fs @@ -1791,15 +1791,15 @@ let main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinarie // Type check the inputs let inputs = inputs |> List.map fst - let tcState, topAttrs, typedAssembly, tcEnvAtEnd = + let tcState, topAttrs, typedAssembly, _tcEnvAtEnd = TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, inputs, exiter) AbortOnError(errorLogger, exiter) ReportTime tcConfig "Typechecked" - Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter, tcEnvAtEnd.NameEnv) + Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter) -let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter, nenv)) = +let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter)) = if tcConfig.typeCheckOnly then exiter.Exit 0 @@ -1845,7 +1845,7 @@ let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, gener end // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter, nenv) + Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter) // set up typecheck for given AST without parsing any command line parameters @@ -1895,7 +1895,7 @@ let main1OfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyNam use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.TypeCheck) let tcEnv0 = GetInitialTcEnv (assemblyName, rangeStartup, tcConfig, tcImports, tcGlobals) - let tcState,topAttrs,typedAssembly,tcEnvAtEnd = + let tcState, topAttrs, typedAssembly, _tcEnvAtEnd = TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, inputs,exiter) let generatedCcu = tcState.Ccu @@ -1915,11 +1915,11 @@ let main1OfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyNam // Pass on only the minimum information required for the next phase to ensure GC kicks in. // In principle the JIT should be able to do good liveness analysis to clean things up, but the // data structures involved here are so large we can't take the risk. - Args(ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedAssembly, topAttrs, pdbFile, assemblyName, assemVerFromAttrib, signingInfo ,exiter, tcEnvAtEnd.NameEnv) + Args(ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedAssembly, topAttrs, pdbFile, assemblyName, assemVerFromAttrib, signingInfo ,exiter) /// Phase 2a: encode signature data, optimize, encode optimization data -let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, errorLogger: ErrorLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter, nenv)) = +let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlobals, errorLogger: ErrorLogger, generatedCcu: CcuThunk, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter: Exiter)) = // Encode the signature data ReportTime tcConfig ("Encode Interface Data") @@ -1942,7 +1942,7 @@ let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlo match tcConfig.metadataVersion with | Some v -> v | _ -> match (frameworkTcImports.DllTable.TryFind tcConfig.primaryAssembly.Name) with | Some ib -> ib.RawMetadata.TryGetRawILModule().Value.MetadataVersion | _ -> "" - let optimizedImpls, optimizationData, _ = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, generatedCcu, typedImplFiles, nenv) + let optimizedImpls, optimizationData, _ = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, generatedCcu, typedImplFiles) AbortOnError(errorLogger, exiter) @@ -1951,10 +1951,10 @@ let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlo let optDataResources = EncodeOptimizationData(tcGlobals, tcConfig, outfile, exportRemapping, (generatedCcu, optimizationData), false) // Pass on only the minimum information required for the next phase - Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, (sigDataAttributes, sigDataResources), optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter, nenv) + Args (ctok, tcConfig, tcImports, tcGlobals, errorLogger, generatedCcu, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, (sigDataAttributes, sigDataResources), optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter) /// Phase 2b: IL code generation -let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, idata, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter, nenv)) = +let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcConfig, tcImports, tcGlobals: TcGlobals, errorLogger, generatedCcu: CcuThunk, outfile, optimizedImpls, topAttrs, pdbfile, assemblyName, idata, optDataResources, assemVerFromAttrib, signingInfo, metadataVersion, exiter: Exiter)) = match tcImportsCapture with | None -> () @@ -1974,7 +1974,7 @@ let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcCo // Check if System.SerializableAttribute exists in mscorlib.dll, // so that make sure the compiler only emits "serializable" bit into IL metadata when it is available. // Note that SerializableAttribute may be relocated in the future but now resides in mscorlib. - let codegenResults = GenerateIlxCode ((if Option.isSome dynamicAssemblyCreator then IlReflectBackend else IlWriteBackend), Option.isSome dynamicAssemblyCreator, false, tcConfig, topAttrs, optimizedImpls, generatedCcu.AssemblyName, ilxGenerator, nenv) + let codegenResults = GenerateIlxCode ((if Option.isSome dynamicAssemblyCreator then IlReflectBackend else IlWriteBackend), Option.isSome dynamicAssemblyCreator, false, tcConfig, topAttrs, optimizedImpls, generatedCcu.AssemblyName, ilxGenerator) let casApplied = new Dictionary() let securityAttrs, topAssemblyAttrs = topAttrs.assemblyAttrs |> List.partition (fun a -> TypeChecker.IsSecurityAttribute tcGlobals (tcImports.GetImportMap()) casApplied a rangeStartup) // remove any security attributes from the top-level assembly attribute list diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs index f89cda50455..b9331351ffe 100644 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -1010,7 +1010,6 @@ type internal FsiDynamicCompiler let optEnv = istate.optEnv let emEnv = istate.emEnv let tcState = istate.tcState - let nenv = tcState.TcEnvFromImpls.NameEnv let ilxGenerator = istate.ilxGenerator let tcConfig = TcConfig.Create(tcConfigB,validate=false) @@ -1032,11 +1031,11 @@ type internal FsiDynamicCompiler let importMap = tcImports.GetImportMap() // optimize: note we collect the incremental optimization environment - let optimizedImpls, _optData, optEnv = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, isIncrementalFragment, optEnv, tcState.Ccu, declaredImpls, nenv) + let optimizedImpls, _optData, optEnv = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, isIncrementalFragment, optEnv, tcState.Ccu, declaredImpls) errorLogger.AbortOnError(fsiConsoleOutput); let fragName = textOfLid prefixPath - let codegenResults = GenerateIlxCode (IlReflectBackend, isInteractiveItExpr, runningOnMono, tcConfig, topCustomAttrs, optimizedImpls, fragName, ilxGenerator, nenv) + let codegenResults = GenerateIlxCode (IlReflectBackend, isInteractiveItExpr, runningOnMono, tcConfig, topCustomAttrs, optimizedImpls, fragName, ilxGenerator) errorLogger.AbortOnError(fsiConsoleOutput); // Each input is like a small separately compiled extension to a single source file. diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 5e8f3a3b498..859c4483639 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -296,6 +296,18 @@ let ImportReturnTypeFromMetaData amap m ty scoref tinst minst = | ILType.Void -> None | retTy -> Some (ImportILTypeFromMetadata amap m scoref tinst minst retTy) + +/// Search for the relevant extension values again if a name resolution environment is provided +/// Basically, if you use a generic thing, then the extension members in scope at the point of _use_ +/// are the ones available to solve the constraint +let FillInExtSlnsForConstraint getExtSlnsOpt traitInfo = + let (TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns)) = traitInfo + let extSlns2 = + match getExtSlnsOpt with + | None -> extSlns + | Some f -> f traitInfo + TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns2) + /// Copy constraints. If the constraint comes from a type parameter associated /// with a type constructor then we are simply renaming type variables. If it comes /// from a generic method in a generic class (e.g. typ.M<_>) then we may be both substituting the @@ -332,15 +344,9 @@ let CopyTyparConstraints getExtSlnsOpt m tprefInst (tporig:Typar) = TyparConstraint.SimpleChoice (List.map (instType tprefInst) tys,m) | TyparConstraint.RequiresDefaultConstructor _ -> TyparConstraint.RequiresDefaultConstructor m - | TyparConstraint.MayResolveMember(traitInfo, _, extVals) -> - // Search for the relevant extension values again if a name resolution environment is provided - // Basically, if you use a generic thing, then the extension members in scope at the point of _use_ - // are the ones available to solve the constraint - let extVals2 = - match getExtSlnsOpt with - | None -> extVals - | Some f -> f traitInfo - TyparConstraint.MayResolveMember (instTrait tprefInst traitInfo,m,List.map (instValRef tprefInst) extVals2)) + | TyparConstraint.MayResolveMember(traitInfo, _) -> + let traitInfo2 = FillInExtSlnsForConstraint getExtSlnsOpt traitInfo + TyparConstraint.MayResolveMember (instTrait tprefInst traitInfo2, m)) /// The constraints for each typar copied from another typar can only be fixed up once /// we have generated all the new constraints, e.g. f List, B :> List> ... @@ -850,9 +856,7 @@ type ILMethInfo = // MethInfo -#if DEBUG [] -#endif /// Describes an F# use of a method [] type MethInfo = @@ -928,7 +932,6 @@ type MethInfo = /// over extension members. member x.ExtensionMemberPriority = defaultArg x.ExtensionMemberPriorityOption System.UInt64.MaxValue -#if DEBUG /// Get the method name in DebuggerDisplayForm member x.DebuggerDisplayName = match x with @@ -938,7 +941,6 @@ type MethInfo = | ProvidedMeth(_,mi,_,m) -> "ProvidedMeth: " + mi.PUntaint((fun mi -> mi.Name),m) #endif | DefaultStructCtor _ -> ".ctor" -#endif /// Get the method name in LogicalName form, i.e. the name as it would be stored in .NET metadata member x.LogicalName = @@ -2123,6 +2125,8 @@ type PropInfo = | ProvidedProp(_,pi,_) -> ProvidedPropertyInfo.TaintedGetHashCode(pi) #endif + override x.ToString() = "property " + x.PropertyName + //------------------------------------------------------------------------- // ILEventInfo @@ -2331,6 +2335,7 @@ type EventInfo = #if EXTENSIONTYPING | ProvidedEvent (_,ei,_) -> ProvidedEventInfo.TaintedGetHashCode(ei) #endif + override x.ToString() = "event " + x.EventName //------------------------------------------------------------------------- // Helpers associated with getting and comparing method signatures diff --git a/src/fsharp/symbols/Exprs.fs b/src/fsharp/symbols/Exprs.fs index 76f3dad6d7c..0f3c93fd62b 100644 --- a/src/fsharp/symbols/Exprs.fs +++ b/src/fsharp/symbols/Exprs.fs @@ -639,7 +639,7 @@ module FSharpExprConvert = let typR = ConvType cenv (mkAppTy tycr tyargs) E.UnionCaseTag(ConvExpr cenv env arg1, typR) - | TOp.TraitCall (TTrait(tys, nm, memFlags, argtys, _rty, _colution)), _, _ -> + | TOp.TraitCall (TTrait(tys, nm, memFlags, argtys, _rty, _solution, _extSlns)), _, _ -> let tysR = ConvTypes cenv tys let tyargsR = ConvTypes cenv tyargs let argtysR = ConvTypes cenv argtys diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index 928243a7a94..92f2dac4d7d 100644 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -1029,7 +1029,8 @@ and FSharpAbstractSignature(cenv, info: SlotSig) = member __.DeclaringType = FSharpType(cenv, info.ImplementedType) and FSharpGenericParameterMemberConstraint(cenv, info: TraitConstraintInfo) = - let (TTrait(tys, nm, flags, atys, rty, _)) = info + let (TTrait(tys, nm, flags, atys, rty, _, _extSlns)) = info + member __.MemberSources = tys |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection @@ -1087,7 +1088,7 @@ and FSharpGenericParameterConstraint(cenv, cx: TyparConstraint) = member __.MemberConstraintData = match cx with - | TyparConstraint.MayResolveMember(info, _, _) -> FSharpGenericParameterMemberConstraint(cenv, info) + | TyparConstraint.MayResolveMember(info, _) -> FSharpGenericParameterMemberConstraint(cenv, info) | _ -> invalidOp "not a member constraint" member __.IsNonNullableValueTypeConstraint = diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 76d2a1eea38..3218f0e0d26 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -2045,7 +2045,7 @@ and /// Indicates a constraint that a type has a member with the given signature // TODO: allow .NET-defined extension members to solve trait constraints. Currently only ValRefs indicating possible solutions are stored - | MayResolveMember of TraitConstraintInfo * range * possibleExtensionMemberSolutions: PossibleExtensionMemberSolutions + | MayResolveMember of TraitConstraintInfo * range /// Indicates a constraint that a type is a non-Nullable value type /// These are part of .NET's model of generic constraints, and in order to @@ -2085,16 +2085,19 @@ and /// /// Indicates the signature of a member constraint. Contains a mutable solution cell /// to store the inferred solution of the constraint. - | TTrait of TTypes * string * MemberFlags * TTypes * TType option * TraitConstraintSln option ref + | TTrait of TTypes * string * MemberFlags * TTypes * TType option * TraitConstraintSln option ref * extSlns: PossibleExtensionMemberSolutions /// Get the member name associated with the member constraint. - member x.MemberName = (let (TTrait(_,nm,_,_,_,_)) = x in nm) + member x.MemberName = (let (TTrait(_,nm,_,_,_,_,_)) = x in nm) + /// Get the return type recorded in the member constraint. - member x.ReturnType = (let (TTrait(_,_,_,_,ty,_)) = x in ty) + member x.ReturnType = (let (TTrait(_,_,_,_,ty,_,_)) = x in ty) + /// Get or set the solution of the member constraint during inference member x.Solution - with get() = (let (TTrait(_,_,_,_,_,sln)) = x in sln.Value) - and set v = (let (TTrait(_,_,_,_,_,sln)) = x in sln.Value <- v) + with get() = (let (TTrait(_,_,_,_,_,sln,_)) = x in sln.Value) + and set v = (let (TTrait(_,_,_,_,_,sln,_)) = x in sln.Value <- v) + override x.ToString() = "trait " + x.MemberName and @@ -4181,7 +4184,7 @@ and | Label of ILCodeLabel /// Pseudo method calls. This is used for overloaded operations like op_Addition. - | TraitCall of TraitConstraintInfo + | TraitCall of TraitConstraintInfo /// Operation nodes representing C-style operations on byrefs and mutable vals (l-values) | LValueOp of LValueOperation * ValRef diff --git a/testfiles/test.fs b/testfiles/test.fs index 6bbc677c57e..bef8723762d 100644 --- a/testfiles/test.fs +++ b/testfiles/test.fs @@ -1,11 +1,20 @@ module Test +(* module Example1 = type System.Int32 with static member (++)(a: int, b: int) = a let result = 1 ++ 2 +module Bug1 = + type System.Int32 with + static member Add(a: int, b: int) = a + + let inline addGeneric< ^A when ^A : (static member Add : ^A * ^A -> ^A) > (a,b) : ^A = + (^A : (static member Add : ^A * ^A -> ^A) (a,b)) + let result = addGeneric (1,2) + module Example2 = type System.Int32 with @@ -50,10 +59,21 @@ module Example2 = let v2 = 1 ++++ 1 () +*) module Example3 = + //let v = [3].Length type List<'T> with - member x.Count = x.Length + member x.Count = 3 //x.Length + + let inline count (a : ^A when ^A : (member Count : int)) = + (^A : (member Count : int) (a)) + + //let inline length (a : ^A when ^A : (member Length : int)) = + // (^A : (member Length : int) (a)) + + //let v1 = [3].Count + //let v3 = length [3] - [3].Count + let v2 = count [3] diff --git a/tests/fsharpqa/Source/Conformance/ObjectOrientedTypeDefinitions/TypeExtensions/basic/E_ExtensionOperator01.fs b/tests/fsharpqa/Source/Conformance/ObjectOrientedTypeDefinitions/TypeExtensions/basic/E_ExtensionOperator01.fs index e038022643b..a2d10e07e4a 100644 --- a/tests/fsharpqa/Source/Conformance/ObjectOrientedTypeDefinitions/TypeExtensions/basic/E_ExtensionOperator01.fs +++ b/tests/fsharpqa/Source/Conformance/ObjectOrientedTypeDefinitions/TypeExtensions/basic/E_ExtensionOperator01.fs @@ -1,26 +1,26 @@ // #Regression #Conformance #ObjectOrientedTypes #TypeExtensions // Regression for FSHARP1.0:3592 // Can't use extension methods to define operators -//Extension members cannot provide operator overloads\. Consider defining the operator as part of the type definition instead\. -//Extension members cannot provide operator overloads\. Consider defining the operator as part of the type definition instead\. //The type 'Exception' does not support the operator '\+'$ //The type 'Exception' does not support the operator '\+'$ //The type 'MyType' does not support the operator '\+'$ //The type 'MyType' does not support the operator '\+'$ + + open System type MyType() = member this.X = 1 -module TestExtensions = - type MyType with - static member (+) (e1: MyType, e2: MyType) = - new MyType() - - type System.Exception with - static member (+) (e1: Exception, e2: Exception) = - new Exception(e1.Message + " " + e2.Message) +//module TestExtensions = +// type MyType with +// static member (+) (e1: MyType, e2: MyType) = +// new MyType() +// +// type System.Exception with +// static member (+) (e1: Exception, e2: Exception) = +// new Exception(e1.Message + " " + e2.Message) let e1 = Exception() let e2 = Exception() From 91d1a35b55e0191d6644f1e8d7170de2629a30f6 Mon Sep 17 00:00:00 2001 From: dsyme Date: Mon, 2 Oct 2017 15:43:16 +0100 Subject: [PATCH 14/40] support extenstion properties on generic types --- src/fsharp/ConstraintSolver.fs | 342 ++++++++++++++++++--------------- src/fsharp/MethodCalls.fs | 19 +- src/fsharp/NameResolution.fs | 38 ++-- src/fsharp/NameResolution.fsi | 11 ++ src/fsharp/TastOps.fs | 2 +- src/fsharp/tast.fs | 3 +- testfiles/test.fs | 105 +++++++--- 7 files changed, 316 insertions(+), 204 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 7d0fcd0eb83..37a4a9b88c8 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -271,11 +271,15 @@ let isFpTy g ty = let isDecimalTy g ty = typeEquivAux EraseMeasures g g.decimal_ty ty -let IsNonDecimalNumericOrIntegralEnumType g ty = isIntegerOrIntegerEnumTy g ty || isFpTy g ty -let IsNumericOrIntegralEnumType g ty = IsNonDecimalNumericOrIntegralEnumType g ty || isDecimalTy g ty -let IsNonDecimalNumericType g ty = isIntegerTy g ty || isFpTy g ty -let IsNumericType g ty = IsNonDecimalNumericType g ty || isDecimalTy g ty -let IsRelationalType g ty = IsNumericType g ty || isStringTy g ty || isCharTy g ty || isBoolTy g ty +let IsNonDecimalNumericOrIntegralEnumTy g ty = isIntegerOrIntegerEnumTy g ty || isFpTy g ty +let IsIntegerOrEnumTy g ty = isIntegerOrIntegerEnumTy g ty || isEnumTy g ty +let IsNumericOrIntegralEnumTy g ty = IsNonDecimalNumericOrIntegralEnumTy g ty || isDecimalTy g ty +let IsNonDecimalNumericTy g ty = isIntegerTy g ty || isFpTy g ty +let IsNumericTy g ty = IsNonDecimalNumericTy g ty || isDecimalTy g ty +let IsNumericOrCharTy g ty = IsNumericTy g ty || isCharTy g ty +let IsRelationalTy g ty = IsNumericTy g ty || isStringTy g ty || isCharTy g ty || isBoolTy g ty +let IsFpOrDecimalTy g ty = isFpTy g ty || isDecimalTy g ty +let IsSignedIntegerOrFpOrDecimalTy g ty = isSignedIntegerTy g ty || IsFpOrDecimalTy g ty // Get measure of type, float<_> or float32<_> or decimal<_> but not float=float<1> or float32=float32<1> or decimal=decimal<1> let GetMeasureOfType g ty = @@ -945,7 +949,7 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty /// will deal with the problem. and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace traitInfo : OperationResult = // Do not re-solve if already solved - let (TTrait(tys, nm, memFlags, argtys, rty, sln, extVals)) = traitInfo + let (TTrait(traitSupportTys, traitName, traitMemFlags, traitObjAndArgTys, traitRetTy, sln, extSlns)) = traitInfo if sln.Value.IsSome then ResultD true else let g = csenv.g let m = csenv.m @@ -956,27 +960,27 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p DepthCheck ndeep m ++ (fun () -> // Remove duplicates from the set of types in the support - let tys = ListSet.setify (typeAEquiv g aenv) tys + let traitSupportTys = ListSet.setify (typeAEquiv g aenv) traitSupportTys // Rebuild the trait info after removing duplicates - let traitInfo = TTrait(tys, nm, memFlags, argtys, rty, sln, extVals) - let rty = GetFSharpViewOfReturnType g rty + let traitInfo = TTrait(traitSupportTys, traitName, traitMemFlags, traitObjAndArgTys, traitRetTy, sln, extSlns) + let traitRetTy = GetFSharpViewOfReturnType g traitRetTy // Assert the object type if the constraint is for an instance member - if memFlags.IsInstance then - match tys, argtys with + if traitMemFlags.IsInstance then + match traitSupportTys, traitObjAndArgTys with | [ty], (h :: _) -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace h ty | _ -> ErrorD (ConstraintSolverError(FSComp.SR.csExpectedArguments(), m, m2)) else CompleteD ++ (fun () -> // Trait calls are only supported on pseudo type (variables) - tys |> IterateD (SolveTypStaticReq csenv trace HeadTypeStaticReq)) ++ (fun () -> + traitSupportTys |> IterateD (SolveTypStaticReq csenv trace HeadTypeStaticReq)) ++ (fun () -> - let argtys = if memFlags.IsInstance then List.tail argtys else argtys - let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo + let traitArgTys = if traitMemFlags.IsInstance then List.tail traitObjAndArgTys else traitObjAndArgTys + let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution traitName traitInfo - match minfos, tys, memFlags.IsInstance, nm, argtys with - | _, _, false, ("op_Division" | "op_Multiply"), [argty1;argty2] + match traitMemFlags.IsInstance, traitName, traitArgTys with + | false, ("op_Division" | "op_Multiply"), [argty1;argty2] when // This simulates the existence of // float * float -> float @@ -1003,7 +1007,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // decimal<'u> * 'a <--- (let checkRuleAppliesInPreferenceToMethods argty1 argty2 = // Check that at least one of the argument types is numeric - (IsNumericOrIntegralEnumType g argty1) && + (IsNumericOrIntegralEnumTy g argty1) && // Check that the support of type variables is empty. That is, // if we're canonicalizing, then having one of the types nominal is sufficient. // If not, then both must be nominal (i.e. not a type variable). @@ -1012,7 +1016,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // - Neither type contributes any methods OR // - We have the special case "decimal<_> * decimal". In this case we have some // possibly-relevant methods from "decimal" but we ignore them in this case. - (isNil minfos || (Option.isSome (GetMeasureOfType g argty1) && isDecimalTy g argty2)) in + (isNil minfos || IsNumericOrIntegralEnumTy g argty2 || (Option.isSome (GetMeasureOfType g argty1) && isDecimalTy g argty2)) checkRuleAppliesInPreferenceToMethods argty1 argty2 || checkRuleAppliesInPreferenceToMethods argty2 argty1) -> @@ -1021,186 +1025,201 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p | Some (tcref, ms1) -> let ms2 = freshMeasure () SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 (mkAppTy tcref [TType_measure ms2]) ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if traitName = "op_Multiply" then ms2 else Measure.Inv ms2))]) ++ (fun () -> ResultD TTraitBuiltIn)) | _ -> match GetMeasureOfType g argty2 with | Some (tcref, ms2) -> let ms1 = freshMeasure () SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty1 (mkAppTy tcref [TType_measure ms1]) ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if nm = "op_Multiply" then ms2 else Measure.Inv ms2))]) ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy (mkAppTy tcref [TType_measure (Measure.Prod(ms1, if traitName = "op_Multiply" then ms2 else Measure.Inv ms2))]) ++ (fun () -> ResultD TTraitBuiltIn)) | _ -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 argty1 ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty1 ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty1 ++ (fun () -> ResultD TTraitBuiltIn)) - | _, _, false, ("op_Addition" | "op_Subtraction" | "op_Modulus"), [argty1;argty2] - when // Ignore any explicit +/- overloads from any basic integral types - (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.EnclosingType ) && - ( (IsNumericOrIntegralEnumType g argty1 || (nm = "op_Addition" && (isCharTy g argty1 || isStringTy g argty1))) && (permitWeakResolution || not (isTyparTy g argty2)) - || (IsNumericOrIntegralEnumType g argty2 || (nm = "op_Addition" && (isCharTy g argty2 || isStringTy g argty2))) && (permitWeakResolution || not (isTyparTy g argty1)))) -> + | false, ("op_Addition" | "op_Subtraction" | "op_Modulus"), [argty1;argty2] + when traitSupportTys |> List.exists (IsNumericOrIntegralEnumTy g) && + ( (IsNumericOrIntegralEnumTy g argty1 || (traitName = "op_Addition" && (isCharTy g argty1 || isStringTy g argty1))) && (permitWeakResolution || not (isTyparTy g argty2)) + || (IsNumericOrIntegralEnumTy g argty2 || (traitName = "op_Addition" && (isCharTy g argty2 || isStringTy g argty2))) && (permitWeakResolution || not (isTyparTy g argty1))) -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 argty1 ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty1 ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty1 ++ (fun () -> ResultD TTraitBuiltIn)) - | _, _, false, ("op_LessThan" | "op_LessThanOrEqual" | "op_GreaterThan" | "op_GreaterThanOrEqual" | "op_Equality" | "op_Inequality" ), [argty1;argty2] - when // Ignore any explicit overloads from any basic integral types - (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.EnclosingType ) && - ( (IsRelationalType g argty1 && (permitWeakResolution || not (isTyparTy g argty2))) - || (IsRelationalType g argty2 && (permitWeakResolution || not (isTyparTy g argty1))))) -> + | false, ("op_LessThan" | "op_LessThanOrEqual" | "op_GreaterThan" | "op_GreaterThanOrEqual" | "op_Equality" | "op_Inequality" ), [argty1;argty2] + when traitSupportTys |> List.exists (IsRelationalTy g) && + ( (IsRelationalTy g argty1 && (permitWeakResolution || not (isTyparTy g argty2))) + || (IsRelationalTy g argty2 && (permitWeakResolution || not (isTyparTy g argty1)))) -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 argty1 ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty g.bool_ty ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy g.bool_ty ++ (fun () -> ResultD 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 -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty ty ++ (fun () -> + | false, "get_Zero", [] + when traitSupportTys |> List.exists (IsNumericTy g) -> + + let ty = traitSupportTys |> List.find (IsNumericTy g) + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy ty ++ (fun () -> ResultD TTraitBuiltIn) - | [], [ty], false, "get_One", [] - when IsNumericType g ty || isCharTy g ty -> + | false, "get_One", [] + when traitSupportTys |> List.exists (IsNumericOrCharTy g) -> + + let ty = traitSupportTys |> List.find (IsNumericOrCharTy g) SolveDimensionlessNumericType csenv ndeep m2 trace ty ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty ty ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy ty ++ (fun () -> ResultD TTraitBuiltIn)) - | [], _, false, ("DivideByInt"), [argty1;argty2] - when isFpTy g argty1 || isDecimalTy g argty1 -> + | false, "DivideByInt", [argty1;argty2] + when traitSupportTys |> List.exists (IsFpOrDecimalTy g) -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 g.int_ty ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty1 ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty1 ++ (fun () -> ResultD 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 -> + // Simulate the 'string' has an indexer property called 'Item' + | true, "get_Item", [argty1] + when traitSupportTys |> List.exists (isStringTy g) -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty1 g.int_ty ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty g.char_ty ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy g.char_ty ++ (fun () -> ResultD TTraitBuiltIn)) - | [], [ty], true, ("get_Item"), argtys - when isArrayTy g ty -> + // Simulate that all array types have an indexer property called 'Item' + | true, "get_Item", argtys + when traitSupportTys |> List.exists (isArrayTy g) -> - (if rankOfArrayTy g ty <> argtys.Length then ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), argtys.Length), m, m2)) else CompleteD) ++ (fun () -> + let arrayTy = traitSupportTys |> List.find (isArrayTy g) + let rank = rankOfArrayTy g arrayTy + (if rank <> argtys.Length then ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch(rank, argtys.Length), m, m2)) else CompleteD) ++ (fun () -> (argtys |> IterateD (fun argty -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty g.int_ty)) ++ (fun () -> - let ety = destArrayTy g ty - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty ety ++ (fun () -> + let ety = destArrayTy g arrayTy + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy ety ++ (fun () -> ResultD TTraitBuiltIn))) - | [], [ty], true, ("set_Item"), argtys - when isArrayTy g ty -> + // Simulate that all array types have an indexer setter property called 'Item' + | true, "set_Item", argtys + when traitSupportTys |> List.exists (isArrayTy g) -> - (if rankOfArrayTy g ty <> argtys.Length - 1 then ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), (argtys.Length - 1)), m, m2)) else CompleteD) ++ (fun () -> + let arrayTy = traitSupportTys |> List.find (isArrayTy g) + let rank = rankOfArrayTy g arrayTy + (if rank <> argtys.Length - 1 then ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch(rank, (argtys.Length - 1)), m, m2)) else CompleteD) ++ (fun () -> let argtys, ety = List.frontAndBack argtys (argtys |> IterateD (fun argty -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty g.int_ty)) ++ (fun () -> - let etys = destArrayTy g ty + let etys = destArrayTy g arrayTy SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace ety etys ++ (fun () -> ResultD TTraitBuiltIn))) - | [], _, false, ("op_BitwiseAnd" | "op_BitwiseOr" | "op_ExclusiveOr"), [argty1;argty2] - when (isIntegerOrIntegerEnumTy g argty1 || (isEnumTy g argty1)) && (permitWeakResolution || not (isTyparTy g argty2)) - || (isIntegerOrIntegerEnumTy g argty2 || (isEnumTy g argty2)) && (permitWeakResolution || not (isTyparTy g argty1)) -> + | false, ("op_BitwiseAnd" | "op_BitwiseOr" | "op_ExclusiveOr"), [argty1;argty2] + when traitSupportTys |> List.exists (IsIntegerOrEnumTy g) && + ( IsIntegerOrEnumTy g argty1 && (permitWeakResolution || not (isTyparTy g argty2)) + || IsIntegerOrEnumTy g argty2 && (permitWeakResolution || not (isTyparTy g argty1))) -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 argty1 ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty1 ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty1 ++ (fun () -> SolveDimensionlessNumericType csenv ndeep m2 trace argty1 ++ (fun () -> - ResultD TTraitBuiltIn))); + ResultD TTraitBuiltIn))) - | [], _, false, ("op_LeftShift" | "op_RightShift"), [argty1;argty2] - when isIntegerOrIntegerEnumTy g argty1 -> + | false, ("op_LeftShift" | "op_RightShift"), [argty1;argty2] + when traitSupportTys |> List.exists (isIntegerOrIntegerEnumTy g) && + isIntegerOrIntegerEnumTy g argty1 -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 g.int_ty ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty1 ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty1 ++ (fun () -> SolveDimensionlessNumericType csenv ndeep m2 trace argty1 ++ (fun () -> ResultD TTraitBuiltIn))) - | _, _, false, ("op_UnaryPlus"), [argty] - when IsNumericOrIntegralEnumType g argty -> + | false, "op_UnaryPlus", [argty] + when traitSupportTys |> List.exists (IsNumericOrIntegralEnumTy g) && + IsNumericOrIntegralEnumTy g argty -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty ++ (fun () -> ResultD TTraitBuiltIn) - | _, _, false, ("op_UnaryNegation"), [argty] - when isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty -> + | false, "op_UnaryNegation", [argty] + when traitSupportTys |> List.exists (IsSignedIntegerOrFpOrDecimalTy g) && + IsSignedIntegerOrFpOrDecimalTy g argty -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty ++ (fun () -> ResultD TTraitBuiltIn) - | _, _, true, ("get_Sign"), [] - when (let argty = tys.Head in isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty) -> + | true, "get_Sign", [] + when traitSupportTys |> List.exists (IsSignedIntegerOrFpOrDecimalTy g) -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty g.int32_ty ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy g.int32_ty ++ (fun () -> ResultD TTraitBuiltIn) - | _, _, false, ("op_LogicalNot" | "op_OnesComplement"), [argty] - when isIntegerOrIntegerEnumTy g argty -> + | false, ("op_LogicalNot" | "op_OnesComplement"), [argty] + when traitSupportTys |> List.exists (isIntegerOrIntegerEnumTy g) -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty ++ (fun () -> SolveDimensionlessNumericType csenv ndeep m2 trace argty ++ (fun () -> ResultD TTraitBuiltIn)) - | _, _, false, ("Abs"), [argty] - when isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty -> + | false, "Abs", [argty] + when traitSupportTys |> List.exists (IsSignedIntegerOrFpOrDecimalTy g) -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty ++ (fun () -> ResultD TTraitBuiltIn) - | _, _, false, "Sqrt", [argty1] - when isFpTy g argty1 -> - match GetMeasureOfType g argty1 with + | false, "Sqrt", [argty] + when traitSupportTys |> List.exists (isFpTy g) -> + + match GetMeasureOfType g argty with | Some (tcref, _) -> let ms1 = freshMeasure () - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty1 (mkAppTy tcref [TType_measure (Measure.Prod (ms1, ms1))]) ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure ms1]) ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty (mkAppTy tcref [TType_measure (Measure.Prod (ms1, ms1))]) ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy (mkAppTy tcref [TType_measure ms1]) ++ (fun () -> ResultD TTraitBuiltIn)) | None -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty1 ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty ++ (fun () -> ResultD TTraitBuiltIn) - | _, _, false, ("Sin" | "Cos" | "Tan" | "Sinh" | "Cosh" | "Tanh" | "Atan" | "Acos" | "Asin" | "Exp" | "Ceiling" | "Floor" | "Round" | "Truncate" | "Log10" | "Log" | "Sqrt"), [argty] - when isFpTy g argty -> + | false, ("Sin" | "Cos" | "Tan" | "Sinh" | "Cosh" | "Tanh" | "Atan" | "Acos" | "Asin" | "Exp" | "Ceiling" | "Floor" | "Round" | "Truncate" | "Log10" | "Log" | "Sqrt"), [argty] + when traitSupportTys |> List.exists (isFpTy g) -> SolveDimensionlessNumericType csenv ndeep m2 trace argty ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty ++ (fun () -> ResultD TTraitBuiltIn)) - | _, _, false, ("op_Explicit"), [argty] + // Simulate solutions to op_Implicit and op_Explicit + | false, "op_Explicit", [argty] when (// The input type. - (IsNonDecimalNumericOrIntegralEnumType g argty || isStringTy g argty || isCharTy g argty) && + (IsNonDecimalNumericOrIntegralEnumTy g argty || isStringTy g argty || isCharTy g argty) && // The output type - (IsNonDecimalNumericOrIntegralEnumType g rty || isCharTy g rty) && + (IsNonDecimalNumericOrIntegralEnumTy g traitRetTy || isCharTy g traitRetTy) && // Exclusion: IntPtr and UIntPtr do not support .Parse() from string - not (isStringTy g argty && isNativeIntegerTy g rty) && + not (isStringTy g argty && isNativeIntegerTy g traitRetTy) && // Exclusion: No conversion from char to decimal - not (isCharTy g argty && isDecimalTy g rty)) -> + not (isCharTy g argty && isDecimalTy g traitRetTy)) -> ResultD TTraitBuiltIn - | _, _, false, ("op_Explicit"), [argty] + | false, "op_Explicit", [argty] when (// The input type. - (IsNumericOrIntegralEnumType g argty || isStringTy g argty) && + (IsNumericOrIntegralEnumTy g argty || isStringTy g argty) && // The output type - (isDecimalTy g rty)) -> + (isDecimalTy g traitRetTy)) -> ResultD TTraitBuiltIn - | [], _, false, "Pow", [argty1; argty2] - when isFpTy g argty1 -> + | false, "Pow", [argty1; argty2] + when traitSupportTys |> List.exists (isFpTy g) -> SolveDimensionlessNumericType csenv ndeep m2 trace argty1 ++ (fun () -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 argty1 ++ (fun () -> - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty1 ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty1 ++ (fun () -> ResultD TTraitBuiltIn))) - | _, _, false, ("Atan2"), [argty1; argty2] - when isFpTy g argty1 -> + | false, "Atan2", [argty1; argty2] + when traitSupportTys |> List.exists (isFpTy g) -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 argty1 ++ (fun () -> match GetMeasureOfType g argty1 with - | None -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty argty1 - | Some (tcref, _) -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty (mkAppTy tcref [TType_measure Measure.One])) ++ (fun () -> + | None -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty1 + | Some (tcref, _) -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy (mkAppTy tcref [TType_measure Measure.One])) ++ (fun () -> ResultD TTraitBuiltIn) | _ -> @@ -1209,16 +1228,16 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // First look for a solution by a record property let recdPropSearch = - let isGetProp = nm.StartsWith "get_" - let isSetProp = nm.StartsWith "set_" - if argtys.IsEmpty && isGetProp || isSetProp then - let propName = nm.[4..] + let isGetProp = traitName.StartsWith "get_" + let isSetProp = traitName.StartsWith "set_" + if (traitArgTys.IsEmpty && isGetProp) || isSetProp then + let propName = traitName.[4..] let props = - tys |> List.choose (fun ty -> + traitSupportTys |> List.choose (fun ty -> match TryFindIntrinsicNamedItemOfType csenv.InfoReader (propName, AccessibleFromEverywhere) FindMemberFlag.IgnoreOverrides m ty with | Some (RecdFieldItem rfinfo) when (isGetProp || rfinfo.RecdField.IsMutable) && - (rfinfo.IsStatic = not memFlags.IsInstance) && + (rfinfo.IsStatic = not traitMemFlags.IsInstance) && IsRecdFieldAccessible amap m AccessibleFromEverywhere rfinfo.RecdFieldRef && not rfinfo.LiteralValue.IsSome && not rfinfo.RecdField.IsCompilerGenerated -> @@ -1232,29 +1251,33 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // Now check if there are no feasible solutions at all match minfos, recdPropSearch with - | [], None when not (tys |> List.exists (isAnyParTy g)) -> - if tys |> List.exists (isFunTy g) then - ErrorD (ConstraintSolverError(FSComp.SR.csExpectTypeWithOperatorButGivenFunction(DecompileOpName nm), m, m2)) - elif tys |> List.exists (isAnyTupleTy g) then - ErrorD (ConstraintSolverError(FSComp.SR.csExpectTypeWithOperatorButGivenTuple(DecompileOpName nm), m, m2)) + | [], None when not (traitSupportTys |> List.exists (isAnyParTy g)) -> + + if traitSupportTys |> List.exists (isFunTy g) then + ErrorD (ConstraintSolverError(FSComp.SR.csExpectTypeWithOperatorButGivenFunction(DecompileOpName traitName), m, m2)) + + elif traitSupportTys |> List.exists (isAnyTupleTy g) then + ErrorD (ConstraintSolverError(FSComp.SR.csExpectTypeWithOperatorButGivenTuple(DecompileOpName traitName), m, m2)) + else - match nm, argtys with - | "op_Explicit", [argty] -> ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportConversion((NicePrint.prettyStringOfTy denv argty), (NicePrint.prettyStringOfTy denv rty)), m, m2)) + + match traitName, traitArgTys with + | "op_Explicit", [argty] -> ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportConversion((NicePrint.prettyStringOfTy denv argty), (NicePrint.prettyStringOfTy denv traitRetTy)), m, m2)) | _ -> let tyString = - match tys with + match traitSupportTys with | [ty] -> NicePrint.minimalStringOfType denv ty - | _ -> tys |> List.map (NicePrint.minimalStringOfType denv) |> String.concat ", " - let opName = DecompileOpName nm + | _ -> traitSupportTys |> List.map (NicePrint.minimalStringOfType denv) |> String.concat ", " + let opName = DecompileOpName traitName let err = match opName with | "?>=" | "?>" | "?<=" | "?<" | "?=" | "?<>" | ">=?" | ">?" | "<=?" | "?" | "?>=?" | "?>?" | "?<=?" | "??" -> - if tys.Length = 1 then FSComp.SR.csTypeDoesNotSupportOperatorNullable(tyString, opName) + if traitSupportTys.Length = 1 then FSComp.SR.csTypeDoesNotSupportOperatorNullable(tyString, opName) else FSComp.SR.csTypesDoNotSupportOperatorNullable(tyString, opName) | _ -> - if tys.Length = 1 then FSComp.SR.csTypeDoesNotSupportOperator(tyString, opName) + if traitSupportTys.Length = 1 then FSComp.SR.csTypeDoesNotSupportOperator(tyString, opName) else FSComp.SR.csTypesDoNotSupportOperator(tyString, opName) ErrorD(ConstraintSolverError(err, m, m2)) @@ -1266,30 +1289,33 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // curried members may not be used to satisfy constraints |> List.choose (fun minfo -> if minfo.IsCurried then None else - let callerArgs = argtys |> List.map (fun argty -> CallerArg(argty, m, false, dummyExpr)) + let callerArgs = traitArgTys |> List.map (fun argty -> CallerArg(argty, m, false, dummyExpr)) let minst = FreshenMethInfo None m minfo - let objtys = minfo.GetObjArgTypes(amap, m, minst) - Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo None, m, AccessibleFromEverywhere, minfo, minst, minst, None, objtys, [(callerArgs, [])], false, false, None))) + //let objtys = minfo.GetObjArgTypes(amap, m, minst) + let callerObjTys = if traitMemFlags.IsInstance then [ List.head traitObjAndArgTys ] else [] + Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo None, m, AccessibleFromEverywhere, minfo, minst, minst, None, callerObjTys, [(callerArgs, [])], false, false, None))) let methOverloadResult, errors = - trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) (fun trace -> ResolveOverloading csenv (WithTrace trace) nm ndeep (Some traitInfo) (0, 0) AccessibleFromEverywhere calledMethGroup false (Some rty)) + trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) (fun trace -> + ResolveOverloading csenv (WithTrace trace) traitName ndeep (Some traitInfo) (0, 0) AccessibleFromEverywhere calledMethGroup false (Some traitRetTy)) match recdPropSearch, methOverloadResult with | 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 - SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace rty rty2 ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy rty2 ++ (fun () -> ResultD (TTraitSolvedRecdProp(rfinfo, isSetProp))) + | None, Some (calledMeth:CalledMeth<_>) -> - // OK, the constraint is solved. + // OK, the constraint is solved by a method let minfo = calledMeth.Method errors ++ (fun () -> let isInstance = minfo.IsInstance - if isInstance <> memFlags.IsInstance then + if isInstance <> traitMemFlags.IsInstance then if isInstance then - ErrorD(ConstraintSolverError(FSComp.SR.csMethodFoundButIsNotStatic((NicePrint.minimalStringOfType denv minfo.EnclosingType), (DecompileOpName nm), nm), m, m2 )) + ErrorD(ConstraintSolverError(FSComp.SR.csMethodFoundButIsNotStatic((NicePrint.minimalStringOfType denv minfo.EnclosingType), (DecompileOpName traitName), traitName), m, m2 )) else - ErrorD(ConstraintSolverError(FSComp.SR.csMethodFoundButIsStatic((NicePrint.minimalStringOfType denv minfo.EnclosingType), (DecompileOpName nm), nm), m, m2 )) + ErrorD(ConstraintSolverError(FSComp.SR.csMethodFoundButIsStatic((NicePrint.minimalStringOfType denv minfo.EnclosingType), (DecompileOpName traitName), traitName), m, m2 )) else CheckMethInfoAttributes g m None minfo ++ (fun () -> ResultD (TTraitSolved (minfo, calledMeth.CalledTyArgs)))) @@ -1303,7 +1329,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // Otherwise re-record the trait waiting for canonicalization else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees) ++ (fun () -> match errors with - | ErrorResult (_, UnresolvedOverloading _) when not ignoreUnresolvedOverload && (not (nm = "op_Explicit" || nm = "op_Implicit")) -> ErrorD LocallyAbortOperationThatFailsToResolveOverload + | ErrorResult (_, UnresolvedOverloading _) when not ignoreUnresolvedOverload && (not (traitName = "op_Explicit" || traitName = "op_Implicit")) -> ErrorD LocallyAbortOperationThatFailsToResolveOverload | _ -> ResultD TTraitUnsolved) ) ++ @@ -1323,12 +1349,12 @@ and RecordMemberConstraintSolution css m trace traitInfo res = ResultD true | TTraitBuiltIn -> - TransactMemberConstraintSolution traitInfo trace BuiltInSln; + TransactMemberConstraintSolution traitInfo trace BuiltInSln ResultD true | TTraitSolvedRecdProp (rfinfo, isSetProp) -> let sln = MemberConstraintSolutionOfRecdFieldInfo rfinfo isSetProp - TransactMemberConstraintSolution traitInfo trace sln; + TransactMemberConstraintSolution traitInfo trace sln ResultD true /// Convert a MethInfo into the data we save in the TAST @@ -1344,7 +1370,11 @@ and MemberConstraintSolutionOfMethInfo css m minfo minst = let iltref = ilMeth.DeclaringTyconRefOption |> Option.map (fun tcref -> tcref.CompiledRepresentationForNamedType) ILMethSln(ilMeth.ApparentEnclosingType, iltref, mref, minst) | FSMeth(_, typ, vref, _) -> - FSMethSln(typ, vref, minst) +#if DEBUG + let vtinst = minfo.DeclaringTypeInst @ minst + if vref.Typars.Length <> vtinst.Length then error(InternalError("MemberConstraintSolutionOfMethInfo: unexpected typar length mismatch",m)) +#endif + FSMethSln(typ, vref, minst) | MethInfo.DefaultStructCtor _ -> error(InternalError("the default struct constructor was the unexpected solution to a trait constraint", m)) #if EXTENSIONTYPING @@ -1380,13 +1410,16 @@ and TransactMemberConstraintSolution traitInfo (trace:OptionalTrace) sln = let prev = traitInfo.Solution trace.Exec (fun () -> traitInfo.Solution <- Some sln) (fun () -> traitInfo.Solution <- prev) -and GetRelevantExtensionMethodsForTrait g (TTrait(tys, _, _, _, _, _, extVals)) = +and GetRelevantExtensionMethodsForTrait m (amap: Import.ImportMap) (TTrait(traitSupportTys, _, _, _, _, _, extSlns)) = // TODO: check the use of 'allPairs' - not all these extensions apply to each type variable. - (tys,extVals) ||> List.allPairs |> List.map (fun (t,vref) -> FSMeth(g, t, vref, Some 1uL) ) + (traitSupportTys,extSlns) ||> List.allPairs |> List.choose (fun (traitSupportTy,extMem) -> + match (extMem :?> ExtensionMember) with + | FSExtMem (vref, pri) -> Some (FSMeth(amap.g, traitSupportTy, vref, Some pri) ) + | ILExtMem (actualParent, minfo, pri) -> TrySelectExtensionMethInfoOfILExtMem m amap traitSupportTy (actualParent, minfo, pri)) /// Only consider overload resolution if canonicalizing or all the types are now nominal. /// That is, don't perform resolution if more nominal information may influence the set of available overloads -and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys, _, memFlags, argtys, rty, soln, extVals) as traitInfo) : MethInfo list = +and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution traitName (TTrait(traitSupportTys, _, memFlags, argtys, traitRetTy, soln, extSlns) as traitInfo) : MethInfo list = let results = let strongResolution = isNil (GetSupportOfMemberConstraint csenv traitInfo) if permitWeakResolution || strongResolution then @@ -1394,9 +1427,9 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution let minfos = match memFlags.MemberKind with | MemberKind.Constructor -> - tys |> List.map (GetIntrinsicConstructorInfosOfType csenv.SolverState.InfoReader m) + traitSupportTys |> List.map (GetIntrinsicConstructorInfosOfType csenv.SolverState.InfoReader m) | _ -> - tys |> List.map (GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm, AccessibleFromSomeFSharpCode, AllowMultiIntfInstantiations.Yes) IgnoreOverrides m) + traitSupportTys |> List.map (GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some traitName, AccessibleFromSomeFSharpCode, AllowMultiIntfInstantiations.Yes) IgnoreOverrides m) /// Merge the sets so we don't get the same minfo from each side /// We merge based on whether minfos use identical metadata or not. @@ -1405,7 +1438,7 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution // Get the extension method that may be relevant to solving the constraint as MethInfo objects. // Extension members are not used when canonicalizing prior to generalization (permitWeakResolution=true) let extMInfos = - if strongResolution then GetRelevantExtensionMethodsForTrait csenv.g traitInfo + if strongResolution then GetRelevantExtensionMethodsForTrait csenv.m csenv.amap traitInfo else [] let extMInfos = extMInfos |> ListSet.setify MethInfo.MethInfosUseIdenticalDefinitions @@ -1418,19 +1451,19 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution [] // The trait name "op_Explicit" also covers "op_Implicit", so look for that one too. - if nm = "op_Explicit" then - results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln, extVals)) + if traitName = "op_Explicit" then + results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(traitSupportTys, "op_Implicit", memFlags, argtys, traitRetTy, soln, extSlns)) else results /// The nominal support of the member constraint -and GetSupportOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _, _)) = - tys |> List.choose (tryAnyParTy csenv.g) +and GetSupportOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(traitSupportTys, _, _, _, _, _, _)) = + traitSupportTys |> List.choose (tryAnyParTy csenv.g) /// All the typars relevant to the member constraint *) -and GetFreeTyparsOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, argtys, rty, _, _)) = - freeInTypesLeftToRightSkippingConstraints csenv.g (tys@argtys@ Option.toList rty) +and GetFreeTyparsOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(traitSupportTys, _, _, argtys, traitRetTy, _, _)) = + freeInTypesLeftToRightSkippingConstraints csenv.g (traitSupportTys@argtys@ Option.toList traitRetTy) /// 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 @@ -1450,12 +1483,7 @@ and SolveRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep permitWeakR and GetRelevantPossibleExtensionSolutionsToConstraint (nenv: NameResolutionEnv) (traitInfo: TraitConstraintInfo) = NameMultiMap.find traitInfo.MemberName nenv.eExtensionMembersByName - |> List.choose (function - | FSExtMem (v,_) -> - if v.LogicalName = traitInfo.MemberName then Some v - else None - // TODO: allow .NET-defined extension members to solve trait constraints - | ILExtMem (_,_,_) -> None) + |> List.map (fun extMem -> (extMem :> PossibleExtensionMemberSolution)) and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep permitWeakResolution (trace:OptionalTrace) tp = let cxst = csenv.SolverState.ExtraCxs @@ -2624,8 +2652,11 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait TcVal = tcVal ExtraCxs = HashMultiMap(10, HashIdentity.Structural) InfoReader = new InfoReader(g,amap) } + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) + SolveMemberConstraint csenv true (*permitWeakResolution*)true 0 m NoTrace traitInfo ++ (fun _res -> + let sln = match traitInfo.Solution with | None -> Choice4Of4() @@ -2649,8 +2680,9 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait Choice4Of4 () | ClosedExprSln expr -> Choice3Of4 expr + match sln with - | Choice1Of4(minfo, methArgTys) -> + | Choice1Of4(minfo, minst) -> let argExprs = // FIX for #421894 - typechecker assumes that coercion can be applied for the trait calls arguments but codegen doesn't emit coercion operations // result - generation of non-verifyable code @@ -2658,8 +2690,9 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait // flatten list of argument types (looks like trait calls with curried arguments are not supported so we can just convert argument list in straighforward way) let argTypes = - minfo.GetParamTypes(amap, m, methArgTys) + minfo.GetParamTypes(amap, m, minst) |> List.concat + // do not apply coercion to the 'receiver' argument let receiverArgOpt, argExprs = if minfo.IsInstance then @@ -2667,6 +2700,7 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait | h::t -> Some h, t | argExprs -> None, argExprs else None, argExprs + let convertedArgs = (argExprs, argTypes) ||> List.map2 (fun expr expectedTy -> mkCoerceIfNeeded g expectedTy (tyOfExpr g expr) expr) match receiverArgOpt with | Some r -> r::convertedArgs @@ -2679,7 +2713,7 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait let wrap, h' = mkExprAddrOfExpr g true false PossiblyMutates h None m ResultD (Some (wrap (Expr.Op(TOp.TraitCall(traitInfo), [], (h' :: t), m)))) else - ResultD (Some (MakeMethInfoCall amap m minfo methArgTys argExprs )) + ResultD (Some (MakeMethInfoCall amap m minfo minst argExprs )) | Choice2Of4 (tinst, rfref, isSet) -> let res = diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index aae55a83121..c7319fa4b1b 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -633,13 +633,13 @@ let BuildFSharpMethodApp g m (vref: ValRef) vexp vexprty (args: Exprs) = retTy /// Build a call to an F# method. -let BuildFSharpMethodCall g m (typ,vref:ValRef) valUseFlags minst args = - let vexp = Expr.Val (vref,valUseFlags,m) +let BuildFSharpMethodCall g m (vref:ValRef) valUseFlags declaringTypeInst minst args = + let vexp = Expr.Val (vref, valUseFlags, m) let vexpty = vref.Type let tpsorig,tau = vref.TypeScheme - let vtinst = (if vref.IsExtensionMember then [] else argsOfAppTy g typ) @ minst - if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected List.length mismatch",m)) - let expr = mkTyAppExpr m (vexp,vexpty) vtinst + let vtinst = declaringTypeInst @ minst + if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected typar length mismatch",m)) + let expr = mkTyAppExpr m (vexp, vexpty) vtinst let exprty = instType (mkTyparInst tpsorig vtinst) tau BuildFSharpMethodApp g m vref expr exprty args @@ -648,15 +648,20 @@ let BuildFSharpMethodCall g m (typ,vref:ValRef) valUseFlags minst args = /// calls to the type-directed solutions to member constraints. let MakeMethInfoCall amap m minfo minst args = let valUseFlags = NormalValUse // correct unless if we allow wild trait constraints like "T has a ctor and can be used as a parent class" + match minfo with + | ILMeth(g,ilminfo,_) -> let direct = not minfo.IsVirtual let isProp = false // not necessarily correct, but this is only used post-creflect where this flag is irrelevant BuildILMethInfoCall g amap m isProp ilminfo valUseFlags minst direct args |> fst - | FSMeth(g,typ,vref,_) -> - BuildFSharpMethodCall g m (typ,vref) valUseFlags minst args |> fst + + | FSMeth(g, _, vref, _) -> + BuildFSharpMethodCall g m vref valUseFlags minfo.DeclaringTypeInst minst args |> fst + | DefaultStructCtor(_,typ) -> mkDefault (m,typ) + #if EXTENSIONTYPING | ProvidedMeth(amap,mi,_,m) -> let isProp = false // not necessarily correct, but this is only used post-creflect where this flag is irrelevant diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index f956c7c277d..5f829ca4f9d 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -269,7 +269,7 @@ let (|ItemWithInst|) (x:ItemWithInst) = (x.Item, x.TyparInst) type FieldResolution = FieldResolution of RecdFieldRef * bool /// Information about an extension member held in the name resolution environment -type ExtensionMember = +type ExtensionMember = /// F#-style Extrinsic extension member, defined in F# code | FSExtMem of ValRef * ExtensionMethodPriority @@ -279,6 +279,8 @@ type ExtensionMember = /// IL-style extension member, backed by some kind of method with an [] attribute | ILExtMem of TyconRef * MethInfo * ExtensionMethodPriority + interface PossibleExtensionMemberSolution + /// Check if two extension members refer to the same definition static member Equality g e1 e2 = match e1, e2 with @@ -368,7 +370,7 @@ type NameResolutionEnv = /// Extension members by type and name eIndexedExtensionMembers: TyconRefMultiMap - /// Extension members by name + /// Extension members by name eExtensionMembersByName: NameMultiMap /// Other extension members unindexed by type @@ -1899,6 +1901,21 @@ let IntrinsicMethInfosOfType (infoReader:InfoReader) (optFilter,ad,allowMultiInt let minfos = minfos |> ExcludeHiddenOfMethInfos g amap m minfos +let TrySelectExtensionMethInfoOfILExtMem m amap apparentTy (actualParent, minfo, pri) = + match minfo with + | ILMeth(_,ilminfo,_) -> + MethInfo.CreateILExtensionMeth (amap, m, apparentTy, actualParent, Some pri, ilminfo.RawMetadata) |> Some + // F#-defined IL-style extension methods are not seen as extension methods in F# code + | FSMeth(g,_,vref,_) -> + FSMeth(g, apparentTy, vref, Some pri) |> Some +#if EXTENSIONTYPING + // // Provided extension methods are not yet supported + | ProvidedMeth(amap,providedMeth,_,m) -> + ProvidedMeth(amap, providedMeth, Some pri,m) |> Some +#endif + | DefaultStructCtor _ -> + None + /// Select from a list of extension methods let SelectMethInfosFromExtMembers (infoReader:InfoReader) optFilter apparentTy m extMemInfos = let g = infoReader.g @@ -1916,20 +1933,9 @@ let SelectMethInfosFromExtMembers (infoReader:InfoReader) optFilter apparentTy m | Some m -> yield m | _ -> () | ILExtMem (actualParent,minfo,pri) when (match optFilter with None -> true | Some nm -> nm = minfo.LogicalName) -> - // Make a reference to the type containing the extension members - match minfo with - | ILMeth(_,ilminfo,_) -> - yield (MethInfo.CreateILExtensionMeth (infoReader.amap, m, apparentTy, actualParent, Some pri, ilminfo.RawMetadata)) - // F#-defined IL-style extension methods are not seen as extension methods in F# code - | FSMeth(g,_,vref,_) -> - yield (FSMeth(g, apparentTy, vref, Some pri)) -#if EXTENSIONTYPING - // // Provided extension methods are not yet supported - | ProvidedMeth(amap,providedMeth,_,m) -> - yield (ProvidedMeth(amap, providedMeth, Some pri,m)) -#endif - | DefaultStructCtor _ -> - () + match TrySelectExtensionMethInfoOfILExtMem m infoReader.amap apparentTy (actualParent, minfo, pri) with + | Some minfo -> yield minfo + | None -> () | _ -> () ] diff --git a/src/fsharp/NameResolution.fsi b/src/fsharp/NameResolution.fsi index 3e4488ac7b2..dddb3ab910e 100755 --- a/src/fsharp/NameResolution.fsi +++ b/src/fsharp/NameResolution.fsi @@ -142,6 +142,15 @@ type ExtensionMember = /// IL-style extension member, backed by some kind of method with an [] attribute | ILExtMem of TyconRef * MethInfo * ExtensionMethodPriority + interface PossibleExtensionMemberSolution + + /// The logical name, e.g. for constraint solving + member LogicalName : string + + /// Describes the sequence order of the introduction of an extension method. Extension methods that are introduced + /// later through 'open' get priority in overload resolution. + member Priority : ExtensionMethodPriority + /// The environment of information used to resolve names [] type NameResolutionEnv = @@ -535,3 +544,5 @@ val ResolveCompletionsInType : NameResolver -> NameResolutionEnv -> Resolv val GetVisibleNamespacesAndModulesAtPoint : NameResolver -> NameResolutionEnv -> range -> AccessorDomain -> ModuleOrNamespaceRef list val IsItemResolvable : NameResolver -> NameResolutionEnv -> range -> AccessorDomain -> string list -> Item -> bool + +val TrySelectExtensionMethInfoOfILExtMem : range -> ImportMap -> TType -> TyconRef * MethInfo * ExtensionMethodPriority -> MethInfo option \ No newline at end of file diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 01220650150..3db6fdd1ade 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -278,7 +278,7 @@ and remapTraitAux tyenv (TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns)) = if tyenv.extSlnsMap.ContainsKey nm then tyenv.extSlnsMap.[nm] else - List.map (remapValRef tyenv) extSlns + extSlns // TODO: do we need to remap here??? // Note: we reallocate a new solution cell (though keep existing solutions unless 'removeTraitSolutions'=true) on every traversal of a trait constraint // This feels incorrect for trait constraints that are quantified: it seems we should have diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 3218f0e0d26..4163a415720 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -2029,7 +2029,8 @@ and override x.ToString() = x.Name -and PossibleExtensionMemberSolutions = ValRef list +and PossibleExtensionMemberSolutions = PossibleExtensionMemberSolution list +and PossibleExtensionMemberSolution = interface end // only satisfied by type 'ExtensionMember' and [] diff --git a/testfiles/test.fs b/testfiles/test.fs index bef8723762d..c06a5a4e9a6 100644 --- a/testfiles/test.fs +++ b/testfiles/test.fs @@ -1,30 +1,49 @@ module Test -(* -module Example1 = - type System.Int32 with - static member (++)(a: int, b: int) = a +type MyType = + | MyType of int - let result = 1 ++ 2 +/// Extending a .NET primitive type with new operator -module Bug1 = +module DotNetPrimtiveWithNewOperator = type System.Int32 with - static member Add(a: int, b: int) = a - - let inline addGeneric< ^A when ^A : (static member Add : ^A * ^A -> ^A) > (a,b) : ^A = - (^A : (static member Add : ^A * ^A -> ^A) (a,b)) - let result = addGeneric (1,2) + static member (++)(a: int, b: int) = a + let result = 1 ++ 2 -module Example2 = - type System.Int32 with - static member Add(a: int, b: int) = a +/// Extending an F# type with + operator +module FSharpTypeWithExtrinsicOperators = - type MyType = - | MyType of int + [] + module Extensions = + type MyType with + static member (+)(MyType x, MyType y) = MyType (x + y) + static member (*)(MyType x, MyType y) = MyType (x * y) + static member (/)(MyType x, MyType y) = MyType (x / y) + static member (-)(MyType x, MyType y) = MyType (x - y) + static member (~-)(MyType x) = MyType (-x) + static member (|||)(MyType x, MyType y) = MyType (x ||| y) + static member (&&&)(MyType x, MyType y) = MyType (x &&& y) + static member (^^^)(MyType x, MyType y) = MyType (x &&& y) + + let v = MyType 3 + let result1 = v + v + let result2 = v * v + let result3 = v - v + let result4 = v / v + let result5 = -v + let result6 = v ||| v + let result7 = v &&& v + let result8 = v ^^^ v + + +module TwoTypesWithExtensionOfSameName = [] module Extensions = + type System.Int32 with + static member Add(a: int, b: int) = a + type MyType with static member Add(MyType x, MyType y) = MyType (x + y) @@ -59,21 +78,57 @@ module Example2 = let v2 = 1 ++++ 1 () -*) -module Example3 = - //let v = [3].Length +/// Extending a generic type with a property +module ExtendingGenericTypeWithProperty = + + type List<'T> with + member x.Count = x.Length + + let inline count (a : ^A when ^A : (member Count : int)) = + (^A : (member Count : int) (a)) + + let v0 = [3].Count // sanity check + + let v3 = count [3] + + let v5 = count (ResizeArray [| 3 |]) + +/// Extending a generic type with a property +/// Extending the .NET array type with a property +module ExtendingGenericTypeAndArrayWithProperty = + type List<'T> with - member x.Count = 3 //x.Length + member x.Count = x.Length + + type ``[]``<'T> with + member x.Count = x.Length let inline count (a : ^A when ^A : (member Count : int)) = (^A : (member Count : int) (a)) - //let inline length (a : ^A when ^A : (member Length : int)) = - // (^A : (member Length : int) (a)) + let v0 = [3].Count // sanity check + + let v1 = [|3|].Count // sanity check + + let v3 = count [3] + + let v4 = count [| 3 |] + + let v5 = count (ResizeArray [| 3 |]) + + +/// Solving using LINQ extensions +module LinqExtensionMethodsProvideSolutions = + + open System.Linq + + let inline count (a : ^A when ^A : (member Count : int)) = + (^A : (member Count : int) (a)) - //let v1 = [3].Count - //let v3 = length [3] + let seqv = seq { yield 1; yield 2 } + + let v0 = seqv.Count // sanity check - let v2 = count [3] + let v1 = count seqv From 7513645ad59b55c35fc064e3721a249000a63eac Mon Sep 17 00:00:00 2001 From: dsyme Date: Mon, 2 Oct 2017 18:20:32 +0100 Subject: [PATCH 15/40] range of fixes to freshening and trait printing --- src/fsharp/AccessibilityLogic.fs | 3 + src/fsharp/ConstraintSolver.fs | 107 +++++---- src/fsharp/ConstraintSolver.fsi | 32 ++- src/fsharp/FindUnsolved.fs | 2 +- src/fsharp/NameResolution.fs | 2 +- src/fsharp/NameResolution.fsi | 2 +- src/fsharp/NicePrint.fs | 14 +- src/fsharp/PostInferenceChecks.fs | 4 +- src/fsharp/TastOps.fs | 20 +- src/fsharp/TastOps.fsi | 2 +- src/fsharp/TastPickle.fs | 5 +- src/fsharp/TypeChecker.fs | 347 +++++++++++++++--------------- src/fsharp/TypeRelations.fs | 4 +- src/fsharp/infos.fs | 27 ++- src/fsharp/symbols/Exprs.fs | 2 +- src/fsharp/symbols/Symbols.fs | 2 +- src/fsharp/tast.fs | 33 ++- testfiles/test.fs | 91 +++++++- 18 files changed, 427 insertions(+), 272 deletions(-) diff --git a/src/fsharp/AccessibilityLogic.fs b/src/fsharp/AccessibilityLogic.fs index 6c4362d9a4f..848bead1ff8 100644 --- a/src/fsharp/AccessibilityLogic.fs +++ b/src/fsharp/AccessibilityLogic.fs @@ -40,6 +40,8 @@ type AccessorDomain = /// An AccessorDomain which returns all items | AccessibleFromSomewhere + interface TraitAccessorDomain + // Hashing and comparison is used for the memoization tables keyed by an accessor domain. // It is dependent on a TcGlobals because of the TyconRef in the data structure static member CustomGetHashCode(ad:AccessorDomain) = @@ -48,6 +50,7 @@ type AccessorDomain = | AccessibleFromEverywhere -> 2 | AccessibleFromSomeFSharpCode -> 3 | AccessibleFromSomewhere -> 4 + static member CustomEquals(g:TcGlobals, ad1:AccessorDomain, ad2:AccessorDomain) = match ad1, ad2 with | AccessibleFrom(cs1,tc1), AccessibleFrom(cs2,tc2) -> (cs1 = cs2) && (match tc1,tc2 with None,None -> true | Some tc1, Some tc2 -> tyconRefEq g tc1 tc2 | _ -> false) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 37a4a9b88c8..99c90a0a4df 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -82,29 +82,32 @@ let NewErrorMeasure () = Measure.Var (NewErrorMeasureVar ()) let NewInferenceTypes l = l |> List.map (fun _ -> NewInferenceType ()) +/// Freshen a trait for use at a particular location +type TraitFreshener = (TraitConstraintInfo -> TraitPossibleExtensionMemberSolutions * TraitAccessorDomain) + // QUERY: should 'rigid' ever really be 'true'? We set this when we know // we are going to have to generalize a typar, e.g. when implementing a // abstract generic method slot. But we later check the generalization // condition anyway, so we could get away with a non-rigid typar. This // would sort of be cleaner, though give errors later. -let FreshenAndFixupTypars getExtSlnsOpt m rigid fctps tinst tpsorig = +let FreshenAndFixupTypars (traitFreshner: TraitFreshener option) m rigid fctps tinst tpsorig = let copy_tyvar (tp:Typar) = NewCompGenTypar (tp.Kind, rigid, tp.StaticReq, (if rigid=TyparRigidity.Rigid then TyparDynamicReq.Yes else TyparDynamicReq.No), false) let tps = tpsorig |> List.map copy_tyvar - let renaming, tinst = FixupNewTypars getExtSlnsOpt m fctps tinst tpsorig tps + let renaming, tinst = FixupNewTypars traitFreshner m fctps tinst tpsorig tps tps, renaming, tinst -let FreshenTypeInst getExtSlnsOpt m tpsorig = FreshenAndFixupTypars getExtSlnsOpt m TyparRigidity.Flexible [] [] tpsorig -let FreshenMethInst getExtSlnsOpt m fctps tinst tpsorig = FreshenAndFixupTypars getExtSlnsOpt m TyparRigidity.Flexible fctps tinst tpsorig +let FreshenTypeInst traitFreshner m tpsorig = FreshenAndFixupTypars traitFreshner m TyparRigidity.Flexible [] [] tpsorig +let FreshenMethInst traitFreshner m fctps tinst tpsorig = FreshenAndFixupTypars traitFreshner m TyparRigidity.Flexible fctps tinst tpsorig -let FreshenTypars getExtSlnsOpt m tpsorig = +let FreshenTypars traitFreshner m tpsorig = match tpsorig with | [] -> [] | _ -> - let _, _, tptys = FreshenTypeInst getExtSlnsOpt m tpsorig + let _, _, tptys = FreshenTypeInst traitFreshner m tpsorig tptys -let FreshenMethInfo getExtSlnsOpt m (minfo:MethInfo) = - let _, _, tptys = FreshenMethInst getExtSlnsOpt m (minfo.GetFormalTyparsOfDeclaringType m) minfo.DeclaringTypeInst minfo.FormalMethodTypars +let FreshenMethInfo traitFreshner m (minfo:MethInfo) = + let _, _, tptys = FreshenMethInst traitFreshner m (minfo.GetFormalTyparsOfDeclaringType m) minfo.DeclaringTypeInst minfo.FormalMethodTypars tptys @@ -949,7 +952,7 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty /// will deal with the problem. and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace traitInfo : OperationResult = // Do not re-solve if already solved - let (TTrait(traitSupportTys, traitName, traitMemFlags, traitObjAndArgTys, traitRetTy, sln, extSlns)) = traitInfo + let (TTrait(traitSupportTys, traitName, traitMemFlags, traitObjAndArgTys, traitRetTy, sln, extSlns, traitAD)) = traitInfo if sln.Value.IsSome then ResultD true else let g = csenv.g let m = csenv.m @@ -961,9 +964,11 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // Remove duplicates from the set of types in the support let traitSupportTys = ListSet.setify (typeAEquiv g aenv) traitSupportTys + // Rebuild the trait info after removing duplicates - let traitInfo = TTrait(traitSupportTys, traitName, traitMemFlags, traitObjAndArgTys, traitRetTy, sln, extSlns) + let traitInfo = TTrait(traitSupportTys, traitName, traitMemFlags, traitObjAndArgTys, traitRetTy, sln, extSlns, traitAD) let traitRetTy = GetFSharpViewOfReturnType g traitRetTy + let traitAD = match traitAD with None -> AccessibilityLogic.AccessibleFromEverywhere | Some ad -> (ad :?> AccessorDomain) // Assert the object type if the constraint is for an instance member if traitMemFlags.IsInstance then @@ -1234,11 +1239,11 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p let propName = traitName.[4..] let props = traitSupportTys |> List.choose (fun ty -> - match TryFindIntrinsicNamedItemOfType csenv.InfoReader (propName, AccessibleFromEverywhere) FindMemberFlag.IgnoreOverrides m ty with + match TryFindIntrinsicNamedItemOfType csenv.InfoReader (propName, traitAD) FindMemberFlag.IgnoreOverrides m ty with | Some (RecdFieldItem rfinfo) when (isGetProp || rfinfo.RecdField.IsMutable) && (rfinfo.IsStatic = not traitMemFlags.IsInstance) && - IsRecdFieldAccessible amap m AccessibleFromEverywhere rfinfo.RecdFieldRef && + IsRecdFieldAccessible amap m traitAD rfinfo.RecdFieldRef && not rfinfo.LiteralValue.IsSome && not rfinfo.RecdField.IsCompilerGenerated -> Some (rfinfo, isSetProp) @@ -1293,11 +1298,11 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p let minst = FreshenMethInfo None m minfo //let objtys = minfo.GetObjArgTypes(amap, m, minst) let callerObjTys = if traitMemFlags.IsInstance then [ List.head traitObjAndArgTys ] else [] - Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo None, m, AccessibleFromEverywhere, minfo, minst, minst, None, callerObjTys, [(callerArgs, [])], false, false, None))) + Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo None, m, traitAD, minfo, minst, minst, None, callerObjTys, [(callerArgs, [])], false, false, None))) let methOverloadResult, errors = trace.CollectThenUndoOrCommit (fun (a, _) -> Option.isSome a) (fun trace -> - ResolveOverloading csenv (WithTrace trace) traitName ndeep (Some traitInfo) (0, 0) AccessibleFromEverywhere calledMethGroup false (Some traitRetTy)) + ResolveOverloading csenv (WithTrace trace) traitName ndeep (Some traitInfo) (0, 0) traitAD calledMethGroup false (Some traitRetTy)) match recdPropSearch, methOverloadResult with | Some (rfinfo, isSetProp), None -> @@ -1369,14 +1374,13 @@ and MemberConstraintSolutionOfMethInfo css m minfo minst = let mref = IL.mkRefToILMethod (ilMeth.DeclaringTyconRef.CompiledRepresentationForNamedType, ilMeth.RawMetadata) let iltref = ilMeth.DeclaringTyconRefOption |> Option.map (fun tcref -> tcref.CompiledRepresentationForNamedType) ILMethSln(ilMeth.ApparentEnclosingType, iltref, mref, minst) + | FSMeth(_, typ, vref, _) -> -#if DEBUG - let vtinst = minfo.DeclaringTypeInst @ minst - if vref.Typars.Length <> vtinst.Length then error(InternalError("MemberConstraintSolutionOfMethInfo: unexpected typar length mismatch",m)) -#endif FSMethSln(typ, vref, minst) + | MethInfo.DefaultStructCtor _ -> error(InternalError("the default struct constructor was the unexpected solution to a trait constraint", m)) + #if EXTENSIONTYPING | ProvidedMeth(amap, mi, _, m) -> let g = amap.g @@ -1410,16 +1414,19 @@ and TransactMemberConstraintSolution traitInfo (trace:OptionalTrace) sln = let prev = traitInfo.Solution trace.Exec (fun () -> traitInfo.Solution <- Some sln) (fun () -> traitInfo.Solution <- prev) -and GetRelevantExtensionMethodsForTrait m (amap: Import.ImportMap) (TTrait(traitSupportTys, _, _, _, _, _, extSlns)) = +and GetRelevantExtensionMethodsForTrait m (amap: Import.ImportMap) (traitInfo: TraitConstraintInfo) = + // TODO: check the use of 'allPairs' - not all these extensions apply to each type variable. - (traitSupportTys,extSlns) ||> List.allPairs |> List.choose (fun (traitSupportTy,extMem) -> + (traitInfo.SupportTypes, traitInfo.PossibleExtensionSolutions) + ||> List.allPairs + |> List.choose (fun (traitSupportTy,extMem) -> match (extMem :?> ExtensionMember) with | FSExtMem (vref, pri) -> Some (FSMeth(amap.g, traitSupportTy, vref, Some pri) ) | ILExtMem (actualParent, minfo, pri) -> TrySelectExtensionMethInfoOfILExtMem m amap traitSupportTy (actualParent, minfo, pri)) /// Only consider overload resolution if canonicalizing or all the types are now nominal. /// That is, don't perform resolution if more nominal information may influence the set of available overloads -and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution traitName (TTrait(traitSupportTys, _, memFlags, argtys, traitRetTy, soln, extSlns) as traitInfo) : MethInfo list = +and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution traitName (TTrait(traitSupportTys, _, memFlags, argtys, traitRetTy, soln, extSlns, ad) as traitInfo) : MethInfo list = let results = let strongResolution = isNil (GetSupportOfMemberConstraint csenv traitInfo) if permitWeakResolution || strongResolution then @@ -1452,18 +1459,18 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution // The trait name "op_Explicit" also covers "op_Implicit", so look for that one too. if traitName = "op_Explicit" then - results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(traitSupportTys, "op_Implicit", memFlags, argtys, traitRetTy, soln, extSlns)) + results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(traitSupportTys, "op_Implicit", memFlags, argtys, traitRetTy, soln, extSlns, ad)) else results /// The nominal support of the member constraint -and GetSupportOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(traitSupportTys, _, _, _, _, _, _)) = - traitSupportTys |> List.choose (tryAnyParTy csenv.g) +and GetSupportOfMemberConstraint (csenv:ConstraintSolverEnv) (traitInfo : TraitConstraintInfo) = + traitInfo.SupportTypes |> List.choose (tryAnyParTy csenv.g) /// All the typars relevant to the member constraint *) -and GetFreeTyparsOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(traitSupportTys, _, _, argtys, traitRetTy, _, _)) = - freeInTypesLeftToRightSkippingConstraints csenv.g (traitSupportTys@argtys@ Option.toList traitRetTy) +and GetFreeTyparsOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(traitSupportTys, _, _, traitArgTys, traitRetTy, _, _, _)) = + freeInTypesLeftToRightSkippingConstraints csenv.g (traitSupportTys@traitArgTys@ Option.toList traitRetTy) /// 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 @@ -1481,9 +1488,11 @@ and SolveRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep permitWeakR | None -> ResultD false)) -and GetRelevantPossibleExtensionSolutionsToConstraint (nenv: NameResolutionEnv) (traitInfo: TraitConstraintInfo) = - NameMultiMap.find traitInfo.MemberName nenv.eExtensionMembersByName - |> List.map (fun extMem -> (extMem :> PossibleExtensionMemberSolution)) +and GetTraitFreshner (ad: AccessorDomain) (nenv: NameResolutionEnv) (traitInfo: TraitConstraintInfo) = + let slns = + NameMultiMap.find traitInfo.MemberName nenv.eExtensionMembersByName + |> List.map (fun extMem -> (extMem :> TraitPossibleExtensionMemberSolution)) + slns, (ad :> TraitAccessorDomain) and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep permitWeakResolution (trace:OptionalTrace) tp = let cxst = csenv.SolverState.ExtraCxs @@ -1543,8 +1552,8 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint = // may require type annotations. See FSharp 1.0 bug 6477. let consistent tpc1 tpc2 = match tpc1, tpc2 with - | (TyparConstraint.MayResolveMember(TTrait(tys1, nm1, memFlags1, argtys1, rty1, _, _), _), - TyparConstraint.MayResolveMember(TTrait(tys2, nm2, memFlags2, argtys2, rty2, _, _), _)) + | (TyparConstraint.MayResolveMember(TTrait(tys1, nm1, memFlags1, argtys1, rty1, _, _, _), _), + TyparConstraint.MayResolveMember(TTrait(tys2, nm2, memFlags2, argtys2, rty2, _, _, _), _)) when (memFlags1 = memFlags2 && nm1 = nm2 && // Multiple op_Explicit and op_Implicit constraints can exist for the same type variable. @@ -2661,23 +2670,37 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait match traitInfo.Solution with | None -> Choice4Of4() | Some sln -> + + // Given the solution information, reconstruct the MethInfo for the solution match sln with - | ILMethSln(typ, extOpt, mref, minst) -> - let tcref, _tinst = destAppTy g typ - let mdef = IL.resolveILMethodRef tcref.ILTyconRawMetadata mref + | ILMethSln (apparentTy, extOpt, mref, minst) -> + + // Find the actual type containing the solution + let actualTyconRef = + match extOpt with + | None -> tcrefOfAppTy g apparentTy + | Some ilActualTypeRef -> Import.ImportILTypeRef amap m ilActualTypeRef + + // Find the ILMethodDef corresponding to the solution + let mdef = IL.resolveILMethodRef actualTyconRef.ILTyconRawMetadata mref + + // Make the MethInfo for the solution let ilMethInfo = match extOpt with - | None -> MethInfo.CreateILMeth(amap, m, typ, mdef) - | Some ilActualTypeRef -> - let actualTyconRef = Import.ImportILTypeRef amap m ilActualTypeRef - MethInfo.CreateILExtensionMeth(amap, m, typ, actualTyconRef, None, mdef) + | None -> MethInfo.CreateILMeth(amap, m, apparentTy, mdef) + | Some _ -> MethInfo.CreateILExtensionMeth(amap, m, apparentTy, actualTyconRef, None, mdef) + Choice1Of4 (ilMethInfo, minst) - | FSMethSln(typ, vref, minst) -> - Choice1Of4 (FSMeth(g, typ, vref, None), minst) - | FSRecdFieldSln(tinst, rfref, isSetProp) -> - Choice2Of4 (tinst, rfref, isSetProp) + + | FSMethSln (apparentTy, vref, minst) -> + Choice1Of4 (FSMeth(g, apparentTy, vref, None), minst) + + | FSRecdFieldSln (tinst, rfref, isSetProp) -> + Choice2Of4 (tinst, rfref, isSetProp) + | BuiltInSln -> Choice4Of4 () + | ClosedExprSln expr -> Choice3Of4 expr diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 66462506c87..ff710203c19 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -38,45 +38,65 @@ val NewErrorMeasure : unit -> Measure /// Create a list of inference type variables, one for each element in the input list val NewInferenceTypes : 'a list -> TType list +/// Freshen a trait for use at a particular location +type TraitFreshener = (TraitConstraintInfo -> TraitPossibleExtensionMemberSolutions * TraitAccessorDomain) + /// Given a set of formal type parameters and their constraints, make new inference type variables for /// each and ensure that the constraints on the new type variables are adjusted to refer to these. -val FreshenAndFixupTypars : (TraitConstraintInfo -> PossibleExtensionMemberSolutions) option -> range -> TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInst * TType list +val FreshenAndFixupTypars : TraitFreshener option -> range -> TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInst * TType list -val FreshenTypeInst : (TraitConstraintInfo -> PossibleExtensionMemberSolutions) option -> range -> Typars -> Typars * TyparInst * TType list +/// Make new type inference variables for the use of a generic construct at a particular location +val FreshenTypeInst : TraitFreshener option -> range -> Typars -> Typars * TyparInst * TType list -val FreshenTypars : (TraitConstraintInfo -> PossibleExtensionMemberSolutions) option -> range -> Typars -> TType list +/// Make new type inference variables for the use of a generic construct at a particular location +val FreshenTypars : TraitFreshener option -> range -> Typars -> TType list -val FreshenMethInfo : (TraitConstraintInfo -> PossibleExtensionMemberSolutions) option -> range -> MethInfo -> TType list +/// Make new type inference variables for the use of a method at a particular location +val FreshenMethInfo : TraitFreshener option -> range -> MethInfo -> TType list -val GetRelevantPossibleExtensionSolutionsToConstraint : NameResolutionEnv -> TraitConstraintInfo -> PossibleExtensionMemberSolutions +/// Get the trait freshener for a particular location +val GetTraitFreshner : AccessorDomain -> NameResolutionEnv -> TraitFreshener [] -/// Information about the context of a type equation. +/// Information about the context of a type equation, for better error reporting type ContextInfo = + /// No context was given. | NoContext + /// The type equation comes from an IF expression. | IfExpression of range + /// The type equation comes from an omitted else branch. | OmittedElseBranch of range + /// The type equation comes from a type check of the result of an else branch. | ElseBranchResult of range + /// The type equation comes from the verification of record fields. | RecordFields + /// The type equation comes from the verification of a tuple in record fields. | TupleInRecordFields + /// The type equation comes from a list or array constructor | CollectionElement of bool * range + /// The type equation comes from a return in a computation expression. | ReturnInComputationExpression + /// The type equation comes from a yield in a computation expression. | YieldInComputationExpression + /// The type equation comes from a runtime type test. | RuntimeTypeTest of bool + /// The type equation comes from an downcast where a upcast could be used. | DowncastUsedInsteadOfUpcast of bool + /// The type equation comes from a return type of a pattern match clause (not the first clause). | FollowingPatternMatchClause of range + /// The type equation comes from a pattern match guard. | PatternMatchGuard of range diff --git a/src/fsharp/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index a6434a4e4e1..9e279bad9c5 100644 --- a/src/fsharp/FindUnsolved.fs +++ b/src/fsharp/FindUnsolved.fs @@ -114,7 +114,7 @@ and accOp cenv env (op,tyargs,args,_m) = accTypeInst cenv env enclTypeArgs accTypeInst cenv env methTypeArgs accTypeInst cenv env tys - | TOp.TraitCall(TTrait(tys, _nm, _, argtys, rty, _sln, _extSlns)) -> + | TOp.TraitCall(TTrait(tys, _nm, _, argtys, rty, _sln, _extSlns, _ad)) -> argtys |> accTypeInst cenv env rty |> Option.iter (accTy cenv env) tys |> List.iter (accTy cenv env) diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index 5f829ca4f9d..ebe204bf750 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -279,7 +279,7 @@ type ExtensionMember = /// IL-style extension member, backed by some kind of method with an [] attribute | ILExtMem of TyconRef * MethInfo * ExtensionMethodPriority - interface PossibleExtensionMemberSolution + interface TraitPossibleExtensionMemberSolution /// Check if two extension members refer to the same definition static member Equality g e1 e2 = diff --git a/src/fsharp/NameResolution.fsi b/src/fsharp/NameResolution.fsi index dddb3ab910e..d7b7f600bb5 100755 --- a/src/fsharp/NameResolution.fsi +++ b/src/fsharp/NameResolution.fsi @@ -142,7 +142,7 @@ type ExtensionMember = /// IL-style extension member, backed by some kind of method with an [] attribute | ILExtMem of TyconRef * MethInfo * ExtensionMethodPriority - interface PossibleExtensionMemberSolution + interface TraitPossibleExtensionMemberSolution /// The logical name, e.g. for constraint solving member LogicalName : string diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 0e49e7eff72..06ec2c800b0 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -865,7 +865,7 @@ module private PrintTypes = WordL.arrow ^^ (layoutTyparRefWithInfo denv env tp)) |> longConstraintPrefix] - and private layoutTraitWithInfo denv env (TTrait(tys, nm, memFlags, argtys, rty, _, _)) = + and private layoutTraitWithInfo denv env (TTrait(tys, nm, memFlags, argtys, rty, _, _, _)) = let nm = DemangleOperatorName nm if denv.shortConstraints then WordL.keywordMember ^^ wordL (tagMember nm) @@ -877,9 +877,19 @@ module private PrintTypes = match tys with | [ty] -> layoutTypeWithInfo denv env ty | tys -> bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagKeyword "or")) tys) + + let argtys = + if memFlags.IsInstance then + match argtys with + | [] | [_] -> [denv.g.unit_ty] + | _ :: rest -> rest + else argtys + + let argtysL = layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) argtys + tysL ^^ wordL (tagPunctuation ":") --- bracketL (stat ++ wordL (tagMember nm) ^^ wordL (tagPunctuation ":") --- - ((layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) argtys --- wordL (tagPunctuation "->")) --- (layoutTypeWithInfo denv env rty))) + ((argtysL --- wordL (tagPunctuation "->")) --- (layoutTypeWithInfo denv env rty))) /// Layout a unit expression diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 3995ebc468e..51b932b611b 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -213,7 +213,7 @@ let rec CheckTypeDeep ((visitTyp,visitTyconRefOpt,visitAppTyOpt,visitTraitSoluti | TType_var tp when tp.Solution.IsSome -> tp.Constraints |> List.iter (fun cx -> match cx with - | TyparConstraint.MayResolveMember((TTrait(_, _, _, _, _, soln, _)), _) -> + | TyparConstraint.MayResolveMember((TTrait(_, _, _, _, _, soln, _, _)), _) -> match visitTraitSolutionOpt, !soln with | Some visitTraitSolution, Some sln -> visitTraitSolution sln | _ -> () @@ -267,7 +267,7 @@ and CheckTypeConstraintDeep f g env x = | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> () -and CheckTraitInfoDeep ((_,_,_,visitTraitSolutionOpt,_) as f) g env (TTrait(typs, _, _, argtys, rty, soln, _extSlns)) = +and CheckTraitInfoDeep ((_,_,_,visitTraitSolutionOpt,_) as f) g env (TTrait(typs, _, _, argtys, rty, soln, _extSlns, _ad)) = CheckTypesDeep f g env typs CheckTypesDeep f g env argtys Option.iter (CheckTypeDeep f g env) rty diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 3db6fdd1ade..551e668ac59 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -101,7 +101,7 @@ type Remap = removeTraitSolutions: bool /// A map indicating how to fill in extSlns for traits as we copy an expression. Indexed by the member name of the trait - extSlnsMap: Map } + extSlnsMap: Map } let emptyRemap = { tpinst = emptyTyparInst; @@ -254,7 +254,7 @@ and remapTyparConstraintsAux tyenv cs = | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> Some(x)) -and remapTraitAux tyenv (TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns)) = +and remapTraitAux tyenv (TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns, ad)) = let slnCell = match !slnCell with | None -> None @@ -288,7 +288,7 @@ and remapTraitAux tyenv (TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns)) = // The danger here is that a solution for one syntactic occurrence of a trait constraint won't // be propagated to other, "linked" solutions. However trait constraints don't appear in any algebra // in the same way as types - TTrait(remapTypesAux tyenv typs, nm, mf, remapTypesAux tyenv argtys, Option.map (remapTypeAux tyenv) rty, ref slnCell, extSlnsNew) + TTrait(remapTypesAux tyenv typs, nm, mf, remapTypesAux tyenv argtys, Option.map (remapTypeAux tyenv) rty, ref slnCell, extSlnsNew, ad) and bindTypars tps tyargs tpinst = match tps with @@ -821,7 +821,7 @@ type TypeEquivEnv with static member FromEquivTypars tps1 tps2 = TypeEquivEnv.Empty.BindEquivTypars tps1 tps2 -let rec traitsAEquivAux erasureFlag g aenv (TTrait(typs1, nm, mf1, argtys, rty, _, _)) (TTrait(typs2, nm2, mf2, argtys2, rty2, _, _)) = +let rec traitsAEquivAux erasureFlag g aenv (TTrait(typs1, nm, mf1, argtys, rty, _, _, _)) (TTrait(typs2, nm2, mf2, argtys2, rty2, _, _, _)) = mf1 = mf2 && nm = nm2 && ListSet.equals (typeAEquivAux erasureFlag g aenv) typs1 typs2 && @@ -1917,7 +1917,7 @@ and accFreeInTyparConstraint opts tpc acc = | TyparConstraint.IsUnmanaged _ | TyparConstraint.RequiresDefaultConstructor _ -> acc -and accFreeInTrait opts (TTrait(typs, _, _, argtys, rty, sln, _)) acc = +and accFreeInTrait opts (TTrait(typs, _, _, argtys, rty, sln, _, _ad)) acc = Option.foldBack (accFreeInTraitSln opts) sln.Value (accFreeInTypes opts typs (accFreeInTypes opts argtys @@ -2022,7 +2022,7 @@ and accFreeInTyparConstraintLeftToRight g cxFlag thruFlag acc tpc = | TyparConstraint.IsReferenceType _ | TyparConstraint.RequiresDefaultConstructor _ -> acc -and accFreeInTraitLeftToRight g cxFlag thruFlag acc (TTrait(typs, _, _, argtys, rty, _, _extSlns)) = +and accFreeInTraitLeftToRight g cxFlag thruFlag acc (TTrait(typs, _, _, argtys, rty, _, _extSlns, _ad)) = let acc = accFreeInTypesLeftToRight g cxFlag thruFlag acc typs let acc = accFreeInTypesLeftToRight g cxFlag thruFlag acc argtys let acc = Option.fold (accFreeInTypeLeftToRight g cxFlag thruFlag) acc rty @@ -2081,7 +2081,7 @@ and accExtSlnsInTyparConstraint acc tpc = | TyparConstraint.MayResolveMember (traitInfo, _) -> accExtSlnsInTrait acc traitInfo | _ -> acc -and accExtSlnsInTrait acc (TTrait(_typs, nm, _, _argtys, _rty, _, extSlns)) = +and accExtSlnsInTrait acc (TTrait(_typs, nm, _, _argtys, _rty, _, extSlns, _ad)) = // We don't traverse the contents of traits, that wouldn't terminate and is not necessary since the type variables individiaull contain the extSlns we need //let acc = accExtSlnsInTypes g acc typs //let acc = accExtSlnsInTypes g acc argtys @@ -3189,7 +3189,7 @@ module DebugPrint = begin and auxTraitL env (ttrait: TraitConstraintInfo) = #if DEBUG - let (TTrait(tys, nm, memFlags, argtys, rty, _, _extSlns)) = ttrait + let (TTrait(tys, nm, memFlags, argtys, rty, _, _extSlns, _ad)) = ttrait match !global_g with | None -> wordL (tagText "") | Some g -> @@ -4349,7 +4349,7 @@ and accFreeInOp opts op acc = | TOp.ILAsm (_, tys) -> accFreeVarsInTys opts tys acc | TOp.Reraise -> accUsesRethrow true acc - | TOp.TraitCall(TTrait(tys, _, _, argtys, rty, sln, _extSlns)) -> + | TOp.TraitCall(TTrait(tys, _, _, argtys, rty, sln, _extSlns, _ad)) -> Option.foldBack (accFreeVarsInTraitSln opts) sln.Value (accFreeVarsInTys opts tys (accFreeVarsInTys opts argtys @@ -5338,7 +5338,7 @@ let rec tyOfExpr g e = | TOp.LValueOp (LByrefGet, v) -> destByrefTy g v.Type | TOp.LValueOp (LGetAddr, v) -> mkByrefTy g v.Type | TOp.RefAddrGet -> (match tinst with [ty] -> mkByrefTy g ty | _ -> failwith "bad TOp.RefAddrGet node") - | TOp.TraitCall (TTrait(_, _, _, _, ty, _, _)) -> GetFSharpViewOfReturnType g ty + | TOp.TraitCall traitInfo -> GetFSharpViewOfReturnType g traitInfo.ReturnType | TOp.Reraise -> (match tinst with [rtn_ty] -> rtn_ty | _ -> failwith "bad TOp.Reraise node") | TOp.Goto _ | TOp.Label _ | TOp.Return -> //assert false; diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 2213fb5565b..e06a38040af 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -351,7 +351,7 @@ type Remap = removeTraitSolutions: bool /// A map indicating how to fill in extSlns for traits as we copy an expression. Indexed by the member name of the trait - extSlnsMap: Map } + extSlnsMap: Map } static member Empty : Remap diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index aa2137f12bb..600c7d2770e 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -1320,7 +1320,7 @@ let p_trait_sln sln st = | FSRecdFieldSln(a,b,c) -> p_byte 4 st; p_tup3 p_typs p_rfref p_bool (a,b,c) st -let p_trait (TTrait(a, b, c, d, e, f, _extSlns)) st = +let p_trait (TTrait(a, b, c, d, e, f, _extSlns, _ad)) st = // The _extSlns do not get pickled. We are assuming this is a generic or solved constraint p_tup6 p_typs p_string p_MemberFlags p_typs (p_option p_typ) (p_option p_trait_sln) (a,b,c,d,e,!f) st @@ -1346,7 +1346,8 @@ let u_trait_sln st = let u_trait st = let a,b,c,d,e,f = u_tup6 u_typs u_string u_MemberFlags u_typs (u_option u_typ) (u_option u_trait_sln) st // extSlns starts empty. TODO: check the ramifications of this - TTrait (a, b, c, d, e, ref f, []) + // ad starts as None. TODO: check the ramifications of this + TTrait (a, b, c, d, e, ref f, [], None) let p_rational q st = p_int32 (GetNumerator q) st; p_int32 (GetDenominator q) st diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 22c5d66e208..379413eb9ba 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -240,7 +240,7 @@ type UngeneralizableItem(computeFreeTyvars : (unit -> FreeTyvars)) = [] type TcEnv = { /// Name resolution information - eNameResEnv : NameResolutionEnv + eNameEnv : NameResolutionEnv /// The list of items in the environment that may contain free inference /// variables (which may not be generalized). The relevant types may @@ -263,6 +263,7 @@ type TcEnv = ePath: Ident list eCompPath: CompilationPath eAccessPath: CompilationPath + /// This field is computed from other fields, but we amortize the cost of computing it. eAccessRights: AccessorDomain @@ -284,18 +285,19 @@ type TcEnv = eCallerMemberName : string option } - member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv - member tenv.NameEnv = tenv.eNameResEnv + member tenv.DisplayEnv = tenv.eNameEnv.DisplayEnv + member tenv.NameEnv = tenv.eNameEnv member tenv.AccessRights = tenv.eAccessRights - member tenv.GetExtSlns = Some (GetRelevantPossibleExtensionSolutionsToConstraint tenv.NameEnv) + + member tenv.TraitFreshner = Some (GetTraitFreshner tenv.AccessRights tenv.NameEnv) /// Compute the value of this computed, cached field let computeAccessRights eAccessPath eInternalsVisibleCompPaths eFamilyType = - AccessibleFrom (eAccessPath :: eInternalsVisibleCompPaths, eFamilyType) // env.eAccessRights + AccessibleFrom (eAccessPath :: eInternalsVisibleCompPaths, eFamilyType) // env.AccessRights let emptyTcEnv g = let cpath = compPathInternal // allow internal access initially - { eNameResEnv = NameResolutionEnv.Empty g + { eNameEnv = NameResolutionEnv.Empty g eUngeneralizableItems = [] ePath = [] eCompPath = cpath // dummy @@ -385,7 +387,7 @@ let addInternalsAccessibility env (ccu:CcuThunk) = eAccessRights = computeAccessRights env.eAccessPath eInternalsVisibleCompPaths env.eFamilyType // update this computed field eInternalsVisibleCompPaths = compPath :: env.eInternalsVisibleCompPaths } -let ModifyNameResEnv f env = { env with eNameResEnv = f env.eNameResEnv } +let ModifyNameResEnv f env = { env with eNameEnv = f env.NameEnv } let AddLocalValPrimitive (v:Val) env = let env = ModifyNameResEnv (fun nenv -> AddValRefToNameEnv nenv (mkLocalValRef v)) env @@ -399,7 +401,7 @@ let AddLocalValMap tcSink scopem (vals:Val NameMap) env = else let env = ModifyNameResEnv (AddValMapToNameEnv vals) env { env with eUngeneralizableItems = NameMap.foldBackRange (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems } - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env let AddLocalVals tcSink scopem (vals:Val list) env = @@ -409,20 +411,20 @@ let AddLocalVals tcSink scopem (vals:Val list) env = else let env = ModifyNameResEnv (AddValListToNameEnv vals) env { env with eUngeneralizableItems = List.foldBack (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems } - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env let AddLocalVal tcSink scopem v env = let env = ModifyNameResEnv (fun nenv -> AddValRefToNameEnv nenv (mkLocalValRef v)) env let env = {env with eUngeneralizableItems = addFreeItemOfTy v.Type env.eUngeneralizableItems } - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env let AddLocalExnDefnAndReport tcSink scopem env (exnc:Tycon) = let env = ModifyNameResEnv (fun nenv -> AddExceptionDeclsToNameEnv BulkAdd.No nenv (mkLocalEntityRef exnc)) env (* Also make VisualStudio think there is an identifier in scope at the range of the identifier text of its binding location *) - CallEnvSink tcSink (exnc.Range, env.NameEnv, env.eAccessRights) - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (exnc.Range, env.NameEnv, env.AccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env let AddLocalTyconRefs ownDefinition g amap m tcrefs env = @@ -435,7 +437,7 @@ let AddLocalTycons g amap m (tycons: Tycon list) env = let AddLocalTyconsAndReport tcSink scopem g amap m tycons env = let env = AddLocalTycons g amap m tycons env - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env //------------------------------------------------------------------------- @@ -445,13 +447,13 @@ let AddLocalTyconsAndReport tcSink scopem g amap m tycons env = let OpenModulesOrNamespaces tcSink g amap scopem root env mvvs = let env = if isNil mvvs then env else - ModifyNameResEnv (fun nenv -> AddModulesAndNamespacesContentsToNameEnv g amap env.eAccessRights scopem root nenv mvvs) env - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + ModifyNameResEnv (fun nenv -> AddModulesAndNamespacesContentsToNameEnv g amap env.AccessRights scopem root nenv mvvs) env + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env let AddRootModuleOrNamespaceRefs g amap m env modrefs = if isNil modrefs then env else - ModifyNameResEnv (fun nenv -> AddModuleOrNamespaceRefsToNameEnv g amap m true env.eAccessRights nenv modrefs) env + ModifyNameResEnv (fun nenv -> AddModuleOrNamespaceRefsToNameEnv g amap m true env.AccessRights nenv modrefs) env let AddNonLocalCcu g amap scopem env assemblyName (ccu:CcuThunk, internalsVisibleToAttributes) = @@ -473,7 +475,7 @@ let AddNonLocalCcu g amap scopem env assemblyName (ccu:CcuThunk, internalsVisib let env = if isNil tcrefs then env else ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.Yes false g amap scopem true nenv tcrefs) env - //CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + //CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env let AddLocalRootModuleOrNamespace tcSink g amap scopem env (mtyp:ModuleOrNamespaceType) = @@ -486,16 +488,16 @@ let AddLocalRootModuleOrNamespace tcSink g amap scopem env (mtyp:ModuleOrNamespa if isNil tcrefs then env else ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.No false g amap scopem true nenv tcrefs) env let env = { env with eUngeneralizableItems = addFreeItemOfModuleTy mtyp env.eUngeneralizableItems } - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env let AddModuleAbbreviationAndReport tcSink scopem id modrefs env = let env = if isNil modrefs then env else ModifyNameResEnv (fun nenv -> AddModuleAbbrevToNameEnv id nenv modrefs) env - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) let item = Item.ModuleOrNamespaces modrefs - CallNameResolutionSink tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) env let AddLocalSubModule g amap m env (modul:ModuleOrNamespace) = @@ -505,7 +507,7 @@ let AddLocalSubModule g amap m env (modul:ModuleOrNamespace) = let AddLocalSubModuleAndReport tcSink scopem g amap m env (modul:ModuleOrNamespace) = let env = AddLocalSubModule g amap m env modul - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env let RegisterDeclaredTypars typars env = @@ -571,7 +573,7 @@ type cenv = static member Create (g, isScript, niceNameGen, amap, topCcu, isSig, haveSig, conditionalDefines, tcSink, tcVal) = let infoReader = new InfoReader(g, amap) - let instantiationGenerator m tpsorig = ConstraintSolver.FreshenTypars None m tpsorig // TODO: check 'None' here for env.GetExtSlns + let instantiationGenerator m tpsorig = ConstraintSolver.FreshenTypars None m tpsorig // TODO: check 'None' here for env.TraitFreshner let nameResolver = new NameResolver(g, amap, infoReader, instantiationGenerator) { g = g amap = amap @@ -591,8 +593,8 @@ type cenv = compilingCanonicalFslibModuleType = (isSig || not haveSig) && g.compilingFslib conditionalDefines = conditionalDefines } -let CopyAndFixupTypars getExtSlnsOpt m rigid tpsorig = - ConstraintSolver.FreshenAndFixupTypars getExtSlnsOpt m rigid [] [] tpsorig +let CopyAndFixupTypars traitFreshner m rigid tpsorig = + ConstraintSolver.FreshenAndFixupTypars traitFreshner m rigid [] [] tpsorig let UnifyTypes cenv (env: TcEnv) m expectedTy actualTy = ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g expectedTy) (tryNormalizeMeasureInType cenv.g actualTy) @@ -615,7 +617,7 @@ let MakeInnerEnvWithAcc env nm mtypeAcc modKind = eCompPath = cpath eAccessPath = cpath eAccessRights = computeAccessRights cpath env.eInternalsVisibleCompPaths env.eFamilyType // update this computed field - eNameResEnv = { env.eNameResEnv with eDisplayEnv = env.DisplayEnv.AddOpenPath (pathOfLid path) } + eNameEnv = { env.NameEnv with eDisplayEnv = env.DisplayEnv.AddOpenPath (pathOfLid path) } eModuleOrNamespaceTypeAccumulator = mtypeAcc } let MakeInnerEnv env nm modKind = @@ -691,7 +693,7 @@ let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath env = | None -> enclosingNamespacePath let ad = env.eAccessRights - match ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AllResults amap scopem OpenQualified env.eNameResEnv ad enclosingNamespacePathToOpen with + match ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AllResults amap scopem OpenQualified env.eNameEnv ad enclosingNamespacePathToOpen with | Result modrefs -> OpenModulesOrNamespaces tcSink g amap scopem false env (List.map p23 modrefs) | Exception _ -> env @@ -826,7 +828,7 @@ module AttributeTargets = let ForNewConstructors tcSink (env:TcEnv) mObjTy methodName meths = let origItem = Item.CtorGroup(methodName, meths) - let callSink (item, minst) = CallNameResolutionSink tcSink (mObjTy, env.NameEnv, item, origItem, minst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + let callSink (item, minst) = CallNameResolutionSink tcSink (mObjTy, env.NameEnv, item, origItem, minst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) let sendToSink minst refinedMeths = callSink (Item.CtorGroup(methodName, refinedMeths), minst) match meths with | [] -> @@ -852,7 +854,7 @@ let TcConst cenv ty m env c = | SynMeasure.One -> Measure.One | SynMeasure.Named(tc, m) -> let ad = env.eAccessRights - let tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Use OpenQualified env.eNameResEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No) + let tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Use OpenQualified env.eNameEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No) match tcref.TypeOrMeasureKind with | TyparKind.Type -> error(Error(FSComp.SR.tcExpectedUnitOfMeasureNotType(), m)) | TyparKind.Measure -> Measure.Con tcref @@ -1274,7 +1276,7 @@ let PublishModuleDefn cenv env mspec = if intoFslibCcu then mty else mty.AddEntity mspec) let item = Item.ModuleOrNamespaces([mkLocalModRef mspec]) - CallNameResolutionSink cenv.tcSink (mspec.Range, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (mspec.Range, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.AccessRights) let PublishTypeDefn cenv env tycon = UpdateAccModuleOrNamespaceType cenv env (fun _ mty -> @@ -1497,9 +1499,9 @@ let MakeAndPublishVal cenv env (altActualParent, inSig, declKind, vrec, (ValSche | None when vspec.BaseOrThisInfo = ValBaseOrThisInfo.MemberThisVal && vspec.LogicalName = "__" -> () | _ -> let nenv = AddFakeNamedValRefToNameEnv vspec.DisplayName env.NameEnv (mkLocalValRef vspec) - CallEnvSink cenv.tcSink (vspec.Range, nenv, env.eAccessRights) + CallEnvSink cenv.tcSink (vspec.Range, nenv, env.AccessRights) let item = Item.Value(mkLocalValRef vspec) - CallNameResolutionSink cenv.tcSink (vspec.Range, nenv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (vspec.Range, nenv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.AccessRights) vspec let MakeAndPublishVals cenv env (altActualParent, inSig, declKind, vrec, valSchemes, attrs, doc, konst) = @@ -1868,33 +1870,33 @@ let MakeAndPublishSimpleVals cenv env m names mergeNamesInOneNameresEnv = // to C<_> occurs then generate C for a fresh type inference variable ?ty. //------------------------------------------------------------------------- -let FreshenTyconRef getExtSlnsOpt m rigid (tcref:TyconRef) declaredTyconTypars = +let FreshenTyconRef traitFreshner m rigid (tcref:TyconRef) declaredTyconTypars = let tpsorig = declaredTyconTypars let tps = copyTypars tpsorig if rigid <> TyparRigidity.Rigid then tps |> List.iter (fun tp -> tp.SetRigidity rigid) - let renaming, tinst = FixupNewTypars getExtSlnsOpt m [] [] tpsorig tps + let renaming, tinst = FixupNewTypars traitFreshner m [] [] tpsorig tps (TType_app(tcref, List.map mkTyparTy tpsorig), tps, renaming, TType_app(tcref, tinst)) -let FreshenPossibleForallTy getExtSlnsOpt g m rigid ty = +let FreshenPossibleForallTy traitFreshner g m rigid ty = let tpsorig, tau = tryDestForallTy g ty if isNil tpsorig then [], [], [], tau else // tps may be have been equated to other tps in equi-recursive type inference and units-of-measure type inference. Normalize them here let tpsorig = NormalizeDeclaredTyparsForEquiRecursiveInference g tpsorig - let tps, renaming, tinst = CopyAndFixupTypars getExtSlnsOpt m rigid tpsorig + let tps, renaming, tinst = CopyAndFixupTypars traitFreshner m rigid tpsorig tpsorig, tps, tinst, instType renaming tau -let FreshenTyconRef2 getExtSlnsOpt m (tcref:TyconRef) = - let tps, renaming, tinst = FreshenTypeInst getExtSlnsOpt m (tcref.Typars m) +let FreshenTyconRef2 traitFreshner m (tcref:TyconRef) = + let tps, renaming, tinst = FreshenTypeInst traitFreshner m (tcref.Typars m) tps, renaming, tinst, TType_app (tcref, tinst) /// Given a abstract method, which may be a generic method, freshen the type in preparation /// to apply it as a constraint to the method that implements the abstract slot -let FreshenAbstractSlot getExtSlnsOpt g amap m synTyparDecls absMethInfo = +let FreshenAbstractSlot traitFreshner g amap m synTyparDecls absMethInfo = // Work out if an explicit instantiation has been given. If so then the explicit type // parameters will be made rigid and checked for generalization. If not then auto-generalize @@ -1916,7 +1918,7 @@ let FreshenAbstractSlot getExtSlnsOpt g amap m synTyparDecls absMethInfo = let ttps = absMethInfo.GetFormalTyparsOfDeclaringType m let ttinst = argsOfAppTy g absMethInfo.EnclosingType let rigid = if typarsFromAbsSlotAreRigid then TyparRigidity.Rigid else TyparRigidity.Flexible - ConstraintSolver.FreshenAndFixupTypars getExtSlnsOpt m rigid ttps ttinst fmtps + ConstraintSolver.FreshenAndFixupTypars traitFreshner m rigid ttps ttinst fmtps // Work out the required type of the member let argTysFromAbsSlot = argtys |> List.mapSquared (instType typarInstFromAbsSlot) @@ -1936,7 +1938,7 @@ let BuildFieldMap cenv env isPartial ty flds m = let allFields = flds |> List.map (fun ((_, ident), _) -> ident) flds |> List.map (fun (fld, fldExpr) -> - let frefSet = ResolveField cenv.tcSink cenv.nameResolver env.eNameResEnv ad ty fld allFields + let frefSet = ResolveField cenv.tcSink cenv.nameResolver env.eNameEnv ad ty fld allFields fld, frefSet, fldExpr) let relevantTypeSets = @@ -1967,7 +1969,7 @@ let BuildFieldMap cenv env isPartial ty flds m = // Record the precise resolution of the field for intellisense let item = FreshenRecdFieldRef cenv.nameResolver m fref2 - CallNameResolutionSink cenv.tcSink ((snd fld).idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, ad) + CallNameResolutionSink cenv.tcSink ((snd fld).idRange, env.eNameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, ad) CheckRecdFieldAccessible cenv.amap m env.eAccessRights fref2 |> ignore CheckFSharpAttributes cenv.g fref2.PropertyAttribs m |> CommitOperationResult @@ -2023,9 +2025,9 @@ let UnionCaseOrExnCheck (env: TcEnv) nargtys nargs m = if nargs <> nargtys then error (UnionCaseWrongArguments(env.DisplayEnv, nargtys, nargs, m)) let TcUnionCaseOrExnField cenv (env: TcEnv) ty1 m c n funcs = - let ad = env.eAccessRights + let ad = env.AccessRights let mkf, argtys, _argNames = - match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver AllIdsOK false m ad env.eNameResEnv TypeNameResolutionInfo.Default c with + match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver AllIdsOK false m ad env.NameEnv TypeNameResolutionInfo.Default c with | (Item.UnionCase _ | Item.ExnCase _) as item -> ApplyUnionCaseOrExn funcs m cenv env ty1 item | _ -> error(Error(FSComp.SR.tcUnknownUnion(), m)) @@ -2074,24 +2076,24 @@ module GeneralizationHelpers = let ComputeUnabstractableTycons env = - let acc_in_free_item acc (item: UngeneralizableItem) = + let accInFreeItem acc (item: UngeneralizableItem) = let ftycs = if item.WillNeverHaveFreeTypars then item.CachedFreeLocalTycons else let ftyvs = item.GetFreeTyvars() ftyvs.FreeTycons if ftycs.IsEmpty then acc else unionFreeTycons ftycs acc - List.fold acc_in_free_item emptyFreeTycons env.eUngeneralizableItems + List.fold accInFreeItem emptyFreeTycons env.eUngeneralizableItems let ComputeUnabstractableTraitSolutions env = - let acc_in_free_item acc (item: UngeneralizableItem) = + let accInFreeItem acc (item: UngeneralizableItem) = let ftycs = if item.WillNeverHaveFreeTypars then item.CachedFreeTraitSolutions else let ftyvs = item.GetFreeTyvars() ftyvs.FreeTraitSolutions if ftycs.IsEmpty then acc else unionFreeLocals ftycs acc - List.fold acc_in_free_item emptyFreeLocals env.eUngeneralizableItems + List.fold accInFreeItem emptyFreeLocals env.eUngeneralizableItems let rec IsGeneralizableValue g t = match t with @@ -2482,7 +2484,7 @@ module BindingNormalization = | _ -> MakeNormalizedInstanceMemberBinding cenv thisId memberId toolId vis m typars args rhsExpr valSynData let private NormalizeBindingPattern cenv nameResolver isObjExprBinding (env: TcEnv) valSynData pat rhsExpr = - let ad = env.eAccessRights + let ad = env.AccessRights let (SynValData(memberFlagsOpt, _, _)) = valSynData let rec normPattern pat = // One major problem with versions of F# prior to 1.9.x was that data constructors easily 'pollute' the namespace @@ -2493,7 +2495,7 @@ module BindingNormalization = let typars = match tyargs with None -> inferredTyparDecls | Some typars -> typars match memberFlagsOpt with | None -> - match ResolvePatternLongIdent cenv.tcSink nameResolver AllIdsOK true m ad env.eNameResEnv TypeNameResolutionInfo.Default longId with + match ResolvePatternLongIdent cenv.tcSink nameResolver AllIdsOK true m ad env.NameEnv TypeNameResolutionInfo.Default longId with | Item.NewDef id -> if id.idText = opNameCons then NormalizedBindingPat(pat, rhsExpr, valSynData, typars) @@ -2625,11 +2627,11 @@ module EventDeclarationNormalization = /// Make a copy of the "this" type for a generic object type, e.g. List<'T> --> List<'?> for a fresh inference variable. /// Also adjust the "this" type to take into account whether the type is a struct. -let FreshenObjectArgType cenv getExtSlnsOpt m rigid tcref isExtrinsic declaredTyconTypars = +let FreshenObjectArgType cenv traitFreshner m rigid tcref isExtrinsic declaredTyconTypars = #if EXTENDED_EXTENSION_MEMBERS // indicates if extension members can add additional constraints to type parameters let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy = FreshenTyconRef m (if isExtrinsic then TyparRigidity.Flexible else rigid) tcref declaredTyconTypars #else - let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy = FreshenTyconRef getExtSlnsOpt m rigid tcref declaredTyconTypars + let tcrefObjTy, enclosingDeclaredTypars, renaming, objTy = FreshenTyconRef traitFreshner m rigid tcref declaredTyconTypars #endif // Struct members have a byref 'this' type (unless they are extrinsic extension members) let thisTy = @@ -2696,7 +2698,7 @@ let TcValEarlyGeneralizationConsistencyCheck cenv (env:TcEnv) (v:Val, vrec, tins /// | CtorValUsedAsSuperInit "inherit Panel()" /// | CtorValUsedAsSelfInit "new() = new OwnType(3)" /// | VSlotDirectCall "base.OnClick(eventArgs)" -let TcVal getExtSlnsOpt checkAttributes cenv env tpenv (vref:ValRef) optInst optAfterResolution m = +let TcVal traitFreshner checkAttributes cenv env tpenv (vref:ValRef) optInst optAfterResolution m = let (tpsorig, _, _, _, tinst, _) as res = let v = vref.Deref let vrec = v.RecursiveValInfo @@ -2717,7 +2719,7 @@ let TcVal getExtSlnsOpt checkAttributes cenv env tpenv (vref:ValRef) optInst opt // The value may still be generic, e.g. // [] // let Null = null - let tpsorig, _, tinst, tau = FreshenPossibleForallTy getExtSlnsOpt cenv.g m TyparRigidity.Flexible vty + let tpsorig, _, tinst, tau = FreshenPossibleForallTy traitFreshner cenv.g m TyparRigidity.Flexible vty tpsorig, Expr.Const(c, m, tau), isSpecial, tau, tinst, tpenv | None -> @@ -2747,8 +2749,8 @@ let TcVal getExtSlnsOpt checkAttributes cenv env tpenv (vref:ValRef) optInst opt tpsorig, NormalValUse, tinst, tau, tpenv | ValInRecScope true | ValNotInRecScope -> - let tpsorig, _, tinst, tau = FreshenPossibleForallTy getExtSlnsOpt cenv.g m TyparRigidity.Flexible vty - tpsorig, NormalValUse, tinst, tau, tpenv + let tpsorig, _, tptys, tau = FreshenPossibleForallTy traitFreshner cenv.g m TyparRigidity.Flexible vty + tpsorig, NormalValUse, tptys, tau, tpenv // If we have got an explicit instantiation then use that | Some(vrefFlags, checkTys) -> @@ -2768,7 +2770,7 @@ let TcVal getExtSlnsOpt checkAttributes cenv env tpenv (vref:ValRef) optInst opt tpsorig, vrefFlags, tinst, tau2, tpenv | ValInRecScope true | ValNotInRecScope -> - let tpsorig, tps, tptys, tau = FreshenPossibleForallTy getExtSlnsOpt cenv.g m TyparRigidity.Flexible vty + let tpsorig, tps, tptys, tau = FreshenPossibleForallTy traitFreshner cenv.g m TyparRigidity.Flexible vty //dprintfn "After Freshen: tau = %s" (Layout.showL (typeL tau)) let (tinst:TypeInst), tpenv = checkTys tpenv (tps |> List.map (fun tp -> tp.Kind)) checkInst tinst @@ -2778,7 +2780,7 @@ let TcVal getExtSlnsOpt checkAttributes cenv env tpenv (vref:ValRef) optInst opt TcValEarlyGeneralizationConsistencyCheck cenv env (v, vrec, tinst, vty, tau, m) //dprintfn "After Unify: tau = %s" (Layout.showL (typeL tau)) - tpsorig, vrefFlags, tinst, tau, tpenv + tpsorig, vrefFlags, tptys, tau, tpenv let exprForVal = Expr.Val (vref, vrefFlags, m) let exprForVal = mkTyAppExpr m (exprForVal, vty) tinst @@ -2986,7 +2988,7 @@ let BuildPossiblyConditionalMethodCall cenv env isMutable m isProp minfo valUseF | _ -> #endif let tcVal valref valUse ttypes m = - let _, a, _, b, _, _ = TcVal env.GetExtSlns true cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) None m + let _, a, _, b, _, _ = TcVal env.TraitFreshner true cenv env emptyUnscopedTyparEnv valref (Some (valUse, (fun x _ -> ttypes, x))) None m a, b BuildMethodCall tcVal cenv.g cenv.amap isMutable m isProp minfo valUseFlags minst objArgs args @@ -3112,7 +3114,7 @@ let (|JoinRelation|_|) cenv env (e:SynExpr) = let isOpName opName vref s = (s = opName) && - match ResolveExprLongIdent cenv.tcSink cenv.nameResolver m ad env.eNameResEnv TypeNameResolutionInfo.Default [ident(opName, m)] with + match ResolveExprLongIdent cenv.tcSink cenv.nameResolver m ad env.eNameEnv TypeNameResolutionInfo.Default [ident(opName, m)] with | Item.Value vref2, [] -> valRefEq cenv.g vref vref2 | _ -> false @@ -3204,7 +3206,7 @@ let CompilePatternForMatchClauses cenv env mExpr matchm warnOnUnused actionOnFai // localAlloc is relevant if the enumerator is a mutable struct and indicates // if the enumerator can be allocated as a mutable local variable let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr = - let ad = env.eAccessRights + let ad = env.AccessRights let err k ty = let txt = NicePrint.minimalStringOfType env.DisplayEnv ty @@ -3228,7 +3230,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> Exception e | Result getEnumerator_minfo -> - let getEnumerator_minst = FreshenMethInfo env.GetExtSlns m getEnumerator_minfo + let getEnumerator_minst = FreshenMethInfo env.TraitFreshner m getEnumerator_minfo let retTypeOfGetEnumerator = getEnumerator_minfo.GetFSharpReturnTy(cenv.amap, m, getEnumerator_minst) if hasArgs getEnumerator_minfo getEnumerator_minst then err true tyToSearchForGetEnumeratorAndItem else @@ -3236,7 +3238,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> Exception e | Result moveNext_minfo -> - let moveNext_minst = FreshenMethInfo env.GetExtSlns m moveNext_minfo + let moveNext_minst = FreshenMethInfo env.TraitFreshner m moveNext_minfo let retTypeOfMoveNext = moveNext_minfo.GetFSharpReturnTy(cenv.amap, m, moveNext_minst) if not (typeEquiv cenv.g cenv.g.bool_ty retTypeOfMoveNext) then err false retTypeOfGetEnumerator else if hasArgs moveNext_minfo moveNext_minst then err false retTypeOfGetEnumerator else @@ -3245,7 +3247,7 @@ let AnalyzeArbitraryExprAsEnumerable cenv (env: TcEnv) localAlloc m exprty expr | Exception e -> Exception e | Result get_Current_minfo -> - let get_Current_minst = FreshenMethInfo env.GetExtSlns m get_Current_minfo + let get_Current_minst = FreshenMethInfo env.TraitFreshner m get_Current_minfo if hasArgs get_Current_minfo get_Current_minst then err false retTypeOfGetEnumerator else let enumElemTy = get_Current_minfo.GetFSharpReturnTy(cenv.amap, m, get_Current_minst) @@ -4204,7 +4206,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | WhereTyparSupportsMember(tps, memSpfn, m) -> let traitInfo, tpenv = TcPseudoMemberSpec cenv newOk env tps tpenv memSpfn m match traitInfo with - | TTrait(objtys, ".ctor", memberFlags, argtys, returnTy, _, _) when memberFlags.MemberKind = MemberKind.Constructor -> + | TTrait(objtys, ".ctor", memberFlags, argtys, returnTy, _, _, _) when memberFlags.MemberKind = MemberKind.Constructor -> match objtys, argtys with | [ty], [] when typeEquiv cenv.g ty (GetFSharpViewOfReturnType cenv.g returnTy) -> AddCxTypeMustSupportDefaultCtor env.DisplayEnv cenv.css m NoTrace ty @@ -4238,10 +4240,11 @@ and TcPseudoMemberSpec cenv newOk env synTypes tpenv memSpfn m = let logicalCompiledName = ComputeLogicalName id memberFlags let item = Item.ArgName (id, memberConstraintTy, None) - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) // extSlns starts off empty because the trait has some support - TTrait(tys, logicalCompiledName, memberFlags, argtys, returnTy, ref None, []), tpenv + // ad starts off as None because the trait has some support + TTrait(tys, logicalCompiledName, memberFlags, argtys, returnTy, ref None, [], None), tpenv | _ -> error(Error(FSComp.SR.tcInvalidConstraint(), m)) @@ -4257,7 +4260,7 @@ and TcValSpec cenv env declKind newOk containerInfo memFlagsOpt thisTyOpt tpenv match tcrefContainerInfo with | Some(MemberOrValContainerInfo(tcref, _, _, _, declaredTyconTypars)) -> let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let _, enclosingDeclaredTypars, _, _, thisTy = FreshenObjectArgType cenv env.GetExtSlns m TyparRigidity.Rigid tcref isExtrinsic declaredTyconTypars + let _, enclosingDeclaredTypars, _, _, thisTy = FreshenObjectArgType cenv env.TraitFreshner m TyparRigidity.Rigid tcref isExtrinsic declaredTyconTypars // An implemented interface type is in terms of the type's type parameters. // We need a signature in terms of the values' type parameters. // let optIntfSlotTy = Option.map (instType renaming) optIntfSlotTy in @@ -4402,12 +4405,12 @@ and TcTyparOrMeasurePar optKind cenv (env:TcEnv) newOk tpenv (Typar(id, _, _) as | Some TyparKind.Type, TyparKind.Measure -> error (Error(FSComp.SR.tcExpectedTypeParameter(), id.idRange)); res, tpenv | _, _ -> let item = Item.TypeVar(id.idText, res) - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.UseInType, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.UseInType, env.DisplayEnv, env.AccessRights) // record the ' as well for tokenization - // CallNameResolutionSink cenv.tcSink (tp.Range.StartRange, env.NameEnv, item, item, ItemOccurence.UseInType, env.DisplayEnv, env.eAccessRights) + // CallNameResolutionSink cenv.tcSink (tp.Range.StartRange, env.NameEnv, item, item, ItemOccurence.UseInType, env.DisplayEnv, env.AccessRights) res, tpenv let key = id.idText - match env.eNameResEnv.eTypars.TryFind key with + match env.NameEnv.eTypars.TryFind key with | Some res -> checkRes res | None -> match TryFindUnscopedTypar key tpenv with @@ -4416,7 +4419,7 @@ and TcTyparOrMeasurePar optKind cenv (env:TcEnv) newOk tpenv (Typar(id, _, _) as if newOk = NoNewTypars then let predictTypeParameters() = let predictions1 = - env.eNameResEnv.eTypars + env.NameEnv.eTypars |> Seq.map (fun p -> "'" + p.Key) |> Set.ofSeq @@ -4436,7 +4439,7 @@ and TcTyparOrMeasurePar optKind cenv (env:TcEnv) newOk tpenv (Typar(id, _, _) as // The kind defaults to Type let tp' = NewTypar ((match optKind with None -> TyparKind.Type | Some kind -> kind), TyparRigidity.WarnIfNotRigid, tp, false, TyparDynamicReq.Yes, [], false, false) let item = Item.TypeVar(id.idText, tp') - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.UseInType, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.UseInType, env.DisplayEnv, env.AccessRights) tp', AddUnscopedTypar key tp' tpenv and TcTypar cenv env newOk tpenv tp = @@ -4455,7 +4458,7 @@ and TcTyparDecl cenv env (TyparDecl(synAttrs, (Typar(id, _, _) as stp))) = | None -> () let item = Item.TypeVar(id.idText, tp) - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.UseInType, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.UseInType, env.DisplayEnv, env.AccessRights) tp @@ -4474,7 +4477,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped | SynType.LongIdent(LongIdentWithDots(tc, _) as lidwd) -> let m = lidwd.Range let ad = env.eAccessRights - let tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver occ OpenQualified env.eNameResEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No) + let tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver occ OpenQualified env.NameEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No) match optKind, tcref.TypeOrMeasureKind with | Some TyparKind.Type, TyparKind.Measure -> error(Error(FSComp.SR.tcExpectedTypeNotUnitOfMeasure(), m)) @@ -4489,7 +4492,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped | SynType.App (SynType.LongIdent(LongIdentWithDots(tc, _)), _, args, _commas, _, postfix, m) -> let ad = env.eAccessRights - let tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInType OpenQualified env.eNameResEnv ad tc (TypeNameResolutionStaticArgsInfo.FromTyArgs args.Length) PermitDirectReferenceToGeneratedType.No) + let tcref = ForceRaise(ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInType OpenQualified env.eNameEnv ad tc (TypeNameResolutionStaticArgsInfo.FromTyArgs args.Length) PermitDirectReferenceToGeneratedType.No) match optKind, tcref.TypeOrMeasureKind with | Some TyparKind.Type, TyparKind.Measure -> error(Error(FSComp.SR.tcExpectedTypeNotUnitOfMeasure(), m)) @@ -4516,7 +4519,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped let ltyp, tpenv = TcType cenv newOk checkCxs occ env tpenv ltyp match ltyp with | AppTy cenv.g (tcref, tinst) -> - let tcref = ResolveTypeLongIdentInTyconRef cenv.tcSink cenv.nameResolver env.eNameResEnv (TypeNameResolutionInfo.ResolveToTypeRefs (TypeNameResolutionStaticArgsInfo.FromTyArgs args.Length)) ad m tcref longId + let tcref = ResolveTypeLongIdentInTyconRef cenv.tcSink cenv.nameResolver env.eNameEnv (TypeNameResolutionInfo.ResolveToTypeRefs (TypeNameResolutionStaticArgsInfo.FromTyArgs args.Length)) ad m tcref longId TcTypeApp cenv newOk checkCxs occ env tpenv m tcref tinst args | _ -> error(Error(FSComp.SR.tcTypeHasNoNestedTypes(), m)) @@ -4686,7 +4689,7 @@ and TcStaticConstantParameter cenv (env:TcEnv) tpenv kind (v:SynType) idOpt cont match idOpt with | Some id -> let item = Item.ArgName (id, ttype, Some container) - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) | _ -> () match v with @@ -4865,7 +4868,7 @@ and TcProvidedTypeApp cenv env tpenv tcref args m = /// In this case, 'args' is only the instantiation of the suffix type arguments, and pathTypeArgs gives /// the prefix of type arguments. and TcTypeApp cenv newOk checkCxs occ env tpenv m tcref pathTypeArgs (synArgTys: SynType list) = - CheckTyconAccessible cenv.amap m env.eAccessRights tcref |> ignore + CheckTyconAccessible cenv.amap m env.AccessRights tcref |> ignore CheckEntityAttributes cenv.g tcref m |> CommitOperationResult #if EXTENSIONTYPING @@ -4874,7 +4877,7 @@ and TcTypeApp cenv newOk checkCxs occ env tpenv m tcref pathTypeArgs (synArgTys: if tcref.Deref.IsProvided then TcProvidedTypeApp cenv env tpenv tcref synArgTys m else #endif - let tps, _, tinst, _ = FreshenTyconRef2 env.GetExtSlns m tcref + let tps, _, tinst, _ = FreshenTyconRef2 env.TraitFreshner m tcref // If we're not checking constraints, i.e. when we first assert the super/interfaces of a type definition, then just // clear the constraint lists of the freshly generated type variables. A little ugly but fairly localized. @@ -4931,7 +4934,7 @@ and TcNestedTypeApplication cenv newOk checkCxs occ env tpenv mWholeTypeApp typ and TryAdjustHiddenVarNameToCompGenName cenv env (id:Ident) altNameRefCellOpt = match altNameRefCellOpt with | Some ({contents = Undecided altId } as altNameRefCell) -> - match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver AllIdsOK false id.idRange env.eAccessRights env.eNameResEnv TypeNameResolutionInfo.Default [id] with + match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver AllIdsOK false id.idRange env.eAccessRights env.eNameEnv TypeNameResolutionInfo.Default [id] with | Item.NewDef _ -> None // the name is not in scope as a pattern identifier (e.g. union case), so do not use the alternate ID | _ -> altNameRefCell := Decided altId; Some altId // the name is in scope as a pattern identifier, so use the alternate ID | Some ({contents = Decided altId }) -> Some altId @@ -5045,7 +5048,7 @@ and TcPatBindingName cenv env id ty isMemberThis vis1 topValData (inlineFlag, de | Some value -> let name = id.idText if not (String.IsNullOrEmpty name) && Char.IsLower(name.[0]) then - match TryFindPatternByName name env.eNameResEnv with + match TryFindPatternByName name env.NameEnv with | Some (Item.Value vref) when vref.LiteralValue.IsSome -> warning(Error(FSComp.SR.checkLowercaseLiteralBindingInPattern(id.idText), id.idRange)) | Some _ | None -> () @@ -5057,7 +5060,7 @@ and TcPatBindingName cenv env id ty isMemberThis vis1 topValData (inlineFlag, de // For non-left-most paths, we register the name resolutions here if not isLeftMost && not vspec.IsCompilerGenerated && not (String.hasPrefix vspec.LogicalName "_") then let item = Item.Value(mkLocalValRef vspec) - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.AccessRights) PBind(vspec, typeScheme)), names, takenNames @@ -5082,7 +5085,7 @@ and TcPatAndRecover warnOnUpper cenv (env:TcEnv) topValInfo vFlags (tpenv, names /// the second-phase function in terms of a List.map from names to actual /// value specifications. and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty pat = - let ad = env.eAccessRights + let ad = env.AccessRights match pat with | SynPat.Const (c, m) -> match c with @@ -5161,7 +5164,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | SynConstructorArgs.NamePatPairs (pairs, _) -> pairs.Length if nargs <> 0 then error(Error(FSComp.SR.tcLiteralDoesNotTakeArguments(), m)) - match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver warnOnUpperForId false m ad env.eNameResEnv TypeNameResolutionInfo.Default longId with + match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver warnOnUpperForId false m ad env.NameEnv TypeNameResolutionInfo.Default longId with | Item.NewDef id -> match args with | SynConstructorArgs.Pats [] @@ -5171,7 +5174,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | Item.ActivePatternCase(APElemRef(apinfo, vref, idx)) as item -> let args = match args with SynConstructorArgs.Pats args -> args | _ -> error(Error(FSComp.SR.tcNamedActivePattern(apinfo.ActiveTags.[idx]), m)) // TOTAL/PARTIAL ACTIVE PATTERNS - let _, vexp, _, _, tinst, _ = TcVal env.GetExtSlns true cenv env tpenv vref None None m + let _, vexp, _, _, tinst, _ = TcVal env.TraitFreshner true cenv env tpenv vref None None m let vexp = MakeApplicableExprWithFlex cenv env vexp let vexpty = vexp.Type @@ -5232,7 +5235,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p let activePatIdentity = if isNil activePatArgsAsSynExprs then Some (vref, tinst) else None (fun values -> // Report information about the 'active recognizer' occurrence to IDE - CallNameResolutionSink cenv.tcSink (rangeOfLid longId, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (rangeOfLid longId, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.AccessRights) TPat_query((activePatExpr, activePatResTys, activePatIdentity, idx, apinfo), arg' values, m)), (tpenv, names, takenNames) @@ -5297,12 +5300,12 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p let args', acc = TcPatterns warnOnUpper cenv env vFlags (tpenv, names, takenNames) argtys args (fun values -> // Report information about the case occurrence to IDE - CallNameResolutionSink cenv.tcSink (rangeOfLid longId, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (rangeOfLid longId, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Pattern, env.DisplayEnv, env.AccessRights) mkf m (List.map (fun f -> f values) args')), acc | Item.ILField finfo -> // LITERAL .NET FIELDS - CheckILFieldInfoAccessible cenv.g cenv.amap m env.eAccessRights finfo + CheckILFieldInfoAccessible cenv.g cenv.amap m env.AccessRights finfo if not finfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(finfo.FieldName), m)) CheckILFieldAttributes cenv.g finfo m match finfo.LiteralValue with @@ -5317,7 +5320,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | Item.RecdField rfinfo -> // LITERAL F# FIELDS - CheckRecdFieldInfoAccessible cenv.amap m env.eAccessRights rfinfo + CheckRecdFieldInfoAccessible cenv.amap m env.AccessRights rfinfo if not rfinfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.Name), m)) CheckRecdFieldInfoAttributes cenv.g rfinfo m |> CommitOperationResult match rfinfo.LiteralValue with @@ -5335,8 +5338,8 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p match vref.LiteralValue with | None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m)) | Some lit -> - let _, _, _, vexpty, _, _ = TcVal env.GetExtSlns true cenv env tpenv vref None None m - CheckValAccessible m env.eAccessRights vref + let _, _, _, vexpty, _, _ = TcVal env.TraitFreshner true cenv env tpenv vref None None m + CheckValAccessible m env.AccessRights vref CheckFSharpAttributes cenv.g vref.Attribs m |> CommitOperationResult checkNoArgsForLiteral() UnifyTypes cenv env m ty vexpty @@ -5375,7 +5378,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | SynPat.Record (flds, m) -> let tcref, fldsmap, _fldsList = BuildFieldMap cenv env true ty flds m // REVIEW: use _fldsList to type check pattern in code order not field defn order - let _, inst, tinst, gtyp = FreshenTyconRef2 env.GetExtSlns m tcref + let _, inst, tinst, gtyp = FreshenTyconRef2 env.TraitFreshner m tcref UnifyTypes cenv env m ty gtyp let fields = tcref.TrueInstanceFieldsAsList let ftys = fields |> List.map (fun fsp -> actualTyOfRecdField inst fsp, fsp) @@ -5611,18 +5614,18 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.Paren (expr2, _, _, mWholeExprIncludingParentheses) -> // We invoke CallExprHasTypeSink for every construct which is atomic in the syntax, i.e. where a '.' immediately following the // construct is a dot-lookup for the result of the construct. - CallExprHasTypeSink cenv.tcSink (mWholeExprIncludingParentheses, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (mWholeExprIncludingParentheses, env.NameEnv, overallTy, env.DisplayEnv, env.AccessRights) TcExpr cenv overallTy env tpenv expr2 | SynExpr.DotIndexedGet _ | SynExpr.DotIndexedSet _ | SynExpr.TypeApp _ | SynExpr.Ident _ | SynExpr.LongIdent _ | SynExpr.App _ | SynExpr.DotGet _ -> error(Error(FSComp.SR.tcExprUndelayed(), expr.Range)) | SynExpr.Const (SynConst.String (s, m), _) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.AccessRights) TcConstStringExpr cenv overallTy env m tpenv s | SynExpr.Const (c, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.AccessRights) TcConstExpr cenv overallTy env m tpenv c | SynExpr.Lambda _ -> TcIteratedLambdas cenv true env overallTy Set.empty tpenv expr @@ -5737,7 +5740,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = mkAnyTupled cenv.g m tupInfoStruct args' argtys, tpenv | SynExpr.ArrayOrList (isArray, args, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.AccessRights) let argty = NewInferenceType () UnifyTypes cenv env m overallTy (if isArray then mkArrayType cenv.g argty else Tastops.mkListTy cenv.g argty) @@ -5765,11 +5768,11 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = TcNewExpr cenv env tpenv objTy (Some synObjTy.Range) superInit arg mNewExpr | SynExpr.ObjExpr(objTy, argopt, binds, extraImpls, mNewExpr, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.AccessRights) TcObjectExpr cenv overallTy env tpenv (objTy, argopt, binds, extraImpls, mNewExpr, m) | SynExpr.Record (inherits, optOrigExpr, flds, mWholeExpr) -> - CallExprHasTypeSink cenv.tcSink (mWholeExpr, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (mWholeExpr, env.NameEnv, overallTy, env.DisplayEnv, env.AccessRights) TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr) | SynExpr.While (spWhile, e1, e2, m) -> @@ -5787,7 +5790,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = // notify name resolution sink about loop variable let item = Item.Value(mkLocalValRef idv) - CallNameResolutionSink cenv.tcSink (idv.Range, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (idv.Range, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.AccessRights) let bodyExpr, tpenv = TcStmt cenv envinner tpenv body mkFastForLoop cenv.g (spBind, m, idv, startExpr, dir, finishExpr, bodyExpr), tpenv @@ -5813,7 +5816,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = TcComputationOrSequenceExpression cenv env overallTy m None tpenv comp | SynExpr.ArrayOrListOfSeqExpr (isArray, comp, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.AccessRights) match comp with | SynExpr.CompExpr(_, _, (SimpleSemicolonSequence true elems as body), _) -> @@ -5979,11 +5982,13 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.TraitCall(tps, memSpfn, arg, m) -> let synTypes = tps |> List.map (fun tp -> SynType.Var(tp, m)) - let (TTrait(_, logicalCompiledName, _, argtys, returnTy, _, _) as traitInfo), tpenv = TcPseudoMemberSpec cenv NewTyparsOK env synTypes tpenv memSpfn m - if BakedInTraitConstraintNames.Contains logicalCompiledName then - warning(BakedInMemberConstraintName(logicalCompiledName, m)) + let traitInfo, tpenv = TcPseudoMemberSpec cenv NewTyparsOK env synTypes tpenv memSpfn m + + if BakedInTraitConstraintNames.Contains traitInfo.MemberName then + warning(BakedInMemberConstraintName(traitInfo.MemberName, m)) - let returnTy = GetFSharpViewOfReturnType cenv.g returnTy + let argtys = traitInfo.ArgumentTypes + let returnTy = GetFSharpViewOfReturnType cenv.g traitInfo.ReturnType let args, namedCallerArgs = GetMethodArgs arg if not (isNil namedCallerArgs) then errorR(Error(FSComp.SR.tcNamedArgumentsCannotBeUsedInMemberTraits(), m)) // Subsumption at trait calls if arguments have nominal type prior to unification of any arguments or return type @@ -6030,7 +6035,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = mkAsmExpr(Array.toList s, tyargs', args', rtys', m), tpenv | SynExpr.Quote(oper, raw, ast, isFromQueryExpression, m) -> - CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (m, env.NameEnv, overallTy, env.DisplayEnv, env.AccessRights) TcQuotationExpr cenv overallTy env tpenv (oper, raw, ast, isFromQueryExpression, m) | SynExpr.YieldOrReturn ((isTrueYield, _), _, m) @@ -6073,7 +6078,7 @@ and TcIteratedLambdas cenv isFirst (env: TcEnv) overallTy takenNames tpenv e = // .NET metadata. This means we manually typecheck 'e1' and look to see if it has a nominal type. We then // do the right thing in each case. and TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv wholeExpr e1 indexArgs delayed = - let ad = env.eAccessRights + let ad = env.AccessRights let e1', e1ty, tpenv = TcExprOfUnknownType cenv env tpenv e1 // Find the first type in the effective hierarchy that either has a DefaultMember attribute OR @@ -6187,7 +6192,7 @@ and TcIndexerThen cenv env overallTy mWholeExpr mDot tpenv wholeExpr e1 indexArg /// For 'inherit Type(args)', mWholeExprOrObjTy is the whole expression /// For an implicit inherit from System.Object or a default constructor, mWholeExprOrObjTy is the type name of the type being defined and TcNewExpr cenv env tpenv objTy mObjTyOpt superInit arg mWholeExprOrObjTy = - let ad = env.eAccessRights + let ad = env.AccessRights // Handle the case 'new 'a()' if (isTyparTy cenv.g objTy) then if superInit then error(Error(FSComp.SR.tcCannotInheritFromVariableType(), mWholeExprOrObjTy)) @@ -6206,7 +6211,7 @@ and TcNewExpr cenv env tpenv objTy mObjTyOpt superInit arg mWholeExprOrObjTy = /// Check an 'inheritedTys declaration in an implicit or explicit class and TcCtorCall isNaked cenv env tpenv overallTy objTy mObjTyOpt item superInit args mWholeCall delayed afterTcOverloadResolutionOpt = - let ad = env.eAccessRights + let ad = env.AccessRights let isSuperInit = (if superInit then CtorValUsedAsSuperInit else NormalValUse) let mItem = match mObjTyOpt with Some m -> m | None -> mWholeCall @@ -6235,7 +6240,7 @@ and TcCtorCall isNaked cenv env tpenv overallTy objTy mObjTyOpt item superInit a | Item.DelegateCtor typ, [arg] -> // Re-record the name resolution since we now know it's a constructor call match mObjTyOpt with - | Some mObjTy -> CallNameResolutionSink cenv.tcSink (mObjTy, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + | Some mObjTy -> CallNameResolutionSink cenv.tcSink (mObjTy, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) | None -> () TcNewDelegateThen cenv objTy env tpenv mItem mWholeCall typ arg ExprAtomicFlag.NonAtomic delayed @@ -6318,7 +6323,7 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m = // Check accessibility: this is also done in BuildFieldMap, but also need to check // for fields in { new R with a=1 and b=2 } constructions and { r with a=1 } copy-and-update expressions rfrefs |> List.iter (fun rfref -> - CheckRecdFieldAccessible cenv.amap m env.eAccessRights rfref |> ignore + CheckRecdFieldAccessible cenv.amap m env.AccessRights rfref |> ignore CheckFSharpAttributes cenv.g rfref.PropertyAttribs m |> CommitOperationResult) let args = List.map snd fldsList @@ -6415,7 +6420,7 @@ and FreshenObjExprAbstractSlot cenv (env: TcEnv) (implty:TType) virtNameAndArity | [(_, absSlot)] -> - let typarsFromAbsSlotAreRigid, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot = FreshenAbstractSlot env.GetExtSlns cenv.g cenv.amap mBinding synTyparDecls absSlot + let typarsFromAbsSlotAreRigid, typarsFromAbsSlot, argTysFromAbsSlot, retTyFromAbsSlot = FreshenAbstractSlot env.TraitFreshner cenv.g cenv.amap mBinding synTyparDecls absSlot // Work out the required type of the member let bindingTy = implty --> (mkMethodTy cenv.g argTysFromAbsSlot retTyFromAbsSlot) @@ -6580,7 +6585,7 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, // Object expression members can access protected members of the implemented type let env = EnterFamilyRegion tcref env - let ad = env.eAccessRights + let ad = env.AccessRights if // record construction ? isRecordTy || @@ -6622,7 +6627,7 @@ and TcObjectExpr cenv overallTy env tpenv (synObjTy, argopt, binds, extraImpls, | Item.CtorGroup(methodName, minfos), Some (arg, baseIdOpt) -> let meths = minfos |> List.map (fun minfo -> minfo, None) let afterResolution = ForNewConstructors cenv.tcSink env synObjTy.Range methodName minfos - let ad = env.eAccessRights + let ad = env.AccessRights let expr, tpenv = TcMethodApplicationThen cenv env objTy None tpenv None [] mWholeExpr mObjTy methodName ad PossiblyMutates false meths afterResolution CtorValUsedAsSuperInit [arg] ExprAtomicFlag.Atomic [] // The 'base' value is always bound @@ -6746,8 +6751,8 @@ and TcConstExpr cenv overallTy env m tpenv c = | SynConst.UserNum (s, suffix) -> let expr = let modName = "NumericLiteral" + suffix - let ad = env.eAccessRights - match ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AtMostOneResult cenv.amap m OpenQualified env.eNameResEnv ad [ident (modName, m)] with + let ad = env.AccessRights + match ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AtMostOneResult cenv.amap m OpenQualified env.NameEnv ad [ident (modName, m)] with | Result [] | Exception _ -> error(Error(FSComp.SR.tcNumericLiteralRequiresModule(modName), m)) | Result ((_, mref, _) :: _) -> @@ -6834,7 +6839,7 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr | [] -> [] | _ -> let tcref, _, fldsList = BuildFieldMap cenv env hasOrigExpr overallTy flds mWholeExpr - let _, _, _, gtyp = FreshenTyconRef2 env.GetExtSlns mWholeExpr tcref + let _, _, _, gtyp = FreshenTyconRef2 env.TraitFreshner mWholeExpr tcref UnifyTypes cenv env mWholeExpr overallTy gtyp [ for n, v in fldsList do @@ -7028,7 +7033,7 @@ and IgnoreAttribute _ = None and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv comp = //dprintfn "TcComputationOrSequenceExpression, comp = \n%A\n-------------------\n" comp - let ad = env.eAccessRights + let ad = env.AccessRights let mkSynDelay2 (e: SynExpr) = mkSynDelay (e.Range.MakeSynthetic()) e @@ -7040,7 +7045,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv match interpExpr with | Expr.Val(vf, _, m) -> let item = Item.CustomBuilder (vf.DisplayName, vf) - CallNameResolutionSink cenv.tcSink (m, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (m, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) valRefEq cenv.g vf cenv.g.query_value_vref | _ -> false @@ -7247,7 +7252,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv match e with | SynExpr.App(_, _, SynExpr.App(_, _, e1, SingleIdent opName, _), e2, _) when opName.idText = customOperationJoinConditionWord nm -> let item = Item.CustomOperation (opName.idText, (fun () -> None), None) - CallNameResolutionSink cenv.tcSink (opName.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (opName.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) Some (e1, e2) | _ -> None @@ -7266,7 +7271,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv | IntoSuffix (x, intoWordRange, intoPat) -> // record the "into" as a custom operation for colorization let item = Item.CustomOperation ("into", (fun () -> None), None) - CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) (x, intoPat, alreadyGivenError) | _ -> if not alreadyGivenError then @@ -7400,7 +7405,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv match optInto with | Some (intoWordRange, optInfo) -> let item = Item.CustomOperation ("into", (fun () -> None), None) - CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) Some optInfo | None -> None @@ -7535,7 +7540,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv // FUTURE: consider whether we can do better than emptyTyparInst here, in order to display instantiations // of type variables in the quick info provided in the IDE. - CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) let mkJoinExpr keySelector1 keySelector2 innerPat e = let mSynthetic = mOpCore.MakeSynthetic() @@ -7729,7 +7734,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv // FUTURE: consider whether we can do better than emptyTyparInst here, in order to display instantiations // of type variables in the quick info provided in the IDE. - CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) if isLikeZip || isLikeJoin || isLikeGroupJoin then errorR(Error(FSComp.SR.tcBinaryOperatorRequiresBody(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) @@ -8296,7 +8301,7 @@ and TcDelayed cenv overallTy env tpenv mExpr expr exprty (atomicFlag:ExprAtomicF // OK, we've typechecked the thing on the left of the delayed lookup chain. // We can now record for posterity the type of this expression and the location of the expression. if (atomicFlag = ExprAtomicFlag.Atomic) then - CallExprHasTypeSink cenv.tcSink (mExpr, env.NameEnv, exprty, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (mExpr, env.NameEnv, exprty, env.DisplayEnv, env.AccessRights) match delayed with | [] @@ -8374,7 +8379,7 @@ and TcFunctionApplicationThen cenv overallTy env tpenv mExprAndArg expr exprty ( and TcLongIdentThen cenv overallTy env tpenv (LongIdentWithDots(longId, _)) delayed = - let ad = env.eAccessRights + let ad = env.AccessRights let typeNameResInfo = // Given 'MyOverloadedType.MySubType...' use arity of #given type arguments to help // resolve type name lookup of 'MyOverloadedType' @@ -8391,7 +8396,7 @@ and TcLongIdentThen cenv overallTy env tpenv (LongIdentWithDots(longId, _)) dela | _ -> TypeNameResolutionInfo.Default - let nameResolutionResult = ResolveLongIdentAsExprAndComputeRange cenv.tcSink cenv.nameResolver (rangeOfLid longId) ad env.eNameResEnv typeNameResInfo longId + let nameResolutionResult = ResolveLongIdentAsExprAndComputeRange cenv.tcSink cenv.nameResolver (rangeOfLid longId) ad env.NameEnv typeNameResInfo longId TcItemThen cenv overallTy env tpenv nameResolutionResult delayed //------------------------------------------------------------------------- @@ -8400,7 +8405,7 @@ and TcLongIdentThen cenv overallTy env tpenv (LongIdentWithDots(longId, _)) dela // mItem is the textual range covered by the long identifiers that make up the item and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) delayed = let delayed = delayRest rest mItem delayed - let ad = env.eAccessRights + let ad = env.AccessRights match item with // x where x is a union case or active pattern result tag. | (Item.UnionCase _ | Item.ExnCase _ | Item.ActivePatternResult _) as item -> @@ -8416,7 +8421,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del mkConstrApp, [ucaseAppTy], [ for (s, m) in apinfo.ActiveTagsWithRanges -> mkSynId m s ] | _ -> let ucref = mkChoiceCaseRef cenv.g mItem aparity n - let _, _, tinst, _ = FreshenTyconRef2 env.GetExtSlns mItem ucref.TyconRef + let _, _, tinst, _ = FreshenTyconRef2 env.TraitFreshner mItem ucref.TyconRef let ucinfo = UnionCaseInfo(tinst, ucref) ApplyUnionCaseOrExnTypes mItem cenv env ucaseAppTy (Item.UnionCase(ucinfo, false)) | _ -> @@ -8555,14 +8560,14 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // Report information about the whole expression including type arguments to VS let item = Item.Types(nm, [typ]) - CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) - TcItemThen cenv overallTy env tpenv (ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver (unionRanges mExprAndTypeArgs mLongId) ad env.eNameResEnv typ longId IgnoreOverrides true) otherDelayed + CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) + TcItemThen cenv overallTy env tpenv (ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver (unionRanges mExprAndTypeArgs mLongId) ad env.NameEnv typ longId IgnoreOverrides true) otherDelayed | ((DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs))::_delayed') -> // A case where we have an incomplete name e.g. 'Foo.' - we still want to report it to VS! let typ, _ = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs typ tyargs let item = Item.Types(nm, [typ]) - CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) // Same error as in the following case error(Error(FSComp.SR.tcInvalidUseOfTypeName(), mItem)) @@ -8588,7 +8593,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // Replace the resolution including the static parameters, plus the extra information about the original method info let item = Item.MethodGroup(methodName, [minfoAfterStaticArguments], Some minfos.[0]) - CallNameResolutionSinkReplacing cenv.tcSink (mItem, env.NameEnv, item, item, [], ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSinkReplacing cenv.tcSink (mItem, env.NameEnv, item, item, [], ItemOccurence.Use, env.DisplayEnv, env.AccessRights) match otherDelayed with | DelayedApp(atomicFlag, arg, mExprAndArg) :: otherDelayed -> @@ -8604,7 +8609,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // FUTURE: can we do better than emptyTyparInst here, in order to display instantiations // of type variables in the quick info provided in the IDE? But note we haven't yet even checked if the // number of type arguments is correct... - CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) match otherDelayed with | DelayedApp(atomicFlag, arg, mExprAndArg) :: otherDelayed -> @@ -8627,13 +8632,13 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del match delayed with | ((DelayedApp (_, arg, mExprAndArg))::otherDelayed) -> - CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTy, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTy, env.DisplayEnv, env.AccessRights) TcCtorCall true cenv env tpenv overallTy objTy (Some mItem) item false [arg] mExprAndArg otherDelayed (Some afterResolution) | ((DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs))::(DelayedApp (_, arg, mExprAndArg))::otherDelayed) -> let objTyAfterTyArgs, tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs objTy tyargs - CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTyAfterTyArgs, env.DisplayEnv, env.eAccessRights) + CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTyAfterTyArgs, env.DisplayEnv, env.AccessRights) let itemAfterTyArgs, minfosAfterTyArgs = #if EXTENSIONTYPING // If the type is provided and took static arguments then the constructor will have changed @@ -8657,7 +8662,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // A case where we have an incomplete name e.g. 'Foo.' - we still want to report it to VS! let resolvedItem = Item.Types(nm, [objTy]) - CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, resolvedItem, resolvedItem, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, resolvedItem, resolvedItem, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) minfos |> List.iter (fun minfo -> UnifyTypes cenv env mExprAndTypeArgs minfo.EnclosingType objTy) TcCtorCall true cenv env tpenv overallTy objTy (Some mExprAndTypeArgs) item false [] mExprAndTypeArgs otherDelayed (Some afterResolution) @@ -8696,8 +8701,8 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del let memberFlags = StaticMemberFlags MemberKind.Member let logicalCompiledName = ComputeLogicalName id memberFlags - let traitInfo = TTrait(argTys, logicalCompiledName, memberFlags, argTys, Some retTy, sln, []) - let traitInfo = FillInExtSlnsForConstraint env.GetExtSlns traitInfo + let traitInfo = TTrait(argTys, logicalCompiledName, memberFlags, argTys, Some retTy, sln, [], None) + let traitInfo = FreshenTrait env.TraitFreshner traitInfo let expr = Expr.Op(TOp.TraitCall(traitInfo), [], ves, mItem) let expr = mkLambdas mItem [] vs (expr, retTy) @@ -8796,7 +8801,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // Report information about the whole expression including type arguments to VS let item = Item.DelegateCtor typ - CallNameResolutionSink cenv.tcSink (mItemAndTypeArgs, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (mItemAndTypeArgs, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) TcNewDelegateThen cenv overallTy env tpenv mItem mItemAndArg typ arg atomicFlag otherDelayed | _ -> error(Error(FSComp.SR.tcInvalidUseOfDelegate(), mItem)) @@ -8809,7 +8814,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) UnifyTypes cenv env mStmt overallTy cenv.g.unit_ty vref.Deref.SetHasBeenReferenced() - CheckValAccessible mItem env.eAccessRights vref + CheckValAccessible mItem env.AccessRights vref CheckValAttributes cenv.g vref mItem |> CommitOperationResult let vty = vref.Type let vty2 = @@ -8835,7 +8840,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // - it isn't a CtorValUsedAsSelfInit // - it isn't a VSlotDirectCall (uses of base values do not take type arguments let checkTys tpenv kinds = TcTypesOrMeasures (Some kinds) cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tys mItem - let _, vexp, isSpecial, _, _, tpenv = TcVal env.GetExtSlns true cenv env tpenv vref (Some (NormalValUse, checkTys)) (Some afterResolution) mItem + let _, vexp, isSpecial, _, _, tpenv = TcVal env.TraitFreshner true cenv env tpenv vref (Some (NormalValUse, checkTys)) (Some afterResolution) mItem let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vexp else MakeApplicableExprWithFlex cenv env vexp) // We need to eventually record the type resolution for an expression, but this is done // inside PropagateThenTcDelayed, so we don't have to explicitly call 'CallExprHasTypeSink' here @@ -8843,7 +8848,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // Value get | _ -> - let _, vexp, isSpecial, _, _, tpenv = TcVal env.GetExtSlns true cenv env tpenv vref None (Some afterResolution) mItem + let _, vexp, isSpecial, _, _, tpenv = TcVal env.TraitFreshner true cenv env tpenv vref None (Some afterResolution) mItem let vexpFlex = (if isSpecial then MakeApplicableExprNoFlex cenv vexp else MakeApplicableExprWithFlex cenv env vexp) PropagateThenTcDelayed cenv overallTy env tpenv mItem vexpFlex vexpFlex.Type ExprAtomicFlag.Atomic delayed @@ -8979,7 +8984,7 @@ and GetMemberApplicationArgs delayed cenv env tpenv = and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId delayed mExprAndLongId = let objArgs = [objExpr] - let ad = env.eAccessRights + let ad = env.AccessRights // 'base' calls use a different resolution strategy when finding methods. let findFlag = @@ -8990,7 +8995,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela if isTyparTy cenv.g objExprTy then GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv, env.DisplayEnv, mExprAndLongId) (freeInTypeLeftToRight cenv.g false objExprTy) - let item, mItem, rest, afterResolution = ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver mExprAndLongId ad env.eNameResEnv objExprTy longId findFlag false + let item, mItem, rest, afterResolution = ResolveExprDotLongIdentAndComputeRange cenv.tcSink cenv.nameResolver mExprAndLongId ad env.NameEnv objExprTy longId findFlag false let mExprAndItem = unionRanges mObjExpr mItem let delayed = delayRest rest mExprAndItem delayed @@ -9006,7 +9011,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela | Some minfoAfterStaticArguments -> // Replace the resolution including the static parameters, plus the extra information about the original method info let item = Item.MethodGroup(methodName, [minfoAfterStaticArguments], Some minfos.[0]) - CallNameResolutionSinkReplacing cenv.tcSink (mExprAndItem, env.NameEnv, item, item, [], ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSinkReplacing cenv.tcSink (mExprAndItem, env.NameEnv, item, item, [], ItemOccurence.Use, env.DisplayEnv, env.AccessRights) TcMethodApplicationThen cenv env overallTy None tpenv None objArgs mExprAndItem mItem methodName ad mutates false [(minfoAfterStaticArguments, None)] afterResolution NormalValUse args atomicFlag delayed | None -> @@ -9099,7 +9104,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela and TcEventValueThen cenv overallTy env tpenv mItem mExprAndItem objDetails (einfo:EventInfo) delayed = // Instance IL event (fake up event-as-value) let nm = einfo.EventName - let ad = env.eAccessRights + let ad = env.AccessRights match objDetails, einfo.IsStatic with | Some _, true -> error (Error (FSComp.SR.tcEventIsStatic(nm), mItem)) | None, false -> error (Error (FSComp.SR.tcEventIsNotStatic(nm), mItem)) @@ -9108,7 +9113,7 @@ and TcEventValueThen cenv overallTy env tpenv mItem mExprAndItem objDetails (ein let delegateType = einfo.GetDelegateType(cenv.amap, mItem) let (SigOfFunctionForDelegate(invokeMethInfo, compiledViewOfDelArgTys, _, _)) = GetSigOfFunctionForDelegate cenv.infoReader delegateType mItem ad let objArgs = Option.toList (Option.map fst objDetails) - MethInfoChecks cenv.g cenv.amap true None objArgs env.eAccessRights mItem invokeMethInfo + MethInfoChecks cenv.g cenv.amap true None objArgs env.AccessRights mItem invokeMethInfo // This checks for and drops the 'object' sender let argsTy = ArgsTypOfEventInfo cenv.infoReader mItem ad einfo @@ -9405,12 +9410,12 @@ and TcMethodApplication let callerArgs = List.zip unnamedCurriedCallerArgs namedCurriedCallerArgs let makeOneCalledMeth (minfo, pinfoOpt, usesParamArrayConversion) = - let minst = FreshenMethInfo env.GetExtSlns mItem minfo + let minst = FreshenMethInfo env.TraitFreshner mItem minfo let callerTyArgs = match tyargsOpt with | Some tyargs -> minfo.AdjustUserTypeInstForFSharpStyleIndexedExtensionMembers(tyargs) | None -> minst - CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo env.GetExtSlns, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt) + CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo env.TraitFreshner, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt) let preArgumentTypeCheckingCalledMethGroup = [ for (minfo, pinfoOpt) in candidateMethsAndProps do @@ -9509,7 +9514,7 @@ and TcMethodApplication match tyargsOpt with | Some tyargs -> minfo.AdjustUserTypeInstForFSharpStyleIndexedExtensionMembers(tyargs) | None -> minst - CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo env.GetExtSlns, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt)) + CalledMeth(cenv.infoReader, Some(env.NameEnv), isCheckingAttributeCall, FreshenMethInfo env.TraitFreshner, mMethExpr, ad, minfo, minst, callerTyArgs, pinfoOpt, callerObjArgTys, callerArgs, usesParamArrayConversion, true, objTyOpt)) let callerArgCounts = (unnamedCurriedCallerArgs.Length, namedCurriedCallerArgs.Length) let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv @@ -10039,11 +10044,11 @@ and TcMethodArg cenv env (lambdaPropagationInfo, tpenv) (lambdaPropagationInfo /// Typecheck "new Delegate(fun x y z -> ...)" constructs and TcNewDelegateThen cenv overallTy env tpenv mDelTy mExprAndArg delegateTy arg atomicFlag delayed = - let ad = env.eAccessRights + let ad = env.AccessRights UnifyTypes cenv env mExprAndArg overallTy delegateTy let (SigOfFunctionForDelegate(invokeMethInfo, delArgTys, _, fty)) = GetSigOfFunctionForDelegate cenv.infoReader delegateTy mDelTy ad // We pass isInstance = true here because we're checking the rights to access the "Invoke" method - MethInfoChecks cenv.g cenv.amap true None [] env.eAccessRights mExprAndArg invokeMethInfo + MethInfoChecks cenv.g cenv.amap true None [] env.AccessRights mExprAndArg invokeMethInfo let args = GetMethodArgs arg match args with | [farg], [] -> @@ -10354,7 +10359,7 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt apinfo.ActiveTagsWithRanges |> List.iteri (fun i (_tag, tagRange) -> let item = Item.ActivePatternResult(apinfo, cenv.g.unit_ty, i, tagRange) - CallNameResolutionSink cenv.tcSink (tagRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.eAccessRights)) + CallNameResolutionSink cenv.tcSink (tagRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.AccessRights)) ModifyNameResEnv (fun nenv -> AddActivePatternResultTagsToNameEnv apinfo nenv ty m) envinner | None -> @@ -10474,13 +10479,13 @@ and TcAttribute canFail cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = let try1 n = let tyid = mkSynId tyid.idRange n let tycon = (typath @ [tyid]) - let ad = env.eAccessRights - match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInAttribute OpenQualified env.eNameResEnv ad tycon TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No with + let ad = env.AccessRights + match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInAttribute OpenQualified env.NameEnv ad tycon TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No with | Exception err -> raze(err) | _ -> success(TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInAttribute env tpenv (SynType.App(SynType.LongIdent(LongIdentWithDots(tycon, [])), None, [], [], None, false, mAttr)) ) ForceRaise ((try1 (tyid.idText + "Attribute")) |> ResultOrException.otherwise (fun () -> (try1 tyid.idText))) - let ad = env.eAccessRights + let ad = env.AccessRights if not (IsTypeAccessible cenv.g cenv.amap mAttr ad ty) then errorR(Error(FSComp.SR.tcTypeIsInaccessible(), mAttr)) @@ -10825,7 +10830,7 @@ and ComputeIsComplete enclosingDeclaredTypars declaredTypars ty = /// it implements. Apply the inferred slotsig. and ApplyAbstractSlotInference (cenv:cenv) (envinner:TcEnv) (bindingTy, m, synTyparDecls, declaredTypars, memberId, tcrefObjTy, renaming, _objTy, optIntfSlotTy, valSynData, memberFlags, attribs) = - let ad = envinner.eAccessRights + let ad = envinner.AccessRights let typToSearchForAbstractMembers = match optIntfSlotTy with | Some (ty, abstractSlots) -> @@ -11220,7 +11225,7 @@ and AnalyzeAndMakeAndPublishRecursiveValue overridesOK isGeneratedEventVal cenv match toolIdOpt with | Some tid when not tid.idRange.IsSynthetic && tid.idRange <> bindingId.idRange -> let item = Item.Value (mkLocalValRef vspec) - CallNameResolutionSink cenv.tcSink (tid.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.RelatedText, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (tid.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.RelatedText, env.DisplayEnv, env.AccessRights) | _ -> () @@ -12020,7 +12025,7 @@ let TcTyconMemberSpecs cenv env containerInfo declKind tpenv (augSpfn: SynMember let TcModuleOrNamespaceLidAndPermitAutoResolve env amap (longId : Ident list) = let ad = env.eAccessRights let m = longId |> List.map (fun id -> id.idRange) |> List.reduce unionRanges - match ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AllResults amap m OpenQualified env.eNameResEnv ad longId with + match ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AllResults amap m OpenQualified env.eNameEnv ad longId with | Result res -> Result res | Exception err -> raze err @@ -13252,7 +13257,7 @@ module MutRecBindingChecking = let nm = bind.Var.DisplayName let ty = generalizedTyconRef tcref - let ad = envNonRec.eAccessRights + let ad = envNonRec.AccessRights match TryFindIntrinsicMethInfo cenv.infoReader bind.Var.Range ad nm ty, TryFindPropInfo cenv.infoReader bind.Var.Range ad nm ty with | [], [] -> () @@ -13515,7 +13520,7 @@ module MutRecBindingChecking = /// Check a "module X = A.B.C" module abbreviation declaration let TcModuleAbbrevDecl (cenv:cenv) scopem env (id, p, m) = let ad = env.eAccessRights - let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AllResults cenv.amap m OpenQualified env.eNameResEnv ad p) + let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AllResults cenv.amap m OpenQualified env.eNameEnv ad p) let modrefs = mvvs |> List.map p23 if modrefs.Length > 0 && modrefs |> List.forall (fun modref -> modref.IsNamespace) then errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head modrefs)), m)) @@ -14251,9 +14256,9 @@ module TcExceptionDeclarations = let repr = match reprIdOpt with | Some longId -> - match ResolveExprLongIdent cenv.tcSink cenv.nameResolver m ad env.eNameResEnv TypeNameResolutionInfo.Default longId with + match ResolveExprLongIdent cenv.tcSink cenv.nameResolver m ad env.NameEnv TypeNameResolutionInfo.Default longId with | Item.ExnCase exnc, [] -> - CheckTyconAccessible cenv.amap m env.eAccessRights exnc |> ignore + CheckTyconAccessible cenv.amap m env.AccessRights exnc |> ignore if not (isNil args') then errorR (Error(FSComp.SR.tcExceptionAbbreviationsShouldNotHaveArgumentList(), m)) TExnAbbrevRepr exnc @@ -14284,7 +14289,7 @@ module TcExceptionDeclarations = exnc.entity_exn_info <- repr let item = Item.ExnCase(mkLocalTyconRef exnc) - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.eAccessRights) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.AccessRights) args' let private TcExnDefnCore cenv env parent synExnDefnRepr = @@ -14395,7 +14400,7 @@ module EstablishTypeDefinitionCores = | SynTypeDefnSimpleRepr.TypeAbbrev(_, SynType.LongIdent(LongIdentWithDots([unionCaseName], _)), m) when (not hasMeasureAttr && - (isNil (LookupTypeNameInEnvNoArity OpenQualified unionCaseName.idText envinner.eNameResEnv) || + (isNil (LookupTypeNameInEnvNoArity OpenQualified unionCaseName.idText envinner.eNameEnv) || id.idText = unionCaseName.idText)) -> Some(unionCaseName, m) | _ -> @@ -14679,7 +14684,7 @@ module EstablishTypeDefinitionCores = | None -> None | Some (tc, args, m) -> let ad = envinner.eAccessRights - match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInType OpenQualified envinner.eNameResEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.Yes with + match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInType OpenQualified envinner.eNameEnv ad tc TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.Yes with | Result tcrefBeforeStaticArguments when tcrefBeforeStaticArguments.IsProvided && not tcrefBeforeStaticArguments.IsErased -> @@ -15104,7 +15109,7 @@ module EstablishTypeDefinitionCores = // Notify the Language Service about field names in record/class declaration - let ad = envinner.eAccessRights + let ad = envinner.AccessRights let writeFakeRecordFieldsToSink (fields:RecdField list) = let nenv = envinner.NameEnv // Record fields should be visible from IntelliSense, so add fake names for them (similarly to "let a = ..") @@ -15752,14 +15757,14 @@ module TcDeclarations = // This records a name resolution of the type at the location let resInfo = TypeNameResolutionStaticArgsInfo.FromTyArgs synTypars.Length - ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Binding OpenQualified envForDecls.eNameResEnv ad longPath resInfo PermitDirectReferenceToGeneratedType.No + ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Binding OpenQualified envForDecls.eNameEnv ad longPath resInfo PermitDirectReferenceToGeneratedType.No |> ignore mkLocalTyconRef tycon | _ -> let resInfo = TypeNameResolutionStaticArgsInfo.FromTyArgs synTypars.Length - match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Binding OpenQualified envForDecls.eNameResEnv ad longPath resInfo PermitDirectReferenceToGeneratedType.No with + match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Binding OpenQualified envForDecls.eNameEnv ad longPath resInfo PermitDirectReferenceToGeneratedType.No with | Result res -> res | res when inSig && longPath.Length = 1 -> errorR(Deprecated(FSComp.SR.tcReservedSyntaxForAugmentation(), m)) @@ -16297,8 +16302,8 @@ let rec TcSignatureElementNonMutRec cenv parent typeNames endm (env: TcEnv) synS return env | SynModuleSigDecl.ModuleAbbrev (id, p, m) -> - let ad = env.eAccessRights - let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AllResults cenv.amap m OpenQualified env.eNameResEnv ad p) + let ad = env.AccessRights + let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace ResultCollectionSettings.AllResults cenv.amap m OpenQualified env.NameEnv ad p) let scopem = unionRanges m endm let unfilteredModrefs = mvvs |> List.map p23 diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index 8ef6eee6c95..9f29b97cf84 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -143,8 +143,8 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = match tpc with | TyparConstraint.CoercesTo(x,m) -> join m x,m - | TyparConstraint.MayResolveMember(TTrait(_, nm, _, _, _, _, _), m) -> - errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInOverloadedOperator(DemangleOperatorName nm),m)) + | TyparConstraint.MayResolveMember(traitInfo, m) -> + errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInOverloadedOperator(DemangleOperatorName traitInfo.MemberName),m)) maxSoFar,m | TyparConstraint.SimpleChoice(_,m) -> errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInPrintf(),m)) diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 859c4483639..6f92f798ad1 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -300,13 +300,18 @@ let ImportReturnTypeFromMetaData amap m ty scoref tinst minst = /// Search for the relevant extension values again if a name resolution environment is provided /// Basically, if you use a generic thing, then the extension members in scope at the point of _use_ /// are the ones available to solve the constraint -let FillInExtSlnsForConstraint getExtSlnsOpt traitInfo = - let (TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns)) = traitInfo - let extSlns2 = - match getExtSlnsOpt with - | None -> extSlns - | Some f -> f traitInfo - TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns2) +let FreshenTrait traitFreshner traitInfo = + let (TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns, ad)) = traitInfo + + // Call the trait freshner if it is provided + let extSlns2, ad2 = + match traitFreshner with + | None -> extSlns, ad + | Some f -> + let extSlns2, ad2 = f traitInfo + extSlns2, Some ad2 + + TTrait(typs, nm, mf, argtys, rty, slnCell, extSlns2, ad2) /// Copy constraints. If the constraint comes from a type parameter associated /// with a type constructor then we are simply renaming type variables. If it comes @@ -316,7 +321,7 @@ let FillInExtSlnsForConstraint getExtSlnsOpt traitInfo = /// /// Note: this now looks identical to constraint instantiation. -let CopyTyparConstraints getExtSlnsOpt m tprefInst (tporig:Typar) = +let CopyTyparConstraints traitFreshner m tprefInst (tporig:Typar) = tporig.Constraints |> List.map (fun tpc -> match tpc with @@ -345,12 +350,12 @@ let CopyTyparConstraints getExtSlnsOpt m tprefInst (tporig:Typar) = | TyparConstraint.RequiresDefaultConstructor _ -> TyparConstraint.RequiresDefaultConstructor m | TyparConstraint.MayResolveMember(traitInfo, _) -> - let traitInfo2 = FillInExtSlnsForConstraint getExtSlnsOpt traitInfo + let traitInfo2 = FreshenTrait traitFreshner traitInfo TyparConstraint.MayResolveMember (instTrait tprefInst traitInfo2, m)) /// The constraints for each typar copied from another typar can only be fixed up once /// we have generated all the new constraints, e.g. f List, B :> List> ... -let FixupNewTypars getExtSlnsOpt m (formalEnclosingTypars:Typars) (tinst: TType list) (tpsorig: Typars) (tps: Typars) = +let FixupNewTypars traitFreshner m (formalEnclosingTypars:Typars) (tinst: TType list) (tpsorig: Typars) (tps: Typars) = // Checks.. These are defensive programming against early reported errors. let n0 = formalEnclosingTypars.Length let n1 = tinst.Length @@ -362,7 +367,7 @@ let FixupNewTypars getExtSlnsOpt m (formalEnclosingTypars:Typars) (tinst: TType // The real code.. let renaming,tptys = mkTyparToTyparRenaming tpsorig tps let tprefInst = mkTyparInst formalEnclosingTypars tinst @ renaming - (tpsorig,tps) ||> List.iter2 (fun tporig tp -> tp.FixupConstraints (CopyTyparConstraints getExtSlnsOpt m tprefInst tporig)) + (tpsorig,tps) ||> List.iter2 (fun tporig tp -> tp.FixupConstraints (CopyTyparConstraints traitFreshner m tprefInst tporig)) renaming,tptys diff --git a/src/fsharp/symbols/Exprs.fs b/src/fsharp/symbols/Exprs.fs index 0f3c93fd62b..e6074325bca 100644 --- a/src/fsharp/symbols/Exprs.fs +++ b/src/fsharp/symbols/Exprs.fs @@ -639,7 +639,7 @@ module FSharpExprConvert = let typR = ConvType cenv (mkAppTy tycr tyargs) E.UnionCaseTag(ConvExpr cenv env arg1, typR) - | TOp.TraitCall (TTrait(tys, nm, memFlags, argtys, _rty, _solution, _extSlns)), _, _ -> + | TOp.TraitCall (TTrait(tys, nm, memFlags, argtys, _rty, _solution, _extSlns, _ad)), _, _ -> let tysR = ConvTypes cenv tys let tyargsR = ConvTypes cenv tyargs let argtysR = ConvTypes cenv argtys diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index 92f2dac4d7d..7a0cad68f3f 100644 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -1029,7 +1029,7 @@ and FSharpAbstractSignature(cenv, info: SlotSig) = member __.DeclaringType = FSharpType(cenv, info.ImplementedType) and FSharpGenericParameterMemberConstraint(cenv, info: TraitConstraintInfo) = - let (TTrait(tys, nm, flags, atys, rty, _, _extSlns)) = info + let (TTrait(tys, nm, flags, atys, rty, _, _extSlns, _ad)) = info member __.MemberSources = tys |> List.map (fun ty -> FSharpType(cenv, ty)) |> makeReadOnlyCollection diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 4163a415720..c564022927c 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -2029,8 +2029,13 @@ and override x.ToString() = x.Name -and PossibleExtensionMemberSolutions = PossibleExtensionMemberSolution list -and PossibleExtensionMemberSolution = interface end // only satisfied by type 'ExtensionMember' +and TraitPossibleExtensionMemberSolutions = TraitPossibleExtensionMemberSolution list + +/// Only satisfied by type 'ExtensionMember'. Not stored in TastPickle. +and TraitPossibleExtensionMemberSolution = interface end + +/// Only satisfied by 'AccessorDomain'. Not stored in TastPickle. +and TraitAccessorDomain = interface end and [] @@ -2082,22 +2087,34 @@ and [] TraitConstraintInfo = - /// TTrait(tys,nm,memFlags,argtys,rty,colution) + /// TTrait(tys, nm, memFlags, argtys, rty, solutionCell, extSlns, ad) /// /// Indicates the signature of a member constraint. Contains a mutable solution cell /// to store the inferred solution of the constraint. - | TTrait of TTypes * string * MemberFlags * TTypes * TType option * TraitConstraintSln option ref * extSlns: PossibleExtensionMemberSolutions + | TTrait of TTypes * string * MemberFlags * TTypes * TType option * TraitConstraintSln option ref * extSlns: TraitPossibleExtensionMemberSolutions * ad: TraitAccessorDomain option + + /// Get the support types that can help provide members to solve the constraint + member x.SupportTypes= (let (TTrait(tys,_,_,_,_,_,_,_)) = x in tys) /// Get the member name associated with the member constraint. - member x.MemberName = (let (TTrait(_,nm,_,_,_,_,_)) = x in nm) + member x.MemberName = (let (TTrait(_,nm,_,_,_,_,_,_)) = x in nm) + + /// Get the argument types required of a member in order to solve the constraint + member x.ArgumentTypes = (let (TTrait(_,_,_,argtys,_,_,_,_)) = x in argtys) /// Get the return type recorded in the member constraint. - member x.ReturnType = (let (TTrait(_,_,_,_,ty,_,_)) = x in ty) + member x.ReturnType = (let (TTrait(_,_,_,_,rty,_,_,_)) = x in rty) /// Get or set the solution of the member constraint during inference member x.Solution - with get() = (let (TTrait(_,_,_,_,_,sln,_)) = x in sln.Value) - and set v = (let (TTrait(_,_,_,_,_,sln,_)) = x in sln.Value <- v) + with get() = (let (TTrait(_,_,_,_,_,sln,_,_)) = x in sln.Value) + and set v = (let (TTrait(_,_,_,_,_,sln,_,_)) = x in sln.Value <- v) + + /// Get possible extension member solutions available for a use of a trait at a particular location + member x.PossibleExtensionSolutions = (let (TTrait(_,_,_,_,_,_,extSlns,_)) = x in extSlns) + + /// Get access rights for a use of a trait at a particular location + member x.AccessorDomain = (let (TTrait(_,_,_,_,_,_,_,ad)) = x in ad) override x.ToString() = "trait " + x.MemberName diff --git a/testfiles/test.fs b/testfiles/test.fs index c06a5a4e9a6..9abec6c1560 100644 --- a/testfiles/test.fs +++ b/testfiles/test.fs @@ -4,14 +4,41 @@ type MyType = | MyType of int /// Extending a .NET primitive type with new operator - module DotNetPrimtiveWithNewOperator = type System.Int32 with static member (++)(a: int, b: int) = a let result = 1 ++ 2 -/// Extending an F# type with + operator +/// Extending a .NET primitive type with new _internal_ operator +module DotNetPrimtiveWithInternalOperator1 = + type System.Int32 with + static member internal (++)(a: int, b: int) = a + + let result = 1 ++ 2 // this is now allowed + + +/// Extending a .NET primitive type with new _private_ operator where that operator is accessible at point-of-use +module DotNetPrimtiveWithAccessibleOperator2 = + type System.Int32 with + static member private (++)(a: int, b: int) = a + + let result = 1 ++ 2 // this is now allowed. + + + +#if NEGATIVE_TESTS +module DotNetPrimtiveWithInaccessibleOperator = + [] + module Extensions = + type System.Int32 with + static member private (++)(a: int, b: int) = a + + let result = 1 ++ 2 // This should fail to compile because the private member is not accessible from here +#endif + + +/// Locally extending an F# type with a wide range of standard operators module FSharpTypeWithExtrinsicOperators = [] @@ -25,6 +52,15 @@ module FSharpTypeWithExtrinsicOperators = static member (|||)(MyType x, MyType y) = MyType (x ||| y) static member (&&&)(MyType x, MyType y) = MyType (x &&& y) static member (^^^)(MyType x, MyType y) = MyType (x &&& y) + static member Zero = MyType 0 + static member One = MyType 1 + member this.Sign = let (MyType x) = this in sign x + static member Abs (MyType x) = MyType (abs x) + static member Sqrt (MyType x) = MyType (int (sqrt (float x))) + static member Sin (MyType x) = MyType (int (sin (float x))) + static member Cos (MyType x) = MyType (int (cos (float x))) + static member Tan (MyType x) = MyType (int (tan (float x))) + static member DivideByInt (MyType x, n: int) = MyType (x / n) let v = MyType 3 let result1 = v + v @@ -35,8 +71,18 @@ module FSharpTypeWithExtrinsicOperators = let result6 = v ||| v let result7 = v &&& v let result8 = v ^^^ v - - + let result9 = LanguagePrimitives.GenericZero + let result10 = LanguagePrimitives.GenericOne + let result11 = sign v + let result12 = abs v + let result13 = sqrt v + let result14 = sin v + let result15 = cos v + let result16 = tan v + let result17 = LanguagePrimitives.DivideByInt v 4 + + +/// Extending two types with the static member 'Add' module TwoTypesWithExtensionOfSameName = [] @@ -115,20 +161,45 @@ module ExtendingGenericTypeAndArrayWithProperty = let v4 = count [| 3 |] - let v5 = count (ResizeArray [| 3 |]) + let v5 = count (dict [| 1,3 |]) + + let v6 = count (ResizeArray [| 3 |]) // intrinsic from .NET + + /// Solving using LINQ extensions -module LinqExtensionMethodsProvideSolutions = +module LinqExtensionMethodsProvideSolutions_Count = open System.Linq - let inline count (a : ^A when ^A : (member Count : int)) = - (^A : (member Count : int) (a)) + // Note this looks for a _method_ called `Count` taking a single argument + // It is _not_ considered the same as a proprty called `Count` + let inline countm (a : ^A when ^A : (member Count : unit -> int)) = + (^A : (member Count : unit -> int) (a)) - let seqv = seq { yield 1; yield 2 } + let seqv : seq = Seq.singleton 1 let v0 = seqv.Count // sanity check - let v1 = count seqv + let v1 = countm seqv + +/// A random example +module ContainsKeyExample = + let inline containsKey (k: ^Key) (a : ^A when ^A : (member ContainsKey : ^Key -> bool)) = + (^A : (member ContainsKey : ^Key -> bool) (a,k)) + + let v5 = containsKey 1 (dict [| 1,3 |]) + + // Note that without 'inline' this doesn't become generic + let inline f x = containsKey x (dict [| (x,1) |]) + +(* +/// Not implemented +module MapExample = + let inline map (f: ^T -> ^U) (a : ^A when ^A : (val map : (^T -> ^U) -> ^A -> ^A2)) = + (^A : (val map : (^T -> ^U) -> ^A -> ^A2) (f, a)) + + let v5 = map (fun x -> x + 1) [ 1 .. 100 ] +*) From 010bf0f630cbcdd6cc4e665a986790975ce813fb Mon Sep 17 00:00:00 2001 From: dsyme Date: Mon, 2 Oct 2017 19:19:49 +0100 Subject: [PATCH 16/40] fix build --- src/fsharp/ConstraintSolver.fs | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 99c90a0a4df..e0fe9310c55 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -283,6 +283,8 @@ let IsNumericOrCharTy g ty = IsNumericTy g ty || isCharTy g ty let IsRelationalTy g ty = IsNumericTy g ty || isStringTy g ty || isCharTy g ty || isBoolTy g ty let IsFpOrDecimalTy g ty = isFpTy g ty || isDecimalTy g ty let IsSignedIntegerOrFpOrDecimalTy g ty = isSignedIntegerTy g ty || IsFpOrDecimalTy g ty +let IsCharOrStringTy g ty = isCharTy g ty || isStringTy g ty +let IsNumericOrIntegralEnumOrCharOrStringTy g ty = IsNumericOrIntegralEnumTy g ty || IsCharOrStringTy g ty // Get measure of type, float<_> or float32<_> or decimal<_> but not float=float<1> or float32=float32<1> or decimal=decimal<1> let GetMeasureOfType g ty = @@ -1044,10 +1046,18 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty1 ++ (fun () -> ResultD TTraitBuiltIn)) - | false, ("op_Addition" | "op_Subtraction" | "op_Modulus"), [argty1;argty2] + | false, "op_Addition", [argty1;argty2] + when traitSupportTys |> List.exists (IsNumericOrIntegralEnumOrCharOrStringTy g) && + ( IsNumericOrIntegralEnumOrCharOrStringTy g argty1 && (permitWeakResolution || not (isTyparTy g argty2)) + || IsNumericOrIntegralEnumOrCharOrStringTy g argty2 && (permitWeakResolution || not (isTyparTy g argty1))) -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 argty1 ++ (fun () -> + SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty1 ++ (fun () -> + ResultD TTraitBuiltIn)) + + | false, ("op_Subtraction" | "op_Modulus"), [argty1;argty2] when traitSupportTys |> List.exists (IsNumericOrIntegralEnumTy g) && - ( (IsNumericOrIntegralEnumTy g argty1 || (traitName = "op_Addition" && (isCharTy g argty1 || isStringTy g argty1))) && (permitWeakResolution || not (isTyparTy g argty2)) - || (IsNumericOrIntegralEnumTy g argty2 || (traitName = "op_Addition" && (isCharTy g argty2 || isStringTy g argty2))) && (permitWeakResolution || not (isTyparTy g argty1))) -> + ( IsNumericOrIntegralEnumTy g argty1 && (permitWeakResolution || not (isTyparTy g argty2)) + || IsNumericOrIntegralEnumTy g argty2 && (permitWeakResolution || not (isTyparTy g argty1))) -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace argty2 argty1 ++ (fun () -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace traitRetTy argty1 ++ (fun () -> ResultD TTraitBuiltIn)) From 36d26e79f494f662eb9bf91530e4b179d27cdd44 Mon Sep 17 00:00:00 2001 From: dsyme Date: Mon, 2 Oct 2017 19:34:15 +0100 Subject: [PATCH 17/40] reduce diff --- src/fsharp/ConstraintSolver.fs | 21 ++++++++++----------- src/fsharp/Optimizer.fs | 4 ++-- src/fsharp/TastPickle.fs | 3 +-- src/fsharp/tast.fs | 3 +-- 4 files changed, 14 insertions(+), 17 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index e0fe9310c55..0cfb46481fa 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -1537,7 +1537,6 @@ and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace traitInfo sup // check the constraint is not already listed for this type variable // - // TODO: conside whether we need to consider equality over _valRefs as well if not (cxs |> List.exists (fun (traitInfo2, _valRefs) -> traitsAEquiv g aenv traitInfo traitInfo2)) then trace.Exec (fun () -> csenv.SolverState.ExtraCxs.Add (tpn, (traitInfo, m2))) (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) ) @@ -2616,52 +2615,52 @@ let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = let AddCxMethodConstraint denv css m trace (traitInfo : TraitConstraintInfo) = TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) true (*permitWeakResolution*)false 0 m trace traitInfo ++ (fun _ -> CompleteD)) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportNull denv css m trace ty = TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportComparison denv css m trace ty = TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportEquality denv css m trace ty = TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeMustSupportDefaultCtor denv css m trace ty = TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsReferenceType denv css m trace ty = TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsValueType denv css m trace ty = TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsUnmanaged denv css m trace ty = TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsEnum denv css m trace ty underlying = TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty underlying) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let AddCxTypeIsDelegate denv css m trace ty aty bty = TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty aty bty) - (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) + (fun res -> ErrorD (ErrorFromAddingConstraint(denv, res, m))) |> RaiseOperationResult let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:TraitConstraintInfo) argExprs = diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 978a7529c00..26733658403 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -3186,7 +3186,7 @@ and OptimizeImplFileInternal cenv env isIncrementalFragment hidden (TImplFile(qn // Entry point //------------------------------------------------------------------------- -let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementalFragment,emitTailcalls,hidden,mimpls) = +let OptimizeImplFile(settings, ccu, tcGlobals, tcVal, importMap, optEnv, isIncrementalFragment, emitTailcalls, hidden, mimpls) = let cenv = { settings=settings scope=ccu @@ -3197,7 +3197,7 @@ let OptimizeImplFile(settings,ccu,tcGlobals,tcVal, importMap,optEnv,isIncrementa localInternalVals=Dictionary(10000) emitTailcalls=emitTailcalls casApplied=new Dictionary() } - let (optEnvNew,_,_,_ as results) = OptimizeImplFileInternal cenv optEnv isIncrementalFragment hidden mimpls + let (optEnvNew, _, _, _ as results) = OptimizeImplFileInternal cenv optEnv isIncrementalFragment hidden mimpls let optimizeDuringCodeGen expr = OptimizeExpr cenv optEnvNew expr |> fst results, optimizeDuringCodeGen diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index 600c7d2770e..237206f7a33 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -1345,8 +1345,7 @@ let u_trait_sln st = let u_trait st = let a,b,c,d,e,f = u_tup6 u_typs u_string u_MemberFlags u_typs (u_option u_typ) (u_option u_trait_sln) st - // extSlns starts empty. TODO: check the ramifications of this - // ad starts as None. TODO: check the ramifications of this + // extSlns starts empty. TODO: check the ramifications of this when inlining solved trait calls from other assemblies TTrait (a, b, c, d, e, ref f, [], None) diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index c564022927c..873b965e189 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -2050,7 +2050,6 @@ and | SupportsNull of range /// Indicates a constraint that a type has a member with the given signature - // TODO: allow .NET-defined extension members to solve trait constraints. Currently only ValRefs indicating possible solutions are stored | MayResolveMember of TraitConstraintInfo * range /// Indicates a constraint that a type is a non-Nullable value type @@ -3556,7 +3555,7 @@ and + String.concat "," (List.map string tinst) + ")" | TType_fun (d,r) -> "(" + string d + " -> " + string r + ")" | TType_ucase (uc,tinst) -> "union case type " + uc.CaseName + (match tinst with [] -> "" | tys -> "<" + String.concat "," (List.map string tys) + ">") - | TType_var tp -> match tp.Solution with None -> tp.DisplayName | Some sln -> "£"+sln.ToString() + | TType_var tp -> match tp.Solution with None -> tp.DisplayName | Some sln -> "�"+sln.ToString() | TType_measure ms -> sprintf "%A" ms /// For now, used only as a discriminant in error message. From 434b0950d305a2328e5300210644b612484af66e Mon Sep 17 00:00:00 2001 From: dsyme Date: Mon, 2 Oct 2017 22:25:30 +0100 Subject: [PATCH 18/40] merge with master --- testfiles/test.fs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/testfiles/test.fs b/testfiles/test.fs index 9abec6c1560..a8862ead5e9 100644 --- a/testfiles/test.fs +++ b/testfiles/test.fs @@ -10,6 +10,20 @@ module DotNetPrimtiveWithNewOperator = let result = 1 ++ 2 +/// Extending a .NET primitive type with new operator +module DotNetPrimtiveWithAmbiguousNewOperator = + [] + module Extensions = + type System.Int32 with + static member (++)(a: int, b: int) = a + + [] + module Extensions2 = + type System.Int32 with + static member (++)(a: int, b: string) = a + + let f x = 1 ++ x + /// Extending a .NET primitive type with new _internal_ operator module DotNetPrimtiveWithInternalOperator1 = type System.Int32 with From 8b601f2517aeca74d7d73b0a533f114a53885ff6 Mon Sep 17 00:00:00 2001 From: dsyme Date: Fri, 17 Nov 2017 16:09:29 +0000 Subject: [PATCH 19/40] Fix Oddities in statically resolved method constraints and method overloading --- src/fsharp/ConstraintSolver.fs | 75 +++++++++++++++++++++++------- tests/fsharp/core/subtype/test.fsx | 34 ++++++++++++++ 2 files changed, 91 insertions(+), 18 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 0ec8f9f832a..09dc62f6151 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -938,10 +938,22 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty | None -> CompleteD -/// We do a bunch of fakery to pretend that primitive types have certain members. -/// We pretend int and other types support a number of operators. In the actual IL for mscorlib they -/// don't, however the type-directed static optimization rules in the library code that makes use of this -/// will deal with the problem. +/// Attempt to solve a statically resolved member constraint. +/// +/// 1. We do a bunch of fakery to pretend that primitive types have certain members. +/// We pretend int and other types support a number of operators. In the actual IL for mscorlib they +/// don't. The type-directed static optimization rules in the library code that makes use of this +/// will deal with the problem. +/// +/// 2. Some additional solutions are forced prior to generalization (permitWeakResolution=true). These are, roughly speaking, rules +/// for binary-operand constraints arising from constructs such as "1.0 + x" where "x" is an unknown type. THe constraint here +/// involves two type parameters - one for the left, and one for the right. The left is already known to be Double. +/// In this situation (and in the absence of other evidence prior to generalization), constraint solving forces an assumption that +/// the right is also Double - this is "weak" because there is only weak evidence for it. +/// +/// permitWeakResolution also applies to resolutions of multi-type-variable constraints via method overloads. Method overloading gets applied even if +/// only one of the two type variables is known +/// and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace (TTrait(tys, nm, memFlags, argtys, rty, sln)): OperationResult = // Do not re-solve if already solved if sln.Value.IsSome then ResultD true else @@ -999,7 +1011,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // The rule is triggered by these sorts of inputs when permitWeakResolution=true // float * 'a // 'a * float - // decimal<'u> * 'a <--- + // decimal<'u> * 'a (let checkRuleAppliesInPreferenceToMethods argty1 argty2 = // Check that at least one of the argument types is numeric (IsNumericOrIntegralEnumType g argty1) && @@ -1231,7 +1243,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // Now check if there are no feasible solutions at all match minfos, recdPropSearch with - | [], None when not (tys |> List.exists (isAnyParTy g)) -> + | [], None when MemberConstraintIsReadyForStrongResolution csenv traitInfo -> if tys |> List.exists (isFunTy g) then ErrorD (ConstraintSolverError(FSComp.SR.csExpectTypeWithOperatorButGivenFunction(DecompileOpName nm), m, m2)) elif tys |> List.exists (isAnyTupleTy g) then @@ -1298,8 +1310,10 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p let support = GetSupportOfMemberConstraint csenv traitInfo let frees = GetFreeTyparsOfMemberConstraint csenv traitInfo - // If there's nothing left to learn then raise the errors - (if (permitWeakResolution && isNil support) || isNil frees then errors + // If there's nothing left to learn then raise the errors. + // Note: we should likely call MemberConstraintIsReadyForResolution here when permitWeakResolution=false but for stability + // reasons we use the more restrictive isNil frees. + (if (permitWeakResolution && MemberConstraintIsReadyForWeakResolution csenv traitInfo) || isNil frees then errors // Otherwise re-record the trait waiting for canonicalization else AddMemberConstraint csenv ndeep m2 trace traitInfo support frees) ++ (fun () -> match errors with @@ -1384,7 +1398,7 @@ and TransactMemberConstraintSolution traitInfo (trace:OptionalTrace) sln = /// That is, don't perform resolution if more nominal information may influence the set of available overloads and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution nm (TTrait(tys, _, memFlags, argtys, rty, soln) as traitInfo): MethInfo list = let results = - if permitWeakResolution || isNil (GetSupportOfMemberConstraint csenv traitInfo) then + if MemberConstraintSupportIsReadyForDeterminingOverloads permitWeakResolution csenv traitInfo then let m = csenv.m let minfos = match memFlags.MemberKind with @@ -1392,20 +1406,19 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution tys |> List.map (GetIntrinsicConstructorInfosOfType csenv.SolverState.InfoReader m) | _ -> tys |> List.map (GetIntrinsicMethInfosOfType csenv.SolverState.InfoReader (Some nm, AccessibleFromSomeFSharpCode, AllowMultiIntfInstantiations.Yes) IgnoreOverrides m) - /// Merge the sets so we don't get the same minfo from each side - /// We merge based on whether minfos use identical metadata or not. - /// REVIEW: Consider the pathological cases where this may cause a loss of distinction - /// between potential overloads because a generic instantiation derived from the left hand type differs - /// to a generic instantiation for an operator based on the right hand type. - + // Merge the sets so we don't get the same minfo from each side + // We merge based on whether minfos use identical metadata or not. let minfos = List.reduce (ListSet.unionFavourLeft MethInfo.MethInfosUseIdenticalDefinitions) minfos - minfos + if minfos.Length <= 1 || MemberConstraintSignatureIsReadyForResolution csenv traitInfo then + minfos + else + [] // nothing available yet, there are overloads and the signature has not been fully determined else [] // The trait name "op_Explicit" also covers "op_Implicit", so look for that one too. if nm = "op_Explicit" then - results @ GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln)) + results @ GetRelevantMethodsForTrait csenv permitWeakResolution "op_Implicit" (TTrait(tys, "op_Implicit", memFlags, argtys, rty, soln)) else results @@ -1414,10 +1427,36 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution and GetSupportOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _)) = tys |> List.choose (tryAnyParTy csenv.g) -/// All the typars relevant to the member constraint *) +/// Check if the support is fully solved. +and SupportOfMemberConstraintIsFullySolved (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _)) = + tys |> List.forall (isAnyParTy csenv.g >> not) + +/// Check if some part of the support is solved. +and SupportOfMemberConstraintIsPartiallySolved (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _)) = + tys |> List.exists (isAnyParTy csenv.g >> not) + +/// All the typars relevant to the member constraint and GetFreeTyparsOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, argtys, rty, _)) = freeInTypesLeftToRightSkippingConstraints csenv.g (tys@argtys@ Option.toList rty) +/// Check all the statically-resolved type parameters in the trait method signature are solved. +/// This is necessary to prevent overload resolution being applied to statically resolved members +// constraints before all argument and return types are known. +and MemberConstraintSignatureIsReadyForResolution csenv traitInfo = + GetFreeTyparsOfMemberConstraint csenv traitInfo |> List.forall (fun tp -> match tp.StaticReq with HeadTypeStaticReq -> false | _ -> true) + +and MemberConstraintIsReadyForWeakResolution csenv traitInfo = + SupportOfMemberConstraintIsPartiallySolved csenv traitInfo && + MemberConstraintSignatureIsReadyForResolution csenv traitInfo + +and MemberConstraintIsReadyForStrongResolution csenv traitInfo = + SupportOfMemberConstraintIsFullySolved csenv traitInfo && + MemberConstraintSignatureIsReadyForResolution csenv traitInfo + +and MemberConstraintSupportIsReadyForDeterminingOverloads permitWeakResolution csenv traitInfo = + (permitWeakResolution && SupportOfMemberConstraintIsPartiallySolved csenv traitInfo) + || SupportOfMemberConstraintIsFullySolved 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. diff --git a/tests/fsharp/core/subtype/test.fsx b/tests/fsharp/core/subtype/test.fsx index db98179a6d7..0ab18326ca1 100644 --- a/tests/fsharp/core/subtype/test.fsx +++ b/tests/fsharp/core/subtype/test.fsx @@ -1744,6 +1744,40 @@ module GenericPropertyConstraintSolvedByRecord = let v = print_foo_memb { foo=1 } + +/// In this case, the presence of the Method(obj) overload meant overload resolution was being applied and resolving to that +/// overload, even before the full signature of the trait constraint was known. +module MethodOverloadingForTraitConstraintsIsNotDeterminedUntilSignatureIsKnnown = + type X = + static member Method (a: obj) = 1 + static member Method (a: int) = 2 + static member Method (a: int64) = 3 + + + let inline Test< ^t, ^a when ^t: (static member Method: ^a -> int)> (value: ^a) = + ( ^t: (static member Method: ^a -> int)(value)) + + let inline Test2< ^t> a = Test a + + check "slvde0vver90u" (Test2 0) 2 + +/// In this case, the presence of the "Equals" method on System.Object was causing method overloading to be resolved too +/// early, when ^t was not yet known. The underlying problem was that we were proceeding with weak resolution +/// even for a single-support-type trait constraint. +module MethodOverloadingForTraitConstraintsWhereSomeMethodsComeFromObjectTypeIsNotDeterminedTooEarly = + type Test() = + member __.Equals (_: Test) = true + + let inline Equals(a: obj) (b: ^t) = + match a with + | :? ^t as x -> (^t: (member Equals: ^t -> bool) (b, x)) + | _-> false + + let a = Test() + let b = Test() + + check "cewjewcwec09ew" (Equals a b) true + module SRTPFix = open System From 77447d6b85f779ee515727d9e7521082870387cb Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 18 Nov 2017 14:41:05 +0000 Subject: [PATCH 20/40] no return type needed before proceeding to overload resolution --- src/fsharp/ConstraintSolver.fs | 11 ++++++----- tests/fsharp/core/subtype/test.fsx | 23 +++++++++++++++++++++++ 2 files changed, 29 insertions(+), 5 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 09dc62f6151..71e7fb74a57 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -1435,15 +1435,16 @@ and SupportOfMemberConstraintIsFullySolved (csenv:ConstraintSolverEnv) (TTrait(t and SupportOfMemberConstraintIsPartiallySolved (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, _, _, _)) = tys |> List.exists (isAnyParTy csenv.g >> not) -/// All the typars relevant to the member constraint +/// Get all the unsolved typars (statically resolved or not) relevant to the member constraint and GetFreeTyparsOfMemberConstraint (csenv:ConstraintSolverEnv) (TTrait(tys, _, _, argtys, rty, _)) = freeInTypesLeftToRightSkippingConstraints csenv.g (tys@argtys@ Option.toList rty) -/// Check all the statically-resolved type parameters in the trait method signature are solved. +/// Check there are no unsolved statically-resolved type parameters in the argument types of the trait method signature. /// This is necessary to prevent overload resolution being applied to statically resolved members -// constraints before all argument and return types are known. -and MemberConstraintSignatureIsReadyForResolution csenv traitInfo = - GetFreeTyparsOfMemberConstraint csenv traitInfo |> List.forall (fun tp -> match tp.StaticReq with HeadTypeStaticReq -> false | _ -> true) +// constraints before all argument types are known. The return type is not taken into account. +and MemberConstraintSignatureIsReadyForResolution csenv (TTrait(tys, _, _, argtys, _, _)) = + let typarsRelevantToOverloadResultion = freeInTypesLeftToRightSkippingConstraints csenv.g (tys@argtys) + typarsRelevantToOverloadResultion |> List.forall (fun tp -> match tp.StaticReq with HeadTypeStaticReq -> false | _ -> true) and MemberConstraintIsReadyForWeakResolution csenv traitInfo = SupportOfMemberConstraintIsPartiallySolved csenv traitInfo && diff --git a/tests/fsharp/core/subtype/test.fsx b/tests/fsharp/core/subtype/test.fsx index 0ab18326ca1..1aaa90a4fb5 100644 --- a/tests/fsharp/core/subtype/test.fsx +++ b/tests/fsharp/core/subtype/test.fsx @@ -232,8 +232,31 @@ module SomeRandomOperatorConstraints = begin let f2 x : float = x * x let f3 x (y:float) = x * y + //let neg4 x (y:System.DateTime) = x + y + + // This example resolves the type of "y" to "TimeSpam". It checks that a single "+" overload between + // two different types DateTime andd TimeSpan gets resolved via + // vis weak SRTP resolution using a DateTime constraint alone. let f5 (x:DateTime) y = x + y + + // This example checks a use of TimeSpan/DateTime overloads + let f5b (x:DateTime) (y:DateTime) = (x - y) + + + // This example checks a use of TimeSpan/DateTime overloads + let f5b2 (x:DateTime) (y:TimeSpan) = (x - y) + + // This example coincidentally checks that the return type is not taken into account before th list of method overloads + // is prepared in SRTP resolution. That is the type of (a - b) is immediately known (and we can use it for + // dot-notation name resolution of .TotalSeconds) _immediately_ that the types of a and b are + // known and _prior_ to generalization. + let f5c (x: DateTime) (y:DateTime) = + (x - y).TotalSeconds |> int + + let f5c2 (x: DateTime) (y:TimeSpan) = + (x - y).Second |> int + let f6 (x:int64) y = x + y let f7 x y : int64 = x + y let f8 x = Seq.reduce (+) x From c67437df1bd6e33ce5f1477cad19a1388f36d90c Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 18 Nov 2017 17:34:55 +0000 Subject: [PATCH 21/40] fix tests --- tests/fsharp/core/members/basics-hw-mutrec/test.fs | 8 ++++---- tests/fsharp/core/members/basics-hw/test.fsx | 8 ++++---- tests/fsharp/core/members/basics/test.fs | 6 +++--- tests/fsharp/core/members/ops-mutrec/test.fs | 11 +++++------ tests/fsharp/core/members/ops/test.fsx | 10 +++++----- tests/fsharp/typecheck/sigs/neg99.bsl | 2 +- tests/fsharp/typecheck/sigs/neg99.fs | 2 +- 7 files changed, 23 insertions(+), 24 deletions(-) diff --git a/tests/fsharp/core/members/basics-hw-mutrec/test.fs b/tests/fsharp/core/members/basics-hw-mutrec/test.fs index c3421cee247..cf57a0a5929 100644 --- a/tests/fsharp/core/members/basics-hw-mutrec/test.fs +++ b/tests/fsharp/core/members/basics-hw-mutrec/test.fs @@ -1606,9 +1606,9 @@ module MultipleOverloadedOperatorTests = begin let f1 (x:DateTime) (y:TimeSpan) : DateTime = x - y let g1 (x:DateTime) (y:DateTime) : TimeSpan = x - y - // Return type is also sufficient: - let f2 (x:DateTime) y : DateTime = x - y - let g2 (x:DateTime) y : TimeSpan = x - y + // // Return type is not sufficient: + // let f2 (x:DateTime) y : DateTime = x - y + // let g2 (x:DateTime) y : TimeSpan = x - y // Just argument types are also sufficient: let f3 (x:DateTime) (y:TimeSpan) = x - y let g3 (x:DateTime) (y:DateTime) = x - y @@ -5549,7 +5549,7 @@ module Devdiv2_Bug_5385 = g "1" |> ignore; // note, use of non-generic 'g' within a generic, generalized memoized function 2 - and g : string -> int = memoize f // note, computed function value using generic “f” at an instance + and g : string -> int = memoize f // note, computed function value using generic �f� at an instance g "1" let res = test3e() diff --git a/tests/fsharp/core/members/basics-hw/test.fsx b/tests/fsharp/core/members/basics-hw/test.fsx index 2b807659d9a..bb01d42de51 100644 --- a/tests/fsharp/core/members/basics-hw/test.fsx +++ b/tests/fsharp/core/members/basics-hw/test.fsx @@ -1621,9 +1621,9 @@ module MultipleOverloadedOperatorTests = begin let f1 (x:DateTime) (y:TimeSpan) : DateTime = x - y let g1 (x:DateTime) (y:DateTime) : TimeSpan = x - y - // Return type is also sufficient: - let f2 (x:DateTime) y : DateTime = x - y - let g2 (x:DateTime) y : TimeSpan = x - y + // // Return type is not sufficient: + // let f2 (x:DateTime) y : DateTime = x - y + // let g2 (x:DateTime) y : TimeSpan = x - y // Just argument types are also sufficient: let f3 (x:DateTime) (y:TimeSpan) = x - y let g3 (x:DateTime) (y:DateTime) = x - y @@ -5584,7 +5584,7 @@ module Devdiv2_Bug_5385 = g "1" |> ignore; // note, use of non-generic 'g' within a generic, generalized memoized function 2 - and g : string -> int = memoize f // note, computed function value using generic “f” at an instance + and g : string -> int = memoize f // note, computed function value using generic �f� at an instance g "1" let res = test3e() diff --git a/tests/fsharp/core/members/basics/test.fs b/tests/fsharp/core/members/basics/test.fs index 5066bdf6ad0..267087eb51d 100644 --- a/tests/fsharp/core/members/basics/test.fs +++ b/tests/fsharp/core/members/basics/test.fs @@ -1910,9 +1910,9 @@ module MultipleOverloadedOperatorTests = begin let f1 (x:DateTime) (y:TimeSpan) : DateTime = x - y let g1 (x:DateTime) (y:DateTime) : TimeSpan = x - y - // Return type is also sufficient: - let f2 (x:DateTime) y : DateTime = x - y - let g2 (x:DateTime) y : TimeSpan = x - y + // Return type is not sufficient: + //let f2 (x:DateTime) y : DateTime = x - y + //let g2 (x:DateTime) y : TimeSpan = x - y // Just argument types are also sufficient: let f3 (x:DateTime) (y:TimeSpan) = x - y let g3 (x:DateTime) (y:DateTime) = x - y diff --git a/tests/fsharp/core/members/ops-mutrec/test.fs b/tests/fsharp/core/members/ops-mutrec/test.fs index 1fa82e5c373..b944fcc2d77 100644 --- a/tests/fsharp/core/members/ops-mutrec/test.fs +++ b/tests/fsharp/core/members/ops-mutrec/test.fs @@ -214,19 +214,18 @@ module BasicOverloadTests = // This gets type int -> int let f5 x = 1 - x - // This gets type DateTime -> DateTime -> TimeSpan, through non-conservative resolution. - let f6 x1 (x2:System.DateTime) = x1 - x2 + // // This gets type DateTime -> DateTime -> TimeSpan, through non-conservative resolution. + // let f6 x1 (x2:System.DateTime) = x1 - x2 - // This gets type TimeSpan -> TimeSpan -> TimeSpan, through non-conservative resolution. + // This gets type TimeSpan -> TimeSpan -> TimeSpan, through default type propagation let f7 x1 (x2:System.TimeSpan) = x1 - x2 - // This gets type TimeSpan -> TimeSpan -> TimeSpan, through non-conservative resolution. + // This gets type TimeSpan -> TimeSpan -> TimeSpan, through default type propagation let f8 x1 (x2:System.TimeSpan) = x2 - x1 - // This gets type TimeSpan -> TimeSpan -> TimeSpan, through non-conservative resolution. + // This gets type TimeSpan -> TimeSpan -> TimeSpan, through default type propagation let f9 (x1:System.TimeSpan) x2 = x1 - x2 - // This gets type TimeSpan -> TimeSpan -> TimeSpan let f10 x1 (x2:System.TimeSpan) = x1 + x2 diff --git a/tests/fsharp/core/members/ops/test.fsx b/tests/fsharp/core/members/ops/test.fsx index d4756db4233..6f943dce8f2 100644 --- a/tests/fsharp/core/members/ops/test.fsx +++ b/tests/fsharp/core/members/ops/test.fsx @@ -219,16 +219,16 @@ module BasicOverloadTests = // This gets type int -> int let f5 x = 1 - x - // This gets type DateTime -> DateTime -> TimeSpan, through non-conservative resolution. - let f6 x1 (x2:System.DateTime) = x1 - x2 + // // This gets type DateTime -> DateTime -> TimeSpan, through non-conservative resolution. + // let f6 x1 (x2:System.DateTime) = x1 - x2 - // This gets type TimeSpan -> TimeSpan -> TimeSpan, through non-conservative resolution. + // This gets type TimeSpan -> TimeSpan -> TimeSpan, through default type propagation let f7 x1 (x2:System.TimeSpan) = x1 - x2 - // This gets type TimeSpan -> TimeSpan -> TimeSpan, through non-conservative resolution. + // This gets type TimeSpan -> TimeSpan -> TimeSpan, through default type propagation let f8 x1 (x2:System.TimeSpan) = x2 - x1 - // This gets type TimeSpan -> TimeSpan -> TimeSpan, through non-conservative resolution. + // This gets type TimeSpan -> TimeSpan -> TimeSpan, through default type propagation let f9 (x1:System.TimeSpan) x2 = x1 - x2 diff --git a/tests/fsharp/typecheck/sigs/neg99.bsl b/tests/fsharp/typecheck/sigs/neg99.bsl index 9f6010f249d..40bea962e9c 100644 --- a/tests/fsharp/typecheck/sigs/neg99.bsl +++ b/tests/fsharp/typecheck/sigs/neg99.bsl @@ -3,4 +3,4 @@ neg99.fs(19,16,19,64): typecheck error FS0077: Member constraints with the name neg99.fs(22,18,22,64): typecheck error FS0077: Member constraints with the name 'op_Explicit' are given special status by the F# compiler as certain .NET types are implicitly augmented with this member. This may result in runtime failures if you attempt to invoke the member constraint from your own code. -neg99.fs(25,39,25,43): typecheck error FS0043: The type 'CrashFSC.OhOh.MyByte' does not support a conversion to the type 'CrashFSC.OhOh.MyByte' +neg99.fs(25,39,25,43): typecheck error FS0043: The type 'CrashFSC.OhOh.MyByte' does not support a conversion to the type ''a' \ No newline at end of file diff --git a/tests/fsharp/typecheck/sigs/neg99.fs b/tests/fsharp/typecheck/sigs/neg99.fs index 6c3007c74ab..b7d248f13ab 100644 --- a/tests/fsharp/typecheck/sigs/neg99.fs +++ b/tests/fsharp/typecheck/sigs/neg99.fs @@ -12,7 +12,7 @@ module OhOh = static member inline op_Explicit (x: int64): MyByte = MyByte (byte x) static member inline op_Explicit (x: float): MyByte = MyByte (byte x) - static member inline op_Explicit (MyByte x): 'a = failwith "cannot convert" + //static member inline op_Explicit (MyByte x): 'a = failwith "cannot convert" /// testing testing let inline ( !>>> ) (a: ^a) min: ^b option = From 4ca7ea8395f1934b4381358498f567cbf84db6f7 Mon Sep 17 00:00:00 2001 From: dsyme Date: Fri, 1 Dec 2017 16:25:57 +0000 Subject: [PATCH 22/40] minimize diff --- src/fsharp/Fsc/Fsc.fsproj | 1 - 1 file changed, 1 deletion(-) diff --git a/src/fsharp/Fsc/Fsc.fsproj b/src/fsharp/Fsc/Fsc.fsproj index b33648a34be..3fbc85539b5 100644 --- a/src/fsharp/Fsc/Fsc.fsproj +++ b/src/fsharp/Fsc/Fsc.fsproj @@ -51,7 +51,6 @@ - From fa3136789771d4dc6654c3b13a41750c8c6595f5 Mon Sep 17 00:00:00 2001 From: dsyme Date: Fri, 1 Dec 2017 16:26:49 +0000 Subject: [PATCH 23/40] minimize diff --- src/fsharp/Fsc/Fsc.fsproj | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/fsharp/Fsc/Fsc.fsproj b/src/fsharp/Fsc/Fsc.fsproj index 3fbc85539b5..1a029c02289 100644 --- a/src/fsharp/Fsc/Fsc.fsproj +++ b/src/fsharp/Fsc/Fsc.fsproj @@ -46,18 +46,18 @@ default.win32manifest PreserveNewest - - - - - - - - - - + + + + + + + + - + + + {2E4D67B4-522D-4CF7-97E4-BA940F0B18F3} FSharp.Compiler.Private From 281e1f01fa01ae81a656eccc8ad821a65843b481 Mon Sep 17 00:00:00 2001 From: dsyme Date: Fri, 1 Dec 2017 16:27:33 +0000 Subject: [PATCH 24/40] minimize diff --- src/fsharp/Fsc/Fsc.fsproj | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/fsharp/Fsc/Fsc.fsproj b/src/fsharp/Fsc/Fsc.fsproj index 1a029c02289..9fd7a8a2351 100644 --- a/src/fsharp/Fsc/Fsc.fsproj +++ b/src/fsharp/Fsc/Fsc.fsproj @@ -47,14 +47,15 @@ PreserveNewest + - - + + - + @@ -79,4 +80,4 @@ - + From 58787bd76ea33fe74f63cb6a63672dd766d7e598 Mon Sep 17 00:00:00 2001 From: dsyme Date: Fri, 1 Dec 2017 16:28:02 +0000 Subject: [PATCH 25/40] minimize diff --- src/fsharp/Fsc/Fsc.fsproj | 1 + 1 file changed, 1 insertion(+) diff --git a/src/fsharp/Fsc/Fsc.fsproj b/src/fsharp/Fsc/Fsc.fsproj index 9fd7a8a2351..127f1c4753a 100644 --- a/src/fsharp/Fsc/Fsc.fsproj +++ b/src/fsharp/Fsc/Fsc.fsproj @@ -1,6 +1,7 @@ + $(MSBuildProjectDirectory)\..\.. From 1f325a833c70d9c1de9d23e029548fa184ba1eaa Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 26 Feb 2019 15:52:54 +0000 Subject: [PATCH 26/40] reduce diff --- src/fsharp/ConstraintSolver.fs | 68 +++++++++++++++------------------- src/fsharp/TypeChecker.fs | 61 +++++++++++++++--------------- src/fsharp/TypeRelations.fs | 2 +- 3 files changed, 61 insertions(+), 70 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 9605c340dde..c429d3b5aed 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -290,17 +290,11 @@ let isFpTy g ty = let isDecimalTy g ty = typeEquivAux EraseMeasures g g.decimal_ty ty -let IsNonDecimalNumericOrIntegralEnumTy g ty = isIntegerOrIntegerEnumTy g ty || isFpTy g ty -let IsIntegerOrEnumTy g ty = isIntegerOrIntegerEnumTy g ty || isEnumTy g ty -let IsNumericOrIntegralEnumTy g ty = IsNonDecimalNumericOrIntegralEnumTy g ty || isDecimalTy g ty -let IsNonDecimalNumericTy g ty = isIntegerTy g ty || isFpTy g ty -let IsNumericTy g ty = IsNonDecimalNumericTy g ty || isDecimalTy g ty -let IsNumericOrCharTy g ty = IsNumericTy g ty || isCharTy g ty -let IsRelationalTy g ty = IsNumericTy g ty || isStringTy g ty || isCharTy g ty || isBoolTy g ty -let IsFpOrDecimalTy g ty = isFpTy g ty || isDecimalTy g ty -let IsSignedIntegerOrFpOrDecimalTy g ty = isSignedIntegerTy g ty || IsFpOrDecimalTy g ty -let IsCharOrStringTy g ty = isCharTy g ty || isStringTy g ty -let IsNumericOrIntegralEnumOrCharOrStringTy g ty = IsNumericOrIntegralEnumTy g ty || IsCharOrStringTy g ty +let IsNonDecimalNumericOrIntegralEnumType g ty = isIntegerOrIntegerEnumTy g ty || isFpTy g ty +let IsNumericOrIntegralEnumType g ty = IsNonDecimalNumericOrIntegralEnumType g ty || isDecimalTy g ty +let IsNonDecimalNumericType g ty = isIntegerTy g ty || isFpTy g ty +let IsNumericType g ty = IsNonDecimalNumericType g ty || isDecimalTy g ty +let IsRelationalType g ty = IsNumericType g ty || isStringTy g ty || isCharTy g ty || isBoolTy g ty // Get measure of type, float<_> or float32<_> or decimal<_> but not float=float<1> or float32=float32<1> or decimal=decimal<1> let GetMeasureOfType g ty = @@ -750,7 +744,6 @@ let rec SolveTyparEqualsType (csenv:ConstraintSolverEnv) ndeep m2 (trace:Optiona // If so, re-solve the relevant constraints. if csenv.SolverState.ExtraCxs.ContainsKey r.Stamp then do! RepeatWhileD ndeep (fun ndeep -> SolveRelevantMemberConstraintsForTypar csenv ndeep false trace r) - // Re-solve the other constraints associated with this type variable return! solveTypMeetsTyparConstraints csenv ndeep m2 trace ty r @@ -1040,7 +1033,7 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty /// only one of the two type variables is known /// and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace traitInfo : OperationResult = trackErrors { - let (TTrait(tys, nm, memFlags, traitObjAndArgTys, rty, sln, extSlns, traitAD)) = traitInfo + let (TTrait(tys, nm, memFlags, argtys, rty, sln, extSlns, traitAD)) = traitInfo // Do not re-solve if already solved if sln.Value.IsSome then return true else let g = csenv.g @@ -1055,20 +1048,20 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p let tys = ListSet.setify (typeAEquiv g aenv) tys // Rebuild the trait info after removing duplicates - let traitInfo = TTrait(tys, nm, memFlags, traitObjAndArgTys, rty, sln, extSlns, traitAD) + let traitInfo = TTrait(tys, nm, memFlags, argtys, rty, sln, extSlns, traitAD) let rty = GetFSharpViewOfReturnType g rty let traitAD = match traitAD with None -> AccessibilityLogic.AccessibleFromEverywhere | Some ad -> (ad :?> AccessorDomain) // Assert the object type if the constraint is for an instance member if memFlags.IsInstance then - match tys, traitObjAndArgTys with + match tys, argtys with | [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 trace HeadTypeStaticReq e - let argtys = if memFlags.IsInstance then List.tail traitObjAndArgTys else traitObjAndArgTys + let argtys = if memFlags.IsInstance then List.tail argtys else argtys let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo let! res = @@ -1101,7 +1094,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // decimal<'u> * 'a (let checkRuleAppliesInPreferenceToMethods argty1 argty2 = // Check that at least one of the argument types is numeric - (IsNumericOrIntegralEnumTy g argty1) && + (IsNumericOrIntegralEnumType g argty1) && // Check that the support of type variables is empty. That is, // if we're canonicalizing, then having one of the types nominal is sufficient. // If not, then both must be nominal (i.e. not a type variable). @@ -1110,7 +1103,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // - Neither type contributes any methods OR // - We have the special case "decimal<_> * decimal". In this case we have some // possibly-relevant methods from "decimal" but we ignore them in this case. - (isNil minfos || IsNumericOrIntegralEnumTy g argty2 || (Option.isSome (GetMeasureOfType g argty1) && isDecimalTy g argty2)) + (isNil minfos || IsNumericOrIntegralEnumType g argty2 || (Option.isSome (GetMeasureOfType g argty1) && isDecimalTy g argty2)) checkRuleAppliesInPreferenceToMethods argty1 argty2 || checkRuleAppliesInPreferenceToMethods argty2 argty1) -> @@ -1136,8 +1129,8 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p | _, _, false, ("op_Addition" | "op_Subtraction" | "op_Modulus"), [argty1;argty2] when // Ignore any explicit +/- overloads from any basic integral types (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.ApparentEnclosingType ) && - ( (IsNumericOrIntegralEnumTy g argty1 || (nm = "op_Addition" && (isCharTy g argty1 || isStringTy g argty1))) && (permitWeakResolution || not (isTyparTy g argty2)) - || (IsNumericOrIntegralEnumTy g argty2 || (nm = "op_Addition" && (isCharTy g argty2 || isStringTy g argty2))) && (permitWeakResolution || not (isTyparTy g argty1)))) -> + ( (IsNumericOrIntegralEnumType g argty1 || (nm = "op_Addition" && (isCharTy g argty1 || isStringTy g argty1))) && (permitWeakResolution || not (isTyparTy g argty2)) + || (IsNumericOrIntegralEnumType g argty2 || (nm = "op_Addition" && (isCharTy g argty2 || isStringTy g argty2))) && (permitWeakResolution || not (isTyparTy g argty1)))) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn @@ -1145,8 +1138,8 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p | _, _, false, ("op_LessThan" | "op_LessThanOrEqual" | "op_GreaterThan" | "op_GreaterThanOrEqual" | "op_Equality" | "op_Inequality" ), [argty1;argty2] when // Ignore any explicit overloads from any basic integral types (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.ApparentEnclosingType ) && - ( (IsRelationalTy g argty1 && (permitWeakResolution || not (isTyparTy g argty2))) - || (IsRelationalTy g argty2 && (permitWeakResolution || not (isTyparTy g argty1))))) -> + ( (IsRelationalType g argty1 && (permitWeakResolution || not (isTyparTy g argty2))) + || (IsRelationalType g argty2 && (permitWeakResolution || not (isTyparTy g argty1))))) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.bool_ty return TTraitBuiltIn @@ -1154,12 +1147,12 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // 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 IsNumericTy g ty -> + when IsNumericType g ty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ty return TTraitBuiltIn | [], [ty], false, "get_One", [] - when IsNumericTy g ty || isCharTy g ty -> + when IsNumericType g ty || isCharTy g ty -> do! SolveDimensionlessNumericType csenv ndeep m2 trace ty do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ty return TTraitBuiltIn @@ -1217,7 +1210,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p return TTraitBuiltIn | _, _, false, ("op_UnaryPlus"), [argty] - when IsNumericOrIntegralEnumTy g argty -> + when IsNumericOrIntegralEnumType g argty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn @@ -1269,9 +1262,9 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p // Simulate solutions to op_Implicit and op_Explicit | _, _, false, "op_Explicit", [argty] when (// The input type. - (IsNonDecimalNumericOrIntegralEnumTy g argty || isStringTy g argty || isCharTy g argty) && + (IsNonDecimalNumericOrIntegralEnumType g argty || isStringTy g argty || isCharTy g argty) && // The output type - (IsNonDecimalNumericOrIntegralEnumTy g rty || isCharTy g rty) && + (IsNonDecimalNumericOrIntegralEnumType g rty || isCharTy g rty) && // Exclusion: IntPtr and UIntPtr do not support .Parse() from string not (isStringTy g argty && isNativeIntegerTy g rty) && // Exclusion: No conversion from char to decimal @@ -1282,14 +1275,14 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p | _, _, false, "op_Explicit", [argty] when (// The input type. - (IsNumericOrIntegralEnumTy g argty || isStringTy g argty) && + (IsNumericOrIntegralEnumType g argty || isStringTy g argty) && // The output type (isDecimalTy g rty)) -> return TTraitBuiltIn | _, _, false, "Pow", [argty1; argty2] - when tys |> List.exists (isFpTy g) -> + when isFpTy g argty1 -> do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 @@ -1297,7 +1290,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p return TTraitBuiltIn | _, _, false, "Atan2", [argty1; argty2] - when tys |> List.exists (isFpTy g) -> + when isFpTy g argty1 -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 match GetMeasureOfType g argty1 with @@ -1385,7 +1378,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p let callerArgs = argtys |> List.map (fun argty -> CallerArg(argty, m, false, dummyExpr)) let minst = FreshenMethInfo None m minfo //let objtys = minfo.GetObjArgTypes(amap, m, minst) - let callerObjTys = if memFlags.IsInstance then [ List.head traitObjAndArgTys ] else [] + let callerObjTys = if memFlags.IsInstance then [ List.head argtys ] else [] Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo None, m, traitAD, minfo, minst, minst, None, callerObjTys, [(callerArgs, [])], false, false, None))) let methOverloadResult, errors = @@ -1460,7 +1453,7 @@ and RecordMemberConstraintSolution css m trace traitInfo res = ResultD true | TTraitSolvedRecdProp (rfinfo, isSet) -> - let sln = FSRecdFieldSln(rfinfo.TypeInst, rfinfo.RecdFieldRef, isSet) + let sln = FSRecdFieldSln(rfinfo.TypeInst,rfinfo.RecdFieldRef,isSet) TransactMemberConstraintSolution traitInfo trace sln; ResultD true @@ -1623,7 +1616,7 @@ and SolveRelevantMemberConstraintsForTypar (csenv:ConstraintSolverEnv) ndeep per SolveMemberConstraint csenv true permitWeakResolution (ndeep+1) m2 trace traitInfo) and CanonicalizeRelevantMemberConstraints (csenv:ConstraintSolverEnv) ndeep trace tps = - SolveRelevantMemberConstraints csenv ndeep (*permitWeakResolution*)true trace tps + SolveRelevantMemberConstraints csenv ndeep true trace tps and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) traitInfo support (frees: Typar list) = let g = csenv.g @@ -1640,7 +1633,6 @@ and AddMemberConstraint (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTra let cxs = cxst.FindAll tpn // check the constraint is not already listed for this type variable - // if not (cxs |> List.exists (fun (traitInfo2, _valRefs) -> traitsAEquiv g aenv traitInfo traitInfo2)) then trace.Exec (fun () -> csenv.SolverState.ExtraCxs.Add (tpn, (traitInfo, m2))) (fun () -> csenv.SolverState.ExtraCxs.Remove tpn) ) @@ -1739,8 +1731,8 @@ and AddConstraint (csenv:ConstraintSolverEnv) ndeep m2 trace tp newConstraint = // If it does occur, e.g. at instantiation T2, then the check above will have enforced that // T2 = ty2 let implies tpc1 tpc2 = - match tpc1,tpc2 with - | TyparConstraint.MayResolveMember(trait1, _), + match tpc1, tpc2 with + | TyparConstraint.MayResolveMember(trait1, _), TyparConstraint.MayResolveMember(trait2, _) -> traitsAEquiv g aenv trait1 trait2 @@ -2790,7 +2782,7 @@ let CodegenWitnessThatTypeSupportsTraitConstraint tcVal g amap m (traitInfo:Trai amap = amap TcVal = tcVal ExtraCxs = HashMultiMap(10, HashIdentity.Structural) - InfoReader = new InfoReader(g,amap) } + InfoReader = new InfoReader(g, amap) } let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) let! _res = SolveMemberConstraint csenv true true 0 m NoTrace traitInfo @@ -2910,7 +2902,7 @@ let CodegenWitnessThatTypeSupportsTraitConstraint tcVal g amap m (traitInfo:Trai let ChooseTyparSolutionAndSolve css denv tp = let g = css.g let amap = css.amap - let max,m = ChooseTyparSolutionAndRange g amap tp + let max, m = ChooseTyparSolutionAndRange g amap tp let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv TryD (fun () -> SolveTyparEqualsType csenv 0 m NoTrace (mkTyparTy tp) max) (fun err -> ErrorD(ErrorFromApplyingDefault(g, denv, tp, max, err, m))) diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index d78cf4eed0f..981168aa3cf 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -7286,7 +7286,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv match interpExpr with | Expr.Val(vf, _, m) -> let item = Item.CustomBuilder (vf.DisplayName, vf) - CallNameResolutionSink cenv.tcSink (m, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) + CallNameResolutionSink cenv.tcSink (m, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) valRefEq cenv.g vf cenv.g.query_value_vref | _ -> false @@ -7516,7 +7516,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv | IntoSuffix (x, intoWordRange, intoPat) -> // record the "into" as a custom operation for colorization let item = Item.CustomOperation ("into", (fun () -> None), None) - CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) + CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) (x, intoPat, alreadyGivenError) | _ -> if not alreadyGivenError then @@ -7650,7 +7650,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv match optInto with | Some (intoWordRange, optInfo) -> let item = Item.CustomOperation ("into", (fun () -> None), None) - CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) + CallNameResolutionSink cenv.tcSink (intoWordRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) Some optInfo | None -> None @@ -7785,7 +7785,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv // FUTURE: consider whether we can do better than emptyTyparInst here, in order to display instantiations // of type variables in the quick info provided in the IDE. - CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) + CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) let mkJoinExpr keySelector1 keySelector2 innerPat e = let mSynthetic = mOpCore.MakeSynthetic() @@ -7981,7 +7981,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv // FUTURE: consider whether we can do better than emptyTyparInst here, in order to display instantiations // of type variables in the quick info provided in the IDE. - CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) + CallNameResolutionSink cenv.tcSink (nm.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) if isLikeZip || isLikeJoin || isLikeGroupJoin then errorR(Error(FSComp.SR.tcBinaryOperatorRequiresBody(nm.idText, Option.get (customOpUsageText nm)), nm.idRange)) @@ -8583,7 +8583,7 @@ and TcDelayed cenv overallTy env tpenv mExpr expr exprty (atomicFlag:ExprAtomicF // OK, we've typechecked the thing on the left of the delayed lookup chain. // We can now record for posterity the type of this expression and the location of the expression. if (atomicFlag = ExprAtomicFlag.Atomic) then - CallExprHasTypeSink cenv.tcSink (mExpr, env.NameEnv, exprty, env.DisplayEnv, env.AccessRights) + CallExprHasTypeSink cenv.tcSink (mExpr, env.NameEnv, exprty, env.DisplayEnv, env.eAccessRights) match delayed with | [] @@ -8669,7 +8669,7 @@ and TcFunctionApplicationThen cenv overallTy env tpenv mExprAndArg expr exprty ( and TcLongIdentThen cenv overallTy env tpenv (LongIdentWithDots(longId, _)) delayed = - let ad = env.AccessRights + let ad = env.eAccessRights let typeNameResInfo = // Given 'MyOverloadedType.MySubType...' use arity of #given type arguments to help // resolve type name lookup of 'MyOverloadedType' @@ -8686,7 +8686,7 @@ and TcLongIdentThen cenv overallTy env tpenv (LongIdentWithDots(longId, _)) dela | _ -> TypeNameResolutionInfo.Default - let nameResolutionResult = ResolveLongIdentAsExprAndComputeRange cenv.tcSink cenv.nameResolver (rangeOfLid longId) ad env.NameEnv typeNameResInfo longId + let nameResolutionResult = ResolveLongIdentAsExprAndComputeRange cenv.tcSink cenv.nameResolver (rangeOfLid longId) ad env.eNameResEnv typeNameResInfo longId TcItemThen cenv overallTy env tpenv nameResolutionResult delayed //------------------------------------------------------------------------- @@ -8695,7 +8695,7 @@ and TcLongIdentThen cenv overallTy env tpenv (LongIdentWithDots(longId, _)) dela // mItem is the textual range covered by the long identifiers that make up the item and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) delayed = let delayed = delayRest rest mItem delayed - let ad = env.AccessRights + let ad = env.eAccessRights match item with // x where x is a union case or active pattern result tag. | (Item.UnionCase _ | Item.ExnCase _ | Item.ActivePatternResult _) as item -> @@ -8886,7 +8886,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // Replace the resolution including the static parameters, plus the extra information about the original method info let item = Item.MethodGroup(methodName, [minfoAfterStaticArguments], Some minfos.[0]) - CallNameResolutionSinkReplacing cenv.tcSink (mItem, env.NameEnv, item, item, [], ItemOccurence.Use, env.DisplayEnv, env.AccessRights) + CallNameResolutionSinkReplacing cenv.tcSink (mItem, env.NameEnv, item, item, [], ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) match otherDelayed with | DelayedApp(atomicFlag, arg, mExprAndArg) :: otherDelayed -> @@ -8902,7 +8902,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // FUTURE: can we do better than emptyTyparInst here, in order to display instantiations // of type variables in the quick info provided in the IDE? But note we haven't yet even checked if the // number of type arguments is correct... - CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) + CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) match otherDelayed with | DelayedApp(atomicFlag, arg, mExprAndArg) :: otherDelayed -> @@ -8925,13 +8925,13 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del match delayed with | ((DelayedApp (_, arg, mExprAndArg))::otherDelayed) -> - CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTy, env.DisplayEnv, env.AccessRights) + CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTy, env.DisplayEnv, env.eAccessRights) TcCtorCall true cenv env tpenv overallTy objTy (Some mItem) item false [arg] mExprAndArg otherDelayed (Some afterResolution) | ((DelayedTypeApp(tyargs, _mTypeArgs, mExprAndTypeArgs))::(DelayedApp (_, arg, mExprAndArg))::otherDelayed) -> let objTyAfterTyArgs, tpenv = TcNestedTypeApplication cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv mExprAndTypeArgs objTy tyargs - CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTyAfterTyArgs, env.DisplayEnv, env.AccessRights) + CallExprHasTypeSink cenv.tcSink (mExprAndArg, env.NameEnv, objTyAfterTyArgs, env.DisplayEnv, env.eAccessRights) let itemAfterTyArgs, minfosAfterTyArgs = #if !NO_EXTENSIONTYPING // If the type is provided and took static arguments then the constructor will have changed @@ -8955,7 +8955,7 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del // A case where we have an incomplete name e.g. 'Foo.' - we still want to report it to VS! let resolvedItem = Item.Types(nm, [objTy]) - CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, resolvedItem, resolvedItem, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.AccessRights) + CallNameResolutionSink cenv.tcSink (mExprAndTypeArgs, env.NameEnv, resolvedItem, resolvedItem, emptyTyparInst, ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) minfos |> List.iter (fun minfo -> UnifyTypes cenv env mExprAndTypeArgs minfo.ApparentEnclosingType objTy) TcCtorCall true cenv env tpenv overallTy objTy (Some mExprAndTypeArgs) item false [] mExprAndTypeArgs otherDelayed (Some afterResolution) @@ -9292,7 +9292,7 @@ and GetMemberApplicationArgs delayed cenv env tpenv = and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId delayed mExprAndLongId = let objArgs = [objExpr] - let ad = env.AccessRights + let ad = env.eAccessRights // 'base' calls use a different resolution strategy when finding methods. let findFlag = @@ -9319,7 +9319,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela | Some minfoAfterStaticArguments -> // Replace the resolution including the static parameters, plus the extra information about the original method info let item = Item.MethodGroup(methodName, [minfoAfterStaticArguments], Some minfos.[0]) - CallNameResolutionSinkReplacing cenv.tcSink (mExprAndItem, env.NameEnv, item, item, [], ItemOccurence.Use, env.DisplayEnv, env.AccessRights) + CallNameResolutionSinkReplacing cenv.tcSink (mExprAndItem, env.NameEnv, item, item, [], ItemOccurence.Use, env.DisplayEnv, env.eAccessRights) TcMethodApplicationThen cenv env overallTy None tpenv None objArgs mExprAndItem mItem methodName ad mutates false [(minfoAfterStaticArguments, None)] afterResolution NormalValUse args atomicFlag delayed | None -> @@ -9433,7 +9433,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela and TcEventValueThen cenv overallTy env tpenv mItem mExprAndItem objDetails (einfo:EventInfo) delayed = // Instance IL event (fake up event-as-value) let nm = einfo.EventName - let ad = env.AccessRights + let ad = env.eAccessRights match objDetails, einfo.IsStatic with | Some _, true -> error (Error (FSComp.SR.tcEventIsStatic(nm), mItem)) | None, false -> error (Error (FSComp.SR.tcEventIsNotStatic(nm), mItem)) @@ -9442,7 +9442,7 @@ and TcEventValueThen cenv overallTy env tpenv mItem mExprAndItem objDetails (ein let delegateType = einfo.GetDelegateType(cenv.amap, mItem) let (SigOfFunctionForDelegate(invokeMethInfo, compiledViewOfDelArgTys, _, _)) = GetSigOfFunctionForDelegate cenv.infoReader delegateType mItem ad let objArgs = Option.toList (Option.map fst objDetails) - MethInfoChecks cenv.g cenv.amap true None objArgs env.AccessRights mItem invokeMethInfo + MethInfoChecks cenv.g cenv.amap true None objArgs env.eAccessRights mItem invokeMethInfo // This checks for and drops the 'object' sender let argsTy = ArgsTypOfEventInfo cenv.infoReader mItem ad einfo @@ -10406,11 +10406,11 @@ and TcMethodArg cenv env (lambdaPropagationInfo, tpenv) (lambdaPropagationInfo /// Typecheck "new Delegate(fun x y z -> ...)" constructs and TcNewDelegateThen cenv overallTy env tpenv mDelTy mExprAndArg delegateTy arg atomicFlag delayed = - let ad = env.AccessRights + let ad = env.eAccessRights UnifyTypes cenv env mExprAndArg overallTy delegateTy let (SigOfFunctionForDelegate(invokeMethInfo, delArgTys, _, fty)) = GetSigOfFunctionForDelegate cenv.infoReader delegateTy mDelTy ad // We pass isInstance = true here because we're checking the rights to access the "Invoke" method - MethInfoChecks cenv.g cenv.amap true None [] env.AccessRights mExprAndArg invokeMethInfo + MethInfoChecks cenv.g cenv.amap true None [] env.eAccessRights mExprAndArg invokeMethInfo let args = GetMethodArgs arg match args with | [farg], [] -> @@ -10842,13 +10842,13 @@ and TcAttribute canFail cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = let try1 n = let tyid = mkSynId tyid.idRange n let tycon = (typath @ [tyid]) - let ad = env.AccessRights - match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInAttribute OpenQualified env.NameEnv ad tycon TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No with + let ad = env.eAccessRights + match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.UseInAttribute OpenQualified env.eNameResEnv ad tycon TypeNameResolutionStaticArgsInfo.DefiniteEmpty PermitDirectReferenceToGeneratedType.No with | Exception err -> raze(err) | _ -> success(TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInAttribute env tpenv (SynType.App(SynType.LongIdent(LongIdentWithDots(tycon, [])), None, [], [], None, false, mAttr)) ) ForceRaise ((try1 (tyid.idText + "Attribute")) |> ResultOrException.otherwise (fun () -> (try1 tyid.idText))) - let ad = env.AccessRights + let ad = env.eAccessRights if not (IsTypeAccessible cenv.g cenv.amap mAttr ad ty) then errorR(Error(FSComp.SR.tcTypeIsInaccessible(), mAttr)) @@ -11204,7 +11204,7 @@ and ComputeIsComplete enclosingDeclaredTypars declaredTypars ty = /// it implements. Apply the inferred slotsig. and ApplyAbstractSlotInference (cenv:cenv) (envinner:TcEnv) (bindingTy, m, synTyparDecls, declaredTypars, memberId, tcrefObjTy, renaming, _objTy, optIntfSlotTy, valSynData, memberFlags, attribs) = - let ad = envinner.AccessRights + let ad = envinner.eAccessRights let typToSearchForAbstractMembers = match optIntfSlotTy with | Some (ty, abstractSlots) -> @@ -11628,9 +11628,8 @@ and AnalyzeAndMakeAndPublishRecursiveValue overridesOK isGeneratedEventVal cenv match toolIdOpt with | Some tid when not tid.idRange.IsSynthetic && tid.idRange <> bindingId.idRange -> let item = Item.Value (mkLocalValRef vspec) - CallNameResolutionSink cenv.tcSink (tid.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.RelatedText, env.DisplayEnv, env.AccessRights) + CallNameResolutionSink cenv.tcSink (tid.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.RelatedText, env.DisplayEnv, env.eAccessRights) | _ -> () - let mangledId = ident(vspec.LogicalName, vspec.Range) // Reconstitute the binding with the unique name @@ -13674,7 +13673,7 @@ module MutRecBindingChecking = let nm = bind.Var.DisplayName let ty = generalizedTyconRef tcref - let ad = envNonRec.AccessRights + let ad = envNonRec.eAccessRights match TryFindIntrinsicMethInfo cenv.infoReader bind.Var.Range ad nm ty, TryFindPropInfo cenv.infoReader bind.Var.Range ad nm ty with | [], [] -> () @@ -14687,9 +14686,9 @@ module TcExceptionDeclarations = let repr = match reprIdOpt with | Some longId -> - match ResolveExprLongIdent cenv.tcSink cenv.nameResolver m ad env.NameEnv TypeNameResolutionInfo.Default longId with + match ResolveExprLongIdent cenv.tcSink cenv.nameResolver m ad env.eNameResEnv TypeNameResolutionInfo.Default longId with | Item.ExnCase exnc, [] -> - CheckTyconAccessible cenv.amap m env.AccessRights exnc |> ignore + CheckTyconAccessible cenv.amap m env.eAccessRights exnc |> ignore if not (isNil args') then errorR (Error(FSComp.SR.tcExceptionAbbreviationsShouldNotHaveArgumentList(), m)) TExnAbbrevRepr exnc @@ -14720,7 +14719,7 @@ module TcExceptionDeclarations = exnc.SetExceptionInfo repr let item = Item.ExnCase(mkLocalTyconRef exnc) - CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.AccessRights) + CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.eAccessRights) args' let private TcExnDefnCore cenv env parent synExnDefnRepr = @@ -15549,7 +15548,7 @@ module EstablishTypeDefinitionCores = // Notify the Language Service about field names in record/class declaration - let ad = envinner.AccessRights + let ad = envinner.eAccessRights let writeFakeRecordFieldsToSink (fields:RecdField list) = let nenv = envinner.NameEnv // Record fields should be visible from IntelliSense, so add fake names for them (similarly to "let a = ..") diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index d557a742907..6ea59f8d9d6 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -141,7 +141,7 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = match tpc with | TyparConstraint.CoercesTo(x,m) -> join m x,m - | TyparConstraint.MayResolveMember(traitInfo, m) -> + | TyparConstraint.MayResolveMember(_traitInfo, m) -> maxSoFar,m | TyparConstraint.SimpleChoice(_,m) -> errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInPrintf(),m)) From bd86a8fa0c4f1811005aacdb548d7505e551ae75 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 27 Feb 2019 13:24:23 +0000 Subject: [PATCH 27/40] fix build --- src/fsharp/ConstraintSolver.fs | 12 ++++++------ src/fsharp/TastOps.fs | 7 ++++--- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index c429d3b5aed..ce7104c1273 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -1033,7 +1033,7 @@ and SolveDimensionlessNumericType (csenv:ConstraintSolverEnv) ndeep m2 trace ty /// only one of the two type variables is known /// and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload permitWeakResolution ndeep m2 trace traitInfo : OperationResult = trackErrors { - let (TTrait(tys, nm, memFlags, argtys, rty, sln, extSlns, traitAD)) = traitInfo + let (TTrait(tys, nm, memFlags, traitObjAndArgTys, rty, sln, extSlns, traitAD)) = traitInfo // Do not re-solve if already solved if sln.Value.IsSome then return true else let g = csenv.g @@ -1048,20 +1048,21 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p let tys = ListSet.setify (typeAEquiv g aenv) tys // Rebuild the trait info after removing duplicates - let traitInfo = TTrait(tys, nm, memFlags, argtys, rty, sln, extSlns, traitAD) + let traitInfo = TTrait(tys, nm, memFlags, traitObjAndArgTys, rty, sln, extSlns, traitAD) let rty = GetFSharpViewOfReturnType g rty let traitAD = match traitAD with None -> AccessibilityLogic.AccessibleFromEverywhere | Some ad -> (ad :?> AccessorDomain) // Assert the object type if the constraint is for an instance member if memFlags.IsInstance then - match tys, argtys with + match tys, traitObjAndArgTys with | [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 trace HeadTypeStaticReq e - let argtys = if memFlags.IsInstance then List.tail argtys else argtys + let argtys = if memFlags.IsInstance then List.tail traitObjAndArgTys else traitObjAndArgTys let minfos = GetRelevantMethodsForTrait csenv permitWeakResolution nm traitInfo let! res = @@ -1377,8 +1378,7 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) ignoreUnresolvedOverload p if minfo.IsCurried then None else let callerArgs = argtys |> List.map (fun argty -> CallerArg(argty, m, false, dummyExpr)) let minst = FreshenMethInfo None m minfo - //let objtys = minfo.GetObjArgTypes(amap, m, minst) - let callerObjTys = if memFlags.IsInstance then [ List.head argtys ] else [] + let callerObjTys = if memFlags.IsInstance then [ List.head traitObjAndArgTys ] else [] Some(CalledMeth(csenv.InfoReader, None, false, FreshenMethInfo None, m, traitAD, minfo, minst, minst, None, callerObjTys, [(callerArgs, [])], false, false, None))) let methOverloadResult, errors = diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 65801d1f3ff..a659f1bc853 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -2245,9 +2245,10 @@ and accExtSlnsInType acc ty = // NOTE: Unlike almost everywhere else, we do NOT strip ANY equations here. // We _must_ traverse the solved typar containing the new extSlns for the grounded typar constraint, that's the whole point match ty with - | TType_tuple (_tupInfo, l) -> accExtSlnsInTypes acc l - | TType_app (_, tinst) -> accExtSlnsInTypes acc tinst - | TType_ucase (_, tinst) -> accExtSlnsInTypes acc tinst + | TType_tuple (_, tys) + | TType_anon (_, tys) + | TType_app (_, tys) + | TType_ucase (_, tys) -> accExtSlnsInTypes acc tys | TType_fun (d, r) -> accExtSlnsInType (accExtSlnsInType acc d) r | TType_var r -> accExtSlnsTyparRef acc r | TType_forall (_tps, r) -> accExtSlnsInType acc r From 261d654b2679b36ee2cb9a20d232e00c488a9aba Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 27 Feb 2019 18:49:26 +0000 Subject: [PATCH 28/40] update baselines --- tests/fsharp/typecheck/sigs/neg45.bsl | 2 +- tests/fsharp/typecheck/sigs/neg99.bsl | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/fsharp/typecheck/sigs/neg45.bsl b/tests/fsharp/typecheck/sigs/neg45.bsl index 466a998514d..aa1cc2435e6 100644 --- a/tests/fsharp/typecheck/sigs/neg45.bsl +++ b/tests/fsharp/typecheck/sigs/neg45.bsl @@ -77,6 +77,6 @@ neg45.fs(144,13,144,23): typecheck error FS0001: The type 'A1' does not support neg45.fs(145,13,145,23): typecheck error FS0001: The type 'A2' does not support the operator 'get_Name' -neg45.fs(146,13,146,23): typecheck error FS0001: The type 'B' has a method 'get_Name' (full name 'get_Name'), but the method is not static +neg45.fs(146,13,146,23): typecheck error FS0001: get_Name is not a static method neg45.fs(147,15,147,25): typecheck error FS0001: The type 'StaticMutableClassExplicit' does not support the operator 'get_Name' diff --git a/tests/fsharp/typecheck/sigs/neg99.bsl b/tests/fsharp/typecheck/sigs/neg99.bsl index 9f6010f249d..1d050dfedd9 100644 --- a/tests/fsharp/typecheck/sigs/neg99.bsl +++ b/tests/fsharp/typecheck/sigs/neg99.bsl @@ -3,4 +3,4 @@ neg99.fs(19,16,19,64): typecheck error FS0077: Member constraints with the name neg99.fs(22,18,22,64): typecheck error FS0077: Member constraints with the name 'op_Explicit' are given special status by the F# compiler as certain .NET types are implicitly augmented with this member. This may result in runtime failures if you attempt to invoke the member constraint from your own code. -neg99.fs(25,39,25,43): typecheck error FS0043: The type 'CrashFSC.OhOh.MyByte' does not support a conversion to the type 'CrashFSC.OhOh.MyByte' +neg99.fs(25,39,25,43): typecheck error FS0043: The type 'MyByte' does not support a conversion to the type ''a' From 8070d9d5f8be4cbdde5289af92a3782daa379475 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 28 Feb 2019 03:02:02 +0000 Subject: [PATCH 29/40] update baseline --- .../CheckingSyntacticTypes/E_MemberConstraint02.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/fsharpqa/Source/Conformance/TypesAndTypeConstraints/CheckingSyntacticTypes/E_MemberConstraint02.fs b/tests/fsharpqa/Source/Conformance/TypesAndTypeConstraints/CheckingSyntacticTypes/E_MemberConstraint02.fs index 023f7c8a06a..6d2edd7c4fb 100644 --- a/tests/fsharpqa/Source/Conformance/TypesAndTypeConstraints/CheckingSyntacticTypes/E_MemberConstraint02.fs +++ b/tests/fsharpqa/Source/Conformance/TypesAndTypeConstraints/CheckingSyntacticTypes/E_MemberConstraint02.fs @@ -1,5 +1,5 @@ // #Conformance #TypeConstraints #Diagnostics -//The type 'Foo' has a method 'someFunc' \(full name 'someFunc'\), but the method is not static$ +//someFunc is not a static method$ let inline testFunc (a : ^x) = (^x : (static member someFunc : unit -> ^x) ()) From d1b13890945a95cfc691ab94e70f74bbc5c015a7 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 9 Mar 2019 16:54:17 -0800 Subject: [PATCH 30/40] add diagnostics --- tests/EndToEndBuildTests/ProvidedTypes/ProvidedTypes.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/EndToEndBuildTests/ProvidedTypes/ProvidedTypes.fs b/tests/EndToEndBuildTests/ProvidedTypes/ProvidedTypes.fs index 45974519909..e7a924bcfaa 100644 --- a/tests/EndToEndBuildTests/ProvidedTypes/ProvidedTypes.fs +++ b/tests/EndToEndBuildTests/ProvidedTypes/ProvidedTypes.fs @@ -4026,7 +4026,7 @@ namespace ProviderImplementation.ProvidedTypes.AssemblyReader // Emit compressed untagged integer member buf.EmitZUntaggedIndex big idx = if big then buf.EmitInt32 idx - elif idx > 0xffff then failwith "EmitZUntaggedIndex: too big for small address or simple index" + elif idx > 0xffff then failwithf "EmitZUntaggedIndex: too big for small address or simple index, idx = %d, big = %A, stack = %s" idx big ((new System.Diagnostics.StackTrace()).ToString()) else buf.EmitInt32AsUInt16 idx // Emit compressed tagged integer From 0f897111104f50dc93f2495c5f2c214de87e96ba Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 9 Mar 2019 16:54:17 -0800 Subject: [PATCH 31/40] add diagnostics From 7da6aff62f0c5f68453579b0747feb8cedf8d984 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 11 Mar 2019 14:42:08 +0000 Subject: [PATCH 32/40] diagnostics --- src/absil/ilwrite.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs index cac9ccbcefe..8cd58c957a1 100644 --- a/src/absil/ilwrite.fs +++ b/src/absil/ilwrite.fs @@ -89,7 +89,7 @@ type ByteBuffer with // Emit compressed untagged integer member buf.EmitZUntaggedIndex big idx = if big then buf.EmitInt32 idx - elif idx > 0xffff then failwith "EmitZUntaggedIndex: too big for small address or simple index" + elif idx > 0xffff then failwithf "EmitZUntaggedIndex: too big for small address or simple index, idx = %d, big = %A, stack = %s" idx big ((new System.Diagnostics.StackTrace()).ToString()) else buf.EmitInt32AsUInt16 idx // Emit compressed tagged integer From 871489bd13e9eb55cef3d212b0f4211a5a877c6c Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 11 Mar 2019 14:51:43 +0000 Subject: [PATCH 33/40] diagnostics --- src/absil/ilwrite.fs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs index 8cd58c957a1..6e13993d7f8 100644 --- a/src/absil/ilwrite.fs +++ b/src/absil/ilwrite.fs @@ -87,9 +87,9 @@ type ByteBuffer with buf.EmitByte 0x0uy // Emit compressed untagged integer - member buf.EmitZUntaggedIndex big idx = + member buf.EmitZUntaggedIndex nm sz big idx = if big then buf.EmitInt32 idx - elif idx > 0xffff then failwithf "EmitZUntaggedIndex: too big for small address or simple index, idx = %d, big = %A, stack = %s" idx big ((new System.Diagnostics.StackTrace()).ToString()) + elif idx > 0xffff then failwithf "EmitZUntaggedIndex: index into table '%d' is too big for small address or simple index, idx = %d, big = %A, size of table = %d, stack = %s" nm idx big sz ((new System.Diagnostics.StackTrace()).ToString()) else buf.EmitInt32AsUInt16 idx // Emit compressed tagged integer @@ -3198,8 +3198,10 @@ let writeILMetadataAndCode (generatePdb, desiredMetadataVersion, ilg, emitTailca let codedTables = + let sizesTable = Array.map Array.length sortedTables let bignessTable = Array.map (fun rows -> Array.length rows >= 0x10000) sortedTables let bigness (tab:int32) = bignessTable.[tab] + let size (tab:int32) = sizesTable.[tab] let codedBigness nbits tab = (tableSize tab) >= (0x10000 >>> nbits) @@ -3323,10 +3325,12 @@ let writeILMetadataAndCode (generatePdb, desiredMetadataVersion, ilg, emitTailca | _ when t = RowElementTags.ULong -> tablesBuf.EmitInt32 n | _ when t = RowElementTags.Data -> recordRequiredDataFixup requiredDataFixups tablesBuf (tablesStreamStart + tablesBuf.Position) (n, false) | _ when t = RowElementTags.DataResources -> recordRequiredDataFixup requiredDataFixups tablesBuf (tablesStreamStart + tablesBuf.Position) (n, true) - | _ when t = RowElementTags.Guid -> tablesBuf.EmitZUntaggedIndex guidsBig (guidAddress n) - | _ when t = RowElementTags.Blob -> tablesBuf.EmitZUntaggedIndex blobsBig (blobAddress n) - | _ when t = RowElementTags.String -> tablesBuf.EmitZUntaggedIndex stringsBig (stringAddress n) - | _ when t <= RowElementTags.SimpleIndexMax -> tablesBuf.EmitZUntaggedIndex (bigness (t - RowElementTags.SimpleIndexMin)) n + | _ when t = RowElementTags.Guid -> tablesBuf.EmitZUntaggedIndex -3 guidsStreamPaddedSize guidsBig (guidAddress n) + | _ when t = RowElementTags.Blob -> tablesBuf.EmitZUntaggedIndex -2 blobsStreamPaddedSize blobsBig (blobAddress n) + | _ when t = RowElementTags.String -> tablesBuf.EmitZUntaggedIndex -1 stringsStreamPaddedSize stringsBig (stringAddress n) + | _ when t <= RowElementTags.SimpleIndexMax -> + let tnum = t - RowElementTags.SimpleIndexMin + tablesBuf.EmitZUntaggedIndex tnum (size tnum) (bigness tnum) n | _ when t <= RowElementTags.TypeDefOrRefOrSpecMax -> tablesBuf.EmitZTaggedIndex (t - RowElementTags.TypeDefOrRefOrSpecMin) 2 tdorBigness n | _ when t <= RowElementTags.TypeOrMethodDefMax -> tablesBuf.EmitZTaggedIndex (t - RowElementTags.TypeOrMethodDefMin) 1 tomdBigness n | _ when t <= RowElementTags.HasConstantMax -> tablesBuf.EmitZTaggedIndex (t - RowElementTags.HasConstantMin) 2 hcBigness n From 27d00a09c829d9d3086bd056c81b880a5c7c970f Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 11 Mar 2019 14:53:57 +0000 Subject: [PATCH 34/40] diagnostics --- tests/EndToEndBuildTests/ProvidedTypes/ProvidedTypes.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/EndToEndBuildTests/ProvidedTypes/ProvidedTypes.fs b/tests/EndToEndBuildTests/ProvidedTypes/ProvidedTypes.fs index e7a924bcfaa..45974519909 100644 --- a/tests/EndToEndBuildTests/ProvidedTypes/ProvidedTypes.fs +++ b/tests/EndToEndBuildTests/ProvidedTypes/ProvidedTypes.fs @@ -4026,7 +4026,7 @@ namespace ProviderImplementation.ProvidedTypes.AssemblyReader // Emit compressed untagged integer member buf.EmitZUntaggedIndex big idx = if big then buf.EmitInt32 idx - elif idx > 0xffff then failwithf "EmitZUntaggedIndex: too big for small address or simple index, idx = %d, big = %A, stack = %s" idx big ((new System.Diagnostics.StackTrace()).ToString()) + elif idx > 0xffff then failwith "EmitZUntaggedIndex: too big for small address or simple index" else buf.EmitInt32AsUInt16 idx // Emit compressed tagged integer From 7d98d16f6a55a9877089a9ec144d2699d2c589e5 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 11 Mar 2019 15:03:22 +0000 Subject: [PATCH 35/40] add diagnostics and possible fix for tp smoke tests --- .../DummyProviderForLanguageServiceTesting.fs | 27 ++++++++++--------- .../Tests.LanguageService.Script.fs | 6 +++-- 2 files changed, 19 insertions(+), 14 deletions(-) diff --git a/vsintegration/tests/MockTypeProviders/DummyProviderForLanguageServiceTesting/DummyProviderForLanguageServiceTesting.fs b/vsintegration/tests/MockTypeProviders/DummyProviderForLanguageServiceTesting/DummyProviderForLanguageServiceTesting.fs index 1e17fda491f..697ba4a2d7a 100644 --- a/vsintegration/tests/MockTypeProviders/DummyProviderForLanguageServiceTesting/DummyProviderForLanguageServiceTesting.fs +++ b/vsintegration/tests/MockTypeProviders/DummyProviderForLanguageServiceTesting/DummyProviderForLanguageServiceTesting.fs @@ -113,33 +113,36 @@ module internal TPModule = // Used by unit testing to check that Dispose is being called on the type provider module GlobalCounters = - let mutable creations = 0 - let mutable disposals = 0 - let mutable configs = ([]: TypeProviderConfig list) - let GetTotalCreations() = creations - let GetTotalDisposals() = disposals + let counterLock = obj() + let mutable private creations = 0 + let mutable private disposals = 0 + let mutable private configs = ([]: TypeProviderConfig list) + let GetTotalCreations() = lock counterLock (fun () -> creations) + let GetTotalDisposals() = lock counterLock (fun () -> disposals) + let IncrementCreations() = lock counterLock (fun () -> creations <- creations + 1) + let IncrementDisposals() = lock counterLock (fun () -> disposals <- disposals + 1) + let AddConfig c = lock counterLock (fun () -> configs <- c :: configs) + let GetConfigs() = lock counterLock (fun () -> configs) let CheckAllConfigsDisposed() = - for c in configs do + for c in GetConfigs() do try c.SystemRuntimeContainsType("System.Object") |> ignore failwith "expected configuration object to be disposed" with :? System.ObjectDisposedException -> () - - [] type HelloWorldProvider(config: TypeProviderConfig) = inherit TypeProviderForNamespaces(TPModule.namespaceName,TPModule.types) - do GlobalCounters.creations <- GlobalCounters.creations + 1 + do GlobalCounters.IncrementCreations() let mutable disposed = false - do GlobalCounters.configs <- config :: GlobalCounters.configs + do GlobalCounters.AddConfig config interface System.IDisposable with member x.Dispose() = System.Diagnostics.Debug.Assert(not disposed) disposed <- true - GlobalCounters.disposals <- GlobalCounters.disposals + 1 - if GlobalCounters.disposals % 5 = 0 then failwith "simulate random error during disposal" + do GlobalCounters.IncrementDisposals() + if GlobalCounters.GetTotalDisposals() % 5 = 0 then failwith "simulate random error during disposal" // implementation of a poorly behaving TP that sleeps for various numbers of seconds when traversing into members. diff --git a/vsintegration/tests/UnitTests/LegacyLanguageService/Tests.LanguageService.Script.fs b/vsintegration/tests/UnitTests/LegacyLanguageService/Tests.LanguageService.Script.fs index cbe55e9baf9..9255acf3436 100644 --- a/vsintegration/tests/UnitTests/LegacyLanguageService/Tests.LanguageService.Script.fs +++ b/vsintegration/tests/UnitTests/LegacyLanguageService/Tests.LanguageService.Script.fs @@ -1624,8 +1624,10 @@ type UsingMSBuild() as this = // The disposals should be at least one less Assert.IsTrue(countDisposals() < i, "Check1, countDisposals() < i, iteration " + string i) - Assert.IsTrue(countCreations() >= countDisposals(), "Check2, countCreations() >= countDisposals(), iteration " + string i) - Assert.IsTrue(countCreations() = i, "Check3, countCreations() = i, iteration " + string i) + let c = countCreations() + let d = countDisposals() + Assert.IsTrue(c >= countDisposals(), "Check2, countCreations() >= countDisposals(), iteration " + string i + ", countCreations() = " + string c + ", countDisposals() = " + string d) + Assert.IsTrue((c = i), "Check3, countCreations() = i, iteration " + string i + ", countCreations() = " + string c) if not clearing then // By default we hold 3 build incrementalBuilderCache entries and 5 typeCheckInfo entries, so if we're not clearing // there should be some roots to project builds still present From cc6e992c0600f51da712bad6012333238d8bf2fa Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 11 Mar 2019 15:30:09 +0000 Subject: [PATCH 36/40] fix build --- src/absil/ilwrite.fs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs index 6e13993d7f8..4ef18af0069 100644 --- a/src/absil/ilwrite.fs +++ b/src/absil/ilwrite.fs @@ -89,7 +89,13 @@ type ByteBuffer with // Emit compressed untagged integer member buf.EmitZUntaggedIndex nm sz big idx = if big then buf.EmitInt32 idx - elif idx > 0xffff then failwithf "EmitZUntaggedIndex: index into table '%d' is too big for small address or simple index, idx = %d, big = %A, size of table = %d, stack = %s" nm idx big sz ((new System.Diagnostics.StackTrace()).ToString()) + elif idx > 0xffff then +#if NETSTANDARD1_6 + let trace = "no stack trace on.NET Standard 1.6" +#else + let trace = (new Diagnostics.StackTrace()).ToString() +#endif + failwithf "EmitZUntaggedIndex: index into table '%d' is too big for small address or simple index, idx = %d, big = %A, size of table = %d, stack = %s" nm idx big sz trace else buf.EmitInt32AsUInt16 idx // Emit compressed tagged integer From e13b385554fac0903a9079123ef238c56d87148c Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 11 Mar 2019 16:47:00 +0000 Subject: [PATCH 37/40] fix build --- src/absil/ilwrite.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs index 4ef18af0069..62628eb0162 100644 --- a/src/absil/ilwrite.fs +++ b/src/absil/ilwrite.fs @@ -93,7 +93,7 @@ type ByteBuffer with #if NETSTANDARD1_6 let trace = "no stack trace on.NET Standard 1.6" #else - let trace = (new Diagnostics.StackTrace()).ToString() + let trace = (new System.Diagnostics.StackTrace()).ToString() #endif failwithf "EmitZUntaggedIndex: index into table '%d' is too big for small address or simple index, idx = %d, big = %A, size of table = %d, stack = %s" nm idx big sz trace else buf.EmitInt32AsUInt16 idx From 42b1f1d89fc4f64fedfcaaed7738aaa98251c648 Mon Sep 17 00:00:00 2001 From: kevmal Date: Fri, 15 Mar 2019 16:23:48 -0600 Subject: [PATCH 38/40] append extension methods in GetRelevantMethodsForTrait --- src/fsharp/ConstraintSolver.fs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index eed577215c2..27139f79172 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -1536,6 +1536,17 @@ and GetRelevantMethodsForTrait (csenv:ConstraintSolverEnv) permitWeakResolution // We merge based on whether minfos use identical metadata or not. let minfos = List.reduce (ListSet.unionFavourLeft MethInfo.MethInfosUseIdenticalDefinitions) minfos + // Get the extension method that may be relevant to solving the constraint as MethInfo objects. + // Extension members are not used when canonicalizing prior to generalization (permitWeakResolution=true) + let extMInfos = + if MemberConstraintSupportIsReadyForDeterminingOverloads csenv traitInfo then + GetRelevantExtensionMethodsForTrait csenv.m csenv.amap traitInfo + else [] + + let extMInfos = extMInfos |> ListSet.setify MethInfo.MethInfosUseIdenticalDefinitions + + let minfos = minfos @ extMInfos + /// Check that the available members aren't hiding a member from the parent (depth 1 only) let relevantMinfos = minfos |> List.filter(fun minfo -> not minfo.IsDispatchSlot && not minfo.IsVirtual && minfo.IsInstance) minfos From b5365bad273685a05864015d83c48124346a27d6 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 22 Mar 2019 18:18:25 +0000 Subject: [PATCH 39/40] fix tests --- src/fsharp/ConstraintSolver.fs | 46 +++++++++++++++++----------------- testfiles/test.fs | 30 +++++++++++++++++++++- 2 files changed, 52 insertions(+), 24 deletions(-) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index 3bfa6c3a173..72b7ce2088e 100644 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -1067,8 +1067,8 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload let! res = trackErrors { - match minfos, tys, memFlags.IsInstance, nm, argtys with - | _, _, false, ("op_Division" | "op_Multiply"), [argty1;argty2] + match tys, memFlags.IsInstance, nm, argtys with + | _, false, ("op_Division" | "op_Multiply"), [argty1;argty2] when // This simulates the existence of // float * float -> float @@ -1127,7 +1127,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn - | _, _, false, ("op_Addition" | "op_Subtraction" | "op_Modulus"), [argty1;argty2] + | _, false, ("op_Addition" | "op_Subtraction" | "op_Modulus"), [argty1;argty2] when // Ignore any explicit +/- overloads from any basic integral types (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.ApparentEnclosingType ) && ( (IsNumericOrIntegralEnumType g argty1 || (nm = "op_Addition" && (isCharTy g argty1 || isStringTy g argty1))) && (permitWeakResolution || not (isTyparTy g argty2)) @@ -1136,7 +1136,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload 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] + | _, false, ("op_LessThan" | "op_LessThanOrEqual" | "op_GreaterThan" | "op_GreaterThanOrEqual" | "op_Equality" | "op_Inequality" ), [argty1;argty2] when // Ignore any explicit overloads from any basic integral types (minfos |> List.forall (fun minfo -> isIntegerTy g minfo.ApparentEnclosingType ) && ( (IsRelationalType g argty1 && (permitWeakResolution || not (isTyparTy g argty2))) @@ -1147,32 +1147,32 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload // 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", [] + | [ty], false, "get_Zero", [] when IsNumericType g ty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ty return TTraitBuiltIn - | [], [ty], false, "get_One", [] + | [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 return TTraitBuiltIn - | [], _, false, ("DivideByInt"), [argty1;argty2] + | _, 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 return TTraitBuiltIn // We pretend for uniformity that the 'string' and 'array' types have an indexer property called 'Item' - | [], [ty], true, ("get_Item"), [argty1] + | [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 return TTraitBuiltIn - | [], [ty], true, ("get_Item"), argtys + | [ty], true, "get_Item", argtys when isArrayTy g ty -> if rankOfArrayTy g ty <> argtys.Length then do! ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), argtys.Length), m, m2)) @@ -1182,7 +1182,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty ety return TTraitBuiltIn - | [], [ty], true, ("set_Item"), argtys + | [ty], true, "set_Item", argtys when isArrayTy g ty -> if rankOfArrayTy g ty <> argtys.Length - 1 then do! ErrorD(ConstraintSolverError(FSComp.SR.csIndexArgumentMismatch((rankOfArrayTy g ty), (argtys.Length - 1)), m, m2)) @@ -1193,7 +1193,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ety etys return TTraitBuiltIn - | [], _, false, ("op_BitwiseAnd" | "op_BitwiseOr" | "op_ExclusiveOr"), [argty1;argty2] + | _, false, ("op_BitwiseAnd" | "op_BitwiseOr" | "op_ExclusiveOr"), [argty1;argty2] when (isIntegerOrIntegerEnumTy g argty1 || (isEnumTy g argty1)) && (permitWeakResolution || not (isTyparTy g argty2)) || (isIntegerOrIntegerEnumTy g argty2 || (isEnumTy g argty2)) && (permitWeakResolution || not (isTyparTy g argty1)) -> @@ -1202,7 +1202,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 return TTraitBuiltIn - | [], _, false, ("op_LeftShift" | "op_RightShift"), [argty1;argty2] + | _, false, ("op_LeftShift" | "op_RightShift"), [argty1;argty2] when isIntegerOrIntegerEnumTy g argty1 -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 g.int_ty @@ -1210,38 +1210,38 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 return TTraitBuiltIn - | _, _, false, ("op_UnaryPlus"), [argty] + | _, false, "op_UnaryPlus", [argty] when IsNumericOrIntegralEnumType g argty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn - | _, _, false, ("op_UnaryNegation"), [argty] + | _, false, "op_UnaryNegation", [argty] when isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn - | _, _, true, ("get_Sign"), [] + | _, true, "get_Sign", [] when (let argty = tys.Head in isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty) -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty g.int32_ty return TTraitBuiltIn - | _, _, false, ("op_LogicalNot" | "op_OnesComplement"), [argty] + | _, 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 return TTraitBuiltIn - | _, _, false, ("Abs"), [argty] + | _, false, "Abs", [argty] when isSignedIntegerTy g argty || isFpTy g argty || isDecimalTy g argty -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty return TTraitBuiltIn - | _, _, false, "Sqrt", [argty1] + | _, false, "Sqrt", [argty1] when isFpTy g argty1 -> match GetMeasureOfType g argty1 with | Some (tcref, _) -> @@ -1253,7 +1253,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload 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] + | _, 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 @@ -1261,7 +1261,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload return TTraitBuiltIn // Simulate solutions to op_Implicit and op_Explicit - | _, _, false, "op_Explicit", [argty] + | _, false, "op_Explicit", [argty] when (// The input type. (IsNonDecimalNumericOrIntegralEnumType g argty || isStringTy g argty || isCharTy g argty) && // The output type @@ -1274,7 +1274,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload return TTraitBuiltIn - | _, _, false, "op_Explicit", [argty] + | _, false, "op_Explicit", [argty] when (// The input type. (IsNumericOrIntegralEnumType g argty || isStringTy g argty) && // The output type @@ -1282,7 +1282,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload return TTraitBuiltIn - | _, _, false, "Pow", [argty1; argty2] + | _, false, "Pow", [argty1; argty2] when isFpTy g argty1 -> do! SolveDimensionlessNumericType csenv ndeep m2 trace argty1 @@ -1290,7 +1290,7 @@ and SolveMemberConstraint (csenv: ConstraintSolverEnv) ignoreUnresolvedOverload do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty argty1 return TTraitBuiltIn - | _, _, false, "Atan2", [argty1; argty2] + | _, false, "Atan2", [argty1; argty2] when isFpTy g argty1 -> do! SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace argty2 argty1 diff --git a/testfiles/test.fs b/testfiles/test.fs index a8862ead5e9..604f475fd5c 100644 --- a/testfiles/test.fs +++ b/testfiles/test.fs @@ -22,7 +22,9 @@ module DotNetPrimtiveWithAmbiguousNewOperator = type System.Int32 with static member (++)(a: int, b: string) = a - let f x = 1 ++ x + let f (x: string) = 1 ++ x + // TODO: this gives an internal error + // let f x = 1 ++ x /// Extending a .NET primitive type with new _internal_ operator module DotNetPrimtiveWithInternalOperator1 = @@ -217,3 +219,29 @@ module MapExample = let v5 = map (fun x -> x + 1) [ 1 .. 100 ] *) +module ExtenstionAttributeMembers = + open System.Runtime.CompilerServices + [] + type Ext2() = + [] + static member Bleh(a : string) = a.Length + + let inline bleh s = (^a : (member Bleh : unit -> int) s) + + let v = bleh "a" + +module Errors = + open System + type System.Int32 with + static member inline (+)(a, b) = Array.map2 (+) a b + + let _ = [|1;2;3|] + [|2;3;4|] //Okay + let _ = [|TimeSpan.Zero|] + [|TimeSpan.Zero|] //Okay + let _ = [|1m|] + [|2m|] //Okay + let _ = [|1uy|] + [|2uy|] //Okay + let _ = [|1L|] + [|2L|] //Okay + let _ = [|1I|] + [|2I|] //Okay + let _ = [| [|1 ; 1|]; [|2|] |] + [| [|2; 2|]; [|3|] |] //Okay + let _ = [|"1"|] + [|"2"|] //error FS0001 + let _ = [|1.f|] + [|2.f|] //error FS0001 + let _ = [|1.0|] + [|2.0|] //error FS0001 From 0450da8f953ff7f15ee724695e0dbeeee08b3b3b Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 16 Apr 2019 14:53:07 +0100 Subject: [PATCH 40/40] fix build --- src/fsharp/TypeChecker.fs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 1fc1cd4498e..58b3a8bfeed 100644 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -5001,8 +5001,9 @@ and TcProvidedTypeApp cenv env tpenv tcref args m = /// In this case, 'args' is only the instantiation of the suffix type arguments, and pathTypeArgs gives /// the prefix of type arguments. and TcTypeApp cenv newOk checkCxs occ env tpenv m tcref pathTypeArgs (synArgTys: SynType list) = + let g = cenv.g CheckTyconAccessible cenv.amap m env.AccessRights tcref |> ignore - CheckEntityAttributes cenv.g tcref m |> CommitOperationResult + CheckEntityAttributes g tcref m |> CommitOperationResult #if !NO_EXTENSIONTYPING // Provided types are (currently) always non-generic. Their names may include mangled