ilread.fs 192.3 KB
Newer Older
1
// Copyright (c) Microsoft Corporation.  All Rights Reserved.  Licensed under the Apache License, Version 2.0.  See License.txt in the project root for license information.
L
latkin 已提交
2 3 4 5 6 7 8 9 10 11 12 13 14 15 16

//---------------------------------------------------------------------
// The big binary reader
//
//---------------------------------------------------------------------

module internal Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader 

#nowarn "42" // This construct is deprecated: it is only for use in the F# library

open System
open System.IO
open System.Runtime.InteropServices
open System.Collections.Generic
open Internal.Utilities
17
open Internal.Utilities.Collections
L
latkin 已提交
18 19
open Microsoft.FSharp.Compiler.AbstractIL 
open Microsoft.FSharp.Compiler.AbstractIL.Internal 
D
Don Syme 已提交
20
#if !FX_NO_PDB_READER
L
latkin 已提交
21 22 23 24 25 26 27 28 29 30 31
open Microsoft.FSharp.Compiler.AbstractIL.Internal.Support 
#endif
open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics 
open Microsoft.FSharp.Compiler.AbstractIL.Internal.BinaryConstants 
open Microsoft.FSharp.Compiler.AbstractIL.IL  
open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library
open Microsoft.FSharp.Compiler.ErrorLogger
open Microsoft.FSharp.Compiler.Range
open Microsoft.FSharp.NativeInterop

type ILReaderOptions =
D
Don Syme 已提交
32 33
    { pdbPath: string option
      ilGlobals: ILGlobals
L
latkin 已提交
34 35 36 37 38 39 40 41 42 43 44 45
      optimizeForMemory: bool }

#if STATISTICS
let reportRef = ref (fun _oc -> ()) 
let addReport f = let old = !reportRef in reportRef := (fun oc -> old oc; f oc) 
let report (oc:TextWriter) = !reportRef oc ; reportRef := ref (fun _oc -> ()) 
#endif

let checking = false  
let logging = false
let _ = if checking then dprintn "warning : Ilread.checking is on"

D
Don Syme 已提交
46 47
let singleOfBits (x:int32) = System.BitConverter.ToSingle(System.BitConverter.GetBytes(x),0)
let doubleOfBits (x:int64) = System.BitConverter.Int64BitsToDouble(x)
L
latkin 已提交
48

D
Don Syme 已提交
49 50 51
//---------------------------------------------------------------------
// Utilities.  
//---------------------------------------------------------------------
L
latkin 已提交
52

D
Don Syme 已提交
53
let align alignment n = ((n + alignment - 0x1) / alignment) * alignment
L
latkin 已提交
54

D
Don Syme 已提交
55
let uncodedToken (tab:TableName) idx = ((tab.Index <<< 24) ||| idx)
L
latkin 已提交
56

D
Don Syme 已提交
57 58 59 60
let i32ToUncodedToken tok  = 
    let idx = tok &&& 0xffffff
    let tab = tok >>>& 24
    (TableName.FromIndex tab,  idx)
L
latkin 已提交
61

D
Don Syme 已提交
62 63 64 65 66 67

[<Struct>]
type TaggedIndex<'T> = 
    val tag: 'T
    val index : int32
    new(tag,index) = { tag=tag; index=index }
L
latkin 已提交
68

D
Don Syme 已提交
69 70 71 72 73 74 75
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" 
    TaggedIndex(tag,tok)
L
latkin 已提交
76

D
Don Syme 已提交
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
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" 
    TaggedIndex(tag,tok)

let (|TaggedIndex|) (x:TaggedIndex<'T>) = x.tag, x.index    
let 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"
    let tag = tok &&& tagmask
    let idx = tok >>>& nbits
    TaggedIndex(f tag, idx) 
       

[<AbstractClass>]
type BinaryFile() = 
    abstract ReadByte : addr:int -> byte
    abstract ReadBytes : addr:int -> int -> byte[]
    abstract ReadInt32 : addr:int -> int
    abstract ReadUInt16 : addr:int -> uint16
    abstract CountUtf8String : addr:int -> int
    abstract ReadUTF8String : addr: int -> string
L
latkin 已提交
106

W
WilliamBerryiii 已提交
107
/// Read from memory mapped files.
L
latkin 已提交
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156
module MemoryMapping = 

    type HANDLE = nativeint
    type ADDR   = nativeint
    type SIZE_T = nativeint

    [<DllImport("kernel32", SetLastError=true)>]
    extern bool CloseHandle (HANDLE _handler)

    [<DllImport("kernel32", SetLastError=true, CharSet=CharSet.Unicode)>]
    extern HANDLE CreateFile (string _lpFileName, 
                              int _dwDesiredAccess, 
                              int _dwShareMode,
                              HANDLE _lpSecurityAttributes, 
                              int _dwCreationDisposition,
                              int _dwFlagsAndAttributes, 
                              HANDLE _hTemplateFile)
             
    [<DllImport("kernel32", SetLastError=true, CharSet=CharSet.Unicode)>]
    extern HANDLE CreateFileMapping (HANDLE _hFile, 
                                     HANDLE _lpAttributes, 
                                     int _flProtect, 
                                     int _dwMaximumSizeLow, 
                                     int _dwMaximumSizeHigh,
                                     string _lpName) 

    [<DllImport("kernel32", SetLastError=true)>]
    extern ADDR MapViewOfFile (HANDLE _hFileMappingObject, 
                               int    _dwDesiredAccess, 
                               int    _dwFileOffsetHigh,
                               int    _dwFileOffsetLow, 
                               SIZE_T _dwNumBytesToMap)

    [<DllImport("kernel32", SetLastError=true)>]
    extern bool UnmapViewOfFile (ADDR _lpBaseAddress)

    let INVALID_HANDLE = new IntPtr(-1)
    let MAP_READ    = 0x0004
    let GENERIC_READ = 0x80000000
    let NULL_HANDLE = IntPtr.Zero
    let FILE_SHARE_NONE = 0x0000
    let FILE_SHARE_READ = 0x0001
    let FILE_SHARE_WRITE = 0x0002
    let FILE_SHARE_READ_WRITE = 0x0003
    let CREATE_ALWAYS  = 0x0002
    let OPEN_EXISTING   = 0x0003
    let OPEN_ALWAYS  = 0x0004

type MemoryMappedFile(hMap: MemoryMapping.HANDLE, start:nativeint) =
D
Don Syme 已提交
157
    inherit BinaryFile()
L
latkin 已提交
158 159

    static member Create fileName  =
D
Don Syme 已提交
160
        //printf "fileName = %s\n" fileName
L
latkin 已提交
161
        let hFile = MemoryMapping.CreateFile (fileName, MemoryMapping.GENERIC_READ, MemoryMapping.FILE_SHARE_READ_WRITE, IntPtr.Zero, MemoryMapping.OPEN_EXISTING, 0, IntPtr.Zero  )
D
Don Syme 已提交
162
        //printf "hFile = %Lx\n" (hFile.ToInt64())
L
latkin 已提交
163
        if ( hFile.Equals(MemoryMapping.INVALID_HANDLE) ) then
D
Don Syme 已提交
164
            failwithf "CreateFile(0x%08x)" ( Marshal.GetHRForLastWin32Error() )
L
latkin 已提交
165
        let protection = 0x00000002 (* ReadOnly *)
D
Don Syme 已提交
166
        //printf "OK! hFile = %Lx\n" (hFile.ToInt64())
L
latkin 已提交
167
        let hMap = MemoryMapping.CreateFileMapping (hFile, IntPtr.Zero, protection, 0,0, null )
D
Don Syme 已提交
168
        ignore(MemoryMapping.CloseHandle(hFile))
L
latkin 已提交
169
        if hMap.Equals(MemoryMapping.NULL_HANDLE) then
D
Don Syme 已提交
170
            failwithf "CreateFileMapping(0x%08x)" ( Marshal.GetHRForLastWin32Error() )
L
latkin 已提交
171 172 173 174

        let start = MemoryMapping.MapViewOfFile (hMap, MemoryMapping.MAP_READ,0,0,0n)

        if start.Equals(IntPtr.Zero) then
D
Don Syme 已提交
175
           failwithf "MapViewOfFile(0x%08x)" ( Marshal.GetHRForLastWin32Error() )
L
latkin 已提交
176 177 178 179 180
        MemoryMappedFile(hMap, start)

    member m.Addr (i:int) : nativeint = 
        start + nativeint i

D
Don Syme 已提交
181
    override m.ReadByte i = 
K
store  
Kevin Ransom (msft) 已提交
182
        Marshal.ReadByte(m.Addr i)
L
latkin 已提交
183

D
Don Syme 已提交
184
    override m.ReadBytes i len = 
L
latkin 已提交
185
        let res = Bytes.zeroCreate len
D
Don Syme 已提交
186
        Marshal.Copy(m.Addr i, res, 0,len)
L
latkin 已提交
187 188
        res
      
D
Don Syme 已提交
189
    override m.ReadInt32 i = 
190
        Marshal.ReadInt32(m.Addr i)
L
latkin 已提交
191

D
Don Syme 已提交
192
    override m.ReadUInt16 i = 
193
        uint16(Marshal.ReadInt16(m.Addr i))
L
latkin 已提交
194 195

    member m.Close() = 
D
Don Syme 已提交
196
        ignore(MemoryMapping.UnmapViewOfFile start)
L
latkin 已提交
197 198
        ignore(MemoryMapping.CloseHandle hMap)

D
Don Syme 已提交
199
    override m.CountUtf8String i = 
K
store  
Kevin Ransom (msft) 已提交
200
        let start = m.Addr i
L
latkin 已提交
201
        let mutable p = start 
K
store  
Kevin Ransom (msft) 已提交
202
        while Marshal.ReadByte(p) <> 0uy do
L
latkin 已提交
203 204 205
            p <- p + 1n
        int (p - start) 

D
Don Syme 已提交
206
    override m.ReadUTF8String i = 
L
latkin 已提交
207
        let n = m.CountUtf8String i
208
        System.Runtime.InteropServices.Marshal.PtrToStringAnsi((m.Addr i), n)
K
store  
Kevin Ransom (msft) 已提交
209 210 211 212 213
//#if FX_RESHAPED_REFLECTION
//        System.Text.Encoding.UTF8.GetString(NativePtr.ofNativeInt (m.Addr i), n)
//#else
//        new System.String(NativePtr.ofNativeInt (m.Addr i), 0, n, System.Text.Encoding.UTF8)
//#endif
L
latkin 已提交
214 215 216


//---------------------------------------------------------------------
D
Don Syme 已提交
217
// Read file from memory blocks 
L
latkin 已提交
218 219 220
//---------------------------------------------------------------------


D
Don Syme 已提交
221 222
type ByteFile(bytes:byte[]) = 
    inherit BinaryFile()
L
latkin 已提交
223

D
Don Syme 已提交
224 225 226 227 228 229 230
    override mc.ReadByte addr = bytes.[addr]
    override mc.ReadBytes addr len = Array.sub bytes addr len
    override m.CountUtf8String addr = 
        let mutable p = addr
        while bytes.[p] <> 0uy do
            p <- p + 1
        p - addr
L
latkin 已提交
231

D
Don Syme 已提交
232 233 234
    override m.ReadUTF8String addr = 
        let n = m.CountUtf8String addr 
        System.Text.Encoding.UTF8.GetString (bytes, addr, n)
L
latkin 已提交
235

D
Don Syme 已提交
236 237 238 239 240 241
    override is.ReadInt32 addr = 
        let b0 = is.ReadByte addr
        let b1 = is.ReadByte (addr+1)
        let b2 = is.ReadByte (addr+2)
        let b3 = is.ReadByte (addr+3)
        int b0 ||| (int b1 <<< 8) ||| (int b2 <<< 16) ||| (int b3 <<< 24)
L
latkin 已提交
242

D
Don Syme 已提交
243 244 245
    override is.ReadUInt16 addr = 
        let b0 = is.ReadByte addr
        let b1 = is.ReadByte (addr+1)
L
latkin 已提交
246 247
        uint16 b0 ||| (uint16 b1 <<< 8) 
    
D
Don Syme 已提交
248 249 250 251
let seekReadByte (is:BinaryFile) addr = is.ReadByte addr
let seekReadBytes (is:BinaryFile) addr len = is.ReadBytes addr len
let seekReadInt32 (is:BinaryFile) addr = is.ReadInt32 addr
let seekReadUInt16 (is:BinaryFile) addr = is.ReadUInt16 addr
L
latkin 已提交
252
    
D
Don Syme 已提交
253
let seekReadByteAsInt32 is addr = int32 (seekReadByte is addr)
L
latkin 已提交
254
  
D
Don Syme 已提交
255 256 257 258 259 260 261 262 263
let seekReadInt64 is addr = 
    let b0 = seekReadByte is addr
    let b1 = seekReadByte is (addr+1)
    let b2 = seekReadByte is (addr+2)
    let b3 = seekReadByte is (addr+3)
    let b4 = seekReadByte is (addr+4)
    let b5 = seekReadByte is (addr+5)
    let b6 = seekReadByte is (addr+6)
    let b7 = seekReadByte is (addr+7)
L
latkin 已提交
264 265 266
    int64 b0 ||| (int64 b1 <<< 8) ||| (int64 b2 <<< 16) ||| (int64 b3 <<< 24) |||
    (int64 b4 <<< 32) ||| (int64 b5 <<< 40) ||| (int64 b6 <<< 48) ||| (int64 b7 <<< 56)

D
Don Syme 已提交
267
let seekReadUInt16AsInt32 is addr = int32 (seekReadUInt16 is addr)
L
latkin 已提交
268
    
D
Don Syme 已提交
269 270 271
let seekReadCompressedUInt32 is addr = 
    let b0 = seekReadByte is addr
    if b0 <= 0x7Fuy then int b0, addr+1
L
latkin 已提交
272 273
    elif b0 <= 0xBFuy then 
        let b0 = b0 &&& 0x7Fuy
D
Don Syme 已提交
274 275
        let b1 = seekReadByteAsInt32 is (addr+1) 
        (int b0 <<< 8) ||| int b1, addr+2
L
latkin 已提交
276 277
    else 
        let b0 = b0 &&& 0x3Fuy
D
Don Syme 已提交
278 279 280 281 282 283 284 285
        let b1 = seekReadByteAsInt32 is (addr+1) 
        let b2 = seekReadByteAsInt32 is (addr+2) 
        let b3 = seekReadByteAsInt32 is (addr+3) 
        (int b0 <<< 24) ||| (int b1 <<< 16) ||| (int b2 <<< 8) ||| int b3, addr+4

let seekReadSByte         is addr = sbyte (seekReadByte is addr)
let seekReadSingle        is addr = singleOfBits (seekReadInt32 is addr)
let seekReadDouble        is addr = doubleOfBits (seekReadInt64 is addr)
L
latkin 已提交
286
    
D
Don Syme 已提交
287 288
let rec seekCountUtf8String is addr n = 
    let c = seekReadByteAsInt32 is addr
L
latkin 已提交
289
    if c = 0 then n 
D
Don Syme 已提交
290
    else seekCountUtf8String is (addr+1) (n+1)
L
latkin 已提交
291 292

let seekReadUTF8String is addr = 
D
Don Syme 已提交
293 294
    let n = seekCountUtf8String is addr 0
    let bytes = seekReadBytes is addr n
L
latkin 已提交
295 296 297
    System.Text.Encoding.UTF8.GetString (bytes, 0, bytes.Length)

let seekReadBlob is addr = 
D
Don Syme 已提交
298 299
    let len, addr = seekReadCompressedUInt32 is addr
    seekReadBytes is addr len
L
latkin 已提交
300 301
    
let seekReadUserString is addr = 
D
Don Syme 已提交
302 303 304
    let len, addr = seekReadCompressedUInt32 is addr
    let bytes = seekReadBytes is addr (len - 1)
    System.Text.Encoding.Unicode.GetString(bytes, 0, bytes.Length)
L
latkin 已提交
305

D
Don Syme 已提交
306
let seekReadGuid is addr =  seekReadBytes is addr 0x10
L
latkin 已提交
307 308

let seekReadUncodedToken is addr  = 
D
Don Syme 已提交
309
    i32ToUncodedToken (seekReadInt32 is addr)
L
latkin 已提交
310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325

       
//---------------------------------------------------------------------
// 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. "

// All this code should be moved to use a mutable index into the signature
//
//type SigPtr(bytes:byte[], sigptr:int) = 
//    let mutable curr = sigptr
//    member x.GetByte() = let res = bytes.[curr] in curr <- curr + 1; res
        
let sigptrGetByte (bytes:byte[]) sigptr = 
D
Don Syme 已提交
326
    sigptrCheck bytes sigptr
L
latkin 已提交
327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346
    bytes.[sigptr], sigptr + 1

let sigptrGetBool bytes sigptr = 
    let b0,sigptr = sigptrGetByte bytes sigptr
    (b0 = 0x01uy) ,sigptr

let sigptrGetSByte bytes sigptr = 
    let i,sigptr = sigptrGetByte bytes sigptr
    sbyte i,sigptr

let sigptrGetUInt16 bytes sigptr = 
    let b0,sigptr = sigptrGetByte bytes sigptr
    let b1,sigptr = sigptrGetByte bytes sigptr
    uint16 (int b0 ||| (int b1 <<< 8)),sigptr

let sigptrGetInt16 bytes sigptr = 
    let u,sigptr = sigptrGetUInt16 bytes sigptr
    int16 u,sigptr

let sigptrGetInt32 bytes sigptr = 
D
Don Syme 已提交
347
    sigptrCheck bytes sigptr
L
latkin 已提交
348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402
    let b0 = bytes.[sigptr]
    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

let sigptrGetUInt32 bytes sigptr = 
    let u,sigptr = sigptrGetInt32 bytes sigptr
    uint32 u,sigptr

let sigptrGetUInt64 bytes sigptr = 
    let u0,sigptr = sigptrGetUInt32 bytes sigptr
    let u1,sigptr = sigptrGetUInt32 bytes sigptr
    (uint64 u0 ||| (uint64 u1 <<< 32)),sigptr

let sigptrGetInt64 bytes sigptr = 
    let u,sigptr = sigptrGetUInt64 bytes sigptr
    int64 u,sigptr

let sigptrGetSingle bytes sigptr = 
    let u,sigptr = sigptrGetInt32 bytes sigptr
    singleOfBits u,sigptr

let sigptrGetDouble bytes sigptr = 
    let u,sigptr = sigptrGetInt64 bytes sigptr
    doubleOfBits u,sigptr

let sigptrGetZInt32 bytes sigptr = 
    let b0,sigptr = sigptrGetByte bytes sigptr
    if b0 <= 0x7Fuy then int b0, sigptr
    elif b0 <= 0xBFuy then 
        let b0 = b0 &&& 0x7Fuy
        let b1,sigptr = sigptrGetByte bytes sigptr
        (int b0 <<< 8) ||| int b1, sigptr
    else 
        let b0 = b0 &&& 0x3Fuy
        let b1,sigptr = sigptrGetByte bytes sigptr
        let b2,sigptr = sigptrGetByte bytes sigptr
        let b3,sigptr = sigptrGetByte bytes sigptr
        (int b0 <<< 24) ||| (int  b1 <<< 16) ||| (int b2 <<< 8) ||| int b3, 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)
    else 
        List.rev acc, sigptr

let sigptrFold f n (bytes:byte[]) (sigptr:int) = 
    sigptrFoldAcc f n bytes sigptr 0 []


let sigptrGetBytes n (bytes:byte[]) sigptr = 
    if checking && sigptr + n >= bytes.Length then 
D
Don Syme 已提交
403
        dprintn "read past end of sig. in sigptrGetString" 
L
latkin 已提交
404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421
        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
    (System.Text.Encoding.UTF8.GetString(bytearray, 0, bytearray.Length)),sigptr
   

// -------------------------------------------------------------------- 
// Now the tables of instructions
// -------------------------------------------------------------------- 

[<NoEquality; NoComparison>]
type ILInstrPrefixesRegister = 
D
Don Syme 已提交
422 423 424 425
   { mutable al: ILAlignment 
     mutable tl: ILTailcall
     mutable vol: ILVolatility
     mutable ro: ILReadonly
L
latkin 已提交
426 427 428
     mutable constrained: ILType option}
 
let noPrefixes mk prefixes = 
D
Don Syme 已提交
429 430 431 432 433
    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"
L
latkin 已提交
434 435 436
    mk 

let volatileOrUnalignedPrefix mk prefixes = 
D
Don Syme 已提交
437 438 439
    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"
L
latkin 已提交
440 441 442
    mk (prefixes.al,prefixes.vol) 

let volatilePrefix mk prefixes = 
D
Don Syme 已提交
443 444 445 446
    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"
L
latkin 已提交
447 448 449
    mk prefixes.vol

let tailPrefix mk prefixes = 
D
Don Syme 已提交
450 451 452 453
    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"
L
latkin 已提交
454 455 456
    mk prefixes.tl 

let constraintOrTailPrefix mk prefixes = 
D
Don Syme 已提交
457 458 459
    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"
L
latkin 已提交
460 461 462
    mk (prefixes.constrained,prefixes.tl )

let readonlyPrefix mk prefixes = 
D
Don Syme 已提交
463 464 465 466
    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"
L
latkin 已提交
467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483
    mk prefixes.ro


[<NoEquality; NoComparison>]
type ILInstrDecoder = 
    | I_u16_u8_instr of (ILInstrPrefixesRegister -> uint16 -> ILInstr)
    | I_u16_u16_instr of (ILInstrPrefixesRegister -> uint16 -> ILInstr)
    | I_none_instr of (ILInstrPrefixesRegister -> ILInstr)
    | I_i64_instr of (ILInstrPrefixesRegister -> int64 -> ILInstr)
    | I_i32_i32_instr of (ILInstrPrefixesRegister -> int32 -> ILInstr)
    | I_i32_i8_instr of (ILInstrPrefixesRegister -> int32 -> ILInstr)
    | I_r4_instr of (ILInstrPrefixesRegister -> single -> ILInstr)
    | I_r8_instr of (ILInstrPrefixesRegister -> double -> ILInstr)
    | I_field_instr of (ILInstrPrefixesRegister -> ILFieldSpec -> ILInstr)
    | I_method_instr of (ILInstrPrefixesRegister -> ILMethodSpec * ILVarArgs -> ILInstr)
    | I_unconditional_i32_instr of (ILInstrPrefixesRegister -> ILCodeLabel  -> ILInstr)
    | I_unconditional_i8_instr of (ILInstrPrefixesRegister -> ILCodeLabel  -> ILInstr)
D
Don Syme 已提交
484 485
    | I_conditional_i32_instr of (ILInstrPrefixesRegister -> ILCodeLabel -> ILInstr)
    | I_conditional_i8_instr of (ILInstrPrefixesRegister -> ILCodeLabel -> ILInstr)
L
latkin 已提交
486
    | I_string_instr of (ILInstrPrefixesRegister -> string -> ILInstr)
D
Don Syme 已提交
487
    | I_switch_instr of (ILInstrPrefixesRegister -> ILCodeLabel list -> ILInstr)
L
latkin 已提交
488 489 490 491 492 493 494 495 496
    | I_tok_instr of (ILInstrPrefixesRegister -> ILToken -> ILInstr)
    | I_sig_instr of (ILInstrPrefixesRegister -> ILCallingSignature * ILVarArgs -> ILInstr)
    | 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 instrs () = 
D
Don Syme 已提交
497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593
 [ 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) ] 
L
latkin 已提交
594 595 596 597 598 599 600 601 602 603

// 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 oneByteInstrs = ref None
let twoByteInstrs = ref 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 
D
Don Syme 已提交
604
            assert (i >>>& 8 = 0xfe) 
L
latkin 已提交
605 606 607
            let i =  (i &&& 0xff)
            match twoByteInstrTable.[i] with
            | I_invalid_instr -> ()
D
Don Syme 已提交
608
            | _ -> dprintn ("warning: duplicate decode entries for "+string i)
L
latkin 已提交
609 610 611 612
            twoByteInstrTable.[i] <- f
        else 
            match oneByteInstrTable.[i] with
            | I_invalid_instr -> ()
D
Don Syme 已提交
613
            | _ -> dprintn ("warning: duplicate decode entries for "+string i)
L
latkin 已提交
614
            oneByteInstrTable.[i] <- f 
D
Don Syme 已提交
615 616 617
    List.iter addInstr (instrs())
    List.iter (fun (x,mk) -> addInstr (x,I_none_instr (noPrefixes mk))) (noArgInstrs.Force())
    oneByteInstrs := Some oneByteInstrTable
L
latkin 已提交
618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758
    twoByteInstrs := Some twoByteInstrTable

let rec getOneByteInstr i = 
    match !oneByteInstrs with 
    | None -> fillInstrs(); getOneByteInstr i
    | Some t -> t.[i]

