diff --git a/eng/Build.ps1 b/eng/Build.ps1 index b1bac650541..cf7ce0413c0 100644 --- a/eng/Build.ps1 +++ b/eng/Build.ps1 @@ -61,6 +61,8 @@ param ( Set-StrictMode -version 2.0 $ErrorActionPreference = "Stop" +$BuildCategory = "" +$BuildMessage = "" function Print-Usage() { Write-Host "Common settings:" @@ -303,6 +305,9 @@ function EnablePreviewSdks() { } try { + $script:BuildCategory = "Build" + $script:BuildMessage = "Failure preparing build" + Process-Arguments . (Join-Path $PSScriptRoot "build-utils.ps1") @@ -317,9 +322,11 @@ try { } if ($bootstrap) { + $script:BuildMessage = "Failure building bootstrap compiler" $bootstrapDir = Make-BootstrapBuild } + $script:BuildMessage = "Failure building product" if ($restore -or $build -or $rebuild -or $pack -or $sign -or $publish) { if ($noVisualStudio) { BuildCompiler @@ -332,6 +339,8 @@ try { VerifyAssemblyVersionsAndSymbols } + $script:BuildCategory = "Test" + $script:BuildMessage = "Failure running tests" $desktopTargetFramework = "net472" $coreclrTargetFramework = "netcoreapp3.0" @@ -421,6 +430,7 @@ catch { Write-Host $_ Write-Host $_.Exception Write-Host $_.ScriptStackTrace + Write-PipelineTelemetryError -Category $script:BuildCategory -Message $script:BuildMessage ExitWithExitCode 1 } finally { diff --git a/eng/Versions.props b/eng/Versions.props index f7611980e00..64a7ddd7135 100644 --- a/eng/Versions.props +++ b/eng/Versions.props @@ -95,6 +95,7 @@ 4.3.0 4.3.0 4.5.0 + 4.5.0 $(RoslynVersion) $(RoslynVersion) diff --git a/eng/build.sh b/eng/build.sh index a53fce79146..6340d557466 100755 --- a/eng/build.sh +++ b/eng/build.sh @@ -66,6 +66,9 @@ properties="" docker=false args="" +BuildCategory="" +BuildMessage="" + if [[ $# = 0 ]] then usage @@ -150,6 +153,8 @@ done . "$scriptroot/common/tools.sh" function TestUsingNUnit() { + BuildCategory="Test" + BuildMessage="Error running tests" testproject="" targetframework="" while [[ $# > 0 ]]; do @@ -180,14 +185,12 @@ function TestUsingNUnit() { projectname="${projectname%.*}" testlogpath="$artifacts_dir/TestResults/$configuration/${projectname}_$targetframework.xml" args="test \"$testproject\" --no-restore --no-build -c $configuration -f $targetframework --test-adapter-path . --logger \"nunit;LogFilePath=$testlogpath\"" - "$DOTNET_INSTALL_DIR/dotnet" $args || { - local exit_code=$? - Write-PipelineTelemetryError -category 'Test' "dotnet test failed for $testproject:$targetframework (exit code $exit_code)." - ExitWithExitCode $exit_code - } + "$DOTNET_INSTALL_DIR/dotnet" $args || exit $? } function BuildSolution { + BuildCategory="Build" + BuildMessage="Error preparing build" local solution="FSharp.sln" echo "$solution:" @@ -229,33 +232,28 @@ function BuildSolution { rm -fr $bootstrap_dir fi if [ ! -f "$bootstrap_dir/fslex.dll" ]; then + BuildMessage="Error building tools" MSBuild "$repo_root/src/buildtools/buildtools.proj" \ /restore \ /p:Configuration=$bootstrap_config \ - /t:Publish || { - local exit_code=$? - Write-PipelineTelemetryError -category 'Build' "Error building buildtools (exit code '$exit_code')." - ExitWithExitCode $exit_code - } + /t:Publish mkdir -p "$bootstrap_dir" cp -pr $artifacts_dir/bin/fslex/$bootstrap_config/netcoreapp3.0/publish $bootstrap_dir/fslex cp -pr $artifacts_dir/bin/fsyacc/$bootstrap_config/netcoreapp3.0/publish $bootstrap_dir/fsyacc fi if [ ! -f "$bootstrap_dir/fsc.exe" ]; then + BuildMessage="Error building bootstrap" MSBuild "$repo_root/proto.proj" \ /restore \ /p:Configuration=$bootstrap_config \ - /t:Publish || { - local exit_code=$? - Write-PipelineTelemetryError -category 'Build' "Error building bootstrap compiler (exit code '$exit_code')." - ExitWithExitCode $exit_code - } + /t:Publish cp -pr $artifacts_dir/bin/fsc/$bootstrap_config/netcoreapp3.0/publish $bootstrap_dir/fsc fi # do real build + BuildMessage="Error building solution" MSBuild $toolset_build_proj \ $bl \ /v:$verbosity \ @@ -271,13 +269,20 @@ function BuildSolution { /p:ContinuousIntegrationBuild=$ci \ /p:QuietRestore=$quiet_restore \ /p:QuietRestoreBinaryLog="$binary_log" \ - $properties || { - local exit_code=$? - Write-PipelineTelemetryError -category 'Build' "Error building solution (exit code '$exit_code')." - ExitWithExitCode $exit_code - } + $properties +} + +function TrapAndReportError { + local exit_code=$? + if [[ ! $exit_code == 0 ]]; then + Write-PipelineTelemetryError -category $BuildCategory "$BuildMessage (exit code '$exit_code')." + ExitWithExitCode $exit_code + fi } +# allow early termination to report the appropriate build failure reason +trap TrapAndReportError EXIT + InitializeDotNetCli $restore BuildSolution @@ -293,4 +298,3 @@ if [[ "$test_core_clr" == true ]]; then fi ExitWithExitCode 0 - diff --git a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index f99d7aac7af..4ba9a9b2c32 100644 --- a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -680,6 +680,7 @@ + diff --git a/src/absil/bytes.fs b/src/absil/bytes.fs index 9ec17577937..754b9d49dd6 100644 --- a/src/absil/bytes.fs +++ b/src/absil/bytes.fs @@ -306,10 +306,11 @@ type ByteMemory with leaveOpen=false) mmf, mmf.CreateViewAccessor(0L, length, memoryMappedFileAccess), length + // Validate MMF with the access that was intended. match access with - | FileAccess.Read when not accessor.CanRead -> failwith "Cannot read file" - | FileAccess.Write when not accessor.CanWrite -> failwith "Cannot write file" - | _ when not accessor.CanRead || not accessor.CanWrite -> failwith "Cannot read or write file" + | FileAccess.Read when not accessor.CanRead -> invalidOp "Cannot read file" + | FileAccess.Write when not accessor.CanWrite -> invalidOp "Cannot write file" + | FileAccess.ReadWrite when not accessor.CanRead || not accessor.CanWrite -> invalidOp "Cannot read or write file" | _ -> () let safeHolder = diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 22171840542..c90e75a3ae6 100644 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -3756,6 +3756,38 @@ type TcConfigProvider = // TcImports //-------------------------------------------------------------------------- +[] +type TcImportsSafeDisposal + (disposeActions: ResizeArray unit>, +#if !NO_EXTENSIONTYPING + disposeTypeProviderActions: ResizeArray unit>, +#endif + compilationThread: ICompilationThread) = + + let mutable isDisposed = false + + let dispose () = + // disposing deliberately only closes this tcImports, not the ones up the chain + isDisposed <- true + if verbose then + dprintf "disposing of TcImports, %d binaries\n" disposeActions.Count +#if !NO_EXTENSIONTYPING + let actions = disposeTypeProviderActions + if actions.Count > 0 then + compilationThread.EnqueueWork (fun _ -> for action in actions do action()) +#endif + for action in disposeActions do action() + + override _.Finalize() = + dispose () + + interface IDisposable with + + member this.Dispose() = + if not isDisposed then + GC.SuppressFinalize this + dispose () + #if !NO_EXTENSIONTYPING // These are hacks in order to allow TcImports to be held as a weak reference inside a type provider. // The reason is due to older type providers compiled using an older TypeProviderSDK, that SDK used reflection on fields and properties to determine the contract. @@ -3800,34 +3832,24 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse let mutable dllTable: NameMap = NameMap.empty let mutable ccuInfos: ImportedAssembly list = [] let mutable ccuTable: NameMap = NameMap.empty - let mutable disposeActions = [] + let disposeActions = ResizeArray() let mutable disposed = false let mutable ilGlobalsOpt = ilGlobalsOpt let mutable tcGlobals = None #if !NO_EXTENSIONTYPING - let mutable disposeTypeProviderActions = [] + let disposeTypeProviderActions = ResizeArray() let mutable generatedTypeRoots = new System.Collections.Generic.Dictionary() let mutable tcImportsWeak = TcImportsWeakHack (WeakReference<_> this) #endif + + let disposal = new TcImportsSafeDisposal(disposeActions, disposeTypeProviderActions, compilationThread) let CheckDisposed() = if disposed then assert false let dispose () = CheckDisposed() - // disposing deliberately only closes this tcImports, not the ones up the chain - disposed <- true - if verbose then - dprintf "disposing of TcImports, %d binaries\n" disposeActions.Length -#if !NO_EXTENSIONTYPING - let actions = disposeTypeProviderActions - disposeTypeProviderActions <- [] - if actions.Length > 0 then - compilationThread.EnqueueWork (fun _ -> for action in actions do action()) -#endif - let actions = disposeActions - disposeActions <- [] - for action in actions do action() + (disposal :> IDisposable).Dispose() static let ccuHasType (ccu: CcuThunk) (nsname: string list) (tname: string) = let matchNameSpace (entityOpt: Entity option) n = @@ -4043,12 +4065,12 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse member private tcImports.AttachDisposeAction action = CheckDisposed() - disposeActions <- action :: disposeActions + disposeActions.Add action #if !NO_EXTENSIONTYPING member private tcImports.AttachDisposeTypeProviderAction action = CheckDisposed() - disposeTypeProviderActions <- action :: disposeTypeProviderActions + disposeTypeProviderActions.Add action #endif // Note: the returned binary reader is associated with the tcImports, i.e. when the tcImports are closed @@ -4781,9 +4803,6 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse knownUnresolved |> List.map (function UnresolvedAssemblyReference(file, originalReferences) -> file, originalReferences) |> List.iter reportAssemblyNotResolved - - override tcImports.Finalize () = - dispose () static member BuildNonFrameworkTcImports (ctok, tcConfigP: TcConfigProvider, tcGlobals: TcGlobals, baseTcImports, nonFrameworkReferences, knownUnresolved) = cancellable { @@ -4809,7 +4828,6 @@ and [] TcImports(tcConfigP: TcConfigProvider, initialResolutions: TcAsse interface System.IDisposable with member tcImports.Dispose() = dispose () - GC.SuppressFinalize tcImports override tcImports.ToString() = "TcImports(...)" diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 1fce009f616..6aa40c6ea96 100644 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -47,34 +47,48 @@ val FreshenMethInfo : range -> MethInfo -> TType list [] /// 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 -/// The type equation comes from a sequence expression. -| SequenceExpression of TType + + /// 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 + + /// The type equation comes from a sequence expression. + | SequenceExpression of TType exception ConstraintSolverTupleDiffLengths of displayEnv: DisplayEnv * TType list * TType list * range * range exception ConstraintSolverInfiniteTypes of displayEnv: DisplayEnv * contextInfo: ContextInfo * TType * TType * range * range @@ -116,7 +130,10 @@ type OptionalTrace = val SimplifyMeasuresInTypeScheme : TcGlobals -> bool -> Typars -> TType -> TyparConstraint list -> Typars val SolveTyparEqualsType : ConstraintSolverEnv -> int -> range -> OptionalTrace -> TType -> TType -> OperationResult val SolveTypeEqualsTypeKeepAbbrevs : 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/src/fsharp/FSharp.Build/Microsoft.FSharp.NetSdk.targets b/src/fsharp/FSharp.Build/Microsoft.FSharp.NetSdk.targets index a6923d4c177..de13273e2aa 100644 --- a/src/fsharp/FSharp.Build/Microsoft.FSharp.NetSdk.targets +++ b/src/fsharp/FSharp.Build/Microsoft.FSharp.NetSdk.targets @@ -66,17 +66,6 @@ WARNING: DO NOT MODIFY this file unless you are knowledgeable about MSBuild and - - - - Pkg$([System.String]::Copy('%(ResolvedCompileFileDefinitions.NugetPackageId)').Replace('.','_')) - $(%(EnhancedResolvedFile.PackageRootProperty))\content\%(ResolvedCompileFileDefinitions.FileName)%(ResolvedCompileFileDefinitions.Extension).fsx - - - - fsharp41 @@ -115,15 +104,4 @@ WARNING: DO NOT MODIFY this file unless you are knowledgeable about MSBuild and - - - - Pkg$([System.String]::Copy('%(ResolvedCompileFileDefinitions.NugetPackageId)').Replace('.','_')) - $(%(FsxResolvedFile.PackageRootProperty)) - $(%(FsxResolvedFile.PackageRootProperty))\content\%(ResolvedCompileFileDefinitions.FileName)%(ResolvedCompileFileDefinitions.Extension).fsx - - - diff --git a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj index 8710d929be5..c919f3056b1 100644 --- a/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj +++ b/src/fsharp/FSharp.Compiler.Private/FSharp.Compiler.Private.fsproj @@ -743,6 +743,7 @@ + diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 9534358624d..c39fad857fe 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -5273,7 +5273,7 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec, rhsExpr, _)) s // Workaround for .NET and Visual Studio restriction w.r.t debugger type proxys // Mark internal constructors in internal classes as public. let access = - if access = ILMemberAccess.Assembly && vspec.IsConstructor && IsHiddenTycon g eenv.sigToImplRemapInfo vspec.MemberApparentEntity.Deref then + if access = ILMemberAccess.Assembly && vspec.IsConstructor && IsHiddenTycon eenv.sigToImplRemapInfo vspec.MemberApparentEntity.Deref then ILMemberAccess.Public else access @@ -6488,7 +6488,7 @@ and GenModuleBinding cenv (cgbuf: CodeGenBuffer) (qname: QualifiedNameOfFile) la GenLetRecBindings cenv cgbuf eenv ([bind], m) | ModuleOrNamespaceBinding.Module (mspec, mdef) -> - let hidden = IsHiddenTycon cenv.g eenv.sigToImplRemapInfo mspec + let hidden = IsHiddenTycon eenv.sigToImplRemapInfo mspec let eenvinner = if mspec.IsNamespace then eenv else @@ -6827,8 +6827,8 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = let ilIntfTys = tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.map (GenType cenv.amap m eenvinner.tyenv) let ilTypeName = tref.Name - let hidden = IsHiddenTycon g eenv.sigToImplRemapInfo tycon - let hiddenRepr = hidden || IsHiddenTyconRepr g eenv.sigToImplRemapInfo tycon + let hidden = IsHiddenTycon eenv.sigToImplRemapInfo tycon + let hiddenRepr = hidden || IsHiddenTyconRepr eenv.sigToImplRemapInfo tycon let access = ComputeTypeAccess tref hidden // The implicit augmentation doesn't actually create CompareTo(object) or Object.Equals @@ -7411,7 +7411,7 @@ and GenExnDef cenv mgbuf eenv m (exnc: Tycon) = | TExnFresh _ -> let ilThisTy = GenExnType cenv.amap m eenv.tyenv exncref let tref = ilThisTy.TypeRef - let isHidden = IsHiddenTycon g eenv.sigToImplRemapInfo exnc + let isHidden = IsHiddenTycon eenv.sigToImplRemapInfo exnc let access = ComputeTypeAccess tref isHidden let reprAccess = ComputeMemberAccess isHidden let fspecs = exnc.TrueInstanceFieldsAsList diff --git a/src/fsharp/InfoReader.fs b/src/fsharp/InfoReader.fs index 5e655ed0e7e..1fac7a0f6ea 100644 --- a/src/fsharp/InfoReader.fs +++ b/src/fsharp/InfoReader.fs @@ -19,7 +19,7 @@ open FSharp.Compiler.Tastops open 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/MethodCalls.fs b/src/fsharp/MethodCalls.fs index 37f031e7824..9b657f6f8b9 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -498,6 +498,8 @@ type CalledMeth<'T> 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) @@ -1050,15 +1052,20 @@ let BuildFSharpMethodCall g m (ty, 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, ty, vref, _) -> BuildFSharpMethodCall g m (ty, vref) valUseFlags minst args |> fst + | DefaultStructCtor(_, ty) -> mkDefault (m, ty) + #if !NO_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 30f456fd86c..941de1c35e8 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -550,15 +550,30 @@ let AllPropInfosOfTypeInScope collectionSettings infoReader nenv optFilter ad fi @ ExtensionPropInfosOfTypeInScope collectionSettings infoReader nenv optFilter ad m ty /// Get the available methods of a type (both declared and inherited) -let IntrinsicMethInfosOfType (infoReader:InfoReader) optFilter ad allowMultiIntfInst findFlag m ty = +let IntrinsicMethInfosOfType (infoReader: InfoReader) optFilter ad allowMultiIntfInst findFlag m ty = let g = infoReader.g let amap = infoReader.amap let minfos = GetIntrinsicMethInfoSetsOfType infoReader optFilter ad allowMultiIntfInst findFlag m ty 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 !NO_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 SelectMethInfosFromExtMembers (infoReader: InfoReader) optFilter apparentTy m extMemInfos = let g = infoReader.g // NOTE: multiple "open"'s push multiple duplicate values into eIndexedExtensionMembers let seen = HashSet(ExtensionMember.Comparer g) @@ -575,24 +590,14 @@ let SelectMethInfosFromExtMembers (infoReader:InfoReader) optFilter apparentTy 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 !NO_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 -> () | _ -> () ] /// Query the available extension properties of a methods (including extension methods for inherited types) -let ExtensionMethInfosOfTypeInScope (collectionSettings:ResultCollectionSettings) (infoReader:InfoReader) (nenv: NameResolutionEnv) optFilter m ty = +let ExtensionMethInfosOfTypeInScope (collectionSettings: ResultCollectionSettings) (infoReader: InfoReader) (nenv: NameResolutionEnv) optFilter m ty = let extMemsDangling = SelectMethInfosFromExtMembers infoReader optFilter ty m nenv.eUnindexedExtensionMembers if collectionSettings = ResultCollectionSettings.AtMostOneResult && not (isNil extMemsDangling) then extMemsDangling @@ -1702,6 +1707,8 @@ type TcSymbolUses(g, capturedNameResolutions: ResizeArray, ResizeArray(), Array.empty) + /// An accumulator for the results being emitted into the tcSink. type TcResultsSinkImpl(g, ?sourceText: ISourceText) = let capturedEnvs = ResizeArray<_>() diff --git a/src/fsharp/NameResolution.fsi b/src/fsharp/NameResolution.fsi index ea3bbd8aeaf..c0121ce153e 100755 --- a/src/fsharp/NameResolution.fsi +++ b/src/fsharp/NameResolution.fsi @@ -141,25 +141,68 @@ 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 + + /// 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 = - {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. + 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 + + /// 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 @@ -326,6 +369,9 @@ type internal TcSymbolUses = /// Get the locations of all the printf format specifiers in the file member GetFormatSpecifierLocationsAndArity : unit -> (range * int)[] + /// Empty collection of symbol uses + static member Empty : TcSymbolUses + /// Represents open declaration statement. type internal OpenDeclaration = { /// Long identifier as it's presented in source code. @@ -542,3 +588,6 @@ 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/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 2420e636d24..aedf7252d9c 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -1926,8 +1926,8 @@ let CheckRecdField isUnion cenv env (tycon: Tycon) (rfield: RecdField) = let m = rfield.Range let fieldTy = stripTyEqns cenv.g rfield.FormalType let isHidden = - IsHiddenTycon cenv.g env.sigToImplRemapInfo tycon || - IsHiddenTyconRepr cenv.g env.sigToImplRemapInfo tycon || + IsHiddenTycon env.sigToImplRemapInfo tycon || + IsHiddenTyconRepr env.sigToImplRemapInfo tycon || (not isUnion && IsHiddenRecdField env.sigToImplRemapInfo (tcref.MakeNestedRecdFieldRef rfield)) let access = AdjustAccess isHidden (fun () -> tycon.CompilationPath) rfield.Accessibility CheckTypeForAccess cenv env (fun () -> rfield.Name) access m fieldTy @@ -2189,7 +2189,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = uc.RecdFieldsArray |> Array.iter (CheckRecdField true cenv env tycon)) // Access checks - let access = AdjustAccess (IsHiddenTycon g env.sigToImplRemapInfo tycon) (fun () -> tycon.CompilationPath) tycon.Accessibility + let access = AdjustAccess (IsHiddenTycon env.sigToImplRemapInfo tycon) (fun () -> tycon.CompilationPath) tycon.Accessibility let visitType ty = CheckTypeForAccess cenv env (fun () -> tycon.DisplayNameWithStaticParametersAndUnderscoreTypars) access tycon.Range ty abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> visitType) diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index fe30b314d15..3d474dadbcc 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -95,8 +95,14 @@ let emptyTyparInst = ([]: TyparInst) [] type Remap = { tpinst: TyparInst + + /// Values to remap valRemap: ValRemap + + /// TyconRefs to remap tyconRefRemap: TyconRefRemap + + /// Remove existing trait solutions? removeTraitSolutions: bool } let emptyRemap = @@ -889,7 +895,9 @@ type TypeEquivEnv with static member FromEquivTypars tps1 tps2 = TypeEquivEnv.Empty.BindEquivTypars tps1 tps2 -let rec traitsAEquivAux erasureFlag g aenv (TTrait(tys1, nm, mf1, argtys, rty, _)) (TTrait(tys2, nm2, mf2, argtys2, rty2, _)) = +let rec traitsAEquivAux erasureFlag g aenv traitInfo1 traitInfo2 = + let (TTrait(tys1, nm, mf1, argtys, rty, _)) = traitInfo1 + let (TTrait(tys2, nm2, mf2, argtys2, rty2, _)) = traitInfo2 mf1 = mf2 && nm = nm2 && ListSet.equals (typeAEquivAux erasureFlag g aenv) tys1 tys2 && @@ -909,7 +917,7 @@ and typarConstraintsAEquivAux erasureFlag g aenv tpc1 tpc2 = TyparConstraint.CoercesTo(fcty, _) -> typeAEquivAux erasureFlag g aenv acty fcty - | TyparConstraint.MayResolveMember(trait1, _), + | TyparConstraint.MayResolveMember(trait1, _), TyparConstraint.MayResolveMember(trait2, _) -> traitsAEquivAux erasureFlag g aenv trait1 trait2 @@ -2479,8 +2487,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 @@ -2494,7 +2500,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 @@ -4081,7 +4086,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 HiddenVals = Zset.add implVal mhi.HiddenVals } (mrpi, mhi) | Some (sigVal: Val) -> @@ -4105,7 +4109,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 @@ -4166,7 +4169,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 @@ -4222,16 +4224,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 @@ -4242,18 +4242,15 @@ 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.HiddenTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) mrmi x + +let IsHiddenTyconRepr mrmi x = IsHidden (fun mhi -> mhi.HiddenTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) mrmi x + +let IsHiddenVal mrmi x = IsHidden (fun mhi -> mhi.HiddenVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) mrmi x -let IsHiddenTycon g mrmi x = - let debugPrint x = DebugPrint.tyconL g x - IsHidden (fun mhi -> mhi.HiddenTycons) (fun tc -> tc.Accessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) debugPrint mrmi x -let IsHiddenTyconRepr g mrmi x = - let debugPrint x = DebugPrint.tyconL g x - IsHidden (fun mhi -> mhi.HiddenTyconReprs) (fun v -> v.TypeReprAccessibility) (fun rpi x -> (remapTyconRef rpi.tyconRefRemap (mkLocalTyconRef x)).Deref) debugPrint mrmi x -let IsHiddenVal mrmi x = IsHidden (fun mhi -> mhi.HiddenVals) (fun v -> v.Accessibility) (fun rpi x -> (remapValRef rpi (mkLocalValRef x)).Deref) DebugPrint.valL mrmi x -let IsHiddenRecdField mrmi x = IsHidden (fun mhi -> mhi.HiddenRecdFields) (fun rfref -> rfref.RecdField.Accessibility) (fun rpi x -> remapRecdFieldRef rpi.tyconRefRemap x) DebugPrint.recdFieldRefL mrmi x +let IsHiddenRecdField mrmi x = IsHidden (fun mhi -> mhi.HiddenRecdFields) (fun rfref -> rfref.RecdField.Accessibility) (fun rpi x -> remapRecdFieldRef rpi.tyconRefRemap x) mrmi x //-------------------------------------------------------------------------- // Generic operations on module types @@ -5725,7 +5722,7 @@ let rec tyOfExpr g e = | TOp.LValueOp (LByrefGet, v) -> destByrefTy g v.Type | TOp.LValueOp (LAddrOf readonly, v) -> mkByrefTyWithFlag g readonly v.Type | TOp.RefAddrGet readonly -> (match tinst with [ty] -> mkByrefTyWithFlag g readonly 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 @@ -7782,7 +7779,6 @@ let typarEnc _g (gtpsType, gtpsMethod) typar = "``0" 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 5179b85239e..176f64df72c 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -1208,16 +1208,16 @@ val MakeExportRemapping : CcuThunk -> ModuleOrNamespace -> Remap val ApplyExportRemappingToEntity : TcGlobals -> Remap -> ModuleOrNamespace -> ModuleOrNamespace /// Determine if a type definition is hidden by a signature -val IsHiddenTycon : TcGlobals -> (Remap * SignatureHidingInfo) list -> Tycon -> bool +val IsHiddenTycon: (Remap * SignatureHidingInfo) list -> Tycon -> bool /// Determine if the representation of a type definition is hidden by a signature -val IsHiddenTyconRepr : TcGlobals -> (Remap * SignatureHidingInfo) list -> Tycon -> bool +val IsHiddenTyconRepr: (Remap * SignatureHidingInfo) list -> Tycon -> bool /// Determine if a member, function or value is hidden by a signature -val IsHiddenVal : (Remap * SignatureHidingInfo) list -> Val -> bool +val IsHiddenVal: (Remap * SignatureHidingInfo) list -> Val -> bool /// Determine if a record field is hidden by a signature -val IsHiddenRecdField : (Remap * SignatureHidingInfo) list -> RecdFieldRef -> bool +val IsHiddenRecdField: (Remap * SignatureHidingInfo) list -> RecdFieldRef -> bool /// Adjust marks in expressions, replacing all marks by the given mark. /// Used when inlining. diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 5d7a170c2c8..539f67d844e 100644 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -223,7 +223,7 @@ type TcEnv = /// 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 @@ -324,7 +324,7 @@ let AddLocalValMap tcSink scopem (vals: Val NameMap) env = { env with eNameResEnv = AddValMapToNameEnv vals env.eNameResEnv eUngeneralizableItems = NameMap.foldBackRange (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems } - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env /// Add a list of local values to TcEnv and report them to the sink @@ -336,7 +336,7 @@ let AddLocalVals tcSink scopem (vals: Val list) env = { env with eNameResEnv = AddValListToNameEnv vals env.eNameResEnv eUngeneralizableItems = List.foldBack (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems } - CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) + CallEnvSink tcSink (scopem, env.NameEnv, env.AccessRights) env /// Add a local value to TcEnv and report it to the sink @@ -351,8 +351,8 @@ let AddLocalVal tcSink scopem v env = let AddLocalExnDefnAndReport tcSink scopem env (exnc: Tycon) = let env = { env with eNameResEnv = AddExceptionDeclsToNameEnv BulkAdd.No env.eNameResEnv (mkLocalEntityRef exnc) } // 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 /// Add a list of type definitions to TcEnv @@ -431,7 +431,7 @@ let AddModuleAbbreviationAndReport tcSink scopem id modrefs env = CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) 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 /// Add a "module X = ..." definition to the TcEnv @@ -558,7 +558,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) } + eNameResEnv = { env.NameEnv with eDisplayEnv = env.DisplayEnv.AddOpenPath (pathOfLid path) } eModuleOrNamespaceTypeAccumulator = mtypeAcc } /// Make an environment suitable for a module or namespace, creating a new accumulator. @@ -863,7 +863,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 | [] -> @@ -1301,7 +1301,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 -> @@ -1531,7 +1531,7 @@ let MakeAndPublishVal cenv env (altActualParent, inSig, declKind, vrec, vscheme, baseOrThisInfo = ValBaseOrThisInfo.MemberThisVal && vspec.LogicalName = "__" -> false | _ -> true - match cenv.tcSink.CurrentSink with + match cenv.tcSink.CurrentSink with | Some _ when not vspec.IsCompilerGenerated && shouldNotifySink vspec -> let nenv = AddFakeNamedValRefToNameEnv vspec.DisplayName env.NameEnv (mkLocalValRef vspec) CallEnvSink cenv.tcSink (vspec.Range, nenv, env.eAccessRights) @@ -1931,7 +1931,7 @@ let FreshenPossibleForallTy g m rigid ty = let tps, renaming, tinst = CopyAndFixupTypars m rigid tpsorig tpsorig, tps, tinst, instType renaming tau -let infoOfTyconRef m (tcref: TyconRef) = +let FreshenTyconRef2 m (tcref: TyconRef) = let tps, renaming, tinst = FreshenTypeInst m (tcref.Typars m) tps, renaming, tinst, TType_app (tcref, tinst) @@ -2119,24 +2119,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 @@ -2291,17 +2291,17 @@ module GeneralizationHelpers = (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, + m, + freeInEnv: FreeTypars, + canInferTypars, + genConstrainedTyparFlag, + inlineFlag, + exprOpt, + allDeclaredTypars: Typars, + maxInferredTypars: Typars, + tauTy, resultFirst) = let allDeclaredTypars = NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g allDeclaredTypars @@ -2534,7 +2534,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 @@ -2545,7 +2545,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) @@ -3278,7 +3278,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 @@ -4419,7 +4419,7 @@ 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) TTrait(tys, logicalCompiledName, memberFlags, argTys, returnTy, ref None), tpenv | _ -> error(Error(FSComp.SR.tcInvalidConstraint(), m)) @@ -4580,7 +4580,7 @@ and TcTyparOrMeasurePar optKind cenv (env: TcEnv) newOk tpenv (Typar(id, _, _) a | 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) res, tpenv @@ -4608,7 +4608,7 @@ and TcTyparOrMeasurePar optKind cenv (env: TcEnv) newOk tpenv (Typar(id, _, _) a // 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 = @@ -4648,7 +4648,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: SyntacticUnscope | 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)) @@ -4880,7 +4880,7 @@ and TcStaticConstantParameter cenv (env: TcEnv) tpenv kind (v: SynType) idOpt co 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 @@ -5060,7 +5060,7 @@ and TcProvidedTypeApp cenv env tpenv tcref args m = /// 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.eAccessRights tcref |> ignore + CheckTyconAccessible cenv.amap m env.AccessRights tcref |> ignore CheckEntityAttributes g tcref m |> CommitOperationResult #if !NO_EXTENSIONTYPING @@ -5069,7 +5069,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 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. @@ -5250,7 +5250,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 (vspec.LogicalName.StartsWithOrdinal("_")) 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 @@ -5275,7 +5275,7 @@ and TcPatAndRecover warnOnUpper cenv (env: TcEnv) topValInfo vFlags (tpenv, name /// 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 @@ -5354,7 +5354,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | SynConstructorArgs.NamePatPairs (pairs, _) -> pairs.Length if numArgs <> 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 [] @@ -5425,7 +5425,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) @@ -5492,12 +5492,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 @@ -5512,7 +5512,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 @@ -5531,7 +5531,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m)) | Some lit -> let _, _, _, vexpty, _, _ = TcVal true cenv env tpenv vref None None m - CheckValAccessible m env.eAccessRights vref + CheckValAccessible m env.AccessRights vref CheckFSharpAttributes cenv.g vref.Attribs m |> CommitOperationResult checkNoArgsForLiteral() UnifyTypes cenv env m ty vexpty @@ -5563,7 +5563,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 m tcref UnifyTypes cenv env m ty gtyp let fields = tcref.TrueInstanceFieldsAsList let ftys = fields |> List.map (fun fsp -> actualTyOfRecdField inst fsp, fsp) @@ -5587,6 +5587,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv, names, takenNames) ty p | 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) @@ -5813,7 +5814,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: 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) let env = ShrinkContext env mWholeExprIncludingParentheses expr2.Range TcExpr cenv overallTy env tpenv expr2 @@ -5821,11 +5822,11 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = | SynExpr.TypeApp _ | SynExpr.Ident _ | SynExpr.LongIdent _ | SynExpr.App _ | SynExpr.DotGet _ -> error(Error(FSComp.SR.tcExprUndelayed(), synExpr.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 (synConst, 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 synConst | SynExpr.Lambda _ -> @@ -5941,7 +5942,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = TcAnonRecdExpr cenv overallTy env tpenv (isStruct, optOrigExpr, unsortedFieldExprs, mWholeExpr) | 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) @@ -5973,7 +5974,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: SynExpr) = 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, synGuardExpr, synBodyExpr, m) -> @@ -5991,7 +5992,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: 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 @@ -6192,11 +6193,12 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: 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 @@ -6243,7 +6245,7 @@ and TcExprUndelayed cenv overallTy env tpenv (synExpr: 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) @@ -6293,7 +6295,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 @@ -6495,7 +6497,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)) @@ -6514,7 +6516,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 @@ -6543,7 +6545,7 @@ and TcCtorCall isNaked cenv env tpenv overallTy objTy mObjTyOpt item superInit a | Item.DelegateCtor ty, [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 ty arg ExprAtomicFlag.NonAtomic delayed @@ -6884,7 +6886,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 || @@ -6926,7 +6928,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 @@ -7132,7 +7134,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 mWholeExpr tcref UnifyTypes cenv env mWholeExpr overallTy gtyp [ for n, v in fldsList do @@ -7723,7 +7725,7 @@ and TcComputationExpression cenv env overallTy mWhole (interpExpr: Expr) builder 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 @@ -9046,8 +9048,8 @@ 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 g mItem aparity n - let _, _, tinst, _ = infoOfTyconRef mItem ucref.TyconRef - let ucinfo = UnionCaseInfo(tinst, ucref) + let _, _, tinst, _ = FreshenTyconRef2 mItem ucref.TyconRef + let ucinfo = UnionCaseInfo (tinst, ucref) ApplyUnionCaseOrExnTypes mItem cenv env ucaseAppTy (Item.UnionCase(ucinfo, false)) | _ -> ApplyUnionCaseOrExnTypes mItem cenv env ucaseAppTy item @@ -9301,6 +9303,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 @@ -9441,8 +9444,8 @@ and TcItemThen cenv overallTy env tpenv (item, mItem, rest, afterResolution) del | DelayedSet(e2, mStmt) :: otherDelayed -> if not (isNil otherDelayed) then error(Error(FSComp.SR.tcInvalidAssignment(), mStmt)) UnifyTypes cenv env mStmt overallTy g.unit_ty - vref.Deref.SetHasBeenReferenced() - CheckValAccessible mItem env.eAccessRights vref + vref.Deref.SetHasBeenReferenced() + CheckValAccessible mItem env.AccessRights vref CheckValAttributes g vref mItem |> CommitOperationResult let vty = vref.Type let vty2 = @@ -9637,7 +9640,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 @@ -10085,7 +10088,7 @@ and TcMethodApplication if meth.UsesParamArrayConversion then yield makeOneCalledMeth (minfo, pinfoOpt, false) ] - let uniquelyResolved = + let uniquelyResolved = let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv UnifyUniqueOverloading csenv callerArgCounts methodName ad preArgumentTypeCheckingCalledMethGroup returnTy @@ -10842,7 +10845,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)) { envinner with eNameResEnv = AddActivePatternResultTagsToNameEnv apinfo envinner.eNameResEnv ty m } | None -> @@ -11750,7 +11753,6 @@ and AnalyzeAndMakeAndPublishRecursiveValue overridesOK isGeneratedEventVal cenv let item = Item.Value (mkLocalValRef vspec) 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 diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index dd32a6ee001..98788809725 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -133,7 +133,7 @@ let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) = match tpc with | TyparConstraint.CoercesTo(x, m) -> join m x, m - | TyparConstraint.MayResolveMember(TTrait(_, _, _, _, _, _), m) -> + | TyparConstraint.MayResolveMember(_traitInfo, m) -> maxSoFar, m | TyparConstraint.SimpleChoice(_, m) -> errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInPrintf(), m)) diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs index e140b3351f5..c717d9b6e3a 100644 --- a/src/fsharp/fsc.fs +++ b/src/fsharp/fsc.fs @@ -1978,7 +1978,7 @@ let main1OfAst (ctok, legacyReferenceResolver, reduceMemoryUsage, assemblyName, 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 @@ -2024,7 +2024,7 @@ 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 diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 83d7ab4c358..1db4e36b356 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -870,9 +870,7 @@ type ILMethInfo = // MethInfo -#if DEBUG [] -#endif /// Describes an F# use of a method [] type MethInfo = @@ -955,7 +953,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 @@ -965,7 +962,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 = @@ -2247,6 +2243,8 @@ type PropInfo = | ProvidedProp(_, pi, _) -> ProvidedPropertyInfo.TaintedGetHashCode pi #endif + override x.ToString() = "property " + x.PropertyName + //------------------------------------------------------------------------- // ILEventInfo @@ -2494,6 +2492,7 @@ type EventInfo = #if !NO_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/service/IncrementalBuild.fs b/src/fsharp/service/IncrementalBuild.fs index de773fd3aa3..5e36f94b558 100755 --- a/src/fsharp/service/IncrementalBuild.fs +++ b/src/fsharp/service/IncrementalBuild.fs @@ -1208,7 +1208,7 @@ type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals, tcState: type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInputs, nonFrameworkResolutions, unresolvedReferences, tcConfig: TcConfig, projectDirectory, outfile, assemblyName, niceNameGen: NiceNameGenerator, lexResourceManager, sourceFiles, loadClosureOpt: LoadClosure option, - keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds) = + keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds, keepAllBackgroundSymbolUses) = let tcConfigP = TcConfigProvider.Constant tcConfig let fileParsed = new Event() @@ -1386,7 +1386,7 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput let implFile = if keepAssemblyContents then implFile else None let tcResolutions = if keepAllBackgroundResolutions then sink.GetResolutions() else TcResolutions.Empty let tcEnvAtEndOfFile = (if keepAllBackgroundResolutions then tcEnvAtEndOfFile else tcState.TcEnvFromImpls) - let tcSymbolUses = sink.GetSymbolUses() + let tcSymbolUses = if keepAllBackgroundSymbolUses then sink.GetSymbolUses() else TcSymbolUses.Empty RequireCompilationThread ctok // Note: events get raised on the CompilationThread @@ -1700,7 +1700,7 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput projectReferences, projectDirectory, useScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds, - tryGetMetadataSnapshot, suggestNamesForErrors) = + tryGetMetadataSnapshot, suggestNamesForErrors, keepAllBackgroundSymbolUses) = let useSimpleResolutionSwitch = "--simpleresolution" cancellable { @@ -1820,7 +1820,8 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput resourceManager, sourceFilesNew, loadClosureOpt, keepAssemblyContents=keepAssemblyContents, keepAllBackgroundResolutions=keepAllBackgroundResolutions, - maxTimeShareMilliseconds=maxTimeShareMilliseconds) + maxTimeShareMilliseconds=maxTimeShareMilliseconds, + keepAllBackgroundSymbolUses=keepAllBackgroundSymbolUses) return Some builder with e -> errorRecoveryNoRange e diff --git a/src/fsharp/service/IncrementalBuild.fsi b/src/fsharp/service/IncrementalBuild.fsi index fb60dbff690..d775c92fcce 100755 --- a/src/fsharp/service/IncrementalBuild.fsi +++ b/src/fsharp/service/IncrementalBuild.fsi @@ -161,7 +161,7 @@ type internal IncrementalBuilder = /// This may be a marginally long-running operation (parses are relatively quick, only one file needs to be parsed) member GetParseResultsForFile : CompilationThreadToken * filename:string -> Cancellable - static member TryCreateBackgroundBuilderForProjectOptions : CompilationThreadToken * ReferenceResolver.Resolver * defaultFSharpBinariesDir: string * FrameworkImportsCache * scriptClosureOptions:LoadClosure option * sourceFiles:string list * commandLineArgs:string list * projectReferences: IProjectReference list * projectDirectory:string * useScriptResolutionRules:bool * keepAssemblyContents: bool * keepAllBackgroundResolutions: bool * maxTimeShareMilliseconds: int64 * tryGetMetadataSnapshot: ILBinaryReader.ILReaderTryGetMetadataSnapshot * suggestNamesForErrors: bool -> Cancellable + static member TryCreateBackgroundBuilderForProjectOptions : CompilationThreadToken * ReferenceResolver.Resolver * defaultFSharpBinariesDir: string * FrameworkImportsCache * scriptClosureOptions:LoadClosure option * sourceFiles:string list * commandLineArgs:string list * projectReferences: IProjectReference list * projectDirectory:string * useScriptResolutionRules:bool * keepAssemblyContents: bool * keepAllBackgroundResolutions: bool * maxTimeShareMilliseconds: int64 * tryGetMetadataSnapshot: ILBinaryReader.ILReaderTryGetMetadataSnapshot * suggestNamesForErrors: bool * keepAllBackgroundSymbolUses: bool -> Cancellable /// Generalized Incremental Builder. This is exposed only for unit testing purposes. module internal IncrementalBuild = diff --git a/src/fsharp/service/service.fs b/src/fsharp/service/service.fs index 7030262aab5..978d6cd087f 100644 --- a/src/fsharp/service/service.fs +++ b/src/fsharp/service/service.fs @@ -249,7 +249,7 @@ type ScriptClosureCacheToken() = interface LockToken // There is only one instance of this type, held in FSharpChecker -type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot, suggestNamesForErrors) as self = +type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot, suggestNamesForErrors, keepAllBackgroundSymbolUses) as self = // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.reactor: The one and only Reactor let reactor = Reactor.Singleton let beforeFileChecked = Event() @@ -306,7 +306,7 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC (ctok, legacyReferenceResolver, FSharpCheckerResultsSettings.defaultFSharpBinariesDir, frameworkTcImportsCache, loadClosure, Array.toList options.SourceFiles, Array.toList options.OtherOptions, projectReferences, options.ProjectDirectory, options.UseScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions, FSharpCheckerResultsSettings.maxTimeShareMilliseconds, - tryGetMetadataSnapshot, suggestNamesForErrors) + tryGetMetadataSnapshot, suggestNamesForErrors, keepAllBackgroundSymbolUses) match builderOpt with | None -> () @@ -905,9 +905,10 @@ type FSharpChecker(legacyReferenceResolver, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot, - suggestNamesForErrors) = + suggestNamesForErrors, + keepAllBackgroundSymbolUses) = - let backgroundCompiler = BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot, suggestNamesForErrors) + let backgroundCompiler = BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot, suggestNamesForErrors, keepAllBackgroundSymbolUses) static let globalInstance = lazy FSharpChecker.Create() @@ -924,7 +925,7 @@ type FSharpChecker(legacyReferenceResolver, let maxMemEvent = new Event() /// Instantiate an interactive checker. - static member Create(?projectCacheSize, ?keepAssemblyContents, ?keepAllBackgroundResolutions, ?legacyReferenceResolver, ?tryGetMetadataSnapshot, ?suggestNamesForErrors) = + static member Create(?projectCacheSize, ?keepAssemblyContents, ?keepAllBackgroundResolutions, ?legacyReferenceResolver, ?tryGetMetadataSnapshot, ?suggestNamesForErrors, ?keepAllBackgroundSymbolUses) = let legacyReferenceResolver = match legacyReferenceResolver with @@ -936,7 +937,8 @@ type FSharpChecker(legacyReferenceResolver, let projectCacheSizeReal = defaultArg projectCacheSize projectCacheSizeDefault let tryGetMetadataSnapshot = defaultArg tryGetMetadataSnapshot (fun _ -> None) let suggestNamesForErrors = defaultArg suggestNamesForErrors false - new FSharpChecker(legacyReferenceResolver, projectCacheSizeReal,keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot, suggestNamesForErrors) + let keepAllBackgroundSymbolUses = defaultArg keepAllBackgroundSymbolUses true + new FSharpChecker(legacyReferenceResolver, projectCacheSizeReal,keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot, suggestNamesForErrors, keepAllBackgroundSymbolUses) member __.ReferenceResolver = legacyReferenceResolver diff --git a/src/fsharp/service/service.fsi b/src/fsharp/service/service.fsi index 182714e8d64..c463f2a2eef 100755 --- a/src/fsharp/service/service.fsi +++ b/src/fsharp/service/service.fsi @@ -77,7 +77,7 @@ type public FSharpChecker = /// If false, do not keep full intermediate checking results from background checking suitable for returning from GetBackgroundCheckResultsForFileInProject. This reduces memory usage. /// An optional resolver for non-file references, for legacy purposes /// An optional resolver to access the contents of .NET binaries in a memory-efficient way - static member Create : ?projectCacheSize: int * ?keepAssemblyContents: bool * ?keepAllBackgroundResolutions: bool * ?legacyReferenceResolver: ReferenceResolver.Resolver * ?tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot * ?suggestNamesForErrors: bool -> FSharpChecker + static member Create : ?projectCacheSize: int * ?keepAssemblyContents: bool * ?keepAllBackgroundResolutions: bool * ?legacyReferenceResolver: ReferenceResolver.Resolver * ?tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot * ?suggestNamesForErrors: bool * ?keepAllBackgroundSymbolUses: bool -> FSharpChecker /// /// Parse a source code file, returning information about brace matching in the file. diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index a6d5ae499ad..27caa7b6008 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -2357,7 +2357,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 /// 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 @@ -2408,6 +2408,9 @@ and /// Get the member name associated with the member constraint. 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) @@ -4880,7 +4883,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/src/utils/prim-parsing.fs b/src/utils/prim-parsing.fs index b58e592278d..996cdc67d59 100644 --- a/src/utils/prim-parsing.fs +++ b/src/utils/prim-parsing.fs @@ -7,6 +7,7 @@ namespace Internal.Utilities.Text.Parsing open Internal.Utilities.Text.Lexing open System +open System.Buffers exception RecoverableParseError exception Accept of obj @@ -131,11 +132,7 @@ module internal Implementation = //------------------------------------------------------------------------- // Read the tables written by FSYACC. - type AssocTable(elemTab:uint16[], offsetTab:uint16[]) = - let cacheSize = 7919 // the 1000'th prime - // Use a simpler hash table with faster lookup, but only one - // hash bucket per key. - let cache = Array.zeroCreate (cacheSize * 2) + type AssocTable(elemTab: uint16[], offsetTab: uint16[], cache: int[], cacheSize: int) = member t.ReadAssoc (minElemNum,maxElemNum,defaultValueOfAssoc,keyToFind) = // do a binary chop on the table @@ -234,8 +231,21 @@ module internal Implementation = let ruleValues = (Array.zeroCreate 100 : obj[]) let lhsPos = (Array.zeroCreate 2 : Position[]) let reductions = tables.reductions - let actionTable = new AssocTable(tables.actionTableElements, tables.actionTableRowOffsets) - let gotoTable = new AssocTable(tables.gotos, tables.sparseGotoTableRowOffsets) + let cacheSize = 7919 // the 1000'th prime + // Use a simpler hash table with faster lookup, but only one + // hash bucket per key. + let actionTableCache = ArrayPool.Shared.Rent(cacheSize * 2) + let gotoTableCache = ArrayPool.Shared.Rent(cacheSize * 2) + // Clear the arrays since ArrayPool does not + Array.Clear(actionTableCache, 0, actionTableCache.Length) + Array.Clear(gotoTableCache, 0, gotoTableCache.Length) + use _cacheDisposal = + { new IDisposable with + member _.Dispose() = + ArrayPool.Shared.Return actionTableCache + ArrayPool.Shared.Return gotoTableCache } + let actionTable = AssocTable(tables.actionTableElements, tables.actionTableRowOffsets, actionTableCache, cacheSize) + let gotoTable = AssocTable(tables.gotos, tables.sparseGotoTableRowOffsets, gotoTableCache, cacheSize) let stateToProdIdxsTable = new IdxToIdxListTable(tables.stateToProdIdxsTableElements, tables.stateToProdIdxsTableRowOffsets) let parseState =