diff --git a/NuGet.Config b/NuGet.Config index 72f6d27ef5..f4c19635b0 100644 --- a/NuGet.Config +++ b/NuGet.Config @@ -1,4 +1,4 @@ - + @@ -10,4 +10,4 @@ - + \ No newline at end of file diff --git a/PublishToBlob.proj b/PublishToBlob.proj index c4b4991b9a..6d71be84df 100644 --- a/PublishToBlob.proj +++ b/PublishToBlob.proj @@ -10,7 +10,7 @@ Microsoft.DotNet.Build.Tasks.Feed - 1.0.0-prerelease-02219-01 + 2.1.0-prerelease-02419-02 diff --git a/fcs/.gitignore b/fcs/.gitignore new file mode 100644 index 0000000000..176f453284 --- /dev/null +++ b/fcs/.gitignore @@ -0,0 +1,10 @@ +FSharp.Compiler.Service.netstandard/illex.fs +FSharp.Compiler.Service.netstandard/ilpars.fs +FSharp.Compiler.Service.netstandard/ilpars.fsi +FSharp.Compiler.Service.netstandard/lex.fs +FSharp.Compiler.Service.netstandard/pars.fs +FSharp.Compiler.Service.netstandard/pars.fsi +FSharp.Compiler.Service.netstandard/pplex.fs +FSharp.Compiler.Service.netstandard/pppars.fs +FSharp.Compiler.Service.netstandard/pppars.fsi + diff --git a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index 8d7f42d4ee..ce45abbc31 100644 --- a/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/fcs/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -651,7 +651,7 @@ - $(FSharpSourcesRoot)\..\packages\System.ValueTuple.4.3.1\lib\netstandard1.0\System.ValueTuple.dll + $(FSharpSourcesRoot)\..\packages\System.ValueTuple.4.4.0\lib\netstandard1.0\System.ValueTuple.dll diff --git a/fcs/README.md b/fcs/README.md index d297185ee6..290012d34e 100644 --- a/fcs/README.md +++ b/fcs/README.md @@ -60,9 +60,9 @@ which does things like: Yu can push the packages if you have permissions, either automatically using ``build Release`` or manually set APIKEY=... - .nuget\nuget.exe push release\fcs\FSharp.Compiler.Service.21.0.1.nupkg %APIKEY% -Source https://nuget.org - .nuget\nuget.exe push release\fcs\FSharp.Compiler.Service.MSBuild.v12.21.0.1.nupkg %APIKEY% -Source https://nuget.org - .nuget\nuget.exe push release\fcs\FSharp.Compiler.Service.ProjectCracker.21.0.1.nupkg %APIKEY% -Source https://nuget.org + .nuget\nuget.exe push release\fcs\FSharp.Compiler.Service.22.0.1.nupkg %APIKEY% -Source https://nuget.org + .nuget\nuget.exe push release\fcs\FSharp.Compiler.Service.MSBuild.v12.22.0.1.nupkg %APIKEY% -Source https://nuget.org + .nuget\nuget.exe push release\fcs\FSharp.Compiler.Service.ProjectCracker.22.0.1.nupkg %APIKEY% -Source https://nuget.org ### Use of Paket and FAKE diff --git a/fcs/RELEASE_NOTES.md b/fcs/RELEASE_NOTES.md index 4708e1f2b8..0d83971b13 100644 --- a/fcs/RELEASE_NOTES.md +++ b/fcs/RELEASE_NOTES.md @@ -1,3 +1,7 @@ +#### 22.0.1 + * Integrate visualfsharp master + * Includes recent memory usage reduction work for ByteFile and ILAttributes + #### 21.0.1 * Use new .NET SDK project files * FSharp.Compiler.Service nuget now uses net45 and netstandard2.0 diff --git a/fcs/build.fsx b/fcs/build.fsx index 29ee4f111b..79c214683c 100644 --- a/fcs/build.fsx +++ b/fcs/build.fsx @@ -20,7 +20,8 @@ let isMono = true let isMono = false #endif -let dotnetExePath = DotNetCli.InstallDotNetSDK "2.1.4" + +let dotnetExePath = DotNetCli.InstallDotNetSDK "2.1.102" let runDotnet workingDir args = let result = diff --git a/fcs/fcs.props b/fcs/fcs.props index c3e2198b38..646b8ccbf9 100644 --- a/fcs/fcs.props +++ b/fcs/fcs.props @@ -3,7 +3,7 @@ - 21.0.1 + 22.0.1 $(FSharpSourcesRoot)\..\packages\FSharp.Compiler.Tools.4.1.27\tools diff --git a/packages.config b/packages.config index 01feddf7d5..7458826a65 100644 --- a/packages.config +++ b/packages.config @@ -13,6 +13,7 @@ + @@ -27,13 +28,13 @@ - + - + diff --git a/src/absil/il.fs b/src/absil/il.fs index 3316f156e6..ce8ee4065e 100644 --- a/src/absil/il.fs +++ b/src/absil/il.fs @@ -7,16 +7,19 @@ module Microsoft.FSharp.Compiler.AbstractIL.IL #nowarn "346" // The struct, record or union type 'IlxExtensionType' has an explicit implementation of 'Object.Equals'. ... -open Internal.Utilities -open Microsoft.FSharp.Compiler.AbstractIL -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open Microsoft.FSharp.Compiler.AbstractIL.Internal -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open System open System.Collections open System.Collections.Generic open System.Collections.Concurrent open System.Runtime.CompilerServices open System.Reflection + +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library + +open Internal.Utilities let logging = false @@ -42,7 +45,7 @@ let _ = if logging then dprintn "* warning: Il.logging is on" let int_order = LanguagePrimitives.FastGenericComparer -let notlazy v = Lazy.CreateFromValue v +let notlazy v = Lazy<_>.CreateFromValue v /// A little ugly, but the idea is that if a data structure does not /// contain lazy values then we don't add laziness. So if the thing to map @@ -321,12 +324,12 @@ type PublicKey = [] type AssemblyRefData = - { assemRefName: string; - assemRefHash: byte[] option; - assemRefPublicKeyInfo: PublicKey option; - assemRefRetargetable: bool; - assemRefVersion: ILVersionInfo option; - assemRefLocale: Locale option; } + { assemRefName: string + assemRefHash: byte[] option + assemRefPublicKeyInfo: PublicKey option + assemRefRetargetable: bool + assemRefVersion: ILVersionInfo option + assemRefLocale: Locale option } /// Global state: table of all assembly references keyed by AssemblyRefData. let AssemblyRefUniqueStampGenerator = new UniqueStampGenerator() @@ -721,11 +724,11 @@ let mkILCallSig (cc,args,ret) = { ArgTypes=args; CallingConv=cc; ReturnType=ret} let mkILBoxedType (tspec:ILTypeSpec) = tspec.TypeRef.AsBoxedType tspec type ILMethodRef = - { mrefParent: ILTypeRef; - mrefCallconv: ILCallingConv; - mrefGenericArity: int; - mrefName: string; - mrefArgs: ILTypes; + { mrefParent: ILTypeRef + mrefCallconv: ILCallingConv + mrefGenericArity: int + mrefName: string + mrefArgs: ILTypes mrefReturn: ILType } member x.DeclaringTypeRef = x.mrefParent member x.CallingConv = x.mrefCallconv @@ -736,8 +739,10 @@ type ILMethodRef = member x.ReturnType = x.mrefReturn member x.CallingSignature = mkILCallSig (x.CallingConv,x.ArgTypes,x.ReturnType) + static member Create(a,b,c,d,e,f) = { mrefParent= a;mrefCallconv=b;mrefName=c;mrefGenericArity=d; mrefArgs=e;mrefReturn=f } + override x.ToString() = x.DeclaringTypeRef.ToString() + "::" + x.Name + "(...)" @@ -750,9 +755,9 @@ type ILFieldRef = [] type ILMethodSpec = - { mspecMethodRef: ILMethodRef; - mspecDeclaringType: ILType; - mspecMethodInst: ILGenericArgs; } + { mspecMethodRef: ILMethodRef + mspecDeclaringType: ILType + mspecMethodInst: ILGenericArgs } static member Create(a,b,c) = { mspecDeclaringType=a; mspecMethodRef =b; mspecMethodInst=c } member x.MethodRef = x.mspecMethodRef member x.DeclaringType=x.mspecDeclaringType @@ -764,16 +769,14 @@ type ILMethodSpec = member x.FormalReturnType = x.MethodRef.ReturnType override x.ToString() = x.MethodRef.ToString() + "(...)" - type ILFieldSpec = - { FieldRef: ILFieldRef; + { FieldRef: ILFieldRef DeclaringType: ILType } member x.FormalType = x.FieldRef.Type member x.Name = x.FieldRef.Name member x.DeclaringTypeRef = x.FieldRef.DeclaringTypeRef override x.ToString() = x.FieldRef.ToString() - // -------------------------------------------------------------------- // Debug info. // -------------------------------------------------------------------- @@ -844,16 +847,34 @@ type ILAttribElem = type ILAttributeNamedArg = (string * ILType * bool * ILAttribElem) type ILAttribute = - { Method: ILMethodSpec; + { Method: ILMethodSpec Data: byte[] Elements: ILAttribElem list} -[] -type ILAttributes(f: unit -> ILAttribute[]) = - let mutable array = InlineDelayInit<_>(f) - member x.AsArray = array.Value +[] +type ILAttributes(array : ILAttribute[]) = + member x.AsArray = array member x.AsList = x.AsArray |> Array.toList +[] +type ILAttributesStored = + /// Computed by ilread.fs based on metadata index + | Reader of (int32 -> ILAttribute[]) + /// Already computed + | Given of ILAttributes + member x.GetCustomAttrs metadataIndex = + match x with + | Reader f -> ILAttributes(f metadataIndex) + | Given attrs -> attrs + +let emptyILCustomAttrs = ILAttributes [| |] +let mkILCustomAttrsFromArray (attrs: ILAttribute[]) = if attrs.Length = 0 then emptyILCustomAttrs else ILAttributes attrs +let mkILCustomAttrs l = match l with [] -> emptyILCustomAttrs | _ -> mkILCustomAttrsFromArray (List.toArray l) + +let emptyILCustomAttrsStored = ILAttributesStored.Given emptyILCustomAttrs +let storeILCustomAttrs (attrs: ILAttributes) = if attrs.AsArray.Length = 0 then emptyILCustomAttrsStored else ILAttributesStored.Given attrs +let mkILCustomAttrsReader f = ILAttributesStored.Reader f + type ILCodeLabel = int // -------------------------------------------------------------------- @@ -1233,14 +1254,31 @@ type | DemandChoice [] -type ILPermission = - | PermissionSet of ILSecurityAction * byte[] +type ILSecurityDecl = + | ILSecurityDecl of ILSecurityAction * byte[] + +[] +type ILSecurityDecls(array : ILSecurityDecl[]) = + member x.AsArray = array + member x.AsList = x.AsArray |> Array.toList + +[] +type ILSecurityDeclsStored = + /// Computed by ilread.fs based on metadata index + | Reader of (int32 -> ILSecurityDecl[]) + /// Already computed + | Given of ILSecurityDecls + member x.GetSecurityDecls metadataIndex = + match x with + | Reader f -> ILSecurityDecls(f metadataIndex) + | Given attrs -> attrs + +let emptyILSecurityDecls = ILSecurityDecls [| |] +let emptyILSecurityDeclsStored = ILSecurityDeclsStored.Given emptyILSecurityDecls +let mkILSecurityDecls l = match l with [] -> emptyILSecurityDecls | _ -> ILSecurityDecls (Array.ofList l) +let storeILSecurityDecls (x: ILSecurityDecls) = if x.AsArray.Length = 0 then emptyILSecurityDeclsStored else ILSecurityDeclsStored.Given x +let mkILSecurityDeclsReader f = ILSecurityDeclsStored.Reader f -[] -type ILPermissions = - | SecurityDecls of ILPermission list - | SecurityDeclsLazy of Lazy - member x.AsList = match x with SecurityDecls m -> m | SecurityDeclsLazy m -> m.Force() [] type PInvokeCharBestFit = @@ -1272,33 +1310,37 @@ type PInvokeCharEncoding = [] type PInvokeMethod = - { Where: ILModuleRef; - Name: string; - CallingConv: PInvokeCallingConvention; - CharEncoding: PInvokeCharEncoding; - NoMangle: bool; - LastError: bool; - ThrowOnUnmappableChar: PInvokeThrowOnUnmappableChar; + { Where: ILModuleRef + Name: string + CallingConv: PInvokeCallingConvention + CharEncoding: PInvokeCharEncoding + NoMangle: bool + LastError: bool + ThrowOnUnmappableChar: PInvokeThrowOnUnmappableChar CharBestFit: PInvokeCharBestFit } [] type ILParameter = - { Name: string option; - Type: ILType; - Default: ILFieldInit option; - Marshal: ILNativeType option; - IsIn: bool; - IsOut: bool; - IsOptional: bool; - CustomAttrs: ILAttributes } + { Name: string option + Type: ILType + Default: ILFieldInit option + Marshal: ILNativeType option + IsIn: bool + IsOut: bool + IsOptional: bool + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex type ILParameters = list [] type ILReturn = - { Marshal: ILNativeType option; - Type: ILType; - CustomAttrs: ILAttributes } + { Marshal: ILNativeType option + Type: ILType + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex type ILOverridesSpec = | OverridesSpec of ILMethodRef * ILType @@ -1324,6 +1366,7 @@ type MethodBody = | PInvoke of PInvokeMethod (* platform invoke to native *) | Abstract | Native + | NotAvailable type ILLazyMethodBody = | ILLazyMethodBody of Lazy @@ -1335,7 +1378,7 @@ type MethodCodeKind = | Native | Runtime -let mkMethBodyAux mb = ILLazyMethodBody (Lazy.CreateFromValue mb) +let mkMethBodyAux mb = ILLazyMethodBody (notlazy mb) let mkMethBodyLazyAux mb = ILLazyMethodBody mb let typesOfILParams (ps:ILParameters) : ILTypes = ps |> List.map (fun p -> p.Type) @@ -1347,14 +1390,16 @@ type ILGenericVariance = | ContraVariant type ILGenericParameterDef = - { Name: string; - Constraints: ILTypes; - Variance: ILGenericVariance; - HasReferenceTypeConstraint: bool; - CustomAttrs : ILAttributes; - HasNotNullableValueTypeConstraint: bool; - HasDefaultConstructorConstraint: bool; } - + { Name: string + Constraints: ILTypes + Variance: ILGenericVariance + HasReferenceTypeConstraint: bool + HasNotNullableValueTypeConstraint: bool + HasDefaultConstructorConstraint: bool + CustomAttrsStored : ILAttributesStored + MetadataIndex: int32 } + + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex override x.ToString() = x.Name type ILGenericParameterDefs = ILGenericParameterDef list @@ -1380,29 +1425,58 @@ let convertMemberAccess (ilMemberAccess:ILMemberAccess) = let inline conditionalAdd condition flagToAdd source = if condition then source ||| flagToAdd else source &&& ~~~flagToAdd +let NoMetadataIdx = -1 + [] -type ILMethodDef = - { Name: string; - Attributes: MethodAttributes; - ImplAttributes: MethodImplAttributes; - CallingConv: ILCallingConv; - Parameters: ILParameters; - Return: ILReturn; - mdBody: ILLazyMethodBody; - SecurityDecls: ILPermissions; - IsEntryPoint:bool; - GenericParams: ILGenericParameterDefs; - CustomAttrs: ILAttributes; } +type ILMethodDef (name: string, attributes: MethodAttributes, implAttributes: MethodImplAttributes, callingConv: ILCallingConv, + parameters: ILParameters, ret: ILReturn, body: ILLazyMethodBody, isEntryPoint:bool, genericParams: ILGenericParameterDefs, + securityDeclsStored: ILSecurityDeclsStored, customAttrsStored: ILAttributesStored, metadataIndex: int32) = + + new (name, attributes, implAttributes, callingConv, parameters, ret, body, isEntryPoint, genericParams, securityDecls, customAttrs) = + ILMethodDef(name, attributes, implAttributes, callingConv, parameters, ret, body, isEntryPoint, genericParams, + storeILSecurityDecls securityDecls, storeILCustomAttrs customAttrs, NoMetadataIdx) + + // The captured data - remember the object will be as large as the data captured by these members + member __.Name = name + member __.Attributes = attributes + member __.ImplAttributes = implAttributes + member __.CallingConv = callingConv + member __.Parameters = parameters + member __.Return = ret + member __.Body = body + member __.SecurityDeclsStored = securityDeclsStored + member __.IsEntryPoint = isEntryPoint + member __.GenericParams = genericParams + member __.CustomAttrsStored = customAttrsStored + member __.MetadataIndex = metadataIndex + + member x.With (?name: string, ?attributes: MethodAttributes, ?implAttributes: MethodImplAttributes, ?callingConv: ILCallingConv, ?parameters: ILParameters, ?ret: ILReturn, ?body: ILLazyMethodBody, ?securityDecls: ILSecurityDecls, ?isEntryPoint:bool, ?genericParams: ILGenericParameterDefs, ?customAttrs: ILAttributes) = + ILMethodDef (name = defaultArg name x.Name, + attributes = defaultArg attributes x.Attributes, + implAttributes = defaultArg implAttributes x.ImplAttributes, + callingConv = defaultArg callingConv x.CallingConv, + parameters = defaultArg parameters x.Parameters, + ret = defaultArg ret x.Return, + body = defaultArg body x.Body, + securityDecls = (match securityDecls with None -> x.SecurityDecls | Some attrs -> attrs), + isEntryPoint = defaultArg isEntryPoint x.IsEntryPoint, + genericParams = defaultArg genericParams x.GenericParams, + customAttrs=(match customAttrs with None -> x.CustomAttrs | Some attrs -> attrs)) + + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs metadataIndex + member x.SecurityDecls = x.SecurityDeclsStored.GetSecurityDecls x.MetadataIndex member x.ParameterTypes = typesOfILParams x.Parameters - // Whidbey feature: SafeHandle finalizer must be run + member md.Code = - match md.mdBody.Contents with + match md.Body.Contents with | MethodBody.IL il-> Some il.Code | _ -> None - member x.IsIL = match x.mdBody.Contents with | MethodBody.IL _ -> true | _ -> false - member x.Locals = match x.mdBody.Contents with | MethodBody.IL il -> il.Locals | _ -> [] - member x.MethodBody = match x.mdBody.Contents with MethodBody.IL il -> il | _ -> failwith "not IL" + member x.IsIL = match x.Body.Contents with | MethodBody.IL _ -> true | _ -> false + + member x.Locals = match x.Body.Contents with | MethodBody.IL il -> il.Locals | _ -> [] + + member x.MethodBody = match x.Body.Contents with MethodBody.IL il -> il | _ -> failwith "not IL" member x.SourceMarker = x.MethodBody.SourceMarker member x.MaxStack = x.MethodBody.MaxStack @@ -1436,24 +1510,23 @@ type ILMethodDef = member x.IsAggressiveInline= x.ImplAttributes &&& MethodImplAttributes.AggressiveInlining <> enum 0 member x.IsMustRun = x.ImplAttributes &&& MethodImplAttributes.NoOptimization <> enum 0 - member x.WithSpecialName = { x with Attributes = x.Attributes ||| MethodAttributes.SpecialName } + member x.WithSpecialName = x.With(attributes = (x.Attributes ||| MethodAttributes.SpecialName)) member x.WithHideBySig() = - { x with - Attributes = + x.With(attributes = ( if x.IsVirtual then x.Attributes &&& ~~~MethodAttributes.CheckAccessOnOverride ||| MethodAttributes.HideBySig - else failwith "WithHideBySig" } - member x.WithHideBySig(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition MethodAttributes.HideBySig} - member x.WithFinal(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition MethodAttributes.Final} - member x.WithAbstract(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition MethodAttributes.Abstract} - member x.WithAccess(access) = { x with Attributes = x.Attributes &&& ~~~MethodAttributes.MemberAccessMask ||| convertMemberAccess access } - member x.WithNewSlot = { x with Attributes = x.Attributes ||| MethodAttributes.NewSlot } - member x.WithSecurity(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition MethodAttributes.HasSecurity} - member x.WithPInvoke(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition MethodAttributes.PinvokeImpl} - member x.WithPreserveSig(condition) = { x with ImplAttributes = x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.PreserveSig} - member x.WithSynchronized(condition) = { x with ImplAttributes = x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.Synchronized} - member x.WithNoInlining(condition) = { x with ImplAttributes = x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.NoInlining} - member x.WithAggressiveInlining(condition) = { x with ImplAttributes = x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.AggressiveInlining} - member x.WithRuntime(condition) = { x with ImplAttributes = x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.Runtime} + else failwith "WithHideBySig")) + member x.WithHideBySig(condition) = x.With(attributes = (x.Attributes |> conditionalAdd condition MethodAttributes.HideBySig)) + member x.WithFinal(condition) = x.With(attributes = (x.Attributes |> conditionalAdd condition MethodAttributes.Final)) + member x.WithAbstract(condition) = x.With(attributes = (x.Attributes |> conditionalAdd condition MethodAttributes.Abstract)) + member x.WithAccess(access) = x.With(attributes = (x.Attributes &&& ~~~MethodAttributes.MemberAccessMask ||| convertMemberAccess access)) + member x.WithNewSlot = x.With(attributes = (x.Attributes ||| MethodAttributes.NewSlot)) + member x.WithSecurity(condition) = x.With(attributes = (x.Attributes |> conditionalAdd condition MethodAttributes.HasSecurity)) + member x.WithPInvoke(condition) = x.With(attributes = (x.Attributes |> conditionalAdd condition MethodAttributes.PinvokeImpl)) + member x.WithPreserveSig(condition) = x.With(implAttributes = (x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.PreserveSig)) + member x.WithSynchronized(condition) = x.With(implAttributes = (x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.Synchronized)) + member x.WithNoInlining(condition) = x.With(implAttributes = (x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.NoInlining)) + member x.WithAggressiveInlining(condition) = x.With(implAttributes = (x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.AggressiveInlining)) + member x.WithRuntime(condition) = x.With(implAttributes = (x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.Runtime)) /// Index table by name and arity. type MethodDefMap = Map @@ -1486,37 +1559,74 @@ type ILMethodDefs(f : (unit -> ILMethodDef[])) = member x.FindByNameAndArity (nm,arity) = x.FindByName nm |> List.filter (fun x -> List.length x.Parameters = arity) [] -type ILEventDef = - { Type: ILType option; - Name: string; - Attributes: EventAttributes - AddMethod: ILMethodRef; - RemoveMethod: ILMethodRef; - FireMethod: ILMethodRef option; - OtherMethods: ILMethodRef list; - CustomAttrs: ILAttributes; } +type ILEventDef(eventType: ILType option, name: string, attributes: EventAttributes, addMethod: ILMethodRef, removeMethod: ILMethodRef, fireMethod: ILMethodRef option, otherMethods: ILMethodRef list, customAttrsStored: ILAttributesStored, metadataIndex: int32) = + + new (eventType, name, attributes, addMethod, removeMethod, fireMethod, otherMethods, customAttrs) = + ILEventDef(eventType, name, attributes, addMethod, removeMethod, fireMethod, otherMethods, storeILCustomAttrs customAttrs, NoMetadataIdx) + + member __.EventType = eventType + member __.Name = name + member __.Attributes = attributes + member __.AddMethod = addMethod + member __.RemoveMethod = removeMethod + member __.FireMethod = fireMethod + member __.OtherMethods = otherMethods + member __.CustomAttrsStored = customAttrsStored + member __.MetadataIndex = metadataIndex + member x.CustomAttrs = customAttrsStored.GetCustomAttrs x.MetadataIndex + + member x.With(?eventType, ?name, ?attributes, ?addMethod, ?removeMethod, ?fireMethod, ?otherMethods, ?customAttrs) = + ILEventDef(eventType= defaultArg eventType x.EventType, + name= defaultArg name x.Name, + attributes= defaultArg attributes x.Attributes, + addMethod=defaultArg addMethod x.AddMethod, + removeMethod=defaultArg removeMethod x.RemoveMethod, + fireMethod= defaultArg fireMethod x.FireMethod, + otherMethods= defaultArg otherMethods x.OtherMethods, + customAttrs=(match customAttrs with None -> x.CustomAttrs | Some attrs -> attrs)) + member x.IsSpecialName = (x.Attributes &&& EventAttributes.SpecialName) <> enum<_>(0) member x.IsRTSpecialName = (x.Attributes &&& EventAttributes.RTSpecialName) <> enum<_>(0) + override x.ToString() = "event " + x.Name (* Index table by name. *) [] type ILEventDefs = - | Events of LazyOrderedMultiMap - member x.AsList = let (Events t) = x in t.Entries() - member x.LookupByName s = let (Events t) = x in t.[s] + | ILEvents of LazyOrderedMultiMap + member x.AsList = let (ILEvents t) = x in t.Entries() + member x.LookupByName s = let (ILEvents t) = x in t.[s] [] -type ILPropertyDef = - { Name: string; - Attributes: PropertyAttributes; - SetMethod: ILMethodRef option; - GetMethod: ILMethodRef option; - CallingConv: ILThisConvention; - Type: ILType; - Init: ILFieldInit option; - Args: ILTypes; - CustomAttrs: ILAttributes; } +type ILPropertyDef(name: string, attributes: PropertyAttributes, setMethod: ILMethodRef option, getMethod: ILMethodRef option, callingConv: ILThisConvention, propertyType: ILType, init: ILFieldInit option, args: ILTypes, customAttrsStored: ILAttributesStored, metadataIndex: int32) = + + new (name, attributes, setMethod, getMethod, callingConv, propertyType, init, args, customAttrs) = + ILPropertyDef(name, attributes, setMethod, getMethod, callingConv, propertyType, init, args, storeILCustomAttrs customAttrs, NoMetadataIdx) + + member x.Name = name + member x.Attributes = attributes + member x.GetMethod = getMethod + member x.SetMethod = setMethod + member x.CallingConv = callingConv + member x.PropertyType = propertyType + member x.Init = init + member x.Args = args + member x.CustomAttrsStored = customAttrsStored + member x.CustomAttrs = customAttrsStored.GetCustomAttrs x.MetadataIndex + member x.MetadataIndex = metadataIndex + + member x.With(?name, ?attributes, ?setMethod, ?getMethod, ?callingConv, ?propertyType, ?init, ?args, ?customAttrs) = + ILPropertyDef(name=defaultArg name x.Name, + attributes=defaultArg attributes x.Attributes, + setMethod=defaultArg setMethod x.SetMethod, + getMethod=defaultArg getMethod x.GetMethod, + callingConv=defaultArg callingConv x.CallingConv, + propertyType=defaultArg propertyType x.PropertyType, + init=defaultArg init x.Init, + args=defaultArg args x.Args, + customAttrs=(match customAttrs with None -> x.CustomAttrs | Some attrs -> attrs)) + + member x.IsSpecialName = (x.Attributes &&& PropertyAttributes.SpecialName) <> enum<_>(0) member x.IsRTSpecialName = (x.Attributes &&& PropertyAttributes.RTSpecialName) <> enum<_>(0) override x.ToString() = "property " + x.Name @@ -1524,9 +1634,9 @@ type ILPropertyDef = // Index table by name. [] type ILPropertyDefs = - | Properties of LazyOrderedMultiMap - member x.AsList = let (Properties t) = x in t.Entries() - member x.LookupByName s = let (Properties t) = x in t.[s] + | ILProperties of LazyOrderedMultiMap + member x.AsList = let (ILProperties t) = x in t.Entries() + member x.LookupByName s = let (ILProperties t) = x in t.[s] let convertFieldAccess (ilMemberAccess:ILMemberAccess) = match ilMemberAccess with @@ -1538,36 +1648,50 @@ let convertFieldAccess (ilMemberAccess:ILMemberAccess) = | ILMemberAccess.Public -> FieldAttributes.Public [] -type ILFieldDef = - { Name: string; - Type: ILType; - Attributes: FieldAttributes; - Data: byte[] option; - LiteralValue: ILFieldInit option; - Offset: int32 option; - Marshal: ILNativeType option; - CustomAttrs: ILAttributes; } +type ILFieldDef(name: string, fieldType: ILType, attributes: FieldAttributes, data: byte[] option, literalValue: ILFieldInit option, offset: int32 option, marshal: ILNativeType option, customAttrsStored: ILAttributesStored, metadataIndex: int32) = + + new (name, fieldType, attributes, data, literalValue, offset, marshal, customAttrs) = + ILFieldDef(name, fieldType, attributes, data, literalValue, offset, marshal, storeILCustomAttrs customAttrs, NoMetadataIdx) + member __.Name=name + member __.FieldType = fieldType + member __.Attributes=attributes + member __.Data=data + member __.LiteralValue=literalValue + member __.Offset=offset + member __.Marshal=marshal + member x.CustomAttrsStored = customAttrsStored + member x.CustomAttrs = customAttrsStored.GetCustomAttrs x.MetadataIndex + member x.MetadataIndex = metadataIndex + + member x.With(?name: string, ?fieldType: ILType, ?attributes: FieldAttributes, ?data: byte[] option, ?literalValue: ILFieldInit option, ?offset: int32 option, ?marshal: ILNativeType option, ?customAttrs: ILAttributes) = + ILFieldDef(name=defaultArg name x.Name, + fieldType=defaultArg fieldType x.FieldType, + attributes=defaultArg attributes x.Attributes, + data=defaultArg data x.Data, + literalValue=defaultArg literalValue x.LiteralValue, + offset=defaultArg offset x.Offset, + marshal=defaultArg marshal x.Marshal, + customAttrs=defaultArg customAttrs x.CustomAttrs) member x.IsStatic = x.Attributes &&& FieldAttributes.Static <> enum 0 member x.IsSpecialName = x.Attributes &&& FieldAttributes.SpecialName <> enum 0 member x.IsLiteral = x.Attributes &&& FieldAttributes.Literal <> enum 0 member x.NotSerialized = x.Attributes &&& FieldAttributes.NotSerialized <> enum 0 member x.IsInitOnly = x.Attributes &&& FieldAttributes.InitOnly <> enum 0 member x.Access = memberAccessOfFlags (int x.Attributes) - member x.WithAccess(access) = { x with Attributes = x.Attributes &&& ~~~FieldAttributes.FieldAccessMask ||| convertFieldAccess access } - member x.WithInitOnly(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition FieldAttributes.InitOnly } - member x.WithStatic(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition FieldAttributes.Static } - member x.WithSpecialName(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition (FieldAttributes.SpecialName ||| FieldAttributes.RTSpecialName) } - member x.WithNotSerialized(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition FieldAttributes.NotSerialized } - member x.WithLiteral(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition FieldAttributes.Literal } - member x.WithHasDefault(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition FieldAttributes.HasDefault } - member x.WithHasFieldMarshal(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition FieldAttributes.HasFieldMarshal } + member x.WithAccess(access) = x.With(attributes = (x.Attributes &&& ~~~FieldAttributes.FieldAccessMask ||| convertFieldAccess access)) + member x.WithInitOnly(condition) = x.With(attributes = (x.Attributes |> conditionalAdd condition FieldAttributes.InitOnly)) + member x.WithStatic(condition) = x.With(attributes = (x.Attributes |> conditionalAdd condition FieldAttributes.Static)) + member x.WithSpecialName(condition) = x.With(attributes = (x.Attributes |> conditionalAdd condition (FieldAttributes.SpecialName ||| FieldAttributes.RTSpecialName))) + member x.WithNotSerialized(condition) = x.With(attributes = (x.Attributes |> conditionalAdd condition FieldAttributes.NotSerialized)) + member x.WithLiteralDefaultValue(literal) = x.With(literalValue = literal, attributes = (x.Attributes |> conditionalAdd literal.IsSome (FieldAttributes.Literal ||| FieldAttributes.HasDefault))) + member x.WithFieldMarshal(marshal) = x.With(marshal = marshal, attributes = (x.Attributes |> conditionalAdd marshal.IsSome FieldAttributes.HasFieldMarshal)) // Index table by name. Keep a canonical list to make sure field order is not disturbed for binary manipulation. type ILFieldDefs = - | Fields of LazyOrderedMultiMap - member x.AsList = let (Fields t) = x in t.Entries() - member x.LookupByName s = let (Fields t) = x in t.[s] + | ILFields of LazyOrderedMultiMap + member x.AsList = let (ILFields t) = x in t.Entries() + member x.LookupByName s = let (ILFields t) = x in t.[s] type ILMethodImplDef = { Overrides: ILOverridesSpec; @@ -1575,8 +1699,8 @@ type ILMethodImplDef = // Index table by name and arity. type ILMethodImplDefs = - | MethodImpls of Lazy - member x.AsList = let (MethodImpls ltab) = x in Map.foldBack (fun _x y r -> y@r) (ltab.Force()) [] + | ILMethodImpls of Lazy + member x.AsList = let (ILMethodImpls ltab) = x in Map.foldBack (fun _x y r -> y@r) (ltab.Force()) [] and MethodImplsMap = Map @@ -1694,21 +1818,48 @@ let convertInitSemantics (init:ILTypeInit) = | ILTypeInit.OnAny -> enum 0 [] -type ILTypeDef = - { Name: string; - Attributes: TypeAttributes; - GenericParams: ILGenericParameterDefs; (* class is generic *) - Layout: ILTypeDefLayout; - NestedTypes: ILTypeDefs; - Implements: ILTypes; - Extends: ILType option; - Methods: ILMethodDefs; - SecurityDecls: ILPermissions; - Fields: ILFieldDefs; - MethodImpls: ILMethodImplDefs; - Events: ILEventDefs; - Properties: ILPropertyDefs; - CustomAttrs: ILAttributes; } +type ILTypeDef(name: string, attributes: TypeAttributes, layout: ILTypeDefLayout, implements: ILTypes, genericParams: ILGenericParameterDefs, + extends: ILType option, methods: ILMethodDefs, nestedTypes: ILTypeDefs, fields: ILFieldDefs, methodImpls: ILMethodImplDefs, + events: ILEventDefs, properties: ILPropertyDefs, securityDeclsStored: ILSecurityDeclsStored, customAttrsStored: ILAttributesStored, metadataIndex: int32) = + + new (name, attributes, layout, implements, genericParams, extends, methods, nestedTypes, fields, methodImpls, events, properties, securityDecls, customAttrs) = + ILTypeDef (name, attributes, layout, implements, genericParams, extends, methods, nestedTypes, fields, methodImpls, events, properties, storeILSecurityDecls securityDecls, storeILCustomAttrs customAttrs, NoMetadataIdx) + + member __.Name = name + member __.Attributes = attributes + member __.GenericParams = genericParams + member __.Layout = layout + member __.NestedTypes = nestedTypes + member __.Implements = implements + member __.Extends = extends + member __.Methods = methods + member __.SecurityDeclsStored = securityDeclsStored + member __.Fields = fields + member __.MethodImpls = methodImpls + member __.Events = events + member __.Properties = properties + member __.CustomAttrsStored = customAttrsStored + member __.MetadataIndex = metadataIndex + + member x.With(?name, ?attributes, ?layout, ?implements, ?genericParams, ?extends, ?methods, ?nestedTypes, ?fields, ?methodImpls, ?events, ?properties, ?customAttrs, ?securityDecls) = + ILTypeDef(name=defaultArg name x.Name, + attributes=defaultArg attributes x.Attributes, + layout=defaultArg layout x.Layout, + genericParams = defaultArg genericParams x.GenericParams, + nestedTypes = defaultArg nestedTypes x.NestedTypes, + implements = defaultArg implements x.Implements, + extends = defaultArg extends x.Extends, + methods = defaultArg methods x.Methods, + securityDecls = defaultArg securityDecls x.SecurityDecls, + fields = defaultArg fields x.Fields, + methodImpls = defaultArg methodImpls x.MethodImpls, + events = defaultArg events x.Events, + properties = defaultArg properties x.Properties, + customAttrs = defaultArg customAttrs x.CustomAttrs) + + member x.CustomAttrs = customAttrsStored.GetCustomAttrs x.MetadataIndex + member x.SecurityDecls = x.SecurityDeclsStored.GetSecurityDecls x.MetadataIndex + member x.IsClass = (typeKindOfFlags x.Name x.Methods x.Fields x.Extends (int x.Attributes)) = ILTypeDefKind.Class member x.IsStruct = (typeKindOfFlags x.Name x.Methods x.Fields x.Extends (int x.Attributes)) = ILTypeDefKind.ValueType member x.IsInterface = (typeKindOfFlags x.Name x.Methods x.Fields x.Extends (int x.Attributes)) = ILTypeDefKind.Interface @@ -1723,51 +1874,81 @@ type ILTypeDef = member x.HasSecurity = x.Attributes &&& TypeAttributes.HasSecurity <> enum 0 member x.Encoding = typeEncodingOfFlags (int x.Attributes) member x.IsStructOrEnum = x.IsStruct || x.IsEnum - member x.WithAccess(access) = { x with Attributes = x.Attributes &&& ~~~TypeAttributes.VisibilityMask ||| convertTypeAccessFlags access } - member x.WithNestedAccess(access) = { x with Attributes = x.Attributes &&& ~~~TypeAttributes.VisibilityMask ||| convertToNestedTypeAccess access } - member x.WithSealed(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition TypeAttributes.Sealed } - member x.WithSerializable(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition TypeAttributes.Serializable } - member x.WithAbstract(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition TypeAttributes.Abstract } - member x.WithImport(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition TypeAttributes.Import } - member x.WithHasSecurity(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition TypeAttributes.HasSecurity } - member x.WithLayout(layout) = { x with Attributes = x.Attributes ||| convertLayout layout; Layout = layout } - member x.WithKind(kind) = { x with Attributes = x.Attributes ||| convertTypeKind kind; Extends = match kind with ILTypeDefKind.Interface -> None | _ -> x.Extends } - member x.WithEncoding(encoding) = { x with Attributes = x.Attributes &&& ~~~TypeAttributes.StringFormatMask ||| convertEncoding encoding } - member x.WithSpecialName(condition) = { x with Attributes = x.Attributes |> conditionalAdd condition TypeAttributes.SpecialName} - member x.WithInitSemantics(init) = { x with Attributes = x.Attributes ||| convertInitSemantics init } - -and [] ILTypeDefs(f : unit -> (string list * string * ILAttributes * Lazy)[]) = + member x.WithAccess(access) = x.With(attributes=(x.Attributes &&& ~~~TypeAttributes.VisibilityMask ||| convertTypeAccessFlags access)) + member x.WithNestedAccess(access) = x.With(attributes=(x.Attributes &&& ~~~TypeAttributes.VisibilityMask ||| convertToNestedTypeAccess access)) + member x.WithSealed(condition) = x.With(attributes=(x.Attributes |> conditionalAdd condition TypeAttributes.Sealed)) + member x.WithSerializable(condition) = x.With(attributes=(x.Attributes |> conditionalAdd condition TypeAttributes.Serializable)) + member x.WithAbstract(condition) = x.With(attributes=(x.Attributes |> conditionalAdd condition TypeAttributes.Abstract)) + member x.WithImport(condition) = x.With(attributes=(x.Attributes |> conditionalAdd condition TypeAttributes.Import)) + member x.WithHasSecurity(condition) = x.With(attributes=(x.Attributes |> conditionalAdd condition TypeAttributes.HasSecurity)) + member x.WithLayout(layout) = x.With(attributes=(x.Attributes ||| convertLayout layout), layout = layout) + member x.WithKind(kind) = x.With(attributes=(x.Attributes ||| convertTypeKind kind), extends = match kind with ILTypeDefKind.Interface -> None | _ -> x.Extends) + member x.WithEncoding(encoding) = x.With(attributes=(x.Attributes &&& ~~~TypeAttributes.StringFormatMask ||| convertEncoding encoding)) + member x.WithSpecialName(condition) = x.With(attributes=(x.Attributes |> conditionalAdd condition TypeAttributes.SpecialName)) + member x.WithInitSemantics(init) = x.With(attributes=(x.Attributes ||| convertInitSemantics init)) + +and [] ILTypeDefs(f : unit -> ILPreTypeDef[]) = let mutable array = InlineDelayInit<_>(f) let mutable dict = InlineDelayInit<_>(fun () -> - let arr = array.Value - let t = Dictionary<_,_>(HashIdentity.Structural) - for (nsp, nm, _attr, ltd) in arr do - let key = nsp, nm - t.[key] <- ltd - t) + let arr = array.Value + let t = Dictionary<_,_>(HashIdentity.Structural) + for pre in arr do + let key = pre.Namespace, pre.Name + t.[key] <- pre + t) - member x.AsArray = [| for (_,_,_,ltd) in array.Value -> ltd.Force() |] - member x.AsList = [ for (_,_,_,ltd) in array.Value -> ltd.Force() ] + member x.AsArray = [| for pre in array.Value -> pre.GetTypeDef() |] + member x.AsList = [ for pre in array.Value -> pre.GetTypeDef() ] interface IEnumerable with member x.GetEnumerator() = ((x :> IEnumerable).GetEnumerator() :> IEnumerator) interface IEnumerable with member x.GetEnumerator() = - (seq { for (_,_,_,ltd) in array.Value -> ltd.Force() }).GetEnumerator() + (seq { for pre in array.Value -> pre.GetTypeDef() }).GetEnumerator() - member x.AsArrayOfLazyTypeDefs = array.Value + member x.AsArrayOfPreTypeDefs = array.Value member x.FindByName nm = let ns,n = splitILTypeName nm - dict.Value.[(ns,n)].Force() + dict.Value.[(ns,n)].GetTypeDef() + +/// This is a memory-critical class. Very many of these objects get allocated and held to represent the contents of .NET assemblies. +and [] ILPreTypeDef(nameSpace: string list, name: string, metadataIndex: int32, storage: ILTypeDefStored) = + let mutable store : ILTypeDef = Unchecked.defaultof<_> + + member __.Namespace = nameSpace + member __.Name = name + member __.MetadataIndex = metadataIndex + + member x.GetTypeDef() = + match box store with + | null -> + match storage with + | ILTypeDefStored.Given td -> + store <- td + td + | ILTypeDefStored.Computed f -> + System.Threading.LazyInitializer.EnsureInitialized(&store, System.Func<_>(fun () -> f())) + | ILTypeDefStored.Reader f -> + System.Threading.LazyInitializer.EnsureInitialized(&store, System.Func<_>(fun () -> f x.MetadataIndex)) + | _ -> store + +and ILTypeDefStored = + | Given of ILTypeDef + | Reader of (int32 -> ILTypeDef) + | Computed of (unit -> ILTypeDef) + +let mkILTypeDefReader f = ILTypeDefStored.Reader f type ILNestedExportedType = - { Name: string; - Access: ILMemberAccess; - Nested: ILNestedExportedTypes; - CustomAttrs: ILAttributes } + { Name: string + Access: ILMemberAccess + Nested: ILNestedExportedTypes + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex and ILNestedExportedTypes = | ILNestedExportedTypes of Lazy> @@ -1775,13 +1956,15 @@ and ILNestedExportedTypes = and [] ILExportedTypeOrForwarder = - { ScopeRef: ILScopeRef; - Name: string; + { ScopeRef: ILScopeRef + Name: string Attributes: TypeAttributes - Nested: ILNestedExportedTypes; - CustomAttrs: ILAttributes } + Nested: ILNestedExportedTypes + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } member x.Access = typeAccessOfFlags (int x.Attributes) member x.IsForwarder = x.Attributes &&& enum(0x00200000) <> enum 0 + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex and ILExportedTypesAndForwarders = | ILExportedTypesAndForwarders of Lazy> @@ -1794,24 +1977,31 @@ type ILResourceAccess = [] type ILResourceLocation = - | Local of (unit -> byte[]) + | LocalIn of string * int * int + | LocalOut of byte[] | File of ILModuleRef * int32 | Assembly of ILAssemblyRef type ILResource = { Name: string; - Location: ILResourceLocation; - Access: ILResourceAccess; - CustomAttrs: ILAttributes } + Location: ILResourceLocation + Access: ILResourceAccess + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } + /// Read the bytes from a resource local to an assembly - member r.Bytes = - match r.Location with - | ILResourceLocation.Local b -> b() - | _ -> failwith "Bytes" + member r.GetBytes() = + match r.Location with + | ILResourceLocation.LocalIn (file, start, len) -> + FileSystem.ReadAllBytesShim(file).[start .. start + len - 1] + | ILResourceLocation.LocalOut bytes -> bytes + | _ -> failwith "GetBytes" + + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex type ILResources = - | ILResources of Lazy - member x.AsList = let (ILResources ltab) = x in (ltab.Force()) + | ILResources of ILResource list + member x.AsList = let (ILResources ltab) = x in ltab // -------------------------------------------------------------------- // One module in the "current" assembly @@ -1827,48 +2017,57 @@ type ILAssemblyLongevity = type ILAssemblyManifest = - { Name: string; - AuxModuleHashAlgorithm: int32; - SecurityDecls: ILPermissions; - PublicKey: byte[] option; - Version: ILVersionInfo option; - Locale: Locale option; - CustomAttrs: ILAttributes; - - AssemblyLongevity: ILAssemblyLongevity; - DisableJitOptimizations: bool; - JitTracking: bool; - IgnoreSymbolStoreSequencePoints: bool; - Retargetable: bool; + { Name: string + AuxModuleHashAlgorithm: int32 + SecurityDeclsStored: ILSecurityDeclsStored + PublicKey: byte[] option + Version: ILVersionInfo option + Locale: Locale option + CustomAttrsStored: ILAttributesStored + + AssemblyLongevity: ILAssemblyLongevity + DisableJitOptimizations: bool + JitTracking: bool + IgnoreSymbolStoreSequencePoints: bool + Retargetable: bool /// Records the types implemented by other modules. - ExportedTypes: ILExportedTypesAndForwarders; + ExportedTypes: ILExportedTypesAndForwarders /// Records whether the entrypoint resides in another module. - EntrypointElsewhere: ILModuleRef option; + EntrypointElsewhere: ILModuleRef option + MetadataIndex: int32 } + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex + member x.SecurityDecls = x.SecurityDeclsStored.GetSecurityDecls x.MetadataIndex + +[] +type ILNativeResource = + | In of fileName: string * linkedResourceBase: int * linkedResourceStart: int * linkedResourceLength: int + | Out of unlinkedResource: byte[] type ILModuleDef = - { Manifest: ILAssemblyManifest option; - CustomAttrs: ILAttributes; - Name: string; - TypeDefs: ILTypeDefs; + { Manifest: ILAssemblyManifest option + Name: string + TypeDefs: ILTypeDefs SubsystemVersion : int * int UseHighEntropyVA : bool (* Random bits of relatively uninteresting data *) - SubSystemFlags: int32; - IsDLL: bool; - IsILOnly: bool; - Platform: ILPlatform option; - StackReserveSize: int32 option; - Is32Bit: bool; - Is32BitPreferred: bool; - Is64Bit: bool; - VirtualAlignment: int32; - PhysicalAlignment: int32; - ImageBase: int32; - MetadataVersion: string; - Resources: ILResources; - NativeResources: list>; (* e.g. win32 resources *) + SubSystemFlags: int32 + IsDLL: bool + IsILOnly: bool + Platform: ILPlatform option + StackReserveSize: int32 option + Is32Bit: bool + Is32BitPreferred: bool + Is64Bit: bool + VirtualAlignment: int32 + PhysicalAlignment: int32 + ImageBase: int32 + MetadataVersion: string + Resources: ILResources + NativeResources: ILNativeResource list (* e.g. win32 resources *) + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } member x.ManifestOfAssembly = match x.Manifest with @@ -1878,6 +2077,7 @@ type ILModuleDef = member m.HasManifest = match m.Manifest with None -> false | _ -> true + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex // -------------------------------------------------------------------- // Add fields and types to tables, with decent error messages @@ -1957,16 +2157,16 @@ let isTypeNameForGlobalFunctions d = (d = typeNameForGlobalFunctions) let mkILMethRef (tref,callconv,nm,gparams,args,rty) = - { mrefParent=tref; - mrefCallconv=callconv; - mrefGenericArity=gparams; - mrefName=nm; - mrefArgs=args; + { mrefParent=tref + mrefCallconv=callconv + mrefGenericArity=gparams + mrefName=nm + mrefArgs=args mrefReturn=rty} let mkILMethSpecForMethRefInTy (mref,typ,minst) = - { mspecMethodRef=mref; - mspecDeclaringType=typ; + { mspecMethodRef=mref + mspecDeclaringType=typ mspecMethodInst=minst } let mkILMethSpec (mref, vc, tinst, minst) = mkILMethSpecForMethRefInTy (mref,mkILNamedTy vc mref.DeclaringTypeRef tinst, minst) @@ -2012,11 +2212,6 @@ let mkILFieldSpec (tref,ty) = { FieldRef= tref; DeclaringType=ty } let mkILFieldSpecInTy (typ:ILType,nm,fty) = mkILFieldSpec (mkILFieldRef (typ.TypeRef,nm,fty), typ) -let emptyILCustomAttrs = ILAttributes (fun () -> [| |]) - -let mkILCustomAttrsFromArray (l: ILAttribute[]) = if l.Length = 0 then emptyILCustomAttrs else ILAttributes (fun () -> l) -let mkILCustomAttrs l = l |> List.toArray |> mkILCustomAttrsFromArray -let mkILComputedCustomAttrs f = ILAttributes f let andTailness x y = match x with Tailcall when y -> Tailcall | _ -> Normalcall @@ -2052,20 +2247,17 @@ let nonBranchingInstrsToCode instrs : ILCode = // // -------------------------------------------------------------------- -let emptyILSecurityDecls = ILPermissions.SecurityDecls [] -let mkILSecurityDecls l = match l with [] -> emptyILSecurityDecls | _ -> ILPermissions.SecurityDecls l -let mkILLazySecurityDecls l = ILPermissions.SecurityDeclsLazy l - let mkILTyvarTy tv = ILType.TypeVar tv let mkILSimpleTypar nm = - { Name=nm; + { Name=nm Constraints = [] - Variance=NonVariant; - HasReferenceTypeConstraint=false; - HasNotNullableValueTypeConstraint=false; - HasDefaultConstructorConstraint=false; - CustomAttrs = emptyILCustomAttrs } + Variance=NonVariant + HasReferenceTypeConstraint=false + HasNotNullableValueTypeConstraint=false + HasDefaultConstructorConstraint=false + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx } let gparam_of_gactual (_ga:ILType) = mkILSimpleTypar "T" @@ -2089,13 +2281,17 @@ let mkRefForNestedILTypeDef scope (enc:ILTypeDef list,td:ILTypeDef) = // Operations on type tables. // -------------------------------------------------------------------- -let getName (ltd: Lazy) = - let td = Lazy.force ltd +let mkILPreTypeDef (td:ILTypeDef) = let ns,n = splitILTypeName td.Name - (ns,n,td.CustomAttrs,ltd) + ILPreTypeDef(ns, n, NoMetadataIdx, ILTypeDefStored.Given td) +let mkILPreTypeDefComputed (ns, n, f) = + ILPreTypeDef(ns, n, NoMetadataIdx, ILTypeDefStored.Computed f) +let mkILPreTypeDefRead (ns, n, idx, f) = + ILPreTypeDef(ns, n, idx, f) -let addILTypeDef td (tdefs: ILTypeDefs) = ILTypeDefs (fun () -> [| yield getName (notlazy td); yield! tdefs.AsArrayOfLazyTypeDefs |]) -let mkILTypeDefsFromArray l = ILTypeDefs (fun () -> Array.map (notlazy >> getName) l) + +let addILTypeDef td (tdefs: ILTypeDefs) = ILTypeDefs (fun () -> [| yield mkILPreTypeDef td; yield! tdefs.AsArrayOfPreTypeDefs |]) +let mkILTypeDefsFromArray (l: ILTypeDef[]) = ILTypeDefs (fun () -> Array.map mkILPreTypeDef l) let mkILTypeDefs l = mkILTypeDefsFromArray (Array.ofList l) let mkILTypeDefsComputed f = ILTypeDefs f let emptyILTypeDefs = mkILTypeDefsFromArray [| |] @@ -2403,21 +2599,23 @@ let instILType i t = instILTypeAux 0 i t // -------------------------------------------------------------------- let mkILParam (name,ty) : ILParameter = - { Name=name; - Default=None; - Marshal=None; - IsIn=false; - IsOut=false; - IsOptional=false; - Type=ty; - CustomAttrs=emptyILCustomAttrs } + { Name=name + Default=None + Marshal=None + IsIn=false + IsOut=false + IsOptional=false + Type=ty + CustomAttrsStored=storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx } let mkILParamNamed (s,ty) = mkILParam (Some s,ty) let mkILParamAnon ty = mkILParam (None,ty) let mkILReturn ty : ILReturn = - { Marshal=None; - Type=ty; - CustomAttrs=emptyILCustomAttrs } + { Marshal=None + Type=ty + CustomAttrsStored=storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx } let mkILLocal ty dbgInfo : ILLocal = { IsPinned=false; @@ -2450,19 +2648,22 @@ let mkMethodBody (zeroinit,locals,maxstack,code,tag) = MethodBody.IL (mkILMethod let mkILVoidReturn = mkILReturn ILType.Void +let methBodyNotAvailable = mkMethBodyAux MethodBody.NotAvailable +let methBodyAbstract = mkMethBodyAux MethodBody.Abstract +let methBodyNative = mkMethBodyAux MethodBody.Native let mkILCtor (access,args,impl) = - { Name=".ctor"; - Attributes=convertMemberAccess access ||| MethodAttributes.SpecialName ||| MethodAttributes.RTSpecialName; - ImplAttributes=MethodImplAttributes.Managed - CallingConv=ILCallingConv.Instance; - Parameters = args - Return= mkILVoidReturn; - mdBody= mkMethBodyAux impl; - SecurityDecls=emptyILSecurityDecls; - IsEntryPoint=false; - GenericParams=mkILEmptyGenericParams; - CustomAttrs = emptyILCustomAttrs; } + ILMethodDef(name=".ctor", + attributes=(convertMemberAccess access ||| MethodAttributes.SpecialName ||| MethodAttributes.RTSpecialName), + implAttributes=MethodImplAttributes.Managed, + callingConv=ILCallingConv.Instance, + parameters = args, + ret= mkILVoidReturn, + body= mkMethBodyAux impl, + securityDecls=emptyILSecurityDecls, + isEntryPoint=false, + genericParams=mkILEmptyGenericParams, + customAttrs = emptyILCustomAttrs) // -------------------------------------------------------------------- // Do-nothing ctor, just pass on to monomorphic superclass @@ -2491,33 +2692,33 @@ let mkILNonGenericEmptyCtor tag superTy = // -------------------------------------------------------------------- let mkILStaticMethod (genparams,nm,access,args,ret,impl) = - { GenericParams=genparams; - Name=nm; - Attributes=convertMemberAccess access ||| MethodAttributes.Static; - ImplAttributes=MethodImplAttributes.Managed - CallingConv = ILCallingConv.Static; - Parameters = args - Return= ret; - SecurityDecls=emptyILSecurityDecls; - IsEntryPoint=false; - CustomAttrs = emptyILCustomAttrs; - mdBody= mkMethBodyAux impl; } + ILMethodDef(genericParams=genparams, + name=nm, + attributes=(convertMemberAccess access ||| MethodAttributes.Static), + implAttributes=MethodImplAttributes.Managed, + callingConv = ILCallingConv.Static, + parameters = args, + ret= ret, + securityDecls=emptyILSecurityDecls, + isEntryPoint=false, + customAttrs = emptyILCustomAttrs, + body= mkMethBodyAux impl) let mkILNonGenericStaticMethod (nm,access,args,ret,impl) = mkILStaticMethod (mkILEmptyGenericParams,nm,access,args,ret,impl) let mkILClassCtor impl = - { Name=".cctor"; - Attributes=MethodAttributes.Private ||| MethodAttributes.Static ||| MethodAttributes.SpecialName ||| MethodAttributes.RTSpecialName; - ImplAttributes=MethodImplAttributes.Managed - CallingConv=ILCallingConv.Static; - GenericParams=mkILEmptyGenericParams; - Parameters = [] - Return=mkILVoidReturn; - IsEntryPoint=false; - SecurityDecls=emptyILSecurityDecls; - CustomAttrs = emptyILCustomAttrs; - mdBody= mkMethBodyAux impl; } + ILMethodDef(name=".cctor", + attributes=(MethodAttributes.Private ||| MethodAttributes.Static ||| MethodAttributes.SpecialName ||| MethodAttributes.RTSpecialName), + implAttributes=MethodImplAttributes.Managed, + callingConv=ILCallingConv.Static, + genericParams=mkILEmptyGenericParams, + parameters = [], + ret=mkILVoidReturn, + isEntryPoint=false, + securityDecls=emptyILSecurityDecls, + customAttrs=emptyILCustomAttrs, + body= mkMethBodyAux impl) // -------------------------------------------------------------------- // Make a virtual method, where the overriding is simply the default @@ -2528,36 +2729,36 @@ let mk_ospec (typ:ILType,callconv,nm,genparams,formal_args,formal_ret) = OverridesSpec (mkILMethRef (typ.TypeRef, callconv, nm, genparams, formal_args,formal_ret), typ) let mkILGenericVirtualMethod (nm,access,genparams,actual_args,actual_ret,impl) = - { Name=nm; - Attributes= - convertMemberAccess access ||| - MethodAttributes.CheckAccessOnOverride ||| - (match impl with MethodBody.Abstract -> MethodAttributes.Abstract ||| MethodAttributes.Virtual | _ -> MethodAttributes.Virtual); - ImplAttributes=MethodImplAttributes.Managed - GenericParams=genparams; - CallingConv=ILCallingConv.Instance; - Parameters=actual_args; - Return=actual_ret; - IsEntryPoint=false; - SecurityDecls=emptyILSecurityDecls; - CustomAttrs = emptyILCustomAttrs; - mdBody= mkMethBodyAux impl; } + ILMethodDef(name=nm, + attributes= + (convertMemberAccess access ||| + MethodAttributes.CheckAccessOnOverride ||| + (match impl with MethodBody.Abstract -> MethodAttributes.Abstract ||| MethodAttributes.Virtual | _ -> MethodAttributes.Virtual)), + implAttributes=MethodImplAttributes.Managed, + genericParams=genparams, + callingConv=ILCallingConv.Instance, + parameters=actual_args, + ret=actual_ret, + isEntryPoint=false, + securityDecls=emptyILSecurityDecls, + customAttrs = emptyILCustomAttrs, + body= mkMethBodyAux impl) let mkILNonGenericVirtualMethod (nm,access,args,ret,impl) = - mkILGenericVirtualMethod (nm,access,mkILEmptyGenericParams,args,ret,impl) + mkILGenericVirtualMethod (nm,access,mkILEmptyGenericParams,args,ret,impl) let mkILGenericNonVirtualMethod (nm,access,genparams, actual_args,actual_ret, impl) = - { Name=nm; - Attributes=convertMemberAccess access ||| MethodAttributes.HideBySig; // see Bug343136: missing HideBySig attribute makes it problematic for C# to consume F# method overloads. - ImplAttributes=MethodImplAttributes.Managed - GenericParams=genparams; - CallingConv=ILCallingConv.Instance; - Parameters=actual_args; - Return=actual_ret; - IsEntryPoint=false; - SecurityDecls=emptyILSecurityDecls; - CustomAttrs = emptyILCustomAttrs; - mdBody= mkMethBodyAux impl; } + ILMethodDef(name=nm, + attributes=(convertMemberAccess access ||| MethodAttributes.HideBySig), + implAttributes=MethodImplAttributes.Managed, + genericParams=genparams, + callingConv=ILCallingConv.Instance, + parameters=actual_args, + ret=actual_ret, + isEntryPoint=false, + securityDecls=emptyILSecurityDecls, + customAttrs = emptyILCustomAttrs, + body= mkMethBodyAux impl) let mkILNonGenericInstanceMethod (nm,access,args,ret,impl) = mkILGenericNonVirtualMethod (nm,access,mkILEmptyGenericParams,args,ret,impl) @@ -2571,13 +2772,13 @@ let mkILNonGenericInstanceMethod (nm,access,args,ret,impl) = let ilmbody_code2code f (il: ILMethodBody) = {il with Code = f il.Code} -let mdef_code2code f md = +let mdef_code2code f (md: ILMethodDef) = let il = - match md.mdBody.Contents with + match md.Body.Contents with | MethodBody.IL il-> il | _ -> failwith "mdef_code2code - method not IL" let b = MethodBody.IL (ilmbody_code2code f il) - {md with mdBody= mkMethBodyAux b } + md.With(body= mkMethBodyAux b) let prependInstrsToCode (instrs: ILInstr list) (c2: ILCode) = let instrs = Array.ofList instrs @@ -2603,7 +2804,7 @@ let prependInstrsToMethod new_code md = mdef_code2code (prependInstrsToCode new_code) md // Creates cctor if needed -let cdef_cctorCode2CodeOrCreate tag f cd = +let cdef_cctorCode2CodeOrCreate tag f (cd: ILTypeDef) = let mdefs = cd.Methods let cctor = match mdefs.FindByName ".cctor" with @@ -2612,7 +2813,7 @@ let cdef_cctorCode2CodeOrCreate tag f cd = | _ -> failwith "bad method table: more than one .cctor found" let methods = ILMethodDefs (fun () -> [| yield f cctor; for md in mdefs do if md.Name <> ".cctor" then yield md |]) - {cd with Methods = methods} + cd.With(methods = methods) let code_of_mdef (md:ILMethodDef) = @@ -2623,10 +2824,10 @@ let code_of_mdef (md:ILMethodDef) = let mkRefToILMethod (tref, md: ILMethodDef) = mkILMethRef (tref, md.CallingConv, md.Name, md.GenericParams.Length, md.ParameterTypes, md.Return.Type) -let mkRefToILField (tref,fdef:ILFieldDef) = mkILFieldRef (tref, fdef.Name, fdef.Type) +let mkRefToILField (tref,fdef:ILFieldDef) = mkILFieldRef (tref, fdef.Name, fdef.FieldType) let mkRefForILMethod scope (tdefs,tdef) mdef = mkRefToILMethod (mkRefForNestedILTypeDef scope (tdefs,tdef), mdef) -let mkRefForILField scope (tdefs,tdef) (fdef:ILFieldDef) = mkILFieldRef (mkRefForNestedILTypeDef scope (tdefs,tdef), fdef.Name, fdef.Type) +let mkRefForILField scope (tdefs,tdef) (fdef:ILFieldDef) = mkILFieldRef (mkRefForNestedILTypeDef scope (tdefs,tdef), fdef.Name, fdef.FieldType) (* Creates cctor if needed *) @@ -2635,18 +2836,19 @@ let prependInstrsToClassCtor instrs tag cd = let mkILField (isStatic,nm,ty,(init:ILFieldInit option),(at: byte [] option),access,isLiteral) = - { Name=nm; - Type=ty; - Attributes=convertFieldAccess access ||| - (if isStatic then FieldAttributes.Static else enum 0) ||| - (if isLiteral then FieldAttributes.Literal else enum 0) ||| - (if init.IsSome then FieldAttributes.HasDefault else enum 0) ||| - (if at.IsSome then FieldAttributes.HasFieldRVA else enum 0) - LiteralValue = init; - Data=at; - Offset=None; - Marshal=None; - CustomAttrs=emptyILCustomAttrs } + ILFieldDef(name=nm, + fieldType=ty, + attributes= + (convertFieldAccess access ||| + (if isStatic then FieldAttributes.Static else enum 0) ||| + (if isLiteral then FieldAttributes.Literal else enum 0) ||| + (if init.IsSome then FieldAttributes.HasDefault else enum 0) ||| + (if at.IsSome then FieldAttributes.HasFieldRVA else enum 0)), + literalValue = init, + data=at, + offset=None, + marshal=None, + customAttrs=emptyILCustomAttrs) let mkILInstanceField (nm,ty,init,access) = mkILField (false,nm,ty,init,None,access,false) let mkILStaticField (nm,ty,init,at,access) = mkILField (true,nm,ty,init,at,access,false) @@ -2666,15 +2868,15 @@ type ILLocalsAllocator(numPrealloc:int) = member tmps.Close() = ResizeArray.toList newLocals -let mkILFieldsLazy l = Fields (LazyOrderedMultiMap((fun (f:ILFieldDef) -> f.Name),l)) +let mkILFieldsLazy l = ILFields (LazyOrderedMultiMap((fun (f:ILFieldDef) -> f.Name),l)) let mkILFields l = mkILFieldsLazy (notlazy l) let emptyILFields = mkILFields [] -let mkILEventsLazy l = Events (LazyOrderedMultiMap((fun (e: ILEventDef) -> e.Name),l)) +let mkILEventsLazy l = ILEvents (LazyOrderedMultiMap((fun (e: ILEventDef) -> e.Name),l)) let mkILEvents l = mkILEventsLazy (notlazy l) let emptyILEvents = mkILEvents [] -let mkILPropertiesLazy l = Properties (LazyOrderedMultiMap((fun (p: ILPropertyDef) -> p.Name),l) ) +let mkILPropertiesLazy l = ILProperties (LazyOrderedMultiMap((fun (p: ILPropertyDef) -> p.Name),l) ) let mkILProperties l = mkILPropertiesLazy (notlazy l) let emptyILProperties = mkILProperties [] @@ -2686,11 +2888,12 @@ let addNestedExportedTypeToTable (y: ILNestedExportedType) tab = Map.add y.Name y tab let mkTypeForwarder scopeRef name nested customAttrs access = - { ScopeRef=scopeRef; - Name=name; - Attributes=enum(0x00200000) ||| convertTypeAccessFlags access; - Nested=nested; - CustomAttrs=customAttrs; } + { ScopeRef=scopeRef + Name=name + Attributes=enum(0x00200000) ||| convertTypeAccessFlags access + Nested=nested + CustomAttrsStored=storeILCustomAttrs customAttrs + MetadataIndex = NoMetadataIdx } let mkILNestedExportedTypes l = ILNestedExportedTypes (notlazy (List.foldBack addNestedExportedTypeToTable l Map.empty)) @@ -2698,16 +2901,15 @@ let mkILNestedExportedTypes l = let mkILNestedExportedTypesLazy (l:Lazy<_>) = ILNestedExportedTypes (lazy (List.foldBack addNestedExportedTypeToTable (l.Force()) Map.empty)) -let mkILResources l = ILResources (notlazy l) -let mkILResourcesLazy l = ILResources l +let mkILResources l = ILResources l let addMethodImplToTable y tab = let key = (y.Overrides.MethodRef.Name,y.Overrides.MethodRef.ArgTypes.Length) let prev = Map.tryFindMulti key tab Map.add key (y::prev) tab -let mkILMethodImpls l = MethodImpls (notlazy (List.foldBack addMethodImplToTable l Map.empty)) -let mkILMethodImplsLazy l = MethodImpls (lazy (List.foldBack addMethodImplToTable (Lazy.force l) Map.empty)) +let mkILMethodImpls l = ILMethodImpls (notlazy (List.foldBack addMethodImplToTable l Map.empty)) +let mkILMethodImplsLazy l = ILMethodImpls (lazy (List.foldBack addMethodImplToTable (Lazy.force l) Map.empty)) let emptyILMethodImpls = mkILMethodImpls [] @@ -2751,37 +2953,36 @@ let mkILStorageCtor(tag,preblock,typ,flds,access) = mkILStorageCtorWithParamName let mkILGenericClass (nm, access, genparams, extends, impl, methods, fields, nestedTypes, props, events, attrs, init) = - { Name=nm; - Attributes=convertTypeAccessFlags access ||| TypeAttributes.AutoLayout ||| TypeAttributes.Class ||| (match init with | ILTypeInit.BeforeField -> TypeAttributes.BeforeFieldInit | _ -> enum 0) ||| TypeAttributes.AnsiClass; - GenericParams= genparams; - Implements = impl; - Layout=ILTypeDefLayout.Auto; - Extends = Some extends; - Methods= methods; - Fields= fields; - NestedTypes=nestedTypes; - CustomAttrs=attrs; - MethodImpls=emptyILMethodImpls; - Properties=props; - Events=events; - SecurityDecls=emptyILSecurityDecls; -} + ILTypeDef(name=nm, + attributes=(convertTypeAccessFlags access ||| TypeAttributes.AutoLayout ||| TypeAttributes.Class ||| (match init with | ILTypeInit.BeforeField -> TypeAttributes.BeforeFieldInit | _ -> enum 0) ||| TypeAttributes.AnsiClass), + genericParams= genparams, + implements = impl, + layout=ILTypeDefLayout.Auto, + extends = Some extends, + methods= methods , + fields= fields, + nestedTypes=nestedTypes, + customAttrs=attrs, + methodImpls=emptyILMethodImpls, + properties=props, + events=events, + securityDecls=emptyILSecurityDecls) let mkRawDataValueTypeDef (iltyp_ValueType: ILType) (nm,size,pack) = - { Name = nm; - GenericParams= []; - Attributes = TypeAttributes.NotPublic ||| TypeAttributes.Sealed ||| TypeAttributes.ExplicitLayout ||| TypeAttributes.BeforeFieldInit ||| TypeAttributes.AnsiClass; - Implements = [] - Extends = Some iltyp_ValueType; - Layout=ILTypeDefLayout.Explicit { Size=Some size; Pack=Some pack }; - Methods= emptyILMethods; - Fields= emptyILFields; - NestedTypes=emptyILTypeDefs; - CustomAttrs=emptyILCustomAttrs; - MethodImpls=emptyILMethodImpls; - Properties=emptyILProperties; - Events=emptyILEvents; - SecurityDecls=emptyILSecurityDecls; } + ILTypeDef(name = nm, + genericParams= [], + attributes = (TypeAttributes.NotPublic ||| TypeAttributes.Sealed ||| TypeAttributes.ExplicitLayout ||| TypeAttributes.BeforeFieldInit ||| TypeAttributes.AnsiClass), + implements = [], + extends = Some iltyp_ValueType, + layout=ILTypeDefLayout.Explicit { Size=Some size; Pack=Some pack }, + methods= emptyILMethods, + fields= emptyILFields, + nestedTypes=emptyILTypeDefs, + customAttrs=emptyILCustomAttrs, + methodImpls=emptyILMethodImpls, + properties=emptyILProperties, + events=emptyILEvents, + securityDecls=emptyILSecurityDecls) let mkILSimpleClass (ilg: ILGlobals) (nm, access, methods, fields, nestedTypes, props, events, attrs, init) = @@ -2796,41 +2997,43 @@ let destTypeDefsWithGlobalFunctionsFirst ilg (tdefs: ILTypeDefs) = top2@nontop let mkILSimpleModule assname modname dll subsystemVersion useHighEntropyVA tdefs hashalg locale flags exportedTypes metadataVersion = - { Manifest= - Some { Name=assname; - AuxModuleHashAlgorithm= match hashalg with | Some(alg) -> alg | _ -> 0x8004; // SHA1 - SecurityDecls=emptyILSecurityDecls; - PublicKey= None; - Version= None; - Locale=locale - CustomAttrs=emptyILCustomAttrs; - AssemblyLongevity=ILAssemblyLongevity.Unspecified; - DisableJitOptimizations = 0 <> (flags &&& 0x4000); - JitTracking = (0 <> (flags &&& 0x8000)); // always turn these on - IgnoreSymbolStoreSequencePoints = (0 <> (flags &&& 0x2000)); - Retargetable = (0 <> (flags &&& 0x100)); - ExportedTypes=exportedTypes; - EntrypointElsewhere=None - }; - CustomAttrs=emptyILCustomAttrs; - Name=modname; - NativeResources=[]; - TypeDefs=tdefs; + let manifest = + { Name=assname + AuxModuleHashAlgorithm= match hashalg with | Some(alg) -> alg | _ -> 0x8004 // SHA1 + SecurityDeclsStored=emptyILSecurityDeclsStored + PublicKey= None + Version= None + Locale=locale + CustomAttrsStored=storeILCustomAttrs emptyILCustomAttrs + AssemblyLongevity=ILAssemblyLongevity.Unspecified + DisableJitOptimizations = 0 <> (flags &&& 0x4000) + JitTracking = (0 <> (flags &&& 0x8000)) // always turn these on + IgnoreSymbolStoreSequencePoints = (0 <> (flags &&& 0x2000)) + Retargetable = (0 <> (flags &&& 0x100)) + ExportedTypes=exportedTypes + EntrypointElsewhere=None + MetadataIndex = NoMetadataIdx } + { Manifest= Some manifest + CustomAttrsStored=storeILCustomAttrs emptyILCustomAttrs + Name=modname + NativeResources=[] + TypeDefs=tdefs SubsystemVersion = subsystemVersion UseHighEntropyVA = useHighEntropyVA - SubSystemFlags=defaultSubSystem; - IsDLL=dll; - IsILOnly=true; - Platform=None; - StackReserveSize=None; - Is32Bit=false; - Is32BitPreferred=false; - Is64Bit=false; - PhysicalAlignment=defaultPhysAlignment; - VirtualAlignment=defaultVirtAlignment; - ImageBase=defaultImageBase; - MetadataVersion=metadataVersion; - Resources=mkILResources []; + SubSystemFlags=defaultSubSystem + IsDLL=dll + IsILOnly=true + Platform=None + StackReserveSize=None + Is32Bit=false + Is32BitPreferred=false + Is64Bit=false + PhysicalAlignment=defaultPhysAlignment + VirtualAlignment=defaultVirtAlignment + ImageBase=defaultImageBase + MetadataVersion=metadataVersion + Resources=mkILResources [] + MetadataIndex = NoMetadataIdx } @@ -2883,7 +3086,7 @@ let getTyOfILEnumInfo info = info.enumType let computeILEnumInfo (mdName,mdFields: ILFieldDefs) = match (List.partition (fun (fd:ILFieldDef) -> fd.IsStatic) mdFields.AsList) with | staticFields,[vfd] -> - { enumType = vfd.Type; + { enumType = vfd.FieldType; enumValues = staticFields |> List.map (fun fd -> (fd.Name, match fd.LiteralValue with Some i -> i | None -> failwith ("info_of_enum_tdef: badly formed enum "+mdName+": static field does not have an default value"))) } | _,[] -> failwith ("info_of_enum_tdef: badly formed enum "+mdName+": no non-static field found") | _,_ -> failwith ("info_of_enum_tdef: badly formed enum "+mdName+": more than one non-static field found") @@ -3211,7 +3414,7 @@ let MscorlibScopeRef = ILScopeRef.Assembly (ILAssemblyRef.Create("mscorlib", Non let EcmaMscorlibILGlobals = mkILGlobals MscorlibScopeRef -// PermissionSet is a 'blob' having the following format: +// ILSecurityDecl is a 'blob' having the following format: // - A byte containing a period (.). // - A compressed int32 containing the number of attributes encoded in the blob. // - An array of attributes each containing the following: @@ -3232,7 +3435,7 @@ let mkPermissionSet (ilg: ILGlobals) (action,attributes: list<(ILTypeRef * (stri yield! z_unsigned_int bytes.Length; yield! bytes |] - ILPermission.PermissionSet(action,bytes) + ILSecurityDecl.ILSecurityDecl(action,bytes) // Parse an IL type signature argument within a custom attribute blob @@ -3619,11 +3822,11 @@ and refs_of_mbody s x = | MethodBody.PInvoke (attr) -> refs_of_modref s attr.Where | _ -> () -and refs_of_mdef s md = - List.iter (refs_of_param s) md.Parameters; - refs_of_return s md.Return; - refs_of_mbody s md.mdBody.Contents; - refs_of_custom_attrs s md.CustomAttrs; +and refs_of_mdef s (md: ILMethodDef) = + List.iter (refs_of_param s) md.Parameters + refs_of_return s md.Return + refs_of_mbody s md.Body.Contents + refs_of_custom_attrs s md.CustomAttrs refs_of_genparams s md.GenericParams and refs_of_param s p = refs_of_typ s p.Type @@ -3631,26 +3834,26 @@ and refs_of_return s (rt:ILReturn) = refs_of_typ s rt.Type and refs_of_mdefs s x = Seq.iter (refs_of_mdef s) x and refs_of_event_def s (ed: ILEventDef) = - Option.iter (refs_of_typ s) ed.Type ; - refs_of_mref s ed.AddMethod ; - refs_of_mref s ed.RemoveMethod; - Option.iter (refs_of_mref s) ed.FireMethod ; - List.iter (refs_of_mref s) ed.OtherMethods ; - refs_of_custom_attrs s ed.CustomAttrs + Option.iter (refs_of_typ s) ed.EventType + refs_of_mref s ed.AddMethod + refs_of_mref s ed.RemoveMethod + Option.iter (refs_of_mref s) ed.FireMethod + List.iter (refs_of_mref s) ed.OtherMethods + refs_of_custom_attrs s ed.CustomAttrs and refs_of_events s (x: ILEventDefs) = List.iter (refs_of_event_def s) x.AsList -and refs_of_property_def s pd = - Option.iter (refs_of_mref s) pd.SetMethod ; - Option.iter (refs_of_mref s) pd.GetMethod ; - refs_of_typ s pd.Type ; - refs_of_typs s pd.Args ; - refs_of_custom_attrs s pd.CustomAttrs +and refs_of_property_def s (pd: ILPropertyDef) = + Option.iter (refs_of_mref s) pd.SetMethod + Option.iter (refs_of_mref s) pd.GetMethod + refs_of_typ s pd.PropertyType + refs_of_typs s pd.Args + refs_of_custom_attrs s pd.CustomAttrs and refs_of_properties s (x: ILPropertyDefs) = List.iter (refs_of_property_def s) x.AsList -and refs_of_fdef s fd = - refs_of_typ s fd.Type; +and refs_of_fdef s (fd: ILFieldDef) = + refs_of_typ s fd.FieldType refs_of_custom_attrs s fd.CustomAttrs and refs_of_fields s fields = List.iter (refs_of_fdef s) fields @@ -3658,22 +3861,22 @@ and refs_of_fields s fields = List.iter (refs_of_fdef s) fields and refs_of_method_impls s mimpls = List.iter (refs_of_method_impl s) mimpls and refs_of_method_impl s m = - refs_of_ospec s m.Overrides; + refs_of_ospec s m.Overrides refs_of_mspec s m.OverrideBy and refs_of_tdef_kind _s _k = () and refs_of_tdef s (td : ILTypeDef) = - refs_of_types s td.NestedTypes; - refs_of_genparams s td.GenericParams; - refs_of_typs s td.Implements; - Option.iter (refs_of_typ s) td.Extends; - refs_of_mdefs s td.Methods; - refs_of_fields s td.Fields.AsList; - refs_of_method_impls s td.MethodImpls.AsList; - refs_of_events s td.Events; - refs_of_tdef_kind s td; - refs_of_custom_attrs s td.CustomAttrs; + refs_of_types s td.NestedTypes + refs_of_genparams s td.GenericParams + refs_of_typs s td.Implements + Option.iter (refs_of_typ s) td.Extends + refs_of_mdefs s td.Methods + refs_of_fields s td.Fields.AsList + refs_of_method_impls s td.MethodImpls.AsList + refs_of_events s td.Events + refs_of_tdef_kind s td + refs_of_custom_attrs s td.CustomAttrs refs_of_properties s td.Properties and refs_of_string _s _ = () @@ -3686,23 +3889,24 @@ and refs_of_exported_types s (tab: ILExportedTypesAndForwarders) = List.iter (re and refs_of_resource_where s x = match x with - | ILResourceLocation.Local _ -> () + | ILResourceLocation.LocalIn _ -> () + | ILResourceLocation.LocalOut _ -> () | ILResourceLocation.File (mref,_) -> refs_of_modref s mref | ILResourceLocation.Assembly aref -> refs_of_assref s aref and refs_of_resource s x = - refs_of_resource_where s x.Location; + refs_of_resource_where s x.Location refs_of_custom_attrs s x.CustomAttrs and refs_of_resources s (tab: ILResources) = List.iter (refs_of_resource s) tab.AsList and refs_of_modul s m = - refs_of_types s m.TypeDefs; - refs_of_resources s m.Resources; + refs_of_types s m.TypeDefs + refs_of_resources s m.Resources Option.iter (refs_of_manifest s) m.Manifest -and refs_of_manifest s m = - refs_of_custom_attrs s m.CustomAttrs; +and refs_of_manifest s (m: ILAssemblyManifest) = + refs_of_custom_attrs s m.CustomAttrs refs_of_exported_types s m.ExportedTypes let computeILRefs modul = @@ -3710,7 +3914,7 @@ let computeILRefs modul = { refsA = HashSet<_>(HashIdentity.Structural) refsM = HashSet<_>(HashIdentity.Structural) } - refs_of_modul s modul; + refs_of_modul s modul { AssemblyReferences = Seq.fold (fun acc x -> x::acc) [] s.refsA ModuleReferences = Seq.fold (fun acc x -> x::acc) [] s.refsM } @@ -3731,19 +3935,19 @@ let parseILVersion (vstr : string) = failwith "Invalid version format" else // set the build number to the number of days since Jan 1, 2000 - versionComponents.[2] <- defaultBuild.ToString() ; + versionComponents.[2] <- defaultBuild.ToString() // Set the revision number to number of seconds today / 2 - vstr <- System.String.Join(".",versionComponents) + "." + defaultRevision.ToString() ; + vstr <- System.String.Join(".",versionComponents) + "." + defaultRevision.ToString() elif versionComponents.Length > 3 && versionComponents.[3] = "*" then // Set the revision number to number of seconds today / 2 - versionComponents.[3] <- defaultRevision.ToString() ; - vstr <- System.String.Join(".",versionComponents) ; + versionComponents.[3] <- defaultRevision.ToString() + vstr <- System.String.Join(".",versionComponents) let version = System.Version(vstr) let zero32 n = if n < 0 then 0us else uint16(n) // since the minor revision will be -1 if none is specified, we need to truncate to 0 to not break existing code let minorRevision = if version.Revision = -1 then 0us else uint16(version.MinorRevision) - (zero32 version.Major, zero32 version.Minor, zero32 version.Build, minorRevision);; + (zero32 version.Major, zero32 version.Minor, zero32 version.Build, minorRevision) let compareILVersions (a1,a2,a3,a4) ((b1,b2,b3,b4) : ILVersionInfo) = @@ -3783,7 +3987,7 @@ and unscopeILTypes i = and unscopeILCallSig csig = mkILCallSig (csig.CallingConv,unscopeILTypes csig.ArgTypes,unscopeILType csig.ReturnType) -let resolveILMethodRefWithRescope r td (mref:ILMethodRef) = +let resolveILMethodRefWithRescope r (td: ILTypeDef) (mref:ILMethodRef) = let args = mref.ArgTypes let nargs = args.Length let nm = mref.Name @@ -3816,7 +4020,7 @@ let ungenericizeTypeName n = (let m = String.rindex n sym let res = ref (m < n.Length - 1) for i = m + 1 to n.Length - 1 do - res := !res && n.[i] >= '0' && n.[i] <= '9'; + res := !res && n.[i] >= '0' && n.[i] <= '9' !res) then let pos = String.rindex n sym diff --git a/src/absil/il.fsi b/src/absil/il.fsi index cb24a7180a..33b077e197 100755 --- a/src/absil/il.fsi +++ b/src/absil/il.fsi @@ -1,10 +1,8 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -/// The "unlinked" view of .NET metadata and code. Central to -/// to Abstract IL library +/// The "unlinked" view of .NET metadata and code. Central to the Abstract IL library module public Microsoft.FSharp.Compiler.AbstractIL.IL -open Internal.Utilities open System.Collections.Generic open System.Reflection @@ -16,49 +14,7 @@ type PrimaryAssembly = member Name: string -// ==================================================================== -// .NET binaries can be converted to the data structures below by using -// the functions in the "Ilread" module. -// -// Constituent types are listed in ascending order of complexity, -// all the way up to the type ILModuleDef, representing the read of an IL -// assembly (.dll or .exe), or part of a multi-module assembly. Types are -// often specified via a concrete representation for the type (e.g. a record), -// though some types are abstract. -// -// The second part of the file (after the definition of all the types) -// specifies a large set of utilities for building objects belonging to -// the types. You will only need to become familiar with these if you -// are transforming code or writing a code-generating compiler. -// -// Several other utilities are also defined in this file: -// 1. A code builder for turning linear sequences of instructions -// augmented with exception tables into the more structured -// format used for code. -// -// 2. The "typ_XYZ", "tspec_XYZ" and "mspec_XYZ" values which -// can be used to reference types in the "primary assembly (either System.Runtime or mscorlib)" assembly. -// -// 3. The "rescopeXYZ" functions which can be used to lift a piece of -// metadata from one assembly and transform it to a piece of metadata -// suitable for use from another assembly. The transformation adjusts -// references in the metadata to take into account the assembly -// where the metadata will now be located. -// -// 4. The "instantiateXYZ" utilities to replace type variables -// by types. These are associated with generics. -// -// 5. The "intern_XYZ" tables for reducing the memory used by -// generated constructs. -// -// 6. The "refs_of_XYZ" utilities for finding all the assemblies -// referenced by a module. -// -// 7. A somewhat obscure facility to allow new instructions and types -// to be added to the This is only used by ILX. -// ==================================================================== - -// Guids (Note: consider adjusting these to the System.Guid type) +/// Represents guids type ILGuid = byte[] [] @@ -71,7 +27,7 @@ type ILPlatform = /// points and some other locations. [] type ILSourceDocument = - static member Create : language: ILGuid option * vendor: ILGuid option * documentType: ILGuid option * file: string -> ILSourceDocument + static member Create: language: ILGuid option * vendor: ILGuid option * documentType: ILGuid option * file: string -> ILSourceDocument member Language: ILGuid option member Vendor: ILGuid option member DocumentType: ILGuid option @@ -80,7 +36,7 @@ type ILSourceDocument = [] type ILSourceMarker = - static member Create : document: ILSourceDocument * line: int * column: int * endLine:int * endColumn: int-> ILSourceMarker + static member Create: document: ILSourceDocument * line: int * column: int * endLine:int * endColumn: int-> ILSourceMarker member Document: ILSourceDocument member Line: int member Column: int @@ -101,89 +57,31 @@ type ILVersionInfo = uint16 * uint16 * uint16 * uint16 [] type ILAssemblyRef = - static member Create : name: string * hash: byte[] option * publicKey: PublicKey option * retargetable: bool * version: ILVersionInfo option * locale: string option -> ILAssemblyRef - static member FromAssemblyName : System.Reflection.AssemblyName -> ILAssemblyRef - member Name: string; + static member Create: name: string * hash: byte[] option * publicKey: PublicKey option * retargetable: bool * version: ILVersionInfo option * locale: string option -> ILAssemblyRef + static member FromAssemblyName: System.Reflection.AssemblyName -> ILAssemblyRef + member Name: string + /// The fully qualified name of the assembly reference, e.g. mscorlib, Version=1.0.3705 etc. - member QualifiedName: string; - member Hash: byte[] option; - member PublicKey: PublicKey option; + member QualifiedName: string + member Hash: byte[] option + member PublicKey: PublicKey option + /// CLI says this indicates if the assembly can be retargeted (at runtime) to be from a different publisher. - member Retargetable: bool; - member Version: ILVersionInfo option; + member Retargetable: bool + member Version: ILVersionInfo option member Locale: string option interface System.IComparable [] type ILModuleRef = - static member Create : name: string * hasMetadata: bool * hash: byte[] option -> ILModuleRef + static member Create: name: string * hasMetadata: bool * hash: byte[] option -> ILModuleRef member Name: string member HasMetadata: bool member Hash: byte[] option interface System.IComparable // Scope references -// -// Scope references are the bits of metadata attached to type names -// that indicate where a type can be found. CIL has three -// kinds: local, module and assembly references: -// o Local: the type must reside in the same module as the scope reference -// o Module: the type must reside in the indicated module in the same -// assembly as the scope reference -// o Assembly: The type must reside in the indicated assembly. -// These have no implicit context. Assembly references can end up -// binding to the assembly containing the reference, i.e. -// may be self or mutually referential. -// -// Assembly reference may also resolve to type in an -// auxiliary module of an assembly when the assembly -// has an "exported types" (here called "classes elsewhere") table. -// -// We represent these references by values embedded within type -// references. These values are usually "shared" across the data -// structures for a module, i.e. one such value is created for each -// assembly or module reference, and this value is reused within each -// type object. -// -// Note that as with method references the term structure is not -// _linked_, i.e. a "ILScopeRef" is still a _reference_ to a scope, -// not the scope itself. Because the structure is not linked, -// the Abstract IL toolset does not require -// strongly connected inputs: you can manipulate an assembly -// without loading all its dependent assemblies. This is the primary -// difference between Abstract IL and Reflection, and it can be both -// a blessing and a curse depending on the kind of manipulation you -// wish to perform. -// -// Similarly, you can manipulate individual modules within -// an assembly without having the whole assembly loaded. (But note that -// most assemblies are single-module in any case). -// -// [ILScopeRef]'s _cannot_ be compared for equality in the way that -// might be expected, in these sense that two ILScopeRef's may -// resolve to the same assembly/module even though they are not equal. -// -// Aside: People have suggested normalizing all scope references -// so that this would be possible, and early versions of this -// toolkit did this. However, this meant that in order to load -// each module you had to tell the toolkit which assembly it belonged to. -// Furthermore, you had to know the exact resolved details of -// each assembly the module refers to. This is -// effectively like having a "fully-linked" view of the graph -// of assemblies, like that provided in the Ilbind module. This is really problematic for compile-time tools, -// as, for example, the policy for linking at the runtime-machine -// may actually alter the results of linking. If such compile-time -// assumptions are to be made then the tool built on top -// of the toolkit rather than the toolkit itself should -// make them. -// -// Scope references, type references, field references and method references -// can be "bound" to particular assemblies using the functions in "Ilbind". -// This simulates the resolution/binding process performed by a Common Language -// Runtime during execution. Various tests and derived operations -// can then be performed on the results of binding. -[] -[] +[] type ILScopeRef = /// A reference to the type in the current module | Local @@ -228,29 +126,31 @@ type ILThisConvention = [] type ILCallingConv = | Callconv of ILThisConvention * ILArgConvention - member IsInstance : bool - member IsInstanceExplicit : bool - member IsStatic : bool - member ThisConv : ILThisConvention - member BasicConv : ILArgConvention - static member Instance : ILCallingConv - static member Static : ILCallingConv - -/// Array shapes. For most purposes, including verification, the -/// rank is the only thing that matters. - + + member IsInstance: bool + member IsInstanceExplicit: bool + member IsStatic: bool + member ThisConv: ILThisConvention + member BasicConv: ILArgConvention + + static member Instance: ILCallingConv + static member Static : ILCallingConv + +/// Array shapes. For most purposes the rank is the only thing that matters. type ILArrayBound = int32 option + +/// Lower-bound/size pairs type ILArrayBounds = ILArrayBound * ILArrayBound -[] type ILArrayShape = - | ILArrayShape of ILArrayBounds list // lobound/size pairs - member Rank : int + | ILArrayShape of ILArrayBounds list + + member Rank: int + /// Bounds for a single dimensional, zero based array static member SingleDimensional: ILArrayShape - static member FromRank : int -> ILArrayShape + static member FromRank: int -> ILArrayShape -[] type ILBoxity = | AsObject | AsValue @@ -265,7 +165,7 @@ type ILGenericVariance = type ILTypeRef = /// Create a ILTypeRef. - static member Create : scope: ILScopeRef * enclosing: string list * name: string -> ILTypeRef + static member Create: scope: ILScopeRef * enclosing: string list * name: string -> ILTypeRef /// Where is the type, i.e. is it in this module, in another module in this assembly or in another assembly? member Scope: ILScopeRef @@ -280,7 +180,7 @@ type ILTypeRef = member FullName: string /// The name of the type in the assembly using the '+' notation for nested types. - member BasicQualifiedName : string + member BasicQualifiedName: string member QualifiedName: string @@ -291,17 +191,9 @@ type ILTypeRef = interface System.IComparable /// Type specs and types. -/// -/// These are the types that appear syntactically in .NET binaries. -/// -/// Generic type definitions must be combined with -/// an instantiation to form a type. Throughout this file, -/// a "ref" refers to something that is uninstantiated, and -/// a "spec" to a ref that is combined with the relevant instantiations. - [] type ILTypeSpec = - static member Create : typeRef:ILTypeRef * instantiation:ILGenericArgs -> ILTypeSpec + static member Create: typeRef:ILTypeRef * instantiation:ILGenericArgs -> ILTypeSpec /// Which type is being referred to? member TypeRef: ILTypeRef @@ -317,22 +209,31 @@ type ILTypeSpec = and [] ILType = + /// Used only in return and pointer types. | Void + /// Array types | Array of ILArrayShape * ILType + /// Unboxed types, including builtin types. | Value of ILTypeSpec + /// Reference types. Also may be used for parents of members even if for members in value types. | Boxed of ILTypeSpec + /// Unmanaged pointers. Nb. the type is used by tools and for binding only, not by the verifier. | Ptr of ILType + /// Managed pointers. | Byref of ILType + /// ILCode pointers. | FunctionPointer of ILCallingSignature + /// Reference a generic arg. | TypeVar of uint16 + /// Custom modifiers. | Modified of /// True if modifier is "required". @@ -341,38 +242,34 @@ and ILTypeRef * /// The type being modified. ILType - member TypeSpec : ILTypeSpec - member Boxity : ILBoxity - member TypeRef : ILTypeRef - member IsNominal : bool - member GenericArgs : ILGenericArgs - member IsTyvar : bool - member BasicQualifiedName : string - member QualifiedNameWithNoShortPrimaryAssembly : string + + member TypeSpec: ILTypeSpec + member Boxity: ILBoxity + member TypeRef: ILTypeRef + member IsNominal: bool + member GenericArgs: ILGenericArgs + member IsTyvar: bool + member BasicQualifiedName: string + member QualifiedNameWithNoShortPrimaryAssembly: string and [] ILCallingSignature = - { CallingConv: ILCallingConv; - ArgTypes: ILTypes; + { CallingConv: ILCallingConv + ArgTypes: ILTypes ReturnType: ILType } /// Actual generic parameters are always types. +and ILGenericArgs = ILType list +and ILTypes = ILType list -and ILGenericArgs = list -and ILTypes = list - -/// Formal identities of methods. Method refs refer to methods on -/// named types. In general you should work with ILMethodSpec objects -/// rather than MethodRef objects, because ILMethodSpec objects carry -/// information about how generic methods are instantiated. MethodRef -/// objects are only used at a few places in the Abstract IL syntax -/// and if analyzing or generating IL you will be unlikely to come across -/// these. - +/// Formal identities of methods. [] type ILMethodRef = - static member Create : enclosingTypeRef: ILTypeRef * callingConv: ILCallingConv * name: string * genericArity: int * argTypes: ILTypes * returnType: ILType -> ILMethodRef + + /// Functional creation + static member Create: enclosingTypeRef: ILTypeRef * callingConv: ILCallingConv * name: string * genericArity: int * argTypes: ILTypes * returnType: ILType -> ILMethodRef + member DeclaringTypeRef: ILTypeRef member CallingConv: ILCallingConv member Name: string @@ -383,30 +280,20 @@ type ILMethodRef = member CallingSignature: ILCallingSignature interface System.IComparable -/// Formal identities of fields. - +/// Formal identities of fields. [] type ILFieldRef = - { DeclaringTypeRef: ILTypeRef; - Name: string; + { DeclaringTypeRef: ILTypeRef + Name: string Type: ILType } /// The information at the callsite of a method -// -// A ILMethodSpec is everything given at the callsite (apart from whether the call is a tailcall and whether it is passing -// varargs - see the instruction set below). It is made up of: -// 1) a (possibly generic) ILMethodRef -// 2) a "usage type" that indicates the how the type containing the declaration is being used (as -// a value class, a boxed value class, an instantiated generic class or whatever - see below) -// 3) an instantiation in the case where the method is generic. -// -// In this unbound form of the metadata, the enclosing type may be ILType.Boxed even when the member is a member of a value type or -// enumeration. This is because the binary format of the metadata does not carry enough information in a MemberRefParent to determine -// from the binary alone whether the enclosing type is a value type or not. - [] type ILMethodSpec = - static member Create : ILType * ILMethodRef * ILGenericArgs -> ILMethodSpec + + /// Functional creation + static member Create: ILType * ILMethodRef * ILGenericArgs -> ILMethodSpec + member MethodRef: ILMethodRef member DeclaringType: ILType member GenericArgs: ILGenericArgs @@ -417,20 +304,18 @@ type ILMethodSpec = member FormalReturnType: ILType interface System.IComparable - /// Field specs. The data given for a ldfld, stfld etc. instruction. [] type ILFieldSpec = - { FieldRef: ILFieldRef; + { FieldRef: ILFieldRef DeclaringType: ILType } + member DeclaringTypeRef: ILTypeRef member Name: string member FormalType: ILType - member ActualType : ILType - -/// ILCode labels. In structured code each code label -/// refers to a basic block somewhere in the code of the method. + member ActualType: ILType +/// ILCode labels. In structured code each code label refers to a basic block somewhere in the code of the method. type ILCodeLabel = int [] @@ -499,15 +384,8 @@ type ILComparisonInstr = | BI_brtrue /// The instruction set. -/// -/// In general we don't categorize instructions, as different -/// instruction groups are relevant for different types of operations. -/// However we do collect the branch and compare instructions together -/// because they all take an address, and the ILArithInstr ones because -/// none of them take any direct arguments. [] type ILInstr = - // Basic | AI_add | AI_add_ovf | AI_add_ovf_un @@ -636,16 +514,15 @@ type ILInstr = // Varargs - C++ only | I_arglist - // Local aggregates, i.e. stack allocated data (alloca) : C++ only + // Local aggregates, i.e. stack allocated data (alloca): C++ only | I_localloc | I_cpblk of ILAlignment * ILVolatility | I_initblk of ILAlignment * ILVolatility - // EXTENSIONS, e.g. MS-ILX + // EXTENSIONS | EI_ilzero of ILType | EI_ldlen_multi of int32 * int32 - [] type ILExceptionClause = | Finally of (ILCodeLabel * ILCodeLabel) @@ -655,7 +532,7 @@ type ILExceptionClause = [] type ILExceptionSpec = - { Range: (ILCodeLabel * ILCodeLabel); + { Range: (ILCodeLabel * ILCodeLabel) Clause: ILExceptionClause } /// Indicates that a particular local variable has a particular source @@ -663,8 +540,8 @@ type ILExceptionSpec = /// variable numbering, which is global over the whole method. [] type ILLocalDebugMapping = - { LocalIndex: int; - LocalName: string; } + { LocalIndex: int + LocalName: string } [] type ILLocalDebugInfo = @@ -679,7 +556,6 @@ type ILCode = Locals: ILLocalDebugInfo list } /// Field Init - [] type ILFieldInit = | String of string @@ -746,7 +622,6 @@ type ILNativeVariant = /// Native Types, for marshalling to the native C interface. /// These are taken directly from the ILASM syntax, see ECMA Spec (Partition II, 7.4). - [] type ILNativeType = | Empty @@ -774,7 +649,8 @@ type ILNativeType = | UInt16 | UInt32 | UInt64 - | Array of ILNativeType option * (int32 * int32 option) option (* optional idx of parameter giving size plus optional additive i.e. num elems *) + /// optional idx of parameter giving size plus optional additive i.e. num elems + | Array of ILNativeType option * (int32 * int32 option) option | Int | UInt | Method @@ -788,12 +664,11 @@ type ILNativeType = | ANSIBSTR | VariantBool - /// Local variables [] type ILLocal = - { Type: ILType; - IsPinned: bool; + { Type: ILType + IsPinned: bool DebugInfo: (string * int * int) option } type ILLocals = list @@ -801,13 +676,12 @@ type ILLocals = list /// IL method bodies [] type ILMethodBody = - { IsZeroInit: bool; - /// strictly speaking should be a uint16 - MaxStack: int32; - NoInlining: bool; - AggressiveInlining: bool; - Locals: ILLocals; - Code: ILCode; + { IsZeroInit: bool + MaxStack: int32 + NoInlining: bool + AggressiveInlining: bool + Locals: ILLocals + Code: ILCode SourceMarker: ILSourceMarker option } /// Member Access @@ -848,42 +722,48 @@ type ILAttributeNamedArg = string * ILType * bool * ILAttribElem /// Custom attributes. See 'decodeILAttribData' for a helper to parse the byte[] /// to ILAttribElem's as best as possible. type ILAttribute = - { Method: ILMethodSpec; + { Method: ILMethodSpec Data: byte[] Elements: ILAttribElem list} -[] +[] type ILAttributes = - member AsArray : ILAttribute [] - member AsList : ILAttribute list + member AsArray: ILAttribute [] + member AsList: ILAttribute list -/// Method parameters and return values. +/// Represents the efficiency-oriented storage of ILAttributes in another item. +[] +type ILAttributesStored +/// Method parameters and return values. [] type ILParameter = - { Name: string option; - Type: ILType; - Default: ILFieldInit option; + { Name: string option + Type: ILType + Default: ILFieldInit option /// Marshalling map for parameters. COM Interop only. - Marshal: ILNativeType option; - IsIn: bool; - IsOut: bool; - IsOptional: bool; - CustomAttrs: ILAttributes } + Marshal: ILNativeType option + IsIn: bool + IsOut: bool + IsOptional: bool + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } + member CustomAttrs: ILAttributes type ILParameters = list -val typesOfILParams : ILParameters -> ILType list +val typesOfILParams: ILParameters -> ILType list /// Method return values. [] type ILReturn = - { Marshal: ILNativeType option; - Type: ILType; - CustomAttrs: ILAttributes } + { Marshal: ILNativeType option + Type: ILType + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } + + member CustomAttrs: ILAttributes -/// Security ILPermissions -/// Attached to various structures... [] type ILSecurityAction = | Request @@ -905,14 +785,18 @@ type ILSecurityAction = | InheritanceDemandChoice | DemandChoice -type ILPermission = - | PermissionSet of ILSecurityAction * byte[] +type ILSecurityDecl = + | ILSecurityDecl of ILSecurityAction * byte[] -/// Abstract type equivalent to ILPermission list - use helpers +/// Abstract type equivalent to ILSecurityDecl list - use helpers /// below to construct/destruct these. -[] -type ILPermissions = - member AsList : ILPermission list +[] +type ILSecurityDecls = + member AsList: ILSecurityDecl list + +/// Represents the efficiency-oriented storage of ILSecurityDecls in another item. +[] +type ILSecurityDeclsStored /// PInvoke attributes. [] @@ -945,33 +829,27 @@ type PInvokeThrowOnUnmappableChar = [] type PInvokeMethod = - { Where: ILModuleRef; - Name: string; - CallingConv: PInvokeCallingConvention; - CharEncoding: PInvokeCharEncoding; - NoMangle: bool; - LastError: bool; - ThrowOnUnmappableChar: PInvokeThrowOnUnmappableChar; + { Where: ILModuleRef + Name: string + CallingConv: PInvokeCallingConvention + CharEncoding: PInvokeCharEncoding + NoMangle: bool + LastError: bool + ThrowOnUnmappableChar: PInvokeThrowOnUnmappableChar CharBestFit: PInvokeCharBestFit } -/// [OverridesSpec] - refer to a method declaration in a superclass -/// or superinterface. Used for overriding/method impls. Includes -/// a type for the parent for the same reason that a method specs -/// includes the type of the enclosing type, i.e. the type -/// gives the "ILGenericArgs" at which the parent type is being used. - +/// [OverridesSpec] - refer to a method declaration in a superclass or interface. type ILOverridesSpec = | OverridesSpec of ILMethodRef * ILType member MethodRef: ILMethodRef member DeclaringType: ILType -// REVIEW: fold this into ILMethodDef. type ILMethodVirtualInfo = - { IsFinal: bool; - IsNewSlot: bool; - IsCheckAccessOnOverride: bool; - IsAbstract: bool; } + { IsFinal: bool + IsNewSlot: bool + IsCheckAccessOnOverride: bool + IsAbstract: bool } [] type MethodKind = @@ -981,87 +859,98 @@ type MethodKind = | NonVirtual | Virtual of ILMethodVirtualInfo -// REVIEW: fold this into ILMethodDef. [] type MethodBody = | IL of ILMethodBody - | PInvoke of PInvokeMethod (* platform invoke to native *) + | PInvoke of PInvokeMethod | Abstract | Native + | NotAvailable -// REVIEW: fold this into ILMethodDef. [] type MethodCodeKind = | IL | Native | Runtime -/// Generic parameters. Formal generic parameter declarations -/// may include the bounds, if any, on the generic parameter. +/// Generic parameters. Formal generic parameter declarations may include the bounds, if any, on the generic parameter. type ILGenericParameterDef = - { Name: string; - /// At most one is the parent type, the others are interface types. - Constraints: ILTypes; + { Name: string + + /// At most one is the parent type, the others are interface types. + Constraints: ILTypes + /// Variance of type parameters, only applicable to generic parameters for generic interfaces and delegates. - Variance: ILGenericVariance; + Variance: ILGenericVariance + /// Indicates the type argument must be a reference type. - HasReferenceTypeConstraint: bool; - CustomAttrs : ILAttributes; + HasReferenceTypeConstraint: bool + /// Indicates the type argument must be a value type, but not Nullable. - HasNotNullableValueTypeConstraint: bool; + HasNotNullableValueTypeConstraint: bool + /// Indicates the type argument must have a public nullary constructor. - HasDefaultConstructorConstraint: bool; } + HasDefaultConstructorConstraint: bool + + /// Do not use this + CustomAttrsStored: ILAttributesStored + /// Do not use this + MetadataIndex: int32 } + + member CustomAttrs: ILAttributes type ILGenericParameterDefs = ILGenericParameterDef list [] type ILLazyMethodBody = - member Contents : MethodBody - -/// Method definitions. -/// -/// There are several different flavours of methods (constructors, -/// abstract, virtual, static, instance, class constructors). There -/// is no perfect factorization of these as the combinations are not -/// independent. + member Contents: MethodBody +/// IL Method definitions. [] type ILMethodDef = - { Name: string; - Attributes: MethodAttributes; - ImplAttributes: MethodImplAttributes; - CallingConv: ILCallingConv; - Parameters: ILParameters; - Return: ILReturn; - mdBody: ILLazyMethodBody; - SecurityDecls: ILPermissions; - IsEntryPoint:bool; - GenericParams: ILGenericParameterDefs; - CustomAttrs: ILAttributes; } + + /// Functional creation of a value, with delayed reading of some elements via a metadata index + new: name: string * attributes: MethodAttributes * implAttributes: MethodImplAttributes * callingConv: ILCallingConv * + parameters: ILParameters * ret: ILReturn * body: ILLazyMethodBody * isEntryPoint:bool * genericParams: ILGenericParameterDefs * + securityDeclsStored: ILSecurityDeclsStored * customAttrsStored: ILAttributesStored * metadataIndex: int32 -> ILMethodDef + + /// Functional creation of a value, immediate + new: name: string * attributes: MethodAttributes * implAttributes: MethodImplAttributes * callingConv: ILCallingConv * + parameters: ILParameters * ret: ILReturn * body: ILLazyMethodBody * isEntryPoint:bool * genericParams: ILGenericParameterDefs * + securityDecls: ILSecurityDecls * customAttrs: ILAttributes -> ILMethodDef - member ParameterTypes: ILTypes; - member IsIL : bool - member Code : ILCode option - member Locals : ILLocals - member MaxStack : int32 - member IsZeroInit : bool + member Name: string + member Attributes: MethodAttributes + member ImplAttributes: MethodImplAttributes + member CallingConv: ILCallingConv + member Parameters: ILParameters + member Return: ILReturn + member Body: ILLazyMethodBody + member SecurityDecls: ILSecurityDecls + member IsEntryPoint:bool + member GenericParams: ILGenericParameterDefs + member CustomAttrs: ILAttributes + member ParameterTypes: ILTypes + member IsIL: bool + member Code: ILCode option + member Locals: ILLocals + member MaxStack: int32 + member IsZeroInit: bool - /// .cctor methods. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) - /// form a complete, non-overlapping classification of this type. + /// Indicates a .cctor method. member IsClassInitializer: bool - /// .ctor methods. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) - /// form a complete, non-overlapping classification of this type. + + /// Indicates a .ctor method. member IsConstructor: bool - /// static methods. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) - /// form a complete, non-overlapping classification of this type. + + /// Indicates a static method. member IsStatic: bool - /// instance methods that are not virtual. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) - /// form a complete, non-overlapping classification of this type. + + /// Indicates this is an instance methods that is not virtual. member IsNonVirtualInstance: bool - /// instance methods that are virtual or abstract or implement an interface slot. - /// The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) - /// form a complete, non-overlapping classification of this type. + + /// Indicates an instance methods that is virtual or abstract or implements an interface slot. member IsVirtual: bool member IsFinal: bool @@ -1073,9 +962,11 @@ type ILMethodDef = member Access: ILMemberAccess member IsHideBySig: bool member IsSpecialName: bool + /// The method is exported to unmanaged code using COM interop. member IsUnmanagedExport: bool member IsReqSecObj: bool + /// Some methods are marked "HasSecurity" even if there are no permissions attached, e.g. if they use SuppressUnmanagedCodeSecurityAttribute member HasSecurity: bool member IsManaged: bool @@ -1085,9 +976,14 @@ type ILMethodDef = member IsSynchronized: bool member IsNoInline: bool member IsAggressiveInline: bool - /// .NET 2.0 feature: SafeHandle finalizer must be run. + + /// SafeHandle finalizer must be run. member IsMustRun: bool + /// Functional update of the value + member With: ?name: string * ?attributes: MethodAttributes * ?implAttributes: MethodImplAttributes * ?callingConv: ILCallingConv * + ?parameters: ILParameters * ?ret: ILReturn * ?body: ILLazyMethodBody * ?securityDecls: ILSecurityDecls * ?isEntryPoint:bool * + ?genericParams: ILGenericParameterDefs * ?customAttrs: ILAttributes -> ILMethodDef member WithSpecialName: ILMethodDef member WithHideBySig: unit -> ILMethodDef member WithHideBySig: bool -> ILMethodDef @@ -1106,104 +1002,144 @@ type ILMethodDef = /// Tables of methods. Logically equivalent to a list of methods but /// the table is kept in a form optimized for looking up methods by /// name and arity. - -/// abstract type equivalent to [ILMethodDef list] [] type ILMethodDefs = interface IEnumerable - member AsArray : ILMethodDef[] - member AsList : ILMethodDef list - member FindByName : string -> ILMethodDef list + member AsArray: ILMethodDef[] + member AsList: ILMethodDef list + member FindByName: string -> ILMethodDef list /// Field definitions. [] type ILFieldDef = - { Name: string; - Type: ILType; - Attributes: FieldAttributes; - Data: byte[] option; - LiteralValue: ILFieldInit option; - /// The explicit offset in bytes when explicit layout is used. - Offset: int32 option; - Marshal: ILNativeType option; - CustomAttrs: ILAttributes; } - member IsStatic: bool - member IsSpecialName: bool - member IsLiteral: bool - member NotSerialized: bool - member IsInitOnly: bool - member Access: ILMemberAccess - member WithAccess: ILMemberAccess -> ILFieldDef - member WithInitOnly: bool -> ILFieldDef - member WithStatic: bool -> ILFieldDef - member WithSpecialName: bool -> ILFieldDef - member WithNotSerialized: bool -> ILFieldDef - member WithLiteral: bool -> ILFieldDef - member WithHasDefault: bool -> ILFieldDef - member WithHasFieldMarshal: bool -> ILFieldDef - -/// Tables of fields. Logically equivalent to a list of fields but -/// the table is kept in a form optimized for looking up fields by -/// name. + + /// Functional creation of a value using delayed reading via a metadata index + new: name: string * fieldType: ILType * attributes: FieldAttributes * data: byte[] option * + literalValue: ILFieldInit option * offset: int32 option * marshal: ILNativeType option * + customAttrsStored: ILAttributesStored * metadataIndex: int32 -> ILFieldDef + + /// Functional creation of a value, immediate + new: name: string * fieldType: ILType * attributes: FieldAttributes * data: byte[] option * + literalValue: ILFieldInit option * offset: int32 option * marshal: ILNativeType option * + customAttrs: ILAttributes -> ILFieldDef + + member Name: string + member FieldType: ILType + member Attributes: FieldAttributes + member Data: byte[] option + member LiteralValue: ILFieldInit option + + /// The explicit offset in bytes when explicit layout is used. + member Offset: int32 option + member Marshal: ILNativeType option + member CustomAttrs: ILAttributes + member IsStatic: bool + member IsSpecialName: bool + member IsLiteral: bool + member NotSerialized: bool + member IsInitOnly: bool + member Access: ILMemberAccess + + /// Functional update of the value + member With: ?name: string * ?fieldType: ILType * ?attributes: FieldAttributes * ?data: byte[] option * ?literalValue: ILFieldInit option * + ?offset: int32 option * ?marshal: ILNativeType option * ?customAttrs: ILAttributes -> ILFieldDef + member WithAccess: ILMemberAccess -> ILFieldDef + member WithInitOnly: bool -> ILFieldDef + member WithStatic: bool -> ILFieldDef + member WithSpecialName: bool -> ILFieldDef + member WithNotSerialized: bool -> ILFieldDef + member WithLiteralDefaultValue: ILFieldInit option -> ILFieldDef + member WithFieldMarshal: ILNativeType option -> ILFieldDef + +/// Tables of fields. Logically equivalent to a list of fields but the table is kept in +/// a form to allow efficient looking up fields by name. [] type ILFieldDefs = - member AsList : ILFieldDef list - member LookupByName : string -> ILFieldDef list + member AsList: ILFieldDef list + member LookupByName: string -> ILFieldDef list /// Event definitions. [] type ILEventDef = - { Type: ILType option; - Name: string; - Attributes: EventAttributes - AddMethod: ILMethodRef; - RemoveMethod: ILMethodRef; - FireMethod: ILMethodRef option; - OtherMethods: ILMethodRef list; - CustomAttrs: ILAttributes; } - member IsSpecialName : bool - member IsRTSpecialName : bool + + /// Functional creation of a value, using delayed reading via a metadata index, for ilread.fs + new: eventType: ILType option * name: string * attributes: EventAttributes * addMethod: ILMethodRef * + removeMethod: ILMethodRef * fireMethod: ILMethodRef option * otherMethods: ILMethodRef list * + customAttrsStored: ILAttributesStored * metadataIndex: int32 -> ILEventDef + + /// Functional creation of a value, immediate + new: eventType: ILType option * name: string * attributes: EventAttributes * addMethod: ILMethodRef * + removeMethod: ILMethodRef * fireMethod: ILMethodRef option * otherMethods: ILMethodRef list * + customAttrs: ILAttributes -> ILEventDef + + member EventType: ILType option + member Name: string + member Attributes: EventAttributes + member AddMethod: ILMethodRef + member RemoveMethod: ILMethodRef + member FireMethod: ILMethodRef option + member OtherMethods: ILMethodRef list + member CustomAttrs: ILAttributes + member IsSpecialName: bool + member IsRTSpecialName: bool + + /// Functional update of the value + member With: ?eventType: ILType option * ?name: string * ?attributes: EventAttributes * ?addMethod: ILMethodRef * + ?removeMethod: ILMethodRef * ?fireMethod: ILMethodRef option * ?otherMethods: ILMethodRef list * + ?customAttrs: ILAttributes -> ILEventDef /// Table of those events in a type definition. [] type ILEventDefs = - member AsList : ILEventDef list - member LookupByName : string -> ILEventDef list + member AsList: ILEventDef list + member LookupByName: string -> ILEventDef list -/// Property definitions. +/// Property definitions [] type ILPropertyDef = - { Name: string; - Attributes: PropertyAttributes; - SetMethod: ILMethodRef option; - GetMethod: ILMethodRef option; - CallingConv: ILThisConvention; - Type: ILType; - Init: ILFieldInit option; - Args: ILTypes; - CustomAttrs: ILAttributes; } - member IsSpecialName : bool - member IsRTSpecialName : bool - -/// Table of those properties in a type definition. + + /// Functional creation of a value, using delayed reading via a metadata index, for ilread.fs + new: name: string * attributes: PropertyAttributes * setMethod: ILMethodRef option * getMethod: ILMethodRef option * + callingConv: ILThisConvention * propertyType: ILType * init: ILFieldInit option * args: ILTypes * + customAttrsStored: ILAttributesStored * metadataIndex: int32 -> ILPropertyDef + + /// Functional creation of a value, immediate + new: name: string * attributes: PropertyAttributes * setMethod: ILMethodRef option * getMethod: ILMethodRef option * + callingConv: ILThisConvention * propertyType: ILType * init: ILFieldInit option * args: ILTypes * + customAttrs: ILAttributes -> ILPropertyDef + + member Name: string + member Attributes: PropertyAttributes + member SetMethod: ILMethodRef option + member GetMethod: ILMethodRef option + member CallingConv: ILThisConvention + member PropertyType: ILType + member Init: ILFieldInit option + member Args: ILTypes + member CustomAttrs: ILAttributes + member IsSpecialName: bool + member IsRTSpecialName: bool + + /// Functional update of the value + member With: ?name: string * ?attributes: PropertyAttributes * ?setMethod: ILMethodRef option * ?getMethod: ILMethodRef option * + ?callingConv: ILThisConvention * ?propertyType: ILType * ?init: ILFieldInit option * ?args: ILTypes * + ?customAttrs: ILAttributes -> ILPropertyDef + +/// Table of properties in an IL type definition. [] [] type ILPropertyDefs = - member AsList : ILPropertyDef list - member LookupByName : string -> ILPropertyDef list + member AsList: ILPropertyDef list + member LookupByName: string -> ILPropertyDef list /// Method Impls -/// -/// If there is an entry (pms --> ms) in this table, then method [ms] -/// is used to implement method [pms] for the purposes of this class -/// and its subclasses. type ILMethodImplDef = - { Overrides: ILOverridesSpec; + { Overrides: ILOverridesSpec OverrideBy: ILMethodSpec } [] type ILMethodImplDefs = - member AsList : ILMethodImplDef list + member AsList: ILMethodImplDef list /// Type Layout information. [] @@ -1213,7 +1149,7 @@ type ILTypeDefLayout = | Explicit of ILTypeDefLayoutInfo and ILTypeDefLayoutInfo = - { Size: int32 option; + { Size: int32 option Pack: uint16 option } /// Indicate the initialization semantics of a type. @@ -1237,20 +1173,6 @@ type ILTypeDefAccess = | Nested of ILMemberAccess /// A categorization of type definitions into "kinds" - -//------------------------------------------------------------------- -// A note for the nit-picky.... In theory, the "kind" of a type -// definition can only be partially determined prior to binding. -// For example, you cannot really, absolutely tell if a type is -// really, absolutely a value type until you bind the -// super class and test it for type equality against System.ValueType. -// However, this is unbearably annoying, as it means you -// have to load "primary runtime assembly (System.Runtime or mscorlib)" and perform bind operations -// in order to be able to determine some quite simple -// things. So we approximate by simply looking at the name -// of the superclass when loading. -// ------------------------------------------------------------------ - [] type ILTypeDefKind = | Class @@ -1259,56 +1181,58 @@ type ILTypeDefKind = | Enum | Delegate -/// Tables of named type definitions. The types and table may contain on-demand -/// (lazy) computations, e.g. the actual reading of some aspects -/// of a type definition may be delayed if the reader being used supports -/// this. -/// -/// This is an abstract type equivalent to "ILTypeDef list". -[] -[] +/// Tables of named type definitions. +[] type ILTypeDefs = interface IEnumerable - member AsArray : ILTypeDef[] - member AsList : ILTypeDef list + + member AsArray: ILTypeDef[] + + member AsList: ILTypeDef list /// Get some information about the type defs, but do not force the read of the type defs themselves. - member AsArrayOfLazyTypeDefs : (string list * string * ILAttributes * Lazy) array + member AsArrayOfPreTypeDefs: ILPreTypeDef[] /// Calls to FindByName will result in any laziness in the overall /// set of ILTypeDefs being read in in addition /// to the details for the type found, but the remaining individual /// type definitions will not be read. - member FindByName : string -> ILTypeDef + member FindByName: string -> ILTypeDef -/// Type Definitions -/// -/// As for methods there are several important constraints not encoded -/// in the type definition below, for example that the super class of -/// an interface type is always None, or that enumerations always -/// have a very specific form. +/// Represents IL Type Definitions. and [] ILTypeDef = - { Name: string; - Attributes: TypeAttributes; - GenericParams: ILGenericParameterDefs; - Layout: ILTypeDefLayout; - NestedTypes: ILTypeDefs; - Implements: ILTypes; - Extends: ILType option; - Methods: ILMethodDefs; - SecurityDecls: ILPermissions; - Fields: ILFieldDefs; - MethodImpls: ILMethodImplDefs; - Events: ILEventDefs; - Properties: ILPropertyDefs; - CustomAttrs: ILAttributes; } - member IsClass: bool; - member IsStruct: bool; - member IsInterface: bool; - member IsEnum: bool; - member IsDelegate: bool; - member IsStructOrEnum : bool + + /// Functional creation of a value, using delayed reading via a metadata index, for ilread.fs + new: name: string * attributes: TypeAttributes * layout: ILTypeDefLayout * implements: ILTypes * genericParams: ILGenericParameterDefs * + extends: ILType option * methods: ILMethodDefs * nestedTypes: ILTypeDefs * fields: ILFieldDefs * methodImpls: ILMethodImplDefs * + events: ILEventDefs * properties: ILPropertyDefs * securityDeclsStored: ILSecurityDeclsStored * customAttrsStored: ILAttributesStored * metadataIndex: int32 -> ILTypeDef + + /// Functional creation of a value, immediate + new: name: string * attributes: TypeAttributes * layout: ILTypeDefLayout * implements: ILTypes * genericParams: ILGenericParameterDefs * + extends: ILType option * methods: ILMethodDefs * nestedTypes: ILTypeDefs * fields: ILFieldDefs * methodImpls: ILMethodImplDefs * + events: ILEventDefs * properties: ILPropertyDefs * securityDecls: ILSecurityDecls * customAttrs: ILAttributes -> ILTypeDef + + member Name: string + member Attributes: TypeAttributes + member GenericParams: ILGenericParameterDefs + member Layout: ILTypeDefLayout + member NestedTypes: ILTypeDefs + member Implements: ILTypes + member Extends: ILType option + member Methods: ILMethodDefs + member SecurityDecls: ILSecurityDecls + member Fields: ILFieldDefs + member MethodImpls: ILMethodImplDefs + member Events: ILEventDefs + member Properties: ILPropertyDefs + member CustomAttrs: ILAttributes + member IsClass: bool + member IsStruct: bool + member IsInterface: bool + member IsEnum: bool + member IsDelegate: bool + member IsStructOrEnum: bool member Access: ILTypeDefAccess member IsAbstract: bool member IsSealed: bool @@ -1319,7 +1243,8 @@ and [] /// Some classes are marked "HasSecurity" even if there are no permissions attached, /// e.g. if they use SuppressUnmanagedCodeSecurityAttribute member HasSecurity: bool - member Encoding: ILDefaultPInvokeEncoding; + member Encoding: ILDefaultPInvokeEncoding + member WithAccess: ILTypeDefAccess -> ILTypeDef member WithNestedAccess: ILMemberAccess -> ILTypeDef member WithSealed: bool -> ILTypeDef @@ -1333,10 +1258,34 @@ and [] member WithSpecialName: bool -> ILTypeDef member WithInitSemantics: ILTypeInit -> ILTypeDef -[] -[] + /// Functional update + member With: ?name: string * ?attributes: TypeAttributes * ?layout: ILTypeDefLayout * ?implements: ILTypes * + ?genericParams:ILGenericParameterDefs * ?extends:ILType option * ?methods:ILMethodDefs * + ?nestedTypes:ILTypeDefs * ?fields: ILFieldDefs * ?methodImpls:ILMethodImplDefs * ?events:ILEventDefs * + ?properties:ILPropertyDefs * ?customAttrs:ILAttributes * ?securityDecls: ILSecurityDecls -> ILTypeDef + +/// Represents a prefix of information for ILTypeDef. +/// +/// The information is enough to perform name resolution for the F# compiler, probe attributes +/// for ExtensionAttribute etc. This is key to the on-demand exploration of .NET metadata. +/// This information has to be "Goldilocks" - not too much, not too little, just right. +and [] ILPreTypeDef = + member Namespace: string list + member Name: string + member MetadataIndex: int32 + /// Realise the actual full typedef + member GetTypeDef : unit -> ILTypeDef + +and [] ILTypeDefStored + +val mkILPreTypeDef : ILTypeDef -> ILPreTypeDef +val mkILPreTypeDefComputed : string list * string * (unit -> ILTypeDef) -> ILPreTypeDef +val mkILPreTypeDefRead : string list * string * int32 * ILTypeDefStored -> ILPreTypeDef +val mkILTypeDefReader: (int32 -> ILTypeDef) -> ILTypeDefStored + +[] type ILNestedExportedTypes = - member AsList : ILNestedExportedType list + member AsList: ILNestedExportedType list /// "Classes Elsewhere" - classes in auxiliary modules. /// @@ -1366,27 +1315,31 @@ type ILNestedExportedTypes = /// these are only found in the "Nested" field of ILExportedTypeOrForwarder objects // REVIEW: fold this into ILExportedTypeOrForwarder. There's not much value in keeping these distinct and ILNestedExportedType = - { Name: string; - Access: ILMemberAccess; - Nested: ILNestedExportedTypes; - CustomAttrs: ILAttributes } + { Name: string + Access: ILMemberAccess + Nested: ILNestedExportedTypes + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } + member CustomAttrs: ILAttributes /// these are only found in the ILExportedTypesAndForwarders table in the manifest [] type ILExportedTypeOrForwarder = - { ScopeRef: ILScopeRef; + { ScopeRef: ILScopeRef /// [Namespace.]Name - Name: string; + Name: string Attributes: TypeAttributes - Nested: ILNestedExportedTypes; - CustomAttrs: ILAttributes } + Nested: ILNestedExportedTypes + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } member Access: ILTypeDefAccess member IsForwarder: bool + member CustomAttrs: ILAttributes [] [] type ILExportedTypesAndForwarders = - member AsList : ILExportedTypeOrForwarder list + member AsList: ILExportedTypeOrForwarder list [] type ILResourceAccess = @@ -1395,8 +1348,16 @@ type ILResourceAccess = [] type ILResourceLocation = - | Local of (unit -> byte[]) (* resources may be re-read each time this function is called *) + /// Represents a manifest resource that can be read from within the PE file + | LocalIn of string * int * int + + /// Represents a manifest resource that is due to be written to the output PE file + | LocalOut of byte[] + + /// Represents a manifest resource in an associated file | File of ILModuleRef * int32 + + /// Represents a manifest resource in a different assembly | Assembly of ILAssemblyRef /// "Manifest ILResources" are chunks of resource data, being one of: @@ -1404,18 +1365,22 @@ type ILResourceLocation = /// - in an external file in this assembly (offset given in the ILResourceLocation field). /// - as a resources in another assembly of the same name. type ILResource = - { Name: string; - Location: ILResourceLocation; - Access: ILResourceAccess; - CustomAttrs: ILAttributes } - /// Read the bytes from a resource local to an assembly - member Bytes : byte[] + { Name: string + Location: ILResourceLocation + Access: ILResourceAccess + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } + + /// Read the bytes from a resource local to an assembly. Will fail for non-local resources. + member GetBytes : unit -> byte[] + + member CustomAttrs: ILAttributes /// Table of resources in a module. [] [] type ILResources = - member AsList : ILResource list + member AsList: ILResource list [] @@ -1428,64 +1393,78 @@ type ILAssemblyLongevity = /// The main module of an assembly is a module plus some manifest information. type ILAssemblyManifest = - { Name: string; + { Name: string /// This is the ID of the algorithm used for the hashes of auxiliary /// files in the assembly. These hashes are stored in the /// ILModuleRef.Hash fields of this assembly. These are not /// cryptographic hashes: they are simple file hashes. The algorithm /// is normally 0x00008004 indicating the SHA1 hash algorithm. - AuxModuleHashAlgorithm: int32; - SecurityDecls: ILPermissions; + AuxModuleHashAlgorithm: int32 + SecurityDeclsStored: ILSecurityDeclsStored /// This is the public key used to sign this /// assembly (the signature itself is stored elsewhere: see the /// binary format, and may not have been written if delay signing /// is used). (member Name, member PublicKey) forms the full /// public name of the assembly. - PublicKey: byte[] option; - Version: ILVersionInfo option; - Locale: string option; - CustomAttrs: ILAttributes; - AssemblyLongevity: ILAssemblyLongevity; - DisableJitOptimizations: bool; - JitTracking: bool; - IgnoreSymbolStoreSequencePoints: bool; - Retargetable: bool; + PublicKey: byte[] option + Version: ILVersionInfo option + Locale: string option + CustomAttrsStored: ILAttributesStored + AssemblyLongevity: ILAssemblyLongevity + DisableJitOptimizations: bool + JitTracking: bool + IgnoreSymbolStoreSequencePoints: bool + Retargetable: bool /// Records the types implemented by this assembly in auxiliary /// modules. - ExportedTypes: ILExportedTypesAndForwarders; + ExportedTypes: ILExportedTypesAndForwarders /// Records whether the entrypoint resides in another module. - EntrypointElsewhere: ILModuleRef option; + EntrypointElsewhere: ILModuleRef option + MetadataIndex: int32 } + member CustomAttrs: ILAttributes + member SecurityDecls: ILSecurityDecls + +[] +type ILNativeResource = + /// Represents a native resource to be read from the PE file + | In of fileName: string * linkedResourceBase: int * linkedResourceStart: int * linkedResourceLength: int + + /// Represents a native resource to be written in an output file + | Out of unlinkedResource: byte[] + /// One module in the "current" assembly, either a main-module or /// an auxiliary module. The main module will have a manifest. /// /// An assembly is built by joining together a "main" module plus /// several auxiliary modules. type ILModuleDef = - { Manifest: ILAssemblyManifest option; - CustomAttrs: ILAttributes; - Name: string; - TypeDefs: ILTypeDefs; - SubsystemVersion : int * int - UseHighEntropyVA : bool - SubSystemFlags: int32; - IsDLL: bool; - IsILOnly: bool; - Platform: ILPlatform option; - StackReserveSize: int32 option; - Is32Bit: bool; - Is32BitPreferred: bool; - Is64Bit: bool; - VirtualAlignment: int32; - PhysicalAlignment: int32; - ImageBase: int32; - MetadataVersion: string; - Resources: ILResources; - /// e.g. win86 resources, as the exact contents of a .res or .obj file. - NativeResources: Lazy list; } + { Manifest: ILAssemblyManifest option + Name: string + TypeDefs: ILTypeDefs + SubsystemVersion: int * int + UseHighEntropyVA: bool + SubSystemFlags: int32 + IsDLL: bool + IsILOnly: bool + Platform: ILPlatform option + StackReserveSize: int32 option + Is32Bit: bool + Is32BitPreferred: bool + Is64Bit: bool + VirtualAlignment: int32 + PhysicalAlignment: int32 + ImageBase: int32 + MetadataVersion: string + Resources: ILResources + /// e.g. win86 resources, as the exact contents of a .res or .obj file. Must be unlinked manually. + NativeResources: ILNativeResource list + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } member ManifestOfAssembly: ILAssemblyManifest - member HasManifest : bool + member HasManifest: bool + member CustomAttrs: ILAttributes /// Find the method definition corresponding to the given property or /// event operation. These are always in the same class as the property @@ -1522,8 +1501,8 @@ val splitILTypeNameWithPossibleStaticArguments: string -> string[] * string /// namespace is kept as a whole string, rather than split at dots. val splitTypeNameRight: string -> string option * string - val typeNameForGlobalFunctions: string + val isTypeNameForGlobalFunctions: string -> bool val ungenericizeTypeName: string -> string (* e.g. List`1 --> List *) @@ -1542,8 +1521,8 @@ val ungenericizeTypeName: string -> string (* e.g. List`1 --> List *) /// reference items from it via an ILGlobals for that specific version built using mkILGlobals. [] type ILGlobals = - member primaryAssemblyScopeRef : ILScopeRef - member primaryAssemblyName : string + member primaryAssemblyScopeRef: ILScopeRef + member primaryAssemblyName: string member typ_Object: ILType member typ_String: ILType member typ_Type: ILType @@ -1567,7 +1546,7 @@ type ILGlobals = /// Build the table of commonly used references given functions to find types in system assemblies val mkILGlobals: ILScopeRef -> ILGlobals -val EcmaMscorlibILGlobals : ILGlobals +val EcmaMscorlibILGlobals: ILGlobals /// When writing a binary the fake "toplevel" type definition (called ) /// must come first. This function puts it first, and creates it in the returned @@ -1585,6 +1564,7 @@ val decodeILAttribData: /// Generate simple references to assemblies and modules. val mkSimpleAssRef: string -> ILAssemblyRef + val mkSimpleModRef: string -> ILModuleRef val mkILTyvarTy: uint16 -> ILType @@ -1611,7 +1591,7 @@ val mkILArrTy: ILType * ILArrayShape -> ILType val mkILArr1DTy: ILType -> ILType val isILArrTy: ILType -> bool val destILArrTy: ILType -> ILArrayShape * ILType -val mkILBoxedType : ILTypeSpec -> ILType +val mkILBoxedType: ILTypeSpec -> ILType /// Make method references and specs. val mkILMethRef: ILTypeRef * ILCallingConv * string * int * ILType list * ILType -> ILMethodRef @@ -1644,14 +1624,14 @@ val mkILFieldSpecInTy: ILType * string * ILType -> ILFieldSpec val mkILCallSig: ILCallingConv * ILType list * ILType -> ILCallingSignature -/// Make generalized versions of possibly-generic types, -/// e.g. Given the ILTypeDef for List, return the type "List". +/// Make generalized versions of possibly-generic types, e.g. Given the ILTypeDef for List, return the type "List". val mkILFormalBoxedTy: ILTypeRef -> ILGenericParameterDef list -> ILType val mkILFormalNamedTy: ILBoxity -> ILTypeRef -> ILGenericParameterDef list -> ILType val mkILFormalTypars: ILType list -> ILGenericParameterDefs val mkILFormalGenericArgs: int -> ILGenericParameterDefs -> ILGenericArgsList -val mkILSimpleTypar : string -> ILGenericParameterDef +val mkILSimpleTypar: string -> ILGenericParameterDef + /// Make custom attributes. val mkILCustomAttribMethRef: ILGlobals @@ -1667,11 +1647,11 @@ val mkILCustomAttribute: ILAttributeNamedArg list (* named args: values and flags indicating if they are fields or properties *) -> ILAttribute -val mkPermissionSet : ILGlobals -> ILSecurityAction * (ILTypeRef * (string * ILType * ILAttribElem) list) list -> ILPermission +val mkPermissionSet: ILGlobals -> ILSecurityAction * (ILTypeRef * (string * ILType * ILAttribElem) list) list -> ILSecurityDecl /// Making code. val generateCodeLabel: unit -> ILCodeLabel -val formatCodeLabel : ILCodeLabel -> string +val formatCodeLabel: ILCodeLabel -> string /// Make some code that is a straight line sequence of instructions. /// The function will add a "return" if the last instruction is not an exiting instruction. @@ -1679,16 +1659,16 @@ val nonBranchingInstrsToCode: ILInstr list -> ILCode /// Helpers for codegen: scopes for allocating new temporary variables. type ILLocalsAllocator = - new : preAlloc: int -> ILLocalsAllocator - member AllocLocal : ILLocal -> uint16 - member Close : unit -> ILLocal list + new: preAlloc: int -> ILLocalsAllocator + member AllocLocal: ILLocal -> uint16 + member Close: unit -> ILLocal list /// Derived functions for making some common patterns of instructions. val mkNormalCall: ILMethodSpec -> ILInstr val mkNormalCallvirt: ILMethodSpec -> ILInstr val mkNormalCallconstraint: ILType * ILMethodSpec -> ILInstr val mkNormalNewobj: ILMethodSpec -> ILInstr -val mkCallBaseConstructor : ILType * ILType list -> ILInstr list +val mkCallBaseConstructor: ILType * ILType list -> ILInstr list val mkNormalStfld: ILFieldSpec -> ILInstr val mkNormalStsfld: ILFieldSpec -> ILInstr val mkNormalLdsfld: ILFieldSpec -> ILInstr @@ -1718,6 +1698,9 @@ val mkILEmptyGenericParams: ILGenericParameterDefs /// Make method definitions. val mkILMethodBody: initlocals:bool * ILLocals * int * ILCode * ILSourceMarker option -> ILMethodBody val mkMethodBody: bool * ILLocals * int * ILCode * ILSourceMarker option -> MethodBody +val methBodyNotAvailable: ILLazyMethodBody +val methBodyAbstract: ILLazyMethodBody +val methBodyNative: ILLazyMethodBody val mkILCtor: ILMemberAccess * ILParameter list * MethodBody -> ILMethodDef val mkILClassCtor: MethodBody -> ILMethodDef @@ -1778,15 +1761,17 @@ val mkILTypeForGlobalFunctions: ILScopeRef -> ILType /// Making tables of custom attributes, etc. val mkILCustomAttrs: ILAttribute list -> ILAttributes val mkILCustomAttrsFromArray: ILAttribute[] -> ILAttributes -val mkILComputedCustomAttrs: (unit -> ILAttribute[]) -> ILAttributes +val storeILCustomAttrs: ILAttributes -> ILAttributesStored +val mkILCustomAttrsReader: (int32 -> ILAttribute[]) -> ILAttributesStored val emptyILCustomAttrs: ILAttributes -val mkILSecurityDecls: ILPermission list -> ILPermissions -val mkILLazySecurityDecls: Lazy -> ILPermissions -val emptyILSecurityDecls: ILPermissions +val mkILSecurityDecls: ILSecurityDecl list -> ILSecurityDecls +val emptyILSecurityDecls: ILSecurityDecls +val storeILSecurityDecls: ILSecurityDecls -> ILSecurityDeclsStored +val mkILSecurityDeclsReader: (int32 -> ILSecurityDecl[]) -> ILSecurityDeclsStored -val mkMethBodyAux : MethodBody -> ILLazyMethodBody -val mkMethBodyLazyAux : Lazy -> ILLazyMethodBody +val mkMethBodyAux: MethodBody -> ILLazyMethodBody +val mkMethBodyLazyAux: Lazy -> ILLazyMethodBody val mkILEvents: ILEventDef list -> ILEventDefs val mkILEventsLazy: Lazy -> ILEventDefs @@ -1821,7 +1806,7 @@ val emptyILTypeDefs: ILTypeDefs /// /// Note that individual type definitions may contain further delays /// in their method, field and other tables. -val mkILTypeDefsComputed: (unit -> (string list * string * ILAttributes * Lazy) array) -> ILTypeDefs +val mkILTypeDefsComputed: (unit -> ILPreTypeDef[]) -> ILTypeDefs val addILTypeDef: ILTypeDef -> ILTypeDefs -> ILTypeDefs val mkTypeForwarder: ILScopeRef -> string -> ILNestedExportedTypes -> ILAttributes -> ILTypeDefAccess -> ILExportedTypeOrForwarder @@ -1832,10 +1817,9 @@ val mkILExportedTypes: ILExportedTypeOrForwarder list -> ILExportedTypesAndForwa val mkILExportedTypesLazy: Lazy -> ILExportedTypesAndForwarders val mkILResources: ILResource list -> ILResources -val mkILResourcesLazy: Lazy -> ILResources /// Making modules. -val mkILSimpleModule: assemblyName:string -> moduleName:string -> dll:bool -> subsystemVersion : (int * int) -> useHighEntropyVA : bool -> ILTypeDefs -> int32 option -> string option -> int -> ILExportedTypesAndForwarders -> string -> ILModuleDef +val mkILSimpleModule: assemblyName:string -> moduleName:string -> dll:bool -> subsystemVersion: (int * int) -> useHighEntropyVA: bool -> ILTypeDefs -> int32 option -> string option -> int -> ILExportedTypesAndForwarders -> string -> ILModuleDef /// Generate references to existing type definitions, method definitions /// etc. Useful for generating references, e.g. to a class we're processing @@ -1844,9 +1828,9 @@ val mkILSimpleModule: assemblyName:string -> moduleName:string -> dll:bool -> su /// an auxiliary module or are generating multiple assemblies at /// once. -val mkRefForNestedILTypeDef : ILScopeRef -> ILTypeDef list * ILTypeDef -> ILTypeRef -val mkRefForILMethod : ILScopeRef -> ILTypeDef list * ILTypeDef -> ILMethodDef -> ILMethodRef -val mkRefForILField : ILScopeRef -> ILTypeDef list * ILTypeDef -> ILFieldDef -> ILFieldRef +val mkRefForNestedILTypeDef: ILScopeRef -> ILTypeDef list * ILTypeDef -> ILTypeRef +val mkRefForILMethod : ILScopeRef -> ILTypeDef list * ILTypeDef -> ILMethodDef -> ILMethodRef +val mkRefForILField : ILScopeRef -> ILTypeDef list * ILTypeDef -> ILFieldDef -> ILFieldRef val mkRefToILMethod: ILTypeRef * ILMethodDef -> ILMethodRef val mkRefToILField: ILTypeRef * ILFieldDef -> ILFieldRef @@ -1854,6 +1838,7 @@ val mkRefToILField: ILTypeRef * ILFieldDef -> ILFieldRef val mkRefToILAssembly: ILAssemblyManifest -> ILAssemblyRef val mkRefToILModule: ILModuleDef -> ILModuleRef +val NoMetadataIdx: int32 // -------------------------------------------------------------------- // Rescoping. @@ -1876,15 +1861,19 @@ val mkRefToILModule: ILModuleDef -> ILModuleRef /// Rescoping. The first argument tells the function how to reference the original scope from /// the new scope. val rescopeILScopeRef: ILScopeRef -> ILScopeRef -> ILScopeRef + /// Rescoping. The first argument tells the function how to reference the original scope from /// the new scope. val rescopeILTypeSpec: ILScopeRef -> ILTypeSpec -> ILTypeSpec + /// Rescoping. The first argument tells the function how to reference the original scope from /// the new scope. val rescopeILType: ILScopeRef -> ILType -> ILType + /// Rescoping. The first argument tells the function how to reference the original scope from /// the new scope. val rescopeILMethodRef: ILScopeRef -> ILMethodRef -> ILMethodRef + /// Rescoping. The first argument tells the function how to reference the original scope from /// the new scope. val rescopeILFieldRef: ILScopeRef -> ILFieldRef -> ILFieldRef @@ -1892,26 +1881,14 @@ val rescopeILFieldRef: ILScopeRef -> ILFieldRef -> ILFieldRef /// Unscoping. Clears every scope information, use for looking up IL method references only. val unscopeILType: ILType -> ILType -//----------------------------------------------------------------------- -// The ILCode Builder utility. -//---------------------------------------------------------------------- - val buildILCode: string -> lab2pc: Dictionary -> instrs:ILInstr[] -> ILExceptionSpec list -> ILLocalDebugInfo list -> ILCode -// -------------------------------------------------------------------- -// The instantiation utilities. -// -------------------------------------------------------------------- - /// Instantiate type variables that occur within types and other items. val instILTypeAux: int -> ILGenericArgs -> ILType -> ILType /// Instantiate type variables that occur within types and other items. val instILType: ILGenericArgs -> ILType -> ILType -// -------------------------------------------------------------------- -// ECMA globals -// -------------------------------------------------------------------- - /// This is a 'vendor neutral' way of referencing mscorlib. val ecmaPublicKey: PublicKey @@ -1935,7 +1912,7 @@ val isILDoubleTy: ILType -> bool val isILSingleTy: ILType -> bool /// Get a public key token from a public key. -val sha1HashBytes : byte[] -> byte[] (* SHA1 hash *) +val sha1HashBytes: byte[] -> byte[] (* SHA1 hash *) /// Get a version number from a CLR version string, e.g. 1.0.3705.0 val parseILVersion: string -> ILVersionInfo @@ -1944,29 +1921,24 @@ val compareILVersions: ILVersionInfo -> ILVersionInfo -> int /// Decompose a type definition according to its kind. type ILEnumInfo = - { enumValues: (string * ILFieldInit) list; + { enumValues: (string * ILFieldInit) list enumType: ILType } val getTyOfILEnumInfo: ILEnumInfo -> ILType val computeILEnumInfo: string * ILFieldDefs -> ILEnumInfo - -// -------------------------------------------------------------------- -// For completeness. These do not occur in metadata but tools that -// care about the existence of properties and events in the metadata -// can benefit from them. -// -------------------------------------------------------------------- - +/// A utility type provided for completeness [] type ILEventRef = - static member Create : ILTypeRef * string -> ILEventRef + static member Create: ILTypeRef * string -> ILEventRef member DeclaringTypeRef: ILTypeRef member Name: string +/// A utility type provided for completeness [] type ILPropertyRef = - static member Create : ILTypeRef * string -> ILPropertyRef + static member Create: ILTypeRef * string -> ILPropertyRef member DeclaringTypeRef: ILTypeRef member Name: string interface System.IComparable @@ -1974,8 +1946,8 @@ type ILPropertyRef = val runningOnMono: bool type ILReferences = - { AssemblyReferences: ILAssemblyRef list; - ModuleReferences: ILModuleRef list; } + { AssemblyReferences: ILAssemblyRef list + ModuleReferences: ILModuleRef list } /// Find the full set of assemblies referenced by a module. val computeILRefs: ILModuleDef -> ILReferences diff --git a/src/absil/illib.fs b/src/absil/illib.fs index a19497e8c5..01aa270788 100755 --- a/src/absil/illib.fs +++ b/src/absil/illib.fs @@ -7,7 +7,11 @@ module public Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open System open System.Collections open System.Collections.Generic +open System.Diagnostics +open System.IO open System.Reflection +open System.Text +open System.Threading open Internal.Utilities #if FX_RESHAPED_REFLECTION @@ -37,17 +41,17 @@ let inline isSingleton l = let inline isNonNull x = not (isNull x) let inline nonNull msg x = if isNull x then failwith ("null: " ^ msg) else x -let (===) x y = LanguagePrimitives.PhysicalEquality x y +let inline (===) x y = LanguagePrimitives.PhysicalEquality x y //--------------------------------------------------------------------- // Library: ReportTime //--------------------------------------------------------------------- let reportTime = - let tFirst = ref None - let tPrev = ref None + let tFirst = ref None + let tPrev = ref None fun showTimes descr -> if showTimes then - let t = System.Diagnostics.Process.GetCurrentProcess().UserProcessorTime.TotalSeconds + let t = Process.GetCurrentProcess().UserProcessorTime.TotalSeconds let prev = match !tPrev with None -> 0.0 | Some t -> t let first = match !tFirst with None -> (tFirst := Some t; t) | Some t -> t printf "ilwrite: TIME %10.3f (total) %10.3f (delta) - %s\n" (t - first) (t - prev) descr @@ -60,14 +64,14 @@ let reportTime = [] /// An efficient lazy for inline storage in a class type. Results in fewer thunks. type InlineDelayInit<'T when 'T : not struct> = - new (f: unit -> 'T) = {store = Unchecked.defaultof<'T>; func = System.Func<_>(f) } + new (f: unit -> 'T) = {store = Unchecked.defaultof<'T>; func = Func<_>(f) } val mutable store : 'T - val mutable func : System.Func<'T> + val mutable func : Func<'T> member x.Value = match x.func with | null -> x.store | _ -> - let res = System.Threading.LazyInitializer.EnsureInitialized(&x.store, x.func) + let res = LazyInitializer.EnsureInitialized(&x.store, x.func) x.func <- Unchecked.defaultof<_> res @@ -237,36 +241,12 @@ module Option = let mapFold f s opt = match opt with | None -> None,s - | Some x -> let x',s' = f s x in Some x',s' - - let otherwise opt dflt = - match opt with - | None -> dflt - | Some x -> x - - let fold f z x = - match x with - | None -> z - | Some x -> f z x - - let attempt (f: unit -> 'T) = try Some (f()) with _ -> None - - - let orElseWith f opt = - match opt with - | None -> f() - | x -> x - - let orElse v opt = - match opt with - | None -> v - | x -> x - - let defaultValue v opt = - match opt with - | None -> v - | Some x -> x + | Some x -> + let x',s' = f s x + Some x',s' + let attempt (f: unit -> 'T) = try Some (f()) with _ -> None + module List = //let item n xs = List.nth xs n @@ -358,7 +338,7 @@ module List = let rec loop acc l = match l with | [] -> - System.Diagnostics.Debug.Assert(false, "empty list") + Debug.Assert(false, "empty list") invalidArg "l" "empty list" | [h] -> List.rev acc,h | h::t -> loop (h::acc) t @@ -377,7 +357,7 @@ module List = let headAndTail l = match l with | [] -> - System.Diagnostics.Debug.Assert(false, "empty list") + Debug.Assert(false, "empty list") failwith "List.headAndTail" | h::t -> h,t @@ -419,7 +399,7 @@ module List = let range n m = [ n .. m ] - let indexNotFound() = raise (new System.Collections.Generic.KeyNotFoundException("An index satisfying the predicate was not found in the collection")) + let indexNotFound() = raise (new KeyNotFoundException("An index satisfying the predicate was not found in the collection")) let rec assoc x l = match l with @@ -442,9 +422,6 @@ module List = | x::xs -> if i=n then f x::xs else x::mn (i+1) xs mn 0 xs - - let rec until p l = match l with [] -> [] | h::t -> if p h then [] else h :: until p t - let count pred xs = List.fold (fun n x -> if pred x then n+1 else n) 0 xs // WARNING: not tail-recursive @@ -483,9 +460,9 @@ module ValueOption = let inline bind f x = match x with VSome x -> f x | VNone -> VNone module String = - let indexNotFound() = raise (new System.Collections.Generic.KeyNotFoundException("An index for the character was not found in the string")) + let indexNotFound() = raise (new KeyNotFoundException("An index for the character was not found in the string")) - let make (n: int) (c: char) : string = new System.String(c, n) + let make (n: int) (c: char) : string = new String(c, n) let get (str:string) i = str.[i] @@ -511,7 +488,7 @@ module String = s.ToUpperInvariant() let isUpper (s:string) = - s.Length >= 1 && System.Char.IsUpper s.[0] && not (System.Char.IsLower s.[0]) + s.Length >= 1 && Char.IsUpper s.[0] && not (Char.IsLower s.[0]) let capitalize (s:string) = if s.Length = 0 then s @@ -521,26 +498,9 @@ module String = if s.Length = 0 then s else lowercase s.[0..0] + s.[ 1.. s.Length - 1 ] + let dropPrefix (s:string) (t:string) = s.[t.Length..s.Length - 1] - let tryDropPrefix (s:string) (t:string) = - if s.StartsWith t then - Some s.[t.Length..s.Length - 1] - else - None - - let tryDropSuffix (s:string) (t:string) = - if s.EndsWith t then - Some s.[0..s.Length - t.Length - 1] - else - None - - let hasPrefix s t = Option.isSome (tryDropPrefix s t) - let dropPrefix s t = match (tryDropPrefix s t) with Some(res) -> res | None -> failwith "dropPrefix" - - let dropSuffix s t = match (tryDropSuffix s t) with Some(res) -> res | None -> failwith "dropSuffix" - - open System - open System.IO + let dropSuffix (s:string) (t:string) = s.[0..s.Length - t.Length - 1] let inline toCharArray (str: string) = str.ToCharArray() @@ -603,7 +563,7 @@ module String = |] module Dictionary = - let inline newWithSize (size: int) = System.Collections.Generic.Dictionary<_,_>(size, HashIdentity.Structural) + let inline newWithSize (size: int) = Dictionary<_,_>(size, HashIdentity.Structural) module Lazy = @@ -660,7 +620,7 @@ module Map = type ResultOrException<'TResult> = | Result of 'TResult - | Exception of System.Exception + | Exception of Exception [] module ResultOrException = @@ -694,13 +654,13 @@ type ValueOrCancelled<'TResult> = /// /// A cancellable computation is passed may be cancelled via a CancellationToken, which is propagated implicitly. /// If cancellation occurs, it is propagated as data rather than by raising an OperationCanceledException. -type Cancellable<'TResult> = Cancellable of (System.Threading.CancellationToken -> ValueOrCancelled<'TResult>) +type Cancellable<'TResult> = Cancellable of (CancellationToken -> ValueOrCancelled<'TResult>) [] module Cancellable = /// Run a cancellable computation using the given cancellation token - let run (ct: System.Threading.CancellationToken) (Cancellable oper) = + let run (ct: CancellationToken) (Cancellable oper) = if ct.IsCancellationRequested then ValueOrCancelled.Cancelled (OperationCanceledException ct) else @@ -753,7 +713,7 @@ module Cancellable = /// Run the computation in a mode where it may not be cancelled. The computation never results in a /// ValueOrCancelled.Cancelled. let runWithoutCancellation comp = - let res = run System.Threading.CancellationToken.None comp + let res = run CancellationToken.None comp match res with | ValueOrCancelled.Cancelled _ -> failwith "unexpected cancellation" | ValueOrCancelled.Value r -> r @@ -807,7 +767,7 @@ type CancellableBuilder() = member x.ReturnFrom(v) = v member x.Combine(e1,e2) = e1 |> Cancellable.bind (fun () -> e2) member x.TryWith(e,handler) = Cancellable.tryWith e handler - member x.Using(resource,e) = Cancellable.tryFinally (e resource) (fun () -> (resource :> System.IDisposable).Dispose()) + member x.Using(resource,e) = Cancellable.tryFinally (e resource) (fun () -> (resource :> IDisposable).Dispose()) member x.TryFinally(e,compensation) = Cancellable.tryFinally e compensation member x.Delay(f) = Cancellable.delay f member x.Zero() = Cancellable.ret () @@ -832,7 +792,6 @@ type Eventually<'T> = [] module Eventually = - open System.Threading let rec box e = match e with @@ -855,7 +814,7 @@ module Eventually = /// /// If cancellation happens, the operation is left half-complete, ready to resume. let repeatedlyProgressUntilDoneOrTimeShareOverOrCanceled timeShareInMilliseconds (ct: CancellationToken) runner e = - let sw = new System.Diagnostics.Stopwatch() + let sw = new Stopwatch() let rec runTimeShare ctok e = runner ctok (fun ctok -> sw.Reset() @@ -966,7 +925,7 @@ type UniqueStampGenerator<'T when 'T : equality>() = type MemoizationTable<'T,'U>(compute: 'T -> 'U, keyComparer: IEqualityComparer<'T>, ?canMemoize) = - let table = new System.Collections.Generic.Dictionary<'T,'U>(keyComparer) + let table = new Dictionary<'T,'U>(keyComparer) member t.Apply(x) = if (match canMemoize with None -> true | Some f -> f x) then let mutable res = Unchecked.defaultof<'U> @@ -1018,11 +977,11 @@ type LazyWithContext<'T,'ctxt> = | null -> x.value | _ -> // Enter the lock in case another thread is in the process of evaluating the result - System.Threading.Monitor.Enter(x); + Monitor.Enter(x); try x.UnsynchronizedForce(ctxt) finally - System.Threading.Monitor.Exit(x) + Monitor.Exit(x) member x.UnsynchronizedForce(ctxt) = match x.funcOrException with @@ -1222,56 +1181,85 @@ type LayeredMultiMap<'Key,'Value when 'Key : equality and 'Key : comparison>(con [] module Shim = - open System.IO - #if FX_RESHAPED_REFLECTION open PrimReflectionAdapters open Microsoft.FSharp.Core.ReflectionAdapters #endif type IFileSystem = + + /// A shim over File.ReadAllBytes abstract ReadAllBytesShim: fileName:string -> byte[] - abstract FileStreamReadShim: fileName:string -> System.IO.Stream - abstract FileStreamCreateShim: fileName:string -> System.IO.Stream - abstract FileStreamWriteExistingShim: fileName:string -> System.IO.Stream + + /// A shim over FileStream with FileMode.Open,FileAccess.Read,FileShare.ReadWrite + abstract FileStreamReadShim: fileName:string -> Stream + + /// A shim over FileStream with FileMode.Create,FileAccess.Write,FileShare.Read + abstract FileStreamCreateShim: fileName:string -> Stream + + /// A shim over FileStream with FileMode.Open,FileAccess.Write,FileShare.Read + abstract FileStreamWriteExistingShim: fileName:string -> Stream /// Take in a filename with an absolute path, and return the same filename /// but canonicalized with respect to extra path separators (e.g. C:\\\\foo.txt) /// and '..' portions abstract GetFullPathShim: fileName:string -> string + + /// A shim over Path.IsPathRooted abstract IsPathRootedShim: path:string -> bool + + /// A shim over Path.IsInvalidPath abstract IsInvalidPathShim: filename:string -> bool + + /// A shim over Path.GetTempPath abstract GetTempPathShim : unit -> string /// Utc time of the last modification - abstract GetLastWriteTimeShim: fileName:string -> System.DateTime - abstract SafeExists: fileName:string -> bool - abstract FileDelete: fileName:string -> unit - abstract AssemblyLoadFrom: fileName:string -> System.Reflection.Assembly - abstract AssemblyLoad: assemblyName:System.Reflection.AssemblyName -> System.Reflection.Assembly + abstract GetLastWriteTimeShim: fileName: string -> DateTime + + /// A shim over File.Exists + abstract SafeExists: fileName: string -> bool + + /// A shim over File.Delete + abstract FileDelete: fileName: string -> unit + + /// Used to load type providers and located assemblies in F# Interactive + abstract AssemblyLoadFrom: fileName: string -> Assembly + + /// Used to load a dependency for F# Interactive and in an unused corner-case of type provider loading + abstract AssemblyLoad: assemblyName: AssemblyName -> Assembly + + /// Used to determine if a file will not be subject to deletion during the lifetime of a typical client process. + abstract IsStableFileHeuristic: fileName: string -> bool type DefaultFileSystem() = interface IFileSystem with - member __.AssemblyLoadFrom(fileName:string) = + + member __.AssemblyLoadFrom(fileName: string) = Assembly.LoadFrom fileName - member __.AssemblyLoad(assemblyName:System.Reflection.AssemblyName) = + + member __.AssemblyLoad(assemblyName: AssemblyName) = Assembly.Load assemblyName - member __.ReadAllBytesShim (fileName:string) = File.ReadAllBytes fileName - member __.FileStreamReadShim (fileName:string) = new FileStream(fileName,FileMode.Open,FileAccess.Read,FileShare.ReadWrite) :> Stream - member __.FileStreamCreateShim (fileName:string) = new FileStream(fileName,FileMode.Create,FileAccess.Write,FileShare.Read ,0x1000,false) :> Stream - member __.FileStreamWriteExistingShim (fileName:string) = new FileStream(fileName,FileMode.Open,FileAccess.Write,FileShare.Read ,0x1000,false) :> Stream - member __.GetFullPathShim (fileName:string) = System.IO.Path.GetFullPath fileName + member __.ReadAllBytesShim (fileName: string) = File.ReadAllBytes fileName + + member __.FileStreamReadShim (fileName: string) = new FileStream(fileName,FileMode.Open,FileAccess.Read,FileShare.ReadWrite) :> Stream + + member __.FileStreamCreateShim (fileName: string) = new FileStream(fileName,FileMode.Create,FileAccess.Write,FileShare.Read ,0x1000,false) :> Stream + + member __.FileStreamWriteExistingShim (fileName: string) = new FileStream(fileName,FileMode.Open,FileAccess.Write,FileShare.Read ,0x1000,false) :> Stream - member __.IsPathRootedShim (path:string) = Path.IsPathRooted path + member __.GetFullPathShim (fileName: string) = System.IO.Path.GetFullPath fileName - member __.IsInvalidPathShim(path:string) = + member __.IsPathRootedShim (path: string) = Path.IsPathRooted path + + member __.IsInvalidPathShim(path: string) = let isInvalidPath(p:string) = - String.IsNullOrEmpty(p) || p.IndexOfAny(System.IO.Path.GetInvalidPathChars()) <> -1 + String.IsNullOrEmpty(p) || p.IndexOfAny(Path.GetInvalidPathChars()) <> -1 let isInvalidFilename(p:string) = - String.IsNullOrEmpty(p) || p.IndexOfAny(System.IO.Path.GetInvalidFileNameChars()) <> -1 + String.IsNullOrEmpty(p) || p.IndexOfAny(Path.GetInvalidFileNameChars()) <> -1 let isInvalidDirectory(d:string) = d=null || d.IndexOfAny(Path.GetInvalidPathChars()) <> -1 @@ -1281,14 +1269,31 @@ module Shim = let filename = Path.GetFileName(path) isInvalidDirectory(directory) || isInvalidFilename(filename) - member __.GetTempPathShim() = System.IO.Path.GetTempPath() + member __.GetTempPathShim() = Path.GetTempPath() member __.GetLastWriteTimeShim (fileName:string) = File.GetLastWriteTimeUtc fileName - member __.SafeExists (fileName:string) = System.IO.File.Exists fileName - member __.FileDelete (fileName:string) = System.IO.File.Delete fileName - type System.Text.Encoding with - static member GetEncodingShim(n:int) = - System.Text.Encoding.GetEncoding(n) + member __.SafeExists (fileName:string) = File.Exists fileName + + member __.FileDelete (fileName:string) = File.Delete fileName + + member __.IsStableFileHeuristic (fileName: string) = + let directory = Path.GetDirectoryName(fileName) + directory.Contains("Reference Assemblies/") || + directory.Contains("Reference Assemblies\\") || + directory.Contains("packages/") || + directory.Contains("packages\\") || + directory.Contains("lib/mono/") let mutable FileSystem = DefaultFileSystem() :> IFileSystem + + type File with + static member ReadBinaryChunk (fileName, start, len) = + use stream = FileSystem.FileStreamReadShim fileName + stream.Seek(int64 start, SeekOrigin.Begin) |> ignore + let buffer = Array.zeroCreate len + let mutable n = 0 + while n < len do + n <- n + stream.Read(buffer, n, len-n) + buffer + diff --git a/src/absil/ilmorph.fs b/src/absil/ilmorph.fs index 90b0e267f6..ad28e1736a 100755 --- a/src/absil/ilmorph.fs +++ b/src/absil/ilmorph.fs @@ -155,8 +155,8 @@ let cattrs_typ2typ ilg f (cs: ILAttributes) = mkILCustomAttrs (List.map (cattr_typ2typ ilg f) cs.AsList) let fdef_typ2typ ilg ftype (fd: ILFieldDef) = - {fd with Type=ftype fd.Type; - CustomAttrs=cattrs_typ2typ ilg ftype fd.CustomAttrs} + fd.With(fieldType=ftype fd.FieldType, + customAttrs=cattrs_typ2typ ilg ftype fd.CustomAttrs) let local_typ2typ f (l: ILLocal) = {l with Type = f l.Type} let varargs_typ2typ f (varargs: ILVarArgs) = Option.map (List.map f) varargs @@ -200,8 +200,8 @@ let morphILTypesInILInstr ((factualty,fformalty)) i = | ILToken.ILField fr -> I_ldtoken (ILToken.ILField (conv_fspec fr)) | x -> x -let return_typ2typ ilg f (r:ILReturn) = {r with Type=f r.Type; CustomAttrs=cattrs_typ2typ ilg f r.CustomAttrs} -let param_typ2typ ilg f (p: ILParameter) = {p with Type=f p.Type; CustomAttrs=cattrs_typ2typ ilg f p.CustomAttrs} +let return_typ2typ ilg f (r:ILReturn) = {r with Type=f r.Type; CustomAttrsStored= storeILCustomAttrs (cattrs_typ2typ ilg f r.CustomAttrs)} +let param_typ2typ ilg f (p: ILParameter) = {p with Type=f p.Type; CustomAttrsStored= storeILCustomAttrs (cattrs_typ2typ ilg f p.CustomAttrs)} let morphILMethodDefs f (m:ILMethodDefs) = mkILMethods (List.map f m.AsList) let fdefs_fdef2fdef f (m:ILFieldDefs) = mkILFields (List.map f m.AsList) @@ -225,16 +225,15 @@ let morphILMethodBody (filmbody) (x: ILLazyMethodBody) = let ospec_typ2typ f (OverridesSpec(mref,ty)) = OverridesSpec(mref_typ2typ f mref, f ty) -let mdef_typ2typ_ilmbody2ilmbody ilg fs md = +let mdef_typ2typ_ilmbody2ilmbody ilg fs (md: ILMethodDef) = let (ftype,filmbody) = fs let ftype' = ftype (Some md) - let body' = morphILMethodBody (filmbody (Some md)) md.mdBody - {md with - GenericParams=gparams_typ2typ ftype' md.GenericParams; - mdBody= body'; - Parameters = List.map (param_typ2typ ilg ftype') md.Parameters; - Return = return_typ2typ ilg ftype' md.Return; - CustomAttrs=cattrs_typ2typ ilg ftype' md.CustomAttrs } + let body' = morphILMethodBody (filmbody (Some md)) md.Body + md.With(genericParams=gparams_typ2typ ftype' md.GenericParams, + body= body', + parameters = List.map (param_typ2typ ilg ftype') md.Parameters, + ret = return_typ2typ ilg ftype' md.Return, + customAttrs=cattrs_typ2typ ilg ftype' md.CustomAttrs) let fdefs_typ2typ ilg f x = fdefs_fdef2fdef (fdef_typ2typ ilg f) x @@ -244,44 +243,41 @@ let mimpl_typ2typ f e = { Overrides = ospec_typ2typ f e.Overrides; OverrideBy = mspec_typ2typ (f,(fun _ -> f)) e.OverrideBy; } -let edef_typ2typ ilg f e = - { e with - Type = Option.map f e.Type; - AddMethod = mref_typ2typ f e.AddMethod; - RemoveMethod = mref_typ2typ f e.RemoveMethod; - FireMethod = Option.map (mref_typ2typ f) e.FireMethod; - OtherMethods = List.map (mref_typ2typ f) e.OtherMethods; - CustomAttrs = cattrs_typ2typ ilg f e.CustomAttrs } - -let pdef_typ2typ ilg f p = - { p with - SetMethod = Option.map (mref_typ2typ f) p.SetMethod; - GetMethod = Option.map (mref_typ2typ f) p.GetMethod; - Type = f p.Type; - Args = List.map f p.Args; - CustomAttrs = cattrs_typ2typ ilg f p.CustomAttrs } +let edef_typ2typ ilg f (e: ILEventDef) = + e.With(eventType = Option.map f e.EventType, + addMethod = mref_typ2typ f e.AddMethod, + removeMethod = mref_typ2typ f e.RemoveMethod, + fireMethod = Option.map (mref_typ2typ f) e.FireMethod, + otherMethods = List.map (mref_typ2typ f) e.OtherMethods, + customAttrs = cattrs_typ2typ ilg f e.CustomAttrs) + +let pdef_typ2typ ilg f (p: ILPropertyDef) = + p.With(setMethod = Option.map (mref_typ2typ f) p.SetMethod, + getMethod = Option.map (mref_typ2typ f) p.GetMethod, + propertyType = f p.PropertyType, + args = List.map f p.Args, + customAttrs = cattrs_typ2typ ilg f p.CustomAttrs) let pdefs_typ2typ ilg f (pdefs: ILPropertyDefs) = mkILProperties (List.map (pdef_typ2typ ilg f) pdefs.AsList) let edefs_typ2typ ilg f (edefs: ILEventDefs) = mkILEvents (List.map (edef_typ2typ ilg f) edefs.AsList) let mimpls_typ2typ f (mimpls : ILMethodImplDefs) = mkILMethodImpls (List.map (mimpl_typ2typ f) mimpls.AsList) -let rec tdef_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg enc fs td = +let rec tdef_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg enc fs (td: ILTypeDef) = let (ftype,fmdefs) = fs let ftype' = ftype (Some (enc,td)) None let mdefs' = fmdefs (enc,td) td.Methods let fdefs' = fdefs_typ2typ ilg ftype' td.Fields - {td with Implements= List.map ftype' td.Implements; - GenericParams= gparams_typ2typ ftype' td.GenericParams; - Extends = Option.map ftype' td.Extends; - Methods=mdefs'; - NestedTypes=tdefs_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg (enc@[td]) fs td.NestedTypes; - Fields=fdefs'; - MethodImpls = mimpls_typ2typ ftype' td.MethodImpls; - Events = edefs_typ2typ ilg ftype' td.Events; - Properties = pdefs_typ2typ ilg ftype' td.Properties; - CustomAttrs = cattrs_typ2typ ilg ftype' td.CustomAttrs; - } + td.With(implements= List.map ftype' td.Implements, + genericParams= gparams_typ2typ ftype' td.GenericParams, + extends = Option.map ftype' td.Extends, + methods=mdefs', + nestedTypes=tdefs_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg (enc@[td]) fs td.NestedTypes, + fields=fdefs', + methodImpls = mimpls_typ2typ ftype' td.MethodImpls, + events = edefs_typ2typ ilg ftype' td.Events, + properties = pdefs_typ2typ ilg ftype' td.Properties, + customAttrs = cattrs_typ2typ ilg ftype' td.CustomAttrs) and tdefs_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg enc fs tdefs = morphILTypeDefs (tdef_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg enc fs) tdefs @@ -291,14 +287,14 @@ and tdefs_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg enc fs tdefs = // -------------------------------------------------------------------- let manifest_typ2typ ilg f (m : ILAssemblyManifest) = - { m with CustomAttrs = cattrs_typ2typ ilg f m.CustomAttrs } + { m with CustomAttrsStored = storeILCustomAttrs (cattrs_typ2typ ilg f m.CustomAttrs) } let morphILTypeInILModule_ilmbody2ilmbody_mdefs2mdefs ilg ((ftype: ILModuleDef -> (ILTypeDef list * ILTypeDef) option -> ILMethodDef option -> ILType -> ILType),fmdefs) m = let ftdefs = tdefs_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg [] (ftype m,fmdefs m) { m with TypeDefs=ftdefs m.TypeDefs; - CustomAttrs=cattrs_typ2typ ilg (ftype m None None) m.CustomAttrs; + CustomAttrsStored= storeILCustomAttrs (cattrs_typ2typ ilg (ftype m None None) m.CustomAttrs); Manifest=Option.map (manifest_typ2typ ilg (ftype m None None)) m.Manifest } let module_instr2instr_typ2typ ilg fs x = diff --git a/src/absil/ilprint.fs b/src/absil/ilprint.fs index 0344a4fbb5..723c747007 100755 --- a/src/absil/ilprint.fs +++ b/src/absil/ilprint.fs @@ -213,11 +213,10 @@ and goutput_typ_with_shortened_class_syntax env os = function | typ2 -> goutput_typ env os typ2 and goutput_gactuals env os inst = - if inst.Length = 0 then () - else - output_string os "<"; + if not (List.isEmpty inst) then + output_string os "<" output_seq ", " (goutput_gactual env) os inst - output_string os ">"; + output_string os ">" and goutput_gactual env os ty = goutput_typ env os ty @@ -271,14 +270,14 @@ and goutput_permission _env os p = match p with - | PermissionSet (sa,b) -> + | ILSecurityDecl (sa,b) -> output_string os " .permissionset " output_security_action os sa output_string os " = (" output_bytes os b output_string os ")" -and goutput_security_decls env os (ps: ILPermissions) = output_seq " " (goutput_permission env) os ps.AsList +and goutput_security_decls env os (ps: ILSecurityDecls) = output_seq " " (goutput_permission env) os ps.AsList and goutput_gparam env os (gf: ILGenericParameterDef) = output_string os (tyvar_generator gf.Name); @@ -470,30 +469,30 @@ let output_custom_attr_data os data = output_string os " = "; output_parens output_bytes os data let goutput_custom_attr env os attr = - output_string os " .custom "; - goutput_mspec env os attr.Method; + output_string os " .custom " + goutput_mspec env os attr.Method output_custom_attr_data os attr.Data let goutput_custom_attrs env os (attrs : ILAttributes) = List.iter (fun attr -> goutput_custom_attr env os attr; output_string os "\n" ) attrs.AsList -let goutput_fdef _tref env os fd = - output_string os " .field "; +let goutput_fdef _tref env os (fd: ILFieldDef) = + output_string os " .field " match fd.Offset with Some i -> output_string os "["; output_i32 os i; output_string os "] " | None -> () match fd.Marshal with Some _i -> output_string os "// marshal attribute not printed\n"; | None -> () - output_member_access os fd.Access; - output_string os " "; - if fd.IsStatic then output_string os " static "; - if fd.IsLiteral then output_string os " literal "; - if fd.IsSpecialName then output_string os " specialname rtspecialname "; - if fd.IsInitOnly then output_string os " initonly "; - if fd.NotSerialized then output_string os " notserialized "; - goutput_typ env os fd.Type; - output_string os " "; - output_id os fd.Name; - output_option output_at os fd.Data; - output_option output_field_init os fd.LiteralValue; - output_string os "\n"; + output_member_access os fd.Access + output_string os " " + if fd.IsStatic then output_string os " static " + if fd.IsLiteral then output_string os " literal " + if fd.IsSpecialName then output_string os " specialname rtspecialname " + if fd.IsInitOnly then output_string os " initonly " + if fd.NotSerialized then output_string os " notserialized " + goutput_typ env os fd.FieldType + output_string os " " + output_id os fd.Name + output_option output_at os fd.Data + output_option output_field_init os fd.LiteralValue + output_string os "\n" goutput_custom_attrs env os fd.CustomAttrs @@ -769,7 +768,7 @@ let goutput_ilmbody env os (il: ILMethodBody) = output_string os ")\n" -let goutput_mbody is_entrypoint env os md = +let goutput_mbody is_entrypoint env os (md: ILMethodDef) = if md.ImplAttributes &&& MethodImplAttributes.Native <> enum 0 then output_string os "native " elif md.ImplAttributes &&& MethodImplAttributes.IL <> enum 0 then output_string os "cil " else output_string os "runtime " @@ -780,7 +779,7 @@ let goutput_mbody is_entrypoint env os md = output_string os " \n{ \n" ; goutput_security_decls env os md.SecurityDecls; goutput_custom_attrs env os md.CustomAttrs; - match md.mdBody.Contents with + match md.Body.Contents with | MethodBody.IL il -> goutput_ilmbody env os il | _ -> () if is_entrypoint then output_string os " .entrypoint"; @@ -800,7 +799,7 @@ let goutput_mdef env os (md:ILMethodDef) = elif md.IsConstructor then "rtspecialname" elif md.IsStatic then "static "^ - (match md.mdBody.Contents with + (match md.Body.Contents with MethodBody.PInvoke (attr) -> "pinvokeimpl(\""^ attr.Where.Name^"\" as \""^ attr.Name ^"\""^ (match attr.CallingConv with @@ -853,7 +852,7 @@ let goutput_mdef env os (md:ILMethodDef) = (goutput_mbody is_entrypoint menv) os md; output_string os "\n" -let goutput_pdef env os pd = +let goutput_pdef env os (pd: ILPropertyDef) = output_string os "property\n\tgetter: "; (match pd.GetMethod with None -> () | Some mref -> goutput_mref env os mref); output_string os "\n\tsetter: "; @@ -864,14 +863,14 @@ let goutput_superclass env os = function | Some typ -> output_string os "extends "; (goutput_typ_with_shortened_class_syntax env) os typ let goutput_superinterfaces env os imp = - if imp = [] then () else - output_string os "implements "; - output_seq "," (goutput_typ_with_shortened_class_syntax env) os imp + if not (List.isEmpty imp) then + output_string os "implements " + output_seq "," (goutput_typ_with_shortened_class_syntax env) os imp let goutput_implements env os (imp:ILTypes) = - if imp.Length = 0 then () else - output_string os "implements "; - output_seq "," (goutput_typ_with_shortened_class_syntax env) os imp + if not (List.isEmpty imp) then + output_string os "implements " + output_seq "," (goutput_typ_with_shortened_class_syntax env) os imp let the = function Some x -> x | None -> failwith "the" @@ -892,7 +891,7 @@ let goutput_mdefs env os (mdefs: ILMethodDefs) = let goutput_pdefs env os (pdefs: ILPropertyDefs) = List.iter (fun f -> (goutput_pdef env) os f; output_string os "\n" ) pdefs.AsList -let rec goutput_tdef (enc) env contents os cd = +let rec goutput_tdef enc env contents os (cd: ILTypeDef) = let env = ppenv_enter_tdef cd.GenericParams env let layout_attr,pp_layout_decls = splitTypeLayout cd.Layout if isTypeNameForGlobalFunctions cd.Name then @@ -940,26 +939,26 @@ and output_init_semantics os f = and goutput_lambdas env os lambdas = match lambdas with | Lambdas_forall (gf,l) -> - output_angled (goutput_gparam env) os gf; - output_string os " "; + output_angled (goutput_gparam env) os gf + output_string os " " (goutput_lambdas env) os l | Lambdas_lambda (ps,l) -> output_parens (goutput_param env) os ps; - output_string os " "; + output_string os " " (goutput_lambdas env) os l | Lambdas_return typ -> output_string os "--> "; (goutput_typ env) os typ -and goutput_tdefs contents (enc) env os (td: ILTypeDefs) = +and goutput_tdefs contents enc env os (td: ILTypeDefs) = List.iter (goutput_tdef enc env contents os) td.AsList let output_ver os (a,b,c,d) = - output_string os " .ver "; - output_u16 os a; - output_string os " : "; - output_u16 os b; - output_string os " : "; - output_u16 os c; - output_string os " : "; + output_string os " .ver " + output_u16 os a + output_string os " : " + output_u16 os b + output_string os " : " + output_u16 os c + output_string os " : " output_u16 os d let output_locale os s = output_string os " .Locale "; output_qstring os s @@ -998,7 +997,8 @@ let goutput_resource env os r = output_string os " { "; goutput_custom_attrs env os r.CustomAttrs; match r.Location with - | ILResourceLocation.Local _ -> + | ILResourceLocation.LocalIn _ + | ILResourceLocation.LocalOut _ -> output_string os " /* loc nyi */ "; | ILResourceLocation.File (mref,off) -> output_string os " .file "; @@ -1021,11 +1021,10 @@ let goutput_manifest env os m = output_sqstring os m.Name; output_string os " { \n"; output_string os ".hash algorithm "; output_i32 os m.AuxModuleHashAlgorithm; output_string os "\n"; - goutput_custom_attrs env os m.CustomAttrs; - goutput_security_decls env os m.SecurityDecls; - (output_option output_publickey) os m.PublicKey; - (output_option output_ver) os m.Version; - (output_option output_locale) os m.Locale; + goutput_custom_attrs env os m.CustomAttrs + (output_option output_publickey) os m.PublicKey + (output_option output_ver) os m.Version + (output_option output_locale) os m.Locale output_string os " } \n" diff --git a/src/absil/ilread.fs b/src/absil/ilread.fs index c1e4ac3b9c..d9d66d2464 100755 --- a/src/absil/ilread.fs +++ b/src/absil/ilread.fs @@ -5,14 +5,16 @@ // //--------------------------------------------------------------------- -module internal Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader +module Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader #nowarn "42" // This construct is deprecated: it is only for use in the F# library open System +open System.Collections.Generic +open System.Diagnostics open System.IO open System.Runtime.InteropServices -open System.Collections.Generic +open System.Text open Internal.Utilities open Internal.Utilities.Collections open Microsoft.FSharp.Compiler.AbstractIL @@ -29,20 +31,11 @@ open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.NativeInterop open System.Reflection -type ILReaderOptions = - { pdbPath: string option - ilGlobals: ILGlobals - optimizeForMemory: bool } - -#if STATISTICS -let reportRef = ref (fun _oc -> ()) -let addReport f = let old = !reportRef in reportRef := (fun oc -> old oc; f oc) -let report (oc:TextWriter) = !reportRef oc ; reportRef := ref (fun _oc -> ()) -#endif - let checking = false let logging = false let _ = if checking then dprintn "warning : Ilread.checking is on" +let noStableFileHeuristic = try (System.Environment.GetEnvironmentVariable("FSharp_NoStableFileHeuristic") <> null) with _ -> false +let alwaysMemoryMapFSC = try (System.Environment.GetEnvironmentVariable("FSharp_AlwaysMemoryMapCommandLineCompiler") <> null) with _ -> false let singleOfBits (x:int32) = System.BitConverter.ToSingle(System.BitConverter.GetBytes(x), 0) let doubleOfBits (x:int64) = System.BitConverter.Int64BitsToDouble(x) @@ -95,16 +88,103 @@ let tokToTaggedIdx f nbits tok = let idx = tok >>>& nbits TaggedIndex(f tag, idx) +type Statistics = + { mutable rawMemoryFileCount : int + mutable memoryMapFileOpenedCount : int + mutable memoryMapFileClosedCount : int + mutable weakByteFileCount : int + mutable byteFileCount : int } + +let stats = + { rawMemoryFileCount = 0 + memoryMapFileOpenedCount = 0 + memoryMapFileClosedCount = 0 + weakByteFileCount = 0 + byteFileCount = 0 } + +let GetStatistics() = stats [] -type BinaryFile() = +/// An abstraction over how we access the contents of .NET binaries. May be backed by managed or unmanaged memory, +/// memory mapped file or by on-disk resources. These objects should never need explicit disposal - they must either +/// not hold resources of clean up after themselves when collected. +type BinaryView() = + + /// Read a byte from the file abstract ReadByte : addr:int -> byte + + /// Read a chunk of bytes from the file abstract ReadBytes : addr:int -> int -> byte[] + + /// Read an Int32 from the file abstract ReadInt32 : addr:int -> int + + /// Read a UInt16 from the file abstract ReadUInt16 : addr:int -> uint16 + + /// Read a length of a UTF8 string from the file abstract CountUtf8String : addr:int -> int + + /// Read a UTF8 string from the file abstract ReadUTF8String : addr: int -> string +/// An abstraction over how we access the contents of .NET binaries. May be backed by managed or unmanaged memory, +/// memory mapped file or by on-disk resources. +type BinaryFile = + /// Return a BinaryView for temporary use which eagerly holds any necessary memory resources for the duration of its lifetime, + /// and is faster to access byte-by-byte. The returned BinaryView should _not_ be captured in a closure that outlives the + /// desired lifetime. + abstract GetView : unit -> BinaryView + +/// A view over a raw pointer to memory +type RawMemoryView(obj: obj, start:nativeint, len: int) = + inherit BinaryView() + + override m.ReadByte i = + if nativeint i + 1n > nativeint len then failwithf "RawMemoryView overrun, i = %d, obj = %A" i obj + Marshal.ReadByte(start + nativeint i) + + override m.ReadBytes i n = + if nativeint i + nativeint n > nativeint len then failwithf "RawMemoryView overrun, i = %d, n = %d, obj = %A" i n obj + let res = Bytes.zeroCreate n + Marshal.Copy(start + nativeint i, res, 0, n) + res + + override m.ReadInt32 i = + if nativeint i + 4n > nativeint len then failwithf "RawMemoryView overrun, i = %d, obj = %A" i obj + Marshal.ReadInt32(start + nativeint i) + + override m.ReadUInt16 i = + if nativeint i + 2n > nativeint len then failwithf "RawMemoryView overrun, i = %d, obj = %A" i obj + uint16(Marshal.ReadInt16(start + nativeint i)) + + override m.CountUtf8String i = + if nativeint i > nativeint len then failwithf "RawMemoryView overrun, i = %d, obj = %A" i obj + let pStart = start + nativeint i + let mutable p = start + while Marshal.ReadByte(p) <> 0uy do + p <- p + 1n + int (p - pStart) + + override m.ReadUTF8String i = + let n = m.CountUtf8String i + if nativeint i + nativeint n > nativeint len then failwithf "RawMemoryView overrun, i = %d, n = %d, obj = %A" i n obj + System.Runtime.InteropServices.Marshal.PtrToStringAnsi(start + nativeint i, n) + + member __.HoldObj() = obj + + +/// Gives views over a raw chunk of memory, for example those returned to us by the memory manager in Roslyn's +/// Visual Studio integration. 'obj' must keep the memory alive. The object will capture it and thus also keep the memory alive for +/// the lifetime of this object. +type RawMemoryFile(fileName: string, obj: obj, addr: nativeint, length: int) = + do stats.rawMemoryFileCount <- stats.rawMemoryFileCount + 1 + let view = RawMemoryView(obj, addr, length) + member __.HoldObj() = obj // make sure we capture 'obj' + member __.FileName = fileName + interface BinaryFile with + override __.GetView() = view :>_ + /// Read from memory mapped files. module MemoryMapping = @@ -154,160 +234,217 @@ module MemoryMapping = let OPEN_EXISTING = 0x0003 let OPEN_ALWAYS = 0x0004 -type MemoryMappedFile(hMap: MemoryMapping.HANDLE, start:nativeint) = - inherit BinaryFile() - - static member Create fileName = - //printf "fileName = %s\n" fileName - let hFile = MemoryMapping.CreateFile (fileName, MemoryMapping.GENERIC_READ, MemoryMapping.FILE_SHARE_READ_WRITE, IntPtr.Zero, MemoryMapping.OPEN_EXISTING, 0, IntPtr.Zero ) - //printf "hFile = %Lx\n" (hFile.ToInt64()) - if ( hFile.Equals(MemoryMapping.INVALID_HANDLE) ) then - failwithf "CreateFile(0x%08x)" ( Marshal.GetHRForLastWin32Error() ) - let protection = 0x00000002 (* ReadOnly *) - //printf "OK! hFile = %Lx\n" (hFile.ToInt64()) - let hMap = MemoryMapping.CreateFileMapping (hFile, IntPtr.Zero, protection, 0, 0, null ) - ignore(MemoryMapping.CloseHandle(hFile)) - if hMap.Equals(MemoryMapping.NULL_HANDLE) then - failwithf "CreateFileMapping(0x%08x)" ( Marshal.GetHRForLastWin32Error() ) - - let start = MemoryMapping.MapViewOfFile (hMap, MemoryMapping.MAP_READ, 0, 0, 0n) - - if start.Equals(IntPtr.Zero) then - failwithf "MapViewOfFile(0x%08x)" ( Marshal.GetHRForLastWin32Error() ) - MemoryMappedFile(hMap, start) - - member m.Addr (i:int) : nativeint = - start + nativeint i +/// A view over a raw pointer to memory given by a memory mapped file. +/// NOTE: we should do more checking of validity here. +type MemoryMapView(start:nativeint) = + inherit BinaryView() override m.ReadByte i = - Marshal.ReadByte(m.Addr i) + Marshal.ReadByte(start + nativeint i) - override m.ReadBytes i len = - let res = Bytes.zeroCreate len - Marshal.Copy(m.Addr i, res, 0, len) + override m.ReadBytes i n = + let res = Bytes.zeroCreate n + Marshal.Copy(start + nativeint i, res, 0, n) res override m.ReadInt32 i = - Marshal.ReadInt32(m.Addr i) + Marshal.ReadInt32(start + nativeint i) override m.ReadUInt16 i = - uint16(Marshal.ReadInt16(m.Addr i)) - - member m.Close() = - ignore(MemoryMapping.UnmapViewOfFile start) - ignore(MemoryMapping.CloseHandle hMap) + uint16(Marshal.ReadInt16(start + nativeint i)) override m.CountUtf8String i = - let start = m.Addr i + let pStart = start + nativeint i let mutable p = start while Marshal.ReadByte(p) <> 0uy do p <- p + 1n - int (p - start) + int (p - pStart) override m.ReadUTF8String i = let n = m.CountUtf8String i - System.Runtime.InteropServices.Marshal.PtrToStringAnsi((m.Addr i), n) -//#if FX_RESHAPED_REFLECTION -// System.Text.Encoding.UTF8.GetString(NativePtr.ofNativeInt (m.Addr i), n) -//#else -// new System.String(NativePtr.ofNativeInt (m.Addr i), 0, n, System.Text.Encoding.UTF8) -//#endif + System.Runtime.InteropServices.Marshal.PtrToStringAnsi(start + nativeint i, n) +/// Memory maps a file and creates a single view over the entirety of its contents. The +/// lock on the file is only released when the object is disposed. +/// For memory mapping we currently take one view and never release it. +[] +type MemoryMapFile(fileName: string, view: MemoryMapView, hMap: MemoryMapping.HANDLE, hView:nativeint) = -//--------------------------------------------------------------------- -// Read file from memory blocks -//--------------------------------------------------------------------- + do stats.memoryMapFileOpenedCount <- stats.memoryMapFileOpenedCount + 1 + let mutable closed = false + static member Create fileName = + let hFile = MemoryMapping.CreateFile (fileName, MemoryMapping.GENERIC_READ, MemoryMapping.FILE_SHARE_READ_WRITE, IntPtr.Zero, MemoryMapping.OPEN_EXISTING, 0, IntPtr.Zero ) + if hFile.Equals(MemoryMapping.INVALID_HANDLE) then + failwithf "CreateFile(0x%08x)" (Marshal.GetHRForLastWin32Error()) + let protection = 0x00000002 + let hMap = MemoryMapping.CreateFileMapping (hFile, IntPtr.Zero, protection, 0, 0, null ) + ignore(MemoryMapping.CloseHandle(hFile)) + if hMap.Equals(MemoryMapping.NULL_HANDLE) then + failwithf "CreateFileMapping(0x%08x)" (Marshal.GetHRForLastWin32Error()) + + let hView = MemoryMapping.MapViewOfFile (hMap, MemoryMapping.MAP_READ, 0, 0, 0n) + + if hView.Equals(IntPtr.Zero) then + failwithf "MapViewOfFile(0x%08x)" (Marshal.GetHRForLastWin32Error()) + + let view = MemoryMapView(hView) + + MemoryMapFile(fileName, view, hMap, hView) + + member __.FileName = fileName + + member __.Close() = + stats.memoryMapFileClosedCount <- stats.memoryMapFileClosedCount + 1 + if not closed then + closed <- true + MemoryMapping.UnmapViewOfFile hView |> ignore + MemoryMapping.CloseHandle hMap |> ignore + interface BinaryFile with + override __.GetView() = (view :> BinaryView) -type ByteFile(bytes:byte[]) = - inherit BinaryFile() +/// Read file from memory blocks +type ByteView(bytes:byte[]) = + inherit BinaryView() - override mc.ReadByte addr = bytes.[addr] - override mc.ReadBytes addr len = Array.sub bytes addr len - override m.CountUtf8String addr = + override __.ReadByte addr = bytes.[addr] + + override __.ReadBytes addr len = Array.sub bytes addr len + + override __.CountUtf8String addr = let mutable p = addr while bytes.[p] <> 0uy do p <- p + 1 p - addr - override m.ReadUTF8String addr = - let n = m.CountUtf8String addr + override bfv.ReadUTF8String addr = + let n = bfv.CountUtf8String addr System.Text.Encoding.UTF8.GetString (bytes, addr, n) - override is.ReadInt32 addr = - let b0 = is.ReadByte addr - let b1 = is.ReadByte (addr+1) - let b2 = is.ReadByte (addr+2) - let b3 = is.ReadByte (addr+3) + override bfv.ReadInt32 addr = + let b0 = bfv.ReadByte addr + let b1 = bfv.ReadByte (addr+1) + let b2 = bfv.ReadByte (addr+2) + let b3 = bfv.ReadByte (addr+3) int b0 ||| (int b1 <<< 8) ||| (int b2 <<< 16) ||| (int b3 <<< 24) - override is.ReadUInt16 addr = - let b0 = is.ReadByte addr - let b1 = is.ReadByte (addr+1) + override bfv.ReadUInt16 addr = + let b0 = bfv.ReadByte addr + let b1 = bfv.ReadByte (addr+1) uint16 b0 ||| (uint16 b1 <<< 8) + +/// A BinaryFile backed by an array of bytes held strongly as managed memory +[] +type ByteFile(fileName: string, bytes:byte[]) = + let view = ByteView(bytes) + do stats.byteFileCount <- stats.byteFileCount + 1 + member __.FileName = fileName + interface BinaryFile with + override bf.GetView() = view :> BinaryView + +/// Same as ByteFile but holds the bytes weakly. The bytes will be re-read from the backing file when a view is requested. +/// This is the default implementation used by F# Compiler Services when accessing "stable" binaries. It is not used +/// by Visual Studio, where tryGetMetadataSnapshot provides a RawMemoryFile backed by Roslyn data. +[] +type WeakByteFile(fileName: string) = + + do stats.weakByteFileCount <- stats.weakByteFileCount + 1 + + /// Used to check that the file hasn't changed + let fileStamp = FileSystem.GetLastWriteTimeShim(fileName) + + /// The weak handle to the bytes for the file + let weakBytes = new WeakReference (null) + + member __.FileName = fileName + /// Get the bytes for the file + member this.Get() = + let mutable tg = null + if not (weakBytes.TryGetTarget(&tg)) then + if FileSystem.GetLastWriteTimeShim(fileName) <> fileStamp then + errorR (Error (FSComp.SR.ilreadFileChanged fileName, range0)) + + tg <- FileSystem.ReadAllBytesShim fileName + weakBytes.SetTarget tg + tg + + interface BinaryFile with + override __.GetView() = + let mutable tg = null + let strongBytes = + if not (weakBytes.TryGetTarget(&tg)) then + if FileSystem.GetLastWriteTimeShim(fileName) <> fileStamp then + errorR (Error (FSComp.SR.ilreadFileChanged fileName, range0)) + + tg <- FileSystem.ReadAllBytesShim fileName + weakBytes.SetTarget tg + tg + (ByteView(strongBytes) :> BinaryView) + + -let seekReadByte (is:BinaryFile) addr = is.ReadByte addr -let seekReadBytes (is:BinaryFile) addr len = is.ReadBytes addr len -let seekReadInt32 (is:BinaryFile) addr = is.ReadInt32 addr -let seekReadUInt16 (is:BinaryFile) addr = is.ReadUInt16 addr +let seekReadByte (mdv:BinaryView) addr = mdv.ReadByte addr +let seekReadBytes (mdv:BinaryView) addr len = mdv.ReadBytes addr len +let seekReadInt32 (mdv:BinaryView) addr = mdv.ReadInt32 addr +let seekReadUInt16 (mdv:BinaryView) addr = mdv.ReadUInt16 addr -let seekReadByteAsInt32 is addr = int32 (seekReadByte is addr) +let seekReadByteAsInt32 mdv addr = int32 (seekReadByte mdv addr) -let seekReadInt64 is addr = - let b0 = seekReadByte is addr - let b1 = seekReadByte is (addr+1) - let b2 = seekReadByte is (addr+2) - let b3 = seekReadByte is (addr+3) - let b4 = seekReadByte is (addr+4) - let b5 = seekReadByte is (addr+5) - let b6 = seekReadByte is (addr+6) - let b7 = seekReadByte is (addr+7) +let seekReadInt64 mdv addr = + let b0 = seekReadByte mdv addr + let b1 = seekReadByte mdv (addr+1) + let b2 = seekReadByte mdv (addr+2) + let b3 = seekReadByte mdv (addr+3) + let b4 = seekReadByte mdv (addr+4) + let b5 = seekReadByte mdv (addr+5) + let b6 = seekReadByte mdv (addr+6) + let b7 = seekReadByte mdv (addr+7) int64 b0 ||| (int64 b1 <<< 8) ||| (int64 b2 <<< 16) ||| (int64 b3 <<< 24) ||| (int64 b4 <<< 32) ||| (int64 b5 <<< 40) ||| (int64 b6 <<< 48) ||| (int64 b7 <<< 56) -let seekReadUInt16AsInt32 is addr = int32 (seekReadUInt16 is addr) +let seekReadUInt16AsInt32 mdv addr = int32 (seekReadUInt16 mdv addr) -let seekReadCompressedUInt32 is addr = - let b0 = seekReadByte is addr +let seekReadCompressedUInt32 mdv addr = + let b0 = seekReadByte mdv addr if b0 <= 0x7Fuy then int b0, addr+1 elif b0 <= 0xBFuy then let b0 = b0 &&& 0x7Fuy - let b1 = seekReadByteAsInt32 is (addr+1) + let b1 = seekReadByteAsInt32 mdv (addr+1) (int b0 <<< 8) ||| int b1, addr+2 else let b0 = b0 &&& 0x3Fuy - let b1 = seekReadByteAsInt32 is (addr+1) - let b2 = seekReadByteAsInt32 is (addr+2) - let b3 = seekReadByteAsInt32 is (addr+3) + let b1 = seekReadByteAsInt32 mdv (addr+1) + let b2 = seekReadByteAsInt32 mdv (addr+2) + let b3 = seekReadByteAsInt32 mdv (addr+3) (int b0 <<< 24) ||| (int b1 <<< 16) ||| (int b2 <<< 8) ||| int b3, addr+4 -let seekReadSByte is addr = sbyte (seekReadByte is addr) -let seekReadSingle is addr = singleOfBits (seekReadInt32 is addr) -let seekReadDouble is addr = doubleOfBits (seekReadInt64 is addr) +let seekReadSByte mdv addr = sbyte (seekReadByte mdv addr) +let seekReadSingle mdv addr = singleOfBits (seekReadInt32 mdv addr) +let seekReadDouble mdv addr = doubleOfBits (seekReadInt64 mdv addr) -let rec seekCountUtf8String is addr n = - let c = seekReadByteAsInt32 is addr +let rec seekCountUtf8String mdv addr n = + let c = seekReadByteAsInt32 mdv addr if c = 0 then n - else seekCountUtf8String is (addr+1) (n+1) + else seekCountUtf8String mdv (addr+1) (n+1) -let seekReadUTF8String is addr = - let n = seekCountUtf8String is addr 0 - let bytes = seekReadBytes is addr n +let seekReadUTF8String mdv addr = + let n = seekCountUtf8String mdv addr 0 + let bytes = seekReadBytes mdv addr n System.Text.Encoding.UTF8.GetString (bytes, 0, bytes.Length) -let seekReadBlob is addr = - let len, addr = seekReadCompressedUInt32 is addr - seekReadBytes is addr len +let seekReadBlob mdv addr = + let len, addr = seekReadCompressedUInt32 mdv addr + seekReadBytes mdv addr len -let seekReadUserString is addr = - let len, addr = seekReadCompressedUInt32 is addr - let bytes = seekReadBytes is addr (len - 1) - System.Text.Encoding.Unicode.GetString(bytes, 0, bytes.Length) +let seekReadUserString mdv addr = + let len, addr = seekReadCompressedUInt32 mdv addr + let bytes = seekReadBytes mdv addr (len - 1) + Encoding.Unicode.GetString(bytes, 0, bytes.Length) -let seekReadGuid is addr = seekReadBytes is addr 0x10 +let seekReadGuid mdv addr = seekReadBytes mdv addr 0x10 -let seekReadUncodedToken is addr = - i32ToUncodedToken (seekReadInt32 is addr) +let seekReadUncodedToken mdv addr = + i32ToUncodedToken (seekReadInt32 mdv addr) //--------------------------------------------------------------------- @@ -745,7 +882,6 @@ type MemberRefAsMspecIdx = MemberRefAsMspecIdx of int * int type MethodSpecAsMspecIdx = MethodSpecAsMspecIdx of int * int type MemberRefAsFspecIdx = MemberRefAsFspecIdx of int * int type CustomAttrIdx = CustomAttrIdx of CustomAttributeTypeTag * int * int32 -type SecurityDeclIdx = SecurityDeclIdx of uint16 * int32 type GenericParamsIdx = GenericParamsIdx of int * TypeOrMethodDefTag * int //--------------------------------------------------------------------- @@ -881,7 +1017,7 @@ let seekReadIndexedRows (numRows, rowReader, keyFunc, keyComparer, binaryChop, r List.rev !res -let seekReadOptionalIndexedRow (info) = +let seekReadOptionalIndexedRow info = match seekReadIndexedRows info with | [k] -> Some k | [] -> None @@ -889,7 +1025,7 @@ let seekReadOptionalIndexedRow (info) = dprintn ("multiple rows found when indexing table") Some h -let seekReadIndexedRow (info) = +let seekReadIndexedRow info = match seekReadOptionalIndexedRow info with | Some row -> row | None -> failwith ("no row found for key when indexing table") @@ -898,31 +1034,19 @@ let seekReadIndexedRow (info) = // The big fat reader. //--------------------------------------------------------------------- -type ILModuleReader = - { modul: ILModuleDef - ilAssemblyRefs: Lazy - dispose: unit -> unit } - member x.ILModuleDef = x.modul - member x.ILAssemblyRefs = x.ilAssemblyRefs.Force() - interface IDisposable with - member x.Dispose() = x.dispose() - - type MethodData = MethodData of ILType * ILCallingConv * string * ILTypes * ILType * ILTypes type VarArgMethodData = VarArgMethodData of ILType * ILCallingConv * string * ILTypes * ILVarArgs * ILType * ILTypes -[] -type ILReaderContext = - { ilg: ILGlobals - dataEndPoints: Lazy - sorted: int64 +[] +type PEReader = + { fileName: string #if FX_NO_PDB_READER pdb: obj option #else pdb: (PdbReader * (string -> ILSourceDocument)) option #endif entryPointToken: TableName * int - getNumRows: TableName -> int + pefile: BinaryFile textSegmentPhysicalLoc : int32 textSegmentPhysicalSize : int32 dataSegmentPhysicalLoc : int32 @@ -935,8 +1059,18 @@ type ILReaderContext = resourcesAddr:int32 strongnameAddr:int32 vtableFixupsAddr:int32 - is: BinaryFile - infile:string +} + +[] +type ILMetadataReader = + { ilg: ILGlobals + sorted: int64 + mdfile: BinaryFile + pectxtCaptured: PEReader option // only set when reading full PE including code etc. for static linking + entryPointToken: TableName * int + dataEndPoints: Lazy + fileName:string + getNumRows: TableName -> int userStringsStreamPhysicalLoc: int32 stringsStreamPhysicalLoc: int32 blobsStreamPhysicalLoc: int32 @@ -964,52 +1098,15 @@ type ILReaderContext = stringsBigness: bool guidsBigness: bool blobsBigness: bool - countTypeRef : int ref - countTypeDef : int ref - countField : int ref - countMethod : int ref - countParam : int ref - countInterfaceImpl : int ref - countMemberRef : int ref - countConstant : int ref - countCustomAttribute : int ref - countFieldMarshal: int ref - countPermission : int ref - countClassLayout : int ref - countFieldLayout : int ref - countStandAloneSig : int ref - countEventMap : int ref - countEvent : int ref - countPropertyMap : int ref - countProperty : int ref - countMethodSemantics : int ref - countMethodImpl : int ref - countModuleRef : int ref - countTypeSpec : int ref - countImplMap : int ref - countFieldRVA : int ref - countAssembly : int ref - countAssemblyRef : int ref - countFile : int ref - countExportedType : int ref - countManifestResource : int ref - countNested : int ref - countGenericParam : int ref - countGenericParamConstraint : int ref - countMethodSpec : int ref seekReadNestedRow : int -> int * int seekReadConstantRow : int -> uint16 * TaggedIndex * int32 seekReadMethodSemanticsRow : int -> int32 * int * TaggedIndex seekReadTypeDefRow : int -> int32 * int32 * int32 * TaggedIndex * int * int - seekReadInterfaceImplRow : int -> int * TaggedIndex - seekReadFieldMarshalRow : int -> TaggedIndex * int32 - seekReadPropertyMapRow : int -> int * int seekReadAssemblyRef : int -> ILAssemblyRef seekReadMethodSpecAsMethodData : MethodSpecAsMspecIdx -> VarArgMethodData seekReadMemberRefAsMethodData : MemberRefAsMspecIdx -> VarArgMethodData seekReadMemberRefAsFieldSpec : MemberRefAsFspecIdx -> ILFieldSpec seekReadCustomAttr : CustomAttrIdx -> ILAttribute - seekReadSecurityDecl : SecurityDeclIdx -> ILPermission seekReadTypeRef : int ->ILTypeRef seekReadTypeRefAsType : TypeRefAsTypIdx -> ILType readBlobHeapAsPropertySig : BlobAsPropSigIdx -> ILThisConvention * ILType * ILTypes @@ -1019,414 +1116,395 @@ type ILReaderContext = seekReadTypeDefAsType : TypeDefAsTypIdx -> ILType seekReadMethodDefAsMethodData : int -> MethodData seekReadGenericParams : GenericParamsIdx -> ILGenericParameterDef list - seekReadFieldDefAsFieldSpec : int -> ILFieldSpec } + seekReadFieldDefAsFieldSpec : int -> ILFieldSpec + customAttrsReader_Module : ILAttributesStored + customAttrsReader_Assembly : ILAttributesStored + customAttrsReader_TypeDef : ILAttributesStored + customAttrsReader_GenericParam: ILAttributesStored + customAttrsReader_FieldDef: ILAttributesStored + customAttrsReader_MethodDef: ILAttributesStored + customAttrsReader_ParamDef: ILAttributesStored + customAttrsReader_Event: ILAttributesStored + customAttrsReader_Property: ILAttributesStored + customAttrsReader_ManifestResource: ILAttributesStored + customAttrsReader_ExportedType: ILAttributesStored + securityDeclsReader_TypeDef : ILSecurityDeclsStored + securityDeclsReader_MethodDef : ILSecurityDeclsStored + securityDeclsReader_Assembly : ILSecurityDeclsStored + typeDefReader : ILTypeDefStored } -let count c = -#if DEBUG - incr c -#else - c |> ignore - () -#endif - -let seekReadUInt16Adv ctxt (addr: byref) = - let res = seekReadUInt16 ctxt.is addr +let seekReadUInt16Adv mdv (addr: byref) = + let res = seekReadUInt16 mdv addr addr <- addr + 2 res -let seekReadInt32Adv ctxt (addr: byref) = - let res = seekReadInt32 ctxt.is addr +let seekReadInt32Adv mdv (addr: byref) = + let res = seekReadInt32 mdv addr addr <- addr+4 res -let seekReadUInt16AsInt32Adv ctxt (addr: byref) = - let res = seekReadUInt16AsInt32 ctxt.is addr +let seekReadUInt16AsInt32Adv mdv (addr: byref) = + let res = seekReadUInt16AsInt32 mdv addr addr <- addr+2 res -let seekReadTaggedIdx f nbits big is (addr: byref) = - let tok = if big then seekReadInt32Adv is &addr else seekReadUInt16AsInt32Adv is &addr +let seekReadTaggedIdx f nbits big mdv (addr: byref) = + let tok = if big then seekReadInt32Adv mdv &addr else seekReadUInt16AsInt32Adv mdv &addr tokToTaggedIdx f nbits tok -let seekReadIdx big ctxt (addr: byref) = - if big then seekReadInt32Adv ctxt &addr else seekReadUInt16AsInt32Adv ctxt &addr +let seekReadIdx big mdv (addr: byref) = + if big then seekReadInt32Adv mdv &addr else seekReadUInt16AsInt32Adv mdv &addr -let seekReadUntaggedIdx (tab:TableName) ctxt (addr: byref) = - seekReadIdx ctxt.tableBigness.[tab.Index] ctxt &addr +let seekReadUntaggedIdx (tab:TableName) (ctxt: ILMetadataReader) mdv (addr: byref) = + seekReadIdx ctxt.tableBigness.[tab.Index] mdv &addr -let seekReadResolutionScopeIdx ctxt (addr: byref) = seekReadTaggedIdx mkResolutionScopeTag 2 ctxt.rsBigness ctxt &addr -let seekReadTypeDefOrRefOrSpecIdx ctxt (addr: byref) = seekReadTaggedIdx mkTypeDefOrRefOrSpecTag 2 ctxt.tdorBigness ctxt &addr -let seekReadTypeOrMethodDefIdx ctxt (addr: byref) = seekReadTaggedIdx mkTypeOrMethodDefTag 1 ctxt.tomdBigness ctxt &addr -let seekReadHasConstantIdx ctxt (addr: byref) = seekReadTaggedIdx mkHasConstantTag 2 ctxt.hcBigness ctxt &addr -let seekReadHasCustomAttributeIdx ctxt (addr: byref) = seekReadTaggedIdx mkHasCustomAttributeTag 5 ctxt.hcaBigness ctxt &addr -let seekReadHasFieldMarshalIdx ctxt (addr: byref) = seekReadTaggedIdx mkHasFieldMarshalTag 1 ctxt.hfmBigness ctxt &addr -let seekReadHasDeclSecurityIdx ctxt (addr: byref) = seekReadTaggedIdx mkHasDeclSecurityTag 2 ctxt.hdsBigness ctxt &addr -let seekReadMemberRefParentIdx ctxt (addr: byref) = seekReadTaggedIdx mkMemberRefParentTag 3 ctxt.mrpBigness ctxt &addr -let seekReadHasSemanticsIdx ctxt (addr: byref) = seekReadTaggedIdx mkHasSemanticsTag 1 ctxt.hsBigness ctxt &addr -let seekReadMethodDefOrRefIdx ctxt (addr: byref) = seekReadTaggedIdx mkMethodDefOrRefTag 1 ctxt.mdorBigness ctxt &addr -let seekReadMemberForwardedIdx ctxt (addr: byref) = seekReadTaggedIdx mkMemberForwardedTag 1 ctxt.mfBigness ctxt &addr -let seekReadImplementationIdx ctxt (addr: byref) = seekReadTaggedIdx mkImplementationTag 2 ctxt.iBigness ctxt &addr -let seekReadCustomAttributeTypeIdx ctxt (addr: byref) = seekReadTaggedIdx mkILCustomAttributeTypeTag 3 ctxt.catBigness ctxt &addr -let seekReadStringIdx ctxt (addr: byref) = seekReadIdx ctxt.stringsBigness ctxt &addr -let seekReadGuidIdx ctxt (addr: byref) = seekReadIdx ctxt.guidsBigness ctxt &addr -let seekReadBlobIdx ctxt (addr: byref) = seekReadIdx ctxt.blobsBigness ctxt &addr +let seekReadResolutionScopeIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkResolutionScopeTag 2 ctxt.rsBigness mdv &addr +let seekReadTypeDefOrRefOrSpecIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkTypeDefOrRefOrSpecTag 2 ctxt.tdorBigness mdv &addr +let seekReadTypeOrMethodDefIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkTypeOrMethodDefTag 1 ctxt.tomdBigness mdv &addr +let seekReadHasConstantIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkHasConstantTag 2 ctxt.hcBigness mdv &addr +let seekReadHasCustomAttributeIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkHasCustomAttributeTag 5 ctxt.hcaBigness mdv &addr +let seekReadHasFieldMarshalIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkHasFieldMarshalTag 1 ctxt.hfmBigness mdv &addr +let seekReadHasDeclSecurityIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkHasDeclSecurityTag 2 ctxt.hdsBigness mdv &addr +let seekReadMemberRefParentIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkMemberRefParentTag 3 ctxt.mrpBigness mdv &addr +let seekReadHasSemanticsIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkHasSemanticsTag 1 ctxt.hsBigness mdv &addr +let seekReadMethodDefOrRefIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkMethodDefOrRefTag 1 ctxt.mdorBigness mdv &addr +let seekReadMemberForwardedIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkMemberForwardedTag 1 ctxt.mfBigness mdv &addr +let seekReadImplementationIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkImplementationTag 2 ctxt.iBigness mdv &addr +let seekReadCustomAttributeTypeIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadTaggedIdx mkILCustomAttributeTypeTag 3 ctxt.catBigness mdv &addr +let seekReadStringIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadIdx ctxt.stringsBigness mdv &addr +let seekReadGuidIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadIdx ctxt.guidsBigness mdv &addr +let seekReadBlobIdx (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadIdx ctxt.blobsBigness mdv &addr -let seekReadModuleRow ctxt idx = +let seekReadModuleRow (ctxt: ILMetadataReader) mdv idx = if idx = 0 then failwith "cannot read Module table row 0" let mutable addr = ctxt.rowAddr TableNames.Module idx - let generation = seekReadUInt16Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let mvidIdx = seekReadGuidIdx ctxt &addr - let encidIdx = seekReadGuidIdx ctxt &addr - let encbaseidIdx = seekReadGuidIdx ctxt &addr + let generation = seekReadUInt16Adv mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let mvidIdx = seekReadGuidIdx ctxt mdv &addr + let encidIdx = seekReadGuidIdx ctxt mdv &addr + let encbaseidIdx = seekReadGuidIdx ctxt mdv &addr (generation, nameIdx, mvidIdx, encidIdx, encbaseidIdx) /// Read Table ILTypeRef. -let seekReadTypeRefRow ctxt idx = - count ctxt.countTypeRef +let seekReadTypeRefRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.TypeRef idx - let scopeIdx = seekReadResolutionScopeIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let namespaceIdx = seekReadStringIdx ctxt &addr + let scopeIdx = seekReadResolutionScopeIdx ctxt mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let namespaceIdx = seekReadStringIdx ctxt mdv &addr (scopeIdx, nameIdx, namespaceIdx) /// Read Table ILTypeDef. -let seekReadTypeDefRow ctxt idx = ctxt.seekReadTypeDefRow idx +let seekReadTypeDefRow (ctxt: ILMetadataReader) idx = ctxt.seekReadTypeDefRow idx let seekReadTypeDefRowUncached ctxtH idx = - let ctxt = getHole ctxtH - count ctxt.countTypeDef + let (ctxt : ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() let mutable addr = ctxt.rowAddr TableNames.TypeDef idx - let flags = seekReadInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let namespaceIdx = seekReadStringIdx ctxt &addr - let extendsIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr - let fieldsIdx = seekReadUntaggedIdx TableNames.Field ctxt &addr - let methodsIdx = seekReadUntaggedIdx TableNames.Method ctxt &addr + let flags = seekReadInt32Adv mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let namespaceIdx = seekReadStringIdx ctxt mdv &addr + let extendsIdx = seekReadTypeDefOrRefOrSpecIdx ctxt mdv &addr + let fieldsIdx = seekReadUntaggedIdx TableNames.Field ctxt mdv &addr + let methodsIdx = seekReadUntaggedIdx TableNames.Method ctxt mdv &addr (flags, nameIdx, namespaceIdx, extendsIdx, fieldsIdx, methodsIdx) /// Read Table Field. -let seekReadFieldRow ctxt idx = - count ctxt.countField +let seekReadFieldRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.Field idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let typeIdx = seekReadBlobIdx ctxt &addr + let flags = seekReadUInt16AsInt32Adv mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let typeIdx = seekReadBlobIdx ctxt mdv &addr (flags, nameIdx, typeIdx) /// Read Table Method. -let seekReadMethodRow ctxt idx = - count ctxt.countMethod +let seekReadMethodRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.Method idx - let codeRVA = seekReadInt32Adv ctxt &addr - let implflags = seekReadUInt16AsInt32Adv ctxt &addr - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let typeIdx = seekReadBlobIdx ctxt &addr - let paramIdx = seekReadUntaggedIdx TableNames.Param ctxt &addr + let codeRVA = seekReadInt32Adv mdv &addr + let implflags = seekReadUInt16AsInt32Adv mdv &addr + let flags = seekReadUInt16AsInt32Adv mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let typeIdx = seekReadBlobIdx ctxt mdv &addr + let paramIdx = seekReadUntaggedIdx TableNames.Param ctxt mdv &addr (codeRVA, implflags, flags, nameIdx, typeIdx, paramIdx) /// Read Table Param. -let seekReadParamRow ctxt idx = - count ctxt.countParam +let seekReadParamRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.Param idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let seq = seekReadUInt16AsInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr + let flags = seekReadUInt16AsInt32Adv mdv &addr + let seq = seekReadUInt16AsInt32Adv mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr (flags, seq, nameIdx) /// Read Table InterfaceImpl. -let seekReadInterfaceImplRow ctxt idx = ctxt.seekReadInterfaceImplRow idx -let seekReadInterfaceImplRowUncached ctxtH idx = - let ctxt = getHole ctxtH - count ctxt.countInterfaceImpl +let seekReadInterfaceImplRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.InterfaceImpl idx - let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr - let intfIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr + let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr + let intfIdx = seekReadTypeDefOrRefOrSpecIdx ctxt mdv &addr (tidx, intfIdx) /// Read Table MemberRef. -let seekReadMemberRefRow ctxt idx = - count ctxt.countMemberRef +let seekReadMemberRefRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.MemberRef idx - let mrpIdx = seekReadMemberRefParentIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let typeIdx = seekReadBlobIdx ctxt &addr + let mrpIdx = seekReadMemberRefParentIdx ctxt mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let typeIdx = seekReadBlobIdx ctxt mdv &addr (mrpIdx, nameIdx, typeIdx) /// Read Table Constant. -let seekReadConstantRow ctxt idx = ctxt.seekReadConstantRow idx +let seekReadConstantRow (ctxt: ILMetadataReader) idx = ctxt.seekReadConstantRow idx let seekReadConstantRowUncached ctxtH idx = - let ctxt = getHole ctxtH - count ctxt.countConstant + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() let mutable addr = ctxt.rowAddr TableNames.Constant idx - let kind = seekReadUInt16Adv ctxt &addr - let parentIdx = seekReadHasConstantIdx ctxt &addr - let valIdx = seekReadBlobIdx ctxt &addr + let kind = seekReadUInt16Adv mdv &addr + let parentIdx = seekReadHasConstantIdx ctxt mdv &addr + let valIdx = seekReadBlobIdx ctxt mdv &addr (kind, parentIdx, valIdx) /// Read Table CustomAttribute. -let seekReadCustomAttributeRow ctxt idx = - count ctxt.countCustomAttribute +let seekReadCustomAttributeRow (ctxt: ILMetadataReader) idx = + let mdv = ctxt.mdfile.GetView() let mutable addr = ctxt.rowAddr TableNames.CustomAttribute idx - let parentIdx = seekReadHasCustomAttributeIdx ctxt &addr - let typeIdx = seekReadCustomAttributeTypeIdx ctxt &addr - let valIdx = seekReadBlobIdx ctxt &addr + let parentIdx = seekReadHasCustomAttributeIdx ctxt mdv &addr + let typeIdx = seekReadCustomAttributeTypeIdx ctxt mdv &addr + let valIdx = seekReadBlobIdx ctxt mdv &addr (parentIdx, typeIdx, valIdx) /// Read Table FieldMarshal. -let seekReadFieldMarshalRow ctxt idx = ctxt.seekReadFieldMarshalRow idx -let seekReadFieldMarshalRowUncached ctxtH idx = - let ctxt = getHole ctxtH - count ctxt.countFieldMarshal +let seekReadFieldMarshalRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.FieldMarshal idx - let parentIdx = seekReadHasFieldMarshalIdx ctxt &addr - let typeIdx = seekReadBlobIdx ctxt &addr + let parentIdx = seekReadHasFieldMarshalIdx ctxt mdv &addr + let typeIdx = seekReadBlobIdx ctxt mdv &addr (parentIdx, typeIdx) /// Read Table Permission. -let seekReadPermissionRow ctxt idx = - count ctxt.countPermission +let seekReadPermissionRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.Permission idx - let action = seekReadUInt16Adv ctxt &addr - let parentIdx = seekReadHasDeclSecurityIdx ctxt &addr - let typeIdx = seekReadBlobIdx ctxt &addr + let action = seekReadUInt16Adv mdv &addr + let parentIdx = seekReadHasDeclSecurityIdx ctxt mdv &addr + let typeIdx = seekReadBlobIdx ctxt mdv &addr (action, parentIdx, typeIdx) /// Read Table ClassLayout. -let seekReadClassLayoutRow ctxt idx = - count ctxt.countClassLayout +let seekReadClassLayoutRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.ClassLayout idx - let pack = seekReadUInt16Adv ctxt &addr - let size = seekReadInt32Adv ctxt &addr - let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr + let pack = seekReadUInt16Adv mdv &addr + let size = seekReadInt32Adv mdv &addr + let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr (pack, size, tidx) /// Read Table FieldLayout. -let seekReadFieldLayoutRow ctxt idx = - count ctxt.countFieldLayout +let seekReadFieldLayoutRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.FieldLayout idx - let offset = seekReadInt32Adv ctxt &addr - let fidx = seekReadUntaggedIdx TableNames.Field ctxt &addr + let offset = seekReadInt32Adv mdv &addr + let fidx = seekReadUntaggedIdx TableNames.Field ctxt mdv &addr (offset, fidx) //// Read Table StandAloneSig. -let seekReadStandAloneSigRow ctxt idx = - count ctxt.countStandAloneSig +let seekReadStandAloneSigRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.StandAloneSig idx - let sigIdx = seekReadBlobIdx ctxt &addr + let sigIdx = seekReadBlobIdx ctxt mdv &addr sigIdx /// Read Table EventMap. -let seekReadEventMapRow ctxt idx = - count ctxt.countEventMap +let seekReadEventMapRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.EventMap idx - let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr - let eventsIdx = seekReadUntaggedIdx TableNames.Event ctxt &addr + let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr + let eventsIdx = seekReadUntaggedIdx TableNames.Event ctxt mdv &addr (tidx, eventsIdx) /// Read Table Event. -let seekReadEventRow ctxt idx = - count ctxt.countEvent +let seekReadEventRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.Event idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let typIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr + let flags = seekReadUInt16AsInt32Adv mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let typIdx = seekReadTypeDefOrRefOrSpecIdx ctxt mdv &addr (flags, nameIdx, typIdx) /// Read Table PropertyMap. -let seekReadPropertyMapRow ctxt idx = ctxt.seekReadPropertyMapRow idx -let seekReadPropertyMapRowUncached ctxtH idx = - let ctxt = getHole ctxtH - count ctxt.countPropertyMap +let seekReadPropertyMapRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.PropertyMap idx - let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr - let propsIdx = seekReadUntaggedIdx TableNames.Property ctxt &addr + let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr + let propsIdx = seekReadUntaggedIdx TableNames.Property ctxt mdv &addr (tidx, propsIdx) /// Read Table Property. -let seekReadPropertyRow ctxt idx = - count ctxt.countProperty +let seekReadPropertyRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.Property idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let typIdx = seekReadBlobIdx ctxt &addr + let flags = seekReadUInt16AsInt32Adv mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let typIdx = seekReadBlobIdx ctxt mdv &addr (flags, nameIdx, typIdx) /// Read Table MethodSemantics. -let seekReadMethodSemanticsRow ctxt idx = ctxt.seekReadMethodSemanticsRow idx +let seekReadMethodSemanticsRow (ctxt: ILMetadataReader) idx = ctxt.seekReadMethodSemanticsRow idx let seekReadMethodSemanticsRowUncached ctxtH idx = - let ctxt = getHole ctxtH - count ctxt.countMethodSemantics + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() let mutable addr = ctxt.rowAddr TableNames.MethodSemantics idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let midx = seekReadUntaggedIdx TableNames.Method ctxt &addr - let assocIdx = seekReadHasSemanticsIdx ctxt &addr + let flags = seekReadUInt16AsInt32Adv mdv &addr + let midx = seekReadUntaggedIdx TableNames.Method ctxt mdv &addr + let assocIdx = seekReadHasSemanticsIdx ctxt mdv &addr (flags, midx, assocIdx) /// Read Table MethodImpl. -let seekReadMethodImplRow ctxt idx = - count ctxt.countMethodImpl +let seekReadMethodImplRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.MethodImpl idx - let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr - let mbodyIdx = seekReadMethodDefOrRefIdx ctxt &addr - let mdeclIdx = seekReadMethodDefOrRefIdx ctxt &addr + let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr + let mbodyIdx = seekReadMethodDefOrRefIdx ctxt mdv &addr + let mdeclIdx = seekReadMethodDefOrRefIdx ctxt mdv &addr (tidx, mbodyIdx, mdeclIdx) /// Read Table ILModuleRef. -let seekReadModuleRefRow ctxt idx = - count ctxt.countModuleRef +let seekReadModuleRefRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.ModuleRef idx - let nameIdx = seekReadStringIdx ctxt &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr nameIdx /// Read Table ILTypeSpec. -let seekReadTypeSpecRow ctxt idx = - count ctxt.countTypeSpec +let seekReadTypeSpecRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.TypeSpec idx - let blobIdx = seekReadBlobIdx ctxt &addr + let blobIdx = seekReadBlobIdx ctxt mdv &addr blobIdx /// Read Table ImplMap. -let seekReadImplMapRow ctxt idx = - count ctxt.countImplMap +let seekReadImplMapRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.ImplMap idx - let flags = seekReadUInt16AsInt32Adv ctxt &addr - let forwrdedIdx = seekReadMemberForwardedIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let scopeIdx = seekReadUntaggedIdx TableNames.ModuleRef ctxt &addr + let flags = seekReadUInt16AsInt32Adv mdv &addr + let forwrdedIdx = seekReadMemberForwardedIdx ctxt mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let scopeIdx = seekReadUntaggedIdx TableNames.ModuleRef ctxt mdv &addr (flags, forwrdedIdx, nameIdx, scopeIdx) /// Read Table FieldRVA. -let seekReadFieldRVARow ctxt idx = - count ctxt.countFieldRVA +let seekReadFieldRVARow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.FieldRVA idx - let rva = seekReadInt32Adv ctxt &addr - let fidx = seekReadUntaggedIdx TableNames.Field ctxt &addr + let rva = seekReadInt32Adv mdv &addr + let fidx = seekReadUntaggedIdx TableNames.Field ctxt mdv &addr (rva, fidx) /// Read Table Assembly. -let seekReadAssemblyRow ctxt idx = - count ctxt.countAssembly +let seekReadAssemblyRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.Assembly idx - let hash = seekReadInt32Adv ctxt &addr - let v1 = seekReadUInt16Adv ctxt &addr - let v2 = seekReadUInt16Adv ctxt &addr - let v3 = seekReadUInt16Adv ctxt &addr - let v4 = seekReadUInt16Adv ctxt &addr - let flags = seekReadInt32Adv ctxt &addr - let publicKeyIdx = seekReadBlobIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let localeIdx = seekReadStringIdx ctxt &addr + let hash = seekReadInt32Adv mdv &addr + let v1 = seekReadUInt16Adv mdv &addr + let v2 = seekReadUInt16Adv mdv &addr + let v3 = seekReadUInt16Adv mdv &addr + let v4 = seekReadUInt16Adv mdv &addr + let flags = seekReadInt32Adv mdv &addr + let publicKeyIdx = seekReadBlobIdx ctxt mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let localeIdx = seekReadStringIdx ctxt mdv &addr (hash, v1, v2, v3, v4, flags, publicKeyIdx, nameIdx, localeIdx) /// Read Table ILAssemblyRef. -let seekReadAssemblyRefRow ctxt idx = - count ctxt.countAssemblyRef +let seekReadAssemblyRefRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.AssemblyRef idx - let v1 = seekReadUInt16Adv ctxt &addr - let v2 = seekReadUInt16Adv ctxt &addr - let v3 = seekReadUInt16Adv ctxt &addr - let v4 = seekReadUInt16Adv ctxt &addr - let flags = seekReadInt32Adv ctxt &addr - let publicKeyOrTokenIdx = seekReadBlobIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let localeIdx = seekReadStringIdx ctxt &addr - let hashValueIdx = seekReadBlobIdx ctxt &addr + let v1 = seekReadUInt16Adv mdv &addr + let v2 = seekReadUInt16Adv mdv &addr + let v3 = seekReadUInt16Adv mdv &addr + let v4 = seekReadUInt16Adv mdv &addr + let flags = seekReadInt32Adv mdv &addr + let publicKeyOrTokenIdx = seekReadBlobIdx ctxt mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let localeIdx = seekReadStringIdx ctxt mdv &addr + let hashValueIdx = seekReadBlobIdx ctxt mdv &addr (v1, v2, v3, v4, flags, publicKeyOrTokenIdx, nameIdx, localeIdx, hashValueIdx) /// Read Table File. -let seekReadFileRow ctxt idx = - count ctxt.countFile +let seekReadFileRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.File idx - let flags = seekReadInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let hashValueIdx = seekReadBlobIdx ctxt &addr + let flags = seekReadInt32Adv mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let hashValueIdx = seekReadBlobIdx ctxt mdv &addr (flags, nameIdx, hashValueIdx) /// Read Table ILExportedTypeOrForwarder. -let seekReadExportedTypeRow ctxt idx = - count ctxt.countExportedType +let seekReadExportedTypeRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.ExportedType idx - let flags = seekReadInt32Adv ctxt &addr - let tok = seekReadInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let namespaceIdx = seekReadStringIdx ctxt &addr - let implIdx = seekReadImplementationIdx ctxt &addr + let flags = seekReadInt32Adv mdv &addr + let tok = seekReadInt32Adv mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let namespaceIdx = seekReadStringIdx ctxt mdv &addr + let implIdx = seekReadImplementationIdx ctxt mdv &addr (flags, tok, nameIdx, namespaceIdx, implIdx) /// Read Table ManifestResource. -let seekReadManifestResourceRow ctxt idx = - count ctxt.countManifestResource +let seekReadManifestResourceRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.ManifestResource idx - let offset = seekReadInt32Adv ctxt &addr - let flags = seekReadInt32Adv ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr - let implIdx = seekReadImplementationIdx ctxt &addr + let offset = seekReadInt32Adv mdv &addr + let flags = seekReadInt32Adv mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr + let implIdx = seekReadImplementationIdx ctxt mdv &addr (offset, flags, nameIdx, implIdx) /// Read Table Nested. -let seekReadNestedRow ctxt idx = ctxt.seekReadNestedRow idx +let seekReadNestedRow (ctxt: ILMetadataReader) idx = ctxt.seekReadNestedRow idx let seekReadNestedRowUncached ctxtH idx = - let ctxt = getHole ctxtH - count ctxt.countNested + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() let mutable addr = ctxt.rowAddr TableNames.Nested idx - let nestedIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr - let enclIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr + let nestedIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr + let enclIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt mdv &addr (nestedIdx, enclIdx) /// Read Table GenericParam. -let seekReadGenericParamRow ctxt idx = - count ctxt.countGenericParam +let seekReadGenericParamRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.GenericParam idx - let seq = seekReadUInt16Adv ctxt &addr - let flags = seekReadUInt16Adv ctxt &addr - let ownerIdx = seekReadTypeOrMethodDefIdx ctxt &addr - let nameIdx = seekReadStringIdx ctxt &addr + let seq = seekReadUInt16Adv mdv &addr + let flags = seekReadUInt16Adv mdv &addr + let ownerIdx = seekReadTypeOrMethodDefIdx ctxt mdv &addr + let nameIdx = seekReadStringIdx ctxt mdv &addr (idx, seq, flags, ownerIdx, nameIdx) // Read Table GenericParamConstraint. -let seekReadGenericParamConstraintRow ctxt idx = - count ctxt.countGenericParamConstraint +let seekReadGenericParamConstraintRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.GenericParamConstraint idx - let pidx = seekReadUntaggedIdx TableNames.GenericParam ctxt &addr - let constraintIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr + let pidx = seekReadUntaggedIdx TableNames.GenericParam ctxt mdv &addr + let constraintIdx = seekReadTypeDefOrRefOrSpecIdx ctxt mdv &addr (pidx, constraintIdx) /// Read Table ILMethodSpec. -let seekReadMethodSpecRow ctxt idx = - count ctxt.countMethodSpec +let seekReadMethodSpecRow (ctxt: ILMetadataReader) mdv idx = let mutable addr = ctxt.rowAddr TableNames.MethodSpec idx - let mdorIdx = seekReadMethodDefOrRefIdx ctxt &addr - let instIdx = seekReadBlobIdx ctxt &addr + let mdorIdx = seekReadMethodDefOrRefIdx ctxt mdv &addr + let instIdx = seekReadBlobIdx ctxt mdv &addr (mdorIdx, instIdx) let readUserStringHeapUncached ctxtH idx = - let ctxt = getHole ctxtH - seekReadUserString ctxt.is (ctxt.userStringsStreamPhysicalLoc + idx) + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + seekReadUserString mdv (ctxt.userStringsStreamPhysicalLoc + idx) -let readUserStringHeap ctxt idx = ctxt.readUserStringHeap idx +let readUserStringHeap (ctxt: ILMetadataReader) idx = ctxt.readUserStringHeap idx let readStringHeapUncached ctxtH idx = - let ctxt = getHole ctxtH - seekReadUTF8String ctxt.is (ctxt.stringsStreamPhysicalLoc + idx) -let readStringHeap ctxt idx = ctxt.readStringHeap idx -let readStringHeapOption ctxt idx = if idx = 0 then None else Some (readStringHeap ctxt idx) + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + seekReadUTF8String mdv (ctxt.stringsStreamPhysicalLoc + idx) + +let readStringHeap (ctxt: ILMetadataReader) idx = ctxt.readStringHeap idx + +let readStringHeapOption (ctxt: ILMetadataReader) idx = if idx = 0 then None else Some (readStringHeap ctxt idx) let emptyByteArray: byte[] = [||] + let readBlobHeapUncached ctxtH idx = - let ctxt = getHole ctxtH + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() // valid index lies in range [1..streamSize) - // NOTE: idx cannot be 0 - Blob\String heap has first empty element that is one byte 0 + // NOTE: idx cannot be 0 - Blob\String heap has first empty element that mdv one byte 0 if idx <= 0 || idx >= ctxt.blobsStreamSize then emptyByteArray - else seekReadBlob ctxt.is (ctxt.blobsStreamPhysicalLoc + idx) -let readBlobHeap ctxt idx = ctxt.readBlobHeap idx + else seekReadBlob mdv (ctxt.blobsStreamPhysicalLoc + idx) + +let readBlobHeap (ctxt: ILMetadataReader) idx = ctxt.readBlobHeap idx + let readBlobHeapOption ctxt idx = if idx = 0 then None else Some (readBlobHeap ctxt idx) -let readGuidHeap ctxt idx = seekReadGuid ctxt.is (ctxt.guidsStreamPhysicalLoc + idx) +//let readGuidHeap ctxt idx = seekReadGuid ctxt.mdv (ctxt.guidsStreamPhysicalLoc + idx) // read a single value out of a blob heap using the given function let readBlobHeapAsBool ctxt vidx = fst (sigptrGetBool (readBlobHeap ctxt vidx) 0) @@ -1458,31 +1536,24 @@ let readBlobHeapAsDouble ctxt vidx = fst (sigptrGetDouble (readBlobHeap ctxt vid // (e) the start of the native resources attached to the binary if any // ----------------------------------------------------------------------*) -#if FX_NO_LINKEDRESOURCES -let readNativeResources _ctxt = [] -#else -let readNativeResources ctxt = - let nativeResources = - if ctxt.nativeResourcesSize = 0x0 || ctxt.nativeResourcesAddr = 0x0 then - [] - else - [ (lazy (let linkedResource = seekReadBytes ctxt.is (ctxt.anyV2P (ctxt.infile + ": native resources", ctxt.nativeResourcesAddr)) ctxt.nativeResourcesSize - unlinkResource ctxt.nativeResourcesAddr linkedResource)) ] - nativeResources -#endif +let readNativeResources (pectxt: PEReader) = + [ if pectxt.nativeResourcesSize <> 0x0 && pectxt.nativeResourcesAddr <> 0x0 then + let start = pectxt.anyV2P (pectxt.fileName + ": native resources", pectxt.nativeResourcesAddr) + yield ILNativeResource.In (pectxt.fileName, pectxt.nativeResourcesAddr, start, pectxt.nativeResourcesSize ) ] -let dataEndPoints ctxtH = +let getDataEndPointsDelayed (pectxt: PEReader) ctxtH = lazy - let ctxt = getHole ctxtH + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() let dataStartPoints = let res = ref [] for i = 1 to ctxt.getNumRows (TableNames.FieldRVA) do - let rva, _fidx = seekReadFieldRVARow ctxt i + let rva, _fidx = seekReadFieldRVARow ctxt mdv i res := ("field", rva) :: !res for i = 1 to ctxt.getNumRows TableNames.ManifestResource do - let (offset, _, _, TaggedIndex(_tag, idx)) = seekReadManifestResourceRow ctxt i + let (offset, _, _, TaggedIndex(_tag, idx)) = seekReadManifestResourceRow ctxt mdv i if idx = 0 then - let rva = ctxt.resourcesAddr + offset + let rva = pectxt.resourcesAddr + offset res := ("manifest resource", rva) :: !res !res if isNil dataStartPoints then [] @@ -1490,61 +1561,65 @@ let dataEndPoints ctxtH = let methodRVAs = let res = ref [] for i = 1 to ctxt.getNumRows TableNames.Method do - let (rva, _, _, nameIdx, _, _) = seekReadMethodRow ctxt i + let (rva, _, _, nameIdx, _, _) = seekReadMethodRow ctxt mdv i if rva <> 0 then let nm = readStringHeap ctxt nameIdx res := (nm, rva) :: !res !res - ([ ctxt.textSegmentPhysicalLoc + ctxt.textSegmentPhysicalSize ; - ctxt.dataSegmentPhysicalLoc + ctxt.dataSegmentPhysicalSize ] + ([ pectxt.textSegmentPhysicalLoc + pectxt.textSegmentPhysicalSize ; + pectxt.dataSegmentPhysicalLoc + pectxt.dataSegmentPhysicalSize ] @ - (List.map ctxt.anyV2P + (List.map pectxt.anyV2P (dataStartPoints - @ [for (virtAddr, _virtSize, _physLoc) in ctxt.sectionHeaders do yield ("section start", virtAddr) done] - @ [("md", ctxt.metadataAddr)] - @ (if ctxt.nativeResourcesAddr = 0x0 then [] else [("native resources", ctxt.nativeResourcesAddr) ]) - @ (if ctxt.resourcesAddr = 0x0 then [] else [("managed resources", ctxt.resourcesAddr) ]) - @ (if ctxt.strongnameAddr = 0x0 then [] else [("managed strongname", ctxt.strongnameAddr) ]) - @ (if ctxt.vtableFixupsAddr = 0x0 then [] else [("managed vtable_fixups", ctxt.vtableFixupsAddr) ]) + @ [for (virtAddr, _virtSize, _physLoc) in pectxt.sectionHeaders do yield ("section start", virtAddr) done] + @ [("md", pectxt.metadataAddr)] + @ (if pectxt.nativeResourcesAddr = 0x0 then [] else [("native resources", pectxt.nativeResourcesAddr) ]) + @ (if pectxt.resourcesAddr = 0x0 then [] else [("managed resources", pectxt.resourcesAddr) ]) + @ (if pectxt.strongnameAddr = 0x0 then [] else [("managed strongname", pectxt.strongnameAddr) ]) + @ (if pectxt.vtableFixupsAddr = 0x0 then [] else [("managed vtable_fixups", pectxt.vtableFixupsAddr) ]) @ methodRVAs))) |> List.distinct |> List.sort -let rec rvaToData ctxt nm rva = +let rvaToData (ctxt: ILMetadataReader) (pectxt: PEReader) nm rva = if rva = 0x0 then failwith "rva is zero" - let start = ctxt.anyV2P (nm, rva) + let start = pectxt.anyV2P (nm, rva) let endPoints = (Lazy.force ctxt.dataEndPoints) let rec look l = match l with | [] -> - failwithf "find_text_data_extent: none found for infile=%s, name=%s, rva=0x%08x, start=0x%08x" ctxt.infile nm rva start + failwithf "find_text_data_extent: none found for fileName=%s, name=%s, rva=0x%08x, start=0x%08x" ctxt.fileName nm rva start | e::t -> if start < e then - (seekReadBytes ctxt.is start (e - start)) + let pev = pectxt.pefile.GetView() + seekReadBytes pev start (e - start) else look t look endPoints - //----------------------------------------------------------------------- // Read the AbsIL structure (lazily) by reading off the relevant rows. // ---------------------------------------------------------------------- -let isSorted ctxt (tab:TableName) = ((ctxt.sorted &&& (int64 1 <<< tab.Index)) <> int64 0x0) +let isSorted (ctxt: ILMetadataReader) (tab:TableName) = ((ctxt.sorted &&& (int64 1 <<< tab.Index)) <> int64 0x0) -let rec seekReadModule ctxt (subsys, subsysversion, useHighEntropyVA, ilOnly, only32, is32bitpreferred, only64, platform, isDll, alignVirt, alignPhys, imageBaseReal, ilMetadataVersion) idx = - let (_generation, nameIdx, _mvidIdx, _encidIdx, _encbaseidIdx) = seekReadModuleRow ctxt idx +// Note, pectxtEager and pevEager must not be captured by the results of this function +let rec seekReadModule (ctxt: ILMetadataReader) (pectxtEager: PEReader) pevEager peinfo ilMetadataVersion idx = + let (subsys, subsysversion, useHighEntropyVA, ilOnly, only32, is32bitpreferred, only64, platform, isDll, alignVirt, alignPhys, imageBaseReal) = peinfo + let mdv = ctxt.mdfile.GetView() + let (_generation, nameIdx, _mvidIdx, _encidIdx, _encbaseidIdx) = seekReadModuleRow ctxt mdv idx let ilModuleName = readStringHeap ctxt nameIdx - let nativeResources = readNativeResources ctxt + let nativeResources = readNativeResources pectxtEager { Manifest = - if ctxt.getNumRows (TableNames.Assembly) > 0 then Some (seekReadAssemblyManifest ctxt 1) + if ctxt.getNumRows (TableNames.Assembly) > 0 then Some (seekReadAssemblyManifest ctxt pectxtEager 1) else None - CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_Module, idx)) + CustomAttrsStored = ctxt.customAttrsReader_Module + MetadataIndex = idx Name = ilModuleName NativeResources=nativeResources - TypeDefs = mkILTypeDefsComputed (fun () -> seekReadTopTypeDefs ctxt ()) + TypeDefs = mkILTypeDefsComputed (fun () -> seekReadTopTypeDefs ctxt) SubSystemFlags = int32 subsys IsILOnly = ilOnly SubsystemVersion = subsysversion @@ -1559,39 +1634,43 @@ let rec seekReadModule ctxt (subsys, subsysversion, useHighEntropyVA, ilOnly, on PhysicalAlignment = alignPhys ImageBase = imageBaseReal MetadataVersion = ilMetadataVersion - Resources = seekReadManifestResources ctxt () } + Resources = seekReadManifestResources ctxt mdv pectxtEager pevEager } -and seekReadAssemblyManifest ctxt idx = - let (hash, v1, v2, v3, v4, flags, publicKeyIdx, nameIdx, localeIdx) = seekReadAssemblyRow ctxt idx +and seekReadAssemblyManifest (ctxt: ILMetadataReader) pectxt idx = + let mdview = ctxt.mdfile.GetView() + let (hash, v1, v2, v3, v4, flags, publicKeyIdx, nameIdx, localeIdx) = seekReadAssemblyRow ctxt mdview idx let name = readStringHeap ctxt nameIdx let pubkey = readBlobHeapOption ctxt publicKeyIdx { Name= name AuxModuleHashAlgorithm=hash - SecurityDecls= seekReadSecurityDecls ctxt (TaggedIndex(hds_Assembly, idx)) + SecurityDeclsStored= ctxt.securityDeclsReader_Assembly PublicKey= pubkey Version= Some (v1, v2, v3, v4) Locale= readStringHeapOption ctxt localeIdx - CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_Assembly, idx)) + CustomAttrsStored = ctxt.customAttrsReader_Assembly + MetadataIndex = idx AssemblyLongevity= - begin let masked = flags &&& 0x000e - if masked = 0x0000 then ILAssemblyLongevity.Unspecified - elif masked = 0x0002 then ILAssemblyLongevity.Library - elif masked = 0x0004 then ILAssemblyLongevity.PlatformAppDomain - elif masked = 0x0006 then ILAssemblyLongevity.PlatformProcess - elif masked = 0x0008 then ILAssemblyLongevity.PlatformSystem - else ILAssemblyLongevity.Unspecified - end - ExportedTypes= seekReadTopExportedTypes ctxt () - EntrypointElsewhere=(if fst ctxt.entryPointToken = TableNames.File then Some (seekReadFile ctxt (snd ctxt.entryPointToken)) else None) + let masked = flags &&& 0x000e + if masked = 0x0000 then ILAssemblyLongevity.Unspecified + elif masked = 0x0002 then ILAssemblyLongevity.Library + elif masked = 0x0004 then ILAssemblyLongevity.PlatformAppDomain + elif masked = 0x0006 then ILAssemblyLongevity.PlatformProcess + elif masked = 0x0008 then ILAssemblyLongevity.PlatformSystem + else ILAssemblyLongevity.Unspecified + ExportedTypes= seekReadTopExportedTypes ctxt + EntrypointElsewhere= + let (tab, tok) = pectxt.entryPointToken + if tab = TableNames.File then Some (seekReadFile ctxt mdview tok) else None Retargetable = 0 <> (flags &&& 0x100) DisableJitOptimizations = 0 <> (flags &&& 0x4000) JitTracking = 0 <> (flags &&& 0x8000) IgnoreSymbolStoreSequencePoints = 0 <> (flags &&& 0x2000) } -and seekReadAssemblyRef ctxt idx = ctxt.seekReadAssemblyRef idx +and seekReadAssemblyRef (ctxt: ILMetadataReader) idx = ctxt.seekReadAssemblyRef idx and seekReadAssemblyRefUncached ctxtH idx = - let ctxt = getHole ctxtH - let (v1, v2, v3, v4, flags, publicKeyOrTokenIdx, nameIdx, localeIdx, hashValueIdx) = seekReadAssemblyRefRow ctxt idx + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + let (v1, v2, v3, v4, flags, publicKeyOrTokenIdx, nameIdx, localeIdx, hashValueIdx) = seekReadAssemblyRefRow ctxt mdv idx let nm = readStringHeap ctxt nameIdx let publicKey = match readBlobHeapOption ctxt publicKeyOrTokenIdx with @@ -1606,20 +1685,16 @@ and seekReadAssemblyRefUncached ctxtH idx = version=Some(v1, v2, v3, v4), locale=readStringHeapOption ctxt localeIdx) -and seekReadModuleRef ctxt idx = - let (nameIdx) = seekReadModuleRefRow ctxt idx - ILModuleRef.Create(name = readStringHeap ctxt nameIdx, - hasMetadata=true, - hash=None) +and seekReadModuleRef (ctxt: ILMetadataReader) mdv idx = + let (nameIdx) = seekReadModuleRefRow ctxt mdv idx + ILModuleRef.Create(name = readStringHeap ctxt nameIdx, hasMetadata=true, hash=None) -and seekReadFile ctxt idx = - let (flags, nameIdx, hashValueIdx) = seekReadFileRow ctxt idx - ILModuleRef.Create(name = readStringHeap ctxt nameIdx, - hasMetadata= ((flags &&& 0x0001) = 0x0), - hash= readBlobHeapOption ctxt hashValueIdx) +and seekReadFile (ctxt: ILMetadataReader) mdv idx = + let (flags, nameIdx, hashValueIdx) = seekReadFileRow ctxt mdv idx + ILModuleRef.Create(name = readStringHeap ctxt nameIdx, hasMetadata= ((flags &&& 0x0001) = 0x0), hash= readBlobHeapOption ctxt hashValueIdx) -and seekReadClassLayout ctxt idx = - match seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.ClassLayout, seekReadClassLayoutRow ctxt, (fun (_, _, tidx) -> tidx), simpleIndexCompare idx, isSorted ctxt TableNames.ClassLayout, (fun (pack, size, _) -> pack, size)) with +and seekReadClassLayout (ctxt: ILMetadataReader) mdv idx = + match seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.ClassLayout, seekReadClassLayoutRow ctxt mdv, (fun (_, _, tidx) -> tidx), simpleIndexCompare idx, isSorted ctxt TableNames.ClassLayout, (fun (pack, size, _) -> pack, size)) with | None -> { Size = None; Pack = None } | Some (pack, size) -> { Size = Some size; Pack = Some pack } @@ -1634,10 +1709,10 @@ and typeAccessOfFlags flags = elif f = 0x00000005 then ILTypeDefAccess.Nested ILMemberAccess.Assembly else ILTypeDefAccess.Private -and typeLayoutOfFlags ctxt flags tidx = +and typeLayoutOfFlags (ctxt: ILMetadataReader) mdv flags tidx = let f = (flags &&& 0x00000018) - if f = 0x00000008 then ILTypeDefLayout.Sequential (seekReadClassLayout ctxt tidx) - elif f = 0x00000010 then ILTypeDefLayout.Explicit (seekReadClassLayout ctxt tidx) + if f = 0x00000008 then ILTypeDefLayout.Sequential (seekReadClassLayout ctxt mdv tidx) + elif f = 0x00000010 then ILTypeDefLayout.Explicit (seekReadClassLayout ctxt mdv tidx) else ILTypeDefLayout.Auto and isTopTypeDef flags = @@ -1662,7 +1737,7 @@ and readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) = | None -> name | Some ns -> ctxt.memoizeString (ns+"."+name) -and seekReadTypeDefRowExtents ctxt _info (idx:int) = +and seekReadTypeDefRowExtents (ctxt: ILMetadataReader) _info (idx:int) = if idx >= ctxt.getNumRows TableNames.TypeDef then ctxt.getNumRows TableNames.Field + 1, ctxt.getNumRows TableNames.Method + 1 @@ -1674,81 +1749,85 @@ and seekReadTypeDefRowWithExtents ctxt (idx:int) = let info= seekReadTypeDefRow ctxt idx info, seekReadTypeDefRowExtents ctxt info idx -and seekReadTypeDef ctxt toponly (idx:int) = +and seekReadPreTypeDef ctxt toponly (idx:int) = let (flags, nameIdx, namespaceIdx, _, _, _) = seekReadTypeDefRow ctxt idx if toponly && not (isTopTypeDef flags) then None else let ns, n = readBlobHeapAsSplitTypeName ctxt (nameIdx, namespaceIdx) - let cas = seekReadCustomAttrs ctxt (TaggedIndex(hca_TypeDef, idx)) - - let rest = - lazy + // Return the ILPreTypeDef + Some (mkILPreTypeDefRead (ns, n, idx, ctxt.typeDefReader)) + +and typeDefReader ctxtH : ILTypeDefStored = + mkILTypeDefReader + (fun idx -> + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() // Re-read so as not to save all these in the lazy closure - this suspension ctxt.is the largest // heavily allocated one in all of AbsIL + let ((flags, nameIdx, namespaceIdx, extendsIdx, fieldsIdx, methodsIdx) as info) = seekReadTypeDefRow ctxt idx let nm = readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) - let cas = seekReadCustomAttrs ctxt (TaggedIndex(hca_TypeDef, idx)) - let (endFieldsIdx, endMethodsIdx) = seekReadTypeDefRowExtents ctxt info idx let typars = seekReadGenericParams ctxt 0 (tomd_TypeDef, idx) let numtypars = typars.Length let super = seekReadOptionalTypeDefOrRef ctxt numtypars AsObject extendsIdx - let layout = typeLayoutOfFlags ctxt flags idx + let layout = typeLayoutOfFlags ctxt mdv flags idx let hasLayout = (match layout with ILTypeDefLayout.Explicit _ -> true | _ -> false) let mdefs = seekReadMethods ctxt numtypars methodsIdx endMethodsIdx let fdefs = seekReadFields ctxt (numtypars, hasLayout) fieldsIdx endFieldsIdx let nested = seekReadNestedTypeDefs ctxt idx - let impls = seekReadInterfaceImpls ctxt numtypars idx - let sdecls = seekReadSecurityDecls ctxt (TaggedIndex(hds_TypeDef, idx)) + let impls = seekReadInterfaceImpls ctxt mdv numtypars idx let mimpls = seekReadMethodImpls ctxt numtypars idx let props = seekReadProperties ctxt numtypars idx let events = seekReadEvents ctxt numtypars idx - { Name=nm - GenericParams=typars - Attributes= enum(flags) - Layout = layout - NestedTypes= nested - Implements = impls - Extends = super - Methods = mdefs - SecurityDecls = sdecls - Fields=fdefs - MethodImpls=mimpls - Events= events - Properties=props - CustomAttrs=cas } - Some (ns, n, cas, rest) - -and seekReadTopTypeDefs ctxt () = + ILTypeDef(name=nm, + genericParams=typars , + attributes= enum(flags), + layout = layout, + nestedTypes= nested, + implements = impls, + extends = super, + methods = mdefs, + securityDeclsStored = ctxt.securityDeclsReader_TypeDef, + fields=fdefs, + methodImpls=mimpls, + events= events, + properties=props, + customAttrsStored=ctxt.customAttrsReader_TypeDef, + metadataIndex=idx) + ) + +and seekReadTopTypeDefs (ctxt: ILMetadataReader) = [| for i = 1 to ctxt.getNumRows TableNames.TypeDef do - match seekReadTypeDef ctxt true i with + match seekReadPreTypeDef ctxt true i with | None -> () | Some td -> yield td |] -and seekReadNestedTypeDefs ctxt tidx = +and seekReadNestedTypeDefs (ctxt: ILMetadataReader) tidx = mkILTypeDefsComputed (fun () -> let nestedIdxs = seekReadIndexedRows (ctxt.getNumRows TableNames.Nested, seekReadNestedRow ctxt, snd, simpleIndexCompare tidx, false, fst) [| for i in nestedIdxs do - match seekReadTypeDef ctxt false i with + match seekReadPreTypeDef ctxt false i with | None -> () | Some td -> yield td |]) -and seekReadInterfaceImpls ctxt numtypars tidx = +and seekReadInterfaceImpls (ctxt: ILMetadataReader) mdv numtypars tidx = seekReadIndexedRows (ctxt.getNumRows TableNames.InterfaceImpl, - seekReadInterfaceImplRow ctxt, - fst, - simpleIndexCompare tidx, - isSorted ctxt TableNames.InterfaceImpl, - (snd >> seekReadTypeDefOrRef ctxt numtypars AsObject (*ok*) List.empty)) + seekReadInterfaceImplRow ctxt mdv, + fst, + simpleIndexCompare tidx, + isSorted ctxt TableNames.InterfaceImpl, + (snd >> seekReadTypeDefOrRef ctxt numtypars AsObject (*ok*) List.empty)) and seekReadGenericParams ctxt numtypars (a, b) : ILGenericParameterDefs = ctxt.seekReadGenericParams (GenericParamsIdx(numtypars, a, b)) and seekReadGenericParamsUncached ctxtH (GenericParamsIdx(numtypars, a, b)) = - let ctxt = getHole ctxtH + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() let pars = seekReadIndexedRows - (ctxt.getNumRows TableNames.GenericParam, seekReadGenericParamRow ctxt, + (ctxt.getNumRows TableNames.GenericParam, seekReadGenericParamRow ctxt mdv, (fun (_, _, _, tomd, _) -> tomd), tomdCompare (TaggedIndex(a, b)), isSorted ctxt TableNames.GenericParam, @@ -1760,34 +1839,34 @@ and seekReadGenericParamsUncached ctxtH (GenericParamsIdx(numtypars, a, b)) = elif variance_flags = 0x0001 then CoVariant elif variance_flags = 0x0002 then ContraVariant else NonVariant - let constraints = seekReadGenericParamConstraintsUncached ctxt numtypars gpidx - let cas = seekReadCustomAttrs ctxt (TaggedIndex(hca_GenericParam, gpidx)) + let constraints = seekReadGenericParamConstraints ctxt mdv numtypars gpidx seq, {Name=readStringHeap ctxt nameIdx Constraints = constraints Variance=variance - CustomAttrs=cas + CustomAttrsStored = ctxt.customAttrsReader_GenericParam + MetadataIndex=gpidx HasReferenceTypeConstraint= (flags &&& 0x0004) <> 0 HasNotNullableValueTypeConstraint= (flags &&& 0x0008) <> 0 HasDefaultConstructorConstraint=(flags &&& 0x0010) <> 0 })) pars |> List.sortBy fst |> List.map snd -and seekReadGenericParamConstraintsUncached ctxt numtypars gpidx = +and seekReadGenericParamConstraints (ctxt: ILMetadataReader) mdv numtypars gpidx = seekReadIndexedRows (ctxt.getNumRows TableNames.GenericParamConstraint, - seekReadGenericParamConstraintRow ctxt, + seekReadGenericParamConstraintRow ctxt mdv, fst, simpleIndexCompare gpidx, isSorted ctxt TableNames.GenericParamConstraint, (snd >> seekReadTypeDefOrRef ctxt numtypars AsObject (*ok*) List.empty)) -and seekReadTypeDefAsType ctxt boxity (ginst:ILTypes) idx = +and seekReadTypeDefAsType (ctxt: ILMetadataReader) boxity (ginst:ILTypes) idx = ctxt.seekReadTypeDefAsType (TypeDefAsTypIdx (boxity, ginst, idx)) and seekReadTypeDefAsTypeUncached ctxtH (TypeDefAsTypIdx (boxity, ginst, idx)) = let ctxt = getHole ctxtH mkILTy boxity (ILTypeSpec.Create(seekReadTypeDefAsTypeRef ctxt idx, ginst)) -and seekReadTypeDefAsTypeRef ctxt idx = +and seekReadTypeDefAsTypeRef (ctxt: ILMetadataReader) idx = let enc = if seekIsTopTypeDefOfIdx ctxt idx then [] else @@ -1798,63 +1877,65 @@ and seekReadTypeDefAsTypeRef ctxt idx = let nm = readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) ILTypeRef.Create(scope=ILScopeRef.Local, enclosing=enc, name = nm ) -and seekReadTypeRef ctxt idx = ctxt.seekReadTypeRef idx +and seekReadTypeRef (ctxt: ILMetadataReader) idx = ctxt.seekReadTypeRef idx and seekReadTypeRefUncached ctxtH idx = - let ctxt = getHole ctxtH - let scopeIdx, nameIdx, namespaceIdx = seekReadTypeRefRow ctxt idx - let scope, enc = seekReadTypeRefScope ctxt scopeIdx + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + let scopeIdx, nameIdx, namespaceIdx = seekReadTypeRefRow ctxt mdv idx + let scope, enc = seekReadTypeRefScope ctxt mdv scopeIdx let nm = readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) ILTypeRef.Create(scope=scope, enclosing=enc, name = nm) -and seekReadTypeRefAsType ctxt boxity ginst idx = ctxt.seekReadTypeRefAsType (TypeRefAsTypIdx (boxity, ginst, idx)) +and seekReadTypeRefAsType (ctxt: ILMetadataReader) boxity ginst idx = ctxt.seekReadTypeRefAsType (TypeRefAsTypIdx (boxity, ginst, idx)) and seekReadTypeRefAsTypeUncached ctxtH (TypeRefAsTypIdx (boxity, ginst, idx)) = let ctxt = getHole ctxtH mkILTy boxity (ILTypeSpec.Create(seekReadTypeRef ctxt idx, ginst)) -and seekReadTypeDefOrRef ctxt numtypars boxity (ginst:ILTypes) (TaggedIndex(tag, idx) ) = +and seekReadTypeDefOrRef (ctxt: ILMetadataReader) numtypars boxity (ginst:ILTypes) (TaggedIndex(tag, idx) ) = + let mdv = ctxt.mdfile.GetView() match tag with | tag when tag = tdor_TypeDef -> seekReadTypeDefAsType ctxt boxity ginst idx | tag when tag = tdor_TypeRef -> seekReadTypeRefAsType ctxt boxity ginst idx | tag when tag = tdor_TypeSpec -> - if ginst.Length > 0 then dprintn ("type spec used as type constructor for a generic instantiation: ignoring instantiation") - readBlobHeapAsType ctxt numtypars (seekReadTypeSpecRow ctxt idx) + if not (List.isEmpty ginst) then dprintn ("type spec used as type constructor for a generic instantiation: ignoring instantiation") + readBlobHeapAsType ctxt numtypars (seekReadTypeSpecRow ctxt mdv idx) | _ -> failwith "seekReadTypeDefOrRef ctxt" -and seekReadTypeDefOrRefAsTypeRef ctxt (TaggedIndex(tag, idx) ) = +and seekReadTypeDefOrRefAsTypeRef (ctxt: ILMetadataReader) (TaggedIndex(tag, idx) ) = match tag with | tag when tag = tdor_TypeDef -> seekReadTypeDefAsTypeRef ctxt idx | tag when tag = tdor_TypeRef -> seekReadTypeRef ctxt idx | tag when tag = tdor_TypeSpec -> - dprintn ("type spec used where a type ref or def ctxt.is required") + dprintn ("type spec used where a type ref or def is required") ctxt.ilg.typ_Object.TypeRef | _ -> failwith "seekReadTypeDefOrRefAsTypeRef_readTypeDefOrRefOrSpec" -and seekReadMethodRefParent ctxt numtypars (TaggedIndex(tag, idx)) = +and seekReadMethodRefParent (ctxt: ILMetadataReader) mdv numtypars (TaggedIndex(tag, idx)) = match tag with - | tag when tag = mrp_TypeRef -> seekReadTypeRefAsType ctxt AsObject (* not ok - no way to tell if a member ref parent ctxt.is a value type or not *) List.empty idx - | tag when tag = mrp_ModuleRef -> mkILTypeForGlobalFunctions (ILScopeRef.Module (seekReadModuleRef ctxt idx)) + | tag when tag = mrp_TypeRef -> seekReadTypeRefAsType ctxt AsObject (* not ok - no way to tell if a member ref parent is a value type or not *) List.empty idx + | tag when tag = mrp_ModuleRef -> mkILTypeForGlobalFunctions (ILScopeRef.Module (seekReadModuleRef ctxt mdv idx)) | tag when tag = mrp_MethodDef -> let (MethodData(enclTyp, cc, nm, argtys, retty, minst)) = seekReadMethodDefAsMethodData ctxt idx let mspec = mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty, minst) mspec.DeclaringType - | tag when tag = mrp_TypeSpec -> readBlobHeapAsType ctxt numtypars (seekReadTypeSpecRow ctxt idx) - | _ -> failwith "seekReadMethodRefParent ctxt" + | tag when tag = mrp_TypeSpec -> readBlobHeapAsType ctxt numtypars (seekReadTypeSpecRow ctxt mdv idx) + | _ -> failwith "seekReadMethodRefParent" -and seekReadMethodDefOrRef ctxt numtypars (TaggedIndex(tag, idx)) = +and seekReadMethodDefOrRef (ctxt: ILMetadataReader) numtypars (TaggedIndex(tag, idx)) = match tag with | tag when tag = mdor_MethodDef -> let (MethodData(enclTyp, cc, nm, argtys, retty, minst)) = seekReadMethodDefAsMethodData ctxt idx VarArgMethodData(enclTyp, cc, nm, argtys, None, retty, minst) | tag when tag = mdor_MemberRef -> seekReadMemberRefAsMethodData ctxt numtypars idx - | _ -> failwith "seekReadMethodDefOrRef ctxt" + | _ -> failwith "seekReadMethodDefOrRef" -and seekReadMethodDefOrRefNoVarargs ctxt numtypars x = +and seekReadMethodDefOrRefNoVarargs (ctxt: ILMetadataReader) numtypars x = let (VarArgMethodData(enclTyp, cc, nm, argtys, varargs, retty, minst)) = seekReadMethodDefOrRef ctxt numtypars x if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef token signature" MethodData(enclTyp, cc, nm, argtys, retty, minst) -and seekReadCustomAttrType ctxt (TaggedIndex(tag, idx) ) = +and seekReadCustomAttrType (ctxt: ILMetadataReader) (TaggedIndex(tag, idx) ) = match tag with | tag when tag = cat_MethodDef -> let (MethodData(enclTyp, cc, nm, argtys, retty, minst)) = seekReadMethodDefAsMethodData ctxt idx @@ -1864,67 +1945,74 @@ and seekReadCustomAttrType ctxt (TaggedIndex(tag, idx) ) = mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty, minst) | _ -> failwith "seekReadCustomAttrType ctxt" -and seekReadImplAsScopeRef ctxt (TaggedIndex(tag, idx) ) = +and seekReadImplAsScopeRef (ctxt: ILMetadataReader) mdv (TaggedIndex(tag, idx) ) = if idx = 0 then ILScopeRef.Local else match tag with - | tag when tag = i_File -> ILScopeRef.Module (seekReadFile ctxt idx) + | tag when tag = i_File -> ILScopeRef.Module (seekReadFile ctxt mdv idx) | tag when tag = i_AssemblyRef -> ILScopeRef.Assembly (seekReadAssemblyRef ctxt idx) - | tag when tag = i_ExportedType -> failwith "seekReadImplAsScopeRef ctxt" - | _ -> failwith "seekReadImplAsScopeRef ctxt" + | tag when tag = i_ExportedType -> failwith "seekReadImplAsScopeRef" + | _ -> failwith "seekReadImplAsScopeRef" -and seekReadTypeRefScope ctxt (TaggedIndex(tag, idx) ) = +and seekReadTypeRefScope (ctxt: ILMetadataReader) mdv (TaggedIndex(tag, idx) ) = match tag with | tag when tag = rs_Module -> ILScopeRef.Local, [] - | tag when tag = rs_ModuleRef -> ILScopeRef.Module (seekReadModuleRef ctxt idx), [] + | tag when tag = rs_ModuleRef -> ILScopeRef.Module (seekReadModuleRef ctxt mdv idx), [] | tag when tag = rs_AssemblyRef -> ILScopeRef.Assembly (seekReadAssemblyRef ctxt idx), [] | tag when tag = rs_TypeRef -> let tref = seekReadTypeRef ctxt idx tref.Scope, (tref.Enclosing@[tref.Name]) - | _ -> failwith "seekReadTypeRefScope ctxt" + | _ -> failwith "seekReadTypeRefScope" -and seekReadOptionalTypeDefOrRef ctxt numtypars boxity idx = +and seekReadOptionalTypeDefOrRef (ctxt: ILMetadataReader) numtypars boxity idx = if idx = TaggedIndex(tdor_TypeDef, 0) then None else Some (seekReadTypeDefOrRef ctxt numtypars boxity List.empty idx) -and seekReadField ctxt (numtypars, hasLayout) (idx:int) = - let (flags, nameIdx, typeIdx) = seekReadFieldRow ctxt idx - let nm = readStringHeap ctxt nameIdx - let isStatic = (flags &&& 0x0010) <> 0 - let fd = - { Name = nm - Type= readBlobHeapAsFieldSig ctxt numtypars typeIdx - Attributes = enum(flags) - LiteralValue = if (flags &&& 0x8000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_FieldDef, idx))) - Marshal = - if (flags &&& 0x1000) = 0 then None else - Some (seekReadIndexedRow (ctxt.getNumRows TableNames.FieldMarshal, seekReadFieldMarshalRow ctxt, - fst, hfmCompare (TaggedIndex(hfm_FieldDef, idx)), - isSorted ctxt TableNames.FieldMarshal, - (snd >> readBlobHeapAsNativeType ctxt))) - Data = - if (flags &&& 0x0100) = 0 then None - else - let rva = seekReadIndexedRow (ctxt.getNumRows TableNames.FieldRVA, seekReadFieldRVARow ctxt, - snd, simpleIndexCompare idx, isSorted ctxt TableNames.FieldRVA, fst) - Some (rvaToData ctxt "field" rva) - Offset = - if hasLayout && not isStatic then - Some (seekReadIndexedRow (ctxt.getNumRows TableNames.FieldLayout, seekReadFieldLayoutRow ctxt, - snd, simpleIndexCompare idx, isSorted ctxt TableNames.FieldLayout, fst)) else None - CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_FieldDef, idx)) } - fd +and seekReadField ctxt mdv (numtypars, hasLayout) (idx:int) = + let (flags, nameIdx, typeIdx) = seekReadFieldRow ctxt mdv idx + let nm = readStringHeap ctxt nameIdx + let isStatic = (flags &&& 0x0010) <> 0 + ILFieldDef(name = nm, + fieldType= readBlobHeapAsFieldSig ctxt numtypars typeIdx, + attributes = enum(flags), + literalValue = (if (flags &&& 0x8000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_FieldDef, idx)))), + marshal = + (if (flags &&& 0x1000) = 0 then + None + else + Some (seekReadIndexedRow (ctxt.getNumRows TableNames.FieldMarshal, seekReadFieldMarshalRow ctxt mdv, + fst, hfmCompare (TaggedIndex(hfm_FieldDef, idx)), + isSorted ctxt TableNames.FieldMarshal, + (snd >> readBlobHeapAsNativeType ctxt)))), + data = + (if (flags &&& 0x0100) = 0 then + None + else + match ctxt.pectxtCaptured with + | None -> None // indicates metadata only, where Data is not available + | Some pectxt -> + let rva = seekReadIndexedRow (ctxt.getNumRows TableNames.FieldRVA, seekReadFieldRVARow ctxt mdv, + snd, simpleIndexCompare idx, isSorted ctxt TableNames.FieldRVA, fst) + Some (rvaToData ctxt pectxt "field" rva)), + offset = + (if hasLayout && not isStatic then + Some (seekReadIndexedRow (ctxt.getNumRows TableNames.FieldLayout, seekReadFieldLayoutRow ctxt mdv, + snd, simpleIndexCompare idx, isSorted ctxt TableNames.FieldLayout, fst)) else None), + customAttrsStored=ctxt.customAttrsReader_FieldDef, + metadataIndex = idx) -and seekReadFields ctxt (numtypars, hasLayout) fidx1 fidx2 = +and seekReadFields (ctxt: ILMetadataReader) (numtypars, hasLayout) fidx1 fidx2 = mkILFieldsLazy (lazy + let mdv = ctxt.mdfile.GetView() [ for i = fidx1 to fidx2 - 1 do - yield seekReadField ctxt (numtypars, hasLayout) i ]) + yield seekReadField ctxt mdv (numtypars, hasLayout) i ]) -and seekReadMethods ctxt numtypars midx1 midx2 = +and seekReadMethods (ctxt: ILMetadataReader) numtypars midx1 midx2 = mkILMethodsComputed (fun () -> + let mdv = ctxt.mdfile.GetView() [| for i = midx1 to midx2 - 1 do - yield seekReadMethod ctxt numtypars i |]) + yield seekReadMethod ctxt mdv numtypars i |]) and sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr = let n, sigptr = sigptrGetZInt32 bytes sigptr @@ -1933,7 +2021,7 @@ and sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr = else (* Type Ref *) TaggedIndex(tdor_TypeRef, (n >>>& 2)), sigptr -and sigptrGetTy ctxt numtypars bytes sigptr = +and sigptrGetTy (ctxt: ILMetadataReader) numtypars bytes sigptr = let b0, sigptr = sigptrGetByte bytes sigptr if b0 = et_OBJECT then ctxt.ilg.typ_Object , sigptr elif b0 = et_STRING then ctxt.ilg.typ_String, sigptr @@ -2017,10 +2105,10 @@ and sigptrGetTy ctxt numtypars bytes sigptr = elif b0 = et_SENTINEL then failwith "varargs NYI" else ILType.Void , sigptr -and sigptrGetVarArgTys ctxt n numtypars bytes sigptr = +and sigptrGetVarArgTys (ctxt: ILMetadataReader) n numtypars bytes sigptr = sigptrFold (sigptrGetTy ctxt numtypars) n bytes sigptr -and sigptrGetArgTys ctxt n numtypars bytes sigptr acc = +and sigptrGetArgTys (ctxt: ILMetadataReader) n numtypars bytes sigptr acc = if n <= 0 then (List.rev acc, None), sigptr else let b0, sigptr2 = sigptrGetByte bytes sigptr @@ -2031,7 +2119,7 @@ and sigptrGetArgTys ctxt n numtypars bytes sigptr acc = let x, sigptr = sigptrGetTy ctxt numtypars bytes sigptr sigptrGetArgTys ctxt (n-1) numtypars bytes sigptr (x::acc) -and sigptrGetLocal ctxt numtypars bytes sigptr = +and sigptrGetLocal (ctxt: ILMetadataReader) numtypars bytes sigptr = let pinned, sigptr = let b0, sigptr' = sigptrGetByte bytes sigptr if b0 = et_PINNED then @@ -2042,11 +2130,11 @@ and sigptrGetLocal ctxt numtypars bytes sigptr = let loc : ILLocal = { IsPinned = pinned; Type = typ; DebugInfo = None } loc, sigptr -and readBlobHeapAsMethodSig ctxt numtypars blobIdx = +and readBlobHeapAsMethodSig (ctxt: ILMetadataReader) numtypars blobIdx = ctxt.readBlobHeapAsMethodSig (BlobAsMethodSigIdx (numtypars, blobIdx)) and readBlobHeapAsMethodSigUncached ctxtH (BlobAsMethodSigIdx (numtypars, blobIdx)) = - let ctxt = getHole ctxtH + let (ctxt: ILMetadataReader) = getHole ctxtH let bytes = readBlobHeap ctxt blobIdx let sigptr = 0 let ccByte, sigptr = sigptrGetByte bytes sigptr @@ -2054,7 +2142,7 @@ and readBlobHeapAsMethodSigUncached ctxtH (BlobAsMethodSigIdx (numtypars, blobId let genarity, sigptr = if generic then sigptrGetZInt32 bytes sigptr else 0x0, sigptr let numparams, sigptr = sigptrGetZInt32 bytes sigptr let retty, sigptr = sigptrGetTy ctxt numtypars bytes sigptr - let (argtys, varargs), _sigptr = sigptrGetArgTys ctxt ( numparams) numtypars bytes sigptr [] + let (argtys, varargs), _sigptr = sigptrGetArgTys ctxt numparams numtypars bytes sigptr [] generic, genarity, cc, retty, argtys, varargs and readBlobHeapAsType ctxt numtypars blobIdx = @@ -2075,8 +2163,9 @@ and readBlobHeapAsFieldSigUncached ctxtH (BlobAsFieldSigIdx (numtypars, blobIdx) retty -and readBlobHeapAsPropertySig ctxt numtypars blobIdx = +and readBlobHeapAsPropertySig (ctxt: ILMetadataReader) numtypars blobIdx = ctxt.readBlobHeapAsPropertySig (BlobAsPropSigIdx (numtypars, blobIdx)) + and readBlobHeapAsPropertySigUncached ctxtH (BlobAsPropSigIdx (numtypars, blobIdx)) = let ctxt = getHole ctxtH let bytes = readBlobHeap ctxt blobIdx @@ -2090,7 +2179,7 @@ and readBlobHeapAsPropertySigUncached ctxtH (BlobAsPropSigIdx (numtypars, blobId let argtys, _sigptr = sigptrFold (sigptrGetTy ctxt numtypars) ( numparams) bytes sigptr hasthis, retty, argtys -and readBlobHeapAsLocalsSig ctxt numtypars blobIdx = +and readBlobHeapAsLocalsSig (ctxt: ILMetadataReader) numtypars blobIdx = ctxt.readBlobHeapAsLocalsSig (BlobAsLocalSigIdx (numtypars, blobIdx)) and readBlobHeapAsLocalsSigUncached ctxtH (BlobAsLocalSigIdx (numtypars, blobIdx)) = @@ -2123,11 +2212,13 @@ and byteAsCallConv b = and seekReadMemberRefAsMethodData ctxt numtypars idx : VarArgMethodData = ctxt.seekReadMemberRefAsMethodData (MemberRefAsMspecIdx (numtypars, idx)) + and seekReadMemberRefAsMethodDataUncached ctxtH (MemberRefAsMspecIdx (numtypars, idx)) = - let ctxt = getHole ctxtH - let (mrpIdx, nameIdx, typeIdx) = seekReadMemberRefRow ctxt idx + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + let (mrpIdx, nameIdx, typeIdx) = seekReadMemberRefRow ctxt mdv idx let nm = readStringHeap ctxt nameIdx - let enclTyp = seekReadMethodRefParent ctxt numtypars mrpIdx + let enclTyp = seekReadMethodRefParent ctxt mdv numtypars mrpIdx let _generic, genarity, cc, retty, argtys, varargs = readBlobHeapAsMethodSig ctxt enclTyp.GenericArgs.Length typeIdx let minst = List.init genarity (fun n -> mkILTyvarTy (uint16 (numtypars+n))) (VarArgMethodData(enclTyp, cc, nm, argtys, varargs, retty, minst)) @@ -2137,11 +2228,13 @@ and seekReadMemberRefAsMethDataNoVarArgs ctxt numtypars idx : MethodData = if Option.isSome varargs then dprintf "ignoring sentinel and varargs in ILMethodDef token signature" (MethodData(enclTyp, cc, nm, argtys, retty, minst)) -and seekReadMethodSpecAsMethodData ctxt numtypars idx = +and seekReadMethodSpecAsMethodData (ctxt: ILMetadataReader) numtypars idx = ctxt.seekReadMethodSpecAsMethodData (MethodSpecAsMspecIdx (numtypars, idx)) + and seekReadMethodSpecAsMethodDataUncached ctxtH (MethodSpecAsMspecIdx (numtypars, idx)) = - let ctxt = getHole ctxtH - let (mdorIdx, instIdx) = seekReadMethodSpecRow ctxt idx + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + let (mdorIdx, instIdx) = seekReadMethodSpecRow ctxt mdv idx let (VarArgMethodData(enclTyp, cc, nm, argtys, varargs, retty, _)) = seekReadMethodDefOrRef ctxt numtypars mdorIdx let minst = let bytes = readBlobHeap ctxt instIdx @@ -2153,13 +2246,15 @@ and seekReadMethodSpecAsMethodDataUncached ctxtH (MethodSpecAsMspecIdx (numtypar argtys VarArgMethodData(enclTyp, cc, nm, argtys, varargs, retty, minst) -and seekReadMemberRefAsFieldSpec ctxt numtypars idx = +and seekReadMemberRefAsFieldSpec (ctxt: ILMetadataReader) numtypars idx = ctxt.seekReadMemberRefAsFieldSpec (MemberRefAsFspecIdx (numtypars, idx)) + and seekReadMemberRefAsFieldSpecUncached ctxtH (MemberRefAsFspecIdx (numtypars, idx)) = - let ctxt = getHole ctxtH - let (mrpIdx, nameIdx, typeIdx) = seekReadMemberRefRow ctxt idx + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + let (mrpIdx, nameIdx, typeIdx) = seekReadMemberRefRow ctxt mdv idx let nm = readStringHeap ctxt nameIdx - let enclTyp = seekReadMethodRefParent ctxt numtypars mrpIdx + let enclTyp = seekReadMethodRefParent ctxt mdv numtypars mrpIdx let retty = readBlobHeapAsFieldSig ctxt numtypars typeIdx mkILFieldSpecInTy(enclTyp, nm, retty) @@ -2171,8 +2266,10 @@ and seekReadMemberRefAsFieldSpecUncached ctxtH (MemberRefAsFspecIdx (numtypars, // method-range and field-range start/finish indexes and seekReadMethodDefAsMethodData ctxt idx = ctxt.seekReadMethodDefAsMethodData idx + and seekReadMethodDefAsMethodDataUncached ctxtH idx = - let ctxt = getHole ctxtH + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() // Look for the method def parent. let tidx = seekReadIndexedRow (ctxt.getNumRows TableNames.TypeDef, @@ -2192,11 +2289,12 @@ and seekReadMethodDefAsMethodDataUncached ctxtH idx = let finst = mkILFormalGenericArgs 0 typeGenericArgs let minst = mkILFormalGenericArgs typeGenericArgsCount methodGenericArgs + // Read the method def parent. let enclTyp = seekReadTypeDefAsType ctxt AsObject (* not ok: see note *) finst tidx - // Return the constituent parts: put it together at the place where this is called. - let (_code_rva, _implflags, _flags, nameIdx, typeIdx, _paramIdx) = seekReadMethodRow ctxt idx + // Return the constituent parts: put it together at the place where this is called. + let (_code_rva, _implflags, _flags, nameIdx, typeIdx, _paramIdx) = seekReadMethodRow ctxt mdv idx let nm = readStringHeap ctxt nameIdx // Read the method def signature. @@ -2206,12 +2304,13 @@ and seekReadMethodDefAsMethodDataUncached ctxtH idx = MethodData(enclTyp, cc, nm, argtys, retty, minst) - (* Similarly for fields. *) -and seekReadFieldDefAsFieldSpec ctxt idx = +and seekReadFieldDefAsFieldSpec (ctxt: ILMetadataReader) idx = ctxt.seekReadFieldDefAsFieldSpec idx + and seekReadFieldDefAsFieldSpecUncached ctxtH idx = - let ctxt = getHole ctxtH - let (_flags, nameIdx, typeIdx) = seekReadFieldRow ctxt idx + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + let (_flags, nameIdx, typeIdx) = seekReadFieldRow ctxt mdv idx let nm = readStringHeap ctxt nameIdx (* Look for the field def parent. *) let tidx = @@ -2225,15 +2324,18 @@ and seekReadFieldDefAsFieldSpecUncached ctxtH idx = true, fst) // Read the field signature. let retty = readBlobHeapAsFieldSig ctxt 0 typeIdx + // Create a formal instantiation if needed let finst = mkILFormalGenericArgs 0 (seekReadGenericParams ctxt 0 (tomd_TypeDef, tidx)) + // Read the field def parent. let enclTyp = seekReadTypeDefAsType ctxt AsObject (* not ok: see note *) finst tidx + // Put it together. mkILFieldSpecInTy(enclTyp, nm, retty) -and seekReadMethod ctxt numtypars (idx:int) = - let (codeRVA, implflags, flags, nameIdx, typeIdx, paramIdx) = seekReadMethodRow ctxt idx +and seekReadMethod (ctxt: ILMetadataReader) mdv numtypars (idx:int) = + let (codeRVA, implflags, flags, nameIdx, typeIdx, paramIdx) = seekReadMethodRow ctxt mdv idx let nm = readStringHeap ctxt nameIdx let abstr = (flags &&& 0x0400) <> 0x0 let pinvoke = (flags &&& 0x2000) <> 0x0 @@ -2249,63 +2351,59 @@ and seekReadMethod ctxt numtypars (idx:int) = if idx >= ctxt.getNumRows TableNames.Method then ctxt.getNumRows TableNames.Param + 1 else - let (_, _, _, _, _, paramIdx) = seekReadMethodRow ctxt (idx + 1) + let (_, _, _, _, _, paramIdx) = seekReadMethodRow ctxt mdv (idx + 1) paramIdx - let ret, ilParams = seekReadParams ctxt (retty, argtys) paramIdx endParamIdx - - { Name=nm - Attributes = enum(flags) - ImplAttributes= enum(implflags) - SecurityDecls=seekReadSecurityDecls ctxt (TaggedIndex(hds_MethodDef, idx)) - IsEntryPoint= (fst ctxt.entryPointToken = TableNames.Method && snd ctxt.entryPointToken = idx) - GenericParams=seekReadGenericParams ctxt numtypars (tomd_MethodDef, idx) - CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_MethodDef, idx)) - Parameters= ilParams - CallingConv=cc - Return=ret - mdBody= + let ret, ilParams = seekReadParams ctxt mdv (retty, argtys) paramIdx endParamIdx + + let isEntryPoint = + let (tab, tok) = ctxt.entryPointToken + (tab = TableNames.Method && tok = idx) + + let body = if (codetype = 0x01) && pinvoke then - mkMethBodyLazyAux (notlazy MethodBody.Native) + methBodyNative elif pinvoke then - seekReadImplMap ctxt nm idx + seekReadImplMap ctxt nm idx elif internalcall || abstr || unmanaged || (codetype <> 0x00) then - //if codeRVA <> 0x0 then dprintn "non-IL or abstract method with non-zero RVA" - mkMethBodyLazyAux (notlazy MethodBody.Abstract) + methBodyAbstract else - seekReadMethodRVA ctxt (idx, nm, internalcall, noinline, aggressiveinline, numtypars) codeRVA - } + match ctxt.pectxtCaptured with + | None -> methBodyNotAvailable + | Some pectxt -> seekReadMethodRVA pectxt ctxt (idx, nm, internalcall, noinline, aggressiveinline, numtypars) codeRVA + + ILMethodDef(name=nm, + attributes = enum(flags), + implAttributes= enum(implflags), + securityDeclsStored=ctxt.securityDeclsReader_MethodDef, + isEntryPoint=isEntryPoint, + genericParams=seekReadGenericParams ctxt numtypars (tomd_MethodDef, idx), + parameters= ilParams, + callingConv=cc, + ret=ret, + body=body, + customAttrsStored=ctxt.customAttrsReader_MethodDef, + metadataIndex=idx) -and seekReadParams ctxt (retty, argtys) pidx1 pidx2 = - let retRes : ILReturn ref = ref { Marshal=None; Type=retty; CustomAttrs=emptyILCustomAttrs } - let paramsRes : ILParameter [] = - argtys - |> List.toArray - |> Array.map (fun ty -> - { Name=None - Default=None - Marshal=None - IsIn=false - IsOut=false - IsOptional=false - Type=ty - CustomAttrs=emptyILCustomAttrs }) +and seekReadParams (ctxt: ILMetadataReader) mdv (retty, argtys) pidx1 pidx2 = + let retRes = ref (mkILReturn retty) + let paramsRes = argtys |> List.toArray |> Array.map mkILParamAnon for i = pidx1 to pidx2 - 1 do - seekReadParamExtras ctxt (retRes, paramsRes) i + seekReadParamExtras ctxt mdv (retRes, paramsRes) i !retRes, List.ofArray paramsRes -and seekReadParamExtras ctxt (retRes, paramsRes) (idx:int) = - let (flags, seq, nameIdx) = seekReadParamRow ctxt idx +and seekReadParamExtras (ctxt: ILMetadataReader) mdv (retRes, paramsRes) (idx:int) = + let (flags, seq, nameIdx) = seekReadParamRow ctxt mdv idx let inOutMasked = (flags &&& 0x00FF) let hasMarshal = (flags &&& 0x2000) <> 0x0 let hasDefault = (flags &&& 0x1000) <> 0x0 - let fmReader idx = seekReadIndexedRow (ctxt.getNumRows TableNames.FieldMarshal, seekReadFieldMarshalRow ctxt, fst, hfmCompare idx, isSorted ctxt TableNames.FieldMarshal, (snd >> readBlobHeapAsNativeType ctxt)) - let cas = seekReadCustomAttrs ctxt (TaggedIndex(hca_ParamDef, idx)) + let fmReader idx = seekReadIndexedRow (ctxt.getNumRows TableNames.FieldMarshal, seekReadFieldMarshalRow ctxt mdv, fst, hfmCompare idx, isSorted ctxt TableNames.FieldMarshal, (snd >> readBlobHeapAsNativeType ctxt)) if seq = 0 then retRes := { !retRes with Marshal=(if hasMarshal then Some (fmReader (TaggedIndex(hfm_ParamDef, idx))) else None) - CustomAttrs = cas } + CustomAttrsStored = ctxt.customAttrsReader_ParamDef + MetadataIndex = idx} elif seq > Array.length paramsRes then dprintn "bad seq num. for param" else paramsRes.[seq - 1] <- @@ -2316,12 +2414,14 @@ and seekReadParamExtras ctxt (retRes, paramsRes) (idx:int) = IsIn = ((inOutMasked &&& 0x0001) <> 0x0) IsOut = ((inOutMasked &&& 0x0002) <> 0x0) IsOptional = ((inOutMasked &&& 0x0010) <> 0x0) - CustomAttrs =cas } + CustomAttrsStored = ctxt.customAttrsReader_ParamDef + MetadataIndex = idx } -and seekReadMethodImpls ctxt numtypars tidx = +and seekReadMethodImpls (ctxt: ILMetadataReader) numtypars tidx = mkILMethodImplsLazy (lazy - let mimpls = seekReadIndexedRows (ctxt.getNumRows TableNames.MethodImpl, seekReadMethodImplRow ctxt, (fun (a, _, _) -> a), simpleIndexCompare tidx, isSorted ctxt TableNames.MethodImpl, (fun (_, b, c) -> b, c)) + let mdv = ctxt.mdfile.GetView() + let mimpls = seekReadIndexedRows (ctxt.getNumRows TableNames.MethodImpl, seekReadMethodImplRow ctxt mdv, (fun (a, _, _) -> a), simpleIndexCompare tidx, isSorted ctxt TableNames.MethodImpl, (fun (_, b, c) -> b, c)) mimpls |> List.map (fun (b, c) -> { OverrideBy= let (MethodData(enclTyp, cc, nm, argtys, retty, minst)) = seekReadMethodDefOrRefNoVarargs ctxt numtypars b @@ -2331,7 +2431,7 @@ and seekReadMethodImpls ctxt numtypars tidx = let mspec = mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty, minst) OverridesSpec(mspec.MethodRef, mspec.DeclaringType) })) -and seekReadMultipleMethodSemantics ctxt (flags, id) = +and seekReadMultipleMethodSemantics (ctxt: ILMetadataReader) (flags, id) = seekReadIndexedRows (ctxt.getNumRows TableNames.MethodSemantics , seekReadMethodSemanticsRow ctxt, @@ -2356,36 +2456,38 @@ and seekReadMethodSemantics ctxt id = | None -> failwith "seekReadMethodSemantics ctxt: no method found" | Some x -> x -and seekReadEvent ctxt numtypars idx = - let (flags, nameIdx, typIdx) = seekReadEventRow ctxt idx - { Type = seekReadOptionalTypeDefOrRef ctxt numtypars AsObject typIdx - Name = readStringHeap ctxt nameIdx - Attributes = enum(flags) - AddMethod= seekReadMethodSemantics ctxt (0x0008, TaggedIndex(hs_Event, idx)) - RemoveMethod=seekReadMethodSemantics ctxt (0x0010, TaggedIndex(hs_Event, idx)) - FireMethod=seekReadoptional_MethodSemantics ctxt (0x0020, TaggedIndex(hs_Event, idx)) - OtherMethods = seekReadMultipleMethodSemantics ctxt (0x0004, TaggedIndex(hs_Event, idx)) - CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_Event, idx)) } +and seekReadEvent ctxt mdv numtypars idx = + let (flags, nameIdx, typIdx) = seekReadEventRow ctxt mdv idx + ILEventDef(eventType = seekReadOptionalTypeDefOrRef ctxt numtypars AsObject typIdx, + name = readStringHeap ctxt nameIdx, + attributes = enum(flags), + addMethod= seekReadMethodSemantics ctxt (0x0008, TaggedIndex(hs_Event, idx)), + removeMethod=seekReadMethodSemantics ctxt (0x0010, TaggedIndex(hs_Event, idx)), + fireMethod=seekReadoptional_MethodSemantics ctxt (0x0020, TaggedIndex(hs_Event, idx)), + otherMethods = seekReadMultipleMethodSemantics ctxt (0x0004, TaggedIndex(hs_Event, idx)), + customAttrsStored=ctxt.customAttrsReader_Event, + metadataIndex = idx ) - (* REVIEW: can substantially reduce numbers of EventMap and PropertyMap reads by first checking if the whole table is sorted according to ILTypeDef tokens and then doing a binary chop *) -and seekReadEvents ctxt numtypars tidx = + (* REVIEW: can substantially reduce numbers of EventMap and PropertyMap reads by first checking if the whole table mdv sorted according to ILTypeDef tokens and then doing a binary chop *) +and seekReadEvents (ctxt: ILMetadataReader) numtypars tidx = mkILEventsLazy (lazy - match seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.EventMap, (fun i -> i, seekReadEventMapRow ctxt i), (fun (_, row) -> fst row), compare tidx, false, (fun (i, row) -> (i, snd row))) with + let mdv = ctxt.mdfile.GetView() + match seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.EventMap, (fun i -> i, seekReadEventMapRow ctxt mdv i), (fun (_, row) -> fst row), compare tidx, false, (fun (i, row) -> (i, snd row))) with | None -> [] | Some (rowNum, beginEventIdx) -> let endEventIdx = if rowNum >= ctxt.getNumRows TableNames.EventMap then ctxt.getNumRows TableNames.Event + 1 else - let (_, endEventIdx) = seekReadEventMapRow ctxt (rowNum + 1) + let (_, endEventIdx) = seekReadEventMapRow ctxt mdv (rowNum + 1) endEventIdx [ for i in beginEventIdx .. endEventIdx - 1 do - yield seekReadEvent ctxt numtypars i ]) + yield seekReadEvent ctxt mdv numtypars i ]) -and seekReadProperty ctxt numtypars idx = - let (flags, nameIdx, typIdx) = seekReadPropertyRow ctxt idx +and seekReadProperty ctxt mdv numtypars idx = + let (flags, nameIdx, typIdx) = seekReadPropertyRow ctxt mdv idx let cc, retty, argtys = readBlobHeapAsPropertySig ctxt numtypars typIdx let setter= seekReadoptional_MethodSemantics ctxt (0x0001, TaggedIndex(hs_Property, idx)) let getter = seekReadoptional_MethodSemantics ctxt (0x0002, TaggedIndex(hs_Property, idx)) @@ -2398,38 +2500,42 @@ and seekReadProperty ctxt numtypars idx = match setter with | Some mref -> mref.CallingConv .ThisConv | None -> cc - { Name=readStringHeap ctxt nameIdx - CallingConv = cc2 - Attributes = enum(flags) - SetMethod=setter - GetMethod=getter - Type=retty - Init= if (flags &&& 0x1000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_Property, idx))) - Args=argtys - CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_Property, idx)) } + + ILPropertyDef(name=readStringHeap ctxt nameIdx, + callingConv = cc2, + attributes = enum(flags), + setMethod=setter, + getMethod=getter, + propertyType=retty, + init= (if (flags &&& 0x1000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_Property, idx)))), + args=argtys, + customAttrsStored=ctxt.customAttrsReader_Property, + metadataIndex = idx ) -and seekReadProperties ctxt numtypars tidx = +and seekReadProperties (ctxt: ILMetadataReader) numtypars tidx = mkILPropertiesLazy (lazy - match seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.PropertyMap, (fun i -> i, seekReadPropertyMapRow ctxt i), (fun (_, row) -> fst row), compare tidx, false, (fun (i, row) -> (i, snd row))) with + let mdv = ctxt.mdfile.GetView() + match seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.PropertyMap, (fun i -> i, seekReadPropertyMapRow ctxt mdv i), (fun (_, row) -> fst row), compare tidx, false, (fun (i, row) -> (i, snd row))) with | None -> [] | Some (rowNum, beginPropIdx) -> let endPropIdx = if rowNum >= ctxt.getNumRows TableNames.PropertyMap then ctxt.getNumRows TableNames.Property + 1 else - let (_, endPropIdx) = seekReadPropertyMapRow ctxt (rowNum + 1) + let (_, endPropIdx) = seekReadPropertyMapRow ctxt mdv (rowNum + 1) endPropIdx [ for i in beginPropIdx .. endPropIdx - 1 do - yield seekReadProperty ctxt numtypars i ]) + yield seekReadProperty ctxt mdv numtypars i ]) -and seekReadCustomAttrs ctxt idx = - mkILComputedCustomAttrs - (fun () -> +and customAttrsReader ctxtH tag : ILAttributesStored = + mkILCustomAttrsReader + (fun idx -> + let (ctxt: ILMetadataReader) = getHole ctxtH seekReadIndexedRows (ctxt.getNumRows TableNames.CustomAttribute, seekReadCustomAttributeRow ctxt, (fun (a, _, _) -> a), - hcaCompare idx, + hcaCompare (TaggedIndex(tag,idx)), isSorted ctxt TableNames.CustomAttribute, (fun (_, b, c) -> seekReadCustomAttr ctxt (b, c))) |> List.toArray) @@ -2446,26 +2552,24 @@ and seekReadCustomAttrUncached ctxtH (CustomAttrIdx (cat, idx, valIdx)) = | None -> Bytes.ofInt32Array [| |] Elements = [] } -and seekReadSecurityDecls ctxt idx = - mkILLazySecurityDecls - (lazy +and securityDeclsReader ctxtH tag = + mkILSecurityDeclsReader + (fun idx -> + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() seekReadIndexedRows (ctxt.getNumRows TableNames.Permission, - seekReadPermissionRow ctxt, + seekReadPermissionRow ctxt mdv, (fun (_, par, _) -> par), - hdsCompare idx, + hdsCompare (TaggedIndex(tag,idx)), isSorted ctxt TableNames.Permission, - (fun (act, _, ty) -> seekReadSecurityDecl ctxt (act, ty)))) - -and seekReadSecurityDecl ctxt (a, b) = - ctxt.seekReadSecurityDecl (SecurityDeclIdx (a, b)) - -and seekReadSecurityDeclUncached ctxtH (SecurityDeclIdx (act, ty)) = - let ctxt = getHole ctxtH - PermissionSet ((if List.memAssoc (int act) (Lazy.force ILSecurityActionRevMap) then List.assoc (int act) (Lazy.force ILSecurityActionRevMap) else failwith "unknown security action"), - readBlobHeap ctxt ty) + (fun (act, _, ty) -> seekReadSecurityDecl ctxt (act, ty))) + |> List.toArray) +and seekReadSecurityDecl ctxt (act, ty) = + ILSecurityDecl ((if List.memAssoc (int act) (Lazy.force ILSecurityActionRevMap) then List.assoc (int act) (Lazy.force ILSecurityActionRevMap) else failwith "unknown security action"), + readBlobHeap ctxt ty) -and seekReadConstant ctxt idx = +and seekReadConstant (ctxt: ILMetadataReader) idx = let kind, vidx = seekReadIndexedRow (ctxt.getNumRows TableNames.Constant, seekReadConstantRow ctxt, (fun (_, key, _) -> key), @@ -2490,11 +2594,12 @@ and seekReadConstant ctxt idx = | x when x = uint16 et_CLASS || x = uint16 et_OBJECT -> ILFieldInit.Null | _ -> ILFieldInit.Null -and seekReadImplMap ctxt nm midx = +and seekReadImplMap (ctxt: ILMetadataReader) nm midx = mkMethBodyLazyAux (lazy + let mdv = ctxt.mdfile.GetView() let (flags, nameIdx, scopeIdx) = seekReadIndexedRow (ctxt.getNumRows TableNames.ImplMap, - seekReadImplMapRow ctxt, + seekReadImplMapRow ctxt mdv, (fun (_, m, _, _) -> m), mfCompare (TaggedIndex(mf_MethodDef, midx)), isSorted ctxt TableNames.ImplMap, @@ -2508,6 +2613,7 @@ and seekReadImplMap ctxt nm midx = elif masked = 0x0500 then PInvokeCallingConvention.Fastcall elif masked = 0x0100 then PInvokeCallingConvention.WinApi else (dprintn "strange CallingConv"; PInvokeCallingConvention.None) + let enc = let masked = flags &&& 0x0006 if masked = 0x0000 then PInvokeCharEncoding.None @@ -2515,12 +2621,14 @@ and seekReadImplMap ctxt nm midx = elif masked = 0x0004 then PInvokeCharEncoding.Unicode elif masked = 0x0006 then PInvokeCharEncoding.Auto else (dprintn "strange CharEncoding"; PInvokeCharEncoding.None) + let bestfit = let masked = flags &&& 0x0030 if masked = 0x0000 then PInvokeCharBestFit.UseAssembly elif masked = 0x0010 then PInvokeCharBestFit.Enabled elif masked = 0x0020 then PInvokeCharBestFit.Disabled else (dprintn "strange CharBestFit"; PInvokeCharBestFit.UseAssembly) + let unmap = let masked = flags &&& 0x3000 if masked = 0x0000 then PInvokeThrowOnUnmappableChar.UseAssembly @@ -2538,9 +2646,9 @@ and seekReadImplMap ctxt nm midx = (match readStringHeapOption ctxt nameIdx with | None -> nm | Some nm2 -> nm2) - Where = seekReadModuleRef ctxt scopeIdx }) + Where = seekReadModuleRef ctxt mdv scopeIdx }) -and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = +and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numtypars (sz:int) start seqpoints = let labelsOfRawOffsets = new Dictionary<_, _>(sz/2) let ilOffsetsOfLabels = new Dictionary<_, _>(sz/2) let tryRawToLabel rawOffset = @@ -2568,11 +2676,11 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = let lastb2 = ref 0x0 let b = ref 0x0 let get () = - lastb := seekReadByteAsInt32 ctxt.is (start + (!curr)) + lastb := seekReadByteAsInt32 pev (start + (!curr)) incr curr b := if !lastb = 0xfe && !curr < sz then - lastb2 := seekReadByteAsInt32 ctxt.is (start + (!curr)) + lastb2 := seekReadByteAsInt32 pev (start + (!curr)) incr curr !lastb2 else @@ -2612,7 +2720,7 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = !b = (i_tail &&& 0xff)) do begin if !b = (i_unaligned &&& 0xff) then - let unal = seekReadByteAsInt32 ctxt.is (start + (!curr)) + let unal = seekReadByteAsInt32 pev (start + (!curr)) incr curr prefixes.al <- if unal = 0x1 then Unaligned1 @@ -2622,7 +2730,7 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = elif !b = (i_volatile &&& 0xff) then prefixes.vol <- Volatile elif !b = (i_readonly &&& 0xff) then prefixes.ro <- ReadonlyAddress elif !b = (i_constrained &&& 0xff) then - let uncoded = seekReadUncodedToken ctxt.is (start + (!curr)) + let uncoded = seekReadUncodedToken pev (start + (!curr)) curr := !curr + 4 let typ = seekReadTypeDefOrRef ctxt numtypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec uncoded) prefixes.constrained <- Some typ @@ -2640,37 +2748,37 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = let instr = match idecoder with | I_u16_u8_instr f -> - let x = seekReadByte ctxt.is (start + (!curr)) |> uint16 + let x = seekReadByte pev (start + (!curr)) |> uint16 curr := !curr + 1 f prefixes x | I_u16_u16_instr f -> - let x = seekReadUInt16 ctxt.is (start + (!curr)) + let x = seekReadUInt16 pev (start + (!curr)) curr := !curr + 2 f prefixes x | I_none_instr f -> f prefixes | I_i64_instr f -> - let x = seekReadInt64 ctxt.is (start + (!curr)) + let x = seekReadInt64 pev (start + (!curr)) curr := !curr + 8 f prefixes x | I_i32_i8_instr f -> - let x = seekReadSByte ctxt.is (start + (!curr)) |> int32 + let x = seekReadSByte pev (start + (!curr)) |> int32 curr := !curr + 1 f prefixes x | I_i32_i32_instr f -> - let x = seekReadInt32 ctxt.is (start + (!curr)) + let x = seekReadInt32 pev (start + (!curr)) curr := !curr + 4 f prefixes x | I_r4_instr f -> - let x = seekReadSingle ctxt.is (start + (!curr)) + let x = seekReadSingle pev (start + (!curr)) curr := !curr + 4 f prefixes x | I_r8_instr f -> - let x = seekReadDouble ctxt.is (start + (!curr)) + let x = seekReadDouble pev (start + (!curr)) curr := !curr + 8 f prefixes x | I_field_instr f -> - let (tab, tok) = seekReadUncodedToken ctxt.is (start + (!curr)) + let (tab, tok) = seekReadUncodedToken pev (start + (!curr)) curr := !curr + 4 let fspec = if tab = TableNames.Field then @@ -2682,7 +2790,7 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = | I_method_instr f -> // method instruction, curr = "+string !curr - let (tab, idx) = seekReadUncodedToken ctxt.is (start + (!curr)) + let (tab, idx) = seekReadUncodedToken pev (start + (!curr)) curr := !curr + 4 let (VarArgMethodData(enclTyp, cc, nm, argtys, varargs, retty, minst)) = if tab = TableNames.Method then @@ -2704,33 +2812,33 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = let mspec = mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty, minst) f prefixes (mspec, varargs) | I_type_instr f -> - let uncoded = seekReadUncodedToken ctxt.is (start + (!curr)) + let uncoded = seekReadUncodedToken pev (start + (!curr)) curr := !curr + 4 let typ = seekReadTypeDefOrRef ctxt numtypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec uncoded) f prefixes typ | I_string_instr f -> - let (tab, idx) = seekReadUncodedToken ctxt.is (start + (!curr)) + let (tab, idx) = seekReadUncodedToken pev (start + (!curr)) curr := !curr + 4 if tab <> TableNames.UserStrings then dprintn "warning: bad table in user string for ldstr" f prefixes (readUserStringHeap ctxt (idx)) | I_conditional_i32_instr f -> - let offsDest = (seekReadInt32 ctxt.is (start + (!curr))) + let offsDest = (seekReadInt32 pev (start + (!curr))) curr := !curr + 4 let dest = !curr + offsDest f prefixes (rawToLabel dest) | I_conditional_i8_instr f -> - let offsDest = int (seekReadSByte ctxt.is (start + (!curr))) + let offsDest = int (seekReadSByte pev (start + (!curr))) curr := !curr + 1 let dest = !curr + offsDest f prefixes (rawToLabel dest) | I_unconditional_i32_instr f -> - let offsDest = (seekReadInt32 ctxt.is (start + (!curr))) + let offsDest = (seekReadInt32 pev (start + (!curr))) curr := !curr + 4 let dest = !curr + offsDest f prefixes (rawToLabel dest) | I_unconditional_i8_instr f -> - let offsDest = int (seekReadSByte ctxt.is (start + (!curr))) + let offsDest = int (seekReadSByte pev (start + (!curr))) curr := !curr + 1 let dest = !curr + offsDest f prefixes (rawToLabel dest) @@ -2738,7 +2846,7 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = dprintn ("invalid instruction: "+string !lastb+ (if !lastb = 0xfe then ", "+string !lastb2 else "")) I_ret | I_tok_instr f -> - let (tab, idx) = seekReadUncodedToken ctxt.is (start + (!curr)) + let (tab, idx) = seekReadUncodedToken pev (start + (!curr)) curr := !curr + 4 (* REVIEW: this incorrectly labels all MemberRef tokens as ILMethod's: we should go look at the MemberRef sig to determine if it is a field or method *) let token_info = @@ -2752,18 +2860,18 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = else failwith "bad token for ldtoken" f prefixes token_info | I_sig_instr f -> - let (tab, idx) = seekReadUncodedToken ctxt.is (start + (!curr)) + let (tab, idx) = seekReadUncodedToken pev (start + (!curr)) curr := !curr + 4 if tab <> TableNames.StandAloneSig then dprintn "strange table for callsig token" - let generic, _genarity, cc, retty, argtys, varargs = readBlobHeapAsMethodSig ctxt numtypars (seekReadStandAloneSigRow ctxt idx) - if generic then failwith "bad image: a generic method signature ctxt.is begin used at a calli instruction" + let generic, _genarity, cc, retty, argtys, varargs = readBlobHeapAsMethodSig ctxt numtypars (seekReadStandAloneSigRow ctxt mdv idx) + if generic then failwith "bad image: a generic method signature is begin used at a calli instruction" f prefixes (mkILCallSig (cc, argtys, retty), varargs) | I_switch_instr f -> - let n = (seekReadInt32 ctxt.is (start + (!curr))) + let n = (seekReadInt32 pev (start + (!curr))) curr := !curr + 4 let offsets = List.init n (fun _ -> - let i = (seekReadInt32 ctxt.is (start + (!curr))) + let i = (seekReadInt32 pev (start + (!curr))) curr := !curr + 4 i) let dests = List.map (fun offs -> rawToLabel (!curr + offs)) offsets @@ -2791,13 +2899,14 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = instrs, rawToLabel, lab2pc, raw2nextLab #if FX_NO_PDB_READER -and seekReadMethodRVA ctxt (_idx, nm, _internalcall, noinline, aggressiveinline, numtypars) rva = +and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (_idx, nm, _internalcall, noinline, aggressiveinline, numtypars) rva = #else -and seekReadMethodRVA ctxt (idx, nm, _internalcall, noinline, aggressiveinline, numtypars) rva = +and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _internalcall, noinline, aggressiveinline, numtypars) rva = #endif mkMethBodyLazyAux (lazy - begin + let pev = pectxt.pefile.GetView() + let mdv = ctxt.mdfile.GetView() // Read any debug information for this method into temporary data structures // -- a list of locals, marked with the raw offsets (actually closures which accept the resolution function that maps raw offsets to labels) @@ -2807,7 +2916,7 @@ and seekReadMethodRVA ctxt (idx, nm, _internalcall, noinline, aggressiveinline, #if FX_NO_PDB_READER [], None, [] #else - match ctxt.pdb with + match pectxt.pdb with | None -> [], None, [] | Some (pdbr, get_doc) -> @@ -2863,14 +2972,14 @@ and seekReadMethodRVA ctxt (idx, nm, _internalcall, noinline, aggressiveinline, [], None, [] #endif - let baseRVA = ctxt.anyV2P("method rva", rva) + let baseRVA = pectxt.anyV2P("method rva", rva) // ": reading body of method "+nm+" at rva "+string rva+", phys "+string baseRVA - let b = seekReadByte ctxt.is baseRVA + let b = seekReadByte pev baseRVA if (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_TinyFormat then let codeBase = baseRVA + 1 let codeSize = (int32 b >>>& 2) // tiny format for "+nm+", code size = " + string codeSize) - let instrs, _, lab2pc, raw2nextLab = seekReadTopCode ctxt numtypars codeSize codeBase seqpoints + let instrs, _, lab2pc, raw2nextLab = seekReadTopCode ctxt pev mdv numtypars codeSize codeBase seqpoints (* Convert the linear code format to the nested code format *) let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos let code = buildILCode nm lab2pc instrs [] localPdbInfos2 @@ -2886,20 +2995,20 @@ and seekReadMethodRVA ctxt (idx, nm, _internalcall, noinline, aggressiveinline, elif (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_FatFormat then let hasMoreSections = (b &&& e_CorILMethod_MoreSects) <> 0x0uy let initlocals = (b &&& e_CorILMethod_InitLocals) <> 0x0uy - let maxstack = seekReadUInt16AsInt32 ctxt.is (baseRVA + 2) - let codeSize = seekReadInt32 ctxt.is (baseRVA + 4) - let localsTab, localToken = seekReadUncodedToken ctxt.is (baseRVA + 8) + let maxstack = seekReadUInt16AsInt32 pev (baseRVA + 2) + let codeSize = seekReadInt32 pev (baseRVA + 4) + let localsTab, localToken = seekReadUncodedToken pev (baseRVA + 8) let codeBase = baseRVA + 12 let locals = if localToken = 0x0 then [] else if localsTab <> TableNames.StandAloneSig then dprintn "strange table for locals token" - readBlobHeapAsLocalsSig ctxt numtypars (seekReadStandAloneSigRow ctxt localToken) + readBlobHeapAsLocalsSig ctxt numtypars (seekReadStandAloneSigRow ctxt pev localToken) // fat format for "+nm+", code size = " + string codeSize+", hasMoreSections = "+(if hasMoreSections then "true" else "false")+", b = "+string b) // Read the method body - let instrs, rawToLabel, lab2pc, raw2nextLab = seekReadTopCode ctxt numtypars ( codeSize) codeBase seqpoints + let instrs, rawToLabel, lab2pc, raw2nextLab = seekReadTopCode ctxt pev mdv numtypars ( codeSize) codeBase seqpoints // Read all the sections that follow the method body. // These contain the exception clauses. @@ -2908,11 +3017,11 @@ and seekReadMethodRVA ctxt (idx, nm, _internalcall, noinline, aggressiveinline, let seh = ref [] while !moreSections do let sectionBase = !nextSectionBase - let sectionFlag = seekReadByte ctxt.is sectionBase + let sectionFlag = seekReadByte pev sectionBase // fat format for "+nm+", sectionFlag = " + string sectionFlag) let sectionSize, clauses = if (sectionFlag &&& e_CorILMethod_Sect_FatFormat) <> 0x0uy then - let bigSize = (seekReadInt32 ctxt.is sectionBase) >>>& 8 + let bigSize = (seekReadInt32 pev sectionBase) >>>& 8 // bigSize = "+string bigSize) let clauses = if (sectionFlag &&& e_CorILMethod_Sect_EHTable) <> 0x0uy then @@ -2923,17 +3032,17 @@ and seekReadMethodRVA ctxt (idx, nm, _internalcall, noinline, aggressiveinline, List.init numClauses (fun i -> let clauseBase = sectionBase + 4 + (i * 24) - let kind = seekReadInt32 ctxt.is (clauseBase + 0) - let st1 = seekReadInt32 ctxt.is (clauseBase + 4) - let sz1 = seekReadInt32 ctxt.is (clauseBase + 8) - let st2 = seekReadInt32 ctxt.is (clauseBase + 12) - let sz2 = seekReadInt32 ctxt.is (clauseBase + 16) - let extra = seekReadInt32 ctxt.is (clauseBase + 20) + let kind = seekReadInt32 pev (clauseBase + 0) + let st1 = seekReadInt32 pev (clauseBase + 4) + let sz1 = seekReadInt32 pev (clauseBase + 8) + let st2 = seekReadInt32 pev (clauseBase + 12) + let sz2 = seekReadInt32 pev (clauseBase + 16) + let extra = seekReadInt32 pev (clauseBase + 20) (kind, st1, sz1, st2, sz2, extra)) else [] bigSize, clauses else - let smallSize = seekReadByteAsInt32 ctxt.is (sectionBase + 0x01) + let smallSize = seekReadByteAsInt32 pev (sectionBase + 0x01) let clauses = if (sectionFlag &&& e_CorILMethod_Sect_EHTable) <> 0x0uy then // WORKAROUND: The ECMA spec says this should be @@ -2943,13 +3052,13 @@ and seekReadMethodRVA ctxt (idx, nm, _internalcall, noinline, aggressiveinline, // dprintn (nm+" has " + string numClauses + " tiny seh clauses") List.init numClauses (fun i -> let clauseBase = sectionBase + 4 + (i * 12) - let kind = seekReadUInt16AsInt32 ctxt.is (clauseBase + 0) + let kind = seekReadUInt16AsInt32 pev (clauseBase + 0) if logging then dprintn ("One tiny SEH clause, kind = "+string kind) - let st1 = seekReadUInt16AsInt32 ctxt.is (clauseBase + 2) - let sz1 = seekReadByteAsInt32 ctxt.is (clauseBase + 4) - let st2 = seekReadUInt16AsInt32 ctxt.is (clauseBase + 5) - let sz2 = seekReadByteAsInt32 ctxt.is (clauseBase + 7) - let extra = seekReadInt32 ctxt.is (clauseBase + 8) + let st1 = seekReadUInt16AsInt32 pev (clauseBase + 2) + let sz1 = seekReadByteAsInt32 pev (clauseBase + 4) + let st2 = seekReadUInt16AsInt32 pev (clauseBase + 5) + let sz2 = seekReadByteAsInt32 pev (clauseBase + 7) + let extra = seekReadInt32 pev (clauseBase + 8) (kind, st1, sz1, st2, sz2, extra)) else [] @@ -2977,7 +3086,7 @@ and seekReadMethodRVA ctxt (idx, nm, _internalcall, noinline, aggressiveinline, elif kind = e_COR_ILEXCEPTION_CLAUSE_FAULT then ILExceptionClause.Fault(handlerStart, handlerFinish) else begin - dprintn (ctxt.infile + ": unknown exception handler kind: "+string kind) + dprintn (ctxt.fileName + ": unknown exception handler kind: "+string kind) ILExceptionClause.Finally(handlerStart, handlerFinish) end @@ -3010,16 +3119,15 @@ and seekReadMethodRVA ctxt (idx, nm, _internalcall, noinline, aggressiveinline, SourceMarker=methRangePdbInfo} else if logging then failwith "unknown format" - MethodBody.Abstract - end) + MethodBody.Abstract) -and int32AsILVariantType ctxt (n:int32) = +and int32AsILVariantType (ctxt: ILMetadataReader) (n:int32) = if List.memAssoc n (Lazy.force ILVariantTypeRevMap) then List.assoc n (Lazy.force ILVariantTypeRevMap) elif (n &&& vt_ARRAY) <> 0x0 then ILNativeVariant.Array (int32AsILVariantType ctxt (n &&& (~~~ vt_ARRAY))) elif (n &&& vt_VECTOR) <> 0x0 then ILNativeVariant.Vector (int32AsILVariantType ctxt (n &&& (~~~ vt_VECTOR))) elif (n &&& vt_BYREF) <> 0x0 then ILNativeVariant.Byref (int32AsILVariantType ctxt (n &&& (~~~ vt_BYREF))) - else (dprintn (ctxt.infile + ": int32AsILVariantType ctxt: unexpected variant type, n = "+string n) ; ILNativeVariant.Empty) + else (dprintn (ctxt.fileName + ": int32AsILVariantType ctxt: unexpected variant type, n = "+string n) ; ILNativeVariant.Empty) and readBlobHeapAsNativeType ctxt blobIdx = // reading native type blob "+string blobIdx) @@ -3094,28 +3202,32 @@ and sigptrGetILNativeType ctxt bytes sigptr = ILNativeType.Array (Some nt, Some(pnum, Some(additive))), sigptr else (ILNativeType.Empty, sigptr) -and seekReadManifestResources ctxt () = - mkILResourcesLazy - (lazy - [ for i = 1 to ctxt.getNumRows TableNames.ManifestResource do - let (offset, flags, nameIdx, implIdx) = seekReadManifestResourceRow ctxt i - let scoref = seekReadImplAsScopeRef ctxt implIdx - let datalab = +// Note, pectxtEager and pevEager must not be captured by the results of this function +// As a result, reading the resource offsets in the physical file is done eagerly to avoid holding on to any resources +and seekReadManifestResources (ctxt: ILMetadataReader) (mdv: BinaryView) (pectxtEager: PEReader) (pevEager: BinaryView) = + mkILResources + [ for i = 1 to ctxt.getNumRows TableNames.ManifestResource do + let (offset, flags, nameIdx, implIdx) = seekReadManifestResourceRow ctxt mdv i + + let scoref = seekReadImplAsScopeRef ctxt mdv implIdx + + let location = match scoref with | ILScopeRef.Local -> - let start = ctxt.anyV2P ("resource", offset + ctxt.resourcesAddr) - let len = seekReadInt32 ctxt.is start - ILResourceLocation.Local (fun () -> seekReadBytes ctxt.is (start + 4) len) + let start = pectxtEager.anyV2P ("resource", offset + pectxtEager.resourcesAddr) + let resourceLength = seekReadInt32 pevEager start + let offsetOfBytesFromStartOfPhysicalPEFile = start + 4 + ILResourceLocation.LocalIn (ctxt.fileName, offsetOfBytesFromStartOfPhysicalPEFile, resourceLength) | ILScopeRef.Module mref -> ILResourceLocation.File (mref, offset) | ILScopeRef.Assembly aref -> ILResourceLocation.Assembly aref let r = { Name= readStringHeap ctxt nameIdx - Location = datalab + Location = location Access = (if (flags &&& 0x01) <> 0x0 then ILResourceAccess.Public else ILResourceAccess.Private) - CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_ManifestResource, i)) } - yield r ]) - + CustomAttrsStored = ctxt.customAttrsReader_ManifestResource + MetadataIndex = i } + yield r ] and seekReadNestedExportedTypes ctxt (exported: _ array) (nested: Lazy<_ array>) parentIdx = mkILNestedExportedTypesLazy @@ -3128,14 +3240,16 @@ and seekReadNestedExportedTypes ctxt (exported: _ array) (nested: Lazy<_ array>) | ILTypeDefAccess.Nested n -> n | _ -> failwith "non-nested access for a nested type described as being in an auxiliary module") Nested = seekReadNestedExportedTypes ctxt exported nested i - CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_ExportedType, i)) } + CustomAttrsStored = ctxt.customAttrsReader_ExportedType + MetadataIndex = i } )) -and seekReadTopExportedTypes ctxt () = +and seekReadTopExportedTypes (ctxt: ILMetadataReader) = mkILExportedTypesLazy (lazy + let mdv = ctxt.mdfile.GetView() let numRows = ctxt.getNumRows TableNames.ExportedType - let exported = [| for i in 1..numRows -> seekReadExportedTypeRow ctxt i |] + let exported = [| for i in 1..numRows -> seekReadExportedTypeRow ctxt mdv i |] // add each nested type id to their parent's children list let nested = lazy ( @@ -3154,20 +3268,21 @@ and seekReadTopExportedTypes ctxt () = // if not a nested type if (isTopTypeDef flags) && (tag <> i_ExportedType) then yield - { ScopeRef = seekReadImplAsScopeRef ctxt implIdx + { ScopeRef = seekReadImplAsScopeRef ctxt mdv implIdx Name = readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) Attributes = enum(flags) Nested = seekReadNestedExportedTypes ctxt exported nested i - CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_ExportedType, i)) } + CustomAttrsStored = ctxt.customAttrsReader_ExportedType + MetadataIndex = i } ]) #if !FX_NO_PDB_READER -let getPdbReader opts infile = - match opts.pdbPath with +let getPdbReader pdbPath fileName = + match pdbPath with | None -> None | Some pdbpath -> try - let pdbr = pdbReadOpen infile pdbpath + let pdbr = pdbReadOpen fileName pdbpath let pdbdocs = pdbReaderGetDocuments pdbr let tab = new Dictionary<_, _>(Array.length pdbdocs) @@ -3184,215 +3299,34 @@ let getPdbReader opts infile = with e -> dprintn ("* Warning: PDB file could not be read and will be ignored: "+e.Message); None #endif -//----------------------------------------------------------------------- -// Crack the binary headers, build a reader context and return the lazy -// read of the AbsIL module. -// ---------------------------------------------------------------------- - -let rec genOpenBinaryReader infile is opts = - - (* MSDOS HEADER *) - let peSignaturePhysLoc = seekReadInt32 is 0x3c - - (* PE HEADER *) - let peFileHeaderPhysLoc = peSignaturePhysLoc + 0x04 - let peOptionalHeaderPhysLoc = peFileHeaderPhysLoc + 0x14 - let peSignature = seekReadInt32 is (peSignaturePhysLoc + 0) - if peSignature <> 0x4550 then failwithf "not a PE file - bad magic PE number 0x%08x, is = %A" peSignature is - - - (* PE SIGNATURE *) - let machine = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 0) - let numSections = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 2) - let optHeaderSize = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 16) - if optHeaderSize <> 0xe0 && - optHeaderSize <> 0xf0 then failwith "not a PE file - bad optional header size" - let x64adjust = optHeaderSize - 0xe0 - let only64 = (optHeaderSize = 0xf0) (* May want to read in the optional header Magic number and check that as well... *) - let platform = match machine with | 0x8664 -> Some(AMD64) | 0x200 -> Some(IA64) | _ -> Some(X86) - let sectionHeadersStartPhysLoc = peOptionalHeaderPhysLoc + optHeaderSize - - let flags = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 18) - let isDll = (flags &&& 0x2000) <> 0x0 - - (* OPTIONAL PE HEADER *) - let _textPhysSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 4) (* Size of the code (text) section, or the sum of all code sections if there are multiple sections. *) - (* x86: 000000a0 *) - let _initdataPhysSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 8) (* Size of the initialized data section, or the sum of all such sections if there are multiple data sections. *) - let _uninitdataPhysSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 12) (* Size of the uninitialized data section, or the sum of all such sections if there are multiple data sections. *) - let _entrypointAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 16) (* RVA of entry point , needs to point to bytes 0xFF 0x25 followed by the RVA+!0x4000000 in a section marked execute/read for EXEs or 0 for DLLs e.g. 0x0000b57e *) - let _textAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 20) (* e.g. 0x0002000 *) - (* x86: 000000b0 *) - let dataSegmentAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 24) (* e.g. 0x0000c000 *) - (* REVIEW: For now, we'll use the DWORD at offset 24 for x64. This currently ok since fsc doesn't support true 64-bit image bases, - but we'll have to fix this up when such support is added. *) - let imageBaseReal = if only64 then dataSegmentAddr else seekReadInt32 is (peOptionalHeaderPhysLoc + 28) (* Image Base Always 0x400000 (see Section 23.1). - QUERY : no it's not always 0x400000, e.g. 0x034f0000 *) - let alignVirt = seekReadInt32 is (peOptionalHeaderPhysLoc + 32) (* Section Alignment Always 0x2000 (see Section 23.1). *) - let alignPhys = seekReadInt32 is (peOptionalHeaderPhysLoc + 36) (* File Alignment Either 0x200 or 0x1000. *) - (* x86: 000000c0 *) - let _osMajor = seekReadUInt16 is (peOptionalHeaderPhysLoc + 40) (* OS Major Always 4 (see Section 23.1). *) - let _osMinor = seekReadUInt16 is (peOptionalHeaderPhysLoc + 42) (* OS Minor Always 0 (see Section 23.1). *) - let _userMajor = seekReadUInt16 is (peOptionalHeaderPhysLoc + 44) (* User Major Always 0 (see Section 23.1). *) - let _userMinor = seekReadUInt16 is (peOptionalHeaderPhysLoc + 46) (* User Minor Always 0 (see Section 23.1). *) - let subsysMajor = seekReadUInt16AsInt32 is (peOptionalHeaderPhysLoc + 48) (* SubSys Major Always 4 (see Section 23.1). *) - let subsysMinor = seekReadUInt16AsInt32 is (peOptionalHeaderPhysLoc + 50) (* SubSys Minor Always 0 (see Section 23.1). *) - (* x86: 000000d0 *) - let _imageEndAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 56) (* Image Size: Size, in bytes, of image, including all headers and padding; shall be a multiple of Section Alignment. e.g. 0x0000e000 *) - let _headerPhysSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 60) (* Header Size Combined size of MS-DOS Header, PE Header, PE Optional Header and padding; shall be a multiple of the file alignment. *) - let subsys = seekReadUInt16 is (peOptionalHeaderPhysLoc + 68) (* SubSystem Subsystem required to run this image. Shall be either IMAGE_SUBSYSTEM_WINDOWS_CE_GUI (!0x3) or IMAGE_SUBSYSTEM_WINDOWS_GUI (!0x2). QUERY: Why is this 3 on the images ILASM produces??? *) - let useHighEnthropyVA = - let n = seekReadUInt16 is (peOptionalHeaderPhysLoc + 70) - let highEnthropyVA = 0x20us - (n &&& highEnthropyVA) = highEnthropyVA - - (* x86: 000000e0 *) - - (* WARNING: THESE ARE 64 bit ON x64/ia64 *) - (* REVIEW: If we ever decide that we need these values for x64, we'll have to read them in as 64bit and fix up the rest of the offsets. - Then again, it should suffice to just use the defaults, and still not bother... *) - (* let stackReserve = seekReadInt32 is (peOptionalHeaderPhysLoc + 72) in *) (* Stack Reserve Size Always 0x100000 (1Mb) (see Section 23.1). *) - (* let stackCommit = seekReadInt32 is (peOptionalHeaderPhysLoc + 76) in *) (* Stack Commit Size Always 0x1000 (4Kb) (see Section 23.1). *) - (* let heapReserve = seekReadInt32 is (peOptionalHeaderPhysLoc + 80) in *) (* Heap Reserve Size Always 0x100000 (1Mb) (see Section 23.1). *) - (* let heapCommit = seekReadInt32 is (peOptionalHeaderPhysLoc + 84) in *) (* Heap Commit Size Always 0x1000 (4Kb) (see Section 23.1). *) - - (* x86: 000000f0, x64: 00000100 *) - let _numDataDirectories = seekReadInt32 is (peOptionalHeaderPhysLoc + 92 + x64adjust) (* Number of Data Directories: Always 0x10 (see Section 23.1). *) - (* 00000100 - these addresses are for x86 - for the x64 location, add x64adjust (0x10) *) - let _importTableAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 104 + x64adjust) (* Import Table RVA of Import Table, (see clause 24.3.1). e.g. 0000b530 *) - let _importTableSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 108 + x64adjust) (* Size of Import Table, (see clause 24.3.1). *) - let nativeResourcesAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 112 + x64adjust) - let nativeResourcesSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 116 + x64adjust) - (* 00000110 *) - (* 00000120 *) - (* let base_relocTableNames.addr = seekReadInt32 is (peOptionalHeaderPhysLoc + 136) - let base_relocTableNames.size = seekReadInt32 is (peOptionalHeaderPhysLoc + 140) in *) - (* 00000130 *) - (* 00000140 *) - (* 00000150 *) - let _importAddrTableAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 192 + x64adjust) (* RVA of Import Addr Table, (see clause 24.3.1). e.g. 0x00002000 *) - let _importAddrTableSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 196 + x64adjust) (* Size of Import Addr Table, (see clause 24.3.1). e.g. 0x00002000 *) - (* 00000160 *) - let cliHeaderAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 208 + x64adjust) - let _cliHeaderSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 212 + x64adjust) - (* 00000170 *) - - - (* Crack section headers *) - - let sectionHeaders = - [ for i in 0 .. numSections-1 do - let pos = sectionHeadersStartPhysLoc + i * 0x28 - let virtSize = seekReadInt32 is (pos + 8) - let virtAddr = seekReadInt32 is (pos + 12) - let physLoc = seekReadInt32 is (pos + 20) - yield (virtAddr, virtSize, physLoc) ] - - let findSectionHeader addr = - let rec look i pos = - if i >= numSections then 0x0 - else - let virtSize = seekReadInt32 is (pos + 8) - let virtAddr = seekReadInt32 is (pos + 12) - if (addr >= virtAddr && addr < virtAddr + virtSize) then pos - else look (i+1) (pos + 0x28) - look 0 sectionHeadersStartPhysLoc - - let textHeaderStart = findSectionHeader cliHeaderAddr - let dataHeaderStart = findSectionHeader dataSegmentAddr - (* let relocHeaderStart = findSectionHeader base_relocTableNames.addr in *) - - let _textSize = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 is (textHeaderStart + 8) - let _textAddr = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 is (textHeaderStart + 12) - let textSegmentPhysicalSize = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 is (textHeaderStart + 16) - let textSegmentPhysicalLoc = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 is (textHeaderStart + 20) - - if logging then dprintn (infile + ": textHeaderStart = "+string textHeaderStart) - if logging then dprintn (infile + ": dataHeaderStart = "+string dataHeaderStart) - if logging then dprintn (infile + ": dataSegmentAddr (pre section crack) = "+string dataSegmentAddr) - - let dataSegmentSize = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 8) - let dataSegmentAddr = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 12) - let dataSegmentPhysicalSize = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 16) - let dataSegmentPhysicalLoc = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 20) - - if logging then dprintn (infile + ": dataSegmentAddr (post section crack) = "+string dataSegmentAddr) - - let anyV2P (n, v) = - let rec look i pos = - if i >= numSections then (failwith (infile + ": bad "+n+", rva "+string v); 0x0) - else - let virtSize = seekReadInt32 is (pos + 8) - let virtAddr = seekReadInt32 is (pos + 12) - let physLoc = seekReadInt32 is (pos + 20) - if (v >= virtAddr && (v < virtAddr + virtSize)) then (v - virtAddr) + physLoc - else look (i+1) (pos + 0x28) - look 0 sectionHeadersStartPhysLoc - - if logging then dprintn (infile + ": numSections = "+string numSections) - if logging then dprintn (infile + ": cliHeaderAddr = "+string cliHeaderAddr) - if logging then dprintn (infile + ": cliHeaderPhys = "+string (anyV2P ("cli header", cliHeaderAddr))) - if logging then dprintn (infile + ": dataSegmentSize = "+string dataSegmentSize) - if logging then dprintn (infile + ": dataSegmentAddr = "+string dataSegmentAddr) - - let cliHeaderPhysLoc = anyV2P ("cli header", cliHeaderAddr) - - let _majorRuntimeVersion = seekReadUInt16 is (cliHeaderPhysLoc + 4) - let _minorRuntimeVersion = seekReadUInt16 is (cliHeaderPhysLoc + 6) - let metadataAddr = seekReadInt32 is (cliHeaderPhysLoc + 8) - let _metadataSegmentSize = seekReadInt32 is (cliHeaderPhysLoc + 12) - let cliFlags = seekReadInt32 is (cliHeaderPhysLoc + 16) - - let ilOnly = (cliFlags &&& 0x01) <> 0x00 - let only32 = (cliFlags &&& 0x02) <> 0x00 - let is32bitpreferred = (cliFlags &&& 0x00020003) <> 0x00 - let _strongnameSigned = (cliFlags &&& 0x08) <> 0x00 - let _trackdebugdata = (cliFlags &&& 0x010000) <> 0x00 - - let entryPointToken = seekReadUncodedToken is (cliHeaderPhysLoc + 20) - let resourcesAddr = seekReadInt32 is (cliHeaderPhysLoc + 24) - let resourcesSize = seekReadInt32 is (cliHeaderPhysLoc + 28) - let strongnameAddr = seekReadInt32 is (cliHeaderPhysLoc + 32) - let _strongnameSize = seekReadInt32 is (cliHeaderPhysLoc + 36) - let vtableFixupsAddr = seekReadInt32 is (cliHeaderPhysLoc + 40) - let _vtableFixupsSize = seekReadInt32 is (cliHeaderPhysLoc + 44) - - if logging then dprintn (infile + ": metadataAddr = "+string metadataAddr) - if logging then dprintn (infile + ": resourcesAddr = "+string resourcesAddr) - if logging then dprintn (infile + ": resourcesSize = "+string resourcesSize) - if logging then dprintn (infile + ": nativeResourcesAddr = "+string nativeResourcesAddr) - if logging then dprintn (infile + ": nativeResourcesSize = "+string nativeResourcesSize) - - let metadataPhysLoc = anyV2P ("metadata", metadataAddr) - let magic = seekReadUInt16AsInt32 is metadataPhysLoc - if magic <> 0x5342 then failwith (infile + ": bad metadata magic number: " + string magic) - let magic2 = seekReadUInt16AsInt32 is (metadataPhysLoc + 2) +// Note, pectxtEager and pevEager must not be captured by the results of this function +let openMetadataReader (fileName, mdfile: BinaryFile, metadataPhysLoc, peinfo, pectxtEager: PEReader, pevEager: BinaryView, pectxtCaptured, reduceMemoryUsage, ilGlobals) = + let mdv = mdfile.GetView() + let magic = seekReadUInt16AsInt32 mdv metadataPhysLoc + if magic <> 0x5342 then failwith (fileName + ": bad metadata magic number: " + string magic) + let magic2 = seekReadUInt16AsInt32 mdv (metadataPhysLoc + 2) if magic2 <> 0x424a then failwith "bad metadata magic number" - let _majorMetadataVersion = seekReadUInt16 is (metadataPhysLoc + 4) - let _minorMetadataVersion = seekReadUInt16 is (metadataPhysLoc + 6) + let _majorMetadataVersion = seekReadUInt16 mdv (metadataPhysLoc + 4) + let _minorMetadataVersion = seekReadUInt16 mdv (metadataPhysLoc + 6) - let versionLength = seekReadInt32 is (metadataPhysLoc + 12) - let ilMetadataVersion = seekReadBytes is (metadataPhysLoc + 16) versionLength |> Array.filter (fun b -> b <> 0uy) + let versionLength = seekReadInt32 mdv (metadataPhysLoc + 12) + let ilMetadataVersion = seekReadBytes mdv (metadataPhysLoc + 16) versionLength |> Array.filter (fun b -> b <> 0uy) let x = align 0x04 (16 + versionLength) - let numStreams = seekReadUInt16AsInt32 is (metadataPhysLoc + x + 2) + let numStreams = seekReadUInt16AsInt32 mdv (metadataPhysLoc + x + 2) let streamHeadersStart = (metadataPhysLoc + x + 4) - if logging then dprintn (infile + ": numStreams = "+string numStreams) - if logging then dprintn (infile + ": streamHeadersStart = "+string streamHeadersStart) - - (* Crack stream headers *) - let tryFindStream name = let rec look i pos = if i >= numStreams then None else - let offset = seekReadInt32 is (pos + 0) - let length = seekReadInt32 is (pos + 4) + let offset = seekReadInt32 mdv (pos + 0) + let length = seekReadInt32 mdv (pos + 4) let res = ref true let fin = ref false let n = ref 0 // read and compare the stream name byte by byte while (not !fin) do - let c= seekReadByteAsInt32 is (pos + 8 + (!n)) + let c= seekReadByteAsInt32 mdv (pos + 8 + (!n)) if c = 0 then fin := true elif !n >= Array.length name || c <> name.[!n] then @@ -3414,9 +3348,8 @@ let rec genOpenBinaryReader infile is opts = match tryFindStream [| 0x23; 0x2d |] (* #-: at least one DLL I've seen uses this! *) with | Some res -> res | None -> - dprintf "no metadata tables found under stream names '#~' or '#-', please report this\n" - let firstStreamOffset = seekReadInt32 is (streamHeadersStart + 0) - let firstStreamLength = seekReadInt32 is (streamHeadersStart + 4) + let firstStreamOffset = seekReadInt32 mdv (streamHeadersStart + 0) + let firstStreamLength = seekReadInt32 mdv (streamHeadersStart + 4) firstStreamOffset, firstStreamLength let (stringsStreamPhysicalLoc, stringsStreamSize) = findStream [| 0x23; 0x53; 0x74; 0x72; 0x69; 0x6e; 0x67; 0x73; |] (* #Strings *) @@ -3491,9 +3424,9 @@ let rec genOpenBinaryReader infile is opts = kindIllegal (* Table 63 *) |] - let heapSizes = seekReadByteAsInt32 is (tablesStreamPhysLoc + 6) - let valid = seekReadInt64 is (tablesStreamPhysLoc + 8) - let sorted = seekReadInt64 is (tablesStreamPhysLoc + 16) + let heapSizes = seekReadByteAsInt32 mdv (tablesStreamPhysLoc + 6) + let valid = seekReadInt64 mdv (tablesStreamPhysLoc + 8) + let sorted = seekReadInt64 mdv (tablesStreamPhysLoc + 16) let tablesPresent, tableRowCount, startOfTables = let present = ref [] let numRows = Array.create 64 0 @@ -3501,7 +3434,7 @@ let rec genOpenBinaryReader infile is opts = for i = 0 to 63 do if (valid &&& (int64 1 <<< i)) <> int64 0 then present := i :: !present - numRows.[i] <- (seekReadInt32 is !prevNumRowIdx) + numRows.[i] <- (seekReadInt32 mdv !prevNumRowIdx) prevNumRowIdx := !prevNumRowIdx + 4 List.rev !present, numRows, !prevNumRowIdx @@ -3511,9 +3444,9 @@ let rec genOpenBinaryReader infile is opts = let guidsBigness = (heapSizes &&& 2) <> 0 let blobsBigness = (heapSizes &&& 4) <> 0 - if logging then dprintn (infile + ": numTables = "+string numTables) - if logging && stringsBigness then dprintn (infile + ": strings are big") - if logging && blobsBigness then dprintn (infile + ": blobs are big") + if logging then dprintn (fileName + ": numTables = "+string numTables) + if logging && stringsBigness then dprintn (fileName + ": strings are big") + if logging && blobsBigness then dprintn (fileName + ": blobs are big") let tableBigness = Array.map (fun n -> n >= 0x10000) tableRowCount @@ -3631,226 +3564,334 @@ let rec genOpenBinaryReader infile is opts = let tablePhysLocations = let res = Array.create 64 0x0 - let prevTablePhysLoc = ref startOfTables + let mutable prevTablePhysLoc = startOfTables for i = 0 to 63 do - res.[i] <- !prevTablePhysLoc - prevTablePhysLoc := !prevTablePhysLoc + (tableRowCount.[i] * tableRowSizes.[i]) - if logging then dprintf "tablePhysLocations.[%d] = %d, offset from startOfTables = 0x%08x\n" i res.[i] (res.[i] - startOfTables) + res.[i] <- prevTablePhysLoc + prevTablePhysLoc <- prevTablePhysLoc + (tableRowCount.[i] * tableRowSizes.[i]) res - let inbase = Filename.fileNameOfPath infile + ": " + let inbase = Filename.fileNameOfPath fileName + ": " // All the caches. The sizes are guesstimates for the rough sharing-density of the assembly - let cacheAssemblyRef = mkCacheInt32 opts.optimizeForMemory inbase "ILAssemblyRef" (getNumRows TableNames.AssemblyRef) - let cacheMethodSpecAsMethodData = mkCacheGeneric opts.optimizeForMemory inbase "MethodSpecAsMethodData" (getNumRows TableNames.MethodSpec / 20 + 1) - let cacheMemberRefAsMemberData = mkCacheGeneric opts.optimizeForMemory inbase "MemberRefAsMemberData" (getNumRows TableNames.MemberRef / 20 + 1) - let cacheCustomAttr = mkCacheGeneric opts.optimizeForMemory inbase "CustomAttr" (getNumRows TableNames.CustomAttribute / 50 + 1) - let cacheTypeRef = mkCacheInt32 opts.optimizeForMemory inbase "ILTypeRef" (getNumRows TableNames.TypeRef / 20 + 1) - let cacheTypeRefAsType = mkCacheGeneric opts.optimizeForMemory inbase "TypeRefAsType" (getNumRows TableNames.TypeRef / 20 + 1) - let cacheBlobHeapAsPropertySig = mkCacheGeneric opts.optimizeForMemory inbase "BlobHeapAsPropertySig" (getNumRows TableNames.Property / 20 + 1) - let cacheBlobHeapAsFieldSig = mkCacheGeneric opts.optimizeForMemory inbase "BlobHeapAsFieldSig" (getNumRows TableNames.Field / 20 + 1) - let cacheBlobHeapAsMethodSig = mkCacheGeneric opts.optimizeForMemory inbase "BlobHeapAsMethodSig" (getNumRows TableNames.Method / 20 + 1) - let cacheTypeDefAsType = mkCacheGeneric opts.optimizeForMemory inbase "TypeDefAsType" (getNumRows TableNames.TypeDef / 20 + 1) - let cacheMethodDefAsMethodData = mkCacheInt32 opts.optimizeForMemory inbase "MethodDefAsMethodData" (getNumRows TableNames.Method / 20 + 1) - let cacheGenericParams = mkCacheGeneric opts.optimizeForMemory inbase "GenericParams" (getNumRows TableNames.GenericParam / 20 + 1) - let cacheFieldDefAsFieldSpec = mkCacheInt32 opts.optimizeForMemory inbase "FieldDefAsFieldSpec" (getNumRows TableNames.Field / 20 + 1) - let cacheUserStringHeap = mkCacheInt32 opts.optimizeForMemory inbase "UserStringHeap" ( userStringsStreamSize / 20 + 1) + let cacheAssemblyRef = mkCacheInt32 reduceMemoryUsage inbase "ILAssemblyRef" (getNumRows TableNames.AssemblyRef) + let cacheMethodSpecAsMethodData = mkCacheGeneric reduceMemoryUsage inbase "MethodSpecAsMethodData" (getNumRows TableNames.MethodSpec / 20 + 1) + let cacheMemberRefAsMemberData = mkCacheGeneric reduceMemoryUsage inbase "MemberRefAsMemberData" (getNumRows TableNames.MemberRef / 20 + 1) + let cacheCustomAttr = mkCacheGeneric reduceMemoryUsage inbase "CustomAttr" (getNumRows TableNames.CustomAttribute / 50 + 1) + let cacheTypeRef = mkCacheInt32 reduceMemoryUsage inbase "ILTypeRef" (getNumRows TableNames.TypeRef / 20 + 1) + let cacheTypeRefAsType = mkCacheGeneric reduceMemoryUsage inbase "TypeRefAsType" (getNumRows TableNames.TypeRef / 20 + 1) + let cacheBlobHeapAsPropertySig = mkCacheGeneric reduceMemoryUsage inbase "BlobHeapAsPropertySig" (getNumRows TableNames.Property / 20 + 1) + let cacheBlobHeapAsFieldSig = mkCacheGeneric reduceMemoryUsage inbase "BlobHeapAsFieldSig" (getNumRows TableNames.Field / 20 + 1) + let cacheBlobHeapAsMethodSig = mkCacheGeneric reduceMemoryUsage inbase "BlobHeapAsMethodSig" (getNumRows TableNames.Method / 20 + 1) + let cacheTypeDefAsType = mkCacheGeneric reduceMemoryUsage inbase "TypeDefAsType" (getNumRows TableNames.TypeDef / 20 + 1) + let cacheMethodDefAsMethodData = mkCacheInt32 reduceMemoryUsage inbase "MethodDefAsMethodData" (getNumRows TableNames.Method / 20 + 1) + let cacheGenericParams = mkCacheGeneric reduceMemoryUsage inbase "GenericParams" (getNumRows TableNames.GenericParam / 20 + 1) + let cacheFieldDefAsFieldSpec = mkCacheInt32 reduceMemoryUsage inbase "FieldDefAsFieldSpec" (getNumRows TableNames.Field / 20 + 1) + let cacheUserStringHeap = mkCacheInt32 reduceMemoryUsage inbase "UserStringHeap" ( userStringsStreamSize / 20 + 1) // nb. Lots and lots of cache hits on this cache, hence never optimize cache away let cacheStringHeap = mkCacheInt32 false inbase "string heap" ( stringsStreamSize / 50 + 1) - let cacheBlobHeap = mkCacheInt32 opts.optimizeForMemory inbase "blob heap" ( blobsStreamSize / 50 + 1) + let cacheBlobHeap = mkCacheInt32 reduceMemoryUsage inbase "blob heap" ( blobsStreamSize / 50 + 1) // These tables are not required to enforce sharing fo the final data // structure, but are very useful as searching these tables gives rise to many reads // in standard applications. - let cacheNestedRow = mkCacheInt32 opts.optimizeForMemory inbase "Nested Table Rows" (getNumRows TableNames.Nested / 20 + 1) - let cacheConstantRow = mkCacheInt32 opts.optimizeForMemory inbase "Constant Rows" (getNumRows TableNames.Constant / 20 + 1) - let cacheMethodSemanticsRow = mkCacheInt32 opts.optimizeForMemory inbase "MethodSemantics Rows" (getNumRows TableNames.MethodSemantics / 20 + 1) - let cacheTypeDefRow = mkCacheInt32 opts.optimizeForMemory inbase "ILTypeDef Rows" (getNumRows TableNames.TypeDef / 20 + 1) - let cacheInterfaceImplRow = mkCacheInt32 opts.optimizeForMemory inbase "InterfaceImpl Rows" (getNumRows TableNames.InterfaceImpl / 20 + 1) - let cacheFieldMarshalRow = mkCacheInt32 opts.optimizeForMemory inbase "FieldMarshal Rows" (getNumRows TableNames.FieldMarshal / 20 + 1) - let cachePropertyMapRow = mkCacheInt32 opts.optimizeForMemory inbase "PropertyMap Rows" (getNumRows TableNames.PropertyMap / 20 + 1) - - let mkRowCounter _nm = - let count = ref 0 -#if DEBUG -#if STATISTICS - addReport (fun oc -> if !count <> 0 then oc.WriteLine (inbase+string !count + " "+_nm+" rows read")) -#endif -#else - _nm |> ignore -#endif - count - - let countTypeRef = mkRowCounter "ILTypeRef" - let countTypeDef = mkRowCounter "ILTypeDef" - let countField = mkRowCounter "Field" - let countMethod = mkRowCounter "Method" - let countParam = mkRowCounter "Param" - let countInterfaceImpl = mkRowCounter "InterfaceImpl" - let countMemberRef = mkRowCounter "MemberRef" - let countConstant = mkRowCounter "Constant" - let countCustomAttribute = mkRowCounter "CustomAttribute" - let countFieldMarshal = mkRowCounter "FieldMarshal" - let countPermission = mkRowCounter "Permission" - let countClassLayout = mkRowCounter "ClassLayout" - let countFieldLayout = mkRowCounter "FieldLayout" - let countStandAloneSig = mkRowCounter "StandAloneSig" - let countEventMap = mkRowCounter "EventMap" - let countEvent = mkRowCounter "Event" - let countPropertyMap = mkRowCounter "PropertyMap" - let countProperty = mkRowCounter "Property" - let countMethodSemantics = mkRowCounter "MethodSemantics" - let countMethodImpl = mkRowCounter "MethodImpl" - let countModuleRef = mkRowCounter "ILModuleRef" - let countTypeSpec = mkRowCounter "ILTypeSpec" - let countImplMap = mkRowCounter "ImplMap" - let countFieldRVA = mkRowCounter "FieldRVA" - let countAssembly = mkRowCounter "Assembly" - let countAssemblyRef = mkRowCounter "ILAssemblyRef" - let countFile = mkRowCounter "File" - let countExportedType = mkRowCounter "ILExportedTypeOrForwarder" - let countManifestResource = mkRowCounter "ManifestResource" - let countNested = mkRowCounter "Nested" - let countGenericParam = mkRowCounter "GenericParam" - let countGenericParamConstraint = mkRowCounter "GenericParamConstraint" - let countMethodSpec = mkRowCounter "ILMethodSpec" + let cacheNestedRow = mkCacheInt32 reduceMemoryUsage inbase "Nested Table Rows" (getNumRows TableNames.Nested / 20 + 1) + let cacheConstantRow = mkCacheInt32 reduceMemoryUsage inbase "Constant Rows" (getNumRows TableNames.Constant / 20 + 1) + let cacheMethodSemanticsRow = mkCacheInt32 reduceMemoryUsage inbase "MethodSemantics Rows" (getNumRows TableNames.MethodSemantics / 20 + 1) + let cacheTypeDefRow = mkCacheInt32 reduceMemoryUsage inbase "ILTypeDef Rows" (getNumRows TableNames.TypeDef / 20 + 1) + + let rowAddr (tab:TableName) idx = tablePhysLocations.[tab.Index] + (idx - 1) * tableRowSizes.[tab.Index] + + // Build the reader context + // Use an initialization hole + let ctxtH = ref None + let ctxt : ILMetadataReader = + { ilg=ilGlobals + sorted=sorted + getNumRows=getNumRows + mdfile=mdfile + dataEndPoints = match pectxtCaptured with None -> notlazy [] | Some pectxt -> getDataEndPointsDelayed pectxt ctxtH + pectxtCaptured=pectxtCaptured + entryPointToken=pectxtEager.entryPointToken + fileName=fileName + userStringsStreamPhysicalLoc = userStringsStreamPhysicalLoc + stringsStreamPhysicalLoc = stringsStreamPhysicalLoc + blobsStreamPhysicalLoc = blobsStreamPhysicalLoc + blobsStreamSize = blobsStreamSize + memoizeString = Tables.memoize id + readUserStringHeap = cacheUserStringHeap (readUserStringHeapUncached ctxtH) + readStringHeap = cacheStringHeap (readStringHeapUncached ctxtH) + readBlobHeap = cacheBlobHeap (readBlobHeapUncached ctxtH) + seekReadNestedRow = cacheNestedRow (seekReadNestedRowUncached ctxtH) + seekReadConstantRow = cacheConstantRow (seekReadConstantRowUncached ctxtH) + seekReadMethodSemanticsRow = cacheMethodSemanticsRow (seekReadMethodSemanticsRowUncached ctxtH) + seekReadTypeDefRow = cacheTypeDefRow (seekReadTypeDefRowUncached ctxtH) + seekReadAssemblyRef = cacheAssemblyRef (seekReadAssemblyRefUncached ctxtH) + seekReadMethodSpecAsMethodData = cacheMethodSpecAsMethodData (seekReadMethodSpecAsMethodDataUncached ctxtH) + seekReadMemberRefAsMethodData = cacheMemberRefAsMemberData (seekReadMemberRefAsMethodDataUncached ctxtH) + seekReadMemberRefAsFieldSpec = seekReadMemberRefAsFieldSpecUncached ctxtH + seekReadCustomAttr = cacheCustomAttr (seekReadCustomAttrUncached ctxtH) + seekReadTypeRef = cacheTypeRef (seekReadTypeRefUncached ctxtH) + readBlobHeapAsPropertySig = cacheBlobHeapAsPropertySig (readBlobHeapAsPropertySigUncached ctxtH) + readBlobHeapAsFieldSig = cacheBlobHeapAsFieldSig (readBlobHeapAsFieldSigUncached ctxtH) + readBlobHeapAsMethodSig = cacheBlobHeapAsMethodSig (readBlobHeapAsMethodSigUncached ctxtH) + readBlobHeapAsLocalsSig = readBlobHeapAsLocalsSigUncached ctxtH + seekReadTypeDefAsType = cacheTypeDefAsType (seekReadTypeDefAsTypeUncached ctxtH) + seekReadTypeRefAsType = cacheTypeRefAsType (seekReadTypeRefAsTypeUncached ctxtH) + seekReadMethodDefAsMethodData = cacheMethodDefAsMethodData (seekReadMethodDefAsMethodDataUncached ctxtH) + seekReadGenericParams = cacheGenericParams (seekReadGenericParamsUncached ctxtH) + seekReadFieldDefAsFieldSpec = cacheFieldDefAsFieldSpec (seekReadFieldDefAsFieldSpecUncached ctxtH) + customAttrsReader_Module = customAttrsReader ctxtH hca_Module + customAttrsReader_Assembly = customAttrsReader ctxtH hca_Assembly + customAttrsReader_TypeDef = customAttrsReader ctxtH hca_TypeDef + customAttrsReader_GenericParam= customAttrsReader ctxtH hca_GenericParam + customAttrsReader_FieldDef= customAttrsReader ctxtH hca_FieldDef + customAttrsReader_MethodDef= customAttrsReader ctxtH hca_MethodDef + customAttrsReader_ParamDef= customAttrsReader ctxtH hca_ParamDef + customAttrsReader_Event= customAttrsReader ctxtH hca_Event + customAttrsReader_Property= customAttrsReader ctxtH hca_Property + customAttrsReader_ManifestResource= customAttrsReader ctxtH hca_ManifestResource + customAttrsReader_ExportedType= customAttrsReader ctxtH hca_ExportedType + securityDeclsReader_TypeDef = securityDeclsReader ctxtH hds_TypeDef + securityDeclsReader_MethodDef = securityDeclsReader ctxtH hds_MethodDef + securityDeclsReader_Assembly = securityDeclsReader ctxtH hds_Assembly + typeDefReader = typeDefReader ctxtH + guidsStreamPhysicalLoc = guidsStreamPhysicalLoc + rowAddr=rowAddr + rsBigness=rsBigness + tdorBigness=tdorBigness + tomdBigness=tomdBigness + hcBigness=hcBigness + hcaBigness=hcaBigness + hfmBigness=hfmBigness + hdsBigness=hdsBigness + mrpBigness=mrpBigness + hsBigness=hsBigness + mdorBigness=mdorBigness + mfBigness=mfBigness + iBigness=iBigness + catBigness=catBigness + stringsBigness=stringsBigness + guidsBigness=guidsBigness + blobsBigness=blobsBigness + tableBigness=tableBigness } + ctxtH := Some ctxt + + let ilModule = seekReadModule ctxt pectxtEager pevEager peinfo (System.Text.Encoding.UTF8.GetString (ilMetadataVersion, 0, ilMetadataVersion.Length)) 1 + let ilAssemblyRefs = lazy [ for i in 1 .. getNumRows TableNames.AssemblyRef do yield seekReadAssemblyRef ctxt i ] + + ilModule, ilAssemblyRefs + +//----------------------------------------------------------------------- +// Crack the binary headers, build a reader context and return the lazy +// read of the AbsIL module. +// ---------------------------------------------------------------------- + +let openPEFileReader (fileName, pefile: BinaryFile, pdbPath) = + let pev = pefile.GetView() + (* MSDOS HEADER *) + let peSignaturePhysLoc = seekReadInt32 pev 0x3c + + (* PE HEADER *) + let peFileHeaderPhysLoc = peSignaturePhysLoc + 0x04 + let peOptionalHeaderPhysLoc = peFileHeaderPhysLoc + 0x14 + let peSignature = seekReadInt32 pev (peSignaturePhysLoc + 0) + if peSignature <> 0x4550 then failwithf "not a PE file - bad magic PE number 0x%08x, is = %A" peSignature pev + + + (* PE SIGNATURE *) + let machine = seekReadUInt16AsInt32 pev (peFileHeaderPhysLoc + 0) + let numSections = seekReadUInt16AsInt32 pev (peFileHeaderPhysLoc + 2) + let optHeaderSize = seekReadUInt16AsInt32 pev (peFileHeaderPhysLoc + 16) + if optHeaderSize <> 0xe0 && + optHeaderSize <> 0xf0 then failwith "not a PE file - bad optional header size" + let x64adjust = optHeaderSize - 0xe0 + let only64 = (optHeaderSize = 0xf0) (* May want to read in the optional header Magic number and check that as well... *) + let platform = match machine with | 0x8664 -> Some(AMD64) | 0x200 -> Some(IA64) | _ -> Some(X86) + let sectionHeadersStartPhysLoc = peOptionalHeaderPhysLoc + optHeaderSize + let flags = seekReadUInt16AsInt32 pev (peFileHeaderPhysLoc + 18) + let isDll = (flags &&& 0x2000) <> 0x0 + (* OPTIONAL PE HEADER *) + let _textPhysSize = seekReadInt32 pev (peOptionalHeaderPhysLoc + 4) (* Size of the code (text) section, or the sum of all code sections if there are multiple sections. *) + (* x86: 000000a0 *) + let _initdataPhysSize = seekReadInt32 pev (peOptionalHeaderPhysLoc + 8) (* Size of the initialized data section, or the sum of all such sections if there are multiple data sections. *) + let _uninitdataPhysSize = seekReadInt32 pev (peOptionalHeaderPhysLoc + 12) (* Size of the uninitialized data section, or the sum of all such sections if there are multiple data sections. *) + let _entrypointAddr = seekReadInt32 pev (peOptionalHeaderPhysLoc + 16) (* RVA of entry point , needs to point to bytes 0xFF 0x25 followed by the RVA+!0x4000000 in a section marked execute/read for EXEs or 0 for DLLs e.g. 0x0000b57e *) + let _textAddr = seekReadInt32 pev (peOptionalHeaderPhysLoc + 20) (* e.g. 0x0002000 *) + (* x86: 000000b0 *) + let dataSegmentAddr = seekReadInt32 pev (peOptionalHeaderPhysLoc + 24) (* e.g. 0x0000c000 *) + (* REVIEW: For now, we'll use the DWORD at offset 24 for x64. This currently ok since fsc doesn't support true 64-bit image bases, + but we'll have to fix this up when such support is added. *) + let imageBaseReal = if only64 then dataSegmentAddr else seekReadInt32 pev (peOptionalHeaderPhysLoc + 28) (* Image Base Always 0x400000 (see Section 23.1). - QUERY : no it's not always 0x400000, e.g. 0x034f0000 *) + let alignVirt = seekReadInt32 pev (peOptionalHeaderPhysLoc + 32) (* Section Alignment Always 0x2000 (see Section 23.1). *) + let alignPhys = seekReadInt32 pev (peOptionalHeaderPhysLoc + 36) (* File Alignment Either 0x200 or 0x1000. *) + (* x86: 000000c0 *) + let _osMajor = seekReadUInt16 pev (peOptionalHeaderPhysLoc + 40) (* OS Major Always 4 (see Section 23.1). *) + let _osMinor = seekReadUInt16 pev (peOptionalHeaderPhysLoc + 42) (* OS Minor Always 0 (see Section 23.1). *) + let _userMajor = seekReadUInt16 pev (peOptionalHeaderPhysLoc + 44) (* User Major Always 0 (see Section 23.1). *) + let _userMinor = seekReadUInt16 pev (peOptionalHeaderPhysLoc + 46) (* User Minor Always 0 (see Section 23.1). *) + let subsysMajor = seekReadUInt16AsInt32 pev (peOptionalHeaderPhysLoc + 48) (* SubSys Major Always 4 (see Section 23.1). *) + let subsysMinor = seekReadUInt16AsInt32 pev (peOptionalHeaderPhysLoc + 50) (* SubSys Minor Always 0 (see Section 23.1). *) + (* x86: 000000d0 *) + let _imageEndAddr = seekReadInt32 pev (peOptionalHeaderPhysLoc + 56) (* Image Size: Size, in bytes, of image, including all headers and padding; shall be a multiple of Section Alignment. e.g. 0x0000e000 *) + let _headerPhysSize = seekReadInt32 pev (peOptionalHeaderPhysLoc + 60) (* Header Size Combined size of MS-DOS Header, PE Header, PE Optional Header and padding; shall be a multiple of the file alignment. *) + let subsys = seekReadUInt16 pev (peOptionalHeaderPhysLoc + 68) (* SubSystem Subsystem required to run this image. Shall be either IMAGE_SUBSYSTEM_WINDOWS_CE_GUI (!0x3) or IMAGE_SUBSYSTEM_WINDOWS_GUI (!0x2). QUERY: Why is this 3 on the images ILASM produces??? *) + let useHighEnthropyVA = + let n = seekReadUInt16 pev (peOptionalHeaderPhysLoc + 70) + let highEnthropyVA = 0x20us + (n &&& highEnthropyVA) = highEnthropyVA + + (* x86: 000000e0 *) + + (* WARNING: THESE ARE 64 bit ON x64/ia64 *) + (* REVIEW: If we ever decide that we need these values for x64, we'll have to read them in as 64bit and fix up the rest of the offsets. + Then again, it should suffice to just use the defaults, and still not bother... *) + (* let stackReserve = seekReadInt32 is (peOptionalHeaderPhysLoc + 72) in *) (* Stack Reserve Size Always 0x100000 (1Mb) (see Section 23.1). *) + (* let stackCommit = seekReadInt32 is (peOptionalHeaderPhysLoc + 76) in *) (* Stack Commit Size Always 0x1000 (4Kb) (see Section 23.1). *) + (* let heapReserve = seekReadInt32 is (peOptionalHeaderPhysLoc + 80) in *) (* Heap Reserve Size Always 0x100000 (1Mb) (see Section 23.1). *) + (* let heapCommit = seekReadInt32 is (peOptionalHeaderPhysLoc + 84) in *) (* Heap Commit Size Always 0x1000 (4Kb) (see Section 23.1). *) + + (* x86: 000000f0, x64: 00000100 *) + let _numDataDirectories = seekReadInt32 pev (peOptionalHeaderPhysLoc + 92 + x64adjust) (* Number of Data Directories: Always 0x10 (see Section 23.1). *) + (* 00000100 - these addresses are for x86 - for the x64 location, add x64adjust (0x10) *) + let _importTableAddr = seekReadInt32 pev (peOptionalHeaderPhysLoc + 104 + x64adjust) (* Import Table RVA of Import Table, (see clause 24.3.1). e.g. 0000b530 *) + let _importTableSize = seekReadInt32 pev (peOptionalHeaderPhysLoc + 108 + x64adjust) (* Size of Import Table, (see clause 24.3.1). *) + let nativeResourcesAddr = seekReadInt32 pev (peOptionalHeaderPhysLoc + 112 + x64adjust) + let nativeResourcesSize = seekReadInt32 pev (peOptionalHeaderPhysLoc + 116 + x64adjust) + (* 00000110 *) + (* 00000120 *) + (* let base_relocTableNames.addr = seekReadInt32 is (peOptionalHeaderPhysLoc + 136) + let base_relocTableNames.size = seekReadInt32 is (peOptionalHeaderPhysLoc + 140) in *) + (* 00000130 *) + (* 00000140 *) + (* 00000150 *) + let _importAddrTableAddr = seekReadInt32 pev (peOptionalHeaderPhysLoc + 192 + x64adjust) (* RVA of Import Addr Table, (see clause 24.3.1). e.g. 0x00002000 *) + let _importAddrTableSize = seekReadInt32 pev (peOptionalHeaderPhysLoc + 196 + x64adjust) (* Size of Import Addr Table, (see clause 24.3.1). e.g. 0x00002000 *) + (* 00000160 *) + let cliHeaderAddr = seekReadInt32 pev (peOptionalHeaderPhysLoc + 208 + x64adjust) + let _cliHeaderSize = seekReadInt32 pev (peOptionalHeaderPhysLoc + 212 + x64adjust) + (* 00000170 *) + + + (* Crack section headers *) + + let sectionHeaders = + [ for i in 0 .. numSections-1 do + let pos = sectionHeadersStartPhysLoc + i * 0x28 + let virtSize = seekReadInt32 pev (pos + 8) + let virtAddr = seekReadInt32 pev (pos + 12) + let physLoc = seekReadInt32 pev (pos + 20) + yield (virtAddr, virtSize, physLoc) ] + + let findSectionHeader addr = + let rec look i pos = + if i >= numSections then 0x0 + else + let virtSize = seekReadInt32 pev (pos + 8) + let virtAddr = seekReadInt32 pev (pos + 12) + if (addr >= virtAddr && addr < virtAddr + virtSize) then pos + else look (i+1) (pos + 0x28) + look 0 sectionHeadersStartPhysLoc + + let textHeaderStart = findSectionHeader cliHeaderAddr + let dataHeaderStart = findSectionHeader dataSegmentAddr + (* let relocHeaderStart = findSectionHeader base_relocTableNames.addr in *) + + let _textSize = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 pev (textHeaderStart + 8) + let _textAddr = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 pev (textHeaderStart + 12) + let textSegmentPhysicalSize = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 pev (textHeaderStart + 16) + let textSegmentPhysicalLoc = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 pev (textHeaderStart + 20) + + //let dataSegmentSize = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 pev (dataHeaderStart + 8) + //let dataSegmentAddr = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 pev (dataHeaderStart + 12) + let dataSegmentPhysicalSize = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 pev (dataHeaderStart + 16) + let dataSegmentPhysicalLoc = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 pev (dataHeaderStart + 20) + + let anyV2P (n, v) = + let pev = pefile.GetView() + let rec look i pos = + if i >= numSections then (failwith (fileName + ": bad "+n+", rva "+string v); 0x0) + else + let virtSize = seekReadInt32 pev (pos + 8) + let virtAddr = seekReadInt32 pev (pos + 12) + let physLoc = seekReadInt32 pev (pos + 20) + if (v >= virtAddr && (v < virtAddr + virtSize)) then (v - virtAddr) + physLoc + else look (i+1) (pos + 0x28) + look 0 sectionHeadersStartPhysLoc + + let cliHeaderPhysLoc = anyV2P ("cli header", cliHeaderAddr) + + let _majorRuntimeVersion = seekReadUInt16 pev (cliHeaderPhysLoc + 4) + let _minorRuntimeVersion = seekReadUInt16 pev (cliHeaderPhysLoc + 6) + let metadataAddr = seekReadInt32 pev (cliHeaderPhysLoc + 8) + let metadataSize = seekReadInt32 pev (cliHeaderPhysLoc + 12) + let cliFlags = seekReadInt32 pev (cliHeaderPhysLoc + 16) + + let ilOnly = (cliFlags &&& 0x01) <> 0x00 + let only32 = (cliFlags &&& 0x02) <> 0x00 + let is32bitpreferred = (cliFlags &&& 0x00020003) <> 0x00 + let _strongnameSigned = (cliFlags &&& 0x08) <> 0x00 + let _trackdebugdata = (cliFlags &&& 0x010000) <> 0x00 + + let entryPointToken = seekReadUncodedToken pev (cliHeaderPhysLoc + 20) + let resourcesAddr = seekReadInt32 pev (cliHeaderPhysLoc + 24) + let resourcesSize = seekReadInt32 pev (cliHeaderPhysLoc + 28) + let strongnameAddr = seekReadInt32 pev (cliHeaderPhysLoc + 32) + let _strongnameSize = seekReadInt32 pev (cliHeaderPhysLoc + 36) + let vtableFixupsAddr = seekReadInt32 pev (cliHeaderPhysLoc + 40) + let _vtableFixupsSize = seekReadInt32 pev (cliHeaderPhysLoc + 44) + + if logging then dprintn (fileName + ": metadataAddr = "+string metadataAddr) + if logging then dprintn (fileName + ": resourcesAddr = "+string resourcesAddr) + if logging then dprintn (fileName + ": resourcesSize = "+string resourcesSize) + if logging then dprintn (fileName + ": nativeResourcesAddr = "+string nativeResourcesAddr) + if logging then dprintn (fileName + ": nativeResourcesSize = "+string nativeResourcesSize) + + let metadataPhysLoc = anyV2P ("metadata", metadataAddr) //----------------------------------------------------------------------- // Set up the PDB reader so we can read debug info for methods. // ---------------------------------------------------------------------- #if FX_NO_PDB_READER - let pdb = None + let pdb = ignore pdbPath; None #else let pdb = if runningOnMono then None else - getPdbReader opts infile + getPdbReader pdbPath fileName #endif - let rowAddr (tab:TableName) idx = tablePhysLocations.[tab.Index] + (idx - 1) * tableRowSizes.[tab.Index] - - - // Build the reader context - // Use an initialization hole - let ctxtH = ref None - let ctxt = { ilg=opts.ilGlobals - dataEndPoints = dataEndPoints ctxtH - pdb=pdb - sorted=sorted - getNumRows=getNumRows - textSegmentPhysicalLoc=textSegmentPhysicalLoc - textSegmentPhysicalSize=textSegmentPhysicalSize - dataSegmentPhysicalLoc=dataSegmentPhysicalLoc - dataSegmentPhysicalSize=dataSegmentPhysicalSize - anyV2P=anyV2P - metadataAddr=metadataAddr - sectionHeaders=sectionHeaders - nativeResourcesAddr=nativeResourcesAddr - nativeResourcesSize=nativeResourcesSize - resourcesAddr=resourcesAddr - strongnameAddr=strongnameAddr - vtableFixupsAddr=vtableFixupsAddr - is=is - infile=infile - userStringsStreamPhysicalLoc = userStringsStreamPhysicalLoc - stringsStreamPhysicalLoc = stringsStreamPhysicalLoc - blobsStreamPhysicalLoc = blobsStreamPhysicalLoc - blobsStreamSize = blobsStreamSize - memoizeString = Tables.memoize id - readUserStringHeap = cacheUserStringHeap (readUserStringHeapUncached ctxtH) - readStringHeap = cacheStringHeap (readStringHeapUncached ctxtH) - readBlobHeap = cacheBlobHeap (readBlobHeapUncached ctxtH) - seekReadNestedRow = cacheNestedRow (seekReadNestedRowUncached ctxtH) - seekReadConstantRow = cacheConstantRow (seekReadConstantRowUncached ctxtH) - seekReadMethodSemanticsRow = cacheMethodSemanticsRow (seekReadMethodSemanticsRowUncached ctxtH) - seekReadTypeDefRow = cacheTypeDefRow (seekReadTypeDefRowUncached ctxtH) - seekReadInterfaceImplRow = cacheInterfaceImplRow (seekReadInterfaceImplRowUncached ctxtH) - seekReadFieldMarshalRow = cacheFieldMarshalRow (seekReadFieldMarshalRowUncached ctxtH) - seekReadPropertyMapRow = cachePropertyMapRow (seekReadPropertyMapRowUncached ctxtH) - seekReadAssemblyRef = cacheAssemblyRef (seekReadAssemblyRefUncached ctxtH) - seekReadMethodSpecAsMethodData = cacheMethodSpecAsMethodData (seekReadMethodSpecAsMethodDataUncached ctxtH) - seekReadMemberRefAsMethodData = cacheMemberRefAsMemberData (seekReadMemberRefAsMethodDataUncached ctxtH) - seekReadMemberRefAsFieldSpec = seekReadMemberRefAsFieldSpecUncached ctxtH - seekReadCustomAttr = cacheCustomAttr (seekReadCustomAttrUncached ctxtH) - seekReadSecurityDecl = seekReadSecurityDeclUncached ctxtH - seekReadTypeRef = cacheTypeRef (seekReadTypeRefUncached ctxtH) - readBlobHeapAsPropertySig = cacheBlobHeapAsPropertySig (readBlobHeapAsPropertySigUncached ctxtH) - readBlobHeapAsFieldSig = cacheBlobHeapAsFieldSig (readBlobHeapAsFieldSigUncached ctxtH) - readBlobHeapAsMethodSig = cacheBlobHeapAsMethodSig (readBlobHeapAsMethodSigUncached ctxtH) - readBlobHeapAsLocalsSig = readBlobHeapAsLocalsSigUncached ctxtH - seekReadTypeDefAsType = cacheTypeDefAsType (seekReadTypeDefAsTypeUncached ctxtH) - seekReadTypeRefAsType = cacheTypeRefAsType (seekReadTypeRefAsTypeUncached ctxtH) - seekReadMethodDefAsMethodData = cacheMethodDefAsMethodData (seekReadMethodDefAsMethodDataUncached ctxtH) - seekReadGenericParams = cacheGenericParams (seekReadGenericParamsUncached ctxtH) - seekReadFieldDefAsFieldSpec = cacheFieldDefAsFieldSpec (seekReadFieldDefAsFieldSpecUncached ctxtH) - guidsStreamPhysicalLoc = guidsStreamPhysicalLoc - rowAddr=rowAddr - entryPointToken=entryPointToken - rsBigness=rsBigness - tdorBigness=tdorBigness - tomdBigness=tomdBigness - hcBigness=hcBigness - hcaBigness=hcaBigness - hfmBigness=hfmBigness - hdsBigness=hdsBigness - mrpBigness=mrpBigness - hsBigness=hsBigness - mdorBigness=mdorBigness - mfBigness=mfBigness - iBigness=iBigness - catBigness=catBigness - stringsBigness=stringsBigness - guidsBigness=guidsBigness - blobsBigness=blobsBigness - tableBigness=tableBigness - countTypeRef = countTypeRef - countTypeDef = countTypeDef - countField = countField - countMethod = countMethod - countParam = countParam - countInterfaceImpl = countInterfaceImpl - countMemberRef = countMemberRef - countConstant = countConstant - countCustomAttribute = countCustomAttribute - countFieldMarshal = countFieldMarshal - countPermission = countPermission - countClassLayout = countClassLayout - countFieldLayout = countFieldLayout - countStandAloneSig = countStandAloneSig - countEventMap = countEventMap - countEvent = countEvent - countPropertyMap = countPropertyMap - countProperty = countProperty - countMethodSemantics = countMethodSemantics - countMethodImpl = countMethodImpl - countModuleRef = countModuleRef - countTypeSpec = countTypeSpec - countImplMap = countImplMap - countFieldRVA = countFieldRVA - countAssembly = countAssembly - countAssemblyRef = countAssemblyRef - countFile = countFile - countExportedType = countExportedType - countManifestResource = countManifestResource - countNested = countNested - countGenericParam = countGenericParam - countGenericParamConstraint = countGenericParamConstraint - countMethodSpec = countMethodSpec } - ctxtH := Some ctxt - - let ilModule = seekReadModule ctxt (subsys, (subsysMajor, subsysMinor), useHighEnthropyVA, ilOnly, only32, is32bitpreferred, only64, platform, isDll, alignVirt, alignPhys, imageBaseReal, System.Text.Encoding.UTF8.GetString (ilMetadataVersion, 0, ilMetadataVersion.Length)) 1 - let ilAssemblyRefs = lazy [ for i in 1 .. getNumRows TableNames.AssemblyRef do yield seekReadAssemblyRef ctxt i ] - + let pectxt : PEReader = + { pdb=pdb + textSegmentPhysicalLoc=textSegmentPhysicalLoc + textSegmentPhysicalSize=textSegmentPhysicalSize + dataSegmentPhysicalLoc=dataSegmentPhysicalLoc + dataSegmentPhysicalSize=dataSegmentPhysicalSize + anyV2P=anyV2P + metadataAddr=metadataAddr + sectionHeaders=sectionHeaders + nativeResourcesAddr=nativeResourcesAddr + nativeResourcesSize=nativeResourcesSize + resourcesAddr=resourcesAddr + strongnameAddr=strongnameAddr + vtableFixupsAddr=vtableFixupsAddr + pefile=pefile + fileName=fileName + entryPointToken=entryPointToken + } + let peinfo = (subsys, (subsysMajor, subsysMinor), useHighEnthropyVA, ilOnly, only32, is32bitpreferred, only64, platform, isDll, alignVirt, alignPhys, imageBaseReal) + (metadataPhysLoc, metadataSize, peinfo, pectxt, pev, pdb) + +let openPE (fileName, pefile, pdbPath, reduceMemoryUsage, ilGlobals) = + let (metadataPhysLoc, _metadataSize, peinfo, pectxt, pev, pdb) = openPEFileReader (fileName, pefile, pdbPath) + let ilModule, ilAssemblyRefs = openMetadataReader (fileName, pefile, metadataPhysLoc, peinfo, pectxt, pev, Some pectxt, reduceMemoryUsage, ilGlobals) ilModule, ilAssemblyRefs, pdb - -let mkDefault ilg = - { optimizeForMemory=false - pdbPath= None - ilGlobals = ilg } +let openPEMetadataOnly (fileName, peinfo, pectxtEager, pev, mdfile: BinaryFile, reduceMemoryUsage, ilGlobals) = + openMetadataReader (fileName, mdfile, 0, peinfo, pectxtEager, pev, None, reduceMemoryUsage, ilGlobals) + let ClosePdbReader pdb = #if FX_NO_PDB_READER ignore pdb @@ -3861,69 +3902,161 @@ let ClosePdbReader pdb = | None -> () #endif -let OpenILModuleReader infile opts = - - try - let mmap = MemoryMappedFile.Create infile - let modul, ilAssemblyRefs, pdb = genOpenBinaryReader infile mmap opts - { modul = modul - ilAssemblyRefs=ilAssemblyRefs - dispose = (fun () -> - mmap.Close() - ClosePdbReader pdb) } - with _ -> - let mc = ByteFile(infile |> FileSystem.ReadAllBytesShim) - let modul, ilAssemblyRefs, pdb = genOpenBinaryReader infile mc opts - { modul = modul - ilAssemblyRefs = ilAssemblyRefs - dispose = (fun () -> - ClosePdbReader pdb) } +type ILReaderMetadataSnapshot = (obj * nativeint * int) +type ILReaderTryGetMetadataSnapshot = (* path: *) string * (* snapshotTimeStamp: *) System.DateTime -> ILReaderMetadataSnapshot option + +[] +type MetadataOnlyFlag = Yes | No + +[] +type ReduceMemoryFlag = Yes | No +type ILReaderOptions = + { pdbPath: string option + ilGlobals: ILGlobals + reduceMemoryUsage: ReduceMemoryFlag + metadataOnly: MetadataOnlyFlag + tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot } + +[] +type ILModuleReader(ilModule: ILModuleDef, ilAssemblyRefs: Lazy, dispose: unit -> unit) = + member x.ILModuleDef = ilModule + member x.ILAssemblyRefs = ilAssemblyRefs.Force() + interface IDisposable with + member x.Dispose() = dispose() + // ++GLOBAL MUTABLE STATE (concurrency safe via locking) type ILModuleReaderCacheLockToken() = interface LockToken -let ilModuleReaderCache = new AgedLookup(0, areSimilar=(fun (x, y) -> x = y)) +let ilModuleReaderCache = new AgedLookup(0, areSimilar=(fun (x, y) -> x = y)) let ilModuleReaderCacheLock = Lock() -let OpenILModuleReaderAfterReadingAllBytes infile opts = +let stableFileHeuristicApplies fileName = + not noStableFileHeuristic && try FileSystem.IsStableFileHeuristic fileName with _ -> false + +let createByteFile opts fileName = + // If we're trying to reduce memory usage then we are willing to go back and re-read the binary, so we can use + // a weakly-held handle to an array of bytes. + if opts.reduceMemoryUsage = ReduceMemoryFlag.Yes && stableFileHeuristicApplies fileName then + WeakByteFile(fileName) :> BinaryFile + else + let bytes = FileSystem.ReadAllBytesShim(fileName) + ByteFile(fileName, bytes) :> BinaryFile + +let tryMemoryMap opts fileName = + let file = + try + MemoryMapFile.Create fileName :> BinaryFile + with _ -> + createByteFile opts fileName + let disposer = + { new IDisposable with + member __.Dispose() = + match file with + | :? MemoryMapFile as m -> m.Close() // Note that the PE file reader is not required after this point for metadata-only reading + | _ -> () } + disposer, file + +let OpenILModuleReaderFromBytes fileName bytes opts = + let pefile = ByteFile(fileName, bytes) :> BinaryFile + let ilModule, ilAssemblyRefs, pdb = openPE (fileName, pefile, opts.pdbPath, (opts.reduceMemoryUsage = ReduceMemoryFlag.Yes), opts.ilGlobals) + new ILModuleReader(ilModule, ilAssemblyRefs, (fun () -> ClosePdbReader pdb)) + +let OpenILModuleReader fileName opts = // Pseudo-normalize the paths. - let key, succeeded = + let ((_,writeStamp,_,_,_,_) as key), keyOk = try - (FileSystem.GetFullPathShim(infile), - FileSystem.GetLastWriteTimeShim(infile), + (FileSystem.GetFullPathShim(fileName), + FileSystem.GetLastWriteTimeShim(fileName), opts.ilGlobals.primaryAssemblyScopeRef, - opts.pdbPath.IsSome), true + opts.pdbPath.IsSome, + opts.reduceMemoryUsage, + opts.metadataOnly), true with e -> - System.Diagnostics.Debug.Assert(false, sprintf "Failed to compute key in OpenILModuleReaderAfterReadingAllBytes cache for '%s'. Falling back to uncached." infile) - ("", System.DateTime.UtcNow, ILScopeRef.Local, false), false + System.Diagnostics.Debug.Assert(false, sprintf "Failed to compute key in OpenILModuleReader cache for '%s'. Falling back to uncached." fileName) + ("", System.DateTime.UtcNow, ILScopeRef.Local, false, ReduceMemoryFlag.Yes, MetadataOnlyFlag.Yes), false let cacheResult = - if not succeeded then None // Fall back to uncached. - else if opts.pdbPath.IsSome then None // can't used a cached entry when reading PDBs, since it makes the returned object IDisposable - else ilModuleReaderCacheLock.AcquireLock (fun ltok -> ilModuleReaderCache.TryGet(ltok, key)) + if keyOk then + if opts.pdbPath.IsSome then None // can't used a cached entry when reading PDBs, since it makes the returned object IDisposable + else ilModuleReaderCacheLock.AcquireLock (fun ltok -> ilModuleReaderCache.TryGet(ltok, key)) + else + None match cacheResult with - | Some(ilModuleReader) -> ilModuleReader + | Some ilModuleReader -> ilModuleReader | None -> - let mc = ByteFile(infile |> FileSystem.ReadAllBytesShim) - let modul, ilAssemblyRefs, pdb = genOpenBinaryReader infile mc opts + + let reduceMemoryUsage = (opts.reduceMemoryUsage = ReduceMemoryFlag.Yes) + let metadataOnly = (opts.metadataOnly = MetadataOnlyFlag.Yes) + + if reduceMemoryUsage && opts.pdbPath.IsNone then + + // This case is used in FCS applications, devenv.exe and fsi.exe + // let ilModuleReader = - { modul = modul - ilAssemblyRefs = ilAssemblyRefs - dispose = (fun () -> ClosePdbReader pdb) } - if Option.isNone pdb && succeeded then + // Check if we are doing metadataOnly reading (the most common case in both the compiler and IDE) + if metadataOnly then + + // See if tryGetMetadata gives us a BinaryFile for the metadata section alone. + let mdfileOpt = + match opts.tryGetMetadataSnapshot (fileName, writeStamp) with + | Some (obj, start, len) -> Some (RawMemoryFile(fileName, obj, start, len) :> BinaryFile) + | None -> None + + // For metadata-only, always use a temporary, short-lived PE file reader, preferably over a memory mapped file. + // Then use the metadata blob as the long-lived memory resource. + let disposer, pefileEager = tryMemoryMap opts fileName + use _disposer = disposer + let (metadataPhysLoc, metadataSize, peinfo, pectxtEager, pevEager, _pdb) = openPEFileReader (fileName, pefileEager, None) + let mdfile = + match mdfileOpt with + | Some mdfile -> mdfile + | None -> + // If tryGetMetadata doesn't give anything, then just read the metadata chunk out of the binary + let bytes = File.ReadBinaryChunk (fileName, metadataPhysLoc, metadataSize) + ByteFile(fileName, bytes) :> BinaryFile + + let ilModule, ilAssemblyRefs = openPEMetadataOnly (fileName, peinfo, pectxtEager, pevEager, mdfile, reduceMemoryUsage, opts.ilGlobals) + new ILModuleReader(ilModule, ilAssemblyRefs, ignore) + else + // If we are not doing metadata-only, then just go ahead and read all the bytes and hold them either strongly or weakly + // depending on the heuristic + let pefile = createByteFile opts fileName + let ilModule, ilAssemblyRefs, _pdb = openPE (fileName, pefile, None, reduceMemoryUsage, opts.ilGlobals) + new ILModuleReader(ilModule, ilAssemblyRefs, ignore) + + if keyOk then ilModuleReaderCacheLock.AcquireLock (fun ltok -> ilModuleReaderCache.Put(ltok, key, ilModuleReader)) - ilModuleReader -let OpenILModuleReaderFromBytes fileNameForDebugOutput bytes opts = - assert opts.pdbPath.IsNone - let mc = ByteFile(bytes) - let modul, ilAssemblyRefs, pdb = genOpenBinaryReader fileNameForDebugOutput mc opts - let ilModuleReader = - { modul = modul - ilAssemblyRefs = ilAssemblyRefs - dispose = (fun () -> ClosePdbReader pdb) } ilModuleReader + + else + // This case is primarily used in fsc.exe. + // + // In fsc.exe, we're not trying to reduce memory usage, nor do we really care if we leak memory. + // + // Note we ignore the "metadata only" flag as it's generally OK to read in the + // whole binary for the command-line compiler: address space is rarely an issue. + // + // We do however care about avoiding locks on files that prevent their deletion during a + // multi-proc build. So use memory mapping, but only for stable files. Other files + // fill use an in-memory ByteFile + let _disposer, pefile = + if alwaysMemoryMapFSC || stableFileHeuristicApplies fileName then + tryMemoryMap opts fileName + else + let pefile = createByteFile opts fileName + let disposer = { new IDisposable with member __.Dispose() = () } + disposer, pefile + + let ilModule, ilAssemblyRefs, pdb = openPE (fileName, pefile, opts.pdbPath, reduceMemoryUsage, opts.ilGlobals) + let ilModuleReader = new ILModuleReader(ilModule, ilAssemblyRefs, (fun () -> ClosePdbReader pdb)) + + // Readers with PDB reader disposal logic don't go in the cache. Note the PDB reader is only used in static linking. + if keyOk && opts.pdbPath.IsNone then + ilModuleReaderCacheLock.AcquireLock (fun ltok -> ilModuleReaderCache.Put(ltok, key, ilModuleReader)) + ilModuleReader diff --git a/src/absil/ilread.fsi b/src/absil/ilread.fsi index c69312f037..8101e4d4ef 100755 --- a/src/absil/ilread.fsi +++ b/src/absil/ilread.fsi @@ -24,7 +24,7 @@ /// class. That is not particularly satisfactory, and it may be /// a good idea to build a small library which extracts the information /// you need. -module internal Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader +module Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL @@ -33,35 +33,60 @@ open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.ErrorLogger open System.IO +/// Used to implement a Binary file over native memory, used by Roslyn integration +type ILReaderMetadataSnapshot = (obj * nativeint * int) +type ILReaderTryGetMetadataSnapshot = (* path: *) string * (* snapshotTimeStamp: *) System.DateTime -> ILReaderMetadataSnapshot option -type ILReaderOptions = - { pdbPath: string option; - ilGlobals: ILGlobals; - optimizeForMemory: bool (* normally off, i.e. optimize for startup-path speed *) } +[] +type internal MetadataOnlyFlag = Yes | No -val mkDefault : ILGlobals -> ILReaderOptions +[] +type internal ReduceMemoryFlag = Yes | No -// The non-memory resources (i.e. the file handle) associated with -// the read can be recovered by calling Dispose. Any remaining -// lazily-computed items in the metadata graph returned by MetadataOfILModuleReader -// will no longer be valid. +type internal ILReaderOptions = + { pdbPath: string option + + ilGlobals: ILGlobals + + // fsc.exe does not use reduceMemoryUsage (hence keeps MORE caches in AbstractIL and MORE memory mapping and MORE memory hogging but FASTER and SIMPLER file access) + // fsi.exe does uses reduceMemoryUsage (hence keeps FEWER caches in AbstractIL and LESS memory mapping and LESS memory hogging but slightly SLOWER file access), because its long running + // FCS uses reduceMemoryUsage (hence keeps FEWER caches in AbstractIL and LESS memory mapping and LESS memory hogging), because it is typically long running + reduceMemoryUsage: ReduceMemoryFlag + + /// Only open a metadata reader for the metadata portion of the .NET binary without keeping alive any data associated with the PE reader + /// - IL code will not be available (mdBody in ILMethodDef will return NotAvailable) + /// - Managed resources will be reported back as ILResourceLocation.LocalIn (as always) + /// - Native resources will not be available (none will be returned) + /// - Static data associated with fields will not be available + metadataOnly: MetadataOnlyFlag + + /// A function to call to try to get an object that acts as a snapshot of the metadata section of a .NET binary, + /// and from which we can read the metadata. Only used when metadataOnly=true. + tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot } + +/// Represents a reader of the metadata of a .NET binary. May also give some values (e.g. IL code) from the PE file +/// if it was provided. [] -type ILModuleReader = +type internal ILModuleReader = member ILModuleDef : ILModuleDef member ILAssemblyRefs : ILAssemblyRef list + + /// ILModuleReader objects only need to be explicitly disposed if memory mapping is used, i.e. reduceMemoryUsage = false interface System.IDisposable -val OpenILModuleReader: string -> ILReaderOptions -> ILModuleReader - /// Open a binary reader, except first copy the entire contents of the binary into /// memory, close the file and ensure any subsequent reads happen from the in-memory store. /// PDB files may not be read with this option. -val OpenILModuleReaderAfterReadingAllBytes: string -> ILReaderOptions -> ILModuleReader +val internal OpenILModuleReader: string -> ILReaderOptions -> ILModuleReader /// Open a binary reader based on the given bytes. -val OpenILModuleReaderFromBytes: fileNameForDebugOutput:string -> assemblyContents: byte[] -> options: ILReaderOptions -> ILModuleReader +val internal OpenILModuleReaderFromBytes: fileNameForDebugOutput:string -> assemblyContents: byte[] -> options: ILReaderOptions -> ILModuleReader + +type Statistics = + { mutable rawMemoryFileCount : int + mutable memoryMapFileOpenedCount : int + mutable memoryMapFileClosedCount : int + mutable weakByteFileCount : int + mutable byteFileCount : int } -#if STATISTICS -(* report statistics from all reads *) -val report: TextWriter -> unit -#endif +val GetStatistics : unit -> Statistics \ No newline at end of file diff --git a/src/absil/ilreflect.fs b/src/absil/ilreflect.fs index 8f040838c6..841c16bb98 100755 --- a/src/absil/ilreflect.fs +++ b/src/absil/ilreflect.fs @@ -1385,9 +1385,10 @@ let emitILMethodBody cenv modB emEnv (ilG:ILGenerator) (ilmbody: ILMethodBody) = let emitMethodBody cenv modB emEnv ilG _name (mbody: ILLazyMethodBody) = match mbody.Contents with | MethodBody.IL ilmbody -> emitILMethodBody cenv modB emEnv (ilG()) ilmbody - | MethodBody.PInvoke _pinvoke -> () (* printf "EMIT: pinvoke method %s\n" name *) (* XXX - check *) - | MethodBody.Abstract -> () (* printf "EMIT: abstract method %s\n" name *) (* XXX - check *) - | MethodBody.Native -> failwith "emitMethodBody cenv: native" (* XXX - gap *) + | MethodBody.PInvoke _pinvoke -> () + | MethodBody.Abstract -> () + | MethodBody.Native -> failwith "emitMethodBody: native" + | MethodBody.NotAvailable -> failwith "emitMethodBody: metadata only" let convCustomAttr cenv emEnv cattr = let methInfo = @@ -1430,7 +1431,7 @@ let buildGenParamsPass1b cenv emEnv (genArgs : Type array) (gps : ILGenericParam | _ -> failwith "buildGenParam: multiple base types" ); // set interface constraints (interfaces that instances of gp must meet) - gpB.SetInterfaceConstraints(Array.ofList interfaceTs); + gpB.SetInterfaceConstraints(Array.ofList interfaceTs) gp.CustomAttrs |> emitCustomAttrs cenv emEnv (wrapCustomAttr gpB.SetCustomAttribute) let flags = GenericParameterAttributes.None @@ -1474,17 +1475,12 @@ let rec buildMethodPass2 cenv tref (typB:TypeBuilder) emEnv (mdef : ILMethodDef) let implflags = mdef.ImplAttributes let cconv = convCallConv mdef.CallingConv let mref = mkRefToILMethod (tref, mdef) - let emEnv = if mdef.IsEntryPoint && isNil mdef.ParameterTypes then - (* Bug 2209: - Here, we collect the entry points generated by ilxgen corresponding to the top-level effects. - Users can (now) annotate their own functions with EntryPoint attributes. - However, these user entry points functions must take string[] argument. - By only adding entry points with no arguments, we only collect the top-level effects. - *) - envAddEntryPt emEnv (typB, mdef.Name) - else - emEnv - match mdef.mdBody.Contents with + let emEnv = + if mdef.IsEntryPoint && isNil mdef.ParameterTypes then + envAddEntryPt emEnv (typB, mdef.Name) + else + emEnv + match mdef.Body.Contents with #if !FX_RESHAPED_REFEMIT | MethodBody.PInvoke p -> let argtys = convTypesToArray cenv emEnv mdef.ParameterTypes @@ -1508,17 +1504,7 @@ let rec buildMethodPass2 cenv tref (typB:TypeBuilder) emEnv (mdef : ILMethodDef) (* p.CharBestFit *) (* p.NoMangle *) - let methB = typB.DefinePInvokeMethod(mdef.Name, - p.Where.Name, - p.Name, - attrs, - cconv, - rty, - null, null, - argtys, - null, null, - pcc, - pcs) + let methB = typB.DefinePInvokeMethod(mdef.Name, p.Where.Name, p.Name, attrs, cconv, rty, null, null, argtys, null, null, pcc, pcs) methB.SetImplementationFlagsAndLog(implflags); envBindMethodRef emEnv mref methB #endif @@ -1554,7 +1540,7 @@ let rec buildMethodPass2 cenv tref (typB:TypeBuilder) emEnv (mdef : ILMethodDef) let rec buildMethodPass3 cenv tref modB (typB:TypeBuilder) emEnv (mdef : ILMethodDef) = let mref = mkRefToILMethod (tref, mdef) let isPInvoke = - match mdef.mdBody.Contents with + match mdef.Body.Contents with | MethodBody.PInvoke _p -> true | _ -> false match mdef.Name with @@ -1566,7 +1552,7 @@ let rec buildMethodPass3 cenv tref modB (typB:TypeBuilder) emEnv (mdef : ILMetho let defineParameter (i, attr, name) = consB.DefineParameterAndLog(i+1, attr, name) mdef.Parameters |> List.iteri (emitParameter cenv emEnv defineParameter); // Body - emitMethodBody cenv modB emEnv consB.GetILGenerator mdef.Name mdef.mdBody; + emitMethodBody cenv modB emEnv consB.GetILGenerator mdef.Name mdef.Body; emitCustomAttrs cenv emEnv (wrapCustomAttr consB.SetCustomAttribute) mdef.CustomAttrs; () | _name -> @@ -1587,7 +1573,7 @@ let rec buildMethodPass3 cenv tref modB (typB:TypeBuilder) emEnv (mdef : ILMetho mdef.Parameters |> List.iteri (fun a b -> emitParameter cenv emEnv defineParameter a b); // Body if not isPInvoke then - emitMethodBody cenv modB emEnv methB.GetILGeneratorAndLog mdef.Name mdef.mdBody; + emitMethodBody cenv modB emEnv methB.GetILGeneratorAndLog mdef.Name mdef.Body; let emEnv = envPopTyvars emEnv // case fold later... emitCustomAttrs cenv emEnv methB.SetCustomAttributeAndLog mdef.CustomAttrs @@ -1597,11 +1583,8 @@ let rec buildMethodPass3 cenv tref modB (typB:TypeBuilder) emEnv (mdef : ILMetho let buildFieldPass2 cenv tref (typB:TypeBuilder) emEnv (fdef : ILFieldDef) = - (*{ -Data: bytes option; - -Marshal: NativeType option; *) - let attrs = fdef.Attributes - let fieldT = convType cenv emEnv fdef.Type + let fieldT = convType cenv emEnv fdef.FieldType let fieldB = match fdef.Data with | Some d -> typB.DefineInitializedData(fdef.Name, d, attrs) @@ -1628,11 +1611,11 @@ let buildFieldPass2 cenv tref (typB:TypeBuilder) emEnv (fdef : ILFieldDef) = fdef.Offset |> Option.iter (fun offset -> fieldB.SetOffset(offset)); // custom attributes: done on pass 3 as they may reference attribute constructors generated on // pass 2. - let fref = mkILFieldRef (tref, fdef.Name, fdef.Type) + let fref = mkILFieldRef (tref, fdef.Name, fdef.FieldType) envBindFieldRef emEnv fref fieldB let buildFieldPass3 cenv tref (_typB:TypeBuilder) emEnv (fdef : ILFieldDef) = - let fref = mkILFieldRef (tref, fdef.Name, fdef.Type) + let fref = mkILFieldRef (tref, fdef.Name, fdef.FieldType) let fieldB = envGetFieldB emEnv fref emitCustomAttrs cenv emEnv (wrapCustomAttr fieldB.SetCustomAttribute) fdef.CustomAttrs @@ -1644,7 +1627,7 @@ let buildPropertyPass2 cenv tref (typB:TypeBuilder) emEnv (prop : ILPropertyDef) let attrs = flagsIf prop.IsRTSpecialName PropertyAttributes.RTSpecialName ||| flagsIf prop.IsSpecialName PropertyAttributes.SpecialName - let propB = typB.DefinePropertyAndLog(prop.Name, attrs, convType cenv emEnv prop.Type, convTypesToArray cenv emEnv prop.Args) + let propB = typB.DefinePropertyAndLog(prop.Name, attrs, convType cenv emEnv prop.PropertyType, convTypesToArray cenv emEnv prop.Args) prop.SetMethod |> Option.iter (fun mref -> propB.SetSetMethod(envGetMethB emEnv mref)); prop.GetMethod |> Option.iter (fun mref -> propB.SetGetMethod(envGetMethB emEnv mref)); @@ -1667,8 +1650,8 @@ let buildPropertyPass3 cenv tref (_typB:TypeBuilder) emEnv (prop : ILPropertyDef let buildEventPass3 cenv (typB:TypeBuilder) emEnv (eventDef : ILEventDef) = let attrs = flagsIf eventDef.IsSpecialName EventAttributes.SpecialName ||| flagsIf eventDef.IsRTSpecialName EventAttributes.RTSpecialName - assert eventDef.Type.IsSome - let eventB = typB.DefineEventAndLog(eventDef.Name, attrs, convType cenv emEnv eventDef.Type.Value) + assert eventDef.EventType.IsSome + let eventB = typB.DefineEventAndLog(eventDef.Name, attrs, convType cenv emEnv eventDef.EventType.Value) eventDef.AddMethod |> (fun mref -> eventB.SetAddOnMethod(envGetMethB emEnv mref)); eventDef.RemoveMethod |> (fun mref -> eventB.SetRemoveOnMethod(envGetMethB emEnv mref)); @@ -1911,33 +1894,33 @@ let verbose2 = false let createTypeRef (visited : Dictionary<_, _>, created : Dictionary<_, _>) emEnv tref = let rec traverseTypeDef (tref:ILTypeRef) (tdef:ILTypeDef) = - if verbose2 then dprintf "buildTypeDefPass4: Creating Enclosing Types of %s\n" tdef.Name; + if verbose2 then dprintf "buildTypeDefPass4: Creating Enclosing Types of %s\n" tdef.Name for enc in getEnclosingTypeRefs tref do traverseTypeRef enc // WORKAROUND (ProductStudio FSharp 1.0 bug 615): the constraints on generic method parameters // are resolved overly eagerly by reflection emit's CreateType. - if verbose2 then dprintf "buildTypeDefPass4: Doing type typar constraints of %s\n" tdef.Name; + if verbose2 then dprintf "buildTypeDefPass4: Doing type typar constraints of %s\n" tdef.Name for gp in tdef.GenericParams do for cx in gp.Constraints do traverseType CollectTypes.All cx - if verbose2 then dprintf "buildTypeDefPass4: Doing method constraints of %s\n" tdef.Name; + if verbose2 then dprintf "buildTypeDefPass4: Doing method constraints of %s\n" tdef.Name for md in tdef.Methods.AsList do for gp in md.GenericParams do for cx in gp.Constraints do traverseType CollectTypes.All cx // We absolutely need the exact parent type... - if verbose2 then dprintf "buildTypeDefPass4: Creating Super Class Chain of %s\n" tdef.Name; + if verbose2 then dprintf "buildTypeDefPass4: Creating Super Class Chain of %s\n" tdef.Name tdef.Extends |> Option.iter (traverseType CollectTypes.All) // We absolutely need the exact interface types... - if verbose2 then dprintf "buildTypeDefPass4: Creating Interface Chain of %s\n" tdef.Name; + if verbose2 then dprintf "buildTypeDefPass4: Creating Interface Chain of %s\n" tdef.Name tdef.Implements |> List.iter (traverseType CollectTypes.All) - if verbose2 then dprintf "buildTypeDefPass4: Do value types in fields of %s\n" tdef.Name; - tdef.Fields.AsList |> List.iter (fun fd -> traverseType CollectTypes.ValueTypesOnly fd.Type) + if verbose2 then dprintf "buildTypeDefPass4: Do value types in fields of %s\n" tdef.Name + tdef.Fields.AsList |> List.iter (fun fd -> traverseType CollectTypes.ValueTypesOnly fd.FieldType) if verbose2 then dprintf "buildTypeDefPass4: Done with dependencies of %s\n" tdef.Name @@ -2041,8 +2024,11 @@ let buildModuleFragment cenv emEnv (asmB : AssemblyBuilder) (modB : ModuleBuilde m.Resources.AsList |> List.iter (fun r -> let attribs = (match r.Access with ILResourceAccess.Public -> ResourceAttributes.Public | ILResourceAccess.Private -> ResourceAttributes.Private) match r.Location with - | ILResourceLocation.Local bf -> - modB.DefineManifestResourceAndLog(r.Name, new System.IO.MemoryStream(bf()), attribs) + | ILResourceLocation.LocalIn (file, start, len) -> + let bytes = FileSystem.ReadAllBytesShim(file).[start .. start + len - 1] + modB.DefineManifestResourceAndLog(r.Name, new System.IO.MemoryStream(bytes), attribs) + | ILResourceLocation.LocalOut bytes -> + modB.DefineManifestResourceAndLog(r.Name, new System.IO.MemoryStream(bytes), attribs) | ILResourceLocation.File (mr, _) -> asmB.AddResourceFileAndLog(r.Name, mr.Name, attribs) | ILResourceLocation.Assembly _ -> diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs index 255a3e6193..b7ef6be5f5 100755 --- a/src/absil/ilwrite.fs +++ b/src/absil/ilwrite.fs @@ -1120,7 +1120,7 @@ and GetTypeDefAsEventMapRow cenv tidx = SimpleIndex (TableNames.Event, cenv.eventDefs.Count + 1) |] and GetKeyForFieldDef tidx (fd: ILFieldDef) = - FieldDefKey (tidx, fd.Name, fd.Type) + FieldDefKey (tidx, fd.Name, fd.FieldType) and GenFieldDefPass2 cenv tidx fd = ignore (cenv.fieldDefs.AddUniqueEntry "field" (fun (fdkey:FieldDefKey) -> fdkey.Name) (GetKeyForFieldDef tidx fd)) @@ -1144,7 +1144,7 @@ and GenMethodDefPass2 cenv tidx md = cenv.methodDefIdxs.[md] <- idx and GetKeyForPropertyDef tidx (x: ILPropertyDef) = - PropKey (tidx, x.Name, x.Type, x.Args) + PropKey (tidx, x.Name, x.PropertyType, x.Args) and GenPropertyDefPass2 cenv tidx x = ignore (cenv.propertyDefs.AddUniqueEntry "property" (fun (PropKey (_, n, _, _)) -> n) (GetKeyForPropertyDef tidx x)) @@ -1307,10 +1307,10 @@ and GetMethodDefOrRefAsUncodedToken (tag, idx) = getUncodedToken tab idx and GetMethodSpecInfoAsUncodedToken cenv env ((_, _, _, _, _, _, minst:ILGenericArgs) as minfo) = - if minst.Length > 0 then - getUncodedToken TableNames.MethodSpec (GetMethodSpecInfoAsMethodSpecIdx cenv env minfo) - else - GetMethodDefOrRefAsUncodedToken (GetMethodRefInfoAsMethodRefOrDef false cenv env (GetMethodRefInfoOfMethodSpecInfo minfo)) + if List.isEmpty minst then + GetMethodDefOrRefAsUncodedToken (GetMethodRefInfoAsMethodRefOrDef false cenv env (GetMethodRefInfoOfMethodSpecInfo minfo)) + else + getUncodedToken TableNames.MethodSpec (GetMethodSpecInfoAsMethodSpecIdx cenv env minfo) and GetMethodSpecAsUncodedToken cenv env mspec = GetMethodSpecInfoAsUncodedToken cenv env (InfoOfMethodSpec mspec) @@ -1400,10 +1400,10 @@ and GenCustomAttrsPass3Or4 cenv hca (attrs: ILAttributes) = attrs.AsList |> List.iter (GenCustomAttrPass3Or4 cenv hca) // -------------------------------------------------------------------- -// ILPermissionSet --> DeclSecurity rows +// ILSecurityDecl --> DeclSecurity rows // -------------------------------------------------------------------- *) -let rec GetSecurityDeclRow cenv hds (PermissionSet (action, s)) = +let rec GetSecurityDeclRow cenv hds (ILSecurityDecl (action, s)) = UnsharedRow [| UShort (uint16 (List.assoc action (Lazy.force ILSecurityActionMap))) HasDeclSecurity (fst hds, snd hds) @@ -2323,7 +2323,7 @@ let rec GetFieldDefAsFieldDefRow cenv env (fd: ILFieldDef) = StringE (GetStringHeapIdx cenv fd.Name) Blob (GetFieldDefSigAsBlobIdx cenv env fd ) |] -and GetFieldDefSigAsBlobIdx cenv env fd = GetFieldDefTypeAsBlobIdx cenv env fd.Type +and GetFieldDefSigAsBlobIdx cenv env fd = GetFieldDefTypeAsBlobIdx cenv env fd.FieldType and GenFieldDefPass3 cenv env fd = let fidx = AddUnsharedRow cenv TableNames.Field (GetFieldDefAsFieldDefRow cenv env fd) @@ -2475,7 +2475,7 @@ let GenReturnPass3 cenv (returnv: ILReturn) = let GetMethodDefSigAsBytes cenv env (mdef: ILMethodDef) = emitBytesViaBuffer (fun bb -> bb.EmitByte (callconvToByte mdef.GenericParams.Length mdef.CallingConv) - if mdef.GenericParams.Length > 0 then bb.EmitZ32 mdef.GenericParams.Length + if not (List.isEmpty mdef.GenericParams) then bb.EmitZ32 mdef.GenericParams.Length bb.EmitZ32 mdef.Parameters.Length EmitType cenv env bb mdef.Return.Type mdef.ParameterTypes |> List.iter (EmitType cenv env bb)) @@ -2492,7 +2492,7 @@ let GenMethodDefAsRow cenv env midx (md: ILMethodDef) = if cenv.entrypoint <> None then failwith "duplicate entrypoint" else cenv.entrypoint <- Some (true, midx) let codeAddr = - (match md.mdBody.Contents with + (match md.Body.Contents with | MethodBody.IL ilmbody -> let addr = cenv.nextCodeAddr let (localToken, code, seqpoints, rootScope) = GenILMethodBody md.Name cenv env ilmbody @@ -2563,7 +2563,7 @@ let GenMethodDefPass3 cenv env (md:ILMethodDef) = md.CustomAttrs |> GenCustomAttrsPass3Or4 cenv (hca_MethodDef, midx) md.SecurityDecls.AsList |> GenSecurityDeclsPass3 cenv (hds_MethodDef, midx) md.GenericParams |> List.iteri (fun n gp -> GenGenericParamPass3 cenv env n (tomd_MethodDef, midx) gp) - match md.mdBody.Contents with + match md.Body.Contents with | MethodBody.PInvoke attr -> let flags = begin match attr.CallingConv with @@ -2616,12 +2616,12 @@ let GenPropertyMethodSemanticsPass3 cenv pidx kind mref = let rec GetPropertySigAsBlobIdx cenv env prop = GetBytesAsBlobIdx cenv (GetPropertySigAsBytes cenv env prop) -and GetPropertySigAsBytes cenv env prop = +and GetPropertySigAsBytes cenv env (prop: ILPropertyDef) = emitBytesViaBuffer (fun bb -> let b = ((hasthisToByte prop.CallingConv) ||| e_IMAGE_CEE_CS_CALLCONV_PROPERTY) bb.EmitByte b bb.EmitZ32 prop.Args.Length - EmitType cenv env bb prop.Type + EmitType cenv env bb prop.PropertyType prop.Args |> List.iter (EmitType cenv env bb)) and GetPropertyAsPropertyRow cenv env (prop:ILPropertyDef) = @@ -2658,7 +2658,7 @@ let rec GenEventMethodSemanticsPass3 cenv eidx kind mref = /// ILEventDef --> Event Row + MethodSemantics entries and GenEventAsEventRow cenv env (md: ILEventDef) = let flags = md.Attributes - let tdorTag, tdorRow = GetTypeOptionAsTypeDefOrRef cenv env md.Type + let tdorTag, tdorRow = GetTypeOptionAsTypeDefOrRef cenv env md.EventType UnsharedRow [| UShort (uint16 flags) StringE (GetStringHeapIdx cenv md.Name) @@ -2680,17 +2680,18 @@ and GenEventPass3 cenv env (md: ILEventDef) = let rec GetResourceAsManifestResourceRow cenv r = let data, impl = match r.Location with - | ILResourceLocation.Local bf -> - let b = bf() + | ILResourceLocation.LocalIn _ + | ILResourceLocation.LocalOut _ -> + let bytes = r.GetBytes() // Embedded managed resources must be word-aligned. However resource format is // not specified in ECMA. Some mscorlib resources appear to be non-aligned - it seems it doesn't matter.. let offset = cenv.resources.Position let alignedOffset = (align 0x8 offset) let pad = alignedOffset - offset - let resourceSize = b.Length + let resourceSize = bytes.Length cenv.resources.EmitPadding pad cenv.resources.EmitInt32 resourceSize - cenv.resources.EmitBytes b + cenv.resources.EmitBytes bytes Data (alignedOffset, true), (i_File, 0) | ILResourceLocation.File (mref, offset) -> ULong offset, (i_File, GetModuleRefAsFileIdx cenv mref) | ILResourceLocation.Assembly aref -> ULong 0x0, (i_AssemblyRef, GetAssemblyRefAsIdx cenv aref) @@ -3712,7 +3713,13 @@ let writeBinaryAndReportMappings (outfile, ignore resourceFormat [||] #else - let unlinkedResources = List.map Lazy.force resources + let unlinkedResources = + resources |> List.map (function + | ILNativeResource.Out bytes -> bytes + | ILNativeResource.In (fileName, linkedResourceBase, start, len) -> + let linkedResource = File.ReadBinaryChunk (fileName, start, len) + unlinkResource linkedResourceBase linkedResource) + begin try linkNativeResources unlinkedResources next resourceFormat (Path.GetDirectoryName(outfile)) with e -> failwith ("Linking a native resource failed: "+e.Message+"") diff --git a/src/absil/ilwritepdb.fs b/src/absil/ilwritepdb.fs index f8baa3aea4..760ac9e428 100644 --- a/src/absil/ilwritepdb.fs +++ b/src/absil/ilwritepdb.fs @@ -423,22 +423,15 @@ let generatePortablePdb (embedAllSource:bool) (embedSourceList:string list) (sou list.ToArray() |> Array.sortWith scopeSorter collectScopes scope |> Seq.iter(fun s -> - if s.Children.Length = 0 then - metadata.AddLocalScope(MetadataTokens.MethodDefinitionHandle(minfo.MethToken), - Unchecked.defaultof, - nextHandle lastLocalVariableHandle, - Unchecked.defaultof, - 0, s.EndOffset - s.StartOffset ) |>ignore - else - metadata.AddLocalScope(MetadataTokens.MethodDefinitionHandle(minfo.MethToken), - Unchecked.defaultof, - nextHandle lastLocalVariableHandle, - Unchecked.defaultof, - s.StartOffset, s.EndOffset - s.StartOffset) |>ignore - - for localVariable in s.Locals do - lastLocalVariableHandle <- metadata.AddLocalVariable(LocalVariableAttributes.None, localVariable.Index, metadata.GetOrAddString(localVariable.Name)) - ) + metadata.AddLocalScope(MetadataTokens.MethodDefinitionHandle(minfo.MethToken), + Unchecked.defaultof, + nextHandle lastLocalVariableHandle, + Unchecked.defaultof, + s.StartOffset, s.EndOffset - s.StartOffset ) |>ignore + + for localVariable in s.Locals do + lastLocalVariableHandle <- metadata.AddLocalVariable(LocalVariableAttributes.None, localVariable.Index, metadata.GetOrAddString(localVariable.Name)) + ) match minfo.RootScope with | None -> () diff --git a/src/absil/ilx.fs b/src/absil/ilx.fs index d28ff3d2f4..1914ace9b0 100755 --- a/src/absil/ilx.fs +++ b/src/absil/ilx.fs @@ -22,7 +22,7 @@ let mkLowerName (nm: string) = type IlxUnionField(fd: ILFieldDef) = let lowerName = mkLowerName fd.Name member x.ILField = fd - member x.Type = x.ILField.Type + member x.Type = x.ILField.FieldType member x.Name = x.ILField.Name member x.LowerName = lowerName diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 7224d15740..7c0c6220f1 100755 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -18,6 +18,7 @@ open Internal.Utilities.Filename open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX @@ -153,6 +154,7 @@ let GetRangeOfDiagnostic(err:PhasedDiagnostic) = | InterfaceNotRevealed(_, _, m) | WrappedError (_, m) | PatternMatchCompilation.MatchIncomplete (_, _, m) + | PatternMatchCompilation.EnumMatchIncomplete (_, _, m) | PatternMatchCompilation.RuleNeverMatched m | ValNotMutable(_, _, m) | ValNotLocal(_, _, m) @@ -354,6 +356,7 @@ let GetDiagnosticNumber(err:PhasedDiagnostic) = | ExtensionTyping.ProvidedTypeResolutionNoRange _ | ExtensionTyping.ProvidedTypeResolution _ -> 103 #endif + | PatternMatchCompilation.EnumMatchIncomplete _ -> 104 (* DO NOT CHANGE THE NUMBERS *) // Strip TargetInvocationException wrappers @@ -559,6 +562,7 @@ let MatchIncomplete2E() = DeclareResourceString("MatchIncomplete2", "%s") let MatchIncomplete3E() = DeclareResourceString("MatchIncomplete3", "%s") let MatchIncomplete4E() = DeclareResourceString("MatchIncomplete4", "") let RuleNeverMatchedE() = DeclareResourceString("RuleNeverMatched", "") +let EnumMatchIncomplete1E() = DeclareResourceString("EnumMatchIncomplete1", "") let ValNotMutableE() = DeclareResourceString("ValNotMutable", "%s") let ValNotLocalE() = DeclareResourceString("ValNotLocal", "") let Obsolete1E() = DeclareResourceString("Obsolete1", "") @@ -1401,6 +1405,15 @@ let OutputPhasedErrorR (os:StringBuilder) (err:PhasedDiagnostic) = if isComp then os.Append(MatchIncomplete4E().Format) |> ignore + | PatternMatchCompilation.EnumMatchIncomplete (isComp, cexOpt, _) -> + os.Append(EnumMatchIncomplete1E().Format) |> ignore + match cexOpt with + | None -> () + | Some (cex, false) -> os.Append(MatchIncomplete2E().Format cex) |> ignore + | Some (cex, true) -> os.Append(MatchIncomplete3E().Format cex) |> ignore + if isComp then + os.Append(MatchIncomplete4E().Format) |> ignore + | PatternMatchCompilation.RuleNeverMatched _ -> os.Append(RuleNeverMatchedE().Format) |> ignore | ValNotMutable(_, valRef, _) -> os.Append(ValNotMutableE().Format(valRef.DisplayName)) |> ignore @@ -2036,6 +2049,7 @@ let ComputeMakePathAbsolute implicitIncludeDir (path : string) = // Configuration //---------------------------------------------------------------------------- +[] type CompilerTarget = | WinExe | ConsoleExe @@ -2043,8 +2057,12 @@ type CompilerTarget = | Module member x.IsExe = (match x with ConsoleExe | WinExe -> true | _ -> false) +[] type ResolveAssemblyReferenceMode = Speculative | ReportErrors +[] +type CopyFSharpCoreFlag = Yes | No + /// Represents the file or string used for the --version flag type VersionFlag = | VersionString of string @@ -2078,7 +2096,7 @@ type IRawFSharpAssemblyData = abstract GetInternalsVisibleToAttributes : ILGlobals -> string list /// The raw IL module definition in the assembly, if any. This is not present for cross-project references /// in the language service - abstract TryGetRawILModule : unit -> ILModuleDef option + abstract TryGetILModuleDef : unit -> ILModuleDef option /// The raw F# signature data in the assembly, if any abstract GetRawFSharpSignatureData : range * ilShortAssemName: string * fileName: string -> (string * byte[]) list /// The raw F# optimization data in the assembly, if any @@ -2179,13 +2197,13 @@ type CcuLoadFailureAction = | RaiseError | ReturnNone +[] type TcConfigBuilder = { mutable primaryAssembly : PrimaryAssembly mutable autoResolveOpenDirectivesToDlls: bool mutable noFeedback: bool mutable stackReserveSize: int32 option mutable implicitIncludeDir: string (* normally "." *) - mutable openBinariesInMemory: bool (* false for command line, true for VS *) mutable openDebugInformationForLaterStaticLinking: bool (* only for --standalone *) defaultFSharpBinariesDir: string mutable compilingFslib: bool @@ -2205,7 +2223,7 @@ type TcConfigBuilder = mutable referencedDLLs : AssemblyReference list mutable projectReferences : IProjectReference list mutable knownUnresolvedReferences : UnresolvedAssemblyReference list - optimizeForMemory: bool + reduceMemoryUsage: ReduceMemoryFlag mutable subsystemVersion : int * int mutable useHighEntropyVA : bool mutable inputCodePage: int option @@ -2316,9 +2334,6 @@ type TcConfigBuilder = isInvalidationSupported : bool /// used to log sqm data - mutable sqmSessionGuid : System.Guid option - mutable sqmNumOfSourceFiles : int - sqmSessionStartedTime : int64 /// if true - every expression in quotations will be augmented with full debug info (filename, location in file) mutable emitDebugInfoInQuotations : bool @@ -2326,10 +2341,15 @@ type TcConfigBuilder = mutable exename : string option // If true - the compiler will copy FSharp.Core.dll along the produced binaries - mutable copyFSharpCore : bool + mutable copyFSharpCore : CopyFSharpCoreFlag /// When false FSI will lock referenced assemblies requiring process restart, false = disable Shadow Copy false (*default*) mutable shadowCopyReferences : bool + + /// A function to call to try to get an object that acts as a snapshot of the metadata section of a .NET binary, + /// and from which we can read the metadata. Only used when metadataOnly=true. + mutable tryGetMetadataSnapshot : ILReaderTryGetMetadataSnapshot + } static member Initial = @@ -2345,7 +2365,6 @@ type TcConfigBuilder = conditionalCompilationDefines = [] implicitIncludeDir = String.Empty autoResolveOpenDirectivesToDlls = false - openBinariesInMemory = false openDebugInformationForLaterStaticLinking = false defaultFSharpBinariesDir = String.Empty compilingFslib = false @@ -2366,7 +2385,7 @@ type TcConfigBuilder = errorSeverityOptions = FSharpErrorSeverityOptions.Default embedResources = [] inputCodePage = None - optimizeForMemory = true + reduceMemoryUsage = ReduceMemoryFlag.Yes // always gets set explicitly subsystemVersion = 4, 0 // per spec for 357994 useHighEntropyVA = false mlCompatibility = false @@ -2376,7 +2395,7 @@ type TcConfigBuilder = platform = None prefer32Bit = false useSimpleResolution = runningOnMono - target = ConsoleExe + target = CompilerTarget.ConsoleExe debuginfo = false testFlagEmitFeeFeeAs100001 = false dumpDebugInfo = false @@ -2462,29 +2481,31 @@ type TcConfigBuilder = noDebugData = false isInteractive = false isInvalidationSupported = false - sqmSessionGuid = None - sqmNumOfSourceFiles = 0 - sqmSessionStartedTime = System.DateTime.UtcNow.Ticks emitDebugInfoInQuotations = false exename = None - copyFSharpCore = false + copyFSharpCore = CopyFSharpCoreFlag.No shadowCopyReferences = false + tryGetMetadataSnapshot = (fun _ -> None) } - static member CreateNew(legacyReferenceResolver, defaultFSharpBinariesDir, optimizeForMemory, implicitIncludeDir, - isInteractive, isInvalidationSupported, defaultCopyFSharpCore) = - Debug.Assert(FileSystem.IsPathRootedShim(implicitIncludeDir), sprintf "implicitIncludeDir should be absolute: '%s'" implicitIncludeDir) - if (String.IsNullOrEmpty(defaultFSharpBinariesDir)) then - failwith "Expected a valid defaultFSharpBinariesDir" - { TcConfigBuilder.Initial with - implicitIncludeDir = implicitIncludeDir - defaultFSharpBinariesDir = defaultFSharpBinariesDir - optimizeForMemory = optimizeForMemory - legacyReferenceResolver = legacyReferenceResolver - isInteractive = isInteractive - isInvalidationSupported = isInvalidationSupported - copyFSharpCore = defaultCopyFSharpCore - } + static member CreateNew(legacyReferenceResolver, defaultFSharpBinariesDir, reduceMemoryUsage, implicitIncludeDir, + isInteractive, isInvalidationSupported, defaultCopyFSharpCore, tryGetMetadataSnapshot) = + + Debug.Assert(FileSystem.IsPathRootedShim(implicitIncludeDir), sprintf "implicitIncludeDir should be absolute: '%s'" implicitIncludeDir) + + if (String.IsNullOrEmpty(defaultFSharpBinariesDir)) then + failwith "Expected a valid defaultFSharpBinariesDir" + + { TcConfigBuilder.Initial with + implicitIncludeDir = implicitIncludeDir + defaultFSharpBinariesDir = defaultFSharpBinariesDir + reduceMemoryUsage = reduceMemoryUsage + legacyReferenceResolver = legacyReferenceResolver + isInteractive = isInteractive + isInvalidationSupported = isInvalidationSupported + copyFSharpCore = defaultCopyFSharpCore + tryGetMetadataSnapshot = tryGetMetadataSnapshot + } member tcConfigB.ResolveSourceFile(m, nm, pathLoadedFrom) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter @@ -2494,7 +2515,7 @@ type TcConfigBuilder = member tcConfigB.DecideNames (sourceFiles) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter if sourceFiles = [] then errorR(Error(FSComp.SR.buildNoInputsSpecified(), rangeCmdArgs)) - let ext() = match tcConfigB.target with Dll -> ".dll" | Module -> ".netmodule" | ConsoleExe | WinExe -> ".exe" + let ext() = match tcConfigB.target with CompilerTarget.Dll -> ".dll" | CompilerTarget.Module -> ".netmodule" | CompilerTarget.ConsoleExe | CompilerTarget.WinExe -> ".exe" let implFiles = sourceFiles |> List.filter (fun lower -> List.exists (Filename.checkSuffix (String.lowercase lower)) FSharpImplFileSuffixes) let outfile = match tcConfigB.outputFile, List.rev implFiles with @@ -2607,7 +2628,7 @@ type TcConfigBuilder = ri, fileNameOfPath ri, ILResourceAccess.Public -let OpenILBinary(filename, optimizeForMemory, openBinariesInMemory, ilGlobalsOpt, pdbPathOption, shadowCopyReferences) = +let OpenILBinary(filename, reduceMemoryUsage, ilGlobalsOpt, pdbPathOption, shadowCopyReferences, tryGetMetadataSnapshot) = let ilGlobals = // ILScopeRef.Local can be used only for primary assembly (mscorlib or System.Runtime) itself // Remaining assemblies should be opened using existing ilGlobals (so they can properly locate fundamental types) @@ -2615,18 +2636,14 @@ let OpenILBinary(filename, optimizeForMemory, openBinariesInMemory, ilGlobalsOpt | None -> mkILGlobals ILScopeRef.Local | Some g -> g - let opts = { ILBinaryReader.mkDefault ilGlobals with - // fsc.exe does not uses optimizeForMemory (hence keeps MORE caches in AbstractIL) - // fsi.exe does use optimizeForMemory (hence keeps FEWER caches in AbstractIL), because its long running - // Visual Studio does use optimizeForMemory (hence keeps FEWER caches in AbstractIL), because its long running - ILBinaryReader.optimizeForMemory=optimizeForMemory - ILBinaryReader.pdbPath = pdbPathOption } + let opts : ILReaderOptions = + { ilGlobals = ilGlobals + metadataOnly = MetadataOnlyFlag.Yes + reduceMemoryUsage = reduceMemoryUsage + pdbPath = pdbPathOption + tryGetMetadataSnapshot = tryGetMetadataSnapshot } - // Visual Studio uses OpenILModuleReaderAfterReadingAllBytes for all DLLs to avoid having to dispose of any readers explicitly - if openBinariesInMemory then // && not syslib - ILBinaryReader.OpenILModuleReaderAfterReadingAllBytes filename opts - else - let location = + let location = #if !FX_RESHAPED_REFLECTION // shadow copy not supported // In order to use memory mapped files on the shadow copied version of the Assembly, we `preload the assembly // We swallow all exceptions so that we do not change the exception contract of this API @@ -2639,7 +2656,7 @@ let OpenILBinary(filename, optimizeForMemory, openBinariesInMemory, ilGlobalsOpt ignore shadowCopyReferences #endif filename - ILBinaryReader.OpenILModuleReader location opts + OpenILModuleReader location opts #if DEBUG [] @@ -2662,7 +2679,7 @@ type AssemblyResolution = /// This is because ``EvaluateRawContents(ctok)`` is used. However this path is only currently used /// in fsi.fs, which does not use project references. // - member this.GetILAssemblyRef(ctok) = + member this.GetILAssemblyRef(ctok, reduceMemoryUsage, tryGetMetadataSnapshot) = cancellable { match !this.ilAssemblyRef with | Some(assref) -> return assref @@ -2684,8 +2701,13 @@ type AssemblyResolution = match assRefOpt with | Some aref -> aref | None -> - let readerSettings : ILBinaryReader.ILReaderOptions = {pdbPath=None;ilGlobals = EcmaMscorlibILGlobals;optimizeForMemory=false} - use reader = ILBinaryReader.OpenILModuleReaderAfterReadingAllBytes this.resolvedPath readerSettings + let readerSettings : ILReaderOptions = + { pdbPath=None + ilGlobals = EcmaMscorlibILGlobals + reduceMemoryUsage = reduceMemoryUsage + metadataOnly = MetadataOnlyFlag.Yes + tryGetMetadataSnapshot = tryGetMetadataSnapshot } + use reader = OpenILModuleReader this.resolvedPath readerSettings mkRefToILAssembly reader.ILModuleDef.ManifestOfAssembly this.ilAssemblyRef := Some(assRef) return assRef @@ -2769,7 +2791,7 @@ type TcConfig private (data : TcConfigBuilder, validate:bool) = | Some(primaryAssemblyFilename) -> let filename = ComputeMakePathAbsolute data.implicitIncludeDir primaryAssemblyFilename try - use ilReader = OpenILBinary(filename, data.optimizeForMemory, data.openBinariesInMemory, None, None, data.shadowCopyReferences) + use ilReader = OpenILBinary(filename, data.reduceMemoryUsage, None, None, data.shadowCopyReferences, data.tryGetMetadataSnapshot) let ilModule = ilReader.ILModuleDef match ilModule.ManifestOfAssembly.Version with | Some(v1, v2, _, _) -> @@ -2798,11 +2820,11 @@ type TcConfig private (data : TcConfigBuilder, validate:bool) = data.defaultFSharpBinariesDir #else match fslibExplicitFilenameOpt with - | Some(fslibFilename) -> + | Some fslibFilename -> let filename = ComputeMakePathAbsolute data.implicitIncludeDir fslibFilename if fslibReference.ProjectReference.IsNone then try - use ilReader = OpenILBinary(filename, data.optimizeForMemory, data.openBinariesInMemory, None, None, data.shadowCopyReferences) + use ilReader = OpenILBinary(filename, data.reduceMemoryUsage, None, None, data.shadowCopyReferences, data.tryGetMetadataSnapshot) () with e -> error(Error(FSComp.SR.buildErrorOpeningBinaryFile(filename, e.Message), rangeStartup)) @@ -2818,7 +2840,6 @@ type TcConfig private (data : TcConfigBuilder, validate:bool) = member x.noFeedback = data.noFeedback member x.stackReserveSize = data.stackReserveSize member x.implicitIncludeDir = data.implicitIncludeDir - member x.openBinariesInMemory = data.openBinariesInMemory member x.openDebugInformationForLaterStaticLinking = data.openDebugInformationForLaterStaticLinking member x.fsharpBinariesDir = fsharpBinariesDirValue member x.compilingFslib = data.compilingFslib @@ -2838,7 +2859,7 @@ type TcConfig private (data : TcConfigBuilder, validate:bool) = member x.referencedDLLs = data.referencedDLLs member x.knownUnresolvedReferences = data.knownUnresolvedReferences member x.clrRoot = clrRootValue - member x.optimizeForMemory = data.optimizeForMemory + member x.reduceMemoryUsage = data.reduceMemoryUsage member x.subsystemVersion = data.subsystemVersion member x.useHighEntropyVA = data.useHighEntropyVA member x.inputCodePage = data.inputCodePage @@ -2928,11 +2949,9 @@ type TcConfig private (data : TcConfigBuilder, validate:bool) = member x.isInteractive = data.isInteractive member x.isInvalidationSupported = data.isInvalidationSupported member x.emitDebugInfoInQuotations = data.emitDebugInfoInQuotations - member x.sqmSessionGuid = data.sqmSessionGuid - member x.sqmNumOfSourceFiles = data.sqmNumOfSourceFiles - member x.sqmSessionStartedTime = data.sqmSessionStartedTime member x.copyFSharpCore = data.copyFSharpCore member x.shadowCopyReferences = data.shadowCopyReferences + member x.tryGetMetadataSnapshot = data.tryGetMetadataSnapshot static member Create(builder, validate) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter TcConfig(builder, validate) @@ -3067,10 +3086,6 @@ type TcConfig private (data : TcConfigBuilder, validate:bool) = let ext = System.IO.Path.GetExtension(nm) let isNetModule = String.Compare(ext, ".netmodule", StringComparison.OrdinalIgnoreCase)=0 - let unknownToolTip (resolvedPath, resolved) = - let line(append:string) = append.Trim([|' '|])+"\n" - line(resolvedPath) + line(resolved) - // See if the language service has already produced the contents of the assembly for us, virtually match r.ProjectReference with | Some _ -> @@ -3102,20 +3117,13 @@ type TcConfig private (data : TcConfigBuilder, validate:bool) = match resolved with | Some(resolved) -> let sysdir = tcConfig.IsSystemAssembly resolved - let fusionName = - if isNetModule then "" - else - try - let readerSettings : ILBinaryReader.ILReaderOptions = {pdbPath=None;ilGlobals = EcmaMscorlibILGlobals;optimizeForMemory=false} - use reader = ILBinaryReader.OpenILModuleReaderAfterReadingAllBytes resolved readerSettings - let assRef = mkRefToILAssembly reader.ILModuleDef.ManifestOfAssembly - assRef.QualifiedName - with e -> - "" Some { originalReference = r resolvedPath = resolved - prepareToolTip = (fun () -> unknownToolTip (resolved, fusionName)) + prepareToolTip = (fun () -> + let fusionName = System.Reflection.AssemblyName.GetAssemblyName(resolved).ToString() + let line(append:string) = append.Trim([|' '|])+"\n" + line(resolved) + line(fusionName)) sysdir = sysdir ilAssemblyRef = ref None } | None -> None @@ -3177,7 +3185,7 @@ type TcConfig private (data : TcConfigBuilder, validate:bool) = let logDiagnostic showMessages = (fun isError code message-> - if showMessages && mode = ReportErrors then + if showMessages && mode = ResolveAssemblyReferenceMode.ReportErrors then if isError then errorR(MSBuildReferenceResolutionError(code, message, errorAndWarningRange)) else @@ -3243,11 +3251,11 @@ type TcConfig private (data : TcConfigBuilder, validate:bool) = ms|>List.map(fun originalReference -> System.Diagnostics.Debug.Assert(FileSystem.IsPathRootedShim(resolvedFile.itemSpec), sprintf "msbuild-resolved path is not absolute: '%s'" resolvedFile.itemSpec) let canonicalItemSpec = FileSystem.GetFullPathShim(resolvedFile.itemSpec) - {originalReference=originalReference - resolvedPath=canonicalItemSpec - prepareToolTip = (fun () -> resolvedFile.prepareToolTip (originalReference.Text, canonicalItemSpec)) - sysdir= tcConfig.IsSystemAssembly canonicalItemSpec - ilAssemblyRef = ref None}) + { originalReference=originalReference + resolvedPath=canonicalItemSpec + prepareToolTip = (fun () -> resolvedFile.prepareToolTip (originalReference.Text, canonicalItemSpec)) + sysdir= tcConfig.IsSystemAssembly canonicalItemSpec + ilAssemblyRef = ref None }) (maxIndexOfReference, assemblyResolutions)) // When calculating the resulting resolutions, we're going to use the index of the reference @@ -3276,7 +3284,7 @@ type TcConfig private (data : TcConfigBuilder, validate:bool) = // If mode=Speculative, then we haven't reported any errors. // We report the error condition by returning an empty list of resolutions - if mode = Speculative && (List.length unresolvedReferences) > 0 then + if mode = ResolveAssemblyReferenceMode.Speculative && (List.length unresolvedReferences) > 0 then [], (List.ofArray groupedReferences) |> List.map (fun (name, _, r) -> (name, r)) |> List.map UnresolvedAssemblyReference else resultingResolutions, unresolvedReferences |> List.map (fun (name, _, r) -> (name, r)) |> List.map UnresolvedAssemblyReference @@ -3622,7 +3630,7 @@ let ParseOneInputLexbuf (tcConfig:TcConfig, lexResourceManager, conditionalCompi with e -> (* errorR(Failure("parse failed")); *) errorRecovery e rangeStartup; None -let ParseOneInputFile (tcConfig:TcConfig, lexResourceManager, conditionalCompilationDefines, filename, isLastCompiland, errorLogger, retryLocked) = +let ParseOneInputFile (tcConfig: TcConfig, lexResourceManager, conditionalCompilationDefines, filename, isLastCompiland, errorLogger, retryLocked) = try let lower = String.lowercase filename if List.exists (Filename.checkSuffix lower) (FSharpSigFileSuffixes@FSharpImplFileSuffixes) then @@ -3636,16 +3644,16 @@ let ParseOneInputFile (tcConfig:TcConfig, lexResourceManager, conditionalCompila [] -type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : UnresolvedAssemblyReference list) = +type TcAssemblyResolutions(tcConfig: TcConfig, results: AssemblyResolution list, unresolved : UnresolvedAssemblyReference list) = let originalReferenceToResolution = results |> List.map (fun r -> r.originalReference.Text, r) |> Map.ofList let resolvedPathToResolution = results |> List.map (fun r -> r.resolvedPath, r) |> Map.ofList /// Add some resolutions to the map of resolution results. - member tcResolutions.AddResolutionResults(newResults) = TcAssemblyResolutions(results @ newResults, unresolved) + member tcResolutions.AddResolutionResults(newResults) = TcAssemblyResolutions(tcConfig, results @ newResults, unresolved) /// Add some unresolved results. - member tcResolutions.AddUnresolvedReferences(newUnresolved) = TcAssemblyResolutions(results, unresolved @ newUnresolved) + member tcResolutions.AddUnresolvedReferences(newUnresolved) = TcAssemblyResolutions(tcConfig, results, unresolved @ newUnresolved) /// Get information about referenced DLLs member tcResolutions.GetAssemblyResolutions() = results @@ -3655,13 +3663,13 @@ type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : Unres /// This doesn't need to be cancellable, it is only used by F# Interactive member tcResolution.TryFindByExactILAssemblyRef (ctok, assref) = results |> List.tryFind (fun ar-> - let r = ar.GetILAssemblyRef(ctok) |> Cancellable.runWithoutCancellation + let r = ar.GetILAssemblyRef(ctok, tcConfig.reduceMemoryUsage, tcConfig.tryGetMetadataSnapshot) |> Cancellable.runWithoutCancellation r = assref) /// This doesn't need to be cancellable, it is only used by F# Interactive member tcResolution.TryFindBySimpleAssemblyName (ctok, simpleAssemName) = results |> List.tryFind (fun ar-> - let r = ar.GetILAssemblyRef(ctok) |> Cancellable.runWithoutCancellation + let r = ar.GetILAssemblyRef(ctok, tcConfig.reduceMemoryUsage, tcConfig.tryGetMetadataSnapshot) |> Cancellable.runWithoutCancellation r.Name = simpleAssemName) member tcResolutions.TryFindByResolvedPath nm = resolvedPathToResolution.TryFind nm @@ -3683,8 +3691,8 @@ type TcAssemblyResolutions(results : AssemblyResolution list, unresolved : Unres successes, failures else RequireCompilationThread ctok // we don't want to do assembly resolution concurrently, we assume MSBuild doesn't handle this - TcConfig.TryResolveLibsUsingMSBuildRules (tcConfig, assemblyList, rangeStartup, ReportErrors) - TcAssemblyResolutions(resolved, unresolved @ knownUnresolved) + TcConfig.TryResolveLibsUsingMSBuildRules (tcConfig, assemblyList, rangeStartup, ResolveAssemblyReferenceMode.ReportErrors) + TcAssemblyResolutions(tcConfig, resolved, unresolved @ knownUnresolved) static member GetAllDllReferences (tcConfig:TcConfig) = @@ -3772,24 +3780,19 @@ let GetOptimizationDataResourceName (r: ILResource) = let IsReflectedDefinitionsResource (r: ILResource) = r.Name.StartsWith QuotationPickler.SerializedReflectedDefinitionsResourceNameBase -type ILResource with - /// Get a function to read the bytes from a resource local to an assembly - member r.GetByteReader(m) = - match r.Location with - | ILResourceLocation.Local b -> b - | _-> error(InternalError("GetByteReader", m)) - let MakeILResource rname bytes = { Name = rname - Location = ILResourceLocation.Local (fun () -> bytes) + Location = ILResourceLocation.LocalOut bytes Access = ILResourceAccess.Public - CustomAttrs = emptyILCustomAttrs } + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx } let PickleToResource inMem file g scope rname p x = { Name = rname - Location = (let bytes = pickleObjWithDanglingCcus inMem file g scope p x in ILResourceLocation.Local (fun () -> bytes)) + Location = (let bytes = pickleObjWithDanglingCcus inMem file g scope p x in ILResourceLocation.LocalOut bytes) Access = ILResourceAccess.Public - CustomAttrs = emptyILCustomAttrs } + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx } let GetSignatureData (file, ilScopeRef, ilModule, byteReader) : PickledDataWithReferences = unpickleObjWithDanglingCcus file ilScopeRef ilModule unpickleCcuInfo byteReader @@ -3822,15 +3825,15 @@ type RawFSharpAssemblyDataBackedByFileOnDisk (ilModule: ILModuleDef, ilAssemblyR interface IRawFSharpAssemblyData with member __.GetAutoOpenAttributes(ilg) = GetAutoOpenAttributes ilg ilModule member __.GetInternalsVisibleToAttributes(ilg) = GetInternalsVisibleToAttributes ilg ilModule - member __.TryGetRawILModule() = Some ilModule + member __.TryGetILModuleDef() = Some ilModule member __.GetRawFSharpSignatureData(m, ilShortAssemName, filename) = let resources = ilModule.Resources.AsList let sigDataReaders = [ for iresource in resources do if IsSignatureDataResource iresource then let ccuName = GetSignatureDataResourceName iresource - let byteReader = iresource.GetByteReader(m) - yield (ccuName, byteReader()) ] + let bytes = iresource.GetBytes() + yield (ccuName, bytes) ] let sigDataReaders = if sigDataReaders.IsEmpty && List.contains ilShortAssemName externalSigAndOptData then @@ -3844,7 +3847,7 @@ type RawFSharpAssemblyDataBackedByFileOnDisk (ilModule: ILModuleDef, ilAssemblyR member __.GetRawFSharpOptimizationData(m, ilShortAssemName, filename) = let optDataReaders = ilModule.Resources.AsList - |> List.choose (fun r -> if IsOptimizationDataResource r then Some(GetOptimizationDataResourceName r, r.GetByteReader(m)) else None) + |> List.choose (fun r -> if IsOptimizationDataResource r then Some(GetOptimizationDataResourceName r, (fun () -> r.GetBytes())) else None) // Look for optimization data in a file let optDataReaders = @@ -4056,11 +4059,15 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti let ilScopeRef = ILScopeRef.Assembly (ILAssemblyRef.FromAssemblyName aname) let fileName = aname.Name + ".dll" let bytes = assembly.PApplyWithProvider((fun (assembly, provider) -> assembly.GetManifestModuleContents(provider)), m).PUntaint(id, m) + let tcConfig = tcConfigP.Get(ctok) let ilModule, ilAssemblyRefs = - let opts = { ILBinaryReader.mkDefault g.ilg with - ILBinaryReader.optimizeForMemory=true - ILBinaryReader.pdbPath = None } - let reader = ILBinaryReader.OpenILModuleReaderFromBytes fileName bytes opts + let opts : ILReaderOptions = + { ilGlobals = g.ilg + reduceMemoryUsage = tcConfig.reduceMemoryUsage + pdbPath = None + metadataOnly = MetadataOnlyFlag.Yes + tryGetMetadataSnapshot = tcConfig.tryGetMetadataSnapshot } + let reader = OpenILModuleReaderFromBytes fileName bytes opts reader.ILModuleDef, reader.ILAssemblyRefs let theActualAssembly = assembly.PUntaint((fun x -> x.Handle), m) @@ -4086,6 +4093,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti FileName = Some fileName MemberSignatureEquality = (fun ty1 ty2 -> Tastops.typeEquivAux EraseAll g ty1 ty2) ImportProvidedType = (fun ty -> Import.ImportProvidedType (tcImports.GetImportMap()) m ty) + TryGetILModuleDef = (fun () -> Some ilModule) TypeForwarders = Map.empty } let ccu = CcuThunk.Create(ilShortAssemName, ccuData) @@ -4121,15 +4129,6 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti CheckDisposed() disposeActions <- action :: disposeActions - override obj.ToString() = - sprintf "tcImports = \n dllInfos=%A\n dllTable=%A\n ccuInfos=%A\n ccuTable=%A\n Base=%s\n" - dllInfos - dllTable - ccuInfos - ccuTable - (match importsBase with None-> "None" | Some(importsBase) -> importsBase.ToString()) - - // Note: the returned binary reader is associated with the tcImports, i.e. when the tcImports are closed // then the reader is closed. member tcImports.OpenILBinaryModule(ctok, filename, m) = @@ -4149,7 +4148,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti None else None - let ilILBinaryReader = OpenILBinary(filename, tcConfig.optimizeForMemory, tcConfig.openBinariesInMemory, ilGlobalsOpt, pdbPathOption, tcConfig.shadowCopyReferences) + let ilILBinaryReader = OpenILBinary(filename, tcConfig.reduceMemoryUsage, ilGlobalsOpt, pdbPathOption, tcConfig.shadowCopyReferences, tcConfig.tryGetMetadataSnapshot) tcImports.AttachDisposeAction(fun _ -> (ilILBinaryReader :> IDisposable).Dispose()) ilILBinaryReader.ILModuleDef, ilILBinaryReader.ILAssemblyRefs with e -> @@ -4287,7 +4286,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti // specified in the attributes |> List.distinctBy (fun s -> try Path.GetFileNameWithoutExtension(s) with _ -> s) - if designTimeAssemblyNames.Length > 0 then + if not (List.isEmpty designTimeAssemblyNames) then // Find the SystemRuntimeAssemblyVersion value to report in the TypeProviderConfig. let primaryAssemblyVersion = @@ -4397,8 +4396,8 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti member tcImports.PrepareToImportReferencedILAssembly (ctok, m, filename, dllinfo:ImportedBinary) = CheckDisposed() let tcConfig = tcConfigP.Get(ctok) - assert dllinfo.RawMetadata.TryGetRawILModule().IsSome - let ilModule = dllinfo.RawMetadata.TryGetRawILModule().Value + assert dllinfo.RawMetadata.TryGetILModuleDef().IsSome + let ilModule = dllinfo.RawMetadata.TryGetILModuleDef().Value let ilScopeRef = dllinfo.ILScopeRef let aref = match ilScopeRef with @@ -4446,7 +4445,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti let ccuRawDataAndInfos = ilModule.GetRawFSharpSignatureData(m, ilShortAssemName, filename) |> List.map (fun (ccuName, sigDataReader) -> - let data = GetSignatureData (filename, ilScopeRef, ilModule.TryGetRawILModule(), sigDataReader) + let data = GetSignatureData (filename, ilScopeRef, ilModule.TryGetILModuleDef(), sigDataReader) let optDatas = Map.ofList optDataReaders @@ -4471,6 +4470,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti IsProviderGenerated = false ImportProvidedType = (fun ty -> Import.ImportProvidedType (tcImports.GetImportMap()) m ty) #endif + TryGetILModuleDef = ilModule.TryGetILModuleDef UsesFSharp20PlusQuotations = minfo.usesQuotations MemberSignatureEquality= (fun ty1 ty2 -> Tastops.typeEquivAux EraseAll (tcImports.GetTcGlobals()) ty1 ty2) TypeForwarders = ImportILAssemblyTypeForwarders(tcImports.GetImportMap, m, ilModule.GetRawTypeForwarders()) } @@ -4484,7 +4484,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti if verbose then dprintf "*** no optimization data for CCU %s, was DLL compiled with --no-optimization-data??\n" ccuName None | Some info -> - let data = GetOptimizationData (filename, ilScopeRef, ilModule.TryGetRawILModule(), info) + let data = GetOptimizationData (filename, ilScopeRef, ilModule.TryGetILModuleDef(), info) let res = data.OptionalFixup(fun nm -> availableToOptionalCcu(tcImports.FindCcu(ctok, m, nm, lookupOnly=false))) if verbose then dprintf "found optimization data for CCU %s\n" ccuName Some res) @@ -4501,7 +4501,7 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti ILScopeRef = ilScopeRef } let phase2() = #if !NO_EXTENSIONTYPING - match ilModule.TryGetRawILModule() with + match ilModule.TryGetILModuleDef() with | None -> () // no type providers can be used without a real IL Module present | Some ilModule -> ccuinfo.TypeProviders <- tcImports.ImportTypeProviderExtensions (ctok, tcConfig, filename, ilScopeRef, ilModule.ManifestOfAssembly.CustomAttrs.AsList, ccu.Contents, invalidateCcu, m) @@ -4826,6 +4826,8 @@ type TcImports(tcConfigP:TcConfigProvider, initialResolutions:TcAssemblyResoluti disposeActions <- [] for action in actions do action() + override tcImports.ToString() = "TcImports(...)" + /// Process #r in F# Interactive. /// Adds the reference to the tcImports and add the ccu to the type checking environment. let RequireDLL (ctok, tcImports:TcImports, tcEnv, thisAssemblyName, m, file) = @@ -5056,11 +5058,11 @@ module private ScriptPreprocessClosure = ParseOneInputLexbuf (tcConfig, lexResourceManager, defines, lexbuf, filename, isLastCompiland, errorLogger) /// Create a TcConfig for load closure starting from a single .fsx file - let CreateScriptSourceTcConfig (legacyReferenceResolver, defaultFSharpBinariesDir, filename:string, codeContext, useSimpleResolution, useFsiAuxLib, basicReferences, applyCommandLineArgs, assumeDotNetFramework) = + let CreateScriptTextTcConfig (legacyReferenceResolver, defaultFSharpBinariesDir, filename:string, codeContext, useSimpleResolution, useFsiAuxLib, basicReferences, applyCommandLineArgs, assumeDotNetFramework, tryGetMetadataSnapshot, reduceMemoryUsage) = let projectDir = Path.GetDirectoryName(filename) let isInteractive = (codeContext = CodeContext.CompilationAndEvaluation) let isInvalidationSupported = (codeContext = CodeContext.Editing) - let tcConfigB = TcConfigBuilder.CreateNew(legacyReferenceResolver, defaultFSharpBinariesDir, true (* optimize for memory *), projectDir, isInteractive, isInvalidationSupported, defaultCopyFSharpCore=false) + let tcConfigB = TcConfigBuilder.CreateNew(legacyReferenceResolver, defaultFSharpBinariesDir, reduceMemoryUsage, projectDir, isInteractive, isInvalidationSupported, defaultCopyFSharpCore=CopyFSharpCoreFlag.No, tryGetMetadataSnapshot=tryGetMetadataSnapshot) applyCommandLineArgs tcConfigB match basicReferences with | None -> BasicReferencesForScriptLoadClosure(useFsiAuxLib, assumeDotNetFramework) |> List.iter(fun f->tcConfigB.AddReferencedAssemblyByPath(range0, f)) // Add script references @@ -5085,7 +5087,7 @@ module private ScriptPreprocessClosure = use reader = match inputCodePage with | None -> new StreamReader(stream, true) - | Some n -> new StreamReader(stream, Encoding.GetEncodingShim(n)) + | Some (n: int) -> new StreamReader(stream, Encoding.GetEncoding(n)) let source = reader.ReadToEnd() [ClosureSource(filename, m, source, parseRequired)] with e -> @@ -5210,11 +5212,11 @@ module private ScriptPreprocessClosure = let allRootDiagnostics = allRootDiagnostics |> List.filter (fst >> isRootRange) let result : LoadClosure = - { SourceFiles = List.groupByFirst sourceFiles - References = List.groupByFirst references + { SourceFiles = List.groupBy fst sourceFiles |> List.map (map2Of2 (List.map snd)) + References = List.groupBy fst references |> List.map (map2Of2 (List.map snd)) UnresolvedReferences = unresolvedReferences Inputs = sourceInputs - NoWarns = List.groupByFirst globalNoWarns + NoWarns = List.groupBy fst globalNoWarns |> List.map (map2Of2 (List.map snd)) OriginalLoadReferences = tcConfig.loadedSources ResolutionDiagnostics = resolutionDiagnostics AllRootFileDiagnostics = allRootDiagnostics @@ -5223,18 +5225,18 @@ module private ScriptPreprocessClosure = result /// Given source text, find the full load closure. Used from service.fs, when editing a script file - let GetFullClosureOfScriptSource(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename, source, codeContext, useSimpleResolution, useFsiAuxLib, lexResourceManager:Lexhelp.LexResourceManager, applyCommmandLineArgs, assumeDotNetFramework) = + let GetFullClosureOfScriptText(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename, source, codeContext, useSimpleResolution, useFsiAuxLib, lexResourceManager:Lexhelp.LexResourceManager, applyCommmandLineArgs, assumeDotNetFramework, tryGetMetadataSnapshot, reduceMemoryUsage) = // Resolve the basic references such as FSharp.Core.dll first, before processing any #I directives in the script // // This is tries to mimic the action of running the script in F# Interactive - the initial context for scripting is created // first, then #I and other directives are processed. let references0 = - let tcConfig = CreateScriptSourceTcConfig(legacyReferenceResolver, defaultFSharpBinariesDir, filename, codeContext, useSimpleResolution, useFsiAuxLib, None, applyCommmandLineArgs, assumeDotNetFramework) + let tcConfig = CreateScriptTextTcConfig(legacyReferenceResolver, defaultFSharpBinariesDir, filename, codeContext, useSimpleResolution, useFsiAuxLib, None, applyCommmandLineArgs, assumeDotNetFramework, tryGetMetadataSnapshot, reduceMemoryUsage) let resolutions0, _unresolvedReferences = GetAssemblyResolutionInformation(ctok, tcConfig) let references0 = resolutions0 |> List.map (fun r->r.originalReference.Range, r.resolvedPath) |> Seq.distinct |> List.ofSeq references0 - let tcConfig = CreateScriptSourceTcConfig(legacyReferenceResolver, defaultFSharpBinariesDir, filename, codeContext, useSimpleResolution, useFsiAuxLib, Some references0, applyCommmandLineArgs, assumeDotNetFramework) + let tcConfig = CreateScriptTextTcConfig(legacyReferenceResolver, defaultFSharpBinariesDir, filename, codeContext, useSimpleResolution, useFsiAuxLib, Some references0, applyCommmandLineArgs, assumeDotNetFramework, tryGetMetadataSnapshot, reduceMemoryUsage) let closureSources = [ClosureSource(filename, range0, source, true)] let closureFiles, tcConfig = FindClosureFiles(closureSources, tcConfig, codeContext, lexResourceManager) @@ -5249,14 +5251,18 @@ module private ScriptPreprocessClosure = GetLoadClosure(ctok, mainFile, closureFiles, tcConfig, codeContext) type LoadClosure with - // Used from service.fs, when editing a script file - static member ComputeClosureOfSourceText(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename:string, source:string, codeContext, useSimpleResolution:bool, useFsiAuxLib, lexResourceManager:Lexhelp.LexResourceManager, applyCommmandLineArgs, assumeDotNetFramework) : LoadClosure = + /// Analyze a script text and find the closure of its references. + /// Used from FCS, when editing a script file. + // + /// A temporary TcConfig is created along the way, is why this routine takes so many arguments. We want to be sure to use exactly the + /// same arguments as the rest of the application. + static member ComputeClosureOfScriptText(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename:string, source:string, codeContext, useSimpleResolution:bool, useFsiAuxLib, lexResourceManager:Lexhelp.LexResourceManager, applyCommmandLineArgs, assumeDotNetFramework, tryGetMetadataSnapshot, reduceMemoryUsage) : LoadClosure = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse - ScriptPreprocessClosure.GetFullClosureOfScriptSource(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename, source, codeContext, useSimpleResolution, useFsiAuxLib, lexResourceManager, applyCommmandLineArgs, assumeDotNetFramework) + ScriptPreprocessClosure.GetFullClosureOfScriptText(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename, source, codeContext, useSimpleResolution, useFsiAuxLib, lexResourceManager, applyCommmandLineArgs, assumeDotNetFramework, tryGetMetadataSnapshot, reduceMemoryUsage) - /// Used from fsi.fs and fsc.fs, for #load and command line. - /// The resulting references are then added to a TcConfig. - static member ComputeClosureOfSourceFiles (ctok, tcConfig:TcConfig, files:(string*range) list, codeContext, lexResourceManager:Lexhelp.LexResourceManager) = + /// Analyze a set of script files and find the closure of their references. The resulting references are then added to the given TcConfig. + /// Used from fsi.fs and fsc.fs, for #load and command line. + static member ComputeClosureOfScriptFiles (ctok, tcConfig:TcConfig, files:(string*range) list, codeContext, lexResourceManager:Lexhelp.LexResourceManager) = use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parse ScriptPreprocessClosure.GetFullClosureOfScriptFiles (ctok, tcConfig, files, codeContext, lexResourceManager) @@ -5363,6 +5369,7 @@ let GetInitialTcState(m, ccuName, tcConfig:TcConfig, tcGlobals, tcImports:TcImpo IsProviderGenerated = false ImportProvidedType = (fun ty -> Import.ImportProvidedType (tcImports.GetImportMap()) m ty) #endif + TryGetILModuleDef = (fun () -> None) FileName=None Stamp = newStamp() QualifiedName= None @@ -5431,7 +5438,7 @@ let TypeCheckOneInputEventually let m = qualNameOfFile.Range TcOpenDecl tcSink tcGlobals amap m m tcEnv prefixPath - let res = (EmptyTopAttrs, [], tcEnv, tcEnv, tcState.tcsTcImplEnv, RootSigsAndImpls(rootSigs, rootImpls, allSigModulTyp, allImplementedSigModulTyp), tcState.tcsCcuType, createsGeneratedProvidedTypes) + let res = (EmptyTopAttrs, None, tcEnv, tcEnv, tcState.tcsTcImplEnv, RootSigsAndImpls(rootSigs, rootImpls, allSigModulTyp, allImplementedSigModulTyp), tcState.tcsCcuType, createsGeneratedProvidedTypes) return res | ParsedInput.ImplFile (ParsedImplFileInput(filename, _, qualNameOfFile, _, _, _, _) as file) -> @@ -5491,7 +5498,7 @@ let TypeCheckOneInputEventually if verbose then dprintf "done TypeCheckOneInputEventually...\n" let topSigsAndImpls = RootSigsAndImpls(rootSigs, rootImpls, allSigModulTyp, allImplementedSigModulTyp) - let res = (topAttrs, [implFile], tcEnvAtEnd, tcSigEnv, tcImplEnv, topSigsAndImpls, ccuType, createsGeneratedProvidedTypes) + let res = (topAttrs, Some implFile, tcEnvAtEnd, tcSigEnv, tcImplEnv, topSigsAndImpls, ccuType, createsGeneratedProvidedTypes) return res } return (tcEnvAtEnd, topAttrs, implFiles), @@ -5503,7 +5510,7 @@ let TypeCheckOneInputEventually tcsRootSigsAndImpls = topSigsAndImpls } with e -> errorRecovery e range0 - return (tcState.TcEnvFromSignatures, EmptyTopAttrs, []), tcState + return (tcState.TcEnvFromSignatures, EmptyTopAttrs, None), tcState } /// Typecheck a single file (or interactive entry into F# Interactive) @@ -5519,7 +5526,7 @@ let TypeCheckMultipleInputsFinish(results, tcState: TcState) = let tcEnvsAtEndFile, topAttrs, implFiles = List.unzip3 results let topAttrs = List.foldBack CombineTopAttrs topAttrs EmptyTopAttrs - let implFiles = List.concat implFiles + let implFiles = List.choose id implFiles // This is the environment required by fsi.exe when incrementally adding definitions let tcEnvAtEndOfLastFile = (match tcEnvsAtEndFile with h :: _ -> h | _ -> tcState.TcEnvFromSignatures) diff --git a/src/fsharp/CompileOps.fsi b/src/fsharp/CompileOps.fsi index 1d7d2b1f77..0b40471266 100755 --- a/src/fsharp/CompileOps.fsi +++ b/src/fsharp/CompileOps.fsi @@ -6,7 +6,9 @@ module internal Microsoft.FSharp.Compiler.CompileOps open System open System.Text open System.Collections.Generic +open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.TypeChecker @@ -143,7 +145,7 @@ type IRawFSharpAssemblyData = abstract GetInternalsVisibleToAttributes: ILGlobals -> string list /// The raw IL module definition in the assembly, if any. This is not present for cross-project references /// in the language service - abstract TryGetRawILModule: unit -> ILModuleDef option + abstract TryGetILModuleDef: unit -> ILModuleDef option abstract HasAnyFSharpSignatureDataAttribute: bool abstract HasMatchingFSharpSignatureDataAttribute: ILGlobals -> bool /// The raw F# signature data in the assembly, if any @@ -204,6 +206,7 @@ type UnresolvedAssemblyReference = UnresolvedAssemblyReference of string * Assem type ResolvedExtensionReference = ResolvedExtensionReference of string * AssemblyReference list * Tainted list #endif +[] type CompilerTarget = | WinExe | ConsoleExe @@ -211,10 +214,14 @@ type CompilerTarget = | Module member IsExe: bool +[] type ResolveAssemblyReferenceMode = | Speculative | ReportErrors +[] +type CopyFSharpCoreFlag = Yes | No + //---------------------------------------------------------------------------- // TcConfig //-------------------------------------------------------------------------- @@ -227,13 +234,13 @@ type VersionFlag = member GetVersionInfo: implicitIncludeDir:string -> ILVersionInfo member GetVersionString: implicitIncludeDir:string -> string +[] type TcConfigBuilder = { mutable primaryAssembly: PrimaryAssembly mutable autoResolveOpenDirectivesToDlls: bool mutable noFeedback: bool mutable stackReserveSize: int32 option mutable implicitIncludeDir: string - mutable openBinariesInMemory: bool mutable openDebugInformationForLaterStaticLinking: bool defaultFSharpBinariesDir: string mutable compilingFslib: bool @@ -256,7 +263,7 @@ type TcConfigBuilder = mutable referencedDLLs: AssemblyReference list mutable projectReferences: IProjectReference list mutable knownUnresolvedReferences: UnresolvedAssemblyReference list - optimizeForMemory: bool + reduceMemoryUsage: ReduceMemoryFlag mutable subsystemVersion: int * int mutable useHighEntropyVA: bool mutable inputCodePage: int option @@ -348,13 +355,14 @@ type TcConfigBuilder = /// If true, indicates all type checking and code generation is in the context of fsi.exe isInteractive: bool isInvalidationSupported: bool - mutable sqmSessionGuid: System.Guid option - mutable sqmNumOfSourceFiles: int - sqmSessionStartedTime: int64 mutable emitDebugInfoInQuotations: bool mutable exename: string option - mutable copyFSharpCore: bool + mutable copyFSharpCore: CopyFSharpCoreFlag mutable shadowCopyReferences: bool + + /// A function to call to try to get an object that acts as a snapshot of the metadata section of a .NET binary, + /// and from which we can read the metadata. Only used when metadataOnly=true. + mutable tryGetMetadataSnapshot : ILReaderTryGetMetadataSnapshot } static member Initial: TcConfigBuilder @@ -362,11 +370,13 @@ type TcConfigBuilder = static member CreateNew: legacyReferenceResolver: ReferenceResolver.Resolver * defaultFSharpBinariesDir: string * - optimizeForMemory: bool * + reduceMemoryUsage: ReduceMemoryFlag * implicitIncludeDir: string * isInteractive: bool * isInvalidationSupported: bool * - defaultCopyFSharpCore: bool -> TcConfigBuilder + defaultCopyFSharpCore: CopyFSharpCoreFlag * + tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot + -> TcConfigBuilder member DecideNames: string list -> outfile: string * pdbfile: string option * assemblyName: string member TurnWarningOff: range * string -> unit @@ -389,7 +399,6 @@ type TcConfig = member noFeedback: bool member stackReserveSize: int32 option member implicitIncludeDir: string - member openBinariesInMemory: bool member openDebugInformationForLaterStaticLinking: bool member fsharpBinariesDir: string member compilingFslib: bool @@ -408,7 +417,7 @@ type TcConfig = member subsystemVersion: int * int member useHighEntropyVA: bool member referencedDLLs: AssemblyReference list - member optimizeForMemory: bool + member reduceMemoryUsage: ReduceMemoryFlag member inputCodePage: int option member embedResources: string list member errorSeverityOptions: FSharpErrorSeverityOptions @@ -512,10 +521,7 @@ type TcConfig = /// File system query based on TcConfig settings member MakePathAbsolute: string -> string - member sqmSessionGuid: System.Guid option - member sqmNumOfSourceFiles: int - member sqmSessionStartedTime: int64 - member copyFSharpCore: bool + member copyFSharpCore: CopyFSharpCoreFlag member shadowCopyReferences: bool static member Create: TcConfigBuilder * validate: bool -> TcConfig @@ -567,11 +573,8 @@ type ImportedAssembly = [] type TcAssemblyResolutions = member GetAssemblyResolutions: unit -> AssemblyResolution list - static member SplitNonFoundationalResolutions : CompilationThreadToken * TcConfig -> AssemblyResolution list * AssemblyResolution list * UnresolvedAssemblyReference list static member BuildFromPriorResolutions : CompilationThreadToken * TcConfig * AssemblyResolution list * UnresolvedAssemblyReference list -> TcAssemblyResolutions - - /// Represents a table of imported assemblies with their resolutions. [] @@ -636,6 +639,9 @@ val WriteSignatureData: TcConfig * TcGlobals * Tastops.Remap * CcuThunk * filena /// Write F# optimization data as an IL resource val WriteOptimizationData: TcGlobals * filename: string * inMem: bool * CcuThunk * Optimizer.LazyModuleInfo -> ILResource +//---------------------------------------------------------------------------- +// #r and other directives +//-------------------------------------------------------------------------- //---------------------------------------------------------------------------- // #r and other directives @@ -712,10 +718,10 @@ val GetInitialTcState: /// Check one input, returned as an Eventually computation val TypeCheckOneInputEventually : checkForErrors:(unit -> bool) * TcConfig * TcImports * TcGlobals * Ast.LongIdent option * NameResolution.TcResultsSink * TcState * Ast.ParsedInput - -> Eventually<(TcEnv * TopAttribs * TypedImplFile list) * TcState> + -> Eventually<(TcEnv * TopAttribs * TypedImplFile option) * TcState> /// Finish the checking of multiple inputs -val TypeCheckMultipleInputsFinish: (TcEnv * TopAttribs * 'T list) list * TcState -> (TcEnv * TopAttribs * 'T list) * TcState +val TypeCheckMultipleInputsFinish: (TcEnv * TopAttribs * 'T option) list * TcState -> (TcEnv * TopAttribs * 'T list) * TcState /// Finish the checking of a closed set of inputs val TypeCheckClosedInputSetFinish: TypedImplFile list * TcState -> TcState * TypedImplFile list @@ -751,7 +757,6 @@ type LoadClosureInput = ParseDiagnostics: (PhasedDiagnostic * bool) list MetaCommandDiagnostics: (PhasedDiagnostic * bool) list } - [] type LoadClosure = { /// The source files along with the ranges of the #load positions in each file. @@ -781,8 +786,13 @@ type LoadClosure = /// Diagnostics seen while processing the compiler options implied root of closure LoadClosureRootFileDiagnostics: (PhasedDiagnostic * bool) list } - // Used from service.fs, when editing a script file - static member ComputeClosureOfSourceText: CompilationThreadToken * legacyReferenceResolver: ReferenceResolver.Resolver * defaultFSharpBinariesDir: string * filename: string * source: string * implicitDefines:CodeContext * useSimpleResolution: bool * useFsiAuxLib: bool * lexResourceManager: Lexhelp.LexResourceManager * applyCompilerOptions: (TcConfigBuilder -> unit) * assumeDotNetFramework: bool -> LoadClosure + /// Analyze a script text and find the closure of its references. + /// Used from FCS, when editing a script file. + // + /// A temporary TcConfig is created along the way, is why this routine takes so many arguments. We want to be sure to use exactly the + /// same arguments as the rest of the application. + static member ComputeClosureOfScriptText: CompilationThreadToken * legacyReferenceResolver: ReferenceResolver.Resolver * defaultFSharpBinariesDir: string * filename: string * source: string * implicitDefines:CodeContext * useSimpleResolution: bool * useFsiAuxLib: bool * lexResourceManager: Lexhelp.LexResourceManager * applyCompilerOptions: (TcConfigBuilder -> unit) * assumeDotNetFramework: bool * tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot * reduceMemoryUsage: ReduceMemoryFlag -> LoadClosure - /// Used from fsi.fs and fsc.fs, for #load and command line. The resulting references are then added to a TcConfig. - static member ComputeClosureOfSourceFiles: CompilationThreadToken * tcConfig:TcConfig * (string * range) list * implicitDefines:CodeContext * lexResourceManager: Lexhelp.LexResourceManager -> LoadClosure + /// Analyze a set of script files and find the closure of their references. The resulting references are then added to the given TcConfig. + /// Used from fsi.fs and fsc.fs, for #load and command line. + static member ComputeClosureOfScriptFiles: CompilationThreadToken * tcConfig:TcConfig * (string * range) list * implicitDefines:CodeContext * lexResourceManager: Lexhelp.LexResourceManager -> LoadClosure diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index dd4ea4e1ef..5969e38fc8 100755 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -457,10 +457,10 @@ let (++) x s = x @ [s] let SetTarget (tcConfigB : TcConfigBuilder)(s : string) = match s.ToLowerInvariant() with - | "exe" -> tcConfigB.target <- ConsoleExe - | "winexe" -> tcConfigB.target <- WinExe - | "library" -> tcConfigB.target <- Dll - | "module" -> tcConfigB.target <- Module + | "exe" -> tcConfigB.target <- CompilerTarget.ConsoleExe + | "winexe" -> tcConfigB.target <- CompilerTarget.WinExe + | "library" -> tcConfigB.target <- CompilerTarget.Dll + | "module" -> tcConfigB.target <- CompilerTarget.Module | _ -> error(Error(FSComp.SR.optsUnrecognizedTarget(s),rangeCmdArgs)) let SetDebugSwitch (tcConfigB : TcConfigBuilder) (dtype : string option) (s : OptionSwitch) = @@ -648,7 +648,7 @@ let outputFileFlagsFsc (tcConfigB : TcConfigBuilder) = CompilerOption("sig", tagFile, OptionString (setSignatureFile tcConfigB), None, Some (FSComp.SR.optsSig())) - CompilerOption("nocopyfsharpcore", tagNone, OptionUnit (fun () -> tcConfigB.copyFSharpCore <- false), None, Some (FSComp.SR.optsNoCopyFsharpCore())) + CompilerOption("nocopyfsharpcore", tagNone, OptionUnit (fun () -> tcConfigB.copyFSharpCore <- CopyFSharpCoreFlag.No), None, Some (FSComp.SR.optsNoCopyFsharpCore())) ] @@ -738,7 +738,7 @@ let libFlagAbbrev (tcConfigB : TcConfigBuilder) = let codePageFlag (tcConfigB : TcConfigBuilder) = CompilerOption("codepage", tagInt, OptionInt (fun n -> try - System.Text.Encoding.GetEncodingShim(n) |> ignore + System.Text.Encoding.GetEncoding(n) |> ignore with :? System.ArgumentException as err -> error(Error(FSComp.SR.optsProblemWithCodepage(n,err.Message),rangeCmdArgs)) @@ -851,16 +851,16 @@ let testFlag tcConfigB = let vsSpecificFlags (tcConfigB: TcConfigBuilder) = [ CompilerOption("vserrors", tagNone, OptionUnit (fun () -> tcConfigB.errorStyle <- ErrorStyle.VSErrors), None, None) CompilerOption("validate-type-providers", tagNone, OptionUnit (id), None, None) // preserved for compatibility's sake, no longer has any effect - CompilerOption("LCID", tagInt, OptionInt (fun _n -> ()), None, None) + CompilerOption("LCID", tagInt, OptionInt ignore, None, None) CompilerOption("flaterrors", tagNone, OptionUnit (fun () -> tcConfigB.flatErrors <- true), None, None) - CompilerOption("sqmsessionguid", tagNone, OptionString (fun s -> tcConfigB.sqmSessionGuid <- try System.Guid(s) |> Some with e -> None), None, None) + CompilerOption("sqmsessionguid", tagNone, OptionString ignore, None, None) CompilerOption("gccerrors", tagNone, OptionUnit (fun () -> tcConfigB.errorStyle <- ErrorStyle.GccErrors), None, None) CompilerOption("exename", tagNone, OptionString (fun s -> tcConfigB.exename <- Some(s)), None, None) CompilerOption("maxerrors", tagInt, OptionInt (fun n -> tcConfigB.maxErrors <- n), None, None) ] let internalFlags (tcConfigB:TcConfigBuilder) = [ - CompilerOption("stamps", tagNone, OptionUnit (fun () -> ()), Some(InternalCommandLineOption("--stamps", rangeCmdArgs)), None) + CompilerOption("stamps", tagNone, OptionUnit ignore, Some(InternalCommandLineOption("--stamps", rangeCmdArgs)), None) CompilerOption("ranges", tagNone, OptionSet Tastops.DebugPrint.layoutRanges, Some(InternalCommandLineOption("--ranges", rangeCmdArgs)), None) CompilerOption("terms" , tagNone, OptionUnit (fun () -> tcConfigB.showTerms <- true), Some(InternalCommandLineOption("--terms", rangeCmdArgs)), None) CompilerOption("termsfile" , tagNone, OptionUnit (fun () -> tcConfigB.writeTermsToFiles <- true), Some(InternalCommandLineOption("--termsfile", rangeCmdArgs)), None) @@ -1016,7 +1016,7 @@ let abbreviatedFlagsFsc tcConfigB = abbreviatedFlagsBoth tcConfigB @ [ (* FSC only abbreviated options *) CompilerOption("o", tagString, OptionString (setOutFileName tcConfigB), None, Some(FSComp.SR.optsShortFormOf("--out"))) - CompilerOption("a", tagString, OptionUnit (fun () -> tcConfigB.target <- Dll), None, Some(FSComp.SR.optsShortFormOf("--target library"))) + CompilerOption("a", tagString, OptionUnit (fun () -> tcConfigB.target <- CompilerTarget.Dll), None, Some(FSComp.SR.optsShortFormOf("--target library"))) (* FSC help abbreviations. FSI has it's own help options... *) CompilerOption("?" , tagNone, OptionHelp (fun blocks -> displayHelpFsc tcConfigB blocks), None, Some(FSComp.SR.optsShortFormOf("--help"))) CompilerOption("help" , tagNone, OptionHelp (fun blocks -> displayHelpFsc tcConfigB blocks), None, Some(FSComp.SR.optsShortFormOf("--help"))) @@ -1348,7 +1348,7 @@ let GenerateIlxCode (ilxBackend, isInteractiveItExpr, isInteractiveOnMono, tcCon fragName = fragName localOptimizationsAreOn= tcConfig.optSettings.localOpt () testFlagEmitFeeFeeAs100001 = tcConfig.testFlagEmitFeeFeeAs100001 - mainMethodInfo= (if (tcConfig.target = Dll || tcConfig.target = Module) then None else Some topAttrs.mainMethodAttrs) + mainMethodInfo= (if (tcConfig.target = CompilerTarget.Dll || tcConfig.target = CompilerTarget.Module) then None else Some topAttrs.mainMethodAttrs) ilxBackend = ilxBackend isInteractive = tcConfig.isInteractive isInteractiveItExpr = isInteractiveItExpr @@ -1372,7 +1372,7 @@ let NormalizeAssemblyRefs (ctok, tcImports:TcImports) scoref = let GetGeneratedILModuleName (t:CompilerTarget) (s:string) = // return the name of the file as a module name - let ext = match t with | Dll -> "dll" | Module -> "netmodule" | _ -> "exe" + let ext = match t with CompilerTarget.Dll -> "dll" | CompilerTarget.Module -> "netmodule" | _ -> "exe" s + "." + ext let ignoreFailureOnMono1_1_16 f = try f() with _ -> () diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index b1b690c6a8..8b1cea8c9f 100755 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -359,7 +359,7 @@ let FilterEachThenUndo f meths = trace.Undo() match CheckNoErrorsAndGetWarnings res with | None -> None - | Some warns -> Some (calledMeth, warns.Length, trace)) + | Some warns -> Some (calledMeth, warns, trace)) let ShowAccessDomain ad = match ad with @@ -2194,8 +2194,8 @@ and ResolveOverloading (ArgsEquivInsideUndo csenv cx.IsSome) reqdRetTyOpt calledMeth) with - | [(calledMeth, _, _)] -> - Some calledMeth, CompleteD, NoTrace // Can't re-play the trace since ArgsEquivInsideUndo was used + | [(calledMeth, warns, _)] -> + Some calledMeth, OkResult (warns, ()), NoTrace // Can't re-play the trace since ArgsEquivInsideUndo was used | _ -> // Now determine the applicable methods. @@ -2255,8 +2255,8 @@ and ResolveOverloading None, ErrorD (failOverloading (FSComp.SR.csNoOverloadsFound methodName) errors), NoTrace - | [(calledMeth, _, t)] -> - Some calledMeth, CompleteD, WithTrace t + | [(calledMeth, warns, t)] -> + Some calledMeth, OkResult (warns, ()), WithTrace t | applicableMeths -> @@ -2292,7 +2292,9 @@ and ResolveOverloading if c <> 0 then c else 0 - let better (candidate:CalledMeth<_>, candidateWarnCount, _) (other:CalledMeth<_>, otherWarnCount, _) = + let better (candidate:CalledMeth<_>, candidateWarnings, _) (other:CalledMeth<_>, otherwarnings, _) = + let candidateWarnCount = List.length candidateWarnings + let otherWarnCount = List.length otherwarnings // Prefer methods that don't give "this code is less generic" warnings // Note: Relies on 'compare' respecting true > false let c = compare (candidateWarnCount = 0) (otherWarnCount = 0) @@ -2383,7 +2385,7 @@ and ResolveOverloading else None) match bestMethods with - | [(calledMeth, _, t)] -> Some calledMeth, CompleteD, WithTrace t + | [(calledMeth, warns, t)] -> Some calledMeth, OkResult (warns, ()), WithTrace t | bestMethods -> let methodNames = let methods = diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs index e654fd67e4..fdce9b5522 100755 --- a/src/fsharp/ErrorLogger.fs +++ b/src/fsharp/ErrorLogger.fs @@ -2,11 +2,7 @@ module public Microsoft.FSharp.Compiler.ErrorLogger -open Internal.Utilities open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Range open System @@ -109,23 +105,23 @@ exception ErrorWithSuggestions of (int * string) * range * string * Suggestions let inline protectAssemblyExploration dflt f = try f() - with - | UnresolvedPathReferenceNoRange _ -> dflt - | _ -> reraise() + with + | UnresolvedPathReferenceNoRange _ -> dflt + | _ -> reraise() let inline protectAssemblyExplorationF dflt f = try f() - with - | UnresolvedPathReferenceNoRange (asmName, path) -> dflt(asmName, path) - | _ -> reraise() + with + | UnresolvedPathReferenceNoRange (asmName, path) -> dflt(asmName, path) + | _ -> reraise() let inline protectAssemblyExplorationNoReraise dflt1 dflt2 f = try f() - with - | UnresolvedPathReferenceNoRange _ -> dflt1 - | _ -> dflt2 + with + | UnresolvedPathReferenceNoRange _ -> dflt1 + | _ -> dflt2 // Attach a range if this is a range dual exception. let rec AttachRange m (exn:exn) = @@ -150,20 +146,22 @@ type Exiter = let QuitProcessExiter = { new Exiter with - member x.Exit(n) = + member __.Exit(n) = try System.Environment.Exit(n) with _ -> () - failwithf "%s" <| FSComp.SR.elSysEnvExitDidntExit() } + FSComp.SR.elSysEnvExitDidntExit() + |> failwith } /// Closed enumeration of build phases. +[] type BuildPhase = | DefaultPhase | Compile | Parameter | Parse | TypeCheck | CodeGen - | Optimize | IlxGen | IlGen | Output + | Optimize | IlxGen | IlGen | Output | Interactive // An error seen during interactive execution /// Literal build phase subcategory strings. @@ -212,17 +210,17 @@ type PhasedDiagnostic = /// member pe.Subcategory() = match pe.Phase with - | DefaultPhase -> BuildPhaseSubcategory.DefaultPhase - | Compile -> BuildPhaseSubcategory.Compile - | Parameter -> BuildPhaseSubcategory.Parameter - | Parse -> BuildPhaseSubcategory.Parse - | TypeCheck -> BuildPhaseSubcategory.TypeCheck - | CodeGen -> BuildPhaseSubcategory.CodeGen - | Optimize -> BuildPhaseSubcategory.Optimize - | IlxGen -> BuildPhaseSubcategory.IlxGen - | IlGen -> BuildPhaseSubcategory.IlGen - | Output -> BuildPhaseSubcategory.Output - | Interactive -> BuildPhaseSubcategory.Interactive + | BuildPhase.DefaultPhase -> BuildPhaseSubcategory.DefaultPhase + | BuildPhase.Compile -> BuildPhaseSubcategory.Compile + | BuildPhase.Parameter -> BuildPhaseSubcategory.Parameter + | BuildPhase.Parse -> BuildPhaseSubcategory.Parse + | BuildPhase.TypeCheck -> BuildPhaseSubcategory.TypeCheck + | BuildPhase.CodeGen -> BuildPhaseSubcategory.CodeGen + | BuildPhase.Optimize -> BuildPhaseSubcategory.Optimize + | BuildPhase.IlxGen -> BuildPhaseSubcategory.IlxGen + | BuildPhase.IlGen -> BuildPhaseSubcategory.IlGen + | BuildPhase.Output -> BuildPhaseSubcategory.Output + | BuildPhase.Interactive -> BuildPhaseSubcategory.Interactive /// Return true if the textual phase given is from the compile part of the build process. /// This set needs to be equal to the set of subcategories that the language service can produce. @@ -256,7 +254,7 @@ type PhasedDiagnostic = member pe.IsPhaseInCompile() = let isPhaseInCompile = match pe.Phase with - | Compile | Parameter | Parse | TypeCheck -> true + | BuildPhase.Compile | BuildPhase.Parameter | BuildPhase.Parse | BuildPhase.TypeCheck -> true | _ -> false // Sanity check ensures that Phase matches Subcategory #if DEBUG @@ -274,7 +272,7 @@ type ErrorLogger(nameForDebugging:string) = // The 'Impl' factoring enables a developer to place a breakpoint at the non-Impl // code just below and get a breakpoint for all error logger implementations. abstract DiagnosticSink: phasedError: PhasedDiagnostic * isError: bool -> unit - member this.DebugDisplay() = sprintf "ErrorLogger(%s)" nameForDebugging + member __.DebugDisplay() = sprintf "ErrorLogger(%s)" nameForDebugging let DiscardErrorsLogger = { new ErrorLogger("DiscardErrorsLogger") with @@ -337,7 +335,7 @@ module ErrorLoggerExtensions = try let preserveStackTrace = typeof.GetMethod("InternalPreserveStackTrace", BindingFlags.Instance ||| BindingFlags.NonPublic) preserveStackTrace.Invoke(exn, null) |> ignore - with e-> + with _ -> // This is probably only the mono case. System.Diagnostics.Debug.Assert(false, "Could not preserve stack trace for watson exception.") () @@ -411,7 +409,7 @@ module ErrorLoggerExtensions = x.ErrorR (AttachRange m exn) // may raise exceptions, e.g. an fsi error sink raises StopProcessing. ReraiseIfWatsonable(exn) with - | ReportedError _ | WrappedError(ReportedError _, _) -> () + | ReportedError _ | WrappedError(ReportedError _, _) -> () member x.StopProcessingRecovery (exn:exn) (m:range) = // Do standard error recovery. @@ -421,10 +419,11 @@ module ErrorLoggerExtensions = match exn with | StopProcessing | WrappedError(StopProcessing, _) -> () // suppress, so skip error recovery. | _ -> - try x.ErrorRecovery exn m + try + x.ErrorRecovery exn m with - | StopProcessing | WrappedError(StopProcessing, _) -> () // catch, e.g. raised by DiagnosticSink. - | ReportedError _ | WrappedError(ReportedError _, _) -> () // catch, but not expected unless ErrorRecovery is changed. + | StopProcessing | WrappedError(StopProcessing, _) -> () // catch, e.g. raised by DiagnosticSink. + | ReportedError _ | WrappedError(ReportedError _, _) -> () // catch, but not expected unless ErrorRecovery is changed. member x.ErrorRecoveryNoRange (exn:exn) = x.ErrorRecovery exn range0 @@ -445,13 +444,13 @@ let PushErrorLoggerPhaseUntilUnwind(errorLoggerTransformer : ErrorLogger -> #Err let newInstalled = ref true let newIsInstalled() = if !newInstalled then () else (assert false; (); (*failwith "error logger used after unwind"*)) // REVIEW: ok to throw? let chkErrorLogger = { new ErrorLogger("PushErrorLoggerPhaseUntilUnwind") with - member x.DiagnosticSink(phasedError, isError) = newIsInstalled(); newErrorLogger.DiagnosticSink(phasedError, isError) - member x.ErrorCount = newIsInstalled(); newErrorLogger.ErrorCount } + member __.DiagnosticSink(phasedError, isError) = newIsInstalled(); newErrorLogger.DiagnosticSink(phasedError, isError) + member __.ErrorCount = newIsInstalled(); newErrorLogger.ErrorCount } CompileThreadStatic.ErrorLogger <- chkErrorLogger { new System.IDisposable with - member x.Dispose() = + member __.Dispose() = CompileThreadStatic.ErrorLogger <- oldErrorLogger newInstalled := false } @@ -461,13 +460,13 @@ let SetThreadErrorLoggerNoUnwind(errorLogger) = CompileThreadStatic.ErrorLog // Global functions are still used by parser and TAST ops. /// Raises an exception with error recovery and returns unit. -let errorR exn = CompileThreadStatic.ErrorLogger.ErrorR exn +let errorR exn = CompileThreadStatic.ErrorLogger.ErrorR exn /// Raises a warning with error recovery and returns unit. let warning exn = CompileThreadStatic.ErrorLogger.Warning exn /// Raises a special exception and returns 'T - can be caught later at an errorRecovery point. -let error exn = CompileThreadStatic.ErrorLogger.Error exn +let error exn = CompileThreadStatic.ErrorLogger.Error exn /// Simulates an error. For test purposes only. let simulateError (p : PhasedDiagnostic) = CompileThreadStatic.ErrorLogger.SimulateError p @@ -497,8 +496,8 @@ let suppressErrorReporting f = try let errorLogger = { new ErrorLogger("suppressErrorReporting") with - member x.DiagnosticSink(_phasedError, _isError) = () - member x.ErrorCount = 0 } + member __.DiagnosticSink(_phasedError, _isError) = () + member __.ErrorCount = 0 } SetThreadErrorLoggerNoUnwind(errorLogger) f() finally diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index f09efb42d9..7e0b05f5ea 100755 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -1423,4 +1423,5 @@ notAFunctionButMaybeDeclaration,"This value is not a function and cannot be appl 3219,pickleUnexpectedNonZero,"An error occurred while reading the F# metadata of assembly '%s'. A reserved construct was utilized. You may need to upgrade your F# compiler or use an earlier version of the assembly that doesn't make use of a specific construct." 3220,tcTupleMemberNotNormallyUsed,"This method or property is not normally used from F# code, use an explicit tuple pattern for deconstruction instead." 3221,implicitlyDiscardedInSequenceExpression,"This expression returns a value of type '%s' but is implicitly discarded. Consider using 'let' to bind the result to a name, e.g. 'let result = expression'. If you intended to use the expression as a value in the sequence then use an explicit 'yield'." -3222,implicitlyDiscardedSequenceInSequenceExpression,"This expression returns a value of type '%s' but is implicitly discarded. Consider using 'let' to bind the result to a name, e.g. 'let result = expression'. If you intended to use the expression as a value in the sequence then use an explicit 'yield!'." \ No newline at end of file +3222,implicitlyDiscardedSequenceInSequenceExpression,"This expression returns a value of type '%s' but is implicitly discarded. Consider using 'let' to bind the result to a name, e.g. 'let result = expression'. If you intended to use the expression as a value in the sequence then use an explicit 'yield!'." +3223,ilreadFileChanged,"The file '%s' changed on disk unexpectedly, please reload." \ No newline at end of file diff --git a/src/fsharp/FSStrings.resx b/src/fsharp/FSStrings.resx index eb8a8f975c..bdbe391db2 100755 --- a/src/fsharp/FSStrings.resx +++ b/src/fsharp/FSStrings.resx @@ -969,6 +969,9 @@ Unmatched elements will be ignored. + + Enums may take values outside known cases. + This rule will never be matched diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index edce05ea7b..493b9c3c96 100755 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -17,7 +17,6 @@ open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.Internal.BinaryConstants open Microsoft.FSharp.Compiler @@ -35,7 +34,6 @@ open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.TypeRelations open Microsoft.FSharp.Compiler.TypeChecker open Microsoft.FSharp.Compiler.Infos -open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types let IsNonErasedTypar (tp:Typar) = not tp.IsErased @@ -436,14 +434,13 @@ and GenTypeAux amap m (tyenv: TypeReprEnv) voidOK ptrsOK ty = // Generate ILX references to closures, classunions etc. given a tyenv //-------------------------------------------------------------------------- -and GenUnionCaseRef (amap: ImportMap) m tyenv i (fspecs:RecdField array) = +and GenUnionCaseRef (amap: ImportMap) m tyenv i (fspecs:RecdField[]) = let g = amap.g fspecs |> Array.mapi (fun j fspec -> let ilFieldDef = IL.mkILInstanceField(fspec.Name,GenType amap m tyenv fspec.FormalType, None, ILMemberAccess.Public) + // These properties on the "field" of an alternative end up going on a property generated by cu_erase.fs IlxUnionField - { ilFieldDef with - // These properties on the "field" of an alternative end up going on a property generated by cu_erase.fs - CustomAttrs = mkILCustomAttrs [(mkCompilationMappingAttrWithVariantNumAndSeqNum g (int SourceConstructFlags.Field) i j )] } ) + (ilFieldDef.With(customAttrs = mkILCustomAttrs [(mkCompilationMappingAttrWithVariantNumAndSeqNum g (int SourceConstructFlags.Field) i j )]))) and GenUnionRef (amap: ImportMap) m (tcref: TyconRef) = @@ -1049,9 +1046,9 @@ let MergeOptions m o1 o2 = #endif Some x -let MergePropertyPair m (pd: ILPropertyDef) pdef = - {pd with GetMethod=MergeOptions m pd.GetMethod pdef.GetMethod - SetMethod=MergeOptions m pd.SetMethod pdef.SetMethod} +let MergePropertyPair m (pd: ILPropertyDef) (pdef: ILPropertyDef) = + pd.With(getMethod=MergeOptions m pd.GetMethod pdef.GetMethod, + setMethod=MergeOptions m pd.SetMethod pdef.SetMethod) type PropKey = PropKey of string * ILTypes * ILThisConvention @@ -1075,7 +1072,7 @@ let MergePropertyDefs m ilPropertyDefs = //-------------------------------------------------------------------------- /// Information collected imperatively for each type definition -type TypeDefBuilder(tdef, tdefDiscards) = +type TypeDefBuilder(tdef: ILTypeDef, tdefDiscards) = let gmethods = new ResizeArray(0) let gfields = new ResizeArray(0) let gproperties : Dictionary = new Dictionary<_,_>(3,HashIdentity.Structural) @@ -1083,16 +1080,16 @@ type TypeDefBuilder(tdef, tdefDiscards) = let gnested = new TypeDefsBuilder() member b.Close() = - { tdef with - Methods = mkILMethods (tdef.Methods.AsList @ ResizeArray.toList gmethods) - Fields = mkILFields (tdef.Fields.AsList @ ResizeArray.toList gfields) - Properties = mkILProperties (tdef.Properties.AsList @ HashRangeSorted gproperties ) - Events = mkILEvents (tdef.Events.AsList @ ResizeArray.toList gevents) - NestedTypes = mkILTypeDefs (tdef.NestedTypes.AsList @ gnested.Close()) } - + tdef.With(methods = mkILMethods (tdef.Methods.AsList @ ResizeArray.toList gmethods), + fields = mkILFields (tdef.Fields.AsList @ ResizeArray.toList gfields), + properties = mkILProperties (tdef.Properties.AsList @ HashRangeSorted gproperties ), + events = mkILEvents (tdef.Events.AsList @ ResizeArray.toList gevents), + nestedTypes = mkILTypeDefs (tdef.NestedTypes.AsList @ gnested.Close())) member b.AddEventDef(edef) = gevents.Add edef + member b.AddFieldDef(ilFieldDef) = gfields.Add ilFieldDef + member b.AddMethodDef(ilMethodDef) = let discard = match tdefDiscards with @@ -1100,7 +1097,9 @@ type TypeDefBuilder(tdef, tdefDiscards) = | None -> false if not discard then gmethods.Add ilMethodDef + member b.NestedTypeDefs = gnested + member b.GetCurrentFields() = gfields |> Seq.readonly /// Merge Get and Set property nodes, which we generate independently for F# code @@ -1187,7 +1186,7 @@ type AssemblyBuilder(cenv:cenv) as mgbuf = match explicitEntryPointInfo with | Some tref -> let IntializeCompiledScript(fspec,m) = - mgbuf.AddExplicitInitToSpecificMethodDef((fun md -> md.IsEntryPoint), tref, fspec, GenPossibleILSourceMarker cenv m, [], []) + mgbuf.AddExplicitInitToSpecificMethodDef((fun (md:ILMethodDef) -> md.IsEntryPoint), tref, fspec, GenPossibleILSourceMarker cenv m, [], []) scriptInitFspecs |> List.iter IntializeCompiledScript | None -> () @@ -1502,7 +1501,7 @@ let GenConstArray cenv (cgbuf:CodeGenBuffer) eenv ilElementType (data:'a[]) (wri let ilFieldName = CompilerGeneratedName ("field" + string(newUnique())) let fty = ILType.Value vtspec let ilFieldDef = mkILStaticField (ilFieldName,fty, None, Some bytes, ILMemberAccess.Assembly) - let ilFieldDef = { ilFieldDef with CustomAttrs = mkILCustomAttrs [ cenv.g.DebuggerBrowsableNeverAttribute ] } + let ilFieldDef = ilFieldDef.With(customAttrs = mkILCustomAttrs [ cenv.g.DebuggerBrowsableNeverAttribute ]) let fspec = mkILFieldSpecInTy (mkILTyForCompLoc eenv.cloc,ilFieldName, fty) CountStaticFieldDef() cgbuf.mgbuf.AddFieldDef(fspec.DeclaringTypeRef,ilFieldDef) @@ -3455,7 +3454,8 @@ and GenGenericParam cenv eenv (tp:Typar) = Constraints = subTypeConstraints Variance=NonVariant - CustomAttrs = mkILCustomAttrs (GenAttrs cenv eenv tp.Attribs) + CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs (GenAttrs cenv eenv tp.Attribs)) + MetadataIndex = NoMetadataIdx HasReferenceTypeConstraint=refTypeConstraint HasNotNullableValueTypeConstraint=notNullableValueTypeConstraint HasDefaultConstructorConstraint= defaultConstructorConstraint } @@ -3475,7 +3475,8 @@ and GenSlotParam m cenv eenv (TSlotParam(nm,ty,inFlag,outFlag,optionalFlag,attri IsIn=inFlag || inFlag2 IsOut=outFlag || outFlag2 IsOptional=optionalFlag || optionalFlag2 - CustomAttrs= mkILCustomAttrs (GenAttrs cenv eenv attribs) } + CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs (GenAttrs cenv eenv attribs)) + MetadataIndex = NoMetadataIdx } and GenFormalSlotsig m cenv eenv (TSlotSig(_,typ,ctps,mtps,paraml,returnTy)) = let paraml = List.concat paraml @@ -3526,7 +3527,7 @@ and fixupVirtualSlotFlags (mdef:ILMethodDef) = mdef.WithHideBySig() and renameMethodDef nameOfOverridingMethod (mdef : ILMethodDef) = - {mdef with Name=nameOfOverridingMethod } + mdef.With(name=nameOfOverridingMethod) and fixupMethodImplFlags (mdef:ILMethodDef) = mdef.WithAccess(ILMemberAccess.Private).WithHideBySig().WithFinal(true).WithNewSlot @@ -3562,7 +3563,7 @@ and GenObjectMethod cenv eenvinner (cgbuf:CodeGenBuffer) useMethodImpl tmethod = // fixup attributes to generate a method impl let mdef = if useMethodImpl then fixupMethodImplFlags mdef else mdef let mdef = fixupVirtualSlotFlags mdef - let mdef = { mdef with CustomAttrs = mkILCustomAttrs ilAttribs } + let mdef = mdef.With(customAttrs = mkILCustomAttrs ilAttribs) [(useMethodImpl,methodImplGenerator,methTyparsOfOverridingMethod),mdef] and GenObjectExpr cenv cgbuf eenvouter expr (baseType,baseValOpt,basecall,overrides,interfaceImpls,m) sequel = @@ -3715,24 +3716,30 @@ and GenClosureTypeDefs cenv (tref:ILTypeRef, ilGenParams, attrs, ilCloFreeVars, cloStructure=ilCloLambdas cloCode=notlazy ilCtorBody } - let td = - { Name = tref.Name - Layout = ILTypeDefLayout.Auto - Attributes = enum 0 - GenericParams = ilGenParams - CustomAttrs = mkILCustomAttrs(attrs @ [mkCompilationMappingAttr cenv.g (int SourceConstructFlags.Closure) ]) - Fields = emptyILFields - Events= emptyILEvents - Properties = emptyILProperties - Methods= mkILMethods mdefs - MethodImpls= mkILMethodImpls mimpls - NestedTypes=emptyILTypeDefs - Implements = ilIntfTys - Extends= Some ext - SecurityDecls= emptyILSecurityDecls } - let td = td.WithSealed(true).WithSerializable(true).WithSpecialName(true).WithAccess(ComputeTypeAccess tref true).WithLayout(ILTypeDefLayout.Auto).WithEncoding(ILDefaultPInvokeEncoding.Auto).WithInitSemantics(ILTypeInit.BeforeField) - - let tdefs = EraseClosures.convIlxClosureDef cenv.g.ilxPubCloEnv tref.Enclosing td cloInfo + let tdef = + ILTypeDef(name = tref.Name, + layout = ILTypeDefLayout.Auto, + attributes = enum 0, + genericParams = ilGenParams, + customAttrs = mkILCustomAttrs(attrs @ [mkCompilationMappingAttr cenv.g (int SourceConstructFlags.Closure) ]), + fields = emptyILFields, + events= emptyILEvents, + properties = emptyILProperties, + methods= mkILMethods mdefs, + methodImpls= mkILMethodImpls mimpls, + nestedTypes=emptyILTypeDefs, + implements = ilIntfTys, + extends= Some ext, + securityDecls= emptyILSecurityDecls) + .WithSealed(true) + .WithSerializable(true) + .WithSpecialName(true) + .WithAccess(ComputeTypeAccess tref true) + .WithLayout(ILTypeDefLayout.Auto) + .WithEncoding(ILDefaultPInvokeEncoding.Auto) + .WithInitSemantics(ILTypeInit.BeforeField) + + let tdefs = EraseClosures.convIlxClosureDef cenv.g.ilxPubCloEnv tref.Enclosing tdef cloInfo tdefs and GenGenericParams cenv eenv tps = tps |> DropErasedTypars |> List.map (GenGenericParam cenv eenv) @@ -3763,20 +3770,20 @@ and GenLambdaClosure cenv (cgbuf:CodeGenBuffer) eenv isLocalTypeFunc selfv expr let ilContractMeths = [ilContractCtor; mkILGenericVirtualMethod("DirectInvoke",ILMemberAccess.Assembly,ilContractMethTyargs,[],mkILReturn ilContractFormalRetTy, MethodBody.Abstract) ] let ilContractTypeDef = - { Name = ilContractTypeRef.Name - Layout = ILTypeDefLayout.Auto - Attributes = enum 0 - GenericParams = ilContractGenericParams - CustomAttrs = mkILCustomAttrs [mkCompilationMappingAttr cenv.g (int SourceConstructFlags.Closure) ] - Fields = emptyILFields - Events= emptyILEvents - Properties = emptyILProperties - Methods= mkILMethods ilContractMeths - MethodImpls= emptyILMethodImpls - NestedTypes=emptyILTypeDefs - Implements = [] - Extends= Some cenv.g.ilg.typ_Object - SecurityDecls= emptyILSecurityDecls } + ILTypeDef(name = ilContractTypeRef.Name, + layout = ILTypeDefLayout.Auto, + attributes = enum 0, + genericParams = ilContractGenericParams, + customAttrs = mkILCustomAttrs [mkCompilationMappingAttr cenv.g (int SourceConstructFlags.Closure) ], + fields = emptyILFields, + events= emptyILEvents, + properties = emptyILProperties, + methods= mkILMethods ilContractMeths, + methodImpls= emptyILMethodImpls, + nestedTypes=emptyILTypeDefs, + implements = [], + extends= Some cenv.g.ilg.typ_Object, + securityDecls= emptyILSecurityDecls) let ilContractTypeDef = ilContractTypeDef.WithAbstract(true).WithAccess(ComputeTypeAccess ilContractTypeRef true).WithSerializable(true).WithSpecialName(true).WithLayout(ILTypeDefLayout.Auto).WithInitSemantics(ILTypeInit.BeforeField).WithEncoding(ILDefaultPInvokeEncoding.Auto) // the contract type is an abstract type and not sealed cgbuf.mgbuf.AddTypeDef(ilContractTypeRef, ilContractTypeDef, false, false, None) @@ -4702,15 +4709,15 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec,rhsExpr,_)) sta let ilAttribs = GenAttrs cenv eenv vspec.Attribs let ilTy = ilGetterMethSpec.FormalReturnType let ilPropDef = - { Name = PrettyNaming.ChopPropertyName ilGetterMethSpec.Name - Attributes = PropertyAttributes.None - SetMethod = None - GetMethod = Some ilGetterMethSpec.MethodRef - CallingConv = ILThisConvention.Static - Type = ilTy - Init = None - Args = [] - CustomAttrs = mkILCustomAttrs ilAttribs } + ILPropertyDef(name = PrettyNaming.ChopPropertyName ilGetterMethSpec.Name, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some ilGetterMethSpec.MethodRef, + callingConv = ILThisConvention.Static, + propertyType = ilTy, + init = None, + args = [], + customAttrs = mkILCustomAttrs ilAttribs) cgbuf.mgbuf.AddOrMergePropertyDef(ilGetterMethSpec.MethodRef.DeclaringTypeRef, ilPropDef,m) let ilMethodDef = @@ -4742,7 +4749,7 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec,rhsExpr,_)) sta let ilFieldDef = mkILStaticField (fspec.Name, fty, None, None, access) let ilFieldDef = match vref.LiteralValue with - | Some konst -> { ilFieldDef.WithHasDefault(true) with LiteralValue = Some(GenFieldInit m konst) } + | Some konst -> ilFieldDef.WithLiteralDefaultValue( Some (GenFieldInit m konst) ) | None -> ilFieldDef let ilFieldDef = @@ -4757,9 +4764,7 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec,rhsExpr,_)) sta else GenAttrs cenv eenv vspec.Attribs // literals have no property, so preserve all the attributes on the field itself - let ilFieldDef = - { ilFieldDef with - CustomAttrs = mkILCustomAttrs (ilAttribs @ [ cenv.g.DebuggerBrowsableNeverAttribute ]) } + let ilFieldDef = ilFieldDef.With(customAttrs = mkILCustomAttrs (ilAttribs @ [ cenv.g.DebuggerBrowsableNeverAttribute ])) [ (fspec.DeclaringTypeRef, ilFieldDef) ] @@ -4776,15 +4781,15 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec,rhsExpr,_)) sta |> List.filter (fun (Attrib(_,_,_,_,_,targets,_)) -> canTarget(targets, System.AttributeTargets.Property)) |> GenAttrs cenv eenv // property only gets attributes that target properties let ilPropDef = - { Name=ilPropName - Attributes = PropertyAttributes.None - SetMethod=if mut || cenv.opts.isInteractiveItExpr then Some ilSetterMethRef else None - GetMethod=Some ilGetterMethRef - CallingConv=ILThisConvention.Static - Type=fty - Init=None - Args = [] - CustomAttrs=mkILCustomAttrs (ilAttribs @ [mkCompilationMappingAttr cenv.g (int SourceConstructFlags.Value)]) } + ILPropertyDef(name=ilPropName, + attributes = PropertyAttributes.None, + setMethod=(if mut || cenv.opts.isInteractiveItExpr then Some ilSetterMethRef else None), + getMethod=Some ilGetterMethRef, + callingConv=ILThisConvention.Static, + propertyType=fty, + init=None, + args = [], + customAttrs=mkILCustomAttrs (ilAttribs @ [mkCompilationMappingAttr cenv.g (int SourceConstructFlags.Value)])) cgbuf.mgbuf.AddOrMergePropertyDef(ilTypeRefForProperty,ilPropDef,m) let getterMethod = @@ -5002,7 +5007,8 @@ and GenParams cenv eenv (mspec:ILMethodSpec) (attribs:ArgReprInfo list) (implVal IsIn=inFlag IsOut=outFlag IsOptional=optionalFlag - CustomAttrs= mkILCustomAttrs (GenAttrs cenv eenv attribs) } + CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs (GenAttrs cenv eenv attribs)) + MetadataIndex = NoMetadataIdx } param, takenNames) |> fst @@ -5011,20 +5017,21 @@ and GenReturnInfo cenv eenv ilRetTy (retInfo : ArgReprInfo) : ILReturn = let marshal,attrs = GenMarshal cenv retInfo.Attribs { Type=ilRetTy Marshal=marshal - CustomAttrs= mkILCustomAttrs (GenAttrs cenv eenv attrs) } + CustomAttrsStored= storeILCustomAttrs (mkILCustomAttrs (GenAttrs cenv eenv attrs)) + MetadataIndex = NoMetadataIdx } and GenPropertyForMethodDef compileAsInstance tref mdef (v:Val) (memberInfo:ValMemberInfo) ilArgTys ilPropTy ilAttrs compiledName = let name = match compiledName with | Some n -> n | _ -> v.PropertyName in (* chop "get_" *) - { Name = name - Attributes = PropertyAttributes.None - SetMethod = (if memberInfo.MemberFlags.MemberKind= MemberKind.PropertySet then Some(mkRefToILMethod(tref,mdef)) else None) - GetMethod = (if memberInfo.MemberFlags.MemberKind= MemberKind.PropertyGet then Some(mkRefToILMethod(tref,mdef)) else None) - CallingConv = (if compileAsInstance then ILThisConvention.Instance else ILThisConvention.Static) - Type = ilPropTy - Init = None - Args = ilArgTys - CustomAttrs = ilAttrs } + ILPropertyDef(name = name, + attributes = PropertyAttributes.None, + setMethod = (if memberInfo.MemberFlags.MemberKind= MemberKind.PropertySet then Some(mkRefToILMethod(tref,mdef)) else None), + getMethod = (if memberInfo.MemberFlags.MemberKind= MemberKind.PropertyGet then Some(mkRefToILMethod(tref,mdef)) else None), + callingConv = (if compileAsInstance then ILThisConvention.Instance else ILThisConvention.Static), + propertyType = ilPropTy, + init = None, + args = ilArgTys, + customAttrs = ilAttrs) and GenEventForProperty cenv eenvForMeth (mspec:ILMethodSpec) (v:Val) ilAttrsThatGoOnPrimaryItem m returnTy = let evname = v.PropertyName @@ -5033,14 +5040,14 @@ and GenEventForProperty cenv eenvForMeth (mspec:ILMethodSpec) (v:Val) ilAttrsTha let ilThisTy = mspec.DeclaringType let addMethRef = mkILMethRef (ilThisTy.TypeRef,mspec.CallingConv,"add_" + evname,0,[ilDelegateTy],ILType.Void) let removeMethRef = mkILMethRef (ilThisTy.TypeRef,mspec.CallingConv,"remove_" + evname,0,[ilDelegateTy],ILType.Void) - { Type = Some(ilDelegateTy) - Name= evname - Attributes = EventAttributes.None - AddMethod = addMethRef - RemoveMethod = removeMethRef - FireMethod= None - OtherMethods= [] - CustomAttrs = mkILCustomAttrs ilAttrsThatGoOnPrimaryItem } + ILEventDef(eventType = Some ilDelegateTy, + name= evname, + attributes = EventAttributes.None, + addMethod = addMethRef, + removeMethod = removeMethRef, + fireMethod= None, + otherMethods= [], + customAttrs = mkILCustomAttrs ilAttrsThatGoOnPrimaryItem) and ComputeFlagFixupsForMemberBinding cenv (v:Val,memberInfo:ValMemberInfo) = @@ -5188,7 +5195,7 @@ and GenMethodForBinding let permissionSets = CreatePermissionSets cenv.g cenv.amap eenv securityAttributes - let secDecls = if securityAttributes.Length > 0 then (mkILSecurityDecls permissionSets) else (emptyILSecurityDecls) + let secDecls = if List.isEmpty securityAttributes then emptyILSecurityDecls else mkILSecurityDecls permissionSets // Do not push the attributes to the method for events and properties let ilAttrsCompilerGenerated = if v.IsCompilerGenerated then [ cenv.g.CompilerGeneratedAttribute ] else [] @@ -5207,12 +5214,15 @@ and GenMethodForBinding // Does the function have an explicit [] attribute? let isExplicitEntryPoint = HasFSharpAttribute cenv.g cenv.g.attrib_EntryPointAttribute attrs - let mdef = mdef.WithSecurity(securityAttributes.Length > 0).WithPInvoke(hasDllImport) - let mdef = mdef.WithPreserveSig(hasPreserveSigImplFlag || hasPreserveSigNamedArg).WithSynchronized(hasSynchronizedImplFlag).WithNoInlining(hasNoInliningFlag).WithAggressiveInlining(hasAggressiveInliningImplFlag) - let mdef = - { mdef with - IsEntryPoint = isExplicitEntryPoint - SecurityDecls = secDecls } + let mdef = + mdef + .WithSecurity(not (List.isEmpty securityAttributes)) + .WithPInvoke(hasDllImport) + .WithPreserveSig(hasPreserveSigImplFlag || hasPreserveSigNamedArg) + .WithSynchronized(hasSynchronizedImplFlag) + .WithNoInlining(hasNoInliningFlag) + .WithAggressiveInlining(hasAggressiveInliningImplFlag) + .With(isEntryPoint=isExplicitEntryPoint, securityDecls=secDecls) let mdef = if // operator names @@ -5239,13 +5249,13 @@ and GenMethodForBinding if memberInfo.MemberFlags.MemberKind = MemberKind.Constructor then assert (isNil ilMethTypars) let mdef = mkILCtor (access,ilParams,ilMethodBody) - let mdef = { mdef with CustomAttrs= mkILCustomAttrs (ilAttrsThatGoOnPrimaryItem @ sourceNameAttribs @ ilAttrsCompilerGenerated) } + let mdef = mdef.With(customAttrs= mkILCustomAttrs (ilAttrsThatGoOnPrimaryItem @ sourceNameAttribs @ ilAttrsCompilerGenerated)) EmitTheMethodDef mdef elif memberInfo.MemberFlags.MemberKind = MemberKind.ClassConstructor then assert (isNil ilMethTypars) let mdef = mkILClassCtor ilMethodBody - let mdef = { mdef with CustomAttrs= mkILCustomAttrs (ilAttrsThatGoOnPrimaryItem @ sourceNameAttribs @ ilAttrsCompilerGenerated) } + let mdef = mdef.With(customAttrs= mkILCustomAttrs (ilAttrsThatGoOnPrimaryItem @ sourceNameAttribs @ ilAttrsCompilerGenerated)) EmitTheMethodDef mdef // Generate virtual/override methods + method-impl information if needed @@ -5302,10 +5312,10 @@ and GenMethodForBinding cgbuf.mgbuf.AddOrMergePropertyDef(tref,ilPropDef,m) // Add the special name flag for all properties - let mdef = { mdef.WithSpecialName with CustomAttrs= mkILCustomAttrs ((GenAttrs cenv eenv attrsAppliedToGetterOrSetter) @ sourceNameAttribs @ ilAttrsCompilerGenerated) } + let mdef = mdef.WithSpecialName.With(customAttrs= mkILCustomAttrs ((GenAttrs cenv eenv attrsAppliedToGetterOrSetter) @ sourceNameAttribs @ ilAttrsCompilerGenerated)) EmitTheMethodDef mdef | _ -> - let mdef = { mdef with CustomAttrs= mkILCustomAttrs (ilAttrsThatGoOnPrimaryItem @ sourceNameAttribs @ ilAttrsCompilerGenerated) } + let mdef = mdef.With(customAttrs= mkILCustomAttrs (ilAttrsThatGoOnPrimaryItem @ sourceNameAttribs @ ilAttrsCompilerGenerated)) EmitTheMethodDef mdef | _ -> @@ -5321,7 +5331,7 @@ and GenMethodForBinding | _ -> ilAttrsThatGoOnPrimaryItem let ilCustomAttrs = mkILCustomAttrs (ilAttrs @ sourceNameAttribs @ ilAttrsCompilerGenerated) - let mdef = { mdef with CustomAttrs= ilCustomAttrs } + let mdef = mdef.With(customAttrs= ilCustomAttrs) EmitTheMethodDef mdef @@ -5954,7 +5964,7 @@ and GenTopImpl cenv mgbuf mainInfoOpt eenv (TImplFile(qname, _, mexpr, hasExplic // generate main@ let ilMainMethodDef = let mdef = mkILNonGenericStaticMethod(mainMethName,ILMemberAccess.Public,[],mkILReturn ILType.Void, MethodBody.IL topCode) - {mdef with IsEntryPoint= true; CustomAttrs = ilAttrs } + mdef.With(isEntryPoint= true, customAttrs = ilAttrs) mgbuf.AddMethodDef(initClassTy.TypeRef,ilMainMethodDef) @@ -6064,7 +6074,7 @@ and GenAbstractBinding cenv eenv tref (vref:ValRef) = | MemberKind.ClassConstructor | MemberKind.Constructor | MemberKind.Member -> - let mdef = {mdef with CustomAttrs= mkILCustomAttrs ilAttrs } + let mdef = mdef.With(customAttrs= mkILCustomAttrs ilAttrs) [mdef], [], [] | MemberKind.PropertyGetSet -> error(Error(FSComp.SR.ilUnexpectedGetSetAnnotation(),m)) | MemberKind.PropertySet | MemberKind.PropertyGet -> @@ -6106,22 +6116,23 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let sprintfMethSpec = mkILMethSpec(sprintfMethSpec.MethodRef,AsObject,[],[funcTy]) // Here's the body of the method. Call printf, then invoke the function it returns let callInstrs = EraseClosures.mkCallFunc cenv.g.ilxPubCloEnv (fun _ -> 0us) eenv.tyenv.Count Normalcall (Apps_app(ilThisTy, Apps_done cenv.g.ilg.typ_String)) - let ilMethodDef = mkILNonGenericVirtualMethod ("ToString",ILMemberAccess.Public,[], - mkILReturn cenv.g.ilg.typ_String, - mkMethodBody (true,[],2,nonBranchingInstrsToCode - ([ // load the hardwired format string - yield I_ldstr "%+A" - // make the printf format object - yield mkNormalNewobj newFormatMethSpec - // call sprintf - yield mkNormalCall sprintfMethSpec - // call the function returned by sprintf - yield mkLdarg0 - if ilThisTy.Boxity = ILBoxity.AsValue then - yield mkNormalLdobj ilThisTy ] @ - callInstrs), - None)) - let mdef = { ilMethodDef with CustomAttrs = mkILCustomAttrs [ cenv.g.CompilerGeneratedAttribute ] } + let mdef = + mkILNonGenericVirtualMethod ("ToString",ILMemberAccess.Public,[], + mkILReturn cenv.g.ilg.typ_String, + mkMethodBody (true,[],2,nonBranchingInstrsToCode + ([ // load the hardwired format string + yield I_ldstr "%+A" + // make the printf format object + yield mkNormalNewobj newFormatMethSpec + // call sprintf + yield mkNormalCall sprintfMethSpec + // call the function returned by sprintf + yield mkLdarg0 + if ilThisTy.Boxity = ILBoxity.AsValue then + yield mkNormalLdobj ilThisTy ] @ + callInstrs), + None)) + let mdef = mdef.With(customAttrs = mkILCustomAttrs [ cenv.g.CompilerGeneratedAttribute ]) yield mdef | None,_ -> () | _,None -> () @@ -6238,7 +6249,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = not (HasFSharpAttribute cenv.g cenv.g.attrib_DebuggerTypeProxyAttribute tycon.Attribs)) let permissionSets = CreatePermissionSets cenv.g cenv.amap eenv securityAttrs - let secDecls = if securityAttrs.Length > 0 then (mkILSecurityDecls permissionSets) else (emptyILSecurityDecls) + let secDecls = if List.isEmpty securityAttrs then emptyILSecurityDecls else mkILSecurityDecls permissionSets let ilDebugDisplayAttributes = [ yield! GenAttrs cenv eenv debugDisplayAttrs @@ -6344,22 +6355,20 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let literalValue = Option.map (GenFieldInit m) fspec.LiteralValue let fdef = - { Name = ilFieldName - Type = ilPropType - Attributes = enum 0 - Data = None - LiteralValue = literalValue - Offset = ilFieldOffset - Marshal = ilFieldMarshal - CustomAttrs = mkILCustomAttrs (GenAttrs cenv eenv fattribs @ extraAttribs) } - let fdef = - fdef.WithAccess(access) + ILFieldDef(name = ilFieldName, + fieldType = ilPropType, + attributes = enum 0, + data = None, + literalValue = None, + offset = ilFieldOffset, + marshal = None, + customAttrs = mkILCustomAttrs (GenAttrs cenv eenv fattribs @ extraAttribs)) + .WithAccess(access) .WithStatic(isStatic) .WithSpecialName(ilFieldName="value__" && tycon.IsEnumTycon) .WithNotSerialized(ilNotSerialized) - .WithLiteral(fspec.LiteralValue.IsSome) - .WithHasDefault(literalValue.IsSome) - .WithHasFieldMarshal(ilFieldMarshal.IsSome) + .WithLiteralDefaultValue(literalValue) + .WithFieldMarshal(ilFieldMarshal) yield fdef if requiresExtraField then @@ -6374,15 +6383,15 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let ilHasSetter = isCLIMutable || isFSharpMutable let ilFieldAttrs = GenAttrs cenv eenv propAttribs @ [mkCompilationMappingAttrWithSeqNum cenv.g (int SourceConstructFlags.Field) i] yield - { Name = ilPropName - Attributes = PropertyAttributes.None - SetMethod = (if ilHasSetter then Some(mkILMethRef(tref,ilCallingConv,"set_" + ilPropName,0,[ilPropType],ILType.Void)) else None) - GetMethod = Some(mkILMethRef(tref,ilCallingConv,"get_" + ilPropName,0,[],ilPropType)) - CallingConv = ilCallingConv.ThisConv - Type = ilPropType - Init = None - Args = [] - CustomAttrs = mkILCustomAttrs ilFieldAttrs } ] + ILPropertyDef(name= ilPropName, + attributes= PropertyAttributes.None, + setMethod= (if ilHasSetter then Some(mkILMethRef(tref,ilCallingConv,"set_" + ilPropName,0,[ilPropType],ILType.Void)) else None), + getMethod= Some(mkILMethRef(tref,ilCallingConv,"get_" + ilPropName,0,[],ilPropType)), + callingConv= ilCallingConv.ThisConv, + propertyType= ilPropType, + init= None, + args= [], + customAttrs = mkILCustomAttrs ilFieldAttrs) ] let methodDefs = [ // Generate property getter methods for those fields that have properties @@ -6523,9 +6532,9 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = match tycon.TypeReprInfo with | TILObjectRepr _ -> - let td = tycon.ILTyconRawMetadata.WithAccess(access) - {td with CustomAttrs = mkILCustomAttrs ilCustomAttrs - GenericParams = ilGenParams }, None + let tdef = tycon.ILTyconRawMetadata.WithAccess(access) + let tdef = tdef.With(customAttrs = mkILCustomAttrs ilCustomAttrs, genericParams = ilGenParams) + tdef, None | TRecdRepr _ | TFSharpObjectRepr _ as tyconRepr -> let super = superOfTycon cenv.g tycon @@ -6566,7 +6575,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let isTheSealedAttribute = tyconRefEq cenv.g tcref cenv.g.attrib_SealedAttribute.TyconRef let tdef = tdef.WithSealed(isSealedTy cenv.g thisTy || isTheSealedAttribute).WithSerializable(isSerializable).WithAbstract(isAbstract).WithImport(isComInteropTy cenv.g thisTy) - let tdef = { tdef with MethodImpls=mkILMethodImpls methodImpls } + let tdef = tdef.With(methodImpls=mkILMethodImpls methodImpls) let tdLayout,tdEncoding = match TryFindFSharpAttribute cenv.g cenv.g.attrib_StructLayoutAttribute tycon.Attribs with @@ -6612,14 +6621,14 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = ILTypeDefLayout.Auto, ILDefaultPInvokeEncoding.Ansi // if the type's layout is Explicit, ensure that each field has a valid offset - let validateExplicit fdef = + let validateExplicit (fdef: ILFieldDef) = match fdef.Offset with // Remove field suffix "@" for pretty printing | None -> errorR(Error(FSComp.SR.ilFieldDoesNotHaveValidOffsetForStructureLayout(tdef.Name, fdef.Name.Replace("@","")), (trimRangeToLine m))) | _ -> () // if the type's layout is Sequential, no offsets should be applied - let validateSequential fdef = + let validateSequential (fdef: ILFieldDef) = match fdef.Offset with | Some _ -> errorR(Error(FSComp.SR.ilFieldHasOffsetForSequentialLayout(), (trimRangeToLine m))) | _ -> () @@ -6658,26 +6667,33 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = else ILTypeDefLayout.Auto + let cattrs = + mkILCustomAttrs (ilCustomAttrs @ + [mkCompilationMappingAttr cenv.g + (int (if hiddenRepr + then SourceConstructFlags.SumType ||| SourceConstructFlags.NonPublicRepresentation + else SourceConstructFlags.SumType)) ]) let tdef = - { Name = ilTypeName - Layout = layout - Attributes = enum 0 - GenericParams = ilGenParams - CustomAttrs = - mkILCustomAttrs (ilCustomAttrs @ - [mkCompilationMappingAttr cenv.g - (int (if hiddenRepr - then SourceConstructFlags.SumType ||| SourceConstructFlags.NonPublicRepresentation - else SourceConstructFlags.SumType)) ]) - Fields = ilFields - Events= ilEvents - Properties = ilProperties - Methods= mkILMethods ilMethods - MethodImpls= mkILMethodImpls methodImpls - NestedTypes=emptyILTypeDefs - Implements = ilIntfTys - Extends= Some (if tycon.IsStructOrEnumTycon then cenv.g.iltyp_ValueType else cenv.g.ilg.typ_Object) - SecurityDecls= emptyILSecurityDecls }.WithLayout(layout).WithSerializable(isSerializable).WithSealed(true).WithEncoding(ILDefaultPInvokeEncoding.Auto).WithAccess(access).WithInitSemantics(ILTypeInit.BeforeField) + ILTypeDef(name = ilTypeName, + layout = layout, + attributes = enum 0, + genericParams = ilGenParams, + customAttrs = cattrs, + fields = ilFields, + events= ilEvents, + properties = ilProperties, + methods= mkILMethods ilMethods, + methodImpls= mkILMethodImpls methodImpls, + nestedTypes=emptyILTypeDefs, + implements = ilIntfTys, + extends= Some (if tycon.IsStructOrEnumTycon then cenv.g.iltyp_ValueType else cenv.g.ilg.typ_Object), + securityDecls= emptyILSecurityDecls) + .WithLayout(layout) + .WithSerializable(isSerializable) + .WithSealed(true) + .WithEncoding(ILDefaultPInvokeEncoding.Auto) + .WithAccess(access) + .WithInitSemantics(ILTypeInit.BeforeField) let tdef2 = cenv.g.eraseClassUnionDef tref tdef cuinfo @@ -6699,10 +6715,8 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = | _ -> failwith "??" - let tdef = tdef.WithHasSecurity(securityAttrs.Length > 0) - let tdef = - { tdef with - SecurityDecls = secDecls } + let tdef = tdef.WithHasSecurity(not (List.isEmpty securityAttrs)) + let tdef = tdef.With(securityDecls = secDecls) mgbuf.AddTypeDef(tref, tdef, false, false, tdefDiscards) // If a non-generic type is written with "static let" and "static do" (i.e. it has a ".cctor") @@ -6738,15 +6752,15 @@ and GenExnDef cenv mgbuf eenv m (exnc:Tycon) = let ilMethodDef = mkLdfldMethodDef (ilMethName,reprAccess,false,ilThisTy,ilFieldName,ilPropType) let ilFieldDef = IL.mkILInstanceField(ilFieldName,ilPropType, None, ILMemberAccess.Assembly) let ilPropDef = - { Name = ilPropName - Attributes = PropertyAttributes.None - SetMethod = None - GetMethod = Some(mkILMethRef(tref,ILCallingConv.Instance,ilMethName,0,[],ilPropType)) - CallingConv = ILThisConvention.Instance - Type = ilPropType - Init = None - Args = [] - CustomAttrs=mkILCustomAttrs (GenAttrs cenv eenv fld.PropertyAttribs @ [mkCompilationMappingAttrWithSeqNum cenv.g (int SourceConstructFlags.Field) i]) } + ILPropertyDef(name = ilPropName, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some(mkILMethRef(tref,ILCallingConv.Instance,ilMethName,0,[],ilPropType)), + callingConv = ILThisConvention.Instance, + propertyType = ilPropType, + init = None, + args = [], + customAttrs=mkILCustomAttrs (GenAttrs cenv eenv fld.PropertyAttribs @ [mkCompilationMappingAttrWithSeqNum cenv.g (int SourceConstructFlags.Field) i])) yield (ilMethodDef,ilFieldDef,ilPropDef,(ilPropName,ilFieldName,ilPropType)) ] |> List.unzip4 diff --git a/src/fsharp/IlxGen.fsi b/src/fsharp/IlxGen.fsi index f3db038698..25c727eca8 100755 --- a/src/fsharp/IlxGen.fsi +++ b/src/fsharp/IlxGen.fsi @@ -18,21 +18,39 @@ type IlxGenBackend = [] type internal IlxGenOptions = { fragName : string + + /// Indicates if we are generating filter blocks generateFilterBlocks : bool + + /// Indicates if we should workaround old reflection emit bugs workAroundReflectionEmitBugs : bool + + /// Indicates if static array data should be emitted using static blobs emitConstantArraysUsingStaticDataBlobs : bool + /// If this is set, then the last module becomes the "main" module mainMethodInfo : Attribs option + + /// Indicates if local optimizations are active localOptimizationsAreOn : bool + + /// Indicates if we are generating debug symbols or not generateDebugSymbols : bool + + /// A flag to help test emit of debug information testFlagEmitFeeFeeAs100001 : bool + + /// Indicates which backend we are generating code for ilxBackend : IlxGenBackend + /// Indicates the code is being generated in FSI.EXE and is executed immediately after code generation /// This includes all interactively compiled code, including #load, definitions, and expressions isInteractive : bool + /// Indicates the code generated is an interactive 'it' expression. We generate a setter to allow clearing of the underlying /// storage, even though 'it' is not logically mutable isInteractiveItExpr : bool + /// Indicates that, whenever possible, use callvirt instead of call alwaysCallVirt : bool } @@ -71,7 +89,7 @@ type public IlxAssemblyGenerator = member GenerateCode : IlxGenOptions * TypedAssemblyAfterOptimization * Attribs * Attribs -> IlxGenResults /// Create the CAS permission sets for an assembly fragment - member CreatePermissionSets : Attrib list -> ILPermission list + member CreatePermissionSets : Attrib list -> ILSecurityDecl list /// Invert the compilation of the given value and clear the storage of the value member ClearGeneratedValue : ExecutionContext * Val -> unit diff --git a/src/fsharp/InternalCollections.fs b/src/fsharp/InternalCollections.fs index 51fedcd6f9..8713eef00f 100755 --- a/src/fsharp/InternalCollections.fs +++ b/src/fsharp/InternalCollections.fs @@ -198,37 +198,3 @@ type internal MruCache<'Token, 'Key,'Value when 'Value : not struct>(keepStrongl member bc.Resize(tok, newKeepStrongly, ?newKeepMax) = cache.Resize(tok, newKeepStrongly, ?newKeepMax=newKeepMax) -/// List helpers -[] -type internal List = - /// Return a new list with one element for each unique 'Key. Multiple 'TValues are flattened. - /// The original order of the first instance of 'Key is preserved. - static member groupByFirst( l : ('Key * 'Value) list) : ('Key * 'Value list) list = - let nextIndex = ref 0 - let result = System.Collections.Generic.List<'Key * System.Collections.Generic.List<'Value>>() - let keyToIndex = Dictionary<'Key,int>(HashIdentity.Structural) - let indexOfKey(key) = - match keyToIndex.TryGetValue(key) with - | true, v -> v - | false, _ -> - keyToIndex.Add(key,!nextIndex) - nextIndex := !nextIndex + 1 - !nextIndex - 1 - - for kv in l do - let index = indexOfKey(fst kv) - if index>= result.Count then - let k,vs = fst kv,System.Collections.Generic.List<'Value>() - vs.Add(snd kv) - result.Add(k,vs) - else - let _,vs = result.[index] - vs.Add(snd kv) - - result |> Seq.map(fun (k,vs) -> k,vs |> List.ofSeq ) |> List.ofSeq - - /// Return each distinct item in the list using reference equality. - static member referenceDistinct( l : 'T list) : 'T list when 'T : not struct = - let set = System.Collections.Generic.Dictionary<'T,bool>(HashIdentity.Reference) - l |> List.iter(fun i->set.Add(i,true)) - set |> Seq.map(fun kv->kv.Key) |> List.ofSeq diff --git a/src/fsharp/InternalCollections.fsi b/src/fsharp/InternalCollections.fsi index 8e26bc9578..711fb91d84 100755 --- a/src/fsharp/InternalCollections.fsi +++ b/src/fsharp/InternalCollections.fsi @@ -75,10 +75,3 @@ namespace Internal.Utilities.Collections /// Resize member Resize : 'Token * keepStrongly: int * ?keepMax : int -> unit - [] - type internal List = - /// Return a new list with one element for each unique 'Key. Multiple 'TValues are flattened. - /// The original order of the first instance of 'Key is preserved. - static member groupByFirst : l:('Key * 'Value) list -> ('Key * 'Value list) list when 'Key : equality - /// Return each distinct item in the list using reference equality. - static member referenceDistinct : 'T list -> 'T list when 'T : not struct diff --git a/src/fsharp/LegacyHostedCompilerForTesting.fs b/src/fsharp/LegacyHostedCompilerForTesting.fs index 38cfd28d8e..1f8e258e07 100644 --- a/src/fsharp/LegacyHostedCompilerForTesting.fs +++ b/src/fsharp/LegacyHostedCompilerForTesting.fs @@ -13,6 +13,7 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Driver open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library /// build issue location @@ -65,7 +66,7 @@ type internal InProcCompiler(legacyReferenceResolver) = { new Exiter with member this.Exit n = exitCode := n; raise StopProcessing } try - typecheckAndCompile(ctok, argv, legacyReferenceResolver, false, false, true, exiter, loggerProvider.Provider, None, None) + typecheckAndCompile(ctok, argv, legacyReferenceResolver, false, ReduceMemoryFlag.Yes, CopyFSharpCoreFlag.Yes, exiter, loggerProvider.Provider, None, None) with | StopProcessing -> () | ReportedError _ | WrappedError(ReportedError _,_) -> diff --git a/src/fsharp/LexFilter.fs b/src/fsharp/LexFilter.fs index 5b9deaf832..c933a847bb 100755 --- a/src/fsharp/LexFilter.fs +++ b/src/fsharp/LexFilter.fs @@ -444,7 +444,7 @@ type TokenTup = let (|TyparsCloseOp|_|) (txt:string) = let angles = txt |> Seq.takeWhile (fun c -> c = '>') |> Seq.toList let afterAngles = txt |> Seq.skipWhile (fun c -> c = '>') |> Seq.toList - if angles.Length = 0 then None else + if List.isEmpty angles then None else let afterOp = match (new System.String(Array.ofSeq afterAngles)) with diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs index 31e2c960f3..46932d3ca7 100644 --- a/src/fsharp/MethodCalls.fs +++ b/src/fsharp/MethodCalls.fs @@ -530,22 +530,21 @@ let ComputeConstrainedCallInfo g amap m (objArgs,minfo:MethInfo) = /// Adjust the 'this' pointer before making a call /// Take the address of a struct, and coerce to an interface/base/constraint type if necessary let TakeObjAddrForMethodCall g amap (minfo:MethInfo) isMutable m objArgs f = - let ccallInfo = ComputeConstrainedCallInfo g amap m (objArgs,minfo) - let mustTakeAddress = - (minfo.IsStruct && not minfo.IsExtensionMember) // don't take the address of a struct when passing to an extension member - || - (match ccallInfo with - | Some _ -> true - | None -> false) + let ccallInfo = ComputeConstrainedCallInfo g amap m (objArgs,minfo) + let wrap,objArgs = match objArgs with - | [objArgExpr] -> + | [objArgExpr] -> + let hasCallInfo = ccallInfo.IsSome + let mustTakeAddress = + (minfo.IsStruct && not minfo.IsExtensionMember) // don't take the address of a struct when passing to an extension member + || hasCallInfo let objArgTy = tyOfExpr g objArgExpr - let wrap,objArgExpr' = mkExprAddrOfExpr g mustTakeAddress (Option.isSome ccallInfo) isMutable objArgExpr None m + let wrap,objArgExpr' = mkExprAddrOfExpr g mustTakeAddress hasCallInfo isMutable objArgExpr None m // Extension members and calls to class constraints may need a coercion for their object argument let objArgExpr' = - if Option.isNone ccallInfo && // minfo.IsExtensionMember && minfo.IsStruct && + if not hasCallInfo && // minfo.IsExtensionMember && minfo.IsStruct && not (TypeDefinitelySubsumesTypeNoCoercion 0 g amap m minfo.ApparentEnclosingType objArgTy) then mkCoerceExpr(objArgExpr',minfo.ApparentEnclosingType,m,objArgTy) else @@ -554,7 +553,7 @@ let TakeObjAddrForMethodCall g amap (minfo:MethInfo) isMutable m objArgs f = wrap,[objArgExpr'] | _ -> - (fun x -> x), objArgs + id, objArgs let e,ety = f ccallInfo objArgs wrap e,ety @@ -579,7 +578,7 @@ let BuildILMethInfoCall g amap m isProp (minfo:ILMethInfo) valUseFlags minst dir let ilMethRef = minfo.ILMethodRef let newobj = ctor && (match valUseFlags with NormalValUse -> true | _ -> false) let exprTy = if ctor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnTy(amap, m, minst) - let retTy = (if not ctor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprTy]) + let retTy = if not ctor && ilMethRef.ReturnType = ILType.Void then [] else [exprTy] let isDllImport = minfo.IsDllImport g Expr.Op(TOp.ILCall(useCallvirt,isProtected,valu,newobj,valUseFlags,isProp,isDllImport,ilMethRef,minfo.DeclaringTypeInst,minst,retTy),[],args,m), exprTy @@ -604,9 +603,7 @@ let BuildFSharpMethodApp g m (vref: ValRef) vexp vexprty (args: Exprs) = ((args,vexprty), arities) ||> List.mapFold (fun (args,fty) arity -> match arity,args with | (0|1),[] when typeEquiv g (domainOfFunTy g fty) g.unit_ty -> mkUnit g m, (args, rangeOfFunTy g fty) - | 0,(arg::argst)-> - - + | 0,(arg::argst) -> warning(InternalError(sprintf "Unexpected zero arity, args = %s" (Layout.showL (Layout.sepListL (Layout.rightL (Layout.TaggedTextOps.tagText ";")) (List.map exprL args))),m)); arg, (argst, rangeOfFunTy g fty) | 1,(arg :: argst) -> arg, (argst, rangeOfFunTy g fty) @@ -673,9 +670,8 @@ let TryImportProvidedMethodBaseAsLibraryIntrinsic (amap:Import.ImportMap, m:rang | _ -> match amap.g.knownFSharpCoreModules.TryGetValue(declaringEntity.LogicalName) with | true,modRef -> - match modRef.ModuleOrNamespaceType.AllValsByLogicalName |> Seq.tryPick (fun (KeyValue(_,v)) -> if v.CompiledName = methodName then Some v else None) with - | Some v -> Some (mkNestedValRef modRef v) - | None -> None + modRef.ModuleOrNamespaceType.AllValsByLogicalName + |> Seq.tryPick (fun (KeyValue(_,v)) -> if v.CompiledName = methodName then Some (mkNestedValRef modRef v) else None) | _ -> None else None @@ -693,13 +689,12 @@ let TryImportProvidedMethodBaseAsLibraryIntrinsic (amap:Import.ImportMap, m:rang // objArgs: the 'this' argument, if any // args: the arguments, if any let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objArgs args = - let direct = IsBaseCall objArgs TakeObjAddrForMethodCall g amap minfo isMutable m objArgs (fun ccallInfo objArgs -> - let allArgs = (objArgs @ args) + let allArgs = objArgs @ args let valUseFlags = - if (direct && (match valUseFlags with NormalValUse -> true | _ -> false)) then + if direct && (match valUseFlags with NormalValUse -> true | _ -> false) then VSlotDirectCall else match ccallInfo with @@ -722,7 +717,7 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA // these calls are provided by the runtime and should not be called from the user code if isArrayTy g enclTy then let tpe = TypeProviderError(FSComp.SR.tcRuntimeSuppliedMethodCannotBeUsedInUserCode(minfo.DisplayName), providedMeth.TypeProviderDesignation, m) - error (tpe) + error tpe let valu = isStructTy g enclTy let isCtor = minfo.IsConstructor if minfo.IsClassConstructor then @@ -747,7 +742,7 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA elif isFunTy g enclTy then [ domainOfFunTy g enclTy; rangeOfFunTy g enclTy ] // provided expressions can call Invoke else minfo.DeclaringTypeInst let actualMethInst = minst - let retTy = (if not isCtor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprTy]) + let retTy = if not isCtor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprTy] let noTailCall = false let expr = Expr.Op(TOp.ILCall(useCallvirt,isProtected,valu,isNewObj,valUseFlags,isProp,noTailCall,ilMethRef,actualTypeInst,actualMethInst, retTy),[],allArgs,m) expr,exprTy @@ -1191,7 +1186,7 @@ module ProvidedMethodCalls = |> Array.map (fun pty -> eraseSystemType (amap,m,pty)) let paramVars = erasedParamTys - |> Array.mapi (fun i erasedParamTy -> erasedParamTy.PApply((fun ty -> ProvidedVar.Fresh("arg" + i.ToString(),ty)),m)) + |> Array.mapi (fun i erasedParamTy -> erasedParamTy.PApply((fun ty -> ProvidedVar.Fresh("arg" + i.ToString(),ty)),m)) // encode "this" as the first ParameterExpression, if applicable diff --git a/src/fsharp/MethodOverrides.fs b/src/fsharp/MethodOverrides.fs index fdaab28249..2ba55b7f75 100644 --- a/src/fsharp/MethodOverrides.fs +++ b/src/fsharp/MethodOverrides.fs @@ -709,7 +709,7 @@ let GetAbstractMethInfosForSynMethodDecl(infoReader:InfoReader,ad,memberName:Ide GetIntrinsicMethInfosOfType infoReader (Some(memberName.idText), ad, AllowMultiIntfInstantiations.Yes) IgnoreOverrides bindm ty let dispatchSlots = minfos |> List.filter (fun minfo -> minfo.IsDispatchSlot) let topValSynArities = SynInfo.AritiesOfArgs valSynData - let topValSynArities = if topValSynArities.Length > 0 then topValSynArities.Tail else topValSynArities + let topValSynArities = if List.isEmpty topValSynArities then topValSynArities else topValSynArities.Tail let dispatchSlotsArityMatch = dispatchSlots |> List.filter (fun minfo -> minfo.NumArgs = topValSynArities) dispatchSlots,dispatchSlotsArityMatch diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index dcbc1f074e..09aa6e3350 100644 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -568,7 +568,7 @@ let AddValRefToNameEnv nenv (vref:ValRef) = /// Add a set of active pattern result tags to the environment. let AddActivePatternResultTagsToNameEnv (apinfo: PrettyNaming.ActivePatternInfo) nenv ty m = - if apinfo.Names.Length = 0 then nenv else + if List.isEmpty apinfo.Names then nenv else let apresl = List.indexed apinfo.Names { nenv with eUnqualifiedItems = @@ -675,13 +675,13 @@ let private AddPartsOfTyconRefToNameEnv bulkAddMode ownDefinition (g:TcGlobals) | _ -> Item.UnqualifiedType [tcref])) else tab - if isILOrRequiredQualifiedAccess || ucrefs.Length = 0 then + if isILOrRequiredQualifiedAccess || List.isEmpty ucrefs then tab else AddUnionCases2 bulkAddMode tab ucrefs let ePatItems = - if isILOrRequiredQualifiedAccess || ucrefs.Length = 0 then + if isILOrRequiredQualifiedAccess || List.isEmpty ucrefs then nenv.ePatItems else AddUnionCases1 nenv.ePatItems ucrefs @@ -1100,14 +1100,9 @@ let ResolveProvidedTypeNameInEntity (amap, m, typeName, modref: ModuleOrNamespac | TProvidedNamespaceExtensionPoint(resolutionEnvironment,resolvers) -> match modref.Deref.PublicPath with | Some(PubPath path) -> - let matches = resolvers |> List.map (fun r-> ExtensionTyping.TryResolveProvidedType(r,m,path,typeName)) - let tcrefs = - [ for st in matches do - match st with - | None -> () - | Some st -> - yield AddEntityForProvidedType (amap, modref, resolutionEnvironment, st, m) ] - tcrefs + resolvers + |> List.choose (fun r-> ExtensionTyping.TryResolveProvidedType(r,m,path,typeName)) + |> List.map (fun st -> AddEntityForProvidedType (amap, modref, resolutionEnvironment, st, m)) | None -> [] // We have a provided type, look up its nested types (populating them on-demand if necessary) @@ -1335,12 +1330,18 @@ let (|ActivePatternCaseUse|_|) (item:Item) = | Item.ActivePatternResult(ap, _, idx,_) -> Some (ap.Range, ap.Range, idx) | _ -> None +let tyconRefDefnHash (_g: TcGlobals) (eref1:EntityRef) = + hash eref1.LogicalName + let tyconRefDefnEq g (eref1:EntityRef) (eref2: EntityRef) = tyconRefEq g eref1 eref2 // Signature items considered equal to implementation items || ((eref1.DefinitionRange = eref2.DefinitionRange || eref1.SigRange = eref2.SigRange) && (eref1.LogicalName = eref2.LogicalName)) +let valRefDefnHash (_g: TcGlobals) (vref1:ValRef)= + hash vref1.DisplayName + let valRefDefnEq g (vref1:ValRef) (vref2: ValRef) = valRefEq g vref1 vref2 // Signature items considered equal to implementation items @@ -1415,6 +1416,23 @@ let ItemsAreEffectivelyEqual g orig other = | _ -> false +/// Given the Item 'orig' - returns function 'other : Item -> bool', that will yield true if other and orig represents the same item and false - otherwise +let ItemsAreEffectivelyEqualHash (g: TcGlobals) orig = + match orig with + | EntityUse tcref -> tyconRefDefnHash g tcref + | Item.TypeVar (nm,_)-> hash nm + | ValUse vref -> valRefDefnHash g vref + | ActivePatternCaseUse (_, _, idx)-> hash idx + | MethodUse minfo -> minfo.ComputeHashCode() + | PropertyUse pinfo -> pinfo.ComputeHashCode() + | Item.ArgName (id,_, _) -> hash id.idText + | ILFieldUse ilfinfo -> ilfinfo.ComputeHashCode() + | UnionCaseUse ucase -> hash ucase.CaseName + | RecordFieldUse (name, _) -> hash name + | EventUse einfo -> einfo.ComputeHashCode() + | Item.ModuleOrNamespaces _ -> 100013 + | _ -> 389329 + [] type CapturedNameResolution(p:pos, i:Item, tpinst, io:ItemOccurence, de:DisplayEnv, nre:NameResolutionEnv, ad:AccessorDomain, m:range) = member this.Pos = p @@ -1452,23 +1470,25 @@ type TcSymbolUseData = Range: range } /// Represents container for all name resolutions that were met so far when typechecking some particular file +/// +/// This is a memory-critical data structure - allocations of this data structure and its immediate contents +/// is one of the highest memory long-lived data structures in typical uses of IDEs. Not many of these objects +/// are allocated (one per file), but they are large because the allUsesOfAllSymbols array is large. type TcSymbolUses(g, capturedNameResolutions : ResizeArray, formatSpecifierLocations: (range * int)[]) = // Make sure we only capture the information we really need to report symbol uses - let cnrs = [| for cnr in capturedNameResolutions -> { Item=cnr.Item; ItemOccurence=cnr.ItemOccurence; DisplayEnv=cnr.DisplayEnv; Range=cnr.Range } |] + let allUsesOfSymbols = [| for cnr in capturedNameResolutions -> { Item=cnr.Item; ItemOccurence=cnr.ItemOccurence; DisplayEnv=cnr.DisplayEnv; Range=cnr.Range } |] let capturedNameResolutions = () do ignore capturedNameResolutions // don't capture this! member this.GetUsesOfSymbol(item) = - [| for cnr in cnrs do - if protectAssemblyExploration false (fun () -> ItemsAreEffectivelyEqual g item cnr.Item) then - yield (cnr.ItemOccurence, cnr.DisplayEnv, cnr.Range) |] + [| for symbolUse in allUsesOfSymbols do + if protectAssemblyExploration false (fun () -> ItemsAreEffectivelyEqual g item symbolUse.Item) then + yield symbolUse |] - member this.GetAllUsesOfSymbols() = - [| for cnr in cnrs do - yield (cnr.Item, cnr.ItemOccurence, cnr.DisplayEnv, cnr.Range) |] + member this.AllUsesOfSymbols = allUsesOfSymbols - member this.GetFormatSpecifierLocationsAndArity() = formatSpecifierLocations + member this.GetFormatSpecifierLocationsAndArity() = formatSpecifierLocations /// An accumulator for the results being emitted into the tcSink. @@ -1500,7 +1520,7 @@ type TcResultsSinkImpl(g, ?source: string) = member this.GetSymbolUses() = TcSymbolUses(g, capturedNameResolutions, capturedFormatSpecifierLocations.ToArray()) - member this.OpenDeclarations = Seq.toList capturedOpenDeclarations + member this.GetOpenDeclarations() = capturedOpenDeclarations.ToArray() interface ITypecheckResultsSink with member sink.NotifyEnvWithScope(m,nenv,ad) = @@ -1725,14 +1745,14 @@ let CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities // no explicit type instantiation typeNameResInfo.StaticArgsInfo.HasNoStaticArgsInfo && // some type arguments required on all types (note sorted by typar count above) - tcref.Typars(m).Length > 0 && + not (List.isEmpty (tcref.Typars m)) && // plausible types have different arities (tcrefs |> Seq.distinctBy (fun (_,tcref) -> tcref.Typars(m).Length) |> Seq.length > 1) -> [ for (resInfo,tcref) in tcrefs do let resInfo = resInfo.AddWarning (fun _typarChecker -> errorR(Error(FSComp.SR.nrTypeInstantiationNeededToDisambiguateTypesWithSameName(tcref.DisplayName, tcref.DisplayNameWithStaticParametersAndUnderscoreTypars),m))) yield (resInfo,tcref) ] - | [(resInfo,tcref)] when typeNameResInfo.StaticArgsInfo.HasNoStaticArgsInfo && tcref.Typars(m).Length > 0 && typeNameResInfo.ResolutionFlag = ResolveTypeNamesToTypeRefs -> + | [(resInfo,tcref)] when typeNameResInfo.StaticArgsInfo.HasNoStaticArgsInfo && not (List.isEmpty (tcref.Typars m)) && typeNameResInfo.ResolutionFlag = ResolveTypeNamesToTypeRefs -> let resInfo = resInfo.AddWarning (fun (ResultTyparChecker typarChecker) -> if not (typarChecker()) then @@ -1758,17 +1778,14 @@ let CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities //------------------------------------------------------------------------- /// Perform name resolution for an identifier which must resolve to be a namespace or module. -let rec ResolveLongIndentAsModuleOrNamespace sink atMostOne amap m fullyQualified (nenv:NameResolutionEnv) ad (lid:Ident list) isOpenDecl = - match lid with - | [] -> NoResultsOrUsefulErrors - - | id :: rest when id.idText = MangledGlobalName -> - if isNil rest then +let rec ResolveLongIndentAsModuleOrNamespace sink atMostOne amap m first fullyQualified (nenv:NameResolutionEnv) ad (id:Ident) (rest:Ident list) isOpenDecl = + if first && id.idText = MangledGlobalName then + match rest with + | [] -> error (Error(FSComp.SR.nrGlobalUsedOnlyAsFirstName(), id.idRange)) - else - ResolveLongIndentAsModuleOrNamespace sink atMostOne amap m FullyQualified nenv ad rest isOpenDecl - - | id :: rest -> + | id2::rest2 -> + ResolveLongIndentAsModuleOrNamespace sink atMostOne amap m false FullyQualified nenv ad id2 rest2 isOpenDecl + else let moduleOrNamespaces = nenv.ModulesAndNamespaces fullyQualified let namespaceNotFound = lazy( let suggestModulesAndNamespaces() = @@ -1820,23 +1837,24 @@ let rec ResolveLongIndentAsModuleOrNamespace sink atMostOne amap m fullyQualifie modrefs |> CollectResults2 atMostOne (fun modref -> if IsEntityAccessible amap m ad modref then - notifyNameResolution modref id.idRange + notifyNameResolution modref id.idRange look 1 modref modref.ModuleOrNamespaceType rest else raze (namespaceNotFound.Force())) | None -> raze (namespaceNotFound.Force()) -let ResolveLongIndentAsModuleOrNamespaceThen sink atMostOne amap m fullyQualified (nenv:NameResolutionEnv) ad lid isOpenDecl f = - match lid with - | [] -> NoResultsOrUsefulErrors - | id :: rest -> - match ResolveLongIndentAsModuleOrNamespace sink ResultCollectionSettings.AllResults amap m fullyQualified nenv ad [id] isOpenDecl with - | Result modrefs -> - modrefs |> CollectResults2 atMostOne (fun (depth,modref,mty) -> - let resInfo = ResolutionInfo.Empty.AddEntity(id.idRange,modref) - f resInfo (depth+1) id.idRange modref mty rest) - | Exception err -> Exception err +let ResolveLongIndentAsModuleOrNamespaceThen sink atMostOne amap m fullyQualified (nenv:NameResolutionEnv) ad id rest isOpenDecl f = + match ResolveLongIndentAsModuleOrNamespace sink ResultCollectionSettings.AllResults amap m true fullyQualified nenv ad id [] isOpenDecl with + | Result modrefs -> + match rest with + | [] -> error(Error(FSComp.SR.nrUnexpectedEmptyLongId(),id.idRange)) + | id2::rest2 -> + modrefs + |> CollectResults2 atMostOne (fun (depth,modref,mty) -> + let resInfo = ResolutionInfo.Empty.AddEntity(id.idRange,modref) + f resInfo (depth+1) id.idRange modref mty id2 rest2) + | Exception err -> Exception err //------------------------------------------------------------------------- // Bind name used in "new Foo.Bar(...)" constructs @@ -2048,155 +2066,156 @@ let GetRecordLabelsForType g nenv typ = // REVIEW: this shows up on performance logs. Consider for example endless resolutions of "List.map" to // the empty set of results, or "x.Length" for a list or array type. This indicates it could be worth adding a cache here. -let rec ResolveLongIdentInTypePrim (ncenv:NameResolver) nenv lookupKind (resInfo:ResolutionInfo) depth m ad (lid:Ident list) findFlag (typeNameResInfo: TypeNameResolutionInfo) typ = +let rec ResolveLongIdentInTypePrim (ncenv:NameResolver) nenv lookupKind (resInfo:ResolutionInfo) depth m ad (id:Ident) (rest:Ident list) findFlag (typeNameResInfo: TypeNameResolutionInfo) typ = let g = ncenv.g - match lid with - | [] -> error(InternalError("ResolveLongIdentInTypePrim",m)) - | id :: rest -> - let m = unionRanges m id.idRange - let nm = id.idText // used to filter the searches of the tables - let optFilter = Some nm // used to filter the searches of the tables - let contentsSearchAccessible = - let unionCaseSearch = - match lookupKind with - | LookupKind.Expr | LookupKind.Pattern -> TryFindUnionCaseOfType g typ nm - | _ -> None - - // Lookup: datatype constructors take precedence - match unionCaseSearch with - | Some ucase -> - OneResult (success(resInfo,Item.UnionCase(ucase,false),rest)) - | None -> - let isLookUpExpr = lookupKind = LookupKind.Expr - match TryFindIntrinsicNamedItemOfType ncenv.InfoReader (nm,ad) findFlag m typ with - | Some (PropertyItem psets) when isLookUpExpr -> - let pinfos = psets |> ExcludeHiddenOfPropInfos g ncenv.amap m + let m = unionRanges m id.idRange + let nm = id.idText // used to filter the searches of the tables + let optFilter = Some nm // used to filter the searches of the tables + let contentsSearchAccessible = + let unionCaseSearch = + match lookupKind with + | LookupKind.Expr | LookupKind.Pattern -> TryFindUnionCaseOfType g typ nm + | _ -> None + + // Lookup: datatype constructors take precedence + match unionCaseSearch with + | Some ucase -> + OneResult (success(resInfo,Item.UnionCase(ucase,false),rest)) + | None -> + let isLookUpExpr = lookupKind = LookupKind.Expr + match TryFindIntrinsicNamedItemOfType ncenv.InfoReader (nm,ad) findFlag m typ with + | Some (PropertyItem psets) when isLookUpExpr -> + let pinfos = psets |> ExcludeHiddenOfPropInfos g ncenv.amap m - // fold the available extension members into the overload resolution - let extensionPropInfos = ExtensionPropInfosOfTypeInScope ncenv.InfoReader nenv (optFilter,ad) m typ + // fold the available extension members into the overload resolution + let extensionPropInfos = ExtensionPropInfosOfTypeInScope ncenv.InfoReader nenv (optFilter,ad) m typ - // make sure to keep the intrinsic pinfos before the extension pinfos in the list, - // since later on this logic is used when giving preference to intrinsic definitions - match DecodeFSharpEvent (pinfos@extensionPropInfos) ad g ncenv m with - | Some x -> success [resInfo, x, rest] - | None -> raze (UndefinedName (depth,FSComp.SR.undefinedNameFieldConstructorOrMember, id,NoSuggestions)) - | Some(MethodItem msets) when isLookUpExpr -> - let minfos = msets |> ExcludeHiddenOfMethInfos g ncenv.amap m + // make sure to keep the intrinsic pinfos before the extension pinfos in the list, + // since later on this logic is used when giving preference to intrinsic definitions + match DecodeFSharpEvent (pinfos@extensionPropInfos) ad g ncenv m with + | Some x -> success [resInfo, x, rest] + | None -> raze (UndefinedName (depth,FSComp.SR.undefinedNameFieldConstructorOrMember, id,NoSuggestions)) + | Some(MethodItem msets) when isLookUpExpr -> + let minfos = msets |> ExcludeHiddenOfMethInfos g ncenv.amap m - // fold the available extension members into the overload resolution - let extensionMethInfos = ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv optFilter m typ + // fold the available extension members into the overload resolution + let extensionMethInfos = ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv optFilter m typ - success [resInfo,Item.MakeMethGroup (nm,minfos@extensionMethInfos),rest] - | Some (ILFieldItem (finfo:: _)) when (match lookupKind with LookupKind.Expr | LookupKind.Pattern -> true | _ -> false) -> - success [resInfo,Item.ILField finfo,rest] + success [resInfo,Item.MakeMethGroup (nm,minfos@extensionMethInfos),rest] + | Some (ILFieldItem (finfo:: _)) when (match lookupKind with LookupKind.Expr | LookupKind.Pattern -> true | _ -> false) -> + success [resInfo,Item.ILField finfo,rest] - | Some (EventItem (einfo :: _)) when isLookUpExpr -> - success [resInfo,Item.Event einfo,rest] - | Some (RecdFieldItem (rfinfo)) when (match lookupKind with LookupKind.Expr | LookupKind.RecdField | LookupKind.Pattern -> true | _ -> false) -> - success [resInfo,Item.RecdField(rfinfo),rest] - | _ -> + | Some (EventItem (einfo :: _)) when isLookUpExpr -> + success [resInfo,Item.Event einfo,rest] + | Some (RecdFieldItem (rfinfo)) when (match lookupKind with LookupKind.Expr | LookupKind.RecdField | LookupKind.Pattern -> true | _ -> false) -> + success [resInfo,Item.RecdField(rfinfo),rest] + | _ -> - let pinfos = ExtensionPropInfosOfTypeInScope ncenv.InfoReader nenv (optFilter, ad) m typ - if not (isNil pinfos) && isLookUpExpr then OneResult(success (resInfo,Item.Property (nm,pinfos),rest)) else - let minfos = ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv optFilter m typ + let pinfos = ExtensionPropInfosOfTypeInScope ncenv.InfoReader nenv (optFilter, ad) m typ + if not (isNil pinfos) && isLookUpExpr then OneResult(success (resInfo,Item.Property (nm,pinfos),rest)) else + let minfos = ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv optFilter m typ - if not (isNil minfos) && isLookUpExpr then - success [resInfo,Item.MakeMethGroup (nm,minfos),rest] - elif isTyparTy g typ then raze (IndeterminateType(unionRanges m id.idRange)) - else NoResultsOrUsefulErrors + if not (isNil minfos) && isLookUpExpr then + success [resInfo,Item.MakeMethGroup (nm,minfos),rest] + elif isTyparTy g typ then raze (IndeterminateType(unionRanges m id.idRange)) + else NoResultsOrUsefulErrors - match contentsSearchAccessible with - | Result res when not (isNil res) -> contentsSearchAccessible - | Exception _ -> contentsSearchAccessible - | _ -> + match contentsSearchAccessible with + | Result res when not (isNil res) -> contentsSearchAccessible + | Exception _ -> contentsSearchAccessible + | _ -> - let nestedSearchAccessible = - let nestedTypes = GetNestedTypesOfType (ad, ncenv, Some nm, (if isNil rest then typeNameResInfo.StaticArgsInfo else TypeNameResolutionStaticArgsInfo.Indefinite), true, m) typ - if isNil rest then - if isNil nestedTypes then - NoResultsOrUsefulErrors - else - match typeNameResInfo.ResolutionFlag with - | ResolveTypeNamesToCtors -> - nestedTypes - |> CollectAtMostOneResult (ResolveObjectConstructorPrim ncenv nenv.eDisplayEnv resInfo m ad) - |> MapResults (fun (resInfo,item) -> (resInfo,item,[])) - | ResolveTypeNamesToTypeRefs -> - OneSuccess (resInfo,Item.Types (nm,nestedTypes),rest) + let nestedSearchAccessible = + match rest with + | [] -> + let nestedTypes = GetNestedTypesOfType (ad, ncenv, Some nm, typeNameResInfo.StaticArgsInfo, true, m) typ + if isNil nestedTypes then + NoResultsOrUsefulErrors else - ResolveLongIdentInNestedTypes ncenv nenv lookupKind resInfo (depth+1) id m ad rest findFlag typeNameResInfo nestedTypes - - match nestedSearchAccessible with - | Result res when not (isNil res) -> nestedSearchAccessible - | _ -> - let suggestMembers() = - let suggestions1 = - ExtensionPropInfosOfTypeInScope ncenv.InfoReader nenv (None, ad) m typ - |> List.map (fun p -> p.PropertyName) + match typeNameResInfo.ResolutionFlag with + | ResolveTypeNamesToCtors -> + nestedTypes + |> CollectAtMostOneResult (ResolveObjectConstructorPrim ncenv nenv.eDisplayEnv resInfo m ad) + |> MapResults (fun (resInfo,item) -> (resInfo,item,[])) + | ResolveTypeNamesToTypeRefs -> + OneSuccess (resInfo,Item.Types (nm,nestedTypes),rest) + | id2::rest2 -> + let nestedTypes = GetNestedTypesOfType (ad, ncenv, Some nm, TypeNameResolutionStaticArgsInfo.Indefinite, true, m) typ + ResolveLongIdentInNestedTypes ncenv nenv lookupKind resInfo (depth+1) id m ad id2 rest2 findFlag typeNameResInfo nestedTypes + + match nestedSearchAccessible with + | Result res when not (isNil res) -> nestedSearchAccessible + | _ -> + let suggestMembers() = + let suggestions1 = + ExtensionPropInfosOfTypeInScope ncenv.InfoReader nenv (None, ad) m typ + |> List.map (fun p -> p.PropertyName) - let suggestions2 = - ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv None m typ - |> List.map (fun m -> m.DisplayName) - - let suggestions3 = - GetIntrinsicPropInfosOfType ncenv.InfoReader (None, ad, AllowMultiIntfInstantiations.No) findFlag m typ - |> List.map (fun p -> p.PropertyName) - - let suggestions4 = - GetIntrinsicMethInfosOfType ncenv.InfoReader (None, ad, AllowMultiIntfInstantiations.No) findFlag m typ - |> List.filter (fun m -> not m.IsClassConstructor && not m.IsConstructor) - |> List.map (fun m -> m.DisplayName) - - let suggestions5 = GetRecordLabelsForType g nenv typ - - let suggestions6 = - match lookupKind with - | LookupKind.Expr | LookupKind.Pattern -> - if isAppTy g typ then - let tcref,_ = destAppTy g typ - tcref.UnionCasesArray - |> Array.map (fun uc -> uc.DisplayName) - else - [||] - | _ -> [||] + let suggestions2 = + ExtensionMethInfosOfTypeInScope ncenv.InfoReader nenv None m typ + |> List.map (fun m -> m.DisplayName) + + let suggestions3 = + GetIntrinsicPropInfosOfType ncenv.InfoReader (None, ad, AllowMultiIntfInstantiations.No) findFlag m typ + |> List.map (fun p -> p.PropertyName) + + let suggestions4 = + GetIntrinsicMethInfosOfType ncenv.InfoReader (None, ad, AllowMultiIntfInstantiations.No) findFlag m typ + |> List.filter (fun m -> not m.IsClassConstructor && not m.IsConstructor) + |> List.map (fun m -> m.DisplayName) + + let suggestions5 = GetRecordLabelsForType g nenv typ + + let suggestions6 = + match lookupKind with + | LookupKind.Expr | LookupKind.Pattern -> + if isAppTy g typ then + let tcref,_ = destAppTy g typ + tcref.UnionCasesArray + |> Array.map (fun uc -> uc.DisplayName) + else + [||] + | _ -> [||] - [ yield! suggestions1 - yield! suggestions2 - yield! suggestions3 - yield! suggestions4 - yield! suggestions5 - yield! suggestions6 ] - |> HashSet - - raze (UndefinedName (depth,FSComp.SR.undefinedNameFieldConstructorOrMember, id, suggestMembers)) + [ yield! suggestions1 + yield! suggestions2 + yield! suggestions3 + yield! suggestions4 + yield! suggestions5 + yield! suggestions6 ] + |> HashSet + + raze (UndefinedName (depth,FSComp.SR.undefinedNameFieldConstructorOrMember, id, suggestMembers)) -and ResolveLongIdentInNestedTypes (ncenv:NameResolver) nenv lookupKind resInfo depth id m ad lid findFlag typeNameResInfo typs = - typs |> CollectAtMostOneResult (fun typ -> +and ResolveLongIdentInNestedTypes (ncenv:NameResolver) nenv lookupKind resInfo depth id m ad (id2:Ident) (rest:Ident list) findFlag typeNameResInfo typs = + typs + |> CollectAtMostOneResult (fun typ -> let resInfo = if isAppTy ncenv.g typ then resInfo.AddEntity(id.idRange,tcrefOfAppTy ncenv.g typ) else resInfo - ResolveLongIdentInTypePrim ncenv nenv lookupKind resInfo depth m ad lid findFlag typeNameResInfo typ + ResolveLongIdentInTypePrim ncenv nenv lookupKind resInfo depth m ad id2 rest findFlag typeNameResInfo typ |> AtMostOneResult m) /// Resolve a long identifier using type-qualified name resolution. -let ResolveLongIdentInType sink ncenv nenv lookupKind m ad lid findFlag typeNameResInfo typ = - let resInfo,item,rest = - ResolveLongIdentInTypePrim (ncenv:NameResolver) nenv lookupKind ResolutionInfo.Empty 0 m ad lid findFlag typeNameResInfo typ +let ResolveLongIdentInType sink ncenv nenv lookupKind m ad id findFlag typeNameResInfo typ = + let resInfo,item,rest = + ResolveLongIdentInTypePrim (ncenv:NameResolver) nenv lookupKind ResolutionInfo.Empty 0 m ad id [] findFlag typeNameResInfo typ |> AtMostOneResult m |> ForceRaise + ResolutionInfo.SendEntityPathToSink (sink,ncenv,nenv,ItemOccurence.UseInType,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item)) item,rest -let private ResolveLongIdentInTyconRef (ncenv:NameResolver) nenv lookupKind resInfo depth m ad lid typeNameResInfo tcref = +let private ResolveLongIdentInTyconRef (ncenv:NameResolver) nenv lookupKind resInfo depth m ad id rest typeNameResInfo tcref = #if !NO_EXTENSIONTYPING // No dotting through type generators to get to a member! CheckForDirectReferenceToGeneratedType (tcref, PermitDirectReferenceToGeneratedType.No, m) #endif let typ = FreshenTycon ncenv m tcref - typ |> ResolveLongIdentInTypePrim ncenv nenv lookupKind resInfo depth m ad lid IgnoreOverrides typeNameResInfo + typ |> ResolveLongIdentInTypePrim ncenv nenv lookupKind resInfo depth m ad id rest IgnoreOverrides typeNameResInfo -let private ResolveLongIdentInTyconRefs atMostOne (ncenv:NameResolver) nenv lookupKind depth m ad lid typeNameResInfo idRange tcrefs = +let private ResolveLongIdentInTyconRefs atMostOne (ncenv:NameResolver) nenv lookupKind depth m ad id rest typeNameResInfo idRange tcrefs = tcrefs |> CollectResults2 atMostOne (fun (resInfo:ResolutionInfo,tcref) -> let resInfo = resInfo.AddEntity(idRange,tcref) - tcref |> ResolveLongIdentInTyconRef ncenv nenv lookupKind resInfo depth m ad lid typeNameResInfo |> AtMostOneResult m) + tcref |> ResolveLongIdentInTyconRef ncenv nenv lookupKind resInfo depth m ad id rest typeNameResInfo |> AtMostOneResult m) //------------------------------------------------------------------------- // ResolveExprLongIdentInModuleOrNamespace @@ -2206,116 +2225,115 @@ let (|AccessibleEntityRef|_|) amap m ad (modref: ModuleOrNamespaceRef) mspec = let eref = modref.NestedTyconRef mspec if IsEntityAccessible amap m ad eref then Some eref else None -let rec ResolveExprLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv (typeNameResInfo: TypeNameResolutionInfo) ad resInfo depth m modref (mty:ModuleOrNamespaceType) (lid :Ident list) = +let rec ResolveExprLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv (typeNameResInfo: TypeNameResolutionInfo) ad resInfo depth m modref (mty:ModuleOrNamespaceType) (id:Ident) (rest :Ident list) = // resInfo records the modules or namespaces actually relevant to a resolution - match lid with - | [] -> raze(Error(FSComp.SR.nrUnexpectedEmptyLongId(),m)) - | id :: rest -> - let m = unionRanges m id.idRange - match mty.AllValsByLogicalName.TryFind(id.idText) with - | Some vspec when IsValAccessible ad (mkNestedValRef modref vspec) -> - success(resInfo,Item.Value (mkNestedValRef modref vspec),rest) - | _-> - match mty.ExceptionDefinitionsByDemangledName.TryFind(id.idText) with - | Some excon when IsTyconReprAccessible ncenv.amap m ad (modref.NestedTyconRef excon) -> - success (resInfo,Item.ExnCase (modref.NestedTyconRef excon),rest) + let m = unionRanges m id.idRange + match mty.AllValsByLogicalName.TryFind(id.idText) with + | Some vspec when IsValAccessible ad (mkNestedValRef modref vspec) -> + success(resInfo,Item.Value (mkNestedValRef modref vspec),rest) + | _-> + match mty.ExceptionDefinitionsByDemangledName.TryFind(id.idText) with + | Some excon when IsTyconReprAccessible ncenv.amap m ad (modref.NestedTyconRef excon) -> + success (resInfo,Item.ExnCase (modref.NestedTyconRef excon),rest) + | _ -> + // Something in a discriminated union without RequireQualifiedAccess attribute? + let unionSearch,hasRequireQualifiedAccessAttribute = + match TryFindTypeWithUnionCase modref id with + | Some tycon when IsTyconReprAccessible ncenv.amap m ad (modref.NestedTyconRef tycon) -> + let ucref = mkUnionCaseRef (modref.NestedTyconRef tycon) id.idText + let ucinfo = FreshenUnionCaseRef ncenv m ucref + let hasRequireQualifiedAccessAttribute = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs + success [resInfo,Item.UnionCase(ucinfo,hasRequireQualifiedAccessAttribute),rest],hasRequireQualifiedAccessAttribute + | _ -> NoResultsOrUsefulErrors,false + + match unionSearch with + | Result (res :: _) when not hasRequireQualifiedAccessAttribute -> success res | _ -> - // Something in a discriminated union without RequireQualifiedAccess attribute? - let unionSearch,hasRequireQualifiedAccessAttribute = - match TryFindTypeWithUnionCase modref id with - | Some tycon when IsTyconReprAccessible ncenv.amap m ad (modref.NestedTyconRef tycon) -> - let ucref = mkUnionCaseRef (modref.NestedTyconRef tycon) id.idText - let ucinfo = FreshenUnionCaseRef ncenv m ucref - let hasRequireQualifiedAccessAttribute = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs - success [resInfo,Item.UnionCase(ucinfo,hasRequireQualifiedAccessAttribute),rest],hasRequireQualifiedAccessAttribute - | _ -> NoResultsOrUsefulErrors,false - - match unionSearch with - | Result (res :: _) when not hasRequireQualifiedAccessAttribute -> success res - | _ -> - // Something in a type? - let tyconSearch = - let tcrefs = LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, id.idRange, ad, id.idText, (if isNil rest then typeNameResInfo.StaticArgsInfo else TypeNameResolutionStaticArgsInfo.Indefinite), modref) - if isNil tcrefs then NoResultsOrUsefulErrors else - let tcrefs = tcrefs |> List.map (fun tcref -> (resInfo,tcref)) - if not (isNil rest) then - let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, TypeNameResolutionInfo (ResolveTypeNamesToTypeRefs,TypeNameResolutionStaticArgsInfo.Indefinite), PermitDirectReferenceToGeneratedType.No, unionRanges m id.idRange) - ResolveLongIdentInTyconRefs ResultCollectionSettings.AtMostOneResult ncenv nenv LookupKind.Expr (depth+1) m ad rest typeNameResInfo id.idRange tcrefs - // Check if we've got some explicit type arguments - else - let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, typeNameResInfo, PermitDirectReferenceToGeneratedType.No, unionRanges m id.idRange) - match typeNameResInfo.ResolutionFlag with - | ResolveTypeNamesToTypeRefs -> - success [ for (resInfo,tcref) in tcrefs do - let typ = FreshenTycon ncenv m tcref - let item = (resInfo,Item.Types(id.idText,[typ]),[]) - yield item ] - | ResolveTypeNamesToCtors -> - tcrefs - |> List.map (fun (resInfo, tcref) -> resInfo, FreshenTycon ncenv m tcref) - |> CollectAtMostOneResult (fun (resInfo,typ) -> ResolveObjectConstructorPrim ncenv nenv.eDisplayEnv resInfo id.idRange ad typ) - |> MapResults (fun (resInfo,item) -> (resInfo,item,[])) - - match tyconSearch with - | Result (res :: _) -> success res + // Something in a type? + let tyconSearch = + let tcrefs = LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, id.idRange, ad, id.idText, (if isNil rest then typeNameResInfo.StaticArgsInfo else TypeNameResolutionStaticArgsInfo.Indefinite), modref) + if isNil tcrefs then NoResultsOrUsefulErrors else + let tcrefs = tcrefs |> List.map (fun tcref -> (resInfo,tcref)) + match rest with + | id2::rest2 -> + let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, TypeNameResolutionInfo (ResolveTypeNamesToTypeRefs,TypeNameResolutionStaticArgsInfo.Indefinite), PermitDirectReferenceToGeneratedType.No, unionRanges m id.idRange) + ResolveLongIdentInTyconRefs ResultCollectionSettings.AtMostOneResult ncenv nenv LookupKind.Expr (depth+1) m ad id2 rest2 typeNameResInfo id.idRange tcrefs + // Check if we've got some explicit type arguments | _ -> + let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, typeNameResInfo, PermitDirectReferenceToGeneratedType.No, unionRanges m id.idRange) + match typeNameResInfo.ResolutionFlag with + | ResolveTypeNamesToTypeRefs -> + success [ for (resInfo,tcref) in tcrefs do + let typ = FreshenTycon ncenv m tcref + let item = (resInfo,Item.Types(id.idText,[typ]),[]) + yield item ] + | ResolveTypeNamesToCtors -> + tcrefs + |> List.map (fun (resInfo, tcref) -> resInfo, FreshenTycon ncenv m tcref) + |> CollectAtMostOneResult (fun (resInfo,typ) -> ResolveObjectConstructorPrim ncenv nenv.eDisplayEnv resInfo id.idRange ad typ) + |> MapResults (fun (resInfo,item) -> (resInfo,item,[])) - // Something in a sub-namespace or sub-module - let moduleSearch = - if not (isNil rest) then - match mty.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with - | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) -> - let resInfo = resInfo.AddEntity(id.idRange,submodref) + match tyconSearch with + | Result (res :: _) -> success res + | _ -> - OneResult (ResolveExprLongIdentInModuleOrNamespace ncenv nenv typeNameResInfo ad resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType rest) - | _ -> - NoResultsOrUsefulErrors - else + // Something in a sub-namespace or sub-module + let moduleSearch = + match rest with + | id2::rest2 -> + match mty.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with + | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) -> + let resInfo = resInfo.AddEntity(id.idRange,submodref) + + OneResult (ResolveExprLongIdentInModuleOrNamespace ncenv nenv typeNameResInfo ad resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType id2 rest2) + | _ -> NoResultsOrUsefulErrors + | _ -> + NoResultsOrUsefulErrors + + match tyconSearch +++ moduleSearch +++ unionSearch with + | Result [] -> + let suggestPossibleTypesAndNames() = + let types = + modref.ModuleOrNamespaceType.AllEntities + |> Seq.filter (fun e -> IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef e)) + |> Seq.map (fun e -> e.DisplayName) - match tyconSearch +++ moduleSearch +++ unionSearch with - | Result [] -> - let suggestPossibleTypesAndNames() = - let types = - modref.ModuleOrNamespaceType.AllEntities - |> Seq.filter (fun e -> IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef e)) - |> Seq.map (fun e -> e.DisplayName) - - let submodules = - mty.ModulesAndNamespacesByDemangledName - |> Seq.filter (fun kv -> IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef kv.Value)) - |> Seq.map (fun e -> e.Value.DisplayName) + let submodules = + mty.ModulesAndNamespacesByDemangledName + |> Seq.filter (fun kv -> IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef kv.Value)) + |> Seq.map (fun e -> e.Value.DisplayName) - let unions = - modref.ModuleOrNamespaceType.AllEntities - |> Seq.collect (fun tycon -> - let hasRequireQualifiedAccessAttribute = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs - if hasRequireQualifiedAccessAttribute then - [||] - else - tycon.UnionCasesArray) - |> Seq.map (fun uc -> uc.DisplayName) - - let vals = - modref.ModuleOrNamespaceType.AllValsByLogicalName - |> Seq.filter (fun e -> IsValAccessible ad (mkNestedValRef modref e.Value)) - |> Seq.map (fun e -> e.Value.DisplayName) + let unions = + modref.ModuleOrNamespaceType.AllEntities + |> Seq.collect (fun tycon -> + let hasRequireQualifiedAccessAttribute = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs + if hasRequireQualifiedAccessAttribute then + [||] + else + tycon.UnionCasesArray) + |> Seq.map (fun uc -> uc.DisplayName) + + let vals = + modref.ModuleOrNamespaceType.AllValsByLogicalName + |> Seq.filter (fun e -> IsValAccessible ad (mkNestedValRef modref e.Value)) + |> Seq.map (fun e -> e.Value.DisplayName) - let exns = - modref.ModuleOrNamespaceType.ExceptionDefinitionsByDemangledName - |> Seq.filter (fun e -> IsTyconReprAccessible ncenv.amap m ad (modref.NestedTyconRef e.Value)) - |> Seq.map (fun e -> e.Value.DisplayName) + let exns = + modref.ModuleOrNamespaceType.ExceptionDefinitionsByDemangledName + |> Seq.filter (fun e -> IsTyconReprAccessible ncenv.amap m ad (modref.NestedTyconRef e.Value)) + |> Seq.map (fun e -> e.Value.DisplayName) - [ yield! types - yield! submodules - yield! unions - yield! vals - yield! exns ] - |> HashSet + [ yield! types + yield! submodules + yield! unions + yield! vals + yield! exns ] + |> HashSet - raze (UndefinedName(depth,FSComp.SR.undefinedNameValueConstructorNamespaceOrType,id,suggestPossibleTypesAndNames)) - | results -> AtMostOneResult id.idRange results + raze (UndefinedName(depth,FSComp.SR.undefinedNameValueConstructorNamespaceOrType,id,suggestPossibleTypesAndNames)) + | results -> AtMostOneResult id.idRange results /// An identifier has resolved to a type name in an expression (corresponding to one or more TyconRefs). /// Return either a set of constructors (later refined by overload resolution), or a set of TyconRefs. @@ -2335,328 +2353,328 @@ let ChooseTyconRefInExpr (ncenv:NameResolver, m, ad, nenv, id:Ident, typeNameRes /// Resolve F# "A.B.C" syntax in expressions /// Not all of the sequence will necessarily be swallowed, i.e. we return some identifiers /// that may represent further actions, e.g. further lookups. -let rec ResolveExprLongIdentPrim sink (ncenv:NameResolver) fullyQualified m ad nenv (typeNameResInfo:TypeNameResolutionInfo) lid isOpenDecl = +let rec ResolveExprLongIdentPrim sink (ncenv:NameResolver) first fullyQualified m ad nenv (typeNameResInfo:TypeNameResolutionInfo) (id:Ident) (rest:Ident list) isOpenDecl = let resInfo = ResolutionInfo.Empty - match lid with - | [] -> error (Error(FSComp.SR.nrInvalidExpression(textOfLid lid), m)) - - | [id] when id.idText = MangledGlobalName -> - error (Error(FSComp.SR.nrGlobalUsedOnlyAsFirstName(), id.idRange)) - - | [id;next] when id.idText = MangledGlobalName -> - ResolveExprLongIdentPrim sink ncenv fullyQualified m ad nenv typeNameResInfo [next] isOpenDecl - - | id :: lid when id.idText = MangledGlobalName -> - ResolveExprLongIdentPrim sink ncenv FullyQualified m ad nenv typeNameResInfo lid isOpenDecl - - | [id] when fullyQualified <> FullyQualified -> - let typeError = ref None - // Single identifier. Lookup the unqualified names in the environment - let envSearch = - match nenv.eUnqualifiedItems.TryFind(id.idText) with - - // The name is a type name and it has not been clobbered by some other name - | Some (Item.UnqualifiedType tcrefs) -> + if first && id.idText = MangledGlobalName then + match rest with + | [] -> + error (Error(FSComp.SR.nrGlobalUsedOnlyAsFirstName(), id.idRange)) + | [next] -> + ResolveExprLongIdentPrim sink ncenv false fullyQualified m ad nenv typeNameResInfo next [] isOpenDecl + | id2::rest2 -> + ResolveExprLongIdentPrim sink ncenv false FullyQualified m ad nenv typeNameResInfo id2 rest2 isOpenDecl + else + if isNil rest && fullyQualified <> FullyQualified then + let typeError = ref None + // Single identifier. Lookup the unqualified names in the environment + let envSearch = + match nenv.eUnqualifiedItems.TryFind(id.idText) with + + // The name is a type name and it has not been clobbered by some other name + | Some (Item.UnqualifiedType tcrefs) -> - // Do not use type names from the environment if an explicit type instantiation is - // given and the number of type parameters do not match - let tcrefs = - tcrefs |> List.filter (fun tcref -> - typeNameResInfo.StaticArgsInfo.HasNoStaticArgsInfo || - typeNameResInfo.StaticArgsInfo.NumStaticArgs = tcref.Typars(m).Length) + // Do not use type names from the environment if an explicit type instantiation is + // given and the number of type parameters do not match + let tcrefs = + tcrefs |> List.filter (fun tcref -> + typeNameResInfo.StaticArgsInfo.HasNoStaticArgsInfo || + typeNameResInfo.StaticArgsInfo.NumStaticArgs = tcref.Typars(m).Length) - let search = ChooseTyconRefInExpr (ncenv, m, ad, nenv, id, typeNameResInfo, resInfo, tcrefs) - match AtMostOneResult m search with - | Result _ as res -> - let resInfo,item,rest = ForceRaise res - ResolutionInfo.SendEntityPathToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item)) - Some(item,rest) - | Exception e -> typeError := Some e; None - - | Some res -> - Some (FreshenUnqualifiedItem ncenv m res, []) - | None -> - None - - match envSearch with - | Some res -> res - | None -> - let innerSearch = - // Check if it's a type name, e.g. a constructor call or a type instantiation - let ctorSearch = - let tcrefs = LookupTypeNameInEnvMaybeHaveArity fullyQualified id.idText typeNameResInfo nenv - ChooseTyconRefInExpr (ncenv, m, ad, nenv, id, typeNameResInfo, resInfo, tcrefs) - - match ctorSearch with - | Result res when not (isNil res) -> ctorSearch - | _ -> - - let implicitOpSearch = - if IsMangledOpName id.idText then - success [(resInfo,Item.ImplicitOp(id, ref None),[])] - else - NoResultsOrUsefulErrors + let search = ChooseTyconRefInExpr (ncenv, m, ad, nenv, id, typeNameResInfo, resInfo, tcrefs) + match AtMostOneResult m search with + | Result _ as res -> + let resInfo,item,rest = ForceRaise res + ResolutionInfo.SendEntityPathToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item)) + Some(item,rest) + | Exception e -> typeError := Some e; None + + | Some res -> + Some (FreshenUnqualifiedItem ncenv m res, []) + | None -> + None - ctorSearch +++ implicitOpSearch + match envSearch with + | Some res -> res + | None -> + let innerSearch = + // Check if it's a type name, e.g. a constructor call or a type instantiation + let ctorSearch = + let tcrefs = LookupTypeNameInEnvMaybeHaveArity fullyQualified id.idText typeNameResInfo nenv + ChooseTyconRefInExpr (ncenv, m, ad, nenv, id, typeNameResInfo, resInfo, tcrefs) + + match ctorSearch with + | Result res when not (isNil res) -> ctorSearch + | _ -> - let resInfo,item,rest = - match AtMostOneResult m innerSearch with - | Result _ as res -> ForceRaise res - | _ -> - let failingCase = - match !typeError with - | Some e -> raze e - | _ -> - let suggestNamesAndTypes() = - let suggestedNames = - nenv.eUnqualifiedItems - |> Seq.map (fun e -> e.Value.DisplayName) - - let suggestedTypes = - nenv.TyconsByDemangledNameAndArity fullyQualified - |> Seq.filter (fun e -> IsEntityAccessible ncenv.amap m ad e.Value) - |> Seq.map (fun e -> e.Value.DisplayName) - - let suggestedModulesAndNamespaces = - nenv.ModulesAndNamespaces fullyQualified - |> Seq.collect (fun kv -> kv.Value) - |> Seq.filter (fun modref -> IsEntityAccessible ncenv.amap m ad modref) - |> Seq.collect (fun e -> [e.DisplayName; e.DemangledModuleOrNamespaceName]) - - let unions = - // check if the user forgot to use qualified access - nenv.eTyconsByDemangledNameAndArity - |> Seq.choose (fun e -> - let hasRequireQualifiedAccessAttribute = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute e.Value.Attribs - if not hasRequireQualifiedAccessAttribute then - None - else - if e.Value.IsUnionTycon && e.Value.UnionCasesArray |> Array.exists (fun c -> c.DisplayName = id.idText) then - Some e.Value - else - None) - |> Seq.map (fun t -> t.DisplayName + "." + id.idText) + let implicitOpSearch = + if IsMangledOpName id.idText then + success [(resInfo,Item.ImplicitOp(id, ref None),[])] + else + NoResultsOrUsefulErrors + + ctorSearch +++ implicitOpSearch + + let resInfo,item,rest = + match AtMostOneResult m innerSearch with + | Result _ as res -> ForceRaise res + | _ -> + let failingCase = + match !typeError with + | Some e -> raze e + | _ -> + let suggestNamesAndTypes() = + let suggestedNames = + nenv.eUnqualifiedItems + |> Seq.map (fun e -> e.Value.DisplayName) + + let suggestedTypes = + nenv.TyconsByDemangledNameAndArity fullyQualified + |> Seq.filter (fun e -> IsEntityAccessible ncenv.amap m ad e.Value) + |> Seq.map (fun e -> e.Value.DisplayName) + + let suggestedModulesAndNamespaces = + nenv.ModulesAndNamespaces fullyQualified + |> Seq.collect (fun kv -> kv.Value) + |> Seq.filter (fun modref -> IsEntityAccessible ncenv.amap m ad modref) + |> Seq.collect (fun e -> [e.DisplayName; e.DemangledModuleOrNamespaceName]) + + let unions = + // check if the user forgot to use qualified access + nenv.eTyconsByDemangledNameAndArity + |> Seq.choose (fun e -> + let hasRequireQualifiedAccessAttribute = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute e.Value.Attribs + if not hasRequireQualifiedAccessAttribute then + None + else + if e.Value.IsUnionTycon && e.Value.UnionCasesArray |> Array.exists (fun c -> c.DisplayName = id.idText) then + Some e.Value + else + None) + |> Seq.map (fun t -> t.DisplayName + "." + id.idText) - [ yield! suggestedNames - yield! suggestedTypes - yield! suggestedModulesAndNamespaces - yield! unions ] - |> HashSet + [ yield! suggestedNames + yield! suggestedTypes + yield! suggestedModulesAndNamespaces + yield! unions ] + |> HashSet - raze (UndefinedName(0,FSComp.SR.undefinedNameValueOfConstructor,id,suggestNamesAndTypes)) - ForceRaise failingCase + raze (UndefinedName(0,FSComp.SR.undefinedNameValueOfConstructor,id,suggestNamesAndTypes)) + ForceRaise failingCase - ResolutionInfo.SendEntityPathToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item)) - item,rest + ResolutionInfo.SendEntityPathToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item)) + item,rest - // A compound identifier. - // It still might be a value in the environment, or something in an F# module, namespace, type, or nested type - | id :: rest -> - - let m = unionRanges m id.idRange - // Values in the environment take total priority, but constructors do NOT for compound lookups, e.g. if someone in some imported - // module has defined a constructor "String" (common enough) then "String.foo" doesn't give an error saying 'constructors have no members' - // Instead we go lookup the String module or type. - let ValIsInEnv nm = - match fullyQualified with - | FullyQualified -> false - | _ -> - match nenv.eUnqualifiedItems.TryFind(nm) with - | Some(Item.Value _) -> true - | _ -> false + // A compound identifier. + // It still might be a value in the environment, or something in an F# module, namespace, type, or nested type + else + let m = unionRanges m id.idRange + // Values in the environment take total priority, but constructors do NOT for compound lookups, e.g. if someone in some imported + // module has defined a constructor "String" (common enough) then "String.foo" doesn't give an error saying 'constructors have no members' + // Instead we go lookup the String module or type. + let ValIsInEnv nm = + match fullyQualified with + | FullyQualified -> false + | _ -> + match nenv.eUnqualifiedItems.TryFind(nm) with + | Some(Item.Value _) -> true + | _ -> false - if ValIsInEnv id.idText then - nenv.eUnqualifiedItems.[id.idText], rest - else - // Otherwise modules are searched first. REVIEW: modules and types should be searched together. - // For each module referenced by 'id', search the module as if it were an F# module and/or a .NET namespace. - let moduleSearch ad = - ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AtMostOneResult ncenv.amap m fullyQualified nenv ad lid isOpenDecl - (ResolveExprLongIdentInModuleOrNamespace ncenv nenv typeNameResInfo ad) - - // REVIEW: somewhat surprisingly, this shows up on performance traces, with tcrefs non-nil. - // This seems strange since we would expect in the vast majority of cases tcrefs is empty here. - let tyconSearch ad = - let tcrefs = LookupTypeNameInEnvNoArity fullyQualified id.idText nenv - if isNil tcrefs then NoResultsOrUsefulErrors else - let tcrefs = tcrefs |> List.map (fun tcref -> (resInfo,tcref)) - let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, TypeNameResolutionInfo.ResolveToTypeRefs (TypeNameResolutionStaticArgsInfo.Indefinite), PermitDirectReferenceToGeneratedType.No, unionRanges m id.idRange) - ResolveLongIdentInTyconRefs ResultCollectionSettings.AtMostOneResult ncenv nenv LookupKind.Expr 1 m ad rest typeNameResInfo id.idRange tcrefs - - let search = - let moduleSearch = moduleSearch ad + if ValIsInEnv id.idText then + nenv.eUnqualifiedItems.[id.idText], rest + else + // Otherwise modules are searched first. REVIEW: modules and types should be searched together. + // For each module referenced by 'id', search the module as if it were an F# module and/or a .NET namespace. + let moduleSearch ad = + ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AtMostOneResult ncenv.amap m fullyQualified nenv ad id rest isOpenDecl + (ResolveExprLongIdentInModuleOrNamespace ncenv nenv typeNameResInfo ad) + + // REVIEW: somewhat surprisingly, this shows up on performance traces, with tcrefs non-nil. + // This seems strange since we would expect in the vast majority of cases tcrefs is empty here. + let tyconSearch ad = + let tcrefs = LookupTypeNameInEnvNoArity fullyQualified id.idText nenv + if isNil tcrefs then NoResultsOrUsefulErrors else + match rest with + | id2::rest2 -> + let tcrefs = tcrefs |> List.map (fun tcref -> (resInfo,tcref)) + let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, TypeNameResolutionInfo.ResolveToTypeRefs (TypeNameResolutionStaticArgsInfo.Indefinite), PermitDirectReferenceToGeneratedType.No, unionRanges m id.idRange) + ResolveLongIdentInTyconRefs ResultCollectionSettings.AtMostOneResult ncenv nenv LookupKind.Expr 1 m ad id2 rest2 typeNameResInfo id.idRange tcrefs + | _ -> + NoResultsOrUsefulErrors + + let search = + let moduleSearch = moduleSearch ad - match moduleSearch with - | Result res when not (isNil res) -> moduleSearch - | _ -> - - let tyconSearch = tyconSearch ad - - match tyconSearch with - | Result res when not (isNil res) -> tyconSearch - | _ -> - - let envSearch = - match fullyQualified with - | FullyQualified -> - NoResultsOrUsefulErrors - | OpenQualified -> - match nenv.eUnqualifiedItems.TryFind id.idText with - | Some (Item.UnqualifiedType _) - | None -> NoResultsOrUsefulErrors - | Some res -> OneSuccess (resInfo,FreshenUnqualifiedItem ncenv m res,rest) - - moduleSearch +++ tyconSearch +++ envSearch - - let resInfo,item,rest = - match AtMostOneResult m search with - | Result _ as res -> ForceRaise res - | _ -> - let innerSearch = - let moduleSearch = moduleSearch AccessibleFromSomeFSharpCode + match moduleSearch with + | Result res when not (isNil res) -> moduleSearch + | _ -> + + let tyconSearch = tyconSearch ad + + match tyconSearch with + | Result res when not (isNil res) -> tyconSearch + | _ -> + + let envSearch = + match fullyQualified with + | FullyQualified -> + NoResultsOrUsefulErrors + | OpenQualified -> + match nenv.eUnqualifiedItems.TryFind id.idText with + | Some (Item.UnqualifiedType _) + | None -> NoResultsOrUsefulErrors + | Some res -> OneSuccess (resInfo,FreshenUnqualifiedItem ncenv m res,rest) + + moduleSearch +++ tyconSearch +++ envSearch + + let resInfo,item,rest = + match AtMostOneResult m search with + | Result _ as res -> ForceRaise res + | _ -> + let innerSearch = + let moduleSearch = moduleSearch AccessibleFromSomeFSharpCode - match moduleSearch with - | Result res when not (isNil res) -> moduleSearch - | _ -> + match moduleSearch with + | Result res when not (isNil res) -> moduleSearch + | _ -> - let tyconSearch = tyconSearch AccessibleFromSomeFSharpCode + let tyconSearch = tyconSearch AccessibleFromSomeFSharpCode - match tyconSearch with - | Result res when not (isNil res) -> tyconSearch - | _ -> + match tyconSearch with + | Result res when not (isNil res) -> tyconSearch + | _ -> - search +++ moduleSearch +++ tyconSearch + search +++ moduleSearch +++ tyconSearch - let suggestEverythingInScope() = - seq { yield! - nenv.ModulesAndNamespaces fullyQualified - |> Seq.collect (fun kv -> kv.Value) - |> Seq.filter (fun modref -> IsEntityAccessible ncenv.amap m ad modref) - |> Seq.collect (fun e -> [e.DisplayName; e.DemangledModuleOrNamespaceName]) + let suggestEverythingInScope() = + seq { yield! + nenv.ModulesAndNamespaces fullyQualified + |> Seq.collect (fun kv -> kv.Value) + |> Seq.filter (fun modref -> IsEntityAccessible ncenv.amap m ad modref) + |> Seq.collect (fun e -> [e.DisplayName; e.DemangledModuleOrNamespaceName]) - yield! - nenv.TyconsByDemangledNameAndArity fullyQualified - |> Seq.filter (fun e -> IsEntityAccessible ncenv.amap m ad e.Value) - |> Seq.map (fun e -> e.Value.DisplayName) - - yield! - nenv.eUnqualifiedItems - |> Seq.map (fun e -> e.Value.DisplayName) - } |> HashSet - - match innerSearch with - | Exception (UndefinedName(0,_,id1,suggestionsF)) when id.idRange = id1.idRange -> - let mergeSuggestions() = - let res = suggestEverythingInScope() - res.UnionWith(suggestionsF()) - res - - let failingCase = raze (UndefinedName(0,FSComp.SR.undefinedNameValueNamespaceTypeOrModule,id,mergeSuggestions)) - ForceRaise failingCase - | Exception err -> ForceRaise(Exception err) - | Result (res :: _) -> ForceRaise(Result res) - | Result [] -> - let failingCase = raze (UndefinedName(0,FSComp.SR.undefinedNameValueNamespaceTypeOrModule,id,suggestEverythingInScope)) - ForceRaise failingCase + yield! + nenv.TyconsByDemangledNameAndArity fullyQualified + |> Seq.filter (fun e -> IsEntityAccessible ncenv.amap m ad e.Value) + |> Seq.map (fun e -> e.Value.DisplayName) + + yield! + nenv.eUnqualifiedItems + |> Seq.map (fun e -> e.Value.DisplayName) + } |> HashSet + + match innerSearch with + | Exception (UndefinedName(0,_,id1,suggestionsF)) when id.idRange = id1.idRange -> + let mergeSuggestions() = + let res = suggestEverythingInScope() + res.UnionWith(suggestionsF()) + res + + let failingCase = raze (UndefinedName(0,FSComp.SR.undefinedNameValueNamespaceTypeOrModule,id,mergeSuggestions)) + ForceRaise failingCase + | Exception err -> ForceRaise(Exception err) + | Result (res :: _) -> ForceRaise(Result res) + | Result [] -> + let failingCase = raze (UndefinedName(0,FSComp.SR.undefinedNameValueNamespaceTypeOrModule,id,suggestEverythingInScope)) + ForceRaise failingCase - ResolutionInfo.SendEntityPathToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item)) - item,rest + ResolutionInfo.SendEntityPathToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item)) + item,rest let ResolveExprLongIdent sink (ncenv:NameResolver) m ad nenv typeNameResInfo lid = - ResolveExprLongIdentPrim sink ncenv OpenQualified m ad nenv typeNameResInfo lid false + match lid with + | [] -> error (Error(FSComp.SR.nrInvalidExpression(textOfLid lid), m)) + | id::rest -> ResolveExprLongIdentPrim sink ncenv true OpenQualified m ad nenv typeNameResInfo id rest false //------------------------------------------------------------------------- // Resolve F#/IL "." syntax in patterns //------------------------------------------------------------------------- -let rec ResolvePatternLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv numTyArgsOpt ad resInfo depth m modref (mty:ModuleOrNamespaceType) (lid: Ident list) = - match lid with - | [] -> raze (InternalError("ResolvePatternLongIdentInModuleOrNamespace",m)) - | id :: rest -> - let m = unionRanges m id.idRange - match TryFindTypeWithUnionCase modref id with - | Some tycon when IsTyconReprAccessible ncenv.amap m ad (modref.NestedTyconRef tycon) -> - let tcref = modref.NestedTyconRef tycon - let ucref = mkUnionCaseRef tcref id.idText - let showDeprecated = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs - let ucinfo = FreshenUnionCaseRef ncenv m ucref - success (resInfo,Item.UnionCase(ucinfo,showDeprecated),rest) - | _ -> - match mty.ExceptionDefinitionsByDemangledName.TryFind(id.idText) with - | Some exnc when IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef exnc) -> - success (resInfo,Item.ExnCase (modref.NestedTyconRef exnc),rest) - | _ -> - // An active pattern constructor in a module - match (ActivePatternElemsOfModuleOrNamespace modref).TryFind(id.idText) with - | Some ( APElemRef(_,vref,_) as apref) when IsValAccessible ad vref -> - success (resInfo,Item.ActivePatternCase apref,rest) - | _ -> - match mty.AllValsByLogicalName.TryFind(id.idText) with - | Some vspec when IsValAccessible ad (mkNestedValRef modref vspec) -> - success(resInfo,Item.Value (mkNestedValRef modref vspec),rest) +let rec ResolvePatternLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv numTyArgsOpt ad resInfo depth m modref (mty:ModuleOrNamespaceType) (id:Ident) (rest: Ident list) = + let m = unionRanges m id.idRange + match TryFindTypeWithUnionCase modref id with + | Some tycon when IsTyconReprAccessible ncenv.amap m ad (modref.NestedTyconRef tycon) -> + let tcref = modref.NestedTyconRef tycon + let ucref = mkUnionCaseRef tcref id.idText + let showDeprecated = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs + let ucinfo = FreshenUnionCaseRef ncenv m ucref + success (resInfo,Item.UnionCase(ucinfo,showDeprecated),rest) + | _ -> + match mty.ExceptionDefinitionsByDemangledName.TryFind(id.idText) with + | Some exnc when IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef exnc) -> + success (resInfo,Item.ExnCase (modref.NestedTyconRef exnc),rest) + | _ -> + // An active pattern constructor in a module + match (ActivePatternElemsOfModuleOrNamespace modref).TryFind(id.idText) with + | Some ( APElemRef(_,vref,_) as apref) when IsValAccessible ad vref -> + success (resInfo,Item.ActivePatternCase apref,rest) + | _ -> + match mty.AllValsByLogicalName.TryFind(id.idText) with + | Some vspec when IsValAccessible ad (mkNestedValRef modref vspec) -> + success(resInfo,Item.Value (mkNestedValRef modref vspec),rest) + | _ -> + let tcrefs = lazy ( + LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, id.idRange, ad, id.idText, TypeNameResolutionStaticArgsInfo.Indefinite, modref) + |> List.map (fun tcref -> (resInfo,tcref))) + + // Something in a type? e.g. a literal field + let tyconSearch = + match rest with + | id2::rest2 -> + let tcrefs = tcrefs.Force() + ResolveLongIdentInTyconRefs ResultCollectionSettings.AtMostOneResult (ncenv:NameResolver) nenv LookupKind.Pattern (depth+1) m ad id2 rest2 numTyArgsOpt id.idRange tcrefs | _ -> - let tcrefs = lazy ( - LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, id.idRange, ad, id.idText, TypeNameResolutionStaticArgsInfo.Indefinite, modref) - |> List.map (fun tcref -> (resInfo,tcref))) + NoResultsOrUsefulErrors - // Something in a type? e.g. a literal field - let tyconSearch = - match lid with - | _ :: rest when not (isNil rest) -> - let tcrefs = tcrefs.Force() - ResolveLongIdentInTyconRefs ResultCollectionSettings.AtMostOneResult (ncenv:NameResolver) nenv LookupKind.Pattern (depth+1) m ad rest numTyArgsOpt id.idRange tcrefs - | _ -> - NoResultsOrUsefulErrors - - match tyconSearch with - | Result (res :: _) -> success res - | _ -> - - // Constructor of a type? - let ctorSearch = - if isNil rest then - tcrefs.Force() - |> List.map (fun (resInfo,tcref) -> (resInfo,FreshenTycon ncenv m tcref)) - |> CollectAtMostOneResult (fun (resInfo,typ) -> ResolveObjectConstructorPrim ncenv nenv.eDisplayEnv resInfo id.idRange ad typ) - |> MapResults (fun (resInfo,item) -> (resInfo,item,[])) - else - NoResultsOrUsefulErrors + match tyconSearch with + | Result (res :: _) -> success res + | _ -> - match ctorSearch with - | Result (res :: _) -> success res - | _ -> + // Constructor of a type? + let ctorSearch = + if isNil rest then + tcrefs.Force() + |> List.map (fun (resInfo,tcref) -> (resInfo,FreshenTycon ncenv m tcref)) + |> CollectAtMostOneResult (fun (resInfo,typ) -> ResolveObjectConstructorPrim ncenv nenv.eDisplayEnv resInfo id.idRange ad typ) + |> MapResults (fun (resInfo,item) -> (resInfo,item,[])) + else + NoResultsOrUsefulErrors - // Something in a sub-namespace or sub-module or nested-type - let moduleSearch = - if not (isNil rest) then - match mty.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with - | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) -> - let resInfo = resInfo.AddEntity(id.idRange,submodref) - OneResult (ResolvePatternLongIdentInModuleOrNamespace ncenv nenv numTyArgsOpt ad resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType rest) - | _ -> - NoResultsOrUsefulErrors - else NoResultsOrUsefulErrors + match ctorSearch with + | Result (res :: _) -> success res + | _ -> - match tyconSearch +++ ctorSearch +++ moduleSearch with - | Result [] -> - let suggestPossibleTypes() = - let submodules = - mty.ModulesAndNamespacesByDemangledName - |> Seq.filter (fun kv -> IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef kv.Value)) - |> Seq.collect (fun e -> [e.Value.DisplayName; e.Value.DemangledModuleOrNamespaceName]) + // Something in a sub-namespace or sub-module or nested-type + let moduleSearch = + match rest with + | id2::rest2 -> + match mty.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with + | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) -> + let resInfo = resInfo.AddEntity(id.idRange,submodref) + OneResult (ResolvePatternLongIdentInModuleOrNamespace ncenv nenv numTyArgsOpt ad resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType id2 rest2) + | _ -> + NoResultsOrUsefulErrors + | [] -> NoResultsOrUsefulErrors + + match tyconSearch +++ ctorSearch +++ moduleSearch with + | Result [] -> + let suggestPossibleTypes() = + let submodules = + mty.ModulesAndNamespacesByDemangledName + |> Seq.filter (fun kv -> IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef kv.Value)) + |> Seq.collect (fun e -> [e.Value.DisplayName; e.Value.DemangledModuleOrNamespaceName]) - let suggestedTypes = - nenv.TyconsByDemangledNameAndArity FullyQualifiedFlag.OpenQualified - |> Seq.filter (fun e -> IsEntityAccessible ncenv.amap m ad e.Value) - |> Seq.map (fun e -> e.Value.DisplayName) + let suggestedTypes = + nenv.TyconsByDemangledNameAndArity FullyQualifiedFlag.OpenQualified + |> Seq.filter (fun e -> IsEntityAccessible ncenv.amap m ad e.Value) + |> Seq.map (fun e -> e.Value.DisplayName) - [ yield! submodules - yield! suggestedTypes ] - |> HashSet + [ yield! submodules + yield! suggestedTypes ] + |> HashSet - raze (UndefinedName(depth,FSComp.SR.undefinedNameConstructorModuleOrNamespace,id,suggestPossibleTypes)) - | results -> AtMostOneResult id.idRange results + raze (UndefinedName(depth,FSComp.SR.undefinedNameConstructorModuleOrNamespace,id,suggestPossibleTypes)) + | results -> AtMostOneResult id.idRange results /// Used to report a warning condition for the use of upper-case identifiers in patterns exception UpperCaseIdentifierInPattern of range @@ -2665,59 +2683,78 @@ exception UpperCaseIdentifierInPattern of range type WarnOnUpperFlag = WarnOnUpperCase | AllIdsOK // Long ID in a pattern -let rec ResolvePatternLongIdentPrim sink (ncenv:NameResolver) fullyQualified warnOnUpper newDef m ad nenv numTyArgsOpt (lid:Ident list) = - match lid with - - | [id] when id.idText = MangledGlobalName -> - error (Error(FSComp.SR.nrGlobalUsedOnlyAsFirstName(), id.idRange)) - - | id :: lid when id.idText = MangledGlobalName -> - ResolvePatternLongIdentPrim sink ncenv FullyQualified warnOnUpper newDef m ad nenv numTyArgsOpt lid - - // Single identifiers in patterns - | [id] when fullyQualified <> FullyQualified -> - // Single identifiers in patterns - bind to constructors and active patterns - // For the special case of - // let C = x - match nenv.ePatItems.TryFind(id.idText) with - | Some res when not newDef -> FreshenUnqualifiedItem ncenv m res - | _ -> - // Single identifiers in patterns - variable bindings - if not newDef && - (warnOnUpper = WarnOnUpperCase) && - id.idText.Length >= 3 && - System.Char.ToLowerInvariant id.idText.[0] <> id.idText.[0] then - warning(UpperCaseIdentifierInPattern(m)) - Item.NewDef id +let rec ResolvePatternLongIdentPrim sink (ncenv:NameResolver) fullyQualified warnOnUpper newDef m ad nenv numTyArgsOpt (id:Ident) (rest:Ident list) = + if id.idText = MangledGlobalName then + match rest with + | [] -> + error (Error(FSComp.SR.nrGlobalUsedOnlyAsFirstName(), id.idRange)) + | id2::rest2 -> + ResolvePatternLongIdentPrim sink ncenv FullyQualified warnOnUpper newDef m ad nenv numTyArgsOpt id2 rest2 + else + // Single identifiers in patterns + if isNil rest && fullyQualified <> FullyQualified then + // Single identifiers in patterns - bind to constructors and active patterns + // For the special case of + // let C = x + match nenv.ePatItems.TryFind(id.idText) with + | Some res when not newDef -> FreshenUnqualifiedItem ncenv m res + | _ -> + // Single identifiers in patterns - variable bindings + if not newDef && + (warnOnUpper = WarnOnUpperCase) && + id.idText.Length >= 3 && + System.Char.ToLowerInvariant id.idText.[0] <> id.idText.[0] then + warning(UpperCaseIdentifierInPattern(m)) + Item.NewDef id - // Long identifiers in patterns - | _ -> - let moduleSearch ad = - ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AtMostOneResult ncenv.amap m fullyQualified nenv ad lid false - (ResolvePatternLongIdentInModuleOrNamespace ncenv nenv numTyArgsOpt ad) - let tyconSearch ad = - match lid with - | tn :: rest when not (isNil rest) -> - let tcrefs = LookupTypeNameInEnvNoArity fullyQualified tn.idText nenv - if isNil tcrefs then NoResultsOrUsefulErrors else - let tcrefs = tcrefs |> List.map (fun tcref -> (ResolutionInfo.Empty,tcref)) - ResolveLongIdentInTyconRefs ResultCollectionSettings.AtMostOneResult ncenv nenv LookupKind.Pattern 1 tn.idRange ad rest numTyArgsOpt tn.idRange tcrefs - | _ -> - NoResultsOrUsefulErrors - let resInfo,res,rest = - match AtMostOneResult m (tyconSearch ad +++ moduleSearch ad) with - | Result _ as res -> ForceRaise res - | _ -> - ForceRaise (AtMostOneResult m (tyconSearch AccessibleFromSomeFSharpCode +++ moduleSearch AccessibleFromSomeFSharpCode)) - ResolutionInfo.SendEntityPathToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> true)) - - if not (isNil rest) then error(Error(FSComp.SR.nrIsNotConstructorOrLiteral(),(List.head rest).idRange)) - res + // Long identifiers in patterns + else + let moduleSearch ad = + ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AtMostOneResult ncenv.amap m fullyQualified nenv ad id rest false + (ResolvePatternLongIdentInModuleOrNamespace ncenv nenv numTyArgsOpt ad) + + let tyconSearch ad = + match rest with + | id2 :: rest2 -> + let tcrefs = LookupTypeNameInEnvNoArity fullyQualified id.idText nenv + if isNil tcrefs then NoResultsOrUsefulErrors else + let tcrefs = tcrefs |> List.map (fun tcref -> (ResolutionInfo.Empty,tcref)) + ResolveLongIdentInTyconRefs ResultCollectionSettings.AtMostOneResult ncenv nenv LookupKind.Pattern 1 id.idRange ad id2 rest2 numTyArgsOpt id.idRange tcrefs + | _ -> + NoResultsOrUsefulErrors + + let resInfo,res,rest = + let tyconResult = tyconSearch ad + match tyconResult with + | Result (res :: _) -> res + | _ -> + + let moduleResult = moduleSearch ad + match moduleResult with + | Result (res :: _) -> res + | _ -> + + match AtMostOneResult m (tyconResult +++ moduleResult) with + | Result _ as res -> ForceRaise res + | _ -> + + let tyconResult = tyconSearch AccessibleFromSomeFSharpCode + match tyconResult with + | Result (res :: _) -> res + | _ -> + ForceRaise (AtMostOneResult m (tyconResult +++ moduleSearch AccessibleFromSomeFSharpCode)) + ResolutionInfo.SendEntityPathToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> true)) + + match rest with + | [] -> res + | element :: _ -> error(Error(FSComp.SR.nrIsNotConstructorOrLiteral(),element.idRange)) /// Resolve a long identifier when used in a pattern. let ResolvePatternLongIdent sink (ncenv:NameResolver) warnOnUpper newDef m ad nenv numTyArgsOpt (lid:Ident list) = - ResolvePatternLongIdentPrim sink ncenv OpenQualified warnOnUpper newDef m ad nenv numTyArgsOpt lid + match lid with + | [] -> error(Error(FSComp.SR.nrUnexpectedEmptyLongId(),m)) + | id::rest -> ResolvePatternLongIdentPrim sink ncenv OpenQualified warnOnUpper newDef m ad nenv numTyArgsOpt id rest //------------------------------------------------------------------------- // Resolve F#/IL "." syntax in types @@ -2737,11 +2774,10 @@ let ResolveNestedTypeThroughAbbreviation (ncenv:NameResolver) (tcref: TyconRef) tcref /// Resolve a long identifier representing a type name -let rec ResolveTypeLongIdentInTyconRefPrim (ncenv:NameResolver) (typeNameResInfo:TypeNameResolutionInfo) ad resInfo genOk depth m (tcref: TyconRef) (lid: Ident list) = +let rec ResolveTypeLongIdentInTyconRefPrim (ncenv:NameResolver) (typeNameResInfo:TypeNameResolutionInfo) ad resInfo genOk depth m (tcref: TyconRef) (id:Ident) (rest: Ident list) = let tcref = ResolveNestedTypeThroughAbbreviation ncenv tcref m - match lid with - | [] -> error(Error(FSComp.SR.nrUnexpectedEmptyLongId(),m)) - | [id] -> + match rest with + | [] -> #if !NO_EXTENSIONTYPING // No dotting through type generators to get to a nested type! CheckForDirectReferenceToGeneratedType (tcref, PermitDirectReferenceToGeneratedType.No, m) @@ -2759,7 +2795,7 @@ let rec ResolveTypeLongIdentInTyconRefPrim (ncenv:NameResolver) (typeNameResInfo |> HashSet raze (UndefinedName(depth,FSComp.SR.undefinedNameType,id,suggestTypes)) - | id::rest -> + | id2::rest2 -> #if !NO_EXTENSIONTYPING // No dotting through type generators to get to a nested type! CheckForDirectReferenceToGeneratedType (tcref, PermitDirectReferenceToGeneratedType.No, m) @@ -2772,7 +2808,7 @@ let rec ResolveTypeLongIdentInTyconRefPrim (ncenv:NameResolver) (typeNameResInfo let tcrefs = tcrefs |> List.map (fun tcref -> (resInfo,tcref)) let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, typeNameResInfo.DropStaticArgsInfo, genOk, m) match tcrefs with - | _ :: _ -> tcrefs |> CollectAtMostOneResult (fun (resInfo,tcref) -> ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad resInfo genOk (depth+1) m tcref rest) + | _ :: _ -> tcrefs |> CollectAtMostOneResult (fun (resInfo,tcref) -> ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad resInfo genOk (depth+1) m tcref id2 rest2) | [] -> let suggestTypes() = tcref.ModuleOrNamespaceType.TypesByDemangledNameAndArity id.idRange @@ -2785,7 +2821,12 @@ let rec ResolveTypeLongIdentInTyconRefPrim (ncenv:NameResolver) (typeNameResInfo /// Resolve a long identifier representing a type name and report the result let ResolveTypeLongIdentInTyconRef sink (ncenv:NameResolver) nenv typeNameResInfo ad m tcref (lid: Ident list) = - let resInfo,tcref = ForceRaise (ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad ResolutionInfo.Empty PermitDirectReferenceToGeneratedType.No 0 m tcref lid) + let resInfo,tcref = + match lid with + | [] -> + error(Error(FSComp.SR.nrUnexpectedEmptyLongId(),m)) + | id::rest -> + ForceRaise (ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad ResolutionInfo.Empty PermitDirectReferenceToGeneratedType.No 0 m tcref id rest) ResolutionInfo.SendEntityPathToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> true)) let item = Item.Types(tcref.DisplayName,[FreshenTycon ncenv m tcref]) CallNameResolutionSink sink (rangeOfLid lid,nenv,item,item,emptyTyparInst,ItemOccurence.UseInType,nenv.eDisplayEnv,ad) @@ -2803,16 +2844,15 @@ let SuggestTypeLongIdentInModuleOrNamespace depth (modref:ModuleOrNamespaceRef) UndefinedName(depth,errorTextF,id,suggestPossibleTypes) /// Resolve a long identifier representing a type in a module or namespace -let rec private ResolveTypeLongIdentInModuleOrNamespace sink nenv (ncenv:NameResolver) (typeNameResInfo: TypeNameResolutionInfo) ad genOk (resInfo:ResolutionInfo) depth m modref _mty (lid: Ident list) = - match lid with - | [] -> error(Error(FSComp.SR.nrUnexpectedEmptyLongId(),m)) - | [id] -> +let rec private ResolveTypeLongIdentInModuleOrNamespace sink nenv (ncenv:NameResolver) (typeNameResInfo: TypeNameResolutionInfo) ad genOk (resInfo:ResolutionInfo) depth m modref _mty (id:Ident) (rest: Ident list) = + match rest with + | [] -> // On all paths except error reporting we have isSome(staticResInfo), hence get at most one result back let tcrefs = LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, id.idRange, ad, id.idText, typeNameResInfo.StaticArgsInfo, modref) match tcrefs with | _ :: _ -> tcrefs |> CollectResults (fun tcref -> success(resInfo,tcref)) | [] -> raze (SuggestTypeLongIdentInModuleOrNamespace depth modref ncenv.amap ad m id) - | id::rest -> + | id2::rest2 -> let m = unionRanges m id.idRange let modulSearch = match modref.ModuleOrNamespaceType.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with @@ -2820,7 +2860,7 @@ let rec private ResolveTypeLongIdentInModuleOrNamespace sink nenv (ncenv:NameRes let item = Item.ModuleOrNamespaces [submodref] CallNameResolutionSink sink (id.idRange, nenv, item, item, emptyTyparInst, ItemOccurence.Use, nenv.DisplayEnv, ad) let resInfo = resInfo.AddEntity(id.idRange,submodref) - ResolveTypeLongIdentInModuleOrNamespace sink nenv ncenv typeNameResInfo ad genOk resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType rest + ResolveTypeLongIdentInModuleOrNamespace sink nenv ncenv typeNameResInfo ad genOk resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType id2 rest2 | _ -> let suggestPossibleModules() = modref.ModuleOrNamespaceType.ModulesAndNamespacesByDemangledName @@ -2832,7 +2872,7 @@ let rec private ResolveTypeLongIdentInModuleOrNamespace sink nenv (ncenv:NameRes let tyconSearch = let tcrefs = LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, id.idRange, ad, id.idText, TypeNameResolutionStaticArgsInfo.Indefinite, modref) match tcrefs with - | _ :: _ -> tcrefs |> CollectResults (fun tcref -> ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad resInfo genOk (depth+1) m tcref rest) + | _ :: _ -> tcrefs |> CollectResults (fun tcref -> ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad resInfo genOk (depth+1) m tcref id2 rest2) | [] -> let suggestTypes() = modref.ModuleOrNamespaceType.TypesByDemangledNameAndArity id.idRange @@ -2843,94 +2883,98 @@ let rec private ResolveTypeLongIdentInModuleOrNamespace sink nenv (ncenv:NameRes tyconSearch +++ modulSearch /// Resolve a long identifier representing a type -let rec ResolveTypeLongIdentPrim sink (ncenv:NameResolver) occurence fullyQualified m nenv ad (lid: Ident list) (staticResInfo: TypeNameResolutionStaticArgsInfo) genOk = +let rec ResolveTypeLongIdentPrim sink (ncenv:NameResolver) occurence first fullyQualified m nenv ad (id:Ident) (rest: Ident list) (staticResInfo: TypeNameResolutionStaticArgsInfo) genOk = let typeNameResInfo = TypeNameResolutionInfo.ResolveToTypeRefs staticResInfo - match lid with - | [] -> error(Error(FSComp.SR.nrUnexpectedEmptyLongId(),m)) - - | [id] when id.idText = MangledGlobalName -> - error (Error(FSComp.SR.nrGlobalUsedOnlyAsFirstName(), id.idRange)) - - | id :: lid when id.idText = MangledGlobalName -> - ResolveTypeLongIdentPrim sink ncenv occurence FullyQualified m nenv ad lid staticResInfo genOk - - | [id] -> - match LookupTypeNameInEnvHaveArity fullyQualified id.idText staticResInfo.NumStaticArgs nenv with - | Some res -> - let res = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities ([(ResolutionInfo.Empty,res)], typeNameResInfo, genOk, unionRanges m id.idRange) - assert (res.Length = 1) - success res.Head - | None -> - // For Good Error Reporting! - let tcrefs = LookupTypeNameInEnvNoArity fullyQualified id.idText nenv - match tcrefs with - | tcref :: _tcrefs -> - // Note: This path is only for error reporting - //CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities tcref rest typeNameResInfo m - success(ResolutionInfo.Empty,tcref) - | [] -> - let suggestPossibleTypes() = - nenv.TyconsByDemangledNameAndArity(fullyQualified) - |> Seq.filter (fun kv -> IsEntityAccessible ncenv.amap m ad kv.Value) - |> Seq.collect (fun e -> - match occurence with - | ItemOccurence.UseInAttribute -> - [yield e.Value.DisplayName - yield e.Value.DemangledModuleOrNamespaceName - if e.Value.DisplayName.EndsWith "Attribute" then - yield e.Value.DisplayName.Replace("Attribute","")] - | _ -> [e.Value.DisplayName; e.Value.DemangledModuleOrNamespaceName]) - |> HashSet - - raze (UndefinedName(0,FSComp.SR.undefinedNameType,id,suggestPossibleTypes)) - - | id::rest -> - let m = unionRanges m id.idRange - let tyconSearch = - match fullyQualified with - | FullyQualified -> - NoResultsOrUsefulErrors - | OpenQualified -> - match LookupTypeNameInEnvHaveArity fullyQualified id.idText staticResInfo.NumStaticArgs nenv with - | Some tcref when IsEntityAccessible ncenv.amap m ad tcref -> - OneResult (ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad ResolutionInfo.Empty genOk 1 m tcref rest) - | _ -> + if first && id.idText = MangledGlobalName then + match rest with + | [] -> + error (Error(FSComp.SR.nrGlobalUsedOnlyAsFirstName(), id.idRange)) + | id2::rest2 -> + ResolveTypeLongIdentPrim sink ncenv occurence false FullyQualified m nenv ad id2 rest2 staticResInfo genOk + else + match rest with + | [] -> + match LookupTypeNameInEnvHaveArity fullyQualified id.idText staticResInfo.NumStaticArgs nenv with + | Some res -> + let res = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities ([(ResolutionInfo.Empty,res)], typeNameResInfo, genOk, unionRanges m id.idRange) + assert (res.Length = 1) + success res.Head + | None -> + // For Good Error Reporting! + let tcrefs = LookupTypeNameInEnvNoArity fullyQualified id.idText nenv + match tcrefs with + | tcref :: _tcrefs -> + // Note: This path is only for error reporting + //CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities tcref rest typeNameResInfo m + success(ResolutionInfo.Empty,tcref) + | [] -> + let suggestPossibleTypes() = + nenv.TyconsByDemangledNameAndArity(fullyQualified) + |> Seq.filter (fun kv -> IsEntityAccessible ncenv.amap m ad kv.Value) + |> Seq.collect (fun e -> + match occurence with + | ItemOccurence.UseInAttribute -> + [yield e.Value.DisplayName + yield e.Value.DemangledModuleOrNamespaceName + if e.Value.DisplayName.EndsWith "Attribute" then + yield e.Value.DisplayName.Replace("Attribute","")] + | _ -> [e.Value.DisplayName; e.Value.DemangledModuleOrNamespaceName]) + |> HashSet + + raze (UndefinedName(0,FSComp.SR.undefinedNameType,id,suggestPossibleTypes)) + | id2::rest2 -> + let m2 = unionRanges m id.idRange + let tyconSearch = + match fullyQualified with + | FullyQualified -> NoResultsOrUsefulErrors + | OpenQualified -> + match LookupTypeNameInEnvHaveArity fullyQualified id.idText staticResInfo.NumStaticArgs nenv with + | Some tcref when IsEntityAccessible ncenv.amap m2 ad tcref -> + OneResult (ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad ResolutionInfo.Empty genOk 1 m2 tcref id2 rest2) + | _ -> + NoResultsOrUsefulErrors - let modulSearch = - ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AllResults ncenv.amap m fullyQualified nenv ad lid false - (ResolveTypeLongIdentInModuleOrNamespace sink nenv ncenv typeNameResInfo ad genOk) - |?> List.concat - - let modulSearchFailed() = - ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AllResults ncenv.amap m fullyQualified nenv AccessibleFromSomeFSharpCode lid false - (ResolveTypeLongIdentInModuleOrNamespace sink nenv ncenv typeNameResInfo.DropStaticArgsInfo AccessibleFromSomeFSharpCode genOk) - |?> List.concat - - let searchSoFar = tyconSearch +++ modulSearch - - match searchSoFar with - | Result results -> - // NOTE: we delay checking the CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities condition until right at the end after we've - // collected all possible resolutions of the type - let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (results, typeNameResInfo, genOk, rangeOfLid lid) - match tcrefs with - | (resInfo,tcref) :: _ -> - // We've already reported the ambiguity, possibly as an error. Now just take the first possible result. - success(resInfo,tcref) - | [] -> - // failing case - report nice ambiguity errors even in this case - AtMostOneResult m ((searchSoFar +++ modulSearchFailed()) |?> (fun tcrefs -> CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, typeNameResInfo, genOk, rangeOfLid lid))) + let modulSearch = + ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AllResults ncenv.amap m2 fullyQualified nenv ad id rest false + (ResolveTypeLongIdentInModuleOrNamespace sink nenv ncenv typeNameResInfo ad genOk) + |?> List.concat + + let modulSearchFailed() = + ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AllResults ncenv.amap m2 fullyQualified nenv AccessibleFromSomeFSharpCode id rest false + (ResolveTypeLongIdentInModuleOrNamespace sink nenv ncenv typeNameResInfo.DropStaticArgsInfo AccessibleFromSomeFSharpCode genOk) + |?> List.concat + + let searchSoFar = tyconSearch +++ modulSearch + + match searchSoFar with + | Result results -> + // NOTE: we delay checking the CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities condition until right at the end after we've + // collected all possible resolutions of the type + let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (results, typeNameResInfo, genOk, m) + match tcrefs with + | (resInfo,tcref) :: _ -> + // We've already reported the ambiguity, possibly as an error. Now just take the first possible result. + success(resInfo,tcref) + | [] -> + // failing case - report nice ambiguity errors even in this case + AtMostOneResult m2 ((searchSoFar +++ modulSearchFailed()) |?> (fun tcrefs -> CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, typeNameResInfo, genOk, m))) - | _ -> - // failing case - report nice ambiguity errors even in this case - AtMostOneResult m ((searchSoFar +++ modulSearchFailed()) |?> (fun tcrefs -> CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, typeNameResInfo, genOk, rangeOfLid lid))) + | _ -> + // failing case - report nice ambiguity errors even in this case + AtMostOneResult m2 ((searchSoFar +++ modulSearchFailed()) |?> (fun tcrefs -> CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, typeNameResInfo, genOk, m))) /// Resolve a long identifier representing a type and report it let ResolveTypeLongIdent sink (ncenv:NameResolver) occurence fullyQualified nenv ad (lid: Ident list) staticResInfo genOk = let m = rangeOfLid lid - let res = ResolveTypeLongIdentPrim sink ncenv occurence fullyQualified m nenv ad lid staticResInfo genOk + let res = + match lid with + | [] -> + error(Error(FSComp.SR.nrUnexpectedEmptyLongId(),m)) + | id::rest -> + ResolveTypeLongIdentPrim sink ncenv occurence true fullyQualified m nenv ad id rest staticResInfo genOk + // Register the result as a name resolution match res with | Result (resInfo,tcref) -> @@ -2945,55 +2989,52 @@ let ResolveTypeLongIdent sink (ncenv:NameResolver) occurence fullyQualified nenv //------------------------------------------------------------------------- /// Resolve a long identifier representing a record field in a module or namespace -let rec ResolveFieldInModuleOrNamespace (ncenv:NameResolver) nenv ad (resInfo:ResolutionInfo) depth m (modref: ModuleOrNamespaceRef) _mty (lid: Ident list) = +let rec ResolveFieldInModuleOrNamespace (ncenv:NameResolver) nenv ad (resInfo:ResolutionInfo) depth m (modref: ModuleOrNamespaceRef) _mty (id:Ident) (rest: Ident list) = let typeNameResInfo = TypeNameResolutionInfo.Default - match lid with - | id::rest -> - let m = unionRanges m id.idRange - // search for module-qualified names, e.g. { Microsoft.FSharp.Core.contents = 1 } - let modulScopedFieldNames = - match TryFindTypeWithRecdField modref id with - | Some tycon when IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef tycon) -> - let showDeprecated = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs - success [resInfo, FieldResolution(modref.RecdFieldRefInNestedTycon tycon id,showDeprecated), rest] - | _ -> raze (UndefinedName(depth,FSComp.SR.undefinedNameRecordLabelOrNamespace,id,NoSuggestions)) + let m = unionRanges m id.idRange + // search for module-qualified names, e.g. { Microsoft.FSharp.Core.contents = 1 } + let modulScopedFieldNames = + match TryFindTypeWithRecdField modref id with + | Some tycon when IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef tycon) -> + let showDeprecated = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs + success [resInfo, FieldResolution(modref.RecdFieldRefInNestedTycon tycon id,showDeprecated), rest] + | _ -> raze (UndefinedName(depth,FSComp.SR.undefinedNameRecordLabelOrNamespace,id,NoSuggestions)) - match modulScopedFieldNames with - | Result (res :: _) -> success res - | _ -> + match modulScopedFieldNames with + | Result (res :: _) -> success res + | _ -> - // search for type-qualified names, e.g. { Microsoft.FSharp.Core.Ref.contents = 1 } - let tyconSearch = - match lid with - | _tn:: rest when not (isNil rest) -> - let tcrefs = LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, id.idRange, ad, id.idText, TypeNameResolutionStaticArgsInfo.Indefinite, modref) - if isNil tcrefs then NoResultsOrUsefulErrors else - let tcrefs = tcrefs |> List.map (fun tcref -> (ResolutionInfo.Empty,tcref)) - let tyconSearch = ResolveLongIdentInTyconRefs ResultCollectionSettings.AllResults ncenv nenv LookupKind.RecdField (depth+1) m ad rest typeNameResInfo id.idRange tcrefs - // choose only fields - let tyconSearch = tyconSearch |?> List.choose (function (resInfo,Item.RecdField(RecdFieldInfo(_,rfref)),rest) -> Some(resInfo,FieldResolution(rfref,false),rest) | _ -> None) - tyconSearch - | _ -> - NoResultsOrUsefulErrors + // search for type-qualified names, e.g. { Microsoft.FSharp.Core.Ref.contents = 1 } + let tyconSearch = + match rest with + | id2::rest2 -> + let tcrefs = LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, id.idRange, ad, id.idText, TypeNameResolutionStaticArgsInfo.Indefinite, modref) + if isNil tcrefs then NoResultsOrUsefulErrors else + let tcrefs = tcrefs |> List.map (fun tcref -> (ResolutionInfo.Empty,tcref)) + let tyconSearch = ResolveLongIdentInTyconRefs ResultCollectionSettings.AllResults ncenv nenv LookupKind.RecdField (depth+1) m ad id2 rest2 typeNameResInfo id.idRange tcrefs + // choose only fields + let tyconSearch = tyconSearch |?> List.choose (function (resInfo,Item.RecdField(RecdFieldInfo(_,rfref)),rest) -> Some(resInfo,FieldResolution(rfref,false),rest) | _ -> None) + tyconSearch + | _ -> + NoResultsOrUsefulErrors - match tyconSearch with - | Result (res :: _) -> success res - | _ -> + match tyconSearch with + | Result (res :: _) -> success res + | _ -> - // search for names in nested modules, e.g. { Microsoft.FSharp.Core.contents = 1 } - let modulSearch = - if not (isNil rest) then - match modref.ModuleOrNamespaceType.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with - | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) -> - let resInfo = resInfo.AddEntity(id.idRange,submodref) - ResolveFieldInModuleOrNamespace ncenv nenv ad resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType rest - |> OneResult - | _ -> raze (UndefinedName(depth,FSComp.SR.undefinedNameRecordLabelOrNamespace,id,NoSuggestions)) - else raze (UndefinedName(depth,FSComp.SR.undefinedNameRecordLabelOrNamespace,id,NoSuggestions)) + // search for names in nested modules, e.g. { Microsoft.FSharp.Core.contents = 1 } + let modulSearch = + match rest with + | id2::rest2 -> + match modref.ModuleOrNamespaceType.ModulesAndNamespacesByDemangledName.TryFind(id.idText) with + | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) -> + let resInfo = resInfo.AddEntity(id.idRange,submodref) + ResolveFieldInModuleOrNamespace ncenv nenv ad resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType id2 rest2 + |> OneResult + | _ -> raze (UndefinedName(depth,FSComp.SR.undefinedNameRecordLabelOrNamespace,id,NoSuggestions)) + | _ -> raze (UndefinedName(depth,FSComp.SR.undefinedNameRecordLabelOrNamespace,id,NoSuggestions)) - AtMostOneResult m (modulScopedFieldNames +++ tyconSearch +++ modulSearch) - | [] -> - error(InternalError("ResolveFieldInModuleOrNamespace",m)) + AtMostOneResult m (modulScopedFieldNames +++ tyconSearch +++ modulSearch) /// Suggest other labels of the same record let SuggestOtherLabelsOfSameRecordType g (nenv:NameResolutionEnv) typ (id:Ident) (allFields:Ident list) = @@ -3095,20 +3136,23 @@ let ResolveFieldPrim sink (ncenv:NameResolver) nenv ad typ (mp,id:Ident) allFiel let lid = (mp@[id]) let tyconSearch ad = match lid with - | tn:: (_ :: _ as rest) -> + | tn :: id2 :: rest2 -> let m = tn.idRange let tcrefs = LookupTypeNameInEnvNoArity OpenQualified tn.idText nenv if isNil tcrefs then NoResultsOrUsefulErrors else let tcrefs = tcrefs |> List.map (fun tcref -> (ResolutionInfo.Empty,tcref)) - let tyconSearch = ResolveLongIdentInTyconRefs ResultCollectionSettings.AllResults ncenv nenv LookupKind.RecdField 1 m ad rest typeNameResInfo tn.idRange tcrefs + let tyconSearch = ResolveLongIdentInTyconRefs ResultCollectionSettings.AllResults ncenv nenv LookupKind.RecdField 1 m ad id2 rest2 typeNameResInfo tn.idRange tcrefs // choose only fields let tyconSearch = tyconSearch |?> List.choose (function (resInfo,Item.RecdField(RecdFieldInfo(_,rfref)),rest) -> Some(resInfo,FieldResolution(rfref,false),rest) | _ -> None) tyconSearch | _ -> NoResultsOrUsefulErrors - let modulSearch ad = - ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AtMostOneResult ncenv.amap m OpenQualified nenv ad lid false - (ResolveFieldInModuleOrNamespace ncenv nenv ad) + let modulSearch ad = + match lid with + | [] -> NoResultsOrUsefulErrors + | id2::rest2 -> + ResolveLongIndentAsModuleOrNamespaceThen sink ResultCollectionSettings.AtMostOneResult ncenv.amap m OpenQualified nenv ad id2 rest2 false + (ResolveFieldInModuleOrNamespace ncenv nenv ad) let search = let moduleSearch1 = modulSearch ad @@ -3164,9 +3208,9 @@ let FreshenRecdFieldRef (ncenv:NameResolver) m (rfref:RecdFieldRef) = /// determine any valid members // // QUERY (instantiationGenerator cleanup): it would be really nice not to flow instantiationGenerator to here. -let private ResolveExprDotLongIdent (ncenv:NameResolver) m ad nenv typ lid findFlag = +let private ResolveExprDotLongIdent (ncenv:NameResolver) m ad nenv typ (id:Ident) rest findFlag = let typeNameResInfo = TypeNameResolutionInfo.Default - let adhoctDotSearchAccessible = AtMostOneResult m (ResolveLongIdentInTypePrim ncenv nenv LookupKind.Expr ResolutionInfo.Empty 1 m ad lid findFlag typeNameResInfo typ) + let adhoctDotSearchAccessible = AtMostOneResult m (ResolveLongIdentInTypePrim ncenv nenv LookupKind.Expr ResolutionInfo.Empty 1 m ad id rest findFlag typeNameResInfo typ) match adhoctDotSearchAccessible with | Exception _ -> // If the dot is not resolved by adhoc overloading then look for a record field @@ -3176,23 +3220,19 @@ let private ResolveExprDotLongIdent (ncenv:NameResolver) m ad nenv typ lid findF if isAppTy ncenv.g typ then NoResultsOrUsefulErrors else - match lid with - // A unique record label access, e.g expr.field - | id::rest when nenv.eFieldLabels.ContainsKey(id.idText) -> - match nenv.eFieldLabels.[id.idText] with - | [] -> NoResultsOrUsefulErrors - | rfref :: _ -> - // NOTE (instantiationGenerator cleanup): we need to freshen here because we don't know the type. - // But perhaps the caller should freshen?? - let item = FreshenRecdFieldRef ncenv m rfref - OneSuccess (ResolutionInfo.Empty,item,rest) - | _ -> NoResultsOrUsefulErrors + match nenv.eFieldLabels |> Map.tryFind id.idText with + | Some(rfref :: _) -> + // NOTE (instantiationGenerator cleanup): we need to freshen here because we don't know the type. + // But perhaps the caller should freshen?? + let item = FreshenRecdFieldRef ncenv m rfref + OneSuccess (ResolutionInfo.Empty,item,rest) + | _ -> NoResultsOrUsefulErrors let search = dotFieldIdSearch match AtMostOneResult m search with | Result _ as res -> ForceRaise res | _ -> - let adhocDotSearchAll = ResolveLongIdentInTypePrim ncenv nenv LookupKind.Expr ResolutionInfo.Empty 1 m AccessibleFromSomeFSharpCode lid findFlag typeNameResInfo typ + let adhocDotSearchAll = ResolveLongIdentInTypePrim ncenv nenv LookupKind.Expr ResolutionInfo.Empty 1 m AccessibleFromSomeFSharpCode id rest findFlag typeNameResInfo typ ForceRaise (AtMostOneResult m (search +++ adhocDotSearchAll)) | _ -> ForceRaise adhoctDotSearchAccessible @@ -3223,9 +3263,9 @@ let NeedsWorkAfterResolution namedItem = | Item.CtorGroup(_,minfos) -> minfos.Length > 1 || minfos |> List.exists (fun minfo -> not (isNil minfo.FormalMethodInst)) | Item.Property(_,pinfos) -> pinfos.Length > 1 | Item.ImplicitOp(_, { contents = Some(TraitConstraintSln.FSMethSln(_, vref, _)) }) - | Item.Value vref | Item.CustomBuilder (_,vref) -> vref.Typars.Length > 0 + | Item.Value vref | Item.CustomBuilder (_,vref) -> not (List.isEmpty vref.Typars) | Item.CustomOperation (_,_,Some minfo) -> not (isNil minfo.FormalMethodInst) - | Item.ActivePatternCase apref -> apref.ActivePatternVal.Typars.Length > 0 + | Item.ActivePatternCase apref -> not (List.isEmpty apref.ActivePatternVal.Typars) | _ -> false /// Specifies additional work to do after an item has been processed further in type checking. @@ -3304,7 +3344,11 @@ let (|NonOverridable|_|) namedItem = /// Also called for 'GenericType.Bar' - for VS IntelliSense, we can filter out non-static members from method groups let ResolveExprDotLongIdentAndComputeRange (sink:TcResultsSink) (ncenv:NameResolver) wholem ad nenv typ lid findFlag thisIsActuallyATyAppNotAnExpr = let resolveExpr findFlag = - let resInfo,item,rest = ResolveExprDotLongIdent ncenv wholem ad nenv typ lid findFlag + let resInfo,item,rest = + match lid with + | id::rest -> + ResolveExprDotLongIdent ncenv wholem ad nenv typ id rest findFlag + | _ -> error(InternalError("ResolveExprDotLongIdentAndComputeRange",wholem)) let itemRange = ComputeItemRange wholem lid rest resInfo,item,rest,itemRange // "true" resolution diff --git a/src/fsharp/NameResolution.fsi b/src/fsharp/NameResolution.fsi index af3a4a6e3c..7af7a278c2 100755 --- a/src/fsharp/NameResolution.fsi +++ b/src/fsharp/NameResolution.fsi @@ -251,6 +251,9 @@ type internal ItemOccurence = /// Check for equality, up to signature matching val ItemsAreEffectivelyEqual : TcGlobals -> Item -> Item -> bool +/// Hash compatible with ItemsAreEffectivelyEqual +val ItemsAreEffectivelyEqualHash : TcGlobals -> Item -> int + [] type internal CapturedNameResolution = /// line and column @@ -298,15 +301,22 @@ type internal TcResolutions = static member Empty : TcResolutions +[] +type TcSymbolUseData = + { Item: Item + ItemOccurence: ItemOccurence + DisplayEnv: DisplayEnv + Range: range } + [] /// Represents container for all name resolutions that were met so far when typechecking some particular file type internal TcSymbolUses = /// Get all the uses of a particular item within the file - member GetUsesOfSymbol : Item -> (ItemOccurence * DisplayEnv * range)[] + member GetUsesOfSymbol : Item -> TcSymbolUseData[] - /// Get all the uses of all items within the file - member GetAllUsesOfSymbols : unit -> (Item * ItemOccurence * DisplayEnv * range)[] + /// All the uses of all items within the file + member AllUsesOfSymbols : TcSymbolUseData[] /// Get the locations of all the printf format specifiers in the file member GetFormatSpecifierLocationsAndArity : unit -> (range * int)[] @@ -365,7 +375,7 @@ type internal TcResultsSinkImpl = member GetSymbolUses : unit -> TcSymbolUses /// Get all open declarations reported to the sink - member OpenDeclarations : OpenDeclaration list + member GetOpenDeclarations : unit -> OpenDeclaration[] interface ITypecheckResultsSink @@ -444,13 +454,13 @@ type ResultCollectionSettings = | AtMostOneResult /// Resolve a long identifier to a namespace or module. -val internal ResolveLongIndentAsModuleOrNamespace : TcResultsSink -> ResultCollectionSettings -> Import.ImportMap -> range -> FullyQualifiedFlag -> NameResolutionEnv -> AccessorDomain -> Ident list -> isOpenDecl: bool -> ResultOrException<(int * ModuleOrNamespaceRef * ModuleOrNamespaceType) list > +val internal ResolveLongIndentAsModuleOrNamespace : TcResultsSink -> ResultCollectionSettings -> Import.ImportMap -> range -> bool -> FullyQualifiedFlag -> NameResolutionEnv -> AccessorDomain -> Ident -> Ident list -> isOpenDecl: bool -> ResultOrException<(int * ModuleOrNamespaceRef * ModuleOrNamespaceType) list > /// Resolve a long identifier to an object constructor. val internal ResolveObjectConstructor : NameResolver -> DisplayEnv -> range -> AccessorDomain -> TType -> ResultOrException /// Resolve a long identifier using type-qualified name resolution. -val internal ResolveLongIdentInType : TcResultsSink -> NameResolver -> NameResolutionEnv -> LookupKind -> range -> AccessorDomain -> Ident list -> FindMemberFlag -> TypeNameResolutionInfo -> TType -> Item * Ident list +val internal ResolveLongIdentInType : TcResultsSink -> NameResolver -> NameResolutionEnv -> LookupKind -> range -> AccessorDomain -> Ident -> FindMemberFlag -> TypeNameResolutionInfo -> TType -> Item * Ident list /// Resolve a long identifier when used in a pattern. val internal ResolvePatternLongIdent : TcResultsSink -> NameResolver -> WarnOnUpperFlag -> bool -> range -> AccessorDomain -> NameResolutionEnv -> TypeNameResolutionInfo -> Ident list -> Item diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 519cca8f3f..e3ad74ad0d 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -71,9 +71,10 @@ module internal PrintUtilities = tcref.DisplayName // has no static params else tcref.DisplayName+"<...>" // shorten - if isAttribute then - defaultArg (String.tryDropSuffix name "Attribute") name - else name + if isAttribute && name.EndsWith "Attribute" then + String.dropSuffix name "Attribute" + else + name let tyconTextL = tagEntityRefName tcref demangled |> mkNav tcref.DefinitionRange @@ -259,7 +260,7 @@ module private PrintIL = let staticL = if f.IsStatic then WordL.keywordStatic else emptyL let name = adjustILName f.Name let nameL = wordL (tagField name) - let typL = layoutILType denv ilTyparSubst f.Type + let typL = layoutILType denv ilTyparSubst f.FieldType staticL ^^ WordL.keywordVal ^^ nameL ^^ WordL.colon ^^ typL let private layoutILEventDef denv ilTyparSubst (e: ILEventDef) = @@ -267,7 +268,7 @@ module private PrintIL = let name = adjustILName e.Name let nameL = wordL (tagEvent name) let typL = - match e.Type with + match e.EventType with | Some t -> layoutILType denv ilTyparSubst t | _ -> emptyL staticL ^^ WordL.keywordEvent ^^ nameL ^^ WordL.colon ^^ typL @@ -294,16 +295,16 @@ module private PrintIL = let typL = match p.GetMethod, p.SetMethod with - | None, None -> layoutILType denv ilTyparSubst p.Type // shouldn't happen - | Some getterRef, _ -> layoutGetterType getterRef - | None, Some setterRef -> layoutSetterType setterRef + | None, None -> layoutILType denv ilTyparSubst p.PropertyType // shouldn't happen + | Some getterRef, _ -> layoutGetterType getterRef + | None, Some setterRef -> layoutSetterType setterRef let specGetSetL = match p.GetMethod, p.SetMethod with - | None,None - | Some _, None -> emptyL - | None, Some _ -> WordL.keywordWith ^^ WordL.keywordSet - | Some _, Some _ -> WordL.keywordWith ^^ WordL.keywordGet ^^ RightL.comma ^^ WordL.keywordSet + | None,None + | Some _, None -> emptyL + | None, Some _ -> WordL.keywordWith ^^ WordL.keywordSet + | Some _, Some _ -> WordL.keywordWith ^^ WordL.keywordGet ^^ RightL.comma ^^ WordL.keywordSet staticL ^^ WordL.keywordMember ^^ nameL ^^ WordL.colon ^^ typL ^^ specGetSetL let layoutILFieldInit x = @@ -654,9 +655,10 @@ module private PrintTypes = | ILAttrib ilMethRef -> let trimmedName = let name = ilMethRef.DeclaringTypeRef.Name - match String.tryDropSuffix name "Attribute" with - | Some shortName -> shortName - | None -> name + if name.EndsWith "Attribute" then + String.dropSuffix name "Attribute" + else + name let tref = ilMethRef.DeclaringTypeRef let tref = ILTypeRef.Create(scope= tref.Scope, enclosing=tref.Enclosing, name=trimmedName) PrintIL.layoutILTypeRef denv tref ++ argsL @@ -1275,7 +1277,7 @@ module InfoMemberPrinting = let paramDatas = minfo.GetParamDatas(amap, m, minst) let layout = layout ^^ - if isNil (List.concat paramDatas) then + if List.forall isNil paramDatas then WordL.structUnit else sepListL WordL.arrow (List.map ((List.map (layoutParamData denv)) >> sepListL WordL.star) paramDatas) diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index d107cd1a78..7ce763fede 100755 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -2507,7 +2507,7 @@ and TryInlineApplication cenv env finfo (tyargs: TType list, args: Expr list, m) false else true)))) -> - let isBaseCall = args.Length > 0 && + let isBaseCall = not (List.isEmpty args) && match args.[0] with | Expr.Val(vref, _, _) when vref.BaseOrThisInfo = BaseVal -> true | _ -> false diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index a40292a356..c2e0c6376d 100755 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -19,6 +19,7 @@ open Microsoft.FSharp.Compiler.Lib exception MatchIncomplete of bool * (string * bool) option * range exception RuleNeverMatched of range +exception EnumMatchIncomplete of bool * (string * bool) option * range type ActionOnFailure = | ThrowIncompleteMatchException @@ -177,33 +178,37 @@ let RefuteDiscrimSet g m path discrims = | PathConj (p,_j) -> go p tm | PathTuple (p,tys,j) -> - go p (fun _ -> mkRefTupled g m (mkOneKnown tm j tys) tys) + let k, eCoversVals = mkOneKnown tm j tys + go p (fun _ -> mkRefTupled g m k tys, eCoversVals) | PathRecd (p,tcref,tinst,j) -> - let flds = tcref |> actualTysOfInstanceRecdFields (mkTyconRefInst tcref tinst) |> mkOneKnown tm j - go p (fun _ -> Expr.Op(TOp.Recd(RecdExpr, tcref),tinst, flds,m)) + let flds, eCoversVals = tcref |> actualTysOfInstanceRecdFields (mkTyconRefInst tcref tinst) |> mkOneKnown tm j + go p (fun _ -> Expr.Op(TOp.Recd(RecdExpr, tcref),tinst, flds,m), eCoversVals) | PathUnionConstr (p,ucref,tinst,j) -> - let flds = ucref |> actualTysOfUnionCaseFields (mkTyconRefInst ucref.TyconRef tinst)|> mkOneKnown tm j - go p (fun _ -> Expr.Op(TOp.UnionCase(ucref),tinst, flds,m)) + let flds, eCoversVals = ucref |> actualTysOfUnionCaseFields (mkTyconRefInst ucref.TyconRef tinst)|> mkOneKnown tm j + go p (fun _ -> Expr.Op(TOp.UnionCase(ucref),tinst, flds,m), eCoversVals) | PathArray (p,ty,len,n) -> - go p (fun _ -> Expr.Op(TOp.Array,[ty], mkOneKnown tm n (List.replicate len ty) ,m)) + let flds, eCoversVals = mkOneKnown tm n (List.replicate len ty) + go p (fun _ -> Expr.Op(TOp.Array,[ty], flds ,m), eCoversVals) | PathExnConstr (p,ecref,n) -> - let flds = ecref |> recdFieldTysOfExnDefRef |> mkOneKnown tm n - go p (fun _ -> Expr.Op(TOp.ExnConstr(ecref),[], flds,m)) + let flds, eCoversVals = ecref |> recdFieldTysOfExnDefRef |> mkOneKnown tm n + go p (fun _ -> Expr.Op(TOp.ExnConstr(ecref),[], flds,m), eCoversVals) | PathEmpty(ty) -> tm ty - and mkOneKnown tm n tys = List.mapi (fun i ty -> if i = n then tm ty else mkUnknown ty) tys - and mkUnknowns tys = List.map mkUnknown tys + and mkOneKnown tm n tys = + let flds = List.mapi (fun i ty -> if i = n then tm ty else (mkUnknown ty, false)) tys + List.map fst flds, List.fold (fun acc (_, eCoversVals) -> eCoversVals || acc) false flds + and mkUnknowns tys = List.map (fun x -> mkUnknown x) tys let tm ty = match discrims with | [DecisionTreeTest.IsNull] -> - snd(mkCompGenLocal m notNullText ty) + snd(mkCompGenLocal m notNullText ty), false | [DecisionTreeTest.IsInst (_,_)] -> - snd(mkCompGenLocal m otherSubtypeText ty) + snd(mkCompGenLocal m otherSubtypeText ty), false | (DecisionTreeTest.Const c :: rest) -> let consts = Set.ofList (c :: List.choose (function DecisionTreeTest.Const(c) -> Some c | _ -> None) rest) let c' = @@ -227,12 +232,23 @@ let RefuteDiscrimSet g m path discrims = | Const.Decimal _ -> seq { 1 .. System.Int32.MaxValue } |> Seq.map (fun v -> Const.Decimal(decimal v)) | _ -> raise CannotRefute) + + let coversKnownEnumValues = + match tryDestAppTy g ty with + | Some tcref when tcref.IsEnumTycon -> + let knownValues = + tcref.AllFieldsArray |> Array.choose (fun f -> + match f.rfield_const, f.rfield_static with + | Some value, true -> Some value + | _, _ -> None) + Array.forall (fun ev -> consts.Contains ev) knownValues + | _ -> false (* REVIEW: we could return a better enumeration literal field here if a field matches one of the enumeration cases *) match c' with | None -> raise CannotRefute - | Some c -> Expr.Const(c,m,ty) + | Some c -> Expr.Const(c,m,ty), coversKnownEnumValues | (DecisionTreeTest.UnionCase (ucref1,tinst) :: rest) -> let ucrefs = ucref1 :: List.choose (function DecisionTreeTest.UnionCase(ucref,_) -> Some ucref | _ -> None) rest @@ -246,10 +262,10 @@ let RefuteDiscrimSet g m path discrims = | [] -> raise CannotRefute | ucref2 :: _ -> let flds = ucref2 |> actualTysOfUnionCaseFields (mkTyconRefInst tcref tinst) |> mkUnknowns - Expr.Op(TOp.UnionCase(ucref2),tinst, flds,m) + Expr.Op(TOp.UnionCase(ucref2),tinst, flds,m), false | [DecisionTreeTest.ArrayLength (n,ty)] -> - Expr.Op(TOp.Array,[ty], mkUnknowns (List.replicate (n+1) ty) ,m) + Expr.Op(TOp.Array,[ty], mkUnknowns (List.replicate (n+1) ty) ,m), false | _ -> raise CannotRefute @@ -302,15 +318,16 @@ let rec CombineRefutations g r1 r2 = let ShowCounterExample g denv m refuted = try let refutations = refuted |> List.collect (function RefutedWhenClause -> [] | (RefutedInvestigation(path,discrim)) -> [RefuteDiscrimSet g m path discrim]) - let counterExample = + let counterExample, enumCoversKnown = match refutations with | [] -> raise CannotRefute - | h :: t -> - if verbose then dprintf "h = %s\n" (Layout.showL (exprL h)) - List.fold (CombineRefutations g) h t + | (r, eck) :: t -> + if verbose then dprintf "r = %s (enumCoversKnownValue = %b)\n" (Layout.showL (exprL r)) eck + List.fold (fun (rAcc, eckAcc) (r, eck) -> + CombineRefutations g rAcc r, eckAcc || eck) (r, eck) t let text = Layout.showL (NicePrint.dataExprL denv counterExample) let failingWhenClause = refuted |> List.exists (function RefutedWhenClause -> true | _ -> false) - Some(text,failingWhenClause) + Some(text,failingWhenClause,enumCoversKnown) with | CannotRefute -> @@ -689,10 +706,15 @@ let CompilePatternBasic (* Emit the incomplete match warning *) if warnOnIncomplete then match actionOnFailure with - | ThrowIncompleteMatchException -> - warning (MatchIncomplete (false,ShowCounterExample g denv matchm refuted, matchm)) - | IgnoreWithWarning -> - warning (MatchIncomplete (true,ShowCounterExample g denv matchm refuted, matchm)) + | ThrowIncompleteMatchException | IgnoreWithWarning -> + let ignoreWithWarning = (actionOnFailure = IgnoreWithWarning) + match ShowCounterExample g denv matchm refuted with + | Some(text,failingWhenClause,true) -> + warning (EnumMatchIncomplete(ignoreWithWarning, Some(text,failingWhenClause), matchm)) + | Some(text,failingWhenClause,false) -> + warning (MatchIncomplete(ignoreWithWarning, Some(text,failingWhenClause), matchm)) + | None -> + warning (MatchIncomplete(ignoreWithWarning, None, matchm)) | _ -> () diff --git a/src/fsharp/PatternMatchCompilation.fsi b/src/fsharp/PatternMatchCompilation.fsi index f2cbce1e99..160396caf0 100755 --- a/src/fsharp/PatternMatchCompilation.fsi +++ b/src/fsharp/PatternMatchCompilation.fsi @@ -67,3 +67,4 @@ val internal CompilePattern : exception internal MatchIncomplete of bool * (string * bool) option * range exception internal RuleNeverMatched of range +exception internal EnumMatchIncomplete of bool * (string * bool) option * range \ No newline at end of file diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index e999a80912..c22fb3f409 100755 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -1191,7 +1191,7 @@ and CheckBinding cenv env alwaysCheckNoReraise (TBind(v,bindRhs,_) as bind) = // If we've already recorded a definition then skip this match v.ReflectedDefinition with - | None -> v.val_defn <- Some bindRhs + | None -> v.SetValDefn bindRhs | Some _ -> () // Run the conversion process over the reflected definition to report any errors in the // front end rather than the back end. We currently re-run this during ilxgen.fs but there's diff --git a/src/fsharp/SignatureConformance.fs b/src/fsharp/SignatureConformance.fs index 21d2fd0613..e4e8fc4252 100644 --- a/src/fsharp/SignatureConformance.fs +++ b/src/fsharp/SignatureConformance.fs @@ -291,7 +291,7 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = elif not (checkValInfo aenv (err denv) implVal sigVal) then false elif not (implVal.IsExtensionMember = sigVal.IsExtensionMember) then err denv (FSComp.SR.ValueNotContainedMutabilityExtensionsDiffer) elif not (checkMemberDatasConform (err denv) (implVal.Attribs, implVal,implVal.MemberInfo) (sigVal.Attribs,sigVal,sigVal.MemberInfo)) then false - else checkAttribs aenv implVal.Attribs sigVal.Attribs (fun attribs -> implVal.val_attribs <- attribs) + else checkAttribs aenv implVal.Attribs sigVal.Attribs (fun attribs -> implVal.SetAttribs attribs) and checkExnInfo err aenv implTypeRepr sigTypeRepr = diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index e12c21f52b..31f0b9790d 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1451,7 +1451,7 @@ let tryDestRefTupleTy g ty = type UncurriedArgInfos = (TType * ArgReprInfo) list type CurriedArgInfos = (TType * ArgReprInfo) list list -// A 'tau' type is one with its type paramaeters stripped off +// A 'tau' type is one with its type parameters stripped off let GetTopTauTypeInFSharpForm g (curriedArgInfos: ArgReprInfo list list) tau m = let nArgInfos = curriedArgInfos.Length let argtys, rty = stripFunTyN g nArgInfos tau @@ -4632,14 +4632,23 @@ and remapValReprInfo g tmenv (ValReprInfo(tpNames, arginfosl, retInfo)) = and remapValData g tmenv (d: ValData) = let ty = d.val_type - let topValInfo = d.val_repr_info - let ty' = ty |> remapPossibleForallTy g tmenv + let topValInfo = d.ValReprInfo + let tyR = ty |> remapPossibleForallTy g tmenv + let declaringEntityR = d.DeclaringEntity |> remapParentRef tmenv + let reprInfoR = d.ValReprInfo |> Option.map (remapValReprInfo g tmenv) + let memberInfoR = d.MemberInfo |> Option.map (remapMemberInfo g d.val_range topValInfo ty tyR tmenv) + let attribsR = d.Attribs |> remapAttribs g tmenv { d with - val_type = ty'; - val_declaring_entity = d.val_declaring_entity |> remapParentRef tmenv; - val_repr_info = d.val_repr_info |> Option.map (remapValReprInfo g tmenv); - val_member_info = d.val_member_info |> Option.map (remapMemberInfo g d.val_range topValInfo ty ty' tmenv); - val_attribs = d.val_attribs |> remapAttribs g tmenv } + val_type = tyR + val_opt_data = + match d.val_opt_data with + | Some dd -> + Some { dd with + val_declaring_entity = declaringEntityR + val_repr_info = reprInfoR + val_member_info = memberInfoR + val_attribs = attribsR } + | None -> None } and remapParentRef tyenv p = match p with @@ -5021,14 +5030,19 @@ and copyAndRemapAndBindTyconsAndVals g compgen tmenv tycons vs = (tycons, tycons') ||> List.iter2 (fun tcd tcd' -> let tps', tmenvinner2 = tmenvCopyRemapAndBindTypars (remapAttribs g tmenvinner) tmenvinner (tcd.entity_typars.Force(tcd.entity_range)) - tcd'.entity_typars <- LazyWithContext.NotLazy tps'; - tcd'.entity_attribs <- tcd.entity_attribs |> remapAttribs g tmenvinner2; - tcd'.entity_tycon_repr <- tcd.entity_tycon_repr |> remapTyconRepr g tmenvinner2; - tcd'.entity_tycon_abbrev <- tcd.entity_tycon_abbrev |> Option.map (remapType tmenvinner2) ; - tcd'.entity_tycon_tcaug <- tcd.entity_tycon_tcaug |> remapTyconAug tmenvinner2 ; + tcd'.entity_typars <- LazyWithContext.NotLazy tps' + tcd'.entity_attribs <- tcd.entity_attribs |> remapAttribs g tmenvinner2 + tcd'.entity_tycon_repr <- tcd.entity_tycon_repr |> remapTyconRepr g tmenvinner2 + let typeAbbrevR = tcd.TypeAbbrev |> Option.map (remapType tmenvinner2) + tcd'.entity_tycon_tcaug <- tcd.entity_tycon_tcaug |> remapTyconAug tmenvinner2 tcd'.entity_modul_contents <- MaybeLazy.Strict (tcd.entity_modul_contents.Value - |> mapImmediateValsAndTycons lookupTycon lookupVal); - tcd'.entity_exn_info <- tcd.entity_exn_info |> remapTyconExnInfo g tmenvinner2) ; + |> mapImmediateValsAndTycons lookupTycon lookupVal) + let exnInfoR = tcd.ExceptionInfo |> remapTyconExnInfo g tmenvinner2 + match tcd'.entity_opt_data with + | Some optData -> tcd'.entity_opt_data <- Some { optData with entity_tycon_abbrev = typeAbbrevR; entity_exn_info = exnInfoR } + | _ -> + tcd'.SetTypeAbbrev typeAbbrevR + tcd'.SetExceptionInfo exnInfoR) tycons', vs', tmenvinner @@ -6997,8 +7011,8 @@ let etaExpandTypeLambda g m tps (tm, ty) = if isNil tps then tm else mkTypeLambda m tps (mkApps g ((tm, ty), [(List.map mkTyparTy tps)], [], m), ty) let AdjustValToTopVal (tmp:Val) parent valData = - tmp.SetValReprInfo (Some valData); - tmp.val_declaring_entity <- parent; + tmp.SetValReprInfo (Some valData) + tmp.SetDeclaringEntity parent tmp.SetIsMemberOrModuleBinding() /// For match with only one non-failing target T0, the other targets, T1... failing (say, raise exception). @@ -7764,17 +7778,26 @@ let MakeExportRemapping viewedCcu (mspec:ModuleOrNamespace) = let rec remapEntityDataToNonLocal g tmenv (d: Entity) = let tps', tmenvinner = tmenvCopyRemapAndBindTypars (remapAttribs g tmenv) tmenv (d.entity_typars.Force(d.entity_range)) - + let typarsR = LazyWithContext.NotLazy tps' + let attribsR = d.entity_attribs |> remapAttribs g tmenvinner + let tyconReprR = d.entity_tycon_repr |> remapTyconRepr g tmenvinner + let tyconAbbrevR = d.TypeAbbrev |> Option.map (remapType tmenvinner) + let tyconTcaugR = d.entity_tycon_tcaug |> remapTyconAug tmenvinner + let modulContentsR = + MaybeLazy.Strict (d.entity_modul_contents.Value + |> mapImmediateValsAndTycons (remapTyconToNonLocal g tmenv) (remapValToNonLocal g tmenv)) + let exnInfoR = d.ExceptionInfo |> remapTyconExnInfo g tmenvinner { d with - entity_typars = LazyWithContext.NotLazy tps'; - entity_attribs = d.entity_attribs |> remapAttribs g tmenvinner; - entity_tycon_repr = d.entity_tycon_repr |> remapTyconRepr g tmenvinner; - entity_tycon_abbrev = d.entity_tycon_abbrev |> Option.map (remapType tmenvinner) ; - entity_tycon_tcaug = d.entity_tycon_tcaug |> remapTyconAug tmenvinner ; - entity_modul_contents = - MaybeLazy.Strict (d.entity_modul_contents.Value - |> mapImmediateValsAndTycons (remapTyconToNonLocal g tmenv) (remapValToNonLocal g tmenv)); - entity_exn_info = d.entity_exn_info |> remapTyconExnInfo g tmenvinner} + entity_typars = typarsR + entity_attribs = attribsR + entity_tycon_repr = tyconReprR + entity_tycon_tcaug = tyconTcaugR + entity_modul_contents = modulContentsR + entity_opt_data = + match d.entity_opt_data with + | Some dd -> + Some { dd with entity_tycon_abbrev = tyconAbbrevR; entity_exn_info = exnInfoR } + | _ -> None } and remapTyconToNonLocal g tmenv x = x |> NewModifiedTycon (remapEntityDataToNonLocal g tmenv) diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index 6e8c485c9a..118c14d33b 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -1706,23 +1706,23 @@ and p_rfield_table x st = and p_entity_spec_data (x:Entity) st = p_typar_specs (x.entity_typars.Force(x.entity_range)) st p_string x.entity_logical_name st - p_option p_string x.entity_compiled_name st + p_option p_string x.EntityCompiledName st p_range x.entity_range st p_option p_pubpath x.entity_pubpath st - p_access x.entity_accessiblity st - p_access x.entity_tycon_repr_accessibility st + p_access x.Accessibility st + p_access x.TypeReprAccessibility st p_attribs x.entity_attribs st let flagBit = p_tycon_repr x.entity_tycon_repr st - p_option p_typ x.entity_tycon_abbrev st + p_option p_typ x.TypeAbbrev st p_tcaug x.entity_tycon_tcaug st - p_string x.entity_xmldocsig st - p_kind x.entity_kind st + p_string System.String.Empty st + p_kind x.TypeOrMeasureKind st p_int64 (x.entity_flags.PickledBits ||| (if flagBit then EntityFlags.ReservedBitForPickleFormatTyconReprFlag else 0L)) st p_option p_cpath x.entity_cpath st p_maybe_lazy p_modul_typ x.entity_modul_contents st - p_exnc_repr x.entity_exn_info st + p_exnc_repr x.ExceptionInfo st if st.oInMem then - p_used_space1 (p_xmldoc x.entity_xmldoc) st + p_used_space1 (p_xmldoc x.XmlDoc) st else p_space 1 () st @@ -1812,20 +1812,20 @@ and p_vrefFlags x st = and p_ValData x st = p_string x.val_logical_name st - p_option p_string x.val_compiled_name st + p_option p_string x.ValCompiledName st // only keep range information on published values, not on optimization data - p_ranges (if x.val_repr_info.IsSome then Some(x.val_range, x.DefinitionRange) else None) st + p_ranges (x.ValReprInfo |> Option.map (fun _ -> x.val_range, x.DefinitionRange)) st p_typ x.val_type st p_int64 x.val_flags.PickledBits st - p_option p_member_info x.val_member_info st - p_attribs x.val_attribs st - p_option p_ValReprInfo x.val_repr_info st - p_string x.val_xmldocsig st - p_access x.val_access st - p_parentref x.val_declaring_entity st - p_option p_const x.val_const st + p_option p_member_info x.MemberInfo st + p_attribs x.Attribs st + p_option p_ValReprInfo x.ValReprInfo st + p_string x.XmlDocSig st + p_access x.Accessibility st + p_parentref x.DeclaringEntity st + p_option p_const x.LiteralValue st if st.oInMem then - p_used_space1 (p_xmldoc x.val_xmldoc) st + p_used_space1 (p_xmldoc x.XmlDoc) st else p_space 1 () st @@ -1959,7 +1959,7 @@ and u_recdfield_spec st = and u_rfield_table st = MakeRecdFieldsTable (u_list u_recdfield_spec st) and u_entity_spec_data st : Entity = - let x1,x2a,x2b,x2c,x3,(x4a,x4b),x6,x7f,x8,x9,x10,x10b,x11,x12,x13,x14,x15 = + let x1,x2a,x2b,x2c,x3,(x4a,x4b),x6,x7f,x8,x9,_x10,x10b,x11,x12,x13,x14,x15 = u_tup17 u_typar_specs u_string @@ -1986,25 +1986,20 @@ and u_entity_spec_data st : Entity = { entity_typars=LazyWithContext.NotLazy x1 entity_stamp=newStamp() entity_logical_name=x2a - entity_compiled_name=x2b entity_range=x2c - entity_other_range=None entity_pubpath=x3 - entity_accessiblity=x4a - entity_tycon_repr_accessibility=x4b entity_attribs=x6 entity_tycon_repr=x7 - entity_tycon_abbrev=x8 entity_tycon_tcaug=x9 - entity_xmldoc= defaultArg x15 XmlDoc.Empty - entity_xmldocsig=x10 - entity_kind=x10b entity_flags=EntityFlags(x11) entity_cpath=x12 entity_modul_contents=MaybeLazy.Lazy x13 - entity_exn_info=x14 entity_il_repr_cache=newCache() - } + entity_opt_data= + match x2b, x10b, x15, x8, x4a, x4b, x14 with + | None, TyparKind.Type, None, None, TAccess [], TAccess [], TExnNone -> None + | _ -> Some { Entity.EmptyEntityOptData with entity_compiled_name = x2b; entity_kind = x10b; entity_xmldoc= defaultArg x15 XmlDoc.Empty; entity_xmldocsig = System.String.Empty; entity_tycon_abbrev = x8; entity_accessiblity = x4a; entity_tycon_repr_accessibility = x4b; entity_exn_info = x14 } + } and u_tcaug st = let a1,a2,a3,b2,c,d,e,g,_space = @@ -2121,22 +2116,27 @@ and u_ValData st = (u_option u_const) (u_used_space1 u_xmldoc) st - { val_logical_name=x1 - val_compiled_name=x1z - val_range=(match x1a with None -> range0 | Some(a,_) -> a) - val_other_range=(match x1a with None -> None | Some(_,b) -> Some(b,true)) - val_type=x2 - val_stamp=newStamp() - val_flags=ValFlags(x4) - val_defn = None - val_member_info=x8 - val_attribs=x9 - val_repr_info=x10 - val_xmldoc= defaultArg x15 XmlDoc.Empty - val_xmldocsig=x12 - val_access=x13 - val_declaring_entity=x13b - val_const=x14 + + { val_logical_name = x1 + val_range = (match x1a with None -> range0 | Some(a,_) -> a) + val_type = x2 + val_stamp = newStamp() + val_flags = ValFlags(x4) + val_opt_data = + match x1z, x1a, x10, x14, x13, x15, x8, x13b, x12, x9 with + | None, None, None, None, TAccess [], None, None, ParentNone, "", [] -> None + | _ -> + Some { val_compiled_name = x1z + val_other_range = (match x1a with None -> None | Some(_,b) -> Some(b,true)) + val_defn = None + val_repr_info = x10 + val_const = x14 + val_access = x13 + val_xmldoc = defaultArg x15 XmlDoc.Empty + val_member_info = x8 + val_declaring_entity = x13b + val_xmldocsig = x12 + val_attribs = x9 } } and u_Val st = u_osgn_decl st.ivals u_ValData st diff --git a/src/fsharp/TcGlobals.fs b/src/fsharp/TcGlobals.fs index 72c8fbb0a7..64ea4e96d6 100755 --- a/src/fsharp/TcGlobals.fs +++ b/src/fsharp/TcGlobals.fs @@ -719,9 +719,9 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d | res -> res mkILCustomAttrs (attrs.AsList @ attribs) - let addMethodGeneratedAttrs (mdef:ILMethodDef) = {mdef with CustomAttrs = addGeneratedAttrs mdef.CustomAttrs} - let addPropertyGeneratedAttrs (pdef:ILPropertyDef) = {pdef with CustomAttrs = addGeneratedAttrs pdef.CustomAttrs} - let addFieldGeneratedAttrs (fdef:ILFieldDef) = {fdef with CustomAttrs = addGeneratedAttrs fdef.CustomAttrs} + let addMethodGeneratedAttrs (mdef:ILMethodDef) = mdef.With(customAttrs = addGeneratedAttrs mdef.CustomAttrs) + let addPropertyGeneratedAttrs (pdef:ILPropertyDef) = pdef.With(customAttrs = addGeneratedAttrs pdef.CustomAttrs) + let addFieldGeneratedAttrs (fdef:ILFieldDef) = fdef.With(customAttrs = addGeneratedAttrs fdef.CustomAttrs) let tref_DebuggerBrowsableAttribute n = let typ_DebuggerBrowsableState = @@ -738,8 +738,8 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d | Some res -> res let addNeverAttrs (attrs: ILAttributes) = mkILCustomAttrs (attrs.AsList @ [mkDebuggerBrowsableNeverAttribute()]) - let addPropertyNeverAttrs (pdef:ILPropertyDef) = {pdef with CustomAttrs = addNeverAttrs pdef.CustomAttrs} - let addFieldNeverAttrs (fdef:ILFieldDef) = {fdef with CustomAttrs = addNeverAttrs fdef.CustomAttrs} + let addPropertyNeverAttrs (pdef:ILPropertyDef) = pdef.With(customAttrs = addNeverAttrs pdef.CustomAttrs) + let addFieldNeverAttrs (fdef:ILFieldDef) = fdef.With(customAttrs = addNeverAttrs fdef.CustomAttrs) let mkDebuggerTypeProxyAttribute (ty : ILType) = mkILCustomAttribute ilg (findSysILTypeRef tname_DebuggerTypeProxyAttribute, [ilg.typ_Type], [ILAttribElem.TypeRef (Some ty.TypeRef)], []) let betterTyconEntries = diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 3a1fa009c4..eb3e39783a 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -388,11 +388,10 @@ let addInternalsAccessibility env (ccu:CcuThunk) = eAccessRights = computeAccessRights env.eAccessPath eInternalsVisibleCompPaths env.eFamilyType // update this computed field eInternalsVisibleCompPaths = compPath :: env.eInternalsVisibleCompPaths } -let ModifyNameResEnv f env = { env with eNameResEnv = f env.eNameResEnv } - let AddLocalValPrimitive (v:Val) env = - let env = ModifyNameResEnv (fun nenv -> AddValRefToNameEnv nenv (mkLocalValRef v)) env - { env with eUngeneralizableItems = addFreeItemOfTy v.Type env.eUngeneralizableItems } + { env with + eNameResEnv = AddValRefToNameEnv env.eNameResEnv (mkLocalValRef v) + eUngeneralizableItems = addFreeItemOfTy v.Type env.eUngeneralizableItems } let AddLocalValMap tcSink scopem (vals:Val NameMap) env = @@ -400,8 +399,9 @@ let AddLocalValMap tcSink scopem (vals:Val NameMap) env = if vals.IsEmpty then env else - let env = ModifyNameResEnv (AddValMapToNameEnv vals) env - { env with eUngeneralizableItems = NameMap.foldBackRange (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems } + { env with + eNameResEnv = AddValMapToNameEnv vals env.eNameResEnv + eUngeneralizableItems = NameMap.foldBackRange (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems } CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) env @@ -410,19 +410,21 @@ let AddLocalVals tcSink scopem (vals:Val list) env = if isNil vals then env else - let env = ModifyNameResEnv (AddValListToNameEnv vals) env - { env with eUngeneralizableItems = List.foldBack (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems } + { env with + eNameResEnv = AddValListToNameEnv vals env.eNameResEnv + eUngeneralizableItems = List.foldBack (typeOfVal >> addFreeItemOfTy) vals env.eUngeneralizableItems } CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) env -let AddLocalVal tcSink scopem v env = - let env = ModifyNameResEnv (fun nenv -> AddValRefToNameEnv nenv (mkLocalValRef v)) env - let env = {env with eUngeneralizableItems = addFreeItemOfTy v.Type env.eUngeneralizableItems } +let AddLocalVal tcSink scopem v env = + let env = { env with + eNameResEnv = AddValRefToNameEnv env.eNameResEnv (mkLocalValRef v) + eUngeneralizableItems = addFreeItemOfTy v.Type env.eUngeneralizableItems } CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) env let AddLocalExnDefnAndReport tcSink scopem env (exnc:Tycon) = - let env = ModifyNameResEnv (fun nenv -> AddExceptionDeclsToNameEnv BulkAdd.No nenv (mkLocalEntityRef exnc)) env + 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) @@ -430,7 +432,7 @@ let AddLocalExnDefnAndReport tcSink scopem env (exnc:Tycon) = let AddLocalTyconRefs ownDefinition g amap m tcrefs env = if isNil tcrefs then env else - env |> ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.No ownDefinition g amap m false nenv tcrefs) + { env with eNameResEnv = AddTyconRefsToNameEnv BulkAdd.No ownDefinition g amap m false env.eNameResEnv tcrefs } let AddLocalTycons g amap m (tycons: Tycon list) env = if isNil tycons then env else @@ -448,14 +450,14 @@ let AddLocalTyconsAndReport tcSink scopem g amap m tycons env = let OpenModulesOrNamespaces tcSink g amap scopem root env mvvs openDeclaration = let env = if isNil mvvs then env else - ModifyNameResEnv (fun nenv -> AddModulesAndNamespacesContentsToNameEnv g amap env.eAccessRights scopem root nenv mvvs) env + { env with eNameResEnv = AddModulesAndNamespacesContentsToNameEnv g amap env.eAccessRights scopem root env.eNameResEnv mvvs } CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) CallOpenDeclarationSink tcSink openDeclaration env let AddRootModuleOrNamespaceRefs g amap m env modrefs = if isNil modrefs then env else - ModifyNameResEnv (fun nenv -> AddModuleOrNamespaceRefsToNameEnv g amap m true env.eAccessRights nenv modrefs) env + { env with eNameResEnv = AddModuleOrNamespaceRefsToNameEnv g amap m true env.eAccessRights env.eNameResEnv modrefs } let AddNonLocalCcu g amap scopem env assemblyName (ccu:CcuThunk, internalsVisibleToAttributes) = @@ -476,7 +478,7 @@ let AddNonLocalCcu g amap scopem env assemblyName (ccu:CcuThunk, internalsVisib let env = AddRootModuleOrNamespaceRefs g amap scopem env modrefs let env = if isNil tcrefs then env else - ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.Yes false g amap scopem true nenv tcrefs) env + { env with eNameResEnv = AddTyconRefsToNameEnv BulkAdd.Yes false g amap scopem true env.eNameResEnv tcrefs } //CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) env @@ -486,25 +488,26 @@ let AddLocalRootModuleOrNamespace tcSink g amap scopem env (mtyp:ModuleOrNamespa // Compute the top-rooted type definitions let tcrefs = mtyp.TypeAndExceptionDefinitions |> List.map mkLocalTyconRef let env = AddRootModuleOrNamespaceRefs g amap scopem env modrefs - let env = - if isNil tcrefs then env else - ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.No false g amap scopem true nenv tcrefs) env - let env = { env with eUngeneralizableItems = addFreeItemOfModuleTy mtyp env.eUngeneralizableItems } + let env = { env with + eNameResEnv = if isNil tcrefs then env.eNameResEnv else AddTyconRefsToNameEnv BulkAdd.No false g amap scopem true env.eNameResEnv tcrefs + eUngeneralizableItems = addFreeItemOfModuleTy mtyp env.eUngeneralizableItems } CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights) env let AddModuleAbbreviationAndReport tcSink scopem id modrefs env = let env = if isNil modrefs then env else - ModifyNameResEnv (fun nenv -> AddModuleAbbrevToNameEnv id nenv modrefs) env + { env with eNameResEnv = AddModuleAbbrevToNameEnv id env.eNameResEnv modrefs } + 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) env let AddLocalSubModule g amap m env (modul:ModuleOrNamespace) = - let env = ModifyNameResEnv (fun nenv -> AddModuleOrNamespaceRefToNameEnv g amap m false env.eAccessRights nenv (mkLocalModRef modul)) env - let env = { env with eUngeneralizableItems = addFreeItemOfModuleTy modul.ModuleOrNamespaceType env.eUngeneralizableItems } + let env = { env with + eNameResEnv = AddModuleOrNamespaceRefToNameEnv g amap m false env.eAccessRights env.eNameResEnv (mkLocalModRef modul) + eUngeneralizableItems = addFreeItemOfModuleTy modul.ModuleOrNamespaceType env.eUngeneralizableItems } env let AddLocalSubModuleAndReport tcSink scopem g amap m env (modul:ModuleOrNamespace) = @@ -518,7 +521,7 @@ let RegisterDeclaredTypars typars env = let AddDeclaredTypars check typars env = if isNil typars then env else - let env = ModifyNameResEnv (fun nenv -> AddDeclaredTyparsToNameEnv check nenv typars) env + let env = { env with eNameResEnv = AddDeclaredTyparsToNameEnv check env.eNameResEnv typars } RegisterDeclaredTypars typars env /// Compilation environment for typechecking a single file in an assembly. Contains the @@ -694,13 +697,16 @@ let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath env = | Some(_, rest) -> rest | None -> enclosingNamespacePath - let ad = env.eAccessRights - match ResolveLongIndentAsModuleOrNamespace tcSink ResultCollectionSettings.AllResults amap scopem OpenQualified env.eNameResEnv ad enclosingNamespacePathToOpen true with - | Result modrefs -> - let modrefs = List.map p23 modrefs - let openDecl = OpenDeclaration.Create (enclosingNamespacePathToOpen, modrefs, scopem, true) - OpenModulesOrNamespaces tcSink g amap scopem false env modrefs openDecl - | Exception _ -> env + match enclosingNamespacePathToOpen with + | id::rest -> + let ad = env.eAccessRights + match ResolveLongIndentAsModuleOrNamespace tcSink ResultCollectionSettings.AllResults amap scopem true OpenQualified env.eNameResEnv ad id rest true with + | Result modrefs -> + let modrefs = List.map p23 modrefs + let openDecl = OpenDeclaration.Create (enclosingNamespacePathToOpen, modrefs, scopem, true) + OpenModulesOrNamespaces tcSink g amap scopem false env modrefs openDecl + | Exception _ -> env + | _ -> env //------------------------------------------------------------------------- @@ -1405,32 +1411,34 @@ let ComputeAccessAndCompPath env declKindOpt m vis overrideVis actualParent = let cpath = if accessModPermitted then Some env.eCompPath else None vis, cpath -let CheckForAbnormalOperatorNames cenv (idRange:range) opName isMember = - if (idRange.EndColumn - idRange.StartColumn <= 5) && - not cenv.g.compilingFslib +let CheckForAbnormalOperatorNames cenv (idRange:range) coreDisplayName (memberInfoOpt: ValMemberInfo option) = + if (idRange.EndColumn - idRange.StartColumn <= 5) && + not cenv.g.compilingFslib then - match opName with + let opName = DecompileOpName coreDisplayName + let isMember = memberInfoOpt.IsSome + match opName with | PrettyNaming.Relational -> if isMember then - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMethodNameForRelationalOperator(opName, (CompileOpName opName)), idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMethodNameForRelationalOperator(opName, coreDisplayName), idRange)) else - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinitionRelational(opName), idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinitionRelational opName, idRange)) | PrettyNaming.Equality -> if isMember then - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMethodNameForEquality(opName, (CompileOpName opName)), idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMethodNameForEquality(opName, coreDisplayName), idRange)) else - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinitionEquality(opName), idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinitionEquality opName, idRange)) | PrettyNaming.Control -> if isMember then - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberName(opName, (CompileOpName opName)), idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberName(opName, coreDisplayName), idRange)) else - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinition(opName), idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidOperatorDefinition opName, idRange)) | PrettyNaming.Indexer -> if not isMember then - error(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidIndexOperatorDefinition(opName), idRange)) + error(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidIndexOperatorDefinition opName, idRange)) | PrettyNaming.FixedTypes -> if isMember then - warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberNameFixedTypes(opName), idRange)) + warning(StandardOperatorRedefinitionWarning(FSComp.SR.tcInvalidMemberNameFixedTypes opName, idRange)) | PrettyNaming.Other -> () let MakeAndPublishVal cenv env (altActualParent, inSig, declKind, vrec, (ValScheme(id, typeScheme, topValData, memberInfoOpt, isMutable, inlineFlag, baseOrThis, vis, compgen, isIncrClass, isTyFunc, hasDeclaredTypars)), attrs, doc, konst, isGeneratedEventVal) = @@ -1537,7 +1545,7 @@ let MakeAndPublishVal cenv env (altActualParent, inSig, declKind, vrec, (ValSche (hasDeclaredTypars || inSig), isGeneratedEventVal, konst, actualParent) - CheckForAbnormalOperatorNames cenv id.idRange (DecompileOpName vspec.CoreDisplayName) (Option.isSome memberInfoOpt) + CheckForAbnormalOperatorNames cenv id.idRange vspec.CoreDisplayName memberInfoOpt PublishValueDefn cenv env declKind vspec @@ -2810,7 +2818,7 @@ let TcVal checkAttributes cenv env tpenv (vref:ValRef) optInst optAfterResolutio // If we have got an explicit instantiation then use that | Some(vrefFlags, checkTys) -> let checkInst (tinst:TypeInst) = - if not v.IsMember && not v.PermitsExplicitTypeInstantiation && tinst.Length > 0 && v.Typars.Length > 0 then + if not v.IsMember && not v.PermitsExplicitTypeInstantiation && not (List.isEmpty tinst) && not (List.isEmpty v.Typars) then warning(Error(FSComp.SR.tcDoesNotAllowExplicitTypeArguments(v.DisplayName), m)) match vrec with | ValInRecScope false -> @@ -5107,7 +5115,7 @@ and TcPatBindingName cenv env id ty isMemberThis vis1 topValData (inlineFlag, de // isLeftMost indicates we are processing the left-most path through a disjunctive or pattern. // For those binding locations, CallNameResolutionSink is called in MakeAndPublishValue, like all other bindings // For non-left-most paths, we register the name resolutions here - if not isLeftMost && not vspec.IsCompilerGenerated && not (String.hasPrefix vspec.LogicalName "_") then + if not isLeftMost && not vspec.IsCompilerGenerated && not (vspec.LogicalName.StartsWith "_") then let item = Item.Value(mkLocalValRef vspec) CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.eAccessRights) @@ -6800,7 +6808,7 @@ and TcConstExpr cenv overallTy env m tpenv c = let expr = let modName = "NumericLiteral" + suffix let ad = env.eAccessRights - match ResolveLongIndentAsModuleOrNamespace cenv.tcSink ResultCollectionSettings.AtMostOneResult cenv.amap m OpenQualified env.eNameResEnv ad [ident (modName, m)] false with + match ResolveLongIndentAsModuleOrNamespace cenv.tcSink ResultCollectionSettings.AtMostOneResult cenv.amap m true OpenQualified env.eNameResEnv ad (ident (modName, m)) [] false with | Result [] | Exception _ -> error(Error(FSComp.SR.tcNumericLiteralRequiresModule(modName), m)) | Result ((_, mref, _) :: _) -> @@ -7243,8 +7251,12 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv /// for all custom operations. This adds them to the completion lists and prevents them being used as values inside /// the query. let env = - env |> ModifyNameResEnv (fun nenv -> (nenv, customOperationMethods) ||> Seq.fold (fun nenv (nm, _, _, _, _, _, _, _, methInfo) -> - AddFakeNameToNameEnv nm nenv (Item.CustomOperation (nm, (fun () -> customOpUsageText (ident (nm, mBuilderVal))), Some methInfo)))) + if List.isEmpty customOperationMethods then env else + { env with + eNameResEnv = + (env.eNameResEnv, customOperationMethods) + ||> Seq.fold (fun nenv (nm, _, _, _, _, _, _, _, methInfo) -> + AddFakeNameToNameEnv nm nenv (Item.CustomOperation (nm, (fun () -> customOpUsageText (ident (nm, mBuilderVal))), Some methInfo))) } // Environment is needed for completions CallEnvSink cenv.tcSink (comp.Range, env.NameEnv, ad) @@ -7493,13 +7505,13 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv | StripApps(SingleIdent nm, [StripApps(SingleIdent nm2, args); arg2]) when PrettyNaming.IsInfixOperator nm.idText && expectedArgCountForCustomOperator nm2 > 0 && - args.Length > 0 -> + not (List.isEmpty args) -> let estimatedRangeOfIntendedLeftAndRightArguments = unionRanges (List.last args).Range arg2.Range errorR(Error(FSComp.SR.tcUnrecognizedQueryBinaryOperator(), estimatedRangeOfIntendedLeftAndRightArguments)) true | SynExpr.Tuple( (StripApps(SingleIdent nm2, args) :: _), _, m) when expectedArgCountForCustomOperator nm2 > 0 && - args.Length > 0 -> + not (List.isEmpty args) -> let estimatedRangeOfIntendedLeftAndRightArguments = unionRanges (List.last args).Range m.EndRange errorR(Error(FSComp.SR.tcUnrecognizedQueryBinaryOperator(), estimatedRangeOfIntendedLeftAndRightArguments)) true @@ -10409,7 +10421,7 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt 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)) - ModifyNameResEnv (fun nenv -> AddActivePatternResultTagsToNameEnv apinfo nenv ty m) envinner + { envinner with eNameResEnv = AddActivePatternResultTagsToNameEnv apinfo envinner.eNameResEnv ty m } | None -> envinner @@ -10623,13 +10635,13 @@ and TcAttribute canFail cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = attributeAssignedNamedItems |> List.map (fun (CallerNamedArg(id, CallerArg(argtyv, m, isOpt, callerArgExpr))) -> if isOpt then error(Error(FSComp.SR.tcOptionalArgumentsCannotBeUsedInCustomAttribute(), m)) let m = callerArgExpr.Range - let setterItem, _ = ResolveLongIdentInType cenv.tcSink cenv.nameResolver env.NameEnv LookupKind.Expr m ad [id] IgnoreOverrides TypeNameResolutionInfo.Default ty + let setterItem, _ = ResolveLongIdentInType cenv.tcSink cenv.nameResolver env.NameEnv LookupKind.Expr m ad id IgnoreOverrides TypeNameResolutionInfo.Default ty let nm, isProp, argty = match setterItem with | Item.Property (_, [pinfo]) -> if not pinfo.HasSetter then errorR(Error(FSComp.SR.tcPropertyCannotBeSet0(), m)) - id.idText, true, pinfo.GetPropertyType(cenv.amap, m) + id.idText, true, pinfo.GetPropertyType(cenv.amap, m) | Item.ILField finfo -> CheckILFieldInfoAccessible cenv.g cenv.amap m ad finfo CheckILFieldAttributes cenv.g finfo m @@ -11252,7 +11264,7 @@ and AnalyzeAndMakeAndPublishRecursiveValue overridesOK isGeneratedEventVal cenv let prelimTyscheme = TypeScheme(enclosingDeclaredTypars@declaredTypars, ty) let partialValReprInfo = TranslateTopValSynInfo mBinding (TcAttributes cenv envinner) valSynInfo let topValInfo = UseSyntacticArity declKind prelimTyscheme partialValReprInfo - let hasDeclaredTypars = declaredTypars.Length > 0 + let hasDeclaredTypars = not (List.isEmpty declaredTypars) let prelimValScheme = ValScheme(bindingId, prelimTyscheme, topValInfo, memberInfoOpt, false, inlineFlag, NormalVal, vis, false, false, false, hasDeclaredTypars) // Check the literal r.h.s., if any @@ -12072,10 +12084,13 @@ let TcTyconMemberSpecs cenv env containerInfo declKind tpenv (augSpfn: SynMember let TcModuleOrNamespaceLidAndPermitAutoResolve tcSink env amap (longId : Ident list) = let ad = env.eAccessRights - let m = longId |> List.map (fun id -> id.idRange) |> List.reduce unionRanges - match ResolveLongIndentAsModuleOrNamespace tcSink ResultCollectionSettings.AllResults amap m OpenQualified env.eNameResEnv ad longId true with - | Result res -> Result res - | Exception err -> raze err + match longId with + | [] -> Result [] + | id::rest -> + let m = longId |> List.map (fun id -> id.idRange) |> List.reduce unionRanges + match ResolveLongIndentAsModuleOrNamespace tcSink ResultCollectionSettings.AllResults amap m true OpenQualified env.eNameResEnv ad id rest true with + | Result res -> Result res + | Exception err -> raze err let TcOpenDecl tcSink (g:TcGlobals) amap m scopem env (longId : Ident list) = let modrefs = ForceRaise (TcModuleOrNamespaceLidAndPermitAutoResolve tcSink env amap longId) @@ -13572,16 +13587,21 @@ module MutRecBindingChecking = /// Check a "module X = A.B.C" module abbreviation declaration let TcModuleAbbrevDecl (cenv:cenv) scopem env (id, p, m) = let ad = env.eAccessRights - let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace cenv.tcSink ResultCollectionSettings.AllResults cenv.amap m OpenQualified env.eNameResEnv ad p false) - let modrefs = mvvs |> List.map p23 - if modrefs.Length > 0 && modrefs |> List.forall (fun modref -> modref.IsNamespace) then + let resolved = + match p with + | [] -> Result [] + | id::rest -> ResolveLongIndentAsModuleOrNamespace cenv.tcSink ResultCollectionSettings.AllResults cenv.amap m true OpenQualified env.eNameResEnv ad id rest false + let mvvs = ForceRaise resolved + if isNil mvvs then env else + let modrefs = mvvs |> List.map p23 + if not (isNil modrefs) && modrefs |> List.forall (fun modref -> modref.IsNamespace) then errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head modrefs)), m)) let modrefs = modrefs |> List.filter (fun mvv -> not mvv.IsNamespace) + if isNil modrefs then env else modrefs |> List.iter (fun modref -> CheckEntityAttributes cenv.g modref m |> CommitOperationResult) - let env = (if modrefs.Length > 0 then AddModuleAbbreviationAndReport cenv.tcSink scopem id modrefs env else env) + let env = AddModuleAbbreviationAndReport cenv.tcSink scopem id modrefs env env - /// Update the contents accessible via the recursive namespace declaration, if any let TcMutRecDefns_UpdateNSContents mutRecNSInfo = match mutRecNSInfo with @@ -14338,7 +14358,7 @@ module TcExceptionDeclarations = | None -> TExnFresh (MakeRecdFieldsTable args') - exnc.entity_exn_info <- repr + exnc.SetExceptionInfo repr let item = Item.ExnCase(mkLocalTyconRef exnc) CallNameResolutionSink cenv.tcSink (id.idRange, env.NameEnv, item, item, emptyTyparInst, ItemOccurence.Binding, env.DisplayEnv, env.eAccessRights) @@ -14645,10 +14665,10 @@ module EstablishTypeDefinitionCores = tycon.SetIsStructRecordOrUnion isStructRecordOrUnionType // Set the compiled name, if any - tycon.entity_compiled_name <- TryFindFSharpStringAttribute cenv.g cenv.g.attrib_CompiledNameAttribute attrs + tycon.SetCompiledName (TryFindFSharpStringAttribute cenv.g cenv.g.attrib_CompiledNameAttribute attrs) if hasMeasureAttr then - tycon.entity_kind <- TyparKind.Measure + tycon.SetTypeOrMeasureKind TyparKind.Measure if not (isNil typars) then error(Error(FSComp.SR.tcMeasureDefinitionsCannotHaveTypeParameters(), m)) let repr = @@ -14970,7 +14990,7 @@ module EstablishTypeDefinitionCores = errorR(Deprecated(FSComp.SR.tcTypeAbbreviationHasTypeParametersMissingOnType(), tycon.Range)) if firstPass then - tycon.entity_tycon_abbrev <- Some ty + tycon.SetTypeAbbrev (Some ty) | _ -> () @@ -15128,10 +15148,10 @@ module EstablishTypeDefinitionCores = if allowed then if kind = explicitKind then warning(PossibleUnverifiableCode(m)) - elif thisTyconRef.Typars(m).Length > 0 then - errorR (Error(FSComp.SR.tcGenericTypesCannotHaveStructLayout(), m)) - else + elif List.isEmpty (thisTyconRef.Typars m) then errorR (Error(FSComp.SR.tcOnlyStructsCanHaveStructLayout(), m)) + else + errorR (Error(FSComp.SR.tcGenericTypesCannotHaveStructLayout(), m)) | None -> () let hiddenReprChecks(hasRepr) = @@ -15487,7 +15507,7 @@ module EstablishTypeDefinitionCores = graph.IterateCycles (fun path -> let tycon = path.Head // The thing is cyclic. Set the abbreviation and representation to be "None" to stop later VS crashes - tycon.entity_tycon_abbrev <- None + tycon.SetTypeAbbrev None tycon.entity_tycon_repr <- TNoRepr errorR(Error(FSComp.SR.tcTypeDefinitionIsCyclic(), tycon.Range))) @@ -15622,7 +15642,7 @@ module EstablishTypeDefinitionCores = graph.IterateCycles (fun path -> let tycon = path.Head // The thing is cyclic. Set the abbreviation and representation to be "None" to stop later VS crashes - tycon.entity_tycon_abbrev <- None + tycon.SetTypeAbbrev None tycon.entity_tycon_repr <- TNoRepr errorR(Error(FSComp.SR.tcTypeDefinitionIsCyclicThroughInheritance(), tycon.Range))) @@ -16355,20 +16375,23 @@ let rec TcSignatureElementNonMutRec cenv parent typeNames endm (env: TcEnv) synS | SynModuleSigDecl.ModuleAbbrev (id, p, m) -> let ad = env.eAccessRights - let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace cenv.tcSink ResultCollectionSettings.AllResults cenv.amap m OpenQualified env.eNameResEnv ad p false) + let resolved = + match p with + | [] -> Result [] + | id::rest -> ResolveLongIndentAsModuleOrNamespace cenv.tcSink ResultCollectionSettings.AllResults cenv.amap m true OpenQualified env.eNameResEnv ad id rest false + let mvvs = ForceRaise resolved let scopem = unionRanges m endm let unfilteredModrefs = mvvs |> List.map p23 let modrefs = unfilteredModrefs |> List.filter (fun modref -> not modref.IsNamespace) - if unfilteredModrefs.Length > 0 && List.isEmpty modrefs then + if not (List.isEmpty unfilteredModrefs) && List.isEmpty modrefs then errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head unfilteredModrefs)), m)) + if List.isEmpty modrefs then return env else modrefs |> List.iter (fun modref -> CheckEntityAttributes cenv.g modref m |> CommitOperationResult) - let env = - if modrefs.Length > 0 then AddModuleAbbreviationAndReport cenv.tcSink scopem id modrefs env - else env + let env = AddModuleAbbreviationAndReport cenv.tcSink scopem id modrefs env return env | SynModuleSigDecl.HashDirective _ -> diff --git a/src/fsharp/UnicodeLexing.fs b/src/fsharp/UnicodeLexing.fs index 254eb8dd33..b6013c0342 100755 --- a/src/fsharp/UnicodeLexing.fs +++ b/src/fsharp/UnicodeLexing.fs @@ -47,7 +47,7 @@ let UnicodeFileAsLexbuf (filename,codePage : int option, retryLocked:bool) : Le use reader = match codePage with | None -> new StreamReader(stream,true) - | Some n -> new StreamReader(stream,System.Text.Encoding.GetEncodingShim(n)) + | Some n -> new StreamReader(stream,System.Text.Encoding.GetEncoding(n)) reader.ReadToEnd() with // We can get here if the file is locked--like when VS is saving a file--we don't have direct diff --git a/src/fsharp/ast.fs b/src/fsharp/ast.fs index 2444a699a8..1963b00ed3 100644 --- a/src/fsharp/ast.fs +++ b/src/fsharp/ast.fs @@ -100,7 +100,7 @@ type XmlDoc = | (lineA::rest) as lines -> let lineAT = lineA.TrimStart([|' '|]) if lineAT = "" then processLines rest - else if String.hasPrefix lineAT "<" then lines + else if lineAT.StartsWith "<" then lines else [""] @ (lines |> List.map (fun line -> Microsoft.FSharp.Core.XmlAdapters.escape(line))) @ [""] diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs index 345071f35e..c4c9357ed6 100755 --- a/src/fsharp/fsc.fs +++ b/src/fsharp/fsc.fs @@ -30,6 +30,7 @@ open Internal.Utilities.Filename open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics @@ -167,10 +168,6 @@ type DisposablesTracker() = try i.Dispose() with _ -> () -//---------------------------------------------------------------------------- -// TypeCheck, AdjustForScriptCompile -//---------------------------------------------------------------------------- - let TypeCheck (ctok, tcConfig, tcImports, tcGlobals, errorLogger:ErrorLogger, assemblyName, niceNameGen, tcEnv0, inputs, exiter: Exiter) = try if isNil inputs then error(Error(FSComp.SR.fscNoImplementationFiles(), Range.rangeStartup)) @@ -206,7 +203,7 @@ let AdjustForScriptCompile(ctok, tcConfigB:TcConfigBuilder, commandLineSourceFil let AppendClosureInformation(filename) = if IsScript filename then - let closure = LoadClosure.ComputeClosureOfSourceFiles(ctok, tcConfig, [filename, rangeStartup], CodeContext.Compilation, lexResourceManager=lexResourceManager) + let closure = LoadClosure.ComputeClosureOfScriptFiles(ctok, tcConfig, [filename, rangeStartup], CodeContext.Compilation, lexResourceManager=lexResourceManager) // Record the references from the analysis of the script. The full resolutions are recorded as the corresponding #I paths used to resolve them // are local to the scripts and not added to the tcConfigB (they are added to localized clones of the tcConfigB). let references = closure.References |> List.collect snd |> List.filter (fun r->r.originalReference.Range<>range0 && r.originalReference.Range<>rangeStartup) @@ -215,7 +212,7 @@ let AdjustForScriptCompile(ctok, tcConfigB:TcConfigBuilder, commandLineSourceFil closure.SourceFiles |> List.map fst |> List.iter AddIfNotPresent closure.AllRootFileDiagnostics |> List.iter diagnosticSink - else AddIfNotPresent(filename) + else AddIfNotPresent(filename) // Find closure of .fsx files. commandLineSourceFiles |> List.iter AppendClosureInformation @@ -437,7 +434,7 @@ let EncodeInterfaceData(tcConfig: TcConfig, tcGlobals, exportRemapping, generate let useDataFiles = (tcConfig.useOptimizationDataFile || tcGlobals.compilingFslib) && not isIncrementalBuild if useDataFiles then let sigDataFileName = (Filename.chopExtension outfile)+".sigdata" - File.WriteAllBytes(sigDataFileName, resource.Bytes) + File.WriteAllBytes(sigDataFileName, resource.GetBytes()) let resources = [ resource ] let sigAttr = mkSignatureDataVersionAttr tcGlobals (IL.parseILVersion Internal.Utilities.FSharpEnvironment.FSharpBinaryMetadataFormatRevision) @@ -770,11 +767,12 @@ module MainModuleBuilder = let systemNumericsAssemblyRef = ILAssemblyRef.Create(refNumericsDllName, aref.Hash, aref.PublicKey, aref.Retargetable, aref.Version, aref.Locale) typesForwardedToSystemNumerics |> Seq.map (fun t -> - { ScopeRef = ILScopeRef.Assembly(systemNumericsAssemblyRef) - Name = t - Attributes = enum(0x00200000) ||| TypeAttributes.Public - Nested = mkILNestedExportedTypes List.empty - CustomAttrs = mkILCustomAttrs List.empty }) |> + { ScopeRef = ILScopeRef.Assembly(systemNumericsAssemblyRef) + Name = t + Attributes = enum(0x00200000) ||| TypeAttributes.Public + Nested = mkILNestedExportedTypes [] + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx }) |> Seq.toList | None -> [] @@ -827,7 +825,7 @@ module MainModuleBuilder = let flags = match AttributeHelpers.TryFindIntAttribute tcGlobals "System.Reflection.AssemblyFlagsAttribute" topAttrs.assemblyAttrs with | Some f -> f | _ -> 0x0 // You're only allowed to set a locale if the assembly is a library - if (locale <> None && locale.Value <> "") && tcConfig.target <> Dll then + if (locale <> None && locale.Value <> "") && tcConfig.target <> CompilerTarget.Dll then error(Error(FSComp.SR.fscAssemblyCultureAttributeError(), rangeCmdArgs)) // Add the type forwarders to any .NET DLL post-.NET-2.0, to give binary compatibility @@ -839,7 +837,7 @@ module MainModuleBuilder = else [] - mkILSimpleModule assemblyName (GetGeneratedILModuleName tcConfig.target assemblyName) (tcConfig.target = Dll || tcConfig.target = Module) tcConfig.subsystemVersion tcConfig.useHighEntropyVA ilTypeDefs hashAlg locale flags (mkILExportedTypes exportedTypesList) metadataVersion + mkILSimpleModule assemblyName (GetGeneratedILModuleName tcConfig.target assemblyName) (tcConfig.target = CompilerTarget.Dll || tcConfig.target = CompilerTarget.Module) tcConfig.subsystemVersion tcConfig.useHighEntropyVA ilTypeDefs hashAlg locale flags (mkILExportedTypes exportedTypesList) metadataVersion let disableJitOptimizations = not (tcConfig.optSettings.jitOpt()) @@ -857,9 +855,10 @@ module MainModuleBuilder = [ ] let reflectedDefinitionResource = { Name=reflectedDefinitionResourceName - Location = ILResourceLocation.Local (fun () -> reflectedDefinitionBytes) + Location = ILResourceLocation.LocalOut reflectedDefinitionBytes Access= ILResourceAccess.Public - CustomAttrs = emptyILCustomAttrs } + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx } reflectedDefinitionAttrs, reflectedDefinitionResource) |> List.unzip |> (fun (attrs, resource) -> List.concat attrs, resource) @@ -878,18 +877,18 @@ module MainModuleBuilder = // Make the manifest of the assembly let manifest = - if tcConfig.target = Module then None else + if tcConfig.target = CompilerTarget.Module then None else let man = mainModule.ManifestOfAssembly let ver = match assemVerFromAttrib with | None -> tcVersion | Some v -> v Some { man with Version= Some ver - CustomAttrs = manifestAttrs + CustomAttrsStored = storeILCustomAttrs manifestAttrs DisableJitOptimizations=disableJitOptimizations JitTracking= tcConfig.jitTracking IgnoreSymbolStoreSequencePoints = tcConfig.ignoreSymbolStoreSequencePoints - SecurityDecls=secDecls } + SecurityDeclsStored=storeILSecurityDecls secDecls } let resources = mkILResources @@ -900,9 +899,10 @@ module MainModuleBuilder = let bytes = FileSystem.ReadAllBytesShim file name, bytes, pub yield { Name=name - Location=ILResourceLocation.Local (fun () -> bytes) + Location=ILResourceLocation.LocalOut bytes Access=pub - CustomAttrs=emptyILCustomAttrs } + CustomAttrsStored=storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx } yield! reflectedDefinitionResources yield! intfDataResources @@ -912,7 +912,8 @@ module MainModuleBuilder = yield { Name=name Location=ILResourceLocation.File(ILModuleRef.Create(name=file, hasMetadata=false, hash=Some (sha1HashBytes (FileSystem.ReadAllBytesShim file))), 0) Access=pub - CustomAttrs=emptyILCustomAttrs } ] + CustomAttrsStored=storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx } ] let assemblyVersion = match tcConfig.version with @@ -1013,30 +1014,31 @@ module MainModuleBuilder = #endif let nativeResources = [ for av in assemblyVersionResources findAttribute assemblyVersion do - yield Lazy<_>.CreateFromValue av + yield ILNativeResource.Out av if not(tcConfig.win32res = "") then - yield Lazy<_>.CreateFromValue (FileSystem.ReadAllBytesShim tcConfig.win32res) + yield ILNativeResource.Out (FileSystem.ReadAllBytesShim tcConfig.win32res) if tcConfig.includewin32manifest && not(win32Manifest = "") && not runningOnMono then - yield Lazy<_>.CreateFromValue [| yield! ResFileFormat.ResFileHeader() - yield! (ManifestResourceFormat.VS_MANIFEST_RESOURCE((FileSystem.ReadAllBytesShim win32Manifest), tcConfig.target = Dll)) |]] + yield ILNativeResource.Out [| yield! ResFileFormat.ResFileHeader() + yield! (ManifestResourceFormat.VS_MANIFEST_RESOURCE((FileSystem.ReadAllBytesShim win32Manifest), tcConfig.target = CompilerTarget.Dll)) |]] // Add attributes, version number, resources etc. {mainModule with StackReserveSize = tcConfig.stackReserveSize - Name = (if tcConfig.target = Module then Filename.fileNameOfPath outfile else mainModule.Name) - SubSystemFlags = (if tcConfig.target = WinExe then 2 else 3) + Name = (if tcConfig.target = CompilerTarget.Module then Filename.fileNameOfPath outfile else mainModule.Name) + SubSystemFlags = (if tcConfig.target = CompilerTarget.WinExe then 2 else 3) Resources= resources ImageBase = (match tcConfig.baseAddress with None -> 0x00400000l | Some b -> b) - IsDLL=(tcConfig.target = Dll || tcConfig.target=Module) + IsDLL=(tcConfig.target = CompilerTarget.Dll || tcConfig.target=CompilerTarget.Module) Platform = tcConfig.platform Is32Bit=(match tcConfig.platform with Some X86 -> true | _ -> false) Is64Bit=(match tcConfig.platform with Some AMD64 | Some IA64 -> true | _ -> false) Is32BitPreferred = if tcConfig.prefer32Bit && not tcConfig.target.IsExe then (error(Error(FSComp.SR.invalidPlatformTarget(), rangeCmdArgs))) else tcConfig.prefer32Bit - CustomAttrs= - mkILCustomAttrs - [ if tcConfig.target = Module then + CustomAttrsStored= + storeILCustomAttrs + (mkILCustomAttrs + [ if tcConfig.target = CompilerTarget.Module then yield! iattrs - yield! codegenResults.ilNetModuleAttrs ] + yield! codegenResults.ilNetModuleAttrs ]) NativeResources=nativeResources Manifest = manifest } @@ -1083,7 +1085,7 @@ module StaticLinker = [ for (_, depILModule) in dependentILModules do match depILModule.Manifest with | Some m -> - for ca in m.CustomAttrs.AsList do + for ca in m.CustomAttrs.AsArray do if ca.Method.MethodRef.DeclaringTypeRef.FullName = typeof.FullName then yield ca | _ -> () ] @@ -1122,7 +1124,6 @@ module StaticLinker = let moduls = ilxMainModule :: (List.map snd dependentILModules) - // NOTE: version resources from statically linked DLLs are dropped in the binary reader/writer let savedNativeResources = [ //yield! ilxMainModule.NativeResources for m in moduls do @@ -1141,8 +1142,8 @@ module StaticLinker = let ilxMainModule = { ilxMainModule with - Manifest = (let m = ilxMainModule.ManifestOfAssembly in Some {m with CustomAttrs = mkILCustomAttrs (m.CustomAttrs.AsList @ savedManifestAttrs) }) - CustomAttrs = mkILCustomAttrs [ for m in moduls do yield! m.CustomAttrs.AsList ] + Manifest = (let m = ilxMainModule.ManifestOfAssembly in Some {m with CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs (m.CustomAttrs.AsList @ savedManifestAttrs)) }) + CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs [ for m in moduls do yield! m.CustomAttrs.AsArray ]) TypeDefs = mkILTypeDefs (topTypeDef :: List.concat normalTypeDefs) Resources = mkILResources (savedResources @ ilxMainModule.Resources.AsList) NativeResources = savedNativeResources } @@ -1159,9 +1160,12 @@ module StaticLinker = let ilBinaryReader = let ilGlobals = mkILGlobals ILScopeRef.Local - let opts = { ILBinaryReader.mkDefault (ilGlobals) with - optimizeForMemory=tcConfig.optimizeForMemory - pdbPath = None } + let opts : ILReaderOptions = + { ilGlobals = ilGlobals + reduceMemoryUsage = tcConfig.reduceMemoryUsage + metadataOnly = MetadataOnlyFlag.No + tryGetMetadataSnapshot = (fun _ -> None) + pdbPath = None } ILBinaryReader.OpenILModuleReader mscorlib40 opts let tdefs1 = ilxMainModule.TypeDefs.AsList |> List.filter (fun td -> not (MainModuleBuilder.injectedCompatTypes.Contains(td.Name))) @@ -1188,14 +1192,14 @@ module StaticLinker = TypeDefs = mkILTypeDefs ([ for td in fakeModule.TypeDefs do - yield {td with - Methods = - td.Methods.AsList - |> List.map (fun md -> - {md with CustomAttrs = - mkILCustomAttrs (td.CustomAttrs.AsList |> List.filter (fun ilattr -> - ilattr.Method.DeclaringType.TypeRef.FullName <> "System.Runtime.TargetedPatchingOptOutAttribute") )}) - |> mkILMethods } ])} + let meths = td.Methods.AsList + |> List.map (fun md -> + md.With(customAttrs = + mkILCustomAttrs (td.CustomAttrs.AsList |> List.filter (fun ilattr -> + ilattr.Method.DeclaringType.TypeRef.FullName <> "System.Runtime.TargetedPatchingOptOutAttribute")))) + |> mkILMethods + let td = td.With(methods=meths) + yield td.With(methods=meths) ])} //ILAsciiWriter.output_module stdout fakeModule fakeModule.TypeDefs.AsList @@ -1214,7 +1218,7 @@ module StaticLinker = mutable visited: bool } // Find all IL modules that are to be statically linked given the static linking roots. - let FindDependentILModulesForStaticLinking (ctok, tcConfig:TcConfig, tcImports:TcImports, ilxMainModule) = + let FindDependentILModulesForStaticLinking (ctok, tcConfig:TcConfig, tcImports:TcImports, ilGlobals, ilxMainModule) = if not tcConfig.standalone && tcConfig.extraStaticLinkRoots.IsEmpty then [] else @@ -1245,7 +1249,31 @@ module StaticLinker = | ResolvedCcu ccu -> Some ccu | UnresolvedCcu(_ccuName) -> None - let modul = dllInfo.RawMetadata.TryGetRawILModule().Value + let fileName = dllInfo.FileName + let modul = + let pdbPathOption = + // We open the pdb file if one exists parallel to the binary we + // are reading, so that --standalone will preserve debug information. + if tcConfig.openDebugInformationForLaterStaticLinking then + let pdbDir = (try Filename.directoryName fileName with _ -> ".") + let pdbFile = (try Filename.chopExtension fileName with _ -> fileName)+".pdb" + if FileSystem.SafeExists pdbFile then + if verbose then dprintf "reading PDB file %s from directory %s during static linking\n" pdbFile pdbDir + Some pdbDir + else + None + else + None + + let opts : ILReaderOptions = + { ilGlobals = ilGlobals + metadataOnly = MetadataOnlyFlag.No // turn this off here as we need the actual IL code + reduceMemoryUsage = tcConfig.reduceMemoryUsage + pdbPath = pdbPathOption + tryGetMetadataSnapshot = (fun _ -> None) } + + let reader = ILBinaryReader.OpenILModuleReader dllInfo.FileName opts + reader.ILModuleDef let refs = if ilAssemRef.Name = GetFSharpCoreLibraryName() then @@ -1314,7 +1342,7 @@ module StaticLinker = | ResolvedCcu ccu -> Some ccu | UnresolvedCcu(_ccuName) -> None - let modul = dllInfo.RawMetadata.TryGetRawILModule().Value + let modul = dllInfo.RawMetadata.TryGetILModuleDef().Value yield (ccu, dllInfo.ILScopeRef, modul), (ilAssemRef.Name, provAssemStaticLinkInfo) | None -> () ] @@ -1346,7 +1374,7 @@ module StaticLinker = (fun ilxMainModule -> ReportTime tcConfig "Find assembly references" - let dependentILModules = FindDependentILModulesForStaticLinking (ctok, tcConfig, tcImports, ilxMainModule) + let dependentILModules = FindDependentILModulesForStaticLinking (ctok, tcConfig, tcImports, ilGlobals, ilxMainModule) ReportTime tcConfig "Static link" @@ -1416,9 +1444,8 @@ module StaticLinker = | ILTypeDefAccess.Private -> ILTypeDefAccess.Nested ILMemberAccess.Private | _ -> ilOrigTypeDef.Access) else ilOrigTypeDef - { ilOrigTypeDef with - Name = ilTgtTyRef.Name - NestedTypes = mkILTypeDefs (List.map buildRelocatedGeneratedType ch) } + ilOrigTypeDef.With(name = ilTgtTyRef.Name, + nestedTypes = mkILTypeDefs (List.map buildRelocatedGeneratedType ch)) else // If there is no matching IL type definition, then make a simple container class if debugStaticLinking then printfn "Generating simple class '%s' because we didn't find an original type '%s' in a provider generated assembly" ilTgtTyRef.QualifiedName ilOrigTyRef.QualifiedName @@ -1452,7 +1479,7 @@ module StaticLinker = (ltdefs, fresh, rtdefs) | (ltdefs, Some htd, rtdefs) -> (ltdefs, htd, rtdefs) - let htd = { htd with NestedTypes = implantTypeDef true htd.NestedTypes t td } + let htd = htd.With(nestedTypes = implantTypeDef true htd.NestedTypes t td) mkILTypeDefs (ltdefs @ [htd] @ rtdefs) let newTypeDefs = @@ -1471,7 +1498,7 @@ module StaticLinker = let ilOrigTyRef = mkILNestedTyRef (ilOrigScopeRef, enc, tdef.Name) if not (ilOrigTyRefsForProviderGeneratedTypesToRelocate.ContainsKey ilOrigTyRef) then if debugStaticLinking then printfn "Keep provided type %s in place because it wasn't relocated" ilOrigTyRef.QualifiedName - yield { tdef with NestedTypes = rw (enc@[tdef.Name]) tdef.NestedTypes } ] + yield tdef.With(nestedTypes = rw (enc@[tdef.Name]) tdef.NestedTypes) ] rw [] ilModule.TypeDefs (ccu, { ilModule with TypeDefs = ilTypeDefsAfterRemovingRelocatedTypes })) @@ -1615,7 +1642,7 @@ let CopyFSharpCore(outFile: string, referencedDlls: AssemblyReference list) = [] type Args<'T> = Args of 'T -let main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinariesInMemory:bool, defaultCopyFSharpCore: bool, exiter:Exiter, errorLoggerProvider : ErrorLoggerProvider, disposables : DisposablesTracker) = +let main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, reduceMemoryUsage:ReduceMemoryFlag, defaultCopyFSharpCore: CopyFSharpCoreFlag, exiter:Exiter, errorLoggerProvider : ErrorLoggerProvider, disposables : DisposablesTracker) = // See Bug 735819 let lcidFromCodePage = @@ -1631,7 +1658,6 @@ let main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinarie let directoryBuildingFrom = Directory.GetCurrentDirectory() let setProcessThreadLocals tcConfigB = - tcConfigB.openBinariesInMemory <- openBinariesInMemory match tcConfigB.preferredUiLang with #if FX_RESHAPED_GLOBALIZATION | Some s -> System.Globalization.CultureInfo.CurrentUICulture <- new System.Globalization.CultureInfo(s) @@ -1647,9 +1673,15 @@ let main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinarie if not bannerAlreadyPrinted then DisplayBannerText tcConfigB - let optimizeForMemory = false // optimizeForMemory - fsc.exe can use as much memory as it likes to try to compile as fast as possible + let tryGetMetadataSnapshot = (fun _ -> None) + + let tcConfigB = + TcConfigBuilder.CreateNew(legacyReferenceResolver, DefaultFSharpBinariesDir, + reduceMemoryUsage=reduceMemoryUsage, implicitIncludeDir=directoryBuildingFrom, + isInteractive=false, isInvalidationSupported=false, + defaultCopyFSharpCore=defaultCopyFSharpCore, + tryGetMetadataSnapshot=tryGetMetadataSnapshot) - let tcConfigB = TcConfigBuilder.CreateNew(legacyReferenceResolver, DefaultFSharpBinariesDir, optimizeForMemory, directoryBuildingFrom, isInteractive=false, isInvalidationSupported=false, defaultCopyFSharpCore=defaultCopyFSharpCore) // Preset: --optimize+ -g --tailcalls+ (see 4505) SetOptimizeSwitch tcConfigB OptionSwitch.On SetDebugSwitch tcConfigB None OptionSwitch.Off @@ -1678,7 +1710,6 @@ let main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinarie delayForFlagsLogger.ForwardDelayedDiagnostics(tcConfigB) exiter.Exit 1 - tcConfigB.sqmNumOfSourceFiles <- sourceFiles.Length tcConfigB.conditionalCompilationDefines <- "COMPILED" :: tcConfigB.conditionalCompilationDefines displayBannerIfNeeded tcConfigB @@ -1787,10 +1818,12 @@ let main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinarie Args (ctok, tcGlobals, tcImports, frameworkTcImports, tcState.Ccu, typedAssembly, topAttrs, tcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter) -let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter)) = +let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, generatedCcu: CcuThunk, typedImplFiles, topAttrs, tcConfig: TcConfig, outfile, pdbfile, assemblyName, errorLogger, exiter: Exiter)) = if tcConfig.typeCheckOnly then exiter.Exit 0 + generatedCcu.Contents.SetAttribs(generatedCcu.Contents.Attribs @ topAttrs.assemblyAttrs) + use unwindPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.CodeGen let signingInfo = ValidateKeySigningAttributes (tcConfig, tcGlobals, topAttrs) @@ -1836,11 +1869,19 @@ let main1(Args (ctok, tcGlobals, tcImports: TcImports, frameworkTcImports, gener Args (ctok, tcConfig, tcImports, frameworkTcImports, tcGlobals, errorLogger, generatedCcu, outfile, typedImplFiles, topAttrs, pdbfile, assemblyName, assemVerFromAttrib, signingInfo, exiter) -// set up typecheck for given AST without parsing any command line parameters -let main1OfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyName, target, outfile, pdbFile, dllReferences, noframework, exiter, errorLoggerProvider: ErrorLoggerProvider, inputs : ParsedInput list) = +// This is for the compile-from-AST feature of FCS. +// TODO: consider removing this feature from FCS, which as far as I know is not used by anyone. +let main1OfAst (ctok, legacyReferenceResolver, reduceMemoryUsage, assemblyName, target, outfile, pdbFile, dllReferences, noframework, exiter, errorLoggerProvider: ErrorLoggerProvider, inputs : ParsedInput list) = + + let tryGetMetadataSnapshot = (fun _ -> None) + + let tcConfigB = + TcConfigBuilder.CreateNew(legacyReferenceResolver, DefaultFSharpBinariesDir, + reduceMemoryUsage=reduceMemoryUsage, implicitIncludeDir=Directory.GetCurrentDirectory(), + isInteractive=false, isInvalidationSupported=false, + defaultCopyFSharpCore=CopyFSharpCoreFlag.No, + tryGetMetadataSnapshot=tryGetMetadataSnapshot) - let tcConfigB = TcConfigBuilder.CreateNew(legacyReferenceResolver, DefaultFSharpBinariesDir, (*optimizeForMemory*) false, Directory.GetCurrentDirectory(), isInteractive=false, isInvalidationSupported=false, defaultCopyFSharpCore=false) - tcConfigB.openBinariesInMemory <- openBinariesInMemory tcConfigB.framework <- not noframework // Preset: --optimize+ -g --tailcalls+ (see 4505) SetOptimizeSwitch tcConfigB OptionSwitch.On @@ -1850,7 +1891,6 @@ let main1OfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyNam | None -> OptionSwitch.Off) SetTailcallSwitch tcConfigB OptionSwitch.On tcConfigB.target <- target - tcConfigB.sqmNumOfSourceFiles <- 1 let errorLogger = errorLoggerProvider.CreateErrorLoggerUpToMaxErrors (tcConfigB, exiter) @@ -1887,6 +1927,7 @@ let main1OfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyNam TypeCheck(ctok, tcConfig, tcImports, tcGlobals, errorLogger, assemblyName, NiceNameGenerator(), tcEnv0, inputs,exiter) let generatedCcu = tcState.Ccu + generatedCcu.Contents.SetAttribs(generatedCcu.Contents.Attribs @ topAttrs.assemblyAttrs) use unwindPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.CodeGen) let signingInfo = ValidateKeySigningAttributes (tcConfig, tcGlobals, topAttrs) @@ -1929,7 +1970,7 @@ let main2a(Args (ctok, tcConfig, tcImports, frameworkTcImports: TcImports, tcGlo let metadataVersion = match tcConfig.metadataVersion with | Some v -> v - | _ -> match (frameworkTcImports.DllTable.TryFind tcConfig.primaryAssembly.Name) with | Some ib -> ib.RawMetadata.TryGetRawILModule().Value.MetadataVersion | _ -> "" + | _ -> match (frameworkTcImports.DllTable.TryFind tcConfig.primaryAssembly.Name) with | Some ib -> ib.RawMetadata.TryGetILModuleDef().Value.MetadataVersion | _ -> "" let optimizedImpls, optimizationData, _ = ApplyAllOptimizations (tcConfig, tcGlobals, (LightweightTcValForUsingInBuildMethodCall tcGlobals), outfile, importMap, false, optEnv0, generatedCcu, typedImplFiles) AbortOnError(errorLogger, exiter) @@ -1966,7 +2007,7 @@ let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args (ctok, tcConfig: TcCo // remove any security attributes from the top-level assembly attribute list let topAttrs = {topAttrs with assemblyAttrs=topAssemblyAttrs} let permissionSets = ilxGenerator.CreatePermissionSets securityAttrs - let secDecls = if securityAttrs.Length > 0 then mkILSecurityDecls permissionSets else emptyILSecurityDecls + let secDecls = if List.isEmpty securityAttrs then emptyILSecurityDecls else mkILSecurityDecls permissionSets let ilxMainModule = MainModuleBuilder.CreateMainModule (ctok, tcConfig, tcGlobals, tcImports, pdbfile, assemblyName, outfile, topAttrs, idata, optDataResources, codegenResults, assemVerFromAttrib, metadataVersion, secDecls) @@ -2031,7 +2072,7 @@ let main4 dynamicAssemblyCreator (Args (ctok, tcConfig, errorLogger: ErrorLogger AbortOnError(errorLogger, exiter) // Don't copy referenced FSharp.core.dll if we are building FSharp.Core.dll - if tcConfig.copyFSharpCore && not tcConfig.compilingFslib && not tcConfig.standalone then + if (tcConfig.copyFSharpCore = CopyFSharpCoreFlag.Yes) && not tcConfig.compilingFslib && not tcConfig.standalone then CopyFSharpCore(outfile, tcConfig.referencedDLLs) ReportTime tcConfig "Exiting" @@ -2041,12 +2082,12 @@ let main4 dynamicAssemblyCreator (Args (ctok, tcConfig, errorLogger: ErrorLogger //----------------------------------------------------------------------------- /// Entry point typecheckAndCompile -let typecheckAndCompile (ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinariesInMemory, defaultCopyFSharpCore, exiter:Exiter, errorLoggerProvider, tcImportsCapture, dynamicAssemblyCreator) = +let typecheckAndCompile (ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, reduceMemoryUsage, defaultCopyFSharpCore, exiter:Exiter, errorLoggerProvider, tcImportsCapture, dynamicAssemblyCreator) = use d = new DisposablesTracker() use e = new SaveAndRestoreConsoleEncoding() - main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinariesInMemory, defaultCopyFSharpCore, exiter, errorLoggerProvider, d) + main0(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, reduceMemoryUsage, defaultCopyFSharpCore, exiter, errorLoggerProvider, d) |> main1 |> main2a |> main2b (tcImportsCapture,dynamicAssemblyCreator) @@ -2054,14 +2095,14 @@ let typecheckAndCompile (ctok, argv, legacyReferenceResolver, bannerAlreadyPrint |> main4 dynamicAssemblyCreator -let compileOfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyName, target, outFile, pdbFile, dllReferences, noframework, exiter, errorLoggerProvider, inputs, tcImportsCapture, dynamicAssemblyCreator) = - main1OfAst (ctok, legacyReferenceResolver, openBinariesInMemory, assemblyName, target, outFile, pdbFile, dllReferences, noframework, exiter, errorLoggerProvider, inputs) +let compileOfAst (ctok, legacyReferenceResolver, reduceMemoryUsage, assemblyName, target, outFile, pdbFile, dllReferences, noframework, exiter, errorLoggerProvider, inputs, tcImportsCapture, dynamicAssemblyCreator) = + main1OfAst (ctok, legacyReferenceResolver, reduceMemoryUsage, assemblyName, target, outFile, pdbFile, dllReferences, noframework, exiter, errorLoggerProvider, inputs) |> main2a |> main2b (tcImportsCapture, dynamicAssemblyCreator) |> main3 |> main4 dynamicAssemblyCreator -let mainCompile (ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinariesInMemory, defaultCopyFSharpCore, exiter, errorLoggerProvider, tcImportsCapture, dynamicAssemblyCreator) = +let mainCompile (ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, reduceMemoryUsage, defaultCopyFSharpCore, exiter, errorLoggerProvider, tcImportsCapture, dynamicAssemblyCreator) = //System.Runtime.GCSettings.LatencyMode <- System.Runtime.GCLatencyMode.Batch - typecheckAndCompile(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, openBinariesInMemory, defaultCopyFSharpCore, exiter, errorLoggerProvider, tcImportsCapture, dynamicAssemblyCreator) + typecheckAndCompile(ctok, argv, legacyReferenceResolver, bannerAlreadyPrinted, reduceMemoryUsage, defaultCopyFSharpCore, exiter, errorLoggerProvider, tcImportsCapture, dynamicAssemblyCreator) diff --git a/src/fsharp/fsc.fsi b/src/fsharp/fsc.fsi index a2ff860977..aec98d978c 100755 --- a/src/fsharp/fsc.fsi +++ b/src/fsharp/fsc.fsi @@ -4,6 +4,7 @@ module internal Microsoft.FSharp.Compiler.Driver open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.ErrorLogger @@ -32,8 +33,8 @@ val typecheckAndCompile : argv : string[] * legacyReferenceResolver: ReferenceResolver.Resolver * bannerAlreadyPrinted : bool * - openBinariesInMemory: bool * - defaultCopyFSharpCore: bool * + reduceMemoryUsage: ReduceMemoryFlag * + defaultCopyFSharpCore: CopyFSharpCoreFlag * exiter : Exiter * loggerProvider: ErrorLoggerProvider * tcImportsCapture: (TcImports -> unit) option * @@ -45,8 +46,8 @@ val mainCompile : argv: string[] * legacyReferenceResolver: ReferenceResolver.Resolver * bannerAlreadyPrinted: bool * - openBinariesInMemory: bool * - defaultCopyFSharpCore: bool * + reduceMemoryUsage: ReduceMemoryFlag * + defaultCopyFSharpCore: CopyFSharpCoreFlag * exiter: Exiter * loggerProvider: ErrorLoggerProvider * tcImportsCapture: (TcImports -> unit) option * @@ -56,7 +57,7 @@ val mainCompile : val compileOfAst : ctok: CompilationThreadToken * legacyReferenceResolver: ReferenceResolver.Resolver * - openBinariesInMemory: bool * + reduceMemoryUsage: ReduceMemoryFlag * assemblyName:string * target:CompilerTarget * targetDll:string * diff --git a/src/fsharp/fscmain.fs b/src/fsharp/fscmain.fs index 344656d6b5..1d50e0c68d 100644 --- a/src/fsharp/fscmain.fs +++ b/src/fsharp/fscmain.fs @@ -9,7 +9,9 @@ open System.Reflection open System.Runtime.CompilerServices open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.AbstractIL.IL // runningOnMono +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Driver open Microsoft.FSharp.Compiler.Lib @@ -34,10 +36,18 @@ module Driver = let ctok = AssumeCompilationThreadWithoutEvidence () // Check for --pause as the very first step so that a compiler can be attached here. - if argv |> Array.exists (fun x -> x = "/pause" || x = "--pause") then + let pauseFlag = argv |> Array.exists (fun x -> x = "/pause" || x = "--pause") + if pauseFlag then System.Console.WriteLine("Press return to continue...") System.Console.ReadLine() |> ignore +#if !FX_NO_APP_DOMAINS + let timesFlag = argv |> Array.exists (fun x -> x = "/times" || x = "--times") + if timesFlag then + let stats = ILBinaryReader.GetStatistics() + AppDomain.CurrentDomain.ProcessExit.Add(fun _ -> printfn "STATS: #ByteArrayFile = %d, #MemoryMappedFileOpen = %d, #MemoryMappedFileClosed = %d, #RawMemoryFile = %d, #WeakByteArrayFile = %d" stats.byteFileCount stats.memoryMapFileOpenedCount stats.memoryMapFileClosedCount stats.rawMemoryFileCount stats.weakByteFileCount) +#endif + let quitProcessExiter = { new Exiter with member x.Exit(n) = @@ -55,7 +65,11 @@ module Driver = MSBuildReferenceResolver.Resolver #endif - mainCompile (ctok, argv, legacyReferenceResolver, (*bannerAlreadyPrinted*)false, (*openBinariesInMemory*)false, (*defaultCopyFSharpCore*)true, quitProcessExiter, ConsoleLoggerProvider(), None, None) + // This is the only place where ReduceMemoryFlag.No is set. This is because fsc.exe is not a long-running process and + // thus we can use file-locking memory mapped files. + // + // This is also one of only two places where CopyFSharpCoreFlag.Yes is set. The other is in LegacyHostedCompilerForTesting. + mainCompile (ctok, argv, legacyReferenceResolver, (*bannerAlreadyPrinted*)false, ReduceMemoryFlag.No, CopyFSharpCoreFlag.Yes, quitProcessExiter, ConsoleLoggerProvider(), None, None) 0 [] diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs index 8f0fbc9c81..6b662c12af 100644 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -23,6 +23,7 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX @@ -1000,11 +1001,11 @@ type internal FsiDynamicCompiler /// Add attributes let CreateModuleFragment (tcConfigB: TcConfigBuilder, assemblyName, codegenResults) = if !progress then fprintfn fsiConsoleOutput.Out "Creating main module..."; - let mainModule = mkILSimpleModule assemblyName (GetGeneratedILModuleName tcConfigB.target assemblyName) (tcConfigB.target = Dll) tcConfigB.subsystemVersion tcConfigB.useHighEntropyVA (mkILTypeDefs codegenResults.ilTypeDefs) None None 0x0 (mkILExportedTypes []) "" + let mainModule = mkILSimpleModule assemblyName (GetGeneratedILModuleName tcConfigB.target assemblyName) (tcConfigB.target = CompilerTarget.Dll) tcConfigB.subsystemVersion tcConfigB.useHighEntropyVA (mkILTypeDefs codegenResults.ilTypeDefs) None None 0x0 (mkILExportedTypes []) "" { mainModule with Manifest = (let man = mainModule.ManifestOfAssembly - Some { man with CustomAttrs = mkILCustomAttrs codegenResults.ilAssemAttrs }); } + Some { man with CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrs codegenResults.ilAssemAttrs) }) } let ProcessInputs (ctok, errorLogger: ErrorLogger, istate: FsiDynamicCompilerState, inputs: ParsedInput list, showTypes: bool, isIncrementalFragment: bool, isInteractiveItExpr: bool, prefixPath: LongIdent) = let optEnv = istate.optEnv @@ -1292,7 +1293,8 @@ type internal FsiDynamicCompiler let sourceFiles = sourceFiles |> List.map (fun nm -> tcConfig.ResolveSourceFile(m, nm, tcConfig.implicitIncludeDir),m) // Close the #load graph on each file and gather the inputs from the scripts. - let closure = LoadClosure.ComputeClosureOfSourceFiles(ctok, TcConfig.Create(tcConfigB,validate=false), sourceFiles, CodeContext.CompilationAndEvaluation, lexResourceManager=lexResourceManager) + let tcConfig = TcConfig.Create(tcConfigB,validate=false) + let closure = LoadClosure.ComputeClosureOfScriptFiles(ctok, tcConfig, sourceFiles, CodeContext.CompilationAndEvaluation, lexResourceManager=lexResourceManager) // Intent "[Loading %s]\n" (String.concat "\n and " sourceFiles) fsiConsoleOutput.uprintf "[%s " (FSIstrings.SR.fsiLoadingFilesPrefixText()) @@ -2029,7 +2031,7 @@ type internal FsiInteractionProcessor // When the last declaration has a shape of DoExp (i.e., non-binding), // transform it to a shape of "let it = ", so we can refer it. - let defsA = if defsA.Length <= 1 || defsB.Length > 0 then defsA else + let defsA = if defsA.Length <= 1 || not (List.isEmpty defsB) then defsA else match List.headAndTail (List.rev defsA) with | SynModuleDecl.DoExpr(_,exp,_), rest -> (rest |> List.rev) @ (fsiDynamicCompiler.BuildItBinding exp) | _ -> defsA @@ -2437,6 +2439,7 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i //---------------------------------------------------------------------------- let currentDirectory = Directory.GetCurrentDirectory() + let tryGetMetadataSnapshot = (fun _ -> None) let defaultFSharpBinariesDir = FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(FSharpEnvironment.tryCurrentDomain()).Value @@ -2445,7 +2448,16 @@ type FsiEvaluationSession (fsi: FsiEvaluationSessionHostConfig, argv:string[], i | None -> SimulatedMSBuildReferenceResolver.GetBestAvailableResolver() | Some rr -> rr - let tcConfigB = TcConfigBuilder.CreateNew(legacyReferenceResolver, defaultFSharpBinariesDir=defaultFSharpBinariesDir, optimizeForMemory=true, implicitIncludeDir=currentDirectory, isInteractive=true, isInvalidationSupported=false, defaultCopyFSharpCore=false) + let tcConfigB = + TcConfigBuilder.CreateNew(legacyReferenceResolver, + defaultFSharpBinariesDir=defaultFSharpBinariesDir, + reduceMemoryUsage=ReduceMemoryFlag.Yes, + implicitIncludeDir=currentDirectory, + isInteractive=true, + isInvalidationSupported=false, + defaultCopyFSharpCore=CopyFSharpCoreFlag.No, + tryGetMetadataSnapshot=tryGetMetadataSnapshot) + let tcConfigP = TcConfigProvider.BasedOnMutableBuilder(tcConfigB) do tcConfigB.resolutionEnvironment <- ResolutionEnvironment.CompilationAndEvaluation // See Bug 3608 do tcConfigB.useFsiAuxLib <- fsi.UseFsiAuxLib diff --git a/src/fsharp/fsi/fsimain.fs b/src/fsharp/fsi/fsimain.fs index 002cfa54a4..92a2f72270 100644 --- a/src/fsharp/fsi/fsimain.fs +++ b/src/fsharp/fsi/fsimain.fs @@ -22,6 +22,7 @@ open System.Windows.Forms #endif open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Interactive.Shell open Microsoft.FSharp.Compiler.Interactive @@ -331,6 +332,14 @@ let MainMain argv = let argv = System.Environment.GetCommandLineArgs() use e = new SaveAndRestoreConsoleEncoding() +#if !FX_NO_APP_DOMAINS + let timesFlag = argv |> Array.exists (fun x -> x = "/times" || x = "--times") + if timesFlag then + AppDomain.CurrentDomain.ProcessExit.Add(fun _ -> + let stats = ILBinaryReader.GetStatistics() + printfn "STATS: #ByteArrayFile = %d, #MemoryMappedFileOpen = %d, #MemoryMappedFileClosed = %d, #RawMemoryFile = %d, #WeakByteArrayFile = %d" stats.byteFileCount stats.memoryMapFileOpenedCount stats.memoryMapFileClosedCount stats.rawMemoryFileCount stats.weakByteFileCount) +#endif + #if FSI_SHADOW_COPY_REFERENCES let isShadowCopy x = (x = "/shadowcopyreferences" || x = "--shadowcopyreferences" || x = "/shadowcopyreferences+" || x = "--shadowcopyreferences+") if AppDomain.CurrentDomain.IsDefaultAppDomain() && argv |> Array.exists isShadowCopy then diff --git a/src/fsharp/import.fs b/src/fsharp/import.fs index f6f5648d8e..f4471be002 100755 --- a/src/fsharp/import.fs +++ b/src/fsharp/import.fs @@ -473,8 +473,8 @@ and ImportILTypeDefList amap m (cpath:CompilationPath) enc items = let modty = lazy (ImportILTypeDefList amap m (cpath.NestedCompPath n Namespace) enc tgs) NewModuleOrNamespace (Some cpath) taccessPublic (mkSynId m n) XmlDoc.Empty [] (MaybeLazy.Lazy modty)) (fun (n,info:Lazy<_>) -> - let (scoref2,_,lazyTypeDef:Lazy) = info.Force() - ImportILTypeDef amap m scoref2 cpath enc n (lazyTypeDef.Force())) + let (scoref2,_,lazyTypeDef:ILPreTypeDef) = info.Force() + ImportILTypeDef amap m scoref2 cpath enc n (lazyTypeDef.GetTypeDef())) let kind = match enc with [] -> Namespace | _ -> ModuleOrType NewModuleOrNamespaceType kind entities [] @@ -483,8 +483,8 @@ and ImportILTypeDefList amap m (cpath:CompilationPath) enc items = /// and ImportILTypeDefs amap m scoref cpath enc (tdefs: ILTypeDefs) = // We be very careful not to force a read of the type defs here - tdefs.AsArrayOfLazyTypeDefs - |> Array.map (fun (ns,n,attrs,lazyTypeDef) -> (ns,(n,notlazy(scoref,attrs,lazyTypeDef)))) + tdefs.AsArrayOfPreTypeDefs + |> Array.map (fun pre -> (pre.Namespace,(pre.Name,notlazy(scoref,pre.MetadataIndex,pre)))) |> Array.toList |> ImportILTypeDefList amap m cpath enc @@ -502,19 +502,20 @@ let ImportILAssemblyExportedType amap m auxModLoader (scoref:ILScopeRef) (export if exportedType.IsForwarder then [] else + let ns,n = splitILTypeName exportedType.Name let info = lazy (match (try let modul = auxModLoader exportedType.ScopeRef - Some (lazy modul.TypeDefs.FindByName exportedType.Name) - with :? System.Collections.Generic.KeyNotFoundException -> None) + let ptd = mkILPreTypeDefComputed (ns, n, (fun () -> modul.TypeDefs.FindByName exportedType.Name)) + Some ptd + with :? KeyNotFoundException -> None) with | None -> error(Error(FSComp.SR.impReferenceToDllRequiredByAssembly(exportedType.ScopeRef.QualifiedName, scoref.QualifiedName, exportedType.Name),m)) - | Some lazyTypeDef -> - scoref,exportedType.CustomAttrs,lazyTypeDef) + | Some preTypeDef -> + scoref,-1,preTypeDef) - let ns,n = splitILTypeName exportedType.Name [ ImportILTypeDefList amap m (CompPath(scoref,[])) [] [(ns,(n,info))] ] /// Import the "exported types" table for multi-module assemblies. @@ -552,10 +553,10 @@ let ImportILAssemblyTypeForwarders (amap, m, exportedTypes:ILExportedTypesAndFor /// Import an IL assembly as a new TAST CCU -let ImportILAssembly(amap:(unit -> ImportMap),m,auxModuleLoader,sref,sourceDir,filename,ilModule:ILModuleDef,invalidateCcu:IEvent) = +let ImportILAssembly(amap:(unit -> ImportMap), m, auxModuleLoader, ilScopeRef, sourceDir, filename, ilModule:ILModuleDef, invalidateCcu:IEvent) = invalidateCcu |> ignore let aref = - match sref with + match ilScopeRef with | ILScopeRef.Assembly aref -> aref | _ -> error(InternalError("ImportILAssembly: cannot reference .NET netmodules directly, reference the containing assembly instead",m)) let nm = aref.Name @@ -568,13 +569,14 @@ let ImportILAssembly(amap:(unit -> ImportMap),m,auxModuleLoader,sref,sourceDir,f IsProviderGenerated = false ImportProvidedType = (fun ty -> ImportProvidedType (amap()) m ty) #endif - QualifiedName= Some sref.QualifiedName - Contents = NewCcuContents sref m nm mty - ILScopeRef = sref + QualifiedName= Some ilScopeRef.QualifiedName + Contents = NewCcuContents ilScopeRef m nm mty + ILScopeRef = ilScopeRef Stamp = newStamp() SourceCodeDirectory = sourceDir // note: not an accurate value, but IL assemblies don't give us this information in any attributes. FileName = filename MemberSignatureEquality= (fun ty1 ty2 -> Tastops.typeEquivAux EraseAll (amap()).g ty1 ty2) + TryGetILModuleDef = (fun () -> Some ilModule) TypeForwarders = (match ilModule.Manifest with | None -> Map.empty diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index d173e06c7f..f6fb690c62 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -1177,7 +1177,11 @@ type MethInfo = | _ -> failwith "not supported" /// Indicates if this is an extension member. - member x.IsExtensionMember = x.IsCSharpStyleExtensionMember || x.IsFSharpStyleExtensionMember + member x.IsExtensionMember = + match x with + | FSMeth (_,_,vref,pri) -> pri.IsSome || vref.IsExtensionMember + | ILMeth (_,_,Some _) -> true + | _ -> false /// Indicates if this is an F# extension member. member x.IsFSharpStyleExtensionMember = @@ -1185,8 +1189,10 @@ type MethInfo = /// Indicates if this is an C#-style extension member. member x.IsCSharpStyleExtensionMember = - x.ExtensionMemberPriorityOption.IsSome && - (match x with ILMeth _ -> true | FSMeth (_,_,vref,_) -> not vref.IsExtensionMember | _ -> false) + match x with + | FSMeth (_,_,vref,Some _) -> not vref.IsExtensionMember + | ILMeth (_,_,Some _) -> true + | _ -> false /// Add the actual type instantiation of the apparent type of an F# extension method. // @@ -1234,6 +1240,7 @@ type MethInfo = /// Tests whether two method infos have the same underlying definition. /// Used to merge operator overloads collected from left and right of an operator constraint. + /// Must be compatible with ItemsAreEffectivelyEqual relation. static member MethInfosUseIdenticalDefinitions x1 x2 = match x1,x2 with | ILMeth(_,x1,_), ILMeth(_,x2,_) -> (x1.RawMetadata === x2.RawMetadata) @@ -1244,8 +1251,7 @@ type MethInfo = #endif | _ -> false - /// Calculates a hash code of method info. Note: this is a very imperfect implementation, - /// but it works decently for comparing methods in the language service... + /// Calculates a hash code of method info. Must be compatible with ItemsAreEffectivelyEqual relation. member x.ComputeHashCode() = match x with | ILMeth(_,x1,_) -> hash x1.RawMetadata.Name @@ -1670,7 +1676,7 @@ type ILFieldInfo = /// Get the type of the field as an IL type member x.ILFieldType = match x with - | ILFieldInfo (_,fdef) -> fdef.Type + | ILFieldInfo (_,fdef) -> fdef.FieldType #if !NO_EXTENSIONTYPING | ProvidedField(amap,fi,m) -> Import.ImportProvidedTypeAsILType amap m (fi.PApply((fun fi -> fi.FieldType),m)) #endif @@ -1678,11 +1684,13 @@ type ILFieldInfo = /// Get the type of the field as an F# type member x.FieldType(amap,m) = match x with - | ILFieldInfo (tinfo,fdef) -> ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInstOfRawMetadata [] fdef.Type + | ILFieldInfo (tinfo,fdef) -> ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInstOfRawMetadata [] fdef.FieldType #if !NO_EXTENSIONTYPING | ProvidedField(amap,fi,m) -> Import.ImportProvidedType amap m (fi.PApply((fun fi -> fi.FieldType),m)) #endif + /// Tests whether two infos have the same underlying definition. + /// Must be compatible with ItemsAreEffectivelyEqual relation. static member ILFieldInfosUseIdenticalDefinitions x1 x2 = match x1,x2 with | ILFieldInfo(_, x1), ILFieldInfo(_, x2) -> (x1 === x2) @@ -1692,6 +1700,10 @@ type ILFieldInfo = #endif /// Get an (uninstantiated) reference to the field as an Abstract IL ILFieldRef member x.ILFieldRef = rescopeILFieldRef x.ScopeRef (mkILFieldRef(x.ILTypeRef,x.FieldName,x.ILFieldType)) + + /// Calculates a hash code of field info. Must be compatible with ItemsAreEffectivelyEqual relation. + member x.ComputeHashCode() = hash x.FieldName + override x.ToString() = x.FieldName @@ -1836,7 +1848,7 @@ type ILPropInfo = /// Any type parameters of the enclosing type are instantiated in the type returned. member x.GetPropertyType (amap,m) = let (ILPropInfo (tinfo,pdef)) = x - ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInstOfRawMetadata [] pdef.Type + ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInstOfRawMetadata [] pdef.PropertyType override x.ToString() = x.ILTypeInfo.ToString() + "::" + x.PropertyName @@ -2150,8 +2162,8 @@ type PropInfo = | FSProp _ -> failwith "no setter method" /// Test whether two property infos have the same underlying definition. - /// /// Uses the same techniques as 'MethInfosUseIdenticalDefinitions'. + /// Must be compatible with ItemsAreEffectivelyEqual relation. static member PropInfosUseIdenticalDefinitions x1 x2 = let optVrefEq g = function | Some(v1), Some(v2) -> valRefEq g v1 v2 @@ -2166,7 +2178,7 @@ type PropInfo = #endif | _ -> false - /// Calculates a hash code of property info (similar as previous) + /// Calculates a hash code of property info. Must be compatible with ItemsAreEffectivelyEqual relation. member pi.ComputeHashCode() = match pi with | ILProp ilpinfo -> hash ilpinfo.RawMetadata.Name @@ -2393,8 +2405,8 @@ type EventInfo = | ILEvent(ILEventInfo(tinfo,edef)) -> // Get the delegate type associated with an IL event, taking into account the instantiation of the // declaring type. - if Option.isNone edef.Type then error (nonStandardEventError x.EventName m) - ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInstOfRawMetadata [] edef.Type.Value + if Option.isNone edef.EventType then error (nonStandardEventError x.EventName m) + ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInstOfRawMetadata [] edef.EventType.Value | FSEvent(g,p,_,_) -> FindDelegateTypeOfPropertyEvent g amap x.EventName m (p.GetPropertyType(amap,m)) @@ -2405,6 +2417,7 @@ type EventInfo = /// Test whether two event infos have the same underlying definition. + /// Must be compatible with ItemsAreEffectivelyEqual relation. static member EventInfosUseIdenticalDefintions x1 x2 = match x1, x2 with | FSEvent(g, pi1, vrefa1, vrefb1), FSEvent(_, pi2, vrefa2, vrefb2) -> @@ -2416,6 +2429,7 @@ type EventInfo = | _ -> false /// Calculates a hash code of event info (similar as previous) + /// Must be compatible with ItemsAreEffectivelyEqual relation. member ei.ComputeHashCode() = match ei with | ILEvent ileinfo -> hash ileinfo.RawMetadata.Name diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index ac44bd844c..0f8f3077e1 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -16,8 +16,8 @@ let verbose = false let progress = ref false let tracking = ref false // intended to be a general hook to control diagnostic output when tracking down bugs -let condition _s = - try (System.Environment.GetEnvironmentVariable(_s) <> null) with _ -> false +let condition s = + try (System.Environment.GetEnvironmentVariable(s) <> null) with _ -> false let GetEnvInteger e dflt = match System.Environment.GetEnvironmentVariable(e) with null -> dflt | t -> try int t with _ -> dflt diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy index c36b188641..267b5d566f 100644 --- a/src/fsharp/pars.fsy +++ b/src/fsharp/pars.fsy @@ -3631,6 +3631,13 @@ atomicExprQualification: | identOrOp { let idm = rhs parseState 1 (fun e lhsm dotm -> mkSynDot dotm lhsm e $1) } + + | GLOBAL + { (fun e lhsm dotm -> + reportParseErrorAt (rhs parseState 3) (FSComp.SR.nrGlobalUsedOnlyAsFirstName()) + let fixedLhsm = mkRange lhsm.FileName lhsm.Start dotm.End // previous lhsm is wrong after 'recover' + mkSynDotMissing dotm fixedLhsm e) } + | /* empty */ { (fun e lhsm dotm -> reportParseErrorAt dotm (FSComp.SR.parsMissingQualificationAfterDot()) diff --git a/src/fsharp/range.fs b/src/fsharp/range.fs index aed660be56..d1da4643be 100755 --- a/src/fsharp/range.fs +++ b/src/fsharp/range.fs @@ -140,7 +140,11 @@ let fileOfFileIndex n = fileIndexTable.IndexToFile(n) let mkPos l c = pos (l, c) [] +#if DEBUG +[ {DebugCode}")>] +#else [] +#endif type range(code:int64) = static member Zero = range(0L) new (fidx, bl, bc, el, ec) = @@ -163,6 +167,19 @@ type range(code:int64) = member m.StartRange = range (m.FileIndex, m.Start, m.Start) member m.EndRange = range (m.FileIndex, m.End, m.End) member r.FileName = fileOfFileIndex r.FileIndex +#if DEBUG + member r.DebugCode = + try + let endCol = r.EndColumn - 1 + let startCol = r.StartColumn - 1 + File.ReadAllLines(r.FileName) + |> Seq.skip (r.StartLine - 1) + |> Seq.take (r.EndLine - r.StartLine + 1) + |> String.concat "\n" + |> fun s -> s.Substring(startCol + 1, s.LastIndexOf("\n") + 1 - startCol + endCol) + with e -> + e.ToString() +#endif member r.MakeSynthetic() = range(code ||| isSyntheticMask) override r.ToString() = sprintf "%s (%d,%d--%d,%d) IsSynthetic=%b" r.FileName r.StartLine r.StartColumn r.EndLine r.EndColumn r.IsSynthetic member r.ToShortString() = sprintf "(%d,%d--%d,%d)" r.StartLine r.StartColumn r.EndLine r.EndColumn diff --git a/src/fsharp/service/IncrementalBuild.fs b/src/fsharp/service/IncrementalBuild.fs index 3fd19dacfe..f1977599a2 100755 --- a/src/fsharp/service/IncrementalBuild.fs +++ b/src/fsharp/service/IncrementalBuild.fs @@ -14,6 +14,7 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.CompileOps open Microsoft.FSharp.Compiler.CompileOptions @@ -1024,13 +1025,24 @@ type TypeCheckAccumulator = tcGlobals:TcGlobals tcConfig:TcConfig tcEnvAtEndOfFile: TcEnv - tcResolutions: TcResolutions list - tcSymbolUses: TcSymbolUses list - tcOpenDeclarations: OpenDeclaration list + + /// Accumulated resolutions, last file first + tcResolutionsRev: TcResolutions list + + /// Accumulated symbol uses, last file first + tcSymbolUsesRev: TcSymbolUses list + + /// Accumulated 'open' declarations, last file first + tcOpenDeclarationsRev: OpenDeclaration[] list topAttribs:TopAttribs option - typedImplFiles:TypedImplFile list + + /// Result of checking most recent file, if any + lastestTypedImplFile:TypedImplFile option + tcDependencyFiles: string list - tcErrors:(PhasedDiagnostic * FSharpErrorSeverity) list } // errors=true, warnings=false + + /// Accumulated errors, last file first + tcErrorsRev:(PhasedDiagnostic * FSharpErrorSeverity)[] list } /// Global service state @@ -1098,14 +1110,26 @@ type PartialCheckResults = TcGlobals: TcGlobals TcConfig: TcConfig TcEnvAtEnd: TcEnv - Errors: (PhasedDiagnostic * FSharpErrorSeverity) list - TcResolutions: TcResolutions list - TcSymbolUses: TcSymbolUses list - TcOpenDeclarations: OpenDeclaration list + + /// Kept in a stack so that each incremental update shares storage with previous files + TcErrorsRev: (PhasedDiagnostic * FSharpErrorSeverity)[] list + + /// Kept in a stack so that each incremental update shares storage with previous files + TcResolutionsRev: TcResolutions list + + /// Kept in a stack so that each incremental update shares storage with previous files + TcSymbolUsesRev: TcSymbolUses list + + /// Kept in a stack so that each incremental update shares storage with previous files + TcOpenDeclarationsRev: OpenDeclaration[] list + TcDependencyFiles: string list TopAttribs: TopAttribs option - TimeStamp: System.DateTime - ImplementationFiles: TypedImplFile list } + TimeStamp: DateTime + LatestImplementationFile: TypedImplFile option } + + member x.TcErrors = Array.concat (List.rev x.TcErrorsRev) + member x.TcSymbolUses = List.rev x.TcSymbolUsesRev static member Create (tcAcc: TypeCheckAccumulator, timestamp) = { TcState = tcAcc.tcState @@ -1113,14 +1137,14 @@ type PartialCheckResults = TcGlobals = tcAcc.tcGlobals TcConfig = tcAcc.tcConfig TcEnvAtEnd = tcAcc.tcEnvAtEndOfFile - Errors = tcAcc.tcErrors - TcResolutions = tcAcc.tcResolutions - TcSymbolUses = tcAcc.tcSymbolUses - TcOpenDeclarations = tcAcc.tcOpenDeclarations + TcErrorsRev = tcAcc.tcErrorsRev + TcResolutionsRev = tcAcc.tcResolutionsRev + TcSymbolUsesRev = tcAcc.tcSymbolUsesRev + TcOpenDeclarationsRev = tcAcc.tcOpenDeclarationsRev TcDependencyFiles = tcAcc.tcDependencyFiles TopAttribs = tcAcc.topAttribs TimeStamp = timestamp - ImplementationFiles = tcAcc.typedImplFiles } + LatestImplementationFile = tcAcc.lastestTypedImplFile } [] @@ -1137,8 +1161,6 @@ module Utilities = /// a virtualized view of the assembly contents as computed by background checking. type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals, tcState:TcState, outfile, topAttrs, assemblyName, ilAssemRef) = - /// Try to find an attribute that takes a string argument - let generatedCcu = tcState.Ccu let exportRemapping = MakeExportRemapping generatedCcu generatedCcu.Contents @@ -1146,10 +1168,7 @@ type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals, tcState: let _sigDataAttributes, sigDataResources = Driver.EncodeInterfaceData(tcConfig, tcGlobals, exportRemapping, generatedCcu, outfile, true) [ for r in sigDataResources do let ccuName = GetSignatureDataResourceName r - let bytes = - match r.Location with - | ILResourceLocation.Local b -> b() - | _ -> assert false; failwith "unreachable" + let bytes = r.GetBytes() yield (ccuName, bytes) ] let autoOpenAttrs = topAttrs.assemblyAttrs |> List.choose (List.singleton >> TryFindFSharpStringAttribute tcGlobals tcGlobals.attrib_AutoOpenAttribute) @@ -1157,7 +1176,7 @@ type RawFSharpAssemblyDataBackedByLanguageService (tcConfig, tcGlobals, tcState: interface IRawFSharpAssemblyData with member __.GetAutoOpenAttributes(_ilg) = autoOpenAttrs member __.GetInternalsVisibleToAttributes(_ilg) = ivtAttrs - member __.TryGetRawILModule() = None + member __.TryGetILModuleDef() = None member __.GetRawFSharpSignatureData(_m, _ilShortAssemName, _filename) = sigData member __.GetRawFSharpOptimizationData(_m, _ilShortAssemName, _filename) = [ ] member __.GetRawTypeForwarders() = mkILExportedTypes [] // TODO: cross-project references with type forwarders @@ -1320,19 +1339,20 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput for (err, isError) in inp.MetaCommandDiagnostics do yield err, (if isError then FSharpErrorSeverity.Error else FSharpErrorSeverity.Warning) ] + let initialErrors = Array.append (Array.ofList loadClosureErrors) (errorLogger.GetErrors()) let tcAcc = { tcGlobals=tcGlobals tcImports=tcImports tcState=tcState tcConfig=tcConfig tcEnvAtEndOfFile=tcInitial - tcResolutions=[] - tcSymbolUses=[] - tcOpenDeclarations=[] + tcResolutionsRev=[] + tcSymbolUsesRev=[] + tcOpenDeclarationsRev=[] topAttribs=None - typedImplFiles=[] + lastestTypedImplFile=None tcDependencyFiles=basicDependencies - tcErrors = loadClosureErrors @ errorLogger.GetErrors() } + tcErrorsRev = [ initialErrors ] } return tcAcc } /// This is a build task function that gets placed into the build rules as the computation for a Vector.ScanLeft @@ -1351,9 +1371,9 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput ApplyMetaCommandsFromInputToTcConfig (tcConfig, input, Path.GetDirectoryName filename) |> ignore let sink = TcResultsSinkImpl(tcAcc.tcGlobals) - let hadParseErrors = not (List.isEmpty parseErrors) + let hadParseErrors = not (Array.isEmpty parseErrors) - let! (tcEnvAtEndOfFile, topAttribs, typedImplFiles), tcState = + let! (tcEnvAtEndOfFile, topAttribs, lastestTypedImplFile), tcState = TypeCheckOneInputEventually ((fun () -> hadParseErrors || errorLogger.ErrorCount > 0), tcConfig, tcAcc.tcImports, @@ -1363,7 +1383,7 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput tcAcc.tcState, input) /// Only keep the typed interface files when doing a "full" build for fsc.exe, otherwise just throw them away - let typedImplFiles = if keepAssemblyContents then typedImplFiles else [] + let lastestTypedImplFile = if keepAssemblyContents then lastestTypedImplFile 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() @@ -1371,14 +1391,15 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput RequireCompilationThread ctok // Note: events get raised on the CompilationThread fileChecked.Trigger (filename) + let newErrors = Array.append parseErrors (capturingErrorLogger.GetErrors()) return {tcAcc with tcState=tcState tcEnvAtEndOfFile=tcEnvAtEndOfFile topAttribs=Some topAttribs - typedImplFiles=typedImplFiles - tcResolutions=tcAcc.tcResolutions @ [tcResolutions] - tcSymbolUses=tcAcc.tcSymbolUses @ [tcSymbolUses] - tcOpenDeclarations=tcAcc.tcOpenDeclarations @ sink.OpenDeclarations - tcErrors = tcAcc.tcErrors @ parseErrors @ capturingErrorLogger.GetErrors() + lastestTypedImplFile=lastestTypedImplFile + tcResolutionsRev=tcResolutions :: tcAcc.tcResolutionsRev + tcSymbolUsesRev=tcSymbolUses :: tcAcc.tcSymbolUsesRev + tcOpenDeclarationsRev = sink.GetOpenDeclarations() :: tcAcc.tcOpenDeclarationsRev + tcErrorsRev = newErrors :: tcAcc.tcErrorsRev tcDependencyFiles = filename :: tcAcc.tcDependencyFiles } } @@ -1417,7 +1438,7 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput // Finish the checking let (_tcEnvAtEndOfLastFile, topAttrs, mimpls), tcState = - let results = tcStates |> List.ofArray |> List.map (fun acc-> acc.tcEnvAtEndOfFile, defaultArg acc.topAttribs EmptyTopAttrs, acc.typedImplFiles) + let results = tcStates |> List.ofArray |> List.map (fun acc-> acc.tcEnvAtEndOfFile, defaultArg acc.topAttribs EmptyTopAttrs, acc.lastestTypedImplFile) TypeCheckMultipleInputsFinish (results, finalAcc.tcState) let ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt = @@ -1473,7 +1494,7 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput let finalAccWithErrors = { finalAcc with - tcErrors = finalAcc.tcErrors @ errorLogger.GetErrors() + tcErrorsRev = errorLogger.GetErrors() :: finalAcc.tcErrorsRev topAttribs = Some topAttrs } return ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt, finalAccWithErrors @@ -1697,7 +1718,7 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput /// CreateIncrementalBuilder (for background type checking). Note that fsc.fs also /// creates an incremental builder used by the command line compiler. - static member TryCreateBackgroundBuilderForProjectOptions (ctok, legacyReferenceResolver, defaultFSharpBinariesDir, frameworkTcImportsCache: FrameworkImportsCache, loadClosureOpt:LoadClosure option, sourceFiles:string list, commandLineArgs:string list, projectReferences, projectDirectory, useScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds) = + static member TryCreateBackgroundBuilderForProjectOptions (ctok, legacyReferenceResolver, defaultFSharpBinariesDir, frameworkTcImportsCache: FrameworkImportsCache, loadClosureOpt:LoadClosure option, sourceFiles:string list, commandLineArgs:string list, projectReferences, projectDirectory, useScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds, tryGetMetadataSnapshot) = let useSimpleResolutionSwitch = "--simpleresolution" cancellable { @@ -1724,11 +1745,15 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput | _ -> None // see also fsc.fs:runFromCommandLineToImportingAssemblies(), as there are many similarities to where the PS creates a tcConfigB - let tcConfigB = TcConfigBuilder.CreateNew(legacyReferenceResolver, defaultFSharpBinariesDir, implicitIncludeDir=projectDirectory, optimizeForMemory=true, isInteractive=false, isInvalidationSupported=true, defaultCopyFSharpCore=false) - - // The following uses more memory but means we don't take read-exclusions on the DLLs we reference - // Could detect well-known assemblies--ie System.dll--and open them with read-locks - tcConfigB.openBinariesInMemory <- true + let tcConfigB = + TcConfigBuilder.CreateNew(legacyReferenceResolver, + defaultFSharpBinariesDir, + implicitIncludeDir=projectDirectory, + reduceMemoryUsage=ReduceMemoryFlag.Yes, + isInteractive=false, + isInvalidationSupported=true, + defaultCopyFSharpCore=CopyFSharpCoreFlag.No, + tryGetMetadataSnapshot=tryGetMetadataSnapshot) tcConfigB.resolutionEnvironment <- (ReferenceResolver.ResolutionEnvironment.EditingOrCompilation true) @@ -1823,10 +1848,10 @@ type IncrementalBuilder(tcGlobals, frameworkTcImports, nonFrameworkAssemblyInput let errorSeverityOptions = builder.TcConfig.errorSeverityOptions let errorLogger = CompilationErrorLogger("IncrementalBuilderCreation", errorSeverityOptions) delayedLogger.CommitDelayedDiagnostics(errorLogger) - errorLogger.GetErrors() |> List.map (fun (d, severity) -> d, severity = FSharpErrorSeverity.Error) + errorLogger.GetErrors() |> Array.map (fun (d, severity) -> d, severity = FSharpErrorSeverity.Error) | _ -> - delayedLogger.Diagnostics - |> List.map (fun (d, isError) -> FSharpErrorInfo.CreateFromException(d, isError, range.Zero)) + Array.ofList delayedLogger.Diagnostics + |> Array.map (fun (d, isError) -> FSharpErrorInfo.CreateFromException(d, isError, range.Zero)) return builderOpt, diagnostics } diff --git a/src/fsharp/service/IncrementalBuild.fsi b/src/fsharp/service/IncrementalBuild.fsi index 807c934281..0f41ce1054 100755 --- a/src/fsharp/service/IncrementalBuild.fsi +++ b/src/fsharp/service/IncrementalBuild.fsi @@ -44,16 +44,16 @@ type internal PartialCheckResults = TcEnvAtEnd : TypeChecker.TcEnv /// Represents the collected errors from type checking - Errors : (PhasedDiagnostic * FSharpErrorSeverity) list + TcErrorsRev : (PhasedDiagnostic * FSharpErrorSeverity)[] list /// Represents the collected name resolutions from type checking - TcResolutions: TcResolutions list + TcResolutionsRev: TcResolutions list /// Represents the collected uses of symbols from type checking - TcSymbolUses: TcSymbolUses list + TcSymbolUsesRev: TcSymbolUses list /// Represents open declarations - TcOpenDeclarations: OpenDeclaration list + TcOpenDeclarationsRev: OpenDeclaration[] list TcDependencyFiles: string list @@ -62,8 +62,13 @@ type internal PartialCheckResults = TimeStamp: DateTime - /// Represents complete typechecked implementation files, including thier typechecked signatures if any. - ImplementationFiles: TypedImplFile list } + /// Represents latest complete typechecked implementation file, including its typechecked signature if any. + /// Empty for a signature file. + LatestImplementationFile: TypedImplFile option } + + member TcErrors: (PhasedDiagnostic * FSharpErrorSeverity)[] + + member TcSymbolUses: TcSymbolUses list /// Manages an incremental build graph for the build of an F# project [] @@ -151,9 +156,9 @@ type internal IncrementalBuilder = /// Await the untyped parse results for a particular slot in the vector of parse results. /// /// 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 + 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 -> 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 -> Cancellable /// Increment the usage count on the IncrementalBuilder by 1. This initial usage count is 0 so immediately after creation /// a call to KeepBuilderAlive should be made. The returns an IDisposable which will diff --git a/src/fsharp/service/ServiceAnalysis.fs b/src/fsharp/service/ServiceAnalysis.fs index d8b05a2d06..69624c252a 100644 --- a/src/fsharp/service/ServiceAnalysis.fs +++ b/src/fsharp/service/ServiceAnalysis.fs @@ -5,26 +5,31 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.PrettyNaming +open System.Collections.Generic +open System.Runtime.CompilerServices module UnusedOpens = - open Microsoft.FSharp.Compiler.PrettyNaming - open System.Runtime.CompilerServices - type Module = - { Entity: FSharpEntity - IsNestedAutoOpen: bool } + let symbolHash = HashIdentity.FromFunctions (fun (x: FSharpSymbol) -> x.GetEffectivelySameAsHash()) (fun x y -> x.IsEffectivelySameAs(y)) - member this.ChildSymbols = - seq { for ent in this.Entity.NestedEntities do + /// Represents one namespace or module opened by an 'open' statement + type OpenedModule(entity: FSharpEntity, isNestedAutoOpen: bool) = + + /// Compute an indexed table of the set of symbols revealed by 'open', on-demand + let revealedSymbols : Lazy> = + lazy + let symbols = + [| for ent in entity.NestedEntities do yield ent :> FSharpSymbol if ent.IsFSharpRecord then for rf in ent.FSharpFields do - yield upcast rf + yield rf :> FSharpSymbol if ent.IsFSharpUnion && not (Symbol.hasAttribute ent.Attributes) then for unionCase in ent.UnionCases do - yield upcast unionCase + yield unionCase :> FSharpSymbol if Symbol.hasAttribute ent.Attributes then for fv in ent.MembersFunctionsAndValues do @@ -32,128 +37,171 @@ module UnusedOpens = // so we have to check Extension attribute instead. // (note: fv.IsExtensionMember has proper value for symbols returning by GetAllUsesOfAllSymbolsInFile though) if Symbol.hasAttribute fv.Attributes then - yield upcast fv + yield fv :> FSharpSymbol - for apCase in this.Entity.ActivePatternCases do - yield upcast apCase + for apCase in entity.ActivePatternCases do + yield apCase :> FSharpSymbol + + // The IsNamespace and IsFSharpModule cases are handled by looking at DeclaringEntity below + if not entity.IsNamespace && not entity.IsFSharpModule then + for fv in entity.MembersFunctionsAndValues do + yield fv :> FSharpSymbol |] + + HashSet<_>(symbols, symbolHash) - for fv in this.Entity.MembersFunctionsAndValues do - yield upcast fv - } |> Seq.cache + member __.Entity = entity + member __.IsNestedAutoOpen = isNestedAutoOpen + member __.RevealedSymbolsContains(symbol) = revealedSymbols.Force().Contains symbol - type ModuleGroup = - { Modules: Module list } + type OpenedModuleGroup = + { OpenedModules: OpenedModule list } static member Create (modul: FSharpEntity) = let rec getModuleAndItsAutoOpens (isNestedAutoOpen: bool) (modul: FSharpEntity) = - [ yield { Entity = modul; IsNestedAutoOpen = isNestedAutoOpen } + [ yield OpenedModule (modul, isNestedAutoOpen) for ent in modul.NestedEntities do if ent.IsFSharpModule && Symbol.hasAttribute ent.Attributes then yield! getModuleAndItsAutoOpens true ent ] - { Modules = getModuleAndItsAutoOpens false modul } + { OpenedModules = getModuleAndItsAutoOpens false modul } /// Represents single open statement. type OpenStatement = - { /// All modules which this open declaration effectively opens, _not_ including auto open ones. - Modules: ModuleGroup list - /// Range of open statement itself. + { /// All namespaces and modules which this open declaration effectively opens, including the AutoOpen ones + OpenedGroups: OpenedModuleGroup list + + /// The range of open statement itself Range: range - /// Scope on which this open declaration is applied. + + /// The scope on which this open declaration is applied AppliedScope: range } - let getOpenStatements (openDeclarations: FSharpOpenDeclaration list) : OpenStatement list = + /// Gets the open statements, their scopes and their resolutions + let getOpenStatements (openDeclarations: FSharpOpenDeclaration[]) : OpenStatement[] = openDeclarations - |> List.filter (fun x -> not x.IsOwnNamespace) - |> List.choose (fun openDecl -> + |> Array.filter (fun x -> not x.IsOwnNamespace) + |> Array.choose (fun openDecl -> match openDecl.LongId, openDecl.Range with | firstId :: _, Some range -> if firstId.idText = MangledGlobalName then None else - Some { Modules = openDecl.Modules |> List.map ModuleGroup.Create + Some { OpenedGroups = openDecl.Modules |> List.map OpenedModuleGroup.Create Range = range AppliedScope = openDecl.AppliedScope } | _ -> None) + /// Only consider symbol uses which are the first part of a long ident, i.e. with no qualifying identifiers let filterSymbolUses (getSourceLineStr: int -> string) (symbolUses: FSharpSymbolUse[]) : FSharpSymbolUse[] = symbolUses |> Array.filter (fun su -> match su.Symbol with | :? FSharpMemberOrFunctionOrValue as fv when fv.IsExtensionMember -> - // extension members should be taken into account even though they have a prefix (as they do most of the time) + // Extension members should be taken into account even though they have a prefix (as they do most of the time) true + | :? FSharpMemberOrFunctionOrValue as fv when not fv.IsModuleValueOrMember -> + // Local values can be ignored + false + | :? FSharpGenericParameter -> + // Generic parameters can be ignored, they never come into scope via 'open' + false | _ -> - let partialName = QuickParse.GetPartialLongNameEx (getSourceLineStr su.RangeAlternate.StartLine, su.RangeAlternate.EndColumn - 1) - // for the rest of symbols we pick only those which are the first part of a long idend, because it's they which are - // conteined in opened namespaces / modules. For example, we pick `IO` from long ident `IO.File.OpenWrite` because + // For the rest of symbols we pick only those which are the first part of a long ident, because it's they which are + // contained in opened namespaces / modules. For example, we pick `IO` from long ident `IO.File.OpenWrite` because // it's `open System` which really brings it into scope. - partialName.QualifyingIdents = []) + let partialName = QuickParse.GetPartialLongNameEx (getSourceLineStr su.RangeAlternate.StartLine, su.RangeAlternate.EndColumn - 1) + List.isEmpty partialName.QualifyingIdents) + /// Split symbol uses into cases that are easy to handle (via DeclaringEntity) and those that don't have a good DeclaringEntity + let splitSymbolUses (symbolUses: FSharpSymbolUse[]) : FSharpSymbolUse[] * FSharpSymbolUse[] = + symbolUses |> Array.partition (fun symbolUse -> + let symbol = symbolUse.Symbol + match symbol with + | :? FSharpMemberOrFunctionOrValue as f -> + match f.DeclaringEntity with + | Some ent when ent.IsNamespace || ent.IsFSharpModule -> true + | _ -> false + | _ -> false) + + /// Represents intermediate tracking data used to track the modules which are known to have been used so far type UsedModule = { Module: FSharpEntity AppliedScope: range } - let getUnusedOpens (checkFileResults: FSharpCheckFileResults, getSourceLineStr: int -> string) : Async = - - let filterOpenStatements (openStatements: OpenStatement list) (symbolUses: FSharpSymbolUse[]) : OpenStatement list = - - let rec filterInner acc (openStatements: OpenStatement list) (usedModules: UsedModule list) = - - let getUsedModules (openStatement: OpenStatement) = - let notAlreadyUsedModuleGroups = - openStatement.Modules - |> List.choose (fun x -> - let notUsedModules = - x.Modules - |> List.filter (fun x -> - not (usedModules - |> List.exists (fun used -> - rangeContainsRange used.AppliedScope openStatement.AppliedScope && - used.Module.IsEffectivelySameAs x.Entity))) + /// Given an 'open' statement, find fresh modules/namespaces referred to by that statement where there is some use of a revealed symbol + /// in the scope of the 'open' is from that module. + /// + /// Performance will be roughly NumberOfOpenStatements x NumberOfSymbolUses + let getUsedModules (symbolUses1: FSharpSymbolUse[], symbolUses2: FSharpSymbolUse[]) (usedModules: UsedModule list) (openStatement: OpenStatement) = + + // Don't re-check modules whose symbols are already known to have been used + let openedGroupsToExamine = + openStatement.OpenedGroups |> List.choose (fun openedGroup -> + let openedEntitiesToExamine = + openedGroup.OpenedModules + |> List.filter (fun openedEntity -> + not (usedModules + |> List.exists (fun used -> + rangeContainsRange used.AppliedScope openStatement.AppliedScope && + used.Module.IsEffectivelySameAs openedEntity.Entity))) - match notUsedModules with - | [] -> None - | _ when notUsedModules |> List.exists (fun x -> not x.IsNestedAutoOpen) -> - Some { Modules = notUsedModules } - | _ -> None) - - match notAlreadyUsedModuleGroups with - | [] -> [] - | _ -> - let symbolUsesInScope = symbolUses |> Array.filter (fun symbolUse -> rangeContainsRange openStatement.AppliedScope symbolUse.RangeAlternate) - notAlreadyUsedModuleGroups - |> List.filter (fun modulGroup -> - modulGroup.Modules - |> List.exists (fun modul -> - symbolUsesInScope - |> Array.exists (fun symbolUse -> - let usedByEnclosingEntity = - match symbolUse.Symbol with - | :? FSharpMemberOrFunctionOrValue as f -> - match f.DeclaringEntity with - | Some ent when ent.IsNamespace || ent.IsFSharpModule -> - Some (ent.IsEffectivelySameAs modul.Entity) - | _ -> None - | _ -> None - match usedByEnclosingEntity with - | Some x -> x - | None -> modul.ChildSymbols |> Seq.exists (fun x -> x.IsEffectivelySameAs symbolUse.Symbol) - ))) - |> List.collect (fun mg -> - mg.Modules |> List.map (fun x -> { Module = x.Entity; AppliedScope = openStatement.AppliedScope })) + match openedEntitiesToExamine with + | [] -> None + | _ when openedEntitiesToExamine |> List.exists (fun x -> not x.IsNestedAutoOpen) -> Some { OpenedModules = openedEntitiesToExamine } + | _ -> None) + + // Find the opened groups that are used by some symbol use + let newlyUsedOpenedGroups = + openedGroupsToExamine |> List.filter (fun openedGroup -> + openedGroup.OpenedModules |> List.exists (fun openedEntity -> + + symbolUses1 |> Array.exists (fun symbolUse -> + rangeContainsRange openStatement.AppliedScope symbolUse.RangeAlternate && + match symbolUse.Symbol with + | :? FSharpMemberOrFunctionOrValue as f -> + match f.DeclaringEntity with + | Some ent when ent.IsNamespace || ent.IsFSharpModule -> ent.IsEffectivelySameAs openedEntity.Entity + | _ -> false + | _ -> false) || + + symbolUses2 |> Array.exists (fun symbolUse -> + rangeContainsRange openStatement.AppliedScope symbolUse.RangeAlternate && + openedEntity.RevealedSymbolsContains symbolUse.Symbol))) + + // Return them as interim used entities + newlyUsedOpenedGroups |> List.collect (fun openedGroup -> + openedGroup.OpenedModules |> List.map (fun x -> { Module = x.Entity; AppliedScope = openStatement.AppliedScope })) - match openStatements with - | os :: xs -> - match getUsedModules os with - | [] -> filterInner (os :: acc) xs usedModules - | um -> filterInner acc xs (um @ usedModules) - | [] -> List.rev acc - - filterInner [] openStatements [] + /// Incrementally filter out the open statements one by one. Filter those whose contents are referred to somewhere in the symbol uses. + /// Async to allow cancellation. + let rec filterOpenStatementsIncremental symbolUses (openStatements: OpenStatement list) (usedModules: UsedModule list) acc = + async { + match openStatements with + | openStatement :: rest -> + match getUsedModules symbolUses usedModules openStatement with + | [] -> + // The open statement has not been used, include it in the results + return! filterOpenStatementsIncremental symbolUses rest usedModules (openStatement :: acc) + | moreUsedModules -> + // The open statement has been used, add the modules which are already known to be used to the list of things we don't need to re-check + return! filterOpenStatementsIncremental symbolUses rest (moreUsedModules @ usedModules) acc + | [] -> return List.rev acc + } + + /// Filter out the open statements whose contents are referred to somewhere in the symbol uses. + /// Async to allow cancellation. + let filterOpenStatements symbolUses openStatements = + async { + let! results = filterOpenStatementsIncremental symbolUses (List.ofArray openStatements) [] [] + return results |> List.map (fun os -> os.Range) + } + /// Get the open statements whose contents are not referred to anywhere in the symbol uses. + /// Async to allow cancellation. + let getUnusedOpens (checkFileResults: FSharpCheckFileResults, getSourceLineStr: int -> string) : Async = async { let! symbolUses = checkFileResults.GetAllUsesOfAllSymbolsInFile() let symbolUses = filterSymbolUses getSourceLineStr symbolUses + let symbolUses = splitSymbolUses symbolUses let openStatements = getOpenStatements checkFileResults.OpenDeclarations - return filterOpenStatements openStatements symbolUses |> List.map (fun os -> os.Range) + return! filterOpenStatements symbolUses openStatements } \ No newline at end of file diff --git a/src/fsharp/service/ServiceDeclarationLists.fs b/src/fsharp/service/ServiceDeclarationLists.fs index 5acc998cf4..83f1bccba0 100644 --- a/src/fsharp/service/ServiceDeclarationLists.fs +++ b/src/fsharp/service/ServiceDeclarationLists.fs @@ -736,7 +736,7 @@ type FSharpMethodGroup( name: string, unsortedMethods: FSharpMethodGroupItem[] ) // BUG 413009 : [ParameterInfo] takes about 3 seconds to move from one overload parameter to another // cache allows to avoid recomputing parameterinfo for the same item #if !FX_NO_WEAKTABLE - static let methodOverloadsCache = System.Runtime.CompilerServices.ConditionalWeakTable() + static let methodOverloadsCache = System.Runtime.CompilerServices.ConditionalWeakTable() #endif let methods = diff --git a/src/fsharp/service/ServiceInterfaceStubGenerator.fs b/src/fsharp/service/ServiceInterfaceStubGenerator.fs index 04b09ec157..7532449dc9 100644 --- a/src/fsharp/service/ServiceInterfaceStubGenerator.fs +++ b/src/fsharp/service/ServiceInterfaceStubGenerator.fs @@ -213,7 +213,7 @@ module internal InterfaceStubGenerator = let nm = match arg.Name with | None -> - if arg.Type.HasTypeDefinition && arg.Type.TypeDefinition.XmlDocSig = "T:Microsoft.FSharp.Core.unit" then "()" + if arg.Type.HasTypeDefinition && arg.Type.TypeDefinition.CompiledName = "unit" && arg.Type.TypeDefinition.Namespace = Some "Microsoft.FSharp.Core" then "()" else sprintf "arg%d" (namesWithIndices |> Map.toSeq |> Seq.map snd |> Seq.sumBy Set.count |> max 1) | Some x -> x @@ -302,7 +302,8 @@ module internal InterfaceStubGenerator = let args, namesWithIndices = match argInfos with | [[x]] when v.IsPropertyGetterMethod && x.Name.IsNone - && x.Type.TypeDefinition.XmlDocSig = "T:Microsoft.FSharp.Core.unit" -> + && x.Type.TypeDefinition.CompiledName = "unit" + && x.Type.TypeDefinition.Namespace = Some "Microsoft.FSharp.Core" -> "", Map.ofList [ctx.ObjectIdent, Set.empty] | _ -> formatArgsUsage ctx verboseMode v argInfos diff --git a/src/fsharp/service/ServiceLexing.fs b/src/fsharp/service/ServiceLexing.fs index ce78b9101e..07a300e2b9 100755 --- a/src/fsharp/service/ServiceLexing.fs +++ b/src/fsharp/service/ServiceLexing.fs @@ -77,6 +77,9 @@ module FSharpTokenTag = let STRUCT = tagOfToken STRUCT let CLASS = tagOfToken CLASS let TRY = tagOfToken TRY + let NEW = tagOfToken NEW + let WITH = tagOfToken WITH + let OWITH = tagOfToken OWITH /// This corresponds to a token categorization originally used in Visual Studio 2003. diff --git a/src/fsharp/service/ServiceLexing.fsi b/src/fsharp/service/ServiceLexing.fsi index 01836f0c70..1501f45415 100755 --- a/src/fsharp/service/ServiceLexing.fsi +++ b/src/fsharp/service/ServiceLexing.fsi @@ -182,6 +182,12 @@ module FSharpTokenTag = val CLASS : int /// Indicates the token is keyword `try` val TRY : int + /// Indicates the token is keyword `with` + val WITH : int + /// Indicates the token is keyword `with` in #light + val OWITH : int + /// Indicates the token is keyword `new` + val NEW : int /// Information about a particular token from the tokenizer type FSharpTokenInfo = diff --git a/src/fsharp/service/service.fs b/src/fsharp/service/service.fs index 2896a17f43..f5f4a64025 100755 --- a/src/fsharp/service/service.fs +++ b/src/fsharp/service/service.fs @@ -17,6 +17,7 @@ open Microsoft.FSharp.Core.Printf open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library @@ -165,8 +166,8 @@ type TypeCheckInfo reactorOps : IReactorOperations, checkAlive : (unit -> bool), textSnapshotInfo:obj option, - implementationFiles: TypedImplFile list, - openDeclarations: OpenDeclaration list) = + implFileOpt: TypedImplFile option, + openDeclarations: OpenDeclaration[]) = let textSnapshotInfo = defaultArg textSnapshotInfo null let (|CNR|) (cnr:CapturedNameResolution) = @@ -1393,7 +1394,7 @@ type TypeCheckInfo /// The assembly being analyzed member __.ThisCcu = thisCcu - member __.ImplementationFiles = implementationFiles + member __.ImplementationFile = implFileOpt /// All open declarations in the file, including auto open modules member __.OpenDeclarations = openDeclarations @@ -1601,7 +1602,7 @@ module internal Parser = tcState: TcState, loadClosure: LoadClosure option, // These are the errors and warnings seen by the background compiler for the entire antecedent - backgroundDiagnostics: (PhasedDiagnostic * FSharpErrorSeverity) list, + backgroundDiagnostics: (PhasedDiagnostic * FSharpErrorSeverity)[], reactorOps: IReactorOperations, // Used by 'FSharpDeclarationListInfo' to check the IncrementalBuilder is still alive. checkAlive : (unit -> bool), @@ -1651,7 +1652,7 @@ module internal Parser = let hashLoadBackgroundDiagnostics, otherBackgroundDiagnostics = backgroundDiagnostics - |> List.partition (fun backgroundError -> + |> Array.partition (fun backgroundError -> hashLoadsInFile |> List.exists (fst >> sameFile (fileOfBackgroundError backgroundError))) @@ -1659,17 +1660,17 @@ module internal Parser = // Group errors and warnings by file name. let hashLoadBackgroundDiagnosticsGroupedByFileName = hashLoadBackgroundDiagnostics - |> List.map(fun err -> fileOfBackgroundError err,err) - |> List.groupByFirst // fileWithErrors, error list + |> Array.map(fun err -> fileOfBackgroundError err,err) + |> Array.groupBy fst // fileWithErrors, error list // Join the sets and report errors. // It is by-design that these messages are only present in the language service. A true build would report the errors at their // spots in the individual source files. for (fileOfHashLoad, rangesOfHashLoad) in hashLoadsInFile do - for errorGroupedByFileName in hashLoadBackgroundDiagnosticsGroupedByFileName do - if sameFile (fst errorGroupedByFileName) fileOfHashLoad then + for (file, errorGroupedByFileName) in hashLoadBackgroundDiagnosticsGroupedByFileName do + if sameFile file fileOfHashLoad then for rangeOfHashLoad in rangesOfHashLoad do // Handle the case of two #loads of the same file - let diagnostics = snd errorGroupedByFileName |> List.map(fun (pe,f)->pe.Exception,f) // Strip the build phase here. It will be replaced, in total, with TypeCheck + let diagnostics = errorGroupedByFileName |> Array.map(fun (_,(pe,f)) -> pe.Exception,f) // Strip the build phase here. It will be replaced, in total, with TypeCheck let errors = [ for (err,sev) in diagnostics do if sev = FSharpErrorSeverity.Error then yield err ] let warnings = [ for (err,sev) in diagnostics do if sev = FSharpErrorSeverity.Warning then yield err ] @@ -1728,25 +1729,25 @@ module internal Parser = let errors = errHandler.CollectedDiagnostics match tcEnvAtEndOpt with - | Some (tcEnvAtEnd, typedImplFiles, tcState) -> + | Some (tcEnvAtEnd, implFiles, tcState) -> let scope = TypeCheckInfo(tcConfig, tcGlobals, - tcState.PartialAssemblySignature, - tcState.Ccu, - tcImports, - tcEnvAtEnd.AccessRights, - //typedImplFiles, - projectFileName, - mainInputFileName, - sink.GetResolutions(), - sink.GetSymbolUses(), - tcEnvAtEnd.NameEnv, - loadClosure, - reactorOps, - checkAlive, - textSnapshotInfo, - typedImplFiles, - sink.OpenDeclarations) + tcState.PartialAssemblySignature, + tcState.Ccu, + tcImports, + tcEnvAtEnd.AccessRights, + //typedImplFiles, + projectFileName, + mainInputFileName, + sink.GetResolutions(), + sink.GetSymbolUses(), + tcEnvAtEnd.NameEnv, + loadClosure, + reactorOps, + checkAlive, + textSnapshotInfo, + List.tryHead implFiles, + sink.GetOpenDeclarations()) return errors, TypeCheckAborted.No scope | None -> return errors, TypeCheckAborted.Yes @@ -1855,10 +1856,11 @@ type FSharpCheckProjectResults(projectFileName:string, tcConfigOption, keepAssem member info.GetUsesOfSymbol(symbol:FSharpSymbol) = let (tcGlobals, _tcImports, _thisCcu, _ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() - [| for r in tcSymbolUses do yield! r.GetUsesOfSymbol(symbol.Item) |] - |> Seq.distinctBy (fun (itemOcc,_denv,m) -> itemOcc, m) - |> Seq.filter (fun (itemOcc,_,_) -> itemOcc <> ItemOccurence.RelatedText) - |> Seq.map (fun (itemOcc,denv,m) -> FSharpSymbolUse(tcGlobals, denv, symbol, itemOcc, m)) + tcSymbolUses + |> Seq.collect (fun r -> r.GetUsesOfSymbol symbol.Item) + |> Seq.distinctBy (fun symbolUse -> symbolUse.ItemOccurence, symbolUse.Range) + |> Seq.filter (fun symbolUse -> symbolUse.ItemOccurence <> ItemOccurence.RelatedText) + |> Seq.map (fun symbolUse -> FSharpSymbolUse(tcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range)) |> Seq.toArray |> async.Return @@ -1866,11 +1868,11 @@ type FSharpCheckProjectResults(projectFileName:string, tcConfigOption, keepAssem member info.GetAllUsesOfAllSymbols() = let (tcGlobals, tcImports, thisCcu, _ccuSig, tcSymbolUses, _topAttribs, _tcAssemblyData, _ilAssemRef, _ad, _tcAssemblyExpr, _dependencyFiles) = getDetails() - [| for r in tcSymbolUses do - for (item,itemOcc,denv,m) in r.GetAllUsesOfSymbols() do - if itemOcc <> ItemOccurence.RelatedText then - let symbol = FSharpSymbol.Create(tcGlobals, thisCcu, tcImports, item) - yield FSharpSymbolUse(tcGlobals, denv, symbol, itemOcc, m) |] + [| for r in tcSymbolUses do + for symbolUse in r.AllUsesOfSymbols do + if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then + let symbol = FSharpSymbol.Create(tcGlobals, thisCcu, tcImports, symbolUse.Item) + yield FSharpSymbolUse(tcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range) |] |> async.Return member info.ProjectContext = @@ -2050,7 +2052,7 @@ type FSharpCheckFileResults(filename: string, errors: FSharpErrorInfo[], scopeOp threadSafeOp (fun () -> failwith "not available") (fun scope -> - // This operation is not asynchronous - GetReferencedAssemblies can be run on the calling thread + // This operation is not asynchronous - GetReferencedAssemblies can be run on the calling thread FSharpProjectContext(scope.ThisCcu, scope.GetReferencedAssemblies(), scope.AccessRights)) member info.DependencyFiles = dependencyFiles @@ -2059,19 +2061,19 @@ type FSharpCheckFileResults(filename: string, errors: FSharpErrorInfo[], scopeOp threadSafeOp (fun () -> [| |]) (fun scope -> - [| for (item,itemOcc,denv,m) in scope.ScopeSymbolUses.GetAllUsesOfSymbols() do - if itemOcc <> ItemOccurence.RelatedText then - let symbol = FSharpSymbol.Create(scope.TcGlobals, scope.ThisCcu, scope.TcImports, item) - yield FSharpSymbolUse(scope.TcGlobals, denv, symbol, itemOcc, m) |]) + [| for symbolUse in scope.ScopeSymbolUses.AllUsesOfSymbols do + if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then + let symbol = FSharpSymbol.Create(scope.TcGlobals, scope.ThisCcu, scope.TcImports, symbolUse.Item) + yield FSharpSymbolUse(scope.TcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range) |]) |> async.Return member info.GetUsesOfSymbolInFile(symbol:FSharpSymbol) = threadSafeOp (fun () -> [| |]) (fun scope -> - [| for (itemOcc,denv,m) in scope.ScopeSymbolUses.GetUsesOfSymbol(symbol.Item) |> Seq.distinctBy (fun (itemOcc,_denv,m) -> itemOcc, m) do - if itemOcc <> ItemOccurence.RelatedText then - yield FSharpSymbolUse(scope.TcGlobals, denv, symbol, itemOcc, m) |]) + [| for symbolUse in scope.ScopeSymbolUses.GetUsesOfSymbol(symbol.Item) |> Seq.distinctBy (fun symbolUse -> symbolUse.ItemOccurence, symbolUse.Range) do + if symbolUse.ItemOccurence <> ItemOccurence.RelatedText then + yield FSharpSymbolUse(scope.TcGlobals, symbolUse.DisplayEnv, symbol, symbolUse.ItemOccurence, symbolUse.Range) |]) |> async.Return member info.GetVisibleNamespacesAndModulesAtPoint(pos: pos) = @@ -2092,25 +2094,26 @@ type FSharpCheckFileResults(filename: string, errors: FSharpErrorInfo[], scopeOp RequireCompilationThread ctok scope.IsRelativeNameResolvableFromSymbol(pos, plid, symbol)) - member info.ImplementationFiles = + member info.ImplementationFile = if not keepAssemblyContents then invalidOp "The 'keepAssemblyContents' flag must be set to true on the FSharpChecker in order to access the checked contents of assemblies" scopeOptX |> Option.map (fun scope -> let cenv = Impl.cenv(scope.TcGlobals, scope.ThisCcu, scope.TcImports) - [ for mimpl in scope.ImplementationFiles -> FSharpImplementationFileContents(cenv, mimpl)]) + scope.ImplementationFile |> Option.map (fun implFile -> FSharpImplementationFileContents(cenv, implFile))) + |> Option.defaultValue None member info.OpenDeclarations = scopeOptX |> Option.map (fun scope -> let cenv = Impl.cenv(scope.TcGlobals, scope.ThisCcu, scope.TcImports) - scope.OpenDeclarations |> List.map (fun x -> + scope.OpenDeclarations |> Array.map (fun x -> { LongId = x.LongId Range = x.Range Modules = x.Modules |> List.map (fun x -> FSharpEntity(cenv, x)) AppliedScope = x.AppliedScope IsOwnNamespace = x.IsOwnNamespace } : FSharpOpenDeclaration )) - |> Option.defaultValue [] + |> Option.defaultValue [| |] override info.ToString() = "FSharpCheckFileResults(" + filename + ")" @@ -2201,7 +2204,7 @@ module CompileHelpers = let errors, errorLogger, loggerProvider = mkCompilationErorHandlers() let result = tryCompile errorLogger (fun exiter -> - mainCompile (ctok, argv, legacyReferenceResolver, (*bannerAlreadyPrinted*)true, (*openBinariesInMemory*)true, (*defaultCopyFSharpCore*)false, exiter, loggerProvider, tcImportsCapture, dynamicAssemblyCreator) ) + mainCompile (ctok, argv, legacyReferenceResolver, (*bannerAlreadyPrinted*)true, ReduceMemoryFlag.Yes, CopyFSharpCoreFlag.No, exiter, loggerProvider, tcImportsCapture, dynamicAssemblyCreator) ) errors.ToArray(), result @@ -2214,7 +2217,7 @@ module CompileHelpers = let result = tryCompile errorLogger (fun exiter -> - compileOfAst (ctok, legacyReferenceResolver, (*openBinariesInMemory=*)true, assemblyName, target, outFile, pdbFile, dependencies, noframework, exiter, loggerProvider, asts, tcImportsCapture, dynamicAssemblyCreator)) + compileOfAst (ctok, legacyReferenceResolver, ReduceMemoryFlag.Yes, assemblyName, target, outFile, pdbFile, dependencies, noframework, exiter, loggerProvider, asts, tcImportsCapture, dynamicAssemblyCreator)) errors.ToArray(), result @@ -2260,7 +2263,7 @@ module CompileHelpers = // Register the reflected definitions for the dynamically generated assembly for resource in ilxMainModule.Resources.AsList do if IsReflectedDefinitionsResource resource then - Quotations.Expr.RegisterReflectedDefinitions(assemblyBuilder, moduleBuilder.Name, resource.Bytes) + Quotations.Expr.RegisterReflectedDefinitions(assemblyBuilder, moduleBuilder.Name, resource.GetBytes()) // Save the result assemblyBuilderRef := Some assemblyBuilder @@ -2285,7 +2288,7 @@ type ScriptClosureCacheToken() = interface LockToken // There is only one instance of this type, held in FSharpChecker -type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions) as self = +type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) as self = // STATIC ROOT: FSharpLanguageServiceTestable.FSharpChecker.backgroundCompiler.reactor: The one and only Reactor let reactor = Reactor.Singleton let beforeFileChecked = Event() @@ -2341,7 +2344,8 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC IncrementalBuilder.TryCreateBackgroundBuilderForProjectOptions (ctok, legacyReferenceResolver, defaultFSharpBinariesDir, frameworkTcImportsCache, loadClosure, Array.toList options.SourceFiles, Array.toList options.OtherOptions, projectReferences, options.ProjectDirectory, - options.UseScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds) + options.UseScriptResolutionRules, keepAssemblyContents, keepAllBackgroundResolutions, maxTimeShareMilliseconds, + tryGetMetadataSnapshot) // We're putting the builder in the cache, so increment its count. let decrement = IncrementalBuilder.KeepBuilderAlive builderOpt @@ -2374,7 +2378,7 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC // /// Cache of builds keyed by options. let incrementalBuildersCache = - MruCache + MruCache (keepStrongly=projectCacheSize, keepMax=projectCacheSize, areSame = FSharpProjectOptions.AreSameForChecking, areSimilar = FSharpProjectOptions.UseSameProjectFileName, @@ -2433,7 +2437,7 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC static let mutable foregroundTypeCheckCount = 0 let MakeCheckFileResultsEmpty(filename, creationErrors) = - FSharpCheckFileResults (filename, Array.ofList creationErrors, None, [| |], None, reactorOps, keepAssemblyContents) + FSharpCheckFileResults (filename, creationErrors, None, [| |], None, reactorOps, keepAssemblyContents) let MakeCheckFileResults(filename, options:FSharpProjectOptions, builder, scope, dependencyFiles, creationErrors, parseErrors, tcErrors) = let errors = @@ -2485,7 +2489,7 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC let! builderOpt, creationErrors, decrement = getOrCreateBuilderAndKeepAlive (ctok, options, userOpName) use _unwind = decrement match builderOpt with - | None -> return FSharpParseFileResults(List.toArray creationErrors, None, true, [| |]) + | None -> return FSharpParseFileResults(creationErrors, None, true, [| |]) | Some builder -> let! parseTreeOpt,_,_,parseErrors = builder.GetParseResultsForFile (ctok, filename) let errors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (builder.TcConfig.errorSeverityOptions, false, filename, parseErrors) |] @@ -2527,11 +2531,11 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC source: string, fileName: string, options: FSharpProjectOptions, - textSnapshotInfo : obj option, - fileVersion : int, - builder : IncrementalBuilder, - tcPrior : PartialCheckResults, - creationErrors : FSharpErrorInfo list, + textSnapshotInfo: obj option, + fileVersion: int, + builder: IncrementalBuilder, + tcPrior: PartialCheckResults, + creationErrors: FSharpErrorInfo[], userOpName: string) = async { @@ -2552,7 +2556,7 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC let loadClosure = scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.TryGet (ltok, options)) let! tcErrors, tcFileResult = Parser.CheckOneFile(parseResults, source, fileName, options.ProjectFileName, tcPrior.TcConfig, tcPrior.TcGlobals, tcPrior.TcImports, - tcPrior.TcState, loadClosure, tcPrior.Errors, reactorOps, (fun () -> builder.IsAlive), textSnapshotInfo, userOpName) + tcPrior.TcState, loadClosure, tcPrior.TcErrors, reactorOps, (fun () -> builder.IsAlive), textSnapshotInfo, userOpName) let parsingOptions = FSharpParsingOptions.FromTcConfig(tcPrior.TcConfig, Array.ofList builder.SourceFiles, options.UseScriptResolutionRules) let checkAnswer = MakeCheckFileAnswer(fileName, tcFileResult, options, builder, Array.ofList tcPrior.TcDependencyFiles, creationErrors, parseResults.Errors, tcErrors) bc.RecordTypeCheckFileInProjectResults(fileName, options, parsingOptions, parseResults, fileVersion, tcPrior.TimeStamp, Some checkAnswer, source) @@ -2652,7 +2656,7 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC use _unwind = decrement match builderOpt with | None -> - let parseResults = FSharpParseFileResults(List.toArray creationErrors, None, true, [| |]) + let parseResults = FSharpParseFileResults(creationErrors, None, true, [| |]) return (parseResults, FSharpCheckFileAnswer.Aborted) | Some builder -> @@ -2685,7 +2689,7 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC use _unwind = decrement match builderOpt with | None -> - let parseResults = FSharpParseFileResults(Array.ofList creationErrors, None, true, [| |]) + let parseResults = FSharpParseFileResults(creationErrors, None, true, [| |]) let typedResults = MakeCheckFileResultsEmpty(filename, creationErrors) return (parseResults, typedResults) | Some builder -> @@ -2693,18 +2697,18 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC let! tcProj = builder.GetCheckResultsAfterFileInProject (ctok, filename) let errorOptions = builder.TcConfig.errorSeverityOptions let untypedErrors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, false, filename, untypedErrors) |] - let tcErrors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, false, filename, tcProj.Errors) |] + let tcErrors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, false, filename, tcProj.TcErrors) |] let parseResults = FSharpParseFileResults(errors = untypedErrors, input = parseTreeOpt, parseHadErrors = false, dependencyFiles = builder.AllDependenciesDeprecated) let loadClosure = scriptClosureCacheLock.AcquireLock (fun ltok -> scriptClosureCache.TryGet (ltok, options) ) let scope = TypeCheckInfo(tcProj.TcConfig, tcProj.TcGlobals, tcProj.TcState.PartialAssemblySignature, tcProj.TcState.Ccu, tcProj.TcImports, tcProj.TcEnvAtEnd.AccessRights, options.ProjectFileName, filename, - List.last tcProj.TcResolutions, - List.last tcProj.TcSymbolUses, + List.head tcProj.TcResolutionsRev, + List.head tcProj.TcSymbolUsesRev, tcProj.TcEnvAtEnd.NameEnv, loadClosure, reactorOps, (fun () -> builder.IsAlive), None, - tcProj.ImplementationFiles, - tcProj.TcOpenDeclarations) + tcProj.LatestImplementationFile, + List.head tcProj.TcOpenDeclarationsRev) let typedResults = MakeCheckFileResults(filename, options, builder, scope, Array.ofList tcProj.TcDependencyFiles, creationErrors, parseResults.Errors, tcErrors) return (parseResults, typedResults) }) @@ -2727,12 +2731,12 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC use _unwind = decrement match builderOpt with | None -> - return FSharpCheckProjectResults (options.ProjectFileName, None, keepAssemblyContents, Array.ofList creationErrors, None, reactorOps) + return FSharpCheckProjectResults (options.ProjectFileName, None, keepAssemblyContents, creationErrors, None, reactorOps) | Some builder -> let! (tcProj, ilAssemRef, tcAssemblyDataOpt, tcAssemblyExprOpt) = builder.GetCheckResultsAndImplementationsForProject(ctok) let errorOptions = tcProj.TcConfig.errorSeverityOptions let fileName = TcGlobals.DummyFileNameForRangesWithoutASpecificLocation - let errors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, true, fileName, tcProj.Errors) |] + let errors = [| yield! creationErrors; yield! ErrorHelpers.CreateErrorInfos (errorOptions, true, fileName, tcProj.TcErrors) |] return FSharpCheckProjectResults (options.ProjectFileName, Some tcProj.TcConfig, keepAssemblyContents, errors, Some(tcProj.TcGlobals, tcProj.TcImports, tcProj.TcState.Ccu, tcProj.TcState.PartialAssemblySignature, tcProj.TcSymbolUses, tcProj.TopAttribs, tcAssemblyDataOpt, ilAssemRef, tcProj.TcEnvAtEnd.AccessRights, tcAssemblyExprOpt, Array.ofList tcProj.TcDependencyFiles), reactorOps) } @@ -2763,8 +2767,12 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC reactor.EnqueueAndAwaitOpAsync (userOpName, "GetProjectOptionsFromScript", filename, fun ctok -> cancellable { use errors = new ErrorScope() + // Do we add a reference to FSharp.Compiler.Interactive.Settings by default? let useFsiAuxLib = defaultArg useFsiAuxLib true + + let reduceMemoryUsage = ReduceMemoryFlag.Yes + // Do we assume .NET Framework references for scripts? let assumeDotNetFramework = defaultArg assumeDotNetFramework true let otherFlags = defaultArg otherFlags [| |] @@ -2778,13 +2786,22 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC let applyCompilerOptions tcConfigB = let fsiCompilerOptions = CompileOptions.GetCoreFsiCompilerOptions tcConfigB CompileOptions.ParseCompilerOptions (ignore, fsiCompilerOptions, Array.toList otherFlags) - let loadClosure = LoadClosure.ComputeClosureOfSourceText(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename, source, CodeContext.Editing, useSimpleResolution, useFsiAuxLib, new Lexhelp.LexResourceManager(), applyCompilerOptions, assumeDotNetFramework) + + let loadClosure = + LoadClosure.ComputeClosureOfScriptText(ctok, legacyReferenceResolver, + defaultFSharpBinariesDir, filename, source, + CodeContext.Editing, useSimpleResolution, useFsiAuxLib, new Lexhelp.LexResourceManager(), + applyCompilerOptions, assumeDotNetFramework, + tryGetMetadataSnapshot=tryGetMetadataSnapshot, + reduceMemoryUsage=reduceMemoryUsage) + let otherFlags = [| yield "--noframework"; yield "--warn:3"; yield! otherFlags for r in loadClosure.References do yield "-r:" + fst r for (code,_) in loadClosure.NoWarns do yield "--nowarn:" + code |] + let options = { ProjectFileName = filename + ".fsproj" // Make a name that is unique in this directory. @@ -2901,9 +2918,9 @@ type BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyC [] [] // There is typically only one instance of this type in a Visual Studio process. -type FSharpChecker(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions) = +type FSharpChecker(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) = - let backgroundCompiler = BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions) + let backgroundCompiler = BackgroundCompiler(legacyReferenceResolver, projectCacheSize, keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) static let globalInstance = lazy FSharpChecker.Create() @@ -2919,7 +2936,7 @@ type FSharpChecker(legacyReferenceResolver, projectCacheSize, keepAssemblyConten let maxMemEvent = new Event() /// Instantiate an interactive checker. - static member Create(?projectCacheSize, ?keepAssemblyContents, ?keepAllBackgroundResolutions, ?legacyReferenceResolver) = + static member Create(?projectCacheSize, ?keepAssemblyContents, ?keepAllBackgroundResolutions, ?legacyReferenceResolver, ?tryGetMetadataSnapshot) = let legacyReferenceResolver = match legacyReferenceResolver with @@ -2929,7 +2946,8 @@ type FSharpChecker(legacyReferenceResolver, projectCacheSize, keepAssemblyConten let keepAssemblyContents = defaultArg keepAssemblyContents false let keepAllBackgroundResolutions = defaultArg keepAllBackgroundResolutions true let projectCacheSizeReal = defaultArg projectCacheSize projectCacheSizeDefault - new FSharpChecker(legacyReferenceResolver, projectCacheSizeReal,keepAssemblyContents, keepAllBackgroundResolutions) + let tryGetMetadataSnapshot = defaultArg tryGetMetadataSnapshot (fun _ -> None) + new FSharpChecker(legacyReferenceResolver, projectCacheSizeReal,keepAssemblyContents, keepAllBackgroundResolutions, tryGetMetadataSnapshot) member ic.ReferenceResolver = legacyReferenceResolver @@ -3236,15 +3254,15 @@ type FsiInteractiveChecker(legacyReferenceResolver, reactorOps: IReactorOperatio let dependencyFiles = [| |] // interactions have no dependencies let parseResults = FSharpParseFileResults(parseErrors, parseTreeOpt, parseHadErrors = anyErrors, dependencyFiles = dependencyFiles) - let backgroundDiagnostics = [] - + let backgroundDiagnostics = [| |] + let reduceMemoryUsage = ReduceMemoryFlag.Yes let assumeDotNetFramework = true let applyCompilerOptions tcConfigB = let fsiCompilerOptions = CompileOptions.GetCoreFsiCompilerOptions tcConfigB CompileOptions.ParseCompilerOptions (ignore, fsiCompilerOptions, [ ]) - let loadClosure = LoadClosure.ComputeClosureOfSourceText(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename, source, CodeContext.Editing, tcConfig.useSimpleResolution, tcConfig.useFsiAuxLib, new Lexhelp.LexResourceManager(), applyCompilerOptions, assumeDotNetFramework) + let loadClosure = LoadClosure.ComputeClosureOfScriptText(ctok, legacyReferenceResolver, defaultFSharpBinariesDir, filename, source, CodeContext.Editing, tcConfig.useSimpleResolution, tcConfig.useFsiAuxLib, new Lexhelp.LexResourceManager(), applyCompilerOptions, assumeDotNetFramework, tryGetMetadataSnapshot=(fun _ -> None), reduceMemoryUsage=reduceMemoryUsage) let! tcErrors, tcFileResult = Parser.CheckOneFile(parseResults, source, filename, "project", tcConfig, tcGlobals, tcImports, tcState, Some loadClosure, backgroundDiagnostics, reactorOps, (fun () -> true), None, userOpName) return diff --git a/src/fsharp/service/service.fsi b/src/fsharp/service/service.fsi index 82a1a563ea..072d2813b8 100755 --- a/src/fsharp/service/service.fsi +++ b/src/fsharp/service/service.fsi @@ -10,7 +10,10 @@ open System open System.IO open System.Collections.Generic +open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.Driver @@ -19,12 +22,7 @@ open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.CompileOps -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.Range -open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Infos -open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops @@ -250,11 +248,11 @@ type public FSharpCheckFileResults = /// An optional string used for tracing compiler operations associated with this request. member IsRelativeNameResolvableFromSymbol: cursorPos : pos * plid : string list * symbol: FSharpSymbol * ?userOpName: string -> Async - /// Represents complete typechecked implementation files, including thier typechecked signatures if any. - member ImplementationFiles: FSharpImplementationFileContents list option + /// Represents complete typechecked implementation file, including its typechecked signatures if any. + member ImplementationFile: FSharpImplementationFileContents option /// Open declarations in the file, including auto open modules. - member OpenDeclarations: FSharpOpenDeclaration list + member OpenDeclarations: FSharpOpenDeclaration[] /// A handle to the results of CheckFileInProject. [] @@ -366,7 +364,8 @@ type public FSharpChecker = /// Keep the checked contents of projects. /// 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 - static member Create : ?projectCacheSize: int * ?keepAssemblyContents: bool * ?keepAllBackgroundResolutions: bool * ?legacyReferenceResolver: ReferenceResolver.Resolver -> FSharpChecker + /// 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 -> FSharpChecker /// /// Parse a source code file, returning information about brace matching in the file. diff --git a/src/fsharp/symbols/SymbolHelpers.fs b/src/fsharp/symbols/SymbolHelpers.fs index a2997654b7..2e04170ad0 100644 --- a/src/fsharp/symbols/SymbolHelpers.fs +++ b/src/fsharp/symbols/SymbolHelpers.fs @@ -157,7 +157,7 @@ type internal CompilationErrorLogger (debugName: string, options: FSharpErrorSev override x.ErrorCount = errorCount - member x.GetErrors() = List.ofSeq diagnostics + member x.GetErrors() = diagnostics.ToArray() /// This represents the global state established as each task function runs as part of the build. diff --git a/src/fsharp/symbols/SymbolHelpers.fsi b/src/fsharp/symbols/SymbolHelpers.fsi index 4e95e23a3b..065c28335d 100755 --- a/src/fsharp/symbols/SymbolHelpers.fsi +++ b/src/fsharp/symbols/SymbolHelpers.fsi @@ -188,7 +188,7 @@ type internal CompilationErrorLogger = new: debugName:string * options: FSharpErrorSeverityOptions -> CompilationErrorLogger /// Get the captured errors - member GetErrors: unit -> (PhasedDiagnostic * FSharpErrorSeverity) list + member GetErrors: unit -> (PhasedDiagnostic * FSharpErrorSeverity)[] /// This represents the global state established as each task function runs as part of the build. /// diff --git a/src/fsharp/symbols/Symbols.fs b/src/fsharp/symbols/Symbols.fs index 74aa51c9e2..a21b26650b 100755 --- a/src/fsharp/symbols/Symbols.fs +++ b/src/fsharp/symbols/Symbols.fs @@ -221,6 +221,8 @@ type FSharpSymbol(cenv:cenv, item: (unit -> Item), access: (FSharpSymbol -> CcuT override x.GetHashCode() = hash x.ImplementationLocation + member x.GetEffectivelySameAsHash() = ItemsAreEffectivelyEqualHash cenv.g x.Item + override x.ToString() = "symbol " + (try item().DisplayName with _ -> "?") @@ -367,7 +369,7 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = #if !NO_EXTENSIONTYPING | ProvidedTypeMetadata info -> info.IsClass #endif - | ILTypeMetadata (TILObjectReprData(_, _, td)) -> (td.IsClass) + | ILTypeMetadata (TILObjectReprData(_, _, td)) -> td.IsClass | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> entity.Deref.IsFSharpClassTycon member __.IsByRef = @@ -428,7 +430,6 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member __.Accessibility = if isUnresolved() then FSharpAccessibility(taccessPublic) else - FSharpAccessibility(getApproxFSharpAccessibilityOfEntity entity) member __.RepresentationAccessibility = @@ -471,7 +472,9 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = not (isResolvedAndFSharp()) || entity.Deref.IsPrefixDisplay member x.IsNamespace = entity.IsNamespace + member x.MembersOrValues = x.MembersFunctionsAndValues + member x.MembersFunctionsAndValues = if isUnresolved() then makeReadOnlyCollection[] else protect <| fun () -> @@ -553,6 +556,7 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = |> makeReadOnlyCollection member x.RecordFields = x.FSharpFields + member x.FSharpFields = if isUnresolved() then makeReadOnlyCollection[] else @@ -599,7 +603,7 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = | [] -> [[path]] | _ -> paths |> List.map (fun x -> path :: x) - let walkParts (parts: (string * ModuleOrNamespaceKind) list) = //: string list list = + let walkParts (parts: (string * ModuleOrNamespaceKind) list) = let rec loop (currentPaths: string list list) parts = match parts with | [] -> currentPaths @@ -2169,11 +2173,25 @@ and FSharpAssemblySignature private (cenv, topAttribs: TypeChecker.TopAttribs op loop mtyp |> makeReadOnlyCollection member __.Attributes = - match topAttribs with - | None -> makeReadOnlyCollection [] - | Some tA -> - tA.assemblyAttrs - |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) |> makeReadOnlyCollection + [ match optViewedCcu with + | Some ccu -> + match ccu.TryGetILModuleDef() with + | Some ilModule -> + match ilModule.Manifest with + | None -> () + | Some manifest -> + for a in AttribInfosOfIL cenv.g cenv.amap cenv.thisCcu.ILScopeRef range0 manifest.CustomAttrs do + yield FSharpAttribute(cenv, a) + | None -> + // If no module is available, then look in the CCU contents. + if ccu.IsFSharp then + for a in ccu.Contents.Attribs do + yield FSharpAttribute(cenv, FSAttribInfo (cenv.g, a)) + | None -> + match topAttribs with + | None -> () + | Some tA -> for a in tA.assemblyAttrs do yield FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a)) ] + |> makeReadOnlyCollection member __.FindEntityByPath path = let inline findNested name = function diff --git a/src/fsharp/symbols/Symbols.fsi b/src/fsharp/symbols/Symbols.fsi index 55c1a6fbb2..730c60e79e 100644 --- a/src/fsharp/symbols/Symbols.fsi +++ b/src/fsharp/symbols/Symbols.fsi @@ -86,7 +86,12 @@ type [] public FSharpSymbol = /// /// This is the relation used by GetUsesOfSymbol and GetUsesOfSymbolInFile. member IsEffectivelySameAs : other: FSharpSymbol -> bool + + /// A hash compatible with the IsEffectivelySameAs relation + member GetEffectivelySameAsHash : unit -> int + member IsExplicitlySuppressed : bool + static member GetAccessibility : FSharpSymbol -> FSharpAccessibility option /// Represents an assembly as seen by the F# language @@ -293,7 +298,6 @@ and [] public FSharpEntity = /// Get the cases of a union type member UnionCases : IList - /// Indicates if the type is a delegate with the given Invoke signature member FSharpDelegateSignature : FSharpDelegateSignature diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 77552c18d8..cca16b60a4 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -485,15 +485,51 @@ let ComputeDefinitionLocationOfProvidedItem (p : Tainted<#IProvidedCustomAttribu #endif -/// Represents a type definition, exception definition, module definition or namespace definition. -[] -type Entity = - { /// The declared type parameters of the type - // MUTABILITY; used only during creation and remapping of tycons - mutable entity_typars: LazyWithContext +type EntityOptionalData = + { + /// The name of the type, possibly with `n mangling + // MUTABILITY; used only when establishing tycons. + mutable entity_compiled_name: string option + + // MUTABILITY: the signature is adjusted when it is checked + /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is + /// the signature range for an item in an implementation + mutable entity_other_range: (range * bool) option // MUTABILITY; used only when establishing tycons. mutable entity_kind : TyparKind + + /// The declared documentation for the type or module + // MUTABILITY: only for unpickle linkage + mutable entity_xmldoc : XmlDoc + + /// The XML document signature for this entity + mutable entity_xmldocsig : string + + /// If non-None, indicates the type is an abbreviation for another type. + // + // MUTABILITY; used only during creation and remapping of tycons + mutable entity_tycon_abbrev: TType option + + /// The declared accessibility of the representation, not taking signatures into account + mutable entity_tycon_repr_accessibility: Accessibility + + /// Indicates how visible is the entity is. + // MUTABILITY: only for unpickle linkage + mutable entity_accessiblity: Accessibility + + /// Field used when the 'tycon' is really an exception definition + // + // MUTABILITY; used only during creation and remapping of tycons + mutable entity_exn_info: ExceptionInfo + } + +and /// Represents a type definition, exception definition, module definition or namespace definition. + [] + Entity = + { /// The declared type parameters of the type + // MUTABILITY; used only during creation and remapping of tycons + mutable entity_typars: LazyWithContext mutable entity_flags : EntityFlags @@ -505,21 +541,9 @@ type Entity = // MUTABILITY: only for unpickle linkage mutable entity_logical_name: string - /// The name of the type, possibly with `n mangling - // MUTABILITY; used only when establishing tycons. - mutable entity_compiled_name: string option - /// The declaration location for the type constructor mutable entity_range: range - // MUTABILITY: the signature is adjusted when it is checked - /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is - /// the signature range for an item in an implementation - mutable entity_other_range: (range * bool) option - - /// The declared accessibility of the representation, not taking signatures into account - mutable entity_tycon_repr_accessibility: Accessibility - /// The declared attributes for the type // MUTABILITY; used during creation and remapping of tycons // MUTABILITY; used when propagating signature attributes into the implementation. @@ -529,43 +553,22 @@ type Entity = // // MUTABILITY; used only during creation and remapping of tycons mutable entity_tycon_repr: TyconRepresentation - - /// If non-None, indicates the type is an abbreviation for another type. - // - // MUTABILITY; used only during creation and remapping of tycons - mutable entity_tycon_abbrev: TType option /// The methods and properties of the type // // MUTABILITY; used only during creation and remapping of tycons mutable entity_tycon_tcaug: TyconAugmentation - /// Field used when the 'tycon' is really an exception definition - // - // MUTABILITY; used only during creation and remapping of tycons - mutable entity_exn_info: ExceptionInfo - /// This field is used when the 'tycon' is really a module definition. It holds statically nested type definitions and nested modules // // MUTABILITY: only used during creation and remapping of tycons and // when compiling fslib to fixup compiler forward references to internal items mutable entity_modul_contents: MaybeLazy - /// The declared documentation for the type or module - // MUTABILITY: only for unpickle linkage - mutable entity_xmldoc : XmlDoc - - /// The XML document signature for this entity - mutable entity_xmldocsig : string - /// The stable path to the type, e.g. Microsoft.FSharp.Core.FSharpFunc`2 // REVIEW: it looks like entity_cpath subsumes this // MUTABILITY: only for unpickle linkage mutable entity_pubpath : PublicPath option - - /// Indicates how visible is the entity is. - // MUTABILITY: only for unpickle linkage - mutable entity_accessiblity: Accessibility /// The stable path to the type, e.g. Microsoft.FSharp.Core.FSharpFunc`2 // MUTABILITY: only for unpickle linkage @@ -574,12 +577,30 @@ type Entity = /// Used during codegen to hold the ILX representation indicating how to access the type // MUTABILITY: only for unpickle linkage and caching mutable entity_il_repr_cache : CompiledTypeRepr cache + + mutable entity_opt_data : EntityOptionalData option } + + static member EmptyEntityOptData = { entity_compiled_name = None; entity_other_range = None; entity_kind = TyparKind.Type; entity_xmldoc = XmlDoc.Empty; entity_xmldocsig = ""; entity_tycon_abbrev = None; entity_tycon_repr_accessibility = TAccess []; entity_accessiblity = TAccess []; entity_exn_info = TExnNone } + /// The name of the namespace, module or type, possibly with mangling, e.g. List`1, List or FailureException member x.LogicalName = x.entity_logical_name /// The compiled name of the namespace, module or type, e.g. FSharpList`1, ListModule or FailureException - member x.CompiledName = match x.entity_compiled_name with None -> x.LogicalName | Some s -> s + member x.CompiledName = + match x.entity_opt_data with + | Some { entity_compiled_name = Some s } -> s + | _ -> x.LogicalName + + member x.EntityCompiledName = + match x.entity_opt_data with + | Some optData -> optData.entity_compiled_name + | _ -> None + + member x.SetCompiledName(name) = + match x.entity_opt_data with + | Some optData -> optData.entity_compiled_name <- name + | _ -> x.entity_opt_data <- Some { Entity.EmptyEntityOptData with entity_compiled_name = name } /// The display name of the namespace, module or type, e.g. List instead of List`1, and no static parameters member x.DisplayName = x.GetDisplayName(false, false) @@ -604,7 +625,7 @@ type Entity = | [] -> nm | tps -> let nm = DemangleGenericTypeName nm - if withUnderscoreTypars && tps.Length > 0 then + if withUnderscoreTypars && not (List.isEmpty tps) then nm + "<" + String.concat "," (Array.create tps.Length "_") + ">" else nm @@ -638,16 +659,19 @@ type Entity = /// The range in the implementation, adjusted for an item in a signature member x.DefinitionRange = - match x.entity_other_range with - | Some (r, true) -> r + match x.entity_opt_data with + | Some { entity_other_range = Some (r, true) } -> r | _ -> x.Range member x.SigRange = - match x.entity_other_range with - | Some (r, false) -> r + match x.entity_opt_data with + | Some { entity_other_range = Some (r, false) } -> r | _ -> x.Range - member x.SetOtherRange m = x.entity_other_range <- Some m + member x.SetOtherRange m = + match x.entity_opt_data with + | Some optData -> optData.entity_other_range <- Some m + | _ -> x.entity_opt_data <- Some { Entity.EmptyEntityOptData with entity_other_range = Some m } /// A unique stamp for this module, namespace or type definition within the context of this compilation. /// Note that because of signatures, there are situations where in a single compilation the "same" @@ -668,13 +692,21 @@ type Entity = | TProvidedTypeExtensionPoint info -> XmlDoc (info.ProvidedType.PUntaintNoFailure(fun st -> (st :> IProvidedCustomAttributeProvider).GetXmlDocAttributes(info.ProvidedType.TypeProvider.PUntaintNoFailure(id)))) | _ -> #endif - x.entity_xmldoc + match x.entity_opt_data with + | Some optData -> optData.entity_xmldoc + | _ -> XmlDoc.Empty /// The XML documentation sig-string of the entity, if any, to use to lookup an .xml doc file. This also acts /// as a cache for this sig-string computation. member x.XmlDocSig - with get() = x.entity_xmldocsig - and set v = x.entity_xmldocsig <- v + with get() = + match x.entity_opt_data with + | Some optData -> optData.entity_xmldocsig + | _ -> "" + and set v = + match x.entity_opt_data with + | Some optData -> optData.entity_xmldocsig <- v + | _ -> x.entity_opt_data <- Some { Entity.EmptyEntityOptData with entity_xmldocsig = v } /// The logical contents of the entity when it is a module or namespace fragment. member x.ModuleOrNamespaceType = x.entity_modul_contents.Force() @@ -683,7 +715,15 @@ type Entity = member x.TypeContents = x.entity_tycon_tcaug /// The kind of the type definition - is it a measure definition or a type definition? - member x.TypeOrMeasureKind = x.entity_kind + member x.TypeOrMeasureKind = + match x.entity_opt_data with + | Some optData -> optData.entity_kind + | _ -> TyparKind.Type + + member x.SetTypeOrMeasureKind kind = + match x.entity_opt_data with + | Some optData -> optData.entity_kind <- kind + | _ -> x.entity_opt_data <- Some { Entity.EmptyEntityOptData with entity_kind = kind } /// The identifier at the point of declaration of the type definition. member x.Id = ident(x.LogicalName, x.Range) @@ -692,7 +732,15 @@ type Entity = member x.TypeReprInfo = x.entity_tycon_repr /// The information about the r.h.s. of an F# exception definition, if any. - member x.ExceptionInfo = x.entity_exn_info + member x.ExceptionInfo = + match x.entity_opt_data with + | Some optData -> optData.entity_exn_info + | _ -> TExnNone + + member x.SetExceptionInfo exn_info = + match x.entity_opt_data with + | Some optData -> optData.entity_exn_info <- exn_info + | _ -> x.entity_opt_data <- Some { Entity.EmptyEntityOptData with entity_exn_info = exn_info } /// Indicates if the entity represents an F# exception declaration. member x.IsExceptionDecl = match x.ExceptionInfo with TExnNone -> false | _ -> true @@ -710,13 +758,24 @@ type Entity = member x.TyparsNoRange = x.Typars x.Range /// Get the type abbreviated by this type definition, if it is an F# type abbreviation definition - member x.TypeAbbrev = x.entity_tycon_abbrev + member x.TypeAbbrev = + match x.entity_opt_data with + | Some optData -> optData.entity_tycon_abbrev + | _ -> None + + member x.SetTypeAbbrev tycon_abbrev = + match x.entity_opt_data with + | Some optData -> optData.entity_tycon_abbrev <- tycon_abbrev + | _ -> x.entity_opt_data <- Some { Entity.EmptyEntityOptData with entity_tycon_abbrev = tycon_abbrev } /// Indicates if this entity is an F# type abbreviation definition member x.IsTypeAbbrev = x.TypeAbbrev.IsSome /// Get the value representing the accessibility of the r.h.s. of an F# type definition. - member x.TypeReprAccessibility = x.entity_tycon_repr_accessibility + member x.TypeReprAccessibility = + match x.entity_opt_data with + | Some optData -> optData.entity_tycon_repr_accessibility + | _ -> TAccess [] /// Get the cache of the compiled ILTypeRef representation of this module or type. member x.CompiledReprCache = x.entity_il_repr_cache @@ -725,7 +784,10 @@ type Entity = member x.PublicPath = x.entity_pubpath /// Get the value representing the accessibility of an F# type definition or module. - member x.Accessibility = x.entity_accessiblity + member x.Accessibility = + match x.entity_opt_data with + | Some optData -> optData.entity_accessiblity + | _ -> TAccess [] /// Indicates the type prefers the "tycon" syntax for display etc. member x.IsPrefixDisplay = x.entity_flags.IsPrefixDisplay @@ -849,26 +911,18 @@ type Entity = /// Create a new entity with empty, unlinked data. Only used during unpickling of F# metadata. static member NewUnlinked() : Entity = { entity_typars = Unchecked.defaultof<_> - entity_kind = Unchecked.defaultof<_> entity_flags = Unchecked.defaultof<_> entity_stamp = Unchecked.defaultof<_> entity_logical_name = Unchecked.defaultof<_> - entity_compiled_name = Unchecked.defaultof<_> entity_range = Unchecked.defaultof<_> - entity_other_range = Unchecked.defaultof<_> - entity_tycon_repr_accessibility = Unchecked.defaultof<_> entity_attribs = Unchecked.defaultof<_> entity_tycon_repr= Unchecked.defaultof<_> - entity_tycon_abbrev= Unchecked.defaultof<_> entity_tycon_tcaug= Unchecked.defaultof<_> - entity_exn_info= Unchecked.defaultof<_> entity_modul_contents= Unchecked.defaultof<_> - entity_xmldoc = Unchecked.defaultof<_> - entity_xmldocsig = Unchecked.defaultof<_> entity_pubpath = Unchecked.defaultof<_> - entity_accessiblity= Unchecked.defaultof<_> entity_cpath = Unchecked.defaultof<_> - entity_il_repr_cache = Unchecked.defaultof<_> } + entity_il_repr_cache = Unchecked.defaultof<_> + entity_opt_data = Unchecked.defaultof<_>} /// Create a new entity with the given backing data. Only used during unpickling of F# metadata. static member New _reason (data: Entity) : Entity = data @@ -876,26 +930,21 @@ type Entity = /// Link an entity based on empty, unlinked data to the given data. Only used during unpickling of F# metadata. member x.Link (tg: EntityData) = x.entity_typars <- tg.entity_typars - x.entity_kind <- tg.entity_kind x.entity_flags <- tg.entity_flags x.entity_stamp <- tg.entity_stamp x.entity_logical_name <- tg.entity_logical_name - x.entity_compiled_name <- tg.entity_compiled_name x.entity_range <- tg.entity_range - x.entity_other_range <- tg.entity_other_range - x.entity_tycon_repr_accessibility <- tg.entity_tycon_repr_accessibility x.entity_attribs <- tg.entity_attribs x.entity_tycon_repr <- tg.entity_tycon_repr - x.entity_tycon_abbrev <- tg.entity_tycon_abbrev x.entity_tycon_tcaug <- tg.entity_tycon_tcaug - x.entity_exn_info <- tg.entity_exn_info x.entity_modul_contents <- tg.entity_modul_contents - x.entity_xmldoc <- tg.entity_xmldoc - x.entity_xmldocsig <- tg.entity_xmldocsig x.entity_pubpath <- tg.entity_pubpath - x.entity_accessiblity <- tg.entity_accessiblity x.entity_cpath <- tg.entity_cpath x.entity_il_repr_cache <- tg.entity_il_repr_cache + match tg.entity_opt_data with + | Some tg -> + x.entity_opt_data <- Some { entity_compiled_name = tg.entity_compiled_name; entity_other_range = tg.entity_other_range; entity_kind = tg.entity_kind; entity_xmldoc = tg.entity_xmldoc; entity_xmldocsig = tg.entity_xmldocsig; entity_tycon_abbrev = tg.entity_tycon_abbrev; entity_tycon_repr_accessibility = tg.entity_tycon_repr_accessibility; entity_accessiblity = tg.entity_accessiblity; entity_exn_info = tg.entity_exn_info } + | None -> () /// Indicates if the entity is linked to backing data. Only used during unpickling of F# metadata. @@ -1809,26 +1858,21 @@ and Construct = Tycon.New "tycon" { entity_stamp=stamp entity_logical_name=name - entity_compiled_name=None - entity_kind=kind entity_range=m - entity_other_range=None entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false,preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordOrUnionType=false) entity_attribs=[] // fetched on demand via est.fs API entity_typars= LazyWithContext.NotLazy [] - entity_tycon_abbrev = None entity_tycon_repr = repr - entity_tycon_repr_accessibility = TAccess([]) - entity_exn_info=TExnNone entity_tycon_tcaug=TyconAugmentation.Create() entity_modul_contents = MaybeLazy.Lazy (lazy new ModuleOrNamespaceType(Namespace, QueueList.ofList [], QueueList.ofList [])) // Generated types get internal accessibility - entity_accessiblity= access - entity_xmldoc = XmlDoc [||] // fetched on demand via est.fs API - entity_xmldocsig="" entity_pubpath = Some pubpath entity_cpath = Some cpath - entity_il_repr_cache = newCache() } + entity_il_repr_cache = newCache() + entity_opt_data = + match kind, access with + | TyparKind.Type, TAccess [] -> None + | _ -> Some { Entity.EmptyEntityOptData with entity_kind = kind; entity_accessiblity = access } } #endif static member NewModuleOrNamespace cpath access (id:Ident) xml attribs mtype = @@ -1836,26 +1880,21 @@ and Construct = // Put the module suffix on if needed Tycon.New "mspec" { entity_logical_name=id.idText - entity_compiled_name=None entity_range = id.idRange - entity_other_range = None entity_stamp=stamp - entity_kind=TyparKind.Type entity_modul_contents = mtype entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=true, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false,isStructRecordOrUnionType=false) entity_typars=LazyWithContext.NotLazy [] - entity_tycon_abbrev = None entity_tycon_repr = TNoRepr - entity_tycon_repr_accessibility = access - entity_exn_info=TExnNone entity_tycon_tcaug=TyconAugmentation.Create() entity_pubpath=cpath |> Option.map (fun (cp:CompilationPath) -> cp.NestedPublicPath id) entity_cpath=cpath - entity_accessiblity=access entity_attribs=attribs - entity_xmldoc=xml - entity_xmldocsig="" - entity_il_repr_cache = newCache() } + entity_il_repr_cache = newCache() + entity_opt_data = + match xml, access with + | XmlDoc [||], TAccess [] -> None + | _ -> Some { Entity.EmptyEntityOptData with entity_xmldoc = xml; entity_tycon_repr_accessibility = access; entity_accessiblity = access } } and Accessibility = /// Indicates the construct can only be accessed from any code in the given type constructor, module or assembly. [] indicates global scope. @@ -2156,57 +2195,21 @@ and ValLinkageFullKey(partialKey: ValLinkagePartialKey, typeForLinkage:TType op /// The full type of the value for the purposes of linking. May be None for non-members, since they can't be overloaded. member x.TypeForLinkage = typeForLinkage - -and ValData = Val -and [] - Val = - // ValData is 19 words!! CONSIDER THIS TINY FORMAT, for all local, immutable, attribute-free values - // val_logical_name: string - // val_range: range - // mutable val_type: TType - // val_stamp: Stamp - - { - /// MUTABILITY: for unpickle linkage - mutable val_logical_name: string - +and ValOptionalData = + { /// MUTABILITY: for unpickle linkage mutable val_compiled_name: string option - /// MUTABILITY: for unpickle linkage - mutable val_range: range - /// If this field is populated, this is the implementation range for an item in a signature, otherwise it is /// the signature range for an item in an implementation mutable val_other_range: (range * bool) option - mutable val_type: TType - - /// MUTABILITY: for unpickle linkage - mutable val_stamp: Stamp - - /// See vflags section further below for encoding/decodings here - mutable val_flags: ValFlags - mutable val_const: Const option /// What is the original, unoptimized, closed-term definition, if any? /// Used to implement [] mutable val_defn: Expr option - /// How visible is this? - /// MUTABILITY: for unpickle linkage - mutable val_access: Accessibility - - /// Is the value actually an instance method/property/event that augments - /// a type, and if so what name does it take in the IL? - /// MUTABILITY: for unpickle linkage - mutable val_member_info: ValMemberInfo option - - /// Custom attributes attached to the value. These contain references to other values (i.e. constructors in types). Mutable to fixup - /// these value references after copying a collection of values. - mutable val_attribs: Attribs - // MUTABILITY CLEANUP: mutability of this field is used by // -- adjustAllUsesOfRecValue // -- TLR optimizations @@ -2216,29 +2219,65 @@ and [] // type-checked expression. mutable val_repr_info: ValReprInfo option + /// How visible is this? + /// MUTABILITY: for unpickle linkage + mutable val_access: Accessibility + + /// XML documentation attached to a value. + /// MUTABILITY: for unpickle linkage + mutable val_xmldoc : XmlDoc + + /// Is the value actually an instance method/property/event that augments + /// a type, and if so what name does it take in the IL? + /// MUTABILITY: for unpickle linkage + mutable val_member_info: ValMemberInfo option + // MUTABILITY CLEANUP: mutability of this field is used by // -- LinearizeTopMatch // // The fresh temporary should just be created with the right parent mutable val_declaring_entity: ParentRef - /// XML documentation attached to a value. + /// XML documentation signature for the value + mutable val_xmldocsig : string + + /// Custom attributes attached to the value. These contain references to other values (i.e. constructors in types). Mutable to fixup + /// these value references after copying a collection of values. + mutable val_attribs: Attribs + } + +and ValData = Val +and [] + Val = + { /// MUTABILITY: for unpickle linkage - mutable val_xmldoc : XmlDoc + mutable val_logical_name: string + + /// MUTABILITY: for unpickle linkage + mutable val_range: range + + mutable val_type: TType + + /// MUTABILITY: for unpickle linkage + mutable val_stamp: Stamp + + /// See vflags section further below for encoding/decodings here + mutable val_flags: ValFlags - /// XML documentation signature for the value - mutable val_xmldocsig : string } + mutable val_opt_data : ValOptionalData option } + + static member EmptyValOptData = { val_compiled_name = None; val_other_range = None; val_const = None; val_defn = None; val_repr_info = None; val_access = TAccess []; val_xmldoc = XmlDoc.Empty; val_member_info = None; val_declaring_entity = ParentNone; val_xmldocsig = String.Empty; val_attribs = [] } /// Range of the definition (implementation) of the value, used by Visual Studio member x.DefinitionRange = - match x.val_other_range with - | Some (m,true) -> m + match x.val_opt_data with + | Some { val_other_range = Some(m,true) } -> m | _ -> x.val_range /// Range of the definition (signature) of the value, used by Visual Studio member x.SigRange = - match x.val_other_range with - | Some (m,false) -> m + match x.val_opt_data with + | Some { val_other_range = Some(m,false) } -> m | _ -> x.val_range /// The place where the value was defined. @@ -2255,10 +2294,16 @@ and [] member x.Type = x.val_type /// How visible is this value, function or member? - member x.Accessibility = x.val_access + member x.Accessibility = + match x.val_opt_data with + | Some optData -> optData.val_access + | _ -> TAccess [] /// The value of a value or member marked with [] - member x.LiteralValue = x.val_const + member x.LiteralValue = + match x.val_opt_data with + | Some optData -> optData.val_const + | _ -> None /// Records the "extra information" for a value compiled as a method. /// @@ -2275,7 +2320,10 @@ and [] /// /// TLR also sets this for inner bindings that it wants to /// represent as "top level" bindings. - member x.ValReprInfo : ValReprInfo option = x.val_repr_info + member x.ValReprInfo : ValReprInfo option = + match x.val_opt_data with + | Some optData -> optData.val_repr_info + | _ -> None member x.Id = ident(x.LogicalName,x.Range) @@ -2311,13 +2359,19 @@ and [] member x.IsExtensionMember = x.val_flags.IsExtensionMember /// The quotation expression associated with a value given the [] tag - member x.ReflectedDefinition = x.val_defn + member x.ReflectedDefinition = + match x.val_opt_data with + | Some optData -> optData.val_defn + | _ -> None /// Is this a member, if so some more data about the member. /// /// Note, the value may still be (a) an extension member or (b) and abstract slot without /// a true body. These cases are often causes of bugs in the compiler. - member x.MemberInfo = x.val_member_info + member x.MemberInfo = + match x.val_opt_data with + | Some optData -> optData.val_member_info + | _ -> None /// Indicates if this is a member member x.IsMember = x.MemberInfo.IsSome @@ -2401,18 +2455,33 @@ and [] member x.IsCompilerGenerated = x.val_flags.IsCompilerGenerated /// Get the declared attributes for the value - member x.Attribs = x.val_attribs + member x.Attribs = + match x.val_opt_data with + | Some optData -> optData.val_attribs + | _ -> [] /// Get the declared documentation for the value - member x.XmlDoc = x.val_xmldoc + member x.XmlDoc = + match x.val_opt_data with + | Some optData -> optData.val_xmldoc + | _ -> XmlDoc.Empty ///Get the signature for the value's XML documentation member x.XmlDocSig - with get() = x.val_xmldocsig - and set(v) = x.val_xmldocsig <- v + with get() = + match x.val_opt_data with + | Some optData -> optData.val_xmldocsig + | _ -> String.Empty + and set(v) = + match x.val_opt_data with + | Some optData -> optData.val_xmldocsig <- v + | _ -> x.val_opt_data <- Some { Val.EmptyValOptData with val_xmldocsig = v } /// The parent type or module, if any (None for expression bindings and parameters) - member x.DeclaringEntity = x.val_declaring_entity + member x.DeclaringEntity = + match x.val_opt_data with + | Some optData -> optData.val_declaring_entity + | _ -> ParentNone /// Get the actual parent entity for the value (a module or a type), i.e. the entity under which the /// value will appear in compiled code. For extension members this is the module where the extension member @@ -2503,6 +2572,11 @@ and [] | slotsig :: _ -> slotsig.Name | _ -> x.val_logical_name + member x.ValCompiledName = + match x.val_opt_data with + | Some optData -> optData.val_compiled_name + | _ -> None + /// The name of the method in compiled code (with some exceptions where ilxgen.fs decides not to use a method impl) /// - If this is a property then this is 'get_Foo' or 'set_Foo' /// - If this is an implementation of an abstract slot then this may be a mangled name @@ -2510,9 +2584,9 @@ and [] /// - If this is an operator then this is 'op_Addition' member x.CompiledName = let givenName = - match x.val_compiled_name with - | Some n -> n - | None -> x.LogicalName + match x.val_opt_data with + | Some { val_compiled_name = Some n } -> n + | _ -> x.LogicalName // These cases must get stable unique names for their static field & static property. This name // must be stable across quotation generation and IL code generation (quotations can refer to the // properties implicit in these) @@ -2568,28 +2642,40 @@ and [] member x.SetHasBeenReferenced() = x.val_flags <- x.val_flags.SetHasBeenReferenced member x.SetIsCompiledAsStaticPropertyWithoutField() = x.val_flags <- x.val_flags.SetIsCompiledAsStaticPropertyWithoutField member x.SetIsFixed() = x.val_flags <- x.val_flags.SetIsFixed - member x.SetValReprInfo info = x.val_repr_info <- info + member x.SetValReprInfo info = + match x.val_opt_data with + | Some optData -> optData.val_repr_info <- info + | _ -> x.val_opt_data <- Some { Val.EmptyValOptData with val_repr_info = info } member x.SetType ty = x.val_type <- ty - member x.SetOtherRange m = x.val_other_range <- Some m + member x.SetOtherRange m = + match x.val_opt_data with + | Some optData -> optData.val_other_range <- Some m + | _ -> x.val_opt_data <- Some { Val.EmptyValOptData with val_other_range = Some m } + member x.SetDeclaringEntity parent = + match x.val_opt_data with + | Some optData -> optData.val_declaring_entity <- parent + | _ -> x.val_opt_data <- Some { Val.EmptyValOptData with val_declaring_entity = parent } + member x.SetAttribs attribs = + match x.val_opt_data with + | Some optData -> optData.val_attribs <- attribs + | _ -> x.val_opt_data <- Some { Val.EmptyValOptData with val_attribs = attribs } + member x.SetMemberInfo member_info = + match x.val_opt_data with + | Some optData -> optData.val_member_info <- Some member_info + | _ -> x.val_opt_data <- Some { Val.EmptyValOptData with val_member_info = Some member_info } + member x.SetValDefn val_defn = + match x.val_opt_data with + | Some optData -> optData.val_defn <- Some val_defn + | _ -> x.val_opt_data <- Some { Val.EmptyValOptData with val_defn = Some val_defn } /// Create a new value with empty, unlinked data. Only used during unpickling of F# metadata. static member NewUnlinked() : Val = { val_logical_name = Unchecked.defaultof<_> - val_compiled_name = Unchecked.defaultof<_> val_range = Unchecked.defaultof<_> - val_other_range = Unchecked.defaultof<_> val_type = Unchecked.defaultof<_> val_stamp = Unchecked.defaultof<_> val_flags = Unchecked.defaultof<_> - val_const = Unchecked.defaultof<_> - val_defn = Unchecked.defaultof<_> - val_access = Unchecked.defaultof<_> - val_member_info = Unchecked.defaultof<_> - val_attribs = Unchecked.defaultof<_> - val_repr_info = Unchecked.defaultof<_> - val_declaring_entity = Unchecked.defaultof<_> - val_xmldoc = Unchecked.defaultof<_> - val_xmldocsig = Unchecked.defaultof<_> } + val_opt_data = Unchecked.defaultof<_> } /// Create a new value with the given backing data. Only used during unpickling of F# metadata. @@ -2601,24 +2687,16 @@ and [] /// Set all the data on a value member x.SetData (tg: ValData) = x.val_logical_name <- tg.val_logical_name - x.val_compiled_name <- tg.val_compiled_name x.val_range <- tg.val_range - x.val_other_range <- tg.val_other_range x.val_type <- tg.val_type x.val_stamp <- tg.val_stamp x.val_flags <- tg.val_flags - x.val_const <- tg.val_const - x.val_defn <- tg.val_defn - x.val_access <- tg.val_access - x.val_member_info <- tg.val_member_info - x.val_attribs <- tg.val_attribs - x.val_repr_info <- tg.val_repr_info - x.val_declaring_entity <- tg.val_declaring_entity - x.val_xmldoc <- tg.val_xmldoc - x.val_xmldocsig <- tg.val_xmldocsig + match tg.val_opt_data with + | Some tg -> x.val_opt_data <- Some { val_compiled_name = tg.val_compiled_name; val_other_range = tg.val_other_range; val_const = tg.val_const; val_defn = tg.val_defn; val_repr_info = tg.val_repr_info; val_access = tg.val_access; val_xmldoc = tg.val_xmldoc; val_member_info = tg.val_member_info; val_declaring_entity = tg.val_declaring_entity; val_xmldocsig = tg.val_xmldocsig; val_attribs = tg.val_attribs } + | None -> () /// Indicates if a value is linked to backing data yet. Only used during unpickling of F# metadata. - member x.IsLinked = match box x.val_attribs with null -> false | _ -> true + member x.IsLinked = match box x.val_logical_name with null -> false | _ -> true override x.ToString() = x.LogicalName @@ -3615,6 +3693,10 @@ and // NOTE: may contain transient state during typechecking mutable Contents: ModuleOrNamespace + /// A helper function used to link method signatures using type equality. This is effectively a forward call to the type equality + /// logic in tastops.fs + TryGetILModuleDef: (unit -> ILModuleDef option) + /// A helper function used to link method signatures using type equality. This is effectively a forward call to the type equality /// logic in tastops.fs MemberSignatureEquality : (TType -> TType -> bool) @@ -3687,6 +3769,9 @@ and CcuThunk = /// Holds the filename for the DLL, if any member ccu.FileName = ccu.Deref.FileName + /// Try to get the .NET Assembly, if known. May not be present for `IsFSharp` for in-memory cross-project references + member ccu.TryGetILModuleDef() = ccu.Deref.TryGetILModuleDef() + #if !NO_EXTENSIONTYPING /// Is the CCu an EST injected assembly member ccu.IsProviderGenerated = ccu.Deref.IsProviderGenerated @@ -4899,25 +4984,20 @@ let NewExn cpath (id:Ident) access repr attribs doc = Tycon.New "exnc" { entity_stamp=newStamp() entity_attribs=attribs - entity_kind=TyparKind.Type entity_logical_name=id.idText - entity_compiled_name=None entity_range=id.idRange - entity_other_range=None - entity_exn_info= repr entity_tycon_tcaug=TyconAugmentation.Create() - entity_xmldoc=doc - entity_xmldocsig="" entity_pubpath=cpath |> Option.map (fun (cp:CompilationPath) -> cp.NestedPublicPath id) - entity_accessiblity=access - entity_tycon_repr_accessibility=access entity_modul_contents = MaybeLazy.Strict (NewEmptyModuleOrNamespaceType ModuleOrType) entity_cpath= cpath entity_typars=LazyWithContext.NotLazy [] - entity_tycon_abbrev = None entity_tycon_repr = TNoRepr entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordOrUnionType=false) - entity_il_repr_cache= newCache() } + entity_il_repr_cache= newCache() + entity_opt_data = + match doc, access, repr with + | XmlDoc [||], TAccess [], TExnNone -> None + | _ -> Some { Entity.EmptyEntityOptData with entity_xmldoc = doc; entity_accessiblity = access; entity_tycon_repr_accessibility = access; entity_exn_info = repr } } /// Create a new TAST RecdField node for an F# class, struct or record field let NewRecdField stat konst id nameGenerated ty isMutable isVolatile pattribs fattribs docOption access secret = @@ -4942,25 +5022,20 @@ let NewTycon (cpath, nm, m, access, reprAccess, kind, typars, docOption, usesPre Tycon.New "tycon" { entity_stamp=stamp entity_logical_name=nm - entity_compiled_name=None - entity_kind=kind entity_range=m - entity_other_range=None entity_flags=EntityFlags(usesPrefixDisplay=usesPrefixDisplay, isModuleOrNamespace=false,preEstablishedHasDefaultCtor=preEstablishedHasDefaultCtor, hasSelfReferentialCtor=hasSelfReferentialCtor, isStructRecordOrUnionType=false) entity_attribs=[] // fixed up after entity_typars=typars - entity_tycon_abbrev = None entity_tycon_repr = TNoRepr - entity_tycon_repr_accessibility = reprAccess - entity_exn_info=TExnNone entity_tycon_tcaug=TyconAugmentation.Create() entity_modul_contents = mtyp - entity_accessiblity=access - entity_xmldoc = docOption - entity_xmldocsig="" entity_pubpath=cpath |> Option.map (fun (cp:CompilationPath) -> cp.NestedPublicPath (mkSynId m nm)) entity_cpath = cpath - entity_il_repr_cache = newCache() } + entity_il_repr_cache = newCache() + entity_opt_data = + match kind, docOption, reprAccess, access with + | TyparKind.Type, XmlDoc [||], TAccess [], TAccess [] -> None + | _ -> Some { Entity.EmptyEntityOptData with entity_kind = kind; entity_xmldoc = docOption; entity_tycon_repr_accessibility = reprAccess; entity_accessiblity=access } } let NewILTycon nlpath (nm,m) tps (scoref:ILScopeRef, enc, tdef:ILTypeDef) mtyp = @@ -4980,24 +5055,27 @@ exception FullAbstraction of string * range let NewModuleOrNamespace cpath access (id:Ident) xml attribs mtype = Construct.NewModuleOrNamespace cpath access id xml attribs mtype let NewVal (logicalName:string,m:range,compiledName,ty,isMutable,isCompGen,arity,access,recValInfo,specialRepr,baseOrThis,attribs,inlineInfo,doc,isModuleOrMemberBinding,isExtensionMember,isIncrClassSpecialMember,isTyFunc,allowTypeInst,isGeneratedEventVal,konst,actualParent) : Val = - let stamp = newStamp() + let stamp = newStamp() Val.New - { val_stamp = stamp - val_logical_name=logicalName - val_compiled_name= (match compiledName with Some v when v <> logicalName -> compiledName | _ -> None) - val_range=m - val_other_range=None - val_defn=None - val_repr_info= arity - val_declaring_entity= actualParent - val_flags = ValFlags(recValInfo,baseOrThis,isCompGen,inlineInfo,isMutable,isModuleOrMemberBinding,isExtensionMember,isIncrClassSpecialMember,isTyFunc,allowTypeInst,isGeneratedEventVal) - val_const= konst - val_access=access - val_member_info=specialRepr - val_attribs=attribs - val_type = ty - val_xmldoc = doc - val_xmldocsig = ""} + { val_stamp = stamp + val_logical_name = logicalName + val_range = m + val_flags = ValFlags(recValInfo,baseOrThis,isCompGen,inlineInfo,isMutable,isModuleOrMemberBinding,isExtensionMember,isIncrClassSpecialMember,isTyFunc,allowTypeInst,isGeneratedEventVal) + val_type = ty + val_opt_data = + match compiledName, arity, konst, access, doc, specialRepr, actualParent, attribs with + | None, None, None, TAccess [], XmlDoc [||], None, ParentNone, [] -> None + | _ -> + Some { Val.EmptyValOptData with + val_compiled_name = (match compiledName with Some v when v <> logicalName -> compiledName | _ -> None) + val_repr_info = arity + val_const = konst + val_access = access + val_xmldoc = doc + val_member_info = specialRepr + val_declaring_entity = actualParent + val_attribs = attribs } + } let NewCcuContents sref m nm mty = @@ -5073,10 +5151,14 @@ let CombineCcuContentFragments m l = match entity1.IsModuleOrNamespace, entity2.IsModuleOrNamespace with | true,true -> entity1 |> NewModifiedTycon (fun data1 -> + let xml = XmlDoc.Merge entity1.XmlDoc entity2.XmlDoc { data1 with - entity_xmldoc = XmlDoc.Merge entity1.XmlDoc entity2.XmlDoc entity_attribs = entity1.Attribs @ entity2.Attribs - entity_modul_contents = MaybeLazy.Lazy (lazy (CombineModuleOrNamespaceTypes (path@[entity2.DemangledModuleOrNamespaceName]) entity2.Range entity1.ModuleOrNamespaceType entity2.ModuleOrNamespaceType)) }) + entity_modul_contents = MaybeLazy.Lazy (lazy (CombineModuleOrNamespaceTypes (path@[entity2.DemangledModuleOrNamespaceName]) entity2.Range entity1.ModuleOrNamespaceType entity2.ModuleOrNamespaceType)) + entity_opt_data = + match data1.entity_opt_data with + | Some optData -> Some { optData with entity_xmldoc = xml } + | _ -> Some { Entity.EmptyEntityOptData with entity_xmldoc = xml } }) | false,false -> error(Error(FSComp.SR.tastDuplicateTypeDefinitionInAssembly(entity2.LogicalName, textOfPath path),entity2.Range)) | _,_ -> diff --git a/src/ilx/EraseClosures.fs b/src/ilx/EraseClosures.fs index c8adbfff69..92476961fe 100755 --- a/src/ilx/EraseClosures.fs +++ b/src/ilx/EraseClosures.fs @@ -123,8 +123,8 @@ type cenv = addFieldNeverAttrs: ILFieldDef -> ILFieldDef addMethodGeneratedAttrs: ILMethodDef -> ILMethodDef } -let addMethodGeneratedAttrsToTypeDef cenv tdef = - { tdef with Methods = tdef.Methods.AsList |> List.map (fun md -> md |> cenv.addMethodGeneratedAttrs) |> mkILMethods } +let addMethodGeneratedAttrsToTypeDef cenv (tdef: ILTypeDef) = + tdef.With(methods = (tdef.Methods.AsList |> List.map (fun md -> md |> cenv.addMethodGeneratedAttrs) |> mkILMethods)) let newIlxPubCloEnv(ilg, addMethodGeneratedAttrs, addFieldGeneratedAttrs, addFieldNeverAttrs) = { ilg = ilg @@ -314,8 +314,8 @@ let convMethodBody thisClo = function | x -> x let convMethodDef thisClo (md: ILMethodDef) = - let b' = convMethodBody thisClo (md.mdBody.Contents) - {md with mdBody=mkMethBodyAux b'} + let b' = convMethodBody thisClo (md.Body.Contents) + md.With(body=mkMethBodyAux b') // -------------------------------------------------------------------- // Make fields for free variables of a type abstraction. @@ -428,8 +428,7 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo = let laterCode = rewriteCodeToAccessArgsFromEnv laterCloSpec [(0, selfFreeVar)] let laterTypeDefs = convIlxClosureDef cenv encl - {td with GenericParams=laterGenericParams - Name=laterTypeName} + (td.With(genericParams=laterGenericParams, name=laterTypeName)) {clo with cloStructure=laterStruct cloFreeVars=laterFields cloCode=notlazy laterCode} @@ -479,20 +478,27 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo = |> cenv.addMethodGeneratedAttrs let cloTypeDef = - { Name = td.Name - GenericParams= td.GenericParams - Attributes = td.Attributes - Implements = List.empty - NestedTypes = emptyILTypeDefs - Layout=ILTypeDefLayout.Auto - Extends= Some cenv.mkILTyFuncTy - Methods= mkILMethods ([ctorMethodDef] @ [nowApplyMethDef]) - Fields= mkILFields (mkILCloFldDefs cenv nowFields) - CustomAttrs=emptyILCustomAttrs - MethodImpls=emptyILMethodImpls - Properties=emptyILProperties - Events=emptyILEvents - SecurityDecls=emptyILSecurityDecls }.WithSpecialName(false).WithImport(false).WithHasSecurity(false).WithAbstract(false).WithSealed(true).WithInitSemantics(ILTypeInit.BeforeField).WithEncoding(ILDefaultPInvokeEncoding.Ansi) + ILTypeDef(name = td.Name, + genericParams= td.GenericParams, + attributes = td.Attributes, + implements = [], + nestedTypes = emptyILTypeDefs, + layout=ILTypeDefLayout.Auto, + extends= Some cenv.mkILTyFuncTy, + methods= mkILMethods ([ctorMethodDef] @ [nowApplyMethDef]) , + fields= mkILFields (mkILCloFldDefs cenv nowFields), + customAttrs=emptyILCustomAttrs, + methodImpls=emptyILMethodImpls, + properties=emptyILProperties, + events=emptyILEvents, + securityDecls=emptyILSecurityDecls) + .WithSpecialName(false) + .WithImport(false) + .WithHasSecurity(false) + .WithAbstract(false) + .WithSealed(true) + .WithInitSemantics(ILTypeInit.BeforeField) + .WithEncoding(ILDefaultPInvokeEncoding.Ansi) [ cloTypeDef] // CASE 2 - Term Application @@ -536,8 +542,7 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo = let laterTypeDefs = convIlxClosureDef cenv encl - {td with GenericParams=laterGenericParams - Name=laterTypeName} + (td.With(genericParams=laterGenericParams, name=laterTypeName)) {clo with cloStructure=laterStruct cloFreeVars=laterFields cloCode=notlazy laterCode} @@ -570,20 +575,27 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo = ILMemberAccess.Assembly) |> cenv.addMethodGeneratedAttrs - { Name = td.Name - GenericParams= td.GenericParams - Attributes = td.Attributes - Implements = [] - Layout=ILTypeDefLayout.Auto - NestedTypes = emptyILTypeDefs - Extends= Some nowEnvParentClass - Methods= mkILMethods ([ctorMethodDef] @ [nowApplyMethDef]) - Fields= mkILFields (mkILCloFldDefs cenv nowFields) - CustomAttrs=emptyILCustomAttrs - MethodImpls=emptyILMethodImpls - Properties=emptyILProperties - Events=emptyILEvents - SecurityDecls=emptyILSecurityDecls }.WithHasSecurity(false).WithSpecialName(false).WithAbstract(false).WithImport(false).WithEncoding(ILDefaultPInvokeEncoding.Ansi).WithSealed(true).WithInitSemantics(ILTypeInit.BeforeField) + ILTypeDef(name = td.Name, + genericParams= td.GenericParams, + attributes = td.Attributes, + implements = [], + layout=ILTypeDefLayout.Auto, + nestedTypes = emptyILTypeDefs, + extends= Some nowEnvParentClass, + methods= mkILMethods ([ctorMethodDef] @ [nowApplyMethDef]), + fields= mkILFields (mkILCloFldDefs cenv nowFields), + customAttrs=emptyILCustomAttrs, + methodImpls=emptyILMethodImpls, + properties=emptyILProperties, + events=emptyILEvents, + securityDecls=emptyILSecurityDecls) + .WithHasSecurity(false) + .WithSpecialName(false) + .WithAbstract(false) + .WithImport(false) + .WithEncoding(ILDefaultPInvokeEncoding.Ansi) + .WithSealed(true) + .WithInitSemantics(ILTypeInit.BeforeField) [cloTypeDef] @@ -613,13 +625,12 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo = None)) let cloTypeDef = - { td with - Implements= td.Implements - Extends= (match td.Extends with None -> Some cenv.ilg.typ_Object | Some x -> Some(x)) - Name = td.Name - GenericParams= td.GenericParams - Methods= mkILMethods (ctorMethodDef :: List.map (convMethodDef (Some nowCloSpec)) td.Methods.AsList) - Fields= mkILFields (mkILCloFldDefs cenv nowFields @ td.Fields.AsList) } + td.With(implements= td.Implements, + extends= (match td.Extends with None -> Some cenv.ilg.typ_Object | Some x -> Some(x)), + name = td.Name, + genericParams= td.GenericParams, + methods= mkILMethods (ctorMethodDef :: List.map (convMethodDef (Some nowCloSpec)) td.Methods.AsList), + fields= mkILFields (mkILCloFldDefs cenv nowFields @ td.Fields.AsList)) [cloTypeDef] diff --git a/src/ilx/EraseUnions.fs b/src/ilx/EraseUnions.fs index 6eece54f24..51ae9a26e9 100755 --- a/src/ilx/EraseUnions.fs +++ b/src/ilx/EraseUnions.fs @@ -614,15 +614,15 @@ let mkMethodsAndPropertiesForFields (addMethodGeneratedAttrs, addPropertyGenerat let basicProps = fields |> Array.map (fun field -> - { Name = adjustFieldName hasHelpers field.Name - Attributes = PropertyAttributes.None - SetMethod = None - GetMethod = Some (mkILMethRef (typ.TypeRef, ILCallingConv.Instance, "get_" + adjustFieldName hasHelpers field.Name, 0, [], field.Type)) - CallingConv = ILThisConvention.Instance - Type = field.Type - Init = None - Args = [] - CustomAttrs = field.ILField.CustomAttrs } + ILPropertyDef(name = adjustFieldName hasHelpers field.Name, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some (mkILMethRef (typ.TypeRef, ILCallingConv.Instance, "get_" + adjustFieldName hasHelpers field.Name, 0, [], field.Type)), + callingConv = ILThisConvention.Instance, + propertyType = field.Type, + init = None, + args = [], + customAttrs = field.ILField.CustomAttrs) |> addPropertyGeneratedAttrs ) |> Array.toList @@ -648,7 +648,7 @@ let convAlternativeDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addP let repr = cudefRepr // Attributes on unions get attached to the construction methods in the helpers - let addAltAttribs (mdef: ILMethodDef) = { mdef with CustomAttrs=alt.altCustomAttrs } + let addAltAttribs (mdef: ILMethodDef) = mdef.With(customAttrs=alt.altCustomAttrs) // The stdata instruction is only ever used for the F# "List" type // @@ -698,15 +698,15 @@ let convAlternativeDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addP mkMethodBody(true,[],2,nonBranchingInstrsToCode ([ mkLdarg0 ] @ mkIsData ilg (true, cuspec, num)), attr)) |> addMethodGeneratedAttrs ], - [ { Name = mkTesterName altName - Attributes = PropertyAttributes.None - SetMethod = None - GetMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Instance, "get_" + mkTesterName altName, 0, [], ilg.typ_Bool)) - CallingConv = ILThisConvention.Instance - Type = ilg.typ_Bool - Init = None - Args = [] - CustomAttrs = emptyILCustomAttrs } + [ ILPropertyDef(name = mkTesterName altName, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Instance, "get_" + mkTesterName altName, 0, [], ilg.typ_Bool)), + callingConv = ILThisConvention.Instance, + propertyType = ilg.typ_Bool, + init = None, + args = [], + customAttrs = emptyILCustomAttrs) |> addPropertyGeneratedAttrs |> addPropertyNeverAttrs ] @@ -726,15 +726,15 @@ let convAlternativeDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addP let nullaryProp = - { Name = altName - Attributes = PropertyAttributes.None - SetMethod = None - GetMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Static, "get_" + altName, 0, [], baseTy)) - CallingConv = ILThisConvention.Static - Type = baseTy - Init = None - Args = [] - CustomAttrs = emptyILCustomAttrs } + ILPropertyDef(name = altName, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Static, "get_" + altName, 0, [], baseTy)), + callingConv = ILThisConvention.Static, + propertyType = baseTy, + init = None, + args = [], + customAttrs = emptyILCustomAttrs) |> addPropertyGeneratedAttrs |> addPropertyNeverAttrs @@ -827,15 +827,15 @@ let convAlternativeDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addP let debugProxyGetterProps = fields |> Array.map (fun fdef -> - { Name = fdef.Name - Attributes = PropertyAttributes.None - SetMethod = None - GetMethod = Some(mkILMethRef(debugProxyTy.TypeRef,ILCallingConv.Instance,"get_" + fdef.Name,0,[],fdef.Type)) - CallingConv = ILThisConvention.Instance - Type = fdef.Type - Init = None - Args = [] - CustomAttrs = fdef.ILField.CustomAttrs } + ILPropertyDef(name = fdef.Name, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some(mkILMethRef(debugProxyTy.TypeRef,ILCallingConv.Instance,"get_" + fdef.Name,0,[],fdef.Type)), + callingConv = ILThisConvention.Instance, + propertyType = fdef.Type, + init = None, + args = [], + customAttrs = fdef.ILField.CustomAttrs) |> addPropertyGeneratedAttrs) |> Array.toList @@ -881,7 +881,7 @@ let convAlternativeDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addP | TailOrNull -> failwith "unreachable" ], altTy, - (basicFields |> List.map (fun fdef -> fdef.Name, fdef.Type) ), + (basicFields |> List.map (fun fdef -> fdef.Name, fdef.FieldType) ), (if cuspec.HasHelpers = AllHelpers then ILMemberAccess.Assembly else cud.cudReprAccess)) |> addMethodGeneratedAttrs @@ -1039,15 +1039,15 @@ let mkClassUnionDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addProp [ mkILNonGenericInstanceMethod("get_" + tagPropertyName,cud.cudHelpersAccess,[],mkILReturn tagFieldType,body) |> addMethodGeneratedAttrs ], - [ { Name = tagPropertyName - Attributes = PropertyAttributes.None - SetMethod = None - GetMethod = Some(mkILMethRef(baseTy.TypeRef,ILCallingConv.Instance,"get_" + tagPropertyName,0,[], tagFieldType)) - CallingConv = ILThisConvention.Instance - Type = tagFieldType - Init = None - Args = [] - CustomAttrs = emptyILCustomAttrs } + [ ILPropertyDef(name = tagPropertyName, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some(mkILMethRef(baseTy.TypeRef,ILCallingConv.Instance,"get_" + tagPropertyName,0,[], tagFieldType)), + callingConv = ILThisConvention.Instance, + propertyType = tagFieldType, + init = None, + args = [], + customAttrs = emptyILCustomAttrs) |> addPropertyGeneratedAttrs |> addPropertyNeverAttrs ] @@ -1065,29 +1065,36 @@ let mkClassUnionDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addProp if tagEnumFields.Length <= 1 then None else - Some( - { Name = "Tags" - NestedTypes = emptyILTypeDefs - GenericParams= td.GenericParams - Attributes = enum 0 - Layout=ILTypeDefLayout.Auto - Implements = [] - Extends= Some ilg.typ_Object - Methods= emptyILMethods - SecurityDecls=emptyILSecurityDecls - Fields=mkILFields tagEnumFields - MethodImpls=emptyILMethodImpls - Events=emptyILEvents - Properties=emptyILProperties - CustomAttrs= emptyILCustomAttrs }.WithNestedAccess(cud.cudReprAccess).WithAbstract(true).WithSealed(true).WithImport(false).WithEncoding(ILDefaultPInvokeEncoding.Ansi).WithHasSecurity(false)) + let tdef = + ILTypeDef(name = "Tags", + nestedTypes = emptyILTypeDefs, + genericParams= td.GenericParams, + attributes = enum 0, + layout=ILTypeDefLayout.Auto, + implements = [], + extends= Some ilg.typ_Object, + methods= emptyILMethods, + securityDecls=emptyILSecurityDecls, + fields=mkILFields tagEnumFields, + methodImpls=emptyILMethodImpls, + events=emptyILEvents, + properties=emptyILProperties, + customAttrs= emptyILCustomAttrs) + .WithNestedAccess(cud.cudReprAccess) + .WithAbstract(true) + .WithSealed(true) + .WithImport(false) + .WithEncoding(ILDefaultPInvokeEncoding.Ansi) + .WithHasSecurity(false) + Some tdef let baseTypeDef = - { td.WithInitSemantics(ILTypeInit.BeforeField) with - NestedTypes = mkILTypeDefs (Option.toList enumTypeDef @ altTypeDefs @ altDebugTypeDefs @ td.NestedTypes.AsList) - Extends= (match td.Extends with None -> Some ilg.typ_Object | _ -> td.Extends) - Methods= mkILMethods (ctorMeths @ baseMethsFromAlt @ selfMeths @ tagMeths @ altUniqObjMeths @ existingMeths) - Fields=mkILFields (selfAndTagFields @ List.map (fun (_,_,_,_,fdef,_) -> fdef) altNullaryFields @ td.Fields.AsList) - Properties=mkILProperties (tagProps @ basePropsFromAlt @ selfProps @ existingProps) } + td.WithInitSemantics(ILTypeInit.BeforeField) + .With(nestedTypes = mkILTypeDefs (Option.toList enumTypeDef @ altTypeDefs @ altDebugTypeDefs @ td.NestedTypes.AsList), + extends= (match td.Extends with None -> Some ilg.typ_Object | _ -> td.Extends), + methods= mkILMethods (ctorMeths @ baseMethsFromAlt @ selfMeths @ tagMeths @ altUniqObjMeths @ existingMeths), + fields=mkILFields (selfAndTagFields @ List.map (fun (_,_,_,_,fdef,_) -> fdef) altNullaryFields @ td.Fields.AsList), + properties=mkILProperties (tagProps @ basePropsFromAlt @ selfProps @ existingProps)) // The .cctor goes on the Cases type since that's where the constant fields for nullary constructors live |> addConstFieldInit diff --git a/src/scripts/VerifyAllTranslations.fsx b/src/scripts/VerifyAllTranslations.fsx new file mode 100644 index 0000000000..24e2d4eebb --- /dev/null +++ b/src/scripts/VerifyAllTranslations.fsx @@ -0,0 +1,39 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +// verifies that all translations in all .xlf files have `state="translated"`. + +#r "System.Xml.Linq" + +open System +open System.IO +open System.Xml.Linq + +// usage: fsi VerifyAllTranslations.fsx -- baseDirectory +let baseDirectory = + Environment.GetCommandLineArgs() + |> Seq.skipWhile ((<>) "--") + |> Seq.skip 1 + |> Seq.head + +let hasUntranslatedStrings (xlfFile:string) = + let doc = XDocument.Load(xlfFile) + let untranslatedStates = + doc.Root.Descendants() + |> Seq.filter (fun (elem:XElement) -> elem.Name.LocalName = "target") + |> Seq.map (fun (elem:XElement) -> elem.Attribute(XName.op_Implicit("state"))) + |> Seq.filter (isNull >> not) + |> Seq.map (fun (attr:XAttribute) -> attr.Value) + |> Seq.filter ((<>) "translated") + Seq.length untranslatedStates > 0 + +let filesWithMissingTranslations = + Directory.EnumerateFiles(baseDirectory, "*.xlf", SearchOption.AllDirectories) + |> Seq.filter (fun (file:string) -> file.EndsWith(".en.xlf") |> not) // the english baseline files are never translated + |> Seq.filter hasUntranslatedStrings + |> Seq.toList + +match filesWithMissingTranslations with +| [] -> printfn "All .xlf files have translations assigned." +| _ -> + printfn "The following .xlf files have untranslated strings (state != 'translated'):\n\t%s" (String.Join("\n\t", filesWithMissingTranslations)) + Environment.Exit(1) diff --git a/src/utils/CompilerLocationUtils.fs b/src/utils/CompilerLocationUtils.fs index 2cc60b183d..9bfcbf3fc2 100755 --- a/src/utils/CompilerLocationUtils.fs +++ b/src/utils/CompilerLocationUtils.fs @@ -12,7 +12,7 @@ open System.Runtime.InteropServices module internal FSharpEnvironment = /// The F# version reported in the banner - let FSharpBannerVersion = "4.1" + let FSharpBannerVersion = "10.1.0 for F# 4.1" let versionOf<'t> = #if FX_RESHAPED_REFLECTION @@ -210,31 +210,28 @@ module internal FSharpEnvironment = let result = tryAppConfig "fsharp-compiler-location" match result with | Some _ -> result - | None -> - + | None -> + let safeExists f = (try File.Exists(f) with _ -> false) // Look in the probePoint if given, e.g. look for a compiler alongside of FSharp.Build.dll match probePoint with | Some p when safeExists (Path.Combine(p,"FSharp.Core.dll")) -> Some p | _ -> - + // On windows the location of the compiler is via a registry key // Note: If the keys below change, be sure to update code in: // Property pages (ApplicationPropPage.vb) - - let key1 = @"Software\Microsoft\FSharp\4.1\Runtime\v4.0" - let key2 = @"Software\Microsoft\FSharp\4.0\Runtime\v4.0" - - let result = tryRegKey key1 - match result with - | Some _ -> result - | None -> - let result = tryRegKey key2 - match result with - | Some _ -> result + let keys = + [| + @"Software\Microsoft\FSharp\10.1\Runtime\v4.0"; + @"Software\Microsoft\FSharp\4.1\Runtime\v4.0"; + @"Software\Microsoft\FSharp\4.0\Runtime\v4.0" + |] + let path = keys |> Seq.tryPick(fun k -> tryRegKey k) + match path with + | Some _ -> path | None -> - // On Unix we let you set FSHARP_COMPILER_BIN. I've rarely seen this used and its not documented in the install instructions. let result = let var = System.Environment.GetEnvironmentVariable("FSHARP_COMPILER_BIN") diff --git a/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net40/Sample_VS2012_FSharp_ConsoleApp_net40/Sample_VS2012_FSharp_ConsoleApp_net40.fsproj b/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net40/Sample_VS2012_FSharp_ConsoleApp_net40/Sample_VS2012_FSharp_ConsoleApp_net40.fsproj index 4eddaeffb8..0b4c365d7b 100644 --- a/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net40/Sample_VS2012_FSharp_ConsoleApp_net40/Sample_VS2012_FSharp_ConsoleApp_net40.fsproj +++ b/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net40/Sample_VS2012_FSharp_ConsoleApp_net40/Sample_VS2012_FSharp_ConsoleApp_net40.fsproj @@ -43,7 +43,7 @@ - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013.fsproj b/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013.fsproj index 0c174af62d..ed2fa4ea5e 100644 --- a/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013.fsproj +++ b/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013/Sample_VS2012_FSharp_ConsoleApp_net40_upgraded_VS2013.fsproj @@ -43,7 +43,7 @@ - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2012_FSharp_Portable_Library/Sample_VS2012_FSharp_Portable_Library.fsproj b/tests/projects/Sample_VS2012_FSharp_Portable_Library/Sample_VS2012_FSharp_Portable_Library.fsproj index 921365806d..1bd9fcf104 100644 --- a/tests/projects/Sample_VS2012_FSharp_Portable_Library/Sample_VS2012_FSharp_Portable_Library.fsproj +++ b/tests/projects/Sample_VS2012_FSharp_Portable_Library/Sample_VS2012_FSharp_Portable_Library.fsproj @@ -36,7 +36,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2012_FSharp_Portable_Library_upgraded_2013/Sample_VS2012_FSharp_Portable_Library_upgraded_2013.fsproj b/tests/projects/Sample_VS2012_FSharp_Portable_Library_upgraded_2013/Sample_VS2012_FSharp_Portable_Library_upgraded_2013.fsproj index 75b8b871bd..deff760e73 100644 --- a/tests/projects/Sample_VS2012_FSharp_Portable_Library_upgraded_2013/Sample_VS2012_FSharp_Portable_Library_upgraded_2013.fsproj +++ b/tests/projects/Sample_VS2012_FSharp_Portable_Library_upgraded_2013/Sample_VS2012_FSharp_Portable_Library_upgraded_2013.fsproj @@ -35,7 +35,7 @@ - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll True diff --git a/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net40/Sample_VS2013_FSharp_Portable_Library_Legacy_net40.fsproj b/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net40/Sample_VS2013_FSharp_Portable_Library_Legacy_net40.fsproj index 727a28f6d8..14fe941407 100644 --- a/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net40/Sample_VS2013_FSharp_Portable_Library_Legacy_net40.fsproj +++ b/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net40/Sample_VS2013_FSharp_Portable_Library_Legacy_net40.fsproj @@ -37,7 +37,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net45/Sample_VS2013_FSharp_Portable_Library_Legacy_net45.fsproj b/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net45/Sample_VS2013_FSharp_Portable_Library_Legacy_net45.fsproj index 77e65fa263..e541b68e46 100644 --- a/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net45/Sample_VS2013_FSharp_Portable_Library_Legacy_net45.fsproj +++ b/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net45/Sample_VS2013_FSharp_Portable_Library_Legacy_net45.fsproj @@ -37,7 +37,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net451/Sample_VS2013_FSharp_Portable_Library_Legacy_net451.fsproj b/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net451/Sample_VS2013_FSharp_Portable_Library_Legacy_net451.fsproj index 4fc3681cb3..207cd13232 100644 --- a/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net451/Sample_VS2013_FSharp_Portable_Library_Legacy_net451.fsproj +++ b/tests/projects/Sample_VS2013_FSharp_Portable_Library_Legacy_net451/Sample_VS2013_FSharp_Portable_Library_Legacy_net451.fsproj @@ -37,7 +37,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2013_FSharp_Portable_Library_net45/Sample_VS2013_FSharp_Portable_Library_net45.fsproj b/tests/projects/Sample_VS2013_FSharp_Portable_Library_net45/Sample_VS2013_FSharp_Portable_Library_net45.fsproj index 5ee9437dc1..b44150d5af 100644 --- a/tests/projects/Sample_VS2013_FSharp_Portable_Library_net45/Sample_VS2013_FSharp_Portable_Library_net45.fsproj +++ b/tests/projects/Sample_VS2013_FSharp_Portable_Library_net45/Sample_VS2013_FSharp_Portable_Library_net45.fsproj @@ -38,7 +38,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+netcore45\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+netcore45\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451/Sample_VS2013_FSharp_Portable_Library_net451.fsproj b/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451/Sample_VS2013_FSharp_Portable_Library_net451.fsproj index 2bd9905029..eb60ed1d6c 100644 --- a/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451/Sample_VS2013_FSharp_Portable_Library_net451.fsproj +++ b/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451/Sample_VS2013_FSharp_Portable_Library_net451.fsproj @@ -38,7 +38,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+netcore45\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+netcore45\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile259/Sample_VS2013_FSharp_Portable_Library_net451.fsproj b/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile259/Sample_VS2013_FSharp_Portable_Library_net451.fsproj index 84cd51e717..119d6805e7 100644 --- a/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile259/Sample_VS2013_FSharp_Portable_Library_net451.fsproj +++ b/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile259/Sample_VS2013_FSharp_Portable_Library_net451.fsproj @@ -38,7 +38,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+netcore45+wpa81+wp8\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+netcore45+wpa81+wp8\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile78/Sample_VS2013_FSharp_Portable_Library_net451.fsproj b/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile78/Sample_VS2013_FSharp_Portable_Library_net451.fsproj index 960a7f5a33..319f6dc420 100644 --- a/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile78/Sample_VS2013_FSharp_Portable_Library_net451.fsproj +++ b/tests/projects/Sample_VS2013_FSharp_Portable_Library_net451_adjusted_to_profile78/Sample_VS2013_FSharp_Portable_Library_net451.fsproj @@ -38,7 +38,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+netcore45+wp8\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+netcore45+wp8\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2015_FSharp_Portable259_Library/Sample_VS2015_FSharp_Portable259_Library.fsproj b/tests/projects/Sample_VS2015_FSharp_Portable259_Library/Sample_VS2015_FSharp_Portable259_Library.fsproj index 3860254ff7..160e117760 100644 --- a/tests/projects/Sample_VS2015_FSharp_Portable259_Library/Sample_VS2015_FSharp_Portable259_Library.fsproj +++ b/tests/projects/Sample_VS2015_FSharp_Portable259_Library/Sample_VS2015_FSharp_Portable259_Library.fsproj @@ -39,7 +39,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+netcore45+wpa81+wp8\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+netcore45+wpa81+wp8\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2015_FSharp_Portable47_Library/Sample_VS2015_FSharp_Portable47_Library.fsproj b/tests/projects/Sample_VS2015_FSharp_Portable47_Library/Sample_VS2015_FSharp_Portable47_Library.fsproj index 2497d03f00..ace02e6235 100644 --- a/tests/projects/Sample_VS2015_FSharp_Portable47_Library/Sample_VS2015_FSharp_Portable47_Library.fsproj +++ b/tests/projects/Sample_VS2015_FSharp_Portable47_Library/Sample_VS2015_FSharp_Portable47_Library.fsproj @@ -38,7 +38,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+sl5+netcore45\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2015_FSharp_Portable78_Library/Sample_VS2015_FSharp_Portable78_Library.fsproj b/tests/projects/Sample_VS2015_FSharp_Portable78_Library/Sample_VS2015_FSharp_Portable78_Library.fsproj index 7741d5f5b3..c422bd847c 100644 --- a/tests/projects/Sample_VS2015_FSharp_Portable78_Library/Sample_VS2015_FSharp_Portable78_Library.fsproj +++ b/tests/projects/Sample_VS2015_FSharp_Portable78_Library/Sample_VS2015_FSharp_Portable78_Library.fsproj @@ -39,7 +39,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+netcore45+wp8\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+netcore45+wp8\FSharp.Core.dll diff --git a/tests/projects/Sample_VS2015_FSharp_Portable7_Library/Sample_VS2015_FSharp_Portable7_Library.fsproj b/tests/projects/Sample_VS2015_FSharp_Portable7_Library/Sample_VS2015_FSharp_Portable7_Library.fsproj index 8ebe0160da..08c0756194 100644 --- a/tests/projects/Sample_VS2015_FSharp_Portable7_Library/Sample_VS2015_FSharp_Portable7_Library.fsproj +++ b/tests/projects/Sample_VS2015_FSharp_Portable7_Library/Sample_VS2015_FSharp_Portable7_Library.fsproj @@ -39,7 +39,7 @@ FSharp.Core FSharp.Core.dll - ..\..\..\packages\Microsoft.Portable.FSharp.Core.4.1.20\lib\profiles\portable-net45+netcore45+wpa81+wp8\FSharp.Core.dll + ..\..\..\packages\Microsoft.Portable.FSharp.Core.$(FSharpCoreFrozenPortablePackageVersion)\lib\profiles\portable-net45+netcore45+wpa81+wp8\FSharp.Core.dll diff --git a/tests/projects/misc/ProjectWithBuildErrors/ProjectWithBuildErrors/ProjectWithBuildErrors.fsproj b/tests/projects/misc/ProjectWithBuildErrors/ProjectWithBuildErrors/ProjectWithBuildErrors.fsproj index 8a07b57459..43aa06b77c 100644 --- a/tests/projects/misc/ProjectWithBuildErrors/ProjectWithBuildErrors/ProjectWithBuildErrors.fsproj +++ b/tests/projects/misc/ProjectWithBuildErrors/ProjectWithBuildErrors/ProjectWithBuildErrors.fsproj @@ -70,7 +70,7 @@ - ..\packages\System.ValueTuple.4.3.1\lib\netstandard1.0\System.ValueTuple.dll + ..\packages\System.ValueTuple.4.4.0\lib\netstandard1.0\System.ValueTuple.dll