let rec getTwoByteInstr i = 
    match !twoByteInstrs with 
    | None -> fillInstrs(); getTwoByteInstr i
    | Some t -> t.[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)

type RowElementKind = 
    | UShort 
    | ULong 
    | Byte 
    | Data 
    | GGuid 
    | Blob 
    | SString 
    | SimpleIndex of TableName
    | TypeDefOrRefOrSpec
    | TypeOrMethodDef
    | HasConstant 
    | HasCustomAttribute
    | HasFieldMarshal 
    | HasDeclSecurity 
    | MemberRefParent 
    | HasSemantics 
    | MethodDefOrRef
    | MemberForwarded
    | Implementation 
    | CustomAttributeType
    | ResolutionScope

type RowKind = RowKind of RowElementKind list

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 kindCustomAttribute        = RowKind [ HasCustomAttribute; CustomAttributeType; Blob ]
let kindDeclSecurity           = RowKind [ UShort; HasDeclSecurity; Blob ]
let kindMemberRef              = RowKind [ MemberRefParent; SString; Blob ]
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 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 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 kindGenericParam_v2_0      = RowKind [ UShort; UShort; TypeOrMethodDef; SString ]
let kindMethodSpec             = RowKind [ MethodDefOrRef; Blob ]
let kindGenericParamConstraint = RowKind [ SimpleIndex TableNames.GenericParam; TypeDefOrRefOrSpec ]
let kindModule                 = RowKind [ UShort; SString; GGuid; GGuid; GGuid ]
let kindIllegal                = RowKind [ ]

//---------------------------------------------------------------------
// Used for binary searches of sorted tables.  Each function that reads
// a table row returns a tuple that contains the elements of the row.
// One of these elements may be a key for a sorted table.  These
// keys can be compared using the functions below depending on the
// 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 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 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 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 simpleIndexCompare (idx1:int) (idx2:int) = 
    compare idx1 idx2

//---------------------------------------------------------------------
// The various keys for the various caches.  
//---------------------------------------------------------------------

type TypeDefAsTypIdx = TypeDefAsTypIdx of ILBoxity * ILGenericArgs * int
type TypeRefAsTypIdx = TypeRefAsTypIdx of ILBoxity * ILGenericArgs * int
type BlobAsMethodSigIdx = BlobAsMethodSigIdx of int * int32
type BlobAsFieldSigIdx = BlobAsFieldSigIdx of int * int32
type BlobAsPropSigIdx = BlobAsPropSigIdx of int * int32
type BlobAsLocalSigIdx = BlobAsLocalSigIdx of int * int32
type MemberRefAsMspecIdx =  MemberRefAsMspecIdx of int * int
type MethodSpecAsMspecIdx =  MethodSpecAsMspecIdx of int * int
type MemberRefAsFspecIdx = MemberRefAsFspecIdx of int * int
type CustomAttrIdx = CustomAttrIdx of CustomAttributeTypeTag * int * int32
type SecurityDeclIdx   = SecurityDeclIdx of uint16 * int32
type GenericParamsIdx = GenericParamsIdx of int * TypeOrMethodDefTag * int

//---------------------------------------------------------------------
// Polymorphic caches for row and heap readers
//---------------------------------------------------------------------

let mkCacheInt32 lowMem _inbase _nm _sz  =
    if lowMem then (fun f x -> f x) else
    let cache = ref null 
    let count = ref 0
#if STATISTICS
D
Don Syme 已提交
759
    addReport (fun oc -> if !count <> 0 then oc.WriteLine ((_inbase + string !count + " "+ _nm + " cache hits")  : string))
L
latkin 已提交
760 761 762 763 764 765 766 767 768 769
#endif
    fun f (idx:int32) ->
        let cache = 
            match !cache with
            | null -> cache :=  new Dictionary<int32,_>(11)
            | _ -> ()
            !cache
        let mutable res = Unchecked.defaultof<_>
        let ok = cache.TryGetValue(idx, &res)
        if ok then 
D
Don Syme 已提交
770
            incr count 
L
latkin 已提交
771 772 773
            res
        else 
            let res = f idx 
D
Don Syme 已提交
774
            cache.[idx] <- res 
L
latkin 已提交
775 776 777 778 779 780 781
            res 

let mkCacheGeneric lowMem _inbase _nm _sz  =
    if lowMem then (fun f x -> f x) else
    let cache = ref null 
    let count = ref 0
#if STATISTICS
D
Don Syme 已提交
782
    addReport (fun oc -> if !count <> 0 then oc.WriteLine ((_inbase + string !count + " " + _nm + " cache hits") : string))
L
latkin 已提交
783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799
#endif
    fun f (idx :'T) ->
        let cache = 
            match !cache with
            | null -> cache := new Dictionary<_,_>(11 (* sz:int *) ) 
            | _ -> ()
            !cache
        if cache.ContainsKey idx then (incr count; cache.[idx])
        else let res = f idx in cache.[idx] <- res; res 

//-----------------------------------------------------------------------
// Polymorphic general helpers for searching for particular rows.
// ----------------------------------------------------------------------

let seekFindRow numRows rowChooser =
    let mutable i = 1
    while (i <= numRows &&  not (rowChooser i)) do 
D
Don Syme 已提交
800 801
        i <- i + 1
    if i > numRows then dprintn "warning: seekFindRow: row not found"
L
latkin 已提交
802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823
    i  

// search for rows satisfying predicate 
let seekReadIndexedRows (numRows, rowReader, keyFunc, keyComparer, binaryChop, rowConverter) =
    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
D
Don Syme 已提交
824
        end
L
latkin 已提交
825 826 827 828 829 830 831 832 833 834
        let mutable res = []
        if high - low > 1 then 
            // now read off rows, forward and backwards 
            let mid = (low + high) / 2
            // read forward 
            begin 
                let mutable fin = false
                let mutable curr = mid
                while not fin do 
                  if curr > numRows then 
D
Don Syme 已提交
835
                      fin <- true
L
latkin 已提交
836 837 838
                  else 
                      let currrow = rowReader curr
                      if keyComparer (keyFunc currrow) = 0 then 
D
Don Syme 已提交
839
                          res <- rowConverter currrow :: res
L
latkin 已提交
840
                      else 
D
Don Syme 已提交
841 842 843 844 845
                          fin <- true
                      curr <- curr + 1
                done
            end
            res <- List.rev res
L
latkin 已提交
846 847 848 849 850 851 852 853 854 855
            // read backwards 
            begin 
                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 
D
Don Syme 已提交
856
                        res <- rowConverter currrow :: res
L
latkin 已提交
857
                    else 
D
Don Syme 已提交
858 859 860
                        fin <- true
                    curr <- curr - 1
            end
L
latkin 已提交
861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878
        // 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 ]
            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)
#endif
        
        res
    else 
        let res = ref []
        for i = 1 to numRows do
            let rowinfo = rowReader i
            if keyComparer (keyFunc rowinfo) = 0 then 
D
Don Syme 已提交
879
              res := rowConverter rowinfo :: !res
L
latkin 已提交
880 881 882 883 884 885 886 887
        List.rev !res  


let seekReadOptionalIndexedRow (info) =
    match seekReadIndexedRows info with 
    | [k] -> Some k
    | [] -> None
    | h::_ -> 
D
Don Syme 已提交
888
        dprintn ("multiple rows found when indexing table") 
L
latkin 已提交
889 890 891 892 893 894 895 896 897 898 899 900
        Some h 
        
let seekReadIndexedRow (info) =
    match seekReadOptionalIndexedRow info with 
    | Some row -> row
    | None -> failwith ("no row found for key when indexing table")

//---------------------------------------------------------------------
// The big fat reader.
//---------------------------------------------------------------------

type ILModuleReader = 
D
Don Syme 已提交
901
    { modul: ILModuleDef 
L
latkin 已提交
902 903 904 905
      ilAssemblyRefs: Lazy<ILAssemblyRef list>
      dispose: unit -> unit }
    member x.ILModuleDef = x.modul
    member x.ILAssemblyRefs = x.ilAssemblyRefs.Force()
906 907
    interface IDisposable with
        member x.Dispose() = x.dispose()
L
latkin 已提交
908 909 910 911 912 913 914
    
 
type MethodData = MethodData of ILType * ILCallingConv * string * ILTypes * ILType * ILTypes
type VarArgMethodData = VarArgMethodData of ILType * ILCallingConv * string * ILTypes * ILVarArgs * ILType * ILTypes

[<NoEquality; NoComparison>]
type ILReaderContext = 
D
Don Syme 已提交
915 916 917
  { ilg: ILGlobals
    dataEndPoints: Lazy<int32 list>
    sorted: int64
918
#if FX_NO_PDB_READER
D
Don Syme 已提交
919
    pdb: obj option
L
latkin 已提交
920
#else
D
Don Syme 已提交
921
    pdb: (PdbReader * (string -> ILSourceDocument)) option
L
latkin 已提交
922
#endif
D
Don Syme 已提交
923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021
    entryPointToken: TableName * int
    getNumRows: TableName -> int 
    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
    is: BinaryFile
    infile:string
    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 array
    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   
    countTypeRef : int ref
    countTypeDef : int ref     
    countField : int ref      
    countMethod : int ref     
    countParam : int ref          
    countInterfaceImpl : int ref  
    countMemberRef : int ref        
    countConstant : int ref         
    countCustomAttribute : int ref  
    countFieldMarshal: int ref    
    countPermission : int ref      
    countClassLayout : int ref     
    countFieldLayout : int ref       
    countStandAloneSig : int ref    
    countEventMap : int ref         
    countEvent : int ref            
    countPropertyMap : int ref       
    countProperty : int ref           
    countMethodSemantics : int ref    
    countMethodImpl : int ref  
    countModuleRef : int ref       
    countTypeSpec : int ref         
    countImplMap : int ref      
    countFieldRVA : int ref   
    countAssembly : int ref        
    countAssemblyRef : int ref    
    countFile : int ref           
    countExportedType : int ref  
    countManifestResource : int ref
    countNested : int ref         
    countGenericParam : int ref       
    countGenericParamConstraint : int ref     
    countMethodSpec : int ref        
    seekReadNestedRow  : int -> int * int
    seekReadConstantRow  : int -> uint16 * TaggedIndex<HasConstantTag> * int32
    seekReadMethodSemanticsRow  : int -> int32 * int * TaggedIndex<HasSemanticsTag>
    seekReadTypeDefRow : int -> int32 * int32 * int32 * TaggedIndex<TypeDefOrRefTag> * int * int
    seekReadInterfaceImplRow  : int -> int * TaggedIndex<TypeDefOrRefTag>
    seekReadFieldMarshalRow  : int -> TaggedIndex<HasFieldMarshalTag> * int32
    seekReadPropertyMapRow  : int -> int * int 
    seekReadAssemblyRef : int -> ILAssemblyRef
    seekReadMethodSpecAsMethodData : MethodSpecAsMspecIdx -> VarArgMethodData
    seekReadMemberRefAsMethodData : MemberRefAsMspecIdx -> VarArgMethodData
    seekReadMemberRefAsFieldSpec : MemberRefAsFspecIdx -> ILFieldSpec
    seekReadCustomAttr : CustomAttrIdx -> ILAttribute
    seekReadSecurityDecl : SecurityDeclIdx -> ILPermission
    seekReadTypeRef : int ->ILTypeRef
    seekReadTypeRefAsType : TypeRefAsTypIdx -> ILType
    readBlobHeapAsPropertySig : BlobAsPropSigIdx -> ILThisConvention * ILType * ILTypes
    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 }
L
latkin 已提交
1022 1023 1024 1025 1026 1027 1028 1029 1030
   
let count c = 
#if DEBUG
    incr c
#else
    c |> ignore
    ()
#endif
        
D
Don Syme 已提交
1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075

let seekReadUInt16Adv ctxt (addr: byref<int>) =  
    let res = seekReadUInt16 ctxt.is addr
    addr <- addr + 2
    res

let seekReadInt32Adv ctxt (addr: byref<int>) = 
    let res = seekReadInt32 ctxt.is addr
    addr <- addr+4
    res

let seekReadUInt16AsInt32Adv ctxt (addr: byref<int>) = 
    let res = seekReadUInt16AsInt32 ctxt.is addr
    addr <- addr+2
    res

let seekReadTaggedIdx f nbits big is (addr: byref<int>) =  
    let tok = if big then seekReadInt32Adv is &addr else seekReadUInt16AsInt32Adv is &addr 
    tokToTaggedIdx f nbits tok


let seekReadIdx big ctxt (addr: byref<int>) =  
    if big then seekReadInt32Adv ctxt &addr else seekReadUInt16AsInt32Adv ctxt &addr

let seekReadUntaggedIdx (tab:TableName) ctxt (addr: byref<int>) =  
    seekReadIdx ctxt.tableBigness.[tab.Index] ctxt &addr


let seekReadResolutionScopeIdx     ctxt (addr: byref<int>) = seekReadTaggedIdx mkResolutionScopeTag     2 ctxt.rsBigness   ctxt &addr
let seekReadTypeDefOrRefOrSpecIdx  ctxt (addr: byref<int>) = seekReadTaggedIdx mkTypeDefOrRefOrSpecTag  2 ctxt.tdorBigness ctxt &addr   
let seekReadTypeOrMethodDefIdx     ctxt (addr: byref<int>) = seekReadTaggedIdx mkTypeOrMethodDefTag     1 ctxt.tomdBigness ctxt &addr
let seekReadHasConstantIdx         ctxt (addr: byref<int>) = seekReadTaggedIdx mkHasConstantTag         2 ctxt.hcBigness   ctxt &addr   
let seekReadHasCustomAttributeIdx  ctxt (addr: byref<int>) = seekReadTaggedIdx mkHasCustomAttributeTag  5 ctxt.hcaBigness  ctxt &addr
let seekReadHasFieldMarshalIdx     ctxt (addr: byref<int>) = seekReadTaggedIdx mkHasFieldMarshalTag     1 ctxt.hfmBigness ctxt &addr
let seekReadHasDeclSecurityIdx     ctxt (addr: byref<int>) = seekReadTaggedIdx mkHasDeclSecurityTag     2 ctxt.hdsBigness ctxt &addr
let seekReadMemberRefParentIdx     ctxt (addr: byref<int>) = seekReadTaggedIdx mkMemberRefParentTag     3 ctxt.mrpBigness ctxt &addr
let seekReadHasSemanticsIdx        ctxt (addr: byref<int>) = seekReadTaggedIdx mkHasSemanticsTag        1 ctxt.hsBigness ctxt &addr
let seekReadMethodDefOrRefIdx      ctxt (addr: byref<int>) = seekReadTaggedIdx mkMethodDefOrRefTag      1 ctxt.mdorBigness ctxt &addr
let seekReadMemberForwardedIdx     ctxt (addr: byref<int>) = seekReadTaggedIdx mkMemberForwardedTag     1 ctxt.mfBigness ctxt &addr
let seekReadImplementationIdx      ctxt (addr: byref<int>) = seekReadTaggedIdx mkImplementationTag      2 ctxt.iBigness ctxt &addr
let seekReadCustomAttributeTypeIdx ctxt (addr: byref<int>) = seekReadTaggedIdx mkILCustomAttributeTypeTag 3 ctxt.catBigness ctxt &addr  
let seekReadStringIdx ctxt (addr: byref<int>) = seekReadIdx ctxt.stringsBigness ctxt &addr
let seekReadGuidIdx ctxt (addr: byref<int>) = seekReadIdx ctxt.guidsBigness ctxt &addr
let seekReadBlobIdx ctxt (addr: byref<int>) = seekReadIdx ctxt.blobsBigness ctxt &addr 

L
latkin 已提交
1076
let seekReadModuleRow ctxt idx =
D
Don Syme 已提交
1077
    if idx = 0 then failwith "cannot read Module table row 0"
D
Don Syme 已提交
1078 1079 1080 1081 1082 1083
    let mutable addr = ctxt.rowAddr TableNames.Module idx
    let generation = seekReadUInt16Adv ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let mvidIdx = seekReadGuidIdx ctxt &addr
    let encidIdx = seekReadGuidIdx ctxt &addr
    let encbaseidIdx = seekReadGuidIdx ctxt &addr
L
latkin 已提交
1084 1085
    (generation, nameIdx, mvidIdx, encidIdx, encbaseidIdx) 

W
WilliamBerryiii 已提交
1086
/// Read Table ILTypeRef.
L
latkin 已提交
1087
let seekReadTypeRefRow ctxt idx =
D
Don Syme 已提交
1088
    count ctxt.countTypeRef
D
Don Syme 已提交
1089 1090 1091 1092
    let mutable addr = ctxt.rowAddr TableNames.TypeRef idx
    let scopeIdx = seekReadResolutionScopeIdx ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let namespaceIdx = seekReadStringIdx ctxt &addr
L
latkin 已提交
1093 1094
    (scopeIdx,nameIdx,namespaceIdx) 

W
WilliamBerryiii 已提交
1095
/// Read Table ILTypeDef.
L
latkin 已提交
1096 1097 1098
let seekReadTypeDefRow ctxt idx = ctxt.seekReadTypeDefRow idx
let seekReadTypeDefRowUncached ctxtH idx =
    let ctxt = getHole ctxtH
D
Don Syme 已提交
1099
    count ctxt.countTypeDef
D
Don Syme 已提交
1100 1101 1102 1103 1104 1105 1106
    let mutable addr = ctxt.rowAddr TableNames.TypeDef idx
    let flags = seekReadInt32Adv ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let namespaceIdx = seekReadStringIdx ctxt &addr
    let extendsIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr
    let fieldsIdx = seekReadUntaggedIdx TableNames.Field ctxt &addr
    let methodsIdx = seekReadUntaggedIdx TableNames.Method ctxt &addr
L
latkin 已提交
1107 1108
    (flags, nameIdx, namespaceIdx, extendsIdx, fieldsIdx, methodsIdx) 

W
WilliamBerryiii 已提交
1109
/// Read Table Field.
L
latkin 已提交
1110
let seekReadFieldRow ctxt idx =
D
Don Syme 已提交
1111
    count ctxt.countField
D
Don Syme 已提交
1112 1113 1114 1115
    let mutable addr = ctxt.rowAddr TableNames.Field idx
    let flags = seekReadUInt16AsInt32Adv ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let typeIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1116 1117
    (flags,nameIdx,typeIdx)  

W
WilliamBerryiii 已提交
1118
/// Read Table Method.
L
latkin 已提交
1119
let seekReadMethodRow ctxt idx =
D
Don Syme 已提交
1120
    count ctxt.countMethod
D
Don Syme 已提交
1121 1122 1123 1124 1125 1126 1127
    let mutable addr = ctxt.rowAddr TableNames.Method idx
    let codeRVA = seekReadInt32Adv ctxt &addr
    let implflags = seekReadUInt16AsInt32Adv ctxt &addr
    let flags = seekReadUInt16AsInt32Adv ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let typeIdx = seekReadBlobIdx ctxt &addr
    let paramIdx = seekReadUntaggedIdx TableNames.Param ctxt &addr
L
latkin 已提交
1128 1129
    (codeRVA, implflags, flags, nameIdx, typeIdx, paramIdx) 

W
WilliamBerryiii 已提交
1130
/// Read Table Param.
L
latkin 已提交
1131
let seekReadParamRow ctxt idx =
D
Don Syme 已提交
1132
    count ctxt.countParam
D
Don Syme 已提交
1133 1134 1135 1136
    let mutable addr = ctxt.rowAddr TableNames.Param idx
    let flags = seekReadUInt16AsInt32Adv ctxt &addr
    let seq =  seekReadUInt16AsInt32Adv ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
L
latkin 已提交
1137 1138
    (flags,seq,nameIdx) 

W
WilliamBerryiii 已提交
1139
/// Read Table InterfaceImpl.
L
latkin 已提交
1140 1141 1142
let seekReadInterfaceImplRow ctxt idx = ctxt.seekReadInterfaceImplRow idx
let seekReadInterfaceImplRowUncached ctxtH idx =
    let ctxt = getHole ctxtH
D
Don Syme 已提交
1143
    count ctxt.countInterfaceImpl
D
Don Syme 已提交
1144 1145 1146
    let mutable addr = ctxt.rowAddr TableNames.InterfaceImpl idx
    let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr
    let intfIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr
L
latkin 已提交
1147 1148
    (tidx,intfIdx)

W
WilliamBerryiii 已提交
1149
/// Read Table MemberRef.
L
latkin 已提交
1150
let seekReadMemberRefRow ctxt idx =
D
Don Syme 已提交
1151
    count ctxt.countMemberRef
D
Don Syme 已提交
1152 1153 1154 1155
    let mutable addr = ctxt.rowAddr TableNames.MemberRef idx
    let mrpIdx = seekReadMemberRefParentIdx ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let typeIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1156 1157
    (mrpIdx,nameIdx,typeIdx) 

W
WilliamBerryiii 已提交
1158
/// Read Table Constant.
L
latkin 已提交
1159 1160 1161
let seekReadConstantRow ctxt idx = ctxt.seekReadConstantRow idx
let seekReadConstantRowUncached ctxtH idx =
    let ctxt = getHole ctxtH
D
Don Syme 已提交
1162
    count ctxt.countConstant
D
Don Syme 已提交
1163 1164 1165 1166
    let mutable addr = ctxt.rowAddr TableNames.Constant idx
    let kind = seekReadUInt16Adv ctxt &addr
    let parentIdx = seekReadHasConstantIdx ctxt &addr
    let valIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1167 1168
    (kind, parentIdx, valIdx)

W
WilliamBerryiii 已提交
1169
/// Read Table CustomAttribute.
L
latkin 已提交
1170
let seekReadCustomAttributeRow ctxt idx =
D
Don Syme 已提交
1171
    count ctxt.countCustomAttribute
D
Don Syme 已提交
1172 1173 1174 1175
    let mutable addr = ctxt.rowAddr TableNames.CustomAttribute idx
    let parentIdx = seekReadHasCustomAttributeIdx ctxt &addr
    let typeIdx = seekReadCustomAttributeTypeIdx ctxt &addr
    let valIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1176 1177
    (parentIdx, typeIdx, valIdx)  

W
WilliamBerryiii 已提交
1178
/// Read Table FieldMarshal.
L
latkin 已提交
1179 1180 1181
let seekReadFieldMarshalRow ctxt idx = ctxt.seekReadFieldMarshalRow idx
let seekReadFieldMarshalRowUncached ctxtH idx =
    let ctxt = getHole ctxtH
D
Don Syme 已提交
1182
    count ctxt.countFieldMarshal
D
Don Syme 已提交
1183 1184 1185
    let mutable addr = ctxt.rowAddr TableNames.FieldMarshal idx
    let parentIdx = seekReadHasFieldMarshalIdx ctxt &addr
    let typeIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1186 1187
    (parentIdx, typeIdx)

W
WilliamBerryiii 已提交
1188
/// Read Table Permission.
L
latkin 已提交
1189
let seekReadPermissionRow ctxt idx =
D
Don Syme 已提交
1190
    count ctxt.countPermission
D
Don Syme 已提交
1191 1192 1193 1194 1195
    let mutable addr = ctxt.rowAddr TableNames.Permission idx
    let action = seekReadUInt16Adv ctxt &addr
    let parentIdx = seekReadHasDeclSecurityIdx ctxt &addr
    let typeIdx = seekReadBlobIdx ctxt &addr
    (action, parentIdx, typeIdx) 
L
latkin 已提交
1196

W
WilliamBerryiii 已提交
1197
/// Read Table ClassLayout. 
L
latkin 已提交
1198
let seekReadClassLayoutRow ctxt idx =
D
Don Syme 已提交
1199
    count ctxt.countClassLayout
D
Don Syme 已提交
1200 1201 1202 1203
    let mutable addr = ctxt.rowAddr TableNames.ClassLayout idx
    let pack = seekReadUInt16Adv ctxt &addr
    let size = seekReadInt32Adv ctxt &addr
    let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr
L
latkin 已提交
1204 1205
    (pack,size,tidx)  

W
WilliamBerryiii 已提交
1206
/// Read Table FieldLayout. 
L
latkin 已提交
1207
let seekReadFieldLayoutRow ctxt idx =
D
Don Syme 已提交
1208
    count ctxt.countFieldLayout
D
Don Syme 已提交
1209 1210 1211
    let mutable addr = ctxt.rowAddr TableNames.FieldLayout idx
    let offset = seekReadInt32Adv ctxt &addr
    let fidx = seekReadUntaggedIdx TableNames.Field ctxt &addr
L
latkin 已提交
1212 1213
    (offset,fidx)  

W
WilliamBerryiii 已提交
1214
//// Read Table StandAloneSig. 
L
latkin 已提交
1215
let seekReadStandAloneSigRow ctxt idx =
D
Don Syme 已提交
1216
    count ctxt.countStandAloneSig
D
Don Syme 已提交
1217 1218
    let mutable addr = ctxt.rowAddr TableNames.StandAloneSig idx
    let sigIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1219 1220
    sigIdx

