diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index 563f0afcbfb..cfa5411ee33 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -321,6 +321,7 @@ stages: - script: eng\CIBuildNoPublish.cmd -compressallmetadata -buildnorealsig -testDesktop -configuration Release -testBatch $(System.JobPositionInPhase) env: + FSharp_CacheEvictionImmediate: true DOTNET_DbgEnableMiniDump: 1 DOTNET_DbgMiniDumpType: 3 # Triage dump, 1 for mini, 2 for Heap, 3 for triage, 4 for full. Don't use 4 unless you know what you're doing. DOTNET_DbgMiniDumpName: $(Build.SourcesDirectory)\artifacts\log\Release\$(Build.BuildId)-%e-%p-%t.dmp @@ -456,11 +457,13 @@ stages: fsharpqa_release: _configuration: Release _testKind: testFSharpQA + FSharp_CacheEvictionImmediate: true transparentCompiler: vs_release: _configuration: Release _testKind: testVs setupVsHive: true + FSharp_CacheEvictionImmediate: true transparentCompiler: transparent_compiler_release: _configuration: Release @@ -559,6 +562,7 @@ stages: - script: eng\CIBuildNoPublish.cmd -compressallmetadata -configuration Release -testDesktop -testBatch $(System.JobPositionInPhase) env: + FSharp_CacheEvictionImmediate: true DOTNET_DbgEnableMiniDump: 1 DOTNET_DbgMiniDumpType: 3 # Triage dump, 1 for mini, 2 for Heap, 3 for triage, 4 for full. Don't use 4 unless you know what you're doing. DOTNET_DbgMiniDumpName: $(Build.SourcesDirectory)\artifacts\log\Release\$(Build.BuildId)-%e-%p-%t.dmp diff --git a/src/Compiler/Checking/CheckBasics.fs b/src/Compiler/Checking/CheckBasics.fs index 7cbca970cc3..1b71371b4ea 100644 --- a/src/Compiler/Checking/CheckBasics.fs +++ b/src/Compiler/Checking/CheckBasics.fs @@ -243,11 +243,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 @@ -319,8 +315,6 @@ type TcFileState = diagnosticOptions: FSharpDiagnosticOptions - argInfoCache: ConcurrentDictionary<(string * range), ArgReprInfo> - // forward call TcPat: WarnOnUpperFlag -> TcFileState -> TcEnv -> PrelimValReprInfo option -> TcPatValFlags -> TcPatLinearEnv -> TType -> SynPat -> (TcPatPhase2Input -> Pattern) * TcPatLinearEnv @@ -370,7 +364,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 179752c394c..6c6537d1165 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<(string * range), ArgReprInfo> - // forward call TcPat: WarnOnUpperFlag diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index cbf79fbdfb3..21447e50281 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -5618,8 +5618,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 ef5eae5c996..99c6648cf2b 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -958,8 +958,12 @@ 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)) = +let TranslateTopArgSynInfo cenv isArg m tcAttributes (SynArgInfo(Attributes attrs, isOpt, nm)) = // Synthesize an artificial "OptionalArgument" attribute for the parameter let optAttrs = if isOpt then @@ -980,20 +984,14 @@ let TranslateTopArgSynInfo (cenv: cenv) isArg m tcAttributes (SynArgInfo(Attribu // Call the attribute checking function let attribs = tcAttributes (optAttrs@attrs) - let key = nm |> Option.map (fun id -> id.idText, id.idRange) + 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. @@ -6384,9 +6382,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/InfoReader.fs b/src/Compiler/Checking/InfoReader.fs index b8a0efd14af..6a17b25136e 100644 --- a/src/Compiler/Checking/InfoReader.fs +++ b/src/Compiler/Checking/InfoReader.fs @@ -727,9 +727,9 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = /// Make a cache for function 'f' keyed by type (plus some additional 'flags') that only /// caches computations for monomorphic types. - let MakeInfoCache f (flagsEq : IEqualityComparer<_>) = + let MakeInfoCache name f (flagsEq : IEqualityComparer<_>) = MemoizationTable<_, _> - (compute=f, + (name, compute=f, // Only cache closed, monomorphic types (closed = all members for the type // have been processed). Generic type instantiations could be processed if we had // a decent hash function for these. @@ -803,18 +803,18 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = member _.GetHashCode((ad, nm)) = AccessorDomain.CustomGetHashCode ad + hash nm member _.Equals((ad1, nm1), (ad2, nm2)) = AccessorDomain.CustomEquals(g, ad1, ad2) && (nm1 = nm2) } - let methodInfoCache = MakeInfoCache GetIntrinsicMethodSetsUncached hashFlags0 - let propertyInfoCache = MakeInfoCache GetIntrinsicPropertySetsUncached hashFlags0 - let recdOrClassFieldInfoCache = MakeInfoCache GetIntrinsicRecdOrClassFieldInfosUncached hashFlags1 - let ilFieldInfoCache = MakeInfoCache GetIntrinsicILFieldInfosUncached hashFlags1 - let eventInfoCache = MakeInfoCache GetIntrinsicEventInfosUncached hashFlags1 - let namedItemsCache = MakeInfoCache GetIntrinsicNamedItemsUncached hashFlags2 - let mostSpecificOverrideMethodInfoCache = MakeInfoCache GetIntrinsicMostSpecificOverrideMethodSetsUncached hashFlags0 - - let entireTypeHierarchyCache = MakeInfoCache GetEntireTypeHierarchyUncached HashIdentity.Structural - let primaryTypeHierarchyCache = MakeInfoCache GetPrimaryTypeHierarchyUncached HashIdentity.Structural - let implicitConversionCache = MakeInfoCache FindImplicitConversionsUncached hashFlags3 - let isInterfaceWithStaticAbstractMethodCache = MakeInfoCache IsInterfaceTypeWithMatchingStaticAbstractMemberUncached hashFlags4 + let methodInfoCache = MakeInfoCache "methodInfoCache" GetIntrinsicMethodSetsUncached hashFlags0 + let propertyInfoCache = MakeInfoCache "propertyInfoCache" GetIntrinsicPropertySetsUncached hashFlags0 + let recdOrClassFieldInfoCache = MakeInfoCache "recdOrClassFieldInfoCache" GetIntrinsicRecdOrClassFieldInfosUncached hashFlags1 + let ilFieldInfoCache = MakeInfoCache "ilFieldInfoCache" GetIntrinsicILFieldInfosUncached hashFlags1 + let eventInfoCache = MakeInfoCache "eventInfoCache" GetIntrinsicEventInfosUncached hashFlags1 + let namedItemsCache = MakeInfoCache "namedItemsCache" GetIntrinsicNamedItemsUncached hashFlags2 + let mostSpecificOverrideMethodInfoCache = MakeInfoCache "mostSpecificOverrideMethodInfoCache" GetIntrinsicMostSpecificOverrideMethodSetsUncached hashFlags0 + + let entireTypeHierarchyCache = MakeInfoCache "entireTypeHierarchyCache" GetEntireTypeHierarchyUncached HashIdentity.Structural + let primaryTypeHierarchyCache = MakeInfoCache "primaryTypeHierarchyCache" GetPrimaryTypeHierarchyUncached HashIdentity.Structural + let implicitConversionCache = MakeInfoCache "implicitConversionCache" FindImplicitConversionsUncached hashFlags3 + let isInterfaceWithStaticAbstractMethodCache = MakeInfoCache "isInterfaceWithStaticAbstractMethodCache" IsInterfaceTypeWithMatchingStaticAbstractMemberUncached hashFlags4 // Runtime feature support diff --git a/src/Compiler/Checking/TypeRelations.fs b/src/Compiler/Checking/TypeRelations.fs index 27274f7ebda..2d047482763 100644 --- a/src/Compiler/Checking/TypeRelations.fs +++ b/src/Compiler/Checking/TypeRelations.fs @@ -40,6 +40,38 @@ let getTypeSubsumptionCache = new Caches.Cache(options, "typeSubsumptionCache") Extras.WeakMap.getOrCreate factory +// Cache for feasible equivalence checks +[] +type TTypeFeasibleEquivCacheKey = + | TTypeFeasibleEquivCacheKey of TypeStructure * TypeStructure * bool + static member FromStrippedTypes(stripMeasures: bool, ty1: TType, ty2: TType) = + TTypeFeasibleEquivCacheKey(getTypeStructure ty1, getTypeStructure ty2, 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 FromStrippedTypes(ty1: TType, ty2: TType) = + TTypeDefinitelySubsumesNoCoerceCacheKey(getTypeStructure ty1, getTypeStructure ty2) + +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. // @@ -59,20 +91,28 @@ let rec TypeDefinitelySubsumesTypeNoCoercion ndeep g amap m ty1 ty2 = else 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)))) + let checkSubsumes () = + // 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.FromStrippedTypes(ty1, ty2) + (getTypeDefinitelySubsumesNoCoerceCache g).GetOrAdd(key, fun _ -> checkSubsumes ()) + else + checkSubsumes () let stripAll stripMeasures g ty = if stripMeasures then @@ -89,30 +129,42 @@ 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 cache = getTypeFeasibleEquivCache g + let key1 = TTypeFeasibleEquivCacheKey.FromStrippedTypes(stripMeasures, ty1, ty2) + let res = cache.GetOrAdd(key1, fun _ -> computeEquiv ty1 ty2) + // Cache the symmetric result as well since this relation is symmetric + let key2 = TTypeFeasibleEquivCacheKey.FromStrippedTypes(stripMeasures, ty2, ty1) + cache.GetOrAdd(key2, fun _ -> res) |> ignore + res + 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/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 32b04b8c90f..fdca4495fda 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -2334,6 +2334,7 @@ and AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbuf // A memoization table for generating value types for big constant arrays let rawDataValueTypeGenerator = MemoizationTable( + "rawDataValueTypeGenerator", (fun (cloc, size) -> let name = CompilerGeneratedName("T" + string (newUnique ()) + "_" + string size + "Bytes") // Type names ending ...$T_37Bytes diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 5db9b2e1b29..a249c5d2bb1 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -114,6 +114,8 @@ + + @@ -147,8 +149,6 @@ - - diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index ee5a3c38670..9999b801606 100644 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -687,7 +687,7 @@ type TcGlobals( // Build the memoization table for files let v_memoize_file = - MemoizationTable(compute, keyComparer = HashIdentity.Structural) + MemoizationTable("v_memoize_file", compute, keyComparer = HashIdentity.Structural) let v_and_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "&" , None , None , [], mk_rel_sig v_bool_ty) let v_addrof_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "~&" , None , None , [vara], ([[varaTy]], mkByrefTy varaTy)) diff --git a/src/Compiler/Utilities/Caches.fs b/src/Compiler/Utilities/Caches.fs index 51216a4ea6a..aedc7f7b8e4 100644 --- a/src/Compiler/Utilities/Caches.fs +++ b/src/Compiler/Utilities/Caches.fs @@ -194,12 +194,23 @@ type CacheOptions<'Key> = } module CacheOptions = + let forceImmediate = + try + Environment.GetEnvironmentVariable("FSharp_CacheEvictionImmediate") <> null + with _ -> + false + + let defaultEvictionMode = + if forceImmediate then + EvictionMode.Immediate + else + EvictionMode.MailboxProcessor let getDefault comparer = { CacheOptions.TotalCapacity = 1024 CacheOptions.HeadroomPercentage = 50 - CacheOptions.EvictionMode = EvictionMode.MailboxProcessor + CacheOptions.EvictionMode = defaultEvictionMode CacheOptions.Comparer = comparer } diff --git a/src/Compiler/Utilities/TypeHashing.fs b/src/Compiler/Utilities/TypeHashing.fs index af536a9d2b6..01bc4b34cff 100644 --- a/src/Compiler/Utilities/TypeHashing.fs +++ b/src/Compiler/Utilities/TypeHashing.fs @@ -10,6 +10,7 @@ open FSharp.Compiler.TypedTree open FSharp.Compiler.TypedTreeBasics open FSharp.Compiler.TypedTreeOps open System.Collections.Immutable +open System type ObserverVisibility = | PublicOnly @@ -382,7 +383,7 @@ module StructuralUtilities = [] type NeverEqual = struct - interface System.IEquatable with + interface IEquatable with member _.Equals _ = false override _.Equals _ = false diff --git a/src/Compiler/Utilities/illib.fs b/src/Compiler/Utilities/illib.fs index 470d7402e07..aa83558632b 100644 --- a/src/Compiler/Utilities/illib.fs +++ b/src/Compiler/Utilities/illib.fs @@ -11,6 +11,8 @@ open System.Threading open System.Threading.Tasks open System.Runtime.CompilerServices +open FSharp.Compiler.Caches + [] type InterruptibleLazy<'T> private (value, valueFactory: unit -> 'T) = let syncObj = obj () @@ -950,10 +952,11 @@ type UniqueStampGenerator<'T when 'T: equality and 'T: not null>() = member _.Table = encodeTable.Keys /// memoize tables (all entries cached, never collected) -type MemoizationTable<'T, 'U when 'T: not null>(compute: 'T -> 'U, keyComparer: IEqualityComparer<'T>, ?canMemoize) = +type MemoizationTable<'T, 'U when 'T: not null>(name, compute: 'T -> 'U, keyComparer: IEqualityComparer<'T>, ?canMemoize) = - let table = new ConcurrentDictionary<'T, Lazy<'U>>(keyComparer) - let computeFunc = Func<_, _>(fun key -> lazy (compute key)) + let options = CacheOptions.getDefault keyComparer |> CacheOptions.withNoEviction + let table = new Cache<'T, Lazy<'U>>(options, name) + let computeFunc key = lazy compute key member t.Apply x = if diff --git a/src/Compiler/Utilities/illib.fsi b/src/Compiler/Utilities/illib.fsi index e2fba355366..654a7259d82 100644 --- a/src/Compiler/Utilities/illib.fsi +++ b/src/Compiler/Utilities/illib.fsi @@ -386,7 +386,8 @@ type internal UniqueStampGenerator<'T when 'T: equality and 'T: not null> = type internal MemoizationTable<'T, 'U when 'T: not null> = new: - compute: ('T -> 'U) * keyComparer: IEqualityComparer<'T> * ?canMemoize: ('T -> bool) -> MemoizationTable<'T, 'U> + name: string * compute: ('T -> 'U) * keyComparer: IEqualityComparer<'T> * ?canMemoize: ('T -> bool) -> + MemoizationTable<'T, 'U> member Apply: x: 'T -> 'U diff --git a/tests/Directory.Build.props b/tests/Directory.Build.props index c2f0cf4bed4..4e5c4f25528 100644 --- a/tests/Directory.Build.props +++ b/tests/Directory.Build.props @@ -16,6 +16,7 @@ false false true + true diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 960057baf98..78d9fa0020d 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -351,6 +351,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 diff --git a/tests/FSharp.Test.Utilities/CompilerAssert.fs b/tests/FSharp.Test.Utilities/CompilerAssert.fs index d04b39bc04e..c9a760a5f93 100644 --- a/tests/FSharp.Test.Utilities/CompilerAssert.fs +++ b/tests/FSharp.Test.Utilities/CompilerAssert.fs @@ -376,7 +376,7 @@ module CompilerAssertHelpers = let setup = AppDomainSetup(ApplicationBase = thisAssemblyDirectory) let testCaseDomain = AppDomain.CreateDomain($"built app {assembly}", null, setup) - testCaseDomain.add_AssemblyResolve(fun _ args -> + let handler = ResolveEventHandler(fun _ args -> dependecies |> List.tryFind (fun path -> Path.GetFileNameWithoutExtension path = AssemblyName(args.Name).Name) |> Option.filter FileSystem.FileExistsShim @@ -384,6 +384,8 @@ module CompilerAssertHelpers = |> Option.toObj ) + testCaseDomain.add_AssemblyResolve handler + let worker = (testCaseDomain.CreateInstanceFromAndUnwrap(typeof.Assembly.CodeBase, typeof.FullName)) :?> Worker @@ -391,8 +393,8 @@ module CompilerAssertHelpers = // Replay streams captured in appdomain. printf $"{output}" eprintf $"{errors}" - - AppDomain.Unload testCaseDomain + + testCaseDomain.remove_AssemblyResolve handler outcome, output, errors diff --git a/tests/FSharp.Test.Utilities/XunitHelpers.fs b/tests/FSharp.Test.Utilities/XunitHelpers.fs index 1823c5a1b6a..74e982b4a37 100644 --- a/tests/FSharp.Test.Utilities/XunitHelpers.fs +++ b/tests/FSharp.Test.Utilities/XunitHelpers.fs @@ -195,6 +195,8 @@ type OpenTelemetryExport(testRunName, enable) = // However, we want to ensure that OneTimeSetup is called only once per test run. module OneTimeSetup = + open System.Threading + let init = lazy #if !NETCOREAPP @@ -202,6 +204,7 @@ module OneTimeSetup = log "Adding AssemblyResolver" AssemblyResolver.addResolver () #endif + log $"Server GC enabled: {System.Runtime.GCSettings.IsServerGC}" log "Installing TestConsole redirection" TestConsole.install() diff --git a/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs b/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs index 6ffb3cd7d95..256bfbed2c6 100644 --- a/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs +++ b/vsintegration/src/FSharp.Editor/Common/DebugHelpers.fs @@ -31,6 +31,7 @@ open Config open System.Diagnostics.Metrics open System.Text open Microsoft.VisualStudio.Threading +open Microsoft.VisualStudio.FSharp.Editor.CancellableTasks module FSharpOutputPane = @@ -56,29 +57,17 @@ module FSharpOutputPane = let private log logType msg = task { System.Diagnostics.Trace.TraceInformation(msg) - let time = DateTime.Now.ToString("hh:mm:ss tt") - let! pane = pane.GetValueAsync() do! ThreadHelper.JoinableTaskFactory.SwitchToMainThreadAsync() match logType with - | LogType.Message -> - String.Format("[{0}{1}] {2}{3}", "", time, msg, Environment.NewLine) - |> pane.OutputStringThreadSafe - |> ignore - | LogType.Info -> - String.Format("[{0}{1}] {2}{3}", "INFO ", time, msg, Environment.NewLine) - |> pane.OutputStringThreadSafe - |> ignore - | LogType.Warn -> - String.Format("[{0}{1}] {2}{3}", "WARN ", time, msg, Environment.NewLine) - |> pane.OutputStringThreadSafe - |> ignore - | LogType.Error -> - String.Format("[{0}{1}] {2}{3}", "ERROR ", time, msg, Environment.NewLine) - |> pane.OutputStringThreadSafe - |> ignore + | LogType.Message -> $"{msg}" + | LogType.Info -> $"[INFO] {msg}" + | LogType.Warn -> $"[WARN] {msg}" + | LogType.Error -> $"[ERROR] {msg}" + |> pane.OutputStringThreadSafe + |> ignore } |> ignore @@ -102,6 +91,7 @@ module FSharpOutputPane = module FSharpServiceTelemetry = open FSharp.Compiler.Caches + open System.Threading.Tasks let listen filter = let indent (activity: Activity) = @@ -130,6 +120,16 @@ module FSharpServiceTelemetry = ActivitySource.AddActivityListener(listener) + let periodicallyDisplayCacheStats (disposalToken: Threading.CancellationToken) = + cancellableTask { + use _ = CacheMetrics.ListenToAll() + + while true do + do! Task.Delay(TimeSpan.FromSeconds 10.0) + FSharpOutputPane.logMsg (CacheMetrics.StatsToString()) + } + |> CancellableTask.start disposalToken + #if DEBUG open OpenTelemetry.Resources open OpenTelemetry.Trace diff --git a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs index 08318997477..afa9a961e53 100644 --- a/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs +++ b/vsintegration/src/FSharp.Editor/LanguageService/LanguageService.fs @@ -407,6 +407,9 @@ type internal FSharpPackage() as this = globalOptions.BlockForCompletionItems <- false + DebugHelpers.FSharpServiceTelemetry.periodicallyDisplayCacheStats this.DisposalToken + |> ignore + } |> CancellableTask.startAsTask cancellationToken) )