From fcffdd2e8fbe438a545b2eba14120efdd6267328 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 25 May 2022 14:22:34 +0100 Subject: [PATCH] Formatting: Apply formatting to AbstractIL (#13173) * adjust format settings * apply formatting * adjust code and apply formatting * add some spacing --- .fantomasignore | 3 +- src/Compiler/AbstractIL/il.fs | 4107 +++++++++------ src/Compiler/AbstractIL/ilascii.fs | 453 +- src/Compiler/AbstractIL/ilbinary.fs | 1743 +++---- src/Compiler/AbstractIL/ilmorph.fs | 463 +- src/Compiler/AbstractIL/ilnativeres.fs | 937 ++-- src/Compiler/AbstractIL/ilprint.fs | 2174 ++++---- src/Compiler/AbstractIL/ilread.fs | 5680 +++++++++++++-------- src/Compiler/AbstractIL/ilreflect.fs | 1853 ++++--- src/Compiler/AbstractIL/ilsign.fs | 1165 +++-- src/Compiler/AbstractIL/ilsupp.fs | 1154 +++-- src/Compiler/AbstractIL/ilwritepdb.fs | 1083 ++-- src/Compiler/AbstractIL/ilx.fs | 199 +- src/Compiler/Checking/CheckExpressions.fs | 4 + src/Compiler/Service/ServiceLexing.fsi | 1 + 15 files changed, 12720 insertions(+), 8299 deletions(-) diff --git a/.fantomasignore b/.fantomasignore index 0211e8ccb..1f4485485 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -9,11 +9,11 @@ service/ setup/ tests/ vsintegration/ +artifacts/ # Explicitly unformatted implementation files src/FSharp.Core/**/*.fs -src/Compiler/AbstractIL/**/*.fs src/Compiler/Checking/**/*.fs src/Compiler/CodeGen/**/*.fs src/Compiler/DependencyManager/**/*.fs @@ -30,6 +30,7 @@ src/Microsoft.FSharp.Compiler/**/*.fs # Fantomas limitations on implementation files (to investigate) +src/Compiler/AbstractIL/ilwrite.fs src/Compiler/Utilities/lib.fs # Fantomas limitations on signature files (to investigate) diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index 0ba003445..7cd377cad 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -25,7 +25,9 @@ open Internal.Utilities let logging = false -let _ = if logging then dprintn "* warning: Il.logging is on" +let _ = + if logging then + dprintn "* warning: Il.logging is on" let int_order = LanguagePrimitives.FastGenericComparer @@ -35,7 +37,10 @@ let notlazy v = Lazy<_>.CreateFromValue v /// contain lazy values then we don't add laziness. So if the thing to map /// is already evaluated then immediately apply the function. let lazyMap f (x: Lazy<_>) = - if x.IsValueCreated then notlazy (f (x.Force())) else lazy (f (x.Force())) + if x.IsValueCreated then + notlazy (f (x.Force())) + else + lazy (f (x.Force())) [] type PrimaryAssembly = @@ -58,41 +63,50 @@ type PrimaryAssembly = let memoizeNamespaceTable = ConcurrentDictionary() // ++GLOBAL MUTABLE STATE (concurrency-safe) -let memoizeNamespaceRightTable = ConcurrentDictionary() +let memoizeNamespaceRightTable = + ConcurrentDictionary() // ++GLOBAL MUTABLE STATE (concurrency-safe) let memoizeNamespacePartTable = ConcurrentDictionary() - let splitNameAt (nm: string) idx = - if idx < 0 then failwith "splitNameAt: idx < 0" + if idx < 0 then + failwith "splitNameAt: idx < 0" + let last = nm.Length - 1 - if idx > last then failwith "splitNameAt: idx > last" - (nm.Substring (0, idx)), - (if idx < last then nm.Substring (idx+1, last - idx) else "") + + if idx > last then + failwith "splitNameAt: idx > last" + + (nm.Substring(0, idx)), + (if idx < last then + nm.Substring(idx + 1, last - idx) + else + "") let rec splitNamespaceAux (nm: string) = match nm.IndexOf '.' with - | -1 -> [nm] + | -1 -> [ nm ] | idx -> let s1, s2 = splitNameAt nm idx let s1 = memoizeNamespacePartTable.GetOrAdd(s1, id) s1 :: splitNamespaceAux s2 - let splitNamespace nm = - memoizeNamespaceTable.GetOrAdd (nm, splitNamespaceAux) + memoizeNamespaceTable.GetOrAdd(nm, splitNamespaceAux) let splitNamespaceMemoized nm = splitNamespace nm // ++GLOBAL MUTABLE STATE (concurrency-safe) -let memoizeNamespaceArrayTable = - ConcurrentDictionary() +let memoizeNamespaceArrayTable = ConcurrentDictionary() let splitNamespaceToArray nm = - memoizeNamespaceArrayTable.GetOrAdd (nm, fun nm -> - let x = Array.ofList (splitNamespace nm) - x) + memoizeNamespaceArrayTable.GetOrAdd( + nm, + fun nm -> + let x = Array.ofList (splitNamespace nm) + x + ) let splitILTypeName (nm: string) = match nm.LastIndexOf '.' with @@ -115,11 +129,15 @@ let splitILTypeNameWithPossibleStaticArguments (nm: string) = let nsp, nm = match nm.LastIndexOf '.' with - | -1 -> [| |], nm + | -1 -> [||], nm | idx -> let s1, s2 = splitNameAt nm idx splitNamespaceToArray s1, s2 - nsp, (match suffix with None -> nm | Some s -> nm + "," + s) + + nsp, + (match suffix with + | None -> nm + | Some s -> nm + "," + s) (* splitILTypeNameWithPossibleStaticArguments "Foo" = ([| |], "Foo") @@ -137,37 +155,47 @@ let unsplitTypeName (ns, n) = let splitTypeNameRightAux (nm: string) = let idx = nm.LastIndexOf '.' - if idx = -1 then None, nm else - let s1, s2 = splitNameAt nm idx - Some s1, s2 + + if idx = -1 then + None, nm + else + let s1, s2 = splitNameAt nm idx + Some s1, s2 let splitTypeNameRight nm = - memoizeNamespaceRightTable.GetOrAdd (nm, splitTypeNameRightAux) + memoizeNamespaceRightTable.GetOrAdd(nm, splitTypeNameRightAux) // -------------------------------------------------------------------- // Ordered lists with a lookup table // -------------------------------------------------------------------- /// This is used to store event, property and field maps. -type LazyOrderedMultiMap<'Key, 'Data when 'Key : equality>(keyf : 'Data -> 'Key, lazyItems : Lazy<'Data list>) = +type LazyOrderedMultiMap<'Key, 'Data when 'Key: equality>(keyf: 'Data -> 'Key, lazyItems: Lazy<'Data list>) = let quickMap = - lazyItems |> lazyMap (fun entries -> + lazyItems + |> lazyMap (fun entries -> let t = Dictionary<_, _>(entries.Length, HashIdentity.Structural) + for y in entries do let key = keyf y + let v = match t.TryGetValue key with | true, v -> v | _ -> [] + t[key] <- y :: v + t) member self.Entries() = lazyItems.Force() - member self.Add y = new LazyOrderedMultiMap<'Key, 'Data>(keyf, lazyItems |> lazyMap (fun x -> y :: x)) + member self.Add y = + new LazyOrderedMultiMap<'Key, 'Data>(keyf, lazyItems |> lazyMap (fun x -> y :: x)) - member self.Filter f = new LazyOrderedMultiMap<'Key, 'Data>(keyf, lazyItems |> lazyMap (List.filter f)) + member self.Filter f = + new LazyOrderedMultiMap<'Key, 'Data>(keyf, lazyItems |> lazyMap (List.filter f)) member self.Item with get x = @@ -175,33 +203,41 @@ type LazyOrderedMultiMap<'Key, 'Data when 'Key : equality>(keyf : 'Data -> 'Key, | true, v -> v | _ -> [] - //--------------------------------------------------------------------- // SHA1 hash-signing algorithm. Used to get the public key token from // the public key. //--------------------------------------------------------------------- - let b0 n = (n &&& 0xFF) let b1 n = ((n >>> 8) &&& 0xFF) let b2 n = ((n >>> 16) &&& 0xFF) let b3 n = ((n >>> 24) &&& 0xFF) - module SHA1 = let inline (>>>&) (x: int) (y: int) = int32 (uint32 x >>> y) - let f(t, b, c, d) = - if t < 20 then (b &&& c) ||| ((~~~b) &&& d) - elif t < 40 then b ^^^ c ^^^ d - elif t < 60 then (b &&& c) ||| (b &&& d) ||| (c &&& d) - else b ^^^ c ^^^ d + let f (t, b, c, d) = + if t < 20 then + (b &&& c) ||| ((~~~b) &&& d) + elif t < 40 then + b ^^^ c ^^^ d + elif t < 60 then + (b &&& c) ||| (b &&& d) ||| (c &&& d) + else + b ^^^ c ^^^ d + + [] + let k0to19 = 0x5A827999 - let [] k0to19 = 0x5A827999 - let [] k20to39 = 0x6ED9EBA1 - let [] k40to59 = 0x8F1BBCDC - let [] k60to79 = 0xCA62C1D6 + [] + let k20to39 = 0x6ED9EBA1 + + [] + let k40to59 = 0x8F1BBCDC + + [] + let k60to79 = 0xCA62C1D6 let k t = if t < 20 then k0to19 @@ -209,36 +245,56 @@ module SHA1 = elif t < 60 then k40to59 else k60to79 - type SHAStream = - { stream: byte[] - mutable pos: int - mutable eof: bool } - - let rotLeft32 x n = (x <<< n) ||| (x >>>& (32-n)) + { + stream: byte[] + mutable pos: int + mutable eof: bool + } + let rotLeft32 x n = (x <<< n) ||| (x >>>& (32 - n)) // padding and length (in bits!) recorded at end let shaAfterEof sha = let n = sha.pos let len = sha.stream.Length - if n = len then 0x80 + + if n = len then + 0x80 else - let padded_len = (((len + 9 + 63) / 64) * 64) - 8 - if n < padded_len - 8 then 0x0 - elif (n &&& 63) = 56 then int32 ((int64 len * int64 8) >>> 56) &&& 0xff - elif (n &&& 63) = 57 then int32 ((int64 len * int64 8) >>> 48) &&& 0xff - elif (n &&& 63) = 58 then int32 ((int64 len * int64 8) >>> 40) &&& 0xff - elif (n &&& 63) = 59 then int32 ((int64 len * int64 8) >>> 32) &&& 0xff - elif (n &&& 63) = 60 then int32 ((int64 len * int64 8) >>> 24) &&& 0xff - elif (n &&& 63) = 61 then int32 ((int64 len * int64 8) >>> 16) &&& 0xff - elif (n &&& 63) = 62 then int32 ((int64 len * int64 8) >>> 8) &&& 0xff - elif (n &&& 63) = 63 then (sha.eof <- true; int32 (int64 len * int64 8) &&& 0xff) - else 0x0 + let padded_len = (((len + 9 + 63) / 64) * 64) - 8 + + if n < padded_len - 8 then + 0x0 + elif (n &&& 63) = 56 then + int32 ((int64 len * int64 8) >>> 56) &&& 0xff + elif (n &&& 63) = 57 then + int32 ((int64 len * int64 8) >>> 48) &&& 0xff + elif (n &&& 63) = 58 then + int32 ((int64 len * int64 8) >>> 40) &&& 0xff + elif (n &&& 63) = 59 then + int32 ((int64 len * int64 8) >>> 32) &&& 0xff + elif (n &&& 63) = 60 then + int32 ((int64 len * int64 8) >>> 24) &&& 0xff + elif (n &&& 63) = 61 then + int32 ((int64 len * int64 8) >>> 16) &&& 0xff + elif (n &&& 63) = 62 then + int32 ((int64 len * int64 8) >>> 8) &&& 0xff + elif (n &&& 63) = 63 then + (sha.eof <- true + int32 (int64 len * int64 8) &&& 0xff) + else + 0x0 let shaRead8 sha = let s = sha.stream - let b = if sha.pos >= s.Length then shaAfterEof sha else int32 s[sha.pos] + + let b = + if sha.pos >= s.Length then + shaAfterEof sha + else + int32 s[sha.pos] + sha.pos <- sha.pos + 1 b @@ -262,16 +318,20 @@ module SHA1 = let mutable d = 0 let mutable e = 0 let w = Array.create 80 0x00 + while (not sha.eof) do for i = 0 to 15 do w[i] <- shaRead32 sha + for t = 16 to 79 do - w[t] <- rotLeft32 (w[t-3] ^^^ w[t-8] ^^^ w[t-14] ^^^ w[t-16]) 1 + w[t] <- rotLeft32 (w[t - 3] ^^^ w[t - 8] ^^^ w[t - 14] ^^^ w[t - 16]) 1 + a <- h0 b <- h1 c <- h2 d <- h3 e <- h4 + for t = 0 to 79 do let temp = (rotLeft32 a 5) + f (t, b, c, d) + e + w[t] + k t e <- d @@ -279,19 +339,21 @@ module SHA1 = c <- rotLeft32 b 30 b <- a a <- temp + h0 <- h0 + a h1 <- h1 + b h2 <- h2 + c h3 <- h3 + d h4 <- h4 + e + h0, h1, h2, h3, h4 let sha1HashBytes s = - let _h0, _h1, _h2, h3, h4 = sha1Hash { stream = s; pos = 0; eof = false } // the result of the SHA algorithm is stored in registers 3 and 4 - Array.map byte [| b0 h4; b1 h4; b2 h4; b3 h4; b0 h3; b1 h3; b2 h3; b3 h3; |] + let _h0, _h1, _h2, h3, h4 = sha1Hash { stream = s; pos = 0; eof = false } // the result of the SHA algorithm is stored in registers 3 and 4 + Array.map byte [| b0 h4; b1 h4; b2 h4; b3 h4; b0 h3; b1 h3; b2 h3; b3 h3 |] let sha1HashInt64 s = - let _h0,_h1,_h2,h3,h4 = sha1Hash { stream = s; pos = 0; eof = false } // the result of the SHA algorithm is stored in registers 3 and 4 + let _h0, _h1, _h2, h3, h4 = sha1Hash { stream = s; pos = 0; eof = false } // the result of the SHA algorithm is stored in registers 3 and 4 (int64 h3 <<< 32) ||| int64 h4 let sha1HashBytes s = SHA1.sha1HashBytes s @@ -309,12 +371,17 @@ type ILVersionInfo = val Build: uint16 val Revision: uint16 - new (major, minor, build, revision) = - { Major = major; Minor = minor; Build = build; Revision = revision } + new(major, minor, build, revision) = + { + Major = major + Minor = minor + Build = build + Revision = revision + } /// For debugging - override x.ToString() = sprintf "ILVersionInfo: %u %u %u %u" x.Major x.Minor x.Build x.Revision - + override x.ToString() = + sprintf "ILVersionInfo: %u %u %u %u" x.Major x.Minor x.Build x.Revision type Locale = string @@ -325,112 +392,139 @@ type PublicKey = | PublicKeyToken of byte[] - member x.IsKey=match x with PublicKey _ -> true | _ -> false + member x.IsKey = + match x with + | PublicKey _ -> true + | _ -> false - member x.IsKeyToken=match x with PublicKeyToken _ -> true | _ -> false + member x.IsKeyToken = + match x with + | PublicKeyToken _ -> true + | _ -> false - member x.Key=match x with PublicKey b -> b | _ -> invalidOp "not a key" + member x.Key = + match x with + | PublicKey b -> b + | _ -> invalidOp "not a key" - member x.KeyToken=match x with PublicKeyToken b -> b | _ -> invalidOp"not a key token" + member x.KeyToken = + match x with + | PublicKeyToken b -> b + | _ -> invalidOp "not a key token" member x.ToToken() = match x with | PublicKey bytes -> SHA1.sha1HashBytes bytes | PublicKeyToken token -> token - static member KeyAsToken key = PublicKeyToken (PublicKey(key).ToToken()) + static member KeyAsToken key = + PublicKeyToken(PublicKey(key).ToToken()) [] 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 = UniqueStampGenerator() -let isMscorlib data = - data.assemRefName = "mscorlib" +let isMscorlib data = data.assemRefName = "mscorlib" [] type ILAssemblyRef(data) = let pkToken key = match key with - | Some (PublicKey bytes) -> Some (PublicKey (SHA1.sha1HashBytes bytes)) - | Some (PublicKeyToken token) -> Some (PublicKey token) + | Some (PublicKey bytes) -> Some(PublicKey(SHA1.sha1HashBytes bytes)) + | Some (PublicKeyToken token) -> Some(PublicKey token) | None -> None let uniqueStamp = - AssemblyRefUniqueStampGenerator.Encode { data with assemRefPublicKeyInfo = pkToken data.assemRefPublicKeyInfo } + AssemblyRefUniqueStampGenerator.Encode + { data with + assemRefPublicKeyInfo = pkToken data.assemRefPublicKeyInfo + } let uniqueIgnoringVersionStamp = - AssemblyRefUniqueStampGenerator.Encode { data with assemRefVersion = None; assemRefPublicKeyInfo = pkToken data.assemRefPublicKeyInfo } + AssemblyRefUniqueStampGenerator.Encode + { data with + assemRefVersion = None + assemRefPublicKeyInfo = pkToken data.assemRefPublicKeyInfo + } - member x.Name=data.assemRefName + member x.Name = data.assemRefName - member x.Hash=data.assemRefHash + member x.Hash = data.assemRefHash - member x.PublicKey=data.assemRefPublicKeyInfo + member x.PublicKey = data.assemRefPublicKeyInfo - member x.Retargetable=data.assemRefRetargetable + member x.Retargetable = data.assemRefRetargetable - member x.Version=data.assemRefVersion + member x.Version = data.assemRefVersion - member x.Locale=data.assemRefLocale + member x.Locale = data.assemRefLocale - member x.UniqueStamp=uniqueStamp + member x.UniqueStamp = uniqueStamp - member x.UniqueIgnoringVersionStamp=uniqueIgnoringVersionStamp + member x.UniqueIgnoringVersionStamp = uniqueIgnoringVersionStamp - member x.EqualsIgnoringVersion (aref: ILAssemblyRef) = + member x.EqualsIgnoringVersion(aref: ILAssemblyRef) = aref.UniqueIgnoringVersionStamp = uniqueIgnoringVersionStamp override x.GetHashCode() = uniqueStamp - override x.Equals yobj = ((yobj :?> ILAssemblyRef).UniqueStamp = uniqueStamp) + override x.Equals yobj = + ((yobj :?> ILAssemblyRef).UniqueStamp = uniqueStamp) interface IComparable with - override x.CompareTo yobj = compare (yobj :?> ILAssemblyRef).UniqueStamp uniqueStamp + override x.CompareTo yobj = + compare (yobj :?> ILAssemblyRef).UniqueStamp uniqueStamp - static member Create (name, hash, publicKey, retargetable, version, locale) = + static member Create(name, hash, publicKey, retargetable, version, locale) = ILAssemblyRef - { assemRefName=name - assemRefHash=hash - assemRefPublicKeyInfo=publicKey - assemRefRetargetable=retargetable - assemRefVersion=version - assemRefLocale=locale } + { + assemRefName = name + assemRefHash = hash + assemRefPublicKeyInfo = publicKey + assemRefRetargetable = retargetable + assemRefVersion = version + assemRefLocale = locale + } - static member FromAssemblyName (aname: AssemblyName) = + static member FromAssemblyName(aname: AssemblyName) = let locale = None let publicKey = - match aname.GetPublicKey() with - | null | [| |] -> - match aname.GetPublicKeyToken() with - | null | [| |] -> None - | bytes -> Some (PublicKeyToken bytes) - | bytes -> - Some (PublicKey bytes) + match aname.GetPublicKey() with + | null + | [||] -> + match aname.GetPublicKeyToken() with + | null + | [||] -> None + | bytes -> Some(PublicKeyToken bytes) + | bytes -> Some(PublicKey bytes) let version = - match aname.Version with - | null -> None - | v -> Some (ILVersionInfo (uint16 v.Major, uint16 v.Minor, uint16 v.Build, uint16 v.Revision)) + match aname.Version with + | null -> None + | v -> Some(ILVersionInfo(uint16 v.Major, uint16 v.Minor, uint16 v.Build, uint16 v.Revision)) let retargetable = aname.Flags = AssemblyNameFlags.Retargetable - ILAssemblyRef.Create (aname.Name, None, publicKey, retargetable, version, locale) + ILAssemblyRef.Create(aname.Name, None, publicKey, retargetable, version, locale) member aref.QualifiedName = let b = StringBuilder(100) let add (s: string) = b.Append s |> ignore let addC (s: char) = b.Append s |> ignore add aref.Name + match aref.Version with | None -> () | Some version -> @@ -443,45 +537,57 @@ type ILAssemblyRef(data) = add "." add (string (int version.Revision)) add ", Culture=" + match aref.Locale with | None -> add "neutral" | Some b -> add b + add ", PublicKeyToken=" + match aref.PublicKey with | None -> add "null" | Some pki -> - let pkt = pki.ToToken() - let convDigit digit = - let digitc = - if digit < 10 - then Convert.ToInt32 '0' + digit - else Convert.ToInt32 'a' + (digit - 10) - Convert.ToChar digitc - for i = 0 to pkt.Length-1 do - let v = pkt[i] - addC (convDigit (int32 v / 16)) - addC (convDigit (int32 v % 16)) + let pkt = pki.ToToken() + + let convDigit digit = + let digitc = + if digit < 10 then + Convert.ToInt32 '0' + digit + else + Convert.ToInt32 'a' + (digit - 10) + + Convert.ToChar digitc + + for i = 0 to pkt.Length - 1 do + let v = pkt[i] + addC (convDigit (int32 v / 16)) + addC (convDigit (int32 v % 16)) // retargetable can be true only for system assemblies that definitely have Version if aref.Retargetable then add ", Retargetable=Yes" + b.ToString() [] type ILModuleRef = - { name: string - hasMetadata: bool - hash: byte[] option } + { + name: string + hasMetadata: bool + hash: byte[] option + } - static member Create (name, hasMetadata, hash) = - { name=name - hasMetadata= hasMetadata - hash=hash } + static member Create(name, hasMetadata, hash) = + { + name = name + hasMetadata = hasMetadata + hash = hash + } - member x.Name=x.name + member x.Name = x.name - member x.HasMetadata=x.hasMetadata + member x.HasMetadata = x.hasMetadata - member x.Hash=x.hash + member x.Hash = x.hash [] [] @@ -491,12 +597,15 @@ type ILScopeRef = | Assembly of ILAssemblyRef | PrimaryAssembly - member x.IsLocalRef = match x with ILScopeRef.Local -> true | _ -> false + member x.IsLocalRef = + match x with + | ILScopeRef.Local -> true + | _ -> false member x.QualifiedName = match x with | ILScopeRef.Local -> "" - | ILScopeRef.Module mref -> "module "+mref.Name + | ILScopeRef.Module mref -> "module " + mref.Name | ILScopeRef.Assembly aref -> aref.QualifiedName | ILScopeRef.PrimaryAssembly -> "" @@ -513,12 +622,15 @@ type ILArrayShape = static member SingleDimensional = ILArrayShapeStatics.SingleDimensional - static member FromRank n = if n = 1 then ILArrayShape.SingleDimensional else ILArrayShape (List.replicate n (Some 0, None)) - + static member FromRank n = + if n = 1 then + ILArrayShape.SingleDimensional + else + ILArrayShape(List.replicate n (Some 0, None)) and ILArrayShapeStatics() = - static let singleDimensional = ILArrayShape [(Some 0, None)] + static let singleDimensional = ILArrayShape [ (Some 0, None) ] static member SingleDimensional = singleDimensional @@ -547,11 +659,20 @@ type ILCallingConv = member x.BasicConv = let (Callconv (_a, b)) = x in b - member x.IsInstance = match x.ThisConv with ILThisConvention.Instance -> true | _ -> false + member x.IsInstance = + match x.ThisConv with + | ILThisConvention.Instance -> true + | _ -> false - member x.IsInstanceExplicit = match x.ThisConv with ILThisConvention.InstanceExplicit -> true | _ -> false + member x.IsInstanceExplicit = + match x.ThisConv with + | ILThisConvention.InstanceExplicit -> true + | _ -> false - member x.IsStatic = match x.ThisConv with ILThisConvention.Static -> true | _ -> false + member x.IsStatic = + match x.ThisConv with + | ILThisConvention.Static -> true + | _ -> false static member Instance = ILCallingConvStatics.Instance @@ -560,9 +681,9 @@ type ILCallingConv = /// Static storage to amortize the allocation of ILCallingConv.Instance and ILCallingConv.Static. and ILCallingConvStatics() = - static let instanceCallConv = Callconv (ILThisConvention.Instance, ILArgConvention.Default) + static let instanceCallConv = Callconv(ILThisConvention.Instance, ILArgConvention.Default) - static let staticCallConv = Callconv (ILThisConvention.Static, ILArgConvention.Default) + static let staticCallConv = Callconv(ILThisConvention.Static, ILArgConvention.Default) static member Instance = instanceCallConv @@ -575,22 +696,27 @@ type ILBoxity = // IL type references have a pre-computed hash code to enable quick lookup tables during binary generation. [] type ILTypeRef = - { trefScope: ILScopeRef - trefEnclosing: string list - trefName: string - hashCode: int - mutable asBoxedType: ILType } + { + trefScope: ILScopeRef + trefEnclosing: string list + trefName: string + hashCode: int + mutable asBoxedType: ILType + } static member ComputeHash(scope, enclosing, name) = hash scope * 17 ^^^ (hash enclosing * 101 <<< 1) ^^^ (hash name * 47 <<< 2) - static member Create (scope, enclosing, name) = + static member Create(scope, enclosing, name) = let hashCode = ILTypeRef.ComputeHash(scope, enclosing, name) - { trefScope=scope - trefEnclosing=enclosing - trefName=name - hashCode=hashCode - asBoxedType = Unchecked.defaultof<_> } + + { + trefScope = scope + trefEnclosing = enclosing + trefName = name + hashCode = hashCode + asBoxedType = Unchecked.defaultof<_> + } member x.Scope = x.trefScope @@ -600,14 +726,15 @@ type ILTypeRef = member x.ApproxId = x.hashCode - member x.AsBoxedType (tspec: ILTypeSpec) = + member x.AsBoxedType(tspec: ILTypeSpec) = if isNil tspec.tspecInst then let v = x.asBoxedType + match box v with | null -> - let r = ILType.Boxed tspec - x.asBoxedType <- r - r + let r = ILType.Boxed tspec + x.asBoxedType <- r + r | _ -> v else ILType.Boxed tspec @@ -616,14 +743,16 @@ type ILTypeRef = override x.Equals yobj = let y = (yobj :?> ILTypeRef) - (x.ApproxId = y.ApproxId) && - (x.Scope = y.Scope) && - (x.Name = y.Name) && - (x.Enclosing = y.Enclosing) - member x.EqualsWithPrimaryScopeRef(primaryScopeRef:ILScopeRef, yobj:obj) = + (x.ApproxId = y.ApproxId) + && (x.Scope = y.Scope) + && (x.Name = y.Name) + && (x.Enclosing = y.Enclosing) + + member x.EqualsWithPrimaryScopeRef(primaryScopeRef: ILScopeRef, yobj: obj) = let y = (yobj :?> ILTypeRef) - let isPrimary (v:ILTypeRef) = + + let isPrimary (v: ILTypeRef) = match v.Scope with | ILScopeRef.PrimaryAssembly -> true | _ -> false @@ -631,39 +760,71 @@ type ILTypeRef = // Since we can remap the scope, we need to recompute hash ... this is not an expensive operation let isPrimaryX = isPrimary x let isPrimaryY = isPrimary y - let xApproxId = if isPrimaryX && not(isPrimaryY) then ILTypeRef.ComputeHash(primaryScopeRef, x.Enclosing, x.Name) else x.ApproxId - let yApproxId = if isPrimaryY && not(isPrimaryX) then ILTypeRef.ComputeHash(primaryScopeRef, y.Enclosing, y.Name) else y.ApproxId - let xScope = if isPrimaryX then primaryScopeRef else x.Scope - let yScope = if isPrimaryY then primaryScopeRef else y.Scope - (xApproxId = yApproxId) && - (xScope = yScope) && - (x.Name = y.Name) && - (x.Enclosing = y.Enclosing) + let xApproxId = + if isPrimaryX && not (isPrimaryY) then + ILTypeRef.ComputeHash(primaryScopeRef, x.Enclosing, x.Name) + else + x.ApproxId + + let yApproxId = + if isPrimaryY && not (isPrimaryX) then + ILTypeRef.ComputeHash(primaryScopeRef, y.Enclosing, y.Name) + else + y.ApproxId + + let xScope = + if isPrimaryX then + primaryScopeRef + else + x.Scope + + let yScope = + if isPrimaryY then + primaryScopeRef + else + y.Scope + + (xApproxId = yApproxId) + && (xScope = yScope) + && (x.Name = y.Name) + && (x.Enclosing = y.Enclosing) interface IComparable with override x.CompareTo yobj = let y = (yobj :?> ILTypeRef) let c = compare x.ApproxId y.ApproxId - if c <> 0 then c else - let c = compare x.Scope y.Scope - if c <> 0 then c else - let c = compare x.Name y.Name - if c <> 0 then c else - compare x.Enclosing y.Enclosing - member tref.FullName = String.concat "." (tref.Enclosing @ [tref.Name]) + if c <> 0 then + c + else + let c = compare x.Scope y.Scope + + if c <> 0 then + c + else + let c = compare x.Name y.Name + + if c <> 0 then + c + else + compare x.Enclosing y.Enclosing + + member tref.FullName = String.concat "." (tref.Enclosing @ [ tref.Name ]) member tref.BasicQualifiedName = - (String.concat "+" (tref.Enclosing @ [ tref.Name ] )).Replace(",", @"\,") + (String.concat "+" (tref.Enclosing @ [ tref.Name ])).Replace(",", @"\,") member tref.AddQualifiedNameExtension basic = let sco = tref.Scope.QualifiedName - if sco = "" then basic else String.concat ", " [basic;sco] - member tref.QualifiedName = - tref.AddQualifiedNameExtension tref.BasicQualifiedName + if sco = "" then + basic + else + String.concat ", " [ basic; sco ] + + member tref.QualifiedName = tref.AddQualifiedNameExtension tref.BasicQualifiedName /// For debugging [] @@ -672,49 +833,63 @@ type ILTypeRef = /// For debugging override x.ToString() = x.FullName +and [] ILTypeSpec = + { + tspecTypeRef: ILTypeRef + /// The type instantiation if the type is generic. + tspecInst: ILGenericArgs + } -and [] - ILTypeSpec = - { tspecTypeRef: ILTypeRef - /// The type instantiation if the type is generic. - tspecInst: ILGenericArgs } - - member x.TypeRef=x.tspecTypeRef + member x.TypeRef = x.tspecTypeRef - member x.Scope=x.TypeRef.Scope + member x.Scope = x.TypeRef.Scope - member x.Enclosing=x.TypeRef.Enclosing + member x.Enclosing = x.TypeRef.Enclosing - member x.Name=x.TypeRef.Name + member x.Name = x.TypeRef.Name - member x.GenericArgs=x.tspecInst + member x.GenericArgs = x.tspecInst - static member Create (typeRef, instantiation) = { tspecTypeRef =typeRef; tspecInst=instantiation } + static member Create(typeRef, instantiation) = + { + tspecTypeRef = typeRef + tspecInst = instantiation + } member x.BasicQualifiedName = let tc = x.TypeRef.BasicQualifiedName + if isNil x.GenericArgs then tc else - tc + "[" + String.concat "," (x.GenericArgs |> List.map (fun arg -> "[" + arg.QualifiedName + "]")) + "]" + tc + + "[" + + String.concat "," (x.GenericArgs |> List.map (fun arg -> "[" + arg.QualifiedName + "]")) + + "]" member x.AddQualifiedNameExtension basic = x.TypeRef.AddQualifiedNameExtension basic - member x.FullName=x.TypeRef.FullName + member x.FullName = x.TypeRef.FullName /// For debugging [] member x.DebugText = x.ToString() - member x.EqualsWithPrimaryScopeRef(primaryScopeRef:ILScopeRef, yobj:obj) = + member x.EqualsWithPrimaryScopeRef(primaryScopeRef: ILScopeRef, yobj: obj) = let y = (yobj :?> ILTypeSpec) - x.tspecTypeRef.EqualsWithPrimaryScopeRef(primaryScopeRef, y.TypeRef) && (x.GenericArgs = y.GenericArgs) - override x.ToString() = x.TypeRef.ToString() + if isNil x.GenericArgs then "" else "<...>" + x.tspecTypeRef.EqualsWithPrimaryScopeRef(primaryScopeRef, y.TypeRef) + && (x.GenericArgs = y.GenericArgs) -and [] - ILType = + override x.ToString() = + x.TypeRef.ToString() + + if isNil x.GenericArgs then + "" + else + "<...>" + +and [] ILType = | Void | Array of ILArrayShape * ILType | Value of ILTypeSpec @@ -729,8 +904,9 @@ and [ "!" + string n | ILType.Modified (_, _ty1, ty2) -> ty2.BasicQualifiedName - | ILType.Array (ILArrayShape s, ty) -> ty.BasicQualifiedName + "[" + String(',', s.Length-1) + "]" - | ILType.Value tr | ILType.Boxed tr -> tr.BasicQualifiedName + | ILType.Array (ILArrayShape s, ty) -> ty.BasicQualifiedName + "[" + String(',', s.Length - 1) + "]" + | ILType.Value tr + | ILType.Boxed tr -> tr.BasicQualifiedName | ILType.Void -> "void" | ILType.Ptr _ty -> failwith "unexpected pointer type" | ILType.Byref _ty -> failwith "unexpected byref type" @@ -740,19 +916,20 @@ and [ basic | ILType.Modified (_, _ty1, ty2) -> ty2.AddQualifiedNameExtension basic - | ILType.Array (ILArrayShape(_s), ty) -> ty.AddQualifiedNameExtension basic - | ILType.Value tr | ILType.Boxed tr -> tr.AddQualifiedNameExtension basic + | ILType.Array (ILArrayShape (_s), ty) -> ty.AddQualifiedNameExtension basic + | ILType.Value tr + | ILType.Boxed tr -> tr.AddQualifiedNameExtension basic | ILType.Void -> failwith "void" | ILType.Ptr _ty -> failwith "unexpected pointer type" | ILType.Byref _ty -> failwith "unexpected byref type" | ILType.FunctionPointer _mref -> failwith "unexpected function pointer type" - member x.QualifiedName = - x.AddQualifiedNameExtension(x.BasicQualifiedName) + member x.QualifiedName = x.AddQualifiedNameExtension(x.BasicQualifiedName) member x.TypeSpec = match x with - | ILType.Boxed tr | ILType.Value tr -> tr + | ILType.Boxed tr + | ILType.Value tr -> tr | _ -> invalidOp "not a nominal type" member x.Boxity = @@ -763,22 +940,26 @@ and [ tspec.TypeRef + | ILType.Boxed tspec + | ILType.Value tspec -> tspec.TypeRef | _ -> invalidOp "not a nominal type" member x.IsNominal = match x with - | ILType.Boxed _ | ILType.Value _ -> true + | ILType.Boxed _ + | ILType.Value _ -> true | _ -> false member x.GenericArgs = match x with - | ILType.Boxed tspec | ILType.Value tspec -> tspec.GenericArgs + | ILType.Boxed tspec + | ILType.Value tspec -> tspec.GenericArgs | _ -> [] member x.IsTyvar = match x with - | ILType.TypeVar _ -> true | _ -> false + | ILType.TypeVar _ -> true + | _ -> false /// For debugging [] @@ -786,28 +967,36 @@ and [] - ILCallingSignature = - { CallingConv: ILCallingConv - ArgTypes: ILTypes - ReturnType: ILType } +and [] ILCallingSignature = + { + CallingConv: ILCallingConv + ArgTypes: ILTypes + ReturnType: ILType + } and ILGenericArgs = ILType list and ILTypes = ILType list -let mkILCallSig (cc, args, ret) = { ArgTypes=args; CallingConv=cc; ReturnType=ret} +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 - mrefReturn: ILType } + { + mrefParent: ILTypeRef + mrefCallconv: ILCallingConv + mrefGenericArity: int + mrefName: string + mrefArgs: ILTypes + mrefReturn: ILType + } member x.DeclaringTypeRef = x.mrefParent @@ -825,51 +1014,64 @@ type ILMethodRef = member x.CallingSignature = mkILCallSig (x.CallingConv, x.ArgTypes, x.ReturnType) - static member Create (enclosingTypeRef, callingConv, name, genericArity, argTypes, returnType) = - { mrefParent=enclosingTypeRef - mrefCallconv=callingConv - mrefName=name - mrefGenericArity=genericArity - mrefArgs=argTypes - mrefReturn=returnType } + static member Create(enclosingTypeRef, callingConv, name, genericArity, argTypes, returnType) = + { + mrefParent = enclosingTypeRef + mrefCallconv = callingConv + mrefName = name + mrefGenericArity = genericArity + mrefArgs = argTypes + mrefReturn = returnType + } /// For debugging [] member x.DebugText = x.ToString() - override x.ToString() = x.DeclaringTypeRef.ToString() + "::" + x.Name + "(...)" + override x.ToString() = + x.DeclaringTypeRef.ToString() + "::" + x.Name + "(...)" [] type ILFieldRef = - { DeclaringTypeRef: ILTypeRef - Name: string - Type: ILType } + { + DeclaringTypeRef: ILTypeRef + Name: string + Type: ILType + } /// For debugging [] member x.DebugText = x.ToString() - override x.ToString() = x.DeclaringTypeRef.ToString() + "::" + x.Name + override x.ToString() = + x.DeclaringTypeRef.ToString() + "::" + x.Name [] type ILMethodSpec = - { mspecMethodRef: ILMethodRef + { + mspecMethodRef: ILMethodRef - mspecDeclaringType: ILType + mspecDeclaringType: ILType - mspecMethodInst: ILGenericArgs } + mspecMethodInst: ILGenericArgs + } - static member Create (a, b, c) = { mspecDeclaringType=a; mspecMethodRef=b; mspecMethodInst=c } + static member Create(a, b, c) = + { + mspecDeclaringType = a + mspecMethodRef = b + mspecMethodInst = c + } member x.MethodRef = x.mspecMethodRef - member x.DeclaringType=x.mspecDeclaringType + member x.DeclaringType = x.mspecDeclaringType - member x.GenericArgs=x.mspecMethodInst + member x.GenericArgs = x.mspecMethodInst - member x.Name=x.MethodRef.Name + member x.Name = x.MethodRef.Name - member x.CallingConv=x.MethodRef.CallingConv + member x.CallingConv = x.MethodRef.CallingConv member x.GenericArity = x.MethodRef.GenericArity @@ -885,8 +1087,10 @@ type ILMethodSpec = [] type ILFieldSpec = - { FieldRef: ILFieldRef - DeclaringType: ILType } + { + FieldRef: ILFieldRef + DeclaringType: ILType + } member x.FormalType = x.FieldRef.Type @@ -912,74 +1116,83 @@ type ILPlatform = | IA64 type ILSourceDocument = - { sourceLanguage: ILGuid option - sourceVendor: ILGuid option - sourceDocType: ILGuid option - sourceFile: string } + { + sourceLanguage: ILGuid option + sourceVendor: ILGuid option + sourceDocType: ILGuid option + sourceFile: string + } - static member Create (language, vendor, documentType, file) = - { sourceLanguage=language - sourceVendor=vendor - sourceDocType=documentType - sourceFile=file } + static member Create(language, vendor, documentType, file) = + { + sourceLanguage = language + sourceVendor = vendor + sourceDocType = documentType + sourceFile = file + } - member x.Language=x.sourceLanguage + member x.Language = x.sourceLanguage - member x.Vendor=x.sourceVendor + member x.Vendor = x.sourceVendor - member x.DocumentType=x.sourceDocType + member x.DocumentType = x.sourceDocType - member x.File=x.sourceFile + member x.File = x.sourceFile [] type ILDebugPoint = - { sourceDocument: ILSourceDocument - sourceLine: int - sourceColumn: int - sourceEndLine: int - sourceEndColumn: int } + { + sourceDocument: ILSourceDocument + sourceLine: int + sourceColumn: int + sourceEndLine: int + sourceEndColumn: int + } - static member Create (document, line, column, endLine, endColumn) = - { sourceDocument=document - sourceLine=line - sourceColumn=column - sourceEndLine=endLine - sourceEndColumn=endColumn } + static member Create(document, line, column, endLine, endColumn) = + { + sourceDocument = document + sourceLine = line + sourceColumn = column + sourceEndLine = endLine + sourceEndColumn = endColumn + } - member x.Document=x.sourceDocument + member x.Document = x.sourceDocument - member x.Line=x.sourceLine + member x.Line = x.sourceLine - member x.Column=x.sourceColumn + member x.Column = x.sourceColumn - member x.EndLine=x.sourceEndLine + member x.EndLine = x.sourceEndLine - member x.EndColumn=x.sourceEndColumn + member x.EndColumn = x.sourceEndColumn /// For debugging [] member x.DebugText = x.ToString() - override x.ToString() = sprintf "(%d, %d)-(%d, %d)" x.Line x.Column x.EndLine x.EndColumn + override x.ToString() = + sprintf "(%d, %d)-(%d, %d)" x.Line x.Column x.EndLine x.EndColumn type ILAttribElem = - | String of string option - | Bool of bool - | Char of char - | SByte of int8 - | Int16 of int16 - | Int32 of int32 - | Int64 of int64 - | Byte of uint8 - | UInt16 of uint16 - | UInt32 of uint32 - | UInt64 of uint64 - | Single of single - | Double of double - | Null - | Type of ILType option - | TypeRef of ILTypeRef option - | Array of ILType * ILAttribElem list + | String of string option + | Bool of bool + | Char of char + | SByte of int8 + | Int16 of int16 + | Int32 of int32 + | Int64 of int64 + | Byte of uint8 + | UInt16 of uint16 + | UInt32 of uint32 + | UInt64 of uint64 + | Single of single + | Double of double + | Null + | Type of ILType option + | TypeRef of ILTypeRef option + | Array of ILType * ILAttribElem list type ILAttributeNamedArg = string * ILType * bool * ILAttribElem @@ -998,10 +1211,10 @@ type ILAttribute = | Encoded (_, _, elements) -> elements | Decoded (_, fixedArgs, namedArgs) -> fixedArgs @ (namedArgs |> List.map (fun (_, _, _, e) -> e)) - member x.WithMethod (method: ILMethodSpec) = + member x.WithMethod(method: ILMethodSpec) = match x with - | Encoded (_, data, elements) -> Encoded (method, data, elements) - | Decoded (_, fixedArgs, namedArgs) -> Decoded (method, fixedArgs, namedArgs) + | Encoded (_, data, elements) -> Encoded(method, data, elements) + | Decoded (_, fixedArgs, namedArgs) -> Decoded(method, fixedArgs, namedArgs) /// For debugging [] @@ -1010,7 +1223,7 @@ type ILAttribute = override x.ToString() = x.Method.ToString() + "(...)" [] -type ILAttributes(array : ILAttribute[]) = +type ILAttributes(array: ILAttribute[]) = member x.AsArray() = array @@ -1026,25 +1239,30 @@ type ILAttributesStored = | Given of ILAttributes member x.GetCustomAttrs metadataIndex = - match x with - | Reader f -> ILAttributes (f metadataIndex) - | Given attrs -> attrs + match x with + | Reader f -> ILAttributes(f metadataIndex) + | Given attrs -> attrs -let emptyILCustomAttrs = ILAttributes [| |] +let emptyILCustomAttrs = ILAttributes [||] let mkILCustomAttrsFromArray (attrs: ILAttribute[]) = - if attrs.Length = 0 then emptyILCustomAttrs else ILAttributes attrs + 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 emptyILCustomAttrsStored = ILAttributesStored.Given emptyILCustomAttrs let storeILCustomAttrs (attrs: ILAttributes) = - if attrs.AsArray().Length = 0 then emptyILCustomAttrsStored else ILAttributesStored.Given attrs + if attrs.AsArray().Length = 0 then + emptyILCustomAttrsStored + else + ILAttributesStored.Given attrs let mkILCustomAttrsReader f = ILAttributesStored.Reader f @@ -1055,69 +1273,68 @@ type ILCodeLabel = int // -------------------------------------------------------------------- type ILBasicType = - | DT_R - | DT_I1 - | DT_U1 - | DT_I2 - | DT_U2 - | DT_I4 - | DT_U4 - | DT_I8 - | DT_U8 - | DT_R4 - | DT_R8 - | DT_I - | DT_U - | DT_REF + | DT_R + | DT_I1 + | DT_U1 + | DT_I2 + | DT_U2 + | DT_I4 + | DT_U4 + | DT_I8 + | DT_U8 + | DT_R4 + | DT_R8 + | DT_I + | DT_U + | DT_REF [] type ILToken = - | ILType of ILType - | ILMethod of ILMethodSpec - | ILField of ILFieldSpec + | ILType of ILType + | ILMethod of ILMethodSpec + | ILField of ILFieldSpec [] type ILConst = - | I4 of int32 - | I8 of int64 - | R4 of single - | R8 of double + | I4 of int32 + | I8 of int64 + | R4 of single + | R8 of double type ILTailcall = - | Tailcall - | Normalcall + | Tailcall + | Normalcall type ILAlignment = - | Aligned - | Unaligned1 - | Unaligned2 - | Unaligned4 + | Aligned + | Unaligned1 + | Unaligned2 + | Unaligned4 type ILVolatility = - | Volatile - | Nonvolatile + | Volatile + | Nonvolatile type ILReadonly = - | ReadonlyAddress - | NormalAddress + | ReadonlyAddress + | NormalAddress type ILVarArgs = ILTypes option [] type ILComparisonInstr = - | BI_beq - | BI_bge - | BI_bge_un - | BI_bgt - | BI_bgt_un - | BI_ble - | BI_ble_un - | BI_blt - | BI_blt_un - | BI_bne_un - | BI_brfalse - | BI_brtrue - + | BI_beq + | BI_bge + | BI_bge_un + | BI_bgt + | BI_bgt_un + | BI_ble + | BI_ble_un + | BI_blt + | BI_blt_un + | BI_bne_un + | BI_brfalse + | BI_brtrue [] type ILInstr = @@ -1230,7 +1447,6 @@ type ILInstr = | EI_ilzero of ILType | EI_ldlen_multi of int32 * int32 - [] type ILExceptionClause = | Finally of (ILCodeLabel * ILCodeLabel) @@ -1240,62 +1456,68 @@ type ILExceptionClause = [] type ILExceptionSpec = - { Range: ILCodeLabel * ILCodeLabel - Clause: ILExceptionClause } + { + Range: ILCodeLabel * ILCodeLabel + Clause: ILExceptionClause + } /// Indicates that a particular local variable has a particular source /// language name within a given set of ranges. This does not effect local /// variable numbering, which is global over the whole method. [] -type ILLocalDebugMapping = - { LocalIndex: int - LocalName: string } +type ILLocalDebugMapping = { LocalIndex: int; LocalName: string } [] type ILLocalDebugInfo = - { Range: ILCodeLabel * ILCodeLabel - DebugMappings: ILLocalDebugMapping list } + { + Range: ILCodeLabel * ILCodeLabel + DebugMappings: ILLocalDebugMapping list + } [] type ILCode = - { Labels: Dictionary - Instrs: ILInstr[] - Exceptions: ILExceptionSpec list - Locals: ILLocalDebugInfo list } + { + Labels: Dictionary + Instrs: ILInstr[] + Exceptions: ILExceptionSpec list + Locals: ILLocalDebugInfo list + } [] type ILLocal = - { Type: ILType - IsPinned: bool - DebugInfo: (string * int * int) option } + { + Type: ILType + IsPinned: bool + DebugInfo: (string * int * int) option + } type ILLocals = ILLocal list [] type ILDebugImport = - | ImportType of targetType: ILType // * alias: string option + | ImportType of targetType: ILType // * alias: string option | ImportNamespace of targetNamespace: string // * assembly: ILAssemblyRef option * alias: string option - //| ReferenceAlias of string - //| OpenXmlNamespace of prefix: string * xmlNamespace: string +//| ReferenceAlias of string +//| OpenXmlNamespace of prefix: string * xmlNamespace: string type ILDebugImports = { - Parent: ILDebugImports option - Imports: ILDebugImport[] + Parent: ILDebugImports option + Imports: ILDebugImport[] } [] type ILMethodBody = - { - IsZeroInit: bool - MaxStack: int32 - NoInlining: bool - AggressiveInlining: bool - Locals: ILLocals - Code: ILCode - DebugRange: ILDebugPoint option - DebugImports: ILDebugImports option + { + IsZeroInit: bool + MaxStack: int32 + NoInlining: bool + AggressiveInlining: bool + Locals: ILLocals + Code: ILCode + DebugRange: ILDebugPoint option + DebugImports: ILDebugImports option } [] @@ -1375,7 +1597,9 @@ 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 *) + | Array of + ILNativeType option * + (int32 * int32 option) option (* optional idx of parameter giving size plus optional additive i.e. num elems *) | Int | UInt | Method @@ -1389,9 +1613,7 @@ type ILNativeType = | ANSIBSTR | VariantBool -and - [] - ILNativeVariant = +and [] ILNativeVariant = | Empty | Null | Variant @@ -1459,11 +1681,10 @@ type ILSecurityAction = | DemandChoice [] -type ILSecurityDecl = - | ILSecurityDecl of ILSecurityAction * byte[] +type ILSecurityDecl = ILSecurityDecl of ILSecurityAction * byte[] [] -type ILSecurityDecls (array : ILSecurityDecl[]) = +type ILSecurityDecls(array: ILSecurityDecl[]) = member x.AsArray() = array member x.AsList() = x.AsArray() |> Array.toList @@ -1477,20 +1698,24 @@ type ILSecurityDeclsStored = | Given of ILSecurityDecls member x.GetSecurityDecls metadataIndex = - match x with - | Reader f -> ILSecurityDecls(f metadataIndex) - | Given attrs -> attrs + match x with + | Reader f -> ILSecurityDecls(f metadataIndex) + | Given attrs -> attrs -let emptyILSecurityDecls = ILSecurityDecls [| |] +let emptyILSecurityDecls = ILSecurityDecls [||] let emptyILSecurityDeclsStored = ILSecurityDeclsStored.Given emptyILSecurityDecls -let mkILSecurityDecls l = match l with [] -> emptyILSecurityDecls | _ -> ILSecurityDecls (Array.ofList l) +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 + else + ILSecurityDeclsStored.Given x let mkILSecurityDeclsReader f = ILSecurityDeclsStored.Reader f @@ -1524,26 +1749,30 @@ type PInvokeCharEncoding = [] type PInvokeMethod = - { Where: ILModuleRef - Name: string - CallingConv: PInvokeCallingConvention - CharEncoding: PInvokeCharEncoding - NoMangle: bool - LastError: bool - ThrowOnUnmappableChar: PInvokeThrowOnUnmappableChar - CharBestFit: PInvokeCharBestFit } + { + 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 - CustomAttrsStored: ILAttributesStored - MetadataIndex: int32 } + { + 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 @@ -1551,14 +1780,19 @@ type ILParameters = ILParameter list [] type ILReturn = - { Marshal: ILNativeType option - Type: ILType - CustomAttrsStored: ILAttributesStored - MetadataIndex: int32 } + { + Marshal: ILNativeType option + Type: ILType + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 + } member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex - member x.WithCustomAttrs(customAttrs) = { x with CustomAttrsStored = storeILCustomAttrs customAttrs } + member x.WithCustomAttrs(customAttrs) = + { x with + CustomAttrsStored = storeILCustomAttrs customAttrs + } type ILOverridesSpec = | OverridesSpec of ILMethodRef * ILType @@ -1568,10 +1802,12 @@ type ILOverridesSpec = member x.DeclaringType = let (OverridesSpec (_mr, ty)) = x in ty type ILMethodVirtualInfo = - { IsFinal: bool - IsNewSlot: bool - IsCheckAccessOnOverride: bool - IsAbstract: bool } + { + IsFinal: bool + IsNewSlot: bool + IsCheckAccessOnOverride: bool + IsAbstract: bool + } [] type MethodBody = @@ -1597,14 +1833,16 @@ type ILGenericVariance = [] type ILGenericParameterDef = - { Name: string - Constraints: ILTypes - Variance: ILGenericVariance - HasReferenceTypeConstraint: bool - HasNotNullableValueTypeConstraint: bool - HasDefaultConstructorConstraint: bool - CustomAttrsStored : ILAttributesStored - MetadataIndex: int32 } + { + Name: string + Constraints: ILTypes + Variance: ILGenericVariance + HasReferenceTypeConstraint: bool + HasNotNullableValueTypeConstraint: bool + HasDefaultConstructorConstraint: bool + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 + } member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex @@ -1618,13 +1856,21 @@ type ILGenericParameterDefs = ILGenericParameterDef list let memberAccessOfFlags flags = let f = (flags &&& 0x00000007) - if f = 0x00000001 then ILMemberAccess.Private - elif f = 0x00000006 then ILMemberAccess.Public - elif f = 0x00000004 then ILMemberAccess.Family - elif f = 0x00000002 then ILMemberAccess.FamilyAndAssembly - elif f = 0x00000005 then ILMemberAccess.FamilyOrAssembly - elif f = 0x00000003 then ILMemberAccess.Assembly - else ILMemberAccess.CompilerControlled + + if f = 0x00000001 then + ILMemberAccess.Private + elif f = 0x00000006 then + ILMemberAccess.Public + elif f = 0x00000004 then + ILMemberAccess.Family + elif f = 0x00000002 then + ILMemberAccess.FamilyAndAssembly + elif f = 0x00000005 then + ILMemberAccess.FamilyOrAssembly + elif f = 0x00000003 then + ILMemberAccess.Assembly + else + ILMemberAccess.CompilerControlled let convertMemberAccess (ilMemberAccess: ILMemberAccess) = match ilMemberAccess with @@ -1636,18 +1882,46 @@ let convertMemberAccess (ilMemberAccess: ILMemberAccess) = | ILMemberAccess.FamilyOrAssembly -> MethodAttributes.FamORAssem | ILMemberAccess.Family -> MethodAttributes.Family -let inline conditionalAdd condition flagToAdd source = if condition then source ||| flagToAdd else source &&& ~~~flagToAdd +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, ret: ILReturn, body: Lazy, 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) +type ILMethodDef + ( + name: string, + attributes: MethodAttributes, + implAttributes: MethodImplAttributes, + callingConv: ILCallingConv, + parameters: ILParameters, + ret: ILReturn, + body: Lazy, + 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 + ) member private _.LazyBody = body @@ -1676,22 +1950,40 @@ type ILMethodDef (name: string, attributes: MethodAttributes, implAttributes: Me member _.MetadataIndex = metadataIndex - member x.With (?name: string, ?attributes: MethodAttributes, ?implAttributes: MethodImplAttributes, - ?callingConv: ILCallingConv, ?parameters: ILParameters, ?ret: ILReturn, - ?body: Lazy, ?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.LazyBody, - 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.With + ( + ?name: string, + ?attributes: MethodAttributes, + ?implAttributes: MethodImplAttributes, + ?callingConv: ILCallingConv, + ?parameters: ILParameters, + ?ret: ILReturn, + ?body: Lazy, + ?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.LazyBody, + 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 @@ -1700,21 +1992,31 @@ type ILMethodDef (name: string, attributes: MethodAttributes, implAttributes: Me member x.ParameterTypes = typesOfILParams x.Parameters member md.Code = - match md.Body with - | MethodBody.IL il-> Some il.Value.Code - | _ -> None + match md.Body with + | MethodBody.IL il -> Some il.Value.Code + | _ -> None - member x.IsIL = match x.Body with | MethodBody.IL _ -> true | _ -> false + member x.IsIL = + match x.Body with + | MethodBody.IL _ -> true + | _ -> false - member x.Locals = match x.Body with | MethodBody.IL il -> il.Value.Locals | _ -> [] + member x.Locals = + match x.Body with + | MethodBody.IL il -> il.Value.Locals + | _ -> [] - member x.MethodBody = match x.Body with MethodBody.IL il -> il.Value | _ -> failwith "not IL" + member x.MethodBody = + match x.Body with + | MethodBody.IL il -> il.Value + | _ -> failwith "not IL" member x.MaxStack = x.MethodBody.MaxStack member x.IsZeroInit = x.MethodBody.IsZeroInit - member md.CallingSignature = mkILCallSig (md.CallingConv, md.ParameterTypes, md.Return.Type) + member md.CallingSignature = + mkILCallSig (md.CallingConv, md.ParameterTypes, md.Return.Type) member x.IsClassInitializer = x.Name = ".cctor" @@ -1732,7 +2034,8 @@ type ILMethodDef (name: string, attributes: MethodAttributes, implAttributes: Me member x.IsNewSlot = x.Attributes &&& MethodAttributes.NewSlot <> enum 0 - member x.IsCheckAccessOnOverride= x.Attributes &&& MethodAttributes.CheckAccessOnOverride <> enum 0 + member x.IsCheckAccessOnOverride = + x.Attributes &&& MethodAttributes.CheckAccessOnOverride <> enum 0 member x.IsAbstract = x.Attributes &&& MethodAttributes.Abstract <> enum 0 @@ -1740,7 +2043,8 @@ type ILMethodDef (name: string, attributes: MethodAttributes, implAttributes: Me member x.IsSpecialName = x.Attributes &&& MethodAttributes.SpecialName <> enum 0 - member x.IsUnmanagedExport = x.Attributes &&& MethodAttributes.UnmanagedExport <> enum 0 + member x.IsUnmanagedExport = + x.Attributes &&& MethodAttributes.UnmanagedExport <> enum 0 member x.IsReqSecObj = x.Attributes &&& MethodAttributes.RequireSecObject <> enum 0 @@ -1750,119 +2054,191 @@ type ILMethodDef (name: string, attributes: MethodAttributes, implAttributes: Me member x.IsForwardRef = x.ImplAttributes &&& MethodImplAttributes.ForwardRef <> enum 0 - member x.IsInternalCall = x.ImplAttributes &&& MethodImplAttributes.InternalCall <> enum 0 + member x.IsInternalCall = + x.ImplAttributes &&& MethodImplAttributes.InternalCall <> enum 0 - member x.IsPreserveSig = x.ImplAttributes &&& MethodImplAttributes.PreserveSig <> enum 0 + member x.IsPreserveSig = + x.ImplAttributes &&& MethodImplAttributes.PreserveSig <> enum 0 - member x.IsSynchronized = x.ImplAttributes &&& MethodImplAttributes.Synchronized <> enum 0 + member x.IsSynchronized = + x.ImplAttributes &&& MethodImplAttributes.Synchronized <> enum 0 member x.IsNoInline = x.ImplAttributes &&& MethodImplAttributes.NoInlining <> enum 0 - member x.IsAggressiveInline= x.ImplAttributes &&& MethodImplAttributes.AggressiveInlining <> enum 0 + 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 = ( - 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)) + 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.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.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.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.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.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.WithAggressiveInlining(condition) = + x.With( + implAttributes = + (x.ImplAttributes + |> conditionalAdd condition MethodImplAttributes.AggressiveInlining) + ) - member x.WithRuntime(condition) = x.With(implAttributes = (x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.Runtime)) + member x.WithRuntime(condition) = + x.With(implAttributes = (x.ImplAttributes |> conditionalAdd condition MethodImplAttributes.Runtime)) /// Index table by name and arity. type MethodDefMap = Map [] -type ILMethodDefs(f : unit -> ILMethodDef[]) = +type ILMethodDefs(f: unit -> ILMethodDef[]) = let mutable array = InlineDelayInit<_>(f) - let mutable dict = InlineDelayInit<_>(fun () -> + + let mutable dict = + InlineDelayInit<_>(fun () -> let arr = array.Value let t = Dictionary<_, _>() + for i = arr.Length - 1 downto 0 do let y = arr[i] let key = y.Name + match t.TryGetValue key with | true, m -> t[key] <- y :: m - | _ -> t[key] <- [y] + | _ -> t[key] <- [ y ] + t) interface IEnumerable with - member x.GetEnumerator() = ((x :> IEnumerable).GetEnumerator() :> IEnumerator) + member x.GetEnumerator() = + ((x :> IEnumerable).GetEnumerator() :> IEnumerator) interface IEnumerable with - member x.GetEnumerator() = (array.Value :> IEnumerable).GetEnumerator() + member x.GetEnumerator() = + (array.Value :> IEnumerable).GetEnumerator() member x.AsArray() = array.Value - member x.AsList() = array.Value|> Array.toList + member x.AsList() = array.Value |> Array.toList member x.FindByName nm = match dict.Value.TryGetValue nm with | true, m -> m | _ -> [] - member x.FindByNameAndArity (nm, arity) = x.FindByName nm |> List.filter (fun x -> List.length x.Parameters = arity) + member x.FindByNameAndArity(nm, arity) = + x.FindByName nm |> List.filter (fun x -> List.length x.Parameters = arity) - member x.TryFindInstanceByNameAndCallingSignature (nm, callingSig) = + member x.TryFindInstanceByNameAndCallingSignature(nm, callingSig) = x.FindByName nm |> List.tryFind (fun x -> not x.IsStatic && x.CallingSignature = callingSig) [] -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) +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) + 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) /// For debugging [] @@ -1879,12 +2255,33 @@ type ILEventDefs = 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, 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) +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 @@ -1899,19 +2296,26 @@ type ILPropertyDef(name: string, attributes: PropertyAttributes, setMethod: ILMe 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) + 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) /// For debugging [] @@ -1931,7 +2335,7 @@ type ILPropertyDefs = let convertFieldAccess (ilMemberAccess: ILMemberAccess) = match ilMemberAccess with | ILMemberAccess.Assembly -> FieldAttributes.Assembly - | ILMemberAccess.CompilerControlled -> enum(0) + | ILMemberAccess.CompilerControlled -> enum (0) | ILMemberAccess.FamilyAndAssembly -> FieldAttributes.FamANDAssem | ILMemberAccess.FamilyOrAssembly -> FieldAttributes.FamORAssem | ILMemberAccess.Family -> FieldAttributes.Family @@ -1939,45 +2343,95 @@ let convertFieldAccess (ilMemberAccess: ILMemberAccess) = | ILMemberAccess.Public -> FieldAttributes.Public [] -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) = +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 _.Name = name member _.FieldType = fieldType - member _.Attributes=attributes - member _.Data=data - member _.LiteralValue=literalValue - member _.Offset=offset - member _.Marshal=marshal + 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.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.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)) + + 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 = @@ -1988,14 +2442,17 @@ type ILFieldDefs = member x.LookupByName s = let (ILFields t) = x in t[s] type ILMethodImplDef = - { Overrides: ILOverridesSpec - OverrideBy: ILMethodSpec } + { + Overrides: ILOverridesSpec + OverrideBy: ILMethodSpec + } // Index table by name and arity. type ILMethodImplDefs = | ILMethodImpls of Lazy - member x.AsList() = let (ILMethodImpls ltab) = x in Map.foldBack (fun _x y r -> y@r) (ltab.Force()) [] + member x.AsList() = + let (ILMethodImpls ltab) = x in Map.foldBack (fun _x y r -> y @ r) (ltab.Force()) [] and MethodImplsMap = Map @@ -2006,8 +2463,10 @@ type ILTypeDefLayout = | Explicit of ILTypeDefLayoutInfo (* REVIEW: add field info here *) and ILTypeDefLayoutInfo = - { Size: int32 option - Pack: uint16 option } + { + Size: int32 option + Pack: uint16 option + } [] type ILTypeInit = @@ -2027,20 +2486,33 @@ type ILTypeDefAccess = let typeAccessOfFlags flags = let f = (flags &&& 0x00000007) - if f = 0x00000001 then ILTypeDefAccess.Public - elif f = 0x00000002 then ILTypeDefAccess.Nested ILMemberAccess.Public - elif f = 0x00000003 then ILTypeDefAccess.Nested ILMemberAccess.Private - elif f = 0x00000004 then ILTypeDefAccess.Nested ILMemberAccess.Family - elif f = 0x00000006 then ILTypeDefAccess.Nested ILMemberAccess.FamilyAndAssembly - elif f = 0x00000007 then ILTypeDefAccess.Nested ILMemberAccess.FamilyOrAssembly - elif f = 0x00000005 then ILTypeDefAccess.Nested ILMemberAccess.Assembly - else ILTypeDefAccess.Private + + if f = 0x00000001 then + ILTypeDefAccess.Public + elif f = 0x00000002 then + ILTypeDefAccess.Nested ILMemberAccess.Public + elif f = 0x00000003 then + ILTypeDefAccess.Nested ILMemberAccess.Private + elif f = 0x00000004 then + ILTypeDefAccess.Nested ILMemberAccess.Family + elif f = 0x00000006 then + ILTypeDefAccess.Nested ILMemberAccess.FamilyAndAssembly + elif f = 0x00000007 then + ILTypeDefAccess.Nested ILMemberAccess.FamilyOrAssembly + elif f = 0x00000005 then + ILTypeDefAccess.Nested ILMemberAccess.Assembly + else + ILTypeDefAccess.Private let typeEncodingOfFlags flags = let f = (flags &&& 0x00030000) - if f = 0x00020000 then ILDefaultPInvokeEncoding.Auto - elif f = 0x00010000 then ILDefaultPInvokeEncoding.Unicode - else ILDefaultPInvokeEncoding.Ansi + + if f = 0x00020000 then + ILDefaultPInvokeEncoding.Auto + elif f = 0x00010000 then + ILDefaultPInvokeEncoding.Unicode + else + ILDefaultPInvokeEncoding.Ansi [] type ILTypeDefKind = @@ -2051,16 +2523,23 @@ type ILTypeDefKind = | Delegate let typeKindOfFlags nm (super: ILType option) flags = - if (flags &&& 0x00000020) <> 0x0 then ILTypeDefKind.Interface + if (flags &&& 0x00000020) <> 0x0 then + ILTypeDefKind.Interface else match super with | None -> ILTypeDefKind.Class | Some ty -> let name = ty.TypeSpec.Name - if name = "System.Enum" then ILTypeDefKind.Enum - elif (name = "System.Delegate" && nm <> "System.MulticastDelegate") || name = "System.MulticastDelegate" then ILTypeDefKind.Delegate - elif name = "System.ValueType" && nm <> "System.Enum" then ILTypeDefKind.ValueType - else ILTypeDefKind.Class + + if name = "System.Enum" then + ILTypeDefKind.Enum + elif (name = "System.Delegate" && nm <> "System.MulticastDelegate") + || name = "System.MulticastDelegate" then + ILTypeDefKind.Delegate + elif name = "System.ValueType" && nm <> "System.Enum" then + ILTypeDefKind.ValueType + else + ILTypeDefKind.Class let convertTypeAccessFlags access = match access with @@ -2110,48 +2589,129 @@ let convertInitSemantics (init: ILTypeInit) = | ILTypeInit.OnAny -> enum 0 [] -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, isKnownToBeAttribute: bool, securityDeclsStored: ILSecurityDeclsStored, customAttrsStored: ILAttributesStored, metadataIndex: int32) = +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, + isKnownToBeAttribute: bool, + securityDeclsStored: ILSecurityDeclsStored, + customAttrsStored: ILAttributesStored, + metadataIndex: int32 + ) = let mutable customAttrsStored = customAttrsStored - new (name, attributes, layout, implements, genericParams, extends, methods, nestedTypes, fields, methodImpls, events, properties, isKnownToBeAttribute, securityDecls, customAttrs) = - ILTypeDef (name, attributes, layout, implements, genericParams, extends, methods, nestedTypes, fields, methodImpls, events, properties, isKnownToBeAttribute, storeILSecurityDecls securityDecls, storeILCustomAttrs customAttrs, NoMetadataIdx) + new(name, + attributes, + layout, + implements, + genericParams, + extends, + methods, + nestedTypes, + fields, + methodImpls, + events, + properties, + isKnownToBeAttribute, + securityDecls, + customAttrs) = + ILTypeDef( + name, + attributes, + layout, + implements, + genericParams, + extends, + methods, + nestedTypes, + fields, + methodImpls, + events, + properties, + isKnownToBeAttribute, + 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 _.IsKnownToBeAttribute = isKnownToBeAttribute + member _.CustomAttrsStored = customAttrsStored + member _.MetadataIndex = metadataIndex - member x.With(?name, ?attributes, ?layout, ?implements, ?genericParams, ?extends, ?methods, ?nestedTypes, ?fields, ?methodImpls, ?events, ?properties, ?isKnownToBeAttribute, ?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, - isKnownToBeAttribute = defaultArg isKnownToBeAttribute x.IsKnownToBeAttribute, - customAttrs = defaultArg customAttrs x.CustomAttrs) + member x.With + ( + ?name, + ?attributes, + ?layout, + ?implements, + ?genericParams, + ?extends, + ?methods, + ?nestedTypes, + ?fields, + ?methodImpls, + ?events, + ?properties, + ?isKnownToBeAttribute, + ?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, + isKnownToBeAttribute = defaultArg isKnownToBeAttribute x.IsKnownToBeAttribute, + customAttrs = defaultArg customAttrs x.CustomAttrs + ) member x.CustomAttrs = match customAttrsStored with @@ -2159,56 +2719,113 @@ type ILTypeDef(name: string, attributes: TypeAttributes, layout: ILTypeDefLayout let res = ILAttributes(f x.MetadataIndex) customAttrsStored <- ILAttributesStored.Given res res - | ILAttributesStored.Given res -> - res + | ILAttributesStored.Given res -> res member x.SecurityDecls = x.SecurityDeclsStored.GetSecurityDecls x.MetadataIndex - member x.IsClass = (typeKindOfFlags x.Name x.Extends (int x.Attributes)) = ILTypeDefKind.Class - member x.IsStruct = (typeKindOfFlags x.Name x.Extends (int x.Attributes)) = ILTypeDefKind.ValueType - member x.IsInterface = (typeKindOfFlags x.Name x.Extends (int x.Attributes)) = ILTypeDefKind.Interface - member x.IsEnum = (typeKindOfFlags x.Name x.Extends (int x.Attributes)) = ILTypeDefKind.Enum - member x.IsDelegate = (typeKindOfFlags x.Name x.Extends (int x.Attributes)) = ILTypeDefKind.Delegate + member x.IsClass = + (typeKindOfFlags x.Name x.Extends (int x.Attributes)) = ILTypeDefKind.Class + + member x.IsStruct = + (typeKindOfFlags x.Name x.Extends (int x.Attributes)) = ILTypeDefKind.ValueType + + member x.IsInterface = + (typeKindOfFlags x.Name x.Extends (int x.Attributes)) = ILTypeDefKind.Interface + + member x.IsEnum = + (typeKindOfFlags x.Name x.Extends (int x.Attributes)) = ILTypeDefKind.Enum + + member x.IsDelegate = + (typeKindOfFlags x.Name x.Extends (int x.Attributes)) = ILTypeDefKind.Delegate + member x.Access = typeAccessOfFlags (int x.Attributes) member x.IsAbstract = x.Attributes &&& TypeAttributes.Abstract <> enum 0 member x.IsSealed = x.Attributes &&& TypeAttributes.Sealed <> enum 0 member x.IsSerializable = x.Attributes &&& TypeAttributes.Serializable <> enum 0 - member x.IsComInterop = x.Attributes &&& TypeAttributes.Import <> enum 0 (* Class or interface generated for COM interop *) + + member x.IsComInterop = + x.Attributes &&& TypeAttributes.Import + <> enum 0 (* Class or interface generated for COM interop *) + member x.IsSpecialName = x.Attributes &&& TypeAttributes.SpecialName <> enum 0 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 -> ILPreTypeDef[]) = + + 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 pre in arr do - let key = pre.Namespace, pre.Name - t[key] <- pre - ReadOnlyDictionary t) + let mutable dict = + InlineDelayInit<_>(fun () -> + let arr = array.Value + let t = Dictionary<_, _>(HashIdentity.Structural) + + for pre in arr do + let key = pre.Namespace, pre.Name + t[key] <- pre + + ReadOnlyDictionary t) - member x.AsArray() = [| for pre in array.Value -> pre.GetTypeDef() |] + member x.AsArray() = + [| for pre in array.Value -> pre.GetTypeDef() |] - member x.AsList() = [ 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) + member x.GetEnumerator() = + ((x :> IEnumerable).GetEnumerator() :> IEnumerator) interface IEnumerable with member x.GetEnumerator() = @@ -2218,18 +2835,16 @@ and [] ILTypeDefs(f : unit -> ILPreTypeDef[]) = member x.FindByName nm = let ns, n = splitILTypeName nm - dict.Value[(ns, n)].GetTypeDef() - + dict.Value[ (ns, n) ].GetTypeDef() and [] ILPreTypeDef = abstract Namespace: string list abstract Name: string abstract GetTypeDef: unit -> ILTypeDef - /// This is a memory-critical class. Very many of these objects get allocated and held to represent the contents of .NET assemblies. and [] ILPreTypeDefImpl(nameSpace: string list, name: string, metadataIndex: int32, storage: ILTypeDefStored) = - let mutable store : ILTypeDef = Unchecked.defaultof<_> + let mutable store: ILTypeDef = Unchecked.defaultof<_> interface ILPreTypeDef with member _.Namespace = nameSpace @@ -2242,10 +2857,8 @@ and [] ILPreTypeDefImpl(nameSpace: string list, name: string, metadataIn | ILTypeDefStored.Given td -> store <- td td - | ILTypeDefStored.Computed f -> - LazyInitializer.EnsureInitialized(&store, Func<_>(fun () -> f())) - | ILTypeDefStored.Reader f -> - LazyInitializer.EnsureInitialized(&store, Func<_>(fun () -> f metadataIndex)) + | ILTypeDefStored.Computed f -> LazyInitializer.EnsureInitialized(&store, Func<_>(fun () -> f ())) + | ILTypeDefStored.Reader f -> LazyInitializer.EnsureInitialized(&store, Func<_>(fun () -> f metadataIndex)) | _ -> store and ILTypeDefStored = @@ -2256,61 +2869,67 @@ and ILTypeDefStored = let mkILTypeDefReader f = ILTypeDefStored.Reader f type ILNestedExportedType = - { Name: string - Access: ILMemberAccess - Nested: ILNestedExportedTypes - CustomAttrsStored: ILAttributesStored - MetadataIndex: int32 } + { + Name: string + Access: ILMemberAccess + Nested: ILNestedExportedTypes + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 + } member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex and ILNestedExportedTypes = | ILNestedExportedTypes of Lazy> - member x.AsList() = let (ILNestedExportedTypes ltab) = x in Map.foldBack (fun _x y r -> y :: r) (ltab.Force()) [] + member x.AsList() = + let (ILNestedExportedTypes ltab) = x in Map.foldBack (fun _x y r -> y :: r) (ltab.Force()) [] -and [] - ILExportedTypeOrForwarder = - { ScopeRef: ILScopeRef - Name: string - Attributes: TypeAttributes - Nested: ILNestedExportedTypes - CustomAttrsStored: ILAttributesStored - MetadataIndex: int32 } +and [] ILExportedTypeOrForwarder = + { + ScopeRef: ILScopeRef + Name: string + Attributes: TypeAttributes + Nested: ILNestedExportedTypes + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 + } member x.Access = typeAccessOfFlags (int x.Attributes) - member x.IsForwarder = x.Attributes &&& enum(0x00200000) <> enum 0 + member x.IsForwarder = x.Attributes &&& enum (0x00200000) <> enum 0 member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex and ILExportedTypesAndForwarders = | ILExportedTypesAndForwarders of Lazy> - member x.AsList() = let (ILExportedTypesAndForwarders ltab) = x in Map.foldBack (fun _x y r -> y :: r) (ltab.Force()) [] + member x.AsList() = + let (ILExportedTypesAndForwarders ltab) = x in Map.foldBack (fun _x y r -> y :: r) (ltab.Force()) [] member x.TryFindByName nm = match x with - | ILExportedTypesAndForwarders ltab -> - ltab.Value.TryFind nm + | ILExportedTypesAndForwarders ltab -> ltab.Value.TryFind nm [] type ILResourceAccess = | Public | Private -[] +[] type ILResourceLocation = | Local of ByteStorage | File of ILModuleRef * int32 | Assembly of ILAssemblyRef type ILResource = - { Name: string - Location: ILResourceLocation - Access: ILResourceAccess - CustomAttrsStored: ILAttributesStored - MetadataIndex: int32 } + { + Name: string + Location: ILResourceLocation + Access: ILResourceAccess + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 + } /// Read the bytes from a resource local to an assembly member r.GetBytes() = @@ -2340,26 +2959,27 @@ type ILAssemblyLongevity = static member Default = Unspecified type ILAssemblyManifest = - { 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 - - /// Records whether the entrypoint resides in another module. - EntrypointElsewhere: ILModuleRef option - MetadataIndex: int32 + { + 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 + + /// Records whether the entrypoint resides in another module. + EntrypointElsewhere: ILModuleRef option + MetadataIndex: int32 } member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex @@ -2372,36 +2992,40 @@ type ILNativeResource = | Out of unlinkedResource: byte[] type ILModuleDef = - { 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. win32 resources - NativeResources: ILNativeResource list - CustomAttrsStored: ILAttributesStored - MetadataIndex: int32 + { + 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. win32 resources + NativeResources: ILNativeResource list + CustomAttrsStored: ILAttributesStored + MetadataIndex: int32 } + member x.ManifestOfAssembly = match x.Manifest with | Some m -> m | None -> failwith "no manifest" member m.HasManifest = - match m.Manifest with None -> false | _ -> true + match m.Manifest with + | None -> false + | _ -> true member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex @@ -2418,24 +3042,26 @@ let emptyILGenericArgsList = ([]: ILType list) // Make ILTypeRefs etc. // -------------------------------------------------------------------- - -let mkILNestedTyRef (scope, l, nm) = ILTypeRef.Create (scope, l, nm) +let mkILNestedTyRef (scope, l, nm) = ILTypeRef.Create(scope, l, nm) let mkILTyRef (scope, nm) = mkILNestedTyRef (scope, [], nm) type ILGenericArgsList = ILType list -let mkILTySpec (tref, inst) = ILTypeSpec.Create (tref, inst) +let mkILTySpec (tref, inst) = ILTypeSpec.Create(tref, inst) let mkILNonGenericTySpec tref = mkILTySpec (tref, []) let mkILTyRefInTyRef (tref: ILTypeRef, nm) = - mkILNestedTyRef (tref.Scope, tref.Enclosing@[tref.Name], nm) + mkILNestedTyRef (tref.Scope, tref.Enclosing @ [ tref.Name ], nm) let mkILTy boxed tspec = - match boxed with AsObject -> mkILBoxedType tspec | _ -> ILType.Value tspec + match boxed with + | AsObject -> mkILBoxedType tspec + | _ -> ILType.Value tspec -let mkILNamedTy vc tref tinst = mkILTy vc (ILTypeSpec.Create (tref, tinst)) +let mkILNamedTy vc tref tinst = + mkILTy vc (ILTypeSpec.Create(tref, tinst)) let mkILValueTy tref tinst = mkILNamedTy AsValue tref tinst @@ -2446,10 +3072,9 @@ let mkILNonGenericValueTy tref = mkILNamedTy AsValue tref [] let mkILNonGenericBoxedTy tref = mkILNamedTy AsObject tref [] let mkSimpleAssemblyRef n = - ILAssemblyRef.Create (n, None, None, false, None, None) + ILAssemblyRef.Create(n, None, None, false, None, None) -let mkSimpleModRef n = - ILModuleRef.Create (n, true, None) +let mkSimpleModRef n = ILModuleRef.Create(n, true, None) // -------------------------------------------------------------------- // The toplevel class of a module is called "" @@ -2457,28 +3082,33 @@ let mkSimpleModRef n = let typeNameForGlobalFunctions = "" -let mkILTypeForGlobalFunctions scoref = mkILBoxedType (mkILNonGenericTySpec (ILTypeRef.Create (scoref, [], typeNameForGlobalFunctions))) +let mkILTypeForGlobalFunctions scoref = + mkILBoxedType (mkILNonGenericTySpec (ILTypeRef.Create(scoref, [], typeNameForGlobalFunctions))) let isTypeNameForGlobalFunctions d = (d = typeNameForGlobalFunctions) let mkILMethRef (tref, callconv, nm, numGenericParams, argTys, retTy) = - { mrefParent=tref - mrefCallconv=callconv - mrefGenericArity=numGenericParams - mrefName=nm - mrefArgs=argTys - mrefReturn=retTy} + { + mrefParent = tref + mrefCallconv = callconv + mrefGenericArity = numGenericParams + mrefName = nm + mrefArgs = argTys + mrefReturn = retTy + } let mkILMethSpecForMethRefInTy (mref, ty, methInst) = - { mspecMethodRef=mref - mspecDeclaringType=ty - mspecMethodInst=methInst } + { + mspecMethodRef = mref + mspecDeclaringType = ty + mspecMethodInst = methInst + } let mkILMethSpec (mref, vc, tinst, methInst) = mkILMethSpecForMethRefInTy (mref, mkILNamedTy vc mref.DeclaringTypeRef tinst, methInst) let mkILMethSpecInTypeRef (tref, vc, cc, nm, argTys, retTy, tinst, methInst) = - mkILMethSpec (mkILMethRef ( tref, cc, nm, List.length methInst, argTys, retTy), vc, tinst, methInst) + mkILMethSpec (mkILMethRef (tref, cc, nm, List.length methInst, argTys, retTy), vc, tinst, methInst) let mkILMethSpecInTy (ty: ILType, cc, nm, argTys, retTy, methInst: ILGenericArgs) = mkILMethSpecForMethRefInTy (mkILMethRef (ty.TypeRef, cc, nm, methInst.Length, argTys, retTy), ty, methInst) @@ -2502,34 +3132,40 @@ let mkILCtorMethSpec (tref, argTys, tinst) = mkILMethSpecInTypeRef (tref, AsObject, ILCallingConv.Instance, ".ctor", argTys, ILType.Void, tinst, []) let mkILCtorMethSpecForTy (ty, args) = - mkILMethSpecInTy (ty, ILCallingConv.Instance, ".ctor", args, ILType.Void, []) + mkILMethSpecInTy (ty, ILCallingConv.Instance, ".ctor", args, ILType.Void, []) -let mkILNonGenericCtorMethSpec (tref, args) = - mkILCtorMethSpec (tref, args, []) +let mkILNonGenericCtorMethSpec (tref, args) = mkILCtorMethSpec (tref, args, []) // -------------------------------------------------------------------- // Make references to fields // -------------------------------------------------------------------- -let mkILFieldRef (tref, nm, ty) = { DeclaringTypeRef=tref; Name=nm; Type=ty} +let mkILFieldRef (tref, nm, ty) = + { + DeclaringTypeRef = tref + Name = nm + Type = ty + } -let mkILFieldSpec (tref, ty) = { FieldRef= tref; DeclaringType=ty } +let mkILFieldSpec (tref, ty) = { FieldRef = tref; DeclaringType = ty } let mkILFieldSpecInTy (ty: ILType, nm, fty) = mkILFieldSpec (mkILFieldRef (ty.TypeRef, nm, fty), ty) let andTailness x y = - match x with Tailcall when y -> Tailcall | _ -> Normalcall + match x with + | Tailcall when y -> Tailcall + | _ -> Normalcall // -------------------------------------------------------------------- // Basic operations on code. // -------------------------------------------------------------------- -let formatCodeLabel (x: int) = "L"+string x +let formatCodeLabel (x: int) = "L" + string x // ++GLOBAL MUTABLE STATE (concurrency safe) let codeLabelCount = ref 0 -let generateCodeLabel() = Interlocked.Increment codeLabelCount +let generateCodeLabel () = Interlocked.Increment codeLabelCount let instrIsRet i = match i with @@ -2538,15 +3174,19 @@ let instrIsRet i = let nonBranchingInstrsToCode instrs : ILCode = let instrs = Array.ofList instrs - let instrs = - if instrs.Length <> 0 && instrIsRet (Array.last instrs) then instrs - else Array.append instrs [| I_ret |] - { Labels = Dictionary() - Instrs = instrs - Exceptions = [] - Locals = [] } + let instrs = + if instrs.Length <> 0 && instrIsRet (Array.last instrs) then + instrs + else + Array.append instrs [| I_ret |] + { + Labels = Dictionary() + Instrs = instrs + Exceptions = [] + Locals = [] + } // -------------------------------------------------------------------- // @@ -2555,14 +3195,16 @@ let nonBranchingInstrsToCode instrs : ILCode = let mkILTyvarTy tv = ILType.TypeVar tv let mkILSimpleTypar nm = - { Name=nm - Constraints = [] - Variance=NonVariant - HasReferenceTypeConstraint=false - HasNotNullableValueTypeConstraint=false - HasDefaultConstructorConstraint=false - CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs - MetadataIndex = NoMetadataIdx } + { + Name = nm + Constraints = [] + Variance = NonVariant + HasReferenceTypeConstraint = false + HasNotNullableValueTypeConstraint = false + HasDefaultConstructorConstraint = false + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx + } let genericParamOfGenericActual (_ga: ILType) = mkILSimpleTypar "T" @@ -2571,9 +3213,11 @@ let mkILFormalTypars (x: ILGenericArgsList) = List.map genericParamOfGenericActu let mkILFormalGenericArgs numtypars (gparams: ILGenericParameterDefs) = List.mapi (fun n _gf -> mkILTyvarTy (uint16 (numtypars + n))) gparams -let mkILFormalBoxedTy tref gparams = mkILBoxedTy tref (mkILFormalGenericArgs 0 gparams) +let mkILFormalBoxedTy tref gparams = + mkILBoxedTy tref (mkILFormalGenericArgs 0 gparams) -let mkILFormalNamedTy bx tref gparams = mkILNamedTy bx tref (mkILFormalGenericArgs 0 gparams) +let mkILFormalNamedTy bx tref gparams = + mkILNamedTy bx tref (mkILFormalGenericArgs 0 gparams) // -------------------------------------------------------------------- // Operations on class etc. defs. @@ -2588,30 +3232,38 @@ let mkRefForNestedILTypeDef scope (enc: ILTypeDef list, td: ILTypeDef) = let mkILPreTypeDef (td: ILTypeDef) = let ns, n = splitILTypeName td.Name - ILPreTypeDefImpl (ns, n, NoMetadataIdx, ILTypeDefStored.Given td) :> ILPreTypeDef + ILPreTypeDefImpl(ns, n, NoMetadataIdx, ILTypeDefStored.Given td) :> ILPreTypeDef + let mkILPreTypeDefComputed (ns, n, f) = - ILPreTypeDefImpl (ns, n, NoMetadataIdx, ILTypeDefStored.Computed f) :> ILPreTypeDef + ILPreTypeDefImpl(ns, n, NoMetadataIdx, ILTypeDefStored.Computed f) :> ILPreTypeDef + let mkILPreTypeDefRead (ns, n, idx, f) = - ILPreTypeDefImpl (ns, n, idx, f) :> ILPreTypeDef + ILPreTypeDefImpl(ns, n, idx, f) :> ILPreTypeDef +let addILTypeDef td (tdefs: ILTypeDefs) = + ILTypeDefs(fun () -> [| yield mkILPreTypeDef td; yield! tdefs.AsArrayOfPreTypeDefs() |]) + +let mkILTypeDefsFromArray (l: ILTypeDef[]) = + ILTypeDefs(fun () -> Array.map mkILPreTypeDef 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 [| |] +let emptyILTypeDefs = mkILTypeDefsFromArray [||] // -------------------------------------------------------------------- // Operations on method tables. // -------------------------------------------------------------------- -let mkILMethodsFromArray xs = ILMethodDefs (fun () -> xs) -let mkILMethods xs = xs |> Array.ofList |> mkILMethodsFromArray +let mkILMethodsFromArray xs = ILMethodDefs(fun () -> xs) + +let mkILMethods xs = + xs |> Array.ofList |> mkILMethodsFromArray + let mkILMethodsComputed f = ILMethodDefs f -let emptyILMethods = mkILMethodsFromArray [| |] +let emptyILMethods = mkILMethodsFromArray [||] let filterILMethodDefs f (mdefs: ILMethodDefs) = - ILMethodDefs (fun () -> mdefs.AsArray() |> Array.filter f) + ILMethodDefs(fun () -> mdefs.AsArray() |> Array.filter f) // -------------------------------------------------------------------- // Operations and defaults for modules, assemblies etc. @@ -2619,18 +3271,26 @@ let filterILMethodDefs f (mdefs: ILMethodDefs) = let defaultSubSystem = 3 (* this is what comes out of ILDASM on 30/04/2001 *) let defaultPhysAlignment = 512 (* this is what comes out of ILDASM on 30/04/2001 *) -let defaultVirtAlignment = 0x2000 (* this is what comes out of ILDASM on 30/04/2001 *) -let defaultImageBase = 0x034f0000 (* this is what comes out of ILDASM on 30/04/2001 *) + +let defaultVirtAlignment = + 0x2000 (* this is what comes out of ILDASM on 30/04/2001 *) + +let defaultImageBase = + 0x034f0000 (* this is what comes out of ILDASM on 30/04/2001 *) // -------------------------------------------------------------------- // Array types // -------------------------------------------------------------------- -let mkILArrTy (ty, shape) = ILType.Array (shape, ty) +let mkILArrTy (ty, shape) = ILType.Array(shape, ty) -let mkILArr1DTy ty = mkILArrTy (ty, ILArrayShape.SingleDimensional) +let mkILArr1DTy ty = + mkILArrTy (ty, ILArrayShape.SingleDimensional) -let isILArrTy ty = match ty with ILType.Array _ -> true| _ -> false +let isILArrTy ty = + match ty with + | ILType.Array _ -> true + | _ -> false let destILArrTy ty = match ty with @@ -2699,45 +3359,71 @@ let tname_UIntPtr = "System.UIntPtr" let tname_TypedReference = "System.TypedReference" [] -type ILGlobals(primaryScopeRef: ILScopeRef, assembliesThatForwardToPrimaryAssembly: ILAssemblyRef list, fsharpCoreAssemblyScopeRef: ILScopeRef) = +type ILGlobals + ( + primaryScopeRef: ILScopeRef, + assembliesThatForwardToPrimaryAssembly: ILAssemblyRef list, + fsharpCoreAssemblyScopeRef: ILScopeRef + ) = - let assembliesThatForwardToPrimaryAssembly = Array.ofList assembliesThatForwardToPrimaryAssembly + let assembliesThatForwardToPrimaryAssembly = + Array.ofList assembliesThatForwardToPrimaryAssembly let mkSysILTypeRef nm = mkILTyRef (primaryScopeRef, nm) member _.primaryAssemblyScopeRef = primaryScopeRef + member x.primaryAssemblyRef = match primaryScopeRef with | ILScopeRef.Assembly aref -> aref | _ -> failwith "Invalid primary assembly" + member x.primaryAssemblyName = x.primaryAssemblyRef.Name member val typ_Object = mkILBoxedType (mkILNonGenericTySpec (mkSysILTypeRef tname_Object)) + member val typ_String = mkILBoxedType (mkILNonGenericTySpec (mkSysILTypeRef tname_String)) + member val typ_Array = mkILBoxedType (mkILNonGenericTySpec (mkSysILTypeRef tname_Array)) + member val typ_Type = mkILBoxedType (mkILNonGenericTySpec (mkSysILTypeRef tname_Type)) - member val typ_SByte = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_SByte)) - member val typ_Int16 = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_Int16)) - member val typ_Int32 = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_Int32)) - member val typ_Int64 = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_Int64)) - member val typ_Byte = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_Byte)) - member val typ_UInt16 = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_UInt16)) - member val typ_UInt32 = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_UInt32)) - member val typ_UInt64 = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_UInt64)) - member val typ_Single = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_Single)) - member val typ_Double = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_Double)) - member val typ_Bool = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_Bool)) - member val typ_Char = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_Char)) - member val typ_IntPtr = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_IntPtr)) - member val typ_UIntPtr = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_UIntPtr)) - member val typ_TypedReference = ILType.Value (mkILNonGenericTySpec (mkSysILTypeRef tname_TypedReference)) + + member val typ_SByte = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_SByte)) + + member val typ_Int16 = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_Int16)) + + member val typ_Int32 = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_Int32)) + + member val typ_Int64 = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_Int64)) + + member val typ_Byte = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_Byte)) + + member val typ_UInt16 = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_UInt16)) + + member val typ_UInt32 = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_UInt32)) + + member val typ_UInt64 = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_UInt64)) + + member val typ_Single = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_Single)) + + member val typ_Double = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_Double)) + + member val typ_Bool = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_Bool)) + + member val typ_Char = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_Char)) + + member val typ_IntPtr = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_IntPtr)) + + member val typ_UIntPtr = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_UIntPtr)) + + member val typ_TypedReference = ILType.Value(mkILNonGenericTySpec (mkSysILTypeRef tname_TypedReference)) member _.fsharpCoreAssemblyScopeRef = fsharpCoreAssemblyScopeRef member x.IsPossiblePrimaryAssemblyRef(aref: ILAssemblyRef) = - aref.EqualsIgnoringVersion x.primaryAssemblyRef || - assembliesThatForwardToPrimaryAssembly - |> Array.exists aref.EqualsIgnoringVersion + aref.EqualsIgnoringVersion x.primaryAssemblyRef + || assembliesThatForwardToPrimaryAssembly + |> Array.exists aref.EqualsIgnoringVersion /// For debugging [] @@ -2745,15 +3431,17 @@ type ILGlobals(primaryScopeRef: ILScopeRef, assembliesThatForwardToPrimaryAssemb override x.ToString() = "" -let mkILGlobals (primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef) = ILGlobals (primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef) +let mkILGlobals (primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef) = + ILGlobals(primaryScopeRef, assembliesThatForwardToPrimaryAssembly, fsharpCoreAssemblyScopeRef) -let mkNormalCall mspec = I_call (Normalcall, mspec, None) +let mkNormalCall mspec = I_call(Normalcall, mspec, None) -let mkNormalCallvirt mspec = I_callvirt (Normalcall, mspec, None) +let mkNormalCallvirt mspec = I_callvirt(Normalcall, mspec, None) -let mkNormalCallconstraint (ty, mspec) = I_callconstraint (Normalcall, ty, mspec, None) +let mkNormalCallconstraint (ty, mspec) = + I_callconstraint(Normalcall, ty, mspec, None) -let mkNormalNewobj mspec = I_newobj (mspec, None) +let mkNormalNewobj mspec = I_newobj(mspec, None) /// Comment on common object cache sizes: /// mkLdArg - I can't imagine any IL method we generate needing more than this @@ -2761,49 +3449,74 @@ let mkNormalNewobj mspec = I_newobj (mspec, None) /// mkStLoc - it should be the same as LdLoc (where there's a LdLoc there must be a StLoc) /// mkLdcInt32 - just a guess -let ldargs = [| for i in 0 .. 128 -> I_ldarg (uint16 i) |] +let ldargs = [| for i in 0..128 -> I_ldarg(uint16 i) |] -let mkLdarg i = if 0us < i && i < uint16 ldargs.Length then ldargs[int i] else I_ldarg i +let mkLdarg i = + if 0us < i && i < uint16 ldargs.Length then + ldargs[int i] + else + I_ldarg i let mkLdarg0 = mkLdarg 0us -let ldlocs = [| for i in 0 .. 512 -> I_ldloc (uint16 i) |] +let ldlocs = [| for i in 0..512 -> I_ldloc(uint16 i) |] -let mkLdloc i = if 0us < i && i < uint16 ldlocs.Length then ldlocs[int i] else I_ldloc i +let mkLdloc i = + if 0us < i && i < uint16 ldlocs.Length then + ldlocs[int i] + else + I_ldloc i -let stlocs = [| for i in 0 .. 512 -> I_stloc (uint16 i) |] +let stlocs = [| for i in 0..512 -> I_stloc(uint16 i) |] -let mkStloc i = if 0us < i && i < uint16 stlocs.Length then stlocs[int i] else I_stloc i +let mkStloc i = + if 0us < i && i < uint16 stlocs.Length then + stlocs[int i] + else + I_stloc i -let ldi32s = [| for i in 0 .. 256 -> AI_ldc (DT_I4, ILConst.I4 i) |] +let ldi32s = [| for i in 0..256 -> AI_ldc(DT_I4, ILConst.I4 i) |] -let mkLdcInt32 i = if 0 < i && i < ldi32s.Length then ldi32s[i] else AI_ldc (DT_I4, ILConst.I4 i) +let mkLdcInt32 i = + if 0 < i && i < ldi32s.Length then + ldi32s[i] + else + AI_ldc(DT_I4, ILConst.I4 i) -let tname_CompilerGeneratedAttribute = "System.Runtime.CompilerServices.CompilerGeneratedAttribute" +let tname_CompilerGeneratedAttribute = + "System.Runtime.CompilerServices.CompilerGeneratedAttribute" let tname_DebuggableAttribute = "System.Diagnostics.DebuggableAttribute" (* NOTE: ecma_ prefix refers to the standard "mscorlib" *) -let ecmaPublicKey = PublicKeyToken (Bytes.ofInt32Array [|0xde; 0xad; 0xbe; 0xef; 0xca; 0xfe; 0xfa; 0xce |]) +let ecmaPublicKey = + PublicKeyToken(Bytes.ofInt32Array [| 0xde; 0xad; 0xbe; 0xef; 0xca; 0xfe; 0xfa; 0xce |]) -let isILBoxedTy = function ILType.Boxed _ -> true | _ -> false +let isILBoxedTy = + function + | ILType.Boxed _ -> true + | _ -> false -let isILValueTy = function ILType.Value _ -> true | _ -> false +let isILValueTy = + function + | ILType.Value _ -> true + | _ -> false let rec stripILModifiedFromTy (ty: ILType) = match ty with - | ILType.Modified(_, _, ty) -> stripILModifiedFromTy ty + | ILType.Modified (_, _, ty) -> stripILModifiedFromTy ty | _ -> ty let isBuiltInTySpec (ilg: ILGlobals) (tspec: ILTypeSpec) n = let tref = tspec.TypeRef let scoref = tref.Scope - tref.Name = n && - (match scoref with - | ILScopeRef.Local - | ILScopeRef.Module _ -> false - | ILScopeRef.Assembly aref -> ilg.IsPossiblePrimaryAssemblyRef aref - | ILScopeRef.PrimaryAssembly -> true) + + tref.Name = n + && (match scoref with + | ILScopeRef.Local + | ILScopeRef.Module _ -> false + | ILScopeRef.Assembly aref -> ilg.IsPossiblePrimaryAssemblyRef aref + | ILScopeRef.PrimaryAssembly -> true) let isILBoxedBuiltInTy ilg (ty: ILType) n = isILBoxedTy ty && isBuiltInTySpec ilg ty.TypeSpec n @@ -2815,7 +3528,8 @@ let isILObjectTy ilg ty = isILBoxedBuiltInTy ilg ty tname_Object let isILStringTy ilg ty = isILBoxedBuiltInTy ilg ty tname_String -let isILTypedReferenceTy ilg ty = isILValueBuiltInTy ilg ty tname_TypedReference +let isILTypedReferenceTy ilg ty = + isILValueBuiltInTy ilg ty tname_TypedReference let isILSByteTy ilg ty = isILValueBuiltInTy ilg ty tname_SByte @@ -2860,8 +3574,11 @@ let rescopeILScopeRef scoref scoref1 = let rescopeILTypeRef scoref (tref1: ILTypeRef) = let scoref1 = tref1.Scope let scoref2 = rescopeILScopeRef scoref scoref1 - if scoref1 === scoref2 then tref1 - else ILTypeRef.Create (scoref2, tref1.Enclosing, tref1.Name) + + if scoref1 === scoref2 then + tref1 + else + ILTypeRef.Create(scoref2, tref1.Enclosing, tref1.Name) // ORIGINAL IMPLEMENTATION (too many allocations // { tspecTypeRef=rescopeILTypeRef scoref tref @@ -2873,75 +3590,97 @@ let rec rescopeILTypeSpec scoref (tspec1: ILTypeSpec) = // avoid reallocation in the common case if tref1 === tref2 then - if isNil tinst1 then tspec1 else - let tinst2 = rescopeILTypes scoref tinst1 - if tinst1 === tinst2 then tspec1 else - ILTypeSpec.Create (tref2, tinst2) + if isNil tinst1 then + tspec1 + else + let tinst2 = rescopeILTypes scoref tinst1 + + if tinst1 === tinst2 then + tspec1 + else + ILTypeSpec.Create(tref2, tinst2) else let tinst2 = rescopeILTypes scoref tinst1 - ILTypeSpec.Create (tref2, tinst2) + ILTypeSpec.Create(tref2, tinst2) and rescopeILType scoref ty = match ty with - | ILType.Ptr t -> ILType.Ptr (rescopeILType scoref t) - | ILType.FunctionPointer t -> ILType.FunctionPointer (rescopeILCallSig scoref t) - | ILType.Byref t -> ILType.Byref (rescopeILType scoref t) + | ILType.Ptr t -> ILType.Ptr(rescopeILType scoref t) + | ILType.FunctionPointer t -> ILType.FunctionPointer(rescopeILCallSig scoref t) + | ILType.Byref t -> ILType.Byref(rescopeILType scoref t) | ILType.Boxed cr1 -> let cr2 = rescopeILTypeSpec scoref cr1 - if cr1 === cr2 then ty else - mkILBoxedType cr2 + + if cr1 === cr2 then + ty + else + mkILBoxedType cr2 | ILType.Array (s, ety1) -> let ety2 = rescopeILType scoref ety1 - if ety1 === ety2 then ty else - ILType.Array (s, ety2) + + if ety1 === ety2 then + ty + else + ILType.Array(s, ety2) | ILType.Value cr1 -> let cr2 = rescopeILTypeSpec scoref cr1 - if cr1 === cr2 then ty else - ILType.Value cr2 - | ILType.Modified (b, tref, ty) -> ILType.Modified (b, rescopeILTypeRef scoref tref, rescopeILType scoref ty) + + if cr1 === cr2 then + ty + else + ILType.Value cr2 + | ILType.Modified (b, tref, ty) -> ILType.Modified(b, rescopeILTypeRef scoref tref, rescopeILType scoref ty) | x -> x and rescopeILTypes scoref i = - if isNil i then i - else List.mapq (rescopeILType scoref) i + if isNil i then + i + else + List.mapq (rescopeILType scoref) i and rescopeILCallSig scoref csig = mkILCallSig (csig.CallingConv, rescopeILTypes scoref csig.ArgTypes, rescopeILType scoref csig.ReturnType) let rescopeILMethodRef scoref (x: ILMethodRef) = - { mrefParent = rescopeILTypeRef scoref x.DeclaringTypeRef - mrefCallconv = x.mrefCallconv - mrefGenericArity=x.mrefGenericArity - mrefName=x.mrefName - mrefArgs = rescopeILTypes scoref x.mrefArgs - mrefReturn= rescopeILType scoref x.mrefReturn } + { + mrefParent = rescopeILTypeRef scoref x.DeclaringTypeRef + mrefCallconv = x.mrefCallconv + mrefGenericArity = x.mrefGenericArity + mrefName = x.mrefName + mrefArgs = rescopeILTypes scoref x.mrefArgs + mrefReturn = rescopeILType scoref x.mrefReturn + } let rescopeILFieldRef scoref x = - { DeclaringTypeRef = rescopeILTypeRef scoref x.DeclaringTypeRef - Name= x.Name - Type= rescopeILType scoref x.Type } + { + DeclaringTypeRef = rescopeILTypeRef scoref x.DeclaringTypeRef + Name = x.Name + Type = rescopeILType scoref x.Type + } // -------------------------------------------------------------------- // Instantiate polymorphism in types // -------------------------------------------------------------------- let rec instILTypeSpecAux numFree inst (tspec: ILTypeSpec) = - ILTypeSpec.Create (tspec.TypeRef, instILGenericArgsAux numFree inst tspec.GenericArgs) + ILTypeSpec.Create(tspec.TypeRef, instILGenericArgsAux numFree inst tspec.GenericArgs) and instILTypeAux numFree (inst: ILGenericArgs) ty = match ty with - | ILType.Ptr t -> ILType.Ptr (instILTypeAux numFree inst t) - | ILType.FunctionPointer t -> ILType.FunctionPointer (instILCallSigAux numFree inst t) - | ILType.Array (a, t) -> ILType.Array (a, instILTypeAux numFree inst t) - | ILType.Byref t -> ILType.Byref (instILTypeAux numFree inst t) + | ILType.Ptr t -> ILType.Ptr(instILTypeAux numFree inst t) + | ILType.FunctionPointer t -> ILType.FunctionPointer(instILCallSigAux numFree inst t) + | ILType.Array (a, t) -> ILType.Array(a, instILTypeAux numFree inst t) + | ILType.Byref t -> ILType.Byref(instILTypeAux numFree inst t) | ILType.Boxed cr -> mkILBoxedType (instILTypeSpecAux numFree inst cr) - | ILType.Value cr -> ILType.Value (instILTypeSpecAux numFree inst cr) + | ILType.Value cr -> ILType.Value(instILTypeSpecAux numFree inst cr) | ILType.TypeVar v -> let v = int v let top = inst.Length - if v < numFree then ty else - if v - numFree >= top then - ILType.TypeVar (uint16 (v - top)) + + if v < numFree then + ty + else if v - numFree >= top then + ILType.TypeVar(uint16 (v - top)) else List.item (v - numFree) inst | x -> x @@ -2949,7 +3688,7 @@ and instILTypeAux numFree (inst: ILGenericArgs) ty = and instILGenericArgsAux numFree inst i = List.map (instILTypeAux numFree inst) i and instILCallSigAux numFree inst csig = - mkILCallSig (csig.CallingConv, List.map (instILTypeAux numFree inst) csig.ArgTypes, instILTypeAux numFree inst csig.ReturnType) + mkILCallSig (csig.CallingConv, List.map (instILTypeAux numFree inst) csig.ArgTypes, instILTypeAux numFree inst csig.ReturnType) let instILType i t = instILTypeAux 0 i t @@ -2958,32 +3697,39 @@ 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 - CustomAttrsStored=storeILCustomAttrs emptyILCustomAttrs - MetadataIndex = NoMetadataIdx } + { + 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 - CustomAttrsStored=storeILCustomAttrs emptyILCustomAttrs - MetadataIndex = NoMetadataIdx } + { + Marshal = None + Type = ty + CustomAttrsStored = storeILCustomAttrs emptyILCustomAttrs + MetadataIndex = NoMetadataIdx + } let mkILLocal ty dbgInfo : ILLocal = - { IsPinned=false - Type=ty - DebugInfo=dbgInfo } + { + IsPinned = false + Type = ty + DebugInfo = dbgInfo + } type ILFieldSpec with + member fr.ActualType = let env = fr.DeclaringType.GenericArgs instILType env fr.FormalType @@ -2993,18 +3739,20 @@ type ILFieldSpec with // -------------------------------------------------------------------- let mkILMethodBody (initlocals, locals, maxstack, code, tag, imports) : ILMethodBody = - { IsZeroInit=initlocals - MaxStack=maxstack - NoInlining=false - AggressiveInlining=false - Locals= locals - Code= code - DebugRange=tag - DebugImports=imports } + { + IsZeroInit = initlocals + MaxStack = maxstack + NoInlining = false + AggressiveInlining = false + Locals = locals + Code = code + DebugRange = tag + DebugImports = imports + } let mkMethodBody (zeroinit, locals, maxstack, code, tag, imports) = let ilCode = mkILMethodBody (zeroinit, locals, maxstack, code, tag, imports) - MethodBody.IL (lazy ilCode) + MethodBody.IL(lazy ilCode) // -------------------------------------------------------------------- // Make a constructor @@ -3019,40 +3767,45 @@ let methBodyAbstract = notlazy MethodBody.Abstract let methBodyNative = notlazy MethodBody.Native let mkILCtor (access, args, impl) = - ILMethodDef(name=".ctor", - attributes=(convertMemberAccess access ||| MethodAttributes.SpecialName ||| MethodAttributes.RTSpecialName), - implAttributes=MethodImplAttributes.Managed, - callingConv=ILCallingConv.Instance, - parameters = args, - ret= mkILVoidReturn, - body= notlazy 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 = notlazy impl, + securityDecls = emptyILSecurityDecls, + isEntryPoint = false, + genericParams = mkILEmptyGenericParams, + customAttrs = emptyILCustomAttrs + ) // -------------------------------------------------------------------- // Do-nothing ctor, just pass on to monomorphic superclass // -------------------------------------------------------------------- let mkCallBaseConstructor (ty, args: ILType list) = - [ mkLdarg0 ] @ - List.mapi (fun i _ -> mkLdarg (uint16 (i+1))) args @ - [ mkNormalCall (mkILCtorMethSpecForTy (ty, [])) ] + [ mkLdarg0 ] + @ List.mapi (fun i _ -> mkLdarg (uint16 (i + 1))) args + @ [ mkNormalCall (mkILCtorMethSpecForTy (ty, [])) ] -let mkNormalStfld fspec = I_stfld (Aligned, Nonvolatile, fspec) +let mkNormalStfld fspec = I_stfld(Aligned, Nonvolatile, fspec) -let mkNormalStsfld fspec = I_stsfld (Nonvolatile, fspec) +let mkNormalStsfld fspec = I_stsfld(Nonvolatile, fspec) -let mkNormalLdsfld fspec = I_ldsfld (Nonvolatile, fspec) +let mkNormalLdsfld fspec = I_ldsfld(Nonvolatile, fspec) -let mkNormalLdfld fspec = I_ldfld (Aligned, Nonvolatile, fspec) +let mkNormalLdfld fspec = I_ldfld(Aligned, Nonvolatile, fspec) let mkNormalLdflda fspec = I_ldflda fspec -let mkNormalLdobj dt = I_ldobj (Aligned, Nonvolatile, dt) +let mkNormalLdobj dt = I_ldobj(Aligned, Nonvolatile, dt) -let mkNormalStobj dt = I_stobj (Aligned, Nonvolatile, dt) +let mkNormalStobj dt = I_stobj(Aligned, Nonvolatile, dt) let mkILNonGenericEmptyCtor (superTy, tag, imports) = let ctor = mkCallBaseConstructor (superTy, []) @@ -3065,33 +3818,41 @@ let mkILNonGenericEmptyCtor (superTy, tag, imports) = // -------------------------------------------------------------------- let mkILStaticMethod (genparams, nm, access, args, ret, 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= notlazy 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 = notlazy impl + ) let mkILNonGenericStaticMethod (nm, access, args, ret, impl) = mkILStaticMethod (mkILEmptyGenericParams, nm, access, args, ret, impl) let mkILClassCtor 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= notlazy 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 = notlazy impl + ) // -------------------------------------------------------------------- // Make a virtual method, where the overriding is simply the default @@ -3099,80 +3860,104 @@ let mkILClassCtor impl = // -------------------------------------------------------------------- let mk_ospec (ty: ILType, callconv, nm, genparams, formal_args, formal_ret) = - OverridesSpec (mkILMethRef (ty.TypeRef, callconv, nm, genparams, formal_args, formal_ret), ty) + OverridesSpec(mkILMethRef (ty.TypeRef, callconv, nm, genparams, formal_args, formal_ret), ty) let mkILGenericVirtualMethod (nm, access, genparams, actual_args, actual_ret, 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= notlazy 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 = notlazy impl + ) let mkILNonGenericVirtualMethod (nm, access, args, ret, impl) = mkILGenericVirtualMethod (nm, access, mkILEmptyGenericParams, args, ret, impl) let mkILGenericNonVirtualMethod (nm, access, genparams, actual_args, actual_ret, 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= notlazy 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 = notlazy impl + ) let mkILNonGenericInstanceMethod (nm, access, args, ret, impl) = - mkILGenericNonVirtualMethod (nm, access, mkILEmptyGenericParams, args, ret, impl) - + mkILGenericNonVirtualMethod (nm, access, mkILEmptyGenericParams, args, ret, impl) // -------------------------------------------------------------------- // Add some code to the end of the .cctor for a type. Create a .cctor // if one doesn't exist already. // -------------------------------------------------------------------- -let ilmbody_code2code f (il: ILMethodBody) = - {il with Code = f il.Code} +let ilmbody_code2code f (il: ILMethodBody) = { il with Code = f il.Code } let mdef_code2code f (md: ILMethodDef) = let il = match md.Body with - | MethodBody.IL il-> il + | MethodBody.IL il -> il | _ -> failwith "mdef_code2code - method not IL" + let ilCode = ilmbody_code2code f il.Value - let b = MethodBody.IL (notlazy ilCode) + let b = MethodBody.IL(notlazy ilCode) md.With(body = notlazy b) let prependInstrsToCode (instrs: ILInstr list) (c2: ILCode) = let instrs = Array.ofList instrs let n = instrs.Length + match c2.Instrs[0] with // If there is a sequence point as the first instruction then keep it at the front | I_seqpoint _ as i0 -> let labels = let dict = Dictionary.newWithSize c2.Labels.Count - for kvp in c2.Labels do dict.Add (kvp.Key, if kvp.Value = 0 then 0 else kvp.Value + n) + + for kvp in c2.Labels do + dict.Add( + kvp.Key, + if kvp.Value = 0 then + 0 + else + kvp.Value + n + ) + dict - { c2 with Labels = labels - Instrs = Array.concat [| [|i0|] ; instrs ; c2.Instrs[1..] |] } + + { c2 with + Labels = labels + Instrs = Array.concat [| [| i0 |]; instrs; c2.Instrs[1..] |] + } | _ -> let labels = let dict = Dictionary.newWithSize c2.Labels.Count - for kvp in c2.Labels do dict.Add (kvp.Key, kvp.Value + n) + + for kvp in c2.Labels do + dict.Add(kvp.Key, kvp.Value + n) + dict - { c2 with Labels = labels - Instrs = Array.append instrs c2.Instrs } + + { c2 with + Labels = labels + Instrs = Array.append instrs c2.Instrs + } let prependInstrsToMethod newCode md = mdef_code2code (prependInstrsToCode newCode) md @@ -3180,17 +3965,24 @@ let prependInstrsToMethod newCode md = // Creates cctor if needed let cdef_cctorCode2CodeOrCreate tag imports f (cd: ILTypeDef) = let mdefs = cd.Methods + let cctor = match mdefs.FindByName ".cctor" with - | [mdef] -> mdef - | [] -> - let body = mkMethodBody (false, [], 1, nonBranchingInstrsToCode [ ], tag, imports) + | [ mdef ] -> mdef + | [] -> + let body = mkMethodBody (false, [], 1, nonBranchingInstrsToCode [], tag, imports) mkILClassCtor body | _ -> 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) + let methods = + ILMethodDefs(fun () -> + [| + yield f cctor + for md in mdefs do + if md.Name <> ".cctor" then yield md + |]) + cd.With(methods = methods) let codeOfMethodDef (md: ILMethodDef) = match md.Code with @@ -3200,43 +3992,64 @@ let codeOfMethodDef (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.FieldType) +let mkRefToILField (tref, fdef: ILFieldDef) = + mkILFieldRef (tref, fdef.Name, fdef.FieldType) -let mkRefForILMethod scope (tdefs, tdef) mdef = mkRefToILMethod (mkRefForNestedILTypeDef scope (tdefs, tdef), mdef) +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.FieldType) +let mkRefForILField scope (tdefs, tdef) (fdef: ILFieldDef) = + mkILFieldRef (mkRefForNestedILTypeDef scope (tdefs, tdef), fdef.Name, fdef.FieldType) // Creates cctor if needed let prependInstrsToClassCtor instrs tag imports cd = cdef_cctorCode2CodeOrCreate tag imports (prependInstrsToMethod instrs) cd -let mkILField (isStatic, nm, ty, init: ILFieldInit option, at: byte [] option, access, isLiteral) = - 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) - -let mkILLiteralField (nm, ty, init, at, access) = mkILField (true, nm, ty, Some init, at, access, true) +let mkILField (isStatic, nm, ty, init: ILFieldInit option, at: byte[] option, access, isLiteral) = + 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) + +let mkILLiteralField (nm, ty, init, at, access) = + mkILField (true, nm, ty, Some init, at, access, true) // -------------------------------------------------------------------- // Scopes for allocating new temporary variables. // -------------------------------------------------------------------- -type ILLocalsAllocator (preAlloc: int) = +type ILLocalsAllocator(preAlloc: int) = let newLocals = ResizeArray() + member tmps.AllocLocal loc = let locn = uint16 (preAlloc + newLocals.Count) newLocals.Add loc @@ -3244,19 +4057,22 @@ type ILLocalsAllocator (preAlloc: int) = member tmps.Close() = ResizeArray.toList newLocals -let mkILFieldsLazy l = ILFields (LazyOrderedMultiMap ((fun (fdef: ILFieldDef) -> fdef.Name), l)) +let mkILFieldsLazy l = + ILFields(LazyOrderedMultiMap((fun (fdef: ILFieldDef) -> fdef.Name), l)) let mkILFields l = mkILFieldsLazy (notlazy l) let emptyILFields = mkILFields [] -let mkILEventsLazy l = ILEvents (LazyOrderedMultiMap ((fun (edef: ILEventDef) -> edef.Name), l)) +let mkILEventsLazy l = + ILEvents(LazyOrderedMultiMap((fun (edef: ILEventDef) -> edef.Name), l)) let mkILEvents l = mkILEventsLazy (notlazy l) let emptyILEvents = mkILEvents [] -let mkILPropertiesLazy l = ILProperties (LazyOrderedMultiMap ((fun (pdef: ILPropertyDef) -> pdef.Name), l) ) +let mkILPropertiesLazy l = + ILProperties(LazyOrderedMultiMap((fun (pdef: ILPropertyDef) -> pdef.Name), l)) let mkILProperties l = mkILPropertiesLazy (notlazy l) @@ -3264,26 +4080,29 @@ let emptyILProperties = mkILProperties [] let addExportedTypeToTable (y: ILExportedTypeOrForwarder) tab = Map.add y.Name y tab -let mkILExportedTypes l = ILExportedTypesAndForwarders (notlazy (List.foldBack addExportedTypeToTable l Map.empty)) +let mkILExportedTypes l = + ILExportedTypesAndForwarders(notlazy (List.foldBack addExportedTypeToTable l Map.empty)) -let mkILExportedTypesLazy (l: Lazy<_>) = ILExportedTypesAndForwarders (lazy (List.foldBack addExportedTypeToTable (l.Force()) Map.empty)) +let mkILExportedTypesLazy (l: Lazy<_>) = + ILExportedTypesAndForwarders(lazy (List.foldBack addExportedTypeToTable (l.Force()) Map.empty)) -let addNestedExportedTypeToTable (y: ILNestedExportedType) tab = - Map.add y.Name y tab +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 - CustomAttrsStored=storeILCustomAttrs customAttrs - MetadataIndex = NoMetadataIdx } + { + 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)) + ILNestedExportedTypes(notlazy (List.foldBack addNestedExportedTypeToTable l Map.empty)) let mkILNestedExportedTypesLazy (l: Lazy<_>) = - ILNestedExportedTypes (lazy (List.foldBack addNestedExportedTypeToTable (l.Force()) Map.empty)) + ILNestedExportedTypes(lazy (List.foldBack addNestedExportedTypeToTable (l.Force()) Map.empty)) let mkILResources l = ILResources l let emptyILResources = ILResources [] @@ -3293,9 +4112,11 @@ let addMethodImplToTable y tab = let prev = Map.tryFindMulti key tab Map.add key (y :: prev) tab -let mkILMethodImpls l = ILMethodImpls (notlazy (List.foldBack addMethodImplToTable 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 mkILMethodImplsLazy l = + ILMethodImpls(lazy (List.foldBack addMethodImplToTable (Lazy.force l) Map.empty)) let emptyILMethodImpls = mkILMethodImpls [] @@ -3303,27 +4124,26 @@ let emptyILMethodImpls = mkILMethodImpls [] /// them in fields. preblock is how to call the superclass constructor.... let mkILStorageCtorWithParamNames (preblock: ILInstr list, ty, extraParams, flds, access, tag, imports) = let code = - [ match tag with - | Some x -> I_seqpoint x - | None -> () - yield! preblock - for (n, (_pnm, nm, fieldTy)) in List.indexed flds do - mkLdarg0 - mkLdarg (uint16 (n+1)) - mkNormalStfld (mkILFieldSpecInTy (ty, nm, fieldTy)) + [ + match tag with + | Some x -> I_seqpoint x + | None -> () + yield! preblock + for (n, (_pnm, nm, fieldTy)) in List.indexed flds do + mkLdarg0 + mkLdarg (uint16 (n + 1)) + mkNormalStfld (mkILFieldSpecInTy (ty, nm, fieldTy)) ] + let body = mkMethodBody (false, [], 2, nonBranchingInstrsToCode code, tag, imports) - mkILCtor(access, - (flds |> List.map (fun (pnm, _, ty) -> mkILParamNamed (pnm, ty))) @ extraParams, body - ) + mkILCtor (access, (flds |> List.map (fun (pnm, _, ty) -> mkILParamNamed (pnm, ty))) @ extraParams, body) let mkILSimpleStorageCtorWithParamNames (baseTySpec, ty, extraParams, flds, access, tag, imports) = let preblock = - match baseTySpec with - | None -> [] - | Some tspec -> - [ mkLdarg0 - mkNormalCall (mkILCtorMethSpecForTy (mkILBoxedType tspec, [])) ] + match baseTySpec with + | None -> [] + | Some tspec -> [ mkLdarg0; mkNormalCall (mkILCtorMethSpecForTy (mkILBoxedType tspec, [])) ] + mkILStorageCtorWithParamNames (preblock, ty, extraParams, flds, access, tag, imports) let addParamNames flds = @@ -3337,101 +4157,144 @@ let mkILStorageCtor (preblock, ty, flds, access, tag, imports) = let mkILGenericClass (nm, access, genparams, extends, impl, methods, fields, nestedTypes, props, events, attrs, init) = let attributes = - convertTypeAccessFlags access ||| - TypeAttributes.AutoLayout ||| - TypeAttributes.Class ||| - (match init with - | ILTypeInit.BeforeField -> TypeAttributes.BeforeFieldInit - | _ -> enum 0) + convertTypeAccessFlags access + ||| TypeAttributes.AutoLayout + ||| TypeAttributes.Class + ||| (match init with + | ILTypeInit.BeforeField -> TypeAttributes.BeforeFieldInit + | _ -> enum 0) ||| TypeAttributes.AnsiClass - ILTypeDef(name=nm, - attributes=attributes, - genericParams= genparams, + ILTypeDef( + name = nm, + attributes = attributes, + genericParams = genparams, implements = impl, - layout=ILTypeDefLayout.Auto, + layout = ILTypeDefLayout.Auto, extends = Some extends, - methods= methods, - fields= fields, - nestedTypes=nestedTypes, - customAttrs=attrs, - methodImpls=emptyILMethodImpls, - properties=props, - events=events, - isKnownToBeAttribute=false, - securityDecls=emptyILSecurityDecls) + methods = methods, + fields = fields, + nestedTypes = nestedTypes, + customAttrs = attrs, + methodImpls = emptyILMethodImpls, + properties = props, + events = events, + isKnownToBeAttribute = false, + securityDecls = emptyILSecurityDecls + ) let mkRawDataValueTypeDef (iltyp_ValueType: ILType) (nm, size, pack) = - 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, - isKnownToBeAttribute=false, - 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, + isKnownToBeAttribute = false, + securityDecls = emptyILSecurityDecls + ) let mkILSimpleClass (ilg: ILGlobals) (nm, access, methods, fields, nestedTypes, props, events, attrs, init) = - mkILGenericClass (nm, access, mkILEmptyGenericParams, ilg.typ_Object, [], methods, fields, nestedTypes, props, events, attrs, init) + mkILGenericClass (nm, access, mkILEmptyGenericParams, ilg.typ_Object, [], methods, fields, nestedTypes, props, events, attrs, init) let mkILTypeDefForGlobalFunctions ilg (methods, fields) = - mkILSimpleClass ilg (typeNameForGlobalFunctions, ILTypeDefAccess.Public, methods, fields, emptyILTypeDefs, emptyILProperties, emptyILEvents, emptyILCustomAttrs, ILTypeInit.BeforeField) + mkILSimpleClass + ilg + (typeNameForGlobalFunctions, + ILTypeDefAccess.Public, + methods, + fields, + emptyILTypeDefs, + emptyILProperties, + emptyILEvents, + emptyILCustomAttrs, + ILTypeInit.BeforeField) let destTypeDefsWithGlobalFunctionsFirst ilg (tdefs: ILTypeDefs) = - let l = tdefs.AsList() - let top, nontop = l |> List.partition (fun td -> td.Name = typeNameForGlobalFunctions) - let top2 = if isNil top then [ mkILTypeDefForGlobalFunctions ilg (emptyILMethods, emptyILFields) ] else top - top2@nontop + let l = tdefs.AsList() + + let top, nontop = + l |> List.partition (fun td -> td.Name = typeNameForGlobalFunctions) -let mkILSimpleModule assemblyName moduleName dll subsystemVersion useHighEntropyVA tdefs hashalg locale flags exportedTypes metadataVersion = + let top2 = + if isNil top then + [ mkILTypeDefForGlobalFunctions ilg (emptyILMethods, emptyILFields) ] + else + top + + top2 @ nontop + +let mkILSimpleModule + assemblyName + moduleName + dll + subsystemVersion + useHighEntropyVA + tdefs + hashalg + locale + flags + exportedTypes + metadataVersion + = let manifest = - { Name=assemblyName - 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=moduleName - 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 [] - MetadataIndex = NoMetadataIdx - } + { + Name = assemblyName + 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 = moduleName + 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 [] + MetadataIndex = NoMetadataIdx + } //----------------------------------------------------------------------- // [instructions_to_code] makes the basic block structure of code from @@ -3441,16 +4304,16 @@ let mkILSimpleModule assemblyName moduleName dll subsystemVersion useHighEntropy // [bbstartToCodeLabelMap]. //----------------------------------------------------------------------- - // REVIEW: this function shows up on performance traces. If we eliminated the last ILX->IL rewrites from the // F# compiler we could get rid of this structured code representation from Abstract IL altogether and // never convert F# code into this form. let buildILCode (_methName: string) lab2pc instrs tryspecs localspecs : ILCode = - { Labels = lab2pc - Instrs = instrs - Exceptions = tryspecs - Locals = localspecs } - + { + Labels = lab2pc + Instrs = instrs + Exceptions = tryspecs + Locals = localspecs + } // -------------------------------------------------------------------- // Detecting Delegates @@ -3458,45 +4321,95 @@ let buildILCode (_methName: string) lab2pc instrs tryspecs localspecs : ILCode = let mkILDelegateMethods access (ilg: ILGlobals) (iltyp_AsyncCallback, iltyp_IAsyncResult) (parms, rtv: ILReturn) = let retTy = rtv.Type + let one nm args ret = - let mdef = mkILNonGenericVirtualMethod (nm, access, args, mkILReturn ret, MethodBody.Abstract) + let mdef = + mkILNonGenericVirtualMethod (nm, access, args, mkILReturn ret, MethodBody.Abstract) + mdef.WithAbstract(false).WithHideBySig(true).WithRuntime(true) - let ctor = mkILCtor (access, [ mkILParamNamed("object", ilg.typ_Object); mkILParamNamed("method", ilg.typ_IntPtr) ], MethodBody.Abstract) + + let ctor = + mkILCtor ( + access, + [ + mkILParamNamed ("object", ilg.typ_Object) + mkILParamNamed ("method", ilg.typ_IntPtr) + ], + MethodBody.Abstract + ) + let ctor = ctor.WithRuntime(true).WithHideBySig(true) - [ ctor - one "Invoke" parms retTy - one "BeginInvoke" (parms @ [mkILParamNamed ("callback", iltyp_AsyncCallback); mkILParamNamed ("objects", ilg.typ_Object) ] ) iltyp_IAsyncResult - one "EndInvoke" [mkILParamNamed ("result", iltyp_IAsyncResult)] retTy ] + [ + ctor + one "Invoke" parms retTy + one + "BeginInvoke" + (parms + @ [ + mkILParamNamed ("callback", iltyp_AsyncCallback) + mkILParamNamed ("objects", ilg.typ_Object) + ]) + iltyp_IAsyncResult + one "EndInvoke" [ mkILParamNamed ("result", iltyp_IAsyncResult) ] retTy + ] let mkCtorMethSpecForDelegate (ilg: ILGlobals) (ty: ILType, useUIntPtr) = let scoref = ty.TypeRef.Scope + let argTys = - [ rescopeILType scoref ilg.typ_Object - rescopeILType scoref (if useUIntPtr then ilg.typ_UIntPtr else ilg.typ_IntPtr) ] + [ + rescopeILType scoref ilg.typ_Object + rescopeILType + scoref + (if useUIntPtr then + ilg.typ_UIntPtr + else + ilg.typ_IntPtr) + ] + mkILInstanceMethSpecInTy (ty, ".ctor", argTys, ILType.Void, emptyILGenericArgsList) type ILEnumInfo = - { enumValues: (string * ILFieldInit) list - enumType: ILType } + { + enumValues: (string * ILFieldInit) list + enumType: ILType + } 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.FieldType - enumValues = staticFields |> List.map (fun fd -> (fd.Name, match fd.LiteralValue with Some i -> i | None -> failwith ("computeILEnumInfo: badly formed enum "+mdName+": static field does not have an default value"))) } - | _, [] -> failwith ("computeILEnumInfo: badly formed enum "+mdName+": no non-static field found") - | _, _ -> failwith ("computeILEnumInfo: badly formed enum "+mdName+": more than one non-static field found") + | staticFields, [ vfd ] -> + { + enumType = vfd.FieldType + enumValues = + staticFields + |> List.map (fun fd -> + (fd.Name, + match fd.LiteralValue with + | Some i -> i + | None -> + failwith ( + "computeILEnumInfo: badly formed enum " + + mdName + + ": static field does not have an default value" + ))) + } + | _, [] -> failwith ("computeILEnumInfo: badly formed enum " + mdName + ": no non-static field found") + | _, _ -> + failwith ( + "computeILEnumInfo: badly formed enum " + + mdName + + ": more than one non-static field found" + ) //--------------------------------------------------------------------- // Primitives to help read signatures. These do not use the file cursor, but // pass around an int index //--------------------------------------------------------------------- -let sigptr_get_byte bytes sigptr = - Bytes.get bytes sigptr, sigptr + 1 +let sigptr_get_byte bytes sigptr = Bytes.get bytes sigptr, sigptr + 1 let sigptr_get_bool bytes sigptr = let b0, sigptr = sigptr_get_byte bytes sigptr @@ -3539,15 +4452,23 @@ let sigptr_get_i64 bytes sigptr = let b5, sigptr = sigptr_get_byte bytes sigptr let b6, sigptr = sigptr_get_byte bytes sigptr let b7, sigptr = sigptr_get_byte bytes sigptr - int64 b0 ||| (int64 b1 <<< 8) ||| (int64 b2 <<< 16) ||| (int64 b3 <<< 24) ||| - (int64 b4 <<< 32) ||| (int64 b5 <<< 40) ||| (int64 b6 <<< 48) ||| (int64 b7 <<< 56), + + int64 b0 + ||| (int64 b1 <<< 8) + ||| (int64 b2 <<< 16) + ||| (int64 b3 <<< 24) + ||| (int64 b4 <<< 32) + ||| (int64 b5 <<< 40) + ||| (int64 b6 <<< 48) + ||| (int64 b7 <<< 56), sigptr let sigptr_get_u64 bytes sigptr = let u, sigptr = sigptr_get_i64 bytes sigptr uint64 u, sigptr -let float32OfBits (x: int32) = BitConverter.ToSingle (BitConverter.GetBytes x, 0) +let float32OfBits (x: int32) = + BitConverter.ToSingle(BitConverter.GetBytes x, 0) let floatOfBits (x: int64) = BitConverter.Int64BitsToDouble x @@ -3561,17 +4482,21 @@ let sigptr_get_ieee64 bytes sigptr = let sigptr_get_intarray n (bytes: byte[]) sigptr = let res = Bytes.zeroCreate n + for i = 0 to n - 1 do res[i] <- bytes[sigptr + i] + res, sigptr + n let sigptr_get_string n bytes sigptr = let intarray, sigptr = sigptr_get_intarray n bytes sigptr - Encoding.UTF8.GetString (intarray, 0, intarray.Length), sigptr + Encoding.UTF8.GetString(intarray, 0, intarray.Length), sigptr let sigptr_get_z_i32 bytes sigptr = let b0, sigptr = sigptr_get_byte bytes sigptr - if b0 <= 0x7F then b0, sigptr + + if b0 <= 0x7F then + b0, sigptr elif b0 <= 0xbf then let b0 = b0 &&& 0x7f let b1, sigptr = sigptr_get_byte bytes sigptr @@ -3589,9 +4514,10 @@ let sigptr_get_serstring bytes sigptr = let sigptr_get_serstring_possibly_null bytes sigptr = let b0, new_sigptr = sigptr_get_byte bytes sigptr + if b0 = 0xFF then // null case None, new_sigptr - else // throw away new_sigptr, getting length & text advance + else // throw away new_sigptr, getting length & text advance let len, sigptr = sigptr_get_z_i32 bytes sigptr let s, sigptr = sigptr_get_string len bytes sigptr Some s, sigptr @@ -3601,7 +4527,16 @@ let sigptr_get_serstring_possibly_null bytes sigptr = //--------------------------------------------------------------------- let mkRefToILAssembly (m: ILAssemblyManifest) = - ILAssemblyRef.Create (m.Name, None, (match m.PublicKey with Some k -> Some (PublicKey.KeyAsToken k) | None -> None), m.Retargetable, m.Version, m.Locale) + ILAssemblyRef.Create( + m.Name, + None, + (match m.PublicKey with + | Some k -> Some(PublicKey.KeyAsToken k) + | None -> None), + m.Retargetable, + m.Version, + m.Locale + ) let z_unsigned_int_size n = if n <= 0x7F then 1 @@ -3609,12 +4544,17 @@ let z_unsigned_int_size n = else 3 let z_unsigned_int n = - if n >= 0 && n <= 0x7F then [| byte n |] - elif n >= 0x80 && n <= 0x3FFF then [| byte (0x80 ||| (n >>>& 8)); byte (n &&& 0xFF) |] - else [| byte (0xc0 ||| (n >>>& 24)) + if n >= 0 && n <= 0x7F then + [| byte n |] + elif n >= 0x80 && n <= 0x3FFF then + [| byte (0x80 ||| (n >>>& 8)); byte (n &&& 0xFF) |] + else + [| + byte (0xc0 ||| (n >>>& 24)) byte ((n >>>& 16) &&& 0xFF) byte ((n >>>& 8) &&& 0xFF) - byte (n &&& 0xFF) |] + byte (n &&& 0xFF) + |] let string_as_utf8_bytes (s: string) = Encoding.UTF8.GetBytes s @@ -3637,11 +4577,14 @@ let dw0 n = byte (n &&& 0xFFL) let u8AsBytes (i: byte) = [| i |] -let u16AsBytes x = let n = (int x) in [| byte (b0 n); byte (b1 n) |] +let u16AsBytes x = + let n = (int x) in [| byte (b0 n); byte (b1 n) |] -let i32AsBytes i = [| byte (b0 i); byte (b1 i); byte (b2 i); byte (b3 i) |] +let i32AsBytes i = + [| byte (b0 i); byte (b1 i); byte (b2 i); byte (b3 i) |] -let i64AsBytes i = [| dw0 i; dw1 i; dw2 i; dw3 i; dw4 i; dw5 i; dw6 i; dw7 i |] +let i64AsBytes i = + [| dw0 i; dw1 i; dw2 i; dw3 i; dw4 i; dw5 i; dw6 i; dw7 i |] let i8AsBytes (i: sbyte) = u8AsBytes (byte i) @@ -3651,7 +4594,8 @@ let u32AsBytes (i: uint32) = i32AsBytes (int32 i) let u64AsBytes (i: uint64) = i64AsBytes (int64 i) -let bitsOfSingle (x: float32) = BitConverter.ToInt32 (BitConverter.GetBytes x, 0) +let bitsOfSingle (x: float32) = + BitConverter.ToInt32(BitConverter.GetBytes x, 0) let bitsOfDouble (x: float) = BitConverter.DoubleToInt64Bits x @@ -3691,7 +4635,8 @@ let et_MVAR = 0x1Euy let et_CMOD_REQD = 0x1Fuy let et_CMOD_OPT = 0x20uy -let formatILVersion (version: ILVersionInfo) = sprintf "%d.%d.%d.%d" (int version.Major) (int version.Minor) (int version.Build) (int version.Revision) +let formatILVersion (version: ILVersionInfo) = + sprintf "%d.%d.%d.%d" (int version.Major) (int version.Minor) (int version.Build) (int version.Revision) let encodeCustomAttrString s = let arr = string_as_utf8_bytes s @@ -3716,7 +4661,7 @@ let rec encodeCustomAttrElemType x = | ILType.Boxed tspec when tspec.Name = tname_Type -> [| 0x50uy |] | ILType.Value tspec -> Array.append [| 0x55uy |] (encodeCustomAttrString tspec.TypeRef.QualifiedName) | ILType.Array (shape, elemType) when shape = ILArrayShape.SingleDimensional -> - Array.append [| et_SZARRAY |] (encodeCustomAttrElemType elemType) + Array.append [| et_SZARRAY |] (encodeCustomAttrElemType elemType) | _ -> failwith "encodeCustomAttrElemType: unrecognized custom element type" /// Given a custom attribute element, work out the type of the .NET argument for that element. @@ -3735,63 +4680,85 @@ let rec encodeCustomAttrElemTypeForObject x = | ILAttribElem.UInt64 _ -> [| et_U8 |] | ILAttribElem.Type _ -> [| 0x50uy |] | ILAttribElem.TypeRef _ -> [| 0x50uy |] - | ILAttribElem.Null _ -> [| et_STRING |]// yes, the 0xe prefix is used when passing a "null" to a property or argument of type "object" here + | ILAttribElem.Null _ -> [| et_STRING |] // yes, the 0xe prefix is used when passing a "null" to a property or argument of type "object" here | ILAttribElem.Single _ -> [| et_R4 |] | ILAttribElem.Double _ -> [| et_R8 |] | ILAttribElem.Array (elemTy, _) -> [| yield et_SZARRAY; yield! encodeCustomAttrElemType elemTy |] -let tspan = TimeSpan (DateTime.UtcNow.Ticks - DateTime(2000, 1, 1).Ticks) +let tspan = TimeSpan(DateTime.UtcNow.Ticks - DateTime(2000, 1, 1).Ticks) -let parseILVersion (vstr : string) = +let parseILVersion (vstr: string) = // matches "v1.2.3.4" or "1.2.3.4". Note, if numbers are missing, returns -1 (not 0). - let mutable vstr = vstr.TrimStart [|'v'|] + let mutable vstr = vstr.TrimStart [| 'v' |] // if the version string contains wildcards, replace them - let versionComponents = vstr.Split [|'.'|] + let versionComponents = vstr.Split [| '.' |] // account for wildcards if versionComponents.Length > 2 then - let defaultBuild = uint16 tspan.Days % UInt16.MaxValue - 1us - let defaultRevision = uint16 (DateTime.UtcNow.TimeOfDay.TotalSeconds / 2.0) % UInt16.MaxValue - 1us - if versionComponents[2] = "*" then - if versionComponents.Length > 3 then - failwith "Invalid version format" - else - // set the build number to the number of days since Jan 1, 2000 - versionComponents[2] <- defaultBuild.ToString() - // Set the revision number to number of seconds today / 2 - vstr <- 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 <- String.Join (".", versionComponents) + let defaultBuild = uint16 tspan.Days % UInt16.MaxValue - 1us + + let defaultRevision = + uint16 (DateTime.UtcNow.TimeOfDay.TotalSeconds / 2.0) % UInt16.MaxValue - 1us + + if versionComponents[2] = "*" then + if versionComponents.Length > 3 then + failwith "Invalid version format" + else + // set the build number to the number of days since Jan 1, 2000 + versionComponents[2] <- defaultBuild.ToString() + // Set the revision number to number of seconds today / 2 + vstr <- 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 <- String.Join(".", versionComponents) let version = 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 - ILVersionInfo (zero32 version.Major, zero32 version.Minor, zero32 version.Build, minorRevision) + let minorRevision = + if version.Revision = -1 then + 0us + else + uint16 version.MinorRevision -let compareILVersions (version1 : ILVersionInfo) (version2 : ILVersionInfo) = + ILVersionInfo(zero32 version.Major, zero32 version.Minor, zero32 version.Build, minorRevision) + +let compareILVersions (version1: ILVersionInfo) (version2: ILVersionInfo) = let c = compare version1.Major version2.Major - if c <> 0 then c else - let c = compare version1.Minor version2.Minor - if c <> 0 then c else - let c = compare version1.Build version2.Build - if c <> 0 then c else - let c = compare version1.Revision version2.Revision - if c <> 0 then c else - 0 + + if c <> 0 then + c + else + let c = compare version1.Minor version2.Minor + + if c <> 0 then + c + else + let c = compare version1.Build version2.Build + + if c <> 0 then + c + else + let c = compare version1.Revision version2.Revision + if c <> 0 then c else 0 let DummyFSharpCoreScopeRef = let asmRef = // The exact public key token and version used here don't actually matter, or shouldn't. - ILAssemblyRef.Create("FSharp.Core", None, - Some (PublicKeyToken(Bytes.ofInt32Array [| 0xb0; 0x3f; 0x5f; 0x7f; 0x11; 0xd5; 0x0a; 0x3a |])), - false, - Some (parseILVersion "0.0.0.0"), None) + ILAssemblyRef.Create( + "FSharp.Core", + None, + Some(PublicKeyToken(Bytes.ofInt32Array [| 0xb0; 0x3f; 0x5f; 0x7f; 0x11; 0xd5; 0x0a; 0x3a |])), + false, + Some(parseILVersion "0.0.0.0"), + None + ) + ILScopeRef.Assembly asmRef -let PrimaryAssemblyILGlobals = mkILGlobals (ILScopeRef.PrimaryAssembly, [], DummyFSharpCoreScopeRef) +let PrimaryAssemblyILGlobals = + mkILGlobals (ILScopeRef.PrimaryAssembly, [], DummyFSharpCoreScopeRef) let rec decodeCustomAttrElemType bytes sigptr x = match x with @@ -3810,13 +4777,12 @@ let rec decodeCustomAttrElemType bytes sigptr x = | x when x = et_STRING -> PrimaryAssemblyILGlobals.typ_String, sigptr | x when x = et_OBJECT -> PrimaryAssemblyILGlobals.typ_Object, sigptr | x when x = et_SZARRAY -> - let et, sigptr = sigptr_get_u8 bytes sigptr - let elemTy, sigptr = decodeCustomAttrElemType bytes sigptr et - mkILArr1DTy elemTy, sigptr + let et, sigptr = sigptr_get_u8 bytes sigptr + let elemTy, sigptr = decodeCustomAttrElemType bytes sigptr et + mkILArr1DTy elemTy, sigptr | x when x = 0x50uy -> PrimaryAssemblyILGlobals.typ_Type, sigptr | _ -> failwithf "decodeCustomAttrElemType ilg: unrecognized custom element type: %A" x - /// Given a custom attribute element, encode it to a binary representation according to the rules in Ecma 335 Partition II. let rec encodeCustomAttrPrimValue c = match c with @@ -3840,37 +4806,51 @@ let rec encodeCustomAttrPrimValue c = | ILAttribElem.Type (Some ty) -> encodeCustomAttrString ty.QualifiedName | ILAttribElem.TypeRef (Some tref) -> encodeCustomAttrString tref.QualifiedName | ILAttribElem.Array (_, elems) -> - [| yield! i32AsBytes elems.Length; for elem in elems do yield! encodeCustomAttrPrimValue elem |] + [| + yield! i32AsBytes elems.Length + for elem in elems do + yield! encodeCustomAttrPrimValue elem + |] and encodeCustomAttrValue ty c = match ty, c with | ILType.Boxed tspec, _ when tspec.Name = tname_Object -> - [| yield! encodeCustomAttrElemTypeForObject c; yield! encodeCustomAttrPrimValue c |] - | ILType.Array (shape, _), ILAttribElem.Null when shape = ILArrayShape.SingleDimensional -> - [| yield! i32AsBytes 0xFFFFFFFF |] + [| + yield! encodeCustomAttrElemTypeForObject c + yield! encodeCustomAttrPrimValue c + |] + | ILType.Array (shape, _), ILAttribElem.Null when shape = ILArrayShape.SingleDimensional -> [| yield! i32AsBytes 0xFFFFFFFF |] | ILType.Array (shape, elemType), ILAttribElem.Array (_, elems) when shape = ILArrayShape.SingleDimensional -> - [| yield! i32AsBytes elems.Length; for elem in elems do yield! encodeCustomAttrValue elemType elem |] - | _ -> - encodeCustomAttrPrimValue c + [| + yield! i32AsBytes elems.Length + for elem in elems do + yield! encodeCustomAttrValue elemType elem + |] + | _ -> encodeCustomAttrPrimValue c let encodeCustomAttrNamedArg (nm, ty, prop, elem) = - [| yield (if prop then 0x54uy else 0x53uy) - yield! encodeCustomAttrElemType ty - yield! encodeCustomAttrString nm - yield! encodeCustomAttrValue ty elem |] + [| + yield (if prop then 0x54uy else 0x53uy) + yield! encodeCustomAttrElemType ty + yield! encodeCustomAttrString nm + yield! encodeCustomAttrValue ty elem + |] let encodeCustomAttrArgs (mspec: ILMethodSpec) (fixedArgs: _ list) (namedArgs: _ list) = let argTys = mspec.MethodRef.ArgTypes - [| yield! [| 0x01uy; 0x00uy; |] - for argTy, fixedArg in Seq.zip argTys fixedArgs do - yield! encodeCustomAttrValue argTy fixedArg - yield! u16AsBytes (uint16 namedArgs.Length) - for namedArg in namedArgs do - yield! encodeCustomAttrNamedArg namedArg |] + + [| + yield! [| 0x01uy; 0x00uy |] + for argTy, fixedArg in Seq.zip argTys fixedArgs do + yield! encodeCustomAttrValue argTy fixedArg + yield! u16AsBytes (uint16 namedArgs.Length) + for namedArg in namedArgs do + yield! encodeCustomAttrNamedArg namedArg + |] let encodeCustomAttr (mspec: ILMethodSpec, fixedArgs, namedArgs) = let args = encodeCustomAttrArgs mspec fixedArgs namedArgs - ILAttribute.Encoded (mspec, args, fixedArgs @ (namedArgs |> List.map (fun (_, _, _, e) -> e))) + ILAttribute.Encoded(mspec, args, fixedArgs @ (namedArgs |> List.map (fun (_, _, _, e) -> e))) let mkILCustomAttribMethRef (mspec: ILMethodSpec, fixedArgs, namedArgs) = encodeCustomAttr (mspec, fixedArgs, namedArgs) @@ -3881,8 +4861,7 @@ let mkILCustomAttribute (tref, argTys, argvs, propvs) = let getCustomAttrData cattr = match cattr with | ILAttribute.Encoded (_, data, _) -> data - | ILAttribute.Decoded (mspec, fixedArgs, namedArgs) -> - encodeCustomAttrArgs mspec fixedArgs namedArgs + | ILAttribute.Decoded (mspec, fixedArgs, namedArgs) -> encodeCustomAttrArgs mspec fixedArgs namedArgs // ILSecurityDecl is a 'blob' having the following format: // - A byte containing a period (.). @@ -3894,43 +4873,73 @@ let getCustomAttrData cattr = // in §23.3, beginning with NumNamed). let mkPermissionSet (action, attributes: (ILTypeRef * (string * ILType * ILAttribElem) list) list) = let bytes = - [| yield (byte '.') - yield! z_unsigned_int attributes.Length - for tref: ILTypeRef, props in attributes do - yield! encodeCustomAttrString tref.QualifiedName - let bytes = - [| yield! z_unsigned_int props.Length - for nm, ty, value in props do - yield! encodeCustomAttrNamedArg (nm, ty, true, value)|] - yield! z_unsigned_int bytes.Length - yield! bytes |] - - ILSecurityDecl.ILSecurityDecl (action, bytes) + [| + yield (byte '.') + yield! z_unsigned_int attributes.Length + for tref: ILTypeRef, props in attributes do + yield! encodeCustomAttrString tref.QualifiedName + + let bytes = + [| + yield! z_unsigned_int props.Length + for nm, ty, value in props do + yield! encodeCustomAttrNamedArg (nm, ty, true, value) + |] + + yield! z_unsigned_int bytes.Length + yield! bytes + |] + + ILSecurityDecl.ILSecurityDecl(action, bytes) // Parse an IL type signature argument within a custom attribute blob -type ILTypeSigParser (tstring : string) = +type ILTypeSigParser(tstring: string) = let mutable startPos = 0 let mutable currentPos = 0 - let reset() = startPos <- 0 ; currentPos <- 0 + let reset () = + startPos <- 0 + currentPos <- 0 + let nil = '\r' // cannot appear in a type sig // take a look at the next value, but don't advance - let peek() = if currentPos < (tstring.Length-1) then tstring[currentPos+1] else nil - let peekN skip = if currentPos < (tstring.Length - skip) then tstring[currentPos+skip] else nil + let peek () = + if currentPos < (tstring.Length - 1) then + tstring[currentPos + 1] + else + nil + + let peekN skip = + if currentPos < (tstring.Length - skip) then + tstring[currentPos + skip] + else + nil // take a look at the current value, but don't advance - let here() = if currentPos < tstring.Length then tstring[currentPos] else nil + let here () = + if currentPos < tstring.Length then + tstring[currentPos] + else + nil // move on to the next character - let step() = currentPos <- currentPos+1 + let step () = currentPos <- currentPos + 1 // ignore the current lexeme - let skip() = startPos <- currentPos + let skip () = startPos <- currentPos // ignore the current lexeme, advance - let drop() = skip() ; step() ; skip() + let drop () = + skip () + step () + skip () // return the current lexeme, advance - let take() = - let s = if currentPos < tstring.Length then tstring[startPos..currentPos] else "" - drop() + let take () = + let s = + if currentPos < tstring.Length then + tstring[startPos..currentPos] + else + "" + + drop () s // The format we accept is @@ -3950,39 +4959,56 @@ type ILTypeSigParser (tstring : string) = // Does the type name start with a leading '['? If so, ignore it // (if the specialization type is in another module, it will be wrapped in bracket) - if here() = '[' then drop() + if here () = '[' then drop () // 1. Iterate over beginning of type, grabbing the type name and determining if it's generic or an array let typeName = - while (peek() <> '`') && (peek() <> '[') && (peek() <> ']') && (peek() <> ',') && (peek() <> nil) do step() - take() + while (peek () <> '`') + && (peek () <> '[') + && (peek () <> ']') + && (peek () <> ',') + && (peek () <> nil) do + step () + + take () // 2. Classify the type // Is the type generic? let typeName, specializations = - if here() = '`' then - drop() // step to the number + if here () = '`' then + drop () // step to the number // fetch the arity let arity = - while (int(here()) >= (int('0'))) && (int(here()) <= (int('9'))) && (int(peek()) >= (int('0'))) && (int(peek()) <= (int('9'))) do step() - Int32.Parse(take()) + while (int (here ()) >= (int ('0'))) + && (int (here ()) <= (int ('9'))) + && (int (peek ()) >= (int ('0'))) + && (int (peek ()) <= (int ('9'))) do + step () + + Int32.Parse(take ()) // skip the '[' - drop() + drop () // get the specializations - typeName+"`"+(arity.ToString()), Some [for _i in 0..arity-1 do yield x.ParseType()] + typeName + "`" + (arity.ToString()), + Some + [ + for _i in 0 .. arity - 1 do + yield x.ParseType() + ] else typeName, None // Is the type an array? let rank = - if here() = '[' then + if here () = '[' then let mutable rank = 0 - while here() <> ']' do + while here () <> ']' do rank <- rank + 1 - step() - drop() + step () + + drop () Some(ILArrayShape(List.replicate rank (Some 0, None))) else @@ -3990,35 +5016,43 @@ type ILTypeSigParser (tstring : string) = // Is there a scope? let scope = - if (here() = ',' || here() = ' ') && (peek() <> '[' && peekN 2 <> '[') then - let grabScopeComponent() = - if here() = ',' then drop() // ditch the ',' - if here() = ' ' then drop() // ditch the ' ' + if (here () = ',' || here () = ' ') && (peek () <> '[' && peekN 2 <> '[') then + let grabScopeComponent () = + if here () = ',' then drop () // ditch the ',' + if here () = ' ' then drop () // ditch the ' ' - while (peek() <> ',' && peek() <> ']' && peek() <> nil) do step() - take() + while (peek () <> ',' && peek () <> ']' && peek () <> nil) do + step () + + take () let scope = - [ yield grabScopeComponent() // assembly - yield grabScopeComponent() // version - yield grabScopeComponent() // culture - yield grabScopeComponent() // public key token - ] |> String.concat "," + [ + yield grabScopeComponent () // assembly + yield grabScopeComponent () // version + yield grabScopeComponent () // culture + yield grabScopeComponent () // public key token + ] + |> String.concat "," + ILScopeRef.Assembly(ILAssemblyRef.FromAssemblyName(AssemblyName scope)) else ILScopeRef.Local // strip any extraneous trailing brackets or commas - if (here() = ']') then drop() - if (here() = ',') then drop() + if (here () = ']') then drop () + if (here () = ',') then drop () // build the IL type let tref = mkILTyRef (scope, typeName) + let genericArgs = match specializations with | None -> [] | Some genericArgs -> genericArgs - let tspec = ILTypeSpec.Create (tref, genericArgs) + + let tspec = ILTypeSpec.Create(tref, genericArgs) + let ilTy = match tspec.Name with | "System.SByte" @@ -4037,137 +5071,154 @@ type ILTypeSigParser (tstring : string) = // if it's an array, wrap it - otherwise, just return the IL type match rank with - | Some r -> ILType.Array (r, ilTy) + | Some r -> ILType.Array(r, ilTy) | _ -> ilTy member x.ParseTypeSpec() = - reset() + reset () let ilTy = x.ParseType() - ILAttribElem.Type (Some ilTy) + ILAttribElem.Type(Some ilTy) let decodeILAttribData (ca: ILAttribute) = match ca with | ILAttribute.Decoded (_, fixedArgs, namedArgs) -> fixedArgs, namedArgs | ILAttribute.Encoded (_, bytes, _) -> - let sigptr = 0 - let bb0, sigptr = sigptr_get_byte bytes sigptr - let bb1, sigptr = sigptr_get_byte bytes sigptr - if not (bb0 = 0x01 && bb1 = 0x00) then failwith "decodeILAttribData: invalid data" - - let rec parseVal argTy sigptr = - match argTy with - | ILType.Value tspec when tspec.Name = "System.SByte" -> - let n, sigptr = sigptr_get_i8 bytes sigptr - ILAttribElem.SByte n, sigptr - | ILType.Value tspec when tspec.Name = "System.Byte" -> - let n, sigptr = sigptr_get_u8 bytes sigptr - ILAttribElem.Byte n, sigptr - | ILType.Value tspec when tspec.Name = "System.Int16" -> - let n, sigptr = sigptr_get_i16 bytes sigptr - ILAttribElem.Int16 n, sigptr - | ILType.Value tspec when tspec.Name = "System.UInt16" -> - let n, sigptr = sigptr_get_u16 bytes sigptr - ILAttribElem.UInt16 n, sigptr - | ILType.Value tspec when tspec.Name = "System.Int32" -> - let n, sigptr = sigptr_get_i32 bytes sigptr - ILAttribElem.Int32 n, sigptr - | ILType.Value tspec when tspec.Name = "System.UInt32" -> - let n, sigptr = sigptr_get_u32 bytes sigptr - ILAttribElem.UInt32 n, sigptr - | ILType.Value tspec when tspec.Name = "System.Int64" -> - let n, sigptr = sigptr_get_i64 bytes sigptr - ILAttribElem.Int64 n, sigptr - | ILType.Value tspec when tspec.Name = "System.UInt64" -> - let n, sigptr = sigptr_get_u64 bytes sigptr - ILAttribElem.UInt64 n, sigptr - | ILType.Value tspec when tspec.Name = "System.Double" -> - let n, sigptr = sigptr_get_ieee64 bytes sigptr - ILAttribElem.Double n, sigptr - | ILType.Value tspec when tspec.Name = "System.Single" -> - let n, sigptr = sigptr_get_ieee32 bytes sigptr - ILAttribElem.Single n, sigptr - | ILType.Value tspec when tspec.Name = "System.Char" -> - let n, sigptr = sigptr_get_u16 bytes sigptr - ILAttribElem.Char (char (int32 n)), sigptr - | ILType.Value tspec when tspec.Name = "System.Boolean" -> - let n, sigptr = sigptr_get_byte bytes sigptr - ILAttribElem.Bool (not (n = 0)), sigptr - | ILType.Boxed tspec when tspec.Name = "System.String" -> - let n, sigptr = sigptr_get_serstring_possibly_null bytes sigptr - ILAttribElem.String n, sigptr - | ILType.Boxed tspec when tspec.Name = "System.Type" -> - let nOpt, sigptr = sigptr_get_serstring_possibly_null bytes sigptr - match nOpt with - | None -> ILAttribElem.TypeRef None, sigptr - | Some n -> - try - let parser = ILTypeSigParser n - parser.ParseTypeSpec(), sigptr - with exn -> - failwith (sprintf "decodeILAttribData: error parsing type in custom attribute blob: %s" exn.Message) - | ILType.Boxed tspec when tspec.Name = "System.Object" -> - let et, sigptr = sigptr_get_u8 bytes sigptr - if et = 0xFFuy then - ILAttribElem.Null, sigptr - else - let ty, sigptr = decodeCustomAttrElemType bytes sigptr et - parseVal ty sigptr - | ILType.Array (shape, elemTy) when shape = ILArrayShape.SingleDimensional -> - let n, sigptr = sigptr_get_i32 bytes sigptr - if n = 0xFFFFFFFF then ILAttribElem.Null, sigptr else - let rec parseElems acc n sigptr = - if n = 0 then List.rev acc, sigptr else - let v, sigptr = parseVal elemTy sigptr - parseElems (v :: acc) (n-1) sigptr - let elems, sigptr = parseElems [] n sigptr - ILAttribElem.Array (elemTy, elems), sigptr - | ILType.Value _ -> (* assume it is an enumeration *) - let n, sigptr = sigptr_get_i32 bytes sigptr - ILAttribElem.Int32 n, sigptr - | _ -> failwith "decodeILAttribData: attribute data involves an enum or System.Type value" - - let rec parseFixed argTys sigptr = - match argTys with - | [] -> [], sigptr - | h :: t -> - let nh, sigptr = parseVal h sigptr - let nt, sigptr = parseFixed t sigptr - nh :: nt, sigptr - - let fixedArgs, sigptr = parseFixed ca.Method.FormalArgTypes sigptr - let nnamed, sigptr = sigptr_get_u16 bytes sigptr - let rec parseNamed acc n sigptr = - if n = 0 then List.rev acc else - let isPropByte, sigptr = sigptr_get_u8 bytes sigptr - let isProp = (int isPropByte = 0x54) - let et, sigptr = sigptr_get_u8 bytes sigptr - // We have a named value - let ty, sigptr = - if ( (* 0x50 = (int et) || *) 0x55 = (int et)) then - let qualified_tname, sigptr = sigptr_get_serstring bytes sigptr - let unqualified_tname, rest = - let pieces = qualified_tname.Split ',' - if pieces.Length > 1 then - pieces[0], Some (String.concat "," pieces[1..]) + let sigptr = 0 + let bb0, sigptr = sigptr_get_byte bytes sigptr + let bb1, sigptr = sigptr_get_byte bytes sigptr + + if not (bb0 = 0x01 && bb1 = 0x00) then + failwith "decodeILAttribData: invalid data" + + let rec parseVal argTy sigptr = + match argTy with + | ILType.Value tspec when tspec.Name = "System.SByte" -> + let n, sigptr = sigptr_get_i8 bytes sigptr + ILAttribElem.SByte n, sigptr + | ILType.Value tspec when tspec.Name = "System.Byte" -> + let n, sigptr = sigptr_get_u8 bytes sigptr + ILAttribElem.Byte n, sigptr + | ILType.Value tspec when tspec.Name = "System.Int16" -> + let n, sigptr = sigptr_get_i16 bytes sigptr + ILAttribElem.Int16 n, sigptr + | ILType.Value tspec when tspec.Name = "System.UInt16" -> + let n, sigptr = sigptr_get_u16 bytes sigptr + ILAttribElem.UInt16 n, sigptr + | ILType.Value tspec when tspec.Name = "System.Int32" -> + let n, sigptr = sigptr_get_i32 bytes sigptr + ILAttribElem.Int32 n, sigptr + | ILType.Value tspec when tspec.Name = "System.UInt32" -> + let n, sigptr = sigptr_get_u32 bytes sigptr + ILAttribElem.UInt32 n, sigptr + | ILType.Value tspec when tspec.Name = "System.Int64" -> + let n, sigptr = sigptr_get_i64 bytes sigptr + ILAttribElem.Int64 n, sigptr + | ILType.Value tspec when tspec.Name = "System.UInt64" -> + let n, sigptr = sigptr_get_u64 bytes sigptr + ILAttribElem.UInt64 n, sigptr + | ILType.Value tspec when tspec.Name = "System.Double" -> + let n, sigptr = sigptr_get_ieee64 bytes sigptr + ILAttribElem.Double n, sigptr + | ILType.Value tspec when tspec.Name = "System.Single" -> + let n, sigptr = sigptr_get_ieee32 bytes sigptr + ILAttribElem.Single n, sigptr + | ILType.Value tspec when tspec.Name = "System.Char" -> + let n, sigptr = sigptr_get_u16 bytes sigptr + ILAttribElem.Char(char (int32 n)), sigptr + | ILType.Value tspec when tspec.Name = "System.Boolean" -> + let n, sigptr = sigptr_get_byte bytes sigptr + ILAttribElem.Bool(not (n = 0)), sigptr + | ILType.Boxed tspec when tspec.Name = "System.String" -> + let n, sigptr = sigptr_get_serstring_possibly_null bytes sigptr + ILAttribElem.String n, sigptr + | ILType.Boxed tspec when tspec.Name = "System.Type" -> + let nOpt, sigptr = sigptr_get_serstring_possibly_null bytes sigptr + + match nOpt with + | None -> ILAttribElem.TypeRef None, sigptr + | Some n -> + try + let parser = ILTypeSigParser n + parser.ParseTypeSpec(), sigptr + with + | exn -> failwith (sprintf "decodeILAttribData: error parsing type in custom attribute blob: %s" exn.Message) + | ILType.Boxed tspec when tspec.Name = "System.Object" -> + let et, sigptr = sigptr_get_u8 bytes sigptr + + if et = 0xFFuy then + ILAttribElem.Null, sigptr else - pieces[0], None - let scoref = - match rest with - | Some aname -> ILScopeRef.Assembly (ILAssemblyRef.FromAssemblyName (AssemblyName aname)) - | None -> PrimaryAssemblyILGlobals.primaryAssemblyScopeRef - - let tref = mkILTyRef (scoref, unqualified_tname) - let tspec = mkILNonGenericTySpec tref - ILType.Value tspec, sigptr - else - decodeCustomAttrElemType bytes sigptr et - let nm, sigptr = sigptr_get_serstring bytes sigptr - let v, sigptr = parseVal ty sigptr - parseNamed ((nm, ty, isProp, v) :: acc) (n-1) sigptr - let named = parseNamed [] (int nnamed) sigptr - fixedArgs, named + let ty, sigptr = decodeCustomAttrElemType bytes sigptr et + parseVal ty sigptr + | ILType.Array (shape, elemTy) when shape = ILArrayShape.SingleDimensional -> + let n, sigptr = sigptr_get_i32 bytes sigptr + if n = 0xFFFFFFFF then + ILAttribElem.Null, sigptr + else + let rec parseElems acc n sigptr = + if n = 0 then + List.rev acc, sigptr + else + let v, sigptr = parseVal elemTy sigptr + parseElems (v :: acc) (n - 1) sigptr + + let elems, sigptr = parseElems [] n sigptr + ILAttribElem.Array(elemTy, elems), sigptr + | ILType.Value _ -> (* assume it is an enumeration *) + let n, sigptr = sigptr_get_i32 bytes sigptr + ILAttribElem.Int32 n, sigptr + | _ -> failwith "decodeILAttribData: attribute data involves an enum or System.Type value" + + let rec parseFixed argTys sigptr = + match argTys with + | [] -> [], sigptr + | h :: t -> + let nh, sigptr = parseVal h sigptr + let nt, sigptr = parseFixed t sigptr + nh :: nt, sigptr + + let fixedArgs, sigptr = parseFixed ca.Method.FormalArgTypes sigptr + let nnamed, sigptr = sigptr_get_u16 bytes sigptr + + let rec parseNamed acc n sigptr = + if n = 0 then + List.rev acc + else + let isPropByte, sigptr = sigptr_get_u8 bytes sigptr + let isProp = (int isPropByte = 0x54) + let et, sigptr = sigptr_get_u8 bytes sigptr + // We have a named value + let ty, sigptr = + if ( (* 0x50 = (int et) || *) 0x55 = (int et)) then + let qualified_tname, sigptr = sigptr_get_serstring bytes sigptr + + let unqualified_tname, rest = + let pieces = qualified_tname.Split ',' + + if pieces.Length > 1 then + pieces[0], Some(String.concat "," pieces[1..]) + else + pieces[0], None + + let scoref = + match rest with + | Some aname -> ILScopeRef.Assembly(ILAssemblyRef.FromAssemblyName(AssemblyName aname)) + | None -> PrimaryAssemblyILGlobals.primaryAssemblyScopeRef + + let tref = mkILTyRef (scoref, unqualified_tname) + let tspec = mkILNonGenericTySpec tref + ILType.Value tspec, sigptr + else + decodeCustomAttrElemType bytes sigptr et + + let nm, sigptr = sigptr_get_serstring bytes sigptr + let v, sigptr = parseVal ty sigptr + parseNamed ((nm, ty, isProp, v) :: acc) (n - 1) sigptr + + let named = parseNamed [] (int nnamed) sigptr + fixedArgs, named // -------------------------------------------------------------------- // Functions to collect up all the references in a full module or @@ -4176,32 +5227,36 @@ let decodeILAttribData (ca: ILAttribute) = // -------------------------------------------------------------------- type ILReferences = - { AssemblyReferences: ILAssemblyRef[] - ModuleReferences: ILModuleRef[] - TypeReferences: ILTypeRef[] - MethodReferences: ILMethodRef[] - FieldReferences: ILFieldRef[] } + { + AssemblyReferences: ILAssemblyRef[] + ModuleReferences: ILModuleRef[] + TypeReferences: ILTypeRef[] + MethodReferences: ILMethodRef[] + FieldReferences: ILFieldRef[] + } type ILReferencesAccumulator = - { ilg: ILGlobals - refsA: HashSet - refsM: HashSet - refsTs: HashSet - refsMs: HashSet - refsFs: HashSet } + { + ilg: ILGlobals + refsA: HashSet + refsM: HashSet + refsTs: HashSet + refsMs: HashSet + refsFs: HashSet + } let emptyILRefs = - { AssemblyReferences = [||] - ModuleReferences = [||] - TypeReferences = [||] - MethodReferences = [||] - FieldReferences = [||] } + { + AssemblyReferences = [||] + ModuleReferences = [||] + TypeReferences = [||] + MethodReferences = [||] + FieldReferences = [||] + } -let refsOfILAssemblyRef (s: ILReferencesAccumulator) x = - s.refsA.Add x |> ignore +let refsOfILAssemblyRef (s: ILReferencesAccumulator) x = s.refsA.Add x |> ignore -let refsOfILModuleRef (s: ILReferencesAccumulator) x = - s.refsM.Add x |> ignore +let refsOfILModuleRef (s: ILReferencesAccumulator) x = s.refsM.Add x |> ignore let refsOfScopeRef s x = match x with @@ -4214,11 +5269,16 @@ let refsOfILTypeRef s (x: ILTypeRef) = refsOfScopeRef s x.Scope let rec refsOfILType s x = match x with - | ILType.Void | ILType.TypeVar _ -> () - | ILType.Modified (_, ty1, ty2) -> refsOfILTypeRef s ty1; refsOfILType s ty2 + | ILType.Void + | ILType.TypeVar _ -> () + | ILType.Modified (_, ty1, ty2) -> + refsOfILTypeRef s ty1 + refsOfILType s ty2 | ILType.Array (_, ty) - | ILType.Ptr ty | ILType.Byref ty -> refsOfILType s ty - | ILType.Value tr | ILType.Boxed tr -> refsOfILTypeSpec s tr + | ILType.Ptr ty + | ILType.Byref ty -> refsOfILType s ty + | ILType.Value tr + | ILType.Boxed tr -> refsOfILTypeSpec s tr | ILType.FunctionPointer mref -> refsOfILCallsig s mref and refsOfILTypeSpec s (x: ILTypeSpec) = @@ -4229,11 +5289,9 @@ and refsOfILCallsig s csig = refsOfILTypes s csig.ArgTypes refsOfILType s csig.ReturnType -and refsOfILGenericParam s x = - refsOfILTypes s x.Constraints +and refsOfILGenericParam s x = refsOfILTypes s x.Constraints -and refsOfILGenericParams s b = - List.iter (refsOfILGenericParam s) b +and refsOfILGenericParams s b = List.iter (refsOfILGenericParam s) b and refsOfILMethodRef s (x: ILMethodRef) = refsOfILTypeRef s x.DeclaringTypeRef @@ -4272,26 +5330,27 @@ and refsOfILCustomAttrElem s (elem: ILAttribElem) = | Type (Some ty) -> refsOfILType s ty | TypeRef (Some tref) -> refsOfILTypeRef s tref | Array (ty, els) -> - refsOfILType s ty + refsOfILType s ty refsOfILCustomAttrElems s els | _ -> () - + and refsOfILCustomAttrElems s els = els |> List.iter (refsOfILCustomAttrElem s) and refsOfILCustomAttr s (cattr: ILAttribute) = refsOfILMethodSpec s cattr.Method - refsOfILCustomAttrElems s cattr.Elements + refsOfILCustomAttrElems s cattr.Elements -and refsOfILCustomAttrs s (cas : ILAttributes) = +and refsOfILCustomAttrs s (cas: ILAttributes) = cas.AsArray() |> Array.iter (refsOfILCustomAttr s) -and refsOfILVarArgs s tyso = - Option.iter (refsOfILTypes s) tyso +and refsOfILVarArgs s tyso = Option.iter (refsOfILTypes s) tyso and refsOfILInstr s x = match x with - | I_call (_, mr, varargs) | I_newobj (mr, varargs) | I_callvirt (_, mr, varargs) -> + | I_call (_, mr, varargs) + | I_newobj (mr, varargs) + | I_callvirt (_, mr, varargs) -> refsOfILMethodSpec s mr refsOfILVarArgs s varargs | I_callconstraint (_, tr, mr, varargs) -> @@ -4299,28 +5358,99 @@ and refsOfILInstr s x = refsOfILMethodSpec s mr refsOfILVarArgs s varargs | I_calli (_, callsig, varargs) -> - refsOfILCallsig s callsig; refsOfILVarArgs s varargs - | I_jmp mr | I_ldftn mr | I_ldvirtftn mr -> - refsOfILMethodSpec s mr - | I_ldsfld (_, fr) | I_ldfld (_, _, fr) | I_ldsflda fr | I_ldflda fr | I_stsfld (_, fr) | I_stfld (_, _, fr) -> - refsOfILFieldSpec s fr - | I_isinst ty | I_castclass ty | I_cpobj ty | I_initobj ty | I_ldobj (_, _, ty) - | I_stobj (_, _, ty) | I_box ty |I_unbox ty | I_unbox_any ty | I_sizeof ty - | I_ldelem_any (_, ty) | I_ldelema (_, _, _, ty) |I_stelem_any (_, ty) | I_newarr (_, ty) - | I_mkrefany ty | I_refanyval ty + refsOfILCallsig s callsig + refsOfILVarArgs s varargs + | I_jmp mr + | I_ldftn mr + | I_ldvirtftn mr -> refsOfILMethodSpec s mr + | I_ldsfld (_, fr) + | I_ldfld (_, _, fr) + | I_ldsflda fr + | I_ldflda fr + | I_stsfld (_, fr) + | I_stfld (_, _, fr) -> refsOfILFieldSpec s fr + | I_isinst ty + | I_castclass ty + | I_cpobj ty + | I_initobj ty + | I_ldobj (_, _, ty) + | I_stobj (_, _, ty) + | I_box ty + | I_unbox ty + | I_unbox_any ty + | I_sizeof ty + | I_ldelem_any (_, ty) + | I_ldelema (_, _, _, ty) + | I_stelem_any (_, ty) + | I_newarr (_, ty) + | I_mkrefany ty + | I_refanyval ty | EI_ilzero ty -> refsOfILType s ty | I_ldtoken token -> refsOfILToken s token - | I_stelem _|I_ldelem _|I_ldstr _|I_switch _|I_stloc _|I_stind _ - | I_starg _|I_ldloca _|I_ldloc _|I_ldind _ - | I_ldarga _|I_ldarg _|I_leave _|I_br _ - | I_brcmp _|I_rethrow|I_refanytype|I_ldlen|I_throw|I_initblk _ |I_cpblk _ - | I_localloc|I_ret |I_endfilter|I_endfinally|I_arglist + | I_stelem _ + | I_ldelem _ + | I_ldstr _ + | I_switch _ + | I_stloc _ + | I_stind _ + | I_starg _ + | I_ldloca _ + | I_ldloc _ + | I_ldind _ + | I_ldarga _ + | I_ldarg _ + | I_leave _ + | I_br _ + | I_brcmp _ + | I_rethrow + | I_refanytype + | I_ldlen + | I_throw + | I_initblk _ + | I_cpblk _ + | I_localloc + | I_ret + | I_endfilter + | I_endfinally + | I_arglist | I_break - | AI_add | AI_add_ovf | AI_add_ovf_un | AI_and | AI_div | AI_div_un | AI_ceq | AI_cgt | AI_cgt_un | AI_clt - | AI_clt_un | AI_conv _ | AI_conv_ovf _ | AI_conv_ovf_un _ | AI_mul | AI_mul_ovf | AI_mul_ovf_un | AI_rem | AI_rem_un - | AI_shl | AI_shr | AI_shr_un | AI_sub | AI_sub_ovf | AI_sub_ovf_un | AI_xor | AI_or | AI_neg | AI_not - | AI_ldnull | AI_dup | AI_pop | AI_ckfinite | AI_nop | AI_ldc _ - | I_seqpoint _ | EI_ldlen_multi _ -> () + | AI_add + | AI_add_ovf + | AI_add_ovf_un + | AI_and + | AI_div + | AI_div_un + | AI_ceq + | AI_cgt + | AI_cgt_un + | AI_clt + | AI_clt_un + | AI_conv _ + | AI_conv_ovf _ + | AI_conv_ovf_un _ + | AI_mul + | AI_mul_ovf + | AI_mul_ovf_un + | AI_rem + | AI_rem_un + | AI_shl + | AI_shr + | AI_shr_un + | AI_sub + | AI_sub_ovf + | AI_sub_ovf_un + | AI_xor + | AI_or + | AI_neg + | AI_not + | AI_ldnull + | AI_dup + | AI_pop + | AI_ckfinite + | AI_nop + | AI_ldc _ + | I_seqpoint _ + | EI_ldlen_multi _ -> () and refsOfILCode s (c: ILCode) = for i in c.Instrs do @@ -4381,17 +5511,15 @@ and refsOfILFieldDef s (fd: ILFieldDef) = refsOfILType s fd.FieldType refsOfILCustomAttrs s fd.CustomAttrs -and refsOfILFieldDefs s fields = - List.iter (refsOfILFieldDef s) fields +and refsOfILFieldDefs s fields = List.iter (refsOfILFieldDef s) fields -and refsOfILMethodImpls s mimpls = - List.iter (refsOfILMethodImpl s) mimpls +and refsOfILMethodImpls s mimpls = List.iter (refsOfILMethodImpl s) mimpls and refsOfILMethodImpl s m = refsOfILOverridesSpec s m.Overrides refsOfILMethodSpec s m.OverrideBy -and refsOfILTypeDef s (td : ILTypeDef) = +and refsOfILTypeDef s (td: ILTypeDef) = refsOfILTypeDefs s td.NestedTypes refsOfILGenericParams s td.GenericParams refsOfILTypes s td.Implements @@ -4405,8 +5533,7 @@ and refsOfILTypeDef s (td : ILTypeDef) = and refsOfILTypeDefs s (types: ILTypeDefs) = Seq.iter (refsOfILTypeDef s) types -and refsOfILExportedType s (c: ILExportedTypeOrForwarder) = - refsOfILCustomAttrs s c.CustomAttrs +and refsOfILExportedType s (c: ILExportedTypeOrForwarder) = refsOfILCustomAttrs s c.CustomAttrs and refsOfILExportedTypes s (tab: ILExportedTypesAndForwarders) = List.iter (refsOfILExportedType s) (tab.AsList()) @@ -4436,42 +5563,50 @@ and refsOfILManifest s (m: ILAssemblyManifest) = let computeILRefs ilg modul = let s = - { ilg = ilg - refsA = HashSet<_>(HashIdentity.Structural) - refsM = HashSet<_>(HashIdentity.Structural) - refsTs = HashSet<_>(HashIdentity.Structural) - refsMs = HashSet<_>(HashIdentity.Structural) - refsFs = HashSet<_>(HashIdentity.Structural) } + { + ilg = ilg + refsA = HashSet<_>(HashIdentity.Structural) + refsM = HashSet<_>(HashIdentity.Structural) + refsTs = HashSet<_>(HashIdentity.Structural) + refsMs = HashSet<_>(HashIdentity.Structural) + refsFs = HashSet<_>(HashIdentity.Structural) + } refsOfILModule s modul - { AssemblyReferences = s.refsA.ToArray() - ModuleReferences = s.refsM.ToArray() - TypeReferences = s.refsTs.ToArray() - MethodReferences = s.refsMs.ToArray() - FieldReferences = s.refsFs.ToArray() } -let unscopeILTypeRef (x: ILTypeRef) = ILTypeRef.Create (ILScopeRef.Local, x.Enclosing, x.Name) + { + AssemblyReferences = s.refsA.ToArray() + ModuleReferences = s.refsM.ToArray() + TypeReferences = s.refsTs.ToArray() + MethodReferences = s.refsMs.ToArray() + FieldReferences = s.refsFs.ToArray() + } + +let unscopeILTypeRef (x: ILTypeRef) = + ILTypeRef.Create(ILScopeRef.Local, x.Enclosing, x.Name) let rec unscopeILTypeSpec (tspec: ILTypeSpec) = let tref = tspec.TypeRef let tinst = tspec.GenericArgs let tref = unscopeILTypeRef tref - ILTypeSpec.Create (tref, unscopeILTypes tinst) + ILTypeSpec.Create(tref, unscopeILTypes tinst) and unscopeILType ty = match ty with - | ILType.Ptr t -> ILType.Ptr (unscopeILType t) - | ILType.FunctionPointer t -> ILType.FunctionPointer (unscopeILCallSig t) - | ILType.Byref t -> ILType.Byref (unscopeILType t) + | ILType.Ptr t -> ILType.Ptr(unscopeILType t) + | ILType.FunctionPointer t -> ILType.FunctionPointer(unscopeILCallSig t) + | ILType.Byref t -> ILType.Byref(unscopeILType t) | ILType.Boxed cr -> mkILBoxedType (unscopeILTypeSpec cr) - | ILType.Array (s, ty) -> ILType.Array (s, unscopeILType ty) - | ILType.Value cr -> ILType.Value (unscopeILTypeSpec cr) - | ILType.Modified (b, tref, ty) -> ILType.Modified (b, unscopeILTypeRef tref, unscopeILType ty) + | ILType.Array (s, ty) -> ILType.Array(s, unscopeILType ty) + | ILType.Value cr -> ILType.Value(unscopeILTypeSpec cr) + | ILType.Modified (b, tref, ty) -> ILType.Modified(b, unscopeILTypeRef tref, unscopeILType ty) | x -> x and unscopeILTypes i = - if List.isEmpty i then i - else List.map unscopeILType i + if List.isEmpty i then + i + else + List.map unscopeILType i and unscopeILCallSig csig = mkILCallSig (csig.CallingConv, unscopeILTypes csig.ArgTypes, unscopeILType csig.ReturnType) @@ -4480,41 +5615,65 @@ let resolveILMethodRefWithRescope r (td: ILTypeDef) (mref: ILMethodRef) = let args = mref.ArgTypes let nargs = args.Length let nm = mref.Name - let possibles = td.Methods.FindByNameAndArity (nm, nargs) - if isNil possibles then failwith ("no method named " + nm + " found in type " + td.Name) + let possibles = td.Methods.FindByNameAndArity(nm, nargs) + + if isNil possibles then + failwith ("no method named " + nm + " found in type " + td.Name) + let argTypes = mref.ArgTypes |> List.map r - let retType : ILType = r mref.ReturnType - match - possibles |> List.filter (fun md -> - mref.CallingConv = md.CallingConv && - // REVIEW: this uses equality on ILType. For CMOD_OPTIONAL this is not going to be correct - (md.Parameters, argTypes) ||> List.lengthsEqAndForall2 (fun p1 p2 -> r p1.Type = p2) && - // REVIEW: this uses equality on ILType. For CMOD_OPTIONAL this is not going to be correct - r md.Return.Type = retType) with - | [] -> failwith ("no method named "+nm+" with appropriate argument types found in type "+td.Name) - | [mdef] -> mdef - | _ -> failwith ("multiple methods named "+nm+" appear with identical argument types in type "+td.Name) - -let resolveILMethodRef td mref = resolveILMethodRefWithRescope id td mref - -let mkRefToILModule m = - ILModuleRef.Create (m.Name, true, None) + let retType: ILType = r mref.ReturnType + + match possibles + |> List.filter (fun md -> + mref.CallingConv = md.CallingConv + && + // REVIEW: this uses equality on ILType. For CMOD_OPTIONAL this is not going to be correct + (md.Parameters, argTypes) + ||> List.lengthsEqAndForall2 (fun p1 p2 -> r p1.Type = p2) + && + // REVIEW: this uses equality on ILType. For CMOD_OPTIONAL this is not going to be correct + r md.Return.Type = retType) + with + | [] -> + failwith ( + "no method named " + + nm + + " with appropriate argument types found in type " + + td.Name + ) + | [ mdef ] -> mdef + | _ -> + failwith ( + "multiple methods named " + + nm + + " appear with identical argument types in type " + + td.Name + ) + +let resolveILMethodRef td mref = + resolveILMethodRefWithRescope id td mref + +let mkRefToILModule m = ILModuleRef.Create(m.Name, true, None) type ILEventRef = - { erA: ILTypeRef - erB: string } + { + erA: ILTypeRef + erB: string + } - static member Create (a, b) = {erA=a;erB=b} + static member Create(a, b) = { erA = a; erB = b } member x.DeclaringTypeRef = x.erA member x.Name = x.erB type ILPropertyRef = - { prA: ILTypeRef - prB: string } + { + prA: ILTypeRef + prB: string + } - static member Create (a, b) = {prA=a;prB=b} + static member Create(a, b) = { prA = a; prB = b } member x.DeclaringTypeRef = x.prA diff --git a/src/Compiler/AbstractIL/ilascii.fs b/src/Compiler/AbstractIL/ilascii.fs index 495f8fa21..92c481b0f 100644 --- a/src/Compiler/AbstractIL/ilascii.fs +++ b/src/Compiler/AbstractIL/ilascii.fs @@ -8,263 +8,258 @@ open FSharp.Compiler.AbstractIL.IL /// Table of parsing and pretty printing data for instructions. let noArgInstrs = - lazy [ - ["ldc";"i4";"0"], mkLdcInt32 0 - ["ldc";"i4";"1"], mkLdcInt32 1 - ["ldc";"i4";"2"], mkLdcInt32 2 - ["ldc";"i4";"3"], mkLdcInt32 3 - ["ldc";"i4";"4"], mkLdcInt32 4 - ["ldc";"i4";"5"], mkLdcInt32 5 - ["ldc";"i4";"6"], mkLdcInt32 6 - ["ldc";"i4";"7"], mkLdcInt32 7 - ["ldc";"i4";"8"], mkLdcInt32 8 - ["ldc";"i4";"M1"], mkLdcInt32 -1 - ["ldc";"i4";"m1"], mkLdcInt32 -1 - ["stloc";"0"], mkStloc (uint16 0) - ["stloc";"1"], mkStloc (uint16 1) - ["stloc";"2"], mkStloc (uint16 2) - ["stloc";"3"], mkStloc (uint16 3) - ["ldloc";"0"], mkLdloc (uint16 0) - ["ldloc";"1"], mkLdloc (uint16 1) - ["ldloc";"2"], mkLdloc (uint16 2) - ["ldloc";"3"], mkLdloc (uint16 3) - ["ldarg";"0"], mkLdarg (uint16 0) - ["ldarg";"1"], mkLdarg (uint16 1) - ["ldarg";"2"], mkLdarg (uint16 2) - ["ldarg";"3"], mkLdarg (uint16 3) - ["ret"], I_ret - ["add"], AI_add - ["add";"ovf"], AI_add_ovf - ["add";"ovf";"un"], AI_add_ovf_un - ["and"], AI_and - ["div"], AI_div - ["div";"un"], AI_div_un - ["ceq"], AI_ceq - ["cgt"], AI_cgt - ["cgt";"un"], AI_cgt_un - ["clt"], AI_clt - ["clt";"un"], AI_clt_un - ["conv";"i1"], AI_conv DT_I1 - ["conv";"i2"], AI_conv DT_I2 - ["conv";"i4"], AI_conv DT_I4 - ["conv";"i8"], AI_conv DT_I8 - ["conv";"i"], AI_conv DT_I - ["conv";"r4"], AI_conv DT_R4 - ["conv";"r8"], AI_conv DT_R8 - ["conv";"u1"], AI_conv DT_U1 - ["conv";"u2"], AI_conv DT_U2 - ["conv";"u4"], AI_conv DT_U4 - ["conv";"u8"], AI_conv DT_U8 - ["conv";"u"], AI_conv DT_U - ["conv";"r"; "un"], AI_conv DT_R - ["conv";"ovf";"i1"], AI_conv_ovf DT_I1 - ["conv";"ovf";"i2"], AI_conv_ovf DT_I2 - ["conv";"ovf";"i4"], AI_conv_ovf DT_I4 - ["conv";"ovf";"i8"], AI_conv_ovf DT_I8 - ["conv";"ovf";"i"], AI_conv_ovf DT_I - ["conv";"ovf";"u1"], AI_conv_ovf DT_U1 - ["conv";"ovf";"u2"], AI_conv_ovf DT_U2 - ["conv";"ovf";"u4"], AI_conv_ovf DT_U4 - ["conv";"ovf";"u8"], AI_conv_ovf DT_U8 - ["conv";"ovf";"u"], AI_conv_ovf DT_U - ["conv";"ovf";"i1"; "un"], AI_conv_ovf_un DT_I1 - ["conv";"ovf";"i2"; "un"], AI_conv_ovf_un DT_I2 - ["conv";"ovf";"i4"; "un"], AI_conv_ovf_un DT_I4 - ["conv";"ovf";"i8"; "un"], AI_conv_ovf_un DT_I8 - ["conv";"ovf";"i"; "un"], AI_conv_ovf_un DT_I - ["conv";"ovf";"u1"; "un"], AI_conv_ovf_un DT_U1 - ["conv";"ovf";"u2"; "un"], AI_conv_ovf_un DT_U2 - ["conv";"ovf";"u4"; "un"], AI_conv_ovf_un DT_U4 - ["conv";"ovf";"u8"; "un"], AI_conv_ovf_un DT_U8 - ["conv";"ovf";"u"; "un"], AI_conv_ovf_un DT_U - ["stelem";"i1"], I_stelem DT_I1 - ["stelem";"i2"], I_stelem DT_I2 - ["stelem";"i4"], I_stelem DT_I4 - ["stelem";"i8"], I_stelem DT_I8 - ["stelem";"r4"], I_stelem DT_R4 - ["stelem";"r8"], I_stelem DT_R8 - ["stelem";"i"], I_stelem DT_I - ["stelem";"u"], I_stelem DT_I - ["stelem";"u8"], I_stelem DT_I8 - ["stelem";"ref"], I_stelem DT_REF - ["ldelem";"i1"], I_ldelem DT_I1 - ["ldelem";"i2"], I_ldelem DT_I2 - ["ldelem";"i4"], I_ldelem DT_I4 - ["ldelem";"i8"], I_ldelem DT_I8 - ["ldelem";"u8"], I_ldelem DT_I8 - ["ldelem";"u1"], I_ldelem DT_U1 - ["ldelem";"u2"], I_ldelem DT_U2 - ["ldelem";"u4"], I_ldelem DT_U4 - ["ldelem";"r4"], I_ldelem DT_R4 - ["ldelem";"r8"], I_ldelem DT_R8 - ["ldelem";"u"], I_ldelem DT_I // EQUIV - ["ldelem";"i"], I_ldelem DT_I - ["ldelem";"ref"], I_ldelem DT_REF - ["mul"], AI_mul - ["mul";"ovf"], AI_mul_ovf - ["mul";"ovf";"un"], AI_mul_ovf_un - ["rem"], AI_rem - ["rem";"un"], AI_rem_un - ["shl"], AI_shl - ["shr"], AI_shr - ["shr";"un"], AI_shr_un - ["sub"], AI_sub - ["sub";"ovf"], AI_sub_ovf - ["sub";"ovf";"un"], AI_sub_ovf_un - ["xor"], AI_xor - ["or"], AI_or - ["neg"], AI_neg - ["not"], AI_not - ["ldnull"], AI_ldnull - ["dup"], AI_dup - ["pop"], AI_pop - ["ckfinite"], AI_ckfinite - ["nop"], AI_nop - ["break"], I_break - ["arglist"], I_arglist - ["endfilter"], I_endfilter - ["endfinally"], I_endfinally - ["refanytype"], I_refanytype - ["localloc"], I_localloc - ["throw"], I_throw - ["ldlen"], I_ldlen - ["rethrow"], I_rethrow - ] + lazy + [ + [ "ldc"; "i4"; "0" ], mkLdcInt32 0 + [ "ldc"; "i4"; "1" ], mkLdcInt32 1 + [ "ldc"; "i4"; "2" ], mkLdcInt32 2 + [ "ldc"; "i4"; "3" ], mkLdcInt32 3 + [ "ldc"; "i4"; "4" ], mkLdcInt32 4 + [ "ldc"; "i4"; "5" ], mkLdcInt32 5 + [ "ldc"; "i4"; "6" ], mkLdcInt32 6 + [ "ldc"; "i4"; "7" ], mkLdcInt32 7 + [ "ldc"; "i4"; "8" ], mkLdcInt32 8 + [ "ldc"; "i4"; "M1" ], mkLdcInt32 -1 + [ "ldc"; "i4"; "m1" ], mkLdcInt32 -1 + [ "stloc"; "0" ], mkStloc (uint16 0) + [ "stloc"; "1" ], mkStloc (uint16 1) + [ "stloc"; "2" ], mkStloc (uint16 2) + [ "stloc"; "3" ], mkStloc (uint16 3) + [ "ldloc"; "0" ], mkLdloc (uint16 0) + [ "ldloc"; "1" ], mkLdloc (uint16 1) + [ "ldloc"; "2" ], mkLdloc (uint16 2) + [ "ldloc"; "3" ], mkLdloc (uint16 3) + [ "ldarg"; "0" ], mkLdarg (uint16 0) + [ "ldarg"; "1" ], mkLdarg (uint16 1) + [ "ldarg"; "2" ], mkLdarg (uint16 2) + [ "ldarg"; "3" ], mkLdarg (uint16 3) + [ "ret" ], I_ret + [ "add" ], AI_add + [ "add"; "ovf" ], AI_add_ovf + [ "add"; "ovf"; "un" ], AI_add_ovf_un + [ "and" ], AI_and + [ "div" ], AI_div + [ "div"; "un" ], AI_div_un + [ "ceq" ], AI_ceq + [ "cgt" ], AI_cgt + [ "cgt"; "un" ], AI_cgt_un + [ "clt" ], AI_clt + [ "clt"; "un" ], AI_clt_un + [ "conv"; "i1" ], AI_conv DT_I1 + [ "conv"; "i2" ], AI_conv DT_I2 + [ "conv"; "i4" ], AI_conv DT_I4 + [ "conv"; "i8" ], AI_conv DT_I8 + [ "conv"; "i" ], AI_conv DT_I + [ "conv"; "r4" ], AI_conv DT_R4 + [ "conv"; "r8" ], AI_conv DT_R8 + [ "conv"; "u1" ], AI_conv DT_U1 + [ "conv"; "u2" ], AI_conv DT_U2 + [ "conv"; "u4" ], AI_conv DT_U4 + [ "conv"; "u8" ], AI_conv DT_U8 + [ "conv"; "u" ], AI_conv DT_U + [ "conv"; "r"; "un" ], AI_conv DT_R + [ "conv"; "ovf"; "i1" ], AI_conv_ovf DT_I1 + [ "conv"; "ovf"; "i2" ], AI_conv_ovf DT_I2 + [ "conv"; "ovf"; "i4" ], AI_conv_ovf DT_I4 + [ "conv"; "ovf"; "i8" ], AI_conv_ovf DT_I8 + [ "conv"; "ovf"; "i" ], AI_conv_ovf DT_I + [ "conv"; "ovf"; "u1" ], AI_conv_ovf DT_U1 + [ "conv"; "ovf"; "u2" ], AI_conv_ovf DT_U2 + [ "conv"; "ovf"; "u4" ], AI_conv_ovf DT_U4 + [ "conv"; "ovf"; "u8" ], AI_conv_ovf DT_U8 + [ "conv"; "ovf"; "u" ], AI_conv_ovf DT_U + [ "conv"; "ovf"; "i1"; "un" ], AI_conv_ovf_un DT_I1 + [ "conv"; "ovf"; "i2"; "un" ], AI_conv_ovf_un DT_I2 + [ "conv"; "ovf"; "i4"; "un" ], AI_conv_ovf_un DT_I4 + [ "conv"; "ovf"; "i8"; "un" ], AI_conv_ovf_un DT_I8 + [ "conv"; "ovf"; "i"; "un" ], AI_conv_ovf_un DT_I + [ "conv"; "ovf"; "u1"; "un" ], AI_conv_ovf_un DT_U1 + [ "conv"; "ovf"; "u2"; "un" ], AI_conv_ovf_un DT_U2 + [ "conv"; "ovf"; "u4"; "un" ], AI_conv_ovf_un DT_U4 + [ "conv"; "ovf"; "u8"; "un" ], AI_conv_ovf_un DT_U8 + [ "conv"; "ovf"; "u"; "un" ], AI_conv_ovf_un DT_U + [ "stelem"; "i1" ], I_stelem DT_I1 + [ "stelem"; "i2" ], I_stelem DT_I2 + [ "stelem"; "i4" ], I_stelem DT_I4 + [ "stelem"; "i8" ], I_stelem DT_I8 + [ "stelem"; "r4" ], I_stelem DT_R4 + [ "stelem"; "r8" ], I_stelem DT_R8 + [ "stelem"; "i" ], I_stelem DT_I + [ "stelem"; "u" ], I_stelem DT_I + [ "stelem"; "u8" ], I_stelem DT_I8 + [ "stelem"; "ref" ], I_stelem DT_REF + [ "ldelem"; "i1" ], I_ldelem DT_I1 + [ "ldelem"; "i2" ], I_ldelem DT_I2 + [ "ldelem"; "i4" ], I_ldelem DT_I4 + [ "ldelem"; "i8" ], I_ldelem DT_I8 + [ "ldelem"; "u8" ], I_ldelem DT_I8 + [ "ldelem"; "u1" ], I_ldelem DT_U1 + [ "ldelem"; "u2" ], I_ldelem DT_U2 + [ "ldelem"; "u4" ], I_ldelem DT_U4 + [ "ldelem"; "r4" ], I_ldelem DT_R4 + [ "ldelem"; "r8" ], I_ldelem DT_R8 + [ "ldelem"; "u" ], I_ldelem DT_I // EQUIV + [ "ldelem"; "i" ], I_ldelem DT_I + [ "ldelem"; "ref" ], I_ldelem DT_REF + [ "mul" ], AI_mul + [ "mul"; "ovf" ], AI_mul_ovf + [ "mul"; "ovf"; "un" ], AI_mul_ovf_un + [ "rem" ], AI_rem + [ "rem"; "un" ], AI_rem_un + [ "shl" ], AI_shl + [ "shr" ], AI_shr + [ "shr"; "un" ], AI_shr_un + [ "sub" ], AI_sub + [ "sub"; "ovf" ], AI_sub_ovf + [ "sub"; "ovf"; "un" ], AI_sub_ovf_un + [ "xor" ], AI_xor + [ "or" ], AI_or + [ "neg" ], AI_neg + [ "not" ], AI_not + [ "ldnull" ], AI_ldnull + [ "dup" ], AI_dup + [ "pop" ], AI_pop + [ "ckfinite" ], AI_ckfinite + [ "nop" ], AI_nop + [ "break" ], I_break + [ "arglist" ], I_arglist + [ "endfilter" ], I_endfilter + [ "endfinally" ], I_endfinally + [ "refanytype" ], I_refanytype + [ "localloc" ], I_localloc + [ "throw" ], I_throw + [ "ldlen" ], I_ldlen + [ "rethrow" ], I_rethrow + ] #if DEBUG let wordsOfNoArgInstr, isNoArgInstr = let t = - lazy - (let t = HashMultiMap(300, HashIdentity.Structural) - noArgInstrs |> Lazy.force |> List.iter (fun (x, mk) -> t.Add(mk, x)) - t) - (fun s -> (Lazy.force t)[s]), - (fun s -> (Lazy.force t).ContainsKey s) + lazy + (let t = HashMultiMap(300, HashIdentity.Structural) + noArgInstrs |> Lazy.force |> List.iter (fun (x, mk) -> t.Add(mk, x)) + t) + + (fun s -> (Lazy.force t)[s]), (fun s -> (Lazy.force t).ContainsKey s) #endif -let mk_stind (nm, dt) = (nm, (fun () -> I_stind(Aligned, Nonvolatile, dt))) -let mk_ldind (nm, dt) = (nm, (fun () -> I_ldind(Aligned, Nonvolatile, dt))) +let mk_stind (nm, dt) = + (nm, (fun () -> I_stind(Aligned, Nonvolatile, dt))) + +let mk_ldind (nm, dt) = + (nm, (fun () -> I_ldind(Aligned, Nonvolatile, dt))) type NoArgInstr = unit -> ILInstr -type Int32Instr = int32 -> ILInstr -type Int32Int32Instr = int32 * int32 -> ILInstr -type Int64Instr = int64 -> ILInstr -type DoubleInstr = ILConst -> ILInstr -type MethodSpecInstr = ILMethodSpec * ILVarArgs -> ILInstr -type TypeInstr = ILType -> ILInstr -type IntTypeInstr = int * ILType -> ILInstr -type ValueTypeInstr = ILType -> ILInstr (* nb. diff. interp of types to TypeInstr *) -type StringInstr = string -> ILInstr -type TokenInstr = ILToken -> ILInstr -type SwitchInstr = ILCodeLabel list * ILCodeLabel -> ILInstr +type Int32Instr = int32 -> ILInstr +type Int32Int32Instr = int32 * int32 -> ILInstr +type Int64Instr = int64 -> ILInstr +type DoubleInstr = ILConst -> ILInstr +type MethodSpecInstr = ILMethodSpec * ILVarArgs -> ILInstr +type TypeInstr = ILType -> ILInstr +type IntTypeInstr = int * ILType -> ILInstr +type ValueTypeInstr = ILType -> ILInstr (* nb. diff. interp of types to TypeInstr *) +type StringInstr = string -> ILInstr +type TokenInstr = ILToken -> ILInstr +type SwitchInstr = ILCodeLabel list * ILCodeLabel -> ILInstr type InstrTable<'T> = (string list * 'T) list type LazyInstrTable<'T> = Lazy> /// Table of parsing and pretty printing data for instructions. -let NoArgInstrs : Lazy> = - lazy [ - for nm, i in noArgInstrs.Force() do - yield (nm, (fun () -> i)) - yield mk_stind (["stind";"u"], DT_I) - yield mk_stind (["stind";"i"], DT_I) - yield mk_stind (["stind";"u1"], DT_I1) - yield mk_stind (["stind";"i1"], DT_I1) - yield mk_stind (["stind";"u2"], DT_I2) - yield mk_stind (["stind";"i2"], DT_I2) - yield mk_stind (["stind";"u4"], DT_I4) - yield mk_stind (["stind";"i4"], DT_I4) - yield mk_stind (["stind";"u8"], DT_I8) - yield mk_stind (["stind";"i8"], DT_I8) - yield mk_stind (["stind";"r4"], DT_R4) - yield mk_stind (["stind";"r8"], DT_R8) - yield mk_stind (["stind";"ref"], DT_REF) - yield mk_ldind (["ldind";"i"], DT_I) - yield mk_ldind (["ldind";"i1"], DT_I1) - yield mk_ldind (["ldind";"i2"], DT_I2) - yield mk_ldind (["ldind";"i4"], DT_I4) - yield mk_ldind (["ldind";"i8"], DT_I8) - yield mk_ldind (["ldind";"u1"], DT_U1) - yield mk_ldind (["ldind";"u2"], DT_U2) - yield mk_ldind (["ldind";"u4"], DT_U4) - yield mk_ldind (["ldind";"u8"], DT_I8) - yield mk_ldind (["ldind";"r4"], DT_R4) - yield mk_ldind (["ldind";"r8"], DT_R8) - yield mk_ldind (["ldind";"ref"], DT_REF) - yield ["cpblk"], (fun () -> I_cpblk(Aligned, Nonvolatile)) - yield ["initblk"], (fun () -> I_initblk(Aligned, Nonvolatile)) - ] +let NoArgInstrs: Lazy> = + lazy + [ + for nm, i in noArgInstrs.Force() do + yield (nm, (fun () -> i)) + yield mk_stind ([ "stind"; "u" ], DT_I) + yield mk_stind ([ "stind"; "i" ], DT_I) + yield mk_stind ([ "stind"; "u1" ], DT_I1) + yield mk_stind ([ "stind"; "i1" ], DT_I1) + yield mk_stind ([ "stind"; "u2" ], DT_I2) + yield mk_stind ([ "stind"; "i2" ], DT_I2) + yield mk_stind ([ "stind"; "u4" ], DT_I4) + yield mk_stind ([ "stind"; "i4" ], DT_I4) + yield mk_stind ([ "stind"; "u8" ], DT_I8) + yield mk_stind ([ "stind"; "i8" ], DT_I8) + yield mk_stind ([ "stind"; "r4" ], DT_R4) + yield mk_stind ([ "stind"; "r8" ], DT_R8) + yield mk_stind ([ "stind"; "ref" ], DT_REF) + yield mk_ldind ([ "ldind"; "i" ], DT_I) + yield mk_ldind ([ "ldind"; "i1" ], DT_I1) + yield mk_ldind ([ "ldind"; "i2" ], DT_I2) + yield mk_ldind ([ "ldind"; "i4" ], DT_I4) + yield mk_ldind ([ "ldind"; "i8" ], DT_I8) + yield mk_ldind ([ "ldind"; "u1" ], DT_U1) + yield mk_ldind ([ "ldind"; "u2" ], DT_U2) + yield mk_ldind ([ "ldind"; "u4" ], DT_U4) + yield mk_ldind ([ "ldind"; "u8" ], DT_I8) + yield mk_ldind ([ "ldind"; "r4" ], DT_R4) + yield mk_ldind ([ "ldind"; "r8" ], DT_R8) + yield mk_ldind ([ "ldind"; "ref" ], DT_REF) + yield [ "cpblk" ], (fun () -> I_cpblk(Aligned, Nonvolatile)) + yield [ "initblk" ], (fun () -> I_initblk(Aligned, Nonvolatile)) + ] /// Table of parsing and pretty printing data for instructions. -let Int64Instrs : Lazy> = - lazy [ - ["ldc";"i8"], (fun x -> AI_ldc (DT_I8, ILConst.I8 x)) - ] +let Int64Instrs: Lazy> = + lazy [ [ "ldc"; "i8" ], (fun x -> AI_ldc(DT_I8, ILConst.I8 x)) ] /// Table of parsing and pretty printing data for instructions. -let Int32Instrs : Lazy> = - lazy [ - ["ldc";"i4"], mkLdcInt32 - ["ldc";"i4";"s"], mkLdcInt32 - ] +let Int32Instrs: Lazy> = + lazy [ [ "ldc"; "i4" ], mkLdcInt32; [ "ldc"; "i4"; "s" ], mkLdcInt32 ] /// Table of parsing and pretty printing data for instructions. -let Int32Int32Instrs : Lazy> = - lazy [ - ["ldlen";"multi"], EI_ldlen_multi - ] +let Int32Int32Instrs: Lazy> = + lazy [ [ "ldlen"; "multi" ], EI_ldlen_multi ] /// Table of parsing and pretty printing data for instructions. -let DoubleInstrs : Lazy> = - lazy [ - ["ldc";"r4"], (fun x -> (AI_ldc (DT_R4, x))) - ["ldc";"r8"], (fun x -> (AI_ldc (DT_R8, x))) - ] +let DoubleInstrs: Lazy> = + lazy + [ + [ "ldc"; "r4" ], (fun x -> (AI_ldc(DT_R4, x))) + [ "ldc"; "r8" ], (fun x -> (AI_ldc(DT_R8, x))) + ] /// Table of parsing and pretty printing data for instructions. -let StringInstrs : Lazy> = - lazy [ - ["ldstr"], I_ldstr - ] +let StringInstrs: Lazy> = lazy [ [ "ldstr" ], I_ldstr ] /// Table of parsing and pretty printing data for instructions. -let TokenInstrs : Lazy> = - lazy [ - ["ldtoken"], I_ldtoken - ] +let TokenInstrs: Lazy> = lazy [ [ "ldtoken" ], I_ldtoken ] /// Table of parsing and pretty printing data for instructions. -let TypeInstrs : Lazy> = - lazy [ - ["ldelema"], (fun x -> I_ldelema (NormalAddress, false, ILArrayShape.SingleDimensional, x)) - ["ldelem";"any"], (fun x -> I_ldelem_any (ILArrayShape.SingleDimensional, x)) - ["stelem";"any"], (fun x -> I_stelem_any (ILArrayShape.SingleDimensional, x)) - ["newarr"], (fun x -> I_newarr (ILArrayShape.SingleDimensional, x)) - ["castclass"], I_castclass - ["ilzero"], EI_ilzero - ["isinst"], I_isinst - ["initobj";"any"], I_initobj - ["unbox";"any"], I_unbox_any - ] +let TypeInstrs: Lazy> = + lazy + [ + [ "ldelema" ], (fun x -> I_ldelema(NormalAddress, false, ILArrayShape.SingleDimensional, x)) + [ "ldelem"; "any" ], (fun x -> I_ldelem_any(ILArrayShape.SingleDimensional, x)) + [ "stelem"; "any" ], (fun x -> I_stelem_any(ILArrayShape.SingleDimensional, x)) + [ "newarr" ], (fun x -> I_newarr(ILArrayShape.SingleDimensional, x)) + [ "castclass" ], I_castclass + [ "ilzero" ], EI_ilzero + [ "isinst" ], I_isinst + [ "initobj"; "any" ], I_initobj + [ "unbox"; "any" ], I_unbox_any + ] /// Table of parsing and pretty printing data for instructions. -let IntTypeInstrs : Lazy> = - lazy [ - ["ldelem";"multi"], (fun (x, y) -> (I_ldelem_any (ILArrayShape.FromRank x, y))) - ["stelem";"multi"], (fun (x, y) -> (I_stelem_any (ILArrayShape.FromRank x, y))) - ["newarr";"multi"], (fun (x, y) -> (I_newarr (ILArrayShape.FromRank x, y))) - ["ldelema";"multi"], (fun (x, y) -> (I_ldelema (NormalAddress, false, ILArrayShape.FromRank x, y))) - ] +let IntTypeInstrs: Lazy> = + lazy + [ + [ "ldelem"; "multi" ], (fun (x, y) -> (I_ldelem_any(ILArrayShape.FromRank x, y))) + [ "stelem"; "multi" ], (fun (x, y) -> (I_stelem_any(ILArrayShape.FromRank x, y))) + [ "newarr"; "multi" ], (fun (x, y) -> (I_newarr(ILArrayShape.FromRank x, y))) + [ "ldelema"; "multi" ], (fun (x, y) -> (I_ldelema(NormalAddress, false, ILArrayShape.FromRank x, y))) + ] /// Table of parsing and pretty printing data for instructions. -let ValueTypeInstrs : Lazy> = - lazy [ - ["cpobj"], I_cpobj - ["initobj"], I_initobj - ["ldobj"], (fun z -> I_ldobj (Aligned, Nonvolatile, z)) - ["stobj"], (fun z -> I_stobj (Aligned, Nonvolatile, z)) - ["sizeof"], I_sizeof - ["box"], I_box - ["unbox"], I_unbox - ] - +let ValueTypeInstrs: Lazy> = + lazy + [ + [ "cpobj" ], I_cpobj + [ "initobj" ], I_initobj + [ "ldobj" ], (fun z -> I_ldobj(Aligned, Nonvolatile, z)) + [ "stobj" ], (fun z -> I_stobj(Aligned, Nonvolatile, z)) + [ "sizeof" ], I_sizeof + [ "box" ], I_box + [ "unbox" ], I_unbox + ] diff --git a/src/Compiler/AbstractIL/ilbinary.fs b/src/Compiler/AbstractIL/ilbinary.fs index 18f15bc62..f07c714bb 100644 --- a/src/Compiler/AbstractIL/ilbinary.fs +++ b/src/Compiler/AbstractIL/ilbinary.fs @@ -1,283 +1,313 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -module internal FSharp.Compiler.AbstractIL.BinaryConstants +module internal FSharp.Compiler.AbstractIL.BinaryConstants -open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.AbstractIL.IL open Internal.Utilities.Library [] -type TableName(idx: int) = +type TableName(idx: int) = member x.Index = idx - static member FromIndex n = TableName n - -module TableNames = - let Module = TableName 0 - let TypeRef = TableName 1 - let TypeDef = TableName 2 - let FieldPtr = TableName 3 - let Field = TableName 4 - let MethodPtr = TableName 5 - let Method = TableName 6 - let ParamPtr = TableName 7 - let Param = TableName 8 - let InterfaceImpl = TableName 9 - let MemberRef = TableName 10 - let Constant = TableName 11 - let CustomAttribute = TableName 12 - let FieldMarshal = TableName 13 - let Permission = TableName 14 - let ClassLayout = TableName 15 - let FieldLayout = TableName 16 - let StandAloneSig = TableName 17 - let EventMap = TableName 18 - let EventPtr = TableName 19 - let Event = TableName 20 - let PropertyMap = TableName 21 - let PropertyPtr = TableName 22 - let Property = TableName 23 - let MethodSemantics = TableName 24 - let MethodImpl = TableName 25 - let ModuleRef = TableName 26 - let TypeSpec = TableName 27 - let ImplMap = TableName 28 - let FieldRVA = TableName 29 - let ENCLog = TableName 30 - let ENCMap = TableName 31 - let Assembly = TableName 32 - let AssemblyProcessor = TableName 33 - let AssemblyOS = TableName 34 - let AssemblyRef = TableName 35 - let AssemblyRefProcessor = TableName 36 - let AssemblyRefOS = TableName 37 - let File = TableName 38 - let ExportedType = TableName 39 - let ManifestResource = TableName 40 - let Nested = TableName 41 - let GenericParam = TableName 42 - let MethodSpec = TableName 43 + static member FromIndex n = TableName n + +module TableNames = + let Module = TableName 0 + let TypeRef = TableName 1 + let TypeDef = TableName 2 + let FieldPtr = TableName 3 + let Field = TableName 4 + let MethodPtr = TableName 5 + let Method = TableName 6 + let ParamPtr = TableName 7 + let Param = TableName 8 + let InterfaceImpl = TableName 9 + let MemberRef = TableName 10 + let Constant = TableName 11 + let CustomAttribute = TableName 12 + let FieldMarshal = TableName 13 + let Permission = TableName 14 + let ClassLayout = TableName 15 + let FieldLayout = TableName 16 + let StandAloneSig = TableName 17 + let EventMap = TableName 18 + let EventPtr = TableName 19 + let Event = TableName 20 + let PropertyMap = TableName 21 + let PropertyPtr = TableName 22 + let Property = TableName 23 + let MethodSemantics = TableName 24 + let MethodImpl = TableName 25 + let ModuleRef = TableName 26 + let TypeSpec = TableName 27 + let ImplMap = TableName 28 + let FieldRVA = TableName 29 + let ENCLog = TableName 30 + let ENCMap = TableName 31 + let Assembly = TableName 32 + let AssemblyProcessor = TableName 33 + let AssemblyOS = TableName 34 + let AssemblyRef = TableName 35 + let AssemblyRefProcessor = TableName 36 + let AssemblyRefOS = TableName 37 + let File = TableName 38 + let ExportedType = TableName 39 + let ManifestResource = TableName 40 + let Nested = TableName 41 + let GenericParam = TableName 42 + let MethodSpec = TableName 43 let GenericParamConstraint = TableName 44 - let UserStrings = TableName 0x70 (* Special encoding of embedded UserString tokens - See 1.9 Partition III *) + let UserStrings = + TableName 0x70 (* Special encoding of embedded UserString tokens - See 1.9 Partition III *) -/// Which tables are sorted and by which column. +/// Which tables are sorted and by which column. // -// Sorted bit-vector as stored by CLR V1: 00fa 0133 0002 0000 -// But what does this mean? The ECMA spec does not say! -// Metainfo -schema reports sorting as shown below. -// But some sorting, e.g. EventMap does not seem to show -let sortedTableInfo = - [ (TableNames.InterfaceImpl,0) - (TableNames.Constant, 1) - (TableNames.CustomAttribute, 0) - (TableNames.FieldMarshal, 0) - (TableNames.Permission, 1) - (TableNames.ClassLayout, 2) - (TableNames.FieldLayout, 1) - (TableNames.MethodSemantics, 2) - (TableNames.MethodImpl, 0) - (TableNames.ImplMap, 1) - (TableNames.FieldRVA, 1) - (TableNames.Nested, 0) - (TableNames.GenericParam, 2) - (TableNames.GenericParamConstraint, 0) ] - +// Sorted bit-vector as stored by CLR V1: 00fa 0133 0002 0000 +// But what does this mean? The ECMA spec does not say! +// Metainfo -schema reports sorting as shown below. +// But some sorting, e.g. EventMap does not seem to show +let sortedTableInfo = + [ + (TableNames.InterfaceImpl, 0) + (TableNames.Constant, 1) + (TableNames.CustomAttribute, 0) + (TableNames.FieldMarshal, 0) + (TableNames.Permission, 1) + (TableNames.ClassLayout, 2) + (TableNames.FieldLayout, 1) + (TableNames.MethodSemantics, 2) + (TableNames.MethodImpl, 0) + (TableNames.ImplMap, 1) + (TableNames.FieldRVA, 1) + (TableNames.Nested, 0) + (TableNames.GenericParam, 2) + (TableNames.GenericParamConstraint, 0) + ] + [] -type TypeDefOrRefTag(tag: int32) = member x.Tag = tag +type TypeDefOrRefTag(tag: int32) = + member x.Tag = tag + let tdor_TypeDef = TypeDefOrRefTag 0x00 let tdor_TypeRef = TypeDefOrRefTag 0x01 let tdor_TypeSpec = TypeDefOrRefTag 0x2 -let mkTypeDefOrRefOrSpecTag x = - match x with - | 0x00 -> tdor_TypeDef // nb. avoid reallocation + +let mkTypeDefOrRefOrSpecTag x = + match x with + | 0x00 -> tdor_TypeDef // nb. avoid reallocation | 0x01 -> tdor_TypeRef | 0x02 -> tdor_TypeSpec | _ -> invalidArg "x" "mkTypeDefOrRefOrSpecTag" [] -type HasConstantTag(tag: int32) = member x.Tag = tag -let hc_FieldDef = HasConstantTag 0x0 -let hc_ParamDef = HasConstantTag 0x1 +type HasConstantTag(tag: int32) = + member x.Tag = tag + +let hc_FieldDef = HasConstantTag 0x0 +let hc_ParamDef = HasConstantTag 0x1 let hc_Property = HasConstantTag 0x2 -let mkHasConstantTag x = - match x with +let mkHasConstantTag x = + match x with | 0x00 -> hc_FieldDef | 0x01 -> hc_ParamDef | 0x02 -> hc_Property | _ -> invalidArg "x" "mkHasConstantTag" [] -type HasCustomAttributeTag(tag: int32) = member x.Tag = tag -let hca_MethodDef = HasCustomAttributeTag 0x0 -let hca_FieldDef = HasCustomAttributeTag 0x1 -let hca_TypeRef = HasCustomAttributeTag 0x2 -let hca_TypeDef = HasCustomAttributeTag 0x3 -let hca_ParamDef = HasCustomAttributeTag 0x4 -let hca_InterfaceImpl = HasCustomAttributeTag 0x5 -let hca_MemberRef = HasCustomAttributeTag 0x6 -let hca_Module = HasCustomAttributeTag 0x7 -let hca_Permission = HasCustomAttributeTag 0x8 -let hca_Property = HasCustomAttributeTag 0x9 -let hca_Event = HasCustomAttributeTag 0xa -let hca_StandAloneSig = HasCustomAttributeTag 0xb -let hca_ModuleRef = HasCustomAttributeTag 0xc -let hca_TypeSpec = HasCustomAttributeTag 0xd -let hca_Assembly = HasCustomAttributeTag 0xe -let hca_AssemblyRef = HasCustomAttributeTag 0xf -let hca_File = HasCustomAttributeTag 0x10 -let hca_ExportedType = HasCustomAttributeTag 0x11 -let hca_ManifestResource = HasCustomAttributeTag 0x12 -let hca_GenericParam = HasCustomAttributeTag 0x13 -let hca_GenericParamConstraint = HasCustomAttributeTag 0x14 -let hca_MethodSpec = HasCustomAttributeTag 0x15 - -let mkHasCustomAttributeTag x = - match x with - | 0x00 -> hca_MethodDef - | 0x01 -> hca_FieldDef - | 0x02 -> hca_TypeRef - | 0x03 -> hca_TypeDef - | 0x04 -> hca_ParamDef - | 0x05 -> hca_InterfaceImpl - | 0x06 -> hca_MemberRef - | 0x07 -> hca_Module - | 0x08 -> hca_Permission - | 0x09 -> hca_Property - | 0x0a -> hca_Event - | 0x0b -> hca_StandAloneSig - | 0x0c -> hca_ModuleRef - | 0x0d -> hca_TypeSpec - | 0x0e -> hca_Assembly - | 0x0f -> hca_AssemblyRef - | 0x10 -> hca_File - | 0x11 -> hca_ExportedType +type HasCustomAttributeTag(tag: int32) = + member x.Tag = tag + +let hca_MethodDef = HasCustomAttributeTag 0x0 +let hca_FieldDef = HasCustomAttributeTag 0x1 +let hca_TypeRef = HasCustomAttributeTag 0x2 +let hca_TypeDef = HasCustomAttributeTag 0x3 +let hca_ParamDef = HasCustomAttributeTag 0x4 +let hca_InterfaceImpl = HasCustomAttributeTag 0x5 +let hca_MemberRef = HasCustomAttributeTag 0x6 +let hca_Module = HasCustomAttributeTag 0x7 +let hca_Permission = HasCustomAttributeTag 0x8 +let hca_Property = HasCustomAttributeTag 0x9 +let hca_Event = HasCustomAttributeTag 0xa +let hca_StandAloneSig = HasCustomAttributeTag 0xb +let hca_ModuleRef = HasCustomAttributeTag 0xc +let hca_TypeSpec = HasCustomAttributeTag 0xd +let hca_Assembly = HasCustomAttributeTag 0xe +let hca_AssemblyRef = HasCustomAttributeTag 0xf +let hca_File = HasCustomAttributeTag 0x10 +let hca_ExportedType = HasCustomAttributeTag 0x11 +let hca_ManifestResource = HasCustomAttributeTag 0x12 +let hca_GenericParam = HasCustomAttributeTag 0x13 +let hca_GenericParamConstraint = HasCustomAttributeTag 0x14 +let hca_MethodSpec = HasCustomAttributeTag 0x15 + +let mkHasCustomAttributeTag x = + match x with + | 0x00 -> hca_MethodDef + | 0x01 -> hca_FieldDef + | 0x02 -> hca_TypeRef + | 0x03 -> hca_TypeDef + | 0x04 -> hca_ParamDef + | 0x05 -> hca_InterfaceImpl + | 0x06 -> hca_MemberRef + | 0x07 -> hca_Module + | 0x08 -> hca_Permission + | 0x09 -> hca_Property + | 0x0a -> hca_Event + | 0x0b -> hca_StandAloneSig + | 0x0c -> hca_ModuleRef + | 0x0d -> hca_TypeSpec + | 0x0e -> hca_Assembly + | 0x0f -> hca_AssemblyRef + | 0x10 -> hca_File + | 0x11 -> hca_ExportedType | 0x12 -> hca_ManifestResource | 0x13 -> hca_GenericParam | 0x14 -> hca_GenericParamConstraint - | 0x15 -> hca_MethodSpec + | 0x15 -> hca_MethodSpec | _ -> HasCustomAttributeTag x [] -type HasFieldMarshalTag(tag: int32) = member x.Tag = tag -let hfm_FieldDef = HasFieldMarshalTag 0x00 -let hfm_ParamDef = HasFieldMarshalTag 0x01 - -let mkHasFieldMarshalTag x = - match x with - | 0x00 -> hfm_FieldDef - | 0x01 -> hfm_ParamDef +type HasFieldMarshalTag(tag: int32) = + member x.Tag = tag + +let hfm_FieldDef = HasFieldMarshalTag 0x00 +let hfm_ParamDef = HasFieldMarshalTag 0x01 + +let mkHasFieldMarshalTag x = + match x with + | 0x00 -> hfm_FieldDef + | 0x01 -> hfm_ParamDef | _ -> HasFieldMarshalTag x [] -type HasDeclSecurityTag(tag: int32) = member x.Tag = tag -let hds_TypeDef = HasDeclSecurityTag 0x00 -let hds_MethodDef = HasDeclSecurityTag 0x01 -let hds_Assembly = HasDeclSecurityTag 0x02 - -let mkHasDeclSecurityTag x = - match x with - | 0x00 -> hds_TypeDef - | 0x01 -> hds_MethodDef - | 0x02 -> hds_Assembly +type HasDeclSecurityTag(tag: int32) = + member x.Tag = tag + +let hds_TypeDef = HasDeclSecurityTag 0x00 +let hds_MethodDef = HasDeclSecurityTag 0x01 +let hds_Assembly = HasDeclSecurityTag 0x02 + +let mkHasDeclSecurityTag x = + match x with + | 0x00 -> hds_TypeDef + | 0x01 -> hds_MethodDef + | 0x02 -> hds_Assembly | _ -> HasDeclSecurityTag x [] -type MemberRefParentTag(tag: int32) = member x.Tag = tag +type MemberRefParentTag(tag: int32) = + member x.Tag = tag + let mrp_TypeRef = MemberRefParentTag 0x01 let mrp_ModuleRef = MemberRefParentTag 0x02 let mrp_MethodDef = MemberRefParentTag 0x03 -let mrp_TypeSpec = MemberRefParentTag 0x04 - -let mkMemberRefParentTag x = - match x with - | 0x01 -> mrp_TypeRef - | 0x02 -> mrp_ModuleRef - | 0x03 -> mrp_MethodDef - | 0x04 -> mrp_TypeSpec +let mrp_TypeSpec = MemberRefParentTag 0x04 + +let mkMemberRefParentTag x = + match x with + | 0x01 -> mrp_TypeRef + | 0x02 -> mrp_ModuleRef + | 0x03 -> mrp_MethodDef + | 0x04 -> mrp_TypeSpec | _ -> MemberRefParentTag x [] -type HasSemanticsTag(tag: int32) = member x.Tag = tag -let hs_Event = HasSemanticsTag 0x00 -let hs_Property = HasSemanticsTag 0x01 - -let mkHasSemanticsTag x = - match x with - | 0x00 -> hs_Event - | 0x01 -> hs_Property +type HasSemanticsTag(tag: int32) = + member x.Tag = tag + +let hs_Event = HasSemanticsTag 0x00 +let hs_Property = HasSemanticsTag 0x01 + +let mkHasSemanticsTag x = + match x with + | 0x00 -> hs_Event + | 0x01 -> hs_Property | _ -> HasSemanticsTag x [] -type MethodDefOrRefTag(tag: int32) = member x.Tag = tag -let mdor_MethodDef = MethodDefOrRefTag 0x00 -let mdor_MemberRef = MethodDefOrRefTag 0x01 -let mdor_MethodSpec = MethodDefOrRefTag 0x02 - -let mkMethodDefOrRefTag x = - match x with - | 0x00 -> mdor_MethodDef - | 0x01 -> mdor_MemberRef - | 0x02 -> mdor_MethodSpec +type MethodDefOrRefTag(tag: int32) = + member x.Tag = tag + +let mdor_MethodDef = MethodDefOrRefTag 0x00 +let mdor_MemberRef = MethodDefOrRefTag 0x01 +let mdor_MethodSpec = MethodDefOrRefTag 0x02 + +let mkMethodDefOrRefTag x = + match x with + | 0x00 -> mdor_MethodDef + | 0x01 -> mdor_MemberRef + | 0x02 -> mdor_MethodSpec | _ -> MethodDefOrRefTag x [] -type MemberForwardedTag(tag: int32) = member x.Tag = tag -let mf_FieldDef = MemberForwardedTag 0x00 -let mf_MethodDef = MemberForwardedTag 0x01 - -let mkMemberForwardedTag x = - match x with - | 0x00 -> mf_FieldDef - | 0x01 -> mf_MethodDef +type MemberForwardedTag(tag: int32) = + member x.Tag = tag + +let mf_FieldDef = MemberForwardedTag 0x00 +let mf_MethodDef = MemberForwardedTag 0x01 + +let mkMemberForwardedTag x = + match x with + | 0x00 -> mf_FieldDef + | 0x01 -> mf_MethodDef | _ -> MemberForwardedTag x [] -type ImplementationTag(tag: int32) = member x.Tag = tag -let i_File = ImplementationTag 0x00 -let i_AssemblyRef = ImplementationTag 0x01 -let i_ExportedType = ImplementationTag 0x02 - -let mkImplementationTag x = - match x with - | 0x00 -> i_File - | 0x01 -> i_AssemblyRef - | 0x02 -> i_ExportedType +type ImplementationTag(tag: int32) = + member x.Tag = tag + +let i_File = ImplementationTag 0x00 +let i_AssemblyRef = ImplementationTag 0x01 +let i_ExportedType = ImplementationTag 0x02 + +let mkImplementationTag x = + match x with + | 0x00 -> i_File + | 0x01 -> i_AssemblyRef + | 0x02 -> i_ExportedType | _ -> ImplementationTag x [] -type CustomAttributeTypeTag(tag: int32) = member x.Tag = tag -let cat_MethodDef = CustomAttributeTypeTag 0x02 -let cat_MemberRef = CustomAttributeTypeTag 0x03 - -let mkILCustomAttributeTypeTag x = - match x with - | 0x02 -> cat_MethodDef - | 0x03 -> cat_MemberRef +type CustomAttributeTypeTag(tag: int32) = + member x.Tag = tag + +let cat_MethodDef = CustomAttributeTypeTag 0x02 +let cat_MemberRef = CustomAttributeTypeTag 0x03 + +let mkILCustomAttributeTypeTag x = + match x with + | 0x02 -> cat_MethodDef + | 0x03 -> cat_MemberRef | _ -> CustomAttributeTypeTag x [] -type ResolutionScopeTag(tag: int32) = member x.Tag = tag -let rs_Module = ResolutionScopeTag 0x00 -let rs_ModuleRef = ResolutionScopeTag 0x01 -let rs_AssemblyRef = ResolutionScopeTag 0x02 -let rs_TypeRef = ResolutionScopeTag 0x03 - -let mkResolutionScopeTag x = - match x with - | 0x00 -> rs_Module - | 0x01 -> rs_ModuleRef - | 0x02 -> rs_AssemblyRef - | 0x03 -> rs_TypeRef +type ResolutionScopeTag(tag: int32) = + member x.Tag = tag + +let rs_Module = ResolutionScopeTag 0x00 +let rs_ModuleRef = ResolutionScopeTag 0x01 +let rs_AssemblyRef = ResolutionScopeTag 0x02 +let rs_TypeRef = ResolutionScopeTag 0x03 + +let mkResolutionScopeTag x = + match x with + | 0x00 -> rs_Module + | 0x01 -> rs_ModuleRef + | 0x02 -> rs_AssemblyRef + | 0x03 -> rs_TypeRef | _ -> ResolutionScopeTag x [] -type TypeOrMethodDefTag(tag: int32) = member x.Tag = tag +type TypeOrMethodDefTag(tag: int32) = + member x.Tag = tag + let tomd_TypeDef = TypeOrMethodDefTag 0x00 let tomd_MethodDef = TypeOrMethodDefTag 0x01 -let mkTypeOrMethodDefTag x = - match x with - | 0x00 -> tomd_TypeDef +let mkTypeOrMethodDefTag x = + match x with + | 0x00 -> tomd_TypeDef | 0x01 -> tomd_MethodDef | _ -> TypeOrMethodDefTag x @@ -298,544 +328,546 @@ let et_R8 = 0x0Duy let et_STRING = 0x0Euy let et_PTR = 0x0Fuy let et_BYREF = 0x10uy -let et_VALUETYPE = 0x11uy -let et_CLASS = 0x12uy -let et_VAR = 0x13uy -let et_ARRAY = 0x14uy -let et_WITH = 0x15uy -let et_TYPEDBYREF = 0x16uy -let et_I = 0x18uy -let et_U = 0x19uy -let et_FNPTR = 0x1Buy -let et_OBJECT = 0x1Cuy -let et_SZARRAY = 0x1Duy -let et_MVAR = 0x1euy -let et_CMOD_REQD = 0x1Fuy -let et_CMOD_OPT = 0x20uy - -let et_SENTINEL = 0x41uy // sentinel for varargs -let et_PINNED = 0x45uy - - -let i_nop = 0x00 -let i_break = 0x01 -let i_ldarg_0 = 0x02 -let i_ldarg_1 = 0x03 -let i_ldarg_2 = 0x04 -let i_ldarg_3 = 0x05 -let i_ldloc_0 = 0x06 -let i_ldloc_1 = 0x07 -let i_ldloc_2 = 0x08 -let i_ldloc_3 = 0x09 -let i_stloc_0 = 0x0a -let i_stloc_1 = 0x0b -let i_stloc_2 = 0x0c -let i_stloc_3 = 0x0d -let i_ldarg_s = 0x0e -let i_ldarga_s = 0x0f -let i_starg_s = 0x10 -let i_ldloc_s = 0x11 -let i_ldloca_s = 0x12 -let i_stloc_s = 0x13 -let i_ldnull = 0x14 -let i_ldc_i4_m1 = 0x15 -let i_ldc_i4_0 = 0x16 -let i_ldc_i4_1 = 0x17 -let i_ldc_i4_2 = 0x18 -let i_ldc_i4_3 = 0x19 -let i_ldc_i4_4 = 0x1a -let i_ldc_i4_5 = 0x1b -let i_ldc_i4_6 = 0x1c -let i_ldc_i4_7 = 0x1d -let i_ldc_i4_8 = 0x1e -let i_ldc_i4_s = 0x1f -let i_ldc_i4 = 0x20 -let i_ldc_i8 = 0x21 -let i_ldc_r4 = 0x22 -let i_ldc_r8 = 0x23 -let i_dup = 0x25 -let i_pop = 0x26 -let i_jmp = 0x27 -let i_call = 0x28 -let i_calli = 0x29 -let i_ret = 0x2a -let i_br_s = 0x2b -let i_brfalse_s = 0x2c -let i_brtrue_s = 0x2d -let i_beq_s = 0x2e -let i_bge_s = 0x2f -let i_bgt_s = 0x30 -let i_ble_s = 0x31 -let i_blt_s = 0x32 -let i_bne_un_s = 0x33 -let i_bge_un_s = 0x34 -let i_bgt_un_s = 0x35 -let i_ble_un_s = 0x36 -let i_blt_un_s = 0x37 -let i_br = 0x38 -let i_brfalse = 0x39 -let i_brtrue = 0x3a -let i_beq = 0x3b -let i_bge = 0x3c -let i_bgt = 0x3d -let i_ble = 0x3e -let i_blt = 0x3f -let i_bne_un = 0x40 -let i_bge_un = 0x41 -let i_bgt_un = 0x42 -let i_ble_un = 0x43 -let i_blt_un = 0x44 -let i_switch = 0x45 -let i_ldind_i1 = 0x46 -let i_ldind_u1 = 0x47 -let i_ldind_i2 = 0x48 -let i_ldind_u2 = 0x49 -let i_ldind_i4 = 0x4a -let i_ldind_u4 = 0x4b -let i_ldind_i8 = 0x4c -let i_ldind_i = 0x4d -let i_ldind_r4 = 0x4e -let i_ldind_r8 = 0x4f -let i_ldind_ref = 0x50 -let i_stind_ref = 0x51 -let i_stind_i1 = 0x52 -let i_stind_i2 = 0x53 -let i_stind_i4 = 0x54 -let i_stind_i8 = 0x55 -let i_stind_r4 = 0x56 -let i_stind_r8 = 0x57 -let i_add = 0x58 -let i_sub = 0x59 -let i_mul = 0x5a -let i_div = 0x5b -let i_div_un = 0x5c -let i_rem = 0x5d -let i_rem_un = 0x5e -let i_and = 0x5f -let i_or = 0x60 -let i_xor = 0x61 -let i_shl = 0x62 -let i_shr = 0x63 -let i_shr_un = 0x64 -let i_neg = 0x65 -let i_not = 0x66 -let i_conv_i1 = 0x67 -let i_conv_i2 = 0x68 -let i_conv_i4 = 0x69 -let i_conv_i8 = 0x6a -let i_conv_r4 = 0x6b -let i_conv_r8 = 0x6c -let i_conv_u4 = 0x6d -let i_conv_u8 = 0x6e -let i_callvirt = 0x6f -let i_cpobj = 0x70 -let i_ldobj = 0x71 -let i_ldstr = 0x72 -let i_newobj = 0x73 -let i_castclass = 0x74 -let i_isinst = 0x75 -let i_conv_r_un = 0x76 -let i_unbox = 0x79 -let i_throw = 0x7a -let i_ldfld = 0x7b -let i_ldflda = 0x7c -let i_stfld = 0x7d -let i_ldsfld = 0x7e -let i_ldsflda = 0x7f -let i_stsfld = 0x80 -let i_stobj = 0x81 -let i_conv_ovf_i1_un= 0x82 -let i_conv_ovf_i2_un= 0x83 -let i_conv_ovf_i4_un= 0x84 -let i_conv_ovf_i8_un= 0x85 -let i_conv_ovf_u1_un= 0x86 -let i_conv_ovf_u2_un= 0x87 -let i_conv_ovf_u4_un= 0x88 -let i_conv_ovf_u8_un= 0x89 -let i_conv_ovf_i_un = 0x8a -let i_conv_ovf_u_un = 0x8b -let i_box = 0x8c -let i_newarr = 0x8d -let i_ldlen = 0x8e -let i_ldelema = 0x8f -let i_ldelem_i1 = 0x90 -let i_ldelem_u1 = 0x91 -let i_ldelem_i2 = 0x92 -let i_ldelem_u2 = 0x93 -let i_ldelem_i4 = 0x94 -let i_ldelem_u4 = 0x95 -let i_ldelem_i8 = 0x96 -let i_ldelem_i = 0x97 -let i_ldelem_r4 = 0x98 -let i_ldelem_r8 = 0x99 -let i_ldelem_ref = 0x9a -let i_stelem_i = 0x9b -let i_stelem_i1 = 0x9c -let i_stelem_i2 = 0x9d -let i_stelem_i4 = 0x9e -let i_stelem_i8 = 0x9f -let i_stelem_r4 = 0xa0 -let i_stelem_r8 = 0xa1 -let i_stelem_ref = 0xa2 -let i_conv_ovf_i1 = 0xb3 -let i_conv_ovf_u1 = 0xb4 -let i_conv_ovf_i2 = 0xb5 -let i_conv_ovf_u2 = 0xb6 -let i_conv_ovf_i4 = 0xb7 -let i_conv_ovf_u4 = 0xb8 -let i_conv_ovf_i8 = 0xb9 -let i_conv_ovf_u8 = 0xba -let i_refanyval = 0xc2 -let i_ckfinite = 0xc3 -let i_mkrefany = 0xc6 -let i_ldtoken = 0xd0 -let i_conv_u2 = 0xd1 -let i_conv_u1 = 0xd2 -let i_conv_i = 0xd3 -let i_conv_ovf_i = 0xd4 -let i_conv_ovf_u = 0xd5 -let i_add_ovf = 0xd6 -let i_add_ovf_un = 0xd7 -let i_mul_ovf = 0xd8 -let i_mul_ovf_un = 0xd9 -let i_sub_ovf = 0xda -let i_sub_ovf_un = 0xdb -let i_endfinally = 0xdc -let i_leave = 0xdd -let i_leave_s = 0xde -let i_stind_i = 0xdf -let i_conv_u = 0xe0 -let i_arglist = 0xfe00 -let i_ceq = 0xfe01 -let i_cgt = 0xfe02 -let i_cgt_un = 0xfe03 -let i_clt = 0xfe04 -let i_clt_un = 0xfe05 -let i_ldftn = 0xfe06 -let i_ldvirtftn = 0xfe07 -let i_ldarg = 0xfe09 -let i_ldarga = 0xfe0a -let i_starg = 0xfe0b -let i_ldloc = 0xfe0c -let i_ldloca = 0xfe0d -let i_stloc = 0xfe0e -let i_localloc = 0xfe0f -let i_endfilter = 0xfe11 -let i_unaligned = 0xfe12 -let i_volatile = 0xfe13 -let i_constrained = 0xfe16 -let i_readonly = 0xfe1e -let i_tail = 0xfe14 -let i_initobj = 0xfe15 -let i_cpblk = 0xfe17 -let i_initblk = 0xfe18 -let i_rethrow = 0xfe1a -let i_sizeof = 0xfe1c -let i_refanytype = 0xfe1d -let i_ldelem_any = 0xa3 -let i_stelem_any = 0xa4 -let i_unbox_any = 0xa5 +let et_VALUETYPE = 0x11uy +let et_CLASS = 0x12uy +let et_VAR = 0x13uy +let et_ARRAY = 0x14uy +let et_WITH = 0x15uy +let et_TYPEDBYREF = 0x16uy +let et_I = 0x18uy +let et_U = 0x19uy +let et_FNPTR = 0x1Buy +let et_OBJECT = 0x1Cuy +let et_SZARRAY = 0x1Duy +let et_MVAR = 0x1euy +let et_CMOD_REQD = 0x1Fuy +let et_CMOD_OPT = 0x20uy + +let et_SENTINEL = 0x41uy // sentinel for varargs +let et_PINNED = 0x45uy + +let i_nop = 0x00 +let i_break = 0x01 +let i_ldarg_0 = 0x02 +let i_ldarg_1 = 0x03 +let i_ldarg_2 = 0x04 +let i_ldarg_3 = 0x05 +let i_ldloc_0 = 0x06 +let i_ldloc_1 = 0x07 +let i_ldloc_2 = 0x08 +let i_ldloc_3 = 0x09 +let i_stloc_0 = 0x0a +let i_stloc_1 = 0x0b +let i_stloc_2 = 0x0c +let i_stloc_3 = 0x0d +let i_ldarg_s = 0x0e +let i_ldarga_s = 0x0f +let i_starg_s = 0x10 +let i_ldloc_s = 0x11 +let i_ldloca_s = 0x12 +let i_stloc_s = 0x13 +let i_ldnull = 0x14 +let i_ldc_i4_m1 = 0x15 +let i_ldc_i4_0 = 0x16 +let i_ldc_i4_1 = 0x17 +let i_ldc_i4_2 = 0x18 +let i_ldc_i4_3 = 0x19 +let i_ldc_i4_4 = 0x1a +let i_ldc_i4_5 = 0x1b +let i_ldc_i4_6 = 0x1c +let i_ldc_i4_7 = 0x1d +let i_ldc_i4_8 = 0x1e +let i_ldc_i4_s = 0x1f +let i_ldc_i4 = 0x20 +let i_ldc_i8 = 0x21 +let i_ldc_r4 = 0x22 +let i_ldc_r8 = 0x23 +let i_dup = 0x25 +let i_pop = 0x26 +let i_jmp = 0x27 +let i_call = 0x28 +let i_calli = 0x29 +let i_ret = 0x2a +let i_br_s = 0x2b +let i_brfalse_s = 0x2c +let i_brtrue_s = 0x2d +let i_beq_s = 0x2e +let i_bge_s = 0x2f +let i_bgt_s = 0x30 +let i_ble_s = 0x31 +let i_blt_s = 0x32 +let i_bne_un_s = 0x33 +let i_bge_un_s = 0x34 +let i_bgt_un_s = 0x35 +let i_ble_un_s = 0x36 +let i_blt_un_s = 0x37 +let i_br = 0x38 +let i_brfalse = 0x39 +let i_brtrue = 0x3a +let i_beq = 0x3b +let i_bge = 0x3c +let i_bgt = 0x3d +let i_ble = 0x3e +let i_blt = 0x3f +let i_bne_un = 0x40 +let i_bge_un = 0x41 +let i_bgt_un = 0x42 +let i_ble_un = 0x43 +let i_blt_un = 0x44 +let i_switch = 0x45 +let i_ldind_i1 = 0x46 +let i_ldind_u1 = 0x47 +let i_ldind_i2 = 0x48 +let i_ldind_u2 = 0x49 +let i_ldind_i4 = 0x4a +let i_ldind_u4 = 0x4b +let i_ldind_i8 = 0x4c +let i_ldind_i = 0x4d +let i_ldind_r4 = 0x4e +let i_ldind_r8 = 0x4f +let i_ldind_ref = 0x50 +let i_stind_ref = 0x51 +let i_stind_i1 = 0x52 +let i_stind_i2 = 0x53 +let i_stind_i4 = 0x54 +let i_stind_i8 = 0x55 +let i_stind_r4 = 0x56 +let i_stind_r8 = 0x57 +let i_add = 0x58 +let i_sub = 0x59 +let i_mul = 0x5a +let i_div = 0x5b +let i_div_un = 0x5c +let i_rem = 0x5d +let i_rem_un = 0x5e +let i_and = 0x5f +let i_or = 0x60 +let i_xor = 0x61 +let i_shl = 0x62 +let i_shr = 0x63 +let i_shr_un = 0x64 +let i_neg = 0x65 +let i_not = 0x66 +let i_conv_i1 = 0x67 +let i_conv_i2 = 0x68 +let i_conv_i4 = 0x69 +let i_conv_i8 = 0x6a +let i_conv_r4 = 0x6b +let i_conv_r8 = 0x6c +let i_conv_u4 = 0x6d +let i_conv_u8 = 0x6e +let i_callvirt = 0x6f +let i_cpobj = 0x70 +let i_ldobj = 0x71 +let i_ldstr = 0x72 +let i_newobj = 0x73 +let i_castclass = 0x74 +let i_isinst = 0x75 +let i_conv_r_un = 0x76 +let i_unbox = 0x79 +let i_throw = 0x7a +let i_ldfld = 0x7b +let i_ldflda = 0x7c +let i_stfld = 0x7d +let i_ldsfld = 0x7e +let i_ldsflda = 0x7f +let i_stsfld = 0x80 +let i_stobj = 0x81 +let i_conv_ovf_i1_un = 0x82 +let i_conv_ovf_i2_un = 0x83 +let i_conv_ovf_i4_un = 0x84 +let i_conv_ovf_i8_un = 0x85 +let i_conv_ovf_u1_un = 0x86 +let i_conv_ovf_u2_un = 0x87 +let i_conv_ovf_u4_un = 0x88 +let i_conv_ovf_u8_un = 0x89 +let i_conv_ovf_i_un = 0x8a +let i_conv_ovf_u_un = 0x8b +let i_box = 0x8c +let i_newarr = 0x8d +let i_ldlen = 0x8e +let i_ldelema = 0x8f +let i_ldelem_i1 = 0x90 +let i_ldelem_u1 = 0x91 +let i_ldelem_i2 = 0x92 +let i_ldelem_u2 = 0x93 +let i_ldelem_i4 = 0x94 +let i_ldelem_u4 = 0x95 +let i_ldelem_i8 = 0x96 +let i_ldelem_i = 0x97 +let i_ldelem_r4 = 0x98 +let i_ldelem_r8 = 0x99 +let i_ldelem_ref = 0x9a +let i_stelem_i = 0x9b +let i_stelem_i1 = 0x9c +let i_stelem_i2 = 0x9d +let i_stelem_i4 = 0x9e +let i_stelem_i8 = 0x9f +let i_stelem_r4 = 0xa0 +let i_stelem_r8 = 0xa1 +let i_stelem_ref = 0xa2 +let i_conv_ovf_i1 = 0xb3 +let i_conv_ovf_u1 = 0xb4 +let i_conv_ovf_i2 = 0xb5 +let i_conv_ovf_u2 = 0xb6 +let i_conv_ovf_i4 = 0xb7 +let i_conv_ovf_u4 = 0xb8 +let i_conv_ovf_i8 = 0xb9 +let i_conv_ovf_u8 = 0xba +let i_refanyval = 0xc2 +let i_ckfinite = 0xc3 +let i_mkrefany = 0xc6 +let i_ldtoken = 0xd0 +let i_conv_u2 = 0xd1 +let i_conv_u1 = 0xd2 +let i_conv_i = 0xd3 +let i_conv_ovf_i = 0xd4 +let i_conv_ovf_u = 0xd5 +let i_add_ovf = 0xd6 +let i_add_ovf_un = 0xd7 +let i_mul_ovf = 0xd8 +let i_mul_ovf_un = 0xd9 +let i_sub_ovf = 0xda +let i_sub_ovf_un = 0xdb +let i_endfinally = 0xdc +let i_leave = 0xdd +let i_leave_s = 0xde +let i_stind_i = 0xdf +let i_conv_u = 0xe0 +let i_arglist = 0xfe00 +let i_ceq = 0xfe01 +let i_cgt = 0xfe02 +let i_cgt_un = 0xfe03 +let i_clt = 0xfe04 +let i_clt_un = 0xfe05 +let i_ldftn = 0xfe06 +let i_ldvirtftn = 0xfe07 +let i_ldarg = 0xfe09 +let i_ldarga = 0xfe0a +let i_starg = 0xfe0b +let i_ldloc = 0xfe0c +let i_ldloca = 0xfe0d +let i_stloc = 0xfe0e +let i_localloc = 0xfe0f +let i_endfilter = 0xfe11 +let i_unaligned = 0xfe12 +let i_volatile = 0xfe13 +let i_constrained = 0xfe16 +let i_readonly = 0xfe1e +let i_tail = 0xfe14 +let i_initobj = 0xfe15 +let i_cpblk = 0xfe17 +let i_initblk = 0xfe18 +let i_rethrow = 0xfe1a +let i_sizeof = 0xfe1c +let i_refanytype = 0xfe1d +let i_ldelem_any = 0xa3 +let i_stelem_any = 0xa4 +let i_unbox_any = 0xa5 let mk_ldc i = mkLdcInt32 i -let noArgInstrs = - lazy [ i_ldc_i4_0, mk_ldc 0 - i_ldc_i4_1, mk_ldc 1 - i_ldc_i4_2, mk_ldc 2 - i_ldc_i4_3, mk_ldc 3 - i_ldc_i4_4, mk_ldc 4 - i_ldc_i4_5, mk_ldc 5 - i_ldc_i4_6, mk_ldc 6 - i_ldc_i4_7, mk_ldc 7 - i_ldc_i4_8, mk_ldc 8 - i_ldc_i4_m1, mk_ldc -1 - 0x0a, mkStloc 0us - 0x0b, mkStloc 1us - 0x0c, mkStloc 2us - 0x0d, mkStloc 3us - 0x06, mkLdloc 0us - 0x07, mkLdloc 1us - 0x08, mkLdloc 2us - 0x09, mkLdloc 3us - 0x02, mkLdarg 0us - 0x03, mkLdarg 1us - 0x04, mkLdarg 2us - 0x05, mkLdarg 3us - 0x2a, I_ret - 0x58, AI_add - 0xd6, AI_add_ovf - 0xd7, AI_add_ovf_un - 0x5f, AI_and - 0x5b, AI_div - 0x5c, AI_div_un - 0xfe01, AI_ceq - 0xfe02, AI_cgt - 0xfe03, AI_cgt_un - 0xfe04, AI_clt - 0xfe05, AI_clt_un - 0x67, AI_conv DT_I1 - 0x68, AI_conv DT_I2 - 0x69, AI_conv DT_I4 - 0x6a, AI_conv DT_I8 - 0xd3, AI_conv DT_I - 0x6b, AI_conv DT_R4 - 0x6c, AI_conv DT_R8 - 0xd2, AI_conv DT_U1 - 0xd1, AI_conv DT_U2 - 0x6d, AI_conv DT_U4 - 0x6e, AI_conv DT_U8 - 0xe0, AI_conv DT_U - 0x76, AI_conv DT_R - 0xb3, AI_conv_ovf DT_I1 - 0xb5, AI_conv_ovf DT_I2 - 0xb7, AI_conv_ovf DT_I4 - 0xb9, AI_conv_ovf DT_I8 - 0xd4, AI_conv_ovf DT_I - 0xb4, AI_conv_ovf DT_U1 - 0xb6, AI_conv_ovf DT_U2 - 0xb8, AI_conv_ovf DT_U4 - 0xba, AI_conv_ovf DT_U8 - 0xd5, AI_conv_ovf DT_U - 0x82, AI_conv_ovf_un DT_I1 - 0x83, AI_conv_ovf_un DT_I2 - 0x84, AI_conv_ovf_un DT_I4 - 0x85, AI_conv_ovf_un DT_I8 - 0x8a, AI_conv_ovf_un DT_I - 0x86, AI_conv_ovf_un DT_U1 - 0x87, AI_conv_ovf_un DT_U2 - 0x88, AI_conv_ovf_un DT_U4 - 0x89, AI_conv_ovf_un DT_U8 - 0x8b, AI_conv_ovf_un DT_U - 0x9c, I_stelem DT_I1 - 0x9d, I_stelem DT_I2 - 0x9e, I_stelem DT_I4 - 0x9f, I_stelem DT_I8 - 0xa0, I_stelem DT_R4 - 0xa1, I_stelem DT_R8 - 0x9b, I_stelem DT_I - 0xa2, I_stelem DT_REF - 0x90, I_ldelem DT_I1 - 0x92, I_ldelem DT_I2 - 0x94, I_ldelem DT_I4 - 0x96, I_ldelem DT_I8 - 0x91, I_ldelem DT_U1 - 0x93, I_ldelem DT_U2 - 0x95, I_ldelem DT_U4 - 0x98, I_ldelem DT_R4 - 0x99, I_ldelem DT_R8 - 0x97, I_ldelem DT_I - 0x9a, I_ldelem DT_REF - 0x5a, AI_mul - 0xd8, AI_mul_ovf - 0xd9, AI_mul_ovf_un - 0x5d, AI_rem - 0x5e, AI_rem_un - 0x62, AI_shl - 0x63, AI_shr - 0x64, AI_shr_un - 0x59, AI_sub - 0xda, AI_sub_ovf - 0xdb, AI_sub_ovf_un - 0x61, AI_xor - 0x60, AI_or - 0x65, AI_neg - 0x66, AI_not - i_ldnull, AI_ldnull - i_dup, AI_dup - i_pop, AI_pop - i_ckfinite, AI_ckfinite - i_nop, AI_nop - i_break, I_break - i_arglist, I_arglist - i_endfilter, I_endfilter - i_endfinally, I_endfinally - i_refanytype, I_refanytype - i_localloc, I_localloc - i_throw, I_throw - i_ldlen, I_ldlen - i_rethrow, I_rethrow ] - -let isNoArgInstr i = - match i with - | AI_ldc (DT_I4, ILConst.I4 n) when -1 <= n && n <= 8 -> true - | I_stloc n | I_ldloc n | I_ldarg n when n <= 3us -> true - | I_ret - | AI_add - | AI_add_ovf - | AI_add_ovf_un - | AI_and - | AI_div - | AI_div_un - | AI_ceq - | AI_cgt - | AI_cgt_un - | AI_clt - | AI_clt_un - | AI_conv DT_I1 - | AI_conv DT_I2 - | AI_conv DT_I4 - | AI_conv DT_I8 - | AI_conv DT_I - | AI_conv DT_R4 - | AI_conv DT_R8 - | AI_conv DT_U1 - | AI_conv DT_U2 - | AI_conv DT_U4 - | AI_conv DT_U8 - | AI_conv DT_U - | AI_conv DT_R - | AI_conv_ovf DT_I1 - | AI_conv_ovf DT_I2 - | AI_conv_ovf DT_I4 - | AI_conv_ovf DT_I8 - | AI_conv_ovf DT_I - | AI_conv_ovf DT_U1 - | AI_conv_ovf DT_U2 - | AI_conv_ovf DT_U4 - | AI_conv_ovf DT_U8 - | AI_conv_ovf DT_U - | AI_conv_ovf_un DT_I1 - | AI_conv_ovf_un DT_I2 - | AI_conv_ovf_un DT_I4 - | AI_conv_ovf_un DT_I8 - | AI_conv_ovf_un DT_I - | AI_conv_ovf_un DT_U1 - | AI_conv_ovf_un DT_U2 - | AI_conv_ovf_un DT_U4 - | AI_conv_ovf_un DT_U8 - | AI_conv_ovf_un DT_U - | I_stelem DT_I1 - | I_stelem DT_I2 - | I_stelem DT_I4 - | I_stelem DT_I8 - | I_stelem DT_R4 - | I_stelem DT_R8 - | I_stelem DT_I - | I_stelem DT_REF - | I_ldelem DT_I1 - | I_ldelem DT_I2 - | I_ldelem DT_I4 - | I_ldelem DT_I8 - | I_ldelem DT_U1 - | I_ldelem DT_U2 - | I_ldelem DT_U4 - | I_ldelem DT_R4 - | I_ldelem DT_R8 - | I_ldelem DT_I - | I_ldelem DT_REF - | AI_mul - | AI_mul_ovf - | AI_mul_ovf_un - | AI_rem - | AI_rem_un - | AI_shl - | AI_shr - | AI_shr_un - | AI_sub - | AI_sub_ovf - | AI_sub_ovf_un - | AI_xor - | AI_or - | AI_neg - | AI_not - | AI_ldnull - | AI_dup - | AI_pop - | AI_ckfinite - | AI_nop - | I_break - | I_arglist - | I_endfilter - | I_endfinally - | I_refanytype - | I_localloc - | I_throw - | I_ldlen - | I_rethrow -> true - | _ -> false - -let ILCmpInstrMap = - lazy ( - let dict = Dictionary.newWithSize 12 - dict.Add (BI_beq, i_beq ) - dict.Add (BI_bgt, i_bgt ) - dict.Add (BI_bgt_un, i_bgt_un ) - dict.Add (BI_bge, i_bge ) - dict.Add (BI_bge_un, i_bge_un ) - dict.Add (BI_ble, i_ble ) - dict.Add (BI_ble_un, i_ble_un ) - dict.Add (BI_blt, i_blt ) - dict.Add (BI_blt_un, i_blt_un ) - dict.Add (BI_bne_un, i_bne_un ) - dict.Add (BI_brfalse, i_brfalse ) - dict.Add (BI_brtrue, i_brtrue ) - dict - ) - -let ILCmpInstrRevMap = - lazy ( - let dict = Dictionary.newWithSize 12 - dict.Add ( BI_beq, i_beq_s ) - dict.Add ( BI_bgt, i_bgt_s ) - dict.Add ( BI_bgt_un, i_bgt_un_s ) - dict.Add ( BI_bge, i_bge_s ) - dict.Add ( BI_bge_un, i_bge_un_s ) - dict.Add ( BI_ble, i_ble_s ) - dict.Add ( BI_ble_un, i_ble_un_s ) - dict.Add ( BI_blt, i_blt_s ) - dict.Add ( BI_blt_un, i_blt_un_s ) - dict.Add ( BI_bne_un, i_bne_un_s ) - dict.Add ( BI_brfalse, i_brfalse_s ) - dict.Add ( BI_brtrue, i_brtrue_s ) - dict - ) - -// From corhdr.h - -let nt_VOID = 0x1uy -let nt_BOOLEAN = 0x2uy -let nt_I1 = 0x3uy -let nt_U1 = 0x4uy -let nt_I2 = 0x5uy -let nt_U2 = 0x6uy -let nt_I4 = 0x7uy -let nt_U4 = 0x8uy -let nt_I8 = 0x9uy -let nt_U8 = 0xAuy -let nt_R4 = 0xBuy -let nt_R8 = 0xCuy -let nt_SYSCHAR = 0xDuy -let nt_VARIANT = 0xEuy -let nt_CURRENCY = 0xFuy -let nt_PTR = 0x10uy -let nt_DECIMAL = 0x11uy -let nt_DATE = 0x12uy -let nt_BSTR = 0x13uy -let nt_LPSTR = 0x14uy -let nt_LPWSTR = 0x15uy -let nt_LPTSTR = 0x16uy -let nt_FIXEDSYSSTRING = 0x17uy -let nt_OBJECTREF = 0x18uy -let nt_IUNKNOWN = 0x19uy -let nt_IDISPATCH = 0x1Auy -let nt_STRUCT = 0x1Buy -let nt_INTF = 0x1Cuy -let nt_SAFEARRAY = 0x1Duy -let nt_FIXEDARRAY = 0x1Euy -let nt_INT = 0x1Fuy -let nt_UINT = 0x20uy -let nt_NESTEDSTRUCT = 0x21uy -let nt_BYVALSTR = 0x22uy -let nt_ANSIBSTR = 0x23uy -let nt_TBSTR = 0x24uy +let noArgInstrs = + lazy + [ + i_ldc_i4_0, mk_ldc 0 + i_ldc_i4_1, mk_ldc 1 + i_ldc_i4_2, mk_ldc 2 + i_ldc_i4_3, mk_ldc 3 + i_ldc_i4_4, mk_ldc 4 + i_ldc_i4_5, mk_ldc 5 + i_ldc_i4_6, mk_ldc 6 + i_ldc_i4_7, mk_ldc 7 + i_ldc_i4_8, mk_ldc 8 + i_ldc_i4_m1, mk_ldc -1 + 0x0a, mkStloc 0us + 0x0b, mkStloc 1us + 0x0c, mkStloc 2us + 0x0d, mkStloc 3us + 0x06, mkLdloc 0us + 0x07, mkLdloc 1us + 0x08, mkLdloc 2us + 0x09, mkLdloc 3us + 0x02, mkLdarg 0us + 0x03, mkLdarg 1us + 0x04, mkLdarg 2us + 0x05, mkLdarg 3us + 0x2a, I_ret + 0x58, AI_add + 0xd6, AI_add_ovf + 0xd7, AI_add_ovf_un + 0x5f, AI_and + 0x5b, AI_div + 0x5c, AI_div_un + 0xfe01, AI_ceq + 0xfe02, AI_cgt + 0xfe03, AI_cgt_un + 0xfe04, AI_clt + 0xfe05, AI_clt_un + 0x67, AI_conv DT_I1 + 0x68, AI_conv DT_I2 + 0x69, AI_conv DT_I4 + 0x6a, AI_conv DT_I8 + 0xd3, AI_conv DT_I + 0x6b, AI_conv DT_R4 + 0x6c, AI_conv DT_R8 + 0xd2, AI_conv DT_U1 + 0xd1, AI_conv DT_U2 + 0x6d, AI_conv DT_U4 + 0x6e, AI_conv DT_U8 + 0xe0, AI_conv DT_U + 0x76, AI_conv DT_R + 0xb3, AI_conv_ovf DT_I1 + 0xb5, AI_conv_ovf DT_I2 + 0xb7, AI_conv_ovf DT_I4 + 0xb9, AI_conv_ovf DT_I8 + 0xd4, AI_conv_ovf DT_I + 0xb4, AI_conv_ovf DT_U1 + 0xb6, AI_conv_ovf DT_U2 + 0xb8, AI_conv_ovf DT_U4 + 0xba, AI_conv_ovf DT_U8 + 0xd5, AI_conv_ovf DT_U + 0x82, AI_conv_ovf_un DT_I1 + 0x83, AI_conv_ovf_un DT_I2 + 0x84, AI_conv_ovf_un DT_I4 + 0x85, AI_conv_ovf_un DT_I8 + 0x8a, AI_conv_ovf_un DT_I + 0x86, AI_conv_ovf_un DT_U1 + 0x87, AI_conv_ovf_un DT_U2 + 0x88, AI_conv_ovf_un DT_U4 + 0x89, AI_conv_ovf_un DT_U8 + 0x8b, AI_conv_ovf_un DT_U + 0x9c, I_stelem DT_I1 + 0x9d, I_stelem DT_I2 + 0x9e, I_stelem DT_I4 + 0x9f, I_stelem DT_I8 + 0xa0, I_stelem DT_R4 + 0xa1, I_stelem DT_R8 + 0x9b, I_stelem DT_I + 0xa2, I_stelem DT_REF + 0x90, I_ldelem DT_I1 + 0x92, I_ldelem DT_I2 + 0x94, I_ldelem DT_I4 + 0x96, I_ldelem DT_I8 + 0x91, I_ldelem DT_U1 + 0x93, I_ldelem DT_U2 + 0x95, I_ldelem DT_U4 + 0x98, I_ldelem DT_R4 + 0x99, I_ldelem DT_R8 + 0x97, I_ldelem DT_I + 0x9a, I_ldelem DT_REF + 0x5a, AI_mul + 0xd8, AI_mul_ovf + 0xd9, AI_mul_ovf_un + 0x5d, AI_rem + 0x5e, AI_rem_un + 0x62, AI_shl + 0x63, AI_shr + 0x64, AI_shr_un + 0x59, AI_sub + 0xda, AI_sub_ovf + 0xdb, AI_sub_ovf_un + 0x61, AI_xor + 0x60, AI_or + 0x65, AI_neg + 0x66, AI_not + i_ldnull, AI_ldnull + i_dup, AI_dup + i_pop, AI_pop + i_ckfinite, AI_ckfinite + i_nop, AI_nop + i_break, I_break + i_arglist, I_arglist + i_endfilter, I_endfilter + i_endfinally, I_endfinally + i_refanytype, I_refanytype + i_localloc, I_localloc + i_throw, I_throw + i_ldlen, I_ldlen + i_rethrow, I_rethrow + ] + +let isNoArgInstr i = + match i with + | AI_ldc (DT_I4, ILConst.I4 n) when -1 <= n && n <= 8 -> true + | I_stloc n + | I_ldloc n + | I_ldarg n when n <= 3us -> true + | I_ret + | AI_add + | AI_add_ovf + | AI_add_ovf_un + | AI_and + | AI_div + | AI_div_un + | AI_ceq + | AI_cgt + | AI_cgt_un + | AI_clt + | AI_clt_un + | AI_conv DT_I1 + | AI_conv DT_I2 + | AI_conv DT_I4 + | AI_conv DT_I8 + | AI_conv DT_I + | AI_conv DT_R4 + | AI_conv DT_R8 + | AI_conv DT_U1 + | AI_conv DT_U2 + | AI_conv DT_U4 + | AI_conv DT_U8 + | AI_conv DT_U + | AI_conv DT_R + | AI_conv_ovf DT_I1 + | AI_conv_ovf DT_I2 + | AI_conv_ovf DT_I4 + | AI_conv_ovf DT_I8 + | AI_conv_ovf DT_I + | AI_conv_ovf DT_U1 + | AI_conv_ovf DT_U2 + | AI_conv_ovf DT_U4 + | AI_conv_ovf DT_U8 + | AI_conv_ovf DT_U + | AI_conv_ovf_un DT_I1 + | AI_conv_ovf_un DT_I2 + | AI_conv_ovf_un DT_I4 + | AI_conv_ovf_un DT_I8 + | AI_conv_ovf_un DT_I + | AI_conv_ovf_un DT_U1 + | AI_conv_ovf_un DT_U2 + | AI_conv_ovf_un DT_U4 + | AI_conv_ovf_un DT_U8 + | AI_conv_ovf_un DT_U + | I_stelem DT_I1 + | I_stelem DT_I2 + | I_stelem DT_I4 + | I_stelem DT_I8 + | I_stelem DT_R4 + | I_stelem DT_R8 + | I_stelem DT_I + | I_stelem DT_REF + | I_ldelem DT_I1 + | I_ldelem DT_I2 + | I_ldelem DT_I4 + | I_ldelem DT_I8 + | I_ldelem DT_U1 + | I_ldelem DT_U2 + | I_ldelem DT_U4 + | I_ldelem DT_R4 + | I_ldelem DT_R8 + | I_ldelem DT_I + | I_ldelem DT_REF + | AI_mul + | AI_mul_ovf + | AI_mul_ovf_un + | AI_rem + | AI_rem_un + | AI_shl + | AI_shr + | AI_shr_un + | AI_sub + | AI_sub_ovf + | AI_sub_ovf_un + | AI_xor + | AI_or + | AI_neg + | AI_not + | AI_ldnull + | AI_dup + | AI_pop + | AI_ckfinite + | AI_nop + | I_break + | I_arglist + | I_endfilter + | I_endfinally + | I_refanytype + | I_localloc + | I_throw + | I_ldlen + | I_rethrow -> true + | _ -> false + +let ILCmpInstrMap = + lazy + (let dict = Dictionary.newWithSize 12 + dict.Add(BI_beq, i_beq) + dict.Add(BI_bgt, i_bgt) + dict.Add(BI_bgt_un, i_bgt_un) + dict.Add(BI_bge, i_bge) + dict.Add(BI_bge_un, i_bge_un) + dict.Add(BI_ble, i_ble) + dict.Add(BI_ble_un, i_ble_un) + dict.Add(BI_blt, i_blt) + dict.Add(BI_blt_un, i_blt_un) + dict.Add(BI_bne_un, i_bne_un) + dict.Add(BI_brfalse, i_brfalse) + dict.Add(BI_brtrue, i_brtrue) + dict) + +let ILCmpInstrRevMap = + lazy + (let dict = Dictionary.newWithSize 12 + dict.Add(BI_beq, i_beq_s) + dict.Add(BI_bgt, i_bgt_s) + dict.Add(BI_bgt_un, i_bgt_un_s) + dict.Add(BI_bge, i_bge_s) + dict.Add(BI_bge_un, i_bge_un_s) + dict.Add(BI_ble, i_ble_s) + dict.Add(BI_ble_un, i_ble_un_s) + dict.Add(BI_blt, i_blt_s) + dict.Add(BI_blt_un, i_blt_un_s) + dict.Add(BI_bne_un, i_bne_un_s) + dict.Add(BI_brfalse, i_brfalse_s) + dict.Add(BI_brtrue, i_brtrue_s) + dict) + +// From corhdr.h + +let nt_VOID = 0x1uy +let nt_BOOLEAN = 0x2uy +let nt_I1 = 0x3uy +let nt_U1 = 0x4uy +let nt_I2 = 0x5uy +let nt_U2 = 0x6uy +let nt_I4 = 0x7uy +let nt_U4 = 0x8uy +let nt_I8 = 0x9uy +let nt_U8 = 0xAuy +let nt_R4 = 0xBuy +let nt_R8 = 0xCuy +let nt_SYSCHAR = 0xDuy +let nt_VARIANT = 0xEuy +let nt_CURRENCY = 0xFuy +let nt_PTR = 0x10uy +let nt_DECIMAL = 0x11uy +let nt_DATE = 0x12uy +let nt_BSTR = 0x13uy +let nt_LPSTR = 0x14uy +let nt_LPWSTR = 0x15uy +let nt_LPTSTR = 0x16uy +let nt_FIXEDSYSSTRING = 0x17uy +let nt_OBJECTREF = 0x18uy +let nt_IUNKNOWN = 0x19uy +let nt_IDISPATCH = 0x1Auy +let nt_STRUCT = 0x1Buy +let nt_INTF = 0x1Cuy +let nt_SAFEARRAY = 0x1Duy +let nt_FIXEDARRAY = 0x1Euy +let nt_INT = 0x1Fuy +let nt_UINT = 0x20uy +let nt_NESTEDSTRUCT = 0x21uy +let nt_BYVALSTR = 0x22uy +let nt_ANSIBSTR = 0x23uy +let nt_TBSTR = 0x24uy let nt_VARIANTBOOL = 0x25uy -let nt_FUNC = 0x26uy -let nt_ASANY = 0x28uy -let nt_ARRAY = 0x2Auy -let nt_LPSTRUCT = 0x2Buy +let nt_FUNC = 0x26uy +let nt_ASANY = 0x28uy +let nt_ARRAY = 0x2Auy +let nt_LPSTRUCT = 0x2Buy let nt_CUSTOMMARSHALER = 0x2Cuy -let nt_ERROR = 0x2Duy -let nt_LPUTF8STR = 0x30uy +let nt_ERROR = 0x2Duy +let nt_LPUTF8STR = 0x30uy let nt_MAX = 0x50uy // From c:/clrenv.i386/Crt/Inc/i386/hs.h @@ -864,7 +896,7 @@ let vt_UI8 = 21 let vt_INT = 22 let vt_UINT = 23 let vt_VOID = 24 -let vt_HRESULT = 25 +let vt_HRESULT = 25 let vt_PTR = 26 let vt_SAFEARRAY = 27 let vt_CARRAY = 28 @@ -885,110 +917,120 @@ let vt_VECTOR = 0x1000 let vt_ARRAY = 0x2000 let vt_BYREF = 0x4000 - -let ILNativeTypeMap = - lazy [ nt_CURRENCY, ILNativeType.Currency - nt_BSTR, (* COM interop *) ILNativeType.BSTR - nt_LPSTR, ILNativeType.LPSTR - nt_LPWSTR, ILNativeType.LPWSTR - nt_LPTSTR, ILNativeType.LPTSTR - nt_LPUTF8STR, ILNativeType.LPUTF8STR - nt_IUNKNOWN, (* COM interop *) ILNativeType.IUnknown - nt_IDISPATCH, (* COM interop *) ILNativeType.IDispatch - nt_BYVALSTR, ILNativeType.ByValStr - nt_TBSTR, ILNativeType.TBSTR - nt_LPSTRUCT, ILNativeType.LPSTRUCT - nt_INTF, (* COM interop *) ILNativeType.Interface - nt_STRUCT, ILNativeType.Struct - nt_ERROR, (* COM interop *) ILNativeType.Error - nt_VOID, ILNativeType.Void - nt_BOOLEAN, ILNativeType.Bool - nt_I1, ILNativeType.Int8 - nt_I2, ILNativeType.Int16 - nt_I4, ILNativeType.Int32 - nt_I8, ILNativeType.Int64 - nt_R4, ILNativeType.Single - nt_R8, ILNativeType.Double - nt_U1, ILNativeType.Byte - nt_U2, ILNativeType.UInt16 - nt_U4, ILNativeType.UInt32 - nt_U8, ILNativeType.UInt64 - nt_INT, ILNativeType.Int - nt_UINT, ILNativeType.UInt - nt_ANSIBSTR, (* COM interop *) ILNativeType.ANSIBSTR - nt_VARIANTBOOL, (* COM interop *) ILNativeType.VariantBool - nt_FUNC, ILNativeType.Method - nt_ASANY, ILNativeType.AsAny ] - -let ILNativeTypeRevMap = lazy (List.map (fun (x,y) -> (y,x)) (Lazy.force ILNativeTypeMap)) - -let ILVariantTypeMap = - lazy [ ILNativeVariant.Empty, vt_EMPTY - ILNativeVariant.Null, vt_NULL - ILNativeVariant.Variant, vt_VARIANT - ILNativeVariant.Currency, vt_CY - ILNativeVariant.Decimal, vt_DECIMAL - ILNativeVariant.Date, vt_DATE - ILNativeVariant.BSTR, vt_BSTR - ILNativeVariant.LPSTR, vt_LPSTR - ILNativeVariant.LPWSTR, vt_LPWSTR - ILNativeVariant.IUnknown, vt_UNKNOWN - ILNativeVariant.IDispatch, vt_DISPATCH - ILNativeVariant.SafeArray, vt_SAFEARRAY - ILNativeVariant.Error, vt_ERROR - ILNativeVariant.HRESULT, vt_HRESULT - ILNativeVariant.CArray, vt_CARRAY - ILNativeVariant.UserDefined, vt_USERDEFINED - ILNativeVariant.Record, vt_RECORD - ILNativeVariant.FileTime, vt_FILETIME - ILNativeVariant.Blob, vt_BLOB - ILNativeVariant.Stream, vt_STREAM - ILNativeVariant.Storage, vt_STORAGE - ILNativeVariant.StreamedObject, vt_STREAMED_OBJECT - ILNativeVariant.StoredObject, vt_STORED_OBJECT - ILNativeVariant.BlobObject, vt_BLOB_OBJECT - ILNativeVariant.CF, vt_CF - ILNativeVariant.CLSID, vt_CLSID - ILNativeVariant.Void, vt_VOID - ILNativeVariant.Bool, vt_BOOL - ILNativeVariant.Int8, vt_I1 - ILNativeVariant.Int16, vt_I2 - ILNativeVariant.Int32, vt_I4 - ILNativeVariant.Int64, vt_I8 - ILNativeVariant.Single, vt_R4 - ILNativeVariant.Double, vt_R8 - ILNativeVariant.UInt8, vt_UI1 - ILNativeVariant.UInt16, vt_UI2 - ILNativeVariant.UInt32, vt_UI4 - ILNativeVariant.UInt64, vt_UI8 - ILNativeVariant.PTR, vt_PTR - ILNativeVariant.Int, vt_INT - ILNativeVariant.UInt, vt_UINT ] - -let ILVariantTypeRevMap = lazy (List.map (fun (x,y) -> (y,x)) (Lazy.force ILVariantTypeMap)) +let ILNativeTypeMap = + lazy + [ + nt_CURRENCY, ILNativeType.Currency + nt_BSTR (* COM interop *) , ILNativeType.BSTR + nt_LPSTR, ILNativeType.LPSTR + nt_LPWSTR, ILNativeType.LPWSTR + nt_LPTSTR, ILNativeType.LPTSTR + nt_LPUTF8STR, ILNativeType.LPUTF8STR + nt_IUNKNOWN (* COM interop *) , ILNativeType.IUnknown + nt_IDISPATCH (* COM interop *) , ILNativeType.IDispatch + nt_BYVALSTR, ILNativeType.ByValStr + nt_TBSTR, ILNativeType.TBSTR + nt_LPSTRUCT, ILNativeType.LPSTRUCT + nt_INTF (* COM interop *) , ILNativeType.Interface + nt_STRUCT, ILNativeType.Struct + nt_ERROR (* COM interop *) , ILNativeType.Error + nt_VOID, ILNativeType.Void + nt_BOOLEAN, ILNativeType.Bool + nt_I1, ILNativeType.Int8 + nt_I2, ILNativeType.Int16 + nt_I4, ILNativeType.Int32 + nt_I8, ILNativeType.Int64 + nt_R4, ILNativeType.Single + nt_R8, ILNativeType.Double + nt_U1, ILNativeType.Byte + nt_U2, ILNativeType.UInt16 + nt_U4, ILNativeType.UInt32 + nt_U8, ILNativeType.UInt64 + nt_INT, ILNativeType.Int + nt_UINT, ILNativeType.UInt + nt_ANSIBSTR (* COM interop *) , ILNativeType.ANSIBSTR + nt_VARIANTBOOL (* COM interop *) , ILNativeType.VariantBool + nt_FUNC, ILNativeType.Method + nt_ASANY, ILNativeType.AsAny + ] + +let ILNativeTypeRevMap = + lazy (List.map (fun (x, y) -> (y, x)) (Lazy.force ILNativeTypeMap)) + +let ILVariantTypeMap = + lazy + [ + ILNativeVariant.Empty, vt_EMPTY + ILNativeVariant.Null, vt_NULL + ILNativeVariant.Variant, vt_VARIANT + ILNativeVariant.Currency, vt_CY + ILNativeVariant.Decimal, vt_DECIMAL + ILNativeVariant.Date, vt_DATE + ILNativeVariant.BSTR, vt_BSTR + ILNativeVariant.LPSTR, vt_LPSTR + ILNativeVariant.LPWSTR, vt_LPWSTR + ILNativeVariant.IUnknown, vt_UNKNOWN + ILNativeVariant.IDispatch, vt_DISPATCH + ILNativeVariant.SafeArray, vt_SAFEARRAY + ILNativeVariant.Error, vt_ERROR + ILNativeVariant.HRESULT, vt_HRESULT + ILNativeVariant.CArray, vt_CARRAY + ILNativeVariant.UserDefined, vt_USERDEFINED + ILNativeVariant.Record, vt_RECORD + ILNativeVariant.FileTime, vt_FILETIME + ILNativeVariant.Blob, vt_BLOB + ILNativeVariant.Stream, vt_STREAM + ILNativeVariant.Storage, vt_STORAGE + ILNativeVariant.StreamedObject, vt_STREAMED_OBJECT + ILNativeVariant.StoredObject, vt_STORED_OBJECT + ILNativeVariant.BlobObject, vt_BLOB_OBJECT + ILNativeVariant.CF, vt_CF + ILNativeVariant.CLSID, vt_CLSID + ILNativeVariant.Void, vt_VOID + ILNativeVariant.Bool, vt_BOOL + ILNativeVariant.Int8, vt_I1 + ILNativeVariant.Int16, vt_I2 + ILNativeVariant.Int32, vt_I4 + ILNativeVariant.Int64, vt_I8 + ILNativeVariant.Single, vt_R4 + ILNativeVariant.Double, vt_R8 + ILNativeVariant.UInt8, vt_UI1 + ILNativeVariant.UInt16, vt_UI2 + ILNativeVariant.UInt32, vt_UI4 + ILNativeVariant.UInt64, vt_UI8 + ILNativeVariant.PTR, vt_PTR + ILNativeVariant.Int, vt_INT + ILNativeVariant.UInt, vt_UINT + ] + +let ILVariantTypeRevMap = + lazy (List.map (fun (x, y) -> (y, x)) (Lazy.force ILVariantTypeMap)) let ILSecurityActionMap = - lazy - [ ILSecurityAction.Request, 0x0001 - ILSecurityAction.Demand, 0x0002 - ILSecurityAction.Assert, 0x0003 - ILSecurityAction.Deny, 0x0004 - ILSecurityAction.PermitOnly, 0x0005 - ILSecurityAction.LinkCheck, 0x0006 - ILSecurityAction.InheritCheck, 0x0007 - ILSecurityAction.ReqMin, 0x0008 - ILSecurityAction.ReqOpt, 0x0009 - ILSecurityAction.ReqRefuse, 0x000a - ILSecurityAction.PreJitGrant, 0x000b - ILSecurityAction.PreJitDeny, 0x000c - ILSecurityAction.NonCasDemand, 0x000d - ILSecurityAction.NonCasLinkDemand, 0x000e - ILSecurityAction.NonCasInheritance, 0x000f - ILSecurityAction.LinkDemandChoice, 0x0010 - ILSecurityAction.InheritanceDemandChoice, 0x0011 - ILSecurityAction.DemandChoice, 0x0012 ] - -let ILSecurityActionRevMap = lazy (List.map (fun (x,y) -> (y,x)) (Lazy.force ILSecurityActionMap)) + lazy + [ + ILSecurityAction.Request, 0x0001 + ILSecurityAction.Demand, 0x0002 + ILSecurityAction.Assert, 0x0003 + ILSecurityAction.Deny, 0x0004 + ILSecurityAction.PermitOnly, 0x0005 + ILSecurityAction.LinkCheck, 0x0006 + ILSecurityAction.InheritCheck, 0x0007 + ILSecurityAction.ReqMin, 0x0008 + ILSecurityAction.ReqOpt, 0x0009 + ILSecurityAction.ReqRefuse, 0x000a + ILSecurityAction.PreJitGrant, 0x000b + ILSecurityAction.PreJitDeny, 0x000c + ILSecurityAction.NonCasDemand, 0x000d + ILSecurityAction.NonCasLinkDemand, 0x000e + ILSecurityAction.NonCasInheritance, 0x000f + ILSecurityAction.LinkDemandChoice, 0x0010 + ILSecurityAction.InheritanceDemandChoice, 0x0011 + ILSecurityAction.DemandChoice, 0x0012 + ] + +let ILSecurityActionRevMap = + lazy (List.map (fun (x, y) -> (y, x)) (Lazy.force ILSecurityActionMap)) let e_CorILMethod_TinyFormat = 0x02uy let e_CorILMethod_FatFormat = 0x03uy @@ -996,7 +1038,6 @@ let e_CorILMethod_FormatMask = 0x03uy let e_CorILMethod_MoreSects = 0x08uy let e_CorILMethod_InitLocals = 0x10uy - let e_CorILMethod_Sect_EHTable = 0x1uy let e_CorILMethod_Sect_FatFormat = 0x40uy let e_CorILMethod_Sect_MoreSects = 0x80uy @@ -1019,5 +1060,3 @@ let e_IMAGE_CEE_CS_CALLCONV_GENERICINST = 0x0auy let e_IMAGE_CEE_CS_CALLCONV_GENERIC = 0x10uy let e_IMAGE_CEE_CS_CALLCONV_INSTANCE = 0x20uy let e_IMAGE_CEE_CS_CALLCONV_INSTANCE_EXPLICIT = 0x40uy - - diff --git a/src/Compiler/AbstractIL/ilmorph.fs b/src/Compiler/AbstractIL/ilmorph.fs index 6d50df04c..dd60d94d0 100644 --- a/src/Compiler/AbstractIL/ilmorph.fs +++ b/src/Compiler/AbstractIL/ilmorph.fs @@ -1,226 +1,261 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -module internal FSharp.Compiler.AbstractIL.Morphs +module internal FSharp.Compiler.AbstractIL.Morphs open System.Collections.Generic -open Internal.Utilities.Library -open FSharp.Compiler.AbstractIL.IL +open Internal.Utilities.Library +open FSharp.Compiler.AbstractIL.IL let mutable morphCustomAttributeData = false -let enableMorphCustomAttributeData() = - morphCustomAttributeData <- true +let enableMorphCustomAttributeData () = morphCustomAttributeData <- true -let disableMorphCustomAttributeData() = - morphCustomAttributeData <- false +let disableMorphCustomAttributeData () = morphCustomAttributeData <- false let code_instr2instr f (code: ILCode) = - { code with Instrs= Array.map f code.Instrs} + { code with + Instrs = Array.map f code.Instrs + } -let code_instr2instrs f (code: ILCode) = +let code_instr2instrs f (code: ILCode) = let instrs = code.Instrs let codebuf = ResizeArray() let adjust = Dictionary() let mutable old = 0 let mutable nw = 0 - for instr in instrs do + + for instr in instrs do adjust[old] <- nw - let instrs : _ list = f instr + let instrs: _ list = f instr + for instr2 in instrs do codebuf.Add instr2 nw <- nw + 1 + old <- old + 1 + adjust[old] <- nw + let labels = let dict = Dictionary.newWithSize code.Labels.Count - for kvp in code.Labels do dict.Add(kvp.Key, adjust[kvp.Value]) + + for kvp in code.Labels do + dict.Add(kvp.Key, adjust[kvp.Value]) + dict - { code with - Instrs = codebuf.ToArray() - Labels = labels } -let code_instr2instr_ty2ty (finstr,fTy) (code: ILCode) = + { code with + Instrs = codebuf.ToArray() + Labels = labels + } + +let code_instr2instr_ty2ty (finstr, fTy) (code: ILCode) = let codeR = code_instr2instr finstr code + let exnSpecsR = - [ for exnSpec in codeR.Exceptions do - let clause = - match exnSpec.Clause with - | ILExceptionClause.TypeCatch (ilTy, b) -> ILExceptionClause.TypeCatch (fTy ilTy, b) - | cl -> cl - { exnSpec with Clause = clause } ] + [ + for exnSpec in codeR.Exceptions do + let clause = + match exnSpec.Clause with + | ILExceptionClause.TypeCatch (ilTy, b) -> ILExceptionClause.TypeCatch(fTy ilTy, b) + | cl -> cl + + { exnSpec with Clause = clause } + ] + { codeR with Exceptions = exnSpecsR } // -------------------------------------------------------------------- // Standard morphisms - mapping types etc. -// -------------------------------------------------------------------- +// -------------------------------------------------------------------- -let rec morphILTypeRefsInILType f x = - match x with - | ILType.Ptr t -> ILType.Ptr (morphILTypeRefsInILType f t) - | ILType.FunctionPointer x -> +let rec morphILTypeRefsInILType f x = + match x with + | ILType.Ptr t -> ILType.Ptr(morphILTypeRefsInILType f t) + | ILType.FunctionPointer x -> ILType.FunctionPointer - { x with - ArgTypes=List.map (morphILTypeRefsInILType f) x.ArgTypes - ReturnType=morphILTypeRefsInILType f x.ReturnType} - | ILType.Byref t -> ILType.Byref (morphILTypeRefsInILType f t) + { x with + ArgTypes = List.map (morphILTypeRefsInILType f) x.ArgTypes + ReturnType = morphILTypeRefsInILType f x.ReturnType + } + | ILType.Byref t -> ILType.Byref(morphILTypeRefsInILType f t) | ILType.Boxed cr -> mkILBoxedType (tspec_tref2tref f cr) - | ILType.Value ir -> ILType.Value (tspec_tref2tref f ir) - | ILType.Array (s,ty) -> ILType.Array (s,morphILTypeRefsInILType f ty) - | ILType.TypeVar v -> ILType.TypeVar v - | ILType.Modified (req,tref,ty) -> ILType.Modified (req, f tref, morphILTypeRefsInILType f ty) + | ILType.Value ir -> ILType.Value(tspec_tref2tref f ir) + | ILType.Array (s, ty) -> ILType.Array(s, morphILTypeRefsInILType f ty) + | ILType.TypeVar v -> ILType.TypeVar v + | ILType.Modified (req, tref, ty) -> ILType.Modified(req, f tref, morphILTypeRefsInILType f ty) | ILType.Void -> ILType.Void -and tspec_tref2tref f (tspec: ILTypeSpec) = - mkILTySpec(f tspec.TypeRef, List.map (morphILTypeRefsInILType f) tspec.GenericArgs) +and tspec_tref2tref f (tspec: ILTypeSpec) = + mkILTySpec (f tspec.TypeRef, List.map (morphILTypeRefsInILType f) tspec.GenericArgs) -let rec ty_scoref2scoref_tyvar2ty ((_fscope, fTyvar) as fs) ty = - match ty with - | ILType.Ptr elemTy -> ILType.Ptr (ty_scoref2scoref_tyvar2ty fs elemTy) - | ILType.FunctionPointer callsig -> ILType.FunctionPointer (callsig_scoref2scoref_tyvar2ty fs callsig) - | ILType.Byref elemTy -> ILType.Byref (ty_scoref2scoref_tyvar2ty fs elemTy) +let rec ty_scoref2scoref_tyvar2ty ((_fscope, fTyvar) as fs) ty = + match ty with + | ILType.Ptr elemTy -> ILType.Ptr(ty_scoref2scoref_tyvar2ty fs elemTy) + | ILType.FunctionPointer callsig -> ILType.FunctionPointer(callsig_scoref2scoref_tyvar2ty fs callsig) + | ILType.Byref elemTy -> ILType.Byref(ty_scoref2scoref_tyvar2ty fs elemTy) | ILType.Boxed tspec -> mkILBoxedType (tspec_scoref2scoref_tyvar2ty fs tspec) - | ILType.Value tspec -> ILType.Value (tspec_scoref2scoref_tyvar2ty fs tspec) - | ILType.Array (shape, elemTy) -> ILType.Array (shape,ty_scoref2scoref_tyvar2ty fs elemTy) - | ILType.TypeVar idx -> fTyvar idx + | ILType.Value tspec -> ILType.Value(tspec_scoref2scoref_tyvar2ty fs tspec) + | ILType.Array (shape, elemTy) -> ILType.Array(shape, ty_scoref2scoref_tyvar2ty fs elemTy) + | ILType.TypeVar idx -> fTyvar idx | x -> x -and tspec_scoref2scoref_tyvar2ty fs (x:ILTypeSpec) = - ILTypeSpec.Create(morphILScopeRefsInILTypeRef (fst fs) x.TypeRef,tys_scoref2scoref_tyvar2ty fs x.GenericArgs) +and tspec_scoref2scoref_tyvar2ty fs (x: ILTypeSpec) = + ILTypeSpec.Create(morphILScopeRefsInILTypeRef (fst fs) x.TypeRef, tys_scoref2scoref_tyvar2ty fs x.GenericArgs) -and callsig_scoref2scoref_tyvar2ty f x = - { x with - ArgTypes=List.map (ty_scoref2scoref_tyvar2ty f) x.ArgTypes - ReturnType=ty_scoref2scoref_tyvar2ty f x.ReturnType} +and callsig_scoref2scoref_tyvar2ty f x = + { x with + ArgTypes = List.map (ty_scoref2scoref_tyvar2ty f) x.ArgTypes + ReturnType = ty_scoref2scoref_tyvar2ty f x.ReturnType + } -and tys_scoref2scoref_tyvar2ty f i = List.map (ty_scoref2scoref_tyvar2ty f) i +and tys_scoref2scoref_tyvar2ty f i = + List.map (ty_scoref2scoref_tyvar2ty f) i -and gparams_scoref2scoref_tyvar2ty f i = List.map (gparam_scoref2scoref_tyvar2ty f) i +and gparams_scoref2scoref_tyvar2ty f i = + List.map (gparam_scoref2scoref_tyvar2ty f) i and gparam_scoref2scoref_tyvar2ty _f i = i -and morphILScopeRefsInILTypeRef fscope (tref: ILTypeRef) = - ILTypeRef.Create(scope=fscope tref.Scope, enclosing=tref.Enclosing, name = tref.Name) +and morphILScopeRefsInILTypeRef fscope (tref: ILTypeRef) = + ILTypeRef.Create(scope = fscope tref.Scope, enclosing = tref.Enclosing, name = tref.Name) -let callsig_ty2ty f (callsig: ILCallingSignature) = - { CallingConv = callsig.CallingConv - ArgTypes = List.map f callsig.ArgTypes - ReturnType = f callsig.ReturnType} +let callsig_ty2ty f (callsig: ILCallingSignature) = + { + CallingConv = callsig.CallingConv + ArgTypes = List.map f callsig.ArgTypes + ReturnType = f callsig.ReturnType + } -let gparam_ty2ty f gf = {gf with Constraints = List.map f gf.Constraints} -let gparams_ty2ty f gfs = List.map (gparam_ty2ty f) gfs -let tys_ty2ty (f: ILType -> ILType) x = List.map f x -let mref_ty2ty (f: ILType -> ILType) (x:ILMethodRef) = - ILMethodRef.Create(enclosingTypeRef= (f (mkILBoxedType (mkILNonGenericTySpec x.DeclaringTypeRef))).TypeRef, - callingConv=x.CallingConv, - name=x.Name, - genericArity=x.GenericArity, - argTypes= List.map f x.ArgTypes, - returnType= f x.ReturnType) +let gparam_ty2ty f gf = + { gf with + Constraints = List.map f gf.Constraints + } +let gparams_ty2ty f gfs = List.map (gparam_ty2ty f) gfs +let tys_ty2ty (f: ILType -> ILType) x = List.map f x + +let mref_ty2ty (f: ILType -> ILType) (x: ILMethodRef) = + ILMethodRef.Create( + enclosingTypeRef = (f (mkILBoxedType (mkILNonGenericTySpec x.DeclaringTypeRef))).TypeRef, + callingConv = x.CallingConv, + name = x.Name, + genericArity = x.GenericArity, + argTypes = List.map f x.ArgTypes, + returnType = f x.ReturnType + ) type formal_scopeCtxt = Choice -let mspec_ty2ty ((factualTy : ILType -> ILType, fformalTy: formal_scopeCtxt -> ILType -> ILType)) (x: ILMethodSpec) = - mkILMethSpecForMethRefInTy(mref_ty2ty (fformalTy (Choice1Of2 x)) x.MethodRef, - factualTy x.DeclaringType, - tys_ty2ty factualTy x.GenericArgs) +let mspec_ty2ty ((factualTy: ILType -> ILType, fformalTy: formal_scopeCtxt -> ILType -> ILType)) (x: ILMethodSpec) = + mkILMethSpecForMethRefInTy ( + mref_ty2ty (fformalTy (Choice1Of2 x)) x.MethodRef, + factualTy x.DeclaringType, + tys_ty2ty factualTy x.GenericArgs + ) -let fref_ty2ty (f: ILType -> ILType) fref = +let fref_ty2ty (f: ILType -> ILType) fref = { fref with DeclaringTypeRef = (f (mkILBoxedType (mkILNonGenericTySpec fref.DeclaringTypeRef))).TypeRef - Type= f fref.Type } + Type = f fref.Type + } -let fspec_ty2ty ((factualTy,fformalTy : formal_scopeCtxt -> ILType -> ILType)) fspec = - { FieldRef=fref_ty2ty (fformalTy (Choice2Of2 fspec)) fspec.FieldRef - DeclaringType= factualTy fspec.DeclaringType } +let fspec_ty2ty ((factualTy, fformalTy: formal_scopeCtxt -> ILType -> ILType)) fspec = + { + FieldRef = fref_ty2ty (fformalTy (Choice2Of2 fspec)) fspec.FieldRef + DeclaringType = factualTy fspec.DeclaringType + } let rec celem_ty2ty f celem = match celem with - | ILAttribElem.Type (Some ty) -> ILAttribElem.Type (Some (f ty)) - | ILAttribElem.TypeRef (Some tref) -> ILAttribElem.TypeRef (Some (f (mkILBoxedType (mkILNonGenericTySpec tref))).TypeRef) - | ILAttribElem.Array (elemTy,elems) -> ILAttribElem.Array (f elemTy, List.map (celem_ty2ty f) elems) + | ILAttribElem.Type (Some ty) -> ILAttribElem.Type(Some(f ty)) + | ILAttribElem.TypeRef (Some tref) -> ILAttribElem.TypeRef(Some (f (mkILBoxedType (mkILNonGenericTySpec tref))).TypeRef) + | ILAttribElem.Array (elemTy, elems) -> ILAttribElem.Array(f elemTy, List.map (celem_ty2ty f) elems) | _ -> celem -let cnamedarg_ty2ty f ((nm, ty, isProp, elem) : ILAttributeNamedArg) = - (nm, f ty, isProp, celem_ty2ty f elem) +let cnamedarg_ty2ty f ((nm, ty, isProp, elem): ILAttributeNamedArg) = (nm, f ty, isProp, celem_ty2ty f elem) let cattr_ty2ty f (c: ILAttribute) = let meth = mspec_ty2ty (f, (fun _ -> f)) c.Method // dev11 M3 defensive coding: if anything goes wrong with attribute decoding or encoding, then back out. if morphCustomAttributeData then - try - let elems,namedArgs = decodeILAttribData c - let elems = elems |> List.map (celem_ty2ty f) - let namedArgs = namedArgs |> List.map (cnamedarg_ty2ty f) - mkILCustomAttribMethRef (meth, elems, namedArgs) - with _ -> - c.WithMethod(meth) + try + let elems, namedArgs = decodeILAttribData c + let elems = elems |> List.map (celem_ty2ty f) + let namedArgs = namedArgs |> List.map (cnamedarg_ty2ty f) + mkILCustomAttribMethRef (meth, elems, namedArgs) + with + | _ -> c.WithMethod(meth) else c.WithMethod(meth) - let cattrs_ty2ty f (cs: ILAttributes) = mkILCustomAttrs (List.map (cattr_ty2ty f) (cs.AsList())) -let fdef_ty2ty fTyInCtxt (fdef: ILFieldDef) = - fdef.With(fieldType=fTyInCtxt fdef.FieldType, - customAttrs=cattrs_ty2ty fTyInCtxt fdef.CustomAttrs) +let fdef_ty2ty fTyInCtxt (fdef: ILFieldDef) = + fdef.With(fieldType = fTyInCtxt fdef.FieldType, customAttrs = cattrs_ty2ty fTyInCtxt fdef.CustomAttrs) -let morphILLocal f (l: ILLocal) = {l with Type = f l.Type} +let morphILLocal f (l: ILLocal) = { l with Type = f l.Type } let morphILVarArgs f (varargs: ILVarArgs) = Option.map (List.map f) varargs -let morphILTypesInILInstr ((factualTy,fformalTy)) i = - let factualTy = factualTy (Some i) - let conv_fspec fr = fspec_ty2ty (factualTy,fformalTy (Some i)) fr - let conv_mspec mr = mspec_ty2ty (factualTy,fformalTy (Some i)) mr - match i with - | I_calli (a,mref,varargs) -> I_calli (a,callsig_ty2ty factualTy mref, morphILVarArgs factualTy varargs) - | I_call (a,mr,varargs) -> I_call (a,conv_mspec mr, morphILVarArgs factualTy varargs) - | I_callvirt (a,mr,varargs) -> I_callvirt (a,conv_mspec mr, morphILVarArgs factualTy varargs) - | I_callconstraint (a,ty,mr,varargs) -> I_callconstraint (a,factualTy ty,conv_mspec mr, morphILVarArgs factualTy varargs) - | I_newobj (mr,varargs) -> I_newobj (conv_mspec mr, morphILVarArgs factualTy varargs) - | I_ldftn mr -> I_ldftn (conv_mspec mr) - | I_ldvirtftn mr -> I_ldvirtftn (conv_mspec mr) - | I_ldfld (a,b,fr) -> I_ldfld (a,b,conv_fspec fr) - | I_ldsfld (a,fr) -> I_ldsfld (a,conv_fspec fr) - | I_ldsflda fr -> I_ldsflda (conv_fspec fr) - | I_ldflda fr -> I_ldflda (conv_fspec fr) - | I_stfld (a,b,fr) -> I_stfld (a,b,conv_fspec fr) - | I_stsfld (a,fr) -> I_stsfld (a,conv_fspec fr) - | I_castclass ty -> I_castclass (factualTy ty) - | I_isinst ty -> I_isinst (factualTy ty) - | I_initobj ty -> I_initobj (factualTy ty) - | I_cpobj ty -> I_cpobj (factualTy ty) - | I_stobj (al,vol,ty) -> I_stobj (al,vol,factualTy ty) - | I_ldobj (al,vol,ty) -> I_ldobj (al,vol,factualTy ty) - | I_box ty -> I_box (factualTy ty) - | I_unbox ty -> I_unbox (factualTy ty) - | I_unbox_any ty -> I_unbox_any (factualTy ty) - | I_ldelem_any (shape,ty) -> I_ldelem_any (shape,factualTy ty) - | I_stelem_any (shape,ty) -> I_stelem_any (shape,factualTy ty) - | I_newarr (shape,ty) -> I_newarr (shape,factualTy ty) - | I_ldelema (ro,isNativePtr,shape,ty) -> I_ldelema (ro,isNativePtr,shape,factualTy ty) - | I_sizeof ty -> I_sizeof (factualTy ty) - | I_ldtoken tok -> - match tok with - | ILToken.ILType ty -> I_ldtoken (ILToken.ILType (factualTy ty)) - | ILToken.ILMethod mr -> I_ldtoken (ILToken.ILMethod (conv_mspec mr)) - | ILToken.ILField fr -> I_ldtoken (ILToken.ILField (conv_fspec fr)) +let morphILTypesInILInstr ((factualTy, fformalTy)) i = + let factualTy = factualTy (Some i) + + let conv_fspec fr = + fspec_ty2ty (factualTy, fformalTy (Some i)) fr + + let conv_mspec mr = + mspec_ty2ty (factualTy, fformalTy (Some i)) mr + + match i with + | I_calli (a, mref, varargs) -> I_calli(a, callsig_ty2ty factualTy mref, morphILVarArgs factualTy varargs) + | I_call (a, mr, varargs) -> I_call(a, conv_mspec mr, morphILVarArgs factualTy varargs) + | I_callvirt (a, mr, varargs) -> I_callvirt(a, conv_mspec mr, morphILVarArgs factualTy varargs) + | I_callconstraint (a, ty, mr, varargs) -> I_callconstraint(a, factualTy ty, conv_mspec mr, morphILVarArgs factualTy varargs) + | I_newobj (mr, varargs) -> I_newobj(conv_mspec mr, morphILVarArgs factualTy varargs) + | I_ldftn mr -> I_ldftn(conv_mspec mr) + | I_ldvirtftn mr -> I_ldvirtftn(conv_mspec mr) + | I_ldfld (a, b, fr) -> I_ldfld(a, b, conv_fspec fr) + | I_ldsfld (a, fr) -> I_ldsfld(a, conv_fspec fr) + | I_ldsflda fr -> I_ldsflda(conv_fspec fr) + | I_ldflda fr -> I_ldflda(conv_fspec fr) + | I_stfld (a, b, fr) -> I_stfld(a, b, conv_fspec fr) + | I_stsfld (a, fr) -> I_stsfld(a, conv_fspec fr) + | I_castclass ty -> I_castclass(factualTy ty) + | I_isinst ty -> I_isinst(factualTy ty) + | I_initobj ty -> I_initobj(factualTy ty) + | I_cpobj ty -> I_cpobj(factualTy ty) + | I_stobj (al, vol, ty) -> I_stobj(al, vol, factualTy ty) + | I_ldobj (al, vol, ty) -> I_ldobj(al, vol, factualTy ty) + | I_box ty -> I_box(factualTy ty) + | I_unbox ty -> I_unbox(factualTy ty) + | I_unbox_any ty -> I_unbox_any(factualTy ty) + | I_ldelem_any (shape, ty) -> I_ldelem_any(shape, factualTy ty) + | I_stelem_any (shape, ty) -> I_stelem_any(shape, factualTy ty) + | I_newarr (shape, ty) -> I_newarr(shape, factualTy ty) + | I_ldelema (ro, isNativePtr, shape, ty) -> I_ldelema(ro, isNativePtr, shape, factualTy ty) + | I_sizeof ty -> I_sizeof(factualTy ty) + | I_ldtoken tok -> + match tok with + | ILToken.ILType ty -> I_ldtoken(ILToken.ILType(factualTy ty)) + | ILToken.ILMethod mr -> I_ldtoken(ILToken.ILMethod(conv_mspec mr)) + | ILToken.ILField fr -> I_ldtoken(ILToken.ILField(conv_fspec fr)) | x -> x -let morphILReturn f (r:ILReturn) = - {r with - Type=f r.Type - CustomAttrsStored= storeILCustomAttrs (cattrs_ty2ty f r.CustomAttrs)} +let morphILReturn f (r: ILReturn) = + { r with + Type = f r.Type + CustomAttrsStored = storeILCustomAttrs (cattrs_ty2ty f r.CustomAttrs) + } let morphILParameter f (p: ILParameter) = { p with - Type=f p.Type - CustomAttrsStored= storeILCustomAttrs (cattrs_ty2ty f p.CustomAttrs)} + Type = f p.Type + CustomAttrsStored = storeILCustomAttrs (cattrs_ty2ty f p.CustomAttrs) + } -let morphILMethodDefs f (m:ILMethodDefs) = - mkILMethods (List.map f (m.AsList())) +let morphILMethodDefs f (m: ILMethodDefs) = mkILMethods (List.map f (m.AsList())) let morphILFieldDefs f (fdefs: ILFieldDefs) = mkILFields (List.map f (fdefs.AsList())) @@ -228,45 +263,48 @@ let morphILFieldDefs f (fdefs: ILFieldDefs) = let morphILTypeDefs f (tdefs: ILTypeDefs) = mkILTypeDefsFromArray (Array.map f (tdefs.AsArray())) -let morphILLocals f locals = - List.map (morphILLocal f) locals +let morphILLocals f locals = List.map (morphILLocal f) locals + +let ilmbody_instr2instr_ty2ty fs (ilmbody: ILMethodBody) = + let finstr, fTyInCtxt = fs -let ilmbody_instr2instr_ty2ty fs (ilmbody: ILMethodBody) = - let finstr, fTyInCtxt = fs - {ilmbody with - Code=code_instr2instr_ty2ty (finstr, fTyInCtxt) ilmbody.Code - Locals = morphILLocals fTyInCtxt ilmbody.Locals } + { ilmbody with + Code = code_instr2instr_ty2ty (finstr, fTyInCtxt) ilmbody.Code + Locals = morphILLocals fTyInCtxt ilmbody.Locals + } -let morphILMethodBody fMethBody (x: MethodBody) = +let morphILMethodBody fMethBody (x: MethodBody) = match x with - | MethodBody.IL il -> + | MethodBody.IL il -> let ilCode = fMethBody il.Value // Eager - MethodBody.IL (lazy ilCode) + MethodBody.IL(lazy ilCode) | x -> x -let ospec_ty2ty f (OverridesSpec(mref,ty)) = OverridesSpec(mref_ty2ty f mref, f ty) +let ospec_ty2ty f (OverridesSpec (mref, ty)) = OverridesSpec(mref_ty2ty f mref, f ty) + +let mdef_ty2ty_ilmbody2ilmbody fs (md: ILMethodDef) = + let fTyInCtxt, fMethBody = fs + let fTyInCtxtR = fTyInCtxt (Some md) + let bodyR = morphILMethodBody (fMethBody (Some md)) md.Body -let mdef_ty2ty_ilmbody2ilmbody fs (md: ILMethodDef) = - let fTyInCtxt,fMethBody = fs - let fTyInCtxtR = fTyInCtxt (Some md) - let bodyR = morphILMethodBody (fMethBody (Some md)) md.Body md.With( - genericParams=gparams_ty2ty fTyInCtxtR md.GenericParams, - body= notlazy bodyR, + genericParams = gparams_ty2ty fTyInCtxtR md.GenericParams, + body = notlazy bodyR, parameters = List.map (morphILParameter fTyInCtxtR) md.Parameters, ret = morphILReturn fTyInCtxtR md.Return, - customAttrs=cattrs_ty2ty fTyInCtxtR md.CustomAttrs + customAttrs = cattrs_ty2ty fTyInCtxtR md.CustomAttrs ) -let fdefs_ty2ty f fdefs = - morphILFieldDefs (fdef_ty2ty f) fdefs +let fdefs_ty2ty f fdefs = morphILFieldDefs (fdef_ty2ty f) fdefs let mdefs_ty2ty_ilmbody2ilmbody fs mdefs = morphILMethodDefs (mdef_ty2ty_ilmbody2ilmbody fs) mdefs let mimpl_ty2ty f mimpl = - { Overrides = ospec_ty2ty f mimpl.Overrides - OverrideBy = mspec_ty2ty (f,(fun _ -> f)) mimpl.OverrideBy; } + { + Overrides = ospec_ty2ty f mimpl.Overrides + OverrideBy = mspec_ty2ty (f, (fun _ -> f)) mimpl.OverrideBy + } let edef_ty2ty f (edef: ILEventDef) = edef.With( @@ -293,64 +331,77 @@ let pdefs_ty2ty f (pdefs: ILPropertyDefs) = let edefs_ty2ty f (edefs: ILEventDefs) = mkILEvents (edefs.AsList() |> List.map (edef_ty2ty f)) -let mimpls_ty2ty f (mimpls : ILMethodImplDefs) = +let mimpls_ty2ty f (mimpls: ILMethodImplDefs) = mkILMethodImpls (mimpls.AsList() |> List.map (mimpl_ty2ty f)) -let rec tdef_ty2ty_ilmbody2ilmbody_mdefs2mdefs enc fs (tdef: ILTypeDef) = - let fTyInCtxt,fMethodDefs = fs - let fTyInCtxtR = fTyInCtxt (Some (enc,tdef)) None - let mdefsR = fMethodDefs (enc, tdef) tdef.Methods - let fdefsR = fdefs_ty2ty fTyInCtxtR tdef.Fields - tdef.With( - implements= List.map fTyInCtxtR tdef.Implements, - genericParams= gparams_ty2ty fTyInCtxtR tdef.GenericParams, - extends = Option.map fTyInCtxtR tdef.Extends, - methods=mdefsR, - nestedTypes=tdefs_ty2ty_ilmbody2ilmbody_mdefs2mdefs (enc@[tdef]) fs tdef.NestedTypes, - fields=fdefsR, - methodImpls = mimpls_ty2ty fTyInCtxtR tdef.MethodImpls, - events = edefs_ty2ty fTyInCtxtR tdef.Events, - properties = pdefs_ty2ty fTyInCtxtR tdef.Properties, - customAttrs = cattrs_ty2ty fTyInCtxtR tdef.CustomAttrs - ) - -and tdefs_ty2ty_ilmbody2ilmbody_mdefs2mdefs enc fs tdefs = - morphILTypeDefs (tdef_ty2ty_ilmbody2ilmbody_mdefs2mdefs enc fs) tdefs +let rec tdef_ty2ty_ilmbody2ilmbody_mdefs2mdefs enc fs (tdef: ILTypeDef) = + let fTyInCtxt, fMethodDefs = fs + let fTyInCtxtR = fTyInCtxt (Some(enc, tdef)) None + let mdefsR = fMethodDefs (enc, tdef) tdef.Methods + let fdefsR = fdefs_ty2ty fTyInCtxtR tdef.Fields + + tdef.With( + implements = List.map fTyInCtxtR tdef.Implements, + genericParams = gparams_ty2ty fTyInCtxtR tdef.GenericParams, + extends = Option.map fTyInCtxtR tdef.Extends, + methods = mdefsR, + nestedTypes = tdefs_ty2ty_ilmbody2ilmbody_mdefs2mdefs (enc @ [ tdef ]) fs tdef.NestedTypes, + fields = fdefsR, + methodImpls = mimpls_ty2ty fTyInCtxtR tdef.MethodImpls, + events = edefs_ty2ty fTyInCtxtR tdef.Events, + properties = pdefs_ty2ty fTyInCtxtR tdef.Properties, + customAttrs = cattrs_ty2ty fTyInCtxtR tdef.CustomAttrs + ) + +and tdefs_ty2ty_ilmbody2ilmbody_mdefs2mdefs enc fs tdefs = + morphILTypeDefs (tdef_ty2ty_ilmbody2ilmbody_mdefs2mdefs enc fs) tdefs // -------------------------------------------------------------------- // Derived versions of the above, e.g. with defaults added -// -------------------------------------------------------------------- +// -------------------------------------------------------------------- -let manifest_ty2ty f (m : ILAssemblyManifest) = - { m with CustomAttrsStored = storeILCustomAttrs (cattrs_ty2ty f m.CustomAttrs) } +let manifest_ty2ty f (m: ILAssemblyManifest) = + { m with + CustomAttrsStored = storeILCustomAttrs (cattrs_ty2ty f m.CustomAttrs) + } -let morphILTypeInILModule_ilmbody2ilmbody_mdefs2mdefs (fTyInCtxt: ILModuleDef -> (ILTypeDef list * ILTypeDef) option -> ILMethodDef option -> ILType -> ILType, fMethodDefs) modul = +let morphILTypeInILModule_ilmbody2ilmbody_mdefs2mdefs + (fTyInCtxt: ILModuleDef -> (ILTypeDef list * ILTypeDef) option -> ILMethodDef option -> ILType -> ILType, fMethodDefs) + modul + = - let ftdefs = tdefs_ty2ty_ilmbody2ilmbody_mdefs2mdefs [] (fTyInCtxt modul, fMethodDefs modul) + let ftdefs = + tdefs_ty2ty_ilmbody2ilmbody_mdefs2mdefs [] (fTyInCtxt modul, fMethodDefs modul) { modul with - TypeDefs=ftdefs modul.TypeDefs - CustomAttrsStored= storeILCustomAttrs (cattrs_ty2ty (fTyInCtxt modul None None) modul.CustomAttrs) - Manifest=Option.map (manifest_ty2ty (fTyInCtxt modul None None)) modul.Manifest } - -let morphILInstrsAndILTypesInILModule fs modul = - let fCode, fTyInCtxt = fs - let fMethBody modCtxt tdefCtxt mdefCtxt = ilmbody_instr2instr_ty2ty (fCode modCtxt tdefCtxt mdefCtxt, fTyInCtxt modCtxt (Some tdefCtxt) mdefCtxt) - let fMethodDefs modCtxt tdefCtxt = mdefs_ty2ty_ilmbody2ilmbody (fTyInCtxt modCtxt (Some tdefCtxt), fMethBody modCtxt tdefCtxt) - morphILTypeInILModule_ilmbody2ilmbody_mdefs2mdefs (fTyInCtxt, fMethodDefs) modul - -let morphILInstrsInILCode f ilcode = - code_instr2instrs f ilcode - -let morphILTypeInILModule fTyInCtxt modul = + TypeDefs = ftdefs modul.TypeDefs + CustomAttrsStored = storeILCustomAttrs (cattrs_ty2ty (fTyInCtxt modul None None) modul.CustomAttrs) + Manifest = Option.map (manifest_ty2ty (fTyInCtxt modul None None)) modul.Manifest + } + +let morphILInstrsAndILTypesInILModule fs modul = + let fCode, fTyInCtxt = fs + + let fMethBody modCtxt tdefCtxt mdefCtxt = + ilmbody_instr2instr_ty2ty (fCode modCtxt tdefCtxt mdefCtxt, fTyInCtxt modCtxt (Some tdefCtxt) mdefCtxt) + + let fMethodDefs modCtxt tdefCtxt = + mdefs_ty2ty_ilmbody2ilmbody (fTyInCtxt modCtxt (Some tdefCtxt), fMethBody modCtxt tdefCtxt) + + morphILTypeInILModule_ilmbody2ilmbody_mdefs2mdefs (fTyInCtxt, fMethodDefs) modul + +let morphILInstrsInILCode f ilcode = code_instr2instrs f ilcode + +let morphILTypeInILModule fTyInCtxt modul = let finstr modCtxt tdefCtxt mdefCtxt = - let fTy = fTyInCtxt modCtxt (Some tdefCtxt) mdefCtxt - morphILTypesInILInstr ((fun _instrCtxt -> fTy), (fun _instrCtxt _formalCtxt -> fTy)) + let fTy = fTyInCtxt modCtxt (Some tdefCtxt) mdefCtxt + morphILTypesInILInstr ((fun _instrCtxt -> fTy), (fun _instrCtxt _formalCtxt -> fTy)) + morphILInstrsAndILTypesInILModule (finstr, fTyInCtxt) modul -let morphILTypeRefsInILModuleMemoized f modul = +let morphILTypeRefsInILModuleMemoized f modul = let fTy = Tables.memoize (morphILTypeRefsInILType f) morphILTypeInILModule (fun _ _ _ ty -> fTy ty) modul -let morphILScopeRefsInILModuleMemoized f modul = +let morphILScopeRefsInILModuleMemoized f modul = morphILTypeRefsInILModuleMemoized (morphILScopeRefsInILTypeRef f) modul diff --git a/src/Compiler/AbstractIL/ilnativeres.fs b/src/Compiler/AbstractIL/ilnativeres.fs index fbb790235..8bbf79f9a 100644 --- a/src/Compiler/AbstractIL/ilnativeres.fs +++ b/src/Compiler/AbstractIL/ilnativeres.fs @@ -31,13 +31,13 @@ let inline WCHAR s = char s let inline BYTE s = byte s type ResourceException(name: string, ?inner: Exception MaybeNull) = - inherit Exception (name, Option.toObj inner) + inherit Exception(name, Option.toObj inner) -type RESOURCE_STRING () = +type RESOURCE_STRING() = member val Ordinal = Unchecked.defaultof with get, set member val theString = Unchecked.defaultof with get, set -type RESOURCE () = +type RESOURCE() = member val pstringType = Unchecked.defaultof with get, set member val pstringName = Unchecked.defaultof with get, set member val DataSize = Unchecked.defaultof with get, set @@ -49,23 +49,27 @@ type RESOURCE () = member val Characteristics = Unchecked.defaultof with get, set member val data = Unchecked.defaultof with get, set -type CvtResFile () = +type CvtResFile() = static member val private RT_DLGINCLUDE = 17 with get, set - static member ReadResFile (stream: Stream) = - let mutable reader = new BinaryReader (stream, Encoding.Unicode) + static member ReadResFile(stream: Stream) = + let mutable reader = new BinaryReader(stream, Encoding.Unicode) let mutable resourceNames = List() // The stream might be empty, so let's check - if not (reader.PeekChar () = -1) then + if not (reader.PeekChar() = -1) then let mutable startPos = stream.Position - let mutable initial32Bits = reader.ReadUInt32 () + let mutable initial32Bits = reader.ReadUInt32() + if initial32Bits <> uint32 0 then - raise <| ResourceException(FSComp.SR.nativeResourceFormatError()) + raise <| ResourceException(FSComp.SR.nativeResourceFormatError ()) + stream.Position <- startPos + while (stream.Position < stream.Length) do - let mutable cbData = reader.ReadUInt32 () - let mutable cbHdr = reader.ReadUInt32 () + let mutable cbData = reader.ReadUInt32() + let mutable cbHdr = reader.ReadUInt32() + if cbHdr < 2u * uint32 sizeof then // TODO: // Current FSComp.txt converter doesn't yet support %x and %lx so format it as a string @@ -73,6 +77,7 @@ type CvtResFile () = // The conversion fix flows through to the lkg let msg = String.Format("0x{0:x}", stream.Position - 8L) raise <| ResourceException(FSComp.SR.nativeResourceHeaderMalformed msg) + if cbData = 0u then stream.Position <- stream.Position + int64 cbHdr - 2L * int64 sizeof else @@ -81,36 +86,42 @@ type CvtResFile () = pAdditional.DataSize <- cbData pAdditional.pstringType <- CvtResFile.ReadStringOrID reader pAdditional.pstringName <- CvtResFile.ReadStringOrID reader - stream.Position <- stream.Position + 3L &&& ~~~3L - pAdditional.DataVersion <- reader.ReadUInt32 () - pAdditional.MemoryFlags <- reader.ReadUInt16 () - pAdditional.LanguageId <- reader.ReadUInt16 () - pAdditional.Version <- reader.ReadUInt32 () - pAdditional.Characteristics <- reader.ReadUInt32 () + stream.Position <- stream.Position + 3L &&& ~~~ 3L + pAdditional.DataVersion <- reader.ReadUInt32() + pAdditional.MemoryFlags <- reader.ReadUInt16() + pAdditional.LanguageId <- reader.ReadUInt16() + pAdditional.Version <- reader.ReadUInt32() + pAdditional.Characteristics <- reader.ReadUInt32() pAdditional.data <- Array.zeroCreate (int pAdditional.DataSize) - reader.Read (pAdditional.data, 0, pAdditional.data.Length) |> ignore - stream.Position <- stream.Position + 3L &&& ~~~3L - if pAdditional.pstringType.theString = Unchecked.defaultof<_> && (pAdditional.pstringType.Ordinal = uint16 CvtResFile.RT_DLGINCLUDE) then + reader.Read(pAdditional.data, 0, pAdditional.data.Length) |> ignore + stream.Position <- stream.Position + 3L &&& ~~~ 3L + + if pAdditional.pstringType.theString = Unchecked.defaultof<_> + && (pAdditional.pstringType.Ordinal = uint16 CvtResFile.RT_DLGINCLUDE) then () (* ERROR ContinueNotSupported *) else resourceNames.Add pAdditional + resourceNames - static member private ReadStringOrID (fhIn: BinaryReader) = - let mutable (pstring: RESOURCE_STRING) = RESOURCE_STRING () - let mutable (firstWord: WCHAR) = (fhIn.ReadChar ()) + static member private ReadStringOrID(fhIn: BinaryReader) = + let mutable (pstring: RESOURCE_STRING) = RESOURCE_STRING() + let mutable (firstWord: WCHAR) = (fhIn.ReadChar()) + if int firstWord = 0xFFFF then - pstring.Ordinal <- fhIn.ReadUInt16 () + pstring.Ordinal <- fhIn.ReadUInt16() else pstring.Ordinal <- uint16 0xFFFF - let mutable (sb: StringBuilder) = StringBuilder () + let mutable (sb: StringBuilder) = StringBuilder() let mutable (curChar: WCHAR) = firstWord + while (curChar <> char 0) do sb.Append(curChar) |> ignore - curChar <- fhIn.ReadChar () - pstring.theString <- sb.ToString () - pstring + curChar <- fhIn.ReadChar() + + pstring.theString <- sb.ToString() + pstring [] type SectionCharacteristics = @@ -162,105 +173,146 @@ type SectionCharacteristics = | MemWrite = 2147483648u type ResourceSection() = - new(sectionBytes: byte[], relocations: uint32[]) as this = - (ResourceSection ()) + new(sectionBytes: byte[], relocations: uint32[]) as this = + (ResourceSection()) then - Debug.Assert (sectionBytes :> obj <> Unchecked.defaultof<_>) - Debug.Assert (relocations :> obj <> Unchecked.defaultof<_>) + Debug.Assert(sectionBytes :> obj <> Unchecked.defaultof<_>) + Debug.Assert(relocations :> obj <> Unchecked.defaultof<_>) this.SectionBytes <- sectionBytes this.Relocations <- relocations - member val SectionBytes = Unchecked.defaultof with get,set - member val Relocations = Unchecked.defaultof with get,set + member val SectionBytes = Unchecked.defaultof with get, set + member val Relocations = Unchecked.defaultof with get, set [] -type StreamExtensions () = +type StreamExtensions() = [] - static member TryReadAll (stream: Stream, buffer: byte[], offset: int, count: int) = - Debug.Assert (count > 0) + static member TryReadAll(stream: Stream, buffer: byte[], offset: int, count: int) = + Debug.Assert(count > 0) let mutable (totalBytesRead: int) = Unchecked.defaultof let mutable (isFinished: bool) = false let mutable (bytesRead: int) = 0 - do + + do totalBytesRead <- 0 + while totalBytesRead < count && not isFinished do - bytesRead <- stream.Read (buffer, (offset + totalBytesRead), (count - totalBytesRead)) + bytesRead <- stream.Read(buffer, (offset + totalBytesRead), (count - totalBytesRead)) + if bytesRead = 0 then isFinished <- true // break; - else totalBytesRead <- totalBytesRead + bytesRead + else + totalBytesRead <- totalBytesRead + bytesRead + totalBytesRead type COFFResourceReader() = - static member private ConfirmSectionValues (hdr: SectionHeader, fileSize: int64) = + static member private ConfirmSectionValues(hdr: SectionHeader, fileSize: int64) = if int64 hdr.PointerToRawData + int64 hdr.SizeOfRawData > fileSize then raise <| ResourceException "CoffResourceInvalidSectionSize" - static member ReadWin32ResourcesFromCOFF (stream: Stream) = + static member ReadWin32ResourcesFromCOFF(stream: Stream) = let mutable peHeaders = PEHeaders(stream) - let mutable rsrc1 = SectionHeader () - let mutable rsrc2 = SectionHeader () + let mutable rsrc1 = SectionHeader() + let mutable rsrc2 = SectionHeader() let mutable (foundCount: int) = 0 + for sectionHeader in peHeaders.SectionHeaders do if sectionHeader.Name = ".rsrc$01" then rsrc1 <- sectionHeader foundCount <- foundCount + 1 - else - if sectionHeader.Name = ".rsrc$02" then - rsrc2 <- sectionHeader - foundCount <- foundCount + 1 + else if sectionHeader.Name = ".rsrc$02" then + rsrc2 <- sectionHeader + foundCount <- foundCount + 1 + if foundCount <> 2 then raise <| ResourceException "CoffResourceMissingSection" - COFFResourceReader.ConfirmSectionValues (rsrc1, stream.Length) - COFFResourceReader.ConfirmSectionValues (rsrc2, stream.Length) - let mutable imageResourceSectionBytes = Array.zeroCreate (rsrc1.SizeOfRawData + rsrc2.SizeOfRawData) - stream.Seek (int64 rsrc1.PointerToRawData, SeekOrigin.Begin) |> ignore - stream.TryReadAll (imageResourceSectionBytes, 0, rsrc1.SizeOfRawData) |> ignore - stream.Seek (int64 rsrc2.PointerToRawData, SeekOrigin.Begin) |> ignore - stream.TryReadAll (imageResourceSectionBytes, rsrc1.SizeOfRawData, rsrc2.SizeOfRawData) |> ignore + + COFFResourceReader.ConfirmSectionValues(rsrc1, stream.Length) + COFFResourceReader.ConfirmSectionValues(rsrc2, stream.Length) + + let mutable imageResourceSectionBytes = + Array.zeroCreate (rsrc1.SizeOfRawData + rsrc2.SizeOfRawData) + + stream.Seek(int64 rsrc1.PointerToRawData, SeekOrigin.Begin) |> ignore + + stream.TryReadAll(imageResourceSectionBytes, 0, rsrc1.SizeOfRawData) + |> ignore + + stream.Seek(int64 rsrc2.PointerToRawData, SeekOrigin.Begin) |> ignore + + stream.TryReadAll(imageResourceSectionBytes, rsrc1.SizeOfRawData, rsrc2.SizeOfRawData) + |> ignore + let mutable (SizeOfRelocationEntry: int) = 10 + try - let mutable relocLastAddress = rsrc1.PointerToRelocations + (int rsrc1.NumberOfRelocations * SizeOfRelocationEntry) + let mutable relocLastAddress = + rsrc1.PointerToRelocations + + (int rsrc1.NumberOfRelocations * SizeOfRelocationEntry) + if int64 relocLastAddress > stream.Length then raise <| ResourceException "CoffResourceInvalidRelocation" with - :? OverflowException -> (raise <| ResourceException("CoffResourceInvalidRelocation")) + | :? OverflowException -> (raise <| ResourceException("CoffResourceInvalidRelocation")) + let mutable relocationOffsets = Array.zeroCreate (int rsrc1.NumberOfRelocations) - let mutable relocationSymbolIndices = Array.zeroCreate (int rsrc1.NumberOfRelocations) - let mutable reader = new BinaryReader (stream, Encoding.Unicode) + + let mutable relocationSymbolIndices = + Array.zeroCreate (int rsrc1.NumberOfRelocations) + + let mutable reader = new BinaryReader(stream, Encoding.Unicode) stream.Position <- int64 rsrc1.PointerToRelocations - do + + do let mutable (i: int) = 0 + while (i < int rsrc1.NumberOfRelocations) do - relocationOffsets[i] <- reader.ReadUInt32 () - relocationSymbolIndices[i] <- reader.ReadUInt32 () - reader.ReadUInt16 () |> ignore //we do nothing with the "Type" + relocationOffsets[i] <- reader.ReadUInt32() + relocationSymbolIndices[i] <- reader.ReadUInt32() + reader.ReadUInt16() |> ignore //we do nothing with the "Type" i <- i + 1 + stream.Position <- int64 peHeaders.CoffHeader.PointerToSymbolTable let mutable (ImageSizeOfSymbol: uint32) = 18u + try - let mutable lastSymAddress = int64 peHeaders.CoffHeader.PointerToSymbolTable + int64 peHeaders.CoffHeader.NumberOfSymbols * int64 ImageSizeOfSymbol (* ERROR UnknownNode *) + let mutable lastSymAddress = + int64 peHeaders.CoffHeader.PointerToSymbolTable + + int64 peHeaders.CoffHeader.NumberOfSymbols + * int64 ImageSizeOfSymbol (* ERROR UnknownNode *) + if lastSymAddress > stream.Length then raise <| ResourceException "CoffResourceInvalidSymbol" with - :? OverflowException -> (raise <| ResourceException("CoffResourceInvalidSymbol")) - let mutable outputStream = new MemoryStream (imageResourceSectionBytes) - let mutable writer = new BinaryWriter (outputStream) - do + | :? OverflowException -> (raise <| ResourceException("CoffResourceInvalidSymbol")) + + let mutable outputStream = new MemoryStream(imageResourceSectionBytes) + let mutable writer = new BinaryWriter(outputStream) + + do let mutable (i: int) = 0 + while (i < relocationSymbolIndices.Length) do if int relocationSymbolIndices[i] > peHeaders.CoffHeader.NumberOfSymbols then raise <| ResourceException "CoffResourceInvalidRelocation" - let mutable offsetOfSymbol = int64 peHeaders.CoffHeader.PointerToSymbolTable + int64 relocationSymbolIndices[i] * int64 ImageSizeOfSymbol + + let mutable offsetOfSymbol = + int64 peHeaders.CoffHeader.PointerToSymbolTable + + int64 relocationSymbolIndices[i] * int64 ImageSizeOfSymbol + stream.Position <- offsetOfSymbol stream.Position <- stream.Position + 8L - let mutable symValue = reader.ReadUInt32 () - let mutable symSection = reader.ReadInt16 () - let mutable symType = reader.ReadUInt16 () + let mutable symValue = reader.ReadUInt32() + let mutable symSection = reader.ReadInt16() + let mutable symType = reader.ReadUInt16() let mutable (IMAGE_SYM_TYPE_NULL: uint16) = uint16 0x0000 + if symType <> IMAGE_SYM_TYPE_NULL || symSection <> 3s then raise <| ResourceException("CoffResourceInvalidSymbol") + outputStream.Position <- int64 relocationOffsets[i] - writer.Write (uint32 (int64 symValue + int64 rsrc1.SizeOfRawData)) + writer.Write(uint32 (int64 symValue + int64 rsrc1.SizeOfRawData)) i <- i + 1 ResourceSection(imageResourceSectionBytes, relocationOffsets) @@ -285,8 +337,8 @@ type VersionHelper() = /// If parsing succeeds, the parsed version. Otherwise a version that represents as much of the input as could be parsed successfully. /// /// True when parsing succeeds completely (i.e. every character in the string was consumed), false otherwise. - static member TryParse(s: string, [] version: byref) = - VersionHelper.TryParse (s, false, UInt16.MaxValue, true, ref version) + static member TryParse(s: string, [] version: byref) = + VersionHelper.TryParse(s, false, UInt16.MaxValue, true, ref version) /// /// Parses a version string of the form "major [ '.' minor [ '.' ( '*' | ( build [ '.' ( '*' | revision ) ] ) ) ] ]" @@ -302,8 +354,8 @@ type VersionHelper() = /// /// True when parsing succeeds completely (i.e. every character in the string was consumed), false otherwise. - static member TryParseAssemblyVersion (s: string, allowWildcard: bool, [] version: byref) = - VersionHelper.TryParse (s, allowWildcard, (UInt16.MaxValue - 1us), false, ref version) + static member TryParseAssemblyVersion(s: string, allowWildcard: bool, [] version: byref) = + VersionHelper.TryParse(s, allowWildcard, (UInt16.MaxValue - 1us), false, ref version) static member private NullVersion = Version(0, 0, 0, 0) @@ -322,103 +374,133 @@ type VersionHelper() = /// /// /// True when parsing succeeds completely (i.e. every character in the string was consumed), false otherwise. - static member private TryParse(s: string, allowWildcard: bool, maxValue: uint16, allowPartialParse: bool, [] version: byref) = - Debug.Assert (not allowWildcard || maxValue < UInt16.MaxValue) + static member private TryParse + ( + s: string, + allowWildcard: bool, + maxValue: uint16, + allowPartialParse: bool, + [] version: byref + ) = + Debug.Assert(not allowWildcard || maxValue < UInt16.MaxValue) + if String.IsNullOrWhiteSpace s then version <- VersionHelper.NullVersion false else let mutable (elements: string[]) = s.Split '.' - let mutable (hasWildcard: bool) = allowWildcard && elements[(int (elements.Length - 1))] = "*" + + let mutable (hasWildcard: bool) = + allowWildcard && elements[(int (elements.Length - 1))] = "*" + if hasWildcard && elements.Length < 3 || elements.Length > 4 then version <- VersionHelper.NullVersion false else let mutable (values: uint16[]) = Array.zeroCreate 4 - let mutable (lastExplicitValue: int) = + + let mutable (lastExplicitValue: int) = if hasWildcard then elements.Length - 1 - else elements.Length + else + elements.Length + let mutable (parseError: bool) = false let mutable earlyReturn = None - do + + do let mutable (i: int) = 0 let mutable breakLoop = false + while (i < lastExplicitValue) && not breakLoop do - if not (UInt16.TryParse (elements[i], NumberStyles.None, CultureInfo.InvariantCulture, ref values[i])) || values[i] > maxValue then + if + not (UInt16.TryParse(elements[i], NumberStyles.None, CultureInfo.InvariantCulture, ref values[i])) + || values[i] > maxValue + then if not allowPartialParse then earlyReturn <- Some false breakLoop <- true version <- VersionHelper.NullVersion else parseError <- true + if String.IsNullOrWhiteSpace elements[i] then values[i] <- 0us breakLoop <- true + else if values[i] > maxValue then + values[i] <- 0us + breakLoop <- true else - if values[i] > maxValue then - values[i] <- 0us - breakLoop <- true - else - let mutable (invalidFormat: bool) = false - //let mutable (number: bigint) = 0I - do - let mutable idx = 0 - let mutable breakLoop = false - while (idx < elements[i].Length) && not breakLoop do - if not (Char.IsDigit elements[i].[idx]) then - invalidFormat <- true - VersionHelper.TryGetValue ((elements[i].Substring (0, idx)), ref values[i]) |> ignore - breakLoop <- true - else - idx <- idx + 1 - let mutable doBreak = true - if not invalidFormat then - if VersionHelper.TryGetValue (elements[i], ref values[i]) then - //For this scenario the old compiler would continue processing the remaining version elements - //so continue processing - doBreak <- false - () (* ERROR ContinueNotSupported *) - (* ERROR BreakNotSupported *) - if not breakLoop then - i <- i + 1 + let mutable (invalidFormat: bool) = false + //let mutable (number: bigint) = 0I + do + let mutable idx = 0 + let mutable breakLoop = false + + while (idx < elements[i].Length) && not breakLoop do + if not (Char.IsDigit elements[i].[idx]) then + invalidFormat <- true + + VersionHelper.TryGetValue((elements[ i ].Substring(0, idx)), ref values[i]) + |> ignore + + breakLoop <- true + else + idx <- idx + 1 + + let mutable doBreak = true + + if not invalidFormat then + if VersionHelper.TryGetValue(elements[i], ref values[i]) then + //For this scenario the old compiler would continue processing the remaining version elements + //so continue processing + doBreak <- false + () (* ERROR ContinueNotSupported *) + (* ERROR BreakNotSupported *) + if not breakLoop then i <- i + 1 + if hasWildcard then let mutable (i: int) = lastExplicitValue + while (i < values.Length) do values[i] <- UInt16.MaxValue i <- i + 1 + version <- Version(int values[0], int values[1], int values[2], int values[3]) not parseError - static member private TryGetValue(s: string, [] value: byref): bool = + static member private TryGetValue(s: string, [] value: byref) : bool = let mutable (number: bigint) = Unchecked.defaultof - if bigint.TryParse (s, NumberStyles.None, CultureInfo.InvariantCulture, ref number) then + + if bigint.TryParse(s, NumberStyles.None, CultureInfo.InvariantCulture, ref number) then value <- uint16 (number % bigint 65536) true else value <- 0us false - static member GenerateVersionFromPatternAndCurrentTime(time: DateTime, pattern: Version) = + static member GenerateVersionFromPatternAndCurrentTime(time: DateTime, pattern: Version) = if pattern = Unchecked.defaultof<_> || pattern.Revision <> int UInt16.MaxValue then pattern else let mutable time = time - // MSDN doc on the attribute: - // "The default build number increments daily. The default revision number is the number of seconds since midnight local time + // MSDN doc on the attribute: + // "The default build number increments daily. The default revision number is the number of seconds since midnight local time // (without taking into account time zone adjustments for daylight saving time), divided by 2." if time = Unchecked.defaultof then time <- DateTime.Now + let mutable (revision: int) = int time.TimeOfDay.TotalSeconds / 2 - Debug.Assert (revision < int UInt16.MaxValue) + Debug.Assert(revision < int UInt16.MaxValue) + if pattern.Build = int UInt16.MaxValue then let mutable (days: TimeSpan) = time.Date - DateTime(2000, 1, 1) - let mutable (build: int) = Math.Min (int UInt16.MaxValue, (int days.TotalDays)) + let mutable (build: int) = Math.Min(int UInt16.MaxValue, (int days.TotalDays)) Version(pattern.Major, pattern.Minor, int (uint16 build), int (uint16 revision)) else Version(pattern.Major, pattern.Minor, pattern.Build, int (uint16 revision)) -type VersionResourceSerializer () = +type VersionResourceSerializer() = member val private _commentsContents = Unchecked.defaultof with get, set member val private _companyNameContents = Unchecked.defaultof with get, set member val private _fileDescriptionContents = Unchecked.defaultof with get, set @@ -452,9 +534,9 @@ type VersionResourceSerializer () = originalFileName: string, productName: string, productVersion: string, - assemblyVersion: Version) as this = + assemblyVersion: Version) as this = - VersionResourceSerializer () + VersionResourceSerializer() then this._isDll <- isDll this._commentsContents <- comments @@ -468,51 +550,68 @@ type VersionResourceSerializer () = this._productNameContents <- productName this._productVersionContents <- productVersion this._assemblyVersionContents <- assemblyVersion - this._langIdAndCodePageKey <- String.Format ("{0:x4}{1:x4}", 0, VersionResourceSerializer.CP_WINUNICODE) + this._langIdAndCodePageKey <- String.Format("{0:x4}{1:x4}", 0, VersionResourceSerializer.CP_WINUNICODE) static member val private VFT_APP = 0x00000001u static member val private VFT_DLL = 0x00000002u - member private this.GetVerStrings() = seq { - if this._commentsContents <> Unchecked.defaultof<_> then - yield KeyValuePair<_,_>("Comments", this._commentsContents) - if this._companyNameContents <> Unchecked.defaultof<_> then - yield KeyValuePair<_,_>("CompanyName", this._companyNameContents) - if this._fileDescriptionContents <> Unchecked.defaultof<_> then - yield KeyValuePair<_,_>("FileDescription", this._fileDescriptionContents) - yield KeyValuePair<_,_>("FileVersion", this._fileVersionContents) - if this._internalNameContents <> Unchecked.defaultof<_> then - yield KeyValuePair<_,_>("InternalName", this._internalNameContents) - if this._legalCopyrightContents <> Unchecked.defaultof<_> then - yield KeyValuePair<_,_>("LegalCopyright", this._legalCopyrightContents) - if this._legalTrademarksContents <> Unchecked.defaultof<_> then - yield KeyValuePair<_,_>("LegalTrademarks", this._legalTrademarksContents) - if this._originalFileNameContents <> Unchecked.defaultof<_> then - yield KeyValuePair<_,_>("OriginalFilename", this._originalFileNameContents) - if this._productNameContents <> Unchecked.defaultof<_> then - yield KeyValuePair<_,_>("ProductName", this._productNameContents) - yield KeyValuePair<_,_>("ProductVersion", this._fileVersionContents) - if this._assemblyVersionContents <> Unchecked.defaultof<_> then - yield KeyValuePair<_,_>("Assembly Version", this._assemblyVersionContents.ToString()) - } - - member private this.FileType : uint32 = + member private this.GetVerStrings() = + seq { + if this._commentsContents <> Unchecked.defaultof<_> then + yield KeyValuePair<_, _>("Comments", this._commentsContents) + + if this._companyNameContents <> Unchecked.defaultof<_> then + yield KeyValuePair<_, _>("CompanyName", this._companyNameContents) + + if this._fileDescriptionContents <> Unchecked.defaultof<_> then + yield KeyValuePair<_, _>("FileDescription", this._fileDescriptionContents) + + yield KeyValuePair<_, _>("FileVersion", this._fileVersionContents) + + if this._internalNameContents <> Unchecked.defaultof<_> then + yield KeyValuePair<_, _>("InternalName", this._internalNameContents) + + if this._legalCopyrightContents <> Unchecked.defaultof<_> then + yield KeyValuePair<_, _>("LegalCopyright", this._legalCopyrightContents) + + if this._legalTrademarksContents <> Unchecked.defaultof<_> then + yield KeyValuePair<_, _>("LegalTrademarks", this._legalTrademarksContents) + + if this._originalFileNameContents <> Unchecked.defaultof<_> then + yield KeyValuePair<_, _>("OriginalFilename", this._originalFileNameContents) + + if this._productNameContents <> Unchecked.defaultof<_> then + yield KeyValuePair<_, _>("ProductName", this._productNameContents) + + yield KeyValuePair<_, _>("ProductVersion", this._fileVersionContents) + + if this._assemblyVersionContents <> Unchecked.defaultof<_> then + yield KeyValuePair<_, _>("Assembly Version", this._assemblyVersionContents.ToString()) + } + + member private this.FileType: uint32 = if this._isDll then VersionResourceSerializer.VFT_DLL else - VersionResourceSerializer.VFT_APP + VersionResourceSerializer.VFT_APP - member private this.WriteVSFixedFileInfo(writer: BinaryWriter) = + member private this.WriteVSFixedFileInfo(writer: BinaryWriter) = let mutable (fileVersion: Version) = Unchecked.defaultof - VersionHelper.TryParse (this._fileVersionContents, ref fileVersion) |> ignore + + VersionHelper.TryParse(this._fileVersionContents, ref fileVersion) + |> ignore + let mutable (productVersion: Version) = Unchecked.defaultof - VersionHelper.TryParse (this._productVersionContents, ref productVersion) |> ignore + + VersionHelper.TryParse(this._productVersionContents, ref productVersion) + |> ignore + writer.Write 0xFEEF04BDu writer.Write 0x00010000u - writer.Write ((uint32 fileVersion.Major <<< 16) ||| uint32 fileVersion.Minor) - writer.Write ((uint32 fileVersion.Build <<< 16) ||| uint32 fileVersion.Revision) - writer.Write ((uint32 productVersion.Major <<< 16) ||| uint32 productVersion.Minor) - writer.Write ((uint32 productVersion.Build <<< 16) ||| uint32 productVersion.Revision) + writer.Write((uint32 fileVersion.Major <<< 16) ||| uint32 fileVersion.Minor) + writer.Write((uint32 fileVersion.Build <<< 16) ||| uint32 fileVersion.Revision) + writer.Write((uint32 productVersion.Major <<< 16) ||| uint32 productVersion.Minor) + writer.Write((uint32 productVersion.Build <<< 16) ||| uint32 productVersion.Revision) writer.Write 0x0000003Fu writer.Write 0u writer.Write 0x00000004u @@ -521,173 +620,264 @@ type VersionResourceSerializer () = writer.Write 0u writer.Write 0u - static member private PadKeyLen(cb: int) = - VersionResourceSerializer.PadToDword (cb + 3 * sizeof) - 3 * sizeof + static member private PadKeyLen(cb: int) = + VersionResourceSerializer.PadToDword(cb + 3 * sizeof) - 3 * sizeof - static member private PadToDword(cb: int) = - cb + 3 &&& ~~~3 + static member private PadToDword(cb: int) = cb + 3 &&& ~~~ 3 static member val private HDRSIZE = (int (3 * sizeof)) with get, set - static member private SizeofVerString(lpszKey: string, lpszValue: string) = + static member private SizeofVerString(lpszKey: string, lpszValue: string) = let mutable (cbKey: int) = Unchecked.defaultof let mutable (cbValue: int) = Unchecked.defaultof cbKey <- lpszKey.Length + 1 * 2 cbValue <- lpszValue.Length + 1 * 2 - VersionResourceSerializer.PadKeyLen(cbKey) + cbValue + VersionResourceSerializer.HDRSIZE - static member private WriteVersionString(keyValuePair: KeyValuePair, writer: BinaryWriter) = - Debug.Assert (keyValuePair.Value <> Unchecked.defaultof<_>) - let mutable (cbBlock: uint16) = uint16 <| VersionResourceSerializer.SizeofVerString (keyValuePair.Key, keyValuePair.Value) + VersionResourceSerializer.PadKeyLen(cbKey) + + cbValue + + VersionResourceSerializer.HDRSIZE + + static member private WriteVersionString(keyValuePair: KeyValuePair, writer: BinaryWriter) = + Debug.Assert(keyValuePair.Value <> Unchecked.defaultof<_>) + + let mutable (cbBlock: uint16) = + uint16 + <| VersionResourceSerializer.SizeofVerString(keyValuePair.Key, keyValuePair.Value) + let mutable (cbKey: int) = keyValuePair.Key.Length + 1 * 2 //let mutable (cbVal: int) = keyValuePair.Value.Length + 1 * 2 let mutable startPos = writer.BaseStream.Position - Debug.Assert (startPos &&& 3L = 0L) + Debug.Assert(startPos &&& 3L = 0L) writer.Write cbBlock - writer.Write (uint16 (keyValuePair.Value.Length + 1)) + writer.Write(uint16 (keyValuePair.Value.Length + 1)) writer.Write 1us - writer.Write (keyValuePair.Key.ToCharArray ()) - writer.Write (uint16 0) //(WORD)'\0' - writer.Write (Array.zeroCreate (VersionResourceSerializer.PadKeyLen cbKey - cbKey): byte[]) - Debug.Assert (writer.BaseStream.Position &&& 3L = 0L) - writer.Write (keyValuePair.Value.ToCharArray ()) - writer.Write (uint16 0) // (WORD)'\0' - Debug.Assert (int64 cbBlock = writer.BaseStream.Position - startPos) - - static member private KEYSIZE(sz: string) = - VersionResourceSerializer.PadKeyLen (sz.Length + 1 * sizeof) / sizeof - - static member private KEYBYTES(sz: string) = + writer.Write(keyValuePair.Key.ToCharArray()) + writer.Write(uint16 0) //(WORD)'\0' + writer.Write(Array.zeroCreate (VersionResourceSerializer.PadKeyLen cbKey - cbKey): byte[]) + Debug.Assert(writer.BaseStream.Position &&& 3L = 0L) + writer.Write(keyValuePair.Value.ToCharArray()) + writer.Write(uint16 0) // (WORD)'\0' + Debug.Assert(int64 cbBlock = writer.BaseStream.Position - startPos) + + static member private KEYSIZE(sz: string) = + VersionResourceSerializer.PadKeyLen(sz.Length + 1 * sizeof) + / sizeof + + static member private KEYBYTES(sz: string) = VersionResourceSerializer.KEYSIZE sz * sizeof - member private this.GetStringsSize() = + member private this.GetStringsSize() = let mutable (sum: int) = 0 - for verString in this.GetVerStrings () do - sum <- sum + 3 &&& ~~~3 - sum <- sum + VersionResourceSerializer.SizeofVerString (verString.Key, verString.Value) + + for verString in this.GetVerStrings() do + sum <- sum + 3 &&& ~~~ 3 + sum <- sum + VersionResourceSerializer.SizeofVerString(verString.Key, verString.Value) + sum - member this.GetDataSize () = + member this.GetDataSize() = let mutable (sizeEXEVERRESOURCE: int) = - sizeof * 3 * 5 + 2 * sizeof + - VersionResourceSerializer.KEYBYTES VersionResourceSerializer.vsVersionInfoKey + - VersionResourceSerializer.KEYBYTES VersionResourceSerializer.varFileInfoKey + - VersionResourceSerializer.KEYBYTES VersionResourceSerializer.translationKey + - VersionResourceSerializer.KEYBYTES VersionResourceSerializer.stringFileInfoKey + - VersionResourceSerializer.KEYBYTES this._langIdAndCodePageKey + - int VersionResourceSerializer.sizeVS_FIXEDFILEINFO - this.GetStringsSize () + sizeEXEVERRESOURCE - - member this.WriteVerResource (writer: BinaryWriter) = + sizeof * 3 * 5 + + 2 * sizeof + + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.vsVersionInfoKey + + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.varFileInfoKey + + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.translationKey + + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.stringFileInfoKey + + VersionResourceSerializer.KEYBYTES this._langIdAndCodePageKey + + int VersionResourceSerializer.sizeVS_FIXEDFILEINFO + + this.GetStringsSize() + sizeEXEVERRESOURCE + + member this.WriteVerResource(writer: BinaryWriter) = let mutable debugPos = writer.BaseStream.Position - let mutable dataSize = this.GetDataSize () - writer.Write (WORD dataSize) - writer.Write (WORD VersionResourceSerializer.sizeVS_FIXEDFILEINFO) - writer.Write (WORD 0us) - writer.Write (VersionResourceSerializer.vsVersionInfoKey.ToCharArray ()) - writer.Write (Array.zeroCreate (VersionResourceSerializer.KEYBYTES VersionResourceSerializer.vsVersionInfoKey - VersionResourceSerializer.vsVersionInfoKey.Length * 2): byte[]) - Debug.Assert (writer.BaseStream.Position &&& 3L = 0L) + let mutable dataSize = this.GetDataSize() + writer.Write(WORD dataSize) + writer.Write(WORD VersionResourceSerializer.sizeVS_FIXEDFILEINFO) + writer.Write(WORD 0us) + writer.Write(VersionResourceSerializer.vsVersionInfoKey.ToCharArray()) + + writer.Write( + Array.zeroCreate ( + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.vsVersionInfoKey + - VersionResourceSerializer.vsVersionInfoKey.Length * 2 + ): byte[] + ) + + Debug.Assert(writer.BaseStream.Position &&& 3L = 0L) this.WriteVSFixedFileInfo writer - writer.Write (WORD (sizeof * 2 + - 2 * VersionResourceSerializer.HDRSIZE + - VersionResourceSerializer.KEYBYTES VersionResourceSerializer.varFileInfoKey + - VersionResourceSerializer.KEYBYTES VersionResourceSerializer.translationKey)) - writer.Write (WORD 0us) - writer.Write (WORD 1us) - writer.Write (VersionResourceSerializer.varFileInfoKey.ToCharArray ()) - writer.Write (Array.zeroCreate (VersionResourceSerializer.KEYBYTES VersionResourceSerializer.varFileInfoKey - VersionResourceSerializer.varFileInfoKey.Length * 2): byte[]) - Debug.Assert (writer.BaseStream.Position &&& 3L = 0L) - writer.Write (WORD (sizeof * 2 + VersionResourceSerializer.HDRSIZE + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.translationKey)) - writer.Write (WORD (sizeof * 2)) - writer.Write (WORD 0us) - writer.Write (VersionResourceSerializer.translationKey.ToCharArray ()) - writer.Write (Array.zeroCreate (VersionResourceSerializer.KEYBYTES VersionResourceSerializer.translationKey - VersionResourceSerializer.translationKey.Length * 2): byte[]) - Debug.Assert (writer.BaseStream.Position &&& 3L = 0L) + + writer.Write( + WORD( + sizeof * 2 + + 2 * VersionResourceSerializer.HDRSIZE + + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.varFileInfoKey + + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.translationKey + ) + ) + + writer.Write(WORD 0us) + writer.Write(WORD 1us) + writer.Write(VersionResourceSerializer.varFileInfoKey.ToCharArray()) + + writer.Write( + Array.zeroCreate ( + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.varFileInfoKey + - VersionResourceSerializer.varFileInfoKey.Length * 2 + ): byte[] + ) + + Debug.Assert(writer.BaseStream.Position &&& 3L = 0L) + + writer.Write( + WORD( + sizeof * 2 + + VersionResourceSerializer.HDRSIZE + + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.translationKey + ) + ) + + writer.Write(WORD(sizeof * 2)) + writer.Write(WORD 0us) + writer.Write(VersionResourceSerializer.translationKey.ToCharArray()) + + writer.Write( + Array.zeroCreate ( + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.translationKey + - VersionResourceSerializer.translationKey.Length * 2 + ): byte[] + ) + + Debug.Assert(writer.BaseStream.Position &&& 3L = 0L) writer.Write 0us - writer.Write (WORD VersionResourceSerializer.CP_WINUNICODE) - Debug.Assert (writer.BaseStream.Position &&& 3L = 0L) - writer.Write (WORD (2 * VersionResourceSerializer.HDRSIZE + - VersionResourceSerializer.KEYBYTES VersionResourceSerializer.stringFileInfoKey + - VersionResourceSerializer.KEYBYTES this._langIdAndCodePageKey + this.GetStringsSize ())) + writer.Write(WORD VersionResourceSerializer.CP_WINUNICODE) + Debug.Assert(writer.BaseStream.Position &&& 3L = 0L) + + writer.Write( + WORD( + 2 * VersionResourceSerializer.HDRSIZE + + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.stringFileInfoKey + + VersionResourceSerializer.KEYBYTES this._langIdAndCodePageKey + + this.GetStringsSize() + ) + ) + writer.Write 0us writer.Write 1us - writer.Write (VersionResourceSerializer.stringFileInfoKey.ToCharArray ()) - writer.Write (Array.zeroCreate (VersionResourceSerializer.KEYBYTES VersionResourceSerializer.stringFileInfoKey - VersionResourceSerializer.stringFileInfoKey.Length * 2): byte[]) - Debug.Assert (writer.BaseStream.Position &&& 3L = 0L) - writer.Write (WORD (VersionResourceSerializer.HDRSIZE + VersionResourceSerializer.KEYBYTES this._langIdAndCodePageKey + this.GetStringsSize ())) + writer.Write(VersionResourceSerializer.stringFileInfoKey.ToCharArray()) + + writer.Write( + Array.zeroCreate ( + VersionResourceSerializer.KEYBYTES VersionResourceSerializer.stringFileInfoKey + - VersionResourceSerializer.stringFileInfoKey.Length * 2 + ): byte[] + ) + + Debug.Assert(writer.BaseStream.Position &&& 3L = 0L) + + writer.Write( + WORD( + VersionResourceSerializer.HDRSIZE + + VersionResourceSerializer.KEYBYTES this._langIdAndCodePageKey + + this.GetStringsSize() + ) + ) + writer.Write 0us writer.Write 1us - writer.Write (this._langIdAndCodePageKey.ToCharArray ()) - writer.Write (Array.zeroCreate (VersionResourceSerializer.KEYBYTES this._langIdAndCodePageKey - this._langIdAndCodePageKey.Length * 2): byte[]) - Debug.Assert (writer.BaseStream.Position &&& 3L = 0L) - Debug.Assert (writer.BaseStream.Position - debugPos = int64 dataSize - int64 (this.GetStringsSize ())) + writer.Write(this._langIdAndCodePageKey.ToCharArray()) + + writer.Write( + Array.zeroCreate ( + VersionResourceSerializer.KEYBYTES this._langIdAndCodePageKey + - this._langIdAndCodePageKey.Length * 2 + ): byte[] + ) + + Debug.Assert(writer.BaseStream.Position &&& 3L = 0L) + Debug.Assert(writer.BaseStream.Position - debugPos = int64 dataSize - int64 (this.GetStringsSize())) debugPos <- writer.BaseStream.Position - for entry in this.GetVerStrings () do + + for entry in this.GetVerStrings() do let mutable writerPos = writer.BaseStream.Position - writer.Write (Array.zeroCreate (int ((writerPos + 3L) &&& ~~~3L - writerPos)): byte[]) - Debug.Assert (entry.Value <> Unchecked.defaultof<_>) - VersionResourceSerializer.WriteVersionString (entry, writer) - Debug.Assert (writer.BaseStream.Position - debugPos = int64 (this.GetStringsSize ())) + writer.Write(Array.zeroCreate (int ((writerPos + 3L) &&& ~~~ 3L - writerPos)): byte[]) + Debug.Assert(entry.Value <> Unchecked.defaultof<_>) + VersionResourceSerializer.WriteVersionString(entry, writer) + + Debug.Assert(writer.BaseStream.Position - debugPos = int64 (this.GetStringsSize())) -type Win32ResourceConversions () = - static member AppendIconToResourceStream(resStream: Stream, iconStream: Stream) = +type Win32ResourceConversions() = + static member AppendIconToResourceStream(resStream: Stream, iconStream: Stream) = let mutable iconReader = new BinaryReader(iconStream) - let mutable reserved = iconReader.ReadUInt16 () + let mutable reserved = iconReader.ReadUInt16() + if reserved <> 0us then raise <| ResourceException("IconStreamUnexpectedFormat") - let mutable ``type`` = iconReader.ReadUInt16 () + + let mutable ``type`` = iconReader.ReadUInt16() + if ``type`` <> 1us then raise <| ResourceException("IconStreamUnexpectedFormat") - let mutable count = iconReader.ReadUInt16 () + + let mutable count = iconReader.ReadUInt16() + if count = 0us then raise <| ResourceException("IconStreamUnexpectedFormat") - let mutable iconDirEntries: ICONDIRENTRY [] = Array.zeroCreate (int count) - do + + let mutable iconDirEntries: ICONDIRENTRY[] = Array.zeroCreate (int count) + + do let mutable (i: uint16) = 0us + while (i < count) do - iconDirEntries[(int i)].bWidth <- iconReader.ReadByte () - iconDirEntries[(int i)].bHeight <- iconReader.ReadByte () - iconDirEntries[(int i)].bColorCount <- iconReader.ReadByte () - iconDirEntries[(int i)].bReserved <- iconReader.ReadByte () - iconDirEntries[(int i)].wPlanes <- iconReader.ReadUInt16 () - iconDirEntries[(int i)].wBitCount <- iconReader.ReadUInt16 () - iconDirEntries[(int i)].dwBytesInRes <- iconReader.ReadUInt32 () - iconDirEntries[(int i)].dwImageOffset <- iconReader.ReadUInt32 () + iconDirEntries[(int i)].bWidth <- iconReader.ReadByte() + iconDirEntries[(int i)].bHeight <- iconReader.ReadByte() + iconDirEntries[(int i)].bColorCount <- iconReader.ReadByte() + iconDirEntries[(int i)].bReserved <- iconReader.ReadByte() + iconDirEntries[(int i)].wPlanes <- iconReader.ReadUInt16() + iconDirEntries[(int i)].wBitCount <- iconReader.ReadUInt16() + iconDirEntries[(int i)].dwBytesInRes <- iconReader.ReadUInt32() + iconDirEntries[(int i)].dwImageOffset <- iconReader.ReadUInt32() i <- i + 1us + do let mutable (i: uint16) = 0us + while (i < count) do iconStream.Position <- int64 iconDirEntries[(int i)].dwImageOffset - if iconReader.ReadUInt32 () = 40u then + + if iconReader.ReadUInt32() = 40u then iconStream.Position <- iconStream.Position + 8L - iconDirEntries[(int i)].wPlanes <- iconReader.ReadUInt16 () - iconDirEntries[(int i)].wBitCount <- iconReader.ReadUInt16 () + iconDirEntries[(int i)].wPlanes <- iconReader.ReadUInt16() + iconDirEntries[(int i)].wBitCount <- iconReader.ReadUInt16() + i <- i + 1us let mutable resWriter = new BinaryWriter(resStream) let mutable (RT_ICON: WORD) = 3us + do let mutable (i: uint16) = 0us + while (i < count) do - resStream.Position <- resStream.Position + 3L &&& ~~~3L + resStream.Position <- resStream.Position + 3L &&& ~~~ 3L resWriter.Write iconDirEntries[(int i)].dwBytesInRes resWriter.Write 0x00000020u resWriter.Write 0xFFFFus resWriter.Write RT_ICON resWriter.Write 0xFFFFus - resWriter.Write (i + 1us) + resWriter.Write(i + 1us) resWriter.Write 0x00000000u resWriter.Write 0x1010us resWriter.Write 0x0000us resWriter.Write 0x00000000u resWriter.Write 0x00000000u iconStream.Position <- int64 iconDirEntries[(int i)].dwImageOffset - resWriter.Write (iconReader.ReadBytes (int iconDirEntries[int i].dwBytesInRes)) + resWriter.Write(iconReader.ReadBytes(int iconDirEntries[int i].dwBytesInRes)) i <- i + 1us let mutable (RT_GROUP_ICON: WORD) = (RT_ICON + 11us) - resStream.Position <- resStream.Position + 3L &&& ~~~3L - resWriter.Write (uint32 (3 * sizeof + int count * 14)) + resStream.Position <- resStream.Position + 3L &&& ~~~ 3L + resWriter.Write(uint32 (3 * sizeof + int count * 14)) resWriter.Write 0x00000020u resWriter.Write 0xFFFFus resWriter.Write RT_GROUP_ICON @@ -701,8 +891,10 @@ type Win32ResourceConversions () = resWriter.Write 0x0000us resWriter.Write 0x0001us resWriter.Write count + do let mutable (i: uint16) = 0us + while (i < count) do resWriter.Write iconDirEntries[(int i)].bWidth resWriter.Write iconDirEntries[(int i)].bHeight @@ -711,11 +903,14 @@ type Win32ResourceConversions () = resWriter.Write iconDirEntries[(int i)].wPlanes resWriter.Write iconDirEntries[(int i)].wBitCount resWriter.Write iconDirEntries[(int i)].dwBytesInRes - resWriter.Write (i + 1us) + resWriter.Write(i + 1us) i <- i + 1us + () - static member AppendVersionToResourceStream (resStream: Stream, + static member AppendVersionToResourceStream + ( + resStream: Stream, isDll: bool, fileVersion: string, originalFileName: string, @@ -727,7 +922,8 @@ type Win32ResourceConversions () = ?legalTrademarks: string, ?productName: string, ?comments: string, - ?companyName: string) = + ?companyName: string + ) = let fileDescription = (defaultArg fileDescription) " " let legalCopyright = (defaultArg legalCopyright) " " let legalTrademarks = (defaultArg legalTrademarks) Unchecked.defaultof<_> @@ -735,20 +931,32 @@ type Win32ResourceConversions () = let comments = (defaultArg comments) Unchecked.defaultof<_> let companyName = (defaultArg companyName) Unchecked.defaultof<_> let mutable resWriter = new BinaryWriter(resStream, Encoding.Unicode) - resStream.Position <- resStream.Position + 3L &&& ~~~3L + resStream.Position <- resStream.Position + 3L &&& ~~~ 3L let mutable (RT_VERSION: DWORD) = 16u + let mutable ver = - VersionResourceSerializer(isDll, comments, companyName, - fileDescription, fileVersion, internalName, legalCopyright, - legalTrademarks, originalFileName, productName, productVersion, - assemblyVersion) + VersionResourceSerializer( + isDll, + comments, + companyName, + fileDescription, + fileVersion, + internalName, + legalCopyright, + legalTrademarks, + originalFileName, + productName, + productVersion, + assemblyVersion + ) + let mutable startPos = resStream.Position - let mutable dataSize = ver.GetDataSize () + let mutable dataSize = ver.GetDataSize() let mutable (headerSize: int) = 0x20 - resWriter.Write (uint32 dataSize) - resWriter.Write (uint32 headerSize) + resWriter.Write(uint32 dataSize) + resWriter.Write(uint32 headerSize) resWriter.Write 0xFFFFus - resWriter.Write (uint16 RT_VERSION) + resWriter.Write(uint16 RT_VERSION) resWriter.Write 0xFFFFus resWriter.Write 0x0001us resWriter.Write 0x00000000u @@ -757,18 +965,18 @@ type Win32ResourceConversions () = resWriter.Write 0x00000000u resWriter.Write 0x00000000u ver.WriteVerResource resWriter - Debug.Assert (resStream.Position - startPos = int64 dataSize + int64 headerSize) + Debug.Assert(resStream.Position - startPos = int64 dataSize + int64 headerSize) - static member AppendManifestToResourceStream(resStream: Stream, manifestStream: Stream, isDll: bool) = - resStream.Position <- resStream.Position + 3L &&& ~~~3L (* ERROR UnknownPrefixOperator "~" *) + static member AppendManifestToResourceStream(resStream: Stream, manifestStream: Stream, isDll: bool) = + resStream.Position <- resStream.Position + 3L &&& ~~~ 3L (* ERROR UnknownPrefixOperator "~" *) let mutable (RT_MANIFEST: WORD) = 24us let mutable resWriter = new BinaryWriter(resStream) - resWriter.Write (uint32 manifestStream.Length) + resWriter.Write(uint32 manifestStream.Length) resWriter.Write 0x00000020u resWriter.Write 0xFFFFus resWriter.Write RT_MANIFEST resWriter.Write 0xFFFFus - resWriter.Write (if isDll then 0x0002us else 0x0001us) + resWriter.Write(if isDll then 0x0002us else 0x0001us) resWriter.Write 0x00000000u resWriter.Write 0x1030us resWriter.Write 0x0000us @@ -776,8 +984,7 @@ type Win32ResourceConversions () = resWriter.Write 0x00000000u manifestStream.CopyTo resStream - -type Win32Resource (data: byte[], codePage: DWORD, languageId: DWORD, id: int, name: string, typeId: int, typeName: string) = +type Win32Resource(data: byte[], codePage: DWORD, languageId: DWORD, id: int, name: string, typeId: int, typeName: string) = member val Data = data member val CodePage = codePage member val LanguageId = languageId @@ -786,36 +993,39 @@ type Win32Resource (data: byte[], codePage: DWORD, languageId: DWORD, id: int, n member val TypeId = typeId member val TypeName = typeName -type Directory (name, id) = +type Directory(name, id) = member val Name = name member val ID = id member val NumberOfNamedEntries = Unchecked.defaultof with get, set member val NumberOfIdEntries = Unchecked.defaultof with get, set member val Entries = List() -type NativeResourceWriter () = - static member private CompareResources (left: Win32Resource) (right: Win32Resource) = - let mutable (result: int) = NativeResourceWriter.CompareResourceIdentifiers (left.TypeId, left.TypeName, right.TypeId, right.TypeName) +type NativeResourceWriter() = + static member private CompareResources (left: Win32Resource) (right: Win32Resource) = + let mutable (result: int) = + NativeResourceWriter.CompareResourceIdentifiers(left.TypeId, left.TypeName, right.TypeId, right.TypeName) + if result = 0 then - NativeResourceWriter.CompareResourceIdentifiers (left.Id, left.Name, right.Id, right.Name) - else result + NativeResourceWriter.CompareResourceIdentifiers(left.Id, left.Name, right.Id, right.Name) + else + result - static member private CompareResourceIdentifiers (xOrdinal: int, xString: string, yOrdinal: int, yString: string) = + static member private CompareResourceIdentifiers(xOrdinal: int, xString: string, yOrdinal: int, yString: string) = if xString = Unchecked.defaultof<_> then if yString = Unchecked.defaultof<_> then xOrdinal - yOrdinal else 1 + else if yString = Unchecked.defaultof<_> then + -1 else - if yString = Unchecked.defaultof<_> then - -1 - else - String.Compare (xString, yString, StringComparison.OrdinalIgnoreCase) + String.Compare(xString, yString, StringComparison.OrdinalIgnoreCase) - static member SortResources (resources: IEnumerable) = - resources.OrderBy ((fun d -> d), Comparer<_>.Create(Comparison<_> NativeResourceWriter.CompareResources)) :> IEnumerable + static member SortResources(resources: IEnumerable) = + resources.OrderBy((fun d -> d), Comparer<_>.Create (Comparison<_> NativeResourceWriter.CompareResources)) + :> IEnumerable - static member SerializeWin32Resources (builder: BlobBuilder, theResources: IEnumerable, resourcesRva: int) = + static member SerializeWin32Resources(builder: BlobBuilder, theResources: IEnumerable, resourcesRva: int) = let theResources = NativeResourceWriter.SortResources theResources let mutable (typeDirectory: Directory) = Directory(String.Empty, 0) let mutable (nameDirectory: Directory) = Unchecked.defaultof<_> @@ -825,42 +1035,67 @@ type NativeResourceWriter () = let mutable (lastID: int) = Int32.MinValue let mutable (lastName: string) = Unchecked.defaultof<_> let mutable (sizeOfDirectoryTree: uint32) = 16u + for r: Win32Resource in theResources do - let mutable (typeDifferent: bool) = r.TypeId < 0 && r.TypeName <> lastTypeName || r.TypeId > lastTypeID - if typeDifferent then + let mutable (typeDifferent: bool) = + r.TypeId < 0 && r.TypeName <> lastTypeName || r.TypeId > lastTypeID + + if typeDifferent then lastTypeID <- r.TypeId lastTypeName <- r.TypeName + if lastTypeID < 0 then - Debug.Assert ((typeDirectory.NumberOfIdEntries = 0us), "Not all Win32 resources with types encoded as strings precede those encoded as ints") + Debug.Assert( + (typeDirectory.NumberOfIdEntries = 0us), + "Not all Win32 resources with types encoded as strings precede those encoded as ints" + ) + typeDirectory.NumberOfNamedEntries <- typeDirectory.NumberOfNamedEntries + 1us - else + else typeDirectory.NumberOfIdEntries <- typeDirectory.NumberOfIdEntries + 1us + sizeOfDirectoryTree <- sizeOfDirectoryTree + 24u nameDirectory <- Directory(lastTypeName, lastTypeID) typeDirectory.Entries.Add nameDirectory - if typeDifferent || r.Id < 0 && r.Name <> lastName || r.Id > lastID then + + if typeDifferent || r.Id < 0 && r.Name <> lastName || r.Id > lastID then lastID <- r.Id lastName <- r.Name + if lastID < 0 then - Debug.Assert ((nameDirectory.NumberOfIdEntries = 0us), "Not all Win32 resources with names encoded as strings precede those encoded as ints") + Debug.Assert( + (nameDirectory.NumberOfIdEntries = 0us), + "Not all Win32 resources with names encoded as strings precede those encoded as ints" + ) + nameDirectory.NumberOfNamedEntries <- nameDirectory.NumberOfNamedEntries + 1us else nameDirectory.NumberOfIdEntries <- nameDirectory.NumberOfIdEntries + 1us + sizeOfDirectoryTree <- sizeOfDirectoryTree + 24u languageDirectory <- Directory(lastName, lastID) nameDirectory.Entries.Add languageDirectory + languageDirectory.NumberOfIdEntries <- languageDirectory.NumberOfIdEntries + 1us sizeOfDirectoryTree <- sizeOfDirectoryTree + 8u languageDirectory.Entries.Add r + let mutable dataWriter = BlobBuilder() - NativeResourceWriter.WriteDirectory (typeDirectory, builder, 0u, 0u, sizeOfDirectoryTree, resourcesRva, dataWriter) + NativeResourceWriter.WriteDirectory(typeDirectory, builder, 0u, 0u, sizeOfDirectoryTree, resourcesRva, dataWriter) builder.LinkSuffix dataWriter builder.WriteByte 0uy builder.Align 4 - static member private WriteDirectory (directory: Directory, writer: BlobBuilder, offset: uint32, - level: uint32, sizeOfDirectoryTree: uint32, - virtualAddressBase: int, dataWriter: BlobBuilder) = + static member private WriteDirectory + ( + directory: Directory, + writer: BlobBuilder, + offset: uint32, + level: uint32, + sizeOfDirectoryTree: uint32, + virtualAddressBase: int, + dataWriter: BlobBuilder + ) = writer.WriteUInt32 0u writer.WriteUInt32 0u writer.WriteUInt32 0u @@ -868,89 +1103,121 @@ type NativeResourceWriter () = writer.WriteUInt16 directory.NumberOfIdEntries let mutable (n: uint32) = uint32 directory.Entries.Count let mutable (k: uint32) = offset + 16u + n * 8u - do + + do let mutable (i: uint32) = 0u + while (i < n) do let mutable (id: int) = Unchecked.defaultof let mutable (name: string) = Unchecked.defaultof let mutable (nameOffset: uint32) = uint32 dataWriter.Count + sizeOfDirectoryTree let mutable (directoryOffset: uint32) = k + let isDir = match directory.Entries[int i] with | :? Directory as subDir -> id <- subDir.ID name <- subDir.Name - if level = 0u then k <- k + NativeResourceWriter.SizeOfDirectory subDir - else k <- k + 16u + 8u * uint32 subDir.Entries.Count + + if level = 0u then + k <- k + NativeResourceWriter.SizeOfDirectory subDir + else + k <- k + 16u + 8u * uint32 subDir.Entries.Count + true | :? Win32Resource as r -> - id <- - if level = 0u then - r.TypeId - else - if level = 1u then - r.Id - else - int r.LanguageId - name <- - if level = 0u then - r.TypeName - else - if level = 1u then - r.Name - else - Unchecked.defaultof<_> - dataWriter.WriteUInt32 (uint32 virtualAddressBase + sizeOfDirectoryTree + 16u + uint32 dataWriter.Count) - let mutable (data: byte[]) = (List(r.Data)).ToArray () - dataWriter.WriteUInt32 (uint32 data.Length) + id <- + if level = 0u then r.TypeId + else if level = 1u then r.Id + else int r.LanguageId + + name <- + if level = 0u then r.TypeName + else if level = 1u then r.Name + else Unchecked.defaultof<_> + + dataWriter.WriteUInt32(uint32 virtualAddressBase + sizeOfDirectoryTree + 16u + uint32 dataWriter.Count) + let mutable (data: byte[]) = (List(r.Data)).ToArray() + dataWriter.WriteUInt32(uint32 data.Length) dataWriter.WriteUInt32 r.CodePage dataWriter.WriteUInt32 0u dataWriter.WriteBytes data + while (dataWriter.Count % 4 <> 0) do dataWriter.WriteByte 0uy + false - | e -> failwithf "Unknown entry %s" (if isNull e then "" else e.GetType().FullName) - if id >= 0 then writer.WriteInt32 id - else + | e -> + failwithf + "Unknown entry %s" + (if isNull e then + "" + else + e.GetType().FullName) + + if id >= 0 then + writer.WriteInt32 id + else if name = Unchecked.defaultof<_> then name <- String.Empty - writer.WriteUInt32 (nameOffset ||| 0x80000000u) - dataWriter.WriteUInt16 (uint16 name.Length) + + writer.WriteUInt32(nameOffset ||| 0x80000000u) + dataWriter.WriteUInt16(uint16 name.Length) dataWriter.WriteUTF16 name - if isDir then writer.WriteUInt32 (directoryOffset ||| 0x80000000u) - else writer.WriteUInt32 nameOffset + + if isDir then + writer.WriteUInt32(directoryOffset ||| 0x80000000u) + else + writer.WriteUInt32 nameOffset + i <- i + 1u k <- offset + 16u + n * 8u - do + + do let mutable (i: int) = 0 + while (uint32 i < n) do match directory.Entries[i] with | :? Directory as subDir -> - NativeResourceWriter.WriteDirectory (subDir, writer, k, (level + 1u), sizeOfDirectoryTree, virtualAddressBase, dataWriter) + NativeResourceWriter.WriteDirectory( + subDir, + writer, + k, + (level + 1u), + sizeOfDirectoryTree, + virtualAddressBase, + dataWriter + ) + if level = 0u then k <- k + NativeResourceWriter.SizeOfDirectory subDir else k <- k + 16u + 8u * uint32 subDir.Entries.Count | _ -> () + i <- i + 1 + () - static member private SizeOfDirectory (directory: Directory) = + static member private SizeOfDirectory(directory: Directory) = let mutable (n: uint32) = uint32 directory.Entries.Count let mutable (size: uint32) = 16u + 8u * n - do + + do let mutable (i: int) = 0 + while (uint32 i < n) do match directory.Entries[i] with - | :? Directory as subDir -> - size <- size + 16u + 8u * uint32 subDir.Entries.Count + | :? Directory as subDir -> size <- size + 16u + 8u * uint32 subDir.Entries.Count | _ -> () + i <- i + 1 + size - (* - static member SerializeWin32Resources (builder: BlobBuilder, resourceSections: ResourceSection, resourcesRva: int) = +(* + static member SerializeWin32Resources (builder: BlobBuilder, resourceSections: ResourceSection, resourcesRva: int) = let mutable sectionWriter = new BlobWriter (builder.ReserveBytes (resourceSections.SectionBytes.Length)) sectionWriter.WriteBytes (resourceSections.SectionBytes) let mutable readStream = new MemoryStream (resourceSections.SectionBytes) @@ -959,4 +1226,4 @@ type NativeResourceWriter () = sectionWriter.Offset <- addressToFixup reader.BaseStream.Position <- addressToFixup sectionWriter.WriteUInt32 (reader.ReadUInt32 () + resourcesRva :> uint32) - ()*) \ No newline at end of file + ()*) diff --git a/src/Compiler/AbstractIL/ilprint.fs b/src/Compiler/AbstractIL/ilprint.fs index ad0040ffc..71efc7e0c 100644 --- a/src/Compiler/AbstractIL/ilprint.fs +++ b/src/Compiler/AbstractIL/ilprint.fs @@ -20,102 +20,143 @@ let pretty () = true // -------------------------------------------------------------------- let tyvar_generator = - let mutable i = 0 - fun n -> - i <- i + 1 - n + string i + let mutable i = 0 + + fun n -> + i <- i + 1 + n + string i // Carry an environment because the way we print method variables // depends on the gparams of the current scope. type ppenv = - { ilGlobals: ILGlobals - ppenvClassFormals: int - ppenvMethodFormals: int } + { + ilGlobals: ILGlobals + ppenvClassFormals: int + ppenvMethodFormals: int + } -let ppenv_enter_method mgparams env = - {env with ppenvMethodFormals=mgparams} +let ppenv_enter_method mgparams env = + { env with + ppenvMethodFormals = mgparams + } let ppenv_enter_tdef gparams env = - {env with ppenvClassFormals=List.length gparams; ppenvMethodFormals=0} - -let mk_ppenv ilg = { ilGlobals = ilg; ppenvClassFormals = 0; ppenvMethodFormals = 0 } + { env with + ppenvClassFormals = List.length gparams + ppenvMethodFormals = 0 + } + +let mk_ppenv ilg = + { + ilGlobals = ilg + ppenvClassFormals = 0 + ppenvMethodFormals = 0 + } let debug_ppenv = mk_ppenv -let ppenv_enter_modul env = { env with ppenvClassFormals=0; ppenvMethodFormals=0 } +let ppenv_enter_modul env = + { env with + ppenvClassFormals = 0 + ppenvMethodFormals = 0 + } // -------------------------------------------------------------------- // Pretty printing - output streams // -------------------------------------------------------------------- -let output_string (os: TextWriter) (s:string) = os.Write s +let output_string (os: TextWriter) (s: string) = os.Write s -let output_char (os: TextWriter) (c:char) = os.Write c +let output_char (os: TextWriter) (c: char) = os.Write c -let output_int os (i:int) = output_string os (string i) +let output_int os (i: int) = output_string os (string i) let output_hex_digit os i = - assert (i >= 0 && i < 16) - if i > 9 then output_char os (char (int32 'A' + (i-10))) - else output_char os (char (int32 '0' + i)) + assert (i >= 0 && i < 16) -let output_qstring os s = - output_char os '"' - for i = 0 to String.length s - 1 do - let c = String.get s i - if (c >= '\000' && c <= '\031') || (c >= '\127' && c <= '\255') then - let c' = int32 c - output_char os '\\' - output_int os (c'/64) - output_int os ((c' % 64) / 8) - output_int os (c' % 8) - else if (c = '"') then - output_char os '\\'; output_char os '"' - else if (c = '\\') then - output_char os '\\'; output_char os '\\' - else - output_char os c - done - output_char os '"' -let output_sqstring os s = - output_char os '\'' - for i = 0 to String.length s - 1 do - let c = s[i] - if (c >= '\000' && c <= '\031') || (c >= '\127' && c <= '\255') then - let c' = int32 c - output_char os '\\' - output_int os (c'/64) - output_int os ((c' % 64) / 8) - output_int os (c' % 8) - else if (c = '\\') then - output_char os '\\'; output_char os '\\' - else if (c = '\'') then - output_char os '\\'; output_char os '\'' + if i > 9 then + output_char os (char (int32 'A' + (i - 10))) else - output_char os c - done - output_char os '\'' + output_char os (char (int32 '0' + i)) -let output_seq sep f os (a:seq<_>) = - use e = a.GetEnumerator() - if e.MoveNext() then - f os e.Current - while e.MoveNext() do - output_string os sep - f os e.Current - -let output_array sep f os (a:_ []) = - if not (Array.isEmpty a) then - for i in 0..a.Length-2 do - f os a[i] - output_string os sep - f os a[a.Length - 1] - -let output_parens f os a = output_string os "("; f os a; output_string os ")" +let output_qstring os s = + output_char os '"' + + for i = 0 to String.length s - 1 do + let c = String.get s i + + if (c >= '\000' && c <= '\031') || (c >= '\127' && c <= '\255') then + let c' = int32 c + output_char os '\\' + output_int os (c' / 64) + output_int os ((c' % 64) / 8) + output_int os (c' % 8) + else if (c = '"') then + output_char os '\\' + output_char os '"' + else if (c = '\\') then + output_char os '\\' + output_char os '\\' + else + output_char os c + + output_char os '"' -let output_angled f os a = output_string os "<"; f os a; output_string os ">" +let output_sqstring os s = + output_char os '\'' + + for i = 0 to String.length s - 1 do + let c = s[i] + + if (c >= '\000' && c <= '\031') || (c >= '\127' && c <= '\255') then + let c' = int32 c + output_char os '\\' + output_int os (c' / 64) + output_int os ((c' % 64) / 8) + output_int os (c' % 8) + else if (c = '\\') then + output_char os '\\' + output_char os '\\' + else if (c = '\'') then + output_char os '\\' + output_char os '\'' + else + output_char os c + + output_char os '\'' + +let output_seq sep f os (a: seq<_>) = + use e = a.GetEnumerator() + + if e.MoveNext() then + f os e.Current + + while e.MoveNext() do + output_string os sep + f os e.Current + +let output_array sep f os (a: _[]) = + if not (Array.isEmpty a) then + for i in 0 .. a.Length - 2 do + f os a[i] + output_string os sep + + f os a[a.Length - 1] + +let output_parens f os a = + output_string os "(" + f os a + output_string os ")" + +let output_angled f os a = + output_string os "<" + f os a + output_string os ">" -let output_bracks f os a = output_string os "["; f os a; output_string os "]" +let output_bracks f os a = + output_string os "[" + f os a + output_string os "]" let output_id os n = output_sqstring os n @@ -126,870 +167,1183 @@ let output_lid os lid = output_seq "." output_string os lid let string_of_type_name (_, n) = n let output_byte os i = - output_hex_digit os (i / 16) - output_hex_digit os (i % 16) - -let output_bytes os (bytes:byte[]) = - for i = 0 to bytes.Length - 1 do - output_byte os (Bytes.get bytes i) - output_string os " " + output_hex_digit os (i / 16) + output_hex_digit os (i % 16) +let output_bytes os (bytes: byte[]) = + for i = 0 to bytes.Length - 1 do + output_byte os (Bytes.get bytes i) + output_string os " " -let bits_of_float32 (x:float32) = System.BitConverter.ToInt32(System.BitConverter.GetBytes(x), 0) +let bits_of_float32 (x: float32) = + System.BitConverter.ToInt32(System.BitConverter.GetBytes(x), 0) -let bits_of_float (x:float) = System.BitConverter.DoubleToInt64Bits(x) +let bits_of_float (x: float) = + System.BitConverter.DoubleToInt64Bits(x) -let output_u8 os (x:byte) = output_string os (string (int x)) +let output_u8 os (x: byte) = output_string os (string (int x)) -let output_i8 os (x:sbyte) = output_string os (string (int x)) +let output_i8 os (x: sbyte) = output_string os (string (int x)) -let output_u16 os (x:uint16) = output_string os (string (int x)) +let output_u16 os (x: uint16) = output_string os (string (int x)) -let output_i16 os (x:int16) = output_string os (string (int x)) +let output_i16 os (x: int16) = output_string os (string (int x)) -let output_u32 os (x:uint32) = output_string os (string (int64 x)) +let output_u32 os (x: uint32) = output_string os (string (int64 x)) -let output_i32 os (x:int32) = output_string os (string x) +let output_i32 os (x: int32) = output_string os (string x) -let output_u64 os (x:uint64) = output_string os (string (int64 x)) +let output_u64 os (x: uint64) = output_string os (string (int64 x)) -let output_i64 os (x:int64) = output_string os (string x) +let output_i64 os (x: int64) = output_string os (string x) -let output_ieee32 os (x:float32) = output_string os "float32 ("; output_string os (string (bits_of_float32 x)); output_string os ")" +let output_ieee32 os (x: float32) = + output_string os "float32 (" + output_string os (string (bits_of_float32 x)) + output_string os ")" -let output_ieee64 os (x:float) = output_string os "float64 ("; output_string os (string (bits_of_float x)); output_string os ")" +let output_ieee64 os (x: float) = + output_string os "float64 (" + output_string os (string (bits_of_float x)) + output_string os ")" -let rec goutput_scoref env os = function - | ILScopeRef.Local -> () - | ILScopeRef.Assembly aref -> - output_string os "["; output_sqstring os aref.Name; output_string os "]" - | ILScopeRef.Module mref -> - output_string os "[.module "; output_sqstring os mref.Name; output_string os "]" - | ILScopeRef.PrimaryAssembly -> - output_string os "["; output_sqstring os env.ilGlobals.primaryAssemblyName; output_string os "]" +let rec goutput_scoref env os = + function + | ILScopeRef.Local -> () + | ILScopeRef.Assembly aref -> + output_string os "[" + output_sqstring os aref.Name + output_string os "]" + | ILScopeRef.Module mref -> + output_string os "[.module " + output_sqstring os mref.Name + output_string os "]" + | ILScopeRef.PrimaryAssembly -> + output_string os "[" + output_sqstring os env.ilGlobals.primaryAssemblyName + output_string os "]" and goutput_type_name_ref env os (scoref, enc, n) = - goutput_scoref env os scoref - output_seq "/" output_sqstring os (enc@[n]) -and goutput_tref env os (x:ILTypeRef) = - goutput_type_name_ref env os (x.Scope, x.Enclosing, x.Name) + goutput_scoref env os scoref + output_seq "/" output_sqstring os (enc @ [ n ]) + +and goutput_tref env os (x: ILTypeRef) = + goutput_type_name_ref env os (x.Scope, x.Enclosing, x.Name) and goutput_typ env os ty = - match ty with - | ILType.Boxed tr -> goutput_tspec env os tr - | ILType.TypeVar tv -> - // Special rule to print method type variables in Generic EE preferred form - // when an environment is available to help us do this. - let cgparams = env.ppenvClassFormals - let mgparams = env.ppenvMethodFormals - if int tv < cgparams then - output_string os "!" - output_tyvar os tv - elif int tv - cgparams < mgparams then - output_string os "!!" - output_int os (int tv - cgparams) - else - output_string os "!" - output_tyvar os tv - output_int os (int tv) - - | ILType.Byref typ -> goutput_typ env os typ; output_string os "&" - | ILType.Ptr typ -> goutput_typ env os typ; output_string os "*" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_SByte.TypeSpec.Name -> output_string os "int8" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Int16.TypeSpec.Name -> output_string os "int16" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Int32.TypeSpec.Name -> output_string os "int32" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Int64.TypeSpec.Name -> output_string os "int64" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_IntPtr.TypeSpec.Name -> output_string os "native int" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Byte.TypeSpec.Name -> output_string os "unsigned int8" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_UInt16.TypeSpec.Name -> output_string os "unsigned int16" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_UInt32.TypeSpec.Name -> output_string os "unsigned int32" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_UInt64.TypeSpec.Name -> output_string os "unsigned int64" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_UIntPtr.TypeSpec.Name -> output_string os "native unsigned int" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Double.TypeSpec.Name -> output_string os "float64" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Single.TypeSpec.Name -> output_string os "float32" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Bool.TypeSpec.Name -> output_string os "bool" - | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Char.TypeSpec.Name -> output_string os "char" - | ILType.Value tspec -> - output_string os "value class " - goutput_tref env os tspec.TypeRef - output_string os " " - goutput_gactuals env os tspec.GenericArgs - | ILType.Void -> output_string os "void" - | ILType.Array (bounds, ty) -> - goutput_typ env os ty - output_string os "[" - output_arr_bounds os bounds - output_string os "]" - | ILType.FunctionPointer csig -> - output_string os "method " - goutput_typ env os csig.ReturnType - output_string os " *(" - output_seq ", " (goutput_typ env) os csig.ArgTypes - output_string os ")" - | _ -> output_string os "NaT" + match ty with + | ILType.Boxed tr -> goutput_tspec env os tr + | ILType.TypeVar tv -> + // Special rule to print method type variables in Generic EE preferred form + // when an environment is available to help us do this. + let cgparams = env.ppenvClassFormals + let mgparams = env.ppenvMethodFormals + + if int tv < cgparams then + output_string os "!" + output_tyvar os tv + elif int tv - cgparams < mgparams then + output_string os "!!" + output_int os (int tv - cgparams) + else + output_string os "!" + output_tyvar os tv + output_int os (int tv) + + | ILType.Byref typ -> + goutput_typ env os typ + output_string os "&" + | ILType.Ptr typ -> + goutput_typ env os typ + output_string os "*" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_SByte.TypeSpec.Name -> output_string os "int8" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Int16.TypeSpec.Name -> output_string os "int16" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Int32.TypeSpec.Name -> output_string os "int32" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Int64.TypeSpec.Name -> output_string os "int64" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_IntPtr.TypeSpec.Name -> output_string os "native int" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Byte.TypeSpec.Name -> output_string os "unsigned int8" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_UInt16.TypeSpec.Name -> output_string os "unsigned int16" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_UInt32.TypeSpec.Name -> output_string os "unsigned int32" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_UInt64.TypeSpec.Name -> output_string os "unsigned int64" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_UIntPtr.TypeSpec.Name -> output_string os "native unsigned int" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Double.TypeSpec.Name -> output_string os "float64" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Single.TypeSpec.Name -> output_string os "float32" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Bool.TypeSpec.Name -> output_string os "bool" + | ILType.Value tspec when tspec.Name = PrimaryAssemblyILGlobals.typ_Char.TypeSpec.Name -> output_string os "char" + | ILType.Value tspec -> + output_string os "value class " + goutput_tref env os tspec.TypeRef + output_string os " " + goutput_gactuals env os tspec.GenericArgs + | ILType.Void -> output_string os "void" + | ILType.Array (bounds, ty) -> + goutput_typ env os ty + output_string os "[" + output_arr_bounds os bounds + output_string os "]" + | ILType.FunctionPointer csig -> + output_string os "method " + goutput_typ env os csig.ReturnType + output_string os " *(" + output_seq ", " (goutput_typ env) os csig.ArgTypes + output_string os ")" + | _ -> output_string os "NaT" and output_tyvar os d = - output_u16 os d; () - -and goutput_ldtoken_info env os = function - | ILToken.ILType x -> goutput_typ env os x - | ILToken.ILMethod x -> output_string os "method "; goutput_mspec env os x - | ILToken.ILField x -> output_string os "field "; goutput_fspec env os x - -and goutput_typ_with_shortened_class_syntax env os = function - ILType.Boxed tspec when tspec.GenericArgs = [] -> - goutput_tref env os tspec.TypeRef - | typ2 -> goutput_typ env os typ2 + output_u16 os d + () + +and goutput_ldtoken_info env os = + function + | ILToken.ILType x -> goutput_typ env os x + | ILToken.ILMethod x -> + output_string os "method " + goutput_mspec env os x + | ILToken.ILField x -> + output_string os "field " + goutput_fspec env os x + +and goutput_typ_with_shortened_class_syntax env os = + function + | ILType.Boxed tspec when tspec.GenericArgs = [] -> goutput_tref env os tspec.TypeRef + | typ2 -> goutput_typ env os typ2 and goutput_gactuals env os inst = - if not (List.isEmpty inst) then - output_string os "<" - output_seq ", " (goutput_gactual env) os inst - output_string os ">" + if not (List.isEmpty inst) then + output_string os "<" + output_seq ", " (goutput_gactual env) os inst + output_string os ">" and goutput_gactual env os ty = goutput_typ env os ty and goutput_tspec env os tspec = - output_string os "class " - goutput_tref env os tspec.TypeRef - output_string os " " - goutput_gactuals env os tspec.GenericArgs - -and output_arr_bounds os = function - | bounds when bounds = ILArrayShape.SingleDimensional -> () - | ILArrayShape l -> - output_seq ", " - (fun os -> function - | None, None -> output_string os "" - | None, Some sz -> - output_int os sz - | Some lower, None -> - output_int os lower - output_string os " ... " - | Some lower, Some d -> - output_int os lower - output_string os " ... " - output_int os d) - os - l + output_string os "class " + goutput_tref env os tspec.TypeRef + output_string os " " + goutput_gactuals env os tspec.GenericArgs + +and output_arr_bounds os = + function + | bounds when bounds = ILArrayShape.SingleDimensional -> () + | ILArrayShape l -> + output_seq + ", " + (fun os -> + function + | None, None -> output_string os "" + | None, Some sz -> output_int os sz + | Some lower, None -> + output_int os lower + output_string os " ... " + | Some lower, Some d -> + output_int os lower + output_string os " ... " + output_int os d) + os + l and goutput_permission _env os p = - let output_security_action os x = - output_string os - (match x with - | ILSecurityAction.Request -> "request" - | ILSecurityAction.Demand -> "demand" - | ILSecurityAction.Assert-> "assert" - | ILSecurityAction.Deny-> "deny" - | ILSecurityAction.PermitOnly-> "permitonly" - | ILSecurityAction.LinkCheck-> "linkcheck" - | ILSecurityAction.InheritCheck-> "inheritcheck" - | ILSecurityAction.ReqMin-> "reqmin" - | ILSecurityAction.ReqOpt-> "reqopt" - | ILSecurityAction.ReqRefuse-> "reqrefuse" - | ILSecurityAction.PreJitGrant-> "prejitgrant" - | ILSecurityAction.PreJitDeny-> "prejitdeny" - | ILSecurityAction.NonCasDemand-> "noncasdemand" - | ILSecurityAction.NonCasLinkDemand-> "noncaslinkdemand" - | ILSecurityAction.NonCasInheritance-> "noncasinheritance" - | ILSecurityAction.LinkDemandChoice -> "linkdemandchoice" - | ILSecurityAction.InheritanceDemandChoice -> "inheritancedemandchoice" - | ILSecurityAction.DemandChoice -> "demandchoice") - - match p with - | ILSecurityDecl (sa, b) -> - output_string os " .permissionset " - output_security_action os sa - output_string os " = (" - output_bytes os b - output_string os ")" + let output_security_action os x = + output_string + os + (match x with + | ILSecurityAction.Request -> "request" + | ILSecurityAction.Demand -> "demand" + | ILSecurityAction.Assert -> "assert" + | ILSecurityAction.Deny -> "deny" + | ILSecurityAction.PermitOnly -> "permitonly" + | ILSecurityAction.LinkCheck -> "linkcheck" + | ILSecurityAction.InheritCheck -> "inheritcheck" + | ILSecurityAction.ReqMin -> "reqmin" + | ILSecurityAction.ReqOpt -> "reqopt" + | ILSecurityAction.ReqRefuse -> "reqrefuse" + | ILSecurityAction.PreJitGrant -> "prejitgrant" + | ILSecurityAction.PreJitDeny -> "prejitdeny" + | ILSecurityAction.NonCasDemand -> "noncasdemand" + | ILSecurityAction.NonCasLinkDemand -> "noncaslinkdemand" + | ILSecurityAction.NonCasInheritance -> "noncasinheritance" + | ILSecurityAction.LinkDemandChoice -> "linkdemandchoice" + | ILSecurityAction.InheritanceDemandChoice -> "inheritancedemandchoice" + | ILSecurityAction.DemandChoice -> "demandchoice") + + match p with + | 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: ILSecurityDecls) = - output_seq " " (goutput_permission env) os (ps.AsList()) + output_seq " " (goutput_permission env) os (ps.AsList()) and goutput_gparam env os (gf: ILGenericParameterDef) = - output_string os (tyvar_generator gf.Name) - output_parens (output_seq ", " (goutput_typ env)) os gf.Constraints + output_string os (tyvar_generator gf.Name) + output_parens (output_seq ", " (goutput_typ env)) os gf.Constraints and goutput_gparams env os b = - if not (isNil b) then - output_string os "<"; output_seq ", " (goutput_gparam env) os b; output_string os ">"; () + if not (isNil b) then + output_string os "<" + output_seq ", " (goutput_gparam env) os b + output_string os ">" + () and output_bcc os bcc = - output_string os - (match bcc with - | ILArgConvention.FastCall -> "fastcall " - | ILArgConvention.StdCall -> "stdcall " - | ILArgConvention.ThisCall -> "thiscall " - | ILArgConvention.CDecl -> "cdecl " - | ILArgConvention.Default -> " " - | ILArgConvention.VarArg -> "vararg ") + output_string + os + (match bcc with + | ILArgConvention.FastCall -> "fastcall " + | ILArgConvention.StdCall -> "stdcall " + | ILArgConvention.ThisCall -> "thiscall " + | ILArgConvention.CDecl -> "cdecl " + | ILArgConvention.Default -> " " + | ILArgConvention.VarArg -> "vararg ") and output_callconv os (Callconv (hasthis, cc)) = - output_string os - (match hasthis with - ILThisConvention.Instance -> "instance " - | ILThisConvention.InstanceExplicit -> "explicit " - | ILThisConvention.Static -> "") - output_bcc os cc - -and goutput_dlocref env os (dref:ILType) = - match dref with - | dref when - dref.IsNominal && - isTypeNameForGlobalFunctions dref.TypeRef.Name && - dref.TypeRef.Scope = ILScopeRef.Local -> - () - | dref when - dref.IsNominal && - isTypeNameForGlobalFunctions dref.TypeRef.Name -> - goutput_scoref env os dref.TypeRef.Scope - output_string os "::" - | ty ->goutput_typ_with_shortened_class_syntax env os ty; output_string os "::" - -and goutput_callsig env os (csig:ILCallingSignature) = - output_callconv os csig.CallingConv - output_string os " " - goutput_typ env os csig.ReturnType - output_parens (output_seq ", " (goutput_typ env)) os csig.ArgTypes - -and goutput_mref env os (mref:ILMethodRef) = - output_callconv os mref.CallingConv - output_string os " " - goutput_typ_with_shortened_class_syntax env os mref.ReturnType - output_string os " " - // no quotes for ".ctor" - let name = mref.Name - if name = ".ctor" || name = ".cctor" then output_string os name else output_id os name - output_parens (output_seq ", " (goutput_typ env)) os mref.ArgTypes - -and goutput_mspec env os (mspec:ILMethodSpec) = - let fenv = - ppenv_enter_method mspec.GenericArity - (ppenv_enter_tdef (mkILFormalTypars mspec.DeclaringType.GenericArgs) env) - output_callconv os mspec.CallingConv - output_string os " " - goutput_typ fenv os mspec.FormalReturnType - output_string os " " - goutput_dlocref env os mspec.DeclaringType - output_string os " " - let name = mspec.Name - if name = ".ctor" || name = ".cctor" then output_string os name else output_id os name - goutput_gactuals env os mspec.GenericArgs - output_parens (output_seq ", " (goutput_typ fenv)) os mspec.FormalArgTypes + output_string + os + (match hasthis with + | ILThisConvention.Instance -> "instance " + | ILThisConvention.InstanceExplicit -> "explicit " + | ILThisConvention.Static -> "") + + output_bcc os cc + +and goutput_dlocref env os (dref: ILType) = + match dref with + | dref when + dref.IsNominal + && isTypeNameForGlobalFunctions dref.TypeRef.Name + && dref.TypeRef.Scope = ILScopeRef.Local + -> + () + | dref when dref.IsNominal && isTypeNameForGlobalFunctions dref.TypeRef.Name -> + goutput_scoref env os dref.TypeRef.Scope + output_string os "::" + | ty -> + goutput_typ_with_shortened_class_syntax env os ty + output_string os "::" + +and goutput_callsig env os (csig: ILCallingSignature) = + output_callconv os csig.CallingConv + output_string os " " + goutput_typ env os csig.ReturnType + output_parens (output_seq ", " (goutput_typ env)) os csig.ArgTypes + +and goutput_mref env os (mref: ILMethodRef) = + output_callconv os mref.CallingConv + output_string os " " + goutput_typ_with_shortened_class_syntax env os mref.ReturnType + output_string os " " + // no quotes for ".ctor" + let name = mref.Name + + if name = ".ctor" || name = ".cctor" then + output_string os name + else + output_id os name + + output_parens (output_seq ", " (goutput_typ env)) os mref.ArgTypes + +and goutput_mspec env os (mspec: ILMethodSpec) = + let fenv = + ppenv_enter_method mspec.GenericArity (ppenv_enter_tdef (mkILFormalTypars mspec.DeclaringType.GenericArgs) env) + + output_callconv os mspec.CallingConv + output_string os " " + goutput_typ fenv os mspec.FormalReturnType + output_string os " " + goutput_dlocref env os mspec.DeclaringType + output_string os " " + let name = mspec.Name + + if name = ".ctor" || name = ".cctor" then + output_string os name + else + output_id os name + + goutput_gactuals env os mspec.GenericArgs + output_parens (output_seq ", " (goutput_typ fenv)) os mspec.FormalArgTypes and goutput_vararg_mspec env os (mspec, varargs) = - match varargs with - | None -> goutput_mspec env os mspec - | Some varargs' -> - let fenv = - ppenv_enter_method mspec.GenericArity - (ppenv_enter_tdef (mkILFormalTypars mspec.DeclaringType.GenericArgs) env) - output_callconv os mspec.CallingConv - output_string os " " - goutput_typ fenv os mspec.FormalReturnType - output_string os " " - goutput_dlocref env os mspec.DeclaringType - let name = mspec.Name - if name = ".ctor" || name = ".cctor" then output_string os name else output_id os name - goutput_gactuals env os mspec.GenericArgs - output_string os "(" - output_seq ", " (goutput_typ fenv) os mspec.FormalArgTypes - output_string os ", ..., " - output_seq ", " (goutput_typ fenv) os varargs' - output_string os ")" - -and goutput_vararg_sig env os (csig:ILCallingSignature, varargs:ILVarArgs) = - match varargs with - | None -> goutput_callsig env os csig; () - | Some varargs' -> - goutput_typ env os csig.ReturnType - output_string os " (" - let argTys = csig.ArgTypes - if argTys.Length <> 0 then - output_seq ", " (goutput_typ env) os argTys - output_string os ", ..., " - output_seq ", " (goutput_typ env) os varargs' - output_string os ")" - -and goutput_fspec env os (x:ILFieldSpec) = - let fenv = ppenv_enter_tdef (mkILFormalTypars x.DeclaringType.GenericArgs) env - goutput_typ fenv os x.FormalType - output_string os " " - goutput_dlocref env os x.DeclaringType - output_id os x.Name + match varargs with + | None -> goutput_mspec env os mspec + | Some varargs' -> + let fenv = + ppenv_enter_method mspec.GenericArity (ppenv_enter_tdef (mkILFormalTypars mspec.DeclaringType.GenericArgs) env) + + output_callconv os mspec.CallingConv + output_string os " " + goutput_typ fenv os mspec.FormalReturnType + output_string os " " + goutput_dlocref env os mspec.DeclaringType + let name = mspec.Name + + if name = ".ctor" || name = ".cctor" then + output_string os name + else + output_id os name + + goutput_gactuals env os mspec.GenericArgs + output_string os "(" + output_seq ", " (goutput_typ fenv) os mspec.FormalArgTypes + output_string os ", ..., " + output_seq ", " (goutput_typ fenv) os varargs' + output_string os ")" + +and goutput_vararg_sig env os (csig: ILCallingSignature, varargs: ILVarArgs) = + match varargs with + | None -> + goutput_callsig env os csig + () + | Some varargs' -> + goutput_typ env os csig.ReturnType + output_string os " (" + let argTys = csig.ArgTypes + + if argTys.Length <> 0 then + output_seq ", " (goutput_typ env) os argTys + + output_string os ", ..., " + output_seq ", " (goutput_typ env) os varargs' + output_string os ")" + +and goutput_fspec env os (x: ILFieldSpec) = + let fenv = ppenv_enter_tdef (mkILFormalTypars x.DeclaringType.GenericArgs) env + goutput_typ fenv os x.FormalType + output_string os " " + goutput_dlocref env os x.DeclaringType + output_id os x.Name let output_member_access os access = - output_string os - (match access with - | ILMemberAccess.Public -> "public" - | ILMemberAccess.Private -> "private" - | ILMemberAccess.Family -> "family" - | ILMemberAccess.CompilerControlled -> "privatescope" - | ILMemberAccess.FamilyAndAssembly -> "famandassem" - | ILMemberAccess.FamilyOrAssembly -> "famorassem" - | ILMemberAccess.Assembly -> "assembly") + output_string + os + (match access with + | ILMemberAccess.Public -> "public" + | ILMemberAccess.Private -> "private" + | ILMemberAccess.Family -> "family" + | ILMemberAccess.CompilerControlled -> "privatescope" + | ILMemberAccess.FamilyAndAssembly -> "famandassem" + | ILMemberAccess.FamilyOrAssembly -> "famorassem" + | ILMemberAccess.Assembly -> "assembly") let output_type_access os access = - match access with - | ILTypeDefAccess.Public -> output_string os "public" - | ILTypeDefAccess.Private -> output_string os "private" - | ILTypeDefAccess.Nested ilMemberAccess -> output_string os "nested "; output_member_access os ilMemberAccess + match access with + | ILTypeDefAccess.Public -> output_string os "public" + | ILTypeDefAccess.Private -> output_string os "private" + | ILTypeDefAccess.Nested ilMemberAccess -> + output_string os "nested " + output_member_access os ilMemberAccess let output_encoding os e = - match e with - | ILDefaultPInvokeEncoding.Ansi -> output_string os " ansi " - | ILDefaultPInvokeEncoding.Auto -> output_string os " autochar " - | ILDefaultPInvokeEncoding.Unicode -> output_string os " unicode " -let output_field_init os = function - | ILFieldInit.String s -> output_string os "= "; output_string os s - | ILFieldInit.Bool x-> output_string os "= bool"; output_parens output_string os (if x then "true" else "false") - | ILFieldInit.Char x-> output_string os "= char"; output_parens output_u16 os x - | ILFieldInit.Int8 x-> output_string os "= int8"; output_parens output_i8 os x - | ILFieldInit.Int16 x-> output_string os "= int16"; output_parens output_i16 os x - | ILFieldInit.Int32 x-> output_string os "= int32"; output_parens output_i32 os x - | ILFieldInit.Int64 x-> output_string os "= int64"; output_parens output_i64 os x - | ILFieldInit.UInt8 x-> output_string os "= uint8"; output_parens output_u8 os x - | ILFieldInit.UInt16 x-> output_string os "= uint16"; output_parens output_u16 os x - | ILFieldInit.UInt32 x-> output_string os "= uint32"; output_parens output_u32 os x - | ILFieldInit.UInt64 x-> output_string os "= uint64"; output_parens output_u64 os x - | ILFieldInit.Single x-> output_string os "= float32"; output_parens output_ieee32 os x - | ILFieldInit.Double x-> output_string os "= float64"; output_parens output_ieee64 os x - | ILFieldInit.Null-> output_string os "= nullref" + match e with + | ILDefaultPInvokeEncoding.Ansi -> output_string os " ansi " + | ILDefaultPInvokeEncoding.Auto -> output_string os " autochar " + | ILDefaultPInvokeEncoding.Unicode -> output_string os " unicode " + +let output_field_init os = + function + | ILFieldInit.String s -> + output_string os "= " + output_string os s + | ILFieldInit.Bool x -> + output_string os "= bool" + output_parens output_string os (if x then "true" else "false") + | ILFieldInit.Char x -> + output_string os "= char" + output_parens output_u16 os x + | ILFieldInit.Int8 x -> + output_string os "= int8" + output_parens output_i8 os x + | ILFieldInit.Int16 x -> + output_string os "= int16" + output_parens output_i16 os x + | ILFieldInit.Int32 x -> + output_string os "= int32" + output_parens output_i32 os x + | ILFieldInit.Int64 x -> + output_string os "= int64" + output_parens output_i64 os x + | ILFieldInit.UInt8 x -> + output_string os "= uint8" + output_parens output_u8 os x + | ILFieldInit.UInt16 x -> + output_string os "= uint16" + output_parens output_u16 os x + | ILFieldInit.UInt32 x -> + output_string os "= uint32" + output_parens output_u32 os x + | ILFieldInit.UInt64 x -> + output_string os "= uint64" + output_parens output_u64 os x + | ILFieldInit.Single x -> + output_string os "= float32" + output_parens output_ieee32 os x + | ILFieldInit.Double x -> + output_string os "= float64" + output_parens output_ieee64 os x + | ILFieldInit.Null -> output_string os "= nullref" let output_at os b = - Printf.fprintf os " at (* no labels for data available, data = %a *)" (output_parens output_bytes) b + Printf.fprintf os " at (* no labels for data available, data = %a *)" (output_parens output_bytes) b -let output_option f os = function None -> () | Some x -> f os x +let output_option f os = + function + | None -> () + | Some x -> f os x let goutput_alternative_ref env os (alt: IlxUnionCase) = - output_id os alt.Name - alt.FieldDefs |> output_parens (output_array ", " (fun os fdef -> goutput_typ env os fdef.Type)) os + output_id os alt.Name + + alt.FieldDefs + |> output_parens (output_array ", " (fun os fdef -> goutput_typ env os fdef.Type)) os -let goutput_curef env os (IlxUnionRef(_, tref, alts, _, _)) = - output_string os " .classunion import " - goutput_tref env os tref - output_parens (output_array ", " (goutput_alternative_ref env)) os alts +let goutput_curef env os (IlxUnionRef (_, tref, alts, _, _)) = + output_string os " .classunion import " + goutput_tref env os tref + output_parens (output_array ", " (goutput_alternative_ref env)) os alts -let goutput_cuspec env os (IlxUnionSpec(IlxUnionRef(_, tref, _, _, _), i)) = - output_string os "class /* classunion */ " - goutput_tref env os tref - goutput_gactuals env os i +let goutput_cuspec env os (IlxUnionSpec (IlxUnionRef (_, tref, _, _, _), i)) = + output_string os "class /* classunion */ " + goutput_tref env os tref + goutput_gactuals env os i let output_basic_type os x = - output_string os - (match x with - | DT_I1 -> "i1" - | DT_U1 -> "u1" - | DT_I2 -> "i2" - | DT_U2 -> "u2" - | DT_I4 -> "i4" - | DT_U4 -> "u4" - | DT_I8 -> "i8" - | DT_U8 -> "u8" - | DT_R4 -> "r4" - | DT_R8 -> "r8" - | DT_R -> "r" - | DT_I -> "i" - | DT_U -> "u" - | DT_REF -> "ref") + output_string + os + (match x with + | DT_I1 -> "i1" + | DT_U1 -> "u1" + | DT_I2 -> "i2" + | DT_U2 -> "u2" + | DT_I4 -> "i4" + | DT_U4 -> "u4" + | DT_I8 -> "i8" + | DT_U8 -> "u8" + | DT_R4 -> "r4" + | DT_R8 -> "r8" + | DT_R -> "r" + | DT_I -> "i" + | DT_U -> "u" + | DT_REF -> "ref") let output_custom_attr_data os data = - output_string os " = "; output_parens output_bytes os data + output_string os " = " + output_parens output_bytes os data let goutput_custom_attr env os (attr: ILAttribute) = - output_string os " .custom " - goutput_mspec env os attr.Method - let data = getCustomAttrData attr - output_custom_attr_data os data - -let goutput_custom_attrs env os (attrs : ILAttributes) = - Array.iter (fun attr -> goutput_custom_attr env os attr; output_string os "\n" ) (attrs.AsArray()) + output_string os " .custom " + goutput_mspec env os attr.Method + let data = getCustomAttrData attr + output_custom_attr_data os data + +let goutput_custom_attrs env os (attrs: ILAttributes) = + Array.iter + (fun attr -> + goutput_custom_attr env os attr + output_string os "\n") + (attrs.AsArray()) 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.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 - -let output_alignment os = function - Aligned -> () - | Unaligned1 -> output_string os "unaligned. 1 " - | Unaligned2 -> output_string os "unaligned. 2 " - | Unaligned4 -> output_string os "unaligned. 4 " - -let output_volatility os = function - Nonvolatile -> () - | Volatile -> output_string os "volatile. " -let output_tailness os = function - | Tailcall -> output_string os "tail. " - | _ -> () -let output_after_tailcall os = function - | Tailcall -> output_string os " ret " - | _ -> () -let rec goutput_apps env os = function - | Apps_tyapp (actual, cs) -> - output_angled (goutput_gactual env) os actual - output_string os " " - output_angled (goutput_gparam env) os (mkILSimpleTypar "T") - output_string os " " - goutput_apps env os cs - | Apps_app(ty, cs) -> - output_parens (goutput_typ env) os ty - output_string os " " - goutput_apps env os cs - | Apps_done ty -> - output_string os "--> " - goutput_typ env os ty + 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.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 + +let output_alignment os = + function + | Aligned -> () + | Unaligned1 -> output_string os "unaligned. 1 " + | Unaligned2 -> output_string os "unaligned. 2 " + | Unaligned4 -> output_string os "unaligned. 4 " + +let output_volatility os = + function + | Nonvolatile -> () + | Volatile -> output_string os "volatile. " + +let output_tailness os = + function + | Tailcall -> output_string os "tail. " + | _ -> () + +let output_after_tailcall os = + function + | Tailcall -> output_string os " ret " + | _ -> () + +let rec goutput_apps env os = + function + | Apps_tyapp (actual, cs) -> + output_angled (goutput_gactual env) os actual + output_string os " " + output_angled (goutput_gparam env) os (mkILSimpleTypar "T") + output_string os " " + goutput_apps env os cs + | Apps_app (ty, cs) -> + output_parens (goutput_typ env) os ty + output_string os " " + goutput_apps env os cs + | Apps_done ty -> + output_string os "--> " + goutput_typ env os ty /// Print the short form of instructions -let output_short_u16 os (x:uint16) = - if int x < 256 then (output_string os ".s "; output_u16 os x) - else output_string os " "; output_u16 os x +let output_short_u16 os (x: uint16) = + if int x < 256 then + (output_string os ".s " + output_u16 os x) + else + output_string os " " + output_u16 os x let output_short_i32 os i32 = - if i32 < 256 && 0 >= i32 then (output_string os ".s "; output_i32 os i32) - else output_string os " "; output_i32 os i32 + if i32 < 256 && 0 >= i32 then + (output_string os ".s " + output_i32 os i32) + else + output_string os " " + output_i32 os i32 -let output_code_label os lab = - output_string os (formatCodeLabel lab) +let output_code_label os lab = output_string os (formatCodeLabel lab) let goutput_local env os (l: ILLocal) = - goutput_typ env os l.Type - if l.IsPinned then output_string os " pinned" + goutput_typ env os l.Type + + if l.IsPinned then + output_string os " pinned" let goutput_param env os (l: ILParameter) = - match l.Name with - None -> goutput_typ env os l.Type - | Some n -> goutput_typ env os l.Type; output_string os " "; output_sqstring os n + match l.Name with + | None -> goutput_typ env os l.Type + | Some n -> + goutput_typ env os l.Type + output_string os " " + output_sqstring os n let goutput_params env os ps = - output_parens (output_seq ", " (goutput_param env)) os ps + output_parens (output_seq ", " (goutput_param env)) os ps let goutput_freevar env os l = - goutput_typ env os l.fvType; output_string os " "; output_sqstring os l.fvName + goutput_typ env os l.fvType + output_string os " " + output_sqstring os l.fvName let goutput_freevars env os ps = - output_parens (output_seq ", " (goutput_freevar env)) os ps - -let output_source os (s:ILDebugPoint) = - if s.Document.File <> "" then - output_string os " .line " - output_int os s.Line - if s.Column <> -1 then - output_string os " : " - output_int os s.Column - output_string os " /* - " - output_int os s.EndLine - if s.Column <> -1 then - output_string os " : " - output_int os s.EndColumn - output_string os "*/ " - output_sqstring os s.Document.File + output_parens (output_seq ", " (goutput_freevar env)) os ps + +let output_source os (s: ILDebugPoint) = + if s.Document.File <> "" then + output_string os " .line " + output_int os s.Line + + if s.Column <> -1 then + output_string os " : " + output_int os s.Column + + output_string os " /* - " + output_int os s.EndLine + if s.Column <> -1 then + output_string os " : " + output_int os s.EndColumn + + output_string os "*/ " + output_sqstring os s.Document.File let rec goutput_instr env os inst = - match inst with - | si when isNoArgInstr si -> - output_lid os (wordsOfNoArgInstr si) - | I_brcmp (cmp, tg1) -> - output_string os - (match cmp with - | BI_beq -> "beq" - | BI_bgt -> "bgt" - | BI_bgt_un -> "bgt.un" - | BI_bge -> "bge" - | BI_bge_un -> "bge.un" - | BI_ble -> "ble" - | BI_ble_un -> "ble.un" - | BI_blt -> "blt" - | BI_blt_un -> "blt.un" - | BI_bne_un -> "bne.un" - | BI_brfalse -> "brfalse" - | BI_brtrue -> "brtrue") - output_string os " " - output_code_label os tg1 - | I_br tg -> output_string os "/* br "; output_code_label os tg; output_string os "*/" - | I_leave tg -> output_string os "leave "; output_code_label os tg - | I_call (tl, mspec, varargs) -> - output_tailness os tl - output_string os "call " - goutput_vararg_mspec env os (mspec, varargs) - output_after_tailcall os tl - | I_calli (tl, mref, varargs) -> - output_tailness os tl - output_string os "calli " - goutput_vararg_sig env os (mref, varargs) - output_after_tailcall os tl - | I_ldarg u16 -> output_string os "ldarg"; output_short_u16 os u16 - | I_ldarga u16 -> output_string os "ldarga "; output_u16 os u16 - | AI_ldc (dt, ILConst.I4 x) -> - output_string os "ldc."; output_basic_type os dt; output_short_i32 os x - | AI_ldc (dt, ILConst.I8 x) -> - output_string os "ldc."; output_basic_type os dt; output_string os " "; output_i64 os x - | AI_ldc (dt, ILConst.R4 x) -> - output_string os "ldc."; output_basic_type os dt; output_string os " "; output_ieee32 os x - | AI_ldc (dt, ILConst.R8 x) -> - output_string os "ldc."; output_basic_type os dt; output_string os " "; output_ieee64 os x - | I_ldftn mspec -> output_string os "ldftn "; goutput_mspec env os mspec - | I_ldvirtftn mspec -> output_string os "ldvirtftn "; goutput_mspec env os mspec - | I_ldind (al, vol, dt) -> - output_alignment os al - output_volatility os vol - output_string os "ldind." - output_basic_type os dt - | I_cpblk (al, vol) -> - output_alignment os al - output_volatility os vol - output_string os "cpblk" - | I_initblk (al, vol) -> - output_alignment os al - output_volatility os vol - output_string os "initblk" - | I_ldloc u16 -> output_string os "ldloc"; output_short_u16 os u16 - | I_ldloca u16 -> output_string os "ldloca "; output_u16 os u16 - | I_starg u16 -> output_string os "starg "; output_u16 os u16 - | I_stind (al, vol, dt) -> - output_alignment os al - output_volatility os vol - output_string os "stind." - output_basic_type os dt - | I_stloc u16 -> output_string os "stloc"; output_short_u16 os u16 - | I_switch l -> output_string os "switch "; output_parens (output_seq ", " output_code_label) os l - | I_callvirt (tl, mspec, varargs) -> - output_tailness os tl - output_string os "callvirt " - goutput_vararg_mspec env os (mspec, varargs) - output_after_tailcall os tl - | I_callconstraint (tl, ty, mspec, varargs) -> - output_tailness os tl - output_string os "constraint. " - goutput_typ env os ty - output_string os " callvirt " - goutput_vararg_mspec env os (mspec, varargs) - output_after_tailcall os tl - | I_castclass ty -> output_string os "castclass "; goutput_typ env os ty - | I_isinst ty -> output_string os "isinst "; goutput_typ env os ty - | I_ldfld (al, vol, fspec) -> - output_alignment os al - output_volatility os vol - output_string os "ldfld " - goutput_fspec env os fspec - | I_ldflda fspec -> - output_string os "ldflda " - goutput_fspec env os fspec - | I_ldsfld (vol, fspec) -> - output_volatility os vol - output_string os "ldsfld " - goutput_fspec env os fspec - | I_ldsflda fspec -> - output_string os "ldsflda " - goutput_fspec env os fspec - | I_stfld (al, vol, fspec) -> - output_alignment os al - output_volatility os vol - output_string os "stfld " - goutput_fspec env os fspec - | I_stsfld (vol, fspec) -> - output_volatility os vol - output_string os "stsfld " - goutput_fspec env os fspec - | I_ldtoken tok -> output_string os "ldtoken "; goutput_ldtoken_info env os tok - | I_refanyval ty -> output_string os "refanyval "; goutput_typ env os ty - | I_refanytype -> output_string os "refanytype" - | I_mkrefany typ -> output_string os "mkrefany "; goutput_typ env os typ - | I_ldstr s -> - output_string os "ldstr " - output_string os s - | I_newobj (mspec, varargs) -> - // newobj: IL has a special rule that the CC is always implicitly "instance" and need - // not be mentioned explicitly - output_string os "newobj " - goutput_vararg_mspec env os (mspec, varargs) - | I_stelem dt -> output_string os "stelem."; output_basic_type os dt - | I_ldelem dt -> output_string os "ldelem."; output_basic_type os dt - - | I_newarr (shape, typ) -> - if shape = ILArrayShape.SingleDimensional then - output_string os "newarr " - goutput_typ_with_shortened_class_syntax env os typ - else - output_string os "newobj void " - goutput_dlocref env os (mkILArrTy(typ, shape)) - output_string os ".ctor" - let rank = shape.Rank - output_parens (output_array ", " (goutput_typ env)) os (Array.create rank PrimaryAssemblyILGlobals.typ_Int32) - | I_stelem_any (shape, dt) -> - if shape = ILArrayShape.SingleDimensional then - output_string os "stelem.any "; goutput_typ env os dt - else - output_string os "call instance void " - goutput_dlocref env os (mkILArrTy(dt, shape)) - output_string os "Set" - let rank = shape.Rank - let arr = Array.create (rank + 1) PrimaryAssemblyILGlobals.typ_Int32 - arr[rank] <- dt - output_parens (output_array ", " (goutput_typ env)) os arr - | I_ldelem_any (shape, tok) -> - if shape = ILArrayShape.SingleDimensional then - output_string os "ldelem.any "; goutput_typ env os tok - else - output_string os "call instance " - goutput_typ env os tok + match inst with + | si when isNoArgInstr si -> output_lid os (wordsOfNoArgInstr si) + | I_brcmp (cmp, tg1) -> + output_string + os + (match cmp with + | BI_beq -> "beq" + | BI_bgt -> "bgt" + | BI_bgt_un -> "bgt.un" + | BI_bge -> "bge" + | BI_bge_un -> "bge.un" + | BI_ble -> "ble" + | BI_ble_un -> "ble.un" + | BI_blt -> "blt" + | BI_blt_un -> "blt.un" + | BI_bne_un -> "bne.un" + | BI_brfalse -> "brfalse" + | BI_brtrue -> "brtrue") + output_string os " " - goutput_dlocref env os (mkILArrTy(tok, shape)) - output_string os "Get" - let rank = shape.Rank - output_parens (output_array ", " (goutput_typ env)) os (Array.create rank PrimaryAssemblyILGlobals.typ_Int32) - | I_ldelema (ro, _, shape, tok) -> - if ro = ReadonlyAddress then output_string os "readonly. " - if shape = ILArrayShape.SingleDimensional then - output_string os "ldelema "; goutput_typ env os tok - else - output_string os "call instance " - goutput_typ env os (ILType.Byref tok) + output_code_label os tg1 + | I_br tg -> + output_string os "/* br " + output_code_label os tg + output_string os "*/" + | I_leave tg -> + output_string os "leave " + output_code_label os tg + | I_call (tl, mspec, varargs) -> + output_tailness os tl + output_string os "call " + goutput_vararg_mspec env os (mspec, varargs) + output_after_tailcall os tl + | I_calli (tl, mref, varargs) -> + output_tailness os tl + output_string os "calli " + goutput_vararg_sig env os (mref, varargs) + output_after_tailcall os tl + | I_ldarg u16 -> + output_string os "ldarg" + output_short_u16 os u16 + | I_ldarga u16 -> + output_string os "ldarga " + output_u16 os u16 + | AI_ldc (dt, ILConst.I4 x) -> + output_string os "ldc." + output_basic_type os dt + output_short_i32 os x + | AI_ldc (dt, ILConst.I8 x) -> + output_string os "ldc." + output_basic_type os dt output_string os " " - goutput_dlocref env os (mkILArrTy(tok, shape)) - output_string os "Address" - let rank = shape.Rank - output_parens (output_array ", " (goutput_typ env)) os (Array.create rank PrimaryAssemblyILGlobals.typ_Int32) - - | I_box tok -> output_string os "box "; goutput_typ env os tok - | I_unbox tok -> output_string os "unbox "; goutput_typ env os tok - | I_unbox_any tok -> output_string os "unbox.any "; goutput_typ env os tok - | I_initobj tok -> output_string os "initobj "; goutput_typ env os tok - | I_ldobj (al, vol, tok) -> - output_alignment os al - output_volatility os vol - output_string os "ldobj " - goutput_typ env os tok - | I_stobj (al, vol, tok) -> - output_alignment os al - output_volatility os vol - output_string os "stobj " - goutput_typ env os tok - | I_cpobj tok -> output_string os "cpobj "; goutput_typ env os tok - | I_sizeof tok -> output_string os "sizeof "; goutput_typ env os tok - | I_seqpoint s -> output_source os s - | EI_ilzero ty -> output_string os "ilzero "; goutput_typ env os ty - | _ -> - output_string os "" - + output_i64 os x + | AI_ldc (dt, ILConst.R4 x) -> + output_string os "ldc." + output_basic_type os dt + output_string os " " + output_ieee32 os x + | AI_ldc (dt, ILConst.R8 x) -> + output_string os "ldc." + output_basic_type os dt + output_string os " " + output_ieee64 os x + | I_ldftn mspec -> + output_string os "ldftn " + goutput_mspec env os mspec + | I_ldvirtftn mspec -> + output_string os "ldvirtftn " + goutput_mspec env os mspec + | I_ldind (al, vol, dt) -> + output_alignment os al + output_volatility os vol + output_string os "ldind." + output_basic_type os dt + | I_cpblk (al, vol) -> + output_alignment os al + output_volatility os vol + output_string os "cpblk" + | I_initblk (al, vol) -> + output_alignment os al + output_volatility os vol + output_string os "initblk" + | I_ldloc u16 -> + output_string os "ldloc" + output_short_u16 os u16 + | I_ldloca u16 -> + output_string os "ldloca " + output_u16 os u16 + | I_starg u16 -> + output_string os "starg " + output_u16 os u16 + | I_stind (al, vol, dt) -> + output_alignment os al + output_volatility os vol + output_string os "stind." + output_basic_type os dt + | I_stloc u16 -> + output_string os "stloc" + output_short_u16 os u16 + | I_switch l -> + output_string os "switch " + output_parens (output_seq ", " output_code_label) os l + | I_callvirt (tl, mspec, varargs) -> + output_tailness os tl + output_string os "callvirt " + goutput_vararg_mspec env os (mspec, varargs) + output_after_tailcall os tl + | I_callconstraint (tl, ty, mspec, varargs) -> + output_tailness os tl + output_string os "constraint. " + goutput_typ env os ty + output_string os " callvirt " + goutput_vararg_mspec env os (mspec, varargs) + output_after_tailcall os tl + | I_castclass ty -> + output_string os "castclass " + goutput_typ env os ty + | I_isinst ty -> + output_string os "isinst " + goutput_typ env os ty + | I_ldfld (al, vol, fspec) -> + output_alignment os al + output_volatility os vol + output_string os "ldfld " + goutput_fspec env os fspec + | I_ldflda fspec -> + output_string os "ldflda " + goutput_fspec env os fspec + | I_ldsfld (vol, fspec) -> + output_volatility os vol + output_string os "ldsfld " + goutput_fspec env os fspec + | I_ldsflda fspec -> + output_string os "ldsflda " + goutput_fspec env os fspec + | I_stfld (al, vol, fspec) -> + output_alignment os al + output_volatility os vol + output_string os "stfld " + goutput_fspec env os fspec + | I_stsfld (vol, fspec) -> + output_volatility os vol + output_string os "stsfld " + goutput_fspec env os fspec + | I_ldtoken tok -> + output_string os "ldtoken " + goutput_ldtoken_info env os tok + | I_refanyval ty -> + output_string os "refanyval " + goutput_typ env os ty + | I_refanytype -> output_string os "refanytype" + | I_mkrefany typ -> + output_string os "mkrefany " + goutput_typ env os typ + | I_ldstr s -> + output_string os "ldstr " + output_string os s + | I_newobj (mspec, varargs) -> + // newobj: IL has a special rule that the CC is always implicitly "instance" and need + // not be mentioned explicitly + output_string os "newobj " + goutput_vararg_mspec env os (mspec, varargs) + | I_stelem dt -> + output_string os "stelem." + output_basic_type os dt + | I_ldelem dt -> + output_string os "ldelem." + output_basic_type os dt + + | I_newarr (shape, typ) -> + if shape = ILArrayShape.SingleDimensional then + output_string os "newarr " + goutput_typ_with_shortened_class_syntax env os typ + else + output_string os "newobj void " + goutput_dlocref env os (mkILArrTy (typ, shape)) + output_string os ".ctor" + let rank = shape.Rank + output_parens (output_array ", " (goutput_typ env)) os (Array.create rank PrimaryAssemblyILGlobals.typ_Int32) + | I_stelem_any (shape, dt) -> + if shape = ILArrayShape.SingleDimensional then + output_string os "stelem.any " + goutput_typ env os dt + else + output_string os "call instance void " + goutput_dlocref env os (mkILArrTy (dt, shape)) + output_string os "Set" + let rank = shape.Rank + let arr = Array.create (rank + 1) PrimaryAssemblyILGlobals.typ_Int32 + arr[rank] <- dt + output_parens (output_array ", " (goutput_typ env)) os arr + | I_ldelem_any (shape, tok) -> + if shape = ILArrayShape.SingleDimensional then + output_string os "ldelem.any " + goutput_typ env os tok + else + output_string os "call instance " + goutput_typ env os tok + output_string os " " + goutput_dlocref env os (mkILArrTy (tok, shape)) + output_string os "Get" + let rank = shape.Rank + output_parens (output_array ", " (goutput_typ env)) os (Array.create rank PrimaryAssemblyILGlobals.typ_Int32) + | I_ldelema (ro, _, shape, tok) -> + if ro = ReadonlyAddress then + output_string os "readonly. " + + if shape = ILArrayShape.SingleDimensional then + output_string os "ldelema " + goutput_typ env os tok + else + output_string os "call instance " + goutput_typ env os (ILType.Byref tok) + output_string os " " + goutput_dlocref env os (mkILArrTy (tok, shape)) + output_string os "Address" + let rank = shape.Rank + output_parens (output_array ", " (goutput_typ env)) os (Array.create rank PrimaryAssemblyILGlobals.typ_Int32) + + | I_box tok -> + output_string os "box " + goutput_typ env os tok + | I_unbox tok -> + output_string os "unbox " + goutput_typ env os tok + | I_unbox_any tok -> + output_string os "unbox.any " + goutput_typ env os tok + | I_initobj tok -> + output_string os "initobj " + goutput_typ env os tok + | I_ldobj (al, vol, tok) -> + output_alignment os al + output_volatility os vol + output_string os "ldobj " + goutput_typ env os tok + | I_stobj (al, vol, tok) -> + output_alignment os al + output_volatility os vol + output_string os "stobj " + goutput_typ env os tok + | I_cpobj tok -> + output_string os "cpobj " + goutput_typ env os tok + | I_sizeof tok -> + output_string os "sizeof " + goutput_typ env os tok + | I_seqpoint s -> output_source os s + | EI_ilzero ty -> + output_string os "ilzero " + goutput_typ env os ty + | _ -> output_string os "" let goutput_ilmbody env os (il: ILMethodBody) = - if il.IsZeroInit then output_string os " .zeroinit\n" - output_string os " .maxstack " - output_i32 os il.MaxStack - output_string os "\n" - if il.Locals.Length <> 0 then - output_string os " .locals(" - output_seq ", \n " (goutput_local env) os il.Locals - output_string os ")\n" + if il.IsZeroInit then + output_string os " .zeroinit\n" + + output_string os " .maxstack " + output_i32 os il.MaxStack + output_string os "\n" + + if il.Locals.Length <> 0 then + output_string os " .locals(" + output_seq ", \n " (goutput_local env) os il.Locals + output_string os ")\n" 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 " - - output_string os (if md.IsInternalCall then "internalcall " else " ") - output_string os (if md.IsManaged then "managed " else " ") - output_string os (if md.IsForwardRef then "forwardref " else " ") - output_string os " \n{ \n" - goutput_security_decls env os md.SecurityDecls - goutput_custom_attrs env os md.CustomAttrs - match md.Body with + 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 " + + output_string + os + (if md.IsInternalCall then + "internalcall " + else + " ") + + output_string os (if md.IsManaged then "managed " else " ") + + output_string + os + (if md.IsForwardRef then + "forwardref " + else + " ") + + output_string os " \n{ \n" + goutput_security_decls env os md.SecurityDecls + goutput_custom_attrs env os md.CustomAttrs + + match md.Body with | MethodBody.IL il -> goutput_ilmbody env os il.Value | _ -> () - if is_entrypoint then output_string os " .entrypoint" - output_string os "\n" - output_string os "}\n" - -let goutput_mdef env os (md:ILMethodDef) = - let attrs = - if md.IsVirtual then - "virtual " + - (if md.IsFinal then "final " else "") + - (if md.IsNewSlot then "newslot " else "") + - (if md.IsCheckAccessOnOverride then " strict " else "") + - (if md.IsAbstract then " abstract " else "") + - " " - elif md.IsNonVirtualInstance then "" - elif md.IsConstructor then "rtspecialname" - elif md.IsStatic then - "static " + - (match md.Body with - MethodBody.PInvoke attrLazy -> - let attr = attrLazy.Value - "pinvokeimpl(\"" + attr.Where.Name + "\" as \"" + attr.Name + "\"" + - (match attr.CallingConv with - | PInvokeCallingConvention.None -> "" - | PInvokeCallingConvention.Cdecl -> " cdecl" - | PInvokeCallingConvention.Stdcall -> " stdcall" - | PInvokeCallingConvention.Thiscall -> " thiscall" - | PInvokeCallingConvention.Fastcall -> " fastcall" - | PInvokeCallingConvention.WinApi -> " winapi" ) + - - (match attr.CharEncoding with - | PInvokeCharEncoding.None -> "" - | PInvokeCharEncoding.Ansi -> " ansi" - | PInvokeCharEncoding.Unicode -> " unicode" - | PInvokeCharEncoding.Auto -> " autochar") + - - (if attr.NoMangle then " nomangle" else "") + - (if attr.LastError then " lasterr" else "") + - ")" - | _ -> - "") - elif md.IsClassInitializer then "specialname rtspecialname static" - else "" - let is_entrypoint = md.IsEntryPoint - let menv = ppenv_enter_method (List.length md.GenericParams) env - output_string os " .method " - if md.IsHideBySig then output_string os "hidebysig " - if md.IsReqSecObj then output_string os "reqsecobj " - if md.IsSpecialName then output_string os "specialname " - if md.IsUnmanagedExport then output_string os "unmanagedexp " - output_member_access os md.Access - output_string os " " - output_string os attrs - output_string os " " - output_callconv os md.CallingConv - output_string os " " - (goutput_typ menv) os md.Return.Type - output_string os " " - output_id os md.Name - output_string os " " - (goutput_gparams env) os md.GenericParams - output_string os " " - (goutput_params menv) os md.Parameters - output_string os " " - if md.IsSynchronized then output_string os "synchronized " - if md.IsMustRun then output_string os "/* mustrun */ " - if md.IsPreserveSig then output_string os "preservesig " - if md.IsNoInline then output_string os "noinlining " - if md.IsAggressiveInline then output_string os "aggressiveinlining " - (goutput_mbody is_entrypoint menv) os md - output_string os "\n" + + if is_entrypoint then + output_string os " .entrypoint" + + output_string os "\n" + output_string os "}\n" + +let goutput_mdef env os (md: ILMethodDef) = + let attrs = + if md.IsVirtual then + "virtual " + + (if md.IsFinal then "final " else "") + + (if md.IsNewSlot then "newslot " else "") + + (if md.IsCheckAccessOnOverride then + " strict " + else + "") + + (if md.IsAbstract then + " abstract " + else + "") + + " " + elif md.IsNonVirtualInstance then + "" + elif md.IsConstructor then + "rtspecialname" + elif md.IsStatic then + "static " + + (match md.Body with + | MethodBody.PInvoke attrLazy -> + let attr = attrLazy.Value + + "pinvokeimpl(\"" + + attr.Where.Name + + "\" as \"" + + attr.Name + + "\"" + + (match attr.CallingConv with + | PInvokeCallingConvention.None -> "" + | PInvokeCallingConvention.Cdecl -> " cdecl" + | PInvokeCallingConvention.Stdcall -> " stdcall" + | PInvokeCallingConvention.Thiscall -> " thiscall" + | PInvokeCallingConvention.Fastcall -> " fastcall" + | PInvokeCallingConvention.WinApi -> " winapi") + + + + (match attr.CharEncoding with + | PInvokeCharEncoding.None -> "" + | PInvokeCharEncoding.Ansi -> " ansi" + | PInvokeCharEncoding.Unicode -> " unicode" + | PInvokeCharEncoding.Auto -> " autochar") + + + + (if attr.NoMangle then + " nomangle" + else + "") + + (if attr.LastError then + " lasterr" + else + "") + + ")" + | _ -> "") + elif md.IsClassInitializer then + "specialname rtspecialname static" + else + "" + + let is_entrypoint = md.IsEntryPoint + let menv = ppenv_enter_method (List.length md.GenericParams) env + output_string os " .method " + + if md.IsHideBySig then + output_string os "hidebysig " + + if md.IsReqSecObj then + output_string os "reqsecobj " + + if md.IsSpecialName then + output_string os "specialname " + + if md.IsUnmanagedExport then + output_string os "unmanagedexp " + + output_member_access os md.Access + output_string os " " + output_string os attrs + output_string os " " + output_callconv os md.CallingConv + output_string os " " + (goutput_typ menv) os md.Return.Type + output_string os " " + output_id os md.Name + output_string os " " + (goutput_gparams env) os md.GenericParams + output_string os " " + (goutput_params menv) os md.Parameters + output_string os " " + + if md.IsSynchronized then + output_string os "synchronized " + + if md.IsMustRun then + output_string os "/* mustrun */ " + + if md.IsPreserveSig then + output_string os "preservesig " + + if md.IsNoInline then + output_string os "noinlining " + + if md.IsAggressiveInline then + output_string os "aggressiveinlining " + + (goutput_mbody is_entrypoint menv) os md + output_string os "\n" 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: " - (match pd.SetMethod with None -> () | Some mref -> goutput_mref env os mref) + output_string os "property\n\tgetter: " -let goutput_superclass env os = function - None -> () - | Some typ -> output_string os "extends "; (goutput_typ_with_shortened_class_syntax env) os typ + (match pd.GetMethod with + | None -> () + | Some mref -> goutput_mref env os mref) + + output_string os "\n\tsetter: " + + (match pd.SetMethod with + | None -> () + | Some mref -> goutput_mref env os mref) + +let goutput_superclass env os = + function + | None -> () + | Some typ -> + output_string os "extends " + (goutput_typ_with_shortened_class_syntax env) os typ let goutput_superinterfaces env os imp = - if not (List.isEmpty imp) then - 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 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 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" +let the = + function + | Some x -> x + | None -> failwith "the" let output_type_layout_info os info = - if info.Size <> None then (output_string os " .size "; output_i32 os (the info.Size)) - if info.Pack <> None then (output_string os " .pack "; output_u16 os (the info.Pack)) + if info.Size <> None then + (output_string os " .size " + output_i32 os (the info.Size)) + + if info.Pack <> None then + (output_string os " .pack " + output_u16 os (the info.Pack)) -let splitTypeLayout = function - | ILTypeDefLayout.Auto -> "auto", (fun _os () -> ()) - | ILTypeDefLayout.Sequential info -> "sequential", (fun os () -> output_type_layout_info os info) - | ILTypeDefLayout.Explicit info -> "explicit", (fun os () -> output_type_layout_info os info) +let splitTypeLayout = + function + | ILTypeDefLayout.Auto -> "auto", (fun _os () -> ()) + | ILTypeDefLayout.Sequential info -> "sequential", (fun os () -> output_type_layout_info os info) + | ILTypeDefLayout.Explicit info -> "explicit", (fun os () -> output_type_layout_info os info) let goutput_fdefs tref env os (fdefs: ILFieldDefs) = - for f in fdefs.AsList() do - goutput_fdef tref env os f - output_string os "\n" + for f in fdefs.AsList() do + goutput_fdef tref env os f + output_string os "\n" let goutput_mdefs env os (mdefs: ILMethodDefs) = - for f in mdefs.AsArray() do - goutput_mdef env os f - output_string os "\n" + for f in mdefs.AsArray() do + goutput_mdef env os f + output_string os "\n" let goutput_pdefs env os (pdefs: ILPropertyDefs) = - for f in pdefs.AsList() do - goutput_pdef env os f - output_string os "\n" + for f in pdefs.AsList() do + goutput_pdef env os f + output_string os "\n" 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 - if contents then - let tref = (mkILNestedTyRef (ILScopeRef.Local, enc, cd.Name)) - goutput_mdefs env os cd.Methods - goutput_fdefs tref env os cd.Fields - goutput_pdefs env os cd.Properties - else - output_string os "\n" - if cd.IsInterface then output_string os ".class interface " - else output_string os ".class " - output_init_semantics os cd.Attributes - output_string os " " - output_type_access os cd.Access - output_string os " " - output_encoding os cd.Encoding - output_string os " " - output_string os layout_attr - output_string os " " - if cd.IsSealed then output_string os "sealed " - if cd.IsAbstract then output_string os "abstract " - if cd.IsSerializable then output_string os "serializable " - if cd.IsComInterop then output_string os "import " - output_sqstring os cd.Name - goutput_gparams env os cd.GenericParams - output_string os "\n\t" - goutput_superclass env os cd.Extends - output_string os "\n\t" - goutput_implements env os cd.Implements - output_string os "\n{\n " - if contents then - let tref = (mkILNestedTyRef (ILScopeRef.Local, enc, cd.Name)) - goutput_custom_attrs env os cd.CustomAttrs - goutput_security_decls env os cd.SecurityDecls - pp_layout_decls os () - goutput_fdefs tref env os cd.Fields - goutput_mdefs env os cd.Methods - goutput_tdefs contents (enc@[cd.Name]) env os cd.NestedTypes - output_string os "\n}" + let env = ppenv_enter_tdef cd.GenericParams env + let layout_attr, pp_layout_decls = splitTypeLayout cd.Layout + + if isTypeNameForGlobalFunctions cd.Name then + if contents then + let tref = (mkILNestedTyRef (ILScopeRef.Local, enc, cd.Name)) + goutput_mdefs env os cd.Methods + goutput_fdefs tref env os cd.Fields + goutput_pdefs env os cd.Properties + else + output_string os "\n" + + if cd.IsInterface then + output_string os ".class interface " + else + output_string os ".class " + + output_init_semantics os cd.Attributes + output_string os " " + output_type_access os cd.Access + output_string os " " + output_encoding os cd.Encoding + output_string os " " + output_string os layout_attr + output_string os " " + + if cd.IsSealed then + output_string os "sealed " + + if cd.IsAbstract then + output_string os "abstract " + + if cd.IsSerializable then + output_string os "serializable " + + if cd.IsComInterop then + output_string os "import " + + output_sqstring os cd.Name + goutput_gparams env os cd.GenericParams + output_string os "\n\t" + goutput_superclass env os cd.Extends + output_string os "\n\t" + goutput_implements env os cd.Implements + output_string os "\n{\n " + + if contents then + let tref = (mkILNestedTyRef (ILScopeRef.Local, enc, cd.Name)) + goutput_custom_attrs env os cd.CustomAttrs + goutput_security_decls env os cd.SecurityDecls + pp_layout_decls os () + goutput_fdefs tref env os cd.Fields + goutput_mdefs env os cd.Methods + + goutput_tdefs contents (enc @ [ cd.Name ]) env os cd.NestedTypes + output_string os "\n}" and output_init_semantics os f = - if f &&& TypeAttributes.BeforeFieldInit <> enum 0 then output_string os "beforefieldinit" + if f &&& TypeAttributes.BeforeFieldInit <> enum 0 then + output_string os "beforefieldinit" and goutput_lambdas env os lambdas = - match lambdas with - | Lambdas_forall (gf, l) -> - 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 " " - (goutput_lambdas env) os l - | Lambdas_return typ -> output_string os "--> "; (goutput_typ env) os typ + match lambdas with + | Lambdas_forall (gf, l) -> + 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 " " + (goutput_lambdas env) os l + | Lambdas_return typ -> + output_string os "--> " + (goutput_typ env) os typ and goutput_tdefs contents enc env os (tds: ILTypeDefs) = - for td in tds.AsList() do - goutput_tdef enc env contents os td + for td in tds.AsList() do + goutput_tdef enc env contents os td let output_ver os (version: ILVersionInfo) = output_string os " .ver " @@ -1001,71 +1355,98 @@ let output_ver os (version: ILVersionInfo) = output_string os " : " output_u16 os version.Revision -let output_locale os s = output_string os " .Locale "; output_qstring os s +let output_locale os s = + output_string os " .Locale " + output_qstring os s let output_hash os x = - output_string os " .hash = "; output_parens output_bytes os x + output_string os " .hash = " + output_parens output_bytes os x + let output_publickeytoken os x = - output_string os " .publickeytoken = "; output_parens output_bytes os x + output_string os " .publickeytoken = " + output_parens output_bytes os x + let output_publickey os x = - output_string os " .publickey = "; output_parens output_bytes os x - -let output_publickeyinfo os = function - | PublicKey k -> output_publickey os k - | PublicKeyToken k -> output_publickeytoken os k - -let output_assemblyRef os (aref:ILAssemblyRef) = - output_string os " .assembly extern " - output_sqstring os aref.Name - if aref.Retargetable then output_string os " retargetable " - output_string os " { " - output_option output_hash os aref.Hash - output_option output_publickeyinfo os aref.PublicKey - output_option output_ver os aref.Version - output_option output_locale os aref.Locale - output_string os " } " - -let output_modref os (modref:ILModuleRef) = - output_string os (if modref.HasMetadata then " .module extern " else " .file nometadata " ) - output_sqstring os modref.Name - output_option output_hash os modref.Hash + output_string os " .publickey = " + output_parens output_bytes os x + +let output_publickeyinfo os = + function + | PublicKey k -> output_publickey os k + | PublicKeyToken k -> output_publickeytoken os k + +let output_assemblyRef os (aref: ILAssemblyRef) = + output_string os " .assembly extern " + output_sqstring os aref.Name + + if aref.Retargetable then + output_string os " retargetable " + + output_string os " { " + output_option output_hash os aref.Hash + output_option output_publickeyinfo os aref.PublicKey + output_option output_ver os aref.Version + output_option output_locale os aref.Locale + output_string os " } " + +let output_modref os (modref: ILModuleRef) = + output_string + os + (if modref.HasMetadata then + " .module extern " + else + " .file nometadata ") + + output_sqstring os modref.Name + output_option output_hash os modref.Hash let goutput_resource env os r = - output_string os " .mresource " - output_string os (match r.Access with ILResourceAccess.Public -> " public " | ILResourceAccess.Private -> " private ") - output_sqstring os r.Name - output_string os " { " - goutput_custom_attrs env os r.CustomAttrs - match r.Location with - | ILResourceLocation.Local _ -> - output_string os " /* loc nyi */ " - | ILResourceLocation.File (mref, off) -> - output_string os " .file " - output_sqstring os mref.Name - output_string os " at " - output_i32 os off - | ILResourceLocation.Assembly aref -> - output_string os " .assembly extern " - output_sqstring os aref.Name - output_string os " }\n " + output_string os " .mresource " + + output_string + os + (match r.Access with + | ILResourceAccess.Public -> " public " + | ILResourceAccess.Private -> " private ") + + output_sqstring os r.Name + output_string os " { " + goutput_custom_attrs env os r.CustomAttrs + + match r.Location with + | ILResourceLocation.Local _ -> output_string os " /* loc nyi */ " + | ILResourceLocation.File (mref, off) -> + output_string os " .file " + output_sqstring os mref.Name + output_string os " at " + output_i32 os off + | ILResourceLocation.Assembly aref -> + output_string os " .assembly extern " + output_sqstring os aref.Name + + output_string os " }\n " let goutput_manifest env os m = - output_string os " .assembly " - match m.AssemblyLongevity with - | ILAssemblyLongevity.Unspecified -> () - | ILAssemblyLongevity.Library -> output_string os "library " - | ILAssemblyLongevity.PlatformAppDomain -> output_string os "platformappdomain " - | ILAssemblyLongevity.PlatformProcess -> output_string os "platformprocess " - | ILAssemblyLongevity.PlatformSystem -> output_string os "platformmachine " - 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 - 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" - + output_string os " .assembly " + + match m.AssemblyLongevity with + | ILAssemblyLongevity.Unspecified -> () + | ILAssemblyLongevity.Library -> output_string os "library " + | ILAssemblyLongevity.PlatformAppDomain -> output_string os "platformappdomain " + | ILAssemblyLongevity.PlatformProcess -> output_string os "platformprocess " + | ILAssemblyLongevity.PlatformSystem -> output_string os "platformmachine " + + 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 + 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" let output_module_fragment_aux os (ilg: ILGlobals) modul = let env = mk_ppenv ilg @@ -1074,12 +1455,26 @@ let output_module_fragment_aux os (ilg: ILGlobals) modul = goutput_tdefs true [] env os modul.TypeDefs let goutput_module_manifest env os modul = - output_string os " .module "; output_sqstring os modul.Name + output_string os " .module " + output_sqstring os modul.Name goutput_custom_attrs env os modul.CustomAttrs - output_string os " .imagebase "; output_i32 os modul.ImageBase - output_string os " .file alignment "; output_i32 os modul.PhysicalAlignment - output_string os " .subsystem "; output_i32 os modul.SubSystemFlags - output_string os " .corflags "; output_i32 os ((if modul.IsILOnly then 0x0001 else 0) ||| (if modul.Is32Bit then 0x0002 else 0) ||| (if modul.Is32BitPreferred then 0x00020003 else 0)) + output_string os " .imagebase " + output_i32 os modul.ImageBase + output_string os " .file alignment " + output_i32 os modul.PhysicalAlignment + output_string os " .subsystem " + output_i32 os modul.SubSystemFlags + output_string os " .corflags " + + output_i32 + os + ((if modul.IsILOnly then 0x0001 else 0) + ||| (if modul.Is32Bit then 0x0002 else 0) + ||| (if modul.Is32BitPreferred then + 0x00020003 + else + 0)) + List.iter (fun r -> goutput_resource env os r) (modul.Resources.AsList()) output_string os "\n" output_option (goutput_manifest env) os modul.Manifest @@ -1090,9 +1485,4 @@ let output_module os (ilg: ILGlobals) modul = goutput_module_manifest env os modul output_module_fragment_aux os ilg modul - #endif - - - - diff --git a/src/Compiler/AbstractIL/ilread.fs b/src/Compiler/AbstractIL/ilread.fs index 9446bd09a..6ec7cec7c 100644 --- a/src/Compiler/AbstractIL/ilread.fs +++ b/src/Compiler/AbstractIL/ilread.fs @@ -33,20 +33,45 @@ open FSharp.NativeInterop let checking = false let logging = false -let _ = if checking then dprintn "warning: ILBinaryReader.checking is on" -let noStableFileHeuristic = try (Environment.GetEnvironmentVariable("FSharp_NoStableFileHeuristic") <> null) with _ -> false -let alwaysMemoryMapFSC = try (Environment.GetEnvironmentVariable("FSharp_AlwaysMemoryMapCommandLineCompiler") <> null) with _ -> false + +let _ = + if checking then + dprintn "warning: ILBinaryReader.checking is on" + +let noStableFileHeuristic = + try + (Environment.GetEnvironmentVariable("FSharp_NoStableFileHeuristic") <> null) + with + | _ -> false + +let alwaysMemoryMapFSC = + try + (Environment.GetEnvironmentVariable("FSharp_AlwaysMemoryMapCommandLineCompiler") + <> null) + with + | _ -> false + let stronglyHeldReaderCacheSizeDefault = 30 -let stronglyHeldReaderCacheSize = try (match Environment.GetEnvironmentVariable("FSharp_StronglyHeldBinaryReaderCacheSize") with null -> stronglyHeldReaderCacheSizeDefault | s -> int32 s) with _ -> stronglyHeldReaderCacheSizeDefault -let singleOfBits (x: int32) = BitConverter.ToSingle(BitConverter.GetBytes x, 0) +let stronglyHeldReaderCacheSize = + try + (match Environment.GetEnvironmentVariable("FSharp_StronglyHeldBinaryReaderCacheSize") with + | null -> stronglyHeldReaderCacheSizeDefault + | s -> int32 s) + with + | _ -> stronglyHeldReaderCacheSizeDefault + +let singleOfBits (x: int32) = + BitConverter.ToSingle(BitConverter.GetBytes x, 0) + let doubleOfBits (x: int64) = BitConverter.Int64BitsToDouble x //--------------------------------------------------------------------- // Utilities. //--------------------------------------------------------------------- -let align alignment n = ((n + alignment - 0x1) / alignment) * alignment +let align alignment n = + ((n + alignment - 0x1) / alignment) * alignment let uncodedToken (tab: TableName) idx = ((tab.Index <<< 24) ||| idx) @@ -55,56 +80,70 @@ let i32ToUncodedToken tok = let tab = tok >>>& 24 (TableName.FromIndex tab, idx) - [] type TaggedIndex<'T> = val tag: 'T val index: int32 - new(tag, index) = { tag=tag; index=index } + new(tag, index) = { tag = tag; index = index } let uncodedTokenToTypeDefOrRefOrSpec (tab, tok) = let tag = - if tab = TableNames.TypeDef then tdor_TypeDef - elif tab = TableNames.TypeRef then tdor_TypeRef - elif tab = TableNames.TypeSpec then tdor_TypeSpec - else failwith "bad table in uncodedTokenToTypeDefOrRefOrSpec" + if tab = TableNames.TypeDef then + tdor_TypeDef + elif tab = TableNames.TypeRef then + tdor_TypeRef + elif tab = TableNames.TypeSpec then + tdor_TypeSpec + else + failwith "bad table in uncodedTokenToTypeDefOrRefOrSpec" + TaggedIndex(tag, tok) let uncodedTokenToMethodDefOrRef (tab, tok) = let tag = - if tab = TableNames.Method then mdor_MethodDef - elif tab = TableNames.MemberRef then mdor_MemberRef - else failwith "bad table in uncodedTokenToMethodDefOrRef" + if tab = TableNames.Method then + mdor_MethodDef + elif tab = TableNames.MemberRef then + mdor_MemberRef + else + failwith "bad table in uncodedTokenToMethodDefOrRef" + TaggedIndex(tag, tok) let (|TaggedIndex|) (x: TaggedIndex<'T>) = x.tag, x.index + let inline tokToTaggedIdx f nbits tok = let tagmask = if nbits = 1 then 1 elif nbits = 2 then 3 elif nbits = 3 then 7 elif nbits = 4 then 15 - elif nbits = 5 then 31 - else failwith "too many nbits" + elif nbits = 5 then 31 + else failwith "too many nbits" + let tag = tok &&& tagmask 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 } + { + 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 } + { + rawMemoryFileCount = 0 + memoryMapFileOpenedCount = 0 + memoryMapFileClosedCount = 0 + weakByteFileCount = 0 + byteFileCount = 0 + } -let GetStatistics() = stats +let GetStatistics () = stats type private BinaryView = ReadOnlyByteMemory @@ -120,15 +159,16 @@ type RawMemoryFile = val mutable private fileName: string val mutable private view: ReadOnlyByteMemory - new (fileName: string, obj: obj, addr: nativeint, length: int) = + new(fileName: string, obj: obj, addr: nativeint, length: int) = stats.rawMemoryFileCount <- stats.rawMemoryFileCount + 1 + { holder = obj fileName = fileName view = ByteMemory.FromUnsafePointer(addr, length, obj).AsReadOnly() } - new (fileName: string, holder: obj, bmem: ByteMemory) = + new(fileName: string, holder: obj, bmem: ByteMemory) = { holder = holder // gonna be finalized due to how we pass the holder when create RawByteMemory fileName = fileName @@ -144,6 +184,7 @@ type RawMemoryFile = /// Gives a view over any ByteMemory, can be stream-based, mmap-ed, or just byte array. type ByteMemoryFile(fileName: string, view: ByteMemory) = member _.FileName = fileName + interface BinaryFile with override _.GetView() = view.AsReadOnly() @@ -153,6 +194,7 @@ type ByteFile(fileName: string, bytes: byte[]) = let view = ByteMemory.FromArray(bytes).AsReadOnly() do stats.byteFileCount <- stats.byteFileCount + 1 member _.FileName = fileName + interface BinaryFile with override bf.GetView() = view @@ -164,8 +206,7 @@ type PEFile(fileName: string, peReader: PEReader) as this = member _.FileName = fileName - override _.Finalize() = - peReader.Dispose() + override _.Finalize() = peReader.Dispose() interface BinaryFile with override _.GetView() = @@ -173,7 +214,10 @@ type PEFile(fileName: string, peReader: PEReader) as this = | true, m -> m.AsReadOnly() | _ -> let block = peReader.GetEntireImage() // it's ok to call this everytime we do GetView as it is cached in the PEReader. - let m = ByteMemory.FromUnsafePointer(block.Pointer |> NativePtr.toNativeInt, block.Length, this) + + let m = + ByteMemory.FromUnsafePointer(block.Pointer |> NativePtr.toNativeInt, block.Length, this) + weakMemory <- WeakReference(m) m.AsReadOnly() @@ -199,15 +243,17 @@ type WeakByteFile(fileName: string, chunk: (int * int) option) = override this.GetView() = let strongBytes = let mutable tg = null + if not (weakBytes.TryGetTarget(&tg)) then if FileSystem.GetLastWriteTimeShim fileName <> fileStamp then - error (Error (FSComp.SR.ilreadFileChanged fileName, range0)) + error (Error(FSComp.SR.ilreadFileChanged fileName, range0)) let bytes = use stream = FileSystem.OpenFileForReadShim(fileName) + match chunk with | None -> stream.ReadAllBytes() - | Some(start, length) -> stream.ReadBytes(start, length) + | Some (start, length) -> stream.ReadBytes(start, length) tg <- bytes @@ -217,7 +263,6 @@ type WeakByteFile(fileName: string, chunk: (int * int) option) = ByteMemory.FromArray(strongBytes).AsReadOnly() - let seekReadByte (mdv: BinaryView) addr = mdv[addr] let seekReadBytes (mdv: BinaryView) addr len = mdv.ReadBytes(addr, len) let seekReadInt32 (mdv: BinaryView) addr = mdv.ReadInt32 addr @@ -227,31 +272,40 @@ let seekReadByteAsInt32 mdv addr = int32 (seekReadByte mdv addr) 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 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 mdv addr = int32 (seekReadUInt16 mdv addr) let seekReadCompressedUInt32 mdv addr = let b0 = seekReadByte mdv addr - if b0 <= 0x7Fuy then struct (int b0, addr+1) + + if b0 <= 0x7Fuy then + struct (int b0, addr + 1) elif b0 <= 0xBFuy then let b0 = b0 &&& 0x7Fuy - let b1 = seekReadByteAsInt32 mdv (addr+1) - struct ((int b0 <<< 8) ||| int b1, addr+2) + let b1 = seekReadByteAsInt32 mdv (addr + 1) + struct ((int b0 <<< 8) ||| int b1, addr + 2) else let b0 = b0 &&& 0x3Fuy - let b1 = seekReadByteAsInt32 mdv (addr+1) - let b2 = seekReadByteAsInt32 mdv (addr+2) - let b3 = seekReadByteAsInt32 mdv (addr+3) - struct ((int b0 <<< 24) ||| (int b1 <<< 16) ||| (int b2 <<< 8) ||| int b3, addr+4) + let b1 = seekReadByteAsInt32 mdv (addr + 1) + let b2 = seekReadByteAsInt32 mdv (addr + 2) + let b3 = seekReadByteAsInt32 mdv (addr + 3) + struct ((int b0 <<< 24) ||| (int b1 <<< 16) ||| (int b2 <<< 8) ||| int b3, addr + 4) let seekReadSByte mdv addr = sbyte (seekReadByte mdv addr) let seekReadSingle mdv addr = singleOfBits (seekReadInt32 mdv addr) @@ -259,12 +313,15 @@ let seekReadDouble mdv addr = doubleOfBits (seekReadInt64 mdv addr) let rec seekCountUtf8String mdv addr n = let c = seekReadByteAsInt32 mdv addr - if c = 0 then n - else seekCountUtf8String mdv (addr+1) (n+1) + + if c = 0 then + n + else + seekCountUtf8String mdv (addr + 1) (n + 1) let seekReadUTF8String (mdv: BinaryView) addr = let n = seekCountUtf8String mdv addr 0 - mdv.ReadUtf8String (addr, n) + mdv.ReadUtf8String(addr, n) let seekReadBlob mdv addr = let struct (len, addr) = seekReadCompressedUInt32 mdv addr @@ -280,13 +337,13 @@ let seekReadGuid mdv addr = seekReadBytes mdv addr 0x10 let seekReadUncodedToken mdv addr = i32ToUncodedToken (seekReadInt32 mdv addr) - //--------------------------------------------------------------------- // Primitives to help read signatures. These do not use the file cursor //--------------------------------------------------------------------- let sigptrCheck (bytes: byte[]) sigptr = - if checking && sigptr >= bytes.Length then failwith "read past end of sig. " + if checking && sigptr >= bytes.Length then + failwith "read past end of sig. " // All this code should be moved to use a mutable index into the signature // @@ -318,9 +375,9 @@ let sigptrGetInt16 bytes sigptr = let sigptrGetInt32 bytes sigptr = sigptrCheck bytes sigptr let b0 = bytes[sigptr] - let b1 = bytes[sigptr+1] - let b2 = bytes[sigptr+2] - let b3 = bytes[sigptr+3] + let b1 = bytes[sigptr + 1] + let b2 = bytes[sigptr + 2] + let b3 = bytes[sigptr + 3] let res = int b0 ||| (int b1 <<< 8) ||| (int b2 <<< 16) ||| (int b3 <<< 24) res, sigptr + 4 @@ -347,7 +404,9 @@ let sigptrGetDouble bytes sigptr = let sigptrGetZInt32 bytes sigptr = let b0, sigptr = sigptrGetByte bytes sigptr - if b0 <= 0x7Fuy then struct (int b0, sigptr) + + if b0 <= 0x7Fuy then + struct (int b0, sigptr) elif b0 <= 0xBFuy then let b0 = b0 &&& 0x7Fuy let b1, sigptr = sigptrGetByte bytes sigptr @@ -362,20 +421,20 @@ let sigptrGetZInt32 bytes sigptr = let rec sigptrFoldAcc f n (bytes: byte[]) (sigptr: int) i acc = if i < n then let x, sp = f bytes sigptr - sigptrFoldAcc f n bytes sp (i+1) (x :: acc) + sigptrFoldAcc f n bytes sp (i + 1) (x :: acc) else List.rev acc, sigptr -let sigptrFold f n (bytes: byte[]) (sigptr: int) = - sigptrFoldAcc f n bytes sigptr 0 [] +let sigptrFold f n (bytes: byte[]) (sigptr: int) = sigptrFoldAcc f n bytes sigptr 0 [] let sigptrFoldStruct f n (bytes: byte[]) (sigptr: int) = let rec sigptrFoldAcc f n (bytes: byte[]) (sigptr: int) i acc = if i < n then let struct (x, sp) = f bytes sigptr - sigptrFoldAcc f n bytes sp (i+1) (x :: acc) + sigptrFoldAcc f n bytes sp (i + 1) (x :: acc) else struct (List.rev acc, sigptr) + sigptrFoldAcc f n bytes sigptr 0 [] let sigptrGetBytes n (bytes: byte[]) sigptr = @@ -384,68 +443,116 @@ let sigptrGetBytes n (bytes: byte[]) sigptr = Bytes.zeroCreate 0, sigptr else let res = Bytes.zeroCreate n + for i = 0 to (n - 1) do res[i] <- bytes[sigptr + i] + res, sigptr + n let sigptrGetString n bytes sigptr = let bytearray, sigptr = sigptrGetBytes n bytes sigptr (Encoding.UTF8.GetString(bytearray, 0, bytearray.Length)), sigptr - // -------------------------------------------------------------------- // Now the tables of instructions // -------------------------------------------------------------------- [] type ILInstrPrefixesRegister = - { mutable al: ILAlignment - mutable tl: ILTailcall - mutable vol: ILVolatility - mutable ro: ILReadonly - mutable constrained: ILType option} + { + mutable al: ILAlignment + mutable tl: ILTailcall + mutable vol: ILVolatility + mutable ro: ILReadonly + mutable constrained: ILType option + } let noPrefixes mk prefixes = - if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here" - if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here" - if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here" - if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here" - if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here" + if prefixes.al <> Aligned then + failwith "an unaligned prefix is not allowed here" + + if prefixes.vol <> Nonvolatile then + failwith "a volatile prefix is not allowed here" + + if prefixes.tl <> Normalcall then + failwith "a tailcall prefix is not allowed here" + + if prefixes.ro <> NormalAddress then + failwith "a readonly prefix is not allowed here" + + if prefixes.constrained <> None then + failwith "a constrained prefix is not allowed here" + mk let volatileOrUnalignedPrefix mk prefixes = - if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here" - if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here" - if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here" + if prefixes.tl <> Normalcall then + failwith "a tailcall prefix is not allowed here" + + if prefixes.constrained <> None then + failwith "a constrained prefix is not allowed here" + + if prefixes.ro <> NormalAddress then + failwith "a readonly prefix is not allowed here" + mk (prefixes.al, prefixes.vol) let volatilePrefix mk prefixes = - if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here" - if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here" - if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here" - if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here" + if prefixes.al <> Aligned then + failwith "an unaligned prefix is not allowed here" + + if prefixes.tl <> Normalcall then + failwith "a tailcall prefix is not allowed here" + + if prefixes.constrained <> None then + failwith "a constrained prefix is not allowed here" + + if prefixes.ro <> NormalAddress then + failwith "a readonly prefix is not allowed here" + mk prefixes.vol let tailPrefix mk prefixes = - if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here" - if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here" - if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here" - if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here" + if prefixes.al <> Aligned then + failwith "an unaligned prefix is not allowed here" + + if prefixes.vol <> Nonvolatile then + failwith "a volatile prefix is not allowed here" + + if prefixes.constrained <> None then + failwith "a constrained prefix is not allowed here" + + if prefixes.ro <> NormalAddress then + failwith "a readonly prefix is not allowed here" + mk prefixes.tl let constraintOrTailPrefix mk prefixes = - if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here" - if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here" - if prefixes.ro <> NormalAddress then failwith "a readonly prefix is not allowed here" - mk (prefixes.constrained, prefixes.tl ) + if prefixes.al <> Aligned then + failwith "an unaligned prefix is not allowed here" + + if prefixes.vol <> Nonvolatile then + failwith "a volatile prefix is not allowed here" + + if prefixes.ro <> NormalAddress then + failwith "a readonly prefix is not allowed here" + + mk (prefixes.constrained, prefixes.tl) let readonlyPrefix mk prefixes = - if prefixes.al <> Aligned then failwith "an unaligned prefix is not allowed here" - if prefixes.vol <> Nonvolatile then failwith "a volatile prefix is not allowed here" - if prefixes.tl <> Normalcall then failwith "a tailcall prefix is not allowed here" - if prefixes.constrained <> None then failwith "a constrained prefix is not allowed here" - mk prefixes.ro + if prefixes.al <> Aligned then + failwith "an unaligned prefix is not allowed here" + + if prefixes.vol <> Nonvolatile then + failwith "a volatile prefix is not allowed here" + if prefixes.tl <> Normalcall then + failwith "a tailcall prefix is not allowed here" + + if prefixes.constrained <> None then + failwith "a constrained prefix is not allowed here" + + mk prefixes.ro [] type ILInstrDecoder = @@ -470,143 +577,166 @@ type ILInstrDecoder = | I_type_instr of (ILInstrPrefixesRegister -> ILType -> ILInstr) | I_invalid_instr -let mkStind dt = volatileOrUnalignedPrefix (fun (x, y) -> I_stind(x, y, dt)) -let mkLdind dt = volatileOrUnalignedPrefix (fun (x, y) -> I_ldind(x, y, dt)) +let mkStind dt = + volatileOrUnalignedPrefix (fun (x, y) -> I_stind(x, y, dt)) + +let mkLdind dt = + volatileOrUnalignedPrefix (fun (x, y) -> I_ldind(x, y, dt)) let instrs () = - [ i_ldarg_s, I_u16_u8_instr (noPrefixes mkLdarg) - i_starg_s, I_u16_u8_instr (noPrefixes I_starg) - i_ldarga_s, I_u16_u8_instr (noPrefixes I_ldarga) - i_stloc_s, I_u16_u8_instr (noPrefixes mkStloc) - i_ldloc_s, I_u16_u8_instr (noPrefixes mkLdloc) - i_ldloca_s, I_u16_u8_instr (noPrefixes I_ldloca) - i_ldarg, I_u16_u16_instr (noPrefixes mkLdarg) - i_starg, I_u16_u16_instr (noPrefixes I_starg) - i_ldarga, I_u16_u16_instr (noPrefixes I_ldarga) - i_stloc, I_u16_u16_instr (noPrefixes mkStloc) - i_ldloc, I_u16_u16_instr (noPrefixes mkLdloc) - i_ldloca, I_u16_u16_instr (noPrefixes I_ldloca) - i_stind_i, I_none_instr (mkStind DT_I) - i_stind_i1, I_none_instr (mkStind DT_I1) - i_stind_i2, I_none_instr (mkStind DT_I2) - i_stind_i4, I_none_instr (mkStind DT_I4) - i_stind_i8, I_none_instr (mkStind DT_I8) - i_stind_r4, I_none_instr (mkStind DT_R4) - i_stind_r8, I_none_instr (mkStind DT_R8) - i_stind_ref, I_none_instr (mkStind DT_REF) - i_ldind_i, I_none_instr (mkLdind DT_I) - i_ldind_i1, I_none_instr (mkLdind DT_I1) - i_ldind_i2, I_none_instr (mkLdind DT_I2) - i_ldind_i4, I_none_instr (mkLdind DT_I4) - i_ldind_i8, I_none_instr (mkLdind DT_I8) - i_ldind_u1, I_none_instr (mkLdind DT_U1) - i_ldind_u2, I_none_instr (mkLdind DT_U2) - i_ldind_u4, I_none_instr (mkLdind DT_U4) - i_ldind_r4, I_none_instr (mkLdind DT_R4) - i_ldind_r8, I_none_instr (mkLdind DT_R8) - i_ldind_ref, I_none_instr (mkLdind DT_REF) - i_cpblk, I_none_instr (volatileOrUnalignedPrefix I_cpblk) - i_initblk, I_none_instr (volatileOrUnalignedPrefix I_initblk) - i_ldc_i8, I_i64_instr (noPrefixes (fun x ->(AI_ldc (DT_I8, ILConst.I8 x)))) - i_ldc_i4, I_i32_i32_instr (noPrefixes mkLdcInt32) - i_ldc_i4_s, I_i32_i8_instr (noPrefixes mkLdcInt32) - i_ldc_r4, I_r4_instr (noPrefixes (fun x -> (AI_ldc (DT_R4, ILConst.R4 x)))) - i_ldc_r8, I_r8_instr (noPrefixes (fun x -> (AI_ldc (DT_R8, ILConst.R8 x)))) - i_ldfld, I_field_instr (volatileOrUnalignedPrefix(fun (x, y) fspec -> I_ldfld (x, y, fspec))) - i_stfld, I_field_instr (volatileOrUnalignedPrefix(fun (x, y) fspec -> I_stfld (x, y, fspec))) - i_ldsfld, I_field_instr (volatilePrefix (fun x fspec -> I_ldsfld (x, fspec))) - i_stsfld, I_field_instr (volatilePrefix (fun x fspec -> I_stsfld (x, fspec))) - i_ldflda, I_field_instr (noPrefixes I_ldflda) - i_ldsflda, I_field_instr (noPrefixes I_ldsflda) - i_call, I_method_instr (tailPrefix (fun tl (mspec, y) -> I_call (tl, mspec, y))) - i_ldftn, I_method_instr (noPrefixes (fun (mspec, _y) -> I_ldftn mspec)) - i_ldvirtftn, I_method_instr (noPrefixes (fun (mspec, _y) -> I_ldvirtftn mspec)) - i_newobj, I_method_instr (noPrefixes I_newobj) - i_callvirt, I_method_instr (constraintOrTailPrefix (fun (c, tl) (mspec, y) -> match c with Some ty -> I_callconstraint(tl, ty, mspec, y) | None -> I_callvirt (tl, mspec, y))) - i_leave_s, I_unconditional_i8_instr (noPrefixes (fun x -> I_leave x)) - i_br_s, I_unconditional_i8_instr (noPrefixes I_br) - i_leave, I_unconditional_i32_instr (noPrefixes (fun x -> I_leave x)) - i_br, I_unconditional_i32_instr (noPrefixes I_br) - i_brtrue_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_brtrue, x))) - i_brfalse_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_brfalse, x))) - i_beq_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_beq, x))) - i_blt_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_blt, x))) - i_blt_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_blt_un, x))) - i_ble_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_ble, x))) - i_ble_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_ble_un, x))) - i_bgt_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bgt, x))) - i_bgt_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bgt_un, x))) - i_bge_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bge, x))) - i_bge_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bge_un, x))) - i_bne_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bne_un, x))) - i_brtrue, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_brtrue, x))) - i_brfalse, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_brfalse, x))) - i_beq, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_beq, x))) - i_blt, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_blt, x))) - i_blt_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_blt_un, x))) - i_ble, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_ble, x))) - i_ble_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_ble_un, x))) - i_bgt, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bgt, x))) - i_bgt_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bgt_un, x))) - i_bge, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bge, x))) - i_bge_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bge_un, x))) - i_bne_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bne_un, x))) - i_ldstr, I_string_instr (noPrefixes I_ldstr) - i_switch, I_switch_instr (noPrefixes I_switch) - i_ldtoken, I_tok_instr (noPrefixes I_ldtoken) - i_calli, I_sig_instr (tailPrefix (fun tl (x, y) -> I_calli (tl, x, y))) - i_mkrefany, I_type_instr (noPrefixes I_mkrefany) - i_refanyval, I_type_instr (noPrefixes I_refanyval) - i_ldelema, I_type_instr (readonlyPrefix (fun ro x -> I_ldelema (ro, false, ILArrayShape.SingleDimensional, x))) - i_ldelem_any, I_type_instr (noPrefixes (fun x -> I_ldelem_any (ILArrayShape.SingleDimensional, x))) - i_stelem_any, I_type_instr (noPrefixes (fun x -> I_stelem_any (ILArrayShape.SingleDimensional, x))) - i_newarr, I_type_instr (noPrefixes (fun x -> I_newarr (ILArrayShape.SingleDimensional, x))) - i_castclass, I_type_instr (noPrefixes I_castclass) - i_isinst, I_type_instr (noPrefixes I_isinst) - i_unbox_any, I_type_instr (noPrefixes I_unbox_any) - i_cpobj, I_type_instr (noPrefixes I_cpobj) - i_initobj, I_type_instr (noPrefixes I_initobj) - i_ldobj, I_type_instr (volatileOrUnalignedPrefix (fun (x, y) z -> I_ldobj (x, y, z))) - i_stobj, I_type_instr (volatileOrUnalignedPrefix (fun (x, y) z -> I_stobj (x, y, z))) - i_sizeof, I_type_instr (noPrefixes I_sizeof) - i_box, I_type_instr (noPrefixes I_box) - i_unbox, I_type_instr (noPrefixes I_unbox) ] + [ + i_ldarg_s, I_u16_u8_instr(noPrefixes mkLdarg) + i_starg_s, I_u16_u8_instr(noPrefixes I_starg) + i_ldarga_s, I_u16_u8_instr(noPrefixes I_ldarga) + i_stloc_s, I_u16_u8_instr(noPrefixes mkStloc) + i_ldloc_s, I_u16_u8_instr(noPrefixes mkLdloc) + i_ldloca_s, I_u16_u8_instr(noPrefixes I_ldloca) + i_ldarg, I_u16_u16_instr(noPrefixes mkLdarg) + i_starg, I_u16_u16_instr(noPrefixes I_starg) + i_ldarga, I_u16_u16_instr(noPrefixes I_ldarga) + i_stloc, I_u16_u16_instr(noPrefixes mkStloc) + i_ldloc, I_u16_u16_instr(noPrefixes mkLdloc) + i_ldloca, I_u16_u16_instr(noPrefixes I_ldloca) + i_stind_i, I_none_instr(mkStind DT_I) + i_stind_i1, I_none_instr(mkStind DT_I1) + i_stind_i2, I_none_instr(mkStind DT_I2) + i_stind_i4, I_none_instr(mkStind DT_I4) + i_stind_i8, I_none_instr(mkStind DT_I8) + i_stind_r4, I_none_instr(mkStind DT_R4) + i_stind_r8, I_none_instr(mkStind DT_R8) + i_stind_ref, I_none_instr(mkStind DT_REF) + i_ldind_i, I_none_instr(mkLdind DT_I) + i_ldind_i1, I_none_instr(mkLdind DT_I1) + i_ldind_i2, I_none_instr(mkLdind DT_I2) + i_ldind_i4, I_none_instr(mkLdind DT_I4) + i_ldind_i8, I_none_instr(mkLdind DT_I8) + i_ldind_u1, I_none_instr(mkLdind DT_U1) + i_ldind_u2, I_none_instr(mkLdind DT_U2) + i_ldind_u4, I_none_instr(mkLdind DT_U4) + i_ldind_r4, I_none_instr(mkLdind DT_R4) + i_ldind_r8, I_none_instr(mkLdind DT_R8) + i_ldind_ref, I_none_instr(mkLdind DT_REF) + i_cpblk, I_none_instr(volatileOrUnalignedPrefix I_cpblk) + i_initblk, I_none_instr(volatileOrUnalignedPrefix I_initblk) + i_ldc_i8, I_i64_instr(noPrefixes (fun x -> (AI_ldc(DT_I8, ILConst.I8 x)))) + i_ldc_i4, I_i32_i32_instr(noPrefixes mkLdcInt32) + i_ldc_i4_s, I_i32_i8_instr(noPrefixes mkLdcInt32) + i_ldc_r4, I_r4_instr(noPrefixes (fun x -> (AI_ldc(DT_R4, ILConst.R4 x)))) + i_ldc_r8, I_r8_instr(noPrefixes (fun x -> (AI_ldc(DT_R8, ILConst.R8 x)))) + i_ldfld, I_field_instr(volatileOrUnalignedPrefix (fun (x, y) fspec -> I_ldfld(x, y, fspec))) + i_stfld, I_field_instr(volatileOrUnalignedPrefix (fun (x, y) fspec -> I_stfld(x, y, fspec))) + i_ldsfld, I_field_instr(volatilePrefix (fun x fspec -> I_ldsfld(x, fspec))) + i_stsfld, I_field_instr(volatilePrefix (fun x fspec -> I_stsfld(x, fspec))) + i_ldflda, I_field_instr(noPrefixes I_ldflda) + i_ldsflda, I_field_instr(noPrefixes I_ldsflda) + i_call, I_method_instr(tailPrefix (fun tl (mspec, y) -> I_call(tl, mspec, y))) + i_ldftn, I_method_instr(noPrefixes (fun (mspec, _y) -> I_ldftn mspec)) + i_ldvirtftn, I_method_instr(noPrefixes (fun (mspec, _y) -> I_ldvirtftn mspec)) + i_newobj, I_method_instr(noPrefixes I_newobj) + i_callvirt, + I_method_instr( + constraintOrTailPrefix (fun (c, tl) (mspec, y) -> + match c with + | Some ty -> I_callconstraint(tl, ty, mspec, y) + | None -> I_callvirt(tl, mspec, y)) + ) + i_leave_s, I_unconditional_i8_instr(noPrefixes (fun x -> I_leave x)) + i_br_s, I_unconditional_i8_instr(noPrefixes I_br) + i_leave, I_unconditional_i32_instr(noPrefixes (fun x -> I_leave x)) + i_br, I_unconditional_i32_instr(noPrefixes I_br) + i_brtrue_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_brtrue, x))) + i_brfalse_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_brfalse, x))) + i_beq_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_beq, x))) + i_blt_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_blt, x))) + i_blt_un_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_blt_un, x))) + i_ble_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_ble, x))) + i_ble_un_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_ble_un, x))) + i_bgt_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_bgt, x))) + i_bgt_un_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_bgt_un, x))) + i_bge_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_bge, x))) + i_bge_un_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_bge_un, x))) + i_bne_un_s, I_conditional_i8_instr(noPrefixes (fun x -> I_brcmp(BI_bne_un, x))) + i_brtrue, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_brtrue, x))) + i_brfalse, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_brfalse, x))) + i_beq, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_beq, x))) + i_blt, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_blt, x))) + i_blt_un, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_blt_un, x))) + i_ble, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_ble, x))) + i_ble_un, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_ble_un, x))) + i_bgt, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_bgt, x))) + i_bgt_un, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_bgt_un, x))) + i_bge, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_bge, x))) + i_bge_un, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_bge_un, x))) + i_bne_un, I_conditional_i32_instr(noPrefixes (fun x -> I_brcmp(BI_bne_un, x))) + i_ldstr, I_string_instr(noPrefixes I_ldstr) + i_switch, I_switch_instr(noPrefixes I_switch) + i_ldtoken, I_tok_instr(noPrefixes I_ldtoken) + i_calli, I_sig_instr(tailPrefix (fun tl (x, y) -> I_calli(tl, x, y))) + i_mkrefany, I_type_instr(noPrefixes I_mkrefany) + i_refanyval, I_type_instr(noPrefixes I_refanyval) + i_ldelema, I_type_instr(readonlyPrefix (fun ro x -> I_ldelema(ro, false, ILArrayShape.SingleDimensional, x))) + i_ldelem_any, I_type_instr(noPrefixes (fun x -> I_ldelem_any(ILArrayShape.SingleDimensional, x))) + i_stelem_any, I_type_instr(noPrefixes (fun x -> I_stelem_any(ILArrayShape.SingleDimensional, x))) + i_newarr, I_type_instr(noPrefixes (fun x -> I_newarr(ILArrayShape.SingleDimensional, x))) + i_castclass, I_type_instr(noPrefixes I_castclass) + i_isinst, I_type_instr(noPrefixes I_isinst) + i_unbox_any, I_type_instr(noPrefixes I_unbox_any) + i_cpobj, I_type_instr(noPrefixes I_cpobj) + i_initobj, I_type_instr(noPrefixes I_initobj) + i_ldobj, I_type_instr(volatileOrUnalignedPrefix (fun (x, y) z -> I_ldobj(x, y, z))) + i_stobj, I_type_instr(volatileOrUnalignedPrefix (fun (x, y) z -> I_stobj(x, y, z))) + i_sizeof, I_type_instr(noPrefixes I_sizeof) + i_box, I_type_instr(noPrefixes I_box) + i_unbox, I_type_instr(noPrefixes I_unbox) + ] // The tables are delayed to avoid building them unnecessarily at startup // Many applications of AbsIL (e.g. a compiler) don't need to read instructions. let mutable oneByteInstrs = None let mutable twoByteInstrs = None + let fillInstrs () = let oneByteInstrTable = Array.create 256 I_invalid_instr let twoByteInstrTable = Array.create 256 I_invalid_instr + let addInstr (i, f) = if i > 0xff then assert (i >>>& 8 = 0xfe) let i = (i &&& 0xff) + match twoByteInstrTable[i] with | I_invalid_instr -> () - | _ -> dprintn ("warning: duplicate decode entries for "+string i) + | _ -> dprintn ("warning: duplicate decode entries for " + string i) + twoByteInstrTable[i] <- f else match oneByteInstrTable[i] with | I_invalid_instr -> () - | _ -> dprintn ("warning: duplicate decode entries for "+string i) + | _ -> dprintn ("warning: duplicate decode entries for " + string i) + oneByteInstrTable[i] <- f - for i in instrs() do + + for i in instrs () do addInstr i + for x, mk in noArgInstrs.Force() do - addInstr (x, I_none_instr (noPrefixes mk)) + addInstr (x, I_none_instr(noPrefixes mk)) + oneByteInstrs <- Some oneByteInstrTable twoByteInstrs <- Some twoByteInstrTable let rec getOneByteInstr i = match oneByteInstrs with - | None -> fillInstrs(); getOneByteInstr i + | None -> + fillInstrs () + getOneByteInstr i | Some t -> t[i] let rec getTwoByteInstr i = match twoByteInstrs with - | None -> fillInstrs(); getTwoByteInstr i + | None -> + fillInstrs () + getTwoByteInstr i | Some t -> t[i] //--------------------------------------------------------------------- @@ -615,8 +745,8 @@ let rec getTwoByteInstr i = type ImageChunk = { size: int32; addr: int32 } -let chunk sz next = ({addr=next; size=sz}, next + sz) -let nochunk next = ({addr= 0x0;size= 0x0; }, next) +let chunk sz next = ({ addr = next; size = sz }, next + sz) +let nochunk next = ({ addr = 0x0; size = 0x0 }, next) type RowElementKind = | UShort @@ -643,16 +773,37 @@ type RowElementKind = type RowKind = RowKind of RowElementKind list -let kindAssemblyRef = RowKind [ UShort; UShort; UShort; UShort; ULong; Blob; SString; SString; Blob; ] +let kindAssemblyRef = + RowKind [ UShort; UShort; UShort; UShort; ULong; Blob; SString; SString; Blob ] + let kindModuleRef = RowKind [ SString ] let kindFileRef = RowKind [ ULong; SString; Blob ] let kindTypeRef = RowKind [ ResolutionScope; SString; SString ] let kindTypeSpec = RowKind [ Blob ] -let kindTypeDef = RowKind [ ULong; SString; SString; TypeDefOrRefOrSpec; SimpleIndex TableNames.Field; SimpleIndex TableNames.Method ] -let kindPropertyMap = RowKind [ SimpleIndex TableNames.TypeDef; SimpleIndex TableNames.Property ] -let kindEventMap = RowKind [ SimpleIndex TableNames.TypeDef; SimpleIndex TableNames.Event ] -let kindInterfaceImpl = RowKind [ SimpleIndex TableNames.TypeDef; TypeDefOrRefOrSpec ] -let kindNested = RowKind [ SimpleIndex TableNames.TypeDef; SimpleIndex TableNames.TypeDef ] + +let kindTypeDef = + RowKind + [ + ULong + SString + SString + TypeDefOrRefOrSpec + SimpleIndex TableNames.Field + SimpleIndex TableNames.Method + ] + +let kindPropertyMap = + RowKind [ SimpleIndex TableNames.TypeDef; SimpleIndex TableNames.Property ] + +let kindEventMap = + RowKind [ SimpleIndex TableNames.TypeDef; SimpleIndex TableNames.Event ] + +let kindInterfaceImpl = + RowKind [ SimpleIndex TableNames.TypeDef; TypeDefOrRefOrSpec ] + +let kindNested = + RowKind [ SimpleIndex TableNames.TypeDef; SimpleIndex TableNames.TypeDef ] + let kindCustomAttribute = RowKind [ HasCustomAttribute; CustomAttributeType; Blob ] let kindDeclSecurity = RowKind [ UShort; HasDeclSecurity; Blob ] let kindMemberRef = RowKind [ MemberRefParent; SString; Blob ] @@ -660,25 +811,42 @@ let kindStandAloneSig = RowKind [ Blob ] let kindFieldDef = RowKind [ UShort; SString; Blob ] let kindFieldRVA = RowKind [ Data; SimpleIndex TableNames.Field ] let kindFieldMarshal = RowKind [ HasFieldMarshal; Blob ] -let kindConstant = RowKind [ UShort;HasConstant; Blob ] +let kindConstant = RowKind [ UShort; HasConstant; Blob ] let kindFieldLayout = RowKind [ ULong; SimpleIndex TableNames.Field ] let kindParam = RowKind [ UShort; UShort; SString ] -let kindMethodDef = RowKind [ ULong; UShort; UShort; SString; Blob; SimpleIndex TableNames.Param ] -let kindMethodImpl = RowKind [ SimpleIndex TableNames.TypeDef; MethodDefOrRef; MethodDefOrRef ] -let kindImplMap = RowKind [ UShort; MemberForwarded; SString; SimpleIndex TableNames.ModuleRef ] -let kindMethodSemantics = RowKind [ UShort; SimpleIndex TableNames.Method; HasSemantics ] + +let kindMethodDef = + RowKind [ ULong; UShort; UShort; SString; Blob; SimpleIndex TableNames.Param ] + +let kindMethodImpl = + RowKind [ SimpleIndex TableNames.TypeDef; MethodDefOrRef; MethodDefOrRef ] + +let kindImplMap = + RowKind [ UShort; MemberForwarded; SString; SimpleIndex TableNames.ModuleRef ] + +let kindMethodSemantics = + RowKind [ UShort; SimpleIndex TableNames.Method; HasSemantics ] + let kindProperty = RowKind [ UShort; SString; Blob ] let kindEvent = RowKind [ UShort; SString; TypeDefOrRefOrSpec ] let kindManifestResource = RowKind [ ULong; ULong; SString; Implementation ] let kindClassLayout = RowKind [ UShort; ULong; SimpleIndex TableNames.TypeDef ] let kindExportedType = RowKind [ ULong; ULong; SString; SString; Implementation ] -let kindAssembly = RowKind [ ULong; UShort; UShort; UShort; UShort; ULong; Blob; SString; SString ] -let kindGenericParam_v1_1 = RowKind [ UShort; UShort; TypeOrMethodDef; SString; TypeDefOrRefOrSpec ] + +let kindAssembly = + RowKind [ ULong; UShort; UShort; UShort; UShort; ULong; Blob; SString; SString ] + +let kindGenericParam_v1_1 = + RowKind [ UShort; UShort; TypeOrMethodDef; SString; TypeDefOrRefOrSpec ] + let kindGenericParam_v2_0 = RowKind [ UShort; UShort; TypeOrMethodDef; SString ] let kindMethodSpec = RowKind [ MethodDefOrRef; Blob ] -let kindGenericParamConstraint = RowKind [ SimpleIndex TableNames.GenericParam; TypeDefOrRefOrSpec ] + +let kindGenericParamConstraint = + RowKind [ SimpleIndex TableNames.GenericParam; TypeDefOrRefOrSpec ] + let kindModule = RowKind [ UShort; SString; GGuid; GGuid; GGuid ] -let kindIllegal = RowKind [ ] +let kindIllegal = RowKind [] //--------------------------------------------------------------------- // Used for binary searches of sorted tables. Each function that reads @@ -688,35 +856,47 @@ let kindIllegal = RowKind [ ] // kind of element in that column. //--------------------------------------------------------------------- -let hcCompare (TaggedIndex(t1: HasConstantTag, idx1: int)) (TaggedIndex(t2: HasConstantTag, idx2)) = - if idx1 < idx2 then -1 elif idx1 > idx2 then 1 else compare t1.Tag t2.Tag +let hcCompare (TaggedIndex (t1: HasConstantTag, idx1: int)) (TaggedIndex (t2: HasConstantTag, idx2)) = + if idx1 < idx2 then -1 + elif idx1 > idx2 then 1 + else compare t1.Tag t2.Tag -let hsCompare (TaggedIndex(t1: HasSemanticsTag, idx1: int)) (TaggedIndex(t2: HasSemanticsTag, idx2)) = - if idx1 < idx2 then -1 elif idx1 > idx2 then 1 else compare t1.Tag t2.Tag +let hsCompare (TaggedIndex (t1: HasSemanticsTag, idx1: int)) (TaggedIndex (t2: HasSemanticsTag, idx2)) = + if idx1 < idx2 then -1 + elif idx1 > idx2 then 1 + else compare t1.Tag t2.Tag -let hcaCompare (TaggedIndex(t1: HasCustomAttributeTag, idx1: int)) (TaggedIndex(t2: HasCustomAttributeTag, idx2)) = - if idx1 < idx2 then -1 elif idx1 > idx2 then 1 else compare t1.Tag t2.Tag +let hcaCompare (TaggedIndex (t1: HasCustomAttributeTag, idx1: int)) (TaggedIndex (t2: HasCustomAttributeTag, idx2)) = + if idx1 < idx2 then -1 + elif idx1 > idx2 then 1 + else compare t1.Tag t2.Tag -let mfCompare (TaggedIndex(t1: MemberForwardedTag, idx1: int)) (TaggedIndex(t2: MemberForwardedTag, idx2)) = - if idx1 < idx2 then -1 elif idx1 > idx2 then 1 else compare t1.Tag t2.Tag +let mfCompare (TaggedIndex (t1: MemberForwardedTag, idx1: int)) (TaggedIndex (t2: MemberForwardedTag, idx2)) = + if idx1 < idx2 then -1 + elif idx1 > idx2 then 1 + else compare t1.Tag t2.Tag -let hdsCompare (TaggedIndex(t1: HasDeclSecurityTag, idx1: int)) (TaggedIndex(t2: HasDeclSecurityTag, idx2)) = - if idx1 < idx2 then -1 elif idx1 > idx2 then 1 else compare t1.Tag t2.Tag +let hdsCompare (TaggedIndex (t1: HasDeclSecurityTag, idx1: int)) (TaggedIndex (t2: HasDeclSecurityTag, idx2)) = + if idx1 < idx2 then -1 + elif idx1 > idx2 then 1 + else compare t1.Tag t2.Tag -let hfmCompare (TaggedIndex(t1: HasFieldMarshalTag, idx1)) (TaggedIndex(t2: HasFieldMarshalTag, idx2)) = - if idx1 < idx2 then -1 elif idx1 > idx2 then 1 else compare t1.Tag t2.Tag +let hfmCompare (TaggedIndex (t1: HasFieldMarshalTag, idx1)) (TaggedIndex (t2: HasFieldMarshalTag, idx2)) = + if idx1 < idx2 then -1 + elif idx1 > idx2 then 1 + else compare t1.Tag t2.Tag -let tomdCompare (TaggedIndex(t1: TypeOrMethodDefTag, idx1)) (TaggedIndex(t2: TypeOrMethodDefTag, idx2)) = - if idx1 < idx2 then -1 elif idx1 > idx2 then 1 else compare t1.Tag t2.Tag +let tomdCompare (TaggedIndex (t1: TypeOrMethodDefTag, idx1)) (TaggedIndex (t2: TypeOrMethodDefTag, idx2)) = + if idx1 < idx2 then -1 + elif idx1 > idx2 then 1 + else compare t1.Tag t2.Tag -let simpleIndexCompare (idx1: int) (idx2: int) = - compare idx1 idx2 +let simpleIndexCompare (idx1: int) (idx2: int) = compare idx1 idx2 //--------------------------------------------------------------------- // The various keys for the various caches. //--------------------------------------------------------------------- - [] type TypeDefAsTypIdx = TypeDefAsTypIdx of ILBoxity * ILGenericArgs * int @@ -755,50 +935,60 @@ type GenericParamsIdx = GenericParamsIdx of numTypars: int * TypeOrMethodDefTag //--------------------------------------------------------------------- let mkCacheInt32 lowMem _inbase _nm _sz = - if lowMem then (fun f x -> f x) else - let mutable cache = null - let mutable count = 0 + if lowMem then + (fun f x -> f x) + else + let mutable cache = null + let mutable count = 0 #if STATISTICS - addReport (fun oc -> if count <> 0 then oc.WriteLine ((_inbase + string count + " "+ _nm + " cache hits"): string)) + addReport (fun oc -> + if count <> 0 then + oc.WriteLine((_inbase + string count + " " + _nm + " cache hits"): string)) #endif - fun f (idx: int32) -> - let cache = - match cache with - | null -> cache <- ConcurrentDictionary(Environment.ProcessorCount, 11) - | _ -> () - cache - match cache.TryGetValue idx with - | true, res -> - count <- count + 1 - res - | _ -> - let res = f idx - cache[idx] <- res - res + fun f (idx: int32) -> + let cache = + match cache with + | null -> cache <- ConcurrentDictionary(Environment.ProcessorCount, 11) + | _ -> () + + cache + + match cache.TryGetValue idx with + | true, res -> + count <- count + 1 + res + | _ -> + let res = f idx + cache[idx] <- res + res let mkCacheGeneric lowMem _inbase _nm _sz = - if lowMem then (fun f x -> f x) else - let mutable cache = null - let mutable count = 0 + if lowMem then + (fun f x -> f x) + else + let mutable cache = null + let mutable count = 0 #if STATISTICS - addReport (fun oc -> if !count <> 0 then oc.WriteLine ((_inbase + string !count + " " + _nm + " cache hits"): string)) + addReport (fun oc -> + if !count <> 0 then + oc.WriteLine((_inbase + string !count + " " + _nm + " cache hits"): string)) #endif - fun f (idx :'T) -> - let cache = - match cache with - | null -> - cache <- ConcurrentDictionary<_, _>(Environment.ProcessorCount, 11 (* sz: int *) ) - | _ -> () - cache - - match cache.TryGetValue idx with - | true, v -> - count <- count + 1 - v - | _ -> - let res = f idx - cache[idx] <- res - res + fun f (idx: 'T) -> + let cache = + match cache with + | null -> cache <- ConcurrentDictionary<_, _>(Environment.ProcessorCount, 11 (* sz: int *) ) + | _ -> () + + cache + + match cache.TryGetValue idx with + | true, v -> + count <- count + 1 + v + | _ -> + let res = f idx + cache[idx] <- res + res //----------------------------------------------------------------------- // Polymorphic general helpers for searching for particular rows. @@ -806,9 +996,13 @@ let mkCacheGeneric lowMem _inbase _nm _sz = let seekFindRow numRows rowChooser = let mutable i = 1 + while (i <= numRows && not (rowChooser i)) do i <- i + 1 - if i > numRows then dprintn "warning: seekFindRow: row not found" + + if i > numRows then + dprintn "warning: seekFindRow: row not found" + i // search for rows satisfying predicate @@ -816,77 +1010,94 @@ let seekReadIndexedRows (numRows, rowReader, keyFunc, keyComparer, binaryChop, r if binaryChop then let mutable low = 0 let mutable high = numRows + 1 - begin - let mutable fin = false - while not fin do - if high - low <= 1 then - fin <- true - else - let mid = (low + high) / 2 - let midrow = rowReader mid - let c = keyComparer (keyFunc midrow) - if c > 0 then - low <- mid - elif c < 0 then - high <- mid - else - fin <- true - end + + (let mutable fin = false + + while not fin do + if high - low <= 1 then + fin <- true + else + let mid = (low + high) / 2 + let midrow = rowReader mid + let c = keyComparer (keyFunc midrow) + + if c > 0 then low <- mid + elif c < 0 then high <- mid + else fin <- true) + let mutable res = [] + if high - low > 1 then // now read off rows, forward and backwards let mid = (low + high) / 2 // read forward let mutable fin = false let mutable curr = mid + while not fin do if curr > numRows then fin <- true else let currrow = rowReader curr + if keyComparer (keyFunc currrow) = 0 then res <- rowConverter currrow :: res else fin <- true + curr <- curr + 1 res <- List.rev res // read backwards let mutable fin = false let mutable curr = mid - 1 + while not fin do if curr = 0 then fin <- true else let currrow = rowReader curr + if keyComparer (keyFunc currrow) = 0 then res <- rowConverter currrow :: res else fin <- true + curr <- curr - 1 // sanity check #if CHECKING if checking then let res2 = - [ for i = 1 to numRows do - let rowinfo = rowReader i - if keyComparer (keyFunc rowinfo) = 0 then - yield rowConverter rowinfo ] + [ + for i = 1 to numRows do + let rowinfo = rowReader i + + if keyComparer (keyFunc rowinfo) = 0 then + yield rowConverter rowinfo + ] + if (res2 <> res) then - failwith ("results of binary search did not match results of linear search: linear search produced "+string res2.Length+", binary search produced "+string res.Length) + failwith ( + "results of binary search did not match results of linear search: linear search produced " + + string res2.Length + + ", binary search produced " + + string res.Length + ) #endif res else - [ for i = 1 to numRows do - let rowinfo = rowReader i - if keyComparer (keyFunc rowinfo) = 0 then - yield rowConverter rowinfo ] + [ + for i = 1 to numRows do + let rowinfo = rowReader i + if keyComparer (keyFunc rowinfo) = 0 then + yield rowConverter rowinfo + ] let seekReadOptionalIndexedRow info = match seekReadIndexedRows info with - | [k] -> Some k + | [ k ] -> Some k | [] -> None | h :: _ -> dprintn "multiple rows found when indexing table" @@ -903,105 +1114,109 @@ let seekReadIndexedRow info = type MethodData = MethodData of enclTy: ILType * ILCallingConv * name: string * argTys: ILTypes * retTy: ILType * methInst: ILTypes -type VarArgMethodData = VarArgMethodData of enclTy: ILType * ILCallingConv * name: string * argTys: ILTypes * ILVarArgs * retTy: ILType * methInst: ILTypes +type VarArgMethodData = + | VarArgMethodData of enclTy: ILType * ILCallingConv * name: string * argTys: ILTypes * ILVarArgs * retTy: ILType * methInst: ILTypes [] type PEReader = - { fileName: string + { + fileName: string #if FX_NO_PDB_READER - pdb: obj option + pdb: obj option #else - pdb: (PdbReader * (string -> ILSourceDocument)) option + pdb: (PdbReader * (string -> ILSourceDocument)) option #endif - entryPointToken: TableName * int - pefile: BinaryFile - textSegmentPhysicalLoc: int32 - textSegmentPhysicalSize: int32 - dataSegmentPhysicalLoc: int32 - dataSegmentPhysicalSize: int32 - anyV2P: string * int32 -> int32 - metadataAddr: int32 - sectionHeaders: (int32 * int32 * int32) list - nativeResourcesAddr: int32 - nativeResourcesSize: int32 - resourcesAddr: int32 - strongnameAddr: int32 - vtableFixupsAddr: int32 - noFileOnDisk: bool -} + entryPointToken: TableName * int + pefile: BinaryFile + textSegmentPhysicalLoc: int32 + textSegmentPhysicalSize: int32 + dataSegmentPhysicalLoc: int32 + dataSegmentPhysicalSize: int32 + anyV2P: string * int32 -> int32 + metadataAddr: int32 + sectionHeaders: (int32 * int32 * int32) list + nativeResourcesAddr: int32 + nativeResourcesSize: int32 + resourcesAddr: int32 + strongnameAddr: int32 + vtableFixupsAddr: int32 + noFileOnDisk: bool + } [] type ILMetadataReader = - { 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 - blobsStreamSize: int32 - readUserStringHeap: int32 -> string - memoizeString: string -> string - readStringHeap: int32 -> string - readBlobHeap: int32 -> byte[] - guidsStreamPhysicalLoc: int32 - rowAddr: TableName -> int -> int32 - tableBigness: bool [] - rsBigness: bool - tdorBigness: bool - tomdBigness: bool - hcBigness: bool - hcaBigness: bool - hfmBigness: bool - hdsBigness: bool - mrpBigness: bool - hsBigness: bool - mdorBigness: bool - mfBigness: bool - iBigness: bool - catBigness: bool - stringsBigness: bool - guidsBigness: bool - blobsBigness: bool - seekReadNestedRow: int -> int * int - seekReadConstantRow: int -> uint16 * TaggedIndex * int32 - seekReadMethodSemanticsRow: int -> int32 * int * TaggedIndex - seekReadTypeDefRow: int -> int32 * int32 * int32 * TaggedIndex * int * int - seekReadAssemblyRef: int -> ILAssemblyRef - seekReadMethodSpecAsMethodData: MethodSpecAsMspecIdx -> VarArgMethodData - seekReadMemberRefAsMethodData: MemberRefAsMspecIdx -> VarArgMethodData - seekReadMemberRefAsFieldSpec: MemberRefAsFspecIdx -> ILFieldSpec - seekReadCustomAttr: CustomAttrIdx -> ILAttribute - seekReadTypeRef: int ->ILTypeRef - seekReadTypeRefAsType: TypeRefAsTypIdx -> ILType - readBlobHeapAsPropertySig: BlobAsPropSigIdx -> ILThisConvention * ILType * ILTypes - readBlobHeapAsFieldSig: BlobAsFieldSigIdx -> ILType - readBlobHeapAsMethodSig: BlobAsMethodSigIdx -> bool * int32 * ILCallingConv * ILType * ILTypes * ILVarArgs - readBlobHeapAsLocalsSig: BlobAsLocalSigIdx -> ILLocal list - seekReadTypeDefAsType: TypeDefAsTypIdx -> ILType - seekReadMethodDefAsMethodData: int -> MethodData - seekReadGenericParams: GenericParamsIdx -> ILGenericParameterDef list - 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 } - -type ISeekReadIndexedRowReader<'RowT, 'KeyT, 'T when 'RowT : struct> = + { + 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 + blobsStreamSize: int32 + readUserStringHeap: int32 -> string + memoizeString: string -> string + readStringHeap: int32 -> string + readBlobHeap: int32 -> byte[] + guidsStreamPhysicalLoc: int32 + rowAddr: TableName -> int -> int32 + tableBigness: bool[] + rsBigness: bool + tdorBigness: bool + tomdBigness: bool + hcBigness: bool + hcaBigness: bool + hfmBigness: bool + hdsBigness: bool + mrpBigness: bool + hsBigness: bool + mdorBigness: bool + mfBigness: bool + iBigness: bool + catBigness: bool + stringsBigness: bool + guidsBigness: bool + blobsBigness: bool + seekReadNestedRow: int -> int * int + seekReadConstantRow: int -> uint16 * TaggedIndex * int32 + seekReadMethodSemanticsRow: int -> int32 * int * TaggedIndex + seekReadTypeDefRow: int -> int32 * int32 * int32 * TaggedIndex * int * int + seekReadAssemblyRef: int -> ILAssemblyRef + seekReadMethodSpecAsMethodData: MethodSpecAsMspecIdx -> VarArgMethodData + seekReadMemberRefAsMethodData: MemberRefAsMspecIdx -> VarArgMethodData + seekReadMemberRefAsFieldSpec: MemberRefAsFspecIdx -> ILFieldSpec + seekReadCustomAttr: CustomAttrIdx -> ILAttribute + seekReadTypeRef: int -> ILTypeRef + seekReadTypeRefAsType: TypeRefAsTypIdx -> ILType + readBlobHeapAsPropertySig: BlobAsPropSigIdx -> ILThisConvention * ILType * ILTypes + readBlobHeapAsFieldSig: BlobAsFieldSigIdx -> ILType + readBlobHeapAsMethodSig: BlobAsMethodSigIdx -> bool * int32 * ILCallingConv * ILType * ILTypes * ILVarArgs + readBlobHeapAsLocalsSig: BlobAsLocalSigIdx -> ILLocal list + seekReadTypeDefAsType: TypeDefAsTypIdx -> ILType + seekReadMethodDefAsMethodData: int -> MethodData + seekReadGenericParams: GenericParamsIdx -> ILGenericParameterDef list + 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 + } + +type ISeekReadIndexedRowReader<'RowT, 'KeyT, 'T when 'RowT: struct> = abstract GetRow: int * byref<'RowT> -> unit abstract GetKey: byref<'RowT> -> 'KeyT abstract CompareKey: 'KeyT -> int @@ -1009,26 +1224,27 @@ type ISeekReadIndexedRowReader<'RowT, 'KeyT, 'T when 'RowT : struct> = let seekReadIndexedRowsByInterface numRows binaryChop (reader: ISeekReadIndexedRowReader<'RowT, _, _>) = let mutable row = Unchecked.defaultof<'RowT> + if binaryChop then let mutable low = 0 let mutable high = numRows + 1 let mutable fin = false + while not fin do - if high - low <= 1 then + if high - low <= 1 then fin <- true else let mid = (low + high) / 2 reader.GetRow(mid, &row) let c = reader.CompareKey(reader.GetKey(&row)) - if c > 0 then - low <- mid - elif c < 0 then - high <- mid - else - fin <- true + + if c > 0 then low <- mid + elif c < 0 then high <- mid + else fin <- true let res = ImmutableArray.CreateBuilder() + if high - low > 1 then // now read off rows, forward and backwards let mid = (low + high) / 2 @@ -1036,15 +1252,18 @@ let seekReadIndexedRowsByInterface numRows binaryChop (reader: ISeekReadIndexedR // read backwards let mutable fin = false let mutable curr = mid - 1 + while not fin do if curr = 0 then fin <- true else reader.GetRow(curr, &row) + if reader.CompareKey(reader.GetKey(&row)) = 0 then res.Add(reader.ConvertRow(&row)) else fin <- true + curr <- curr - 1 res.Reverse() @@ -1052,24 +1271,30 @@ let seekReadIndexedRowsByInterface numRows binaryChop (reader: ISeekReadIndexedR // read forward let mutable fin = false let mutable curr = mid + while not fin do if curr > numRows then fin <- true else reader.GetRow(curr, &row) + if reader.CompareKey(reader.GetKey(&row)) = 0 then res.Add(reader.ConvertRow(&row)) else fin <- true + curr <- curr + 1 res.ToArray() else let res = ImmutableArray.CreateBuilder() + for i = 1 to numRows do reader.GetRow(i, &row) + if reader.CompareKey(reader.GetKey(&row)) = 0 then - res.Add(reader.ConvertRow(&row)) + res.Add(reader.ConvertRow(&row)) + res.ToArray() [] @@ -1085,43 +1310,81 @@ let seekReadUInt16Adv mdv (addr: byref) = let seekReadInt32Adv mdv (addr: byref) = let res = seekReadInt32 mdv addr - addr <- addr+4 + addr <- addr + 4 res let seekReadUInt16AsInt32Adv mdv (addr: byref) = let res = seekReadUInt16AsInt32 mdv addr - addr <- addr+2 + addr <- addr + 2 res let inline seekReadTaggedIdx f nbits big mdv (addr: byref) = - let tok = if big then seekReadInt32Adv mdv &addr else seekReadUInt16AsInt32Adv mdv &addr + let tok = + if big then + seekReadInt32Adv mdv &addr + else + seekReadUInt16AsInt32Adv mdv &addr + tokToTaggedIdx f nbits tok let seekReadIdx big mdv (addr: byref) = - if big then seekReadInt32Adv mdv &addr else seekReadUInt16AsInt32Adv mdv &addr + if big then + seekReadInt32Adv mdv &addr + else + seekReadUInt16AsInt32Adv mdv &addr let seekReadUntaggedIdx (tab: TableName) (ctxt: ILMetadataReader) mdv (addr: byref) = seekReadIdx ctxt.tableBigness[tab.Index] mdv &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 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: ILMetadataReader) mdv idx = - if idx = 0 then failwith "cannot read Module table row 0" + if idx = 0 then + failwith "cannot read Module table row 0" + let mutable addr = ctxt.rowAddr TableNames.Module idx let generation = seekReadUInt16Adv mdv &addr let nameIdx = seekReadStringIdx ctxt mdv &addr @@ -1140,6 +1403,7 @@ let seekReadTypeRefRow (ctxt: ILMetadataReader) mdv idx = /// Read Table ILTypeDef. let seekReadTypeDefRow (ctxt: ILMetadataReader) idx = ctxt.seekReadTypeDefRow idx + let seekReadTypeDefRowUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() @@ -1196,6 +1460,7 @@ let seekReadMemberRefRow (ctxt: ILMetadataReader) mdv idx = /// Read Table Constant. let seekReadConstantRow (ctxt: ILMetadataReader) idx = ctxt.seekReadConstantRow idx + let seekReadConstantRowUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() @@ -1280,6 +1545,7 @@ let seekReadPropertyRow (ctxt: ILMetadataReader) mdv idx = /// Read Table MethodSemantics. let seekReadMethodSemanticsRow (ctxt: ILMetadataReader) idx = ctxt.seekReadMethodSemanticsRow idx + let seekReadMethodSemanticsRowUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() @@ -1382,6 +1648,7 @@ let seekReadManifestResourceRow (ctxt: ILMetadataReader) mdv idx = /// Read Table Nested. let seekReadNestedRow (ctxt: ILMetadataReader) idx = ctxt.seekReadNestedRow idx + let seekReadNestedRowUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() @@ -1413,7 +1680,6 @@ let seekReadMethodSpecRow (ctxt: ILMetadataReader) mdv idx = let instIdx = seekReadBlobIdx ctxt mdv &addr (mdorIdx, instIdx) - let readUserStringHeapUncached ctxtH idx = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() @@ -1428,34 +1694,65 @@ let readStringHeapUncached ctxtH 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 readStringHeapOption (ctxt: ILMetadataReader) idx = + if idx = 0 then + None + else + Some(readStringHeap ctxt idx) let readBlobHeapUncached ctxtH idx = 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 mdv one byte 0 - if idx <= 0 || idx >= ctxt.blobsStreamSize then [| |] - else seekReadBlob mdv (ctxt.blobsStreamPhysicalLoc + idx) + if idx <= 0 || idx >= ctxt.blobsStreamSize then + [||] + 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 readBlobHeapOption ctxt idx = + if idx = 0 then + None + else + Some(readBlobHeap ctxt 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) -let readBlobHeapAsSByte ctxt vidx = fst (sigptrGetSByte (readBlobHeap ctxt vidx) 0) -let readBlobHeapAsInt16 ctxt vidx = fst (sigptrGetInt16 (readBlobHeap ctxt vidx) 0) -let readBlobHeapAsInt32 ctxt vidx = fst (sigptrGetInt32 (readBlobHeap ctxt vidx) 0) -let readBlobHeapAsInt64 ctxt vidx = fst (sigptrGetInt64 (readBlobHeap ctxt vidx) 0) -let readBlobHeapAsByte ctxt vidx = fst (sigptrGetByte (readBlobHeap ctxt vidx) 0) -let readBlobHeapAsUInt16 ctxt vidx = fst (sigptrGetUInt16 (readBlobHeap ctxt vidx) 0) -let readBlobHeapAsUInt32 ctxt vidx = fst (sigptrGetUInt32 (readBlobHeap ctxt vidx) 0) -let readBlobHeapAsUInt64 ctxt vidx = fst (sigptrGetUInt64 (readBlobHeap ctxt vidx) 0) -let readBlobHeapAsSingle ctxt vidx = fst (sigptrGetSingle (readBlobHeap ctxt vidx) 0) -let readBlobHeapAsDouble ctxt vidx = fst (sigptrGetDouble (readBlobHeap ctxt vidx) 0) +let readBlobHeapAsBool ctxt vidx = + fst (sigptrGetBool (readBlobHeap ctxt vidx) 0) + +let readBlobHeapAsSByte ctxt vidx = + fst (sigptrGetSByte (readBlobHeap ctxt vidx) 0) + +let readBlobHeapAsInt16 ctxt vidx = + fst (sigptrGetInt16 (readBlobHeap ctxt vidx) 0) + +let readBlobHeapAsInt32 ctxt vidx = + fst (sigptrGetInt32 (readBlobHeap ctxt vidx) 0) + +let readBlobHeapAsInt64 ctxt vidx = + fst (sigptrGetInt64 (readBlobHeap ctxt vidx) 0) + +let readBlobHeapAsByte ctxt vidx = + fst (sigptrGetByte (readBlobHeap ctxt vidx) 0) + +let readBlobHeapAsUInt16 ctxt vidx = + fst (sigptrGetUInt16 (readBlobHeap ctxt vidx) 0) + +let readBlobHeapAsUInt32 ctxt vidx = + fst (sigptrGetUInt32 (readBlobHeap ctxt vidx) 0) + +let readBlobHeapAsUInt64 ctxt vidx = + fst (sigptrGetUInt64 (readBlobHeap ctxt vidx) 0) + +let readBlobHeapAsSingle ctxt vidx = + fst (sigptrGetSingle (readBlobHeap ctxt vidx) 0) + +let readBlobHeapAsDouble ctxt vidx = + fst (sigptrGetDouble (readBlobHeap ctxt vidx) 0) //----------------------------------------------------------------------- // Some binaries have raw data embedded their text sections, e.g. mscorlib, for @@ -1478,198 +1775,301 @@ let readBlobHeapAsDouble ctxt vidx = fst (sigptrGetDouble (readBlobHeap ctxt vid // For example the assembly came from a type provider // In this case we eagerly read the native resources into memory let readNativeResources (pectxt: PEReader) = - [ if pectxt.nativeResourcesSize <> 0x0 && pectxt.nativeResourcesAddr <> 0x0 then - let start = pectxt.anyV2P (pectxt.fileName + ": native resources", pectxt.nativeResourcesAddr) - if pectxt.noFileOnDisk then - let unlinkedResource = - let linkedResource = seekReadBytes (pectxt.pefile.GetView()) start pectxt.nativeResourcesSize - unlinkResource pectxt.nativeResourcesAddr linkedResource - yield ILNativeResource.Out unlinkedResource - else - yield ILNativeResource.In (pectxt.fileName, pectxt.nativeResourcesAddr, start, pectxt.nativeResourcesSize ) ] + [ + if pectxt.nativeResourcesSize <> 0x0 && pectxt.nativeResourcesAddr <> 0x0 then + let start = + pectxt.anyV2P (pectxt.fileName + ": native resources", pectxt.nativeResourcesAddr) + + if pectxt.noFileOnDisk then + let unlinkedResource = + let linkedResource = + seekReadBytes (pectxt.pefile.GetView()) start pectxt.nativeResourcesSize + unlinkResource pectxt.nativeResourcesAddr linkedResource + + yield ILNativeResource.Out unlinkedResource + else + yield ILNativeResource.In(pectxt.fileName, pectxt.nativeResourcesAddr, start, pectxt.nativeResourcesSize) + ] let getDataEndPointsDelayed (pectxt: PEReader) ctxtH = lazy let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() + let dataStartPoints = - [ for i = 1 to ctxt.getNumRows TableNames.FieldRVA do - let rva, _fidx = seekReadFieldRVARow ctxt mdv i - ("field", rva) - for i = 1 to ctxt.getNumRows TableNames.ManifestResource do - let offset, _, _, TaggedIndex(_tag, idx) = seekReadManifestResourceRow ctxt mdv i - if idx = 0 then - let rva = pectxt.resourcesAddr + offset - ("manifest resource", rva) ] - - if isNil dataStartPoints then [] + [ + for i = 1 to ctxt.getNumRows TableNames.FieldRVA do + let rva, _fidx = seekReadFieldRVARow ctxt mdv i + ("field", rva) + for i = 1 to ctxt.getNumRows TableNames.ManifestResource do + let offset, _, _, TaggedIndex (_tag, idx) = seekReadManifestResourceRow ctxt mdv i + + if idx = 0 then + let rva = pectxt.resourcesAddr + offset + ("manifest resource", rva) + ] + + if isNil dataStartPoints then + [] else - let methodRVAs = - [ for i = 1 to ctxt.getNumRows TableNames.Method do - let rva, _, _, nameIdx, _, _ = seekReadMethodRow ctxt mdv i - if rva <> 0 then - let nm = readStringHeap ctxt nameIdx - (nm, rva) ] - ([ pectxt.textSegmentPhysicalLoc + pectxt.textSegmentPhysicalSize - pectxt.dataSegmentPhysicalLoc + pectxt.dataSegmentPhysicalSize ] - @ - (List.map pectxt.anyV2P - (dataStartPoints - @ [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 methodRVAs = + [ + for i = 1 to ctxt.getNumRows TableNames.Method do + let rva, _, _, nameIdx, _, _ = seekReadMethodRow ctxt mdv i + + if rva <> 0 then + let nm = readStringHeap ctxt nameIdx + (nm, rva) + ] + + ([ + pectxt.textSegmentPhysicalLoc + pectxt.textSegmentPhysicalSize + pectxt.dataSegmentPhysicalLoc + pectxt.dataSegmentPhysicalSize + ] + @ (List.map + pectxt.anyV2P + (dataStartPoints + @ [ + for virtAddr, _virtSize, _physLoc in pectxt.sectionHeaders do + yield ("section start", virtAddr) + ] + @ [ ("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 rvaToData (ctxt: ILMetadataReader) (pectxt: PEReader) nm rva = if rva = 0x0 then failwith "rva is zero" 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 fileName=%s, name=%s, rva=0x%08x, start=0x%08x" ctxt.fileName 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 - let pev = pectxt.pefile.GetView() - seekReadBytes pev start (e - start) - else look t - look endPoints + if start < e then + 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: ILMetadataReader) (tab: TableName) = ((ctxt.sorted &&& (int64 1 <<< tab.Index)) <> int64 0x0) +let isSorted (ctxt: ILMetadataReader) (tab: TableName) = + ((ctxt.sorted &&& (int64 1 <<< tab.Index)) <> int64 0x0) // Note, pectxtEager and pevEager must not be captured by the results of this function let rec seekReadModule (ctxt: ILMetadataReader) canReduceMemory (pectxtEager: PEReader) pevEager peinfo ilMetadataVersion idx = - let subsys, subsysversion, useHighEntropyVA, ilOnly, only32, is32bitpreferred, only64, platform, isDll, alignVirt, alignPhys, imageBaseReal = peinfo + 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 _generation, nameIdx, _mvidIdx, _encidIdx, _encbaseidIdx = + seekReadModuleRow ctxt mdv idx + let ilModuleName = readStringHeap ctxt nameIdx let nativeResources = readNativeResources pectxtEager - { Manifest = - if ctxt.getNumRows TableNames.Assembly > 0 then Some (seekReadAssemblyManifest ctxt pectxtEager 1) - else None - CustomAttrsStored = ctxt.customAttrsReader_Module - MetadataIndex = idx - Name = ilModuleName - NativeResources=nativeResources - TypeDefs = mkILTypeDefsComputed (fun () -> seekReadTopTypeDefs ctxt) - SubSystemFlags = int32 subsys - IsILOnly = ilOnly - SubsystemVersion = subsysversion - UseHighEntropyVA = useHighEntropyVA - Platform = platform - StackReserveSize = None // TODO - Is32Bit = only32 - Is32BitPreferred = is32bitpreferred - Is64Bit = only64 - IsDLL=isDll - VirtualAlignment = alignVirt - PhysicalAlignment = alignPhys - ImageBase = imageBaseReal - MetadataVersion = ilMetadataVersion - Resources = seekReadManifestResources ctxt canReduceMemory mdv pectxtEager pevEager } + { + Manifest = + if ctxt.getNumRows TableNames.Assembly > 0 then + Some(seekReadAssemblyManifest ctxt pectxtEager 1) + else + None + CustomAttrsStored = ctxt.customAttrsReader_Module + MetadataIndex = idx + Name = ilModuleName + NativeResources = nativeResources + TypeDefs = mkILTypeDefsComputed (fun () -> seekReadTopTypeDefs ctxt) + SubSystemFlags = int32 subsys + IsILOnly = ilOnly + SubsystemVersion = subsysversion + UseHighEntropyVA = useHighEntropyVA + Platform = platform + StackReserveSize = None // TODO + Is32Bit = only32 + Is32BitPreferred = is32bitpreferred + Is64Bit = only64 + IsDLL = isDll + VirtualAlignment = alignVirt + PhysicalAlignment = alignPhys + ImageBase = imageBaseReal + MetadataVersion = ilMetadataVersion + Resources = seekReadManifestResources ctxt canReduceMemory mdv pectxtEager pevEager + } 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 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 - SecurityDeclsStored= ctxt.securityDeclsReader_Assembly - PublicKey= pubkey - Version= Some (ILVersionInfo (v1, v2, v3, v4)) - Locale= readStringHeapOption ctxt localeIdx - CustomAttrsStored = ctxt.customAttrsReader_Assembly - MetadataIndex = idx - AssemblyLongevity = - 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= + + { + Name = name + AuxModuleHashAlgorithm = hash + SecurityDeclsStored = ctxt.securityDeclsReader_Assembly + PublicKey = pubkey + Version = Some(ILVersionInfo(v1, v2, v3, v4)) + Locale = readStringHeapOption ctxt localeIdx + CustomAttrsStored = ctxt.customAttrsReader_Assembly + MetadataIndex = idx + AssemblyLongevity = + 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) } + + 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: ILMetadataReader) idx = ctxt.seekReadAssemblyRef idx + and seekReadAssemblyRefUncached ctxtH 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 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 - | None -> None - | Some blob -> Some (if (flags &&& 0x0001) <> 0x0 then PublicKey blob else PublicKeyToken blob) - - ILAssemblyRef.Create - (name = nm, - hash = readBlobHeapOption ctxt hashValueIdx, - publicKey = publicKey, - retargetable = ((flags &&& 0x0100) <> 0x0), - version = Some (ILVersionInfo (v1, v2, v3, v4)), - locale = readStringHeapOption ctxt localeIdx) + | None -> None + | Some blob -> + Some( + if (flags &&& 0x0001) <> 0x0 then + PublicKey blob + else + PublicKeyToken blob + ) + + ILAssemblyRef.Create( + name = nm, + hash = readBlobHeapOption ctxt hashValueIdx, + publicKey = publicKey, + retargetable = ((flags &&& 0x0100) <> 0x0), + version = Some(ILVersionInfo(v1, v2, v3, v4)), + locale = readStringHeapOption ctxt localeIdx + ) and seekReadModuleRef (ctxt: ILMetadataReader) mdv idx = let nameIdx = seekReadModuleRefRow ctxt mdv idx - ILModuleRef.Create(name = readStringHeap ctxt nameIdx, hasMetadata=true, hash=None) + ILModuleRef.Create(name = readStringHeap ctxt nameIdx, hasMetadata = true, hash = None) 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) + + ILModuleRef.Create( + name = readStringHeap ctxt nameIdx, + hasMetadata = ((flags &&& 0x0001) = 0x0), + hash = readBlobHeapOption ctxt hashValueIdx + ) and seekReadClassLayout (ctxt: ILMetadataReader) mdv idx = let res = - seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.ClassLayout, + seekReadOptionalIndexedRow ( + ctxt.getNumRows TableNames.ClassLayout, seekReadClassLayoutRow ctxt mdv, (fun (_, _, tidx) -> tidx), simpleIndexCompare idx, isSorted ctxt TableNames.ClassLayout, - (fun (pack, size, _) -> pack, size)) - match res with + (fun (pack, size, _) -> pack, size) + ) + + match res with | None -> { Size = None; Pack = None } | Some (pack, size) -> { Size = Some size; Pack = Some pack } and typeAccessOfFlags flags = let f = (flags &&& 0x00000007) - if f = 0x00000001 then ILTypeDefAccess.Public - elif f = 0x00000002 then ILTypeDefAccess.Nested ILMemberAccess.Public - elif f = 0x00000003 then ILTypeDefAccess.Nested ILMemberAccess.Private - elif f = 0x00000004 then ILTypeDefAccess.Nested ILMemberAccess.Family - elif f = 0x00000006 then ILTypeDefAccess.Nested ILMemberAccess.FamilyAndAssembly - elif f = 0x00000007 then ILTypeDefAccess.Nested ILMemberAccess.FamilyOrAssembly - elif f = 0x00000005 then ILTypeDefAccess.Nested ILMemberAccess.Assembly - else ILTypeDefAccess.Private + + if f = 0x00000001 then + ILTypeDefAccess.Public + elif f = 0x00000002 then + ILTypeDefAccess.Nested ILMemberAccess.Public + elif f = 0x00000003 then + ILTypeDefAccess.Nested ILMemberAccess.Private + elif f = 0x00000004 then + ILTypeDefAccess.Nested ILMemberAccess.Family + elif f = 0x00000006 then + ILTypeDefAccess.Nested ILMemberAccess.FamilyAndAssembly + elif f = 0x00000007 then + ILTypeDefAccess.Nested ILMemberAccess.FamilyOrAssembly + elif f = 0x00000005 then + ILTypeDefAccess.Nested ILMemberAccess.Assembly + else + ILTypeDefAccess.Private and typeLayoutOfFlags (ctxt: ILMetadataReader) mdv flags tidx = let f = (flags &&& 0x00000018) - if f = 0x00000008 then ILTypeDefLayout.Sequential (seekReadClassLayout ctxt mdv tidx) - elif f = 0x00000010 then ILTypeDefLayout.Explicit (seekReadClassLayout ctxt mdv tidx) - else ILTypeDefLayout.Auto + + 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 = - (typeAccessOfFlags flags = ILTypeDefAccess.Private) || - typeAccessOfFlags flags = ILTypeDefAccess.Public + (typeAccessOfFlags flags = ILTypeDefAccess.Private) + || typeAccessOfFlags flags = ILTypeDefAccess.Public and seekIsTopTypeDefOfIdx ctxt idx = let flags, _, _, _, _, _ = seekReadTypeDefRow ctxt idx @@ -1678,6 +2078,7 @@ and seekIsTopTypeDefOfIdx ctxt idx = and readBlobHeapAsSplitTypeName ctxt (nameIdx, namespaceIdx) = let name = readStringHeap ctxt nameIdx let nspace = readStringHeapOption ctxt namespaceIdx + match nspace with | Some nspace -> splitNamespace nspace, name | None -> [], name @@ -1685,175 +2086,226 @@ and readBlobHeapAsSplitTypeName ctxt (nameIdx, namespaceIdx) = and readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) = let name = readStringHeap ctxt nameIdx let nspace = readStringHeapOption ctxt namespaceIdx + match nspace with | None -> name - | Some ns -> ctxt.memoizeString (ns+"."+name) + | Some ns -> ctxt.memoizeString (ns + "." + name) and seekReadTypeDefRowExtents (ctxt: ILMetadataReader) _info (idx: int) = if idx >= ctxt.getNumRows TableNames.TypeDef then struct (ctxt.getNumRows TableNames.Field + 1, ctxt.getNumRows TableNames.Method + 1) else let _, _, _, _, fieldsIdx, methodsIdx = seekReadTypeDefRow ctxt (idx + 1) - struct (fieldsIdx, methodsIdx ) + struct (fieldsIdx, methodsIdx) and seekReadTypeDefRowWithExtents ctxt (idx: int) = - let info= seekReadTypeDefRow ctxt idx + let info = seekReadTypeDefRow ctxt idx info, seekReadTypeDefRowExtents ctxt info idx and seekReadPreTypeDef ctxt toponly (idx: int) = let flags, nameIdx, namespaceIdx, _, _, _ = seekReadTypeDefRow ctxt idx - if toponly && not (isTopTypeDef flags) then None + + if toponly && not (isTopTypeDef flags) then + None else - let ns, n = readBlobHeapAsSplitTypeName ctxt (nameIdx, namespaceIdx) - // 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 struct (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 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 mdv numTypars idx - let mimpls = seekReadMethodImpls ctxt numTypars idx - let props = seekReadProperties ctxt numTypars idx - let events = seekReadEvents ctxt numTypars idx - 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, - isKnownToBeAttribute=false, - customAttrsStored=ctxt.customAttrsReader_TypeDef, - metadataIndex=idx) - ) + let ns, n = readBlobHeapAsSplitTypeName ctxt (nameIdx, namespaceIdx) + // 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 struct (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 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 mdv numTypars idx + let mimpls = seekReadMethodImpls ctxt numTypars idx + let props = seekReadProperties ctxt numTypars idx + let events = seekReadEvents ctxt numTypars idx + + 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, + isKnownToBeAttribute = false, + customAttrsStored = ctxt.customAttrsReader_TypeDef, + metadataIndex = idx + )) and seekReadTopTypeDefs (ctxt: ILMetadataReader) = - [| for i = 1 to ctxt.getNumRows TableNames.TypeDef do - match seekReadPreTypeDef ctxt true i with - | None -> () - | Some td -> yield td |] + [| + for i = 1 to ctxt.getNumRows TableNames.TypeDef do + match seekReadPreTypeDef ctxt true i with + | None -> () + | Some td -> yield td + |] 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 seekReadPreTypeDef ctxt false i with - | None -> () - | Some td -> yield td |]) + let nestedIdxs = + seekReadIndexedRows (ctxt.getNumRows TableNames.Nested, seekReadNestedRow ctxt, snd, simpleIndexCompare tidx, false, fst) + + [| + for i in nestedIdxs do + match seekReadPreTypeDef ctxt false i with + | None -> () + | Some td -> yield td + |]) and seekReadInterfaceImpls (ctxt: ILMetadataReader) mdv numTypars tidx = - seekReadIndexedRows (ctxt.getNumRows TableNames.InterfaceImpl, - seekReadInterfaceImplRow ctxt mdv, - fst, - simpleIndexCompare tidx, - isSorted ctxt TableNames.InterfaceImpl, - (snd >> seekReadTypeDefOrRef ctxt numTypars AsObject (*ok*) [])) + seekReadIndexedRows ( + ctxt.getNumRows TableNames.InterfaceImpl, + seekReadInterfaceImplRow ctxt mdv, + fst, + simpleIndexCompare tidx, + isSorted ctxt TableNames.InterfaceImpl, + (snd >> seekReadTypeDefOrRef ctxt numTypars AsObject (*ok*) []) + ) -and seekReadGenericParams ctxt numTypars (a, b): ILGenericParameterDefs = +and seekReadGenericParams ctxt numTypars (a, b) : ILGenericParameterDefs = ctxt.seekReadGenericParams (GenericParamsIdx(numTypars, a, b)) -and seekReadGenericParamsUncached ctxtH (GenericParamsIdx(numTypars, a, b)) = +and seekReadGenericParamsUncached ctxtH (GenericParamsIdx (numTypars, a, b)) = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() + let pars = - seekReadIndexedRows - (ctxt.getNumRows TableNames.GenericParam, seekReadGenericParamRow ctxt mdv, - (fun (_, _, _, tomd, _) -> tomd), - tomdCompare (TaggedIndex(a, b)), - isSorted ctxt TableNames.GenericParam, - (fun (gpidx, seq, flags, _, nameIdx) -> - let flags = int32 flags - let variance_flags = flags &&& 0x0003 - let variance = - if variance_flags = 0x0000 then NonVariant - elif variance_flags = 0x0001 then CoVariant - elif variance_flags = 0x0002 then ContraVariant - else NonVariant - let constraints = seekReadGenericParamConstraints ctxt mdv numTypars gpidx - seq, {Name=readStringHeap ctxt nameIdx - Constraints = constraints - Variance=variance - CustomAttrsStored = ctxt.customAttrsReader_GenericParam - MetadataIndex=gpidx - HasReferenceTypeConstraint= (flags &&& 0x0004) <> 0 - HasNotNullableValueTypeConstraint= (flags &&& 0x0008) <> 0 - HasDefaultConstructorConstraint=(flags &&& 0x0010) <> 0 })) + seekReadIndexedRows ( + ctxt.getNumRows TableNames.GenericParam, + seekReadGenericParamRow ctxt mdv, + (fun (_, _, _, tomd, _) -> tomd), + tomdCompare (TaggedIndex(a, b)), + isSorted ctxt TableNames.GenericParam, + (fun (gpidx, seq, flags, _, nameIdx) -> + let flags = int32 flags + let variance_flags = flags &&& 0x0003 + + let variance = + if variance_flags = 0x0000 then + NonVariant + elif variance_flags = 0x0001 then + CoVariant + elif variance_flags = 0x0002 then + ContraVariant + else + NonVariant + + let constraints = seekReadGenericParamConstraints ctxt mdv numTypars gpidx + + seq, + { + Name = readStringHeap ctxt nameIdx + Constraints = constraints + Variance = variance + 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 seekReadGenericParamConstraints (ctxt: ILMetadataReader) mdv numTypars gpidx = - seekReadIndexedRows - (ctxt.getNumRows TableNames.GenericParamConstraint, - seekReadGenericParamConstraintRow ctxt mdv, - fst, - simpleIndexCompare gpidx, - isSorted ctxt TableNames.GenericParamConstraint, - (snd >> seekReadTypeDefOrRef ctxt numTypars AsObject (*ok*) List.empty)) + seekReadIndexedRows ( + ctxt.getNumRows TableNames.GenericParamConstraint, + seekReadGenericParamConstraintRow ctxt mdv, + fst, + simpleIndexCompare gpidx, + isSorted ctxt TableNames.GenericParamConstraint, + (snd >> seekReadTypeDefOrRef ctxt numTypars AsObject (*ok*) List.empty) + ) and seekReadTypeDefAsType (ctxt: ILMetadataReader) boxity (ginst: ILTypes) idx = - ctxt.seekReadTypeDefAsType (TypeDefAsTypIdx (boxity, ginst, 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: ILMetadataReader) idx = - let enc = - if seekIsTopTypeDefOfIdx ctxt idx then [] - else - let enclIdx = seekReadIndexedRow (ctxt.getNumRows TableNames.Nested, seekReadNestedRow ctxt, fst, simpleIndexCompare idx, isSorted ctxt TableNames.Nested, snd) - let tref = seekReadTypeDefAsTypeRef ctxt enclIdx - tref.Enclosing@[tref.Name] - let _, nameIdx, namespaceIdx, _, _, _ = seekReadTypeDefRow ctxt idx - let nm = readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) - ILTypeRef.Create(scope=ILScopeRef.Local, enclosing=enc, name = nm ) + let enc = + if seekIsTopTypeDefOfIdx ctxt idx then + [] + else + let enclIdx = + seekReadIndexedRow ( + ctxt.getNumRows TableNames.Nested, + seekReadNestedRow ctxt, + fst, + simpleIndexCompare idx, + isSorted ctxt TableNames.Nested, + snd + ) + + let tref = seekReadTypeDefAsTypeRef ctxt enclIdx + tref.Enclosing @ [ tref.Name ] + + let _, nameIdx, namespaceIdx, _, _, _ = seekReadTypeDefRow ctxt idx + let nm = readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) + ILTypeRef.Create(scope = ILScopeRef.Local, enclosing = enc, name = nm) and seekReadTypeRef (ctxt: ILMetadataReader) idx = ctxt.seekReadTypeRef idx + and seekReadTypeRefUncached ctxtH idx = - 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: ILMetadataReader) boxity ginst idx = ctxt.seekReadTypeRefAsType (TypeRefAsTypIdx (boxity, ginst, idx)) + 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: 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)) + let ctxt = getHole ctxtH + mkILTy boxity (ILTypeSpec.Create(seekReadTypeRef ctxt idx, ginst)) -and seekReadTypeDefOrRef (ctxt: ILMetadataReader) 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 not (List.isEmpty ginst) then dprintn "type spec used as type constructor for a generic instantiation: ignoring instantiation" + 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: ILMetadataReader) (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 @@ -1862,114 +2314,168 @@ and seekReadTypeDefOrRefAsTypeRef (ctxt: ILMetadataReader) (TaggedIndex(tag, idx PrimaryAssemblyILGlobals.typ_Object.TypeRef | _ -> failwith "seekReadTypeDefOrRefAsTypeRef_readTypeDefOrRefOrSpec" -and seekReadMethodRefParent (ctxt: ILMetadataReader) mdv 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 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_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(enclTy, cc, nm, argTys, retTy, methInst)) = seekReadMethodDefAsMethodData ctxt idx + let (MethodData (enclTy, cc, nm, argTys, retTy, methInst)) = + seekReadMethodDefAsMethodData ctxt idx + let mspec = mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) mspec.DeclaringType | tag when tag = mrp_TypeSpec -> readBlobHeapAsType ctxt numTypars (seekReadTypeSpecRow ctxt mdv idx) | _ -> failwith "seekReadMethodRefParent" -and seekReadMethodDefOrRef (ctxt: ILMetadataReader) numTypars (TaggedIndex(tag, idx)) = +and seekReadMethodDefOrRef (ctxt: ILMetadataReader) numTypars (TaggedIndex (tag, idx)) = match tag with | tag when tag = mdor_MethodDef -> - let (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) = seekReadMethodDefAsMethodData ctxt idx + let (MethodData (enclTy, cc, nm, argTys, retTy, methInst)) = + seekReadMethodDefAsMethodData ctxt idx + VarArgMethodData(enclTy, cc, nm, argTys, None, retTy, methInst) - | tag when tag = mdor_MemberRef -> - seekReadMemberRefAsMethodData ctxt numTypars idx + | tag when tag = mdor_MemberRef -> seekReadMemberRefAsMethodData ctxt numTypars idx | _ -> failwith "seekReadMethodDefOrRef" and seekReadMethodDefOrRefNoVarargs (ctxt: ILMetadataReader) numTypars x = - let (VarArgMethodData(enclTy, cc, nm, argTys, varargs, retTy, methInst)) = seekReadMethodDefOrRef ctxt numTypars x - if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef token signature" - MethodData(enclTy, cc, nm, argTys, retTy, methInst) + let (VarArgMethodData (enclTy, cc, nm, argTys, varargs, retTy, methInst)) = + seekReadMethodDefOrRef ctxt numTypars x -and seekReadCustomAttrType (ctxt: ILMetadataReader) (TaggedIndex(tag, idx) ) = + if varargs <> None then + dprintf "ignoring sentinel and varargs in ILMethodDef token signature" + + MethodData(enclTy, cc, nm, argTys, retTy, methInst) + +and seekReadCustomAttrType (ctxt: ILMetadataReader) (TaggedIndex (tag, idx)) = match tag with | tag when tag = cat_MethodDef -> - let (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) = seekReadMethodDefAsMethodData ctxt idx + let (MethodData (enclTy, cc, nm, argTys, retTy, methInst)) = + seekReadMethodDefAsMethodData ctxt idx + mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) | tag when tag = cat_MemberRef -> - let (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) = seekReadMemberRefAsMethDataNoVarArgs ctxt 0 idx + let (MethodData (enclTy, cc, nm, argTys, retTy, methInst)) = + seekReadMemberRefAsMethDataNoVarArgs ctxt 0 idx + mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) | _ -> failwith "seekReadCustomAttrType ctxt" -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 mdv idx) - | tag when tag = i_AssemblyRef -> ILScopeRef.Assembly (seekReadAssemblyRef ctxt idx) - | tag when tag = i_ExportedType -> failwith "seekReadImplAsScopeRef" - | _ -> failwith "seekReadImplAsScopeRef" +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 mdv idx) + | tag when tag = i_AssemblyRef -> ILScopeRef.Assembly(seekReadAssemblyRef ctxt idx) + | tag when tag = i_ExportedType -> failwith "seekReadImplAsScopeRef" + | _ -> failwith "seekReadImplAsScopeRef" -and seekReadTypeRefScope (ctxt: ILMetadataReader) mdv (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 mdv idx), [] - | tag when tag = rs_AssemblyRef -> ILScopeRef.Assembly (seekReadAssemblyRef 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]) + tref.Scope, (tref.Enclosing @ [ tref.Name ]) | _ -> failwith "seekReadTypeRefScope" and seekReadOptionalTypeDefOrRef (ctxt: ILMetadataReader) numTypars boxity idx = - if idx = TaggedIndex(tdor_TypeDef, 0) then None - else Some (seekReadTypeDefOrRef ctxt numTypars boxity List.empty idx) + if idx = TaggedIndex(tdor_TypeDef, 0) then + None + else + Some(seekReadTypeDefOrRef ctxt numTypars boxity List.empty idx) 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) + + 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: ILMetadataReader) (numTypars, hasLayout) fidx1 fidx2 = - mkILFieldsLazy - (lazy - let mdv = ctxt.mdfile.GetView() - [ if fidx1 > 0 then - for i = fidx1 to fidx2 - 1 do - yield seekReadField ctxt mdv (numTypars, hasLayout) i ]) + mkILFieldsLazy ( + lazy + let mdv = ctxt.mdfile.GetView() + + [ + if fidx1 > 0 then + for i = fidx1 to fidx2 - 1 do + yield seekReadField ctxt mdv (numTypars, hasLayout) i + ] + ) and seekReadMethods (ctxt: ILMetadataReader) numTypars midx1 midx2 = mkILMethodsComputed (fun () -> - let mdv = ctxt.mdfile.GetView() - [| if midx1 > 0 then - for i = midx1 to midx2 - 1 do - yield seekReadMethod ctxt mdv numTypars i |]) + let mdv = ctxt.mdfile.GetView() + + [| + if midx1 > 0 then + for i = midx1 to midx2 - 1 do + yield seekReadMethod ctxt mdv numTypars i + |]) and sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr = let struct (n, sigptr) = sigptrGetZInt32 bytes sigptr + if (n &&& 0x01) = 0x0 then (* Type Def *) TaggedIndex(tdor_TypeDef, (n >>>& 2)), sigptr else (* Type Ref *) @@ -1977,28 +2483,54 @@ and sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr = and sigptrGetTy (ctxt: ILMetadataReader) numTypars bytes sigptr = let b0, sigptr = sigptrGetByte bytes sigptr - if b0 = et_OBJECT then PrimaryAssemblyILGlobals.typ_Object, sigptr - elif b0 = et_STRING then PrimaryAssemblyILGlobals.typ_String, sigptr - elif b0 = et_I1 then PrimaryAssemblyILGlobals.typ_SByte, sigptr - elif b0 = et_I2 then PrimaryAssemblyILGlobals.typ_Int16, sigptr - elif b0 = et_I4 then PrimaryAssemblyILGlobals.typ_Int32, sigptr - elif b0 = et_I8 then PrimaryAssemblyILGlobals.typ_Int64, sigptr - elif b0 = et_I then PrimaryAssemblyILGlobals.typ_IntPtr, sigptr - elif b0 = et_U1 then PrimaryAssemblyILGlobals.typ_Byte, sigptr - elif b0 = et_U2 then PrimaryAssemblyILGlobals.typ_UInt16, sigptr - elif b0 = et_U4 then PrimaryAssemblyILGlobals.typ_UInt32, sigptr - elif b0 = et_U8 then PrimaryAssemblyILGlobals.typ_UInt64, sigptr - elif b0 = et_U then PrimaryAssemblyILGlobals.typ_UIntPtr, sigptr - elif b0 = et_R4 then PrimaryAssemblyILGlobals.typ_Single, sigptr - elif b0 = et_R8 then PrimaryAssemblyILGlobals.typ_Double, sigptr - elif b0 = et_CHAR then PrimaryAssemblyILGlobals.typ_Char, sigptr - elif b0 = et_BOOLEAN then PrimaryAssemblyILGlobals.typ_Bool, sigptr + + if b0 = et_OBJECT then + PrimaryAssemblyILGlobals.typ_Object, sigptr + elif b0 = et_STRING then + PrimaryAssemblyILGlobals.typ_String, sigptr + elif b0 = et_I1 then + PrimaryAssemblyILGlobals.typ_SByte, sigptr + elif b0 = et_I2 then + PrimaryAssemblyILGlobals.typ_Int16, sigptr + elif b0 = et_I4 then + PrimaryAssemblyILGlobals.typ_Int32, sigptr + elif b0 = et_I8 then + PrimaryAssemblyILGlobals.typ_Int64, sigptr + elif b0 = et_I then + PrimaryAssemblyILGlobals.typ_IntPtr, sigptr + elif b0 = et_U1 then + PrimaryAssemblyILGlobals.typ_Byte, sigptr + elif b0 = et_U2 then + PrimaryAssemblyILGlobals.typ_UInt16, sigptr + elif b0 = et_U4 then + PrimaryAssemblyILGlobals.typ_UInt32, sigptr + elif b0 = et_U8 then + PrimaryAssemblyILGlobals.typ_UInt64, sigptr + elif b0 = et_U then + PrimaryAssemblyILGlobals.typ_UIntPtr, sigptr + elif b0 = et_R4 then + PrimaryAssemblyILGlobals.typ_Single, sigptr + elif b0 = et_R8 then + PrimaryAssemblyILGlobals.typ_Double, sigptr + elif b0 = et_CHAR then + PrimaryAssemblyILGlobals.typ_Char, sigptr + elif b0 = et_BOOLEAN then + PrimaryAssemblyILGlobals.typ_Bool, sigptr elif b0 = et_WITH then let b0, sigptr = sigptrGetByte bytes sigptr let tdorIdx, sigptr = sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr let struct (n, sigptr) = sigptrGetZInt32 bytes sigptr let argTys, sigptr = sigptrFold (sigptrGetTy ctxt numTypars) n bytes sigptr - seekReadTypeDefOrRef ctxt numTypars (if b0 = et_CLASS then AsObject else AsValue) argTys tdorIdx, + + seekReadTypeDefOrRef + ctxt + numTypars + (if b0 = et_CLASS then + AsObject + else + AsValue) + argTys + tdorIdx, sigptr elif b0 = et_CLASS then @@ -2009,10 +2541,10 @@ and sigptrGetTy (ctxt: ILMetadataReader) numTypars bytes sigptr = seekReadTypeDefOrRef ctxt numTypars AsValue List.empty tdorIdx, sigptr elif b0 = et_VAR then let struct (n, sigptr) = sigptrGetZInt32 bytes sigptr - ILType.TypeVar (uint16 n), sigptr + ILType.TypeVar(uint16 n), sigptr elif b0 = et_MVAR then let struct (n, sigptr) = sigptrGetZInt32 bytes sigptr - ILType.TypeVar (uint16 (n + numTypars)), sigptr + ILType.TypeVar(uint16 (n + numTypars)), sigptr elif b0 = et_BYREF then let ty, sigptr = sigptrGetTy ctxt numTypars bytes sigptr ILType.Byref ty, sigptr @@ -2028,15 +2560,27 @@ and sigptrGetTy (ctxt: ILMetadataReader) numTypars bytes sigptr = let struct (numSized, sigptr) = sigptrGetZInt32 bytes sigptr let struct (sizes, sigptr) = sigptrFoldStruct sigptrGetZInt32 numSized bytes sigptr let struct (numLoBounded, sigptr) = sigptrGetZInt32 bytes sigptr - let struct (lobounds, sigptr) = sigptrFoldStruct sigptrGetZInt32 numLoBounded bytes sigptr + + let struct (lobounds, sigptr) = + sigptrFoldStruct sigptrGetZInt32 numLoBounded bytes sigptr + let shape = let dim i = - (if i < numLoBounded then Some (List.item i lobounds) else None), - (if i < numSized then Some (List.item i sizes) else None) - ILArrayShape (List.init rank dim) + (if i < numLoBounded then + Some(List.item i lobounds) + else + None), + (if i < numSized then + Some(List.item i sizes) + else + None) + + ILArrayShape(List.init rank dim) + mkILArrTy (ty, shape), sigptr - elif b0 = et_VOID then ILType.Void, sigptr + elif b0 = et_VOID then + ILType.Void, sigptr elif b0 = et_TYPEDBYREF then PrimaryAssemblyILGlobals.typ_TypedReference, sigptr elif b0 = et_CMOD_REQD || b0 = et_CMOD_OPT then @@ -2046,46 +2590,66 @@ and sigptrGetTy (ctxt: ILMetadataReader) numTypars bytes sigptr = elif b0 = et_FNPTR then let ccByte, sigptr = sigptrGetByte bytes sigptr let generic, cc = byteAsCallConv ccByte - if generic then failwith "fptr sig may not be generic" + + if generic then + failwith "fptr sig may not be generic" + let struct (numparams, sigptr) = sigptrGetZInt32 bytes sigptr let retTy, sigptr = sigptrGetTy ctxt numTypars bytes sigptr let argTys, sigptr = sigptrFold (sigptrGetTy ctxt numTypars) numparams bytes sigptr + let typ = ILType.FunctionPointer - { CallingConv=cc - ArgTypes = argTys - ReturnType=retTy } + { + CallingConv = cc + ArgTypes = argTys + ReturnType = retTy + } + typ, sigptr - elif b0 = et_SENTINEL then failwith "varargs NYI" - else ILType.Void, sigptr + elif b0 = et_SENTINEL then + failwith "varargs NYI" + else + ILType.Void, sigptr and sigptrGetVarArgTys (ctxt: ILMetadataReader) n numTypars bytes sigptr = sigptrFold (sigptrGetTy ctxt numTypars) n bytes sigptr and sigptrGetArgTys (ctxt: ILMetadataReader) n numTypars bytes sigptr acc = - if n <= 0 then (List.rev acc, None), sigptr + if n <= 0 then + (List.rev acc, None), sigptr else - let b0, sigptr2 = sigptrGetByte bytes sigptr - if b0 = et_SENTINEL then - let varargs, sigptr = sigptrGetVarArgTys ctxt n numTypars bytes sigptr2 - (List.rev acc, Some varargs), sigptr - else - let x, sigptr = sigptrGetTy ctxt numTypars bytes sigptr - sigptrGetArgTys ctxt (n-1) numTypars bytes sigptr (x :: acc) + let b0, sigptr2 = sigptrGetByte bytes sigptr + + if b0 = et_SENTINEL then + let varargs, sigptr = sigptrGetVarArgTys ctxt n numTypars bytes sigptr2 + (List.rev acc, Some varargs), sigptr + else + let x, sigptr = sigptrGetTy ctxt numTypars bytes sigptr + sigptrGetArgTys ctxt (n - 1) numTypars bytes sigptr (x :: acc) and sigptrGetLocal (ctxt: ILMetadataReader) numTypars bytes sigptr = let pinned, sigptr = let b0, sigptr' = sigptrGetByte bytes sigptr + if b0 = et_PINNED then true, sigptr' else false, sigptr + let ty, sigptr = sigptrGetTy ctxt numTypars bytes sigptr - let loc: ILLocal = { IsPinned = pinned; Type = ty; DebugInfo = None } + + let loc: ILLocal = + { + IsPinned = pinned + Type = ty + DebugInfo = None + } + loc, sigptr and readBlobHeapAsMethodSig (ctxt: ILMetadataReader) numTypars blobIdx = - ctxt.readBlobHeapAsMethodSig (BlobAsMethodSigIdx (numTypars, blobIdx)) + ctxt.readBlobHeapAsMethodSig (BlobAsMethodSigIdx(numTypars, blobIdx)) and readBlobHeapAsMethodSigUncached ctxtH (BlobAsMethodSigIdx (numTypars, blobIdx)) = let (ctxt: ILMetadataReader) = getHole ctxtH @@ -2093,10 +2657,19 @@ and readBlobHeapAsMethodSigUncached ctxtH (BlobAsMethodSigIdx (numTypars, blobId let sigptr = 0 let ccByte, sigptr = sigptrGetByte bytes sigptr let generic, cc = byteAsCallConv ccByte - let struct (genarity, sigptr) = if generic then sigptrGetZInt32 bytes sigptr else 0x0, sigptr + + let struct (genarity, sigptr) = + if generic then + sigptrGetZInt32 bytes sigptr + else + 0x0, sigptr + let struct (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 = @@ -2105,20 +2678,22 @@ and readBlobHeapAsType ctxt numTypars blobIdx = ty and readBlobHeapAsFieldSig ctxt numTypars blobIdx = - ctxt.readBlobHeapAsFieldSig (BlobAsFieldSigIdx (numTypars, blobIdx)) + ctxt.readBlobHeapAsFieldSig (BlobAsFieldSigIdx(numTypars, blobIdx)) and readBlobHeapAsFieldSigUncached ctxtH (BlobAsFieldSigIdx (numTypars, blobIdx)) = let ctxt = getHole ctxtH let bytes = readBlobHeap ctxt blobIdx let sigptr = 0 let ccByte, sigptr = sigptrGetByte bytes sigptr - if ccByte <> e_IMAGE_CEE_CS_CALLCONV_FIELD then dprintn "warning: field sig was not CC_FIELD" + + if ccByte <> e_IMAGE_CEE_CS_CALLCONV_FIELD then + dprintn "warning: field sig was not CC_FIELD" + let retTy, _sigptr = sigptrGetTy ctxt numTypars bytes sigptr retTy - and readBlobHeapAsPropertySig (ctxt: ILMetadataReader) numTypars blobIdx = - ctxt.readBlobHeapAsPropertySig (BlobAsPropSigIdx (numTypars, blobIdx)) + ctxt.readBlobHeapAsPropertySig (BlobAsPropSigIdx(numTypars, blobIdx)) and readBlobHeapAsPropertySigUncached ctxtH (BlobAsPropSigIdx (numTypars, blobIdx)) = let ctxt = getHole ctxtH @@ -2127,45 +2702,66 @@ and readBlobHeapAsPropertySigUncached ctxtH (BlobAsPropSigIdx (numTypars, blobId let ccByte, sigptr = sigptrGetByte bytes sigptr let hasthis = byteAsHasThis ccByte let ccMaxked = (ccByte &&& 0x0Fuy) - if ccMaxked <> e_IMAGE_CEE_CS_CALLCONV_PROPERTY then dprintn ("warning: property sig was "+string ccMaxked+" instead of CC_PROPERTY") + + if ccMaxked <> e_IMAGE_CEE_CS_CALLCONV_PROPERTY then + dprintn ("warning: property sig was " + string ccMaxked + " instead of CC_PROPERTY") + let struct (numparams, sigptr) = sigptrGetZInt32 bytes sigptr let retTy, sigptr = sigptrGetTy ctxt numTypars bytes sigptr let argTys, _sigptr = sigptrFold (sigptrGetTy ctxt numTypars) numparams bytes sigptr hasthis, retTy, argTys and readBlobHeapAsLocalsSig (ctxt: ILMetadataReader) numTypars blobIdx = - ctxt.readBlobHeapAsLocalsSig (BlobAsLocalSigIdx (numTypars, blobIdx)) + ctxt.readBlobHeapAsLocalsSig (BlobAsLocalSigIdx(numTypars, blobIdx)) and readBlobHeapAsLocalsSigUncached ctxtH (BlobAsLocalSigIdx (numTypars, blobIdx)) = let ctxt = getHole ctxtH let bytes = readBlobHeap ctxt blobIdx let sigptr = 0 let ccByte, sigptr = sigptrGetByte bytes sigptr - if ccByte <> e_IMAGE_CEE_CS_CALLCONV_LOCAL_SIG then dprintn "warning: local sig was not CC_LOCAL" + + if ccByte <> e_IMAGE_CEE_CS_CALLCONV_LOCAL_SIG then + dprintn "warning: local sig was not CC_LOCAL" + let struct (numlocals, sigptr) = sigptrGetZInt32 bytes sigptr - let localtys, _sigptr = sigptrFold (sigptrGetLocal ctxt numTypars) numlocals bytes sigptr + + let localtys, _sigptr = + sigptrFold (sigptrGetLocal ctxt numTypars) numlocals bytes sigptr + localtys and byteAsHasThis b = let hasthis_masked = b &&& 0x60uy - if hasthis_masked = e_IMAGE_CEE_CS_CALLCONV_INSTANCE then ILThisConvention.Instance - elif hasthis_masked = e_IMAGE_CEE_CS_CALLCONV_INSTANCE_EXPLICIT then ILThisConvention.InstanceExplicit - else ILThisConvention.Static + + if hasthis_masked = e_IMAGE_CEE_CS_CALLCONV_INSTANCE then + ILThisConvention.Instance + elif hasthis_masked = e_IMAGE_CEE_CS_CALLCONV_INSTANCE_EXPLICIT then + ILThisConvention.InstanceExplicit + else + ILThisConvention.Static and byteAsCallConv b = let cc = let ccMaxked = b &&& 0x0Fuy - if ccMaxked = e_IMAGE_CEE_CS_CALLCONV_FASTCALL then ILArgConvention.FastCall - elif ccMaxked = e_IMAGE_CEE_CS_CALLCONV_STDCALL then ILArgConvention.StdCall - elif ccMaxked = e_IMAGE_CEE_CS_CALLCONV_THISCALL then ILArgConvention.ThisCall - elif ccMaxked = e_IMAGE_CEE_CS_CALLCONV_CDECL then ILArgConvention.CDecl - elif ccMaxked = e_IMAGE_CEE_CS_CALLCONV_VARARG then ILArgConvention.VarArg - else ILArgConvention.Default + + if ccMaxked = e_IMAGE_CEE_CS_CALLCONV_FASTCALL then + ILArgConvention.FastCall + elif ccMaxked = e_IMAGE_CEE_CS_CALLCONV_STDCALL then + ILArgConvention.StdCall + elif ccMaxked = e_IMAGE_CEE_CS_CALLCONV_THISCALL then + ILArgConvention.ThisCall + elif ccMaxked = e_IMAGE_CEE_CS_CALLCONV_CDECL then + ILArgConvention.CDecl + elif ccMaxked = e_IMAGE_CEE_CS_CALLCONV_VARARG then + ILArgConvention.VarArg + else + ILArgConvention.Default + let generic = (b &&& e_IMAGE_CEE_CS_CALLCONV_GENERIC) <> 0x0uy - generic, Callconv (byteAsHasThis b, cc) + generic, Callconv(byteAsHasThis b, cc) -and seekReadMemberRefAsMethodData ctxt numTypars idx: VarArgMethodData = - ctxt.seekReadMemberRefAsMethodData (MemberRefAsMspecIdx (numTypars, idx)) +and seekReadMemberRefAsMethodData ctxt numTypars idx : VarArgMethodData = + ctxt.seekReadMemberRefAsMethodData (MemberRefAsMspecIdx(numTypars, idx)) and seekReadMemberRefAsMethodDataUncached ctxtH (MemberRefAsMspecIdx (numTypars, idx)) = let (ctxt: ILMetadataReader) = getHole ctxtH @@ -2173,44 +2769,62 @@ and seekReadMemberRefAsMethodDataUncached ctxtH (MemberRefAsMspecIdx (numTypars, let mrpIdx, nameIdx, typeIdx = seekReadMemberRefRow ctxt mdv idx let nm = readStringHeap ctxt nameIdx let enclTy = seekReadMethodRefParent ctxt mdv numTypars mrpIdx - let _generic, genarity, cc, retTy, argTys, varargs = readBlobHeapAsMethodSig ctxt enclTy.GenericArgs.Length typeIdx - let methInst = List.init genarity (fun n -> mkILTyvarTy (uint16 (numTypars+n))) + + let _generic, genarity, cc, retTy, argTys, varargs = + readBlobHeapAsMethodSig ctxt enclTy.GenericArgs.Length typeIdx + + let methInst = List.init genarity (fun n -> mkILTyvarTy (uint16 (numTypars + n))) (VarArgMethodData(enclTy, cc, nm, argTys, varargs, retTy, methInst)) -and seekReadMemberRefAsMethDataNoVarArgs ctxt numTypars idx: MethodData = - let (VarArgMethodData(enclTy, cc, nm, argTys, varargs, retTy, methInst)) = seekReadMemberRefAsMethodData ctxt numTypars idx - if Option.isSome varargs then dprintf "ignoring sentinel and varargs in ILMethodDef token signature" - (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) +and seekReadMemberRefAsMethDataNoVarArgs ctxt numTypars idx : MethodData = + let (VarArgMethodData (enclTy, cc, nm, argTys, varargs, retTy, methInst)) = + seekReadMemberRefAsMethodData ctxt numTypars idx + + if Option.isSome varargs then + dprintf "ignoring sentinel and varargs in ILMethodDef token signature" + + (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) and seekReadMethodSpecAsMethodData (ctxt: ILMetadataReader) numTypars idx = - ctxt.seekReadMethodSpecAsMethodData (MethodSpecAsMspecIdx (numTypars, idx)) + ctxt.seekReadMethodSpecAsMethodData (MethodSpecAsMspecIdx(numTypars, idx)) and seekReadMethodSpecAsMethodDataUncached ctxtH (MethodSpecAsMspecIdx (numTypars, idx)) = let (ctxt: ILMetadataReader) = getHole ctxtH let mdv = ctxt.mdfile.GetView() let mdorIdx, instIdx = seekReadMethodSpecRow ctxt mdv idx - let (VarArgMethodData(enclTy, cc, nm, argTys, varargs, retTy, _)) = seekReadMethodDefOrRef ctxt numTypars mdorIdx + + let (VarArgMethodData (enclTy, cc, nm, argTys, varargs, retTy, _)) = + seekReadMethodDefOrRef ctxt numTypars mdorIdx + let methInst = let bytes = readBlobHeap ctxt instIdx let sigptr = 0 let ccByte, sigptr = sigptrGetByte bytes sigptr - if ccByte <> e_IMAGE_CEE_CS_CALLCONV_GENERICINST then dprintn ("warning: method inst ILCallingConv was "+string ccByte+" instead of CC_GENERICINST") + + if ccByte <> e_IMAGE_CEE_CS_CALLCONV_GENERICINST then + dprintn ( + "warning: method inst ILCallingConv was " + + string ccByte + + " instead of CC_GENERICINST" + ) + let struct (numgpars, sigptr) = sigptrGetZInt32 bytes sigptr let argTys, _sigptr = sigptrFold (sigptrGetTy ctxt numTypars) numgpars bytes sigptr argTys + VarArgMethodData(enclTy, cc, nm, argTys, varargs, retTy, methInst) and seekReadMemberRefAsFieldSpec (ctxt: ILMetadataReader) numTypars idx = - ctxt.seekReadMemberRefAsFieldSpec (MemberRefAsFspecIdx (numTypars, idx)) + ctxt.seekReadMemberRefAsFieldSpec (MemberRefAsFspecIdx(numTypars, idx)) and seekReadMemberRefAsFieldSpecUncached ctxtH (MemberRefAsFspecIdx (numTypars, 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 enclTy = seekReadMethodRefParent ctxt mdv numTypars mrpIdx - let retTy = readBlobHeapAsFieldSig ctxt numTypars typeIdx - mkILFieldSpecInTy(enclTy, nm, retTy) + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + let mrpIdx, nameIdx, typeIdx = seekReadMemberRefRow ctxt mdv idx + let nm = readStringHeap ctxt nameIdx + let enclTy = seekReadMethodRefParent ctxt mdv numTypars mrpIdx + let retTy = readBlobHeapAsFieldSig ctxt numTypars typeIdx + mkILFieldSpecInTy (enclTy, nm, retTy) // One extremely annoying aspect of the MD format is that given a // ILMethodDef token it is non-trivial to find which ILTypeDef it belongs @@ -2218,192 +2832,264 @@ and seekReadMemberRefAsFieldSpecUncached ctxtH (MemberRefAsFspecIdx (numTypars, // looking for which ILTypeDef has the ILMethodDef within its range. // Although the ILTypeDef table is not "sorted", it is effectively sorted by // method-range and field-range start/finish indexes -and seekReadMethodDefAsMethodData ctxt idx = - ctxt.seekReadMethodDefAsMethodData idx +and seekReadMethodDefAsMethodData ctxt idx = ctxt.seekReadMethodDefAsMethodData idx and seekReadMethodDefAsMethodDataUncached ctxtH idx = - let (ctxt: ILMetadataReader) = getHole ctxtH - let mdv = ctxt.mdfile.GetView() - // Look for the method def parent. - let tidx = - seekReadIndexedRow (ctxt.getNumRows TableNames.TypeDef, - (fun i -> i, seekReadTypeDefRowWithExtents ctxt i), - (fun r -> r), - (fun (_, ((_, _, _, _, _, methodsIdx), - (_, endMethodsIdx))) -> - if endMethodsIdx <= idx then 1 - elif methodsIdx <= idx && idx < endMethodsIdx then 0 - else -1), - true, fst) - // Create a formal instantiation if needed - let typeGenericArgs = seekReadGenericParams ctxt 0 (tomd_TypeDef, tidx) - let typeGenericArgsCount = typeGenericArgs.Length + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + // Look for the method def parent. + let tidx = + seekReadIndexedRow ( + ctxt.getNumRows TableNames.TypeDef, + (fun i -> i, seekReadTypeDefRowWithExtents ctxt i), + (fun r -> r), + (fun (_, ((_, _, _, _, _, methodsIdx), (_, endMethodsIdx))) -> + if endMethodsIdx <= idx then + 1 + elif methodsIdx <= idx && idx < endMethodsIdx then + 0 + else + -1), + true, + fst + ) + // Create a formal instantiation if needed + let typeGenericArgs = seekReadGenericParams ctxt 0 (tomd_TypeDef, tidx) + let typeGenericArgsCount = typeGenericArgs.Length - let methodGenericArgs = seekReadGenericParams ctxt typeGenericArgsCount (tomd_MethodDef, idx) + let methodGenericArgs = + seekReadGenericParams ctxt typeGenericArgsCount (tomd_MethodDef, idx) - let finst = mkILFormalGenericArgs 0 typeGenericArgs - let methInst = mkILFormalGenericArgs typeGenericArgsCount methodGenericArgs + let finst = mkILFormalGenericArgs 0 typeGenericArgs + let methInst = mkILFormalGenericArgs typeGenericArgsCount methodGenericArgs - // Read the method def parent. - let enclTy = seekReadTypeDefAsType ctxt AsObject (* not ok: see note *) finst tidx + // Read the method def parent. + let enclTy = 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 mdv idx - let nm = readStringHeap ctxt nameIdx + // 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. - let _generic, _genarity, cc, retTy, argTys, varargs = readBlobHeapAsMethodSig ctxt typeGenericArgsCount typeIdx - if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef token signature" + // Read the method def signature. + let _generic, _genarity, cc, retTy, argTys, varargs = + readBlobHeapAsMethodSig ctxt typeGenericArgsCount typeIdx - MethodData(enclTy, cc, nm, argTys, retTy, methInst) + if varargs <> None then + dprintf "ignoring sentinel and varargs in ILMethodDef token signature" + MethodData(enclTy, cc, nm, argTys, retTy, methInst) -and seekReadFieldDefAsFieldSpec (ctxt: ILMetadataReader) idx = - ctxt.seekReadFieldDefAsFieldSpec idx +and seekReadFieldDefAsFieldSpec (ctxt: ILMetadataReader) idx = ctxt.seekReadFieldDefAsFieldSpec idx and seekReadFieldDefAsFieldSpecUncached ctxtH 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 = - seekReadIndexedRow (ctxt.getNumRows TableNames.TypeDef, - (fun i -> i, seekReadTypeDefRowWithExtents ctxt i), - (fun r -> r), - (fun (_, ((_, _, _, _, fieldsIdx, _), (endFieldsIdx, _))) -> - if endFieldsIdx <= idx then 1 - elif fieldsIdx <= idx && idx < endFieldsIdx then 0 - else -1), - 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 enclTy = seekReadTypeDefAsType ctxt AsObject (* not ok: see note *) finst tidx - - // Put it together. - mkILFieldSpecInTy(enclTy, nm, retTy) + 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 = + seekReadIndexedRow ( + ctxt.getNumRows TableNames.TypeDef, + (fun i -> i, seekReadTypeDefRowWithExtents ctxt i), + (fun r -> r), + (fun (_, ((_, _, _, _, fieldsIdx, _), (endFieldsIdx, _))) -> + if endFieldsIdx <= idx then + 1 + elif fieldsIdx <= idx && idx < endFieldsIdx then + 0 + else + -1), + 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 enclTy = seekReadTypeDefAsType ctxt AsObject (* not ok: see note *) finst tidx + + // Put it together. + mkILFieldSpecInTy (enclTy, nm, retTy) 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 - let codetype = implflags &&& 0x0003 - let unmanaged = (implflags &&& 0x0004) <> 0x0 - let internalcall = (implflags &&& 0x1000) <> 0x0 - let noinline = (implflags &&& 0x0008) <> 0x0 - let aggressiveinline = (implflags &&& 0x0100) <> 0x0 - let _generic, _genarity, cc, retTy, argTys, varargs = readBlobHeapAsMethodSig ctxt numTypars typeIdx - if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef signature" - - let endParamIdx = - if idx >= ctxt.getNumRows TableNames.Method then - ctxt.getNumRows TableNames.Param + 1 - else - let _, _, _, _, _, paramIdx = seekReadMethodRow ctxt mdv (idx + 1) - paramIdx - - 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 - methBodyNative - elif pinvoke then - seekReadImplMap ctxt nm idx - elif internalcall || abstr || unmanaged || (codetype <> 0x00) then - methBodyAbstract - else - 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) + 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 + let codetype = implflags &&& 0x0003 + let unmanaged = (implflags &&& 0x0004) <> 0x0 + let internalcall = (implflags &&& 0x1000) <> 0x0 + let noinline = (implflags &&& 0x0008) <> 0x0 + let aggressiveinline = (implflags &&& 0x0100) <> 0x0 + + let _generic, _genarity, cc, retTy, argTys, varargs = + readBlobHeapAsMethodSig ctxt numTypars typeIdx + + if varargs <> None then + dprintf "ignoring sentinel and varargs in ILMethodDef signature" + + let endParamIdx = + if idx >= ctxt.getNumRows TableNames.Method then + ctxt.getNumRows TableNames.Param + 1 + else + let _, _, _, _, _, paramIdx = seekReadMethodRow ctxt mdv (idx + 1) + paramIdx + + 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 + methBodyNative + elif pinvoke then + seekReadImplMap ctxt nm idx + elif internalcall || abstr || unmanaged || (codetype <> 0x00) then + methBodyAbstract + else + 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: ILMetadataReader) mdv (retTy, argTys) pidx1 pidx2 = let mutable retRes = mkILReturn retTy let paramsRes = argTys |> List.toArray |> Array.map mkILParamAnon + for i = pidx1 to pidx2 - 1 do seekReadParamExtras ctxt mdv (&retRes, paramsRes) i + retRes, List.ofArray paramsRes and seekReadParamExtras (ctxt: ILMetadataReader) mdv (retRes: byref, 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 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) - CustomAttrsStored = ctxt.customAttrsReader_ParamDef - MetadataIndex = idx} - elif seq > Array.length paramsRes then dprintn "bad seq num. for param" - else - paramsRes[seq - 1] <- - { paramsRes[seq - 1] with - Marshal=(if hasMarshal then Some (fmReader (TaggedIndex(hfm_ParamDef, idx))) else None) - Default = (if hasDefault then Some (seekReadConstant ctxt (TaggedIndex(hc_ParamDef, idx))) else None) - Name = readStringHeapOption ctxt nameIdx - IsIn = ((inOutMasked &&& 0x0001) <> 0x0) - IsOut = ((inOutMasked &&& 0x0002) <> 0x0) - IsOptional = ((inOutMasked &&& 0x0010) <> 0x0) - CustomAttrsStored = ctxt.customAttrsReader_ParamDef - MetadataIndex = idx } + 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 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) + CustomAttrsStored = ctxt.customAttrsReader_ParamDef + MetadataIndex = idx + } + elif seq > Array.length paramsRes then + dprintn "bad seq num. for param" + else + paramsRes[seq - 1] <- + { paramsRes[seq - 1] with + Marshal = + (if hasMarshal then + Some(fmReader (TaggedIndex(hfm_ParamDef, idx))) + else + None) + Default = + (if hasDefault then + Some(seekReadConstant ctxt (TaggedIndex(hc_ParamDef, idx))) + else + None) + Name = readStringHeapOption ctxt nameIdx + IsIn = ((inOutMasked &&& 0x0001) <> 0x0) + IsOut = ((inOutMasked &&& 0x0002) <> 0x0) + IsOptional = ((inOutMasked &&& 0x0010) <> 0x0) + CustomAttrsStored = ctxt.customAttrsReader_ParamDef + MetadataIndex = idx + } and seekReadMethodImpls (ctxt: ILMetadataReader) numTypars tidx = - mkILMethodImplsLazy - (lazy - 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(enclTy, cc, nm, argTys, retTy, methInst)) = seekReadMethodDefOrRefNoVarargs ctxt numTypars b - mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) - Overrides= - let (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) = seekReadMethodDefOrRefNoVarargs ctxt numTypars c - let mspec = mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) - OverridesSpec(mspec.MethodRef, mspec.DeclaringType) })) + mkILMethodImplsLazy ( + lazy + 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 (enclTy, cc, nm, argTys, retTy, methInst)) = + seekReadMethodDefOrRefNoVarargs ctxt numTypars b + + mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) + Overrides = + let (MethodData (enclTy, cc, nm, argTys, retTy, methInst)) = + seekReadMethodDefOrRefNoVarargs ctxt numTypars c + + let mspec = mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) + OverridesSpec(mspec.MethodRef, mspec.DeclaringType) + }) + ) and seekReadMultipleMethodSemantics (ctxt: ILMetadataReader) (flags, id) = - seekReadIndexedRows - (ctxt.getNumRows TableNames.MethodSemantics, - seekReadMethodSemanticsRow ctxt, - (fun (_flags, _, c) -> c), - hsCompare id, - isSorted ctxt TableNames.MethodSemantics, - (fun (a, b, _c) -> - let (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) = seekReadMethodDefAsMethodData ctxt b - a, (mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst)).MethodRef)) + seekReadIndexedRows ( + ctxt.getNumRows TableNames.MethodSemantics, + seekReadMethodSemanticsRow ctxt, + (fun (_flags, _, c) -> c), + hsCompare id, + isSorted ctxt TableNames.MethodSemantics, + (fun (a, b, _c) -> + let (MethodData (enclTy, cc, nm, argTys, retTy, methInst)) = + seekReadMethodDefAsMethodData ctxt b + + a, (mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst)).MethodRef) + ) |> List.filter (fun (flags2, _) -> flags = flags2) |> List.map snd - and seekReadOptionalMethodSemantics ctxt id = match seekReadMultipleMethodSemantics ctxt id with | [] -> None - | [h] -> Some h - | h :: _ -> dprintn "multiple method semantics found"; Some h + | [ h ] -> Some h + | h :: _ -> + dprintn "multiple method semantics found" + Some h and seekReadMethodSemantics ctxt id = match seekReadOptionalMethodSemantics ctxt id with @@ -2411,691 +3097,916 @@ and seekReadMethodSemantics ctxt id = | Some x -> x 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=seekReadOptionalMethodSemantics 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 mdv sorted according to ILTypeDef tokens and then doing a binary chop *) + 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 = seekReadOptionalMethodSemantics 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 mdv sorted according to ILTypeDef tokens and then doing a binary chop *) and seekReadEvents (ctxt: ILMetadataReader) numTypars tidx = - mkILEventsLazy - (lazy - 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 mdv (rowNum + 1) - endEventIdx - - [ if beginEventIdx > 0 then - for i in beginEventIdx .. endEventIdx - 1 do - yield seekReadEvent ctxt mdv numTypars i ]) + mkILEventsLazy ( + lazy + 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 mdv (rowNum + 1) + endEventIdx + + [ + if beginEventIdx > 0 then + for i in beginEventIdx .. endEventIdx - 1 do + yield seekReadEvent ctxt mdv numTypars i + ] + ) and seekReadProperty ctxt mdv numTypars idx = - let flags, nameIdx, typIdx = seekReadPropertyRow ctxt mdv idx - let cc, retTy, argTys = readBlobHeapAsPropertySig ctxt numTypars typIdx - let setter= seekReadOptionalMethodSemantics ctxt (0x0001, TaggedIndex(hs_Property, idx)) - let getter = seekReadOptionalMethodSemantics ctxt (0x0002, TaggedIndex(hs_Property, idx)) -(* NOTE: the "ThisConv" value on the property is not reliable: better to look on the getter/setter *) -(* NOTE: e.g. tlbimp on Office msword.olb seems to set this incorrectly *) - let cc2 = - match getter with - | Some mref -> mref.CallingConv.ThisConv - | None -> - match setter with - | Some mref -> mref.CallingConv .ThisConv - | None -> cc - - 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 ) + let flags, nameIdx, typIdx = seekReadPropertyRow ctxt mdv idx + let cc, retTy, argTys = readBlobHeapAsPropertySig ctxt numTypars typIdx + + let setter = + seekReadOptionalMethodSemantics ctxt (0x0001, TaggedIndex(hs_Property, idx)) + + let getter = + seekReadOptionalMethodSemantics ctxt (0x0002, TaggedIndex(hs_Property, idx)) + (* NOTE: the "ThisConv" value on the property is not reliable: better to look on the getter/setter *) + (* NOTE: e.g. tlbimp on Office msword.olb seems to set this incorrectly *) + let cc2 = + match getter with + | Some mref -> mref.CallingConv.ThisConv + | None -> + match setter with + | Some mref -> mref.CallingConv.ThisConv + | None -> cc + + 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: ILMetadataReader) numTypars tidx = - mkILPropertiesLazy - (lazy - 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 mdv (rowNum + 1) - endPropIdx - [ if beginPropIdx > 0 then - for i in beginPropIdx .. endPropIdx - 1 do - yield seekReadProperty ctxt mdv numTypars i ]) - - -and customAttrsReader ctxtH tag: ILAttributesStored = - mkILCustomAttrsReader - (fun idx -> - let (ctxt: ILMetadataReader) = getHole ctxtH + mkILPropertiesLazy ( + lazy let mdv = ctxt.mdfile.GetView() - let reader = - { new ISeekReadIndexedRowReader, ILAttribute> with - member _.GetRow(i, row) = seekReadCustomAttributeRow ctxt mdv i &row - member _.GetKey(attrRow) = attrRow.parentIndex - member _.CompareKey(key) = hcaCompare (TaggedIndex(tag, idx)) key - member _.ConvertRow(attrRow) = seekReadCustomAttr ctxt (attrRow.typeIndex, attrRow.valueIndex) - } - seekReadIndexedRowsByInterface (ctxt.getNumRows TableNames.CustomAttribute) (isSorted ctxt TableNames.CustomAttribute) reader) -and seekReadCustomAttr ctxt (TaggedIndex(cat, idx), b) = - ctxt.seekReadCustomAttr (CustomAttrIdx (cat, idx, b)) + 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 mdv (rowNum + 1) + endPropIdx + + [ + if beginPropIdx > 0 then + for i in beginPropIdx .. endPropIdx - 1 do + yield seekReadProperty ctxt mdv numTypars i + ] + ) + +and customAttrsReader ctxtH tag : ILAttributesStored = + mkILCustomAttrsReader (fun idx -> + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + + let reader = + { new ISeekReadIndexedRowReader, ILAttribute> with + member _.GetRow(i, row) = + seekReadCustomAttributeRow ctxt mdv i &row + + member _.GetKey(attrRow) = attrRow.parentIndex + + member _.CompareKey(key) = hcaCompare (TaggedIndex(tag, idx)) key + + member _.ConvertRow(attrRow) = + seekReadCustomAttr ctxt (attrRow.typeIndex, attrRow.valueIndex) + } + + seekReadIndexedRowsByInterface (ctxt.getNumRows TableNames.CustomAttribute) (isSorted ctxt TableNames.CustomAttribute) reader) + +and seekReadCustomAttr ctxt (TaggedIndex (cat, idx), b) = + ctxt.seekReadCustomAttr (CustomAttrIdx(cat, idx, b)) and seekReadCustomAttrUncached ctxtH (CustomAttrIdx (cat, idx, valIdx)) = let ctxt = getHole ctxtH let method = seekReadCustomAttrType ctxt (TaggedIndex(cat, idx)) + let data = match readBlobHeapOption ctxt valIdx with | Some bytes -> bytes - | None -> Bytes.ofInt32Array [| |] + | None -> Bytes.ofInt32Array [||] + let elements = [] - ILAttribute.Encoded (method, data, elements) + ILAttribute.Encoded(method, data, elements) and securityDeclsReader ctxtH tag = - mkILSecurityDeclsReader - (fun idx -> - let (ctxt: ILMetadataReader) = getHole ctxtH - let mdv = ctxt.mdfile.GetView() - seekReadIndexedRows (ctxt.getNumRows TableNames.Permission, - seekReadPermissionRow ctxt mdv, - (fun (_, par, _) -> par), - hdsCompare (TaggedIndex(tag,idx)), - isSorted ctxt TableNames.Permission, - (fun (act, _, ty) -> seekReadSecurityDecl ctxt (act, ty))) - |> List.toArray) + mkILSecurityDeclsReader (fun idx -> + let (ctxt: ILMetadataReader) = getHole ctxtH + let mdv = ctxt.mdfile.GetView() + + seekReadIndexedRows ( + ctxt.getNumRows TableNames.Permission, + seekReadPermissionRow ctxt mdv, + (fun (_, par, _) -> par), + hdsCompare (TaggedIndex(tag, idx)), + isSorted ctxt TableNames.Permission, + (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) + 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: ILMetadataReader) idx = - let kind, vidx = seekReadIndexedRow (ctxt.getNumRows TableNames.Constant, - seekReadConstantRow ctxt, - (fun (_, key, _) -> key), - hcCompare idx, isSorted ctxt TableNames.Constant, (fun (kind, _, v) -> kind, v)) - match kind with - | x when x = uint16 et_STRING -> - let blobHeap = readBlobHeap ctxt vidx - let s = Encoding.Unicode.GetString(blobHeap, 0, blobHeap.Length) - ILFieldInit.String s - | x when x = uint16 et_BOOLEAN -> ILFieldInit.Bool (readBlobHeapAsBool ctxt vidx) - | x when x = uint16 et_CHAR -> ILFieldInit.Char (readBlobHeapAsUInt16 ctxt vidx) - | x when x = uint16 et_I1 -> ILFieldInit.Int8 (readBlobHeapAsSByte ctxt vidx) - | x when x = uint16 et_I2 -> ILFieldInit.Int16 (readBlobHeapAsInt16 ctxt vidx) - | x when x = uint16 et_I4 -> ILFieldInit.Int32 (readBlobHeapAsInt32 ctxt vidx) - | x when x = uint16 et_I8 -> ILFieldInit.Int64 (readBlobHeapAsInt64 ctxt vidx) - | x when x = uint16 et_U1 -> ILFieldInit.UInt8 (readBlobHeapAsByte ctxt vidx) - | x when x = uint16 et_U2 -> ILFieldInit.UInt16 (readBlobHeapAsUInt16 ctxt vidx) - | x when x = uint16 et_U4 -> ILFieldInit.UInt32 (readBlobHeapAsUInt32 ctxt vidx) - | x when x = uint16 et_U8 -> ILFieldInit.UInt64 (readBlobHeapAsUInt64 ctxt vidx) - | x when x = uint16 et_R4 -> ILFieldInit.Single (readBlobHeapAsSingle ctxt vidx) - | x when x = uint16 et_R8 -> ILFieldInit.Double (readBlobHeapAsDouble ctxt vidx) - | x when x = uint16 et_CLASS || x = uint16 et_OBJECT -> ILFieldInit.Null - | _ -> ILFieldInit.Null + let kind, vidx = + seekReadIndexedRow ( + ctxt.getNumRows TableNames.Constant, + seekReadConstantRow ctxt, + (fun (_, key, _) -> key), + hcCompare idx, + isSorted ctxt TableNames.Constant, + (fun (kind, _, v) -> kind, v) + ) + + match kind with + | x when x = uint16 et_STRING -> + let blobHeap = readBlobHeap ctxt vidx + let s = Encoding.Unicode.GetString(blobHeap, 0, blobHeap.Length) + ILFieldInit.String s + | x when x = uint16 et_BOOLEAN -> ILFieldInit.Bool(readBlobHeapAsBool ctxt vidx) + | x when x = uint16 et_CHAR -> ILFieldInit.Char(readBlobHeapAsUInt16 ctxt vidx) + | x when x = uint16 et_I1 -> ILFieldInit.Int8(readBlobHeapAsSByte ctxt vidx) + | x when x = uint16 et_I2 -> ILFieldInit.Int16(readBlobHeapAsInt16 ctxt vidx) + | x when x = uint16 et_I4 -> ILFieldInit.Int32(readBlobHeapAsInt32 ctxt vidx) + | x when x = uint16 et_I8 -> ILFieldInit.Int64(readBlobHeapAsInt64 ctxt vidx) + | x when x = uint16 et_U1 -> ILFieldInit.UInt8(readBlobHeapAsByte ctxt vidx) + | x when x = uint16 et_U2 -> ILFieldInit.UInt16(readBlobHeapAsUInt16 ctxt vidx) + | x when x = uint16 et_U4 -> ILFieldInit.UInt32(readBlobHeapAsUInt32 ctxt vidx) + | x when x = uint16 et_U8 -> ILFieldInit.UInt64(readBlobHeapAsUInt64 ctxt vidx) + | x when x = uint16 et_R4 -> ILFieldInit.Single(readBlobHeapAsSingle ctxt vidx) + | x when x = uint16 et_R8 -> ILFieldInit.Double(readBlobHeapAsDouble ctxt vidx) + | x when x = uint16 et_CLASS || x = uint16 et_OBJECT -> ILFieldInit.Null + | _ -> ILFieldInit.Null and seekReadImplMap (ctxt: ILMetadataReader) nm midx = - lazy - MethodBody.PInvoke - (lazy - let mdv = ctxt.mdfile.GetView() - let flags, nameIdx, scopeIdx = seekReadIndexedRow (ctxt.getNumRows TableNames.ImplMap, - seekReadImplMapRow ctxt mdv, - (fun (_, m, _, _) -> m), - mfCompare (TaggedIndex(mf_MethodDef, midx)), - isSorted ctxt TableNames.ImplMap, - (fun (a, _, c, d) -> a, c, d)) - let cc = - let masked = flags &&& 0x0700 - if masked = 0x0000 then PInvokeCallingConvention.None - elif masked = 0x0200 then PInvokeCallingConvention.Cdecl - elif masked = 0x0300 then PInvokeCallingConvention.Stdcall - elif masked = 0x0400 then PInvokeCallingConvention.Thiscall - 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 - elif masked = 0x0002 then PInvokeCharEncoding.Ansi - 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 - elif masked = 0x1000 then PInvokeThrowOnUnmappableChar.Enabled - elif masked = 0x2000 then PInvokeThrowOnUnmappableChar.Disabled - else (dprintn "strange ThrowOnUnmappableChar"; PInvokeThrowOnUnmappableChar.UseAssembly) - - { CallingConv = cc - CharEncoding = enc - CharBestFit=bestfit - ThrowOnUnmappableChar=unmap - NoMangle = (flags &&& 0x0001) <> 0x0 - LastError = (flags &&& 0x0040) <> 0x0 - Name = - (match readStringHeapOption ctxt nameIdx with - | None -> nm - | Some nm2 -> nm2) - Where = seekReadModuleRef ctxt mdv scopeIdx }) + lazy + MethodBody.PInvoke( + lazy + let mdv = ctxt.mdfile.GetView() + + let flags, nameIdx, scopeIdx = + seekReadIndexedRow ( + ctxt.getNumRows TableNames.ImplMap, + seekReadImplMapRow ctxt mdv, + (fun (_, m, _, _) -> m), + mfCompare (TaggedIndex(mf_MethodDef, midx)), + isSorted ctxt TableNames.ImplMap, + (fun (a, _, c, d) -> a, c, d) + ) + + let cc = + let masked = flags &&& 0x0700 + + if masked = 0x0000 then + PInvokeCallingConvention.None + elif masked = 0x0200 then + PInvokeCallingConvention.Cdecl + elif masked = 0x0300 then + PInvokeCallingConvention.Stdcall + elif masked = 0x0400 then + PInvokeCallingConvention.Thiscall + 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 + elif masked = 0x0002 then + PInvokeCharEncoding.Ansi + 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 + elif masked = 0x1000 then + PInvokeThrowOnUnmappableChar.Enabled + elif masked = 0x2000 then + PInvokeThrowOnUnmappableChar.Disabled + else + (dprintn "strange ThrowOnUnmappableChar" + PInvokeThrowOnUnmappableChar.UseAssembly) + + { + CallingConv = cc + CharEncoding = enc + CharBestFit = bestfit + ThrowOnUnmappableChar = unmap + NoMangle = (flags &&& 0x0001) <> 0x0 + LastError = (flags &&& 0x0040) <> 0x0 + Name = + (match readStringHeapOption ctxt nameIdx with + | None -> nm + | Some nm2 -> nm2) + Where = seekReadModuleRef ctxt mdv scopeIdx + } + ) and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numTypars (sz: int) start seqpoints = - let labelsOfRawOffsets = Dictionary<_, _>(sz/2) - let ilOffsetsOfLabels = Dictionary<_, _>(sz/2) - - let rawToLabel rawOffset = - match labelsOfRawOffsets.TryGetValue rawOffset with - | true, l -> l - | _ -> - let lab = generateCodeLabel() - labelsOfRawOffsets[rawOffset] <- lab - lab - - let markAsInstructionStart rawOffset ilOffset = - let lab = rawToLabel rawOffset - ilOffsetsOfLabels[lab] <- ilOffset - - let ibuf = ResizeArray<_>(sz/2) - let mutable curr = 0 - let prefixes = { al=Aligned; tl= Normalcall; vol= Nonvolatile;ro=NormalAddress;constrained=None } - let mutable lastb = 0x0 - let mutable lastb2 = 0x0 - let mutable b = 0x0 - let get () = - lastb <- seekReadByteAsInt32 pev (start + curr) - curr <- curr + 1 - b <- - if lastb = 0xfe && curr < sz then - lastb2 <- seekReadByteAsInt32 pev (start + curr) - curr <- curr + 1 - lastb2 - else - lastb - - let mutable seqPointsRemaining = seqpoints - - while curr < sz do - // registering "+string !curr+" as start of an instruction") - markAsInstructionStart curr ibuf.Count - - // Insert any sequence points into the instruction sequence - while - (match seqPointsRemaining with - | (i, _tag) :: _rest when i <= curr -> true - | _ -> false) - do - // Emitting one sequence point - let _, tag = List.head seqPointsRemaining - seqPointsRemaining <- List.tail seqPointsRemaining - ibuf.Add (I_seqpoint tag) - - // Read the prefixes. Leave lastb and lastb2 holding the instruction byte(s) - begin - prefixes.al <- Aligned - prefixes.tl <- Normalcall - prefixes.vol <- Nonvolatile - prefixes.ro<-NormalAddress - prefixes.constrained<-None - get () - while curr < sz && - lastb = 0xfe && - (b = (i_constrained &&& 0xff) || - b = (i_readonly &&& 0xff) || - b = (i_unaligned &&& 0xff) || - b = (i_volatile &&& 0xff) || - b = (i_tail &&& 0xff)) do - begin - if b = (i_unaligned &&& 0xff) then - let unal = seekReadByteAsInt32 pev (start + curr) - curr <- curr + 1 - prefixes.al <- - if unal = 0x1 then Unaligned1 - elif unal = 0x2 then Unaligned2 - elif unal = 0x4 then Unaligned4 - else (dprintn "bad alignment for unaligned"; Aligned) - 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 pev (start + curr) - curr <- curr + 4 - let ty = seekReadTypeDefOrRef ctxt numTypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec uncoded) - prefixes.constrained <- Some ty - else prefixes.tl <- Tailcall - end + let labelsOfRawOffsets = Dictionary<_, _>(sz / 2) + let ilOffsetsOfLabels = Dictionary<_, _>(sz / 2) + + let rawToLabel rawOffset = + match labelsOfRawOffsets.TryGetValue rawOffset with + | true, l -> l + | _ -> + let lab = generateCodeLabel () + labelsOfRawOffsets[rawOffset] <- lab + lab + + let markAsInstructionStart rawOffset ilOffset = + let lab = rawToLabel rawOffset + ilOffsetsOfLabels[lab] <- ilOffset + + let ibuf = ResizeArray<_>(sz / 2) + let mutable curr = 0 + + let prefixes = + { + al = Aligned + tl = Normalcall + vol = Nonvolatile + ro = NormalAddress + constrained = None + } + + let mutable lastb = 0x0 + let mutable lastb2 = 0x0 + let mutable b = 0x0 + + let get () = + lastb <- seekReadByteAsInt32 pev (start + curr) + curr <- curr + 1 + + b <- + if lastb = 0xfe && curr < sz then + lastb2 <- seekReadByteAsInt32 pev (start + curr) + curr <- curr + 1 + lastb2 + else + lastb + + let mutable seqPointsRemaining = seqpoints + + while curr < sz do + // registering "+string !curr+" as start of an instruction") + markAsInstructionStart curr ibuf.Count + + // Insert any sequence points into the instruction sequence + while (match seqPointsRemaining with + | (i, _tag) :: _rest when i <= curr -> true + | _ -> false) do + // Emitting one sequence point + let _, tag = List.head seqPointsRemaining + seqPointsRemaining <- List.tail seqPointsRemaining + ibuf.Add(I_seqpoint tag) + + // Read the prefixes. Leave lastb and lastb2 holding the instruction byte(s) + (prefixes.al <- Aligned + prefixes.tl <- Normalcall + prefixes.vol <- Nonvolatile + prefixes.ro <- NormalAddress + prefixes.constrained <- None get () - end - - // data for instruction begins at "+string !curr - // Read and decode the instruction - if (curr <= sz) then - let idecoder = - if lastb = 0xfe then getTwoByteInstr lastb2 - else getOneByteInstr lastb - let instr = - match idecoder with - | I_u16_u8_instr f -> - let x = seekReadByte pev (start + curr) |> uint16 - curr <- curr + 1 - f prefixes x - | I_u16_u16_instr f -> - 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 pev (start + curr) - curr <- curr + 8 - f prefixes x - | I_i32_i8_instr f -> - let x = seekReadSByte pev (start + curr) |> int32 - curr <- curr + 1 - f prefixes x - | I_i32_i32_instr f -> - let x = seekReadInt32 pev (start + curr) - curr <- curr + 4 - f prefixes x - | I_r4_instr f -> - let x = seekReadSingle pev (start + curr) - curr <- curr + 4 - f prefixes x - | I_r8_instr f -> - let x = seekReadDouble pev (start + curr) - curr <- curr + 8 - f prefixes x - | I_field_instr f -> - let tab, tok = seekReadUncodedToken pev (start + curr) - curr <- curr + 4 - let fspec = - if tab = TableNames.Field then - seekReadFieldDefAsFieldSpec ctxt tok - elif tab = TableNames.MemberRef then - seekReadMemberRefAsFieldSpec ctxt numTypars tok - else failwith "bad table in FieldDefOrRef" - f prefixes fspec - | I_method_instr f -> - // method instruction, curr = "+string !curr - - let tab, idx = seekReadUncodedToken pev (start + curr) - curr <- curr + 4 - let (VarArgMethodData(enclTy, cc, nm, argTys, varargs, retTy, methInst)) = - if tab = TableNames.Method then - seekReadMethodDefOrRef ctxt numTypars (TaggedIndex(mdor_MethodDef, idx)) - elif tab = TableNames.MemberRef then - seekReadMethodDefOrRef ctxt numTypars (TaggedIndex(mdor_MemberRef, idx)) - elif tab = TableNames.MethodSpec then - seekReadMethodSpecAsMethodData ctxt numTypars idx - else failwith "bad table in MethodDefOrRefOrSpec" - match enclTy with - | ILType.Array (shape, ty) -> - match nm with - | "Get" -> I_ldelem_any(shape, ty) - | "Set" -> I_stelem_any(shape, ty) - | "Address" -> I_ldelema(prefixes.ro, false, shape, ty) - | ".ctor" -> I_newarr(shape, ty) - | _ -> failwith "bad method on array type" - | _ -> - let mspec = mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) - f prefixes (mspec, varargs) - | I_type_instr f -> - let uncoded = seekReadUncodedToken pev (start + curr) - curr <- curr + 4 - let ty = seekReadTypeDefOrRef ctxt numTypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec uncoded) - f prefixes ty - | I_string_instr f -> - 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 pev (start + curr)) - curr <- curr + 4 - let dest = curr + offsDest - f prefixes (rawToLabel dest) - | I_conditional_i8_instr f -> - 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 pev (start + curr)) - curr <- curr + 4 - let dest = curr + offsDest - f prefixes (rawToLabel dest) - | I_unconditional_i8_instr f -> - let offsDest = int (seekReadSByte pev (start + curr)) - curr <- curr + 1 - let dest = curr + offsDest - f prefixes (rawToLabel dest) - | I_invalid_instr -> - dprintn ("invalid instruction: "+string lastb+ (if lastb = 0xfe then ", "+string lastb2 else "")) - I_ret - | I_tok_instr f -> - 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 = - if tab = TableNames.Method || tab = TableNames.MemberRef (* REVIEW: generics or tab = TableNames.MethodSpec *) then - let (MethodData(enclTy, cc, nm, argTys, retTy, methInst)) = seekReadMethodDefOrRefNoVarargs ctxt numTypars (uncodedTokenToMethodDefOrRef (tab, idx)) - ILToken.ILMethod (mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst)) - elif tab = TableNames.Field then - ILToken.ILField (seekReadFieldDefAsFieldSpec ctxt idx) - elif tab = TableNames.TypeDef || tab = TableNames.TypeRef || tab = TableNames.TypeSpec then - ILToken.ILType (seekReadTypeDefOrRef ctxt numTypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec (tab, idx))) - else failwith "bad token for ldtoken" - f prefixes token_info - | I_sig_instr f -> - 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 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 pev (start + curr)) - curr <- curr + 4 - let offsets = - List.init n (fun _ -> - let i = (seekReadInt32 pev (start + curr)) - curr <- curr + 4 - i) - let dests = List.map (fun offs -> rawToLabel (curr + offs)) offsets - f prefixes dests - ibuf.Add instr - done - // Finished reading instructions - mark the end of the instruction stream in case the PDB information refers to it. - markAsInstructionStart curr ibuf.Count - // Build the function that maps from raw labels (offsets into the bytecode stream) to indexes in the AbsIL instruction stream - let lab2pc = ilOffsetsOfLabels - - // Some offsets used in debug info refer to the end of an instruction, rather than the - // start of the subsequent instruction. But all labels refer to instruction starts, - // apart from a final label which refers to the end of the method. This function finds - // the start of the next instruction referred to by the raw offset. - let raw2nextLab rawOffset = - let isInstrStart x = - match labelsOfRawOffsets.TryGetValue x with - | true, lab -> ilOffsetsOfLabels.ContainsKey lab - | _ -> false - if isInstrStart rawOffset then rawToLabel rawOffset - elif isInstrStart (rawOffset+1) then rawToLabel (rawOffset+1) - else failwith ("the bytecode raw offset "+string rawOffset+" did not refer either to the start or end of an instruction") - let instrs = ibuf.ToArray() - instrs, rawToLabel, lab2pc, raw2nextLab + + while curr < sz + && lastb = 0xfe + && (b = (i_constrained &&& 0xff) + || b = (i_readonly &&& 0xff) + || b = (i_unaligned &&& 0xff) + || b = (i_volatile &&& 0xff) + || b = (i_tail &&& 0xff)) do + (if b = (i_unaligned &&& 0xff) then + let unal = seekReadByteAsInt32 pev (start + curr) + curr <- curr + 1 + + prefixes.al <- + if unal = 0x1 then + Unaligned1 + elif unal = 0x2 then + Unaligned2 + elif unal = 0x4 then + Unaligned4 + else + (dprintn "bad alignment for unaligned" + Aligned) + 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 pev (start + curr) + curr <- curr + 4 + + let ty = + seekReadTypeDefOrRef ctxt numTypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec uncoded) + + prefixes.constrained <- Some ty + else + prefixes.tl <- Tailcall) + + get ()) + + // data for instruction begins at "+string !curr + // Read and decode the instruction + if (curr <= sz) then + let idecoder = + if lastb = 0xfe then + getTwoByteInstr lastb2 + else + getOneByteInstr lastb + + let instr = + match idecoder with + | I_u16_u8_instr f -> + let x = seekReadByte pev (start + curr) |> uint16 + curr <- curr + 1 + f prefixes x + | I_u16_u16_instr f -> + 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 pev (start + curr) + curr <- curr + 8 + f prefixes x + | I_i32_i8_instr f -> + let x = seekReadSByte pev (start + curr) |> int32 + curr <- curr + 1 + f prefixes x + | I_i32_i32_instr f -> + let x = seekReadInt32 pev (start + curr) + curr <- curr + 4 + f prefixes x + | I_r4_instr f -> + let x = seekReadSingle pev (start + curr) + curr <- curr + 4 + f prefixes x + | I_r8_instr f -> + let x = seekReadDouble pev (start + curr) + curr <- curr + 8 + f prefixes x + | I_field_instr f -> + let tab, tok = seekReadUncodedToken pev (start + curr) + curr <- curr + 4 + + let fspec = + if tab = TableNames.Field then + seekReadFieldDefAsFieldSpec ctxt tok + elif tab = TableNames.MemberRef then + seekReadMemberRefAsFieldSpec ctxt numTypars tok + else + failwith "bad table in FieldDefOrRef" + + f prefixes fspec + | I_method_instr f -> + // method instruction, curr = "+string !curr + + let tab, idx = seekReadUncodedToken pev (start + curr) + curr <- curr + 4 + + let (VarArgMethodData (enclTy, cc, nm, argTys, varargs, retTy, methInst)) = + if tab = TableNames.Method then + seekReadMethodDefOrRef ctxt numTypars (TaggedIndex(mdor_MethodDef, idx)) + elif tab = TableNames.MemberRef then + seekReadMethodDefOrRef ctxt numTypars (TaggedIndex(mdor_MemberRef, idx)) + elif tab = TableNames.MethodSpec then + seekReadMethodSpecAsMethodData ctxt numTypars idx + else + failwith "bad table in MethodDefOrRefOrSpec" + + match enclTy with + | ILType.Array (shape, ty) -> + match nm with + | "Get" -> I_ldelem_any(shape, ty) + | "Set" -> I_stelem_any(shape, ty) + | "Address" -> I_ldelema(prefixes.ro, false, shape, ty) + | ".ctor" -> I_newarr(shape, ty) + | _ -> failwith "bad method on array type" + | _ -> + let mspec = mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst) + f prefixes (mspec, varargs) + | I_type_instr f -> + let uncoded = seekReadUncodedToken pev (start + curr) + curr <- curr + 4 + + let ty = + seekReadTypeDefOrRef ctxt numTypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec uncoded) + + f prefixes ty + | I_string_instr f -> + 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 pev (start + curr)) + curr <- curr + 4 + let dest = curr + offsDest + f prefixes (rawToLabel dest) + | I_conditional_i8_instr f -> + 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 pev (start + curr)) + curr <- curr + 4 + let dest = curr + offsDest + f prefixes (rawToLabel dest) + | I_unconditional_i8_instr f -> + let offsDest = int (seekReadSByte pev (start + curr)) + curr <- curr + 1 + let dest = curr + offsDest + f prefixes (rawToLabel dest) + | I_invalid_instr -> + dprintn ( + "invalid instruction: " + + string lastb + + (if lastb = 0xfe then + ", " + string lastb2 + else + "") + ) + + I_ret + | I_tok_instr f -> + 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 = + if tab = TableNames.Method + || tab = TableNames.MemberRef (* REVIEW: generics or tab = TableNames.MethodSpec *) then + let (MethodData (enclTy, cc, nm, argTys, retTy, methInst)) = + seekReadMethodDefOrRefNoVarargs ctxt numTypars (uncodedTokenToMethodDefOrRef (tab, idx)) + + ILToken.ILMethod(mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst)) + elif tab = TableNames.Field then + ILToken.ILField(seekReadFieldDefAsFieldSpec ctxt idx) + elif tab = TableNames.TypeDef + || tab = TableNames.TypeRef + || tab = TableNames.TypeSpec then + ILToken.ILType(seekReadTypeDefOrRef ctxt numTypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec (tab, idx))) + else + failwith "bad token for ldtoken" + + f prefixes token_info + | I_sig_instr f -> + 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 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 pev (start + curr)) + curr <- curr + 4 + + let offsets = + List.init n (fun _ -> + let i = (seekReadInt32 pev (start + curr)) + curr <- curr + 4 + i) + + let dests = List.map (fun offs -> rawToLabel (curr + offs)) offsets + f prefixes dests + + ibuf.Add instr + // Finished reading instructions - mark the end of the instruction stream in case the PDB information refers to it. + markAsInstructionStart curr ibuf.Count + // Build the function that maps from raw labels (offsets into the bytecode stream) to indexes in the AbsIL instruction stream + let lab2pc = ilOffsetsOfLabels + + // Some offsets used in debug info refer to the end of an instruction, rather than the + // start of the subsequent instruction. But all labels refer to instruction starts, + // apart from a final label which refers to the end of the method. This function finds + // the start of the next instruction referred to by the raw offset. + let raw2nextLab rawOffset = + let isInstrStart x = + match labelsOfRawOffsets.TryGetValue x with + | true, lab -> ilOffsetsOfLabels.ContainsKey lab + | _ -> false + + if isInstrStart rawOffset then + rawToLabel rawOffset + elif isInstrStart (rawOffset + 1) then + rawToLabel (rawOffset + 1) + else + failwith ( + "the bytecode raw offset " + + string rawOffset + + " did not refer either to the start or end of an instruction" + ) + + let instrs = ibuf.ToArray() + instrs, rawToLabel, lab2pc, raw2nextLab #if FX_NO_PDB_READER and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (_idx, nm, _internalcall, noinline, aggressiveinline, numTypars) rva = #else and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _internalcall, noinline, aggressiveinline, numTypars) rva = #endif - lazy - let pev = pectxt.pefile.GetView() - let baseRVA = pectxt.anyV2P("method rva", rva) - // ": reading body of method "+nm+" at rva "+string rva+", phys "+string baseRVA - let b = seekReadByte pev baseRVA - - let isTinyFormat = (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_TinyFormat - let isFatFormat = (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_FatFormat - - if not isTinyFormat && not isFatFormat then - if logging then failwith "unknown format" - MethodBody.Abstract - else - - MethodBody.IL - (lazy - 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) - // -- an overall range for the method - // -- the sequence points for the method - let localPdbInfos, methRangePdbInfo, seqpoints = + lazy + let pev = pectxt.pefile.GetView() + let baseRVA = pectxt.anyV2P ("method rva", rva) + // ": reading body of method "+nm+" at rva "+string rva+", phys "+string baseRVA + let b = seekReadByte pev baseRVA + + let isTinyFormat = (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_TinyFormat + let isFatFormat = (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_FatFormat + + if not isTinyFormat && not isFatFormat then + if logging then + failwith "unknown format" + + MethodBody.Abstract + else + + MethodBody.IL( + lazy + 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) + // -- an overall range for the method + // -- the sequence points for the method + let localPdbInfos, methRangePdbInfo, seqpoints = #if FX_NO_PDB_READER - [], None, [] + [], None, [] #else - match pectxt.pdb with - | None -> - [], None, [] - | Some (pdbr, get_doc) -> - try - - let pdbm = pdbReaderGetMethod pdbr (uncodedToken TableNames.Method idx) - let sps = pdbMethodGetDebugPoints pdbm - (* let roota, rootb = pdbScopeGetOffsets rootScope in *) - let seqpoints = - let arr = - sps |> Array.map (fun sp -> - // It is VERY annoying to have to call GetURL for the document for - // each sequence point. This appears to be a short coming of the PDB - // reader API. They should return an index into the array of documents for the reader - let sourcedoc = get_doc (pdbDocumentGetURL sp.pdbSeqPointDocument) - let source = - ILDebugPoint.Create(document = sourcedoc, - line = sp.pdbSeqPointLine, - column = sp.pdbSeqPointColumn, - endLine = sp.pdbSeqPointEndLine, - endColumn = sp.pdbSeqPointEndColumn) - (sp.pdbSeqPointOffset, source)) - - Array.sortInPlaceBy fst arr - - Array.toList arr - - let rec scopes scp = - let a, b = pdbScopeGetOffsets scp - let lvs = pdbScopeGetLocals scp - let ilvs = - lvs - |> Array.toList - |> List.filter (fun l -> - let k, _idx = pdbVariableGetAddressAttributes l - k = 1 (* ADDR_IL_OFFSET *)) - let ilinfos: ILLocalDebugMapping list = - ilvs |> List.map (fun ilv -> - let _k, idx = pdbVariableGetAddressAttributes ilv - let n = pdbVariableGetName ilv - { LocalIndex= idx - LocalName=n}) - - let thisOne = - (fun raw2nextLab -> - { Range= (raw2nextLab a, raw2nextLab b) - DebugMappings = ilinfos }: ILLocalDebugInfo ) - let others = List.foldBack (scopes >> (@)) (Array.toList (pdbScopeGetChildren scp)) [] - thisOne :: others - let localPdbInfos = [] (* scopes fail for mscorlib scopes rootScope *) - // REVIEW: look through sps to get ranges? Use GetRanges?? Change AbsIL?? - (localPdbInfos, None, seqpoints) - with e -> - // "* Warning: PDB info for method "+nm+" could not be read and will be ignored: "+e.Message - [], None, [] + match pectxt.pdb with + | None -> [], None, [] + | Some (pdbr, get_doc) -> + try + + let pdbm = pdbReaderGetMethod pdbr (uncodedToken TableNames.Method idx) + let sps = pdbMethodGetDebugPoints pdbm + (* let roota, rootb = pdbScopeGetOffsets rootScope in *) + let seqpoints = + let arr = + sps + |> Array.map (fun sp -> + // It is VERY annoying to have to call GetURL for the document for + // each sequence point. This appears to be a short coming of the PDB + // reader API. They should return an index into the array of documents for the reader + let sourcedoc = get_doc (pdbDocumentGetURL sp.pdbSeqPointDocument) + + let source = + ILDebugPoint.Create( + document = sourcedoc, + line = sp.pdbSeqPointLine, + column = sp.pdbSeqPointColumn, + endLine = sp.pdbSeqPointEndLine, + endColumn = sp.pdbSeqPointEndColumn + ) + + (sp.pdbSeqPointOffset, source)) + + Array.sortInPlaceBy fst arr + + Array.toList arr + + let rec scopes scp = + let a, b = pdbScopeGetOffsets scp + let lvs = pdbScopeGetLocals scp + + let ilvs = + lvs + |> Array.toList + |> List.filter (fun l -> + let k, _idx = pdbVariableGetAddressAttributes l + k = 1 (* ADDR_IL_OFFSET *) ) + + let ilinfos: ILLocalDebugMapping list = + ilvs + |> List.map (fun ilv -> + let _k, idx = pdbVariableGetAddressAttributes ilv + let n = pdbVariableGetName ilv + { LocalIndex = idx; LocalName = n }) + + let thisOne = + (fun raw2nextLab -> + { + Range = (raw2nextLab a, raw2nextLab b) + DebugMappings = ilinfos + }: ILLocalDebugInfo) + + let others = + List.foldBack (scopes >> (@)) (Array.toList (pdbScopeGetChildren scp)) [] + + thisOne :: others + + let localPdbInfos = + [] (* scopes fail for mscorlib scopes rootScope *) + // REVIEW: look through sps to get ranges? Use GetRanges?? Change AbsIL?? + (localPdbInfos, None, seqpoints) + with + | e -> + // "* Warning: PDB info for method "+nm+" could not be read and will be ignored: "+e.Message + [], None, [] #endif - if isTinyFormat then - let codeBase = baseRVA + 1 - let codeSize = (int32 b >>>& 2) - // tiny format for "+nm+", code size = " + string codeSize) - 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 - - { - IsZeroInit=false - MaxStack= 8 - NoInlining=noinline - AggressiveInlining=aggressiveinline - Locals=List.empty - Code=code - DebugRange=methRangePdbInfo - DebugImports=None - } - - else - let hasMoreSections = (b &&& e_CorILMethod_MoreSects) <> 0x0uy - let initlocals = (b &&& e_CorILMethod_InitLocals) <> 0x0uy - 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 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 pev mdv numTypars codeSize codeBase seqpoints - - // Read all the sections that follow the method body. - // These contain the exception clauses. - let mutable nextSectionBase = align 4 (codeBase + codeSize) - let mutable moreSections = hasMoreSections - let mutable seh = [] - while moreSections do - let sectionBase = nextSectionBase - 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 pev sectionBase) >>>& 8 - // bigSize = "+string bigSize) - let clauses = - if (sectionFlag &&& e_CorILMethod_Sect_EHTable) <> 0x0uy then - // WORKAROUND: The ECMA spec says this should be - // let numClauses = ((bigSize - 4) / 24) in - // but the CCI IL generator generates multiples of 24 - let numClauses = (bigSize / 24) - - List.init numClauses (fun i -> - let clauseBase = sectionBase + 4 + (i * 24) - 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 pev (sectionBase + 0x01) - let clauses = - if (sectionFlag &&& e_CorILMethod_Sect_EHTable) <> 0x0uy then - // WORKAROUND: The ECMA spec says this should be - // let numClauses = ((smallSize - 4) / 12) in - // but the C# compiler (or some IL generator) generates multiples of 12 - let numClauses = (smallSize / 12) - // dprintn (nm+" has " + string numClauses + " tiny seh clauses") - List.init numClauses (fun i -> - let clauseBase = sectionBase + 4 + (i * 12) - let kind = seekReadUInt16AsInt32 pev (clauseBase + 0) - if logging then dprintn ("One tiny SEH clause, kind = "+string kind) - 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 - [] - smallSize, clauses - - // Morph together clauses that cover the same range - let sehClauses = - let sehMap = Dictionary<_, _>(clauses.Length, HashIdentity.Structural) - - for (kind, st1, sz1, st2, sz2, extra) in clauses do - let tryStart = rawToLabel st1 - let tryFinish = rawToLabel (st1 + sz1) - let handlerStart = rawToLabel st2 - let handlerFinish = rawToLabel (st2 + sz2) - let clause = - if kind = e_COR_ILEXCEPTION_CLAUSE_EXCEPTION then - ILExceptionClause.TypeCatch(seekReadTypeDefOrRef ctxt numTypars AsObject List.empty (uncodedTokenToTypeDefOrRefOrSpec (i32ToUncodedToken extra)), (handlerStart, handlerFinish) ) - elif kind = e_COR_ILEXCEPTION_CLAUSE_FILTER then - let filterStart = rawToLabel extra - let filterFinish = handlerStart - ILExceptionClause.FilterCatch((filterStart, filterFinish), (handlerStart, handlerFinish)) - elif kind = e_COR_ILEXCEPTION_CLAUSE_FINALLY then - ILExceptionClause.Finally(handlerStart, handlerFinish) - elif kind = e_COR_ILEXCEPTION_CLAUSE_FAULT then - ILExceptionClause.Fault(handlerStart, handlerFinish) - else begin - dprintn (ctxt.fileName + ": unknown exception handler kind: "+string kind) - ILExceptionClause.Finally(handlerStart, handlerFinish) - end - - let key = (tryStart, tryFinish) - match sehMap.TryGetValue key with - | true, prev -> sehMap[key] <- prev @ [clause] - | _ -> sehMap[key] <- [clause] - - ([], sehMap) ||> Seq.fold (fun acc (KeyValue(key, bs)) -> [ for b in bs -> {Range=key; Clause=b}: ILExceptionSpec ] @ acc) - seh <- sehClauses - moreSections <- (sectionFlag &&& e_CorILMethod_Sect_MoreSects) <> 0x0uy - nextSectionBase <- sectionBase + sectionSize - - // Convert the linear code format to the nested code format - if logging then dprintn "doing localPdbInfos2" - let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos - if logging then dprintn "done localPdbInfos2, checking code..." - let code = buildILCode nm lab2pc instrs seh localPdbInfos2 - if logging then dprintn "done checking code." - { - IsZeroInit=initlocals - MaxStack= maxstack - NoInlining=noinline - AggressiveInlining=aggressiveinline - Locals = locals - Code=code - DebugRange=methRangePdbInfo - DebugImports = None - }) + if isTinyFormat then + let codeBase = baseRVA + 1 + let codeSize = (int32 b >>>& 2) + // tiny format for "+nm+", code size = " + string codeSize) + 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 + + { + IsZeroInit = false + MaxStack = 8 + NoInlining = noinline + AggressiveInlining = aggressiveinline + Locals = List.empty + Code = code + DebugRange = methRangePdbInfo + DebugImports = None + } + + else + let hasMoreSections = (b &&& e_CorILMethod_MoreSects) <> 0x0uy + let initlocals = (b &&& e_CorILMethod_InitLocals) <> 0x0uy + 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 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 pev mdv numTypars codeSize codeBase seqpoints + + // Read all the sections that follow the method body. + // These contain the exception clauses. + let mutable nextSectionBase = align 4 (codeBase + codeSize) + let mutable moreSections = hasMoreSections + let mutable seh = [] + + while moreSections do + let sectionBase = nextSectionBase + 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 pev sectionBase) >>>& 8 + // bigSize = "+string bigSize) + let clauses = + if (sectionFlag &&& e_CorILMethod_Sect_EHTable) <> 0x0uy then + // WORKAROUND: The ECMA spec says this should be + // let numClauses = ((bigSize - 4) / 24) in + // but the CCI IL generator generates multiples of 24 + let numClauses = (bigSize / 24) + + List.init numClauses (fun i -> + let clauseBase = sectionBase + 4 + (i * 24) + 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 pev (sectionBase + 0x01) + + let clauses = + if (sectionFlag &&& e_CorILMethod_Sect_EHTable) <> 0x0uy then + // WORKAROUND: The ECMA spec says this should be + // let numClauses = ((smallSize - 4) / 12) in + // but the C# compiler (or some IL generator) generates multiples of 12 + let numClauses = (smallSize / 12) + // dprintn (nm+" has " + string numClauses + " tiny seh clauses") + List.init numClauses (fun i -> + let clauseBase = sectionBase + 4 + (i * 12) + let kind = seekReadUInt16AsInt32 pev (clauseBase + 0) + + if logging then + dprintn ("One tiny SEH clause, kind = " + string kind) + + 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 + [] + + smallSize, clauses + + // Morph together clauses that cover the same range + let sehClauses = + let sehMap = Dictionary<_, _>(clauses.Length, HashIdentity.Structural) + + for (kind, st1, sz1, st2, sz2, extra) in clauses do + let tryStart = rawToLabel st1 + let tryFinish = rawToLabel (st1 + sz1) + let handlerStart = rawToLabel st2 + let handlerFinish = rawToLabel (st2 + sz2) + + let clause = + if kind = e_COR_ILEXCEPTION_CLAUSE_EXCEPTION then + ILExceptionClause.TypeCatch( + seekReadTypeDefOrRef + ctxt + numTypars + AsObject + List.empty + (uncodedTokenToTypeDefOrRefOrSpec (i32ToUncodedToken extra)), + (handlerStart, handlerFinish) + ) + elif kind = e_COR_ILEXCEPTION_CLAUSE_FILTER then + let filterStart = rawToLabel extra + let filterFinish = handlerStart + ILExceptionClause.FilterCatch((filterStart, filterFinish), (handlerStart, handlerFinish)) + elif kind = e_COR_ILEXCEPTION_CLAUSE_FINALLY then + ILExceptionClause.Finally(handlerStart, handlerFinish) + elif kind = e_COR_ILEXCEPTION_CLAUSE_FAULT then + ILExceptionClause.Fault(handlerStart, handlerFinish) + else + (dprintn (ctxt.fileName + ": unknown exception handler kind: " + string kind) + ILExceptionClause.Finally(handlerStart, handlerFinish)) + + let key = (tryStart, tryFinish) + + match sehMap.TryGetValue key with + | true, prev -> sehMap[key] <- prev @ [ clause ] + | _ -> sehMap[key] <- [ clause ] + + ([], sehMap) + ||> Seq.fold (fun acc (KeyValue (key, bs)) -> + [ for b in bs -> { Range = key; Clause = b }: ILExceptionSpec ] @ acc) + + seh <- sehClauses + moreSections <- (sectionFlag &&& e_CorILMethod_Sect_MoreSects) <> 0x0uy + nextSectionBase <- sectionBase + sectionSize + + // Convert the linear code format to the nested code format + if logging then + dprintn "doing localPdbInfos2" + + let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos + + if logging then + dprintn "done localPdbInfos2, checking code..." + + let code = buildILCode nm lab2pc instrs seh localPdbInfos2 + + if logging then + dprintn "done checking code." + + { + IsZeroInit = initlocals + MaxStack = maxstack + NoInlining = noinline + AggressiveInlining = aggressiveinline + Locals = locals + Code = code + DebugRange = methRangePdbInfo + DebugImports = None + } + ) 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.fileName + ": int32AsILVariantType ctxt: unexpected variant type, n = "+string n) ; ILNativeVariant.Empty) + 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.fileName + + ": int32AsILVariantType ctxt: unexpected variant type, n = " + + string n + ) + + ILNativeVariant.Empty) and readBlobHeapAsNativeType ctxt blobIdx = // reading native type blob "+string blobIdx) @@ -3106,9 +4017,11 @@ and readBlobHeapAsNativeType ctxt blobIdx = and sigptrGetILNativeType ctxt bytes sigptr : ILNativeType * int = // reading native type blob, sigptr= "+string sigptr) let ntbyte, sigptr = sigptrGetByte bytes sigptr + if List.memAssoc ntbyte (Lazy.force ILNativeTypeMap) then List.assoc ntbyte (Lazy.force ILNativeTypeMap), sigptr - elif ntbyte = 0x0uy then ILNativeType.Empty, sigptr + elif ntbyte = 0x0uy then + ILNativeType.Empty, sigptr elif ntbyte = nt_CUSTOMMARSHALER then // reading native type blob CM1, sigptr= "+string sigptr+ ", bytes.Length = "+string bytes.Length) let struct (guidLen, sigptr) = sigptrGetZInt32 bytes sigptr @@ -3128,189 +4041,256 @@ and sigptrGetILNativeType ctxt bytes sigptr : ILNativeType * int = // reading native type blob CM8, sigptr= "+string sigptr+", cookieStringLen = "+string ( cookieStringLen)) let cookieString, sigptr = sigptrGetBytes cookieStringLen bytes sigptr // reading native type blob CM9, sigptr= "+string sigptr) - ILNativeType.Custom (guid, nativeTypeName, custMarshallerName, cookieString), sigptr + ILNativeType.Custom(guid, nativeTypeName, custMarshallerName, cookieString), sigptr elif ntbyte = nt_FIXEDSYSSTRING then - let struct (i, sigptr) = sigptrGetZInt32 bytes sigptr - ILNativeType.FixedSysString i, sigptr + let struct (i, sigptr) = sigptrGetZInt32 bytes sigptr + ILNativeType.FixedSysString i, sigptr elif ntbyte = nt_FIXEDARRAY then - let struct (i, sigptr) = sigptrGetZInt32 bytes sigptr - ILNativeType.FixedArray i, sigptr + let struct (i, sigptr) = sigptrGetZInt32 bytes sigptr + ILNativeType.FixedArray i, sigptr elif ntbyte = nt_SAFEARRAY then - (if sigptr >= bytes.Length then - ILNativeType.SafeArray(ILNativeVariant.Empty, None), sigptr - else - let struct (i, sigptr) = sigptrGetZInt32 bytes sigptr - if sigptr >= bytes.Length then - ILNativeType.SafeArray (int32AsILVariantType ctxt i, None), sigptr + (if sigptr >= bytes.Length then + ILNativeType.SafeArray(ILNativeVariant.Empty, None), sigptr else - let struct (len, sigptr) = sigptrGetZInt32 bytes sigptr - let s, sigptr = sigptrGetString len bytes sigptr - ILNativeType.SafeArray (int32AsILVariantType ctxt i, Some s), sigptr) + let struct (i, sigptr) = sigptrGetZInt32 bytes sigptr + + if sigptr >= bytes.Length then + ILNativeType.SafeArray(int32AsILVariantType ctxt i, None), sigptr + else + let struct (len, sigptr) = sigptrGetZInt32 bytes sigptr + let s, sigptr = sigptrGetString len bytes sigptr + ILNativeType.SafeArray(int32AsILVariantType ctxt i, Some s), sigptr) elif ntbyte = nt_ARRAY then - if sigptr >= bytes.Length then - ILNativeType.Array(None, None), sigptr - else - let nt, sigptr = - let struct (u, sigptr') = sigptrGetZInt32 bytes sigptr - if (u = int nt_MAX) then - ILNativeType.Empty, sigptr' - else - // NOTE: go back to start and read native type - sigptrGetILNativeType ctxt bytes sigptr - if sigptr >= bytes.Length then - ILNativeType.Array (Some nt, None), sigptr - else - let struct (pnum, sigptr) = sigptrGetZInt32 bytes sigptr - if sigptr >= bytes.Length then - ILNativeType.Array (Some nt, Some(pnum, None)), sigptr - else - let struct (additive, sigptr) = - if sigptr >= bytes.Length then 0, sigptr - else sigptrGetZInt32 bytes sigptr - ILNativeType.Array (Some nt, Some(pnum, Some additive)), sigptr - else (ILNativeType.Empty, sigptr) + if sigptr >= bytes.Length then + ILNativeType.Array(None, None), sigptr + else + let nt, sigptr = + let struct (u, sigptr') = sigptrGetZInt32 bytes sigptr + + if (u = int nt_MAX) then + ILNativeType.Empty, sigptr' + else + // NOTE: go back to start and read native type + sigptrGetILNativeType ctxt bytes sigptr + + if sigptr >= bytes.Length then + ILNativeType.Array(Some nt, None), sigptr + else + let struct (pnum, sigptr) = sigptrGetZInt32 bytes sigptr + + if sigptr >= bytes.Length then + ILNativeType.Array(Some nt, Some(pnum, None)), sigptr + else + let struct (additive, sigptr) = + if sigptr >= bytes.Length then + 0, sigptr + else + sigptrGetZInt32 bytes sigptr + + ILNativeType.Array(Some nt, Some(pnum, Some additive)), sigptr + else + (ILNativeType.Empty, sigptr) // 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) canReduceMemory (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 = pectxtEager.anyV2P ("resource", offset + pectxtEager.resourcesAddr) - let resourceLength = seekReadInt32 pevEager start - let offsetOfBytesFromStartOfPhysicalPEFile = start + 4 - let byteStorage = - let bytes = pevEager.Slice(offsetOfBytesFromStartOfPhysicalPEFile, resourceLength) - ByteStorage.FromByteMemoryAndCopy(bytes, useBackingMemoryMappedFile = canReduceMemory) - ILResourceLocation.Local(byteStorage) - - | ILScopeRef.Module mref -> ILResourceLocation.File (mref, offset) - | ILScopeRef.Assembly aref -> ILResourceLocation.Assembly aref - | _ -> failwith "seekReadManifestResources: Invalid ILScopeRef" - - let r = - { Name= readStringHeap ctxt nameIdx - Location = location - Access = (if (flags &&& 0x01) <> 0x0 then ILResourceAccess.Public else ILResourceAccess.Private) - CustomAttrsStored = ctxt.customAttrsReader_ManifestResource - MetadataIndex = i } - yield r ] - -and seekReadNestedExportedTypes ctxt (exported: _ []) (nested: Lazy<_ []>) parentIdx = - mkILNestedExportedTypesLazy - (lazy - nested.Force().[parentIdx-1] + [ + 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 = pectxtEager.anyV2P ("resource", offset + pectxtEager.resourcesAddr) + let resourceLength = seekReadInt32 pevEager start + let offsetOfBytesFromStartOfPhysicalPEFile = start + 4 + + let byteStorage = + let bytes = pevEager.Slice(offsetOfBytesFromStartOfPhysicalPEFile, resourceLength) + ByteStorage.FromByteMemoryAndCopy(bytes, useBackingMemoryMappedFile = canReduceMemory) + + ILResourceLocation.Local(byteStorage) + + | ILScopeRef.Module mref -> ILResourceLocation.File(mref, offset) + | ILScopeRef.Assembly aref -> ILResourceLocation.Assembly aref + | _ -> failwith "seekReadManifestResources: Invalid ILScopeRef" + + let r = + { + Name = readStringHeap ctxt nameIdx + Location = location + Access = + (if (flags &&& 0x01) <> 0x0 then + ILResourceAccess.Public + else + ILResourceAccess.Private) + CustomAttrsStored = ctxt.customAttrsReader_ManifestResource + MetadataIndex = i + } + + yield r + ] + +and seekReadNestedExportedTypes ctxt (exported: _[]) (nested: Lazy<_[]>) parentIdx = + mkILNestedExportedTypesLazy ( + lazy + nested.Force().[parentIdx - 1] |> List.map (fun i -> - let flags, _tok, nameIdx, namespaceIdx, _implIdx = exported[i-1] - { Name = readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) - Access = (match typeAccessOfFlags flags with - | 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 - CustomAttrsStored = ctxt.customAttrsReader_ExportedType - MetadataIndex = i } - )) + let flags, _tok, nameIdx, namespaceIdx, _implIdx = exported[i - 1] + + { + Name = readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) + Access = + (match typeAccessOfFlags flags with + | 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 + CustomAttrsStored = ctxt.customAttrsReader_ExportedType + MetadataIndex = i + }) + ) and seekReadTopExportedTypes (ctxt: ILMetadataReader) = - mkILExportedTypesLazy - (lazy + mkILExportedTypesLazy ( + lazy let mdv = ctxt.mdfile.GetView() let numRows = ctxt.getNumRows TableNames.ExportedType 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 ( - let nested = [| for _i in 1..numRows -> [] |] - for i = 1 to numRows do - let flags,_,_,_,TaggedIndex(tag, idx) = exported[i-1] - if not (isTopTypeDef flags) && (tag = i_ExportedType) then - nested[idx-1] <- i :: nested[idx-1] - nested) + let nested = + lazy + (let nested = [| for _i in 1..numRows -> [] |] + + for i = 1 to numRows do + let flags, _, _, _, TaggedIndex (tag, idx) = exported[i - 1] + + if not (isTopTypeDef flags) && (tag = i_ExportedType) then + nested[idx - 1] <- i :: nested[idx - 1] + + nested) // return top exported types - [ for i = 1 to numRows do - let flags, _tok, nameIdx, namespaceIdx, implIdx = exported[i-1] - let (TaggedIndex(tag, _idx)) = implIdx - - // if not a nested type - if (isTopTypeDef flags) && (tag <> i_ExportedType) then - yield - { ScopeRef = seekReadImplAsScopeRef ctxt mdv implIdx - Name = readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) - Attributes = enum(flags) - Nested = seekReadNestedExportedTypes ctxt exported nested i - CustomAttrsStored = ctxt.customAttrsReader_ExportedType - MetadataIndex = i } - ]) + [ + for i = 1 to numRows do + let flags, _tok, nameIdx, namespaceIdx, implIdx = exported[i - 1] + let (TaggedIndex (tag, _idx)) = implIdx + + // if not a nested type + if (isTopTypeDef flags) && (tag <> i_ExportedType) then + yield + { + ScopeRef = seekReadImplAsScopeRef ctxt mdv implIdx + Name = readBlobHeapAsTypeName ctxt (nameIdx, namespaceIdx) + Attributes = enum (flags) + Nested = seekReadNestedExportedTypes ctxt exported nested i + CustomAttrsStored = ctxt.customAttrsReader_ExportedType + MetadataIndex = i + } + ] + ) #if !FX_NO_PDB_READER let getPdbReader pdbDirPath fileName = match pdbDirPath with | None -> None | Some pdbpath -> - try - let pdbr = pdbReadOpen fileName pdbpath - let pdbdocs = pdbReaderGetDocuments pdbr - - let tab = new Dictionary<_, _>(Array.length pdbdocs) - pdbdocs |> Array.iter (fun pdbdoc -> - let url = pdbDocumentGetURL pdbdoc - tab.[url] <- - ILSourceDocument.Create(language=Some (pdbDocumentGetLanguage pdbdoc), - vendor = Some (pdbDocumentGetLanguageVendor pdbdoc), - documentType = Some (pdbDocumentGetType pdbdoc), - file = url)) - - let docfun url = - match tab.TryGetValue url with - | true, doc -> doc - | _ -> failwith ("Document with URL " + url + " not found in list of documents in the PDB file") - Some (pdbr, docfun) - with e -> dprintn ("* Warning: PDB file could not be read and will be ignored: "+e.Message); None + try + let pdbr = pdbReadOpen fileName pdbpath + let pdbdocs = pdbReaderGetDocuments pdbr + + let tab = new Dictionary<_, _>(Array.length pdbdocs) + + pdbdocs + |> Array.iter (fun pdbdoc -> + let url = pdbDocumentGetURL pdbdoc + + tab.[url] <- + ILSourceDocument.Create( + language = Some(pdbDocumentGetLanguage pdbdoc), + vendor = Some(pdbDocumentGetLanguageVendor pdbdoc), + documentType = Some(pdbDocumentGetType pdbdoc), + file = url + )) + + let docfun url = + match tab.TryGetValue url with + | true, doc -> doc + | _ -> failwith ("Document with URL " + url + " not found in list of documents in the PDB file") + + Some(pdbr, docfun) + with + | e -> + dprintn ("* Warning: PDB file could not be read and will be ignored: " + e.Message) + None #endif // Note, pectxtEager and pevEager must not be captured by the results of this function -let openMetadataReader (fileName, mdfile: BinaryFile, metadataPhysLoc, peinfo, pectxtEager: PEReader, pevEager, pectxtCaptured, reduceMemoryUsage) = +let openMetadataReader + ( + fileName, + mdfile: BinaryFile, + metadataPhysLoc, + peinfo, + pectxtEager: PEReader, + pevEager, + pectxtCaptured, + reduceMemoryUsage + ) = let mdv = mdfile.GetView() let magic = seekReadUInt16AsInt32 mdv metadataPhysLoc - if magic <> 0x5342 then failwith (fileName + ": bad metadata magic number: " + string magic) + + 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" + + if magic2 <> 0x424a then + failwith "bad metadata magic number" + let _majorMetadataVersion = seekReadUInt16 mdv (metadataPhysLoc + 4) let _minorMetadataVersion = seekReadUInt16 mdv (metadataPhysLoc + 6) let versionLength = seekReadInt32 mdv (metadataPhysLoc + 12) - let ilMetadataVersion = seekReadBytes mdv (metadataPhysLoc + 16) versionLength |> Array.filter (fun b -> b <> 0uy) + + let ilMetadataVersion = + seekReadBytes mdv (metadataPhysLoc + 16) versionLength + |> Array.filter (fun b -> b <> 0uy) + let x = align 0x04 (16 + versionLength) let numStreams = seekReadUInt16AsInt32 mdv (metadataPhysLoc + x + 2) let streamHeadersStart = (metadataPhysLoc + x + 4) let tryFindStream name = - let rec look i pos = - if i >= numStreams then None - else - let offset = seekReadInt32 mdv (pos + 0) - let length = seekReadInt32 mdv (pos + 4) - let mutable res = true - let mutable fin = false - let mutable n = 0 - // read and compare the stream name byte by byte - while not fin do - let c= seekReadByteAsInt32 mdv (pos + 8 + n) - if c = 0 then - fin <- true - elif n >= Array.length name || c <> name[n] then - res <- false - n <- n + 1 - if res then Some(offset + metadataPhysLoc, length) - else look (i+1) (align 0x04 (pos + 8 + n)) - look 0 streamHeadersStart + let rec look i pos = + if i >= numStreams then + None + else + let offset = seekReadInt32 mdv (pos + 0) + let length = seekReadInt32 mdv (pos + 4) + let mutable res = true + let mutable fin = false + let mutable n = 0 + // read and compare the stream name byte by byte + while not fin do + let c = seekReadByteAsInt32 mdv (pos + 8 + n) + + if c = 0 then + fin <- true + elif n >= Array.length name || c <> name[n] then + res <- false + + n <- n + 1 + + if res then + Some(offset + metadataPhysLoc, length) + else + look (i + 1) (align 0x04 (pos + 8 + n)) + + look 0 streamHeadersStart let findStream name = match tryFindStream name with @@ -3318,100 +4298,111 @@ let openMetadataReader (fileName, mdfile: BinaryFile, metadataPhysLoc, peinfo, p | Some positions -> positions let tablesStreamPhysLoc, _tablesStreamSize = - match tryFindStream [| 0x23; 0x7e |] (* #~ *) with - | Some res -> res - | None -> - match tryFindStream [| 0x23; 0x2d |] (* #-: at least one DLL I've seen uses this! *) with + match tryFindStream [| 0x23; 0x7e |] (* #~ *) with | Some res -> res | None -> - let firstStreamOffset = seekReadInt32 mdv (streamHeadersStart + 0) - let firstStreamLength = seekReadInt32 mdv (streamHeadersStart + 4) - firstStreamOffset, firstStreamLength + match tryFindStream [| 0x23; 0x2d |] (* #-: at least one DLL I've seen uses this! *) with + | Some res -> res + | None -> + 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 *) - let userStringsStreamPhysicalLoc, userStringsStreamSize = findStream [| 0x23; 0x55; 0x53; |] (* #US *) - let guidsStreamPhysicalLoc, _guidsStreamSize = findStream [| 0x23; 0x47; 0x55; 0x49; 0x44; |] (* #GUID *) - let blobsStreamPhysicalLoc, blobsStreamSize = findStream [| 0x23; 0x42; 0x6c; 0x6f; 0x62; |] (* #Blob *) + let stringsStreamPhysicalLoc, stringsStreamSize = + findStream [| 0x23; 0x53; 0x74; 0x72; 0x69; 0x6e; 0x67; 0x73 |] (* #Strings *) + + let userStringsStreamPhysicalLoc, userStringsStreamSize = + findStream [| 0x23; 0x55; 0x53 |] (* #US *) + + let guidsStreamPhysicalLoc, _guidsStreamSize = + findStream [| 0x23; 0x47; 0x55; 0x49; 0x44 |] (* #GUID *) + + let blobsStreamPhysicalLoc, blobsStreamSize = + findStream [| 0x23; 0x42; 0x6c; 0x6f; 0x62 |] (* #Blob *) let tableKinds = - [|kindModule (* Table 0 *) - kindTypeRef (* Table 1 *) - kindTypeDef (* Table 2 *) - kindIllegal (* kindFieldPtr *) (* Table 3 *) - kindFieldDef (* Table 4 *) - kindIllegal (* kindMethodPtr *) (* Table 5 *) - kindMethodDef (* Table 6 *) - kindIllegal (* kindParamPtr *) (* Table 7 *) - kindParam (* Table 8 *) - kindInterfaceImpl (* Table 9 *) - kindMemberRef (* Table 10 *) - kindConstant (* Table 11 *) - kindCustomAttribute (* Table 12 *) - kindFieldMarshal (* Table 13 *) - kindDeclSecurity (* Table 14 *) - kindClassLayout (* Table 15 *) - kindFieldLayout (* Table 16 *) - kindStandAloneSig (* Table 17 *) - kindEventMap (* Table 18 *) - kindIllegal (* kindEventPtr *) (* Table 19 *) - kindEvent (* Table 20 *) - kindPropertyMap (* Table 21 *) - kindIllegal (* kindPropertyPtr *) (* Table 22 *) - kindProperty (* Table 23 *) - kindMethodSemantics (* Table 24 *) - kindMethodImpl (* Table 25 *) - kindModuleRef (* Table 26 *) - kindTypeSpec (* Table 27 *) - kindImplMap (* Table 28 *) - kindFieldRVA (* Table 29 *) - kindIllegal (* kindENCLog *) (* Table 30 *) - kindIllegal (* kindENCMap *) (* Table 31 *) - kindAssembly (* Table 32 *) - kindIllegal (* kindAssemblyProcessor *) (* Table 33 *) - kindIllegal (* kindAssemblyOS *) (* Table 34 *) - kindAssemblyRef (* Table 35 *) - kindIllegal (* kindAssemblyRefProcessor *) (* Table 36 *) - kindIllegal (* kindAssemblyRefOS *) (* Table 37 *) - kindFileRef (* Table 38 *) - kindExportedType (* Table 39 *) - kindManifestResource (* Table 40 *) - kindNested (* Table 41 *) - kindGenericParam_v2_0 (* Table 42 *) - kindMethodSpec (* Table 43 *) - kindGenericParamConstraint (* Table 44 *) - kindIllegal (* Table 45 *) - kindIllegal (* Table 46 *) - kindIllegal (* Table 47 *) - kindIllegal (* Table 48 *) - kindIllegal (* Table 49 *) - kindIllegal (* Table 50 *) - kindIllegal (* Table 51 *) - kindIllegal (* Table 52 *) - kindIllegal (* Table 53 *) - kindIllegal (* Table 54 *) - kindIllegal (* Table 55 *) - kindIllegal (* Table 56 *) - kindIllegal (* Table 57 *) - kindIllegal (* Table 58 *) - kindIllegal (* Table 59 *) - kindIllegal (* Table 60 *) - kindIllegal (* Table 61 *) - kindIllegal (* Table 62 *) - kindIllegal (* Table 63 *) + [| + kindModule (* Table 0 *) + kindTypeRef (* Table 1 *) + kindTypeDef (* Table 2 *) + kindIllegal (* kindFieldPtr *) (* Table 3 *) + kindFieldDef (* Table 4 *) + kindIllegal (* kindMethodPtr *) (* Table 5 *) + kindMethodDef (* Table 6 *) + kindIllegal (* kindParamPtr *) (* Table 7 *) + kindParam (* Table 8 *) + kindInterfaceImpl (* Table 9 *) + kindMemberRef (* Table 10 *) + kindConstant (* Table 11 *) + kindCustomAttribute (* Table 12 *) + kindFieldMarshal (* Table 13 *) + kindDeclSecurity (* Table 14 *) + kindClassLayout (* Table 15 *) + kindFieldLayout (* Table 16 *) + kindStandAloneSig (* Table 17 *) + kindEventMap (* Table 18 *) + kindIllegal (* kindEventPtr *) (* Table 19 *) + kindEvent (* Table 20 *) + kindPropertyMap (* Table 21 *) + kindIllegal (* kindPropertyPtr *) (* Table 22 *) + kindProperty (* Table 23 *) + kindMethodSemantics (* Table 24 *) + kindMethodImpl (* Table 25 *) + kindModuleRef (* Table 26 *) + kindTypeSpec (* Table 27 *) + kindImplMap (* Table 28 *) + kindFieldRVA (* Table 29 *) + kindIllegal (* kindENCLog *) (* Table 30 *) + kindIllegal (* kindENCMap *) (* Table 31 *) + kindAssembly (* Table 32 *) + kindIllegal (* kindAssemblyProcessor *) (* Table 33 *) + kindIllegal (* kindAssemblyOS *) (* Table 34 *) + kindAssemblyRef (* Table 35 *) + kindIllegal (* kindAssemblyRefProcessor *) (* Table 36 *) + kindIllegal (* kindAssemblyRefOS *) (* Table 37 *) + kindFileRef (* Table 38 *) + kindExportedType (* Table 39 *) + kindManifestResource (* Table 40 *) + kindNested (* Table 41 *) + kindGenericParam_v2_0 (* Table 42 *) + kindMethodSpec (* Table 43 *) + kindGenericParamConstraint (* Table 44 *) + kindIllegal (* Table 45 *) + kindIllegal (* Table 46 *) + kindIllegal (* Table 47 *) + kindIllegal (* Table 48 *) + kindIllegal (* Table 49 *) + kindIllegal (* Table 50 *) + kindIllegal (* Table 51 *) + kindIllegal (* Table 52 *) + kindIllegal (* Table 53 *) + kindIllegal (* Table 54 *) + kindIllegal (* Table 55 *) + kindIllegal (* Table 56 *) + kindIllegal (* Table 57 *) + kindIllegal (* Table 58 *) + kindIllegal (* Table 59 *) + kindIllegal (* Table 60 *) + kindIllegal (* Table 61 *) + kindIllegal (* Table 62 *) + kindIllegal (* Table 63 *) |] let heapSizes = seekReadByteAsInt32 mdv (tablesStreamPhysLoc + 6) let valid = seekReadInt64 mdv (tablesStreamPhysLoc + 8) let sorted = seekReadInt64 mdv (tablesStreamPhysLoc + 16) + let tablesPresent, tableRowCount, startOfTables = let mutable present = [] let numRows = Array.create 64 0 let mutable prevNumRowIdx = tablesStreamPhysLoc + 24 + for i = 0 to 63 do if (valid &&& (int64 1 <<< i)) <> int64 0 then present <- i :: present numRows[i] <- (seekReadInt32 mdv prevNumRowIdx) prevNumRowIdx <- prevNumRowIdx + 4 + List.rev present, numRows, prevNumRowIdx let getNumRows (tab: TableName) = tableRowCount[tab.Index] @@ -3420,100 +4411,97 @@ let openMetadataReader (fileName, mdfile: BinaryFile, metadataPhysLoc, peinfo, p let guidsBigness = (heapSizes &&& 2) <> 0 let blobsBigness = (heapSizes &&& 4) <> 0 - 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") + 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 let codedBigness nbits tab = - let rows = getNumRows tab - rows >= (0x10000 >>>& nbits) + let rows = getNumRows tab + rows >= (0x10000 >>>& nbits) let tdorBigness = - codedBigness 2 TableNames.TypeDef || - codedBigness 2 TableNames.TypeRef || - codedBigness 2 TableNames.TypeSpec + codedBigness 2 TableNames.TypeDef + || codedBigness 2 TableNames.TypeRef + || codedBigness 2 TableNames.TypeSpec let tomdBigness = - codedBigness 1 TableNames.TypeDef || - codedBigness 1 TableNames.Method + codedBigness 1 TableNames.TypeDef || codedBigness 1 TableNames.Method let hcBigness = - codedBigness 2 TableNames.Field || - codedBigness 2 TableNames.Param || - codedBigness 2 TableNames.Property + codedBigness 2 TableNames.Field + || codedBigness 2 TableNames.Param + || codedBigness 2 TableNames.Property let hcaBigness = - codedBigness 5 TableNames.Method || - codedBigness 5 TableNames.Field || - codedBigness 5 TableNames.TypeRef || - codedBigness 5 TableNames.TypeDef || - codedBigness 5 TableNames.Param || - codedBigness 5 TableNames.InterfaceImpl || - codedBigness 5 TableNames.MemberRef || - codedBigness 5 TableNames.Module || - codedBigness 5 TableNames.Permission || - codedBigness 5 TableNames.Property || - codedBigness 5 TableNames.Event || - codedBigness 5 TableNames.StandAloneSig || - codedBigness 5 TableNames.ModuleRef || - codedBigness 5 TableNames.TypeSpec || - codedBigness 5 TableNames.Assembly || - codedBigness 5 TableNames.AssemblyRef || - codedBigness 5 TableNames.File || - codedBigness 5 TableNames.ExportedType || - codedBigness 5 TableNames.ManifestResource || - codedBigness 5 TableNames.GenericParam || - codedBigness 5 TableNames.GenericParamConstraint || - codedBigness 5 TableNames.MethodSpec - - - let hfmBigness = - codedBigness 1 TableNames.Field || - codedBigness 1 TableNames.Param + codedBigness 5 TableNames.Method + || codedBigness 5 TableNames.Field + || codedBigness 5 TableNames.TypeRef + || codedBigness 5 TableNames.TypeDef + || codedBigness 5 TableNames.Param + || codedBigness 5 TableNames.InterfaceImpl + || codedBigness 5 TableNames.MemberRef + || codedBigness 5 TableNames.Module + || codedBigness 5 TableNames.Permission + || codedBigness 5 TableNames.Property + || codedBigness 5 TableNames.Event + || codedBigness 5 TableNames.StandAloneSig + || codedBigness 5 TableNames.ModuleRef + || codedBigness 5 TableNames.TypeSpec + || codedBigness 5 TableNames.Assembly + || codedBigness 5 TableNames.AssemblyRef + || codedBigness 5 TableNames.File + || codedBigness 5 TableNames.ExportedType + || codedBigness 5 TableNames.ManifestResource + || codedBigness 5 TableNames.GenericParam + || codedBigness 5 TableNames.GenericParamConstraint + || codedBigness 5 TableNames.MethodSpec + + let hfmBigness = codedBigness 1 TableNames.Field || codedBigness 1 TableNames.Param let hdsBigness = - codedBigness 2 TableNames.TypeDef || - codedBigness 2 TableNames.Method || - codedBigness 2 TableNames.Assembly + codedBigness 2 TableNames.TypeDef + || codedBigness 2 TableNames.Method + || codedBigness 2 TableNames.Assembly let mrpBigness = - codedBigness 3 TableNames.TypeDef || - codedBigness 3 TableNames.TypeRef || - codedBigness 3 TableNames.ModuleRef || - codedBigness 3 TableNames.Method || - codedBigness 3 TableNames.TypeSpec + codedBigness 3 TableNames.TypeDef + || codedBigness 3 TableNames.TypeRef + || codedBigness 3 TableNames.ModuleRef + || codedBigness 3 TableNames.Method + || codedBigness 3 TableNames.TypeSpec let hsBigness = - codedBigness 1 TableNames.Event || - codedBigness 1 TableNames.Property + codedBigness 1 TableNames.Event || codedBigness 1 TableNames.Property let mdorBigness = - codedBigness 1 TableNames.Method || - codedBigness 1 TableNames.MemberRef + codedBigness 1 TableNames.Method || codedBigness 1 TableNames.MemberRef - let mfBigness = - codedBigness 1 TableNames.Field || - codedBigness 1 TableNames.Method + let mfBigness = codedBigness 1 TableNames.Field || codedBigness 1 TableNames.Method let iBigness = - codedBigness 2 TableNames.File || - codedBigness 2 TableNames.AssemblyRef || - codedBigness 2 TableNames.ExportedType + codedBigness 2 TableNames.File + || codedBigness 2 TableNames.AssemblyRef + || codedBigness 2 TableNames.ExportedType let catBigness = - codedBigness 3 TableNames.Method || - codedBigness 3 TableNames.MemberRef + codedBigness 3 TableNames.Method || codedBigness 3 TableNames.MemberRef let rsBigness = - codedBigness 2 TableNames.Module || - codedBigness 2 TableNames.ModuleRef || - codedBigness 2 TableNames.AssemblyRef || - codedBigness 2 TableNames.TypeRef + codedBigness 2 TableNames.Module + || codedBigness 2 TableNames.ModuleRef + || codedBigness 2 TableNames.AssemblyRef + || codedBigness 2 TableNames.TypeRef let rowKindSize (RowKind kinds) = - kinds |> List.sumBy (fun x -> + kinds + |> List.sumBy (fun x -> match x with | UShort -> 2 | ULong -> 4 @@ -3540,121 +4528,182 @@ let openMetadataReader (fileName, mdfile: BinaryFile, metadataPhysLoc, peinfo, p let tableRowSizes = tableKinds |> Array.map rowKindSize let tablePhysLocations = - let res = Array.create 64 0x0 - let mutable prevTablePhysLoc = startOfTables - for i = 0 to 63 do - res[i] <- prevTablePhysLoc - prevTablePhysLoc <- prevTablePhysLoc + (tableRowCount[i] * tableRowSizes[i]) - res + let res = Array.create 64 0x0 + let mutable prevTablePhysLoc = startOfTables + + for i = 0 to 63 do + res[i] <- prevTablePhysLoc + prevTablePhysLoc <- prevTablePhysLoc + (tableRowCount[i] * tableRowSizes[i]) + + res let inbase = FileSystemUtils.fileNameOfPath fileName + ": " // All the caches. The sizes are guesstimates for the rough sharing-density of the assembly - let cacheAssemblyRef = mkCacheInt32 false 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 false 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) + let cacheAssemblyRef = + mkCacheInt32 false 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 false 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 reduceMemoryUsage inbase "blob heap" ( blobsStreamSize / 50 + 1) + let cacheStringHeap = + mkCacheInt32 false inbase "string heap" (stringsStreamSize / 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. - // 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 reduceMemoryUsage inbase "Nested Table Rows" (getNumRows TableNames.Nested / 20 + 1) - 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 cacheConstantRow = + mkCacheInt32 reduceMemoryUsage inbase "Constant Rows" (getNumRows TableNames.Constant / 20 + 1) - let rowAddr (tab: TableName) idx = tablePhysLocations[tab.Index] + (idx - 1) * tableRowSizes[tab.Index] + 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 = - { 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 } + { + 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.Value <- Some ctxt - let ilModule = seekReadModule ctxt reduceMemoryUsage pectxtEager pevEager peinfo (Encoding.UTF8.GetString (ilMetadataVersion, 0, ilMetadataVersion.Length)) 1 - let ilAssemblyRefs = lazy [ for i in 1 .. getNumRows TableNames.AssemblyRef do yield seekReadAssemblyRef ctxt i ] + let ilModule = + seekReadModule + ctxt + reduceMemoryUsage + pectxtEager + pevEager + peinfo + (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 @@ -3672,130 +4721,222 @@ let openPEFileReader (fileName, pefile: BinaryFile, pdbDirPath, noFileOnDisk) = 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 + 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 headerSizeOpt = seekReadUInt16AsInt32 pev (peFileHeaderPhysLoc + 16) - if headerSizeOpt <> 0xe0 && - headerSizeOpt <> 0xf0 then failwith "not a PE file - bad optional header size" + + if headerSizeOpt <> 0xe0 && headerSizeOpt <> 0xf0 then + failwith "not a PE file - bad optional header size" + let x64adjust = headerSizeOpt - 0xe0 - let only64 = (headerSizeOpt = 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 only64 = + (headerSizeOpt = 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 + headerSizeOpt 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 *) + (* 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). - 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 - let _headerPhysSize = seekReadInt32 pev (peOptionalHeaderPhysLoc + 60) // Header Size Combined size of MS-DOS Header, PE Header, PE Optional Header and padding - let subsys = seekReadUInt16 pev (peOptionalHeaderPhysLoc + 68) // SubSystem Subsystem required to run this image. + let imageBaseReal = + if only64 then + dataSegmentAddr + else + seekReadInt32 pev (peOptionalHeaderPhysLoc + 28) // Image Base Always 0x400000 (see Section 23.1). + + 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 + let _headerPhysSize = seekReadInt32 pev (peOptionalHeaderPhysLoc + 60) // Header Size Combined size of MS-DOS Header, PE Header, PE Optional Header and padding + let subsys = seekReadUInt16 pev (peOptionalHeaderPhysLoc + 68) // SubSystem Subsystem required to run this image. + let useHighEnthropyVA = let n = seekReadUInt16 pev (peOptionalHeaderPhysLoc + 70) let highEnthropyVA = 0x20us (n &&& highEnthropyVA) = highEnthropyVA - (* x86: 000000e0 *) + (* 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 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 *) + (* 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 *) - + (* 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) ] + [ + 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 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 relocHeaderStart = findSectionHeader base_relocTableNames.addr in *) + + let _textSize = + if textHeaderStart = 0x0 then + 0x0 + else + seekReadInt32 pev (textHeaderStart + 8) - 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 _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 dataSegmentPhysicalSize = + if dataHeaderStart = 0x0 then + 0x0 + else + seekReadInt32 pev (dataHeaderStart + 16) - 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) + let dataSegmentPhysicalLoc = + if dataHeaderStart = 0x0 then + 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 + 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) @@ -3819,18 +4960,29 @@ let openPEFileReader (fileName, pefile: BinaryFile, pdbDirPath, noFileOnDisk) = 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) + 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. - // ---------------------------------------------------------------------- + //----------------------------------------------------------------------- + // Set up the PDB reader so we can read debug info for methods. + // ---------------------------------------------------------------------- #if FX_NO_PDB_READER - let pdb = ignore pdbDirPath; None + let pdb = + ignore pdbDirPath + None #else let pdb = if runningOnMono then @@ -3840,30 +4992,49 @@ let openPEFileReader (fileName, pefile: BinaryFile, pdbDirPath, noFileOnDisk) = #endif 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 - noFileOnDisk=noFileOnDisk + { + 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 + noFileOnDisk = noFileOnDisk } - let peinfo = (subsys, (subsysMajor, subsysMinor), useHighEnthropyVA, ilOnly, only32, is32bitpreferred, only64, platform, isDll, alignVirt, alignPhys, imageBaseReal) + + 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, pdbDirPath, reduceMemoryUsage, noFileOnDisk) = - let metadataPhysLoc, _metadataSize, peinfo, pectxt, pev, pdb = openPEFileReader (fileName, pefile, pdbDirPath, noFileOnDisk) - let ilModule, ilAssemblyRefs = openMetadataReader (fileName, pefile, metadataPhysLoc, peinfo, pectxt, pev, Some pectxt, reduceMemoryUsage) + let metadataPhysLoc, _metadataSize, peinfo, pectxt, pev, pdb = + openPEFileReader (fileName, pefile, pdbDirPath, noFileOnDisk) + + let ilModule, ilAssemblyRefs = + openMetadataReader (fileName, pefile, metadataPhysLoc, peinfo, pectxt, pev, Some pectxt, reduceMemoryUsage) + ilModule, ilAssemblyRefs, pdb let openPEMetadataOnly (fileName, peinfo, pectxtEager, pevEager, mdfile: BinaryFile, reduceMemoryUsage) = @@ -3880,19 +5051,25 @@ let ClosePdbReader pdb = #endif type ILReaderMetadataSnapshot = obj * nativeint * int -type ILReaderTryGetMetadataSnapshot = (* path: *) string * (* snapshotTimeStamp: *) DateTime -> ILReaderMetadataSnapshot option +type ILReaderTryGetMetadataSnapshot = (* path: *) string (* snapshotTimeStamp: *) * DateTime -> ILReaderMetadataSnapshot option [] -type MetadataOnlyFlag = Yes | No +type MetadataOnlyFlag = + | Yes + | No [] -type ReduceMemoryFlag = Yes | No +type ReduceMemoryFlag = + | Yes + | No type ILReaderOptions = - { pdbDirPath: string option - reduceMemoryUsage: ReduceMemoryFlag - metadataOnly: MetadataOnlyFlag - tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot } + { + pdbDirPath: string option + reduceMemoryUsage: ReduceMemoryFlag + metadataOnly: MetadataOnlyFlag + tryGetMetadataSnapshot: ILReaderTryGetMetadataSnapshot + } type ILModuleReader = abstract ILModuleDef: ILModuleDef @@ -3906,53 +5083,66 @@ type ILModuleReaderImpl(ilModule: ILModuleDef, ilAssemblyRefs: Lazy - (stronglyHeldReaderCacheSize, - keepMax=stronglyHeldReaderCacheSize, // only strong entries - areSimilar=(fun (x, y) -> x = y)) + AgedLookup( + stronglyHeldReaderCacheSize, + keepMax = stronglyHeldReaderCacheSize, // only strong entries + areSimilar = (fun (x, y) -> x = y) + ) + let ilModuleReaderCache1Lock = Lock() // // Cache to reuse readers that have already been created and are not yet GC'd -let ilModuleReaderCache2 = ConcurrentDictionary>(HashIdentity.Structural) +let ilModuleReaderCache2 = + ConcurrentDictionary>(HashIdentity.Structural) let stableFileHeuristicApplies fileName = - not noStableFileHeuristic && try FileSystem.IsStableFileHeuristic fileName with _ -> false + not noStableFileHeuristic + && try + FileSystem.IsStableFileHeuristic fileName + with + | _ -> false let createByteFileChunk opts fileName chunk = // 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 + if opts.reduceMemoryUsage = ReduceMemoryFlag.Yes + && stableFileHeuristicApplies fileName then WeakByteFile(fileName, chunk) :> BinaryFile else let bytes = use stream = FileSystem.OpenFileForReadShim(fileName) + match chunk with | None -> stream.ReadAllBytes() - | Some(start, length) -> stream.ReadBytes(start, length) + | Some (start, length) -> stream.ReadBytes(start, length) ByteFile(fileName, bytes) :> BinaryFile let getBinaryFile fileName useMemoryMappedFile = - let stream = FileSystem.OpenFileForReadShim(fileName, useMemoryMappedFile = useMemoryMappedFile) + let stream = + FileSystem.OpenFileForReadShim(fileName, useMemoryMappedFile = useMemoryMappedFile) + let byteMem = stream.AsByteMemory() let safeHolder = { new obj() with - override x.Finalize() = - (x :?> IDisposable).Dispose() + override x.Finalize() = (x :?> IDisposable).Dispose() interface IDisposable with - member x.Dispose() = - GC.SuppressFinalize x - stream.Dispose() - stats.memoryMapFileClosedCount <- stats.memoryMapFileClosedCount + 1 } + member x.Dispose() = + GC.SuppressFinalize x + stream.Dispose() + stats.memoryMapFileClosedCount <- stats.memoryMapFileClosedCount + 1 + } stats.memoryMapFileOpenedCount <- stats.memoryMapFileOpenedCount + 1 @@ -3960,36 +5150,57 @@ let getBinaryFile fileName useMemoryMappedFile = let OpenILModuleReaderFromBytes fileName assemblyContents options = let pefile = ByteFile(fileName, assemblyContents) :> BinaryFile - let ilModule, ilAssemblyRefs, pdb = openPE (fileName, pefile, options.pdbDirPath, (options.reduceMemoryUsage = ReduceMemoryFlag.Yes), true) + + let ilModule, ilAssemblyRefs, pdb = + openPE (fileName, pefile, options.pdbDirPath, (options.reduceMemoryUsage = ReduceMemoryFlag.Yes), true) + new ILModuleReaderImpl(ilModule, ilAssemblyRefs, (fun () -> ClosePdbReader pdb)) :> ILModuleReader let OpenILModuleReaderFromStream fileName (peStream: Stream) options = - let peReader = new System.Reflection.PortableExecutable.PEReader(peStream, PEStreamOptions.PrefetchEntireImage) + let peReader = + new System.Reflection.PortableExecutable.PEReader(peStream, PEStreamOptions.PrefetchEntireImage) + let pefile = PEFile(fileName, peReader) :> BinaryFile - let ilModule, ilAssemblyRefs, pdb = openPE (fileName, pefile, options.pdbDirPath, (options.reduceMemoryUsage = ReduceMemoryFlag.Yes), true) + + let ilModule, ilAssemblyRefs, pdb = + openPE (fileName, pefile, options.pdbDirPath, (options.reduceMemoryUsage = ReduceMemoryFlag.Yes), true) + new ILModuleReaderImpl(ilModule, ilAssemblyRefs, (fun () -> ClosePdbReader pdb)) :> ILModuleReader -let ClearAllILModuleReaderCache() = +let ClearAllILModuleReaderCache () = ilModuleReaderCache1.Clear(ILModuleReaderCache1LockToken()) ilModuleReaderCache2.Clear() let OpenILModuleReader fileName opts = // Pseudo-normalize the paths. - let ILModuleReaderCacheKey (fullPath,writeStamp,_,_,_) as key, keyOk = + let ILModuleReaderCacheKey (fullPath, writeStamp, _, _, _) as key, keyOk = try - let fullPath = FileSystem.GetFullPathShim fileName - let writeTime = FileSystem.GetLastWriteTimeShim fileName - let key = ILModuleReaderCacheKey (fullPath, writeTime, opts.pdbDirPath.IsSome, opts.reduceMemoryUsage, opts.metadataOnly) - key, true - with exn -> - Debug.Assert(false, sprintf "Failed to compute key in OpenILModuleReader cache for '%s'. Falling back to uncached. Error = %s" fileName (exn.ToString())) - let fakeKey = ILModuleReaderCacheKey(fileName, DateTime.UtcNow, false, ReduceMemoryFlag.Yes, MetadataOnlyFlag.Yes) + let fullPath = FileSystem.GetFullPathShim fileName + let writeTime = FileSystem.GetLastWriteTimeShim fileName + + let key = + ILModuleReaderCacheKey(fullPath, writeTime, opts.pdbDirPath.IsSome, opts.reduceMemoryUsage, opts.metadataOnly) + + key, true + with + | exn -> + Debug.Assert( + false, + sprintf + "Failed to compute key in OpenILModuleReader cache for '%s'. Falling back to uncached. Error = %s" + fileName + (exn.ToString()) + ) + + let fakeKey = + ILModuleReaderCacheKey(fileName, DateTime.UtcNow, false, ReduceMemoryFlag.Yes, MetadataOnlyFlag.Yes) + fakeKey, false let cacheResult1 = // can't used a cached entry when reading PDBs, since it makes the returned object IDisposable if keyOk && opts.pdbDirPath.IsNone then - ilModuleReaderCache1Lock.AcquireLock (fun ltok -> ilModuleReaderCache1.TryGet(ltok, key)) + ilModuleReaderCache1Lock.AcquireLock(fun ltok -> ilModuleReaderCache1.TryGet(ltok, key)) else None @@ -3997,92 +5208,105 @@ let OpenILModuleReader fileName opts = | Some ilModuleReader -> ilModuleReader | None -> - let cacheResult2 = - // can't used a cached entry when reading PDBs, since it makes the returned object IDisposable - if keyOk && opts.pdbDirPath.IsNone then - ilModuleReaderCache2.TryGetValue key - else - false, Unchecked.defaultof<_> - - let mutable res = Unchecked.defaultof<_> - match cacheResult2 with - | true, weak when weak.TryGetTarget(&res) -> res - | _ -> - - let reduceMemoryUsage = (opts.reduceMemoryUsage = ReduceMemoryFlag.Yes) - let metadataOnly = (opts.metadataOnly = MetadataOnlyFlag.Yes) - - if reduceMemoryUsage && opts.pdbDirPath.IsNone then - - // This case is used in FCS applications, devenv.exe and fsi.exe - // - let ilModuleReader = - // Check if we are doing metadataOnly reading (the most common case in both the compiler and IDE) - if not runningOnMono && metadataOnly then - - // See if tryGetMetadata gives us a BinaryFile for the metadata section alone. - let mdfileOpt = - match opts.tryGetMetadataSnapshot (fullPath, writeStamp) with - | Some (obj, start, len) -> Some (RawMemoryFile(fullPath, 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 = getBinaryFile fullPath false - use _disposer = disposer - let metadataPhysLoc, metadataSize, peinfo, pectxtEager, pevEager, _pdb = openPEFileReader (fullPath, pefileEager, None, false) - 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 - createByteFileChunk opts fullPath (Some (metadataPhysLoc, metadataSize)) - - let ilModule, ilAssemblyRefs = openPEMetadataOnly (fullPath, peinfo, pectxtEager, pevEager, mdfile, reduceMemoryUsage) - new ILModuleReaderImpl(ilModule, ilAssemblyRefs, ignore) + let cacheResult2 = + // can't used a cached entry when reading PDBs, since it makes the returned object IDisposable + if keyOk && opts.pdbDirPath.IsNone then + ilModuleReaderCache2.TryGetValue key 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 = createByteFileChunk opts fullPath None - let ilModule, ilAssemblyRefs, _pdb = openPE (fullPath, pefile, None, reduceMemoryUsage, false) - new ILModuleReaderImpl(ilModule, ilAssemblyRefs, ignore) + false, Unchecked.defaultof<_> + + let mutable res = Unchecked.defaultof<_> - let ilModuleReader = ilModuleReader :> ILModuleReader - if keyOk then - ilModuleReaderCache1Lock.AcquireLock (fun ltok -> ilModuleReaderCache1.Put(ltok, key, ilModuleReader)) - ilModuleReaderCache2[key] <- System.WeakReference<_>(ilModuleReader) - ilModuleReader + match cacheResult2 with + | true, weak when weak.TryGetTarget(&res) -> res + | _ -> + let reduceMemoryUsage = (opts.reduceMemoryUsage = ReduceMemoryFlag.Yes) + let metadataOnly = (opts.metadataOnly = MetadataOnlyFlag.Yes) + + if reduceMemoryUsage && opts.pdbDirPath.IsNone then + + // This case is used in FCS applications, devenv.exe and fsi.exe + // + let ilModuleReader = + // Check if we are doing metadataOnly reading (the most common case in both the compiler and IDE) + if not runningOnMono && metadataOnly then + + // See if tryGetMetadata gives us a BinaryFile for the metadata section alone. + let mdfileOpt = + match opts.tryGetMetadataSnapshot (fullPath, writeStamp) with + | Some (obj, start, len) -> Some(RawMemoryFile(fullPath, 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 = getBinaryFile fullPath false + use _disposer = disposer + + let metadataPhysLoc, metadataSize, peinfo, pectxtEager, pevEager, _pdb = + openPEFileReader (fullPath, pefileEager, None, false) + + 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 + createByteFileChunk opts fullPath (Some(metadataPhysLoc, metadataSize)) + + let ilModule, ilAssemblyRefs = + openPEMetadataOnly (fullPath, peinfo, pectxtEager, pevEager, mdfile, reduceMemoryUsage) + + new ILModuleReaderImpl(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 = createByteFileChunk opts fullPath None + + let ilModule, ilAssemblyRefs, _pdb = + openPE (fullPath, pefile, None, reduceMemoryUsage, false) + + new ILModuleReaderImpl(ilModule, ilAssemblyRefs, ignore) + + let ilModuleReader = ilModuleReader :> ILModuleReader + + if keyOk then + ilModuleReaderCache1Lock.AcquireLock(fun ltok -> ilModuleReaderCache1.Put(ltok, key, ilModuleReader)) + ilModuleReaderCache2[key] <- System.WeakReference<_>(ilModuleReader) + + 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 - // still use an in-memory ByteFile - let pefile = - if not runningOnMono && (alwaysMemoryMapFSC || stableFileHeuristicApplies fullPath) then - let _, pefile = getBinaryFile fullPath false - pefile else - createByteFileChunk opts fullPath None + // 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 + // still use an in-memory ByteFile + let pefile = + if not runningOnMono && (alwaysMemoryMapFSC || stableFileHeuristicApplies fullPath) then + let _, pefile = getBinaryFile fullPath false + pefile + else + createByteFileChunk opts fullPath None - let ilModule, ilAssemblyRefs, pdb = openPE (fullPath, pefile, opts.pdbDirPath, reduceMemoryUsage, false) - let ilModuleReader = new ILModuleReaderImpl(ilModule, ilAssemblyRefs, (fun () -> ClosePdbReader pdb)) + let ilModule, ilAssemblyRefs, pdb = + openPE (fullPath, pefile, opts.pdbDirPath, reduceMemoryUsage, false) - let ilModuleReader = ilModuleReader :> ILModuleReader + let ilModuleReader = + new ILModuleReaderImpl(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.pdbDirPath.IsNone then - ilModuleReaderCache1Lock.AcquireLock (fun ltok -> ilModuleReaderCache1.Put(ltok, key, ilModuleReader)) - ilModuleReaderCache2[key] <- WeakReference<_>(ilModuleReader) + let ilModuleReader = ilModuleReader :> ILModuleReader + + // 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.pdbDirPath.IsNone then + ilModuleReaderCache1Lock.AcquireLock(fun ltok -> ilModuleReaderCache1.Put(ltok, key, ilModuleReader)) + ilModuleReaderCache2[key] <- WeakReference<_>(ilModuleReader) - ilModuleReader + ilModuleReader [] module Shim = diff --git a/src/Compiler/AbstractIL/ilreflect.fs b/src/Compiler/AbstractIL/ilreflect.fs index 35339c31a..574075ea6 100644 --- a/src/Compiler/AbstractIL/ilreflect.fs +++ b/src/Compiler/AbstractIL/ilreflect.fs @@ -21,8 +21,7 @@ open FSharp.Core.Printf let codeLabelOrder = ComparisonIdentity.Structural // Convert the output of convCustomAttr -let wrapCustomAttr setCustomAttr (cinfo, bytes) = - setCustomAttr(cinfo, bytes) +let wrapCustomAttr setCustomAttr (cinfo, bytes) = setCustomAttr (cinfo, bytes) //---------------------------------------------------------------------------- // logging to enable debugging @@ -31,241 +30,440 @@ let wrapCustomAttr setCustomAttr (cinfo, bytes) = let logRefEmitCalls = false type AssemblyBuilder with - member asmB.DefineDynamicModuleAndLog (a, b, c) = + + member asmB.DefineDynamicModuleAndLog(a, b, c) = #if FX_RESHAPED_REFEMIT ignore b ignore c let modB = asmB.DefineDynamicModule a #else let modB = asmB.DefineDynamicModule(a, b, c) - if logRefEmitCalls then printfn "let moduleBuilder%d = assemblyBuilder%d.DefineDynamicModule(%A, %A, %A)" (abs <| hash modB) (abs <| hash asmB) a b c + + if logRefEmitCalls then + printfn "let moduleBuilder%d = assemblyBuilder%d.DefineDynamicModule(%A, %A, %A)" (abs <| hash modB) (abs <| hash asmB) a b c #endif modB - member asmB.SetCustomAttributeAndLog (cinfo, bytes) = - if logRefEmitCalls then printfn "assemblyBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash asmB) cinfo bytes + member asmB.SetCustomAttributeAndLog(cinfo, bytes) = + if logRefEmitCalls then + printfn "assemblyBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash asmB) cinfo bytes + wrapCustomAttr asmB.SetCustomAttribute (cinfo, bytes) #if !FX_RESHAPED_REFEMIT - member asmB.AddResourceFileAndLog (nm1, nm2, attrs) = - if logRefEmitCalls then printfn "assemblyBuilder%d.AddResourceFile(%A, %A, enum %d)" (abs <| hash asmB) nm1 nm2 (LanguagePrimitives.EnumToValue attrs) + member asmB.AddResourceFileAndLog(nm1, nm2, attrs) = + if logRefEmitCalls then + printfn "assemblyBuilder%d.AddResourceFile(%A, %A, enum %d)" (abs <| hash asmB) nm1 nm2 (LanguagePrimitives.EnumToValue attrs) + asmB.AddResourceFile(nm1, nm2, attrs) #endif member asmB.SetCustomAttributeAndLog cab = - if logRefEmitCalls then printfn "assemblyBuilder%d.SetCustomAttribute(%A)" (abs <| hash asmB) cab - asmB.SetCustomAttribute cab + if logRefEmitCalls then + printfn "assemblyBuilder%d.SetCustomAttribute(%A)" (abs <| hash asmB) cab + asmB.SetCustomAttribute cab type ModuleBuilder with - member modB.GetArrayMethodAndLog (arrayTy, nm, flags, retTy, argTys) = - if logRefEmitCalls then printfn "moduleBuilder%d.GetArrayMethod(%A, %A, %A, %A, %A)" (abs <| hash modB) arrayTy nm flags retTy argTys + + member modB.GetArrayMethodAndLog(arrayTy, nm, flags, retTy, argTys) = + if logRefEmitCalls then + printfn "moduleBuilder%d.GetArrayMethod(%A, %A, %A, %A, %A)" (abs <| hash modB) arrayTy nm flags retTy argTys + modB.GetArrayMethod(arrayTy, nm, flags, retTy, argTys) #if !FX_RESHAPED_REFEMIT - member modB.DefineDocumentAndLog (file, lang, vendor, doctype) = + member modB.DefineDocumentAndLog(file, lang, vendor, doctype) = let symDoc = modB.DefineDocument(file, lang, vendor, doctype) - if logRefEmitCalls then printfn "let docWriter%d = moduleBuilder%d.DefineDocument(@%A, System.Guid(\"%A\"), System.Guid(\"%A\"), System.Guid(\"%A\"))" (abs <| hash symDoc) (abs <| hash modB) file lang vendor doctype + + if logRefEmitCalls then + printfn + "let docWriter%d = moduleBuilder%d.DefineDocument(@%A, System.Guid(\"%A\"), System.Guid(\"%A\"), System.Guid(\"%A\"))" + (abs <| hash symDoc) + (abs <| hash modB) + file + lang + vendor + doctype + symDoc #endif - member modB.GetTypeAndLog (nameInModule, flag1, flag2) = - if logRefEmitCalls then printfn "moduleBuilder%d.GetType(%A, %A, %A) |> ignore" (abs <| hash modB) nameInModule flag1 flag2 + member modB.GetTypeAndLog(nameInModule, flag1, flag2) = + if logRefEmitCalls then + printfn "moduleBuilder%d.GetType(%A, %A, %A) |> ignore" (abs <| hash modB) nameInModule flag1 flag2 + modB.GetType(nameInModule, flag1, flag2) - member modB.DefineTypeAndLog (name, attrs) = + member modB.DefineTypeAndLog(name, attrs) = let typB = modB.DefineType(name, attrs) - if logRefEmitCalls then printfn "let typeBuilder%d = moduleBuilder%d.DefineType(%A, enum %d)" (abs <| hash typB) (abs <| hash modB) name (LanguagePrimitives.EnumToValue attrs) + + if logRefEmitCalls then + printfn + "let typeBuilder%d = moduleBuilder%d.DefineType(%A, enum %d)" + (abs <| hash typB) + (abs <| hash modB) + name + (LanguagePrimitives.EnumToValue attrs) + typB #if !FX_RESHAPED_REFEMIT - member modB.DefineManifestResourceAndLog (name, stream, attrs) = - if logRefEmitCalls then printfn "moduleBuilder%d.DefineManifestResource(%A, %A, enum %d)" (abs <| hash modB) name stream (LanguagePrimitives.EnumToValue attrs) + member modB.DefineManifestResourceAndLog(name, stream, attrs) = + if logRefEmitCalls then + printfn + "moduleBuilder%d.DefineManifestResource(%A, %A, enum %d)" + (abs <| hash modB) + name + stream + (LanguagePrimitives.EnumToValue attrs) + modB.DefineManifestResource(name, stream, attrs) #endif - member modB.SetCustomAttributeAndLog (cinfo, bytes) = - if logRefEmitCalls then printfn "moduleBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash modB) cinfo bytes - wrapCustomAttr modB.SetCustomAttribute (cinfo, bytes) + member modB.SetCustomAttributeAndLog(cinfo, bytes) = + if logRefEmitCalls then + printfn "moduleBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash modB) cinfo bytes + wrapCustomAttr modB.SetCustomAttribute (cinfo, bytes) type ConstructorBuilder with + member consB.SetImplementationFlagsAndLog attrs = - if logRefEmitCalls then printfn "constructorBuilder%d.SetImplementationFlags(enum %d)" (abs <| hash consB) (LanguagePrimitives.EnumToValue attrs) + if logRefEmitCalls then + printfn "constructorBuilder%d.SetImplementationFlags(enum %d)" (abs <| hash consB) (LanguagePrimitives.EnumToValue attrs) + consB.SetImplementationFlags attrs - member consB.DefineParameterAndLog (n, attr, nm) = - if logRefEmitCalls then printfn "constructorBuilder%d.DefineParameter(%d, enum %d, %A)" (abs <| hash consB) n (LanguagePrimitives.EnumToValue attr) nm + member consB.DefineParameterAndLog(n, attr, nm) = + if logRefEmitCalls then + printfn "constructorBuilder%d.DefineParameter(%d, enum %d, %A)" (abs <| hash consB) n (LanguagePrimitives.EnumToValue attr) nm + consB.DefineParameter(n, attr, nm) - member consB.GetILGeneratorAndLog () = + member consB.GetILGeneratorAndLog() = let ilG = consB.GetILGenerator() - if logRefEmitCalls then printfn "let ilg%d = constructorBuilder%d.GetILGenerator()" (abs <| hash ilG) (abs <| hash consB) + + if logRefEmitCalls then + printfn "let ilg%d = constructorBuilder%d.GetILGenerator()" (abs <| hash ilG) (abs <| hash consB) + ilG type MethodBuilder with + member methB.SetImplementationFlagsAndLog attrs = - if logRefEmitCalls then printfn "methodBuilder%d.SetImplementationFlags(enum %d)" (abs <| hash methB) (LanguagePrimitives.EnumToValue attrs) + if logRefEmitCalls then + printfn "methodBuilder%d.SetImplementationFlags(enum %d)" (abs <| hash methB) (LanguagePrimitives.EnumToValue attrs) + methB.SetImplementationFlags attrs - member methB.SetSignatureAndLog (returnType, returnTypeRequiredCustomModifiers, returnTypeOptionalCustomModifiers, parameterTypes, parameterTypeRequiredCustomModifiers,parameterTypeOptionalCustomModifiers) = - if logRefEmitCalls then printfn "methodBuilder%d.SetSignature(...)" (abs <| hash methB) - methB.SetSignature(returnType, returnTypeRequiredCustomModifiers, returnTypeOptionalCustomModifiers, parameterTypes, parameterTypeRequiredCustomModifiers,parameterTypeOptionalCustomModifiers) + member methB.SetSignatureAndLog + ( + returnType, + returnTypeRequiredCustomModifiers, + returnTypeOptionalCustomModifiers, + parameterTypes, + parameterTypeRequiredCustomModifiers, + parameterTypeOptionalCustomModifiers + ) = + if logRefEmitCalls then + printfn "methodBuilder%d.SetSignature(...)" (abs <| hash methB) + + methB.SetSignature( + returnType, + returnTypeRequiredCustomModifiers, + returnTypeOptionalCustomModifiers, + parameterTypes, + parameterTypeRequiredCustomModifiers, + parameterTypeOptionalCustomModifiers + ) + + member methB.DefineParameterAndLog(n, attr, nm) = + if logRefEmitCalls then + printfn "methodBuilder%d.DefineParameter(%d, enum %d, %A)" (abs <| hash methB) n (LanguagePrimitives.EnumToValue attr) nm - member methB.DefineParameterAndLog (n, attr, nm) = - if logRefEmitCalls then printfn "methodBuilder%d.DefineParameter(%d, enum %d, %A)" (abs <| hash methB) n (LanguagePrimitives.EnumToValue attr) nm methB.DefineParameter(n, attr, nm) member methB.DefineGenericParametersAndLog gps = - if logRefEmitCalls then printfn "let gps%d = methodBuilder%d.DefineGenericParameters(%A)" (abs <| hash methB) (abs <| hash methB) gps + if logRefEmitCalls then + printfn "let gps%d = methodBuilder%d.DefineGenericParameters(%A)" (abs <| hash methB) (abs <| hash methB) gps + methB.DefineGenericParameters gps - member methB.GetILGeneratorAndLog () = + member methB.GetILGeneratorAndLog() = let ilG = methB.GetILGenerator() - if logRefEmitCalls then printfn "let ilg%d = methodBuilder%d.GetILGenerator()" (abs <| hash ilG) (abs <| hash methB) + + if logRefEmitCalls then + printfn "let ilg%d = methodBuilder%d.GetILGenerator()" (abs <| hash ilG) (abs <| hash methB) + ilG - member methB.SetCustomAttributeAndLog (cinfo, bytes) = - if logRefEmitCalls then printfn "methodBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash methB) cinfo bytes + member methB.SetCustomAttributeAndLog(cinfo, bytes) = + if logRefEmitCalls then + printfn "methodBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash methB) cinfo bytes + wrapCustomAttr methB.SetCustomAttribute (cinfo, bytes) type TypeBuilder with - member typB.CreateTypeAndLog () = - if logRefEmitCalls then printfn "typeBuilder%d.CreateType()" (abs <| hash typB) + + member typB.CreateTypeAndLog() = + if logRefEmitCalls then + printfn "typeBuilder%d.CreateType()" (abs <| hash typB) #if FX_RESHAPED_REFEMIT typB.CreateTypeInfo().AsType() #else typB.CreateType() #endif - member typB.DefineNestedTypeAndLog (name, attrs) = + member typB.DefineNestedTypeAndLog(name, attrs) = let res = typB.DefineNestedType(name, attrs) - if logRefEmitCalls then printfn "let typeBuilder%d = typeBuilder%d.DefineNestedType(\"%s\", enum %d)" (abs <| hash res) (abs <| hash typB) name (LanguagePrimitives.EnumToValue attrs) + + if logRefEmitCalls then + printfn + "let typeBuilder%d = typeBuilder%d.DefineNestedType(\"%s\", enum %d)" + (abs <| hash res) + (abs <| hash typB) + name + (LanguagePrimitives.EnumToValue attrs) + res - member typB.DefineMethodAndLog (name, attrs, cconv) = + member typB.DefineMethodAndLog(name, attrs, cconv) = let methB = typB.DefineMethod(name, attrs, cconv) - if logRefEmitCalls then printfn "let methodBuilder%d = typeBuilder%d.DefineMethod(\"%s\", enum %d, enum %d)" (abs <| hash methB) (abs <| hash typB) name (LanguagePrimitives.EnumToValue attrs) (LanguagePrimitives.EnumToValue cconv) + + if logRefEmitCalls then + printfn + "let methodBuilder%d = typeBuilder%d.DefineMethod(\"%s\", enum %d, enum %d)" + (abs <| hash methB) + (abs <| hash typB) + name + (LanguagePrimitives.EnumToValue attrs) + (LanguagePrimitives.EnumToValue cconv) + methB member typB.DefineGenericParametersAndLog gps = - if logRefEmitCalls then printfn "typeBuilder%d.DefineGenericParameters(%A)" (abs <| hash typB) gps + if logRefEmitCalls then + printfn "typeBuilder%d.DefineGenericParameters(%A)" (abs <| hash typB) gps + typB.DefineGenericParameters gps - member typB.DefineConstructorAndLog (attrs, cconv, parms) = + member typB.DefineConstructorAndLog(attrs, cconv, parms) = let consB = typB.DefineConstructor(attrs, cconv, parms) - if logRefEmitCalls then printfn "let constructorBuilder%d = typeBuilder%d.DefineConstructor(enum %d, CallingConventions.%A, %A)" (abs <| hash consB) (abs <| hash typB) (LanguagePrimitives.EnumToValue attrs) cconv parms + + if logRefEmitCalls then + printfn + "let constructorBuilder%d = typeBuilder%d.DefineConstructor(enum %d, CallingConventions.%A, %A)" + (abs <| hash consB) + (abs <| hash typB) + (LanguagePrimitives.EnumToValue attrs) + cconv + parms + consB - member typB.DefineFieldAndLog (nm, ty: Type, attrs) = + member typB.DefineFieldAndLog(nm, ty: Type, attrs) = let fieldB = typB.DefineField(nm, ty, attrs) - if logRefEmitCalls then printfn "let fieldBuilder%d = typeBuilder%d.DefineField(\"%s\", typeof<%s>, enum %d)" (abs <| hash fieldB) (abs <| hash typB) nm ty.FullName (LanguagePrimitives.EnumToValue attrs) + + if logRefEmitCalls then + printfn + "let fieldBuilder%d = typeBuilder%d.DefineField(\"%s\", typeof<%s>, enum %d)" + (abs <| hash fieldB) + (abs <| hash typB) + nm + ty.FullName + (LanguagePrimitives.EnumToValue attrs) + fieldB - member typB.DefinePropertyAndLog (nm, attrs, ty: Type, args) = - if logRefEmitCalls then printfn "typeBuilder%d.DefineProperty(\"%A\", enum %d, typeof<%s>, %A)" (abs <| hash typB) nm (LanguagePrimitives.EnumToValue attrs) ty.FullName args + member typB.DefinePropertyAndLog(nm, attrs, ty: Type, args) = + if logRefEmitCalls then + printfn + "typeBuilder%d.DefineProperty(\"%A\", enum %d, typeof<%s>, %A)" + (abs <| hash typB) + nm + (LanguagePrimitives.EnumToValue attrs) + ty.FullName + args + typB.DefineProperty(nm, attrs, ty, args) - member typB.DefineEventAndLog (nm, attrs, ty: Type) = - if logRefEmitCalls then printfn "typeBuilder%d.DefineEvent(\"%A\", enum %d, typeof<%A>)" (abs <| hash typB) nm (LanguagePrimitives.EnumToValue attrs) ty.FullName + member typB.DefineEventAndLog(nm, attrs, ty: Type) = + if logRefEmitCalls then + printfn + "typeBuilder%d.DefineEvent(\"%A\", enum %d, typeof<%A>)" + (abs <| hash typB) + nm + (LanguagePrimitives.EnumToValue attrs) + ty.FullName + typB.DefineEvent(nm, attrs, ty) - member typB.SetParentAndLog (ty: Type) = - if logRefEmitCalls then printfn "typeBuilder%d.SetParent(typeof<%s>)" (abs <| hash typB) ty.FullName + member typB.SetParentAndLog(ty: Type) = + if logRefEmitCalls then + printfn "typeBuilder%d.SetParent(typeof<%s>)" (abs <| hash typB) ty.FullName + typB.SetParent ty member typB.AddInterfaceImplementationAndLog ty = - if logRefEmitCalls then printfn "typeBuilder%d.AddInterfaceImplementation(%A)" (abs <| hash typB) ty + if logRefEmitCalls then + printfn "typeBuilder%d.AddInterfaceImplementation(%A)" (abs <| hash typB) ty + typB.AddInterfaceImplementation ty - member typB.InvokeMemberAndLog (nm, _flags, args) = + member typB.InvokeMemberAndLog(nm, _flags, args) = #if FX_RESHAPED_REFEMIT - let t = typB.CreateTypeAndLog () + let t = typB.CreateTypeAndLog() + let m = - if t <> null then t.GetMethod(nm, (args |> Seq.map(fun x -> x.GetType()) |> Seq.toArray)) - else null - if m <> null then m.Invoke(null, args) - else raise (MissingMethodException nm) + if t <> null then + t.GetMethod(nm, (args |> Seq.map (fun x -> x.GetType()) |> Seq.toArray)) + else + null + + if m <> null then + m.Invoke(null, args) + else + raise (MissingMethodException nm) #else - if logRefEmitCalls then printfn "typeBuilder%d.InvokeMember(\"%s\", enum %d, null, null, %A, Globalization.CultureInfo.InvariantCulture)" (abs <| hash typB) nm (LanguagePrimitives.EnumToValue _flags) args + if logRefEmitCalls then + printfn + "typeBuilder%d.InvokeMember(\"%s\", enum %d, null, null, %A, Globalization.CultureInfo.InvariantCulture)" + (abs <| hash typB) + nm + (LanguagePrimitives.EnumToValue _flags) + args + typB.InvokeMember(nm, _flags, null, null, args, Globalization.CultureInfo.InvariantCulture) #endif - member typB.SetCustomAttributeAndLog (cinfo, bytes) = - if logRefEmitCalls then printfn "typeBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash typB) cinfo bytes - wrapCustomAttr typB.SetCustomAttribute (cinfo, bytes) + member typB.SetCustomAttributeAndLog(cinfo, bytes) = + if logRefEmitCalls then + printfn "typeBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash typB) cinfo bytes + wrapCustomAttr typB.SetCustomAttribute (cinfo, bytes) type OpCode with - member opcode.RefEmitName = (string (Char.ToUpper(opcode.Name[0])) + opcode.Name[1..]).Replace(".", "_").Replace("_i4", "_I4") + + member opcode.RefEmitName = + (string (Char.ToUpper(opcode.Name[0])) + opcode.Name[1..]) + .Replace(".", "_") + .Replace("_i4", "_I4") type ILGenerator with - member ilG.DeclareLocalAndLog (ty: Type, isPinned) = - if logRefEmitCalls then printfn "ilg%d.DeclareLocal(typeof<%s>, %b)" (abs <| hash ilG) ty.FullName isPinned + + member ilG.DeclareLocalAndLog(ty: Type, isPinned) = + if logRefEmitCalls then + printfn "ilg%d.DeclareLocal(typeof<%s>, %b)" (abs <| hash ilG) ty.FullName isPinned + ilG.DeclareLocal(ty, isPinned) member ilG.MarkLabelAndLog lab = - if logRefEmitCalls then printfn "ilg%d.MarkLabel(label%d_%d)" (abs <| hash ilG) (abs <| hash ilG) (abs <| hash lab) + if logRefEmitCalls then + printfn "ilg%d.MarkLabel(label%d_%d)" (abs <| hash ilG) (abs <| hash ilG) (abs <| hash lab) + ilG.MarkLabel lab #if !FX_RESHAPED_REFEMIT - member ilG.MarkSequencePointAndLog (symDoc, l1, c1, l2, c2) = - if logRefEmitCalls then printfn "ilg%d.MarkSequencePoint(docWriter%d, %A, %A, %A, %A)" (abs <| hash ilG) (abs <| hash symDoc) l1 c1 l2 c2 + member ilG.MarkSequencePointAndLog(symDoc, l1, c1, l2, c2) = + if logRefEmitCalls then + printfn "ilg%d.MarkSequencePoint(docWriter%d, %A, %A, %A, %A)" (abs <| hash ilG) (abs <| hash symDoc) l1 c1 l2 c2 + ilG.MarkSequencePoint(symDoc, l1, c1, l2, c2) #endif - member ilG.BeginExceptionBlockAndLog () = - if logRefEmitCalls then printfn "ilg%d.BeginExceptionBlock()" (abs <| hash ilG) + member ilG.BeginExceptionBlockAndLog() = + if logRefEmitCalls then + printfn "ilg%d.BeginExceptionBlock()" (abs <| hash ilG) + ilG.BeginExceptionBlock() - member ilG.EndExceptionBlockAndLog () = - if logRefEmitCalls then printfn "ilg%d.EndExceptionBlock()" (abs <| hash ilG) + member ilG.EndExceptionBlockAndLog() = + if logRefEmitCalls then + printfn "ilg%d.EndExceptionBlock()" (abs <| hash ilG) + ilG.EndExceptionBlock() - member ilG.BeginFinallyBlockAndLog () = - if logRefEmitCalls then printfn "ilg%d.BeginFinallyBlock()" (abs <| hash ilG) + member ilG.BeginFinallyBlockAndLog() = + if logRefEmitCalls then + printfn "ilg%d.BeginFinallyBlock()" (abs <| hash ilG) + ilG.BeginFinallyBlock() member ilG.BeginCatchBlockAndLog ty = - if logRefEmitCalls then printfn "ilg%d.BeginCatchBlock(%A)" (abs <| hash ilG) ty + if logRefEmitCalls then + printfn "ilg%d.BeginCatchBlock(%A)" (abs <| hash ilG) ty + ilG.BeginCatchBlock ty - member ilG.BeginExceptFilterBlockAndLog () = - if logRefEmitCalls then printfn "ilg%d.BeginExceptFilterBlock()" (abs <| hash ilG) + member ilG.BeginExceptFilterBlockAndLog() = + if logRefEmitCalls then + printfn "ilg%d.BeginExceptFilterBlock()" (abs <| hash ilG) + ilG.BeginExceptFilterBlock() - member ilG.BeginFaultBlockAndLog () = - if logRefEmitCalls then printfn "ilg%d.BeginFaultBlock()" (abs <| hash ilG) + member ilG.BeginFaultBlockAndLog() = + if logRefEmitCalls then + printfn "ilg%d.BeginFaultBlock()" (abs <| hash ilG) + ilG.BeginFaultBlock() - member ilG.DefineLabelAndLog () = + member ilG.DefineLabelAndLog() = let lab = ilG.DefineLabel() - if logRefEmitCalls then printfn "let label%d_%d = ilg%d.DefineLabel()" (abs <| hash ilG) (abs <| hash lab) (abs <| hash ilG) + + if logRefEmitCalls then + printfn "let label%d_%d = ilg%d.DefineLabel()" (abs <| hash ilG) (abs <| hash lab) (abs <| hash ilG) + lab - member x.EmitAndLog (op: OpCode) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s)" (abs <| hash x) op.RefEmitName + member x.EmitAndLog(op: OpCode) = + if logRefEmitCalls then + printfn "ilg%d.Emit(OpCodes.%s)" (abs <| hash x) op.RefEmitName + x.Emit op - member x.EmitAndLog (op: OpCode, v: Label) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, label%d_%d)" (abs <| hash x) op.RefEmitName (abs <| hash x) (abs <| hash v) - x.Emit(op, v) - member x.EmitAndLog (op: OpCode, v: int16) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, int16 %d)" (abs <| hash x) op.RefEmitName v + + member x.EmitAndLog(op: OpCode, v: Label) = + if logRefEmitCalls then + printfn "ilg%d.Emit(OpCodes.%s, label%d_%d)" (abs <| hash x) op.RefEmitName (abs <| hash x) (abs <| hash v) + x.Emit(op, v) - member x.EmitAndLog (op: OpCode, v: int32) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, %d)" (abs <| hash x) op.RefEmitName v + + member x.EmitAndLog(op: OpCode, v: int16) = + if logRefEmitCalls then + printfn "ilg%d.Emit(OpCodes.%s, int16 %d)" (abs <| hash x) op.RefEmitName v + x.Emit(op, v) - member x.EmitAndLog (op: OpCode, v: MethodInfo) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, methodBuilder%d) // method %s" (abs <| hash x) op.RefEmitName (abs <| hash v) v.Name + + member x.EmitAndLog(op: OpCode, v: int32) = + if logRefEmitCalls then + printfn "ilg%d.Emit(OpCodes.%s, %d)" (abs <| hash x) op.RefEmitName v + x.Emit(op, v) - member x.EmitAndLog (op: OpCode, v: string) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, \"@%s\")" (abs <| hash x) op.RefEmitName v + + member x.EmitAndLog(op: OpCode, v: MethodInfo) = + if logRefEmitCalls then + printfn "ilg%d.Emit(OpCodes.%s, methodBuilder%d) // method %s" (abs <| hash x) op.RefEmitName (abs <| hash v) v.Name + x.Emit(op, v) - member x.EmitAndLog (op: OpCode, v: Type) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, typeof<%s>)" (abs <| hash x) op.RefEmitName v.FullName + + member x.EmitAndLog(op: OpCode, v: string) = + if logRefEmitCalls then + printfn "ilg%d.Emit(OpCodes.%s, \"@%s\")" (abs <| hash x) op.RefEmitName v + x.Emit(op, v) - member x.EmitAndLog (op: OpCode, v: FieldInfo) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, fieldBuilder%d) // field %s" (abs <| hash x) op.RefEmitName (abs <| hash v) v.Name + + member x.EmitAndLog(op: OpCode, v: Type) = + if logRefEmitCalls then + printfn "ilg%d.Emit(OpCodes.%s, typeof<%s>)" (abs <| hash x) op.RefEmitName v.FullName + x.Emit(op, v) - member x.EmitAndLog (op: OpCode, v: ConstructorInfo) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, constructor_%s)" (abs <| hash x) op.RefEmitName v.DeclaringType.Name + + member x.EmitAndLog(op: OpCode, v: FieldInfo) = + if logRefEmitCalls then + printfn "ilg%d.Emit(OpCodes.%s, fieldBuilder%d) // field %s" (abs <| hash x) op.RefEmitName (abs <| hash v) v.Name + x.Emit(op, v) + member x.EmitAndLog(op: OpCode, v: ConstructorInfo) = + if logRefEmitCalls then + printfn "ilg%d.Emit(OpCodes.%s, constructor_%s)" (abs <| hash x) op.RefEmitName v.DeclaringType.Name + + x.Emit(op, v) //---------------------------------------------------------------------------- // misc @@ -274,19 +472,36 @@ type ILGenerator with let inline flagsIf b x = if b then x else enum 0 module Zmap = - let force x m str = match Zmap.tryFind x m with Some y -> y | None -> failwithf "Zmap.force: %s: x = %+A" str x + let force x m str = + match Zmap.tryFind x m with + | Some y -> y + | None -> failwithf "Zmap.force: %s: x = %+A" str x let equalTypes (s: Type) (t: Type) = s.Equals t -let equalTypeLists ss tt = List.lengthsEqAndForall2 equalTypes ss tt -let equalTypeArrays ss tt = Array.lengthsEqAndForall2 equalTypes ss tt + +let equalTypeLists ss tt = + List.lengthsEqAndForall2 equalTypes ss tt + +let equalTypeArrays ss tt = + Array.lengthsEqAndForall2 equalTypes ss tt let getGenericArgumentsOfType (typT: Type) = - if typT.IsGenericType then typT.GetGenericArguments() else [| |] + if typT.IsGenericType then + typT.GetGenericArguments() + else + [||] + let getGenericArgumentsOfMethod (methI: MethodInfo) = - if methI.IsGenericMethod then methI.GetGenericArguments() else [| |] + if methI.IsGenericMethod then + methI.GetGenericArguments() + else + [||] let getTypeConstructor (ty: Type) = - if ty.IsGenericType then ty.GetGenericTypeDefinition() else ty + if ty.IsGenericType then + ty.GetGenericTypeDefinition() + else + ty //---------------------------------------------------------------------------- // convAssemblyRef @@ -295,12 +510,15 @@ let getTypeConstructor (ty: Type) = let convAssemblyRef (aref: ILAssemblyRef) = let asmName = AssemblyName() asmName.Name <- aref.Name + (match aref.PublicKey with | None -> () | Some (PublicKey bytes) -> asmName.SetPublicKey bytes | Some (PublicKeyToken bytes) -> asmName.SetPublicKeyToken bytes) + let setVersion (version: ILVersionInfo) = - asmName.Version <- Version (int32 version.Major, int32 version.Minor, int32 version.Build, int32 version.Revision) + asmName.Version <- Version(int32 version.Major, int32 version.Minor, int32 version.Build, int32 version.Revision) + Option.iter setVersion aref.Version // asmName.ProcessorArchitecture <- System.Reflection.ProcessorArchitecture.MSIL //Option.iter (fun name -> asmName.CultureInfo <- System.Globalization.CultureInfo.CreateSpecificCulture name) aref.Locale @@ -309,11 +527,13 @@ let convAssemblyRef (aref: ILAssemblyRef) = /// The global environment. type cenv = - { ilg: ILGlobals - emitTailcalls: bool - tryFindSysILTypeRef: string -> ILTypeRef option - generatePdb: bool - resolveAssemblyRef: ILAssemblyRef -> Choice option } + { + ilg: ILGlobals + emitTailcalls: bool + tryFindSysILTypeRef: string -> ILTypeRef option + generatePdb: bool + resolveAssemblyRef: ILAssemblyRef -> Choice option + } override x.ToString() = "" @@ -325,14 +545,15 @@ let convResolveAssemblyRef (cenv: cenv) (asmref: ILAssemblyRef) qualifiedName = let asmName = AssemblyName.GetAssemblyName(path) asmName.CodeBase <- path FileSystem.AssemblyLoader.AssemblyLoad asmName - | Some (Choice2Of2 assembly) -> - assembly + | Some (Choice2Of2 assembly) -> assembly | None -> let asmName = convAssemblyRef asmref FileSystem.AssemblyLoader.AssemblyLoad asmName + let typT = assembly.GetType qualifiedName + match typT with - | null -> error(Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, asmref.QualifiedName), range0)) + | null -> error (Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, asmref.QualifiedName), range0)) | res -> res /// Convert an Abstract IL type reference to Reflection.Emit System.Type value. @@ -343,33 +564,36 @@ let convResolveAssemblyRef (cenv: cenv) (asmref: ILAssemblyRef) qualifiedName = // [ns] , name -> ns+name // [ns;typeA;typeB], name -> ns+typeA+typeB+name let convTypeRefAux (cenv: cenv) (tref: ILTypeRef) = - let qualifiedName = (String.concat "+" (tref.Enclosing @ [ tref.Name ])).Replace(",", @"\,") + let qualifiedName = + (String.concat "+" (tref.Enclosing @ [ tref.Name ])).Replace(",", @"\,") + match tref.Scope with - | ILScopeRef.Assembly asmref -> - convResolveAssemblyRef cenv asmref qualifiedName + | ILScopeRef.Assembly asmref -> convResolveAssemblyRef cenv asmref qualifiedName | ILScopeRef.Module _ | ILScopeRef.Local _ -> let typT = Type.GetType qualifiedName + match typT with - | null -> error(Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, ""), range0)) + | null -> error (Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", qualifiedName, ""), range0)) | res -> res - | ILScopeRef.PrimaryAssembly -> - convResolveAssemblyRef cenv cenv.ilg.primaryAssemblyRef qualifiedName + | ILScopeRef.PrimaryAssembly -> convResolveAssemblyRef cenv cenv.ilg.primaryAssemblyRef qualifiedName /// The (local) emitter env (state). Some of these fields are effectively global accumulators /// and could be placed as hash tables in the global environment. [] type ILDynamicAssemblyEmitEnv = - { emTypMap: Zmap - emConsMap: Zmap - emMethMap: Zmap - emFieldMap: Zmap - emPropMap: Zmap - emLocals: LocalBuilder[] - emLabels: Zmap - emTyvars: Type[] list; // stack - emEntryPts: (TypeBuilder * string) list - delayedFieldInits: (unit -> unit) list} + { + emTypMap: Zmap + emConsMap: Zmap + emMethMap: Zmap + emFieldMap: Zmap + emPropMap: Zmap + emLocals: LocalBuilder[] + emLabels: Zmap + emTyvars: Type[] list // stack + emEntryPts: (TypeBuilder * string) list + delayedFieldInits: (unit -> unit) list + } let orderILTypeRef = ComparisonIdentity.Structural let orderILMethodRef = ComparisonIdentity.Structural @@ -377,29 +601,36 @@ let orderILFieldRef = ComparisonIdentity.Structural let orderILPropertyRef = ComparisonIdentity.Structural let emEnv0 = - { emTypMap = Zmap.empty orderILTypeRef - emConsMap = Zmap.empty orderILMethodRef - emMethMap = Zmap.empty orderILMethodRef - emFieldMap = Zmap.empty orderILFieldRef - emPropMap = Zmap.empty orderILPropertyRef - emLocals = [| |] - emLabels = Zmap.empty codeLabelOrder - emTyvars = [] - emEntryPts = [] - delayedFieldInits = [] } + { + emTypMap = Zmap.empty orderILTypeRef + emConsMap = Zmap.empty orderILMethodRef + emMethMap = Zmap.empty orderILMethodRef + emFieldMap = Zmap.empty orderILFieldRef + emPropMap = Zmap.empty orderILPropertyRef + emLocals = [||] + emLabels = Zmap.empty codeLabelOrder + emTyvars = [] + emEntryPts = [] + delayedFieldInits = [] + } let envBindTypeRef emEnv (tref: ILTypeRef) (typT, typB, typeDef) = match typT with | null -> failwithf "binding null type in envBindTypeRef: %s\n" tref.Name - | _ -> {emEnv with emTypMap = Zmap.add tref (typT, typB, typeDef, None) emEnv.emTypMap} + | _ -> + { emEnv with + emTypMap = Zmap.add tref (typT, typB, typeDef, None) emEnv.emTypMap + } let envUpdateCreatedTypeRef emEnv (tref: ILTypeRef) = // The tref's TypeBuilder has been created, so we have a Type proper. // Update the tables to include this created type (the typT held prior to this is (i think) actually (TypeBuilder :> Type). // The (TypeBuilder :> Type) does not implement all the methods that a Type proper does. - let typT, typB, typeDef, _createdTypOpt = Zmap.force tref emEnv.emTypMap "envGetTypeDef: failed" + let typT, typB, typeDef, _createdTypOpt = + Zmap.force tref emEnv.emTypMap "envGetTypeDef: failed" + if typB.IsCreated() then - let ty = typB.CreateTypeAndLog () + let ty = typB.CreateTypeAndLog() #if ENABLE_MONO_SUPPORT // Mono has a bug where executing code that includes an array type // match "match x with :? C[] -> ..." before the full loading of an object of type @@ -407,12 +638,20 @@ let envUpdateCreatedTypeRef emEnv (tref: ILTypeRef) = // of objects. We use System.Runtime.Serialization.FormatterServices.GetUninitializedObject to do // the fake allocation - this creates an "empty" object, even if the object doesn't have // a constructor. It is not usable in partial trust code. - if runningOnMono && ty.IsClass && not ty.IsAbstract && not ty.IsGenericType && not ty.IsGenericTypeDefinition then + if runningOnMono + && ty.IsClass + && not ty.IsAbstract + && not ty.IsGenericType + && not ty.IsGenericTypeDefinition then try - System.Runtime.Serialization.FormatterServices.GetUninitializedObject ty |> ignore - with _ -> () + System.Runtime.Serialization.FormatterServices.GetUninitializedObject ty + |> ignore + with + | _ -> () #endif - {emEnv with emTypMap = Zmap.add tref (typT, typB, typeDef, Some ty) emEnv.emTypMap} + { emEnv with + emTypMap = Zmap.add tref (typT, typB, typeDef, Some ty) emEnv.emTypMap + } else #if DEBUG printf "envUpdateCreatedTypeRef: expected type to be created\n" @@ -426,25 +665,33 @@ let convTypeRef cenv emEnv preferCreated (tref: ILTypeRef) = | None -> convTypeRefAux cenv tref let envBindConsRef emEnv (mref: ILMethodRef) consB = - {emEnv with emConsMap = Zmap.add mref consB emEnv.emConsMap} + { emEnv with + emConsMap = Zmap.add mref consB emEnv.emConsMap + } let envGetConsB emEnv (mref: ILMethodRef) = Zmap.force mref emEnv.emConsMap "envGetConsB: failed" let envBindMethodRef emEnv (mref: ILMethodRef) methB = - {emEnv with emMethMap = Zmap.add mref methB emEnv.emMethMap} + { emEnv with + emMethMap = Zmap.add mref methB emEnv.emMethMap + } let envGetMethB emEnv (mref: ILMethodRef) = Zmap.force mref emEnv.emMethMap "envGetMethB: failed" let envBindFieldRef emEnv fref fieldB = - {emEnv with emFieldMap = Zmap.add fref fieldB emEnv.emFieldMap} + { emEnv with + emFieldMap = Zmap.add fref fieldB emEnv.emFieldMap + } let envGetFieldB emEnv fref = Zmap.force fref emEnv.emFieldMap "- envGetMethB: failed" let envBindPropRef emEnv (pref: ILPropertyRef) propB = - {emEnv with emPropMap = Zmap.add pref propB emEnv.emPropMap} + { emEnv with + emPropMap = Zmap.add pref propB emEnv.emPropMap + } let envGetPropB emEnv pref = Zmap.force pref emEnv.emPropMap "- envGetPropB: failed" @@ -457,36 +704,51 @@ let envGetTypeDef emEnv (tref: ILTypeRef) = Zmap.force tref emEnv.emTypMap "envGetTypeDef: failed" |> (fun (_typT, _typB, typeDef, _createdTypOpt) -> typeDef) -let envSetLocals emEnv locs = assert (emEnv.emLocals.Length = 0); // check "locals" is not yet set (scopes once only) - {emEnv with emLocals = locs} -let envGetLocal emEnv i = emEnv.emLocals[i] // implicit bounds checking +let envSetLocals emEnv locs = + assert (emEnv.emLocals.Length = 0) // check "locals" is not yet set (scopes once only) + { emEnv with emLocals = locs } + +let envGetLocal emEnv i = emEnv.emLocals[i] let envSetLabel emEnv name lab = assert (not (Zmap.mem name emEnv.emLabels)) - {emEnv with emLabels = Zmap.add name lab emEnv.emLabels} -let envGetLabel emEnv name = - Zmap.find name emEnv.emLabels + { emEnv with + emLabels = Zmap.add name lab emEnv.emLabels + } + +let envGetLabel emEnv name = Zmap.find name emEnv.emLabels -let envPushTyvars emEnv tys = {emEnv with emTyvars = tys :: emEnv.emTyvars} +let envPushTyvars emEnv tys = + { emEnv with + emTyvars = tys :: emEnv.emTyvars + } -let envPopTyvars emEnv = {emEnv with emTyvars = List.tail emEnv.emTyvars} +let envPopTyvars emEnv = + { emEnv with + emTyvars = List.tail emEnv.emTyvars + } let envGetTyvar emEnv u16 = match emEnv.emTyvars with | [] -> failwith "envGetTyvar: not scope of type vars" | tvs :: _ -> let i = int32 u16 - if i<0 || i>= Array.length tvs then + + if i < 0 || i >= Array.length tvs then failwith (sprintf "want tyvar #%d, but only had %d tyvars" i (Array.length tvs)) else tvs[i] let isEmittedTypeRef emEnv tref = Zmap.mem tref emEnv.emTypMap -let envAddEntryPt emEnv mref = {emEnv with emEntryPts = mref :: emEnv.emEntryPts} +let envAddEntryPt emEnv mref = + { emEnv with + emEntryPts = mref :: emEnv.emEntryPts + } -let envPopEntryPts emEnv = {emEnv with emEntryPts = []}, emEnv.emEntryPts +let envPopEntryPts emEnv = + { emEnv with emEntryPts = [] }, emEnv.emEntryPts //---------------------------------------------------------------------------- // convCallConv @@ -510,7 +772,6 @@ let convCallConv (Callconv (hasThis, basic)) = ccA ||| ccB - //---------------------------------------------------------------------------- // convType //---------------------------------------------------------------------------- @@ -518,13 +779,16 @@ let convCallConv (Callconv (hasThis, basic)) = let rec convTypeSpec cenv emEnv preferCreated (tspec: ILTypeSpec) = let typT = convTypeRef cenv emEnv preferCreated tspec.TypeRef let tyargs = List.map (convTypeAux cenv emEnv preferCreated) tspec.GenericArgs + let res = match isNil tyargs, typT.IsGenericType with | _, true -> typT.MakeGenericType(List.toArray tyargs) | true, false -> typT | _, false -> null + match res with - | Null -> error(Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", tspec.TypeRef.QualifiedName, tspec.Scope.QualifiedName), range0)) + | Null -> + error (Error(FSComp.SR.itemNotFoundDuringDynamicCodeGen ("type", tspec.TypeRef.QualifiedName, tspec.Scope.QualifiedName), range0)) | NonNull res -> res and convTypeAux cenv emEnv preferCreated ty = @@ -538,9 +802,10 @@ and convTypeAux cenv emEnv preferCreated ty = // MakeArrayType(2) returns "eltType[, ]" // MakeArrayType(3) returns "eltType[, , ]" // All non-equal. - if nDims=1 - then baseT.MakeArrayType() - else baseT.MakeArrayType shape.Rank + if nDims = 1 then + baseT.MakeArrayType() + else + baseT.MakeArrayType shape.Rank | ILType.Value tspec -> convTypeSpec cenv emEnv preferCreated tspec | ILType.Boxed tspec -> convTypeSpec cenv emEnv preferCreated tspec | ILType.Ptr eltType -> @@ -584,22 +849,35 @@ let convTypeOrTypeDef cenv emEnv ty = let convTypes cenv emEnv (tys: ILTypes) = List.map (convType cenv emEnv) tys -let convTypesToArray cenv emEnv (tys: ILTypes) = convTypes cenv emEnv tys |> List.toArray +let convTypesToArray cenv emEnv (tys: ILTypes) = + convTypes cenv emEnv tys |> List.toArray /// Uses the .CreateType() for emitted type if available. let convCreatedType cenv emEnv ty = convTypeAux cenv emEnv true ty let convCreatedTypeRef cenv emEnv ty = convTypeRef cenv emEnv true ty let rec convParamModifiersOfType cenv emEnv (paramTy: ILType) = - [| match paramTy with + [| + match paramTy with | ILType.Modified (modreq, ty, modifiedTy) -> yield (modreq, convTypeRef cenv emEnv false ty) yield! convParamModifiersOfType cenv emEnv modifiedTy - | _ -> () |] + | _ -> () + |] let splitModifiers mods = - let reqd = mods |> Array.choose (function true, ty -> Some ty | _ -> None) - let optional = mods |> Array.choose (function false, ty -> Some ty | _ -> None) + let reqd = + mods + |> Array.choose (function + | true, ty -> Some ty + | _ -> None) + + let optional = + mods + |> Array.choose (function + | false, ty -> Some ty + | _ -> None) + reqd, optional let convParamModifiers cenv emEnv (p: ILParameter) = @@ -622,12 +900,13 @@ let TypeBuilderInstantiationT = #if ENABLE_MONO_SUPPORT if runningOnMono then let ty = Type.GetType("System.Reflection.MonoGenericClass") + match ty with | null -> Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation") | _ -> ty else #endif - Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation") + Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation") assert (not (isNull ty)) ty @@ -636,145 +915,228 @@ let typeIsNotQueryable (ty: Type) = (ty :? TypeBuilder) || ((ty.GetType()).Equals(TypeBuilderInstantiationT)) let queryableTypeGetField _emEnv (parentT: Type) (fref: ILFieldRef) = - let res = parentT.GetField(fref.Name, BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance ||| BindingFlags.Static ) + let res = + parentT.GetField( + fref.Name, + BindingFlags.Public + ||| BindingFlags.NonPublic + ||| BindingFlags.Instance + ||| BindingFlags.Static + ) + match res with - | Null -> error(Error(FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ("field", fref.Name, fref.DeclaringTypeRef.FullName, fref.DeclaringTypeRef.Scope.QualifiedName), range0)) + | Null -> + error ( + Error( + FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ( + "field", + fref.Name, + fref.DeclaringTypeRef.FullName, + fref.DeclaringTypeRef.Scope.QualifiedName + ), + range0 + ) + ) | NonNull res -> res let nonQueryableTypeGetField (parentTI: Type) (fieldInfo: FieldInfo) : FieldInfo = let res = - if parentTI.IsGenericType then TypeBuilder.GetField(parentTI, fieldInfo) - else fieldInfo + if parentTI.IsGenericType then + TypeBuilder.GetField(parentTI, fieldInfo) + else + fieldInfo + match res with - | Null -> error(Error(FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ("field", fieldInfo.Name, parentTI.AssemblyQualifiedName, parentTI.Assembly.FullName), range0)) + | Null -> + error ( + Error( + FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ( + "field", + fieldInfo.Name, + parentTI.AssemblyQualifiedName, + parentTI.Assembly.FullName + ), + range0 + ) + ) | NonNull res -> res let convFieldSpec cenv emEnv fspec = let fref = fspec.FieldRef let tref = fref.DeclaringTypeRef let parentTI = convType cenv emEnv fspec.DeclaringType + if isEmittedTypeRef emEnv tref then // NOTE: if "convType becomes convCreatedType", then handle queryable types here too. [bug 4063] (necessary? what repro?) let fieldB = envGetFieldB emEnv fref nonQueryableTypeGetField parentTI fieldB else - // Prior type. - if typeIsNotQueryable parentTI then - let parentT = getTypeConstructor parentTI - let fieldInfo = queryableTypeGetField emEnv parentT fref - nonQueryableTypeGetField parentTI fieldInfo - else - queryableTypeGetField emEnv parentTI fspec.FieldRef + // Prior type. + if typeIsNotQueryable parentTI then + let parentT = getTypeConstructor parentTI + let fieldInfo = queryableTypeGetField emEnv parentT fref + nonQueryableTypeGetField parentTI fieldInfo + else + queryableTypeGetField emEnv parentTI fspec.FieldRef //---------------------------------------------------------------------------- // convMethodRef //---------------------------------------------------------------------------- let queryableTypeGetMethodBySearch cenv emEnv parentT (mref: ILMethodRef) = - assert(not (typeIsNotQueryable parentT)) - let cconv = (if mref.CallingConv.IsStatic then BindingFlags.Static else BindingFlags.Instance) - let methInfos = parentT.GetMethods(cconv ||| BindingFlags.Public ||| BindingFlags.NonPublic) |> Array.toList - (* First, filter on name, if unique, then binding "done" *) + assert (not (typeIsNotQueryable parentT)) + + let cconv = + (if mref.CallingConv.IsStatic then + BindingFlags.Static + else + BindingFlags.Instance) + + let methInfos = + parentT.GetMethods(cconv ||| BindingFlags.Public ||| BindingFlags.NonPublic) + |> Array.toList + (* First, filter on name, if unique, then binding "done" *) let tyargTs = getGenericArgumentsOfType parentT let methInfos = methInfos |> List.filter (fun methInfo -> methInfo.Name = mref.Name) + match methInfos with - | [methInfo] -> - methInfo + | [ methInfo ] -> methInfo | _ -> - (* Second, type match. Note type erased (non-generic) F# code would not type match but they have unique names *) + (* Second, type match. Note type erased (non-generic) F# code would not type match but they have unique names *) let satisfiesParameter (a: Type option) (p: Type) = match a with | None -> true | Some a -> - if - // obvious case - p.IsAssignableFrom a - then true - elif - // both are generic - p.IsGenericType && a.IsGenericType - // non obvious due to contravariance: Action where T: IFoo accepts Action (for FooImpl: IFoo) - && p.GetGenericTypeDefinition().IsAssignableFrom(a.GetGenericTypeDefinition()) - then true - else false + if + // obvious case + p.IsAssignableFrom a then + true + elif + p.IsGenericType && a.IsGenericType + // non obvious due to contravariance: Action where T: IFoo accepts Action (for FooImpl: IFoo) + && p.GetGenericTypeDefinition().IsAssignableFrom(a.GetGenericTypeDefinition()) + then + true + else + false let satisfiesAllParameters (args: Type option array) (ps: Type array) = - if Array.length args <> Array.length ps then false - else Array.forall2 satisfiesParameter args ps + if Array.length args <> Array.length ps then + false + else + Array.forall2 satisfiesParameter args ps let select (methInfo: MethodInfo) = // mref implied Types let mtyargTIs = getGenericArgumentsOfMethod methInfo - if mtyargTIs.Length <> mref.GenericArity then false (* method generic arity mismatch *) else - - // methInfo implied Types - let methodParameters = methInfo.GetParameters() - let argTypes = mref.ArgTypes |> List.toArray - if argTypes.Length <> methodParameters.Length then false (* method argument length mismatch *) else - - let haveArgTs = methodParameters |> Array.map (fun param -> param.ParameterType) - let mrefParameterTypes = argTypes |> Array.map (fun t -> if t.IsNominal then Some (convTypeRefAux cenv t.TypeRef) else None) + if mtyargTIs.Length <> mref.GenericArity then + false (* method generic arity mismatch *) + else - // we should reject methods which don't satisfy parameter types by also checking - // type parameters which can be contravariant for delegates for example - // see https://github.com/dotnet/fsharp/issues/2411 - // without this check, subsequent call to convTypes would fail because it - // constructs generic type without checking constraints - if not (satisfiesAllParameters mrefParameterTypes haveArgTs) then false else + // methInfo implied Types + let methodParameters = methInfo.GetParameters() + let argTypes = mref.ArgTypes |> List.toArray - let argTs, resT = - let emEnv = envPushTyvars emEnv (Array.append tyargTs mtyargTIs) - let argTs = convTypes cenv emEnv mref.ArgTypes - let resT = convType cenv emEnv mref.ReturnType - argTs, resT + if argTypes.Length <> methodParameters.Length then + false (* method argument length mismatch *) + else - let haveResT = methInfo.ReturnType - (* check for match *) - if argTs.Length <> methodParameters.Length then false (* method argument length mismatch *) else - let res = equalTypes resT haveResT && equalTypeLists argTs (haveArgTs |> Array.toList) - res + let haveArgTs = methodParameters |> Array.map (fun param -> param.ParameterType) + + let mrefParameterTypes = + argTypes + |> Array.map (fun t -> + if t.IsNominal then + Some(convTypeRefAux cenv t.TypeRef) + else + None) + + // we should reject methods which don't satisfy parameter types by also checking + // type parameters which can be contravariant for delegates for example + // see https://github.com/dotnet/fsharp/issues/2411 + // without this check, subsequent call to convTypes would fail because it + // constructs generic type without checking constraints + if not (satisfiesAllParameters mrefParameterTypes haveArgTs) then + false + else + + let argTs, resT = + let emEnv = envPushTyvars emEnv (Array.append tyargTs mtyargTIs) + let argTs = convTypes cenv emEnv mref.ArgTypes + let resT = convType cenv emEnv mref.ReturnType + argTs, resT + + let haveResT = methInfo.ReturnType + (* check for match *) + if argTs.Length <> methodParameters.Length then + false (* method argument length mismatch *) + else + let res = + equalTypes resT haveResT && equalTypeLists argTs (haveArgTs |> Array.toList) + + res match List.tryFind select methInfos with | None -> let methNames = methInfos |> List.map (fun m -> m.Name) |> List.distinct - failwithf "convMethodRef: could not bind to method '%A' of type '%s'" (String.Join(", ", methNames)) parentT.AssemblyQualifiedName + + failwithf + "convMethodRef: could not bind to method '%A' of type '%s'" + (String.Join(", ", methNames)) + parentT.AssemblyQualifiedName | Some methInfo -> methInfo (* return MethodInfo for (generic) type's (generic) method *) let queryableTypeGetMethod cenv emEnv parentT (mref: ILMethodRef) : MethodInfo = - assert(not (typeIsNotQueryable parentT)) + assert (not (typeIsNotQueryable parentT)) + if mref.GenericArity = 0 then let tyargTs = getGenericArgumentsOfType parentT + let argTs, resT = let emEnv = envPushTyvars emEnv tyargTs let argTs = convTypesToArray cenv emEnv mref.ArgTypes let resT = convType cenv emEnv mref.ReturnType argTs, resT + let stat = mref.CallingConv.IsStatic - let cconv = (if stat then BindingFlags.Static else BindingFlags.Instance) + + let cconv = + (if stat then + BindingFlags.Static + else + BindingFlags.Instance) + let methInfo = try - parentT.GetMethod(mref.Name, cconv ||| BindingFlags.Public ||| BindingFlags.NonPublic, - null, - argTs, - (null: ParameterModifier[])) + parentT.GetMethod( + mref.Name, + cconv ||| BindingFlags.Public ||| BindingFlags.NonPublic, + null, + argTs, + (null: ParameterModifier[]) + ) // This can fail if there is an ambiguity w.r.t. return type - with _ -> null + with + | _ -> null + if (isNotNull methInfo && equalTypes resT methInfo.ReturnType) then - methInfo + methInfo else - queryableTypeGetMethodBySearch cenv emEnv parentT mref + queryableTypeGetMethodBySearch cenv emEnv parentT mref else queryableTypeGetMethodBySearch cenv emEnv parentT mref let nonQueryableTypeGetMethod (parentTI: Type) (methInfo: MethodInfo) : MethodInfo MaybeNull = - if (parentTI.IsGenericType && - not (equalTypes parentTI (getTypeConstructor parentTI))) - then TypeBuilder.GetMethod(parentTI, methInfo ) - else methInfo + if (parentTI.IsGenericType + && not (equalTypes parentTI (getTypeConstructor parentTI))) then + TypeBuilder.GetMethod(parentTI, methInfo) + else + methInfo let convMethodRef cenv emEnv (parentTI: Type) (mref: ILMethodRef) = let parent = mref.DeclaringTypeRef + let res = if isEmittedTypeRef emEnv parent then // NOTE: if "convType becomes convCreatedType", then handle queryable types here too. [bug 4063] @@ -782,15 +1144,22 @@ let convMethodRef cenv emEnv (parentTI: Type) (mref: ILMethodRef) = let methB = envGetMethB emEnv mref nonQueryableTypeGetMethod parentTI methB else - // Prior type. - if typeIsNotQueryable parentTI then - let parentT = getTypeConstructor parentTI - let methInfo = queryableTypeGetMethod cenv emEnv parentT mref - nonQueryableTypeGetMethod parentTI methInfo - else - queryableTypeGetMethod cenv emEnv parentTI mref + // Prior type. + if typeIsNotQueryable parentTI then + let parentT = getTypeConstructor parentTI + let methInfo = queryableTypeGetMethod cenv emEnv parentT mref + nonQueryableTypeGetMethod parentTI methInfo + else + queryableTypeGetMethod cenv emEnv parentTI mref + match res with - | Null -> error(Error(FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ("method", mref.Name, parentTI.FullName, parentTI.Assembly.FullName), range0)) + | Null -> + error ( + Error( + FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ("method", mref.Name, parentTI.FullName, parentTI.Assembly.FullName), + range0 + ) + ) | NonNull res -> res //---------------------------------------------------------------------------- @@ -799,7 +1168,10 @@ let convMethodRef cenv emEnv (parentTI: Type) (mref: ILMethodRef) = let convMethodSpec cenv emEnv (mspec: ILMethodSpec) = let typT = convType cenv emEnv mspec.DeclaringType (* (instanced) parent Type *) - let methInfo = convMethodRef cenv emEnv typT mspec.MethodRef (* (generic) method of (generic) parent *) + + let methInfo = + convMethodRef cenv emEnv typT mspec.MethodRef (* (generic) method of (generic) parent *) + let methInfo = if isNil mspec.GenericArgs then methInfo // non generic @@ -807,41 +1179,62 @@ let convMethodSpec cenv emEnv (mspec: ILMethodSpec) = let minstTs = convTypesToArray cenv emEnv mspec.GenericArgs let methInfo = methInfo.MakeGenericMethod minstTs // instantiate method methInfo + methInfo /// Get a constructor on a non-TypeBuilder type let queryableTypeGetConstructor cenv emEnv (parentT: Type) (mref: ILMethodRef) = let tyargTs = getGenericArgumentsOfType parentT + let reqArgTs = let emEnv = envPushTyvars emEnv tyargTs convTypesToArray cenv emEnv mref.ArgTypes - let res = parentT.GetConstructor(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance, null, reqArgTs, null) + + let res = + parentT.GetConstructor(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Instance, null, reqArgTs, null) + match res with - | null -> error(Error(FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ("constructor", mref.Name, parentT.FullName, parentT.Assembly.FullName), range0)) + | null -> + error ( + Error( + FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ("constructor", mref.Name, parentT.FullName, parentT.Assembly.FullName), + range0 + ) + ) | _ -> res - -let nonQueryableTypeGetConstructor (parentTI:Type) (consInfo : ConstructorInfo) : ConstructorInfo MaybeNull = - if parentTI.IsGenericType then TypeBuilder.GetConstructor(parentTI, consInfo) else consInfo +let nonQueryableTypeGetConstructor (parentTI: Type) (consInfo: ConstructorInfo) : ConstructorInfo MaybeNull = + if parentTI.IsGenericType then + TypeBuilder.GetConstructor(parentTI, consInfo) + else + consInfo /// convConstructorSpec (like convMethodSpec) let convConstructorSpec cenv emEnv (mspec: ILMethodSpec) = let mref = mspec.MethodRef let parentTI = convType cenv emEnv mspec.DeclaringType + let res = if isEmittedTypeRef emEnv mref.DeclaringTypeRef then let consB = envGetConsB emEnv mref nonQueryableTypeGetConstructor parentTI consB else - // Prior type. - if typeIsNotQueryable parentTI then - let parentT = getTypeConstructor parentTI - let ctorG = queryableTypeGetConstructor cenv emEnv parentT mref - nonQueryableTypeGetConstructor parentTI ctorG - else - queryableTypeGetConstructor cenv emEnv parentTI mref + // Prior type. + if typeIsNotQueryable parentTI then + let parentT = getTypeConstructor parentTI + let ctorG = queryableTypeGetConstructor cenv emEnv parentT mref + nonQueryableTypeGetConstructor parentTI ctorG + else + queryableTypeGetConstructor cenv emEnv parentTI mref + match res with - | Null -> error(Error(FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ("constructor", "", parentTI.FullName, parentTI.Assembly.FullName), range0)) + | Null -> + error ( + Error( + FSComp.SR.itemNotFoundInTypeDuringDynamicCodeGen ("constructor", "", parentTI.FullName, parentTI.Assembly.FullName), + range0 + ) + ) | NonNull res -> res let emitLabelMark emEnv (ilG: ILGenerator) (label: ILCodeLabel) = @@ -851,27 +1244,28 @@ let emitLabelMark emEnv (ilG: ILGenerator) (label: ILCodeLabel) = ///Emit comparison instructions. let emitInstrCompare emEnv (ilG: ILGenerator) comp targ = match comp with - | BI_beq -> ilG.EmitAndLog (OpCodes.Beq, envGetLabel emEnv targ) - | BI_bge -> ilG.EmitAndLog (OpCodes.Bge, envGetLabel emEnv targ) - | BI_bge_un -> ilG.EmitAndLog (OpCodes.Bge_Un, envGetLabel emEnv targ) - | BI_bgt -> ilG.EmitAndLog (OpCodes.Bgt, envGetLabel emEnv targ) - | BI_bgt_un -> ilG.EmitAndLog (OpCodes.Bgt_Un, envGetLabel emEnv targ) - | BI_ble -> ilG.EmitAndLog (OpCodes.Ble, envGetLabel emEnv targ) - | BI_ble_un -> ilG.EmitAndLog (OpCodes.Ble_Un, envGetLabel emEnv targ) - | BI_blt -> ilG.EmitAndLog (OpCodes.Blt, envGetLabel emEnv targ) - | BI_blt_un -> ilG.EmitAndLog (OpCodes.Blt_Un, envGetLabel emEnv targ) - | BI_bne_un -> ilG.EmitAndLog (OpCodes.Bne_Un, envGetLabel emEnv targ) - | BI_brfalse -> ilG.EmitAndLog (OpCodes.Brfalse, envGetLabel emEnv targ) - | BI_brtrue -> ilG.EmitAndLog (OpCodes.Brtrue, envGetLabel emEnv targ) - + | BI_beq -> ilG.EmitAndLog(OpCodes.Beq, envGetLabel emEnv targ) + | BI_bge -> ilG.EmitAndLog(OpCodes.Bge, envGetLabel emEnv targ) + | BI_bge_un -> ilG.EmitAndLog(OpCodes.Bge_Un, envGetLabel emEnv targ) + | BI_bgt -> ilG.EmitAndLog(OpCodes.Bgt, envGetLabel emEnv targ) + | BI_bgt_un -> ilG.EmitAndLog(OpCodes.Bgt_Un, envGetLabel emEnv targ) + | BI_ble -> ilG.EmitAndLog(OpCodes.Ble, envGetLabel emEnv targ) + | BI_ble_un -> ilG.EmitAndLog(OpCodes.Ble_Un, envGetLabel emEnv targ) + | BI_blt -> ilG.EmitAndLog(OpCodes.Blt, envGetLabel emEnv targ) + | BI_blt_un -> ilG.EmitAndLog(OpCodes.Blt_Un, envGetLabel emEnv targ) + | BI_bne_un -> ilG.EmitAndLog(OpCodes.Bne_Un, envGetLabel emEnv targ) + | BI_brfalse -> ilG.EmitAndLog(OpCodes.Brfalse, envGetLabel emEnv targ) + | BI_brtrue -> ilG.EmitAndLog(OpCodes.Brtrue, envGetLabel emEnv targ) /// Emit the volatile. prefix -let emitInstrVolatile (ilG: ILGenerator) = function +let emitInstrVolatile (ilG: ILGenerator) = + function | Volatile -> ilG.EmitAndLog OpCodes.Volatile | Nonvolatile -> () /// Emit the align. prefix -let emitInstrAlign (ilG: ILGenerator) = function +let emitInstrAlign (ilG: ILGenerator) = + function | Aligned -> () | Unaligned1 -> ilG.Emit(OpCodes.Unaligned, 1L) // note: doc says use "long" overload! | Unaligned2 -> ilG.Emit(OpCodes.Unaligned, 2L) @@ -880,12 +1274,15 @@ let emitInstrAlign (ilG: ILGenerator) = function /// Emit the tail. prefix if necessary let emitInstrTail (cenv: cenv) (ilG: ILGenerator) tail emitTheCall = match tail with - | Tailcall when cenv.emitTailcalls -> ilG.EmitAndLog OpCodes.Tailcall; emitTheCall(); ilG.EmitAndLog OpCodes.Ret - | _ -> emitTheCall() + | Tailcall when cenv.emitTailcalls -> + ilG.EmitAndLog OpCodes.Tailcall + emitTheCall () + ilG.EmitAndLog OpCodes.Ret + | _ -> emitTheCall () let emitInstrNewobj cenv emEnv (ilG: ILGenerator) mspec varargs = match varargs with - | None -> ilG.EmitAndLog (OpCodes.Newobj, convConstructorSpec cenv emEnv mspec) + | None -> ilG.EmitAndLog(OpCodes.Newobj, convConstructorSpec cenv emEnv mspec) | Some _varargTys -> failwith "emit: pending new varargs" // XXX - gap let emitSilverlightCheck (ilG: ILGenerator) = @@ -896,21 +1293,23 @@ let emitInstrCall cenv emEnv (ilG: ILGenerator) opCall tail (mspec: ILMethodSpec emitInstrTail cenv ilG tail (fun () -> if mspec.MethodRef.Name = ".ctor" || mspec.MethodRef.Name = ".cctor" then let cinfo = convConstructorSpec cenv emEnv mspec + match varargs with - | None -> ilG.EmitAndLog (opCall, cinfo) + | None -> ilG.EmitAndLog(opCall, cinfo) | Some _varargTys -> failwith "emitInstrCall: .ctor and varargs" else let minfo = convMethodSpec cenv emEnv mspec + match varargs with - | None -> ilG.EmitAndLog (opCall, minfo) - | Some varargTys -> ilG.EmitCall (opCall, minfo, convTypesToArray cenv emEnv varargTys) - ) + | None -> ilG.EmitAndLog(opCall, minfo) + | Some varargTys -> ilG.EmitCall(opCall, minfo, convTypesToArray cenv emEnv varargTys)) let getGenericMethodDefinition q (ty: Type) = let gminfo = match q with - | Quotations.Patterns.Call(_, minfo, _) -> minfo.GetGenericMethodDefinition() + | Quotations.Patterns.Call (_, minfo, _) -> minfo.GetGenericMethodDefinition() | _ -> failwith "unexpected failure decoding quotation at ilreflect startup" + gminfo.MakeGenericMethod [| ty |] let getArrayMethInfo n ty = @@ -927,7 +1326,6 @@ let setArrayMethInfo n ty = | 4 -> getGenericMethodDefinition <@@ LanguagePrimitives.IntrinsicFunctions.SetArray4D null 0 0 0 0 0 @@> ty | _ -> invalidArg "n" "not expecting array dimension > 4" - //---------------------------------------------------------------------------- // emitInstr cenv //---------------------------------------------------------------------------- @@ -1016,16 +1414,17 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr = | AI_pop -> ilG.EmitAndLog OpCodes.Pop | AI_ckfinite -> ilG.EmitAndLog OpCodes.Ckfinite | AI_nop -> ilG.EmitAndLog OpCodes.Nop - | AI_ldc (DT_I4, ILConst.I4 i32) -> ilG.EmitAndLog (OpCodes.Ldc_I4, i32) + | AI_ldc (DT_I4, ILConst.I4 i32) -> ilG.EmitAndLog(OpCodes.Ldc_I4, i32) | AI_ldc (DT_I8, ILConst.I8 i64) -> ilG.Emit(OpCodes.Ldc_I8, i64) | AI_ldc (DT_R4, ILConst.R4 r32) -> ilG.Emit(OpCodes.Ldc_R4, r32) | AI_ldc (DT_R8, ILConst.R8 r64) -> ilG.Emit(OpCodes.Ldc_R8, r64) | AI_ldc _ -> failwith "emitInstrI_arith (AI_ldc (ty, const)) iltyped" - | I_ldarg u16 -> ilG.EmitAndLog (OpCodes.Ldarg, int16 u16) - | I_ldarga u16 -> ilG.EmitAndLog (OpCodes.Ldarga, int16 u16) + | I_ldarg u16 -> ilG.EmitAndLog(OpCodes.Ldarg, int16 u16) + | I_ldarga u16 -> ilG.EmitAndLog(OpCodes.Ldarga, int16 u16) | I_ldind (align, vol, dt) -> emitInstrAlign ilG align emitInstrVolatile ilG vol + match dt with | DT_I -> ilG.EmitAndLog OpCodes.Ldind_I | DT_I1 -> ilG.EmitAndLog OpCodes.Ldind_I1 @@ -1041,12 +1440,13 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr = | DT_U4 -> ilG.EmitAndLog OpCodes.Ldind_U4 | DT_U8 -> failwith "emitInstr cenv: ldind U8" | DT_REF -> ilG.EmitAndLog OpCodes.Ldind_Ref - | I_ldloc u16 -> ilG.EmitAndLog (OpCodes.Ldloc, int16 u16) - | I_ldloca u16 -> ilG.EmitAndLog (OpCodes.Ldloca, int16 u16) - | I_starg u16 -> ilG.EmitAndLog (OpCodes.Starg, int16 u16) + | I_ldloc u16 -> ilG.EmitAndLog(OpCodes.Ldloc, int16 u16) + | I_ldloca u16 -> ilG.EmitAndLog(OpCodes.Ldloca, int16 u16) + | I_starg u16 -> ilG.EmitAndLog(OpCodes.Starg, int16 u16) | I_stind (align, vol, dt) -> emitInstrAlign ilG align emitInstrVolatile ilG vol + match dt with | DT_I -> ilG.EmitAndLog OpCodes.Stind_I | DT_I1 -> ilG.EmitAndLog OpCodes.Stind_I1 @@ -1056,15 +1456,15 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr = | DT_R -> failwith "emitInstr cenv: stind R" | DT_R4 -> ilG.EmitAndLog OpCodes.Stind_R4 | DT_R8 -> ilG.EmitAndLog OpCodes.Stind_R8 - | DT_U -> ilG.EmitAndLog OpCodes.Stind_I // NOTE: unsigned -> int conversion - | DT_U1 -> ilG.EmitAndLog OpCodes.Stind_I1 // NOTE: follows code ilwrite.fs - | DT_U2 -> ilG.EmitAndLog OpCodes.Stind_I2 // NOTE: is it ok? - | DT_U4 -> ilG.EmitAndLog OpCodes.Stind_I4 // NOTE: it is generated by bytearray tests - | DT_U8 -> ilG.EmitAndLog OpCodes.Stind_I8 // NOTE: unsigned -> int conversion + | DT_U -> ilG.EmitAndLog OpCodes.Stind_I // NOTE: unsigned -> int conversion + | DT_U1 -> ilG.EmitAndLog OpCodes.Stind_I1 // NOTE: follows code ilwrite.fs + | DT_U2 -> ilG.EmitAndLog OpCodes.Stind_I2 // NOTE: is it ok? + | DT_U4 -> ilG.EmitAndLog OpCodes.Stind_I4 // NOTE: it is generated by bytearray tests + | DT_U8 -> ilG.EmitAndLog OpCodes.Stind_I8 // NOTE: unsigned -> int conversion | DT_REF -> ilG.EmitAndLog OpCodes.Stind_Ref - | I_stloc u16 -> ilG.EmitAndLog (OpCodes.Stloc, int16 u16) - | I_br targ -> ilG.EmitAndLog (OpCodes.Br, envGetLabel emEnv targ) - | I_jmp mspec -> ilG.EmitAndLog (OpCodes.Jmp, convMethodSpec cenv emEnv mspec) + | I_stloc u16 -> ilG.EmitAndLog(OpCodes.Stloc, int16 u16) + | I_br targ -> ilG.EmitAndLog(OpCodes.Br, envGetLabel emEnv targ) + | I_jmp mspec -> ilG.EmitAndLog(OpCodes.Jmp, convMethodSpec cenv emEnv mspec) | I_brcmp (comp, targ) -> emitInstrCompare emEnv ilG comp targ | I_switch labels -> ilG.Emit(OpCodes.Switch, Array.ofList (List.map (envGetLabel emEnv) labels)) | I_ret -> ilG.EmitAndLog OpCodes.Ret @@ -1083,69 +1483,76 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr = | I_calli (tail, callsig, None) -> emitInstrTail cenv ilG tail (fun () -> - ilG.EmitCalli(OpCodes.Calli, - convCallConv callsig.CallingConv, - convType cenv emEnv callsig.ReturnType, - convTypesToArray cenv emEnv callsig.ArgTypes, - Unchecked.defaultof)) + ilG.EmitCalli( + OpCodes.Calli, + convCallConv callsig.CallingConv, + convType cenv emEnv callsig.ReturnType, + convTypesToArray cenv emEnv callsig.ArgTypes, + Unchecked.defaultof + )) | I_calli (tail, callsig, Some varargTys) -> emitInstrTail cenv ilG tail (fun () -> - ilG.EmitCalli(OpCodes.Calli, - convCallConv callsig.CallingConv, - convType cenv emEnv callsig.ReturnType, - convTypesToArray cenv emEnv callsig.ArgTypes, - convTypesToArray cenv emEnv varargTys)) + ilG.EmitCalli( + OpCodes.Calli, + convCallConv callsig.CallingConv, + convType cenv emEnv callsig.ReturnType, + convTypesToArray cenv emEnv callsig.ArgTypes, + convTypesToArray cenv emEnv varargTys + )) - | I_ldftn mspec -> - ilG.EmitAndLog (OpCodes.Ldftn, convMethodSpec cenv emEnv mspec) + | I_ldftn mspec -> ilG.EmitAndLog(OpCodes.Ldftn, convMethodSpec cenv emEnv mspec) - | I_newobj (mspec, varargs) -> - emitInstrNewobj cenv emEnv ilG mspec varargs + | I_newobj (mspec, varargs) -> emitInstrNewobj cenv emEnv ilG mspec varargs | I_throw -> ilG.EmitAndLog OpCodes.Throw | I_endfinally -> ilG.EmitAndLog OpCodes.Endfinally | I_endfilter -> ilG.EmitAndLog OpCodes.Endfilter - | I_leave label -> ilG.EmitAndLog (OpCodes.Leave, envGetLabel emEnv label) - | I_ldsfld (vol, fspec) -> emitInstrVolatile ilG vol; ilG.EmitAndLog (OpCodes.Ldsfld, convFieldSpec cenv emEnv fspec) - | I_ldfld (align, vol, fspec) -> emitInstrAlign ilG align; emitInstrVolatile ilG vol; ilG.EmitAndLog (OpCodes.Ldfld, convFieldSpec cenv emEnv fspec) - | I_ldsflda fspec -> ilG.EmitAndLog (OpCodes.Ldsflda, convFieldSpec cenv emEnv fspec) - | I_ldflda fspec -> ilG.EmitAndLog (OpCodes.Ldflda, convFieldSpec cenv emEnv fspec) + | I_leave label -> ilG.EmitAndLog(OpCodes.Leave, envGetLabel emEnv label) + | I_ldsfld (vol, fspec) -> + emitInstrVolatile ilG vol + ilG.EmitAndLog(OpCodes.Ldsfld, convFieldSpec cenv emEnv fspec) + | I_ldfld (align, vol, fspec) -> + emitInstrAlign ilG align + emitInstrVolatile ilG vol + ilG.EmitAndLog(OpCodes.Ldfld, convFieldSpec cenv emEnv fspec) + | I_ldsflda fspec -> ilG.EmitAndLog(OpCodes.Ldsflda, convFieldSpec cenv emEnv fspec) + | I_ldflda fspec -> ilG.EmitAndLog(OpCodes.Ldflda, convFieldSpec cenv emEnv fspec) | I_stsfld (vol, fspec) -> emitInstrVolatile ilG vol - ilG.EmitAndLog (OpCodes.Stsfld, convFieldSpec cenv emEnv fspec) + ilG.EmitAndLog(OpCodes.Stsfld, convFieldSpec cenv emEnv fspec) | I_stfld (align, vol, fspec) -> emitInstrAlign ilG align emitInstrVolatile ilG vol - ilG.EmitAndLog (OpCodes.Stfld, convFieldSpec cenv emEnv fspec) - - | I_ldstr s -> ilG.EmitAndLog (OpCodes.Ldstr, s) - | I_isinst ty -> ilG.EmitAndLog (OpCodes.Isinst, convType cenv emEnv ty) - | I_castclass ty -> ilG.EmitAndLog (OpCodes.Castclass, convType cenv emEnv ty) - | I_ldtoken (ILToken.ILType ty) -> ilG.EmitAndLog (OpCodes.Ldtoken, convTypeOrTypeDef cenv emEnv ty) - | I_ldtoken (ILToken.ILMethod mspec) -> ilG.EmitAndLog (OpCodes.Ldtoken, convMethodSpec cenv emEnv mspec) - | I_ldtoken (ILToken.ILField fspec) -> ilG.EmitAndLog (OpCodes.Ldtoken, convFieldSpec cenv emEnv fspec) - | I_ldvirtftn mspec -> ilG.EmitAndLog (OpCodes.Ldvirtftn, convMethodSpec cenv emEnv mspec) + ilG.EmitAndLog(OpCodes.Stfld, convFieldSpec cenv emEnv fspec) + + | I_ldstr s -> ilG.EmitAndLog(OpCodes.Ldstr, s) + | I_isinst ty -> ilG.EmitAndLog(OpCodes.Isinst, convType cenv emEnv ty) + | I_castclass ty -> ilG.EmitAndLog(OpCodes.Castclass, convType cenv emEnv ty) + | I_ldtoken (ILToken.ILType ty) -> ilG.EmitAndLog(OpCodes.Ldtoken, convTypeOrTypeDef cenv emEnv ty) + | I_ldtoken (ILToken.ILMethod mspec) -> ilG.EmitAndLog(OpCodes.Ldtoken, convMethodSpec cenv emEnv mspec) + | I_ldtoken (ILToken.ILField fspec) -> ilG.EmitAndLog(OpCodes.Ldtoken, convFieldSpec cenv emEnv fspec) + | I_ldvirtftn mspec -> ilG.EmitAndLog(OpCodes.Ldvirtftn, convMethodSpec cenv emEnv mspec) // Value type instructions - | I_cpobj ty -> ilG.EmitAndLog (OpCodes.Cpobj, convType cenv emEnv ty) - | I_initobj ty -> ilG.EmitAndLog (OpCodes.Initobj, convType cenv emEnv ty) + | I_cpobj ty -> ilG.EmitAndLog(OpCodes.Cpobj, convType cenv emEnv ty) + | I_initobj ty -> ilG.EmitAndLog(OpCodes.Initobj, convType cenv emEnv ty) | I_ldobj (align, vol, ty) -> emitInstrAlign ilG align emitInstrVolatile ilG vol - ilG.EmitAndLog (OpCodes.Ldobj, convType cenv emEnv ty) + ilG.EmitAndLog(OpCodes.Ldobj, convType cenv emEnv ty) | I_stobj (align, vol, ty) -> emitInstrAlign ilG align emitInstrVolatile ilG vol - ilG.EmitAndLog (OpCodes.Stobj, convType cenv emEnv ty) + ilG.EmitAndLog(OpCodes.Stobj, convType cenv emEnv ty) - | I_box ty -> ilG.EmitAndLog (OpCodes.Box, convType cenv emEnv ty) - | I_unbox ty -> ilG.EmitAndLog (OpCodes.Unbox, convType cenv emEnv ty) - | I_unbox_any ty -> ilG.EmitAndLog (OpCodes.Unbox_Any, convType cenv emEnv ty) - | I_sizeof ty -> ilG.EmitAndLog (OpCodes.Sizeof, convType cenv emEnv ty) + | I_box ty -> ilG.EmitAndLog(OpCodes.Box, convType cenv emEnv ty) + | I_unbox ty -> ilG.EmitAndLog(OpCodes.Unbox, convType cenv emEnv ty) + | I_unbox_any ty -> ilG.EmitAndLog(OpCodes.Unbox_Any, convType cenv emEnv ty) + | I_sizeof ty -> ilG.EmitAndLog(OpCodes.Sizeof, convType cenv emEnv ty) // Generalized array instructions. // In AbsIL these instructions include @@ -1194,23 +1601,29 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr = | DT_REF -> ilG.EmitAndLog OpCodes.Stelem_Ref | I_ldelema (ro, _isNativePtr, shape, ty) -> - if (ro = ReadonlyAddress) then ilG.EmitAndLog OpCodes.Readonly + if (ro = ReadonlyAddress) then + ilG.EmitAndLog OpCodes.Readonly + if shape = ILArrayShape.SingleDimensional then - ilG.EmitAndLog (OpCodes.Ldelema, convType cenv emEnv ty) + ilG.EmitAndLog(OpCodes.Ldelema, convType cenv emEnv ty) else let arrayTy = convType cenv emEnv (ILType.Array(shape, ty)) let elemTy = arrayTy.GetElementType() let argTys = Array.create shape.Rank typeof let retTy = elemTy.MakeByRefType() - let meth = modB.GetArrayMethodAndLog (arrayTy, "Address", CallingConventions.HasThis, retTy, argTys) - ilG.EmitAndLog (OpCodes.Call, meth) + + let meth = + modB.GetArrayMethodAndLog(arrayTy, "Address", CallingConventions.HasThis, retTy, argTys) + + ilG.EmitAndLog(OpCodes.Call, meth) | I_ldelem_any (shape, ty) -> if shape = ILArrayShape.SingleDimensional then - ilG.EmitAndLog (OpCodes.Ldelem, convType cenv emEnv ty) + ilG.EmitAndLog(OpCodes.Ldelem, convType cenv emEnv ty) else let arrayTy = convType cenv emEnv (ILType.Array(shape, ty)) let elemTy = arrayTy.GetElementType() + let meth = #if ENABLE_MONO_SUPPORT // See bug 6254: Mono has a bug in reflection-emit dynamic calls to the "Get", "Address" or "Set" methods on arrays @@ -1218,15 +1631,17 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr = getArrayMethInfo shape.Rank elemTy else #endif - modB.GetArrayMethodAndLog (arrayTy, "Get", CallingConventions.HasThis, elemTy, Array.create shape.Rank typeof ) - ilG.EmitAndLog (OpCodes.Call, meth) + modB.GetArrayMethodAndLog(arrayTy, "Get", CallingConventions.HasThis, elemTy, Array.create shape.Rank typeof) + + ilG.EmitAndLog(OpCodes.Call, meth) | I_stelem_any (shape, ty) -> if shape = ILArrayShape.SingleDimensional then - ilG.EmitAndLog (OpCodes.Stelem, convType cenv emEnv ty) + ilG.EmitAndLog(OpCodes.Stelem, convType cenv emEnv ty) else let arrayTy = convType cenv emEnv (ILType.Array(shape, ty)) let elemTy = arrayTy.GetElementType() + let meth = #if ENABLE_MONO_SUPPORT // See bug 6254: Mono has a bug in reflection-emit dynamic calls to the "Get", "Address" or "Set" methods on arrays @@ -1234,21 +1649,31 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr = setArrayMethInfo shape.Rank elemTy else #endif - modB.GetArrayMethodAndLog(arrayTy, "Set", CallingConventions.HasThis, null, Array.append (Array.create shape.Rank typeof) (Array.ofList [ elemTy ])) - ilG.EmitAndLog (OpCodes.Call, meth) + modB.GetArrayMethodAndLog( + arrayTy, + "Set", + CallingConventions.HasThis, + null, + Array.append (Array.create shape.Rank typeof) (Array.ofList [ elemTy ]) + ) + + ilG.EmitAndLog(OpCodes.Call, meth) | I_newarr (shape, ty) -> if shape = ILArrayShape.SingleDimensional then - ilG.EmitAndLog (OpCodes.Newarr, convType cenv emEnv ty) + ilG.EmitAndLog(OpCodes.Newarr, convType cenv emEnv ty) else let arrayTy = convType cenv emEnv (ILType.Array(shape, ty)) - let meth = modB.GetArrayMethodAndLog(arrayTy, ".ctor", CallingConventions.HasThis, null, Array.create shape.Rank typeof) - ilG.EmitAndLog (OpCodes.Newobj, meth) + + let meth = + modB.GetArrayMethodAndLog(arrayTy, ".ctor", CallingConventions.HasThis, null, Array.create shape.Rank typeof) + + ilG.EmitAndLog(OpCodes.Newobj, meth) | I_ldlen -> ilG.EmitAndLog OpCodes.Ldlen - | I_mkrefany ty -> ilG.EmitAndLog (OpCodes.Mkrefany, convType cenv emEnv ty) + | I_mkrefany ty -> ilG.EmitAndLog(OpCodes.Mkrefany, convType cenv emEnv ty) | I_refanytype -> ilG.EmitAndLog OpCodes.Refanytype - | I_refanyval ty -> ilG.EmitAndLog (OpCodes.Refanyval, convType cenv emEnv ty) + | I_refanyval ty -> ilG.EmitAndLog(OpCodes.Refanyval, convType cenv emEnv ty) | I_rethrow -> ilG.EmitAndLog OpCodes.Rethrow | I_break -> ilG.EmitAndLog OpCodes.Break | I_seqpoint src -> @@ -1257,9 +1682,20 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr = () #else if cenv.generatePdb && not (src.Document.File.EndsWithOrdinal("stdin")) then - let guid x = match x with None -> Guid.Empty | Some g -> Guid(g: byte[]) in - let symDoc = modB.DefineDocumentAndLog (src.Document.File, guid src.Document.Language, guid src.Document.Vendor, guid src.Document.DocumentType) - ilG.MarkSequencePointAndLog (symDoc, src.Line, src.Column, src.EndLine, src.EndColumn) + let guid x = + match x with + | None -> Guid.Empty + | Some g -> Guid(g: byte[]) in + + let symDoc = + modB.DefineDocumentAndLog( + src.Document.File, + guid src.Document.Language, + guid src.Document.Vendor, + guid src.Document.DocumentType + ) + + ilG.MarkSequencePointAndLog(symDoc, src.Line, src.Column, src.EndLine, src.EndColumn) #endif | I_arglist -> ilG.EmitAndLog OpCodes.Arglist | I_localloc -> ilG.EmitAndLog OpCodes.Localloc @@ -1276,54 +1712,73 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr = | EI_ldlen_multi (_, m) -> emitInstr cenv modB emEnv ilG (mkLdcInt32 m) - emitInstr cenv modB emEnv ilG (mkNormalCall(mkILNonGenericMethSpecInTy(cenv.ilg.typ_Array, ILCallingConv.Instance, "GetLength", [cenv.ilg.typ_Int32], cenv.ilg.typ_Int32))) - | i -> failwithf "the IL instruction %s cannot be emitted" (i.ToString()) + emitInstr + cenv + modB + emEnv + ilG + (mkNormalCall ( + mkILNonGenericMethSpecInTy ( + cenv.ilg.typ_Array, + ILCallingConv.Instance, + "GetLength", + [ cenv.ilg.typ_Int32 ], + cenv.ilg.typ_Int32 + ) + )) + | i -> failwithf "the IL instruction %s cannot be emitted" (i.ToString()) let emitCode cenv modB emEnv (ilG: ILGenerator) (code: ILCode) = // Pre-define the labels pending determining their actual marks let pc2lab = Dictionary() + let emEnv = - (emEnv, code.Labels) ||> Seq.fold (fun emEnv (KeyValue(label, pc)) -> - let lab = ilG.DefineLabelAndLog () + (emEnv, code.Labels) + ||> Seq.fold (fun emEnv (KeyValue (label, pc)) -> + let lab = ilG.DefineLabelAndLog() + pc2lab[pc] <- match pc2lab.TryGetValue pc with | true, labels -> lab :: labels - | _ -> [lab] + | _ -> [ lab ] + envSetLabel emEnv label lab) // Build a table that contains the operations that define where exception handlers are let pc2action = Dictionary() let lab2pc = code.Labels + let add lab action = let pc = lab2pc[lab] + pc2action[pc] <- match pc2action.TryGetValue pc with - | true, actions -> actions @ [action] - | _ -> [action] + | true, actions -> actions @ [ action ] + | _ -> [ action ] for exnSpec in code.Exceptions do let startTry, _endTry = exnSpec.Range - add startTry (fun () -> ilG.BeginExceptionBlockAndLog () |> ignore) + add startTry (fun () -> ilG.BeginExceptionBlockAndLog() |> ignore) match exnSpec.Clause with - | ILExceptionClause.Finally(startHandler, endHandler) -> + | ILExceptionClause.Finally (startHandler, endHandler) -> add startHandler ilG.BeginFinallyBlockAndLog add endHandler ilG.EndExceptionBlockAndLog - | ILExceptionClause.Fault(startHandler, endHandler) -> + | ILExceptionClause.Fault (startHandler, endHandler) -> add startHandler ilG.BeginFaultBlockAndLog add endHandler ilG.EndExceptionBlockAndLog - | ILExceptionClause.FilterCatch((startFilter, _), (startHandler, endHandler)) -> + | ILExceptionClause.FilterCatch ((startFilter, _), (startHandler, endHandler)) -> add startFilter ilG.BeginExceptFilterBlockAndLog add startHandler (fun () -> ilG.BeginCatchBlockAndLog null) add endHandler ilG.EndExceptionBlockAndLog - | ILExceptionClause.TypeCatch(ty, (startHandler, endHandler)) -> - add startHandler (fun () -> ilG.BeginCatchBlockAndLog (convType cenv emEnv ty)) + | ILExceptionClause.TypeCatch (ty, (startHandler, endHandler)) -> + add startHandler (fun () -> ilG.BeginCatchBlockAndLog(convType cenv emEnv ty)) add endHandler ilG.EndExceptionBlockAndLog // Emit the instructions @@ -1333,7 +1788,7 @@ let emitCode cenv modB emEnv (ilG: ILGenerator) (code: ILCode) = match pc2action.TryGetValue pc with | true, actions -> for action in actions do - action() + action () | _ -> () match pc2lab.TryGetValue pc with @@ -1347,13 +1802,12 @@ let emitCode cenv modB emEnv (ilG: ILGenerator) (code: ILCode) = | I_br l when code.Labels[l] = pc + 1 -> () // compress I_br to next instruction | i -> emitInstr cenv modB emEnv ilG i - let emitLocal cenv emEnv (ilG: ILGenerator) (local: ILLocal) = let ty = convType cenv emEnv local.Type - let locBuilder = ilG.DeclareLocalAndLog (ty, local.IsPinned) + let locBuilder = ilG.DeclareLocalAndLog(ty, local.IsPinned) #if !FX_NO_PDB_WRITER match local.DebugInfo with - | Some(nm, start, finish) -> locBuilder.SetLocalSymInfo(nm, start, finish) + | Some (nm, start, finish) -> locBuilder.SetLocalSymInfo(nm, start, finish) | None -> () #endif locBuilder @@ -1363,10 +1817,9 @@ let emitILMethodBody cenv modB emEnv (ilG: ILGenerator) (ilmbody: ILMethodBody) let emEnv = envSetLocals emEnv localBs emitCode cenv modB emEnv ilG ilmbody.Code - let emitMethodBody cenv modB emEnv ilG _name (mbody: MethodBody) = match mbody with - | MethodBody.IL ilmbody -> emitILMethodBody cenv modB emEnv (ilG()) ilmbody.Value + | MethodBody.IL ilmbody -> emitILMethodBody cenv modB emEnv (ilG ()) ilmbody.Value | MethodBody.PInvoke _pinvoke -> () | MethodBody.Abstract -> () | MethodBody.Native -> failwith "emitMethodBody: native" @@ -1377,8 +1830,7 @@ let convCustomAttr cenv emEnv (cattr: ILAttribute) = let data = getCustomAttrData cattr (methInfo, data) -let emitCustomAttr cenv emEnv add cattr = - add (convCustomAttr cenv emEnv cattr) +let emitCustomAttr cenv emEnv add cattr = add (convCustomAttr cenv emEnv cattr) let emitCustomAttrs cenv emEnv add (cattrs: ILAttributes) = cattrs.AsArray() |> Array.iter (emitCustomAttr cenv emEnv add) @@ -1394,37 +1846,55 @@ let buildGenParamsPass1 _emEnv defineGenericParameters (gps: ILGenericParameterD let gpsNames = gps |> List.map (fun gp -> gp.Name) defineGenericParameters (Array.ofList gpsNames) |> ignore - let buildGenParamsPass1b cenv emEnv (genArgs: Type array) (gps: ILGenericParameterDefs) = let genpBs = genArgs |> Array.map (fun x -> (x :?> GenericTypeParameterBuilder)) - gps |> List.iteri (fun i (gp: ILGenericParameterDef) -> + + gps + |> List.iteri (fun i (gp: ILGenericParameterDef) -> let gpB = genpBs[i] // the Constraints are either the parent (base) type or interfaces. let constraintTs = convTypes cenv emEnv gp.Constraints - let interfaceTs, baseTs = List.partition (fun (ty: Type) -> ty.IsInterface) constraintTs + + let interfaceTs, baseTs = + List.partition (fun (ty: Type) -> ty.IsInterface) constraintTs // set base type constraint (match baseTs with - [ ] -> () // Q: should a baseType be set? It is in some samples. Should this be a failure case? - | [ baseT ] -> gpB.SetBaseTypeConstraint baseT - | _ -> failwith "buildGenParam: multiple base types" - ) + | [] -> () // Q: should a baseType be set? It is in some samples. Should this be a failure case? + | [ baseT ] -> gpB.SetBaseTypeConstraint baseT + | _ -> failwith "buildGenParam: multiple base types") // set interface constraints (interfaces that instances of gp must meet) gpB.SetInterfaceConstraints(Array.ofList interfaceTs) - gp.CustomAttrs |> emitCustomAttrs cenv emEnv (wrapCustomAttr gpB.SetCustomAttribute) + + gp.CustomAttrs + |> emitCustomAttrs cenv emEnv (wrapCustomAttr gpB.SetCustomAttribute) let flags = GenericParameterAttributes.None + let flags = - match gp.Variance with - | NonVariant -> flags - | CoVariant -> flags ||| GenericParameterAttributes.Covariant - | ContraVariant -> flags ||| GenericParameterAttributes.Contravariant + match gp.Variance with + | NonVariant -> flags + | CoVariant -> flags ||| GenericParameterAttributes.Covariant + | ContraVariant -> flags ||| GenericParameterAttributes.Contravariant + + let flags = + if gp.HasReferenceTypeConstraint then + flags ||| GenericParameterAttributes.ReferenceTypeConstraint + else + flags - let flags = if gp.HasReferenceTypeConstraint then flags ||| GenericParameterAttributes.ReferenceTypeConstraint else flags - let flags = if gp.HasNotNullableValueTypeConstraint then flags ||| GenericParameterAttributes.NotNullableValueTypeConstraint else flags - let flags = if gp.HasDefaultConstructorConstraint then flags ||| GenericParameterAttributes.DefaultConstructorConstraint else flags + let flags = + if gp.HasNotNullableValueTypeConstraint then + flags ||| GenericParameterAttributes.NotNullableValueTypeConstraint + else + flags + + let flags = + if gp.HasDefaultConstructorConstraint then + flags ||| GenericParameterAttributes.DefaultConstructorConstraint + else + flags - gpB.SetGenericParameterAttributes flags - ) + gpB.SetGenericParameterAttributes flags) //---------------------------------------------------------------------------- // emitParameter //---------------------------------------------------------------------------- @@ -1433,15 +1903,17 @@ let emitParameter cenv emEnv (defineParameter: int * ParameterAttributes * strin // -Type: ty // -Default: ILFieldInit option // -Marshal: NativeType option; (* Marshalling map for parameters. COM Interop only. *) - let attrs = flagsIf param.IsIn ParameterAttributes.In ||| - flagsIf param.IsOut ParameterAttributes.Out ||| - flagsIf param.IsOptional ParameterAttributes.Optional + let attrs = + flagsIf param.IsIn ParameterAttributes.In + ||| flagsIf param.IsOut ParameterAttributes.Out + ||| flagsIf param.IsOptional ParameterAttributes.Optional + let name = match param.Name with | Some name -> name - | None -> "X" + string(i+1) + | None -> "X" + string (i + 1) - let parB = defineParameter(i, attrs, name) + let parB = defineParameter (i, attrs, name) emitCustomAttrs cenv emEnv (wrapCustomAttr parB.SetCustomAttribute) param.CustomAttrs //---------------------------------------------------------------------------- @@ -1456,20 +1928,23 @@ let enablePInvoke = true // Use reflection to invoke the api when we are executing on a platform that doesn't directly have this API. let definePInvokeMethod = - typeof.GetMethod("DefinePInvokeMethod", [| - typeof - typeof - typeof - typeof - typeof - typeof - typeof - typeof - typeof - typeof - typeof - typeof - typeof |]) + typeof.GetMethod + ("DefinePInvokeMethod", + [| + typeof + typeof + typeof + typeof + typeof + typeof + typeof + typeof + typeof + typeof + typeof + typeof + typeof + |]) let enablePInvoke = definePInvokeMethod <> null #endif @@ -1479,11 +1954,13 @@ 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 envAddEntryPt emEnv (typB, mdef.Name) else emEnv + match mdef.Body with | MethodBody.PInvoke pLazy when enablePInvoke -> let p = pLazy.Value @@ -1512,50 +1989,84 @@ let rec buildMethodPass2 cenv tref (typB: TypeBuilder) emEnv (mdef: ILMethodDef) #if !FX_RESHAPED_REFEMIT || NETCOREAPP3_1 // DefinePInvokeMethod was removed in early versions of coreclr, it was added back in NETCOREAPP3. // It has always been available in the desktop framework - let methB = typB.DefinePInvokeMethod(mdef.Name, p.Where.Name, p.Name, attrs, cconv, retTy, null, null, argTys, null, null, pcc, pcs) + let methB = + typB.DefinePInvokeMethod(mdef.Name, p.Where.Name, p.Name, attrs, cconv, retTy, null, null, argTys, null, null, pcc, pcs) #else // Use reflection to invoke the api when we are executing on a platform that doesn't directly have this API. let methB = - System.Diagnostics.Debug.Assert(definePInvokeMethod <> null, "Runtime does not have DefinePInvokeMethod") // Absolutely can't happen - definePInvokeMethod.Invoke(typB, [| mdef.Name; p.Where.Name; p.Name; attrs; cconv; retTy; null; null; argTys; null; null; pcc; pcs |]) :?> MethodBuilder + System.Diagnostics.Debug.Assert(definePInvokeMethod <> null, "Runtime does not have DefinePInvokeMethod") // Absolutely can't happen + + definePInvokeMethod.Invoke( + typB, + [| + mdef.Name + p.Where.Name + p.Name + attrs + cconv + retTy + null + null + argTys + null + null + pcc + pcs + |] + ) + :?> MethodBuilder #endif methB.SetImplementationFlagsAndLog implflags envBindMethodRef emEnv mref methB | _ -> - match mdef.Name with - | ".cctor" - | ".ctor" -> - let consB = typB.DefineConstructorAndLog (attrs, cconv, convTypesToArray cenv emEnv mdef.ParameterTypes) - consB.SetImplementationFlagsAndLog implflags - envBindConsRef emEnv mref consB - | _name -> - // The return/argument types may involve the generic parameters - let methB = typB.DefineMethodAndLog (mdef.Name, attrs, cconv) - - // Method generic type parameters - buildGenParamsPass1 emEnv methB.DefineGenericParametersAndLog mdef.GenericParams - let genArgs = getGenericArgumentsOfMethod methB - let emEnv = envPushTyvars emEnv (Array.append (getGenericArgumentsOfType (typB.AsType())) genArgs) - buildGenParamsPass1b cenv emEnv genArgs mdef.GenericParams - - // Set parameter and return types (may depend on generic args) - let parameterTypes = convTypesToArray cenv emEnv mdef.ParameterTypes - let parameterTypeRequiredCustomModifiers,parameterTypeOptionalCustomModifiers = - mdef.Parameters - |> List.toArray - |> Array.map (convParamModifiers cenv emEnv) - |> Array.unzip - - let returnTypeRequiredCustomModifiers, returnTypeOptionalCustomModifiers = mdef.Return |> convReturnModifiers cenv emEnv - let returnType = convType cenv emEnv mdef.Return.Type - - methB.SetSignatureAndLog (returnType, returnTypeRequiredCustomModifiers, returnTypeOptionalCustomModifiers, parameterTypes, parameterTypeRequiredCustomModifiers,parameterTypeOptionalCustomModifiers) - - let emEnv = envPopTyvars emEnv - methB.SetImplementationFlagsAndLog implflags - envBindMethodRef emEnv mref methB - + match mdef.Name with + | ".cctor" + | ".ctor" -> + let consB = + typB.DefineConstructorAndLog(attrs, cconv, convTypesToArray cenv emEnv mdef.ParameterTypes) + + consB.SetImplementationFlagsAndLog implflags + envBindConsRef emEnv mref consB + | _name -> + // The return/argument types may involve the generic parameters + let methB = typB.DefineMethodAndLog(mdef.Name, attrs, cconv) + + // Method generic type parameters + buildGenParamsPass1 emEnv methB.DefineGenericParametersAndLog mdef.GenericParams + let genArgs = getGenericArgumentsOfMethod methB + + let emEnv = + envPushTyvars emEnv (Array.append (getGenericArgumentsOfType (typB.AsType())) genArgs) + + buildGenParamsPass1b cenv emEnv genArgs mdef.GenericParams + + // Set parameter and return types (may depend on generic args) + let parameterTypes = convTypesToArray cenv emEnv mdef.ParameterTypes + + let parameterTypeRequiredCustomModifiers, parameterTypeOptionalCustomModifiers = + mdef.Parameters + |> List.toArray + |> Array.map (convParamModifiers cenv emEnv) + |> Array.unzip + + let returnTypeRequiredCustomModifiers, returnTypeOptionalCustomModifiers = + mdef.Return |> convReturnModifiers cenv emEnv + + let returnType = convType cenv emEnv mdef.Return.Type + + methB.SetSignatureAndLog( + returnType, + returnTypeRequiredCustomModifiers, + returnTypeOptionalCustomModifiers, + parameterTypes, + parameterTypeRequiredCustomModifiers, + parameterTypeOptionalCustomModifiers + ) + + let emEnv = envPopTyvars emEnv + methB.SetImplementationFlagsAndLog implflags + envBindMethodRef emEnv mref methB //---------------------------------------------------------------------------- // buildMethodPass3 cenv @@ -1563,41 +2074,50 @@ 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.Body with | MethodBody.PInvoke _p -> true | _ -> false + match mdef.Name with - | ".cctor" | ".ctor" -> - let consB = envGetConsB emEnv mref - // Constructors can not have generic parameters - assert isNil mdef.GenericParams - // Value parameters - 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.Body - emitCustomAttrs cenv emEnv (wrapCustomAttr consB.SetCustomAttribute) mdef.CustomAttrs - () - | _name -> - - let methB = envGetMethB emEnv mref - let emEnv = envPushTyvars emEnv (Array.append - (getGenericArgumentsOfType (typB.AsType())) - (getGenericArgumentsOfMethod methB)) - - if not (Array.isEmpty (mdef.Return.CustomAttrs.AsArray())) then - let retB = methB.DefineParameterAndLog (0, ParameterAttributes.Retval, null) - emitCustomAttrs cenv emEnv (wrapCustomAttr retB.SetCustomAttribute) mdef.Return.CustomAttrs - - // Value parameters - let defineParameter (i, attr, name) = methB.DefineParameterAndLog (i+1, attr, name) - 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.Body - let emEnv = envPopTyvars emEnv // case fold later... - emitCustomAttrs cenv emEnv methB.SetCustomAttributeAndLog mdef.CustomAttrs + | ".cctor" + | ".ctor" -> + let consB = envGetConsB emEnv mref + // Constructors can not have generic parameters + assert isNil mdef.GenericParams + // Value parameters + 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.Body + emitCustomAttrs cenv emEnv (wrapCustomAttr consB.SetCustomAttribute) mdef.CustomAttrs + () + | _name -> + + let methB = envGetMethB emEnv mref + + let emEnv = + envPushTyvars emEnv (Array.append (getGenericArgumentsOfType (typB.AsType())) (getGenericArgumentsOfMethod methB)) + + if not (Array.isEmpty (mdef.Return.CustomAttrs.AsArray())) then + let retB = methB.DefineParameterAndLog(0, ParameterAttributes.Retval, null) + emitCustomAttrs cenv emEnv (wrapCustomAttr retB.SetCustomAttribute) mdef.Return.CustomAttrs + + // Value parameters + let defineParameter (i, attr, name) = + methB.DefineParameterAndLog(i + 1, attr, name) + + 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.Body + + let emEnv = envPopTyvars emEnv // case fold later... + emitCustomAttrs cenv emEnv methB.SetCustomAttributeAndLog mdef.CustomAttrs //---------------------------------------------------------------------------- // buildFieldPass2 @@ -1607,11 +2127,11 @@ let buildFieldPass2 cenv tref (typB: TypeBuilder) emEnv (fdef: ILFieldDef) = let attrs = fdef.Attributes let fieldT = convType cenv emEnv fdef.FieldType + let fieldB = match fdef.Data with | Some d -> typB.DefineInitializedData(fdef.Name, d, attrs) - | None -> - typB.DefineFieldAndLog (fdef.Name, fieldT, attrs) + | None -> typB.DefineFieldAndLog(fdef.Name, fieldT, attrs) // set default value let emEnv = @@ -1619,9 +2139,8 @@ let buildFieldPass2 cenv tref (typB: TypeBuilder) emEnv (fdef: ILFieldDef) = | None -> emEnv | Some initial -> if not fieldT.IsEnum - // it is ok to init fields with type = enum that are defined in other assemblies - || not fieldT.Assembly.IsDynamic - then + // it is ok to init fields with type = enum that are defined in other assemblies + || not fieldT.Assembly.IsDynamic then fieldB.SetConstant(initial.AsObject()) emEnv else @@ -1629,7 +2148,10 @@ let buildFieldPass2 cenv tref (typB: TypeBuilder) emEnv (fdef: ILFieldDef) = // => its underlying type cannot be explicitly specified and will be inferred at the very moment of first field definition // => here we cannot detect if underlying type is already set so as a conservative solution we delay initialization of fields // to the end of pass2 (types and members are already created but method bodies are yet not emitted) - { emEnv with delayedFieldInits = (fun() -> fieldB.SetConstant(initial.AsObject())) :: emEnv.delayedFieldInits } + { emEnv with + delayedFieldInits = (fun () -> fieldB.SetConstant(initial.AsObject())) :: emEnv.delayedFieldInits + } + 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. @@ -1646,39 +2168,55 @@ let buildFieldPass3 cenv tref (_typB: TypeBuilder) emEnv (fdef: ILFieldDef) = //---------------------------------------------------------------------------- let buildPropertyPass2 cenv tref (typB: TypeBuilder) emEnv (prop: ILPropertyDef) = - let attrs = flagsIf prop.IsRTSpecialName PropertyAttributes.RTSpecialName ||| - flagsIf prop.IsSpecialName PropertyAttributes.SpecialName + let attrs = + flagsIf prop.IsRTSpecialName PropertyAttributes.RTSpecialName + ||| flagsIf prop.IsSpecialName PropertyAttributes.SpecialName + + let propB = + typB.DefinePropertyAndLog(prop.Name, attrs, convType cenv emEnv prop.PropertyType, 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.SetMethod |> Option.iter (fun mref -> propB.SetSetMethod(envGetMethB emEnv mref)) - prop.GetMethod |> Option.iter (fun mref -> propB.SetGetMethod(envGetMethB emEnv mref)) + prop.GetMethod + |> Option.iter (fun mref -> propB.SetGetMethod(envGetMethB emEnv mref)) // set default value prop.Init |> Option.iter (fun initial -> propB.SetConstant(initial.AsObject())) // custom attributes - let pref = ILPropertyRef.Create (tref, prop.Name) + let pref = ILPropertyRef.Create(tref, prop.Name) envBindPropRef emEnv pref propB let buildPropertyPass3 cenv tref (_typB: TypeBuilder) emEnv (prop: ILPropertyDef) = - let pref = ILPropertyRef.Create (tref, prop.Name) - let propB = envGetPropB emEnv pref - emitCustomAttrs cenv emEnv (wrapCustomAttr propB.SetCustomAttribute) prop.CustomAttrs + let pref = ILPropertyRef.Create(tref, prop.Name) + let propB = envGetPropB emEnv pref + emitCustomAttrs cenv emEnv (wrapCustomAttr propB.SetCustomAttribute) prop.CustomAttrs //---------------------------------------------------------------------------- // buildEventPass3 //---------------------------------------------------------------------------- - let buildEventPass3 cenv (typB: TypeBuilder) emEnv (eventDef: ILEventDef) = - let attrs = flagsIf eventDef.IsSpecialName EventAttributes.SpecialName ||| - flagsIf eventDef.IsRTSpecialName EventAttributes.RTSpecialName + let attrs = + flagsIf eventDef.IsSpecialName EventAttributes.SpecialName + ||| flagsIf eventDef.IsRTSpecialName EventAttributes.RTSpecialName + 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)) - eventDef.FireMethod |> Option.iter (fun mref -> eventB.SetRaiseMethod(envGetMethB emEnv mref)) - eventDef.OtherMethods |> List.iter (fun mref -> eventB.AddOtherMethod(envGetMethB emEnv mref)) + 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)) + + eventDef.FireMethod + |> Option.iter (fun mref -> eventB.SetRaiseMethod(envGetMethB emEnv mref)) + + eventDef.OtherMethods + |> List.iter (fun mref -> eventB.AddOtherMethod(envGetMethB emEnv mref)) + emitCustomAttrs cenv emEnv (wrapCustomAttr eventB.SetCustomAttribute) eventDef.CustomAttrs //---------------------------------------------------------------------------- @@ -1686,7 +2224,9 @@ let buildEventPass3 cenv (typB: TypeBuilder) emEnv (eventDef: ILEventDef) = //---------------------------------------------------------------------------- let buildMethodImplsPass3 cenv _tref (typB: TypeBuilder) emEnv (mimpl: ILMethodImplDef) = - let bodyMethInfo = convMethodRef cenv emEnv (typB.AsType()) mimpl.OverrideBy.MethodRef // doc: must be MethodBuilder + let bodyMethInfo = + convMethodRef cenv emEnv (typB.AsType()) mimpl.OverrideBy.MethodRef // doc: must be MethodBuilder + let (OverridesSpec (mref, dtyp)) = mimpl.Overrides let declMethTI = convType cenv emEnv dtyp let declMethInfo = convMethodRef cenv emEnv declMethTI mref @@ -1726,27 +2266,38 @@ let typeAttributesOfTypeEncoding x = | ILDefaultPInvokeEncoding.Auto -> TypeAttributes.AutoClass | ILDefaultPInvokeEncoding.Unicode -> TypeAttributes.UnicodeClass - let typeAttributesOfTypeLayout cenv emEnv x = let attr x p = - if p.Size =None && p.Pack = None then None - else - match cenv.tryFindSysILTypeRef "System.Runtime.InteropServices.StructLayoutAttribute", cenv.tryFindSysILTypeRef "System.Runtime.InteropServices.LayoutKind" with - | Some tref1, Some tref2 -> - Some(convCustomAttr cenv emEnv - (mkILCustomAttribute - (tref1, - [mkILNonGenericValueTy tref2 ], - [ ILAttribElem.Int32 x ], - (p.Pack |> Option.toList |> List.map (fun x -> ("Pack", cenv.ilg.typ_Int32, false, ILAttribElem.Int32 (int32 x)))) @ - (p.Size |> Option.toList |> List.map (fun x -> ("Size", cenv.ilg.typ_Int32, false, ILAttribElem.Int32 x)))))) - | _ -> None + if p.Size = None && p.Pack = None then + None + else + match cenv.tryFindSysILTypeRef "System.Runtime.InteropServices.StructLayoutAttribute", + cenv.tryFindSysILTypeRef "System.Runtime.InteropServices.LayoutKind" + with + | Some tref1, Some tref2 -> + Some( + convCustomAttr + cenv + emEnv + (mkILCustomAttribute ( + tref1, + [ mkILNonGenericValueTy tref2 ], + [ ILAttribElem.Int32 x ], + (p.Pack + |> Option.toList + |> List.map (fun x -> ("Pack", cenv.ilg.typ_Int32, false, ILAttribElem.Int32(int32 x)))) + @ (p.Size + |> Option.toList + |> List.map (fun x -> ("Size", cenv.ilg.typ_Int32, false, ILAttribElem.Int32 x))) + )) + ) + | _ -> None + match x with | ILTypeDefLayout.Auto -> None | ILTypeDefLayout.Explicit p -> (attr 0x02 p) | ILTypeDefLayout.Sequential p -> (attr 0x00 p) - //---------------------------------------------------------------------------- // buildTypeDefPass1 cenv //---------------------------------------------------------------------------- @@ -1767,16 +2318,20 @@ let rec buildTypeDefPass1 cenv emEnv (modB: ModuleBuilder) rootTypeBuilder nesti buildGenParamsPass1 emEnv typB.DefineGenericParametersAndLog tdef.GenericParams // bind tref -> (typT, typB) let tref = mkRefForNestedILTypeDef ILScopeRef.Local (nesting, tdef) + let typT = // Q: would it be ok to use typB :> Type ? // Maybe not, recall TypeBuilder maybe subtype of Type, but it is not THE Type. let nameInModule = tref.QualifiedName - modB.GetTypeAndLog (nameInModule, false, false) + modB.GetTypeAndLog(nameInModule, false, false) let emEnv = envBindTypeRef emEnv tref (typT, typB, tdef) // recurse on nested types - let nesting = nesting @ [tdef] - let buildNestedType emEnv tdef = buildTypeTypeDef cenv emEnv modB typB nesting tdef + let nesting = nesting @ [ tdef ] + + let buildNestedType emEnv tdef = + buildTypeTypeDef cenv emEnv modB typB nesting tdef + let emEnv = Array.fold buildNestedType emEnv (tdef.NestedTypes.AsArray()) emEnv @@ -1793,12 +2348,13 @@ let rec buildTypeDefPass1b cenv nesting emEnv (tdef: ILTypeDef) = let genArgs = getGenericArgumentsOfType (typB.AsType()) let emEnv = envPushTyvars emEnv genArgs // Parent may reference types being defined, so has to come after it's Pass1 creation - tdef.Extends |> Option.iter (fun ty -> typB.SetParentAndLog (convType cenv emEnv ty)) + tdef.Extends + |> Option.iter (fun ty -> typB.SetParentAndLog(convType cenv emEnv ty)) // build constraints on ILGenericParameterDefs. Constraints may reference types being defined, // so have to come after all types are created buildGenParamsPass1b cenv emEnv genArgs tdef.GenericParams let emEnv = envPopTyvars emEnv - let nesting = nesting @ [tdef] + let nesting = nesting @ [ tdef ] List.iter (buildTypeDefPass1b cenv nesting emEnv) (tdef.NestedTypes.AsList()) //---------------------------------------------------------------------------- @@ -1810,15 +2366,25 @@ let rec buildTypeDefPass2 cenv nesting emEnv (tdef: ILTypeDef) = let typB = envGetTypB emEnv tref let emEnv = envPushTyvars emEnv (getGenericArgumentsOfType (typB.AsType())) // add interface impls - tdef.Implements |> convTypes cenv emEnv |> List.iter (fun implT -> typB.AddInterfaceImplementationAndLog implT) + tdef.Implements + |> convTypes cenv emEnv + |> List.iter (fun implT -> typB.AddInterfaceImplementationAndLog implT) // add methods, properties - let emEnv = Array.fold (buildMethodPass2 cenv tref typB) emEnv (tdef.Methods.AsArray()) + let emEnv = + Array.fold (buildMethodPass2 cenv tref typB) emEnv (tdef.Methods.AsArray()) + let emEnv = List.fold (buildFieldPass2 cenv tref typB) emEnv (tdef.Fields.AsList()) - let emEnv = List.fold (buildPropertyPass2 cenv tref typB) emEnv (tdef.Properties.AsList()) + + let emEnv = + List.fold (buildPropertyPass2 cenv tref typB) emEnv (tdef.Properties.AsList()) + let emEnv = envPopTyvars emEnv // nested types - let nesting = nesting @ [tdef] - let emEnv = List.fold (buildTypeDefPass2 cenv nesting) emEnv (tdef.NestedTypes.AsList()) + let nesting = nesting @ [ tdef ] + + let emEnv = + List.fold (buildTypeDefPass2 cenv nesting) emEnv (tdef.NestedTypes.AsList()) + emEnv //---------------------------------------------------------------------------- @@ -1834,13 +2400,19 @@ let rec buildTypeDefPass3 cenv nesting modB emEnv (tdef: ILTypeDef) = tdef.Properties.AsList() |> List.iter (buildPropertyPass3 cenv tref typB emEnv) tdef.Events.AsList() |> List.iter (buildEventPass3 cenv typB emEnv) tdef.Fields.AsList() |> List.iter (buildFieldPass3 cenv tref typB emEnv) - let emEnv = List.fold (buildMethodImplsPass3 cenv tref typB) emEnv (tdef.MethodImpls.AsList()) + + let emEnv = + List.fold (buildMethodImplsPass3 cenv tref typB) emEnv (tdef.MethodImpls.AsList()) + tdef.CustomAttrs |> emitCustomAttrs cenv emEnv typB.SetCustomAttributeAndLog // custom attributes let emEnv = envPopTyvars emEnv // nested types - let nesting = nesting @ [tdef] - let emEnv = List.fold (buildTypeDefPass3 cenv nesting modB) emEnv (tdef.NestedTypes.AsList()) + let nesting = nesting @ [ tdef ] + + let emEnv = + List.fold (buildTypeDefPass3 cenv nesting modB) emEnv (tdef.NestedTypes.AsList()) + emEnv //---------------------------------------------------------------------------- @@ -1883,20 +2455,22 @@ let rec buildTypeDefPass3 cenv nesting modB emEnv (tdef: ILTypeDef) = //---------------------------------------------------------------------------- let getEnclosingTypeRefs (tref: ILTypeRef) = - match tref.Enclosing with - | [] -> [] - | h :: t -> List.scan (fun tr nm -> mkILTyRefInTyRef (tr, nm)) (mkILTyRef(tref.Scope, h)) t + match tref.Enclosing with + | [] -> [] + | h :: t -> List.scan (fun tr nm -> mkILTyRefInTyRef (tr, nm)) (mkILTyRef (tref.Scope, h)) t [] -type CollectTypes = ValueTypesOnly | All +type CollectTypes = + | ValueTypesOnly + | All // Find all constituent type references let rec getTypeRefsInType (allTypes: CollectTypes) ty acc = match ty with | ILType.Void | ILType.TypeVar _ -> acc - | ILType.Ptr eltType | ILType.Byref eltType -> - getTypeRefsInType allTypes eltType acc + | ILType.Ptr eltType + | ILType.Byref eltType -> getTypeRefsInType allTypes eltType acc | ILType.Array (_, eltType) -> match allTypes with | CollectTypes.ValueTypesOnly -> acc @@ -1904,11 +2478,14 @@ let rec getTypeRefsInType (allTypes: CollectTypes) ty acc = | ILType.Value tspec -> // We use CollectTypes.All because the .NET type loader appears to always eagerly require all types // referred to in an instantiation of a generic value type - tspec.TypeRef :: List.foldBack (getTypeRefsInType CollectTypes.All) tspec.GenericArgs acc + tspec.TypeRef + :: List.foldBack (getTypeRefsInType CollectTypes.All) tspec.GenericArgs acc | ILType.Boxed tspec -> match allTypes with | CollectTypes.ValueTypesOnly -> acc - | CollectTypes.All -> tspec.TypeRef :: List.foldBack (getTypeRefsInType allTypes) tspec.GenericArgs acc + | CollectTypes.All -> + tspec.TypeRef + :: List.foldBack (getTypeRefsInType allTypes) tspec.GenericArgs acc | ILType.FunctionPointer _callsig -> failwith "getTypeRefsInType: fptr" | ILType.Modified _ -> failwith "getTypeRefsInType: modified" @@ -1917,35 +2494,49 @@ 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.AsArray() 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.FieldType) + 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 + if verbose2 then + dprintf "buildTypeDefPass4: Done with dependencies of %s\n" tdef.Name and traverseType allTypes ty = getTypeRefsInType allTypes ty [] @@ -1954,55 +2545,67 @@ let createTypeRef (visited: Dictionary<_, _>, created: Dictionary<_, _>) emEnv t and traverseTypeRef tref = let typB = envGetTypB emEnv tref - if verbose2 then dprintf "- considering reference to type %s\n" typB.FullName + + if verbose2 then + dprintf "- considering reference to type %s\n" typB.FullName // Re-run traverseTypeDef if we've never visited the type. if not (visited.ContainsKey tref) then visited[tref] <- true let tdef = envGetTypeDef emEnv tref - if verbose2 then dprintf "- traversing type %s\n" typB.FullName + + if verbose2 then + dprintf "- traversing type %s\n" typB.FullName // This looks like a special case (perhaps bogus) of the dependency logic above, where // we require the type r.Name, though with "nestingToProbe" being the enclosing types of the // type being defined. let typeCreationHandler = let nestingToProbe = tref.Enclosing - ResolveEventHandler( - fun o r -> - let typeName = r.Name - let typeRef = ILTypeRef.Create(ILScopeRef.Local, nestingToProbe, typeName) - match emEnv.emTypMap.TryFind typeRef with - | Some(_, tb, _, _) -> - if not (tb.IsCreated()) then - tb.CreateTypeAndLog () |> ignore - tb.Assembly - | None -> null - ) + + ResolveEventHandler(fun o r -> + let typeName = r.Name + let typeRef = ILTypeRef.Create(ILScopeRef.Local, nestingToProbe, typeName) + + match emEnv.emTypMap.TryFind typeRef with + | Some (_, tb, _, _) -> + if not (tb.IsCreated()) then + tb.CreateTypeAndLog() |> ignore + + tb.Assembly + | None -> null) // For some reason, the handler is installed while running 'traverseTypeDef' but not while defining the type // itself. AppDomain.CurrentDomain.add_TypeResolve typeCreationHandler + try traverseTypeDef tref tdef finally - AppDomain.CurrentDomain.remove_TypeResolve typeCreationHandler + AppDomain.CurrentDomain.remove_TypeResolve typeCreationHandler // At this point, we've done everything we can to prepare the type for loading by eagerly forcing the // load of other types. Everything else is up to the implementation of System.Reflection.Emit. if not (created.ContainsKey tref) then created[tref] <- true - if verbose2 then dprintf "- creating type %s\n" typB.FullName - typB.CreateTypeAndLog () |> ignore + + if verbose2 then + dprintf "- creating type %s\n" typB.FullName + + typB.CreateTypeAndLog() |> ignore traverseTypeRef tref let rec buildTypeDefPass4 (visited, created) nesting emEnv (tdef: ILTypeDef) = - if verbose2 then dprintf "buildTypeDefPass4 %s\n" tdef.Name + if verbose2 then + dprintf "buildTypeDefPass4 %s\n" tdef.Name + let tref = mkRefForNestedILTypeDef ILScopeRef.Local (nesting, tdef) createTypeRef (visited, created) emEnv tref - // nested types - let nesting = nesting @ [tdef] - tdef.NestedTypes |> Seq.iter (buildTypeDefPass4 (visited, created) nesting emEnv) + let nesting = nesting @ [ tdef ] + + tdef.NestedTypes + |> Seq.iter (buildTypeDefPass4 (visited, created) nesting emEnv) //---------------------------------------------------------------------------- // buildModuleType @@ -2013,7 +2616,10 @@ let buildModuleTypePass1 cenv (modB: ModuleBuilder) emEnv (tdef: ILTypeDef) = let buildModuleTypePass1b cenv emEnv tdef = buildTypeDefPass1b cenv [] emEnv tdef let buildModuleTypePass2 cenv emEnv tdef = buildTypeDefPass2 cenv [] emEnv tdef -let buildModuleTypePass3 cenv modB emEnv tdef = buildTypeDefPass3 cenv [] modB emEnv tdef + +let buildModuleTypePass3 cenv modB emEnv tdef = + buildTypeDefPass3 cenv [] modB emEnv tdef + let buildModuleTypePass4 visited emEnv tdef = buildTypeDefPass4 visited [] emEnv tdef //---------------------------------------------------------------------------- @@ -2028,7 +2634,7 @@ let buildModuleFragment cenv emEnv (asmB: AssemblyBuilder) (modB: ModuleBuilder) let emEnv = (emEnv, tdefs) ||> List.fold (buildModuleTypePass2 cenv) for delayedFieldInit in emEnv.delayedFieldInits do - delayedFieldInit() + delayedFieldInit () let emEnv = { emEnv with delayedFieldInits = [] } @@ -2041,16 +2647,19 @@ let buildModuleFragment cenv emEnv (asmB: AssemblyBuilder) (modB: ModuleBuilder) #if FX_RESHAPED_REFEMIT ignore asmB #else - m.Resources.AsList() |> List.iter (fun r -> - let attribs = (match r.Access with ILResourceAccess.Public -> ResourceAttributes.Public | ILResourceAccess.Private -> ResourceAttributes.Private) + 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 bytes -> use stream = bytes.GetByteMemory().AsStream() - modB.DefineManifestResourceAndLog (r.Name, stream, attribs) - | ILResourceLocation.File (mr, _) -> - asmB.AddResourceFileAndLog (r.Name, mr.Name, attribs) - | ILResourceLocation.Assembly _ -> - failwith "references to resources other assemblies may not be emitted using System.Reflection") + modB.DefineManifestResourceAndLog(r.Name, stream, attribs) + | ILResourceLocation.File (mr, _) -> asmB.AddResourceFileAndLog(r.Name, mr.Name, attribs) + | ILResourceLocation.Assembly _ -> failwith "references to resources other assemblies may not be emitted using System.Reflection") #endif emEnv @@ -2068,7 +2677,14 @@ let defineDynamicAssemblyAndLog (asmName, flags, asmDir: string) = printfn "open System" printfn "open System.Reflection" printfn "open System.Reflection.Emit" - printfn "let assemblyBuilder%d = System.AppDomain.CurrentDomain.DefineDynamicAssembly(AssemblyName(Name=\"%s\"), enum %d, %A)" (abs <| hash asmB) asmName.Name (LanguagePrimitives.EnumToValue flags) asmDir + + printfn + "let assemblyBuilder%d = System.AppDomain.CurrentDomain.DefineDynamicAssembly(AssemblyName(Name=\"%s\"), enum %d, %A)" + (abs <| hash asmB) + asmName.Name + (LanguagePrimitives.EnumToValue flags) + asmDir + asmB let mkDynamicAssemblyAndModule (assemblyName, optimize, debugInfo: bool, collectible) = @@ -2076,46 +2692,80 @@ let mkDynamicAssemblyAndModule (assemblyName, optimize, debugInfo: bool, collect let asmDir = "." let asmName = AssemblyName() asmName.Name <- assemblyName + let asmAccess = - if collectible then AssemblyBuilderAccess.RunAndCollect + if collectible then + AssemblyBuilderAccess.RunAndCollect #if FX_RESHAPED_REFEMIT - else AssemblyBuilderAccess.Run + else + AssemblyBuilderAccess.Run #else - else AssemblyBuilderAccess.RunAndSave + else + AssemblyBuilderAccess.RunAndSave #endif let asmB = defineDynamicAssemblyAndLog (asmName, asmAccess, asmDir) + if not optimize then let daType = typeof - let daCtor = daType.GetConstructor [| typeof |] - let daBuilder = CustomAttributeBuilder(daCtor, [| System.Diagnostics.DebuggableAttribute.DebuggingModes.DisableOptimizations ||| System.Diagnostics.DebuggableAttribute.DebuggingModes.Default |]) + + let daCtor = + daType.GetConstructor [| typeof |] + + let daBuilder = + CustomAttributeBuilder( + daCtor, + [| + System.Diagnostics.DebuggableAttribute.DebuggingModes.DisableOptimizations + ||| System.Diagnostics.DebuggableAttribute.DebuggingModes.Default + |] + ) + asmB.SetCustomAttributeAndLog daBuilder - let modB = asmB.DefineDynamicModuleAndLog (assemblyName, fileName, debugInfo) + let modB = asmB.DefineDynamicModuleAndLog(assemblyName, fileName, debugInfo) asmB, modB -let EmitDynamicAssemblyFragment (ilg, emitTailcalls, emEnv, asmB: AssemblyBuilder, modB: ModuleBuilder, modul: ILModuleDef, debugInfo: bool, resolveAssemblyRef, tryFindSysILTypeRef) = - let cenv = { ilg = ilg ; emitTailcalls=emitTailcalls; generatePdb = debugInfo; resolveAssemblyRef=resolveAssemblyRef; tryFindSysILTypeRef=tryFindSysILTypeRef } +let EmitDynamicAssemblyFragment + ( + ilg, + emitTailcalls, + emEnv, + asmB: AssemblyBuilder, + modB: ModuleBuilder, + modul: ILModuleDef, + debugInfo: bool, + resolveAssemblyRef, + tryFindSysILTypeRef + ) = + let cenv = + { + ilg = ilg + emitTailcalls = emitTailcalls + generatePdb = debugInfo + resolveAssemblyRef = resolveAssemblyRef + tryFindSysILTypeRef = tryFindSysILTypeRef + } let emEnv = buildModuleFragment cenv emEnv asmB modB modul + match modul.Manifest with | None -> () | Some mani -> - // REVIEW: remainder of manifest - emitCustomAttrs cenv emEnv asmB.SetCustomAttributeAndLog mani.CustomAttrs + // REVIEW: remainder of manifest + emitCustomAttrs cenv emEnv asmB.SetCustomAttributeAndLog mani.CustomAttrs // invoke entry point methods let execEntryPtFun (typB: TypeBuilder, methodName) () = - try - ignore (typB.InvokeMemberAndLog (methodName, BindingFlags.InvokeMethod ||| BindingFlags.Public ||| BindingFlags.Static, [| |])) - None - with :? TargetInvocationException as exn -> - Some exn.InnerException + try + ignore (typB.InvokeMemberAndLog(methodName, BindingFlags.InvokeMethod ||| BindingFlags.Public ||| BindingFlags.Static, [||])) + None + with + | :? TargetInvocationException as exn -> Some exn.InnerException let emEnv, entryPts = envPopEntryPts emEnv let execs = List.map execEntryPtFun entryPts emEnv, execs - //---------------------------------------------------------------------------- // lookup* allow conversion from AbsIL to their emitted representations //---------------------------------------------------------------------------- @@ -2129,4 +2779,3 @@ let EmitDynamicAssemblyFragment (ilg, emitTailcalls, emEnv, asmB: AssemblyBuilde // So Type lookup will return the proper Type not TypeBuilder. let LookupTypeRef cenv emEnv tref = convCreatedTypeRef cenv emEnv tref let LookupType cenv emEnv ty = convCreatedType cenv emEnv ty - diff --git a/src/Compiler/AbstractIL/ilsign.fs b/src/Compiler/AbstractIL/ilsign.fs index 2fa4598aa..b4eb67b8a 100644 --- a/src/Compiler/AbstractIL/ilsign.fs +++ b/src/Compiler/AbstractIL/ilsign.fs @@ -4,102 +4,118 @@ module internal FSharp.Compiler.AbstractIL.StrongNameSign #nowarn "9" - open System - open System.IO - open System.Collections.Immutable - open System.Reflection.PortableExecutable - open System.Security.Cryptography - open System.Reflection - open System.Runtime.InteropServices - - open Internal.Utilities.Library - open FSharp.Compiler.IO - - type KeyType = +open System +open System.IO +open System.Collections.Immutable +open System.Reflection.PortableExecutable +open System.Security.Cryptography +open System.Reflection +open System.Runtime.InteropServices + +open Internal.Utilities.Library +open FSharp.Compiler.IO + +type KeyType = | Public | KeyPair - let ALG_TYPE_RSA = int (2 <<< 9) - let ALG_CLASS_KEY_EXCHANGE = int (5 <<< 13) - let ALG_CLASS_SIGNATURE = int (1 <<< 13) - let CALG_RSA_KEYX = int (ALG_CLASS_KEY_EXCHANGE ||| ALG_TYPE_RSA) - let CALG_RSA_SIGN = int (ALG_CLASS_SIGNATURE ||| ALG_TYPE_RSA) - - let ALG_CLASS_HASH = int (4 <<< 13) - let ALG_TYPE_ANY = int 0 - let CALG_SHA1 = int (ALG_CLASS_HASH ||| ALG_TYPE_ANY ||| 4) - let CALG_SHA_256 = int (ALG_CLASS_HASH ||| ALG_TYPE_ANY ||| 12) - let CALG_SHA_384 = int (ALG_CLASS_HASH ||| ALG_TYPE_ANY ||| 13) - let CALG_SHA_512 = int (ALG_CLASS_HASH ||| ALG_TYPE_ANY ||| 14) - - let PUBLICKEYBLOB = int 0x6 - let PRIVATEKEYBLOB = int 0x7 - let BLOBHEADER_CURRENT_BVERSION = int 0x2 - let BLOBHEADER_LENGTH = int 20 - let RSA_PUB_MAGIC = int 0x31415352 - let RSA_PRIV_MAGIC = int 0x32415352 - - let getResourceString (_, str) = str - let check _action hresult = - if uint32 hresult >= 0x80000000ul then +let ALG_TYPE_RSA = int (2 <<< 9) +let ALG_CLASS_KEY_EXCHANGE = int (5 <<< 13) +let ALG_CLASS_SIGNATURE = int (1 <<< 13) +let CALG_RSA_KEYX = int (ALG_CLASS_KEY_EXCHANGE ||| ALG_TYPE_RSA) +let CALG_RSA_SIGN = int (ALG_CLASS_SIGNATURE ||| ALG_TYPE_RSA) + +let ALG_CLASS_HASH = int (4 <<< 13) +let ALG_TYPE_ANY = int 0 +let CALG_SHA1 = int (ALG_CLASS_HASH ||| ALG_TYPE_ANY ||| 4) +let CALG_SHA_256 = int (ALG_CLASS_HASH ||| ALG_TYPE_ANY ||| 12) +let CALG_SHA_384 = int (ALG_CLASS_HASH ||| ALG_TYPE_ANY ||| 13) +let CALG_SHA_512 = int (ALG_CLASS_HASH ||| ALG_TYPE_ANY ||| 14) + +let PUBLICKEYBLOB = int 0x6 +let PRIVATEKEYBLOB = int 0x7 +let BLOBHEADER_CURRENT_BVERSION = int 0x2 +let BLOBHEADER_LENGTH = int 20 +let RSA_PUB_MAGIC = int 0x31415352 +let RSA_PRIV_MAGIC = int 0x32415352 + +let getResourceString (_, str) = str + +let check _action hresult = + if uint32 hresult >= 0x80000000ul then Marshal.ThrowExceptionForHR hresult - [] - type ByteArrayUnion = - [] - val UnderlyingArray: byte[] - - [] - val ImmutableArray: ImmutableArray - - new (immutableArray: ImmutableArray) = { UnderlyingArray = Array.empty; ImmutableArray = immutableArray} - - let getUnderlyingArray (array: ImmutableArray) =ByteArrayUnion(array).UnderlyingArray - - // Compute a hash over the elements of an assembly manifest file that should - // remain static (skip checksum, Authenticode signatures and strong name signature blob) - let hashAssembly (peReader:PEReader) (hashAlgorithm:IncrementalHash ) = - // Hash content of all headers - let peHeaders = peReader.PEHeaders - let peHeaderOffset = peHeaders.PEHeaderStartOffset - - // Even though some data in OptionalHeader is different for 32 and 64, this field is the same - let checkSumOffset = peHeaderOffset + 0x40; // offsetof(IMAGE_OPTIONAL_HEADER, CheckSum) - let securityDirectoryEntryOffset, peHeaderSize = - match peHeaders.PEHeader.Magic with - | PEMagic.PE32 -> peHeaderOffset + 0x80, 0xE0 // offsetof(IMAGE_OPTIONAL_HEADER32, DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY]), sizeof(IMAGE_OPTIONAL_HEADER32) - | PEMagic.PE32Plus -> peHeaderOffset + 0x90,0xF0 // offsetof(IMAGE_OPTIONAL_HEADER64, DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY]), sizeof(IMAGE_OPTIONAL_HEADER64) - | _ -> raise (BadImageFormatException(getResourceString(FSComp.SR.ilSignInvalidMagicValue()))) - - let allHeadersSize = peHeaderOffset + peHeaderSize + int peHeaders.CoffHeader.NumberOfSections * 0x28; // sizeof(IMAGE_SECTION_HEADER) - let allHeaders = - let array:byte[] = Array.zeroCreate allHeadersSize - peReader.GetEntireImage().GetContent().CopyTo(0, array, 0, allHeadersSize) - array - - // Clear checksum and security data directory - for i in 0 .. 3 do allHeaders[checkSumOffset + i] <- 0uy - for i in 0 .. 7 do allHeaders[securityDirectoryEntryOffset + i] <- 0uy - hashAlgorithm.AppendData(allHeaders, 0, allHeadersSize) - - // Hash content of all sections - let signatureDirectory = peHeaders.CorHeader.StrongNameSignatureDirectory - let signatureStart = - match peHeaders.TryGetDirectoryOffset signatureDirectory with - | true, value -> value - | _ -> raise (BadImageFormatException(getResourceString(FSComp.SR.ilSignBadImageFormat()))) - let signatureEnd = signatureStart + signatureDirectory.Size - let buffer = getUnderlyingArray (peReader.GetEntireImage().GetContent()) - let sectionHeaders = peHeaders.SectionHeaders - - for i in 0 .. (sectionHeaders.Length - 1) do - let section = sectionHeaders[i] - let mutable st = section.PointerToRawData - let en = st + section.SizeOfRawData - - if st <= signatureStart && signatureStart < en then do +[] +type ByteArrayUnion = + [] + val UnderlyingArray: byte[] + + [] + val ImmutableArray: ImmutableArray + + new(immutableArray: ImmutableArray) = + { + UnderlyingArray = Array.empty + ImmutableArray = immutableArray + } + +let getUnderlyingArray (array: ImmutableArray) = ByteArrayUnion(array).UnderlyingArray + +// Compute a hash over the elements of an assembly manifest file that should +// remain static (skip checksum, Authenticode signatures and strong name signature blob) +let hashAssembly (peReader: PEReader) (hashAlgorithm: IncrementalHash) = + // Hash content of all headers + let peHeaders = peReader.PEHeaders + let peHeaderOffset = peHeaders.PEHeaderStartOffset + + // Even though some data in OptionalHeader is different for 32 and 64, this field is the same + let checkSumOffset = peHeaderOffset + 0x40 // offsetof(IMAGE_OPTIONAL_HEADER, CheckSum) + + let securityDirectoryEntryOffset, peHeaderSize = + match peHeaders.PEHeader.Magic with + | PEMagic.PE32 -> peHeaderOffset + 0x80, 0xE0 // offsetof(IMAGE_OPTIONAL_HEADER32, DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY]), sizeof(IMAGE_OPTIONAL_HEADER32) + | PEMagic.PE32Plus -> peHeaderOffset + 0x90, 0xF0 // offsetof(IMAGE_OPTIONAL_HEADER64, DataDirectory[IMAGE_DIRECTORY_ENTRY_SECURITY]), sizeof(IMAGE_OPTIONAL_HEADER64) + | _ -> raise (BadImageFormatException(getResourceString (FSComp.SR.ilSignInvalidMagicValue ()))) + + let allHeadersSize = + peHeaderOffset + peHeaderSize + int peHeaders.CoffHeader.NumberOfSections * 0x28 // sizeof(IMAGE_SECTION_HEADER) + + let allHeaders = + let array: byte[] = Array.zeroCreate allHeadersSize + peReader.GetEntireImage().GetContent().CopyTo(0, array, 0, allHeadersSize) + array + + // Clear checksum and security data directory + for i in 0..3 do + allHeaders[checkSumOffset + i] <- 0uy + + for i in 0..7 do + allHeaders[securityDirectoryEntryOffset + i] <- 0uy + + hashAlgorithm.AppendData(allHeaders, 0, allHeadersSize) + + // Hash content of all sections + let signatureDirectory = peHeaders.CorHeader.StrongNameSignatureDirectory + + let signatureStart = + match peHeaders.TryGetDirectoryOffset signatureDirectory with + | true, value -> value + | _ -> raise (BadImageFormatException(getResourceString (FSComp.SR.ilSignBadImageFormat ()))) + + let signatureEnd = signatureStart + signatureDirectory.Size + let buffer = getUnderlyingArray (peReader.GetEntireImage().GetContent()) + let sectionHeaders = peHeaders.SectionHeaders + + for i in 0 .. (sectionHeaders.Length - 1) do + let section = sectionHeaders[i] + let mutable st = section.PointerToRawData + let en = st + section.SizeOfRawData + + if st <= signatureStart && signatureStart < en then + do // The signature should better end within this section as well - if not ( (st < signatureEnd) && (signatureEnd <= en)) then raise (BadImageFormatException()) + if not ((st < signatureEnd) && (signatureEnd <= en)) then + raise (BadImageFormatException()) // Signature starts within this section - hash everything up to the signature start hashAlgorithm.AppendData(buffer, st, signatureStart - st) @@ -107,480 +123,615 @@ module internal FSharp.Compiler.AbstractIL.StrongNameSign // Trim what we have written st <- signatureEnd - hashAlgorithm.AppendData(buffer, st, en - st) - () - hashAlgorithm.GetHashAndReset() - - type BlobReader = - val mutable _blob:byte[] - val mutable _offset:int - new (blob:byte[]) = { _blob = blob; _offset = 0; } - - member x.ReadInt32() : int = - let offset = x._offset - x._offset <- offset + 4 - int x._blob[offset] ||| (int x._blob[offset + 1] <<< 8) ||| (int x._blob[offset + 2] <<< 16) ||| (int x._blob[offset + 3] <<< 24) - - member x.ReadBigInteger (length:int):byte[] = - let arr:byte[] = Array.zeroCreate length - Array.Copy(x._blob, x._offset, arr, 0, length) - x._offset <- x._offset + length - arr |> Array.rev - - let RSAParamatersFromBlob (blob:byte[]) keyType = - let mutable reader = BlobReader blob - if reader.ReadInt32() <> 0x00000207 && keyType = KeyType.KeyPair then raise (CryptographicException(getResourceString(FSComp.SR.ilSignPrivateKeyExpected()))) - reader.ReadInt32() |> ignore // ALG_ID - if reader.ReadInt32() <> RSA_PRIV_MAGIC then raise (CryptographicException(getResourceString(FSComp.SR.ilSignRsaKeyExpected()))) // 'RSA2' - let byteLen, halfLen = - let bitLen = reader.ReadInt32() - match bitLen % 16 with - | 0 -> (bitLen / 8, bitLen / 16) - | _ -> raise (CryptographicException(getResourceString(FSComp.SR.ilSignInvalidBitLen()))) - let mutable key = RSAParameters() - key.Exponent <- reader.ReadBigInteger 4 - key.Modulus <- reader.ReadBigInteger byteLen - key.P <- reader.ReadBigInteger halfLen - key.Q <- reader.ReadBigInteger halfLen - key.DP <- reader.ReadBigInteger halfLen - key.DQ <- reader.ReadBigInteger halfLen - key.InverseQ <- reader.ReadBigInteger halfLen - key.D <- reader.ReadBigInteger byteLen - key - - let validateRSAField (field: byte[] MaybeNull) expected (name: string) = - match field with - | Null -> () - | NonNull field -> - if field.Length <> expected then - raise (CryptographicException(String.Format(getResourceString(FSComp.SR.ilSignInvalidRSAParams()), name))) - - let toCLRKeyBlob (rsaParameters: RSAParameters) (algId: int) : byte[] = - - // The original FCall this helper emulates supports other algId's - however, the only algid we need to support is CALG_RSA_KEYX. We will not port the codepaths dealing with other algid's. - if algId <> CALG_RSA_KEYX then raise (CryptographicException(getResourceString(FSComp.SR.ilSignInvalidAlgId()))) - - // Validate the RSA structure first. - if rsaParameters.Modulus = null then raise (CryptographicException(String.Format(getResourceString(FSComp.SR.ilSignInvalidRSAParams()), "Modulus"))) - if rsaParameters.Exponent = null || rsaParameters.Exponent.Length > 4 then raise (CryptographicException(String.Format(getResourceString(FSComp.SR.ilSignInvalidRSAParams()), "Exponent"))) - - let modulusLength = rsaParameters.Modulus.Length - let halfModulusLength = (modulusLength + 1) / 2 - - // We assume that if P != null, then so are Q, DP, DQ, InverseQ and D and indicate KeyPair RSA Parameters - let isPrivate = - if rsaParameters.P <> null then - validateRSAField rsaParameters.P halfModulusLength "P" - validateRSAField rsaParameters.Q halfModulusLength "Q" - validateRSAField rsaParameters.DP halfModulusLength "DP" - validateRSAField rsaParameters.InverseQ halfModulusLength "InverseQ" - validateRSAField rsaParameters.D halfModulusLength "D" - true - else false - - let key = - use ms = new MemoryStream() - use bw = new BinaryWriter(ms) - - bw.Write(int CALG_RSA_SIGN) // CLRHeader.aiKeyAlg - bw.Write(int CALG_SHA1) // CLRHeader.aiHashAlg - bw.Write(int (modulusLength + BLOBHEADER_LENGTH)) // CLRHeader.KeyLength - - // Write out the BLOBHEADER - bw.Write(byte (if isPrivate = true then PRIVATEKEYBLOB else PUBLICKEYBLOB))// BLOBHEADER.bType - bw.Write(byte BLOBHEADER_CURRENT_BVERSION) // BLOBHEADER.bVersion - bw.Write(int16 0) // BLOBHEADER.wReserved - bw.Write(int CALG_RSA_SIGN) // BLOBHEADER.aiKeyAlg - - // Write the RSAPubKey header - bw.Write(int (if isPrivate then RSA_PRIV_MAGIC else RSA_PUB_MAGIC)) // RSAPubKey.magic - bw.Write(int (modulusLength * 8)) // RSAPubKey.bitLen - - let expAsDword = - let mutable buffer = int 0 - for i in 0 .. rsaParameters.Exponent.Length - 1 do - buffer <- (buffer <<< 8) ||| int rsaParameters.Exponent[i] - buffer - - bw.Write expAsDword // RSAPubKey.pubExp - bw.Write(rsaParameters.Modulus |> Array.rev) // Copy over the modulus for both public and private - if isPrivate = true then do - bw.Write(rsaParameters.P |> Array.rev) - bw.Write(rsaParameters.Q |> Array.rev) + hashAlgorithm.AppendData(buffer, st, en - st) + () + + hashAlgorithm.GetHashAndReset() + +type BlobReader = + val mutable _blob: byte[] + val mutable _offset: int + new(blob: byte[]) = { _blob = blob; _offset = 0 } + + member x.ReadInt32() : int = + let offset = x._offset + x._offset <- offset + 4 + + int x._blob[offset] + ||| (int x._blob[offset + 1] <<< 8) + ||| (int x._blob[offset + 2] <<< 16) + ||| (int x._blob[offset + 3] <<< 24) + + member x.ReadBigInteger(length: int) : byte[] = + let arr: byte[] = Array.zeroCreate length + Array.Copy(x._blob, x._offset, arr, 0, length) + x._offset <- x._offset + length + arr |> Array.rev + +let RSAParamatersFromBlob (blob: byte[]) keyType = + let mutable reader = BlobReader blob + + if reader.ReadInt32() <> 0x00000207 && keyType = KeyType.KeyPair then + raise (CryptographicException(getResourceString (FSComp.SR.ilSignPrivateKeyExpected ()))) + + reader.ReadInt32() |> ignore // ALG_ID + + if reader.ReadInt32() <> RSA_PRIV_MAGIC then + raise (CryptographicException(getResourceString (FSComp.SR.ilSignRsaKeyExpected ()))) // 'RSA2' + + let byteLen, halfLen = + let bitLen = reader.ReadInt32() + + match bitLen % 16 with + | 0 -> (bitLen / 8, bitLen / 16) + | _ -> raise (CryptographicException(getResourceString (FSComp.SR.ilSignInvalidBitLen ()))) + + let mutable key = RSAParameters() + key.Exponent <- reader.ReadBigInteger 4 + key.Modulus <- reader.ReadBigInteger byteLen + key.P <- reader.ReadBigInteger halfLen + key.Q <- reader.ReadBigInteger halfLen + key.DP <- reader.ReadBigInteger halfLen + key.DQ <- reader.ReadBigInteger halfLen + key.InverseQ <- reader.ReadBigInteger halfLen + key.D <- reader.ReadBigInteger byteLen + key + +let validateRSAField (field: byte[] MaybeNull) expected (name: string) = + match field with + | Null -> () + | NonNull field -> + if field.Length <> expected then + raise (CryptographicException(String.Format(getResourceString (FSComp.SR.ilSignInvalidRSAParams ()), name))) + +let toCLRKeyBlob (rsaParameters: RSAParameters) (algId: int) : byte[] = + + // The original FCall this helper emulates supports other algId's - however, the only algid we need to support is CALG_RSA_KEYX. We will not port the codepaths dealing with other algid's. + if algId <> CALG_RSA_KEYX then + raise (CryptographicException(getResourceString (FSComp.SR.ilSignInvalidAlgId ()))) + + // Validate the RSA structure first. + if rsaParameters.Modulus = null then + raise (CryptographicException(String.Format(getResourceString (FSComp.SR.ilSignInvalidRSAParams ()), "Modulus"))) + + if rsaParameters.Exponent = null || rsaParameters.Exponent.Length > 4 then + raise (CryptographicException(String.Format(getResourceString (FSComp.SR.ilSignInvalidRSAParams ()), "Exponent"))) + + let modulusLength = rsaParameters.Modulus.Length + let halfModulusLength = (modulusLength + 1) / 2 + + // We assume that if P != null, then so are Q, DP, DQ, InverseQ and D and indicate KeyPair RSA Parameters + let isPrivate = + if rsaParameters.P <> null then + validateRSAField rsaParameters.P halfModulusLength "P" + validateRSAField rsaParameters.Q halfModulusLength "Q" + validateRSAField rsaParameters.DP halfModulusLength "DP" + validateRSAField rsaParameters.InverseQ halfModulusLength "InverseQ" + validateRSAField rsaParameters.D halfModulusLength "D" + true + else + false + + let key = + use ms = new MemoryStream() + use bw = new BinaryWriter(ms) + + bw.Write(int CALG_RSA_SIGN) // CLRHeader.aiKeyAlg + bw.Write(int CALG_SHA1) // CLRHeader.aiHashAlg + bw.Write(int (modulusLength + BLOBHEADER_LENGTH)) // CLRHeader.KeyLength + + // Write out the BLOBHEADER + bw.Write( + byte ( + if isPrivate = true then + PRIVATEKEYBLOB + else + PUBLICKEYBLOB + ) + ) // BLOBHEADER.bType + + bw.Write(byte BLOBHEADER_CURRENT_BVERSION) // BLOBHEADER.bVersion + bw.Write(int16 0) // BLOBHEADER.wReserved + bw.Write(int CALG_RSA_SIGN) // BLOBHEADER.aiKeyAlg + + // Write the RSAPubKey header + bw.Write( + int ( + if isPrivate then + RSA_PRIV_MAGIC + else + RSA_PUB_MAGIC + ) + ) // RSAPubKey.magic + + bw.Write(int (modulusLength * 8)) // RSAPubKey.bitLen + + let expAsDword = + let mutable buffer = int 0 + + for i in 0 .. rsaParameters.Exponent.Length - 1 do + buffer <- (buffer <<< 8) ||| int rsaParameters.Exponent[i] + + buffer + + bw.Write expAsDword // RSAPubKey.pubExp + bw.Write(rsaParameters.Modulus |> Array.rev) // Copy over the modulus for both public and private + + if isPrivate = true then + do + bw.Write(rsaParameters.P |> Array.rev) + bw.Write(rsaParameters.Q |> Array.rev) bw.Write(rsaParameters.DP |> Array.rev) bw.Write(rsaParameters.DQ |> Array.rev) bw.Write(rsaParameters.InverseQ |> Array.rev) bw.Write(rsaParameters.D |> Array.rev) - bw.Flush() - ms.ToArray() - key - - let createSignature (hash:byte[]) (keyBlob:byte[]) keyType = - use rsa = RSA.Create() - rsa.ImportParameters(RSAParamatersFromBlob keyBlob keyType) - let signature = rsa.SignHash(hash, HashAlgorithmName.SHA1, RSASignaturePadding.Pkcs1) - signature |>Array.rev - - let patchSignature (stream:Stream) (peReader:PEReader) (signature:byte[]) = - let peHeaders = peReader.PEHeaders - let signatureDirectory = peHeaders.CorHeader.StrongNameSignatureDirectory - let signatureOffset = - if signatureDirectory.Size > signature.Length then raise (BadImageFormatException(getResourceString(FSComp.SR.ilSignInvalidSignatureSize()))) - match peHeaders.TryGetDirectoryOffset signatureDirectory with - | false, _ -> raise (BadImageFormatException(getResourceString(FSComp.SR.ilSignNoSignatureDirectory()))) - | true, signatureOffset -> int64 signatureOffset - stream.Seek(signatureOffset, SeekOrigin.Begin) |>ignore - stream.Write(signature, 0, signature.Length) - - let corHeaderFlagsOffset = int64(peHeaders.CorHeaderStartOffset + 16) // offsetof(IMAGE_COR20_HEADER, Flags) - stream.Seek(corHeaderFlagsOffset, SeekOrigin.Begin) |>ignore - stream.WriteByte (byte (peHeaders.CorHeader.Flags ||| CorFlags.StrongNameSigned)) - () + bw.Flush() + ms.ToArray() + + key + +let createSignature (hash: byte[]) (keyBlob: byte[]) keyType = + use rsa = RSA.Create() + rsa.ImportParameters(RSAParamatersFromBlob keyBlob keyType) + + let signature = + rsa.SignHash(hash, HashAlgorithmName.SHA1, RSASignaturePadding.Pkcs1) + + signature |> Array.rev + +let patchSignature (stream: Stream) (peReader: PEReader) (signature: byte[]) = + let peHeaders = peReader.PEHeaders + let signatureDirectory = peHeaders.CorHeader.StrongNameSignatureDirectory + + let signatureOffset = + if signatureDirectory.Size > signature.Length then + raise (BadImageFormatException(getResourceString (FSComp.SR.ilSignInvalidSignatureSize ()))) - let signStream stream keyBlob = - use peReader = new PEReader(stream, PEStreamOptions.PrefetchEntireImage ||| PEStreamOptions.LeaveOpen) - let hash = - use hashAlgorithm = IncrementalHash.CreateHash(HashAlgorithmName.SHA1) - hashAssembly peReader hashAlgorithm - let signature = createSignature hash keyBlob KeyType.KeyPair - patchSignature stream peReader signature + match peHeaders.TryGetDirectoryOffset signatureDirectory with + | false, _ -> raise (BadImageFormatException(getResourceString (FSComp.SR.ilSignNoSignatureDirectory ()))) + | true, signatureOffset -> int64 signatureOffset - let signFile fileName keyBlob = - use fs = FileSystem.OpenFileForWriteShim(fileName, FileMode.Open, FileAccess.ReadWrite) - signStream fs keyBlob + stream.Seek(signatureOffset, SeekOrigin.Begin) |> ignore + stream.Write(signature, 0, signature.Length) - let signatureSize (pk:byte[]) = - if pk.Length < 25 then raise (CryptographicException(getResourceString(FSComp.SR.ilSignInvalidPKBlob()))) - let mutable reader = BlobReader pk - reader.ReadBigInteger 12 |> ignore // Skip CLRHeader - reader.ReadBigInteger 8 |> ignore // Skip BlobHeader - let magic = reader.ReadInt32() // Read magic - if not (magic = RSA_PRIV_MAGIC || magic = RSA_PUB_MAGIC) then // RSAPubKey.magic - raise (CryptographicException(getResourceString(FSComp.SR.ilSignInvalidPKBlob()))) - let x = reader.ReadInt32() / 8 - x + let corHeaderFlagsOffset = int64 (peHeaders.CorHeaderStartOffset + 16) // offsetof(IMAGE_COR20_HEADER, Flags) + stream.Seek(corHeaderFlagsOffset, SeekOrigin.Begin) |> ignore + stream.WriteByte(byte (peHeaders.CorHeader.Flags ||| CorFlags.StrongNameSigned)) + () - // Returns a CLR Format Blob public key - let getPublicKeyForKeyPair keyBlob = - use rsa = RSA.Create() - rsa.ImportParameters(RSAParamatersFromBlob keyBlob KeyType.KeyPair) - let rsaParameters = rsa.ExportParameters false - toCLRKeyBlob rsaParameters CALG_RSA_KEYX +let signStream stream keyBlob = + use peReader = + new PEReader(stream, PEStreamOptions.PrefetchEntireImage ||| PEStreamOptions.LeaveOpen) - // Key signing - type keyContainerName = string - type keyPair = byte[] - type pubkey = byte[] - type pubkeyOptions = byte[] * bool + let hash = + use hashAlgorithm = IncrementalHash.CreateHash(HashAlgorithmName.SHA1) + hashAssembly peReader hashAlgorithm - let signerOpenPublicKeyFile filePath = FileSystem.OpenFileForReadShim(filePath).ReadAllBytes() + let signature = createSignature hash keyBlob KeyType.KeyPair + patchSignature stream peReader signature - let signerOpenKeyPairFile filePath = FileSystem.OpenFileForReadShim(filePath).ReadAllBytes() +let signFile fileName keyBlob = + use fs = + FileSystem.OpenFileForWriteShim(fileName, FileMode.Open, FileAccess.ReadWrite) - let signerGetPublicKeyForKeyPair (kp: keyPair) : pubkey = getPublicKeyForKeyPair kp + signStream fs keyBlob - let signerGetPublicKeyForKeyContainer (_kcName: keyContainerName) : pubkey = - raise (NotImplementedException("signerGetPublicKeyForKeyContainer is not yet implemented")) +let signatureSize (pk: byte[]) = + if pk.Length < 25 then + raise (CryptographicException(getResourceString (FSComp.SR.ilSignInvalidPKBlob ()))) - let signerCloseKeyContainer (_kc: keyContainerName) : unit = - raise (NotImplementedException("signerCloseKeyContainer is not yet implemented")) + let mutable reader = BlobReader pk + reader.ReadBigInteger 12 |> ignore // Skip CLRHeader + reader.ReadBigInteger 8 |> ignore // Skip BlobHeader + let magic = reader.ReadInt32() // Read magic - let signerSignatureSize (pk: pubkey) : int = signatureSize pk + if not (magic = RSA_PRIV_MAGIC || magic = RSA_PUB_MAGIC) then // RSAPubKey.magic + raise (CryptographicException(getResourceString (FSComp.SR.ilSignInvalidPKBlob ()))) - let signerSignFileWithKeyPair (fileName: string) (kp: keyPair) : unit = signFile fileName kp + let x = reader.ReadInt32() / 8 + x - let signerSignFileWithKeyContainer (_fileName: string) (_kcName: keyContainerName) : unit = - raise (NotImplementedException("signerSignFileWithKeyContainer is not yet implemented")) +// Returns a CLR Format Blob public key +let getPublicKeyForKeyPair keyBlob = + use rsa = RSA.Create() + rsa.ImportParameters(RSAParamatersFromBlob keyBlob KeyType.KeyPair) + let rsaParameters = rsa.ExportParameters false + toCLRKeyBlob rsaParameters CALG_RSA_KEYX + +// Key signing +type keyContainerName = string +type keyPair = byte[] +type pubkey = byte[] +type pubkeyOptions = byte[] * bool + +let signerOpenPublicKeyFile filePath = + FileSystem.OpenFileForReadShim(filePath).ReadAllBytes() + +let signerOpenKeyPairFile filePath = + FileSystem.OpenFileForReadShim(filePath).ReadAllBytes() + +let signerGetPublicKeyForKeyPair (kp: keyPair) : pubkey = getPublicKeyForKeyPair kp + +let signerGetPublicKeyForKeyContainer (_kcName: keyContainerName) : pubkey = + raise (NotImplementedException("signerGetPublicKeyForKeyContainer is not yet implemented")) + +let signerCloseKeyContainer (_kc: keyContainerName) : unit = + raise (NotImplementedException("signerCloseKeyContainer is not yet implemented")) + +let signerSignatureSize (pk: pubkey) : int = signatureSize pk + +let signerSignFileWithKeyPair (fileName: string) (kp: keyPair) : unit = signFile fileName kp + +let signerSignFileWithKeyContainer (_fileName: string) (_kcName: keyContainerName) : unit = + raise (NotImplementedException("signerSignFileWithKeyContainer is not yet implemented")) #if !FX_NO_CORHOST_SIGNER - open System.Runtime.CompilerServices - - // New mscoree functionality - // This type represents methods that we don't currently need, so I'm leaving unimplemented - type UnusedCOMMethod = unit -> unit - [] - [] - type ICLRMetaHost = - [] - abstract GetRuntime: - [] version: string * - [] interfaceId: System.Guid -> [] System.Object - - // Methods that we don't need are stubbed out for now... - abstract GetVersionFromFile: UnusedCOMMethod - abstract EnumerateInstalledRuntimes: UnusedCOMMethod - abstract EnumerateLoadedRuntimes: UnusedCOMMethod - abstract Reserved01: UnusedCOMMethod - - // We don't currently support ComConversionLoss - [] - [] - type ICLRStrongName = - // Methods that we don't need are stubbed out for now... - abstract GetHashFromAssemblyFile: UnusedCOMMethod - abstract GetHashFromAssemblyFileW: UnusedCOMMethod - abstract GetHashFromBlob: UnusedCOMMethod - abstract GetHashFromFile: UnusedCOMMethod - abstract GetHashFromFileW: UnusedCOMMethod - abstract GetHashFromHandle: UnusedCOMMethod - abstract StrongNameCompareAssemblies: UnusedCOMMethod - - [] - abstract StrongNameFreeBuffer: [] pbMemory: nativeint -> unit - - abstract StrongNameGetBlob: UnusedCOMMethod - abstract StrongNameGetBlobFromImage: UnusedCOMMethod - - [] - abstract StrongNameGetPublicKey : - [] pwzKeyContainer: string * - [] pbKeyBlob: byte[] * - [] cbKeyBlob: uint32 * - [] ppbPublicKeyBlob: nativeint byref * - [] pcbPublicKeyBlob: uint32 byref -> unit - - abstract StrongNameHashSize: UnusedCOMMethod - - [] - abstract StrongNameKeyDelete: [] pwzKeyContainer: string -> unit - - abstract StrongNameKeyGen: UnusedCOMMethod - abstract StrongNameKeyGenEx: UnusedCOMMethod - abstract StrongNameKeyInstall: UnusedCOMMethod - - [] - abstract StrongNameSignatureGeneration : - [] pwzFilePath: string * - [] pwzKeyContainer: string * - [] pbKeyBlob: byte [] * - [] cbKeyBlob: uint32 * - [] ppbSignatureBlob: nativeint * - [] pcbSignatureBlob: uint32 byref -> unit - - abstract StrongNameSignatureGenerationEx: UnusedCOMMethod - - [] - abstract StrongNameSignatureSize : - [] pbPublicKeyBlob: byte[] * - [] cbPublicKeyBlob: uint32 * - [] pcbSize: uint32 byref -> unit - - abstract StrongNameSignatureVerification: UnusedCOMMethod - - [] - abstract StrongNameSignatureVerificationEx : - [] pwzFilePath: string * - [] fForceVerification: bool * - [] pfWasVerified: bool byref -> [] bool - - abstract StrongNameSignatureVerificationFromImage: UnusedCOMMethod - abstract StrongNameTokenFromAssembly: UnusedCOMMethod - abstract StrongNameTokenFromAssemblyEx: UnusedCOMMethod - abstract StrongNameTokenFromPublicKey: UnusedCOMMethod - - - [] - [] - type ICLRRuntimeInfo = - // REVIEW: Methods that we don't need will be stubbed out for now... - abstract GetVersionString: unit -> unit - abstract GetRuntimeDirectory: unit -> unit - abstract IsLoaded: unit -> unit - abstract LoadErrorString: unit -> unit - abstract LoadLibrary: unit -> unit - abstract GetProcAddress: unit -> unit - - [] - abstract GetInterface : - [] coClassId: System.Guid * - [] interfaceId: System.Guid -> []System.Object - - [] - [] - let CreateInterface ( - ([] _clsidguid: System.Guid), - ([] _guid: System.Guid), - ([] _metaHost : - ICLRMetaHost byref)) : unit = failwith "CreateInterface" - - let legacySignerOpenPublicKeyFile filePath = FileSystem.OpenFileForReadShim(filePath).ReadAllBytes() - - let legacySignerOpenKeyPairFile filePath = FileSystem.OpenFileForReadShim(filePath).ReadAllBytes() - - let mutable iclrsn: ICLRStrongName option = None - let getICLRStrongName () = - match iclrsn with - | None -> - let CLSID_CLRStrongName = System.Guid(0xB79B0ACDu, 0xF5CDus, 0x409bus, 0xB5uy, 0xA5uy, 0xA1uy, 0x62uy, 0x44uy, 0x61uy, 0x0Buy, 0x92uy) - let IID_ICLRStrongName = System.Guid(0x9FD93CCFu, 0x3280us, 0x4391us, 0xB3uy, 0xA9uy, 0x96uy, 0xE1uy, 0xCDuy, 0xE7uy, 0x7Cuy, 0x8Duy) - let CLSID_CLRMetaHost = System.Guid(0x9280188Du, 0x0E8Eus, 0x4867us, 0xB3uy, 0x0Cuy, 0x7Fuy, 0xA8uy, 0x38uy, 0x84uy, 0xE8uy, 0xDEuy) - let IID_ICLRMetaHost = System.Guid(0xD332DB9Eu, 0xB9B3us, 0x4125us, 0x82uy, 0x07uy, 0xA1uy, 0x48uy, 0x84uy, 0xF5uy, 0x32uy, 0x16uy) - let clrRuntimeInfoGuid = System.Guid(0xBD39D1D2u, 0xBA2Fus, 0x486aus, 0x89uy, 0xB0uy, 0xB4uy, 0xB0uy, 0xCBuy, 0x46uy, 0x68uy, 0x91uy) - - let runtimeVer = System.Runtime.InteropServices.RuntimeEnvironment.GetSystemVersion() - let mutable metaHost = Unchecked.defaultof - CreateInterface(CLSID_CLRMetaHost, IID_ICLRMetaHost, &metaHost) - if Unchecked.defaultof = metaHost then - failwith "Unable to obtain ICLRMetaHost object - check freshness of mscoree.dll" - let runtimeInfo = metaHost.GetRuntime(runtimeVer, clrRuntimeInfoGuid) :?> ICLRRuntimeInfo - let sn = runtimeInfo.GetInterface(CLSID_CLRStrongName, IID_ICLRStrongName) :?> ICLRStrongName - if Unchecked.defaultof = sn then - failwith "Unable to obtain ICLRStrongName object" - iclrsn <- Some sn - sn - | Some sn -> sn - - let legacySignerGetPublicKeyForKeyPair kp = - if runningOnMono then +open System.Runtime.CompilerServices + +// New mscoree functionality +// This type represents methods that we don't currently need, so I'm leaving unimplemented +type UnusedCOMMethod = unit -> unit + +[] +[] +type ICLRMetaHost = + [] + abstract GetRuntime: + [] version: string * [] interfaceId: System.Guid -> + [] System.Object + + // Methods that we don't need are stubbed out for now... + abstract GetVersionFromFile: UnusedCOMMethod + abstract EnumerateInstalledRuntimes: UnusedCOMMethod + abstract EnumerateLoadedRuntimes: UnusedCOMMethod + abstract Reserved01: UnusedCOMMethod + +// We don't currently support ComConversionLoss +[] +[] +type ICLRStrongName = + // Methods that we don't need are stubbed out for now... + abstract GetHashFromAssemblyFile: UnusedCOMMethod + abstract GetHashFromAssemblyFileW: UnusedCOMMethod + abstract GetHashFromBlob: UnusedCOMMethod + abstract GetHashFromFile: UnusedCOMMethod + abstract GetHashFromFileW: UnusedCOMMethod + abstract GetHashFromHandle: UnusedCOMMethod + abstract StrongNameCompareAssemblies: UnusedCOMMethod + + [] + abstract StrongNameFreeBuffer: [] pbMemory: nativeint -> unit + + abstract StrongNameGetBlob: UnusedCOMMethod + abstract StrongNameGetBlobFromImage: UnusedCOMMethod + + [] + abstract StrongNameGetPublicKey: + [] pwzKeyContainer: string * + [] pbKeyBlob: byte[] * + [] cbKeyBlob: uint32 * + [] ppbPublicKeyBlob: nativeint byref * + [] pcbPublicKeyBlob: uint32 byref -> + unit + + abstract StrongNameHashSize: UnusedCOMMethod + + [] + abstract StrongNameKeyDelete: [] pwzKeyContainer: string -> unit + + abstract StrongNameKeyGen: UnusedCOMMethod + abstract StrongNameKeyGenEx: UnusedCOMMethod + abstract StrongNameKeyInstall: UnusedCOMMethod + + [] + abstract StrongNameSignatureGeneration: + [] pwzFilePath: string * + [] pwzKeyContainer: string * + [] pbKeyBlob: byte[] * + [] cbKeyBlob: uint32 * + [] ppbSignatureBlob: nativeint * + [] pcbSignatureBlob: uint32 byref -> + unit + + abstract StrongNameSignatureGenerationEx: UnusedCOMMethod + + [] + abstract StrongNameSignatureSize: + [] pbPublicKeyBlob: byte[] * + [] cbPublicKeyBlob: uint32 * + [] pcbSize: uint32 byref -> + unit + + abstract StrongNameSignatureVerification: UnusedCOMMethod + + [] + abstract StrongNameSignatureVerificationEx: + [] pwzFilePath: string * + [] fForceVerification: bool * + [] pfWasVerified: bool byref -> + [] bool + + abstract StrongNameSignatureVerificationFromImage: UnusedCOMMethod + abstract StrongNameTokenFromAssembly: UnusedCOMMethod + abstract StrongNameTokenFromAssemblyEx: UnusedCOMMethod + abstract StrongNameTokenFromPublicKey: UnusedCOMMethod + +[] +[] +type ICLRRuntimeInfo = + // REVIEW: Methods that we don't need will be stubbed out for now... + abstract GetVersionString: unit -> unit + abstract GetRuntimeDirectory: unit -> unit + abstract IsLoaded: unit -> unit + abstract LoadErrorString: unit -> unit + abstract LoadLibrary: unit -> unit + abstract GetProcAddress: unit -> unit + + [] + abstract GetInterface: + [] coClassId: System.Guid * + [] interfaceId: System.Guid -> + [] System.Object + +[] +[] +let CreateInterface + ( + ([] _clsidguid: System.Guid), + ([] _guid: System.Guid), + ([] _metaHost: ICLRMetaHost byref) + ) : unit = + failwith "CreateInterface" + +let legacySignerOpenPublicKeyFile filePath = + FileSystem.OpenFileForReadShim(filePath).ReadAllBytes() + +let legacySignerOpenKeyPairFile filePath = + FileSystem.OpenFileForReadShim(filePath).ReadAllBytes() + +let mutable iclrsn: ICLRStrongName option = None + +let getICLRStrongName () = + match iclrsn with + | None -> + let CLSID_CLRStrongName = + System.Guid(0xB79B0ACDu, 0xF5CDus, 0x409bus, 0xB5uy, 0xA5uy, 0xA1uy, 0x62uy, 0x44uy, 0x61uy, 0x0Buy, 0x92uy) + + let IID_ICLRStrongName = + System.Guid(0x9FD93CCFu, 0x3280us, 0x4391us, 0xB3uy, 0xA9uy, 0x96uy, 0xE1uy, 0xCDuy, 0xE7uy, 0x7Cuy, 0x8Duy) + + let CLSID_CLRMetaHost = + System.Guid(0x9280188Du, 0x0E8Eus, 0x4867us, 0xB3uy, 0x0Cuy, 0x7Fuy, 0xA8uy, 0x38uy, 0x84uy, 0xE8uy, 0xDEuy) + + let IID_ICLRMetaHost = + System.Guid(0xD332DB9Eu, 0xB9B3us, 0x4125us, 0x82uy, 0x07uy, 0xA1uy, 0x48uy, 0x84uy, 0xF5uy, 0x32uy, 0x16uy) + + let clrRuntimeInfoGuid = + System.Guid(0xBD39D1D2u, 0xBA2Fus, 0x486aus, 0x89uy, 0xB0uy, 0xB4uy, 0xB0uy, 0xCBuy, 0x46uy, 0x68uy, 0x91uy) + + let runtimeVer = + System.Runtime.InteropServices.RuntimeEnvironment.GetSystemVersion() + + let mutable metaHost = Unchecked.defaultof + CreateInterface(CLSID_CLRMetaHost, IID_ICLRMetaHost, &metaHost) + + if Unchecked.defaultof = metaHost then + failwith "Unable to obtain ICLRMetaHost object - check freshness of mscoree.dll" + + let runtimeInfo = + metaHost.GetRuntime(runtimeVer, clrRuntimeInfoGuid) :?> ICLRRuntimeInfo + + let sn = + runtimeInfo.GetInterface(CLSID_CLRStrongName, IID_ICLRStrongName) :?> ICLRStrongName + + if Unchecked.defaultof = sn then + failwith "Unable to obtain ICLRStrongName object" + + iclrsn <- Some sn + sn + | Some sn -> sn + +let legacySignerGetPublicKeyForKeyPair kp = + if runningOnMono then let snt = System.Type.GetType("Mono.Security.StrongName") let sn = System.Activator.CreateInstance(snt, [| box kp |]) - snt.InvokeMember("PublicKey", (BindingFlags.GetProperty ||| BindingFlags.Instance ||| BindingFlags.Public), null, sn, [| |], Globalization.CultureInfo.InvariantCulture) :?> byte[] - else + + snt.InvokeMember( + "PublicKey", + (BindingFlags.GetProperty ||| BindingFlags.Instance ||| BindingFlags.Public), + null, + sn, + [||], + Globalization.CultureInfo.InvariantCulture + ) + :?> byte[] + else let mutable pSize = 0u - let mutable pBuffer: nativeint = (nativeint)0 - let iclrSN = getICLRStrongName() + let mutable pBuffer: nativeint = (nativeint) 0 + let iclrSN = getICLRStrongName () + + iclrSN.StrongNameGetPublicKey(Unchecked.defaultof, kp, (uint32) kp.Length, &pBuffer, &pSize) + |> ignore - iclrSN.StrongNameGetPublicKey(Unchecked.defaultof, kp, (uint32) kp.Length, &pBuffer, &pSize) |> ignore - let mutable keybuffer: byte [] = Bytes.zeroCreate (int pSize) + let mutable keybuffer: byte[] = Bytes.zeroCreate (int pSize) // Copy the marshalled data over - we'll have to free this ourselves Marshal.Copy(pBuffer, keybuffer, 0, int pSize) iclrSN.StrongNameFreeBuffer pBuffer |> ignore keybuffer - let legacySignerGetPublicKeyForKeyContainer kc = +let legacySignerGetPublicKeyForKeyContainer kc = + let mutable pSize = 0u + let mutable pBuffer: nativeint = (nativeint) 0 + let iclrSN = getICLRStrongName () + + iclrSN.StrongNameGetPublicKey(kc, Unchecked.defaultof, 0u, &pBuffer, &pSize) + |> ignore + + let mutable keybuffer: byte[] = Bytes.zeroCreate (int pSize) + // Copy the marshalled data over - we'll have to free this ourselves later + Marshal.Copy(pBuffer, keybuffer, 0, int pSize) + iclrSN.StrongNameFreeBuffer pBuffer |> ignore + keybuffer + +let legacySignerCloseKeyContainer kc = + let iclrSN = getICLRStrongName () + iclrSN.StrongNameKeyDelete kc |> ignore + +let legacySignerSignatureSize (pk: byte[]) = + if runningOnMono then + if pk.Length > 32 then + pk.Length - 32 + else + 128 + else let mutable pSize = 0u - let mutable pBuffer: nativeint = (nativeint)0 - let iclrSN = getICLRStrongName() - iclrSN.StrongNameGetPublicKey(kc, Unchecked.defaultof, 0u, &pBuffer, &pSize) |> ignore - let mutable keybuffer: byte [] = Bytes.zeroCreate (int pSize) - // Copy the marshalled data over - we'll have to free this ourselves later - Marshal.Copy(pBuffer, keybuffer, 0, int pSize) - iclrSN.StrongNameFreeBuffer pBuffer |> ignore - keybuffer - - let legacySignerCloseKeyContainer kc = - let iclrSN = getICLRStrongName() - iclrSN.StrongNameKeyDelete kc |> ignore - - let legacySignerSignatureSize (pk: byte[]) = - if runningOnMono then - if pk.Length > 32 then pk.Length - 32 else 128 - else - let mutable pSize = 0u - let iclrSN = getICLRStrongName() + let iclrSN = getICLRStrongName () iclrSN.StrongNameSignatureSize(pk, uint32 pk.Length, &pSize) |> ignore int pSize - let legacySignerSignFileWithKeyPair fileName kp = - if runningOnMono then +let legacySignerSignFileWithKeyPair fileName kp = + if runningOnMono then let snt = System.Type.GetType("Mono.Security.StrongName") let sn = System.Activator.CreateInstance(snt, [| box kp |]) let conv (x: obj) = if (unbox x: bool) then 0 else -1 - snt.InvokeMember("Sign", (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), null, sn, [| box fileName |], Globalization.CultureInfo.InvariantCulture) |> conv |> check "Sign" - snt.InvokeMember("Verify", (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), null, sn, [| box fileName |], Globalization.CultureInfo.InvariantCulture) |> conv |> check "Verify" - else - let mutable pcb = 0u - let mutable ppb = (nativeint)0 - let mutable ok = false - let iclrSN = getICLRStrongName() - iclrSN.StrongNameSignatureGeneration(fileName, Unchecked.defaultof, kp, uint32 kp.Length, ppb, &pcb) |> ignore - iclrSN.StrongNameSignatureVerificationEx(fileName, true, &ok) |> ignore - let legacySignerSignFileWithKeyContainer fileName kcName = + snt.InvokeMember( + "Sign", + (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), + null, + sn, + [| box fileName |], + Globalization.CultureInfo.InvariantCulture + ) + |> conv + |> check "Sign" + + snt.InvokeMember( + "Verify", + (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), + null, + sn, + [| box fileName |], + Globalization.CultureInfo.InvariantCulture + ) + |> conv + |> check "Verify" + else let mutable pcb = 0u - let mutable ppb = (nativeint)0 + let mutable ppb = (nativeint) 0 let mutable ok = false - let iclrSN = getICLRStrongName() - iclrSN.StrongNameSignatureGeneration(fileName, kcName, Unchecked.defaultof, 0u, ppb, &pcb) |> ignore + let iclrSN = getICLRStrongName () + + iclrSN.StrongNameSignatureGeneration(fileName, Unchecked.defaultof, kp, uint32 kp.Length, ppb, &pcb) + |> ignore + iclrSN.StrongNameSignatureVerificationEx(fileName, true, &ok) |> ignore + +let legacySignerSignFileWithKeyContainer fileName kcName = + let mutable pcb = 0u + let mutable ppb = (nativeint) 0 + let mutable ok = false + let iclrSN = getICLRStrongName () + + iclrSN.StrongNameSignatureGeneration(fileName, kcName, Unchecked.defaultof, 0u, ppb, &pcb) + |> ignore + + iclrSN.StrongNameSignatureVerificationEx(fileName, true, &ok) |> ignore #endif - let failWithContainerSigningUnsupportedOnThisPlatform() = failwith (FSComp.SR.containerSigningUnsupportedOnThisPlatform() |> snd) - - //--------------------------------------------------------------------- - // Strong name signing - //--------------------------------------------------------------------- - type ILStrongNameSigner = - | PublicKeySigner of pubkey - | PublicKeyOptionsSigner of pubkeyOptions - | KeyPair of keyPair - | KeyContainer of keyContainerName - - static member OpenPublicKeyOptions s p = PublicKeyOptionsSigner((signerOpenPublicKeyFile s), p) - static member OpenPublicKey pubkey = PublicKeySigner pubkey - static member OpenKeyPairFile s = KeyPair(signerOpenKeyPairFile s) - static member OpenKeyContainer s = KeyContainer s - - member s.Close () = - match s with - | PublicKeySigner _ - | PublicKeyOptionsSigner _ - | KeyPair _ -> () - | KeyContainer containerName -> +let failWithContainerSigningUnsupportedOnThisPlatform () = + failwith (FSComp.SR.containerSigningUnsupportedOnThisPlatform () |> snd) + +//--------------------------------------------------------------------- +// Strong name signing +//--------------------------------------------------------------------- +type ILStrongNameSigner = + | PublicKeySigner of pubkey + | PublicKeyOptionsSigner of pubkeyOptions + | KeyPair of keyPair + | KeyContainer of keyContainerName + + static member OpenPublicKeyOptions s p = + PublicKeyOptionsSigner((signerOpenPublicKeyFile s), p) + + static member OpenPublicKey pubkey = PublicKeySigner pubkey + static member OpenKeyPairFile s = KeyPair(signerOpenKeyPairFile s) + static member OpenKeyContainer s = KeyContainer s + + member s.Close() = + match s with + | PublicKeySigner _ + | PublicKeyOptionsSigner _ + | KeyPair _ -> () + | KeyContainer containerName -> #if !FX_NO_CORHOST_SIGNER - legacySignerCloseKeyContainer containerName + legacySignerCloseKeyContainer containerName #else - ignore containerName - failWithContainerSigningUnsupportedOnThisPlatform() + ignore containerName + failWithContainerSigningUnsupportedOnThisPlatform () #endif - member s.IsFullySigned = - match s with - | PublicKeySigner _ -> false - | PublicKeyOptionsSigner pko -> let _, usePublicSign = pko - usePublicSign - | KeyPair _ -> true - | KeyContainer _ -> + member s.IsFullySigned = + match s with + | PublicKeySigner _ -> false + | PublicKeyOptionsSigner pko -> + let _, usePublicSign = pko + usePublicSign + | KeyPair _ -> true + | KeyContainer _ -> #if !FX_NO_CORHOST_SIGNER - true + true #else - failWithContainerSigningUnsupportedOnThisPlatform() + failWithContainerSigningUnsupportedOnThisPlatform () #endif - member s.PublicKey = - match s with - | PublicKeySigner pk -> pk - | PublicKeyOptionsSigner pko -> let pk, _ = pko - pk - | KeyPair kp -> signerGetPublicKeyForKeyPair kp - | KeyContainer containerName -> + member s.PublicKey = + match s with + | PublicKeySigner pk -> pk + | PublicKeyOptionsSigner pko -> + let pk, _ = pko + pk + | KeyPair kp -> signerGetPublicKeyForKeyPair kp + | KeyContainer containerName -> #if !FX_NO_CORHOST_SIGNER - legacySignerGetPublicKeyForKeyContainer containerName + legacySignerGetPublicKeyForKeyContainer containerName #else - ignore containerName - failWithContainerSigningUnsupportedOnThisPlatform() + ignore containerName + failWithContainerSigningUnsupportedOnThisPlatform () #endif - member s.SignatureSize = - let pkSignatureSize pk = - try - signerSignatureSize pk - with exn -> - failwith ("A call to StrongNameSignatureSize failed ("+exn.Message+")") - 0x80 - - match s with - | PublicKeySigner pk -> pkSignatureSize pk - | PublicKeyOptionsSigner pko -> let pk, _ = pko - pkSignatureSize pk - | KeyPair kp -> pkSignatureSize (signerGetPublicKeyForKeyPair kp) - | KeyContainer containerName -> + member s.SignatureSize = + let pkSignatureSize pk = + try + signerSignatureSize pk + with + | exn -> + failwith ("A call to StrongNameSignatureSize failed (" + exn.Message + ")") + 0x80 + + match s with + | PublicKeySigner pk -> pkSignatureSize pk + | PublicKeyOptionsSigner pko -> + let pk, _ = pko + pkSignatureSize pk + | KeyPair kp -> pkSignatureSize (signerGetPublicKeyForKeyPair kp) + | KeyContainer containerName -> #if !FX_NO_CORHOST_SIGNER - pkSignatureSize (legacySignerGetPublicKeyForKeyContainer containerName) + pkSignatureSize (legacySignerGetPublicKeyForKeyContainer containerName) #else - ignore containerName - failWithContainerSigningUnsupportedOnThisPlatform() + ignore containerName + failWithContainerSigningUnsupportedOnThisPlatform () #endif - member s.SignFile file = - match s with - | PublicKeySigner _ -> () - | PublicKeyOptionsSigner _ -> () - | KeyPair kp -> signerSignFileWithKeyPair file kp - | KeyContainer containerName -> + member s.SignFile file = + match s with + | PublicKeySigner _ -> () + | PublicKeyOptionsSigner _ -> () + | KeyPair kp -> signerSignFileWithKeyPair file kp + | KeyContainer containerName -> #if !FX_NO_CORHOST_SIGNER - legacySignerSignFileWithKeyContainer file containerName + legacySignerSignFileWithKeyContainer file containerName #else - ignore containerName - failWithContainerSigningUnsupportedOnThisPlatform() + ignore containerName + failWithContainerSigningUnsupportedOnThisPlatform () #endif diff --git a/src/Compiler/AbstractIL/ilsupp.fs b/src/Compiler/AbstractIL/ilsupp.fs index 83609883e..30050580d 100644 --- a/src/Compiler/AbstractIL/ilsupp.fs +++ b/src/Compiler/AbstractIL/ilsupp.fs @@ -15,8 +15,11 @@ open FSharp.Compiler.IO #if FX_NO_CORHOST_SIGNER #endif -let DateTime1970Jan01 = DateTime(1970, 1, 1, 0, 0, 0, DateTimeKind.Utc) (* ECMA Spec (Oct2002), Part II, 24.2.2 PE File Header. *) -let absilWriteGetTimeStamp () = (DateTime.UtcNow - DateTime1970Jan01).TotalSeconds |> int +let DateTime1970Jan01 = + DateTime(1970, 1, 1, 0, 0, 0, DateTimeKind.Utc) (* ECMA Spec (Oct2002), Part II, 24.2.2 PE File Header. *) + +let absilWriteGetTimeStamp () = + (DateTime.UtcNow - DateTime1970Jan01).TotalSeconds |> int // Force inline, so GetLastWin32Error calls are immediately after interop calls as seen by FxCop under Debug build. let inline ignore _x = () @@ -25,232 +28,270 @@ let inline ignore _x = () type IStream = System.Runtime.InteropServices.ComTypes.IStream let check _action hresult = - if uint32 hresult >= 0x80000000ul then - Marshal.ThrowExceptionForHR hresult - //printf "action = %s, hresult = 0x%nx \n" action hresult + if uint32 hresult >= 0x80000000ul then + Marshal.ThrowExceptionForHR hresult +//printf "action = %s, hresult = 0x%nx \n" action hresult let MAX_PATH = 260 let E_FAIL = 0x80004005 -let bytesToWord (b0: byte, b1: byte) = - int16 b0 ||| (int16 b1 <<< 8) +let bytesToWord (b0: byte, b1: byte) = int16 b0 ||| (int16 b1 <<< 8) let bytesToDWord (b0: byte, b1: byte, b2: byte, b3: byte) = int b0 ||| (int b1 <<< 8) ||| (int b2 <<< 16) ||| (int b3 <<< 24) let bytesToQWord (b0: byte, b1: byte, b2: byte, b3: byte, b4: byte, b5: byte, b6: byte, b7: byte) = - int64 b0 ||| (int64 b1 <<< 8) ||| (int64 b2 <<< 16) ||| (int64 b3 <<< 24) ||| (int64 b4 <<< 32) ||| (int64 b5 <<< 40) ||| (int64 b6 <<< 48) ||| (int64 b7 <<< 56) - -let dwToBytes n = [| byte (n &&& 0xff) ; byte ((n >>> 8) &&& 0xff) ; byte ((n >>> 16) &&& 0xff) ; byte ((n >>> 24) &&& 0xff) |], 4 -let wToBytes (n: int16) = [| byte (n &&& 0xffs) ; byte ((n >>> 8) &&& 0xffs) |], 2 + int64 b0 + ||| (int64 b1 <<< 8) + ||| (int64 b2 <<< 16) + ||| (int64 b3 <<< 24) + ||| (int64 b4 <<< 32) + ||| (int64 b5 <<< 40) + ||| (int64 b6 <<< 48) + ||| (int64 b7 <<< 56) + +let dwToBytes n = + [| + byte (n &&& 0xff) + byte ((n >>> 8) &&& 0xff) + byte ((n >>> 16) &&& 0xff) + byte ((n >>> 24) &&& 0xff) + |], + 4 + +let wToBytes (n: int16) = + [| byte (n &&& 0xffs); byte ((n >>> 8) &&& 0xffs) |], 2 // REVIEW: factor these classes under one hierarchy, use reflection for creation from buffer and toBytes() // Though, everything I'd like to unify is static - metaclasses? -type IMAGE_FILE_HEADER (m: int16, secs: int16, tds: int32, ptst: int32, nos: int32, soh: int16, c: int16) = - let mutable machine = m - let mutable numberOfSections = secs - let mutable timeDateStamp = tds - let mutable pointerToSymbolTable = ptst - let mutable numberOfSymbols = nos - let mutable sizeOfOptionalHeader = soh - let mutable characteristics = c - - member x.Machine - with get() = machine - and set value = machine <- value - - member x.NumberOfSections - with get() = numberOfSections - and set value = numberOfSections <- value - - member x.TimeDateStamp - with get() = timeDateStamp - and set value = timeDateStamp <- value - - member x.PointerToSymbolTable - with get() = pointerToSymbolTable - and set value = pointerToSymbolTable <- value - - member x.NumberOfSymbols - with get() = numberOfSymbols - and set value = numberOfSymbols <- value - - member x.SizeOfOptionalHeader - with get() = sizeOfOptionalHeader - and set value = sizeOfOptionalHeader <- value - - member x.Characteristics - with get() = characteristics - and set value = characteristics <- value - - static member Width - with get() = 20 - - member x.toBytes () = - use buf = ByteBuffer.Create IMAGE_FILE_HEADER.Width - buf.EmitUInt16 (uint16 machine) - buf.EmitUInt16 (uint16 numberOfSections) - buf.EmitInt32 timeDateStamp - buf.EmitInt32 pointerToSymbolTable - buf.EmitInt32 numberOfSymbols - buf.EmitUInt16 (uint16 sizeOfOptionalHeader) - buf.EmitUInt16 (uint16 characteristics) - buf.AsMemory().ToArray() +type IMAGE_FILE_HEADER(m: int16, secs: int16, tds: int32, ptst: int32, nos: int32, soh: int16, c: int16) = + let mutable machine = m + let mutable numberOfSections = secs + let mutable timeDateStamp = tds + let mutable pointerToSymbolTable = ptst + let mutable numberOfSymbols = nos + let mutable sizeOfOptionalHeader = soh + let mutable characteristics = c + + member x.Machine + with get () = machine + and set value = machine <- value + + member x.NumberOfSections + with get () = numberOfSections + and set value = numberOfSections <- value + + member x.TimeDateStamp + with get () = timeDateStamp + and set value = timeDateStamp <- value + + member x.PointerToSymbolTable + with get () = pointerToSymbolTable + and set value = pointerToSymbolTable <- value + + member x.NumberOfSymbols + with get () = numberOfSymbols + and set value = numberOfSymbols <- value + + member x.SizeOfOptionalHeader + with get () = sizeOfOptionalHeader + and set value = sizeOfOptionalHeader <- value + + member x.Characteristics + with get () = characteristics + and set value = characteristics <- value + + static member Width = 20 + + member x.toBytes() = + use buf = ByteBuffer.Create IMAGE_FILE_HEADER.Width + buf.EmitUInt16(uint16 machine) + buf.EmitUInt16(uint16 numberOfSections) + buf.EmitInt32 timeDateStamp + buf.EmitInt32 pointerToSymbolTable + buf.EmitInt32 numberOfSymbols + buf.EmitUInt16(uint16 sizeOfOptionalHeader) + buf.EmitUInt16(uint16 characteristics) + buf.AsMemory().ToArray() let bytesToIFH (buffer: byte[]) (offset: int) = if (buffer.Length - offset) < IMAGE_FILE_HEADER.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_FILE_HEADER" - IMAGE_FILE_HEADER( bytesToWord(buffer[offset], buffer[offset+1]), // Machine - bytesToWord(buffer[offset+2], buffer[offset+3]), // NumberOfSections - bytesToDWord(buffer[offset+4], buffer[offset+5], buffer[offset+6], buffer[offset+7]), // TimeDateStamp - bytesToDWord(buffer[offset+8], buffer[offset+9], buffer[offset+10], buffer[offset+11]), // PointerToSymbolTable - bytesToDWord(buffer[offset+12], buffer[offset+13], buffer[offset+14], buffer[offset+15]), // NumberOfSymbols - bytesToWord(buffer[offset+16], buffer[offset+17]), // SizeOfOptionalHeader - bytesToWord(buffer[offset+18], buffer[offset+19])) // Characteristics + + IMAGE_FILE_HEADER( + bytesToWord (buffer[offset], buffer[offset + 1]), // Machine + bytesToWord (buffer[offset + 2], buffer[offset + 3]), // NumberOfSections + bytesToDWord (buffer[offset + 4], buffer[offset + 5], buffer[offset + 6], buffer[offset + 7]), // TimeDateStamp + bytesToDWord (buffer[offset + 8], buffer[offset + 9], buffer[offset + 10], buffer[offset + 11]), // PointerToSymbolTable + bytesToDWord (buffer[offset + 12], buffer[offset + 13], buffer[offset + 14], buffer[offset + 15]), // NumberOfSymbols + bytesToWord (buffer[offset + 16], buffer[offset + 17]), // SizeOfOptionalHeader + bytesToWord (buffer[offset + 18], buffer[offset + 19]) + ) // Characteristics type IMAGE_SECTION_HEADER(n: int64, ai: int32, va: int32, srd: int32, prd: int32, pr: int32, pln: int32, nr: int16, nl: int16, c: int32) = - let mutable name = n - let mutable addressInfo = ai // PhysicalAddress / VirtualSize - let mutable virtualAddress = va - let mutable sizeOfRawData = srd - let mutable pointerToRawData = prd - let mutable pointerToRelocations = pr - let mutable pointerToLineNumbers = pln - let mutable numberOfRelocations = nr - let mutable numberOfLineNumbers = nl - let mutable characteristics = c - - member x.Name - with get() = name - and set value = name <- value - - member x.PhysicalAddress - with get() = addressInfo - and set value = addressInfo <- value - - member x.VirtualSize - with get() = addressInfo - and set value = addressInfo <- value - - member x.VirtualAddress - with get() = virtualAddress - and set value = virtualAddress <- value - - member x.SizeOfRawData - with get() = sizeOfRawData - and set value = sizeOfRawData <- value - - member x.PointerToRawData - with get() = pointerToRawData - and set value = pointerToRawData <- value - - member x.PointerToRelocations - with get() = pointerToRelocations - and set value = pointerToRelocations <- value - - member x.PointerToLineNumbers - with get() = pointerToLineNumbers - and set value = pointerToLineNumbers <- value - - member x.NumberOfRelocations - with get() = numberOfRelocations - and set value = numberOfRelocations <- value - - member x.NumberOfLineNumbers - with get() = numberOfLineNumbers - and set value = numberOfLineNumbers <- value - - member x.Characteristics - with get() = characteristics - and set value = characteristics <- value - - static member Width - with get() = 40 - - member x.toBytes () = - use buf = ByteBuffer.Create IMAGE_SECTION_HEADER.Width - buf.EmitInt64 name - buf.EmitInt32 addressInfo - buf.EmitInt32 virtualAddress - buf.EmitInt32 sizeOfRawData - buf.EmitInt32 pointerToRawData - buf.EmitInt32 pointerToRelocations - buf.EmitInt32 pointerToLineNumbers - buf.EmitUInt16 (uint16 numberOfRelocations) - buf.EmitUInt16 (uint16 numberOfLineNumbers) - buf.EmitInt32 characteristics - buf.AsMemory().ToArray() + let mutable name = n + let mutable addressInfo = ai // PhysicalAddress / VirtualSize + let mutable virtualAddress = va + let mutable sizeOfRawData = srd + let mutable pointerToRawData = prd + let mutable pointerToRelocations = pr + let mutable pointerToLineNumbers = pln + let mutable numberOfRelocations = nr + let mutable numberOfLineNumbers = nl + let mutable characteristics = c + + member x.Name + with get () = name + and set value = name <- value + + member x.PhysicalAddress + with get () = addressInfo + and set value = addressInfo <- value + + member x.VirtualSize + with get () = addressInfo + and set value = addressInfo <- value + + member x.VirtualAddress + with get () = virtualAddress + and set value = virtualAddress <- value + + member x.SizeOfRawData + with get () = sizeOfRawData + and set value = sizeOfRawData <- value + + member x.PointerToRawData + with get () = pointerToRawData + and set value = pointerToRawData <- value + + member x.PointerToRelocations + with get () = pointerToRelocations + and set value = pointerToRelocations <- value + member x.PointerToLineNumbers + with get () = pointerToLineNumbers + and set value = pointerToLineNumbers <- value + + member x.NumberOfRelocations + with get () = numberOfRelocations + and set value = numberOfRelocations <- value + + member x.NumberOfLineNumbers + with get () = numberOfLineNumbers + and set value = numberOfLineNumbers <- value + + member x.Characteristics + with get () = characteristics + and set value = characteristics <- value + + static member Width = 40 + + member x.toBytes() = + use buf = ByteBuffer.Create IMAGE_SECTION_HEADER.Width + buf.EmitInt64 name + buf.EmitInt32 addressInfo + buf.EmitInt32 virtualAddress + buf.EmitInt32 sizeOfRawData + buf.EmitInt32 pointerToRawData + buf.EmitInt32 pointerToRelocations + buf.EmitInt32 pointerToLineNumbers + buf.EmitUInt16(uint16 numberOfRelocations) + buf.EmitUInt16(uint16 numberOfLineNumbers) + buf.EmitInt32 characteristics + buf.AsMemory().ToArray() let bytesToISH (buffer: byte[]) (offset: int) = if (buffer.Length - offset) < IMAGE_SECTION_HEADER.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_SECTION_HEADER" - IMAGE_SECTION_HEADER(bytesToQWord(buffer[offset], buffer[offset+1], buffer[offset+2], buffer[offset+3], buffer[offset+4], buffer[offset+5], buffer[offset+6], buffer[offset+7]), // Name - bytesToDWord(buffer[offset+8], buffer[offset+9], buffer[offset+10], buffer[offset+11]), // AddressInfo - bytesToDWord(buffer[offset+12], buffer[offset+13], buffer[offset+14], buffer[offset+15]), // VirtualAddress - bytesToDWord(buffer[offset+16], buffer[offset+17], buffer[offset+18], buffer[offset+19]), // SizeOfRawData - bytesToDWord(buffer[offset+20], buffer[offset+21], buffer[offset+22], buffer[offset+23]), // PointerToRawData - bytesToDWord(buffer[offset+24], buffer[offset+25], buffer[offset+26], buffer[offset+27]), // PointerToRelocations - bytesToDWord(buffer[offset+28], buffer[offset+29], buffer[offset+30], buffer[offset+31]), // PointerToLineNumbers - bytesToWord(buffer[offset+32], buffer[offset+33]), // NumberOfRelocations - bytesToWord(buffer[offset+34], buffer[offset+35]), // NumberOfLineNumbers - bytesToDWord(buffer[offset+36], buffer[offset+37], buffer[offset+38], buffer[offset+39])) // Characteristics + + IMAGE_SECTION_HEADER( + bytesToQWord ( + buffer[offset], + buffer[offset + 1], + buffer[offset + 2], + buffer[offset + 3], + buffer[offset + 4], + buffer[offset + 5], + buffer[offset + 6], + buffer[offset + 7] + ), // Name + bytesToDWord (buffer[offset + 8], buffer[offset + 9], buffer[offset + 10], buffer[offset + 11]), // AddressInfo + bytesToDWord (buffer[offset + 12], buffer[offset + 13], buffer[offset + 14], buffer[offset + 15]), // VirtualAddress + bytesToDWord (buffer[offset + 16], buffer[offset + 17], buffer[offset + 18], buffer[offset + 19]), // SizeOfRawData + bytesToDWord (buffer[offset + 20], buffer[offset + 21], buffer[offset + 22], buffer[offset + 23]), // PointerToRawData + bytesToDWord (buffer[offset + 24], buffer[offset + 25], buffer[offset + 26], buffer[offset + 27]), // PointerToRelocations + bytesToDWord (buffer[offset + 28], buffer[offset + 29], buffer[offset + 30], buffer[offset + 31]), // PointerToLineNumbers + bytesToWord (buffer[offset + 32], buffer[offset + 33]), // NumberOfRelocations + bytesToWord (buffer[offset + 34], buffer[offset + 35]), // NumberOfLineNumbers + bytesToDWord (buffer[offset + 36], buffer[offset + 37], buffer[offset + 38], buffer[offset + 39]) + ) // Characteristics type IMAGE_SYMBOL(n: int64, v: int32, sn: int16, t: int16, sc: byte, nas: byte) = - let mutable name = n - let mutable value = v - let mutable sectionNumber = sn - let mutable stype = t - let mutable storageClass = sc - let mutable numberOfAuxSymbols = nas - - member x.Name - with get() = name - and set v = name <- v - - member x.Value - with get() = value - and set v = value <- v - - member x.SectionNumber - with get() = sectionNumber - and set v = sectionNumber <- v - - member x.Type - with get() = stype - and set v = stype <- v - - member x.StorageClass - with get() = storageClass - and set v = storageClass <- v - - member x.NumberOfAuxSymbols - with get() = numberOfAuxSymbols - and set v = numberOfAuxSymbols <- v - - static member Width - with get() = 18 - - member x.toBytes() = - use buf = ByteBuffer.Create IMAGE_SYMBOL.Width - buf.EmitInt64 name - buf.EmitInt32 value - buf.EmitUInt16 (uint16 sectionNumber) - buf.EmitUInt16 (uint16 stype) - buf.EmitByte storageClass - buf.EmitByte numberOfAuxSymbols - buf.AsMemory().ToArray() + let mutable name = n + let mutable value = v + let mutable sectionNumber = sn + let mutable stype = t + let mutable storageClass = sc + let mutable numberOfAuxSymbols = nas + + member x.Name + with get () = name + and set v = name <- v + + member x.Value + with get () = value + and set v = value <- v + + member x.SectionNumber + with get () = sectionNumber + and set v = sectionNumber <- v + + member x.Type + with get () = stype + and set v = stype <- v + + member x.StorageClass + with get () = storageClass + and set v = storageClass <- v + + member x.NumberOfAuxSymbols + with get () = numberOfAuxSymbols + and set v = numberOfAuxSymbols <- v + + static member Width = 18 + + member x.toBytes() = + use buf = ByteBuffer.Create IMAGE_SYMBOL.Width + buf.EmitInt64 name + buf.EmitInt32 value + buf.EmitUInt16(uint16 sectionNumber) + buf.EmitUInt16(uint16 stype) + buf.EmitByte storageClass + buf.EmitByte numberOfAuxSymbols + buf.AsMemory().ToArray() let bytesToIS (buffer: byte[]) (offset: int) = if (buffer.Length - offset) < IMAGE_SYMBOL.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_SYMBOL" - IMAGE_SYMBOL( bytesToQWord(buffer[offset], buffer[offset+1], buffer[offset+2], buffer[offset+3], buffer[offset+4], buffer[offset+5], buffer[offset+6], buffer[offset+7]), // Name - bytesToDWord(buffer[offset+8], buffer[offset+9], buffer[offset+10], buffer[offset+11]), // Value - bytesToWord(buffer[offset+12], buffer[offset+13]), // SectionNumber - bytesToWord(buffer[offset+14], buffer[offset+15]), // Type - buffer[offset+16], // StorageClass - buffer[offset+17]) // NumberOfAuxSymbols + + IMAGE_SYMBOL( + bytesToQWord ( + buffer[offset], + buffer[offset + 1], + buffer[offset + 2], + buffer[offset + 3], + buffer[offset + 4], + buffer[offset + 5], + buffer[offset + 6], + buffer[offset + 7] + ), // Name + bytesToDWord (buffer[offset + 8], buffer[offset + 9], buffer[offset + 10], buffer[offset + 11]), // Value + bytesToWord (buffer[offset + 12], buffer[offset + 13]), // SectionNumber + bytesToWord (buffer[offset + 14], buffer[offset + 15]), // Type + buffer[offset + 16], + buffer[offset + 17] + ) // NumberOfAuxSymbols type IMAGE_RELOCATION(va: int32, sti: int32, t: int16) = let mutable virtualAddress = va // Also RelocCount @@ -258,37 +299,39 @@ type IMAGE_RELOCATION(va: int32, sti: int32, t: int16) = let mutable ty = t // type member x.VirtualAddress - with get() = virtualAddress + with get () = virtualAddress and set v = virtualAddress <- v member x.RelocCount - with get() = virtualAddress + with get () = virtualAddress and set v = virtualAddress <- v member x.SymbolTableIndex - with get() = symbolTableIndex + with get () = symbolTableIndex and set v = symbolTableIndex <- v member x.Type - with get() = ty + with get () = ty and set v = ty <- v - static member Width - with get() = 10 + static member Width = 10 member x.toBytes() = use buf = ByteBuffer.Create IMAGE_RELOCATION.Width buf.EmitInt32 virtualAddress buf.EmitInt32 symbolTableIndex - buf.EmitUInt16 (uint16 ty) + buf.EmitUInt16(uint16 ty) buf.AsMemory().ToArray() let bytesToIR (buffer: byte[]) (offset: int) = if (buffer.Length - offset) < IMAGE_RELOCATION.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_RELOCATION" - IMAGE_RELOCATION( bytesToDWord(buffer[offset], buffer[offset+1], buffer[offset+2], buffer[offset+3]), - bytesToDWord(buffer[offset+4], buffer[offset+5], buffer[offset+6], buffer[offset+7]), - bytesToWord(buffer[offset+8], buffer[offset+9])) + + IMAGE_RELOCATION( + bytesToDWord (buffer[offset], buffer[offset + 1], buffer[offset + 2], buffer[offset + 3]), + bytesToDWord (buffer[offset + 4], buffer[offset + 5], buffer[offset + 6], buffer[offset + 7]), + bytesToWord (buffer[offset + 8], buffer[offset + 9]) + ) type IMAGE_RESOURCE_DIRECTORY(c: int32, tds: int32, mjv: int16, mnv: int16, nne: int16, nie: int16) = let mutable characteristics = c @@ -299,72 +342,73 @@ type IMAGE_RESOURCE_DIRECTORY(c: int32, tds: int32, mjv: int16, mnv: int16, nne: let mutable numberOfIdEntries = nie member x.Characteristics - with get() = characteristics + with get () = characteristics and set v = characteristics <- v member x.TimeDateStamp - with get() = timeDateStamp + with get () = timeDateStamp and set v = timeDateStamp <- v member x.MajorVersion - with get() = majorVersion + with get () = majorVersion and set v = majorVersion <- v member x.MinorVersion - with get() = minorVersion + with get () = minorVersion and set v = minorVersion <- v member x.NumberOfNamedEntries - with get() = numberOfNamedEntries + with get () = numberOfNamedEntries and set v = numberOfNamedEntries <- v member x.NumberOfIdEntries - with get() = numberOfIdEntries + with get () = numberOfIdEntries and set v = numberOfIdEntries <- v static member Width = 16 - member x.toBytes () = + member x.toBytes() = use buf = ByteBuffer.Create IMAGE_RESOURCE_DIRECTORY.Width buf.EmitInt32 characteristics buf.EmitInt32 timeDateStamp - buf.EmitUInt16 (uint16 majorVersion) - buf.EmitUInt16 (uint16 minorVersion) - buf.EmitUInt16 (uint16 numberOfNamedEntries) - buf.EmitUInt16 (uint16 numberOfIdEntries) + buf.EmitUInt16(uint16 majorVersion) + buf.EmitUInt16(uint16 minorVersion) + buf.EmitUInt16(uint16 numberOfNamedEntries) + buf.EmitUInt16(uint16 numberOfIdEntries) buf.AsMemory().ToArray() let bytesToIRD (buffer: byte[]) (offset: int) = if (buffer.Length - offset) < IMAGE_RESOURCE_DIRECTORY.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_RESOURCE_DIRECTORY" - IMAGE_RESOURCE_DIRECTORY( bytesToDWord(buffer[offset], buffer[offset+1], buffer[offset+2], buffer[offset+3]), // Characteristics - bytesToDWord(buffer[offset+4], buffer[offset+5], buffer[offset+6], buffer[offset+7]), // TimeDateStamp - bytesToWord(buffer[offset+8], buffer[offset+9]), // MajorVersion - bytesToWord(buffer[offset+10], buffer[offset+11]), // MinorVersion - bytesToWord(buffer[offset+12], buffer[offset+13]), // NumberOfNamedEntries - bytesToWord(buffer[offset+14], buffer[offset+15])) // NumberOfIdEntries + + IMAGE_RESOURCE_DIRECTORY( + bytesToDWord (buffer[offset], buffer[offset + 1], buffer[offset + 2], buffer[offset + 3]), // Characteristics + bytesToDWord (buffer[offset + 4], buffer[offset + 5], buffer[offset + 6], buffer[offset + 7]), // TimeDateStamp + bytesToWord (buffer[offset + 8], buffer[offset + 9]), // MajorVersion + bytesToWord (buffer[offset + 10], buffer[offset + 11]), // MinorVersion + bytesToWord (buffer[offset + 12], buffer[offset + 13]), // NumberOfNamedEntries + bytesToWord (buffer[offset + 14], buffer[offset + 15]) + ) // NumberOfIdEntries type IMAGE_RESOURCE_DIRECTORY_ENTRY(n: int32, o: int32) = let mutable name = n let mutable offset = o member x.Name - with get() = name + with get () = name and set v = name <- v member x.OffsetToData - with get() = offset + with get () = offset and set v = offset <- v - member x.OffsetToDirectory - with get() = offset &&& 0x7fffffff + member x.OffsetToDirectory = offset &&& 0x7fffffff - member x.DataIsDirectory - with get() = (offset &&& 0x80000000) <> 0 + member x.DataIsDirectory = (offset &&& 0x80000000) <> 0 static member Width = 8 - member x.toBytes () = + member x.toBytes() = use buf = ByteBuffer.Create IMAGE_RESOURCE_DIRECTORY_ENTRY.Width buf.EmitInt32 name buf.EmitInt32 offset @@ -373,8 +417,11 @@ type IMAGE_RESOURCE_DIRECTORY_ENTRY(n: int32, o: int32) = let bytesToIRDE (buffer: byte[]) (offset: int) = if (buffer.Length - offset) < IMAGE_RESOURCE_DIRECTORY_ENTRY.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_RESOURCE_DIRECTORY_ENTRY" - IMAGE_RESOURCE_DIRECTORY_ENTRY( bytesToDWord(buffer[offset], buffer[offset+1], buffer[offset+2], buffer[offset+3]), // Name - bytesToDWord(buffer[offset+4], buffer[offset+5], buffer[offset+6], buffer[offset+7])) // Offset + + IMAGE_RESOURCE_DIRECTORY_ENTRY( + bytesToDWord (buffer[offset], buffer[offset + 1], buffer[offset + 2], buffer[offset + 3]), // Name + bytesToDWord (buffer[offset + 4], buffer[offset + 5], buffer[offset + 6], buffer[offset + 7]) + ) // Offset type IMAGE_RESOURCE_DATA_ENTRY(o: int32, s: int32, c: int32, r: int32) = let mutable offsetToData = o @@ -383,16 +430,19 @@ type IMAGE_RESOURCE_DATA_ENTRY(o: int32, s: int32, c: int32, r: int32) = let mutable reserved = r member x.OffsetToData - with get() = offsetToData + with get () = offsetToData and set v = offsetToData <- v + member x.Size - with get() = size + with get () = size and set v = size <- v + member x.CodePage - with get() = codePage + with get () = codePage and set v = codePage <- v + member x.Reserved - with get() = reserved + with get () = reserved and set v = reserved <- v static member Width = 16 @@ -407,11 +457,13 @@ type IMAGE_RESOURCE_DATA_ENTRY(o: int32, s: int32, c: int32, r: int32) = let bytesToIRDataE (buffer: byte[]) (offset: int) = if (buffer.Length - offset) < IMAGE_RESOURCE_DATA_ENTRY.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_RESOURCE_DATA_ENTRY" - IMAGE_RESOURCE_DATA_ENTRY(bytesToDWord(buffer[offset], buffer[offset+1], buffer[offset+2], buffer[offset+3]), // OffsetToData - bytesToDWord(buffer[offset+4], buffer[offset+5], buffer[offset+6], buffer[offset+7]), // Size - bytesToDWord(buffer[offset+8], buffer[offset+9], buffer[offset+10], buffer[offset+11]), // CodePage - bytesToDWord(buffer[offset+12], buffer[offset+13], buffer[offset+14], buffer[offset+15])) // Reserved + IMAGE_RESOURCE_DATA_ENTRY( + bytesToDWord (buffer[offset], buffer[offset + 1], buffer[offset + 2], buffer[offset + 3]), // OffsetToData + bytesToDWord (buffer[offset + 4], buffer[offset + 5], buffer[offset + 6], buffer[offset + 7]), // Size + bytesToDWord (buffer[offset + 8], buffer[offset + 9], buffer[offset + 10], buffer[offset + 11]), // CodePage + bytesToDWord (buffer[offset + 12], buffer[offset + 13], buffer[offset + 14], buffer[offset + 15]) + ) // Reserved type ResFormatHeader() = let mutable dwDataSize = 0 @@ -425,39 +477,39 @@ type ResFormatHeader() = let mutable dwCharacteristics = 0 member x.DataSize - with get() = dwDataSize + with get () = dwDataSize and set v = dwDataSize <- v member x.HeaderSize - with get() = dwHeaderSize + with get () = dwHeaderSize and set v = dwHeaderSize <- v member x.TypeID - with get() = dwTypeID + with get () = dwTypeID and set v = dwTypeID <- v member x.NameID - with get() = dwNameID + with get () = dwNameID and set v = dwNameID <- v member x.DataVersion - with get() = dwDataVersion + with get () = dwDataVersion and set v = dwDataVersion <- v member x.MemFlags - with get() = wMemFlags + with get () = wMemFlags and set v = wMemFlags <- v member x.LangID - with get() = wLangID + with get () = wLangID and set v = wLangID <- v member x.Version - with get() = dwVersion + with get () = dwVersion and set v = dwVersion <- v member x.Characteristics - with get() = dwCharacteristics + with get () = dwCharacteristics and set v = dwCharacteristics <- v static member Width = 32 @@ -469,8 +521,8 @@ type ResFormatHeader() = buf.EmitInt32 dwTypeID buf.EmitInt32 dwNameID buf.EmitInt32 dwDataVersion - buf.EmitUInt16 (uint16 wMemFlags) - buf.EmitUInt16 (uint16 wLangID) + buf.EmitUInt16(uint16 wMemFlags) + buf.EmitUInt16(uint16 wLangID) buf.EmitInt32 dwVersion buf.EmitInt32 dwCharacteristics buf.AsMemory().ToArray() @@ -487,7 +539,10 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink if (tid &&& 0x80000000) <> 0 then // REVIEW: Are names and types mutually exclusive? The C++ code didn't seem to think so, but I can't find any documentation resHdr.TypeID <- 0 let mtid = tid &&& 0x7fffffff - cType <- bytesToDWord(pbLinkedResource[mtid], pbLinkedResource[mtid+1], pbLinkedResource[mtid+2], pbLinkedResource[mtid+3]) + + cType <- + bytesToDWord (pbLinkedResource[mtid], pbLinkedResource[mtid + 1], pbLinkedResource[mtid + 2], pbLinkedResource[mtid + 3]) + wzType <- Bytes.zeroCreate ((cType + 1) * 2) Bytes.blit pbLinkedResource 4 wzType 0 (cType * 2) else @@ -496,7 +551,10 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink if (nid &&& 0x80000000) <> 0 then resHdr.NameID <- 0 let mnid = nid &&& 0x7fffffff - cName <- bytesToDWord(pbLinkedResource[mnid], pbLinkedResource[mnid+1], pbLinkedResource[mnid+2], pbLinkedResource[mnid+3]) + + cName <- + bytesToDWord (pbLinkedResource[mnid], pbLinkedResource[mnid + 1], pbLinkedResource[mnid + 2], pbLinkedResource[mnid + 3]) + wzName <- Bytes.zeroCreate ((cName + 1) * 2) Bytes.blit pbLinkedResource 4 wzName 0 (cName * 2) else @@ -519,13 +577,15 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink //resHdr.HeaderSize <- 32 if Unchecked.defaultof <> wzType then resHdr.HeaderSize <- resHdr.HeaderSize + ((cType + 1) * 2) - 4 + if Unchecked.defaultof <> wzName then resHdr.HeaderSize <- resHdr.HeaderSize + ((cName + 1) * 2) - 4 - let SaveChunk(p: byte[], sz: int) = - if Unchecked.defaultof <> pUnlinkedResource then + let SaveChunk (p: byte[], sz: int) = + if Unchecked.defaultof <> pUnlinkedResource then Bytes.blit p 0 pUnlinkedResource (unlinkedResourceOffset + offset) sz unlinkedResourceOffset <- unlinkedResourceOffset + sz + size <- size + sz () @@ -541,6 +601,7 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink dwFiller <- dwFiller + cType + 1 else SaveChunk(dwToBytes resHdr.TypeID) + if Unchecked.defaultof <> wzName then SaveChunk(wzName, ((cName + 1) * 2)) dwFiller <- dwFiller + cName + 1 @@ -566,28 +627,36 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink SaveChunk(pbData, dataEntry.Size) dwFiller <- dataEntry.Size &&& 0x3 + if dwFiller <> 0 then SaveChunk(bNil, 4 - dwFiller) size -let linkNativeResources (unlinkedResources: byte[] list) (rva: int32) = - let resources = - unlinkedResources - |> Seq.map (fun s -> new MemoryStream(s)) - |> Seq.map (fun s -> - let res = CvtResFile.ReadResFile s - s.Dispose() - res) - |> Seq.collect id - // See MakeWin32ResourceList https://github.com/dotnet/roslyn/blob/f40b89234db51da1e1153c14af184e618504be41/src/Compilers/Core/Portable/Compilation/Compilation.cs - |> Seq.map (fun r -> - Win32Resource(data = r.data, codePage = 0u, languageId = uint32 r.LanguageId, - id = int (int16 r.pstringName.Ordinal), name = r.pstringName.theString, - typeId = int (int16 r.pstringType.Ordinal), typeName = r.pstringType.theString)) - let bb = System.Reflection.Metadata.BlobBuilder() - NativeResourceWriter.SerializeWin32Resources(bb, resources, rva) - bb.ToArray() +let linkNativeResources (unlinkedResources: byte[] list) (rva: int32) = + let resources = + unlinkedResources + |> Seq.map (fun s -> new MemoryStream(s)) + |> Seq.map (fun s -> + let res = CvtResFile.ReadResFile s + s.Dispose() + res) + |> Seq.collect id + // See MakeWin32ResourceList https://github.com/dotnet/roslyn/blob/f40b89234db51da1e1153c14af184e618504be41/src/Compilers/Core/Portable/Compilation/Compilation.cs + |> Seq.map (fun r -> + Win32Resource( + data = r.data, + codePage = 0u, + languageId = uint32 r.LanguageId, + id = int (int16 r.pstringName.Ordinal), + name = r.pstringName.theString, + typeId = int (int16 r.pstringType.Ordinal), + typeName = r.pstringType.theString + )) + + let bb = System.Reflection.Metadata.BlobBuilder() + NativeResourceWriter.SerializeWin32Resources(bb, resources, rva) + bb.ToArray() let unlinkResource (ulLinkedResourceBaseRVA: int32) (pbLinkedResource: byte[]) = let mutable nResNodes = 0 @@ -621,7 +690,7 @@ let unlinkResource (ulLinkedResourceBaseRVA: int32) (pbLinkedResource: byte[]) = else nResNodes <- nResNodes + 1 - let pResNodes: ResFormatNode [] = Array.zeroCreate nResNodes + let pResNodes: ResFormatNode[] = Array.zeroCreate nResNodes nResNodes <- 0 // fill out the entry buffer @@ -631,6 +700,7 @@ let unlinkResource (ulLinkedResourceBaseRVA: int32) (pbLinkedResource: byte[]) = // Need to skip VERSION and RT_MANIFEST resources // REVIEW: ideally we shouldn't allocate space for these, or rename properly so we don't get the naming conflict let skipResource = (0x10 = dwTypeID) || (0x18 = dwTypeID) + if pirdeType.DataIsDirectory then let nameBase = pirdeType.OffsetToDirectory let pirdName = bytesToIRD pbLinkedResource nameBase @@ -654,28 +724,34 @@ let unlinkResource (ulLinkedResourceBaseRVA: int32) (pbLinkedResource: byte[]) = if pirdeLang.DataIsDirectory then // Resource hierarchy exceeds three levels Marshal.ThrowExceptionForHR(E_FAIL) - else - if (not skipResource) then - let rfn = ResFormatNode(dwTypeID, dwNameID, dwLangID, pirdeLang.OffsetToData, pbLinkedResource) - pResNodes[nResNodes] <- rfn - nResNodes <- nResNodes + 1 - else - if (not skipResource) then - let rfn = ResFormatNode(dwTypeID, dwNameID, 0, pirdeName.OffsetToData, pbLinkedResource) - pResNodes[nResNodes] <- rfn - nResNodes <- nResNodes + 1 - else - if (not skipResource) then - let rfn = ResFormatNode(dwTypeID, 0, 0, pirdeType.OffsetToData, pbLinkedResource) // REVIEW: I believe these 0s are what's causing the duplicate res naming problems - pResNodes[nResNodes] <- rfn - nResNodes <- nResNodes + 1 + else if (not skipResource) then + let rfn = + ResFormatNode(dwTypeID, dwNameID, dwLangID, pirdeLang.OffsetToData, pbLinkedResource) + + pResNodes[nResNodes] <- rfn + nResNodes <- nResNodes + 1 + else if (not skipResource) then + let rfn = + ResFormatNode(dwTypeID, dwNameID, 0, pirdeName.OffsetToData, pbLinkedResource) + + pResNodes[nResNodes] <- rfn + nResNodes <- nResNodes + 1 + else if (not skipResource) then + let rfn = ResFormatNode(dwTypeID, 0, 0, pirdeType.OffsetToData, pbLinkedResource) // REVIEW: I believe these 0s are what's causing the duplicate res naming problems + pResNodes[nResNodes] <- rfn + nResNodes <- nResNodes + 1 // Ok, all tree leaves are in ResFormatNode structs, and nResNodes ptrs are in pResNodes let mutable size = 0 + if nResNodes <> 0 then - size <- size + ResFormatHeader.Width ; // sizeof ResFormatHeader + size <- size + ResFormatHeader.Width // sizeof ResFormatHeader + for i = 0 to (nResNodes - 1) do - size <- size + pResNodes[i].Save(ulLinkedResourceBaseRVA, pbLinkedResource, Unchecked.defaultof, 0) + size <- + size + + pResNodes[i] + .Save(ulLinkedResourceBaseRVA, pbLinkedResource, Unchecked.defaultof, 0) let pResBuffer = Bytes.zeroCreate size @@ -684,12 +760,15 @@ let unlinkResource (ulLinkedResourceBaseRVA: int32) (pbLinkedResource: byte[]) = // Write a dummy header let rfh = ResFormatHeader() - let rfhBytes = rfh.toBytes() + let rfhBytes = rfh.toBytes () Bytes.blit rfhBytes 0 pResBuffer 0 ResFormatHeader.Width resBufferOffset <- resBufferOffset + ResFormatHeader.Width for i = 0 to (nResNodes - 1) do - resBufferOffset <- resBufferOffset + pResNodes[i].Save(ulLinkedResourceBaseRVA, pbLinkedResource, pResBuffer, resBufferOffset) + resBufferOffset <- + resBufferOffset + + pResNodes[i] + .Save(ulLinkedResourceBaseRVA, pbLinkedResource, pResBuffer, resBufferOffset) pResBuffer @@ -697,10 +776,16 @@ let unlinkResource (ulLinkedResourceBaseRVA: int32) (pbLinkedResource: byte[]) = // PDB Writing [] -[] +[] type IMetaDataDispenser = abstract DefineScope: unit -> unit // need this here to fill the first vtable slot - abstract OpenScope: [] szScope: string * [] dwOpenFlags: Int32 * [] riid: System.Guid byref * [] punk: Object byref -> unit + + abstract OpenScope: + [] szScope: string * + [] dwOpenFlags: Int32 * + [] riid: System.Guid byref * + [] punk: Object byref -> + unit [] [] @@ -715,11 +800,11 @@ type IMetadataEmit = abstract Placeholder: unit -> unit [] -[< Guid("B01FAFEB-C450-3A4D-BEEC-B4CEEC01E006") ; InterfaceType(ComInterfaceType.InterfaceIsIUnknown) >] -[< ComVisible(false) >] +[] +[] type ISymUnmanagedDocumentWriter = - abstract SetSource: sourceSize: int * [] source: byte[] -> unit - abstract SetCheckSum: algorithmId: System.Guid * checkSumSize: int * [] checkSum: byte [] -> unit + abstract SetSource: sourceSize: int * [] source: byte[] -> unit + abstract SetCheckSum: algorithmId: System.Guid * checkSumSize: int * [] checkSum: byte[] -> unit // Struct used to retrieve info on the debug output [] @@ -736,138 +821,190 @@ type ImageDebugDirectory = [] [] type ISymUnmanagedWriter2 = - abstract DefineDocument: [] url: string * - language: System.Guid byref * - languageVendor: System.Guid byref * - documentType: System.Guid byref * - [] RetVal: ISymUnmanagedDocumentWriter byref -> unit + abstract DefineDocument: + [] url: string * + language: System.Guid byref * + languageVendor: System.Guid byref * + documentType: System.Guid byref * + [] RetVal: ISymUnmanagedDocumentWriter byref -> + unit + abstract SetUserEntryPoint: entryMethod: uint32 -> unit abstract OpenMethod: meth: int -> unit abstract CloseMethod: unit -> unit abstract OpenScope: startOffset: int * pRetVal: int byref -> unit abstract CloseScope: endOffset: int -> unit abstract SetScopeRange: scopeID: int * startOffset: int * endOffset: int -> unit - abstract DefineLocalVariable: [] varName: string * - attributes: int * - cSig: int * - []signature: byte[] * - addressKind: int * - addr1: int * - addr2: int * - addr3: int * - startOffset: int * - endOffset: int -> unit - abstract DefineParameter: [] paramName: string * - attributes: int * - sequence: int * - addressKind: int * - addr1: int * - addr2: int * - addr3: int -> unit - abstract DefineField: parent: int * - [] fieldName: string * - attributes: int * - cSig: int * - []signature: byte[] * - addressKind: int * - addr1: int * - addr2: int * - addr3: int -> unit - abstract DefineGlobalVariable: [] globalVarName: string * - attributes: int * - cSig: int * - []signature: byte[] * - addressKind: int * - addr1: int * - addr2: int * - addr3: int -> unit + + abstract DefineLocalVariable: + [] varName: string * + attributes: int * + cSig: int * + [] signature: byte[] * + addressKind: int * + addr1: int * + addr2: int * + addr3: int * + startOffset: int * + endOffset: int -> + unit + + abstract DefineParameter: + [] paramName: string * + attributes: int * + sequence: int * + addressKind: int * + addr1: int * + addr2: int * + addr3: int -> + unit + + abstract DefineField: + parent: int * + [] fieldName: string * + attributes: int * + cSig: int * + [] signature: byte[] * + addressKind: int * + addr1: int * + addr2: int * + addr3: int -> + unit + + abstract DefineGlobalVariable: + [] globalVarName: string * + attributes: int * + cSig: int * + [] signature: byte[] * + addressKind: int * + addr1: int * + addr2: int * + addr3: int -> + unit + abstract Close: unit -> unit - abstract SetSymAttribute: parent: int * - [] attName: string * - cData: int * - []data: byte[] -> unit + + abstract SetSymAttribute: + parent: int * + [] attName: string * + cData: int * + [] data: byte[] -> + unit + abstract OpenNamespace: [] nsname: string -> unit abstract CloseNamespace: unit -> unit abstract UsingNamespace: [] fullName: string -> unit - abstract SetMethodSourceRange: startDoc: ISymUnmanagedDocumentWriter * - startLine: int * - startColumn: int * - endDoc: ISymUnmanagedDocumentWriter * - endLine: int * - endColumn: int -> unit - abstract Initialize: emitter: nativeint * - [] fileName: string * - stream: IStream * - fullBuild: bool -> unit - abstract GetDebugInfo: iDD: ImageDebugDirectory byref * - cData: int * - pcData: int byref * - []data: byte[] -> unit - abstract DefineSequencePoints: document: ISymUnmanagedDocumentWriter * - spCount: int * - []offsets: int [] * - []lines: int [] * - []columns: int [] * - []endLines: int [] * - []endColumns: int [] -> unit + + abstract SetMethodSourceRange: + startDoc: ISymUnmanagedDocumentWriter * + startLine: int * + startColumn: int * + endDoc: ISymUnmanagedDocumentWriter * + endLine: int * + endColumn: int -> + unit + + abstract Initialize: + emitter: nativeint * [] fileName: string * stream: IStream * fullBuild: bool -> unit + + abstract GetDebugInfo: + iDD: ImageDebugDirectory byref * + cData: int * + pcData: int byref * + [] data: byte[] -> + unit + + abstract DefineSequencePoints: + document: ISymUnmanagedDocumentWriter * + spCount: int * + [] offsets: int[] * + [] lines: int[] * + [] columns: int[] * + [] endLines: int[] * + [] endColumns: int[] -> + unit + abstract RemapToken: oldToken: int * newToken: int -> unit - abstract Initialize2: emitter: nativeint * - [] tempFileName: string * - stream: IStream * - fullBuild: bool * - [] finalFileName: string -> unit - abstract DefineConstant: [] constName: string * - value: Object * - cSig: int * - []signature: byte[] -> unit + + abstract Initialize2: + emitter: nativeint * + [] tempFileName: string * + stream: IStream * + fullBuild: bool * + [] finalFileName: string -> + unit + + abstract DefineConstant: + [] constName: string * + value: Object * + cSig: int * + [] signature: byte[] -> + unit + abstract Abort: unit -> unit - abstract DefineLocalVariable2: [] localVarName2: string * - attributes: int * - sigToken: int * - addressKind: int * - addr1: int * - addr2: int * - addr3: int * - startOffset: int * - endOffset: int -> unit - abstract DefineGlobalVariable2: [] globalVarName2: string * - attributes: int * - sigToken: int * - addressKind: int * - addr1: int * - addr2: int * - addr3: int -> unit - abstract DefineConstant2: [] constantName2: string * - value: Object * - sigToken: int -> unit - abstract OpenMethod2: method2: int * - isect: int * - offset: int -> unit + + abstract DefineLocalVariable2: + [] localVarName2: string * + attributes: int * + sigToken: int * + addressKind: int * + addr1: int * + addr2: int * + addr3: int * + startOffset: int * + endOffset: int -> + unit + + abstract DefineGlobalVariable2: + [] globalVarName2: string * + attributes: int * + sigToken: int * + addressKind: int * + addr1: int * + addr2: int * + addr3: int -> + unit + + abstract DefineConstant2: [] constantName2: string * value: Object * sigToken: int -> unit + abstract OpenMethod2: method2: int * isect: int * offset: int -> unit type PdbWriter = { symWriter: ISymUnmanagedWriter2 } -type PdbDocumentWriter = { symDocWriter: ISymUnmanagedDocumentWriter } (* pointer to pDocumentWriter COM object *) + +type PdbDocumentWriter = + { + symDocWriter: ISymUnmanagedDocumentWriter + } (* pointer to pDocumentWriter COM object *) + type idd = - { iddCharacteristics: int32 - iddMajorVersion: int32; (* actually u16 in IMAGE_DEBUG_DIRECTORY *) - iddMinorVersion: int32; (* actually u16 in IMAGE_DEBUG_DIRECTORY *) - iddType: int32 - iddData: byte[] } + { + iddCharacteristics: int32 + iddMajorVersion: int32 (* actually u16 in IMAGE_DEBUG_DIRECTORY *) + iddMinorVersion: int32 (* actually u16 in IMAGE_DEBUG_DIRECTORY *) + iddType: int32 + iddData: byte[] + } #endif #if !FX_NO_PDB_WRITER let pdbInitialize (binaryName: string) (pdbName: string) = // collect necessary COM types - let CorMetaDataDispenser = System.Type.GetTypeFromProgID("CLRMetaData.CorMetaDataDispenser") + let CorMetaDataDispenser = + System.Type.GetTypeFromProgID("CLRMetaData.CorMetaDataDispenser") // get the importer pointer - let mdd = System.Activator.CreateInstance(CorMetaDataDispenser) :?> IMetaDataDispenser + let mdd = + System.Activator.CreateInstance(CorMetaDataDispenser) :?> IMetaDataDispenser + let mutable IID_IMetaDataEmit = new Guid("BA3FEE4C-ECB9-4E41-83B7-183FA41CD859") let mutable o = Object() mdd.OpenScope(binaryName, 0x1, &IID_IMetaDataEmit, &o) // 0x1 = ofWrite let emitterPtr = Marshal.GetComInterfaceForObject(o, typeof) + let writer = try - let writer = Activator.CreateInstance(System.Type.GetTypeFromProgID("CorSymWriter_SxS")) :?> ISymUnmanagedWriter2 + let writer = + Activator.CreateInstance(System.Type.GetTypeFromProgID("CorSymWriter_SxS")) :?> ISymUnmanagedWriter2 + writer.Initialize(emitterPtr, pdbName, Unchecked.defaultof, true) writer finally @@ -877,10 +1014,8 @@ let pdbInitialize (binaryName: string) (pdbName: string) = { symWriter = writer } - -let pdbCloseDocument(documentWriter: PdbDocumentWriter) = - Marshal.ReleaseComObject (documentWriter.symDocWriter) - |> ignore +let pdbCloseDocument (documentWriter: PdbDocumentWriter) = + Marshal.ReleaseComObject(documentWriter.symDocWriter) |> ignore let pdbClose (writer: PdbWriter) dllFilename pdbFilename = writer.symWriter.Close() @@ -896,17 +1031,20 @@ let pdbClose (writer: PdbWriter) dllFilename pdbFilename = let rc = Marshal.ReleaseComObject(writer.symWriter) for i = 0 to (rc - 1) do - Marshal.ReleaseComObject(writer.symWriter) |> ignore + Marshal.ReleaseComObject(writer.symWriter) |> ignore let isLocked fileName = try - use _holder = FileSystem.OpenFileForWriteShim(fileName, FileMode.Open, FileAccess.ReadWrite, FileShare.None) + use _holder = + FileSystem.OpenFileForWriteShim(fileName, FileMode.Open, FileAccess.ReadWrite, FileShare.None) + false with | _ -> true let mutable attempts = 0 - while (isLocked dllFilename || isLocked pdbFilename) && attempts < 3 do + + while (isLocked dllFilename || isLocked pdbFilename) && attempts < 3 do // Need to induce two full collections for finalizers to run System.GC.Collect() System.GC.Collect() @@ -914,11 +1052,13 @@ let pdbClose (writer: PdbWriter) dllFilename pdbFilename = attempts <- attempts + 1 let pdbSetUserEntryPoint (writer: PdbWriter) (entryMethodToken: int32) = - writer.symWriter.SetUserEntryPoint((uint32)entryMethodToken) + writer.symWriter.SetUserEntryPoint((uint32) entryMethodToken) // Document checksum algorithms -let guidSourceHashMD5 = System.Guid(0x406ea660u, 0x64cfus, 0x4c82us, 0xb6uy, 0xf0uy, 0x42uy, 0xd4uy, 0x81uy, 0x72uy, 0xa7uy, 0x99uy) //406ea660-64cf-4c82-b6f0-42d48172a799 +let guidSourceHashMD5 = + System.Guid(0x406ea660u, 0x64cfus, 0x4c82us, 0xb6uy, 0xf0uy, 0x42uy, 0xd4uy, 0x81uy, 0x72uy, 0xa7uy, 0x99uy) //406ea660-64cf-4c82-b6f0-42d48172a799 + let hashSizeOfMD5 = 16 // If the FIPS algorithm policy is enabled on the computer (e.g., for US government employees and contractors) @@ -929,42 +1069,66 @@ let internal setCheckSum (url: string, writer: ISymUnmanagedDocumentWriter) = use file = FileSystem.OpenFileForReadShim(url) use md5 = System.Security.Cryptography.MD5.Create() let checkSum = md5.ComputeHash file + if (checkSum.Length = hashSizeOfMD5) then - writer.SetCheckSum (guidSourceHashMD5, hashSizeOfMD5, checkSum) - with _ -> () + writer.SetCheckSum(guidSourceHashMD5, hashSizeOfMD5, checkSum) + with + | _ -> () let pdbDefineDocument (writer: PdbWriter) (url: string) = //3F5162F8-07C6-11D3-9053-00C04FA302A1 //let mutable corSymLanguageTypeCSharp = System.Guid(0x3F5162F8u, 0x07C6us, 0x11D3us, 0x90uy, 0x53uy, 0x00uy, 0xC0uy, 0x4Fuy, 0xA3uy, 0x02uy, 0xA1uy) - let mutable corSymLanguageTypeFSharp = System.Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy) - let mutable corSymLanguageVendorMicrosoft = System.Guid(0x994b45c4u, 0xe6e9us, 0x11d2us, 0x90uy, 0x3fuy, 0x00uy, 0xc0uy, 0x4fuy, 0xa3uy, 0x02uy, 0xa1uy) - let mutable corSymDocumentTypeText = System.Guid(0x5a869d0bu, 0x6611us, 0x11d3us, 0xbduy, 0x2auy, 0x0uy, 0x0uy, 0xf8uy, 0x8uy, 0x49uy, 0xbduy) + let mutable corSymLanguageTypeFSharp = + System.Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy) + + let mutable corSymLanguageVendorMicrosoft = + System.Guid(0x994b45c4u, 0xe6e9us, 0x11d2us, 0x90uy, 0x3fuy, 0x00uy, 0xc0uy, 0x4fuy, 0xa3uy, 0x02uy, 0xa1uy) + + let mutable corSymDocumentTypeText = + System.Guid(0x5a869d0bu, 0x6611us, 0x11d3us, 0xbduy, 0x2auy, 0x0uy, 0x0uy, 0xf8uy, 0x8uy, 0x49uy, 0xbduy) + let mutable docWriter = Unchecked.defaultof writer.symWriter.DefineDocument(url, &corSymLanguageTypeFSharp, &corSymLanguageVendorMicrosoft, &corSymDocumentTypeText, &docWriter) setCheckSum (url, docWriter) { symDocWriter = docWriter } -let pdbOpenMethod (writer: PdbWriter) (methodToken: int32) = - writer.symWriter.OpenMethod methodToken +let pdbOpenMethod (writer: PdbWriter) (methodToken: int32) = writer.symWriter.OpenMethod methodToken -let pdbCloseMethod (writer: PdbWriter) = - writer.symWriter.CloseMethod() +let pdbCloseMethod (writer: PdbWriter) = writer.symWriter.CloseMethod() let pdbOpenScope (writer: PdbWriter) (startOffset: int32) = let mutable retInt = 0 writer.symWriter.OpenScope(startOffset, &retInt) check "action" (retInt) -let pdbCloseScope (writer: PdbWriter) (endOffset: int32) = - writer.symWriter.CloseScope endOffset +let pdbCloseScope (writer: PdbWriter) (endOffset: int32) = writer.symWriter.CloseScope endOffset let pdbDefineLocalVariable (writer: PdbWriter) (name: string) (signature: byte[]) (addr1: int32) = - writer.symWriter.DefineLocalVariable(name, 0, signature.Length, signature, int System.Diagnostics.SymbolStore.SymAddressKind.ILOffset, addr1, 0, 0, 0, 0) - -let pdbSetMethodRange (writer: PdbWriter) (docWriter1: PdbDocumentWriter) (startLine: int) (startCol: int) (docWriter2: PdbDocumentWriter) (endLine: int) (endCol: int) = + writer.symWriter.DefineLocalVariable( + name, + 0, + signature.Length, + signature, + int System.Diagnostics.SymbolStore.SymAddressKind.ILOffset, + addr1, + 0, + 0, + 0, + 0 + ) + +let pdbSetMethodRange + (writer: PdbWriter) + (docWriter1: PdbDocumentWriter) + (startLine: int) + (startCol: int) + (docWriter2: PdbDocumentWriter) + (endLine: int) + (endCol: int) + = writer.symWriter.SetMethodSourceRange(docWriter1.symDocWriter, startLine, startCol, docWriter2.symDocWriter, endLine, endCol) -let pdbDefineSequencePoints (writer: PdbWriter) (docWriter: PdbDocumentWriter) (pts: (int * int * int * int * int)[]) = +let pdbDefineSequencePoints (writer: PdbWriter) (docWriter: PdbDocumentWriter) (pts: (int * int * int * int * int)[]) = let offsets = (Array.map (fun (x, _, _, _, _) -> x) pts) let lines = (Array.map (fun (_, x, _, _, _) -> x) pts) let columns = (Array.map (fun (_, _, x, _, _) -> x) pts) @@ -976,86 +1140,120 @@ let pdbWriteDebugInfo (writer: PdbWriter) = let mutable iDD = new ImageDebugDirectory() let mutable length = 0 writer.symWriter.GetDebugInfo(&iDD, 0, &length, null) - let mutable data: byte [] = Array.zeroCreate length + let mutable data: byte[] = Array.zeroCreate length writer.symWriter.GetDebugInfo(&iDD, length, &length, data) - { iddCharacteristics = iDD.Characteristics - iddMajorVersion = int32 iDD.MajorVersion - iddMinorVersion = int32 iDD.MinorVersion - iddType = iDD.Type - iddData = data} + { + iddCharacteristics = iDD.Characteristics + iddMajorVersion = int32 iDD.MajorVersion + iddMinorVersion = int32 iDD.MinorVersion + iddType = iDD.Type + iddData = data + } #endif - #if !FX_NO_PDB_WRITER // PDB reading -type PdbReader = { symReader: ISymbolReader } -type PdbDocument = { symDocument: ISymbolDocument } -type PdbMethod = { symMethod: ISymbolMethod } +type PdbReader = { symReader: ISymbolReader } +type PdbDocument = { symDocument: ISymbolDocument } +type PdbMethod = { symMethod: ISymbolMethod } type PdbVariable = { symVariable: ISymbolVariable } type PdbMethodScope = { symScope: ISymbolScope } type PdbDebugPoint = - { pdbSeqPointOffset: int - pdbSeqPointDocument: PdbDocument - pdbSeqPointLine: int - pdbSeqPointColumn: int - pdbSeqPointEndLine: int - pdbSeqPointEndColumn: int } + { + pdbSeqPointOffset: int + pdbSeqPointDocument: PdbDocument + pdbSeqPointLine: int + pdbSeqPointColumn: int + pdbSeqPointEndLine: int + pdbSeqPointEndColumn: int + } let pdbReadOpen (moduleName: string) (path: string) : PdbReader = - let CorMetaDataDispenser = System.Type.GetTypeFromProgID("CLRMetaData.CorMetaDataDispenser") + let CorMetaDataDispenser = + System.Type.GetTypeFromProgID("CLRMetaData.CorMetaDataDispenser") + let mutable IID_IMetaDataImport = new Guid("7DAC8207-D3AE-4c75-9B67-92801A497D44") - let mdd = System.Activator.CreateInstance(CorMetaDataDispenser) :?> IMetaDataDispenser + + let mdd = + System.Activator.CreateInstance(CorMetaDataDispenser) :?> IMetaDataDispenser + let mutable o: Object = new Object() mdd.OpenScope(moduleName, 0, &IID_IMetaDataImport, &o) let importerPtr = Marshal.GetComInterfaceForObject(o, typeof) + try #if ENABLE_MONO_SUPPORT // ISymWrapper.dll is not available as a compile-time dependency for the cross-platform compiler, since it is Windows-only // Access it via reflection instead.System.Diagnostics.SymbolStore.SymBinder try - let isym = System.Reflection.Assembly.Load("ISymWrapper, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a") + let isym = + System.Reflection.Assembly.Load("ISymWrapper, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a") + let symbolBinder = isym.CreateInstance("System.Diagnostics.SymbolStore.SymBinder") let symbolBinderTy = symbolBinder.GetType() - let reader = symbolBinderTy.InvokeMember("GetReader", BindingFlags.Public ||| BindingFlags.InvokeMethod ||| BindingFlags.Instance, null, symbolBinder, [| box importerPtr; box moduleName; box path |]) + + let reader = + symbolBinderTy.InvokeMember( + "GetReader", + BindingFlags.Public ||| BindingFlags.InvokeMethod ||| BindingFlags.Instance, + null, + symbolBinder, + [| box importerPtr; box moduleName; box path |] + ) + { symReader = reader :?> ISymbolReader } - with _ -> - { symReader = null } + with + | _ -> { symReader = null } #else let symbolBinder = new System.Diagnostics.SymbolStore.SymBinder() - { symReader = symbolBinder.GetReader(importerPtr, moduleName, path) } + + { + symReader = symbolBinder.GetReader(importerPtr, moduleName, path) + } #endif finally // Marshal.GetComInterfaceForObject adds an extra ref for importerPtr if IntPtr.Zero <> importerPtr then - Marshal.Release importerPtr |> ignore + Marshal.Release importerPtr |> ignore // The symbol reader's finalize method will clean up any unmanaged resources. // If file locks persist, we may want to manually invoke finalize let pdbReadClose (_reader: PdbReader) : unit = () let pdbReaderGetMethod (reader: PdbReader) (token: int32) : PdbMethod = - { symMethod = reader.symReader.GetMethod(SymbolToken token) } + { + symMethod = reader.symReader.GetMethod(SymbolToken token) + } -let pdbReaderGetMethodFromDocumentPosition (reader: PdbReader) (document: PdbDocument) (line: int) (column: int) : PdbMethod = - { symMethod = reader.symReader.GetMethodFromDocumentPosition(document.symDocument, line, column) } +let pdbReaderGetMethodFromDocumentPosition (reader: PdbReader) (document: PdbDocument) (line: int) (column: int) : PdbMethod = + { + symMethod = reader.symReader.GetMethodFromDocumentPosition(document.symDocument, line, column) + } let pdbReaderGetDocuments (reader: PdbReader) : PdbDocument[] = let arr = reader.symReader.GetDocuments() - Array.map (fun i -> { symDocument=i }) arr - -let pdbReaderGetDocument (reader: PdbReader) (url: string) (language: byte[]) (languageVendor: byte[]) (documentType: byte[]) : PdbDocument = - { symDocument = reader.symReader.GetDocument(url, Guid language, Guid languageVendor, System.Guid documentType) } - -let pdbDocumentGetURL (document: PdbDocument) : string = - document.symDocument.URL - -let pdbDocumentGetType (document: PdbDocument) : byte[] (* guid *) = + Array.map (fun i -> { symDocument = i }) arr + +let pdbReaderGetDocument + (reader: PdbReader) + (url: string) + (language: byte[]) + (languageVendor: byte[]) + (documentType: byte[]) + : PdbDocument = + { + symDocument = reader.symReader.GetDocument(url, Guid language, Guid languageVendor, System.Guid documentType) + } + +let pdbDocumentGetURL (document: PdbDocument) : string = document.symDocument.URL + +let pdbDocumentGetType (document: PdbDocument) : byte (* guid *) [] = let guid = document.symDocument.DocumentType guid.ToByteArray() -let pdbDocumentGetLanguage (document: PdbDocument) : byte[] (* guid *) = +let pdbDocumentGetLanguage (document: PdbDocument) : byte (* guid *) [] = let guid = document.symDocument.Language guid.ToByteArray() @@ -1071,7 +1269,7 @@ let pdbMethodGetToken (meth: PdbMethod) : int32 = token.GetToken() let pdbMethodGetDebugPoints (meth: PdbMethod) : PdbDebugPoint[] = - let pSize = meth.symMethod.SequencePointCount + let pSize = meth.symMethod.SequencePointCount let offsets = Array.zeroCreate pSize let docs = Array.zeroCreate pSize let lines = Array.zeroCreate pSize @@ -1082,29 +1280,29 @@ let pdbMethodGetDebugPoints (meth: PdbMethod) : PdbDebugPoint[] = meth.symMethod.GetSequencePoints(offsets, docs, lines, cols, endLines, endColumns) Array.init pSize (fun i -> - { pdbSeqPointOffset = offsets.[i] - pdbSeqPointDocument = { symDocument = docs.[i] } - pdbSeqPointLine = lines.[i] - pdbSeqPointColumn = cols.[i] - pdbSeqPointEndLine = endLines.[i] - pdbSeqPointEndColumn = endColumns.[i] }) + { + pdbSeqPointOffset = offsets.[i] + pdbSeqPointDocument = { symDocument = docs.[i] } + pdbSeqPointLine = lines.[i] + pdbSeqPointColumn = cols.[i] + pdbSeqPointEndLine = endLines.[i] + pdbSeqPointEndColumn = endColumns.[i] + }) let pdbScopeGetChildren (scope: PdbMethodScope) : PdbMethodScope[] = let arr = scope.symScope.GetChildren() - Array.map (fun i -> { symScope=i }) arr + Array.map (fun i -> { symScope = i }) arr let pdbScopeGetOffsets (scope: PdbMethodScope) : int * int = (scope.symScope.StartOffset, scope.symScope.EndOffset) let pdbScopeGetLocals (scope: PdbMethodScope) : PdbVariable[] = let arr = scope.symScope.GetLocals() - Array.map (fun i -> { symVariable=i }) arr + Array.map (fun i -> { symVariable = i }) arr -let pdbVariableGetName (variable: PdbVariable) : string = - variable.symVariable.Name +let pdbVariableGetName (variable: PdbVariable) : string = variable.symVariable.Name -let pdbVariableGetSignature (variable: PdbVariable) : byte[] = - variable.symVariable.GetSignature() +let pdbVariableGetSignature (variable: PdbVariable) : byte[] = variable.symVariable.GetSignature() // The tuple is (AddressKind, AddressField1) let pdbVariableGetAddressAttributes (variable: PdbVariable) : (int32 * int32) = diff --git a/src/Compiler/AbstractIL/ilwritepdb.fs b/src/Compiler/AbstractIL/ilwritepdb.fs index a6a5bb8af..0a4a5b537 100644 --- a/src/Compiler/AbstractIL/ilwritepdb.fs +++ b/src/Compiler/AbstractIL/ilwritepdb.fs @@ -20,27 +20,40 @@ open FSharp.Compiler.DiagnosticsLogger open FSharp.Compiler.IO open FSharp.Compiler.Text.Range -type BlobBuildingStream () = +type BlobBuildingStream() = inherit Stream() static let chunkSize = 32 * 1024 let builder = BlobBuilder(chunkSize) override _.CanWrite = true - override _.CanRead = false - override _.CanSeek = false - override _.Length = int64 builder.Count - override _.Write(buffer: byte array, offset: int, count: int) = builder.WriteBytes(buffer, offset, count) + override _.CanRead = false + + override _.CanSeek = false + + override _.Length = int64 builder.Count + + override _.Write(buffer: byte array, offset: int, count: int) = + builder.WriteBytes(buffer, offset, count) + override _.WriteByte(value: byte) = builder.WriteByte value - member _.WriteInt32(value: int) = builder.WriteInt32 value - member _.ToImmutableArray() = builder.ToImmutableArray() - member _.TryWriteBytes(stream: Stream, length: int) = builder.TryWriteBytes(stream, length) + + member _.WriteInt32(value: int) = builder.WriteInt32 value + + member _.ToImmutableArray() = builder.ToImmutableArray() + + member _.TryWriteBytes(stream: Stream, length: int) = builder.TryWriteBytes(stream, length) override _.Flush() = () + override _.Dispose(_disposing: bool) = () + override _.Seek(_offset: int64, _origin: SeekOrigin) = raise (NotSupportedException()) + override _.Read(_buffer: byte array, _offset: int, _count: int) = raise (NotSupportedException()) + + override _.SetLength(_value: int64) = raise (NotSupportedException()) override val Position = 0L with get, set @@ -51,101 +64,106 @@ type PdbDocumentData = ILSourceDocument type PdbLocalVar = { - Name: string - Signature: byte[] - /// the local index the name corresponds to - Index: int32 + Name: string + Signature: byte[] + /// the local index the name corresponds to + Index: int32 } type PdbImport = | ImportType of targetTypeToken: int32 (* alias: string option *) - | ImportNamespace of targetNamespace: string (* assembly: ILAssemblyRef option * alias: string option *) - //| ReferenceAlias of string - //| OpenXmlNamespace of prefix: string * xmlNamespace: string + | ImportNamespace of targetNamespace: string (* assembly: ILAssemblyRef option * alias: string option *) +//| ReferenceAlias of string +//| OpenXmlNamespace of prefix: string * xmlNamespace: string type PdbImports = - { - Parent: PdbImports option - Imports: PdbImport[] + { + Parent: PdbImports option + Imports: PdbImport[] } type PdbMethodScope = - { - Children: PdbMethodScope[] - StartOffset: int - EndOffset: int - Locals: PdbLocalVar[] - Imports: PdbImports option + { + Children: PdbMethodScope[] + StartOffset: int + EndOffset: int + Locals: PdbLocalVar[] + Imports: PdbImports option } type PdbSourceLoc = { - Document: int - Line: int - Column: int + Document: int + Line: int + Column: int } type PdbDebugPoint = { - Document: int - Offset: int - Line: int - Column: int - EndLine: int - EndColumn: int + Document: int + Offset: int + Line: int + Column: int + EndLine: int + EndColumn: int } - override x.ToString() = sprintf "(%d,%d)-(%d,%d)" x.Line x.Column x.EndLine x.EndColumn + + override x.ToString() = + sprintf "(%d,%d)-(%d,%d)" x.Line x.Column x.EndLine x.EndColumn type PdbMethodData = { - MethToken: int32 - MethName: string - LocalSignatureToken: int32 - Params: PdbLocalVar array - RootScope: PdbMethodScope option - DebugRange: (PdbSourceLoc * PdbSourceLoc) option - DebugPoints: PdbDebugPoint array + MethToken: int32 + MethName: string + LocalSignatureToken: int32 + Params: PdbLocalVar array + RootScope: PdbMethodScope option + DebugRange: (PdbSourceLoc * PdbSourceLoc) option + DebugPoints: PdbDebugPoint array } module SequencePoint = let orderBySource sp1 sp2 = let c1 = compare sp1.Document sp2.Document + if c1 <> 0 then c1 else let c1 = compare sp1.Line sp2.Line + if c1 <> 0 then c1 else compare sp1.Column sp2.Column - let orderByOffset sp1 sp2 = - compare sp1.Offset sp2.Offset + let orderByOffset sp1 sp2 = compare sp1.Offset sp2.Offset /// 28 is the size of the IMAGE_DEBUG_DIRECTORY in ntimage.h let sizeof_IMAGE_DEBUG_DIRECTORY = 28 [] type PdbData = - { EntryPoint: int32 option - Timestamp: int32 - ModuleID: byte[] - Documents: PdbDocumentData[] - Methods: PdbMethodData[] - TableRowCounts: int[] } + { + EntryPoint: int32 option + Timestamp: int32 + ModuleID: byte[] + Documents: PdbDocumentData[] + Methods: PdbMethodData[] + TableRowCounts: int[] + } -type BinaryChunk = - { size: int32 - addr: int32 } +type BinaryChunk = { size: int32; addr: int32 } type idd = - { iddCharacteristics: int32 - iddMajorVersion: int32; (* actually u16 in IMAGE_DEBUG_DIRECTORY *) - iddMinorVersion: int32; (* actually u16 in IMAGE_DEBUG_DIRECTORY *) - iddType: int32 - iddTimestamp: int32 - iddData: byte[] - iddChunk: BinaryChunk } + { + iddCharacteristics: int32 + iddMajorVersion: int32 (* actually u16 in IMAGE_DEBUG_DIRECTORY *) + iddMinorVersion: int32 (* actually u16 in IMAGE_DEBUG_DIRECTORY *) + iddType: int32 + iddTimestamp: int32 + iddData: byte[] + iddChunk: BinaryChunk + } /// The specified Hash algorithm to use on portable pdb files. type HashAlgorithm = @@ -159,14 +177,16 @@ let guidSha2 = Guid("8829d00f-11b8-4213-878b-770e8597ac16") let checkSum (url: string) (checksumAlgorithm: HashAlgorithm) = try use file = FileSystem.OpenFileForReadShim(url) + let guid, alg = match checksumAlgorithm with | HashAlgorithm.Sha1 -> guidSha1, SHA1.Create() :> System.Security.Cryptography.HashAlgorithm | HashAlgorithm.Sha256 -> guidSha2, SHA256.Create() :> System.Security.Cryptography.HashAlgorithm let checkSum = alg.ComputeHash file - Some (guid, checkSum) - with _ -> None + Some(guid, checkSum) + with + | _ -> None //--------------------------------------------------------------------- // Portable PDB Writer @@ -176,92 +196,117 @@ let b0 n = (n &&& 0xFF) let b1 n = ((n >>> 8) &&& 0xFF) let b2 n = ((n >>> 16) &&& 0xFF) let b3 n = ((n >>> 24) &&& 0xFF) -let i32AsBytes i = [| byte (b0 i); byte (b1 i); byte (b2 i); byte (b3 i) |] + +let i32AsBytes i = + [| byte (b0 i); byte (b1 i); byte (b2 i); byte (b3 i) |] let cvMagicNumber = 0x53445352L + let pdbGetCvDebugInfo (mvid: byte[]) (timestamp: int32) (filepath: string) (cvChunk: BinaryChunk) = let iddCvBuffer = // Debug directory entry let path = (Encoding.UTF8.GetBytes filepath) - let buffer = Array.zeroCreate (sizeof + mvid.Length + sizeof + path.Length + 1) - let offset, size = (0, sizeof) // Magic Number RSDS dword: 0x53445352L + + let buffer = + Array.zeroCreate (sizeof + mvid.Length + sizeof + path.Length + 1) + + let offset, size = (0, sizeof) // Magic Number RSDS dword: 0x53445352L Buffer.BlockCopy(i32AsBytes (int cvMagicNumber), 0, buffer, offset, size) - let offset, size = (offset + size, mvid.Length) // mvid Guid + let offset, size = (offset + size, mvid.Length) // mvid Guid Buffer.BlockCopy(mvid, 0, buffer, offset, size) - let offset, size = (offset + size, sizeof) // # of pdb files generated (1) + let offset, size = (offset + size, sizeof) // # of pdb files generated (1) Buffer.BlockCopy(i32AsBytes 1, 0, buffer, offset, size) - let offset, size = (offset + size, path.Length) // Path to pdb string + let offset, size = (offset + size, path.Length) // Path to pdb string Buffer.BlockCopy(path, 0, buffer, offset, size) buffer - { iddCharacteristics = 0 // Reserved - iddMajorVersion = 0x0100 // VersionMajor should be 0x0100 - iddMinorVersion = 0x504d // VersionMinor should be 0x504d - iddType = 2 // IMAGE_DEBUG_TYPE_CODEVIEW - iddTimestamp = timestamp - iddData = iddCvBuffer // Path name to the pdb file when built - iddChunk = cvChunk + + { + iddCharacteristics = 0 // Reserved + iddMajorVersion = 0x0100 // VersionMajor should be 0x0100 + iddMinorVersion = 0x504d // VersionMinor should be 0x504d + iddType = 2 // IMAGE_DEBUG_TYPE_CODEVIEW + iddTimestamp = timestamp + iddData = iddCvBuffer // Path name to the pdb file when built + iddChunk = cvChunk } -let pdbMagicNumber= 0x4244504dL +let pdbMagicNumber = 0x4244504dL + let pdbGetEmbeddedPdbDebugInfo (embeddedPdbChunk: BinaryChunk) (uncompressedLength: int64) (compressedStream: MemoryStream) = let iddPdbBuffer = - let buffer = Array.zeroCreate (sizeof + sizeof + int(compressedStream.Length)) - let offset, size = (0, sizeof) // Magic Number dword: 0x4244504dL + let buffer = + Array.zeroCreate (sizeof + sizeof + int (compressedStream.Length)) + + let offset, size = (0, sizeof) // Magic Number dword: 0x4244504dL Buffer.BlockCopy(i32AsBytes (int pdbMagicNumber), 0, buffer, offset, size) - let offset, size = (offset + size, sizeof) // Uncompressed size + let offset, size = (offset + size, sizeof) // Uncompressed size Buffer.BlockCopy(i32AsBytes (int uncompressedLength), 0, buffer, offset, size) - let offset, size = (offset + size, int(compressedStream.Length)) // Uncompressed size + let offset, size = (offset + size, int (compressedStream.Length)) // Uncompressed size Buffer.BlockCopy(compressedStream.ToArray(), 0, buffer, offset, size) buffer - { iddCharacteristics = 0 // Reserved - iddMajorVersion = 0x0100 // VersionMajor should be 0x0100 - iddMinorVersion = 0x0100 // VersionMinor should be 0x0100 - iddType = 17 // IMAGE_DEBUG_TYPE_EMBEDDEDPDB - iddTimestamp = 0 - iddData = iddPdbBuffer // Path name to the pdb file when built - iddChunk = embeddedPdbChunk + + { + iddCharacteristics = 0 // Reserved + iddMajorVersion = 0x0100 // VersionMajor should be 0x0100 + iddMinorVersion = 0x0100 // VersionMinor should be 0x0100 + iddType = 17 // IMAGE_DEBUG_TYPE_EMBEDDEDPDB + iddTimestamp = 0 + iddData = iddPdbBuffer // Path name to the pdb file when built + iddChunk = embeddedPdbChunk } -let pdbChecksumDebugInfo timestamp (checksumPdbChunk: BinaryChunk) (algorithmName:string) (checksum: byte[]) = +let pdbChecksumDebugInfo timestamp (checksumPdbChunk: BinaryChunk) (algorithmName: string) (checksum: byte[]) = let iddBuffer = let alg = Encoding.UTF8.GetBytes(algorithmName) let buffer = Array.zeroCreate (alg.Length + 1 + checksum.Length) Buffer.BlockCopy(alg, 0, buffer, 0, alg.Length) Buffer.BlockCopy(checksum, 0, buffer, alg.Length + 1, checksum.Length) buffer - { iddCharacteristics = 0 // Reserved - iddMajorVersion = 1 // VersionMajor should be 1 - iddMinorVersion = 0 // VersionMinor should be 0 - iddType = 19 // IMAGE_DEBUG_TYPE_CHECKSUMPDB - iddTimestamp = timestamp - iddData = iddBuffer // Path name to the pdb file when built - iddChunk = checksumPdbChunk + + { + iddCharacteristics = 0 // Reserved + iddMajorVersion = 1 // VersionMajor should be 1 + iddMinorVersion = 0 // VersionMinor should be 0 + iddType = 19 // IMAGE_DEBUG_TYPE_CHECKSUMPDB + iddTimestamp = timestamp + iddData = iddBuffer // Path name to the pdb file when built + iddChunk = checksumPdbChunk } let pdbGetPdbDebugDeterministicInfo (deterministicPdbChunk: BinaryChunk) = - { iddCharacteristics = 0 // Reserved - iddMajorVersion = 0 // VersionMajor should be 0 - iddMinorVersion = 0 // VersionMinor should be 00 - iddType = 16 // IMAGE_DEBUG_TYPE_DETERMINISTIC - iddTimestamp = 0 - iddData = Array.empty // No DATA - iddChunk = deterministicPdbChunk + { + iddCharacteristics = 0 // Reserved + iddMajorVersion = 0 // VersionMajor should be 0 + iddMinorVersion = 0 // VersionMinor should be 00 + iddType = 16 // IMAGE_DEBUG_TYPE_DETERMINISTIC + iddTimestamp = 0 + iddData = Array.empty // No DATA + iddChunk = deterministicPdbChunk } -let pdbGetDebugInfo (contentId: byte[]) (timestamp: int32) (filepath: string) - (cvChunk: BinaryChunk) - (embeddedPdbChunk: BinaryChunk option) - (deterministicPdbChunk: BinaryChunk) - (checksumPdbChunk: BinaryChunk) (algorithmName:string) (checksum: byte []) - (uncompressedLength: int64) (compressedStream: MemoryStream option) - (embeddedPdb: bool) (deterministic: bool) = - [| yield pdbGetCvDebugInfo contentId timestamp filepath cvChunk +let pdbGetDebugInfo + (contentId: byte[]) + (timestamp: int32) + (filepath: string) + (cvChunk: BinaryChunk) + (embeddedPdbChunk: BinaryChunk option) + (deterministicPdbChunk: BinaryChunk) + (checksumPdbChunk: BinaryChunk) + (algorithmName: string) + (checksum: byte[]) + (uncompressedLength: int64) + (compressedStream: MemoryStream option) + (embeddedPdb: bool) + (deterministic: bool) + = + [| + yield pdbGetCvDebugInfo contentId timestamp filepath cvChunk yield pdbChecksumDebugInfo timestamp checksumPdbChunk algorithmName checksum if embeddedPdb then match compressedStream, embeddedPdbChunk with - | None, _ | _, None -> () - | Some compressedStream, Some chunk -> - yield pdbGetEmbeddedPdbDebugInfo chunk uncompressedLength compressedStream + | None, _ + | _, None -> () + | Some compressedStream, Some chunk -> yield pdbGetEmbeddedPdbDebugInfo chunk uncompressedLength compressedStream if deterministic then yield pdbGetPdbDebugDeterministicInfo deterministicPdbChunk |] @@ -274,13 +319,13 @@ let pdbGetDebugInfo (contentId: byte[]) (timestamp: int32) (filepath: string) // This function takes output file name and returns debug file name. let getDebugFileName outfile (portablePDB: bool) = #if ENABLE_MONO_SUPPORT - if runningOnMono && not portablePDB then - outfile + ".mdb" - else + if runningOnMono && not portablePDB then + outfile + ".mdb" + else #else - ignore portablePDB + ignore portablePDB #endif - (FileSystemUtils.chopExtension outfile) + ".pdb" + (FileSystemUtils.chopExtension outfile) + ".pdb" let sortMethods showTimes info = reportTime showTimes (sprintf "PDB: Defined %d documents" info.Documents.Length) @@ -290,17 +335,31 @@ let sortMethods showTimes info = let getRowCounts tableRowCounts = let builder = ImmutableArray.CreateBuilder(tableRowCounts |> Array.length) - tableRowCounts |> Seq.iter(fun x -> builder.Add x) + tableRowCounts |> Seq.iter (fun x -> builder.Add x) builder.MoveToImmutable() let scopeSorter (scope1: PdbMethodScope) (scope2: PdbMethodScope) = - if scope1.StartOffset > scope2.StartOffset then 1 - elif scope1.StartOffset < scope2.StartOffset then -1 - elif (scope1.EndOffset - scope1.StartOffset) > (scope2.EndOffset - scope2.StartOffset) then -1 - elif (scope1.EndOffset - scope1.StartOffset) < (scope2.EndOffset - scope2.StartOffset) then 1 - else 0 - -type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, sourceLink: string, checksumAlgorithm, showTimes, info: PdbData, pathMap: PathMap) = + if scope1.StartOffset > scope2.StartOffset then + 1 + elif scope1.StartOffset < scope2.StartOffset then + -1 + elif (scope1.EndOffset - scope1.StartOffset) > (scope2.EndOffset - scope2.StartOffset) then + -1 + elif (scope1.EndOffset - scope1.StartOffset) < (scope2.EndOffset - scope2.StartOffset) then + 1 + else + 0 + +type PortablePdbGenerator + ( + embedAllSource: bool, + embedSourceList: string list, + sourceLink: string, + checksumAlgorithm, + showTimes, + info: PdbData, + pathMap: PathMap + ) = let docs = match info.Documents with @@ -313,23 +372,37 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s let serializeDocumentName (name: string) = let name = PathMap.apply pathMap name - let count s c = s |> Seq.filter(fun ch -> c = ch) |> Seq.length + + let count s c = + s |> Seq.filter (fun ch -> c = ch) |> Seq.length let s1, s2 = '/', '\\' - let separator = if (count name s1) >= (count name s2) then s1 else s2 + + let separator = + if (count name s1) >= (count name s2) then + s1 + else + s2 let writer = BlobBuilder() writer.WriteByte(byte separator) - for part in name.Split( [| separator |] ) do - let partIndex = MetadataTokens.GetHeapOffset(BlobHandle.op_Implicit(metadata.GetOrAddBlobUTF8 part)) + for part in name.Split([| separator |]) do + let partIndex = + MetadataTokens.GetHeapOffset(BlobHandle.op_Implicit (metadata.GetOrAddBlobUTF8 part)) + writer.WriteCompressedInteger(int partIndex) metadata.GetOrAddBlob writer - let corSymLanguageTypeId = Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy) - let embeddedSourceId = Guid(0x0e8a571bu, 0x6926us, 0x466eus, 0xb4uy, 0xaduy, 0x8auy, 0xb0uy, 0x46uy, 0x11uy, 0xf5uy, 0xfeuy) - let sourceLinkId = Guid(0xcc110556u, 0xa091us, 0x4d38us, 0x9fuy, 0xecuy, 0x25uy, 0xabuy, 0x9auy, 0x35uy, 0x1auy, 0x6auy) + let corSymLanguageTypeId = + Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy) + + let embeddedSourceId = + Guid(0x0e8a571bu, 0x6926us, 0x466eus, 0xb4uy, 0xaduy, 0x8auy, 0xb0uy, 0x46uy, 0x11uy, 0xf5uy, 0xfeuy) + + let sourceLinkId = + Guid(0xcc110556u, 0xa091us, 0x4d38us, 0x9fuy, 0xecuy, 0x25uy, 0xabuy, 0x9auy, 0x35uy, 0x1auy, 0x6auy) /// /// The maximum number of bytes in to write out uncompressed. @@ -343,7 +416,9 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s let sourceCompressionThreshold = 200 let includeSource file = - let isInList = embedSourceList |> List.exists (fun f -> String.Compare(file, f, StringComparison.OrdinalIgnoreCase ) = 0) + let isInList = + embedSourceList + |> List.exists (fun f -> String.Compare(file, f, StringComparison.OrdinalIgnoreCase) = 0) if not embedAllSource && not isInList || not (FileSystem.FileExistsShim file) then None @@ -351,10 +426,13 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s use stream = FileSystem.OpenFileForReadShim(file) let length64 = stream.Length - if length64 > int64 Int32.MaxValue then raise (IOException("File is too long")) + + if length64 > int64 Int32.MaxValue then + raise (IOException("File is too long")) let builder = new BlobBuildingStream() let length = int length64 + if length < sourceCompressionThreshold then builder.WriteInt32 0 builder.TryWriteBytes(stream, length) |> ignore @@ -362,14 +440,23 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s builder.WriteInt32 length use deflater = new DeflateStream(builder, CompressionMode.Compress, true) stream.CopyTo deflater - Some (builder.ToImmutableArray()) + + Some(builder.ToImmutableArray()) let documentIndex = let mutable index = Dictionary(docs.Length) - let docLength = docs.Length + if String.IsNullOrEmpty sourceLink then 1 else 0 + + let docLength = + docs.Length + + if String.IsNullOrEmpty sourceLink then + 1 + else + 0 + metadata.SetCapacity(TableIndex.Document, docLength) + for doc in docs do - // For F# Interactive, file name 'stdin' gets generated for interactive inputs + // For F# Interactive, file name 'stdin' gets generated for interactive inputs let handle = match checkSum doc.File checksumAlgorithm with | Some (hashAlg, checkSum) -> @@ -377,31 +464,44 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s (serializeDocumentName doc.File, metadata.GetOrAddGuid hashAlg, metadata.GetOrAddBlob(checkSum.ToImmutableArray()), - metadata.GetOrAddGuid corSymLanguageTypeId) |> metadata.AddDocument + metadata.GetOrAddGuid corSymLanguageTypeId) + |> metadata.AddDocument + match includeSource doc.File with | None -> () | Some blob -> - metadata.AddCustomDebugInformation(DocumentHandle.op_Implicit dbgInfo, - metadata.GetOrAddGuid embeddedSourceId, - metadata.GetOrAddBlob blob) |> ignore + metadata.AddCustomDebugInformation( + DocumentHandle.op_Implicit dbgInfo, + metadata.GetOrAddGuid embeddedSourceId, + metadata.GetOrAddBlob blob + ) + |> ignore + dbgInfo | None -> let dbgInfo = (serializeDocumentName doc.File, metadata.GetOrAddGuid(Guid.Empty), metadata.GetOrAddBlob(ImmutableArray.Empty), - metadata.GetOrAddGuid corSymLanguageTypeId) |> metadata.AddDocument + metadata.GetOrAddGuid corSymLanguageTypeId) + |> metadata.AddDocument + dbgInfo + index.Add(doc.File, handle) if not (String.IsNullOrWhiteSpace sourceLink) then use fs = FileSystem.OpenFileForReadShim(sourceLink) use ms = new MemoryStream() fs.CopyTo ms + metadata.AddCustomDebugInformation( - ModuleDefinitionHandle.op_Implicit(EntityHandle.ModuleDefinition), + ModuleDefinitionHandle.op_Implicit (EntityHandle.ModuleDefinition), metadata.GetOrAddGuid sourceLinkId, - metadata.GetOrAddBlob(ms.ToArray())) |> ignore + metadata.GetOrAddBlob(ms.ToArray()) + ) + |> ignore + index let mutable lastLocalVariableHandle = Unchecked.defaultof @@ -438,57 +538,57 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s // Corresponds to an 'open ' or 'open type' in F# | ImportType targetTypeToken -> - //if (import.AliasOpt != null) - //{ - // // ::= AliasType - // writer.WriteByte((byte)ImportDefinitionKind.AliasType); - // writer.WriteCompressedInteger(MetadataTokens.GetHeapOffset(_debugMetadataOpt.GetOrAddBlobUTF8(import.AliasOpt))); - //} - //else - // ::= ImportType - writer.WriteByte(byte ImportDefinitionKind.ImportType) + //if (import.AliasOpt != null) + //{ + // // ::= AliasType + // writer.WriteByte((byte)ImportDefinitionKind.AliasType); + // writer.WriteCompressedInteger(MetadataTokens.GetHeapOffset(_debugMetadataOpt.GetOrAddBlobUTF8(import.AliasOpt))); + //} + //else + // ::= ImportType + writer.WriteByte(byte ImportDefinitionKind.ImportType) - writer.WriteCompressedInteger(targetTypeToken) + writer.WriteCompressedInteger(targetTypeToken) - // Corresponds to an 'open ' + // Corresponds to an 'open ' | ImportNamespace targetNamespace -> - //if (import.TargetAssemblyOpt != null) - //{ - // if (import.AliasOpt != null) - // { - // // ::= AliasAssemblyNamespace - // writer.WriteByte((byte)ImportDefinitionKind.AliasAssemblyNamespace); - // writer.WriteCompressedInteger(MetadataTokens.GetHeapOffset(_debugMetadataOpt.GetOrAddBlobUTF8(import.AliasOpt))); - // } - // else - // { - // // ::= ImportAssemblyNamespace - // writer.WriteByte((byte)ImportDefinitionKind.ImportAssemblyNamespace); - // } - - // writer.WriteCompressedInteger(MetadataTokens.GetRowNumber(GetAssemblyReferenceHandle(import.TargetAssemblyOpt))); - //} - //else - //{ - //if (import.AliasOpt != null) - //{ - // // ::= AliasNamespace - // writer.WriteByte((byte)ImportDefinitionKind.AliasNamespace); - // writer.WriteCompressedInteger(MetadataTokens.GetHeapOffset(_debugMetadataOpt.GetOrAddBlobUTF8(import.AliasOpt))); - //} - //else - //{ - // ::= ImportNamespace - writer.WriteByte(byte ImportDefinitionKind.ImportNamespace); - writer.WriteCompressedInteger(MetadataTokens.GetHeapOffset(metadata.GetOrAddBlobUTF8(targetNamespace))) - - //| ReferenceAlias alias -> - // // ::= ImportReferenceAlias - // Debug.Assert(import.AliasOpt != null); - // Debug.Assert(import.TargetAssemblyOpt == null); - - // writer.WriteByte((byte)ImportDefinitionKind.ImportAssemblyReferenceAlias); - // writer.WriteCompressedInteger(MetadataTokens.GetHeapOffset(_debugMetadataOpt.GetOrAddBlobUTF8(import.AliasOpt))); + //if (import.TargetAssemblyOpt != null) + //{ + // if (import.AliasOpt != null) + // { + // // ::= AliasAssemblyNamespace + // writer.WriteByte((byte)ImportDefinitionKind.AliasAssemblyNamespace); + // writer.WriteCompressedInteger(MetadataTokens.GetHeapOffset(_debugMetadataOpt.GetOrAddBlobUTF8(import.AliasOpt))); + // } + // else + // { + // // ::= ImportAssemblyNamespace + // writer.WriteByte((byte)ImportDefinitionKind.ImportAssemblyNamespace); + // } + + // writer.WriteCompressedInteger(MetadataTokens.GetRowNumber(GetAssemblyReferenceHandle(import.TargetAssemblyOpt))); + //} + //else + //{ + //if (import.AliasOpt != null) + //{ + // // ::= AliasNamespace + // writer.WriteByte((byte)ImportDefinitionKind.AliasNamespace); + // writer.WriteCompressedInteger(MetadataTokens.GetHeapOffset(_debugMetadataOpt.GetOrAddBlobUTF8(import.AliasOpt))); + //} + //else + //{ + // ::= ImportNamespace + writer.WriteByte(byte ImportDefinitionKind.ImportNamespace) + writer.WriteCompressedInteger(MetadataTokens.GetHeapOffset(metadata.GetOrAddBlobUTF8(targetNamespace))) + + //| ReferenceAlias alias -> + // // ::= ImportReferenceAlias + // Debug.Assert(import.AliasOpt != null); + // Debug.Assert(import.TargetAssemblyOpt == null); + + // writer.WriteByte((byte)ImportDefinitionKind.ImportAssemblyReferenceAlias); + // writer.WriteCompressedInteger(MetadataTokens.GetHeapOffset(_debugMetadataOpt.GetOrAddBlobUTF8(import.AliasOpt))); let serializeImportsBlob (imports: PdbImport[]) = let writer = new BlobBuilder() @@ -499,33 +599,38 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s metadata.GetOrAddBlob(writer) // Define the empty global imports scope for the whole assembly,it gets index #1 (the first entry in the table) - let defineModuleImportScope() = + let defineModuleImportScope () = let writer = new BlobBuilder() let blob = metadata.GetOrAddBlob writer - let rid = metadata.AddImportScope(parentScope=Unchecked.defaultof<_>,imports=blob) - assert(rid = moduleImportScopeHandle) + + let rid = + metadata.AddImportScope(parentScope = Unchecked.defaultof<_>, imports = blob) + + assert (rid = moduleImportScopeHandle) let rec getImportScopeIndex (imports: PdbImports) = match importScopesTable.TryGetValue(imports) with | true, v -> v - | _ -> + | _ -> - let parentScopeHandle = - match imports.Parent with - | None -> moduleImportScopeHandle - | Some parent -> getImportScopeIndex parent + let parentScopeHandle = + match imports.Parent with + | None -> moduleImportScopeHandle + | Some parent -> getImportScopeIndex parent - let blob = serializeImportsBlob imports.Imports - let result = metadata.AddImportScope(parentScopeHandle, blob) + let blob = serializeImportsBlob imports.Imports + let result = metadata.AddImportScope(parentScopeHandle, blob) - importScopesTable.Add(imports, result) - result + importScopesTable.Add(imports, result) + result - let flattenScopes rootScope = + let flattenScopes rootScope = let list = List() + let rec flattenScopes scope parent = list.Add scope + for nestedScope in scope.Children do let isNested = match parent with @@ -536,8 +641,7 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s flattenScopes rootScope None - list.ToArray() - |> Array.sortWith scopeSorter + list.ToArray() |> Array.sortWith scopeSorter let writeMethodScopes methToken rootScope = @@ -547,21 +651,32 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s // Get or create the import scope for this method let importScopeHandle = - match scope.Imports with + match scope.Imports with | None -> Unchecked.defaultof<_> | Some imports -> getImportScopeIndex imports - let lastRowNumber = MetadataTokens.GetRowNumber(LocalVariableHandle.op_Implicit lastLocalVariableHandle) + let lastRowNumber = + MetadataTokens.GetRowNumber(LocalVariableHandle.op_Implicit lastLocalVariableHandle) + let nextHandle = MetadataTokens.LocalVariableHandle(lastRowNumber + 1) - metadata.AddLocalScope(MetadataTokens.MethodDefinitionHandle(methToken), + metadata.AddLocalScope( + MetadataTokens.MethodDefinitionHandle(methToken), importScopeHandle, nextHandle, Unchecked.defaultof, - scope.StartOffset, scope.EndOffset - scope.StartOffset ) |>ignore + scope.StartOffset, + scope.EndOffset - scope.StartOffset + ) + |> ignore for localVariable in scope.Locals do - lastLocalVariableHandle <- metadata.AddLocalVariable(LocalVariableAttributes.None, localVariable.Index, metadata.GetOrAddString(localVariable.Name)) + lastLocalVariableHandle <- + metadata.AddLocalVariable( + LocalVariableAttributes.None, + localVariable.Index, + metadata.GetOrAddString(localVariable.Name) + ) let emitMethod minfo = let docHandle, sequencePointBlob = @@ -577,8 +692,8 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s builder.WriteCompressedInteger(minfo.LocalSignatureToken) if sps.Length = 0 then - builder.WriteCompressedInteger( 0 ) - builder.WriteCompressedInteger( 0 ) + builder.WriteCompressedInteger(0) + builder.WriteCompressedInteger(0) Unchecked.defaultof, Unchecked.defaultof else @@ -586,15 +701,20 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s // If part of the method body is in another document returns nil handle. let tryGetSingleDocumentIndex = let mutable singleDocumentIndex = sps[0].Document + for i in 1 .. sps.Length - 1 do if sps[i].Document <> singleDocumentIndex then singleDocumentIndex <- -1 + singleDocumentIndex // Initial document: When sp's spread over more than one document we put the initial document here. let singleDocumentIndex = tryGetSingleDocumentIndex + if singleDocumentIndex = -1 then - builder.WriteCompressedInteger( MetadataTokens.GetRowNumber(DocumentHandle.op_Implicit(getDocumentHandle sps[0].Document)) ) + builder.WriteCompressedInteger( + MetadataTokens.GetRowNumber(DocumentHandle.op_Implicit (getDocumentHandle sps[0].Document)) + ) let mutable previousNonHiddenStartLine = -1 let mutable previousNonHiddenStartColumn = 0 @@ -602,8 +722,11 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s for i in 0 .. (sps.Length - 1) do if singleDocumentIndex <> -1 && sps[i].Document <> singleDocumentIndex then - builder.WriteCompressedInteger( 0 ) - builder.WriteCompressedInteger( MetadataTokens.GetRowNumber(DocumentHandle.op_Implicit(getDocumentHandle sps[i].Document)) ) + builder.WriteCompressedInteger(0) + + builder.WriteCompressedInteger( + MetadataTokens.GetRowNumber(DocumentHandle.op_Implicit (getDocumentHandle sps[i].Document)) + ) else //============================================================================================================================================= // Sequence-point-record @@ -622,7 +745,7 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s else v let capOffset v = capValue v 0xfffe - let capLine v = capValue v 0x1ffffffe + let capLine v = capValue v 0x1ffffffe let capColumn v = capValue v 0xfffe let offset = capOffset sps[i].Offset @@ -631,34 +754,36 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s let startColumn = capColumn sps[i].Column let endColumn = capColumn sps[i].EndColumn - let offsetDelta = // delta from previous offset - if i > 0 then offset - capOffset sps[i - 1].Offset - else offset + let offsetDelta = // delta from previous offset + if i > 0 then + offset - capOffset sps[i - 1].Offset + else + offset if i < 1 || offsetDelta > 0 then builder.WriteCompressedInteger offsetDelta // Check for hidden-sequence-point-record - if startLine = 0xfeefee || - endLine = 0xfeefee || - (startColumn = 0 && endColumn = 0) || - ((endLine - startLine) = 0 && (endColumn - startColumn) = 0) - then + if startLine = 0xfeefee + || endLine = 0xfeefee + || (startColumn = 0 && endColumn = 0) + || ((endLine - startLine) = 0 && (endColumn - startColumn) = 0) then // Hidden-sequence-point-record builder.WriteCompressedInteger 0 builder.WriteCompressedInteger 0 else // Non-hidden-sequence-point-record - let deltaLines = endLine - startLine // lines + let deltaLines = endLine - startLine // lines builder.WriteCompressedInteger deltaLines - let deltaColumns = endColumn - startColumn // Columns + let deltaColumns = endColumn - startColumn // Columns + if deltaLines = 0 then builder.WriteCompressedInteger deltaColumns else builder.WriteCompressedSignedInteger deltaColumns - if previousNonHiddenStartLine < 0 then // delta Start Line & Column: + if previousNonHiddenStartLine < 0 then // delta Start Line & Column: builder.WriteCompressedInteger startLine builder.WriteCompressedInteger startColumn else @@ -674,13 +799,13 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s match minfo.RootScope with | None -> () - | Some scope -> writeMethodScopes minfo.MethToken scope + | Some scope -> writeMethodScopes minfo.MethToken scope member _.Emit() = sortMethods showTimes info metadata.SetCapacity(TableIndex.MethodDebugInformation, info.Methods.Length) - defineModuleImportScope() + defineModuleImportScope () for minfo in info.Methods do emitMethod minfo @@ -704,34 +829,100 @@ type PortablePdbGenerator (embedAllSource: bool, embedSourceList: string list, s let contentBytes = content |> Seq.collect (fun c -> c.GetBytes()) |> Array.ofSeq contentHash <- contentBytes |> hashAlgorithm.ComputeHash BlobContentId.FromHash contentHash + Func, BlobContentId>(convert) let externalRowCounts = getRowCounts info.TableRowCounts - let serializer = PortablePdbBuilder(metadata, externalRowCounts, entryPoint, idProvider) + let serializer = + PortablePdbBuilder(metadata, externalRowCounts, entryPoint, idProvider) + let blobBuilder = BlobBuilder() - let contentId= serializer.Serialize blobBuilder + let contentId = serializer.Serialize blobBuilder let portablePdbStream = new MemoryStream() blobBuilder.WriteContentTo portablePdbStream reportTime showTimes "PDB: Created" (portablePdbStream.Length, contentId, portablePdbStream, algorithmName, contentHash) -let generatePortablePdb (embedAllSource: bool) (embedSourceList: string list) (sourceLink: string) checksumAlgorithm showTimes (info: PdbData) (pathMap: PathMap) = - let generator = PortablePdbGenerator (embedAllSource, embedSourceList, sourceLink, checksumAlgorithm, showTimes, info, pathMap) +let generatePortablePdb + (embedAllSource: bool) + (embedSourceList: string list) + (sourceLink: string) + checksumAlgorithm + showTimes + (info: PdbData) + (pathMap: PathMap) + = + let generator = + PortablePdbGenerator(embedAllSource, embedSourceList, sourceLink, checksumAlgorithm, showTimes, info, pathMap) + generator.Emit() let compressPortablePdbStream (stream: MemoryStream) = let compressedStream = new MemoryStream() - use compressionStream = new DeflateStream(compressedStream, CompressionMode.Compress,true) + + use compressionStream = + new DeflateStream(compressedStream, CompressionMode.Compress, true) + stream.WriteTo compressionStream compressedStream -let getInfoForPortablePdb (contentId: BlobContentId) pdbfile pathMap cvChunk deterministicPdbChunk checksumPdbChunk algorithmName checksum embeddedPdb deterministic = - pdbGetDebugInfo (contentId.Guid.ToByteArray()) (int32 contentId.Stamp) (PathMap.apply pathMap pdbfile) cvChunk None deterministicPdbChunk checksumPdbChunk algorithmName checksum 0L None embeddedPdb deterministic - -let getInfoForEmbeddedPortablePdb (uncompressedLength: int64) (contentId: BlobContentId) (compressedStream: MemoryStream) pdbfile cvChunk pdbChunk deterministicPdbChunk checksumPdbChunk algorithmName checksum deterministic = +let getInfoForPortablePdb + (contentId: BlobContentId) + pdbfile + pathMap + cvChunk + deterministicPdbChunk + checksumPdbChunk + algorithmName + checksum + embeddedPdb + deterministic + = + pdbGetDebugInfo + (contentId.Guid.ToByteArray()) + (int32 contentId.Stamp) + (PathMap.apply pathMap pdbfile) + cvChunk + None + deterministicPdbChunk + checksumPdbChunk + algorithmName + checksum + 0L + None + embeddedPdb + deterministic + +let getInfoForEmbeddedPortablePdb + (uncompressedLength: int64) + (contentId: BlobContentId) + (compressedStream: MemoryStream) + pdbfile + cvChunk + pdbChunk + deterministicPdbChunk + checksumPdbChunk + algorithmName + checksum + deterministic + = let fn = Path.GetFileName pdbfile - pdbGetDebugInfo (contentId.Guid.ToByteArray()) (int32 contentId.Stamp) fn cvChunk (Some pdbChunk) deterministicPdbChunk checksumPdbChunk algorithmName checksum uncompressedLength (Some compressedStream) true deterministic + + pdbGetDebugInfo + (contentId.Guid.ToByteArray()) + (int32 contentId.Stamp) + fn + cvChunk + (Some pdbChunk) + deterministicPdbChunk + checksumPdbChunk + algorithmName + checksum + uncompressedLength + (Some compressedStream) + true + deterministic #if !FX_NO_PDB_WRITER @@ -743,22 +934,29 @@ open Microsoft.Win32 //--------------------------------------------------------------------- let writePdbInfo showTimes outfile pdbfile info cvChunk = - try FileSystem.FileDeleteShim pdbfile with _ -> () + try + FileSystem.FileDeleteShim pdbfile + with + | _ -> () let pdbw = try pdbInitialize outfile pdbfile - with _ -> - error(Error(FSComp.SR.ilwriteErrorCreatingPdb pdbfile, rangeCmdArgs)) + with + | _ -> error (Error(FSComp.SR.ilwriteErrorCreatingPdb pdbfile, rangeCmdArgs)) match info.EntryPoint with | None -> () | Some x -> pdbSetUserEntryPoint pdbw x let docs = info.Documents |> Array.map (fun doc -> pdbDefineDocument pdbw doc.File) + let getDocument i = - if i < 0 || i > docs.Length then failwith "getDocument: bad doc number" - docs.[i] + if i < 0 || i > docs.Length then + failwith "getDocument: bad doc number" + + docs.[i] + reportTime showTimes (sprintf "PDB: Defined %d documents" info.Documents.Length) Array.sortInPlaceBy (fun x -> x.MethToken) info.Methods reportTime showTimes (sprintf "PDB: Sorted %d methods" info.Methods.Length) @@ -767,81 +965,101 @@ let writePdbInfo showTimes outfile pdbfile info cvChunk = let allSps = Array.collect (fun x -> x.DebugPoints) info.Methods |> Array.indexed let mutable spOffset = 0 - info.Methods |> Array.iteri (fun i minfo -> - - let sps = Array.sub allSps spOffset spCounts.[i] - spOffset <- spOffset + spCounts.[i] - begin match minfo.DebugRange with - | None -> () - | Some (a,b) -> - pdbOpenMethod pdbw minfo.MethToken - - pdbSetMethodRange pdbw - (getDocument a.Document) a.Line a.Column - (getDocument b.Document) b.Line b.Column - - // Partition the sequence points by document - let spsets = - let res = Dictionary() - for (_,sp) in sps do - let k = sp.Document - match res.TryGetValue(k) with - | true, xsR -> - xsR.Value <- sp :: xsR.Value - | _ -> - res.[k] <- ref [sp] - - res - - spsets - |> Seq.iter (fun (KeyValue(_, vref)) -> - let spset = vref.Value - if not spset.IsEmpty then - let spset = Array.ofList spset - Array.sortInPlaceWith SequencePoint.orderByOffset spset - let sps = - spset |> Array.map (fun sp -> - // Ildiag.dprintf "token 0x%08lx has an sp at offset 0x%08x\n" minfo.MethToken sp.Offset - (sp.Offset, sp.Line, sp.Column,sp.EndLine, sp.EndColumn)) - // Use of alloca in implementation of pdbDefineSequencePoints can give stack overflow here - if sps.Length < 5000 then - pdbDefineSequencePoints pdbw (getDocument spset.[0].Document) sps) - - // Avoid stack overflow when writing linearly nested scopes - let stackGuard = StackGuard(100) - // Write the scopes - let rec writePdbScope parent sco = - stackGuard.Guard <| fun () -> - if parent = None || sco.Locals.Length <> 0 || sco.Children.Length <> 0 then - // Only nest scopes if the child scope is a different size from - let nested = - match parent with - | Some p -> sco.StartOffset <> p.StartOffset || sco.EndOffset <> p.EndOffset - | None -> true - if nested then pdbOpenScope pdbw sco.StartOffset - sco.Locals |> Array.iter (fun v -> pdbDefineLocalVariable pdbw v.Name v.Signature v.Index) - sco.Children |> Array.iter (writePdbScope (if nested then Some sco else parent)) - if nested then pdbCloseScope pdbw sco.EndOffset - - match minfo.RootScope with - | None -> () - | Some rootscope -> writePdbScope None rootscope - pdbCloseMethod pdbw - end) + + info.Methods + |> Array.iteri (fun i minfo -> + + let sps = Array.sub allSps spOffset spCounts.[i] + spOffset <- spOffset + spCounts.[i] + + (match minfo.DebugRange with + | None -> () + | Some (a, b) -> + pdbOpenMethod pdbw minfo.MethToken + + pdbSetMethodRange pdbw (getDocument a.Document) a.Line a.Column (getDocument b.Document) b.Line b.Column + + // Partition the sequence points by document + let spsets = + let res = Dictionary() + + for (_, sp) in sps do + let k = sp.Document + + match res.TryGetValue(k) with + | true, xsR -> xsR.Value <- sp :: xsR.Value + | _ -> res.[k] <- ref [ sp ] + + res + + spsets + |> Seq.iter (fun (KeyValue (_, vref)) -> + let spset = vref.Value + + if not spset.IsEmpty then + let spset = Array.ofList spset + Array.sortInPlaceWith SequencePoint.orderByOffset spset + + let sps = + spset + |> Array.map (fun sp -> + // Ildiag.dprintf "token 0x%08lx has an sp at offset 0x%08x\n" minfo.MethToken sp.Offset + (sp.Offset, sp.Line, sp.Column, sp.EndLine, sp.EndColumn)) + // Use of alloca in implementation of pdbDefineSequencePoints can give stack overflow here + if sps.Length < 5000 then + pdbDefineSequencePoints pdbw (getDocument spset.[0].Document) sps) + + // Avoid stack overflow when writing linearly nested scopes + let stackGuard = StackGuard(100) + // Write the scopes + let rec writePdbScope parent sco = + stackGuard.Guard(fun () -> + if parent = None || sco.Locals.Length <> 0 || sco.Children.Length <> 0 then + // Only nest scopes if the child scope is a different size from + let nested = + match parent with + | Some p -> sco.StartOffset <> p.StartOffset || sco.EndOffset <> p.EndOffset + | None -> true + + if nested then + pdbOpenScope pdbw sco.StartOffset + + sco.Locals + |> Array.iter (fun v -> pdbDefineLocalVariable pdbw v.Name v.Signature v.Index) + + sco.Children |> Array.iter (writePdbScope (if nested then Some sco else parent)) + + if nested then + pdbCloseScope pdbw sco.EndOffset) + + match minfo.RootScope with + | None -> () + | Some rootscope -> writePdbScope None rootscope + + pdbCloseMethod pdbw)) + reportTime showTimes "PDB: Wrote methods" let res = pdbWriteDebugInfo pdbw - for pdbDoc in docs do pdbCloseDocument pdbDoc + + for pdbDoc in docs do + pdbCloseDocument pdbDoc + pdbClose pdbw outfile pdbfile reportTime showTimes "PDB: Closed" - [| { iddCharacteristics = res.iddCharacteristics - iddMajorVersion = res.iddMajorVersion - iddMinorVersion = res.iddMinorVersion - iddType = res.iddType - iddTimestamp = info.Timestamp - iddData = res.iddData - iddChunk = cvChunk } |] + + [| + { + iddCharacteristics = res.iddCharacteristics + iddMajorVersion = res.iddMajorVersion + iddMinorVersion = res.iddMinorVersion + iddType = res.iddType + iddTimestamp = info.Timestamp + iddData = res.iddData + iddChunk = cvChunk + } + |] #endif #if ENABLE_MONO_SUPPORT @@ -858,23 +1076,32 @@ open Microsoft.FSharp.Reflection // obj?Foo(1, "a") // call with two arguments (extracted from tuple) // NOTE: This doesn't actually handle all overloads. It just picks first entry with right // number of arguments. -let (?) this memb (args:'Args) : 'R = +let (?) this memb (args: 'Args) : 'R = // Get array of 'obj' arguments for the reflection call let args = - if typeof<'Args> = typeof then [| |] - elif FSharpType.IsTuple typeof<'Args> then FSharpValue.GetTupleFields args - else [| box args |] + if typeof<'Args> = typeof then + [||] + elif FSharpType.IsTuple typeof<'Args> then + FSharpValue.GetTupleFields args + else + [| box args |] // Get methods and perform overload resolution let methods = this.GetType().GetMethods() - let bestMatch = methods |> Array.tryFind (fun mi -> mi.Name = memb && mi.GetParameters().Length = args.Length) + + let bestMatch = + methods + |> Array.tryFind (fun mi -> mi.Name = memb && mi.GetParameters().Length = args.Length) + match bestMatch with - | Some mi -> unbox(mi.Invoke(this, args)) - | None -> error(Error(FSComp.SR.ilwriteMDBMemberMissing memb, rangeCmdArgs)) + | Some mi -> unbox (mi.Invoke(this, args)) + | None -> error (Error(FSComp.SR.ilwriteMDBMemberMissing memb, rangeCmdArgs)) // Creating instances of needed classes from 'Mono.CompilerServices.SymbolWriter' assembly -let monoCompilerSvc = AssemblyName("Mono.CompilerServices.SymbolWriter, Version=2.0.0.0, Culture=neutral, PublicKeyToken=0738eb9f132ed756") +let monoCompilerSvc = + AssemblyName("Mono.CompilerServices.SymbolWriter, Version=2.0.0.0, Culture=neutral, PublicKeyToken=0738eb9f132ed756") + let ctor (asmName: AssemblyName) clsName (args: obj[]) = let asm = Assembly.Load asmName let ty = asm.GetType clsName @@ -891,59 +1118,72 @@ let createWriter (f: string) = //--------------------------------------------------------------------- let writeMdbInfo fmdb f info = // Note, if we can't delete it code will fail later - try FileSystem.FileDeleteShim fmdb with _ -> () + try + FileSystem.FileDeleteShim fmdb + with + | _ -> () // Try loading the MDB symbol writer from an assembly available on Mono dynamically // Report an error if the assembly is not available. let wr = try createWriter f - with _ -> - error(Error(FSComp.SR.ilwriteErrorCreatingMdb(), rangeCmdArgs)) + with + | _ -> error (Error(FSComp.SR.ilwriteErrorCreatingMdb (), rangeCmdArgs)) // NOTE: MonoSymbolWriter doesn't need information about entrypoints, so 'info.EntryPoint' is unused here. // Write information about Documents. Returns '(SourceFileEntry*CompileUnitEntry)[]' let docs = - [| for doc in info.Documents do - let doc = wr?DefineDocument(doc.File) - let unit = wr?DefineCompilationUnit doc - yield doc, unit |] + [| + for doc in info.Documents do + let doc = wr?DefineDocument (doc.File) + let unit = wr?DefineCompilationUnit doc + yield doc, unit + |] let getDocument i = - if i < 0 || i >= Array.length docs then failwith "getDocument: bad doc number" else docs[i] + if i < 0 || i >= Array.length docs then + failwith "getDocument: bad doc number" + else + docs[i] // Sort methods and write them to the MDB file Array.sortInPlaceBy (fun x -> x.MethToken) info.Methods + for meth in info.Methods do // Creates an instance of 'SourceMethodImpl' which is a private class that implements 'IMethodDef' interface // We need this as an argument to 'OpenMethod' below. Using private class is ugly, but since we don't reference // the assembly, the only way to implement 'IMethodDef' interface would be dynamically using Reflection.Emit... let sm = createSourceMethodImpl meth.MethName meth.MethToken 0 + match meth.DebugRange with - | Some(mstart, _) -> + | Some (mstart, _) -> // NOTE: 'meth.Params' is not needed, Mono debugger apparently reads this from meta-data let _, cue = getDocument mstart.Document - wr?OpenMethod(cue, 0, sm) |> ignore + wr?OpenMethod (cue, 0, sm) |> ignore // Write sequence points for sp in meth.DebugPoints do - wr?MarkSequencePoint(sp.Offset, cue?get_SourceFile(), sp.Line, sp.Column, false) + wr?MarkSequencePoint (sp.Offset, cue?get_SourceFile (), sp.Line, sp.Column, false) // Walk through the tree of scopes and write all variables let rec writeScope (scope: PdbMethodScope) = - wr?OpenScope(scope.StartOffset) |> ignore + wr?OpenScope (scope.StartOffset) |> ignore + for local in scope.Locals do - wr?DefineLocalVariable(local.Index, local.Name) + wr?DefineLocalVariable (local.Index, local.Name) + for child in scope.Children do writeScope child - wr?CloseScope(scope.EndOffset) + + wr?CloseScope (scope.EndOffset) + match meth.RootScope with | None -> () | Some rootscope -> writeScope rootscope - // Finished generating debug information for the curretn method - wr?CloseMethod() + wr?CloseMethod () | _ -> () // Finalize - MDB requires the MVID of the generated .NET module @@ -961,98 +1201,125 @@ let logDebugInfo (outfile: string) (info: PdbData) = fprintfn sw "ENTRYPOINT\r\n %b\r\n" info.EntryPoint.IsSome fprintfn sw "DOCUMENTS" - for i, doc in Seq.zip [0 .. info.Documents.Length-1] info.Documents do - // File names elided because they are ephemeral during testing - fprintfn sw " [%d] " i // doc.File - fprintfn sw " Type: %A" doc.DocumentType - fprintfn sw " Language: %A" doc.Language - fprintfn sw " Vendor: %A" doc.Vendor + + for i, doc in Seq.zip [ 0 .. info.Documents.Length - 1 ] info.Documents do + // File names elided because they are ephemeral during testing + fprintfn sw " [%d] " i // doc.File + fprintfn sw " Type: %A" doc.DocumentType + fprintfn sw " Language: %A" doc.Language + fprintfn sw " Vendor: %A" doc.Vendor // Sort methods (because they are sorted in PDBs/MDBs too) fprintfn sw "\r\nMETHODS" Array.sortInPlaceBy (fun x -> x.MethToken) info.Methods + for meth in info.Methods do - fprintfn sw " %s" meth.MethName - fprintfn sw " Params: %A" [ for p in meth.Params -> sprintf "%d: %s" p.Index p.Name ] - fprintfn sw " Range: %A" (meth.DebugRange |> Option.map (fun (f, t) -> - sprintf "[%d,%d:%d] - [%d,%d:%d]" f.Document f.Line f.Column t.Document t.Line t.Column)) - fprintfn sw " Points:" + fprintfn sw " %s" meth.MethName + fprintfn sw " Params: %A" [ for p in meth.Params -> sprintf "%d: %s" p.Index p.Name ] + + fprintfn + sw + " Range: %A" + (meth.DebugRange + |> Option.map (fun (f, t) -> sprintf "[%d,%d:%d] - [%d,%d:%d]" f.Document f.Line f.Column t.Document t.Line t.Column)) + + fprintfn sw " Points:" - for sp in meth.DebugPoints do - fprintfn sw " - Doc: %d Offset:%d [%d:%d]-[%d-%d]" sp.Document sp.Offset sp.Line sp.Column sp.EndLine sp.EndColumn + for sp in meth.DebugPoints do + fprintfn sw " - Doc: %d Offset:%d [%d:%d]-[%d-%d]" sp.Document sp.Offset sp.Line sp.Column sp.EndLine sp.EndColumn - // Walk through the tree of scopes and write all variables - fprintfn sw " Scopes:" - let rec writeScope offs (scope: PdbMethodScope) = - fprintfn sw " %s- [%d-%d]" offs scope.StartOffset scope.EndOffset - if scope.Locals.Length > 0 then - fprintfn sw " %s Locals: %A" offs [ for p in scope.Locals -> sprintf "%d: %s" p.Index p.Name ] + // Walk through the tree of scopes and write all variables + fprintfn sw " Scopes:" - for child in scope.Children do writeScope (offs + " ") child + let rec writeScope offs (scope: PdbMethodScope) = + fprintfn sw " %s- [%d-%d]" offs scope.StartOffset scope.EndOffset - match meth.RootScope with - | None -> () - | Some rootscope -> writeScope "" rootscope - fprintfn sw "" + if scope.Locals.Length > 0 then + fprintfn sw " %s Locals: %A" offs [ for p in scope.Locals -> sprintf "%d: %s" p.Index p.Name ] + + for child in scope.Children do + writeScope (offs + " ") child + + match meth.RootScope with + | None -> () + | Some rootscope -> writeScope "" rootscope + + fprintfn sw "" let rec allNamesOfScope acc (scope: PdbMethodScope) = let acc = (acc, scope.Locals) ||> Array.fold (fun z l -> Set.add l.Name z) let acc = (acc, scope.Children) ||> allNamesOfScopes acc + and allNamesOfScopes acc (scopes: PdbMethodScope[]) = (acc, scopes) ||> Array.fold allNamesOfScope let rec pushShadowedLocals (stackGuard: StackGuard) (localsToPush: PdbLocalVar[]) (scope: PdbMethodScope) = - stackGuard.Guard <| fun () -> - // Check if child scopes are properly nested - if scope.Children |> Array.forall (fun child -> - child.StartOffset >= scope.StartOffset && child.EndOffset <= scope.EndOffset) then - - let children = scope.Children |> Array.sortWith scopeSorter - - // Find all the names defined in this scope - let scopeNames = set [| for n in scope.Locals -> n.Name |] - - // Rename if necessary as we push - let rename, unprocessed = localsToPush |> Array.partition (fun l -> scopeNames.Contains l.Name) - let renamed = [| for l in rename -> { l with Name = l.Name + " (shadowed)" } |] - - let localsToPush2 = [| yield! renamed; yield! unprocessed; yield! scope.Locals |] - let newChildren, splits = children |> Array.map (pushShadowedLocals stackGuard localsToPush2) |> Array.unzip - - // Check if a rename in any of the children forces a split - if splits |> Array.exists id then - let results = - [| - // First fill in the gaps between the children with an adjusted version of this scope. - let gaps = - [| yield (scope.StartOffset, scope.StartOffset) - for newChild in children do - yield (newChild.StartOffset, newChild.EndOffset) - yield (scope.EndOffset, scope.EndOffset) |] - - for ((_,a),(b,_)) in Array.pairwise gaps do - if a < b then - yield { scope with Locals=localsToPush2; Children = [| |]; StartOffset = a; EndOffset = b} - - yield! Array.concat newChildren - |] - let results2 = results |> Array.sortWith scopeSorter - results2, true - else - let splitsParent = renamed.Length > 0 - [| { scope with Locals=localsToPush2 } |], splitsParent - else - [| scope |], false + stackGuard.Guard(fun () -> + // Check if child scopes are properly nested + if scope.Children + |> Array.forall (fun child -> child.StartOffset >= scope.StartOffset && child.EndOffset <= scope.EndOffset) then + + let children = scope.Children |> Array.sortWith scopeSorter + + // Find all the names defined in this scope + let scopeNames = set [| for n in scope.Locals -> n.Name |] + + // Rename if necessary as we push + let rename, unprocessed = + localsToPush |> Array.partition (fun l -> scopeNames.Contains l.Name) + + let renamed = [| for l in rename -> { l with Name = l.Name + " (shadowed)" } |] + + let localsToPush2 = [| yield! renamed; yield! unprocessed; yield! scope.Locals |] + + let newChildren, splits = + children + |> Array.map (pushShadowedLocals stackGuard localsToPush2) + |> Array.unzip + + // Check if a rename in any of the children forces a split + if splits |> Array.exists id then + let results = + [| + // First fill in the gaps between the children with an adjusted version of this scope. + let gaps = + [| + yield (scope.StartOffset, scope.StartOffset) + for newChild in children do + yield (newChild.StartOffset, newChild.EndOffset) + yield (scope.EndOffset, scope.EndOffset) + |] + + for ((_, a), (b, _)) in Array.pairwise gaps do + if a < b then + yield + { scope with + Locals = localsToPush2 + Children = [||] + StartOffset = a + EndOffset = b + } + + yield! Array.concat newChildren + |] + + let results2 = results |> Array.sortWith scopeSorter + results2, true + else + let splitsParent = renamed.Length > 0 + [| { scope with Locals = localsToPush2 } |], splitsParent + else + [| scope |], false) // Check to see if a scope has a local with the same name as any of its children -// -// If so, do not emit 'scope' itself. Instead, +// +// If so, do not emit 'scope' itself. Instead, // 1. Emit a copy of 'scope' in each true gap, with all locals -// 2. Adjust each child scope to also contain the locals from 'scope', +// 2. Adjust each child scope to also contain the locals from 'scope', // adding the text " (shadowed)" to the names of those with name conflicts. let unshadowScopes rootScope = // Avoid stack overflow when writing linearly nested scopes let stackGuard = StackGuard(100) - let result, _ = pushShadowedLocals stackGuard [| |] rootScope + let result, _ = pushShadowedLocals stackGuard [||] rootScope result diff --git a/src/Compiler/AbstractIL/ilx.fs b/src/Compiler/AbstractIL/ilx.fs index 8fb986a07..5ef632ba2 100644 --- a/src/Compiler/AbstractIL/ilx.fs +++ b/src/Compiler/AbstractIL/ilx.fs @@ -3,13 +3,17 @@ /// Defines an extension of the IL algebra module internal FSharp.Compiler.AbstractIL.ILX.Types -open FSharp.Compiler.AbstractIL.IL -open Internal.Utilities.Library +open FSharp.Compiler.AbstractIL.IL +open Internal.Utilities.Library let mkLowerName (nm: string) = // Use the lower case name of a field or constructor as the field/parameter name if it differs from the uppercase name let lowerName = String.uncapitalize nm - if lowerName = nm then "_" + nm else lowerName + + if lowerName = nm then + "_" + nm + else + lowerName [] type IlxUnionCaseField(fd: ILFieldDef) = @@ -18,148 +22,169 @@ type IlxUnionCaseField(fd: ILFieldDef) = member x.Type = x.ILField.FieldType member x.Name = x.ILField.Name member x.LowerName = lowerName - -type IlxUnionCase = - { altName: string - altFields: IlxUnionCaseField[] - altCustomAttrs: ILAttributes } + +type IlxUnionCase = + { + altName: string + altFields: IlxUnionCaseField[] + altCustomAttrs: ILAttributes + } member x.FieldDefs = x.altFields member x.FieldDef n = x.altFields[n] member x.Name = x.altName - member x.IsNullary = (x.FieldDefs.Length = 0) - member x.FieldTypes = x.FieldDefs |> Array.map (fun fd -> fd.Type) - -type IlxUnionHasHelpers = - | NoHelpers - | AllHelpers - | SpecialFSharpListHelpers - | SpecialFSharpOptionHelpers - -type IlxUnionRef = - | IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionCase[] * bool * (* hasHelpers: *) IlxUnionHasHelpers - -type IlxUnionSpec = + member x.IsNullary = (x.FieldDefs.Length = 0) + member x.FieldTypes = x.FieldDefs |> Array.map (fun fd -> fd.Type) + +type IlxUnionHasHelpers = + | NoHelpers + | AllHelpers + | SpecialFSharpListHelpers + | SpecialFSharpOptionHelpers + +type IlxUnionRef = IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionCase[] * bool (* hasHelpers: *) * IlxUnionHasHelpers + +type IlxUnionSpec = | IlxUnionSpec of IlxUnionRef * ILGenericArgs - member x.DeclaringType = let (IlxUnionSpec(IlxUnionRef(bx, tref, _, _, _), inst)) = x in mkILNamedTy bx tref inst - member x.Boxity = let (IlxUnionSpec(IlxUnionRef(bx, _, _, _, _), _)) = x in bx - member x.TypeRef = let (IlxUnionSpec(IlxUnionRef(_, tref, _, _, _), _)) = x in tref - member x.GenericArgs = let (IlxUnionSpec(_, inst)) = x in inst - member x.AlternativesArray = let (IlxUnionSpec(IlxUnionRef(_, _, alts, _, _), _)) = x in alts - member x.IsNullPermitted = let (IlxUnionSpec(IlxUnionRef(_, _, _, np, _), _)) = x in np - member x.HasHelpers = let (IlxUnionSpec(IlxUnionRef(_, _, _, _, b), _)) = x in b + + member x.DeclaringType = + let (IlxUnionSpec (IlxUnionRef (bx, tref, _, _, _), inst)) = x in mkILNamedTy bx tref inst + + member x.Boxity = let (IlxUnionSpec (IlxUnionRef (bx, _, _, _, _), _)) = x in bx + member x.TypeRef = let (IlxUnionSpec (IlxUnionRef (_, tref, _, _, _), _)) = x in tref + member x.GenericArgs = let (IlxUnionSpec (_, inst)) = x in inst + + member x.AlternativesArray = + let (IlxUnionSpec (IlxUnionRef (_, _, alts, _, _), _)) = x in alts + + member x.IsNullPermitted = + let (IlxUnionSpec (IlxUnionRef (_, _, _, np, _), _)) = x in np + + member x.HasHelpers = let (IlxUnionSpec (IlxUnionRef (_, _, _, _, b), _)) = x in b member x.Alternatives = Array.toList x.AlternativesArray member x.Alternative idx = x.AlternativesArray[idx] member x.FieldDef idx fidx = x.Alternative(idx).FieldDef(fidx) -type IlxClosureLambdas = +type IlxClosureLambdas = | Lambdas_forall of ILGenericParameterDef * IlxClosureLambdas | Lambdas_lambda of ILParameter * IlxClosureLambdas | Lambdas_return of ILType -type IlxClosureApps = - | Apps_tyapp of ILType * IlxClosureApps - | Apps_app of ILType * IlxClosureApps - | Apps_done of ILType +type IlxClosureApps = + | Apps_tyapp of ILType * IlxClosureApps + | Apps_app of ILType * IlxClosureApps + | Apps_done of ILType let rec instAppsAux n inst apps = match apps with | Apps_tyapp (ty, rest) -> Apps_tyapp(instILTypeAux n inst ty, instAppsAux n inst rest) - | Apps_app (dty, rest) -> Apps_app(instILTypeAux n inst dty, instAppsAux n inst rest) - | Apps_done retTy -> Apps_done(instILTypeAux n inst retTy) + | Apps_app (dty, rest) -> Apps_app(instILTypeAux n inst dty, instAppsAux n inst rest) + | Apps_done retTy -> Apps_done(instILTypeAux n inst retTy) let rec instLambdasAux n inst lambdas = match lambdas with - | Lambdas_forall (gpdef, bodyTy) -> - Lambdas_forall(gpdef, instLambdasAux n inst bodyTy) - | Lambdas_lambda (pdef, bodyTy) -> - Lambdas_lambda({ pdef with Type=instILTypeAux n inst pdef.Type}, instLambdasAux n inst bodyTy) - | Lambdas_return retTy -> Lambdas_return(instILTypeAux n inst retTy) + | Lambdas_forall (gpdef, bodyTy) -> Lambdas_forall(gpdef, instLambdasAux n inst bodyTy) + | Lambdas_lambda (pdef, bodyTy) -> + Lambdas_lambda( + { pdef with + Type = instILTypeAux n inst pdef.Type + }, + instLambdasAux n inst bodyTy + ) + | Lambdas_return retTy -> Lambdas_return(instILTypeAux n inst retTy) let instLambdas i t = instLambdasAux 0 i t -type IlxClosureFreeVar = - { fvName: string - fvCompilerGenerated:bool - fvType: ILType } +type IlxClosureFreeVar = + { + fvName: string + fvCompilerGenerated: bool + fvType: ILType + } -let mkILFreeVar (name, compgen, ty) = - { fvName=name - fvCompilerGenerated=compgen - fvType=ty } +let mkILFreeVar (name, compgen, ty) = + { + fvName = name + fvCompilerGenerated = compgen + fvType = ty + } -type IlxClosureRef = - | IlxClosureRef of ILTypeRef * IlxClosureLambdas * IlxClosureFreeVar[] - -type IlxClosureSpec = +type IlxClosureRef = IlxClosureRef of ILTypeRef * IlxClosureLambdas * IlxClosureFreeVar[] + +type IlxClosureSpec = | IlxClosureSpec of IlxClosureRef * ILGenericArgs * ILType * useStaticField: bool - member x.TypeRef = let (IlxClosureRef(tref, _, _)) = x.ClosureRef in tref + member x.TypeRef = let (IlxClosureRef (tref, _, _)) = x.ClosureRef in tref - member x.ILType = let (IlxClosureSpec(_, _, ty, _)) = x in ty + member x.ILType = let (IlxClosureSpec (_, _, ty, _)) = x in ty - member x.ClosureRef = let (IlxClosureSpec(cloref, _, _, _)) = x in cloref + member x.ClosureRef = let (IlxClosureSpec (cloref, _, _, _)) = x in cloref - member x.FormalFreeVars = let (IlxClosureRef(_, _, fvs)) = x.ClosureRef in fvs + member x.FormalFreeVars = let (IlxClosureRef (_, _, fvs)) = x.ClosureRef in fvs - member x.FormalLambdas = let (IlxClosureRef(_, lambdas, _)) = x.ClosureRef in lambdas + member x.FormalLambdas = let (IlxClosureRef (_, lambdas, _)) = x.ClosureRef in lambdas - member x.GenericArgs = let (IlxClosureSpec(_, inst, _, _)) = x in inst + member x.GenericArgs = let (IlxClosureSpec (_, inst, _, _)) = x in inst - static member Create (cloref, inst, useStaticField) = - let (IlxClosureRef(tref, _, _)) = cloref + static member Create(cloref, inst, useStaticField) = + let (IlxClosureRef (tref, _, _)) = cloref IlxClosureSpec(cloref, inst, mkILBoxedType (mkILTySpec (tref, inst)), useStaticField) - member x.Constructor = + member x.Constructor = let cloTy = x.ILType let fields = x.FormalFreeVars mkILCtorMethSpecForTy (cloTy, fields |> Array.map (fun fv -> fv.fvType) |> Array.toList) - member x.UseStaticField = - let (IlxClosureSpec(_, _, _, useStaticField)) = x + member x.UseStaticField = + let (IlxClosureSpec (_, _, _, useStaticField)) = x useStaticField - member x.GetStaticFieldSpec() = + member x.GetStaticFieldSpec() = assert x.UseStaticField let formalCloTy = mkILFormalBoxedTy x.TypeRef (mkILFormalTypars x.GenericArgs) mkILFieldSpecInTy (x.ILType, "@_instance", formalCloTy) // Define an extension of the IL algebra of type definitions -type IlxClosureInfo = - { cloStructure: IlxClosureLambdas - cloFreeVars: IlxClosureFreeVar[] - cloCode: Lazy - cloUseStaticField: bool} +type IlxClosureInfo = + { + cloStructure: IlxClosureLambdas + cloFreeVars: IlxClosureFreeVar[] + cloCode: Lazy + cloUseStaticField: bool + } -type IlxUnionInfo = - { - UnionCasesAccessibility: ILMemberAccess +type IlxUnionInfo = + { + UnionCasesAccessibility: ILMemberAccess - HelpersAccessibility: ILMemberAccess + HelpersAccessibility: ILMemberAccess - HasHelpers: IlxUnionHasHelpers + HasHelpers: IlxUnionHasHelpers - GenerateDebugProxies: bool + GenerateDebugProxies: bool - DebugDisplayAttributes: ILAttribute list + DebugDisplayAttributes: ILAttribute list - UnionCases: IlxUnionCase[] + UnionCases: IlxUnionCase[] - IsNullPermitted: bool + IsNullPermitted: bool - DebugPoint: ILDebugPoint option + DebugPoint: ILDebugPoint option - DebugImports: ILDebugImports option - } + DebugImports: ILDebugImports option + } // -------------------------------------------------------------------- // Define these as extensions of the IL types -// -------------------------------------------------------------------- - -let destTyFuncApp = function Apps_tyapp (b, c) -> b, c | _ -> failwith "destTyFuncApp" +// -------------------------------------------------------------------- -let mkILFormalCloRef gparams csig useStaticField = IlxClosureSpec.Create(csig, mkILFormalGenericArgs 0 gparams, useStaticField) +let destTyFuncApp = + function + | Apps_tyapp (b, c) -> b, c + | _ -> failwith "destTyFuncApp" -let actualTypOfIlxUnionField (cuspec : IlxUnionSpec) idx fidx = - instILType cuspec.GenericArgs (cuspec.FieldDef idx fidx).Type +let mkILFormalCloRef gparams csig useStaticField = + IlxClosureSpec.Create(csig, mkILFormalGenericArgs 0 gparams, useStaticField) +let actualTypOfIlxUnionField (cuspec: IlxUnionSpec) idx fidx = + instILType cuspec.GenericArgs (cuspec.FieldDef idx fidx).Type diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index 773d1a01b..0d03bfead 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -1947,9 +1947,13 @@ let MakeAndPublishSimpleValsForMergedScope (cenv: cenv) env m (names: NameMap<_> notifyNameResolution (pos, item, itemGroup, itemTyparInst, occurence, nenv, ad, m, replacing) member _.NotifyExprHasType(_, _, _, _) = assert false // no expr typings in MakeAndPublishSimpleVals + member _.NotifyFormatSpecifierLocation(_, _) = () + member _.NotifyOpenDeclaration _ = () + member _.CurrentSourceText = None + member _.FormatStringCheckContext = None } use _h = WithNewTypecheckResultsSink(sink, cenv.tcSink) diff --git a/src/Compiler/Service/ServiceLexing.fsi b/src/Compiler/Service/ServiceLexing.fsi index 5e2e5a973..df1dfdde2 100755 --- a/src/Compiler/Service/ServiceLexing.fsi +++ b/src/Compiler/Service/ServiceLexing.fsi @@ -6,6 +6,7 @@ open System open System.Threading open FSharp.Compiler open FSharp.Compiler.Text + #nowarn "57" /// Represents encoded information for the end-of-line continuation of lexing -- GitLab