W
WilliamBerryiii 已提交
1221
/// Read Table EventMap. 
L
latkin 已提交
1222
let seekReadEventMapRow ctxt idx =
D
Don Syme 已提交
1223
    count ctxt.countEventMap
D
Don Syme 已提交
1224 1225 1226
    let mutable addr = ctxt.rowAddr TableNames.EventMap idx
    let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr
    let eventsIdx = seekReadUntaggedIdx TableNames.Event ctxt &addr
L
latkin 已提交
1227 1228
    (tidx,eventsIdx) 

W
WilliamBerryiii 已提交
1229
/// Read Table Event. 
L
latkin 已提交
1230
let seekReadEventRow ctxt idx =
D
Don Syme 已提交
1231
    count ctxt.countEvent
D
Don Syme 已提交
1232 1233 1234 1235
    let mutable addr = ctxt.rowAddr TableNames.Event idx
    let flags = seekReadUInt16AsInt32Adv ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let typIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr
L
latkin 已提交
1236 1237
    (flags,nameIdx,typIdx) 
   
W
WilliamBerryiii 已提交
1238
/// Read Table PropertyMap. 
L
latkin 已提交
1239 1240 1241
let seekReadPropertyMapRow ctxt idx = ctxt.seekReadPropertyMapRow idx
let seekReadPropertyMapRowUncached ctxtH idx =
    let ctxt = getHole ctxtH
D
Don Syme 已提交
1242
    count ctxt.countPropertyMap
D
Don Syme 已提交
1243 1244 1245
    let mutable addr = ctxt.rowAddr TableNames.PropertyMap idx
    let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr
    let propsIdx = seekReadUntaggedIdx TableNames.Property ctxt &addr
L
latkin 已提交
1246 1247
    (tidx,propsIdx)

W
WilliamBerryiii 已提交
1248
/// Read Table Property. 
L
latkin 已提交
1249
let seekReadPropertyRow ctxt idx =
D
Don Syme 已提交
1250
    count ctxt.countProperty
D
Don Syme 已提交
1251 1252 1253 1254
    let mutable addr = ctxt.rowAddr TableNames.Property idx
    let flags = seekReadUInt16AsInt32Adv ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let typIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1255 1256
    (flags,nameIdx,typIdx) 

W
WilliamBerryiii 已提交
1257
/// Read Table MethodSemantics.
L
latkin 已提交
1258 1259 1260
let seekReadMethodSemanticsRow ctxt idx = ctxt.seekReadMethodSemanticsRow idx
let seekReadMethodSemanticsRowUncached ctxtH idx =
    let ctxt = getHole ctxtH
D
Don Syme 已提交
1261
    count ctxt.countMethodSemantics
D
Don Syme 已提交
1262 1263 1264 1265
    let mutable addr = ctxt.rowAddr TableNames.MethodSemantics idx
    let flags = seekReadUInt16AsInt32Adv ctxt &addr
    let midx = seekReadUntaggedIdx TableNames.Method ctxt &addr
    let assocIdx = seekReadHasSemanticsIdx ctxt &addr
L
latkin 已提交
1266 1267
    (flags,midx,assocIdx)

W
WilliamBerryiii 已提交
1268
/// Read Table MethodImpl.
L
latkin 已提交
1269
let seekReadMethodImplRow ctxt idx =
D
Don Syme 已提交
1270
    count ctxt.countMethodImpl
D
Don Syme 已提交
1271 1272 1273 1274
    let mutable addr = ctxt.rowAddr TableNames.MethodImpl idx
    let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr
    let mbodyIdx = seekReadMethodDefOrRefIdx ctxt &addr
    let mdeclIdx = seekReadMethodDefOrRefIdx ctxt &addr
L
latkin 已提交
1275 1276
    (tidx,mbodyIdx,mdeclIdx) 

W
WilliamBerryiii 已提交
1277
/// Read Table ILModuleRef.
L
latkin 已提交
1278
let seekReadModuleRefRow ctxt idx =
D
Don Syme 已提交
1279
    count ctxt.countModuleRef
D
Don Syme 已提交
1280 1281
    let mutable addr = ctxt.rowAddr TableNames.ModuleRef idx
    let nameIdx = seekReadStringIdx ctxt &addr
L
latkin 已提交
1282 1283
    nameIdx  

W
WilliamBerryiii 已提交
1284
/// Read Table ILTypeSpec.
L
latkin 已提交
1285
let seekReadTypeSpecRow ctxt idx =
D
Don Syme 已提交
1286
    count ctxt.countTypeSpec
D
Don Syme 已提交
1287 1288
    let mutable addr = ctxt.rowAddr TableNames.TypeSpec idx
    let blobIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1289 1290
    blobIdx  

W
WilliamBerryiii 已提交
1291
/// Read Table ImplMap.
L
latkin 已提交
1292
let seekReadImplMapRow ctxt idx =
D
Don Syme 已提交
1293
    count ctxt.countImplMap
D
Don Syme 已提交
1294 1295 1296 1297 1298
    let mutable addr = ctxt.rowAddr TableNames.ImplMap idx
    let flags = seekReadUInt16AsInt32Adv ctxt &addr
    let forwrdedIdx = seekReadMemberForwardedIdx ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let scopeIdx = seekReadUntaggedIdx TableNames.ModuleRef ctxt &addr
L
latkin 已提交
1299 1300
    (flags, forwrdedIdx, nameIdx, scopeIdx) 

W
WilliamBerryiii 已提交
1301
/// Read Table FieldRVA.
L
latkin 已提交
1302
let seekReadFieldRVARow ctxt idx =
D
Don Syme 已提交
1303
    count ctxt.countFieldRVA
D
Don Syme 已提交
1304 1305 1306
    let mutable addr = ctxt.rowAddr TableNames.FieldRVA idx
    let rva = seekReadInt32Adv ctxt &addr
    let fidx = seekReadUntaggedIdx TableNames.Field ctxt &addr
L
latkin 已提交
1307 1308
    (rva,fidx) 

W
WilliamBerryiii 已提交
1309
/// Read Table Assembly.
L
latkin 已提交
1310
let seekReadAssemblyRow ctxt idx =
D
Don Syme 已提交
1311
    count ctxt.countAssembly
D
Don Syme 已提交
1312 1313 1314 1315 1316 1317 1318 1319 1320 1321
    let mutable addr = ctxt.rowAddr TableNames.Assembly idx
    let hash = seekReadInt32Adv ctxt &addr
    let v1 = seekReadUInt16Adv ctxt &addr
    let v2 = seekReadUInt16Adv ctxt &addr
    let v3 = seekReadUInt16Adv ctxt &addr
    let v4 = seekReadUInt16Adv ctxt &addr
    let flags = seekReadInt32Adv ctxt &addr
    let publicKeyIdx = seekReadBlobIdx ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let localeIdx = seekReadStringIdx ctxt &addr
L
latkin 已提交
1322 1323
    (hash,v1,v2,v3,v4,flags,publicKeyIdx, nameIdx, localeIdx)

W
WilliamBerryiii 已提交
1324
/// Read Table ILAssemblyRef.
L
latkin 已提交
1325
let seekReadAssemblyRefRow ctxt idx =
D
Don Syme 已提交
1326
    count ctxt.countAssemblyRef
D
Don Syme 已提交
1327 1328 1329 1330 1331 1332 1333 1334 1335 1336
    let mutable addr = ctxt.rowAddr TableNames.AssemblyRef idx
    let v1 = seekReadUInt16Adv ctxt &addr
    let v2 = seekReadUInt16Adv ctxt &addr
    let v3 = seekReadUInt16Adv ctxt &addr
    let v4 = seekReadUInt16Adv ctxt &addr
    let flags = seekReadInt32Adv ctxt &addr
    let publicKeyOrTokenIdx = seekReadBlobIdx ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let localeIdx = seekReadStringIdx ctxt &addr
    let hashValueIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1337 1338
    (v1,v2,v3,v4,flags,publicKeyOrTokenIdx, nameIdx, localeIdx,hashValueIdx) 

W
WilliamBerryiii 已提交
1339
/// Read Table File.
L
latkin 已提交
1340
let seekReadFileRow ctxt idx =
D
Don Syme 已提交
1341
    count ctxt.countFile
D
Don Syme 已提交
1342 1343 1344 1345
    let mutable addr = ctxt.rowAddr TableNames.File idx
    let flags = seekReadInt32Adv ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let hashValueIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1346 1347
    (flags, nameIdx, hashValueIdx) 

W
WilliamBerryiii 已提交
1348
/// Read Table ILExportedTypeOrForwarder.
L
latkin 已提交
1349
let seekReadExportedTypeRow ctxt idx =
D
Don Syme 已提交
1350
    count ctxt.countExportedType
D
Don Syme 已提交
1351 1352 1353 1354 1355 1356
    let mutable addr = ctxt.rowAddr TableNames.ExportedType idx
    let flags = seekReadInt32Adv ctxt &addr
    let tok = seekReadInt32Adv ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let namespaceIdx = seekReadStringIdx ctxt &addr
    let implIdx = seekReadImplementationIdx ctxt &addr
L
latkin 已提交
1357 1358
    (flags,tok,nameIdx,namespaceIdx,implIdx) 

W
WilliamBerryiii 已提交
1359
/// Read Table ManifestResource.
L
latkin 已提交
1360
let seekReadManifestResourceRow ctxt idx =
D
Don Syme 已提交
1361
    count ctxt.countManifestResource
D
Don Syme 已提交
1362 1363 1364 1365 1366
    let mutable addr = ctxt.rowAddr TableNames.ManifestResource idx
    let offset = seekReadInt32Adv ctxt &addr
    let flags = seekReadInt32Adv ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
    let implIdx = seekReadImplementationIdx ctxt &addr
L
latkin 已提交
1367 1368
    (offset,flags,nameIdx,implIdx) 

W
WilliamBerryiii 已提交
1369
/// Read Table Nested.
L
latkin 已提交
1370 1371 1372
let seekReadNestedRow ctxt idx = ctxt.seekReadNestedRow idx
let seekReadNestedRowUncached ctxtH idx =
    let ctxt = getHole ctxtH
D
Don Syme 已提交
1373
    count ctxt.countNested
D
Don Syme 已提交
1374 1375 1376
    let mutable addr = ctxt.rowAddr TableNames.Nested idx
    let nestedIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr
    let enclIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr
L
latkin 已提交
1377 1378
    (nestedIdx,enclIdx)

W
WilliamBerryiii 已提交
1379
/// Read Table GenericParam.
L
latkin 已提交
1380
let seekReadGenericParamRow ctxt idx =
D
Don Syme 已提交
1381
    count ctxt.countGenericParam
D
Don Syme 已提交
1382 1383 1384 1385 1386
    let mutable addr = ctxt.rowAddr TableNames.GenericParam idx
    let seq = seekReadUInt16Adv ctxt &addr
    let flags = seekReadUInt16Adv ctxt &addr
    let ownerIdx = seekReadTypeOrMethodDefIdx ctxt &addr
    let nameIdx = seekReadStringIdx ctxt &addr
L
latkin 已提交
1387 1388
    (idx,seq,flags,ownerIdx,nameIdx) 

W
WilliamBerryiii 已提交
1389
// Read Table GenericParamConstraint.
L
latkin 已提交
1390
let seekReadGenericParamConstraintRow ctxt idx =
D
Don Syme 已提交
1391
    count ctxt.countGenericParamConstraint
D
Don Syme 已提交
1392 1393 1394
    let mutable addr = ctxt.rowAddr TableNames.GenericParamConstraint idx
    let pidx = seekReadUntaggedIdx TableNames.GenericParam ctxt &addr
    let constraintIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr
L
latkin 已提交
1395 1396
    (pidx,constraintIdx) 

W
WilliamBerryiii 已提交
1397
/// Read Table ILMethodSpec.
L
latkin 已提交
1398
let seekReadMethodSpecRow ctxt idx =
D
Don Syme 已提交
1399
    count ctxt.countMethodSpec
D
Don Syme 已提交
1400 1401 1402
    let mutable addr = ctxt.rowAddr TableNames.MethodSpec idx
    let mdorIdx = seekReadMethodDefOrRefIdx ctxt &addr
    let instIdx = seekReadBlobIdx ctxt &addr
L
latkin 已提交
1403 1404
    (mdorIdx,instIdx) 

D
Don Syme 已提交
1405

L
latkin 已提交
1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417
let readUserStringHeapUncached ctxtH idx = 
    let ctxt = getHole ctxtH
    seekReadUserString ctxt.is (ctxt.userStringsStreamPhysicalLoc + idx)

let readUserStringHeap ctxt idx = ctxt.readUserStringHeap  idx 

let readStringHeapUncached ctxtH idx = 
    let ctxt = getHole ctxtH
    seekReadUTF8String ctxt.is (ctxt.stringsStreamPhysicalLoc + idx) 
let readStringHeap          ctxt idx = ctxt.readStringHeap idx 
let readStringHeapOption   ctxt idx = if idx = 0 then None else Some (readStringHeap ctxt idx) 

1418
let emptyByteArray: byte[] = [||]
L
latkin 已提交
1419 1420
let readBlobHeapUncached ctxtH idx = 
    let ctxt = getHole ctxtH
1421 1422 1423 1424
    // valid index lies in range [1..streamSize)
    // NOTE: idx cannot be 0 - Blob\String heap has first empty element that is one byte 0
    if idx <= 0 || idx >= ctxt.blobsStreamSize then emptyByteArray
    else seekReadBlob ctxt.is (ctxt.blobsStreamPhysicalLoc + idx) 
L
latkin 已提交
1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459
let readBlobHeap        ctxt idx = ctxt.readBlobHeap idx 
let readBlobHeapOption ctxt idx = if idx = 0 then None else Some (readBlobHeap ctxt idx) 

let readGuidHeap ctxt idx = seekReadGuid ctxt.is (ctxt.guidsStreamPhysicalLoc + idx) 

// 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) 
   
//-----------------------------------------------------------------------
// Some binaries have raw data embedded their text sections, e.g. mscorlib, for 
// field inits.  And there is no information that definitively tells us the extent of 
// the text section that may be interesting data.  But we certainly don't want to duplicate 
// the entire text section as data! 
//  
// So, we assume: 
//   1. no part of the metadata is double-used for raw data  
//   2. the data bits are all the bits of the text section 
//      that stretch from a Field or Resource RVA to one of 
//        (a) the next Field or resource RVA 
//        (b) a MethodRVA 
//        (c) the start of the metadata 
//        (d) the end of a section 
//        (e) the start of the native resources attached to the binary if any
// ----------------------------------------------------------------------*)

1460
#if FX_NO_LINKEDRESOURCES
L
latkin 已提交
1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479
let readNativeResources _ctxt = []
#else
let readNativeResources ctxt = 
    let nativeResources = 
        if ctxt.nativeResourcesSize = 0x0 || ctxt.nativeResourcesAddr = 0x0 then 
            []
        else
            [ (lazy (let linkedResource = seekReadBytes ctxt.is (ctxt.anyV2P (ctxt.infile + ": native resources",ctxt.nativeResourcesAddr)) ctxt.nativeResourcesSize
                     unlinkResource ctxt.nativeResourcesAddr linkedResource)) ]
    nativeResources
#endif
   
let dataEndPoints ctxtH = 
    lazy
        let ctxt = getHole ctxtH
        let dataStartPoints = 
            let res = ref []
            for i = 1 to ctxt.getNumRows (TableNames.FieldRVA) do
                let rva,_fidx = seekReadFieldRVARow ctxt i
D
Don Syme 已提交
1480
                res := ("field",rva) :: !res
L
latkin 已提交
1481 1482 1483 1484
            for i = 1 to ctxt.getNumRows TableNames.ManifestResource do
                let (offset,_,_,TaggedIndex(_tag,idx)) = seekReadManifestResourceRow ctxt i
                if idx = 0 then 
                  let rva = ctxt.resourcesAddr + offset
D
Don Syme 已提交
1485
                  res := ("manifest resource", rva) :: !res
L
latkin 已提交
1486
            !res
D
Don Syme 已提交
1487
        if isNil dataStartPoints then [] 
L
latkin 已提交
1488 1489 1490 1491 1492 1493 1494
        else
          let methodRVAs = 
              let res = ref []
              for i = 1 to ctxt.getNumRows TableNames.Method do
                  let (rva, _, _, nameIdx, _, _) = seekReadMethodRow ctxt i
                  if rva <> 0 then 
                     let nm = readStringHeap ctxt nameIdx
D
Don Syme 已提交
1495
                     res := (nm,rva) :: !res
L
latkin 已提交
1496
              !res
D
Don Syme 已提交
1497 1498
          ([ ctxt.textSegmentPhysicalLoc + ctxt.textSegmentPhysicalSize ; 
             ctxt.dataSegmentPhysicalLoc + ctxt.dataSegmentPhysicalSize ] 
L
latkin 已提交
1499 1500 1501 1502 1503
           @ 
           (List.map ctxt.anyV2P 
              (dataStartPoints 
                @ [for (virtAddr,_virtSize,_physLoc) in ctxt.sectionHeaders do yield ("section start",virtAddr) done]
                @ [("md",ctxt.metadataAddr)]
D
Don Syme 已提交
1504 1505 1506 1507
                @ (if ctxt.nativeResourcesAddr = 0x0 then [] else [("native resources",ctxt.nativeResourcesAddr) ])
                @ (if ctxt.resourcesAddr = 0x0 then [] else [("managed resources",ctxt.resourcesAddr) ])
                @ (if ctxt.strongnameAddr = 0x0 then [] else [("managed strongname",ctxt.strongnameAddr) ])
                @ (if ctxt.vtableFixupsAddr = 0x0 then [] else [("managed vtable_fixups",ctxt.vtableFixupsAddr) ])
L
latkin 已提交
1508
                @ methodRVAs)))
S
Steffen Forkmann 已提交
1509
           |> List.distinct
L
latkin 已提交
1510 1511 1512 1513
           |> List.sort 
      

let rec rvaToData ctxt nm rva = 
D
Don Syme 已提交
1514
    if rva = 0x0 then failwith "rva is zero"
L
latkin 已提交
1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539
    let start = ctxt.anyV2P (nm, rva)
    let endPoints = (Lazy.force ctxt.dataEndPoints)
    let rec look l = 
        match l with 
        | [] -> 
            failwithf "find_text_data_extent: none found for infile=%s, name=%s, rva=0x%08x, start=0x%08x" ctxt.infile nm rva start 
        | e::t -> 
           if start < e then 
             (seekReadBytes ctxt.is start (e - start)) 
           else look t
    look endPoints


  
//-----------------------------------------------------------------------
// Read the AbsIL structure (lazily) by reading off the relevant rows.
// ----------------------------------------------------------------------

let isSorted ctxt (tab:TableName) = ((ctxt.sorted &&& (int64 1 <<< tab.Index)) <> int64 0x0) 

let rec seekReadModule ctxt (subsys,subsysversion,useHighEntropyVA, ilOnly,only32,is32bitpreferred,only64,platform,isDll, alignVirt,alignPhys,imageBaseReal,ilMetadataVersion) idx =
    let (_generation, nameIdx, _mvidIdx, _encidIdx, _encbaseidIdx) = seekReadModuleRow ctxt idx
    let ilModuleName = readStringHeap ctxt nameIdx
    let nativeResources = readNativeResources ctxt

K
KevinRansom 已提交
1540
    { Manifest =
L
latkin 已提交
1541
         if ctxt.getNumRows (TableNames.Assembly) > 0 then Some (seekReadAssemblyManifest ctxt 1) 
D
Don Syme 已提交
1542 1543 1544 1545 1546 1547 1548
         else None
      CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_Module,idx))
      Name = ilModuleName
      NativeResources=nativeResources
      TypeDefs = mkILTypeDefsComputed (fun () -> seekReadTopTypeDefs ctxt ())
      SubSystemFlags = int32 subsys
      IsILOnly = ilOnly
L
latkin 已提交
1549 1550
      SubsystemVersion = subsysversion
      UseHighEntropyVA = useHighEntropyVA
D
Don Syme 已提交
1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561
      Platform = platform
      StackReserveSize = None  // TODO
      Is32Bit = only32
      Is32BitPreferred = is32bitpreferred
      Is64Bit = only64
      IsDLL=isDll
      VirtualAlignment = alignVirt
      PhysicalAlignment = alignPhys
      ImageBase = imageBaseReal
      MetadataVersion = ilMetadataVersion
      Resources = seekReadManifestResources ctxt () }  
L
latkin 已提交
1562 1563 1564 1565 1566

and seekReadAssemblyManifest ctxt idx =
    let (hash,v1,v2,v3,v4,flags,publicKeyIdx, nameIdx, localeIdx) = seekReadAssemblyRow ctxt idx
    let name = readStringHeap ctxt nameIdx
    let pubkey = readBlobHeapOption ctxt publicKeyIdx
D
Don Syme 已提交
1567 1568 1569 1570 1571 1572 1573
    { Name= name 
      AuxModuleHashAlgorithm=hash
      SecurityDecls= seekReadSecurityDecls ctxt (TaggedIndex(hds_Assembly,idx))
      PublicKey= pubkey  
      Version= Some (v1,v2,v3,v4)
      Locale= readStringHeapOption ctxt localeIdx
      CustomAttrs = seekReadCustomAttrs ctxt (TaggedIndex(hca_Assembly,idx))
L
latkin 已提交
1574 1575 1576 1577 1578 1579 1580 1581
      AssemblyLongevity= 
        begin let masked = flags &&& 0x000e
          if masked = 0x0000 then ILAssemblyLongevity.Unspecified
          elif masked = 0x0002 then ILAssemblyLongevity.Library
          elif masked = 0x0004 then ILAssemblyLongevity.PlatformAppDomain
          elif masked = 0x0006 then ILAssemblyLongevity.PlatformProcess
          elif masked = 0x0008 then ILAssemblyLongevity.PlatformSystem
          else ILAssemblyLongevity.Unspecified
D
Don Syme 已提交
1582 1583 1584 1585 1586
        end
      ExportedTypes= seekReadTopExportedTypes ctxt ()
      EntrypointElsewhere=(if fst ctxt.entryPointToken = TableNames.File then Some (seekReadFile ctxt (snd ctxt.entryPointToken)) else None)
      Retargetable = 0 <> (flags &&& 0x100)
      DisableJitOptimizations = 0 <> (flags &&& 0x4000)
1587 1588 1589
      JitTracking = 0 <> (flags &&& 0x8000) 
      IgnoreSymbolStoreSequencePoints = 0 <> (flags &&& 0x2000) } 

L
latkin 已提交
1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605
and seekReadAssemblyRef ctxt idx = ctxt.seekReadAssemblyRef idx
and seekReadAssemblyRefUncached ctxtH idx = 
    let ctxt = getHole ctxtH
    let (v1,v2,v3,v4,flags,publicKeyOrTokenIdx, nameIdx, localeIdx,hashValueIdx) = seekReadAssemblyRefRow ctxt idx
    let 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(v1,v2,v3,v4), 
D
Don Syme 已提交
1606
         locale=readStringHeapOption ctxt localeIdx)
L
latkin 已提交
1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622

and seekReadModuleRef ctxt idx =
    let (nameIdx) = seekReadModuleRefRow ctxt idx
    ILModuleRef.Create(name =  readStringHeap ctxt nameIdx,
                     hasMetadata=true,
                     hash=None)

and seekReadFile ctxt idx =
    let (flags, nameIdx, hashValueIdx) = seekReadFileRow ctxt idx
    ILModuleRef.Create(name =  readStringHeap ctxt nameIdx,
                     hasMetadata= ((flags &&& 0x0001) = 0x0),
                     hash= readBlobHeapOption ctxt hashValueIdx)

and seekReadClassLayout ctxt idx =
    match seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.ClassLayout,seekReadClassLayoutRow ctxt,(fun (_,_,tidx) -> tidx),simpleIndexCompare idx,isSorted ctxt TableNames.ClassLayout,(fun (pack,size,_) -> pack,size)) with 
    | None -> { Size = None; Pack = None }
D
Don Syme 已提交
1623
    | Some (pack,size) -> { Size = Some size; Pack = Some pack }
L
latkin 已提交
1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734

and 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

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

and typeLayoutOfFlags ctxt flags tidx = 
    let f = (flags &&& 0x00000018)
    if f = 0x00000008 then ILTypeDefLayout.Sequential (seekReadClassLayout ctxt tidx)
    elif f = 0x00000010 then  ILTypeDefLayout.Explicit (seekReadClassLayout ctxt tidx)
    else ILTypeDefLayout.Auto

