diff --git a/src/Compiler/Checking/CheckBasics.fs b/src/Compiler/Checking/CheckBasics.fs index d8fdd288af3..02b6772441b 100644 --- a/src/Compiler/Checking/CheckBasics.fs +++ b/src/Compiler/Checking/CheckBasics.fs @@ -235,11 +235,7 @@ type TcEnv = eLambdaArgInfos: ArgReprInfo list list // Do we lay down an implicit debug point? - eIsControlFlow: bool - - // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. - // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. - eCachedImplicitYieldExpressions : HashMultiMap + eIsControlFlow: bool } member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv @@ -311,8 +307,6 @@ type TcFileState = diagnosticOptions: FSharpDiagnosticOptions - argInfoCache: ConcurrentDictionary - // forward call TcPat: WarnOnUpperFlag -> TcFileState -> TcEnv -> PrelimValReprInfo option -> TcPatValFlags -> TcPatLinearEnv -> TType -> SynPat -> (TcPatPhase2Input -> Pattern) * TcPatLinearEnv @@ -362,7 +356,6 @@ type TcFileState = conditionalDefines = conditionalDefines isInternalTestSpanStackReferring = isInternalTestSpanStackReferring diagnosticOptions = diagnosticOptions - argInfoCache = ConcurrentDictionary() TcPat = tcPat TcSimplePats = tcSimplePats TcSequenceExpressionEntry = tcSequenceExpressionEntry diff --git a/src/Compiler/Checking/CheckBasics.fsi b/src/Compiler/Checking/CheckBasics.fsi index 0191cf018f2..1e2c71f49d7 100644 --- a/src/Compiler/Checking/CheckBasics.fsi +++ b/src/Compiler/Checking/CheckBasics.fsi @@ -130,9 +130,6 @@ type TcEnv = eIsControlFlow: bool - // In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. - // This avoids exponential behavior in the type checker when nesting implicit-yield expressions. - eCachedImplicitYieldExpressions: HashMultiMap } member DisplayEnv: DisplayEnv @@ -269,11 +266,6 @@ type TcFileState = diagnosticOptions: FSharpDiagnosticOptions - /// A cache for ArgReprInfos which get created multiple times for the same values - /// Since they need to be later mutated with updates from signature files this should make sure - /// we're always dealing with the same instance and the updates don't get lost - argInfoCache: ConcurrentDictionary - // forward call TcPat: WarnOnUpperFlag diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index e230cd48280..7e488305f75 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5609,8 +5609,7 @@ let emptyTcEnv g = eCtorInfo = None eCallerMemberName = None eLambdaArgInfos = [] - eIsControlFlow = false - eCachedImplicitYieldExpressions = HashMultiMap(HashIdentity.Structural, useConcurrentDictionary = true) } + eIsControlFlow = false } let CreateInitialTcEnv(g, amap, scopem, assemblyName, ccus) = (emptyTcEnv g, ccus) ||> List.collectFold (fun env (ccu, autoOpens, internalsVisible) -> diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 527a09cf1d0..6c786fc12fc 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -958,6 +958,10 @@ let AdjustValSynInfoInSignature g ty (SynValInfo(argsData, retData) as sigMD) = | _ -> sigMD +let getArgInfoCache = + let options = Caches.CacheOptions.getDefault HashIdentity.Structural |> Caches.CacheOptions.withNoEviction + let factory _ = new Caches.Cache<_, ArgReprInfo>(options, "argInfoCache") + WeakMap.getOrCreate factory let TranslateTopArgSynInfo (cenv: cenv) isArg m tcAttributes (SynArgInfo(Attributes attrs, isOpt, nm)) = // Synthesize an artificial "OptionalArgument" attribute for the parameter @@ -982,18 +986,12 @@ let TranslateTopArgSynInfo (cenv: cenv) isArg m tcAttributes (SynArgInfo(Attribu let key = nm |> Option.map (fun id -> id.idText, id.idRange) + let mkDefaultArgInfo _ : ArgReprInfo = { Attribs = attribs; Name = nm; OtherRange = None } + let argInfo = - key - |> Option.map cenv.argInfoCache.TryGetValue - |> Option.bind (fun (found, info) -> - if found then - Some info - else None) - |> Option.defaultValue ({ Attribs = attribs; Name = nm; OtherRange = None }: ArgReprInfo) - - match key with - | Some k -> cenv.argInfoCache.[k] <- argInfo - | None -> () + match key with + | Some key -> (getArgInfoCache cenv).GetOrAdd(key, mkDefaultArgInfo) + | _ -> mkDefaultArgInfo () // Set freshly computed attribs in case they are different in the cache argInfo.Attribs <- attribs @@ -4054,6 +4052,13 @@ type ImplicitlyBoundTyparsAllowed = | NewTyparsOK | NoNewTypars +// In order to avoid checking implicit-yield expressions multiple times, we cache the resulting checked expressions. +// This avoids exponential behavior in the type checker when nesting implicit-yield expressions. +let getImplicitYieldExpressionsCache = + let options = Caches.CacheOptions.getReferenceIdentity() |> Caches.CacheOptions.withNoEviction + let factory _ = new Caches.Cache(options, "implicitYieldExpressions") + WeakMap.getOrCreate factory + //------------------------------------------------------------------------- // Checking types and type constraints //------------------------------------------------------------------------- @@ -5508,19 +5513,12 @@ and CheckForAdjacentListExpression (cenv: cenv) synExpr hpa isInfix delayed (arg and TcExprThen (cenv: cenv) overallTy env tpenv isArg synExpr delayed = let g = cenv.g - let cachedExpression = - env.eCachedImplicitYieldExpressions.FindAll synExpr.Range - |> List.tryPick (fun (se, ty, e) -> - if obj.ReferenceEquals(se, synExpr) then Some (ty, e) else None - ) - - match cachedExpression with - | Some (ty, expr) -> + match (getImplicitYieldExpressionsCache cenv).TryGetValue synExpr with + | true, (ty, expr) -> UnifyOverallType cenv env synExpr.Range overallTy ty expr, tpenv | _ -> - match synExpr with // A. @@ -6382,9 +6380,8 @@ and TcExprSequentialOrImplicitYield (cenv: cenv) overallTy env tpenv (sp, synExp | Expr.DebugPoint(_,e) -> e | _ -> expr1 - env.eCachedImplicitYieldExpressions.Add(synExpr1.Range, (synExpr1, expr1Ty, cachedExpr)) - try TcExpr cenv overallTy env tpenv otherExpr - finally env.eCachedImplicitYieldExpressions.Remove synExpr1.Range + (getImplicitYieldExpressionsCache cenv).AddOrUpdate(synExpr1, (expr1Ty, cachedExpr)) + TcExpr cenv overallTy env tpenv otherExpr and TcExprStaticOptimization (cenv: cenv) overallTy env tpenv (constraints, synExpr2, expr3, m) = let constraintsR, tpenv = List.mapFold (TcStaticOptimizationConstraint cenv env) tpenv constraints diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs index 021370f2067..fed92e82b05 100644 --- a/src/Compiler/Checking/TypeRelations.fs +++ b/src/Compiler/Checking/TypeRelations.fs @@ -25,16 +25,16 @@ type CanCoerce = | CanCoerce | NoCoerce +let tryGetTypeStructure ty = + match ty with + | TType_app _ -> + tryGetTypeStructureOfStrippedType ty + | _ -> ValueNone + [] type TTypeCacheKey = | TTypeCacheKey of TypeStructure * TypeStructure * CanCoerce static member TryGetFromStrippedTypes(ty1, ty2, canCoerce) = - let tryGetTypeStructure ty = - match ty with - | TType_app _ -> - tryGetTypeStructureOfStrippedType ty - | _ -> ValueNone - (tryGetTypeStructure ty1, tryGetTypeStructure ty2) ||> ValueOption.map2(fun t1 t2 -> TTypeCacheKey(t1, t2, canCoerce)) @@ -45,7 +45,44 @@ let getTypeSubsumptionCache = | CompilationMode.OneOff -> Caches.CacheOptions.getDefault HashIdentity.Structural |> Caches.CacheOptions.withNoEviction | _ -> { Caches.CacheOptions.getDefault HashIdentity.Structural with TotalCapacity = 65536; HeadroomPercentage = 75 } new Caches.Cache(options, "typeSubsumptionCache") - Extras.WeakMap.getOrCreate factory + Extras.WeakMap.getOrCreate factory + +// Cache for feasible equivalence checks +[] +type TTypeFeasibleEquivCacheKey = + | TTypeFeasibleEquivCacheKey of TypeStructure * TypeStructure * bool + static member TryGetFromStrippedTypes(stripMeasures: bool, ty1: TType, ty2: TType) = + let sortPair a b = if hash a <= hash b then (a, b) else (b, a) + (tryGetTypeStructure ty1, tryGetTypeStructure ty2) + ||> ValueOption.map2(fun t1 t2 -> + let t1, t2 = sortPair t1 t2 + TTypeFeasibleEquivCacheKey(t1, t2, stripMeasures)) + +let getTypeFeasibleEquivCache = + let factory (g: TcGlobals) = + let options = + match g.compilationMode with + | CompilationMode.OneOff -> Caches.CacheOptions.getDefault HashIdentity.Structural |> Caches.CacheOptions.withNoEviction + | _ -> { Caches.CacheOptions.getDefault HashIdentity.Structural with TotalCapacity = 65536; HeadroomPercentage = 75 } + new Caches.Cache(options, "typeFeasibleEquivCache") + Extras.WeakMap.getOrCreate factory + +// Cache for definite subsumption without coercion +[] +type TTypeDefinitelySubsumesNoCoerceCacheKey = + | TTypeDefinitelySubsumesNoCoerceCacheKey of TypeStructure * TypeStructure + static member TryGetFromStrippedTypes(ty1: TType, ty2: TType) = + (tryGetTypeStructure ty1, tryGetTypeStructure ty2) + ||> ValueOption.map2(fun t1 t2 -> TTypeDefinitelySubsumesNoCoerceCacheKey(t1, t2)) + +let getTypeDefinitelySubsumesNoCoerceCache = + let factory (g: TcGlobals) = + let options = + match g.compilationMode with + | CompilationMode.OneOff -> Caches.CacheOptions.getDefault HashIdentity.Structural |> Caches.CacheOptions.withNoEviction + | _ -> { Caches.CacheOptions.getDefault HashIdentity.Structural with TotalCapacity = 65536; HeadroomPercentage = 75 } + new Caches.Cache(options, "typeDefinitelySubsumesNoCoerceCache") + Extras.WeakMap.getOrCreate factory /// Implements a :> b without coercion based on finalized (no type variable) types // Note: This relation is approximate and not part of the language specification. @@ -64,22 +101,37 @@ let rec TypeDefinitelySubsumesTypeNoCoercion ndeep g amap m ty1 ty2 = if ty1 === ty2 then true elif typeEquiv g ty1 ty2 then true else + + let checkSubsumes ty1 ty2 = + + typeEquiv g ty1 ty2 || + + // F# reference types are subtypes of type 'obj' + (typeEquiv g ty1 g.obj_ty_ambivalent && isRefTy g ty2) || + // Follow the supertype chain + (isAppTy g ty2 && + isRefTy g ty2 && + + ((match GetSuperTypeOfType g amap m ty2 with + | None -> false + | Some ty -> TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1 ty) || + + // Follow the interface hierarchy + (isInterfaceTy g ty1 && + ty2 |> GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m + |> List.exists (TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1)))) + let ty1 = stripTyEqns g ty1 let ty2 = stripTyEqns g ty2 - // F# reference types are subtypes of type 'obj' - (typeEquiv g ty1 g.obj_ty_ambivalent && isRefTy g ty2) || - // Follow the supertype chain - (isAppTy g ty2 && - isRefTy g ty2 && - - ((match GetSuperTypeOfType g amap m ty2 with - | None -> false - | Some ty -> TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1 ty) || - // Follow the interface hierarchy - (isInterfaceTy g ty1 && - ty2 |> GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m - |> List.exists (TypeDefinitelySubsumesTypeNoCoercion (ndeep+1) g amap m ty1)))) + if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then + let key = TTypeDefinitelySubsumesNoCoerceCacheKey.TryGetFromStrippedTypes(ty1, ty2) + match key with + | ValueNone -> checkSubsumes ty1 ty2 + | ValueSome key -> + (getTypeDefinitelySubsumesNoCoerceCache g).GetOrAdd(key, fun _ -> checkSubsumes ty1 ty2) + else + checkSubsumes ty1 ty2 let stripAll stripMeasures g ty = if stripMeasures then @@ -96,30 +148,40 @@ let rec TypesFeasiblyEquivalent stripMeasures ndeep g amap m ty1 ty2 = let ty1 = stripAll stripMeasures g ty1 let ty2 = stripAll stripMeasures g ty2 - match ty1, ty2 with - | TType_measure _, TType_measure _ - | TType_var _, _ - | _, TType_var _ -> true + let computeEquiv ty1 ty2 = + + match ty1, ty2 with + | TType_measure _, TType_measure _ + | TType_var _, _ + | _, TType_var _ -> true + + | TType_app (tcref1, l1, _), TType_app (tcref2, l2, _) when tyconRefEq g tcref1 tcref2 -> + List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2 - | TType_app (tcref1, l1, _), TType_app (tcref2, l2, _) when tyconRefEq g tcref1 tcref2 -> - List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2 + | TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) -> + (evalTupInfoIsStruct anonInfo1.TupInfo = evalTupInfoIsStruct anonInfo2.TupInfo) && + (match anonInfo1.Assembly, anonInfo2.Assembly with ccu1, ccu2 -> ccuEq ccu1 ccu2) && + (anonInfo1.SortedNames = anonInfo2.SortedNames) && + List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2 - | TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) -> - (evalTupInfoIsStruct anonInfo1.TupInfo = evalTupInfoIsStruct anonInfo2.TupInfo) && - (match anonInfo1.Assembly, anonInfo2.Assembly with ccu1, ccu2 -> ccuEq ccu1 ccu2) && - (anonInfo1.SortedNames = anonInfo2.SortedNames) && - List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2 + | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) -> + evalTupInfoIsStruct tupInfo1 = evalTupInfoIsStruct tupInfo2 && + List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2 - | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2) -> - evalTupInfoIsStruct tupInfo1 = evalTupInfoIsStruct tupInfo2 && - List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2 + | TType_fun (domainTy1, rangeTy1, _), TType_fun (domainTy2, rangeTy2, _) -> + TypesFeasiblyEquivalent stripMeasures ndeep g amap m domainTy1 domainTy2 && + TypesFeasiblyEquivalent stripMeasures ndeep g amap m rangeTy1 rangeTy2 - | TType_fun (domainTy1, rangeTy1, _), TType_fun (domainTy2, rangeTy2, _) -> - TypesFeasiblyEquivalent stripMeasures ndeep g amap m domainTy1 domainTy2 && - TypesFeasiblyEquivalent stripMeasures ndeep g amap m rangeTy1 rangeTy2 + | _ -> + false - | _ -> - false + if g.langVersion.SupportsFeature LanguageFeature.UseTypeSubsumptionCache then + let key = TTypeFeasibleEquivCacheKey.TryGetFromStrippedTypes(stripMeasures, ty1, ty2) + match key with + | ValueNone -> computeEquiv ty1 ty2 + | ValueSome key1 ->(getTypeFeasibleEquivCache g).GetOrAdd(key1, fun _ -> computeEquiv ty1 ty2) + else + computeEquiv ty1 ty2 /// The feasible equivalence relation. Part of the language spec. let TypesFeasiblyEquiv ndeep g amap m ty1 ty2 = diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs index 28e1c7e5f00..29c8e70753b 100644 --- a/src/Compiler/Utilities/TypeHashing.fs +++ b/src/Compiler/Utilities/TypeHashing.fs @@ -505,7 +505,7 @@ module StructuralUtilities = | TType_measure m -> yield! emitMeasure m } - let private getTypeStructureOfStrippedType (ty: TType) = + let private getTypeStructureOfStrippedTypeUncached (ty: TType) = let env = { @@ -522,14 +522,14 @@ module StructuralUtilities = else Stable tokens // Speed up repeated calls by memoizing results for types that yield a stable structure. - let private memoize = + let private getTypeStructureOfStrippedType = WeakMap.cacheConditionally (function | Stable _ -> true | _ -> false) - getTypeStructureOfStrippedType + getTypeStructureOfStrippedTypeUncached let tryGetTypeStructureOfStrippedType ty = - match memoize ty with + match getTypeStructureOfStrippedType ty with | PossiblyInfinite -> ValueNone | ts -> ValueSome ts diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 8f5ace7aade..46198f98f41 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -353,6 +353,7 @@ + diff --git a/tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs b/tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs new file mode 100644 index 00000000000..178f273d168 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Optimizer/NestedApplications.fs @@ -0,0 +1,64 @@ +namespace FSharp.Compiler.ComponentTests.Optimizer + +open System.Text +open Xunit +open FSharp.Test +open FSharp.Test.Compiler +open FSharp.Test.Utilities + +module private Gen = + let nestedLetApps depth = + // Builds: let v1 = id 0 in let v2 = id v1 in ... in ignore vN + let sb = StringBuilder() + sb.AppendLine("module M") |> ignore + sb.AppendLine("let id x = x") |> ignore + sb.AppendLine("let run () =") |> ignore + for i in 1 .. depth do + if i = 1 then + sb.Append(" let v1 = id 0") |> ignore + else + sb.Append(" in let v").Append(i).Append(" = id v").Append(i-1) |> ignore + sb.AppendLine(" in ()") |> ignore + sb.ToString() + + let nestedDirectApps depth = + // Builds: let res = id(id(id(...(0)))) in ignore res + let sb = StringBuilder() + sb.AppendLine("module N") |> ignore + sb.AppendLine("let id x = x") |> ignore + sb.Append("let run () = let res = ") |> ignore + for _ in 1 .. depth do + sb.Append("id (") |> ignore + sb.Append("0") |> ignore + for _ in 1 .. depth do + sb.Append(")") |> ignore + sb.AppendLine(" in ignore res") |> ignore + sb.ToString() + +[] +type ``Nested application optimizer``() = + + // Moderate depths to keep CI stable while still exercising the quadratic shapes + [] + [] + [] + let ``let-chains of nested apps compile under --optimize+`` depth = + let src = Gen.nestedLetApps depth + FSharp src + |> withOptions [ "--optimize+"; "--times" ] + |> asExe + |> ignoreWarnings + |> compile + |> shouldSucceed + + [] + [] + [] + let ``direct nested application compiles under --optimize+`` depth = + let src = Gen.nestedDirectApps depth + FSharp src + |> withOptions [ "--optimize+"; "--times" ] + |> asExe + |> ignoreWarnings + |> compile + |> shouldSucceed \ No newline at end of file