and typeKindOfFlags nm _mdefs _fdefs (super:ILType option) flags =
    if (flags &&& 0x00000020) <> 0x0 then ILTypeDefKind.Interface 
    else 
         let isEnum = (match super with None -> false | Some ty -> ty.TypeSpec.Name = "System.Enum")
         let isDelegate = (match super with None -> false | Some ty -> ty.TypeSpec.Name = "System.Delegate")
         let isMulticastDelegate = (match super with None -> false | Some ty -> ty.TypeSpec.Name = "System.MulticastDelegate")
         let selfIsMulticastDelegate = nm = "System.MulticastDelegate"
         let isValueType = (match super with None -> false | Some ty -> ty.TypeSpec.Name = "System.ValueType" && nm <> "System.Enum")
         if isEnum then ILTypeDefKind.Enum 
         elif  (isDelegate && not selfIsMulticastDelegate) || isMulticastDelegate then ILTypeDefKind.Delegate
         elif isValueType then ILTypeDefKind.ValueType 
         else ILTypeDefKind.Class 

and typeEncodingOfFlags flags = 
    let f = (flags &&& 0x00030000)
    if f = 0x00020000 then ILDefaultPInvokeEncoding.Auto 
    elif f = 0x00010000 then ILDefaultPInvokeEncoding.Unicode 
    else ILDefaultPInvokeEncoding.Ansi

and isTopTypeDef flags =
    (typeAccessOfFlags flags =  ILTypeDefAccess.Private) ||
     typeAccessOfFlags flags =  ILTypeDefAccess.Public
       
and seekIsTopTypeDefOfIdx ctxt idx =
    let (flags,_,_, _, _,_) = seekReadTypeDefRow ctxt idx
    isTopTypeDef flags
       
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

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)

and seekReadTypeDefRowExtents ctxt _info (idx:int) =
    if idx >= ctxt.getNumRows TableNames.TypeDef then 
        ctxt.getNumRows TableNames.Field + 1,
        ctxt.getNumRows TableNames.Method + 1
    else
        let (_, _, _, _, fieldsIdx, methodsIdx) = seekReadTypeDefRow ctxt (idx + 1)
        fieldsIdx, methodsIdx 

and seekReadTypeDefRowWithExtents ctxt (idx:int) =
    let info= seekReadTypeDefRow ctxt idx
    info,seekReadTypeDefRowExtents ctxt info idx

and seekReadTypeDef ctxt toponly (idx:int) =
    let (flags,nameIdx,namespaceIdx, _, _, _) = seekReadTypeDefRow ctxt idx
    if toponly && not (isTopTypeDef flags) then None
    else
     let ns,n = readBlobHeapAsSplitTypeName ctxt (nameIdx,namespaceIdx)
     let cas = seekReadCustomAttrs ctxt (TaggedIndex(hca_TypeDef,idx))

     let rest = 
        lazy
           // Re-read so as not to save all these in the lazy closure - this suspension ctxt.is the largest 
           // heavily allocated one in all of AbsIL
           let ((flags,nameIdx,namespaceIdx, extendsIdx, fieldsIdx, methodsIdx) as info) = seekReadTypeDefRow ctxt idx
           let nm = readBlobHeapAsTypeName ctxt (nameIdx,namespaceIdx)
           let cas = seekReadCustomAttrs ctxt (TaggedIndex(hca_TypeDef,idx))

           let (endFieldsIdx, endMethodsIdx) = seekReadTypeDefRowExtents ctxt info idx
           let typars = seekReadGenericParams ctxt 0 (tomd_TypeDef,idx)
           let numtypars = typars.Length
           let super = seekReadOptionalTypeDefOrRef ctxt numtypars AsObject extendsIdx
           let layout = typeLayoutOfFlags ctxt flags idx
           let hasLayout = (match layout with ILTypeDefLayout.Explicit _ -> true | _ -> false)
           let mdefs = seekReadMethods ctxt numtypars methodsIdx endMethodsIdx
           let fdefs = seekReadFields ctxt (numtypars,hasLayout) fieldsIdx endFieldsIdx
           let kind = typeKindOfFlags nm mdefs fdefs super flags
           let nested = seekReadNestedTypeDefs ctxt idx 
           let impls  = seekReadInterfaceImpls ctxt numtypars idx
           let sdecls =  seekReadSecurityDecls ctxt (TaggedIndex(hds_TypeDef,idx))
           let mimpls = seekReadMethodImpls ctxt numtypars idx
           let props  = seekReadProperties ctxt numtypars idx
           let events = seekReadEvents ctxt numtypars idx
D
Don Syme 已提交
1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746
           { tdKind= kind
             Name=nm
             GenericParams=typars 
             Access= typeAccessOfFlags flags
             IsAbstract= (flags &&& 0x00000080) <> 0x0
             IsSealed= (flags &&& 0x00000100) <> 0x0 
             IsSerializable= (flags &&& 0x00002000) <> 0x0 
             IsComInterop= (flags &&& 0x00001000) <> 0x0 
             Layout = layout
             IsSpecialName= (flags &&& 0x00000400) <> 0x0
             Encoding=typeEncodingOfFlags flags
             NestedTypes= nested
1747
             Implements = impls  
D
Don Syme 已提交
1748 1749 1750 1751 1752 1753
             Extends = super 
             Methods = mdefs 
             SecurityDecls = sdecls
             HasSecurity=(flags &&& 0x00040000) <> 0x0
             Fields=fdefs
             MethodImpls=mimpls
L
latkin 已提交
1754 1755 1756
             InitSemantics=
                 if kind = ILTypeDefKind.Interface then ILTypeInit.OnAny
                 elif (flags &&& 0x00100000) <> 0x0 then ILTypeInit.BeforeField
D
Don Syme 已提交
1757 1758 1759 1760
                 else ILTypeInit.OnAny 
             Events= events
             Properties=props
             CustomAttrs=cas }
L
latkin 已提交
1761 1762 1763
     Some (ns,n,cas,rest) 

and seekReadTopTypeDefs ctxt () =
1764
    [| for i = 1 to ctxt.getNumRows TableNames.TypeDef do
L
latkin 已提交
1765 1766
          match seekReadTypeDef ctxt true i  with 
          | None -> ()
1767
          | Some td -> yield td |]
L
latkin 已提交
1768 1769

and seekReadNestedTypeDefs ctxt tidx =
1770
    mkILTypeDefsComputed (fun () -> 
L
latkin 已提交
1771
           let nestedIdxs = seekReadIndexedRows (ctxt.getNumRows TableNames.Nested,seekReadNestedRow ctxt,snd,simpleIndexCompare tidx,false,fst)
1772
           [| for i in nestedIdxs do 
L
latkin 已提交
1773 1774
                 match seekReadTypeDef ctxt false i with 
                 | None -> ()
1775
                 | Some td -> yield td |])
L
latkin 已提交
1776 1777 1778 1779 1780 1781 1782

and seekReadInterfaceImpls ctxt numtypars tidx =
    seekReadIndexedRows (ctxt.getNumRows TableNames.InterfaceImpl,
                            seekReadInterfaceImplRow ctxt,
                            fst,
                            simpleIndexCompare tidx,
                            isSorted ctxt TableNames.InterfaceImpl,
1783
                            (snd >> seekReadTypeDefOrRef ctxt numtypars AsObject (*ok*) List.empty)) 
L
latkin 已提交
1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805

and seekReadGenericParams ctxt numtypars (a,b) : ILGenericParameterDefs = 
    ctxt.seekReadGenericParams (GenericParamsIdx(numtypars,a,b))

and seekReadGenericParamsUncached ctxtH (GenericParamsIdx(numtypars,a,b)) =
    let ctxt = getHole ctxtH
    let pars =
        seekReadIndexedRows
            (ctxt.getNumRows TableNames.GenericParam,seekReadGenericParamRow ctxt,
             (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 = seekReadGenericParamConstraintsUncached ctxt numtypars gpidx
                 let cas = seekReadCustomAttrs ctxt (TaggedIndex(hca_GenericParam,gpidx))
D
Don Syme 已提交
1806
                 seq, {Name=readStringHeap ctxt nameIdx
1807
                       Constraints = constraints
D
Don Syme 已提交
1808 1809 1810 1811 1812
                       Variance=variance  
                       CustomAttrs=cas
                       HasReferenceTypeConstraint= (flags &&& 0x0004) <> 0
                       HasNotNullableValueTypeConstraint= (flags &&& 0x0008) <> 0
                       HasDefaultConstructorConstraint=(flags &&& 0x0010) <> 0 }))
L
latkin 已提交
1813 1814 1815 1816 1817 1818 1819 1820 1821
    pars |> List.sortBy fst |> List.map snd 

and seekReadGenericParamConstraintsUncached ctxt numtypars gpidx =
    seekReadIndexedRows 
        (ctxt.getNumRows TableNames.GenericParamConstraint,
         seekReadGenericParamConstraintRow ctxt,
         fst,
         simpleIndexCompare gpidx,
         isSorted ctxt TableNames.GenericParamConstraint,
1822
         (snd >>  seekReadTypeDefOrRef ctxt numtypars AsObject (*ok*) List.empty))
L
latkin 已提交
1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859

and seekReadTypeDefAsType ctxt boxity (ginst:ILTypes) idx =
      ctxt.seekReadTypeDefAsType (TypeDefAsTypIdx (boxity,ginst,idx))

and seekReadTypeDefAsTypeUncached ctxtH (TypeDefAsTypIdx (boxity,ginst,idx)) =
    let ctxt = getHole ctxtH
    mkILTy boxity (ILTypeSpec.Create(seekReadTypeDefAsTypeRef ctxt idx, ginst))

and seekReadTypeDefAsTypeRef ctxt idx =
     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 idx = ctxt.seekReadTypeRef idx
and seekReadTypeRefUncached ctxtH idx =
     let ctxt = getHole ctxtH
     let scopeIdx,nameIdx,namespaceIdx = seekReadTypeRefRow ctxt idx
     let scope,enc = seekReadTypeRefScope ctxt scopeIdx
     let nm = readBlobHeapAsTypeName ctxt (nameIdx,namespaceIdx)
     ILTypeRef.Create(scope=scope, enclosing=enc, name = nm) 

and seekReadTypeRefAsType ctxt boxity ginst idx = ctxt.seekReadTypeRefAsType (TypeRefAsTypIdx (boxity,ginst,idx))
and seekReadTypeRefAsTypeUncached ctxtH (TypeRefAsTypIdx (boxity,ginst,idx)) =
     let ctxt = getHole ctxtH
     mkILTy boxity (ILTypeSpec.Create(seekReadTypeRef ctxt idx, ginst))

and seekReadTypeDefOrRef ctxt numtypars boxity (ginst:ILTypes) (TaggedIndex(tag,idx) ) =
    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 -> 
D
Don Syme 已提交
1860
        if ginst.Length > 0 then dprintn ("type spec used as type constructor for a generic instantiation: ignoring instantiation")
L
latkin 已提交
1861 1862 1863 1864 1865 1866 1867 1868
        readBlobHeapAsType ctxt numtypars (seekReadTypeSpecRow ctxt idx)
    | _ -> failwith "seekReadTypeDefOrRef ctxt"

and seekReadTypeDefOrRefAsTypeRef ctxt (TaggedIndex(tag,idx) ) =
    match tag with 
    | tag when tag = tdor_TypeDef -> seekReadTypeDefAsTypeRef ctxt idx
    | tag when tag = tdor_TypeRef -> seekReadTypeRef ctxt idx
    | tag when tag = tdor_TypeSpec -> 
D
Don Syme 已提交
1869
        dprintn ("type spec used where a type ref or def ctxt.is required")
1870
        ctxt.ilg.typ_Object.TypeRef
L
latkin 已提交
1871 1872 1873 1874
    | _ -> failwith "seekReadTypeDefOrRefAsTypeRef_readTypeDefOrRefOrSpec"

and seekReadMethodRefParent ctxt numtypars (TaggedIndex(tag,idx)) =
    match tag with 
1875
    | tag when tag = mrp_TypeRef -> seekReadTypeRefAsType ctxt AsObject (* not ok - no way to tell if a member ref parent ctxt.is a value type or not *) List.empty idx
L
latkin 已提交
1876 1877 1878
    | tag when tag = mrp_ModuleRef -> mkILTypeForGlobalFunctions (ILScopeRef.Module (seekReadModuleRef ctxt idx))
    | tag when tag = mrp_MethodDef -> 
        let (MethodData(enclTyp, cc, nm, argtys, retty, minst)) = seekReadMethodDefAsMethodData ctxt idx
1879
        let mspec = mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty, minst)
L
latkin 已提交
1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894
        mspec.EnclosingType
    | tag when tag = mrp_TypeSpec -> readBlobHeapAsType ctxt numtypars (seekReadTypeSpecRow ctxt idx)
    | _ -> failwith "seekReadMethodRefParent ctxt"

and seekReadMethodDefOrRef ctxt numtypars (TaggedIndex(tag,idx)) =
    match tag with 
    | tag when tag = mdor_MethodDef -> 
        let (MethodData(enclTyp, cc, nm, argtys, retty,minst)) = seekReadMethodDefAsMethodData ctxt idx
        VarArgMethodData(enclTyp, cc, nm, argtys, None,retty,minst)
    | tag when tag = mdor_MemberRef -> 
        seekReadMemberRefAsMethodData ctxt numtypars idx
    | _ -> failwith "seekReadMethodDefOrRef ctxt"

and seekReadMethodDefOrRefNoVarargs ctxt numtypars x =
     let (VarArgMethodData(enclTyp, cc, nm, argtys, varargs, retty, minst)) =     seekReadMethodDefOrRef ctxt numtypars x 
D
Don Syme 已提交
1895
     if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef token signature"
L
latkin 已提交
1896 1897 1898 1899 1900 1901
     MethodData(enclTyp, cc, nm, argtys, retty,minst)

and seekReadCustomAttrType ctxt (TaggedIndex(tag,idx) ) =
    match tag with 
    | tag when tag = cat_MethodDef -> 
        let (MethodData(enclTyp, cc, nm, argtys, retty, minst)) = seekReadMethodDefAsMethodData ctxt idx
1902
        mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty, minst)
L
latkin 已提交
1903 1904
    | tag when tag = cat_MemberRef -> 
        let (MethodData(enclTyp, cc, nm, argtys, retty, minst)) = seekReadMemberRefAsMethDataNoVarArgs ctxt 0 idx
1905
        mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty, minst)
L
latkin 已提交
1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928
    | _ -> failwith "seekReadCustomAttrType ctxt"
    
and seekReadImplAsScopeRef ctxt (TaggedIndex(tag,idx) ) =
     if idx = 0 then ILScopeRef.Local
     else 
       match tag with 
       | tag when tag = i_File -> ILScopeRef.Module (seekReadFile ctxt idx)
       | tag when tag = i_AssemblyRef -> ILScopeRef.Assembly (seekReadAssemblyRef ctxt idx)
       | tag when tag = i_ExportedType -> failwith "seekReadImplAsScopeRef ctxt"
       | _ -> failwith "seekReadImplAsScopeRef ctxt"

and seekReadTypeRefScope ctxt (TaggedIndex(tag,idx) ) =
    match tag with 
    | tag when tag = rs_Module -> ILScopeRef.Local,[]
    | tag when tag = rs_ModuleRef -> ILScopeRef.Module (seekReadModuleRef ctxt idx),[]
    | tag when tag = rs_AssemblyRef -> ILScopeRef.Assembly (seekReadAssemblyRef ctxt idx),[]
    | tag when tag = rs_TypeRef -> 
        let tref = seekReadTypeRef ctxt idx
        tref.Scope,(tref.Enclosing@[tref.Name])
    | _ -> failwith "seekReadTypeRefScope ctxt"

and seekReadOptionalTypeDefOrRef ctxt numtypars boxity idx = 
    if idx = TaggedIndex(tdor_TypeDef, 0) then None
1929
    else Some (seekReadTypeDefOrRef ctxt numtypars boxity List.empty idx)
L
latkin 已提交
1930 1931 1932 1933 1934 1935

and seekReadField ctxt (numtypars, hasLayout) (idx:int) =
     let (flags,nameIdx,typeIdx) = seekReadFieldRow ctxt idx
     let nm = readStringHeap ctxt nameIdx
     let isStatic = (flags &&& 0x0010) <> 0
     let fd = 
D
Don Syme 已提交
1936 1937 1938 1939 1940 1941 1942 1943 1944
       { Name = nm
         Type= readBlobHeapAsFieldSig ctxt numtypars typeIdx
         Access = memberAccessOfFlags flags
         IsStatic = isStatic
         IsInitOnly = (flags &&& 0x0020) <> 0
         IsLiteral = (flags &&& 0x0040) <> 0
         NotSerialized = (flags &&& 0x0080) <> 0
         IsSpecialName = (flags &&& 0x0200) <> 0 || (flags &&& 0x0400) <> 0 (* REVIEW: RTSpecialName *)
         LiteralValue = if (flags &&& 0x8000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_FieldDef,idx)))
L
latkin 已提交
1945 1946 1947 1948 1949
         Marshal = 
             if (flags &&& 0x1000) = 0 then None else 
             Some (seekReadIndexedRow (ctxt.getNumRows TableNames.FieldMarshal,seekReadFieldMarshalRow ctxt,
                                       fst,hfmCompare (TaggedIndex(hfm_FieldDef,idx)),
                                       isSorted ctxt TableNames.FieldMarshal,
D
Don Syme 已提交
1950
                                       (snd >> readBlobHeapAsNativeType ctxt)))
L
latkin 已提交
1951 1952 1953 1954 1955 1956 1957 1958 1959
         Data = 
             if (flags &&& 0x0100) = 0 then None 
             else 
               let rva = seekReadIndexedRow (ctxt.getNumRows TableNames.FieldRVA,seekReadFieldRVARow ctxt,
                                             snd,simpleIndexCompare idx,isSorted ctxt TableNames.FieldRVA,fst) 
               Some (rvaToData ctxt "field" rva)
         Offset = 
             if hasLayout && not isStatic then 
                 Some (seekReadIndexedRow (ctxt.getNumRows TableNames.FieldLayout,seekReadFieldLayoutRow ctxt,
D
Don Syme 已提交
1960 1961
                                           snd,simpleIndexCompare idx,isSorted ctxt TableNames.FieldLayout,fst)) else None 
         CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_FieldDef,idx)) }
L
latkin 已提交
1962 1963 1964 1965 1966 1967 1968 1969 1970
     fd
     
and seekReadFields ctxt (numtypars, hasLayout) fidx1 fidx2 =
    mkILFieldsLazy 
       (lazy
           [ for i = fidx1 to fidx2 - 1 do
               yield seekReadField ctxt (numtypars, hasLayout) i ])

and seekReadMethods ctxt numtypars midx1 midx2 =
1971 1972 1973
    mkILMethodsComputed (fun () -> 
           [| for i = midx1 to midx2 - 1 do
                 yield seekReadMethod ctxt numtypars i |])
L
latkin 已提交
1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985

and sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr = 
    let n, sigptr = sigptrGetZInt32 bytes sigptr
    if (n &&& 0x01) = 0x0 then (* Type Def *)
        TaggedIndex(tdor_TypeDef,  (n >>>& 2)), sigptr
    else (* Type Ref *)
        TaggedIndex(tdor_TypeRef,  (n >>>& 2)), sigptr         

and sigptrGetTy ctxt numtypars bytes sigptr = 
    let b0,sigptr = sigptrGetByte bytes sigptr
    if b0 = et_OBJECT then ctxt.ilg.typ_Object , sigptr
    elif b0 = et_STRING then ctxt.ilg.typ_String, sigptr
1986 1987 1988 1989
    elif b0 = et_I1 then ctxt.ilg.typ_SByte, sigptr
    elif b0 = et_I2 then ctxt.ilg.typ_Int16, sigptr
    elif b0 = et_I4 then ctxt.ilg.typ_Int32, sigptr
    elif b0 = et_I8 then ctxt.ilg.typ_Int64, sigptr
L
latkin 已提交
1990
    elif b0 = et_I then ctxt.ilg.typ_IntPtr, sigptr
1991 1992 1993 1994
    elif b0 = et_U1 then ctxt.ilg.typ_Byte, sigptr
    elif b0 = et_U2 then ctxt.ilg.typ_UInt16, sigptr
    elif b0 = et_U4 then ctxt.ilg.typ_UInt32, sigptr
    elif b0 = et_U8 then ctxt.ilg.typ_UInt64, sigptr
L
latkin 已提交
1995
    elif b0 = et_U then ctxt.ilg.typ_UIntPtr, sigptr
1996 1997 1998 1999
    elif b0 = et_R4 then ctxt.ilg.typ_Single, sigptr
    elif b0 = et_R8 then ctxt.ilg.typ_Double, sigptr
    elif b0 = et_CHAR then ctxt.ilg.typ_Char, sigptr
    elif b0 = et_BOOLEAN then ctxt.ilg.typ_Bool, sigptr
L
latkin 已提交
2000 2001 2002 2003 2004
    elif b0 = et_WITH then 
        let b0,sigptr = sigptrGetByte bytes sigptr
        let tdorIdx, sigptr = sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr
        let n, sigptr = sigptrGetZInt32 bytes sigptr
        let argtys,sigptr = sigptrFold (sigptrGetTy ctxt numtypars) n bytes sigptr
2005
        seekReadTypeDefOrRef ctxt numtypars (if b0 = et_CLASS then AsObject else AsValue) argtys tdorIdx,
L
latkin 已提交
2006 2007 2008 2009
        sigptr
        
    elif b0 = et_CLASS then 
        let tdorIdx, sigptr = sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr
2010
        seekReadTypeDefOrRef ctxt numtypars AsObject List.empty tdorIdx, sigptr
L
latkin 已提交
2011 2012
    elif b0 = et_VALUETYPE then 
        let tdorIdx, sigptr = sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr
2013
        seekReadTypeDefOrRef ctxt numtypars AsValue List.empty tdorIdx, sigptr
L
latkin 已提交
2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037
    elif b0 = et_VAR then 
        let n, sigptr = sigptrGetZInt32 bytes sigptr
        ILType.TypeVar (uint16 n),sigptr
    elif b0 = et_MVAR then 
        let n, sigptr = sigptrGetZInt32 bytes sigptr
        ILType.TypeVar (uint16 (n + numtypars)), sigptr
    elif b0 = et_BYREF then 
        let typ, sigptr = sigptrGetTy ctxt numtypars bytes sigptr
        ILType.Byref typ, sigptr
    elif b0 = et_PTR then 
        let typ, sigptr = sigptrGetTy ctxt numtypars bytes sigptr
        ILType.Ptr typ, sigptr
    elif b0 = et_SZARRAY then 
        let typ, sigptr = sigptrGetTy ctxt numtypars bytes sigptr
        mkILArr1DTy typ, sigptr
    elif b0 = et_ARRAY then
        let typ, sigptr = sigptrGetTy ctxt numtypars bytes sigptr
        let rank, sigptr = sigptrGetZInt32 bytes sigptr
        let numSized, sigptr = sigptrGetZInt32 bytes sigptr
        let sizes, sigptr = sigptrFold sigptrGetZInt32 numSized bytes sigptr
        let numLoBounded, sigptr = sigptrGetZInt32 bytes sigptr
        let lobounds, sigptr = sigptrFold sigptrGetZInt32 numLoBounded bytes sigptr
        let shape = 
            let dim i =
2038 2039
              (if i <  numLoBounded then Some (List.item i lobounds) else None),
              (if i <  numSized then Some (List.item i sizes) else None)
L
latkin 已提交
2040 2041 2042 2043 2044
            ILArrayShape (Array.toList (Array.init rank dim))
        mkILArrTy (typ, shape), sigptr
        
    elif b0 = et_VOID then ILType.Void, sigptr
    elif b0 = et_TYPEDBYREF then 
2045 2046
        let t = mkILNonGenericValueTy(mkILTyRef(ctxt.ilg.primaryAssemblyScopeRef,"System.TypedReference"))
        t, sigptr
L
latkin 已提交
2047 2048 2049 2050 2051 2052 2053
    elif b0 = et_CMOD_REQD || b0 = et_CMOD_OPT  then 
        let tdorIdx, sigptr = sigptrGetTypeDefOrRefOrSpecIdx bytes sigptr
        let typ, sigptr = sigptrGetTy ctxt numtypars bytes sigptr
        ILType.Modified((b0 = et_CMOD_REQD), seekReadTypeDefOrRefAsTypeRef ctxt tdorIdx, typ), sigptr
    elif b0 = et_FNPTR then
        let ccByte,sigptr = sigptrGetByte bytes sigptr
        let generic,cc = byteAsCallConv ccByte
D
Don Syme 已提交
2054
        if generic then failwith "fptr sig may not be generic"
L
latkin 已提交
2055 2056 2057 2058
        let numparams,sigptr = sigptrGetZInt32 bytes sigptr
        let retty,sigptr = sigptrGetTy ctxt numtypars bytes sigptr
        let argtys,sigptr = sigptrFold (sigptrGetTy ctxt numtypars) ( numparams) bytes sigptr
        ILType.FunctionPointer
D
Don Syme 已提交
2059
          { CallingConv=cc
2060
            ArgTypes = argtys
L
latkin 已提交
2061 2062 2063 2064 2065 2066 2067 2068 2069
            ReturnType=retty }
          ,sigptr
    elif b0 = et_SENTINEL then failwith "varargs NYI"
    else ILType.Void , sigptr
        
and sigptrGetVarArgTys ctxt n numtypars bytes sigptr = 
    sigptrFold (sigptrGetTy ctxt numtypars) n bytes sigptr 

and sigptrGetArgTys ctxt n numtypars bytes sigptr acc = 
2070
    if n <= 0 then (List.rev acc,None),sigptr 
L
latkin 已提交
2071 2072 2073 2074
    else
      let b0,sigptr2 = sigptrGetByte bytes sigptr
      if b0 = et_SENTINEL then 
        let varargs,sigptr = sigptrGetVarArgTys ctxt n numtypars bytes sigptr2
2075
        (List.rev acc,Some(varargs)),sigptr
L
latkin 已提交
2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087
      else
        let x,sigptr = sigptrGetTy ctxt numtypars bytes sigptr
        sigptrGetArgTys ctxt (n-1) numtypars bytes sigptr (x::acc)
         
and sigptrGetLocal ctxt numtypars bytes sigptr = 
    let pinned,sigptr = 
        let b0, sigptr' = sigptrGetByte bytes sigptr
        if b0 = et_PINNED then 
            true, sigptr'
        else 
            false, sigptr
    let typ, sigptr = sigptrGetTy ctxt numtypars bytes sigptr
D
Don Syme 已提交
2088 2089
    let loc : ILLocal = { IsPinned = pinned; Type = typ; DebugInfo = None }
    loc, sigptr
L
latkin 已提交
2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118
         
and readBlobHeapAsMethodSig ctxt numtypars blobIdx  =
    ctxt.readBlobHeapAsMethodSig (BlobAsMethodSigIdx (numtypars,blobIdx))

and readBlobHeapAsMethodSigUncached ctxtH (BlobAsMethodSigIdx (numtypars,blobIdx)) =
    let ctxt = getHole ctxtH
    let bytes = readBlobHeap ctxt blobIdx
    let sigptr = 0
    let ccByte,sigptr = sigptrGetByte bytes sigptr
    let generic,cc = byteAsCallConv ccByte
    let genarity,sigptr = if generic then sigptrGetZInt32 bytes sigptr else 0x0,sigptr
    let numparams,sigptr = sigptrGetZInt32 bytes sigptr
    let retty,sigptr = sigptrGetTy ctxt numtypars bytes sigptr
    let (argtys,varargs),_sigptr = sigptrGetArgTys ctxt  ( numparams) numtypars bytes sigptr []
    generic,genarity,cc,retty,argtys,varargs
      
and readBlobHeapAsType ctxt numtypars blobIdx = 
    let bytes = readBlobHeap ctxt blobIdx
    let ty,_sigptr = sigptrGetTy ctxt numtypars bytes 0
    ty

and readBlobHeapAsFieldSig ctxt 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
D
Don Syme 已提交
2119
    if ccByte <> e_IMAGE_CEE_CS_CALLCONV_FIELD then dprintn "warning: field sig was not CC_FIELD"
L
latkin 已提交
2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132
    let retty,_sigptr = sigptrGetTy ctxt numtypars bytes sigptr
    retty

      
and readBlobHeapAsPropertySig ctxt numtypars blobIdx  =
    ctxt.readBlobHeapAsPropertySig (BlobAsPropSigIdx (numtypars,blobIdx))
and readBlobHeapAsPropertySigUncached ctxtH (BlobAsPropSigIdx (numtypars,blobIdx))  =
    let ctxt = getHole ctxtH
    let bytes = readBlobHeap ctxt blobIdx
    let sigptr = 0
    let ccByte,sigptr = sigptrGetByte bytes sigptr
    let hasthis = byteAsHasThis ccByte
    let ccMaxked = (ccByte &&& 0x0Fuy)
D
Don Syme 已提交
2133
    if ccMaxked <> e_IMAGE_CEE_CS_CALLCONV_PROPERTY then dprintn ("warning: property sig was "+string ccMaxked+" instead of CC_PROPERTY")
L
latkin 已提交
2134 2135 2136
    let numparams,sigptr = sigptrGetZInt32 bytes sigptr
    let retty,sigptr = sigptrGetTy ctxt numtypars bytes sigptr
    let argtys,_sigptr = sigptrFold (sigptrGetTy ctxt numtypars) ( numparams) bytes sigptr
2137
    hasthis,retty,argtys
L
latkin 已提交
2138 2139 2140 2141 2142 2143 2144 2145 2146
      
and readBlobHeapAsLocalsSig ctxt 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
D
Don Syme 已提交
2147
    if ccByte <> e_IMAGE_CEE_CS_CALLCONV_LOCAL_SIG then dprintn "warning: local sig was not CC_LOCAL"
L
latkin 已提交
2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177
    let numlocals,sigptr = sigptrGetZInt32 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 

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
    let generic = (b &&& e_IMAGE_CEE_CS_CALLCONV_GENERIC) <> 0x0uy
    generic, Callconv (byteAsHasThis b,cc) 
      
and seekReadMemberRefAsMethodData ctxt numtypars idx : VarArgMethodData = 
    ctxt.seekReadMemberRefAsMethodData (MemberRefAsMspecIdx (numtypars,idx))
and seekReadMemberRefAsMethodDataUncached ctxtH (MemberRefAsMspecIdx (numtypars,idx)) = 
    let ctxt = getHole ctxtH
    let (mrpIdx,nameIdx,typeIdx) = seekReadMemberRefRow ctxt idx
    let nm = readStringHeap ctxt nameIdx
    let enclTyp = seekReadMethodRefParent ctxt numtypars mrpIdx
    let _generic,genarity,cc,retty,argtys,varargs = readBlobHeapAsMethodSig ctxt enclTyp.GenericArgs.Length typeIdx
2178
    let minst =  List.init genarity (fun n -> mkILTyvarTy (uint16 (numtypars+n))) 
L
latkin 已提交
2179 2180 2181 2182
    (VarArgMethodData(enclTyp, cc, nm, argtys, varargs,retty,minst))

and seekReadMemberRefAsMethDataNoVarArgs ctxt numtypars idx : MethodData =
   let (VarArgMethodData(enclTyp, cc, nm, argtys,varargs, retty,minst)) =  seekReadMemberRefAsMethodData ctxt numtypars idx
2183
   if Option.isSome varargs then dprintf "ignoring sentinel and varargs in ILMethodDef token signature"
L
latkin 已提交
2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195
   (MethodData(enclTyp, cc, nm, argtys, retty,minst))

and seekReadMethodSpecAsMethodData ctxt numtypars idx =  
    ctxt.seekReadMethodSpecAsMethodData (MethodSpecAsMspecIdx (numtypars,idx))
and seekReadMethodSpecAsMethodDataUncached ctxtH (MethodSpecAsMspecIdx (numtypars,idx)) = 
    let ctxt = getHole ctxtH
    let (mdorIdx,instIdx) = seekReadMethodSpecRow ctxt idx
    let (VarArgMethodData(enclTyp, cc, nm, argtys, varargs,retty,_)) = seekReadMethodDefOrRef ctxt numtypars mdorIdx
    let minst = 
        let bytes = readBlobHeap ctxt instIdx
        let sigptr = 0
        let ccByte,sigptr = sigptrGetByte bytes sigptr
D
Don Syme 已提交
2196
        if ccByte <> e_IMAGE_CEE_CS_CALLCONV_GENERICINST then dprintn ("warning: method inst ILCallingConv was "+string ccByte+" instead of CC_GENERICINST")
L
latkin 已提交
2197 2198
        let numgpars,sigptr = sigptrGetZInt32 bytes sigptr
        let argtys,_sigptr = sigptrFold (sigptrGetTy ctxt numtypars) numgpars bytes sigptr
2199
        argtys
L
latkin 已提交
2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232
    VarArgMethodData(enclTyp, cc, nm, argtys, varargs,retty, minst)

and seekReadMemberRefAsFieldSpec ctxt numtypars idx = 
   ctxt.seekReadMemberRefAsFieldSpec (MemberRefAsFspecIdx (numtypars,idx))
and seekReadMemberRefAsFieldSpecUncached ctxtH (MemberRefAsFspecIdx (numtypars,idx)) = 
   let ctxt = getHole ctxtH
   let (mrpIdx,nameIdx,typeIdx) = seekReadMemberRefRow ctxt idx
   let nm = readStringHeap ctxt nameIdx
   let enclTyp = seekReadMethodRefParent ctxt numtypars mrpIdx
   let retty = readBlobHeapAsFieldSig ctxt numtypars typeIdx
   mkILFieldSpecInTy(enclTyp, 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 
// to.  So we do a binary chop through the ILTypeDef table 
// 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 seekReadMethodDefAsMethodDataUncached ctxtH idx =
   let ctxt = getHole ctxtH
   // 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)
2233 2234 2235 2236 2237 2238 2239 2240
   // 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 finst = mkILFormalGenericArgs 0 typeGenericArgs
   let minst = mkILFormalGenericArgs typeGenericArgsCount methodGenericArgs
L
latkin 已提交
2241 2242 2243
   // Read the method def parent. 
   let enclTyp = seekReadTypeDefAsType ctxt AsObject (* not ok: see note *) finst tidx
   // Return the constituent parts: put it together at the place where this is called. 
2244 2245 2246 2247 2248 2249 2250 2251

   let (_code_rva, _implflags, _flags, nameIdx, typeIdx, _paramIdx) = seekReadMethodRow ctxt 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"

L
latkin 已提交
2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274
   MethodData(enclTyp, cc, nm, argtys, retty, minst)


 (* Similarly for fields. *)
and seekReadFieldDefAsFieldSpec ctxt idx =
   ctxt.seekReadFieldDefAsFieldSpec idx
and seekReadFieldDefAsFieldSpecUncached ctxtH idx =
   let ctxt = getHole ctxtH
   let (_flags, nameIdx, typeIdx) = seekReadFieldRow ctxt 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 
2275
   let finst = mkILFormalGenericArgs 0 (seekReadGenericParams ctxt 0 (tomd_TypeDef,tidx))
L
latkin 已提交
2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303
   // Read the field def parent. 
   let enclTyp = seekReadTypeDefAsType ctxt AsObject (* not ok: see note *) finst tidx
   // Put it together. 
   mkILFieldSpecInTy(enclTyp, nm, retty)

and seekReadMethod ctxt numtypars (idx:int) =
     let (codeRVA, implflags, flags, nameIdx, typeIdx, paramIdx) = seekReadMethodRow ctxt idx
     let nm = readStringHeap ctxt nameIdx
     let isStatic = (flags &&& 0x0010) <> 0x0
     let final = (flags &&& 0x0020) <> 0x0
     let virt = (flags &&& 0x0040) <> 0x0
     let strict = (flags &&& 0x0200) <> 0x0
     let hidebysig = (flags &&& 0x0080) <> 0x0
     let newslot = (flags &&& 0x0100) <> 0x0
     let abstr = (flags &&& 0x0400) <> 0x0
     let specialname = (flags &&& 0x0800) <> 0x0
     let pinvoke = (flags &&& 0x2000) <> 0x0
     let export = (flags &&& 0x0008) <> 0x0
     let _rtspecialname = (flags &&& 0x1000) <> 0x0
     let reqsecobj = (flags &&& 0x8000) <> 0x0
     let hassec = (flags &&& 0x4000) <> 0x0
     let codetype = implflags &&& 0x0003
     let unmanaged = (implflags &&& 0x0004) <> 0x0
     let forwardref = (implflags &&& 0x0010) <> 0x0
     let preservesig = (implflags &&& 0x0080) <> 0x0
     let internalcall = (implflags &&& 0x1000) <> 0x0
     let synchronized = (implflags &&& 0x0020) <> 0x0
     let noinline = (implflags &&& 0x0008) <> 0x0
2304
     let aggressiveinline = (implflags &&& 0x0100) <> 0x0
L
latkin 已提交
2305 2306 2307 2308
     let mustrun = (implflags &&& 0x0040) <> 0x0
     let cctor = (nm = ".cctor")
     let ctor = (nm = ".ctor")
     let _generic,_genarity,cc,retty,argtys,varargs = readBlobHeapAsMethodSig ctxt numtypars typeIdx
D
Don Syme 已提交
2309
     if varargs <> None then dprintf "ignoring sentinel and varargs in ILMethodDef signature"
L
latkin 已提交
2310 2311 2312 2313 2314 2315 2316 2317 2318 2319
     
     let endParamIdx =
       if idx >= ctxt.getNumRows TableNames.Method then 
         ctxt.getNumRows TableNames.Param + 1
       else
         let (_,_,_,_,_, paramIdx) = seekReadMethodRow ctxt (idx + 1)
         paramIdx
     
     let ret,ilParams = seekReadParams ctxt (retty,argtys) paramIdx endParamIdx

D
Don Syme 已提交
2320
     { Name=nm
L
latkin 已提交
2321 2322 2323 2324 2325 2326
       mdKind = 
           (if cctor then MethodKind.Cctor 
            elif ctor then MethodKind.Ctor 
            elif isStatic then MethodKind.Static 
            elif virt then 
             MethodKind.Virtual 
D
Don Syme 已提交
2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341
               { IsFinal=final 
                 IsNewSlot=newslot 
                 IsCheckAccessOnOverride=strict
                 IsAbstract=abstr }
            else MethodKind.NonVirtual)
       Access = memberAccessOfFlags flags
       SecurityDecls=seekReadSecurityDecls ctxt (TaggedIndex(hds_MethodDef,idx))
       HasSecurity=hassec
       IsEntryPoint= (fst ctxt.entryPointToken = TableNames.Method && snd ctxt.entryPointToken = idx)
       IsReqSecObj=reqsecobj
       IsHideBySig=hidebysig
       IsSpecialName=specialname
       IsUnmanagedExport=export
       IsSynchronized=synchronized
       IsNoInline=noinline
2342
       IsAggressiveInline=aggressiveinline
D
Don Syme 已提交
2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353
       IsMustRun=mustrun
       IsPreserveSig=preservesig
       IsManaged = not unmanaged
       IsInternalCall = internalcall
       IsForwardRef = forwardref
       mdCodeKind = (if (codetype = 0x00) then MethodCodeKind.IL elif (codetype = 0x01) then MethodCodeKind.Native elif (codetype = 0x03) then MethodCodeKind.Runtime else MethodCodeKind.Native)
       GenericParams=seekReadGenericParams ctxt numtypars (tomd_MethodDef,idx)
       CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_MethodDef,idx)) 
       Parameters= ilParams
       CallingConv=cc
       Return=ret
L
latkin 已提交
2354 2355 2356 2357 2358 2359
       mdBody=
         if (codetype = 0x01) && pinvoke then 
           mkMethBodyLazyAux (notlazy MethodBody.Native)
         elif pinvoke then 
           seekReadImplMap ctxt nm  idx
         elif internalcall || abstr || unmanaged || (codetype <> 0x00) then 
D
Don Syme 已提交
2360
           //if codeRVA <> 0x0 then dprintn "non-IL or abstract method with non-zero RVA"
L
latkin 已提交
2361 2362
           mkMethBodyLazyAux (notlazy MethodBody.Abstract)  
         else 
2363
           seekReadMethodRVA ctxt (idx,nm,internalcall,noinline,aggressiveinline,numtypars) codeRVA   
L
latkin 已提交
2364 2365 2366 2367 2368
     }
     
     
and seekReadParams ctxt (retty,argtys) pidx1 pidx2 =
    let retRes : ILReturn ref =  ref { Marshal=None; Type=retty; CustomAttrs=emptyILCustomAttrs }
D
Don Syme 已提交
2369
    let paramsRes : ILParameter [] = 
L
latkin 已提交
2370
        argtys 
2371
        |> List.toArray 
L
latkin 已提交
2372
        |> Array.map (fun ty ->  
D
Don Syme 已提交
2373 2374 2375 2376 2377 2378 2379
            { Name=None
              Default=None
              Marshal=None
              IsIn=false
              IsOut=false
              IsOptional=false
              Type=ty
L
latkin 已提交
2380 2381 2382
              CustomAttrs=emptyILCustomAttrs })
    for i = pidx1 to pidx2 - 1 do
        seekReadParamExtras ctxt (retRes,paramsRes) i
2383
    !retRes, List.ofArray paramsRes
L
latkin 已提交
2384 2385 2386 2387 2388 2389 2390 2391 2392 2393

and seekReadParamExtras ctxt (retRes,paramsRes) (idx:int) =
   let (flags,seq,nameIdx) = seekReadParamRow ctxt idx
   let inOutMasked = (flags &&& 0x00FF)
   let hasMarshal = (flags &&& 0x2000) <> 0x0
   let hasDefault = (flags &&& 0x1000) <> 0x0
   let fmReader idx = seekReadIndexedRow (ctxt.getNumRows TableNames.FieldMarshal,seekReadFieldMarshalRow ctxt,fst,hfmCompare idx,isSorted ctxt TableNames.FieldMarshal,(snd >> readBlobHeapAsNativeType ctxt))
   let cas = seekReadCustomAttrs ctxt (TaggedIndex(hca_ParamDef,idx))
   if seq = 0 then
       retRes := { !retRes with 
D
Don Syme 已提交
2394
                        Marshal=(if hasMarshal then Some (fmReader (TaggedIndex(hfm_ParamDef,idx))) else None)
L
latkin 已提交
2395 2396 2397 2398 2399
                        CustomAttrs = cas }
   elif seq > Array.length paramsRes then dprintn "bad seq num. for param"
   else 
       paramsRes.[seq - 1] <- 
          { paramsRes.[seq - 1] with 
D
Don Syme 已提交
2400 2401 2402 2403 2404 2405
               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)
L
latkin 已提交
2406 2407 2408 2409 2410 2411 2412 2413 2414
               CustomAttrs =cas }
          
and seekReadMethodImpls ctxt numtypars tidx =
   mkILMethodImplsLazy 
      (lazy 
          let mimpls = seekReadIndexedRows (ctxt.getNumRows TableNames.MethodImpl,seekReadMethodImplRow ctxt,(fun (a,_,_) -> a),simpleIndexCompare tidx,isSorted ctxt TableNames.MethodImpl,(fun (_,b,c) -> b,c))
          mimpls |> List.map (fun (b,c) -> 
              { OverrideBy=
                  let (MethodData(enclTyp, cc, nm, argtys, retty,minst)) = seekReadMethodDefOrRefNoVarargs ctxt numtypars b
2415
                  mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty,minst)
L
latkin 已提交
2416 2417
                Overrides=
                  let (MethodData(enclTyp, cc, nm, argtys, retty,minst)) = seekReadMethodDefOrRefNoVarargs ctxt numtypars c
2418
                  let mspec = mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty,minst)
L
latkin 已提交
2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429
                  OverridesSpec(mspec.MethodRef, mspec.EnclosingType) }))

and seekReadMultipleMethodSemantics ctxt (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(enclTyp, cc, nm, argtys, retty, minst)) = seekReadMethodDefAsMethodData ctxt b
2430
           a, (mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty, minst)).MethodRef))
L
latkin 已提交
2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447
    |> List.filter (fun (flags2,_) -> flags = flags2) 
    |> List.map snd 


and seekReadoptional_MethodSemantics ctxt id =
    match seekReadMultipleMethodSemantics ctxt id with 
    | [] -> None
    | [h] -> Some h
    | h::_ -> dprintn "multiple method semantics found"; Some h

and seekReadMethodSemantics ctxt id =
    match seekReadoptional_MethodSemantics ctxt id with 
    | None -> failwith "seekReadMethodSemantics ctxt: no method found"
    | Some x -> x

and seekReadEvent ctxt numtypars idx =
   let (flags,nameIdx,typIdx) = seekReadEventRow ctxt idx
D
Don Syme 已提交
2448 2449 2450 2451 2452 2453 2454 2455
   { Name = readStringHeap ctxt nameIdx
     Type = seekReadOptionalTypeDefOrRef ctxt numtypars AsObject typIdx
     IsSpecialName  = (flags &&& 0x0200) <> 0x0 
     IsRTSpecialName = (flags &&& 0x0400) <> 0x0
     AddMethod= seekReadMethodSemantics ctxt (0x0008,TaggedIndex(hs_Event, idx))
     RemoveMethod=seekReadMethodSemantics ctxt (0x0010,TaggedIndex(hs_Event,idx))
     FireMethod=seekReadoptional_MethodSemantics ctxt (0x0020,TaggedIndex(hs_Event,idx))
     OtherMethods = seekReadMultipleMethodSemantics ctxt (0x0004, TaggedIndex(hs_Event, idx))
L
latkin 已提交
2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488
     CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_Event,idx)) }
   
  (* REVIEW: can substantially reduce numbers of EventMap and PropertyMap reads by first checking if the whole table is sorted according to ILTypeDef tokens and then doing a binary chop *)
and seekReadEvents ctxt numtypars tidx =
   mkILEventsLazy 
      (lazy 
           match seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.EventMap,(fun i -> i, seekReadEventMapRow ctxt i),(fun (_,row) -> fst row),compare tidx,false,(fun (i,row) -> (i,snd row))) with 
           | None -> []
           | Some (rowNum,beginEventIdx) ->
               let endEventIdx =
                   if rowNum >= ctxt.getNumRows TableNames.EventMap then 
                       ctxt.getNumRows TableNames.Event + 1
                   else
                       let (_, endEventIdx) = seekReadEventMapRow ctxt (rowNum + 1)
                       endEventIdx

               [ for i in beginEventIdx .. endEventIdx - 1 do
                   yield seekReadEvent ctxt numtypars i ])

and seekReadProperty ctxt numtypars idx =
   let (flags,nameIdx,typIdx) = seekReadPropertyRow ctxt idx
   let cc,retty,argtys = readBlobHeapAsPropertySig ctxt numtypars typIdx
   let setter= seekReadoptional_MethodSemantics ctxt (0x0001,TaggedIndex(hs_Property,idx))
   let getter = seekReadoptional_MethodSemantics ctxt (0x0002,TaggedIndex(hs_Property,idx))
(* 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
D
Don Syme 已提交
2489 2490 2491 2492 2493 2494 2495 2496 2497
   { Name=readStringHeap ctxt nameIdx
     CallingConv = cc2
     IsRTSpecialName=(flags &&& 0x0400) <> 0x0 
     IsSpecialName= (flags &&& 0x0200) <> 0x0 
     SetMethod=setter
     GetMethod=getter
     Type=retty
     Init= if (flags &&& 0x1000) = 0 then None else Some (seekReadConstant ctxt (TaggedIndex(hc_Property,idx)))
     Args=argtys
L
latkin 已提交
2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522
     CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_Property,idx)) }
   
and seekReadProperties ctxt numtypars tidx =
   mkILPropertiesLazy
      (lazy 
           match seekReadOptionalIndexedRow (ctxt.getNumRows TableNames.PropertyMap,(fun i -> i, seekReadPropertyMapRow ctxt i),(fun (_,row) -> fst row),compare tidx,false,(fun (i,row) -> (i,snd row))) with 
           | None -> []
           | Some (rowNum,beginPropIdx) ->
               let endPropIdx =
                   if rowNum >= ctxt.getNumRows TableNames.PropertyMap then 
                       ctxt.getNumRows TableNames.Property + 1
                   else
                       let (_, endPropIdx) = seekReadPropertyMapRow ctxt (rowNum + 1)
                       endPropIdx
               [ for i in beginPropIdx .. endPropIdx - 1 do
                   yield seekReadProperty ctxt numtypars i ])


and seekReadCustomAttrs ctxt idx = 
    mkILComputedCustomAttrs
     (fun () ->
          seekReadIndexedRows (ctxt.getNumRows TableNames.CustomAttribute,
                                  seekReadCustomAttributeRow ctxt,(fun (a,_,_) -> a),
                                  hcaCompare idx,
                                  isSorted ctxt TableNames.CustomAttribute,
2523 2524
                                  (fun (_,b,c) -> seekReadCustomAttr ctxt (b,c)))
          |> List.toArray)
L
latkin 已提交
2525 2526 2527 2528 2529 2530

and seekReadCustomAttr ctxt (TaggedIndex(cat,idx),b) = 
    ctxt.seekReadCustomAttr (CustomAttrIdx (cat,idx,b))

and seekReadCustomAttrUncached ctxtH (CustomAttrIdx (cat,idx,valIdx)) = 
    let ctxt = getHole ctxtH
D
Don Syme 已提交
2531
    { Method=seekReadCustomAttrType ctxt (TaggedIndex(cat,idx))
L
latkin 已提交
2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618
      Data=
        match readBlobHeapOption ctxt valIdx with
        | Some bytes -> bytes
        | None -> Bytes.ofInt32Array [| |] }

and seekReadSecurityDecls ctxt idx = 
   mkILLazySecurityDecls
    (lazy
         seekReadIndexedRows (ctxt.getNumRows TableNames.Permission,
                                 seekReadPermissionRow ctxt,
                                 (fun (_,par,_) -> par),
                                 hdsCompare idx,
                                 isSorted ctxt TableNames.Permission,
                                 (fun (act,_,ty) -> seekReadSecurityDecl ctxt (act,ty))))

and seekReadSecurityDecl ctxt (a,b) = 
    ctxt.seekReadSecurityDecl (SecurityDeclIdx (a,b))

and seekReadSecurityDeclUncached ctxtH (SecurityDeclIdx (act,ty)) = 
    let ctxt = getHole ctxtH
    PermissionSet ((if List.memAssoc (int act) (Lazy.force ILSecurityActionRevMap) then List.assoc (int act) (Lazy.force ILSecurityActionRevMap) else failwith "unknown security action"),
                   readBlobHeap ctxt ty)


and seekReadConstant ctxt 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 = System.Text.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 nm midx = 
   mkMethBodyLazyAux 
      (lazy 
            let (flags,nameIdx, scopeIdx) = seekReadIndexedRow (ctxt.getNumRows TableNames.ImplMap,
                                                                seekReadImplMapRow ctxt,
                                                                (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)

D
Don Syme 已提交
2619 2620 2621 2622 2623 2624
            MethodBody.PInvoke { CallingConv = cc 
                                 CharEncoding = enc
                                 CharBestFit=bestfit
                                 ThrowOnUnmappableChar=unmap
                                 NoMangle = (flags &&& 0x0001) <> 0x0
                                 LastError = (flags &&& 0x0040) <> 0x0
L
latkin 已提交
2625 2626 2627
                                 Name = 
                                     (match readStringHeapOption ctxt nameIdx with 
                                      | None -> nm
D
Don Syme 已提交
2628
                                      | Some nm2 -> nm2)
L
latkin 已提交
2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644
                                 Where = seekReadModuleRef ctxt scopeIdx })

and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = 
   let labelsOfRawOffsets = new Dictionary<_,_>(sz/2)
   let ilOffsetsOfLabels = new Dictionary<_,_>(sz/2)
   let tryRawToLabel rawOffset = 
       if labelsOfRawOffsets.ContainsKey rawOffset then 
           Some(labelsOfRawOffsets.[rawOffset])
       else 
           None

   let rawToLabel rawOffset = 
       match tryRawToLabel rawOffset with 
       | Some l -> l
       | None -> 
           let lab = generateCodeLabel()
D
Don Syme 已提交
2645
           labelsOfRawOffsets.[rawOffset] <- lab
L
latkin 已提交
2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658
           lab

   let markAsInstructionStart rawOffset ilOffset = 
       let lab = rawToLabel rawOffset
       ilOffsetsOfLabels.[lab] <- ilOffset

   let ibuf = new ResizeArray<_>(sz/2)
   let curr = ref 0
   let prefixes = { al=Aligned; tl= Normalcall; vol= Nonvolatile;ro=NormalAddress;constrained=None }
   let lastb = ref 0x0
   let lastb2 = ref 0x0
   let b = ref 0x0
   let get () = 
D
Don Syme 已提交
2659 2660
       lastb := seekReadByteAsInt32 ctxt.is (start + (!curr))
       incr curr
L
latkin 已提交
2661 2662
       b := 
         if !lastb = 0xfe && !curr < sz then 
D
Don Syme 已提交
2663 2664
           lastb2 := seekReadByteAsInt32 ctxt.is (start + (!curr))
           incr curr
L
latkin 已提交
2665 2666 2667 2668 2669 2670 2671 2672
           !lastb2
         else 
           !lastb

   let seqPointsRemaining = ref seqpoints

   while !curr < sz do
     // registering "+string !curr+" as start of an instruction")
D
Don Syme 已提交
2673
     markAsInstructionStart !curr ibuf.Count
L
latkin 已提交
2674 2675 2676 2677 2678 2679 2680 2681 2682

     // 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
D
Don Syme 已提交
2683
         seqPointsRemaining := List.tail !seqPointsRemaining
L
latkin 已提交
2684 2685 2686 2687
         ibuf.Add (I_seqpoint tag)

     // Read the prefixes.  Leave lastb and lastb2 holding the instruction byte(s) 
     begin 
D
Don Syme 已提交
2688 2689 2690 2691 2692 2693
       prefixes.al <- Aligned
       prefixes.tl <- Normalcall
       prefixes.vol <- Nonvolatile
       prefixes.ro<-NormalAddress
       prefixes.constrained<-None
       get ()
L
latkin 已提交
2694 2695 2696 2697 2698 2699 2700
       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
D
Don Syme 已提交
2701
         begin
L
latkin 已提交
2702 2703
             if !b = (i_unaligned &&& 0xff) then
               let unal = seekReadByteAsInt32 ctxt.is (start + (!curr))
D
Don Syme 已提交
2704
               incr curr
L
latkin 已提交
2705 2706 2707 2708 2709 2710 2711 2712 2713
               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 ctxt.is (start + (!curr))
D
Don Syme 已提交
2714
                 curr := !curr + 4
2715
                 let typ = seekReadTypeDefOrRef ctxt numtypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec uncoded)
L
latkin 已提交
2716
                 prefixes.constrained <- Some typ
D
Don Syme 已提交
2717
             else prefixes.tl <- Tailcall
D
Don Syme 已提交
2718
         end
D
Don Syme 已提交
2719 2720
         get ()
     end
L
latkin 已提交
2721 2722

     // data for instruction begins at "+string !curr
D
Don Syme 已提交
2723
     // Read and decode the instruction 
L
latkin 已提交
2724 2725 2726 2727 2728 2729 2730 2731
     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 ctxt.is (start + (!curr)) |> uint16
D
Don Syme 已提交
2732
             curr := !curr + 1
L
latkin 已提交
2733 2734 2735
             f prefixes x
         | I_u16_u16_instr f -> 
             let x = seekReadUInt16 ctxt.is (start + (!curr))
D
Don Syme 已提交
2736
             curr := !curr + 2
L
latkin 已提交
2737 2738 2739 2740 2741
             f prefixes x
         | I_none_instr f -> 
             f prefixes 
         | I_i64_instr f ->
             let x = seekReadInt64 ctxt.is (start + (!curr))
D
Don Syme 已提交
2742
             curr := !curr + 8
L
latkin 已提交
2743 2744 2745
             f prefixes x
         | I_i32_i8_instr f ->
             let x = seekReadSByte ctxt.is (start + (!curr)) |> int32
D
Don Syme 已提交
2746
             curr := !curr + 1
L
latkin 已提交
2747 2748 2749
             f prefixes x
         | I_i32_i32_instr f ->
             let x = seekReadInt32 ctxt.is (start + (!curr))
D
Don Syme 已提交
2750
             curr := !curr + 4
L
latkin 已提交
2751 2752 2753
             f prefixes x
         | I_r4_instr f ->
             let x = seekReadSingle ctxt.is (start + (!curr))
D
Don Syme 已提交
2754
             curr := !curr + 4
L
latkin 已提交
2755 2756 2757
             f prefixes x
         | I_r8_instr f ->
             let x = seekReadDouble ctxt.is (start + (!curr))
D
Don Syme 已提交
2758
             curr := !curr + 8
L
latkin 已提交
2759 2760 2761
             f prefixes x
         | I_field_instr f ->
             let (tab,tok) = seekReadUncodedToken ctxt.is (start + (!curr))
D
Don Syme 已提交
2762
             curr := !curr + 4
L
latkin 已提交
2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773
             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 ctxt.is (start + (!curr))
D
Don Syme 已提交
2774
             curr := !curr + 4
L
latkin 已提交
2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791
             let  (VarArgMethodData(enclTyp, cc, nm, argtys, varargs, retty, minst)) =
               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 enclTyp 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"
             | _ ->
2792
               let mspec = mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty, minst)
L
latkin 已提交
2793 2794 2795
               f prefixes (mspec,varargs)
         | I_type_instr f ->
             let uncoded = seekReadUncodedToken ctxt.is (start + (!curr))
D
Don Syme 已提交
2796
             curr := !curr + 4
2797
             let typ = seekReadTypeDefOrRef ctxt numtypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec uncoded)
L
latkin 已提交
2798 2799 2800
             f prefixes typ
         | I_string_instr f ->
             let (tab,idx) = seekReadUncodedToken ctxt.is (start + (!curr))
D
Don Syme 已提交
2801 2802
             curr := !curr + 4
             if tab <> TableNames.UserStrings then dprintn "warning: bad table in user string for ldstr"
L
latkin 已提交
2803 2804 2805 2806
             f prefixes (readUserStringHeap ctxt (idx))

         | I_conditional_i32_instr f ->
             let offsDest =  (seekReadInt32 ctxt.is (start + (!curr)))
D
Don Syme 已提交
2807
             curr := !curr + 4
L
latkin 已提交
2808
             let dest = !curr + offsDest
D
Don Syme 已提交
2809
             f prefixes (rawToLabel dest)
L
latkin 已提交
2810 2811
         | I_conditional_i8_instr f ->
             let offsDest = int (seekReadSByte ctxt.is (start + (!curr)))
D
Don Syme 已提交
2812
             curr := !curr + 1
L
latkin 已提交
2813
             let dest = !curr + offsDest
D
Don Syme 已提交
2814
             f prefixes (rawToLabel dest)
L
latkin 已提交
2815 2816
         | I_unconditional_i32_instr f ->
             let offsDest =  (seekReadInt32 ctxt.is (start + (!curr)))
D
Don Syme 已提交
2817
             curr := !curr + 4
L
latkin 已提交
2818 2819 2820 2821
             let dest = !curr + offsDest
             f prefixes (rawToLabel dest)
         | I_unconditional_i8_instr f ->
             let offsDest = int (seekReadSByte ctxt.is (start + (!curr)))
D
Don Syme 已提交
2822
             curr := !curr + 1
L
latkin 已提交
2823 2824
             let dest = !curr + offsDest
             f prefixes (rawToLabel dest)
D
Don Syme 已提交
2825 2826 2827
         | I_invalid_instr -> 
             dprintn ("invalid instruction: "+string !lastb+ (if !lastb = 0xfe then ","+string !lastb2 else "")) 
             I_ret
L
latkin 已提交
2828 2829
         | I_tok_instr f ->  
             let (tab,idx) = seekReadUncodedToken ctxt.is (start + (!curr))
D
Don Syme 已提交
2830
             curr := !curr + 4
L
latkin 已提交
2831 2832 2833 2834
             (* 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(enclTyp, cc, nm, argtys, retty, minst)) = seekReadMethodDefOrRefNoVarargs ctxt numtypars (uncodedTokenToMethodDefOrRef (tab,idx))
2835
                 ILToken.ILMethod (mkILMethSpecInTy (enclTyp, cc, nm, argtys, retty, minst))
L
latkin 已提交
2836 2837 2838
               elif tab = TableNames.Field then 
                 ILToken.ILField (seekReadFieldDefAsFieldSpec ctxt idx)
               elif tab = TableNames.TypeDef || tab = TableNames.TypeRef || tab = TableNames.TypeSpec  then 
2839
                 ILToken.ILType (seekReadTypeDefOrRef ctxt numtypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec (tab,idx))) 
L
latkin 已提交
2840 2841 2842 2843
               else failwith "bad token for ldtoken" 
             f prefixes token_info
         | I_sig_instr f ->  
             let (tab,idx) = seekReadUncodedToken ctxt.is (start + (!curr))
D
Don Syme 已提交
2844 2845
             curr := !curr + 4
             if tab <> TableNames.StandAloneSig then dprintn "strange table for callsig token"
L
latkin 已提交
2846
             let generic,_genarity,cc,retty,argtys,varargs = readBlobHeapAsMethodSig ctxt numtypars (seekReadStandAloneSigRow ctxt idx)
D
Don Syme 已提交
2847
             if generic then failwith "bad image: a generic method signature ctxt.is begin used at a calli instruction"
2848
             f prefixes (mkILCallSig (cc,argtys,retty), varargs)
L
latkin 已提交
2849 2850
         | I_switch_instr f ->  
             let n =  (seekReadInt32 ctxt.is (start + (!curr)))
D
Don Syme 已提交
2851
             curr := !curr + 4
L
latkin 已提交
2852 2853 2854
             let offsets = 
               List.init n (fun _ -> 
                   let i =  (seekReadInt32 ctxt.is (start + (!curr)))
D
Don Syme 已提交
2855
                   curr := !curr + 4 
L
latkin 已提交
2856 2857
                   i) 
             let dests = List.map (fun offs -> rawToLabel (!curr + offs)) offsets
D
Don Syme 已提交
2858
             f prefixes dests
L
latkin 已提交
2859
       ibuf.Add instr
D
Don Syme 已提交
2860
   done
L
latkin 已提交
2861
   // Finished reading instructions - mark the end of the instruction stream in case the PDB information refers to it. 
D
Don Syme 已提交
2862
   markAsInstructionStart !curr ibuf.Count
L
latkin 已提交
2863
   // Build the function that maps from raw labels (offsets into the bytecode stream) to indexes in the AbsIL instruction stream 
D
Don Syme 已提交
2864
   let lab2pc = ilOffsetsOfLabels
L
latkin 已提交
2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880

   // 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 tryRawToLabel x with 
           | None -> false
           | Some lab -> ilOffsetsOfLabels.ContainsKey lab
       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

2881
#if FX_NO_PDB_READER
2882
and seekReadMethodRVA ctxt (_idx,nm,_internalcall,noinline,aggressiveinline,numtypars) rva = 
L
latkin 已提交
2883
#else
2884
and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,aggressiveinline,numtypars) rva = 
L
latkin 已提交
2885 2886 2887 2888 2889 2890 2891 2892 2893 2894
#endif
  mkMethBodyLazyAux 
   (lazy
     begin 

       // 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 = 
2895
#if FX_NO_PDB_READER
L
latkin 已提交
2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906
           [], None, []
#else
           match ctxt.pdb with 
           | None -> 
               [], None, []
           | Some (pdbr, get_doc) -> 
               try 

                 let pdbm = pdbReaderGetMethod pdbr (uncodedToken TableNames.Method idx)
                 //let rootScope = pdbMethodGetRootScope pdbm 
                 let sps = pdbMethodGetSequencePoints pdbm
D
Don Syme 已提交
2907
                 (*dprintf "#sps for 0x%x = %d\n" (uncodedToken TableNames.Method idx) (Array.length sps)  *)
L
latkin 已提交
2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921
                 (* 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 = 
                             ILSourceMarker.Create(document = sourcedoc,
                                                 line = sp.pdbSeqPointLine,
                                                 column = sp.pdbSeqPointColumn,
                                                 endLine = sp.pdbSeqPointEndLine,
                                                 endColumn = sp.pdbSeqPointEndColumn)
                           (sp.pdbSeqPointOffset,source))
                         
D
Don Syme 已提交
2922
                    Array.sortInPlaceBy fst arr
L
latkin 已提交
2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933
                    
                    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 *)) 
D
Don Syme 已提交
2934
                       let ilinfos : ILLocalDebugMapping list =
L
latkin 已提交
2935 2936 2937
                         ilvs |> List.map (fun ilv -> 
                             let _k,idx = pdbVariableGetAddressAttributes ilv
                             let n = pdbVariableGetName ilv
D
Don Syme 已提交
2938
                             { LocalIndex=  idx 
L
latkin 已提交
2939 2940 2941 2942
                               LocalName=n})
                           
                       let thisOne = 
                         (fun raw2nextLab ->
D
Don Syme 已提交
2943
                           { Range= (raw2nextLab a,raw2nextLab b) 
D
Don Syme 已提交
2944
                             DebugMappings = ilinfos } : ILLocalDebugInfo )
L
latkin 已提交
2945 2946 2947 2948 2949 2950 2951 2952
                       let others = List.foldBack (scopes >> (@)) (Array.toList (pdbScopeGetChildren scp)) []
                       thisOne :: others
                 let localPdbInfos = [] (* <REVIEW> scopes fail for mscorlib </REVIEW> 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,[]
2953
#endif
L
latkin 已提交
2954 2955 2956 2957 2958 2959 2960
       
       let baseRVA = ctxt.anyV2P("method rva",rva)
       // ": reading body of method "+nm+" at rva "+string rva+", phys "+string baseRVA
       let b = seekReadByte ctxt.is baseRVA
       if (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_TinyFormat then 
           let codeBase = baseRVA + 1
           let codeSize =  (int32 b >>>& 2)
D
Don Syme 已提交
2961
           // tiny format for "+nm+", code size = " + string codeSize)
L
latkin 已提交
2962 2963 2964
           let instrs,_,lab2pc,raw2nextLab = seekReadTopCode ctxt numtypars codeSize codeBase seqpoints
           (* Convert the linear code format to the nested code format *)
           let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos
D
Don Syme 已提交
2965
           let code = buildILCode nm lab2pc instrs [] localPdbInfos2
L
latkin 已提交
2966
           MethodBody.IL
D
Don Syme 已提交
2967 2968 2969
             { IsZeroInit=false
               MaxStack= 8
               NoInlining=noinline
2970
               AggressiveInlining=aggressiveinline
2971
               Locals=List.empty
D
Don Syme 已提交
2972
               SourceMarker=methRangePdbInfo 
L
latkin 已提交
2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984
               Code=code }

       elif (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_FatFormat then 
           let hasMoreSections = (b &&& e_CorILMethod_MoreSects) <> 0x0uy
           let initlocals = (b &&& e_CorILMethod_InitLocals) <> 0x0uy
           let maxstack = seekReadUInt16AsInt32 ctxt.is (baseRVA + 2)
           let codeSize = seekReadInt32 ctxt.is (baseRVA + 4)
           let localsTab,localToken = seekReadUncodedToken ctxt.is (baseRVA + 8)
           let codeBase = baseRVA + 12
           let locals = 
             if localToken = 0x0 then [] 
             else 
D
Don Syme 已提交
2985
               if localsTab <> TableNames.StandAloneSig then dprintn "strange table for locals token"
L
latkin 已提交
2986 2987
               readBlobHeapAsLocalsSig ctxt numtypars (seekReadStandAloneSigRow ctxt localToken) 
             
D
Don Syme 已提交
2988
           // fat format for "+nm+", code size = " + string codeSize+", hasMoreSections = "+(if hasMoreSections then "true" else "false")+",b = "+string b)
L
latkin 已提交
2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000
           
           // Read the method body 
           let instrs,rawToLabel,lab2pc,raw2nextLab = seekReadTopCode ctxt numtypars ( codeSize) codeBase seqpoints

           // Read all the sections that follow the method body. 
           // These contain the exception clauses. 
           let nextSectionBase = ref (align 4 (codeBase + codeSize))
           let moreSections = ref hasMoreSections
           let seh = ref []
           while !moreSections do
             let sectionBase = !nextSectionBase
             let sectionFlag = seekReadByte ctxt.is sectionBase
D
Don Syme 已提交
3001
             // fat format for "+nm+", sectionFlag = " + string sectionFlag)
L
latkin 已提交
3002 3003 3004
             let sectionSize, clauses = 
               if (sectionFlag &&& e_CorILMethod_Sect_FatFormat) <> 0x0uy then 
                   let bigSize = (seekReadInt32 ctxt.is sectionBase) >>>& 8
D
Don Syme 已提交
3005
                   // bigSize = "+string bigSize)
L
latkin 已提交
3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031
                   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 ctxt.is (clauseBase + 0)
                               let st1 = seekReadInt32 ctxt.is (clauseBase + 4)
                               let sz1 = seekReadInt32 ctxt.is (clauseBase + 8)
                               let st2 = seekReadInt32 ctxt.is (clauseBase + 12)
                               let sz2 = seekReadInt32 ctxt.is (clauseBase + 16)
                               let extra = seekReadInt32 ctxt.is (clauseBase + 20)
                               (kind,st1,sz1,st2,sz2,extra))
                       else []
                   bigSize, clauses
               else 
                 let smallSize = seekReadByteAsInt32 ctxt.is (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)
D
Don Syme 已提交
3032
                       // dprintn (nm+" has " + string numClauses + " tiny seh clauses")
L
latkin 已提交
3033 3034 3035
                       List.init numClauses (fun i -> 
                           let clauseBase = sectionBase + 4 + (i * 12)
                           let kind = seekReadUInt16AsInt32 ctxt.is (clauseBase + 0)
D
Don Syme 已提交
3036
                           if logging then dprintn ("One tiny SEH clause, kind = "+string kind)
L
latkin 已提交
3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058
                           let st1 = seekReadUInt16AsInt32 ctxt.is (clauseBase + 2)
                           let sz1 = seekReadByteAsInt32 ctxt.is (clauseBase + 4)
                           let st2 = seekReadUInt16AsInt32 ctxt.is (clauseBase + 5)
                           let sz2 = seekReadByteAsInt32 ctxt.is (clauseBase + 7)
                           let extra = seekReadInt32 ctxt.is (clauseBase + 8)
                           (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) 
        
                List.iter
                  (fun (kind,st1,sz1,st2,sz2,extra) ->
                    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 
3059
                        ILExceptionClause.TypeCatch(seekReadTypeDefOrRef ctxt numtypars AsObject List.empty (uncodedTokenToTypeDefOrRefOrSpec (i32ToUncodedToken extra)), (handlerStart, handlerFinish) )
L
latkin 已提交
3060 3061 3062 3063 3064 3065 3066 3067 3068
                      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
D
Don Syme 已提交
3069
                        dprintn (ctxt.infile + ": unknown exception handler kind: "+string kind)
L
latkin 已提交
3070 3071 3072 3073 3074 3075 3076 3077 3078
                        ILExceptionClause.Finally(handlerStart, handlerFinish)
                      end
                   
                    let key =  (tryStart, tryFinish)
                    if sehMap.ContainsKey key then 
                        let prev = sehMap.[key]
                        sehMap.[key] <- (prev @ [clause])
                    else 
                        sehMap.[key] <- [clause])
D
Don Syme 已提交
3079
                  clauses
D
Don Syme 已提交
3080
                ([],sehMap) ||> Seq.fold  (fun acc (KeyValue(key,bs)) -> [ for b in bs -> {Range=key; Clause=b} : ILExceptionSpec ] @ acc)  
D
Don Syme 已提交
3081 3082 3083 3084
             seh := sehClauses
             moreSections := (sectionFlag &&& e_CorILMethod_Sect_MoreSects) <> 0x0uy
             nextSectionBase := sectionBase + sectionSize
           done (* while *)
L
latkin 已提交
3085 3086

           (* Convert the linear code format to the nested code format *)
D
Don Syme 已提交
3087
           if logging then dprintn ("doing localPdbInfos2") 
L
latkin 已提交
3088
           let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos
D
Don Syme 已提交
3089
           if logging then dprintn ("done localPdbInfos2, checking code...") 
D
Don Syme 已提交
3090
           let code = buildILCode nm lab2pc instrs !seh localPdbInfos2
D
Don Syme 已提交
3091
           if logging then dprintn ("done checking code.") 
L
latkin 已提交
3092
           MethodBody.IL
D
Don Syme 已提交
3093 3094 3095
             { IsZeroInit=initlocals
               MaxStack= maxstack
               NoInlining=noinline
3096
               AggressiveInlining=aggressiveinline
3097
               Locals = locals
D
Don Syme 已提交
3098
               Code=code
L
latkin 已提交
3099 3100
               SourceMarker=methRangePdbInfo}
       else 
D
Don Syme 已提交
3101
           if logging then failwith "unknown format"
L
latkin 已提交
3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113
           MethodBody.Abstract
     end)

and int32AsILVariantType ctxt (n:int32) = 
    if List.memAssoc n (Lazy.force ILVariantTypeRevMap) then 
      List.assoc n (Lazy.force ILVariantTypeRevMap)
    elif (n &&& vt_ARRAY) <> 0x0 then ILNativeVariant.Array (int32AsILVariantType ctxt (n &&& (~~~ vt_ARRAY)))
    elif (n &&& vt_VECTOR) <> 0x0 then ILNativeVariant.Vector (int32AsILVariantType ctxt (n &&& (~~~ vt_VECTOR)))
    elif (n &&& vt_BYREF) <> 0x0 then ILNativeVariant.Byref (int32AsILVariantType ctxt (n &&& (~~~ vt_BYREF)))
    else (dprintn (ctxt.infile + ": int32AsILVariantType ctxt: unexpected variant type, n = "+string n) ; ILNativeVariant.Empty)

and readBlobHeapAsNativeType ctxt blobIdx = 
D
Don Syme 已提交
3114
    // reading native type blob "+string blobIdx) 
L
latkin 已提交
3115 3116 3117 3118 3119
    let bytes = readBlobHeap ctxt blobIdx
    let res,_ = sigptrGetILNativeType ctxt bytes 0
    res

and sigptrGetILNativeType ctxt bytes sigptr = 
D
Don Syme 已提交
3120
    // reading native type blob, sigptr= "+string sigptr) 
L
latkin 已提交
3121 3122 3123 3124 3125
    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 = nt_CUSTOMMARSHALER then  
D
Don Syme 已提交
3126
        // reading native type blob (CM1) , sigptr= "+string sigptr+ ", bytes.Length = "+string bytes.Length) 
L
latkin 已提交
3127
        let guidLen,sigptr = sigptrGetZInt32 bytes sigptr
D
Don Syme 已提交
3128
        // reading native type blob (CM2) , sigptr= "+string sigptr+", guidLen = "+string ( guidLen)) 
L
latkin 已提交
3129
        let guid,sigptr = sigptrGetBytes ( guidLen) bytes sigptr
D
Don Syme 已提交
3130
        // reading native type blob (CM3) , sigptr= "+string sigptr) 
L
latkin 已提交
3131
        let nativeTypeNameLen,sigptr = sigptrGetZInt32 bytes sigptr
D
Don Syme 已提交
3132
        // reading native type blob (CM4) , sigptr= "+string sigptr+", nativeTypeNameLen = "+string ( nativeTypeNameLen)) 
L
latkin 已提交
3133
        let nativeTypeName,sigptr = sigptrGetString ( nativeTypeNameLen) bytes sigptr
D
Don Syme 已提交
3134 3135
        // reading native type blob (CM4) , sigptr= "+string sigptr+", nativeTypeName = "+nativeTypeName) 
        // reading native type blob (CM5) , sigptr= "+string sigptr) 
L
latkin 已提交
3136
        let custMarshallerNameLen,sigptr = sigptrGetZInt32 bytes sigptr
D
Don Syme 已提交
3137
        // reading native type blob (CM6) , sigptr= "+string sigptr+", custMarshallerNameLen = "+string ( custMarshallerNameLen)) 
L
latkin 已提交
3138
        let custMarshallerName,sigptr = sigptrGetString ( custMarshallerNameLen) bytes sigptr
D
Don Syme 已提交
3139
        // reading native type blob (CM7) , sigptr= "+string sigptr+", custMarshallerName = "+custMarshallerName) 
L
latkin 已提交
3140
        let cookieStringLen,sigptr = sigptrGetZInt32 bytes sigptr
D
Don Syme 已提交
3141
        // reading native type blob (CM8) , sigptr= "+string sigptr+", cookieStringLen = "+string ( cookieStringLen)) 
L
latkin 已提交
3142
        let cookieString,sigptr = sigptrGetBytes ( cookieStringLen) bytes sigptr
D
Don Syme 已提交
3143
        // reading native type blob (CM9) , sigptr= "+string sigptr) 
L
latkin 已提交
3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170
        ILNativeType.Custom (guid,nativeTypeName,custMarshallerName,cookieString), sigptr
    elif ntbyte = nt_FIXEDSYSSTRING then 
      let i,sigptr = sigptrGetZInt32 bytes sigptr
      ILNativeType.FixedSysString i, sigptr
    elif ntbyte = nt_FIXEDARRAY then 
      let 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 i,sigptr = sigptrGetZInt32 bytes sigptr
         if sigptr >= bytes.Length then
           ILNativeType.SafeArray (int32AsILVariantType ctxt i, None), sigptr
         else 
           let 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 u,sigptr' = sigptrGetZInt32 bytes sigptr
           if (u = int nt_MAX) then 
             ILNativeType.Empty, sigptr'
           else
W
WilliamBerryiii 已提交
3171
             // NOTE: go back to start and read native type
L
latkin 已提交
3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183
             sigptrGetILNativeType ctxt bytes sigptr
         if sigptr >= bytes.Length then
           ILNativeType.Array (Some nt,None), sigptr
         else
           let pnum,sigptr = sigptrGetZInt32 bytes sigptr
           if sigptr >= bytes.Length then
             ILNativeType.Array (Some nt,Some(pnum,None)), sigptr
           else 
             let additive,sigptr = 
               if sigptr >= bytes.Length then 0, sigptr
               else sigptrGetZInt32 bytes sigptr
             ILNativeType.Array (Some nt,Some(pnum,Some(additive))), sigptr
D
Don Syme 已提交
3184
    else (ILNativeType.Empty, sigptr)
L
latkin 已提交
3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201
      
and seekReadManifestResources ctxt () = 
    mkILResourcesLazy 
      (lazy
         [ for i = 1 to ctxt.getNumRows TableNames.ManifestResource do
             let (offset,flags,nameIdx,implIdx) = seekReadManifestResourceRow ctxt i
             let scoref = seekReadImplAsScopeRef ctxt implIdx
             let datalab = 
               match scoref with
               | ILScopeRef.Local -> 
                  let start = ctxt.anyV2P ("resource",offset + ctxt.resourcesAddr)
                  let len = seekReadInt32 ctxt.is start
                  ILResourceLocation.Local (fun () -> seekReadBytes ctxt.is (start + 4) len)
               | ILScopeRef.Module mref -> ILResourceLocation.File (mref,offset)
               | ILScopeRef.Assembly aref -> ILResourceLocation.Assembly aref

             let r = 
D
Don Syme 已提交
3202 3203 3204
               { Name= readStringHeap ctxt nameIdx
                 Location = datalab
                 Access = (if (flags &&& 0x01) <> 0x0 then ILResourceAccess.Public else ILResourceAccess.Private)
L
latkin 已提交
3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221
                 CustomAttrs =  seekReadCustomAttrs ctxt (TaggedIndex(hca_ManifestResource, i)) }
             yield r ])


and seekReadNestedExportedTypes ctxt parentIdx = 
    mkILNestedExportedTypesLazy
      (lazy
         [ for i = 1 to ctxt.getNumRows TableNames.ExportedType do
               let (flags,_tok,nameIdx,namespaceIdx,implIdx) = seekReadExportedTypeRow ctxt i
               if not (isTopTypeDef flags) then
                   let (TaggedIndex(tag,idx) ) = implIdx
               //let isTopTypeDef =  (idx = 0 || tag <> i_ExportedType) 
               //if not isTopTypeDef then
                   match tag with 
                   | tag when tag = i_ExportedType && idx = parentIdx  ->
                       let nm = readBlobHeapAsTypeName ctxt (nameIdx,namespaceIdx)
                       yield 
D
Don Syme 已提交
3222 3223 3224
                         { Name=nm
                           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 i
L
latkin 已提交
3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243
                           CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_ExportedType, i)) } 
                   | _ -> () ])
      
and seekReadTopExportedTypes ctxt () = 
    mkILExportedTypesLazy 
      (lazy
           let res = ref []
           for i = 1 to ctxt.getNumRows TableNames.ExportedType do
             let (flags,_tok,nameIdx,namespaceIdx,implIdx) = seekReadExportedTypeRow ctxt i
             if isTopTypeDef flags then 
               let (TaggedIndex(tag,_idx) ) = implIdx
               
               // the nested types will be picked up by their enclosing types
               if tag <> i_ExportedType then
                   let nm = readBlobHeapAsTypeName ctxt (nameIdx,namespaceIdx)
                   
                   let scoref = seekReadImplAsScopeRef ctxt implIdx
                        
                   let entry = 
D
Don Syme 已提交
3244 3245 3246 3247 3248
                     { ScopeRef=scoref
                       Name=nm
                       IsForwarder =   ((flags &&& 0x00200000) <> 0)
                       Access=typeAccessOfFlags flags
                       Nested=seekReadNestedExportedTypes ctxt i
L
latkin 已提交
3249
                       CustomAttrs=seekReadCustomAttrs ctxt (TaggedIndex(hca_ExportedType, i)) } 
D
Don Syme 已提交
3250 3251
                   res := entry :: !res
           done
L
latkin 已提交
3252 3253
           List.rev !res)

D
Don Syme 已提交
3254
#if !FX_NO_PDB_READER
L
latkin 已提交
3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269
let getPdbReader opts infile =  
    match opts.pdbPath with 
    | None -> None
    | Some pdbpath ->
         try 
              let pdbr = pdbReadOpen infile 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),
D
Don Syme 已提交
3270
                                            file = url))
L
latkin 已提交
3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290

              let docfun url = if tab.ContainsKey url then tab.[url] else 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
      
//-----------------------------------------------------------------------
// Crack the binary headers, build a reader context and return the lazy
// read of the AbsIL module.
// ----------------------------------------------------------------------

let rec genOpenBinaryReader infile is opts = 

    (* MSDOS HEADER *)
    let peSignaturePhysLoc = seekReadInt32 is 0x3c

    (* PE HEADER *)
    let peFileHeaderPhysLoc = peSignaturePhysLoc + 0x04
    let peOptionalHeaderPhysLoc = peFileHeaderPhysLoc + 0x14
    let peSignature = seekReadInt32 is (peSignaturePhysLoc + 0)
D
Don Syme 已提交
3291
    if peSignature <>  0x4550 then failwithf "not a PE file - bad magic PE number 0x%08x, is = %A" peSignature is
L
latkin 已提交
3292 3293 3294 3295 3296 3297 3298


    (* PE SIGNATURE *)
    let machine = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 0)
    let numSections = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 2)
    let optHeaderSize = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 16)
    if optHeaderSize <>  0xe0 &&
D
Don Syme 已提交
3299
       optHeaderSize <> 0xf0 then failwith "not a PE file - bad optional header size"
L
latkin 已提交
3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398
    let x64adjust = optHeaderSize - 0xe0
    let only64 = (optHeaderSize = 0xf0)    (* May want to read in the optional header Magic number and check that as well... *)
    let platform = match machine with | 0x8664 -> Some(AMD64) | 0x200 -> Some(IA64) | _ -> Some(X86) 
    let sectionHeadersStartPhysLoc = peOptionalHeaderPhysLoc + optHeaderSize

    let flags = seekReadUInt16AsInt32 is (peFileHeaderPhysLoc + 18)
    let isDll = (flags &&& 0x2000) <> 0x0

   (* OPTIONAL PE HEADER *)
    let _textPhysSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 4)  (* Size of the code (text) section, or the sum of all code sections if there are multiple sections. *)
     (* x86: 000000a0 *) 
    let _initdataPhysSize   = seekReadInt32 is (peOptionalHeaderPhysLoc + 8) (* Size of the initialized data section, or the sum of all such sections if there are multiple data sections. *)
    let _uninitdataPhysSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 12) (* Size of the uninitialized data section, or the sum of all such sections if there are multiple data sections. *)
    let _entrypointAddr      = seekReadInt32 is (peOptionalHeaderPhysLoc + 16) (* RVA of entry point , needs to point to bytes 0xFF 0x25 followed by the RVA+!0x4000000 in a section marked execute/read for EXEs or 0 for DLLs e.g. 0x0000b57e *)
    let _textAddr            = seekReadInt32 is (peOptionalHeaderPhysLoc + 20) (* e.g. 0x0002000 *)
     (* x86: 000000b0 *) 
    let dataSegmentAddr       = seekReadInt32 is (peOptionalHeaderPhysLoc + 24) (* e.g. 0x0000c000 *)
    (*  REVIEW: For now, we'll use the DWORD at offset 24 for x64.  This currently ok since fsc doesn't support true 64-bit image bases,
        but we'll have to fix this up when such support is added. *)    
    let imageBaseReal = if only64 then dataSegmentAddr else seekReadInt32 is (peOptionalHeaderPhysLoc + 28)  (* Image Base Always 0x400000 (see Section 23.1). - QUERY : no it's not always 0x400000, e.g. 0x034f0000 *)
    let alignVirt      = seekReadInt32 is (peOptionalHeaderPhysLoc + 32)   (*  Section Alignment Always 0x2000 (see Section 23.1). *)
    let alignPhys      = seekReadInt32 is (peOptionalHeaderPhysLoc + 36)  (* File Alignment Either 0x200 or 0x1000. *)
     (* x86: 000000c0 *) 
    let _osMajor     = seekReadUInt16 is (peOptionalHeaderPhysLoc + 40)   (*  OS Major Always 4 (see Section 23.1). *)
    let _osMinor     = seekReadUInt16 is (peOptionalHeaderPhysLoc + 42)   (* OS Minor Always 0 (see Section 23.1). *)
    let _userMajor   = seekReadUInt16 is (peOptionalHeaderPhysLoc + 44)   (* User Major Always 0 (see Section 23.1). *)
    let _userMinor   = seekReadUInt16 is (peOptionalHeaderPhysLoc + 46)   (* User Minor Always 0 (see Section 23.1). *)
    let subsysMajor = seekReadUInt16AsInt32 is (peOptionalHeaderPhysLoc + 48)   (* SubSys Major Always 4 (see Section 23.1). *)
    let subsysMinor = seekReadUInt16AsInt32 is (peOptionalHeaderPhysLoc + 50)   (* SubSys Minor Always 0 (see Section 23.1). *)
     (* x86: 000000d0 *) 
    let _imageEndAddr   = seekReadInt32 is (peOptionalHeaderPhysLoc + 56)  (* Image Size: Size, in bytes, of image, including all headers and padding; shall be a multiple of Section Alignment. e.g. 0x0000e000 *)
    let _headerPhysSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 60)  (* Header Size Combined size of MS-DOS Header, PE Header, PE Optional Header and padding; shall be a multiple of the file alignment. *)
    let subsys           = seekReadUInt16 is (peOptionalHeaderPhysLoc + 68)   (* SubSystem Subsystem required to run this image. Shall be either IMAGE_SUBSYSTEM_WINDOWS_CE_GUI (!0x3) or IMAGE_SUBSYSTEM_WINDOWS_GUI (!0x2). QUERY: Why is this 3 on the images ILASM produces??? *)
    let useHighEnthropyVA = 
        let n = seekReadUInt16 is (peOptionalHeaderPhysLoc + 70)
        let highEnthropyVA = 0x20us
        (n &&& highEnthropyVA) = highEnthropyVA

     (* x86: 000000e0 *) 

    (* WARNING: THESE ARE 64 bit ON x64/ia64 *)
    (*  REVIEW: If we ever decide that we need these values for x64, we'll have to read them in as 64bit and fix up the rest of the offsets.
        Then again, it should suffice to just use the defaults, and still not bother... *)
    (*  let stackReserve = seekReadInt32 is (peOptionalHeaderPhysLoc + 72) in *)  (* Stack Reserve Size Always 0x100000 (1Mb) (see Section 23.1). *)
    (*   let stackCommit = seekReadInt32 is (peOptionalHeaderPhysLoc + 76) in  *) (* Stack Commit Size Always 0x1000 (4Kb) (see Section 23.1). *)
    (*   let heapReserve = seekReadInt32 is (peOptionalHeaderPhysLoc + 80) in *)  (* Heap Reserve Size Always 0x100000 (1Mb) (see Section 23.1). *)
    (*   let heapCommit = seekReadInt32 is (peOptionalHeaderPhysLoc + 84) in *)  (* Heap Commit Size Always 0x1000 (4Kb) (see Section 23.1). *)

     (* x86: 000000f0, x64: 00000100 *) 
    let _numDataDirectories = seekReadInt32 is (peOptionalHeaderPhysLoc + 92 + x64adjust)   (* Number of Data Directories: Always 0x10 (see Section 23.1). *)
     (* 00000100 - these addresses are for x86 - for the x64 location, add x64adjust (0x10) *) 
    let _importTableAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 104 + x64adjust)   (* Import Table RVA of Import Table, (see clause 24.3.1). e.g. 0000b530 *) 
    let _importTableSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 108 + x64adjust)  (* Size of Import Table, (see clause 24.3.1).  *)
    let nativeResourcesAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 112 + x64adjust)
    let nativeResourcesSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 116 + x64adjust)
     (* 00000110 *) 
     (* 00000120 *) 
  (*   let base_relocTableNames.addr = seekReadInt32 is (peOptionalHeaderPhysLoc + 136)
    let base_relocTableNames.size = seekReadInt32 is (peOptionalHeaderPhysLoc + 140) in  *)
     (* 00000130 *) 
     (* 00000140 *) 
     (* 00000150 *) 
    let _importAddrTableAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 192 + x64adjust)   (* RVA of Import Addr Table, (see clause 24.3.1). e.g. 0x00002000 *) 
    let _importAddrTableSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 196 + x64adjust)  (* Size of Import Addr Table, (see clause 24.3.1). e.g. 0x00002000 *) 
     (* 00000160 *) 
    let cliHeaderAddr = seekReadInt32 is (peOptionalHeaderPhysLoc + 208 + x64adjust)
    let _cliHeaderSize = seekReadInt32 is (peOptionalHeaderPhysLoc + 212 + x64adjust)
     (* 00000170 *) 


    (* Crack section headers *)

    let sectionHeaders = 
      [ for i in 0 .. numSections-1 do
          let pos = sectionHeadersStartPhysLoc + i * 0x28
          let virtSize = seekReadInt32 is (pos + 8)
          let virtAddr = seekReadInt32 is (pos + 12)
          let physLoc = seekReadInt32 is (pos + 20)
          yield (virtAddr,virtSize,physLoc) ]

    let findSectionHeader addr = 
      let rec look i pos = 
        if i >= numSections then 0x0 
        else
          let virtSize = seekReadInt32 is (pos + 8)
          let virtAddr = seekReadInt32 is (pos + 12)
          if (addr >= virtAddr && addr < virtAddr + virtSize) then pos 
          else look (i+1) (pos + 0x28)
      look 0 sectionHeadersStartPhysLoc
    
    let textHeaderStart = findSectionHeader cliHeaderAddr
    let dataHeaderStart = findSectionHeader dataSegmentAddr
  (*  let relocHeaderStart = findSectionHeader base_relocTableNames.addr in  *)

    let _textSize = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 is (textHeaderStart + 8)
    let _textAddr = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 is (textHeaderStart + 12)
    let textSegmentPhysicalSize = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 is (textHeaderStart + 16)
    let textSegmentPhysicalLoc = if textHeaderStart = 0x0 then 0x0 else seekReadInt32 is (textHeaderStart + 20)

D
Don Syme 已提交
3399 3400 3401
    if logging then dprintn (infile + ": textHeaderStart = "+string textHeaderStart)
    if logging then dprintn (infile + ": dataHeaderStart = "+string dataHeaderStart)
    if logging then  dprintn (infile + ": dataSegmentAddr (pre section crack) = "+string dataSegmentAddr)
L
latkin 已提交
3402 3403 3404 3405 3406 3407

    let dataSegmentSize = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 8)
    let dataSegmentAddr = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 12)
    let dataSegmentPhysicalSize = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 16)
    let dataSegmentPhysicalLoc = if dataHeaderStart = 0x0 then 0x0 else seekReadInt32 is (dataHeaderStart + 20)

D
Don Syme 已提交
3408
    if logging then dprintn (infile + ": dataSegmentAddr (post section crack) = "+string dataSegmentAddr)
L
latkin 已提交
3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420

    let anyV2P (n,v) = 
      let rec look i pos = 
        if i >= numSections then (failwith (infile + ": bad "+n+", rva "+string v); 0x0)
        else
          let virtSize = seekReadInt32 is (pos + 8)
          let virtAddr = seekReadInt32 is (pos + 12)
          let physLoc = seekReadInt32 is (pos + 20)
          if (v >= virtAddr && (v < virtAddr + virtSize)) then (v - virtAddr) + physLoc 
          else look (i+1) (pos + 0x28)
      look 0 sectionHeadersStartPhysLoc

D
Don Syme 已提交
3421 3422 3423 3424 3425
    if logging then dprintn (infile + ": numSections = "+string numSections) 
    if logging then dprintn (infile + ": cliHeaderAddr = "+string cliHeaderAddr) 
    if logging then dprintn (infile + ": cliHeaderPhys = "+string (anyV2P ("cli header",cliHeaderAddr))) 
    if logging then dprintn (infile + ": dataSegmentSize = "+string dataSegmentSize) 
    if logging then dprintn (infile + ": dataSegmentAddr = "+string dataSegmentAddr) 
L
latkin 已提交
3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448

    let cliHeaderPhysLoc = anyV2P ("cli header",cliHeaderAddr)

    let _majorRuntimeVersion = seekReadUInt16 is (cliHeaderPhysLoc + 4)
    let _minorRuntimeVersion = seekReadUInt16 is (cliHeaderPhysLoc + 6)
    let metadataAddr         = seekReadInt32 is (cliHeaderPhysLoc + 8)
    let _metadataSegmentSize         = seekReadInt32 is (cliHeaderPhysLoc + 12)
    let cliFlags             = seekReadInt32 is (cliHeaderPhysLoc + 16)
    
    let ilOnly             = (cliFlags &&& 0x01) <> 0x00
    let only32             = (cliFlags &&& 0x02) <> 0x00
    let is32bitpreferred   = (cliFlags &&& 0x00020003) <> 0x00
    let _strongnameSigned  = (cliFlags &&& 0x08) <> 0x00
    let _trackdebugdata     = (cliFlags &&& 0x010000) <> 0x00
    
    let entryPointToken = seekReadUncodedToken is (cliHeaderPhysLoc + 20)
    let resourcesAddr     = seekReadInt32 is (cliHeaderPhysLoc + 24)
    let resourcesSize     = seekReadInt32 is (cliHeaderPhysLoc + 28)
    let strongnameAddr    = seekReadInt32 is (cliHeaderPhysLoc + 32)
    let _strongnameSize    = seekReadInt32 is (cliHeaderPhysLoc + 36)
    let vtableFixupsAddr = seekReadInt32 is (cliHeaderPhysLoc + 40)
    let _vtableFixupsSize = seekReadInt32 is (cliHeaderPhysLoc + 44)

D
Don Syme 已提交
3449 3450 3451 3452 3453
    if logging then dprintn (infile + ": metadataAddr = "+string metadataAddr) 
    if logging then dprintn (infile + ": resourcesAddr = "+string resourcesAddr) 
    if logging then dprintn (infile + ": resourcesSize = "+string resourcesSize) 
    if logging then dprintn (infile + ": nativeResourcesAddr = "+string nativeResourcesAddr) 
    if logging then dprintn (infile + ": nativeResourcesSize = "+string nativeResourcesSize) 
L
latkin 已提交
3454 3455 3456

    let metadataPhysLoc = anyV2P ("metadata",metadataAddr)
    let magic = seekReadUInt16AsInt32 is metadataPhysLoc
D
Don Syme 已提交
3457
    if magic <> 0x5342 then failwith (infile + ": bad metadata magic number: " + string magic)
L
latkin 已提交
3458
    let magic2 = seekReadUInt16AsInt32 is (metadataPhysLoc + 2)
D
Don Syme 已提交
3459
    if magic2 <> 0x424a then failwith "bad metadata magic number"
L
latkin 已提交
3460 3461 3462 3463 3464 3465 3466 3467 3468
    let _majorMetadataVersion = seekReadUInt16 is (metadataPhysLoc + 4)
    let _minorMetadataVersion = seekReadUInt16 is (metadataPhysLoc + 6)

    let versionLength = seekReadInt32 is (metadataPhysLoc + 12)
    let ilMetadataVersion = seekReadBytes is (metadataPhysLoc + 16) versionLength |> Array.filter (fun b -> b <> 0uy)
    let x = align 0x04 (16 + versionLength)
    let numStreams = seekReadUInt16AsInt32 is (metadataPhysLoc + x + 2)
    let streamHeadersStart = (metadataPhysLoc + x + 4)

D
Don Syme 已提交
3469 3470
    if logging then dprintn (infile + ": numStreams = "+string numStreams) 
    if logging then dprintn (infile + ": streamHeadersStart = "+string streamHeadersStart) 
L
latkin 已提交
3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488

  (* Crack stream headers *)

    let tryFindStream name = 
      let rec look i pos = 
        if i >= numStreams then None
        else
          let offset = seekReadInt32 is (pos + 0)
          let length = seekReadInt32 is (pos + 4)
          let res = ref true
          let fin = ref false
          let n = ref 0
          // read and compare the stream name byte by byte 
          while (not !fin) do 
              let c= seekReadByteAsInt32 is (pos + 8 + (!n))
              if c = 0 then 
                  fin := true
              elif !n >= Array.length name || c <> name.[!n] then 
D
Don Syme 已提交
3489
                  res := false
L
latkin 已提交
3490 3491 3492 3493 3494 3495 3496 3497 3498 3499
              incr n
          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
        | None -> (0x0, 0x0)
        | Some positions ->  positions

D
Don Syme 已提交
3500
    let (tablesStreamPhysLoc, _tablesStreamSize) = 
L
latkin 已提交
3501 3502 3503 3504 3505 3506
      match tryFindStream [| 0x23; 0x7e |] (* #~ *) with
      | Some res -> res
      | None -> 
        match tryFindStream [| 0x23; 0x2d |] (* #-: at least one DLL I've seen uses this! *)   with
        | Some res -> res
        | None -> 
D
Don Syme 已提交
3507
         dprintf "no metadata tables found under stream names '#~' or '#-', please report this\n"
L
latkin 已提交
3508 3509 3510 3511 3512 3513 3514 3515 3516 3517
         let firstStreamOffset = seekReadInt32 is (streamHeadersStart + 0)
         let firstStreamLength = seekReadInt32 is (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 tableKinds = 
D
Don Syme 已提交
3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581
        [|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 *)
L
latkin 已提交
3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592
        |]

    let heapSizes = seekReadByteAsInt32 is (tablesStreamPhysLoc + 6)
    let valid = seekReadInt64 is (tablesStreamPhysLoc + 8)
    let sorted = seekReadInt64 is (tablesStreamPhysLoc + 16)
    let tablesPresent, tableRowCount, startOfTables = 
        let present = ref []
        let numRows = Array.create 64 0
        let prevNumRowIdx = ref (tablesStreamPhysLoc + 24)
        for i = 0 to 63 do 
            if (valid &&& (int64 1 <<< i)) <> int64  0 then 
D
Don Syme 已提交
3593 3594
                present := i :: !present
                numRows.[i] <-  (seekReadInt32 is !prevNumRowIdx)
L
latkin 已提交
3595 3596 3597 3598 3599 3600 3601 3602 3603
                prevNumRowIdx := !prevNumRowIdx + 4
        List.rev !present, numRows, !prevNumRowIdx

    let getNumRows (tab:TableName) = tableRowCount.[tab.Index]
    let numTables = tablesPresent.Length
    let stringsBigness = (heapSizes &&& 1) <> 0
    let guidsBigness = (heapSizes &&& 2) <> 0
    let blobsBigness = (heapSizes &&& 4) <> 0

D
Don Syme 已提交
3604 3605 3606
    if logging then dprintn (infile + ": numTables = "+string numTables)
    if logging && stringsBigness then dprintn (infile + ": strings are big")
    if logging && blobsBigness then dprintn (infile + ": blobs are big")
L
latkin 已提交
3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725

    let tableBigness = Array.map (fun n -> n >= 0x10000) tableRowCount
      
    let codedBigness nbits tab =
      let rows = getNumRows tab
      rows >= (0x10000 >>>& nbits)
    
    let tdorBigness = 
      codedBigness 2 TableNames.TypeDef || 
      codedBigness 2 TableNames.TypeRef || 
      codedBigness 2 TableNames.TypeSpec
    
    let tomdBigness = 
      codedBigness 1 TableNames.TypeDef || 
      codedBigness 1 TableNames.Method
    
    let hcBigness = 
      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
    
    let hdsBigness = 
      codedBigness 2 TableNames.TypeDef || 
      codedBigness 2 TableNames.Method ||
      codedBigness 2 TableNames.Assembly
    
    let mrpBigness = 
      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 
    
    let mdorBigness =
      codedBigness 1 TableNames.Method ||    
      codedBigness 1 TableNames.MemberRef 
    
    let mfBigness =
      codedBigness 1 TableNames.Field ||
      codedBigness 1 TableNames.Method 
    
    let iBigness =
      codedBigness 2 TableNames.File || 
      codedBigness 2 TableNames.AssemblyRef ||    
      codedBigness 2 TableNames.ExportedType 
    
    let catBigness =  
      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
      
    let rowKindSize (RowKind kinds) = 
      kinds |> List.sumBy (fun x -> 
            match x with 
            | UShort -> 2
            | ULong -> 4
            | Byte -> 1
            | Data -> 4
            | GGuid -> (if guidsBigness then 4 else 2)
            | Blob  -> (if blobsBigness then 4 else 2)
            | SString  -> (if stringsBigness then 4 else 2)
            | SimpleIndex tab -> (if tableBigness.[tab.Index] then 4 else 2)
            | TypeDefOrRefOrSpec -> (if tdorBigness then 4 else 2)
            | TypeOrMethodDef -> (if tomdBigness then 4 else 2)
            | HasConstant  -> (if hcBigness then 4 else 2)
            | HasCustomAttribute -> (if hcaBigness then 4 else 2)
            | HasFieldMarshal  -> (if hfmBigness then 4 else 2)
            | HasDeclSecurity  -> (if hdsBigness then 4 else 2)
            | MemberRefParent  -> (if mrpBigness then 4 else 2)
            | HasSemantics  -> (if hsBigness then 4 else 2)
            | MethodDefOrRef -> (if mdorBigness then 4 else 2)
            | MemberForwarded -> (if mfBigness then 4 else 2)
            | Implementation  -> (if iBigness then 4 else 2)
            | CustomAttributeType -> (if catBigness then 4 else 2)
            | ResolutionScope -> (if rsBigness then 4 else 2)) 

    let tableRowSizes = tableKinds |> Array.map rowKindSize 

    let tablePhysLocations = 
         let res = Array.create 64 0x0
         let prevTablePhysLoc = ref startOfTables
         for i = 0 to 63 do 
D
Don Syme 已提交
3726 3727 3728
             res.[i] <- !prevTablePhysLoc
             prevTablePhysLoc := !prevTablePhysLoc + (tableRowCount.[i] * tableRowSizes.[i])
             if logging then dprintf "tablePhysLocations.[%d] = %d, offset from startOfTables = 0x%08x\n" i res.[i] (res.[i] -  startOfTables)
L
latkin 已提交
3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767
         res
    
    let inbase = Filename.fileNameOfPath infile + ": "

    // All the caches.  The sizes are guesstimates for the rough sharing-density of the assembly 
    let cacheAssemblyRef               = mkCacheInt32 opts.optimizeForMemory inbase "ILAssemblyRef"  (getNumRows TableNames.AssemblyRef)
    let cacheMethodSpecAsMethodData    = mkCacheGeneric opts.optimizeForMemory inbase "MethodSpecAsMethodData" (getNumRows TableNames.MethodSpec / 20 + 1)
    let cacheMemberRefAsMemberData     = mkCacheGeneric opts.optimizeForMemory inbase "MemberRefAsMemberData" (getNumRows TableNames.MemberRef / 20 + 1)
    let cacheCustomAttr                = mkCacheGeneric opts.optimizeForMemory inbase "CustomAttr" (getNumRows TableNames.CustomAttribute / 50 + 1)
    let cacheTypeRef                   = mkCacheInt32 opts.optimizeForMemory inbase "ILTypeRef" (getNumRows TableNames.TypeRef / 20 + 1)
    let cacheTypeRefAsType             = mkCacheGeneric opts.optimizeForMemory inbase "TypeRefAsType" (getNumRows TableNames.TypeRef / 20 + 1)
    let cacheBlobHeapAsPropertySig     = mkCacheGeneric opts.optimizeForMemory inbase "BlobHeapAsPropertySig" (getNumRows TableNames.Property / 20 + 1)
    let cacheBlobHeapAsFieldSig        = mkCacheGeneric opts.optimizeForMemory inbase "BlobHeapAsFieldSig" (getNumRows TableNames.Field / 20 + 1)
    let cacheBlobHeapAsMethodSig       = mkCacheGeneric opts.optimizeForMemory inbase "BlobHeapAsMethodSig" (getNumRows TableNames.Method / 20 + 1)
    let cacheTypeDefAsType             = mkCacheGeneric opts.optimizeForMemory inbase "TypeDefAsType" (getNumRows TableNames.TypeDef / 20 + 1)
    let cacheMethodDefAsMethodData     = mkCacheInt32 opts.optimizeForMemory inbase "MethodDefAsMethodData" (getNumRows TableNames.Method / 20 + 1)
    let cacheGenericParams             = mkCacheGeneric opts.optimizeForMemory inbase "GenericParams" (getNumRows TableNames.GenericParam / 20 + 1)
    let cacheFieldDefAsFieldSpec       = mkCacheInt32 opts.optimizeForMemory inbase "FieldDefAsFieldSpec" (getNumRows TableNames.Field / 20 + 1)
    let cacheUserStringHeap            = mkCacheInt32 opts.optimizeForMemory inbase "UserStringHeap" ( userStringsStreamSize / 20 + 1)
    // nb. Lots and lots of cache hits on this cache, hence never optimize cache away 
    let cacheStringHeap                = mkCacheInt32 false inbase "string heap" ( stringsStreamSize / 50 + 1)
    let cacheBlobHeap                  = mkCacheInt32 opts.optimizeForMemory inbase "blob heap" ( blobsStreamSize / 50 + 1) 

     // These tables are not required to enforce sharing fo the final data 
     // structure, but are very useful as searching these tables gives rise to many reads 
     // in standard applications.  
     
    let cacheNestedRow          = mkCacheInt32 opts.optimizeForMemory inbase "Nested Table Rows" (getNumRows TableNames.Nested / 20 + 1)
    let cacheConstantRow        = mkCacheInt32 opts.optimizeForMemory inbase "Constant Rows" (getNumRows TableNames.Constant / 20 + 1)
    let cacheMethodSemanticsRow = mkCacheInt32 opts.optimizeForMemory inbase "MethodSemantics Rows" (getNumRows TableNames.MethodSemantics / 20 + 1)
    let cacheTypeDefRow         = mkCacheInt32 opts.optimizeForMemory inbase "ILTypeDef Rows" (getNumRows TableNames.TypeDef / 20 + 1)
    let cacheInterfaceImplRow   = mkCacheInt32 opts.optimizeForMemory inbase "InterfaceImpl Rows" (getNumRows TableNames.InterfaceImpl / 20 + 1)
    let cacheFieldMarshalRow    = mkCacheInt32 opts.optimizeForMemory inbase "FieldMarshal Rows" (getNumRows TableNames.FieldMarshal / 20 + 1)
    let cachePropertyMapRow     = mkCacheInt32 opts.optimizeForMemory inbase "PropertyMap Rows" (getNumRows TableNames.PropertyMap / 20 + 1)

    let mkRowCounter _nm  =
       let count = ref 0
#if DEBUG
#if STATISTICS
D
Don Syme 已提交
3768
       addReport (fun oc -> if !count <> 0 then oc.WriteLine (inbase+string !count + " "+_nm+" rows read"))
L
latkin 已提交
3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812
#endif
#else
       _nm |> ignore
#endif
       count

    let countTypeRef                = mkRowCounter "ILTypeRef"
    let countTypeDef                = mkRowCounter "ILTypeDef"
    let countField                  = mkRowCounter "Field"
    let countMethod                 = mkRowCounter "Method"
    let countParam                  = mkRowCounter "Param"
    let countInterfaceImpl          = mkRowCounter "InterfaceImpl"
    let countMemberRef              = mkRowCounter "MemberRef"
    let countConstant               = mkRowCounter "Constant"
    let countCustomAttribute        = mkRowCounter "CustomAttribute"
    let countFieldMarshal           = mkRowCounter "FieldMarshal"
    let countPermission             = mkRowCounter "Permission"
    let countClassLayout            = mkRowCounter "ClassLayout"
    let countFieldLayout            = mkRowCounter "FieldLayout"
    let countStandAloneSig          = mkRowCounter "StandAloneSig"
    let countEventMap               = mkRowCounter "EventMap"
    let countEvent                  = mkRowCounter "Event"
    let countPropertyMap            = mkRowCounter "PropertyMap"
    let countProperty               = mkRowCounter "Property"
    let countMethodSemantics        = mkRowCounter "MethodSemantics"
    let countMethodImpl             = mkRowCounter "MethodImpl"
    let countModuleRef              = mkRowCounter "ILModuleRef"
    let countTypeSpec               = mkRowCounter "ILTypeSpec"
    let countImplMap                = mkRowCounter "ImplMap"
    let countFieldRVA               = mkRowCounter "FieldRVA"
    let countAssembly               = mkRowCounter "Assembly"
    let countAssemblyRef            = mkRowCounter "ILAssemblyRef"
    let countFile                   = mkRowCounter "File"
    let countExportedType           = mkRowCounter "ILExportedTypeOrForwarder"
    let countManifestResource       = mkRowCounter "ManifestResource"
    let countNested                 = mkRowCounter "Nested"
    let countGenericParam           = mkRowCounter "GenericParam"
    let countGenericParamConstraint = mkRowCounter "GenericParamConstraint"
    let countMethodSpec             = mkRowCounter "ILMethodSpec"


   //-----------------------------------------------------------------------
   // Set up the PDB reader so we can read debug info for methods.
   // ----------------------------------------------------------------------
3813
#if FX_NO_PDB_READER
L
latkin 已提交
3814 3815
    let pdb = None
#else
3816 3817 3818 3819 3820
    let pdb = 
        if runningOnMono then 
            None 
        else 
            getPdbReader opts infile
L
latkin 已提交
3821 3822 3823 3824 3825 3826 3827 3828
#endif

    let rowAddr (tab:TableName) idx = tablePhysLocations.[tab.Index] + (idx - 1) * tableRowSizes.[tab.Index]


    // Build the reader context
    // Use an initialization hole 
    let ctxtH = ref None
D
Don Syme 已提交
3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932
    let ctxt = { ilg=opts.ilGlobals 
                 dataEndPoints = dataEndPoints ctxtH
                 pdb=pdb
                 sorted=sorted
                 getNumRows=getNumRows 
                 textSegmentPhysicalLoc=textSegmentPhysicalLoc 
                 textSegmentPhysicalSize=textSegmentPhysicalSize
                 dataSegmentPhysicalLoc=dataSegmentPhysicalLoc
                 dataSegmentPhysicalSize=dataSegmentPhysicalSize
                 anyV2P=anyV2P
                 metadataAddr=metadataAddr
                 sectionHeaders=sectionHeaders
                 nativeResourcesAddr=nativeResourcesAddr
                 nativeResourcesSize=nativeResourcesSize
                 resourcesAddr=resourcesAddr
                 strongnameAddr=strongnameAddr
                 vtableFixupsAddr=vtableFixupsAddr
                 is=is
                 infile=infile
                 userStringsStreamPhysicalLoc   = userStringsStreamPhysicalLoc
                 stringsStreamPhysicalLoc       = stringsStreamPhysicalLoc
                 blobsStreamPhysicalLoc         = blobsStreamPhysicalLoc
                 blobsStreamSize                = blobsStreamSize
                 memoizeString                  = Tables.memoize id
                 readUserStringHeap             = cacheUserStringHeap (readUserStringHeapUncached ctxtH)
                 readStringHeap                 = cacheStringHeap (readStringHeapUncached ctxtH)
                 readBlobHeap                   = cacheBlobHeap (readBlobHeapUncached ctxtH)
                 seekReadNestedRow              = cacheNestedRow  (seekReadNestedRowUncached ctxtH)
                 seekReadConstantRow            = cacheConstantRow  (seekReadConstantRowUncached ctxtH)
                 seekReadMethodSemanticsRow     = cacheMethodSemanticsRow  (seekReadMethodSemanticsRowUncached ctxtH)
                 seekReadTypeDefRow             = cacheTypeDefRow  (seekReadTypeDefRowUncached ctxtH)
                 seekReadInterfaceImplRow       = cacheInterfaceImplRow  (seekReadInterfaceImplRowUncached ctxtH)
                 seekReadFieldMarshalRow        = cacheFieldMarshalRow  (seekReadFieldMarshalRowUncached ctxtH)
                 seekReadPropertyMapRow         = cachePropertyMapRow  (seekReadPropertyMapRowUncached ctxtH)
                 seekReadAssemblyRef            = cacheAssemblyRef  (seekReadAssemblyRefUncached ctxtH)
                 seekReadMethodSpecAsMethodData = cacheMethodSpecAsMethodData  (seekReadMethodSpecAsMethodDataUncached ctxtH)
                 seekReadMemberRefAsMethodData  = cacheMemberRefAsMemberData  (seekReadMemberRefAsMethodDataUncached ctxtH)
                 seekReadMemberRefAsFieldSpec   = seekReadMemberRefAsFieldSpecUncached ctxtH
                 seekReadCustomAttr             = cacheCustomAttr  (seekReadCustomAttrUncached ctxtH)
                 seekReadSecurityDecl           = seekReadSecurityDeclUncached ctxtH
                 seekReadTypeRef                = cacheTypeRef (seekReadTypeRefUncached ctxtH)
                 readBlobHeapAsPropertySig      = cacheBlobHeapAsPropertySig (readBlobHeapAsPropertySigUncached ctxtH)
                 readBlobHeapAsFieldSig         = cacheBlobHeapAsFieldSig (readBlobHeapAsFieldSigUncached ctxtH)
                 readBlobHeapAsMethodSig        = cacheBlobHeapAsMethodSig (readBlobHeapAsMethodSigUncached ctxtH)
                 readBlobHeapAsLocalsSig        = readBlobHeapAsLocalsSigUncached ctxtH
                 seekReadTypeDefAsType          = cacheTypeDefAsType (seekReadTypeDefAsTypeUncached ctxtH)
                 seekReadTypeRefAsType          = cacheTypeRefAsType (seekReadTypeRefAsTypeUncached ctxtH)
                 seekReadMethodDefAsMethodData  = cacheMethodDefAsMethodData (seekReadMethodDefAsMethodDataUncached ctxtH)
                 seekReadGenericParams          = cacheGenericParams (seekReadGenericParamsUncached ctxtH)
                 seekReadFieldDefAsFieldSpec    = cacheFieldDefAsFieldSpec (seekReadFieldDefAsFieldSpecUncached ctxtH)
                 guidsStreamPhysicalLoc = guidsStreamPhysicalLoc
                 rowAddr=rowAddr
                 entryPointToken=entryPointToken 
                 rsBigness=rsBigness
                 tdorBigness=tdorBigness
                 tomdBigness=tomdBigness   
                 hcBigness=hcBigness   
                 hcaBigness=hcaBigness   
                 hfmBigness=hfmBigness   
                 hdsBigness=hdsBigness
                 mrpBigness=mrpBigness
                 hsBigness=hsBigness
                 mdorBigness=mdorBigness
                 mfBigness=mfBigness
                 iBigness=iBigness
                 catBigness=catBigness 
                 stringsBigness=stringsBigness
                 guidsBigness=guidsBigness
                 blobsBigness=blobsBigness
                 tableBigness=tableBigness
                 countTypeRef                = countTypeRef             
                 countTypeDef                = countTypeDef             
                 countField                  = countField               
                 countMethod                 = countMethod              
                 countParam                  = countParam               
                 countInterfaceImpl          = countInterfaceImpl       
                 countMemberRef              = countMemberRef           
                 countConstant               = countConstant            
                 countCustomAttribute        = countCustomAttribute     
                 countFieldMarshal           = countFieldMarshal        
                 countPermission             = countPermission         
                 countClassLayout            = countClassLayout        
                 countFieldLayout            = countFieldLayout         
                 countStandAloneSig          = countStandAloneSig       
                 countEventMap               = countEventMap            
                 countEvent                  = countEvent               
                 countPropertyMap            = countPropertyMap         
                 countProperty               = countProperty            
                 countMethodSemantics        = countMethodSemantics     
                 countMethodImpl             = countMethodImpl          
                 countModuleRef              = countModuleRef           
                 countTypeSpec               = countTypeSpec            
                 countImplMap                = countImplMap             
                 countFieldRVA               = countFieldRVA            
                 countAssembly               = countAssembly            
                 countAssemblyRef            = countAssemblyRef         
                 countFile                   = countFile                
                 countExportedType           = countExportedType        
                 countManifestResource       = countManifestResource    
                 countNested                 = countNested              
                 countGenericParam           = countGenericParam              
                 countGenericParamConstraint = countGenericParamConstraint              
                 countMethodSpec             = countMethodSpec  } 
    ctxtH := Some ctxt
L
latkin 已提交
3933 3934 3935 3936 3937 3938 3939
     
    let ilModule = seekReadModule ctxt (subsys, (subsysMajor, subsysMinor), useHighEnthropyVA, ilOnly,only32,is32bitpreferred,only64,platform,isDll, alignVirt,alignPhys,imageBaseReal,System.Text.Encoding.UTF8.GetString (ilMetadataVersion, 0, ilMetadataVersion.Length)) 1
    let ilAssemblyRefs = lazy [ for i in 1 .. getNumRows TableNames.AssemblyRef do yield seekReadAssemblyRef ctxt i ]

    ilModule,ilAssemblyRefs,pdb
  
let mkDefault ilg = 
D
Don Syme 已提交
3940 3941
    { optimizeForMemory=false 
      pdbPath= None 
L
latkin 已提交
3942 3943
      ilGlobals = ilg } 

3944
let ClosePdbReader pdb =  
3945
#if FX_NO_PDB_READER
3946 3947
    ignore pdb
    ()
L
latkin 已提交
3948 3949 3950 3951 3952 3953 3954 3955 3956
#else
    match pdb with 
    | Some (pdbr,_) -> pdbReadClose pdbr
    | None -> ()
#endif

let OpenILModuleReader infile opts = 

   try 
D
Don Syme 已提交
3957 3958
        let mmap = MemoryMappedFile.Create infile
        let modul,ilAssemblyRefs,pdb = genOpenBinaryReader infile mmap opts
D
Don Syme 已提交
3959 3960
        { modul = modul 
          ilAssemblyRefs=ilAssemblyRefs
L
latkin 已提交
3961
          dispose = (fun () -> 
D
Don Syme 已提交
3962
            mmap.Close()
L
latkin 已提交
3963
            ClosePdbReader pdb) }
D
Don Syme 已提交
3964
    with _ ->
3965
        let mc = ByteFile(infile |> FileSystem.ReadAllBytesShim)
D
Don Syme 已提交
3966
        let modul,ilAssemblyRefs,pdb = genOpenBinaryReader infile mc opts
D
Don Syme 已提交
3967 3968
        { modul = modul 
          ilAssemblyRefs = ilAssemblyRefs
L
latkin 已提交
3969 3970 3971
          dispose = (fun () -> 
            ClosePdbReader pdb) }

3972 3973
// ++GLOBAL MUTABLE STATE (concurrency safe via locking)
type ILModuleReaderCacheLockToken() = interface LockToken
3974
let ilModuleReaderCache = new AgedLookup<ILModuleReaderCacheLockToken, (string * System.DateTime * ILScopeRef * bool), ILModuleReader>(0, areSimilar=(fun (x,y) -> x = y))
3975
let ilModuleReaderCacheLock = Lock()
L
latkin 已提交
3976 3977 3978 3979

let OpenILModuleReaderAfterReadingAllBytes infile opts = 
    // Pseudo-normalize the paths.
    let key,succeeded = 
D
Don Syme 已提交
3980 3981 3982 3983 3984
        try 
           (FileSystem.GetFullPathShim(infile), 
            FileSystem.GetLastWriteTimeShim(infile), 
            opts.ilGlobals.primaryAssemblyScopeRef,
            opts.pdbPath.IsSome), true
L
latkin 已提交
3985
        with e -> 
D
Don Syme 已提交
3986 3987 3988
            System.Diagnostics.Debug.Assert(false, sprintf "Failed to compute key in OpenILModuleReaderAfterReadingAllBytes cache for '%s'. Falling back to uncached." infile) 
            ("",System.DateTime.Now,ILScopeRef.Local,false), false

L
latkin 已提交
3989 3990 3991
    let cacheResult = 
        if not succeeded then None // Fall back to uncached.
        else if opts.pdbPath.IsSome then None // can't used a cached entry when reading PDBs, since it makes the returned object IDisposable
3992
        else ilModuleReaderCacheLock.AcquireLock (fun ltok -> ilModuleReaderCache.TryGet(ltok, key))
D
Don Syme 已提交
3993

L
latkin 已提交
3994 3995 3996
    match cacheResult with 
    | Some(ilModuleReader) -> ilModuleReader
    | None -> 
3997
        let mc = ByteFile(infile |> FileSystem.ReadAllBytesShim)
D
Don Syme 已提交
3998
        let modul,ilAssemblyRefs,pdb = genOpenBinaryReader infile mc opts
L
latkin 已提交
3999
        let ilModuleReader = 
D
Don Syme 已提交
4000
            { modul = modul 
L
latkin 已提交
4001 4002
              ilAssemblyRefs = ilAssemblyRefs
              dispose = (fun () -> ClosePdbReader pdb) }
4003
        if Option.isNone pdb && succeeded then 
4004
            ilModuleReaderCacheLock.AcquireLock (fun ltok -> ilModuleReaderCache.Put(ltok, key, ilModuleReader))
L
latkin 已提交
4005 4006 4007 4008
        ilModuleReader

let OpenILModuleReaderFromBytes fileNameForDebugOutput bytes opts = 
        assert opts.pdbPath.IsNone
4009
        let mc = ByteFile(bytes)
D
Don Syme 已提交
4010
        let modul,ilAssemblyRefs,pdb = genOpenBinaryReader fileNameForDebugOutput mc opts
L
latkin 已提交
4011
        let ilModuleReader = 
D
Don Syme 已提交
4012
            { modul = modul 
L
latkin 已提交
4013 4014 4015 4016 4017 4018 4019
              ilAssemblyRefs = ilAssemblyRefs
              dispose = (fun () -> ClosePdbReader pdb) }
        ilModuleReader