open System.Collections.Generic

open System.IO

open Internal.Utilities

open Microsoft.FSharp.Compiler.AbstractIL

open Microsoft.FSharp.Compiler.AbstractIL.ILAsciiWriter

open Microsoft.FSharp.Compiler.AbstractIL.IL

open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics

open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types

open Microsoft.FSharp.Compiler.AbstractIL.Internal

open Microsoft.FSharp.Compiler.AbstractIL.Internal.BinaryConstants

open Microsoft.FSharp.Compiler.AbstractIL.Internal.Support

open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library

open Microsoft.FSharp.Compiler.AbstractIL.ILPdbWriter

open Microsoft.FSharp.Compiler.DiagnosticMessage

open Microsoft.FSharp.Compiler.ErrorLogger

open Microsoft.FSharp.Compiler.Range

#if FX_NO_CORHOST_SIGNER

open Microsoft.FSharp.Compiler.AbstractIL.Internal.StrongNameSign

#if DEBUG

let showEntryLookups = false

let b0 n = byte (n &&& 0xFF)

let b1 n = byte ((n >>> 8) &&& 0xFF)

let b2 n = byte ((n >>> 16) &&& 0xFF)

let b3 n = byte ((n >>> 24) &&& 0xFF)

let dw7 n = byte ((n >>> 56) &&& 0xFFL)

let dw6 n = byte ((n >>> 48) &&& 0xFFL)

let dw5 n = byte ((n >>> 40) &&& 0xFFL)

let dw4 n = byte ((n >>> 32) &&& 0xFFL)

let dw3 n = byte ((n >>> 24) &&& 0xFFL)

let dw2 n = byte ((n >>> 16) &&& 0xFFL)

let dw1 n = byte ((n >>> 8) &&& 0xFFL)

let dw0 n = byte (n &&& 0xFFL)

let bitsOfSingle (x:float32) = System.BitConverter.ToInt32(System.BitConverter.GetBytes(x),0)

let bitsOfDouble (x:float) = System.BitConverter.DoubleToInt64Bits(x)

let emitBytesViaBuffer f = let bb = ByteBuffer.Create 10 in f bb; bb.Close()

let align alignment n = ((n + alignment - 1) / alignment) * alignment

type ByteBuffer with

/// Z32 = compressed unsigned integer

static member Z32Size n =

if n <= 0x7F then 1

elif n <= 0x3FFF then 2

else 4

/// Emit int32 as compressed unsigned integer

member buf.EmitZ32 n =

if n >= 0 && n <= 0x7F then

buf.EmitIntAsByte n

elif n >= 0x80 && n <= 0x3FFF then

buf.EmitIntAsByte (0x80 ||| (n >>> 8))

buf.EmitIntAsByte (n &&& 0xFF)

else

buf.EmitIntAsByte (0xc0l ||| ((n >>> 24) &&& 0xFF))

buf.EmitIntAsByte ( (n >>> 16) &&& 0xFF)

buf.EmitIntAsByte ( (n >>> 8) &&& 0xFF)

buf.EmitIntAsByte ( n &&& 0xFF)

member buf.EmitPadding n =

for i = 0 to n-1 do

buf.EmitByte 0x0uy

// Emit compressed untagged integer

member buf.EmitZUntaggedIndex big idx =

if big then buf.EmitInt32 idx

elif idx > 0xffff then failwith "EmitZUntaggedIndex: too big for small address or simple index"

else buf.EmitInt32AsUInt16 idx

// Emit compressed tagged integer

member buf.EmitZTaggedIndex tag nbits big idx =

let idx2 = (idx <<< nbits) ||| tag

if big then buf.EmitInt32 idx2

else buf.EmitInt32AsUInt16 idx2

let getUncodedToken (tab:TableName) idx = ((tab.Index <<< 24) ||| idx)

let markerForUnicodeBytes (b:byte[]) =

let len = b.Length

let rec scan i =

i < len/2 &&

(let b1 = Bytes.get b (i*2)

let b2 = Bytes.get b (i*2+1)

(b2 <> 0)

|| (b1 >= 0x01 && b1 <= 0x08) // as per ECMA and C#

|| (b1 >= 0xE && b1 <= 0x1F) // as per ECMA and C#

|| (b1 = 0x27) // as per ECMA and C#

|| (b1 = 0x2D) // as per ECMA and C#

|| (b1 > 0x7F) // as per C# (but ECMA omits this)

|| scan (i+1))

let marker = if scan 0 then 0x01 else 0x00

marker

let checkFixup32 (data: byte[]) offset exp =

if data.[offset + 3] <> b3 exp then failwith "fixup sanity check failed"

if data.[offset + 2] <> b2 exp then failwith "fixup sanity check failed"

if data.[offset + 1] <> b1 exp then failwith "fixup sanity check failed"

if data.[offset] <> b0 exp then failwith "fixup sanity check failed"

let applyFixup32 (data:byte[]) offset v =

data.[offset] <- b0 v

data.[offset+1] <- b1 v

data.[offset+2] <- b2 v

data.[offset+3] <- b3 v

type ILStrongNameSigner =

| PublicKeySigner of Support.pubkey

| PublicKeyOptionsSigner of Support.pubkeyOptions

| KeyPair of Support.keyPair

| KeyContainer of Support.keyContainerName

static member OpenPublicKeyOptions s p = PublicKeyOptionsSigner((Support.signerOpenPublicKeyFile s), p)

static member OpenPublicKey pubkey = PublicKeySigner(pubkey)

static member OpenKeyPairFile s = KeyPair(Support.signerOpenKeyPairFile s)

static member OpenKeyContainer s = KeyContainer(s)

member s.Close() =

match s with

| PublicKeySigner _

| PublicKeyOptionsSigner _

| KeyPair _ -> ()

| KeyContainer containerName -> Support.signerCloseKeyContainer(containerName)

member s.IsFullySigned =

match s with

| PublicKeySigner _ -> false

| PublicKeyOptionsSigner pko -> let _, usePublicSign = pko

usePublicSign

| KeyPair _ | KeyContainer _ -> true

member s.PublicKey =

match s with

| PublicKeySigner pk -> pk

| PublicKeyOptionsSigner pko -> let pk, _ = pko

pk

| KeyPair kp -> Support.signerGetPublicKeyForKeyPair kp

| KeyContainer kn -> Support.signerGetPublicKeyForKeyContainer kn

member s.SignatureSize =

let pkSignatureSize pk =

try Support.signerSignatureSize(pk)

with e ->

failwith ("A call to StrongNameSignatureSize failed ("+e.Message+")")

0x80

match s with

| PublicKeySigner pk -> pkSignatureSize pk

| PublicKeyOptionsSigner pko -> let pk, _ = pko

pkSignatureSize pk

| KeyPair kp -> pkSignatureSize (Support.signerGetPublicKeyForKeyPair kp)

| KeyContainer kn -> pkSignatureSize (Support.signerGetPublicKeyForKeyContainer kn)

member s.SignFile file =

match s with

| PublicKeySigner _ -> ()

| PublicKeyOptionsSigner _ -> ()

| KeyPair kp -> Support.signerSignFileWithKeyPair file kp

| KeyContainer kn -> Support.signerSignFileWithKeyContainer file kn

module RowElementTags =

let [<Literal>] UShort = 0

let [<Literal>] ULong = 1

let [<Literal>] Data = 2

let [<Literal>] DataResources = 3

let [<Literal>] Guid = 4

let [<Literal>] Blob = 5

let [<Literal>] String = 6

let [<Literal>] SimpleIndexMin = 7

let SimpleIndex (t : TableName) = assert (t.Index <= 112); SimpleIndexMin + t.Index

let [<Literal>] SimpleIndexMax = 119

let [<Literal>] TypeDefOrRefOrSpecMin = 120

let TypeDefOrRefOrSpec (t: TypeDefOrRefTag) = assert (t.Tag <= 2); TypeDefOrRefOrSpecMin + t.Tag (* + 111 + 1 = 0x70 + 1 = max TableName.Tndex + 1 *)

let [<Literal>] TypeDefOrRefOrSpecMax = 122

let [<Literal>] TypeOrMethodDefMin = 123

let TypeOrMethodDef (t: TypeOrMethodDefTag) = assert (t.Tag <= 1); TypeOrMethodDefMin + t.Tag (* + 2 + 1 = max TypeDefOrRefOrSpec.Tag + 1 *)

let [<Literal>] TypeOrMethodDefMax = 124

let [<Literal>] HasConstantMin = 125

let HasConstant (t: HasConstantTag) = assert (t.Tag <= 2); HasConstantMin + t.Tag (* + 1 + 1 = max TypeOrMethodDef.Tag + 1 *)

let [<Literal>] HasConstantMax = 127

let [<Literal>] HasCustomAttributeMin = 128

let HasCustomAttribute (t: HasCustomAttributeTag) = assert (t.Tag <= 21); HasCustomAttributeMin + t.Tag (* + 2 + 1 = max HasConstant.Tag + 1 *)

let [<Literal>] HasCustomAttributeMax = 149

let [<Literal>] HasFieldMarshalMin = 150

let HasFieldMarshal (t: HasFieldMarshalTag) = assert (t.Tag <= 1); HasFieldMarshalMin + t.Tag (* + 21 + 1 = max HasCustomAttribute.Tag + 1 *)

let [<Literal>] HasFieldMarshalMax = 151

let [<Literal>] HasDeclSecurityMin = 152

let HasDeclSecurity (t: HasDeclSecurityTag) = assert (t.Tag <= 2); HasDeclSecurityMin + t.Tag (* + 1 + 1 = max HasFieldMarshal.Tag + 1 *)

let [<Literal>] HasDeclSecurityMax = 154

let [<Literal>] MemberRefParentMin = 155

let MemberRefParent (t: MemberRefParentTag) = assert (t.Tag <= 4); MemberRefParentMin + t.Tag (* + 2 + 1 = max HasDeclSecurity.Tag + 1 *)

let [<Literal>] MemberRefParentMax = 159

let [<Literal>] HasSemanticsMin = 160

let HasSemantics (t: HasSemanticsTag) = assert (t.Tag <= 1); HasSemanticsMin + t.Tag (* + 4 + 1 = max MemberRefParent.Tag + 1 *)

let [<Literal>] HasSemanticsMax = 161

let [<Literal>] MethodDefOrRefMin = 162

let MethodDefOrRef (t: MethodDefOrRefTag) = assert (t.Tag <= 2); MethodDefOrRefMin + t.Tag (* + 1 + 1 = max HasSemantics.Tag + 1 *)

let [<Literal>] MethodDefOrRefMax = 164

let [<Literal>] MemberForwardedMin = 165

let MemberForwarded (t: MemberForwardedTag) = assert (t.Tag <= 1); MemberForwardedMin + t.Tag (* + 2 + 1 = max MethodDefOrRef.Tag + 1 *)

let [<Literal>] MemberForwardedMax = 166

let [<Literal>] ImplementationMin = 167

let Implementation (t: ImplementationTag) = assert (t.Tag <= 2); ImplementationMin + t.Tag (* + 1 + 1 = max MemberForwarded.Tag + 1 *)

let [<Literal>] ImplementationMax = 169

let [<Literal>] CustomAttributeTypeMin = 170

let CustomAttributeType (t: CustomAttributeTypeTag) = assert (t.Tag <= 3); CustomAttributeTypeMin + t.Tag (* + 2 + 1 = max Implementation.Tag + 1 *)

let [<Literal>] CustomAttributeTypeMax = 173

let [<Literal>] ResolutionScopeMin = 174

let ResolutionScope (t: ResolutionScopeTag) = assert (t.Tag <= 4); ResolutionScopeMin + t.Tag (* + 3 + 1 = max CustomAttributeType.Tag + 1 *)

let [<Literal>] ResolutionScopeMax = 178

type RowElement(tag:int32, idx: int32) =

member x.Tag = tag

member x.Val = idx

let UShort (x:uint16) = RowElement(RowElementTags.UShort, int32 x)

let ULong (x:int32) = RowElement(RowElementTags.ULong, x)

let Data (x:int, k:bool) = RowElement((if k then RowElementTags.DataResources else RowElementTags.Data ), x)

let Guid (x:int) = RowElement(RowElementTags.Guid, x)

let Blob (x:int) = RowElement(RowElementTags.Blob, x)

let StringE (x:int) = RowElement(RowElementTags.String, x)

let SimpleIndex (t, x:int) = RowElement(RowElementTags.SimpleIndex t, x)

let TypeDefOrRefOrSpec (t, x:int) = RowElement(RowElementTags.TypeDefOrRefOrSpec t, x)

let TypeOrMethodDef (t, x:int) = RowElement(RowElementTags.TypeOrMethodDef t, x)

let HasConstant (t, x:int) = RowElement(RowElementTags.HasConstant t, x)

let HasCustomAttribute (t, x:int) = RowElement(RowElementTags.HasCustomAttribute t, x)

let HasFieldMarshal (t, x:int) = RowElement(RowElementTags.HasFieldMarshal t, x)

let HasDeclSecurity (t, x:int) = RowElement(RowElementTags.HasDeclSecurity t, x)

let MemberRefParent (t, x:int) = RowElement(RowElementTags.MemberRefParent t, x)

let HasSemantics (t, x:int) = RowElement(RowElementTags.HasSemantics t, x)

let MethodDefOrRef (t, x:int) = RowElement(RowElementTags.MethodDefOrRef t, x)

let MemberForwarded (t, x:int) = RowElement(RowElementTags.MemberForwarded t, x)

let Implementation (t, x:int) = RowElement(RowElementTags.Implementation t, x)

let CustomAttributeType (t, x:int) = RowElement(RowElementTags.CustomAttributeType t, x)

let ResolutionScope (t, x:int) = RowElement(RowElementTags.ResolutionScope t, x)

type BlobIndex = int

type StringIndex = int

let BlobIndex (x:BlobIndex) : int = x

let StringIndex (x:StringIndex) : int = x

let inline combineHash x2 acc = 37 * acc + x2 // (acc <<< 6 + acc >>> 2 + x2 + 0x9e3779b9)

let hashRow (elems:RowElement[]) =

let mutable acc = 0

for i in 0 .. elems.Length - 1 do

acc <- (acc <<< 1) + elems.[i].Tag + elems.[i].Val + 631

acc

let equalRows (elems:RowElement[]) (elems2:RowElement[]) =

if elems.Length <> elems2.Length then false else

let mutable ok = true

let n = elems.Length

let mutable i = 0

while ok && i < n do

if elems.[i].Tag <> elems2.[i].Tag || elems.[i].Val <> elems2.[i].Val then ok <- false

i <- i + 1

ok

type GenericRow = RowElement[]

type SharedRow(elems: RowElement[], hashCode: int) =

member x.GenericRow = elems

override x.GetHashCode() = hashCode

override x.Equals(obj:obj) =

match obj with

| :? SharedRow as y -> equalRows elems y.GenericRow

| _ -> false

let SharedRow(elems: RowElement[]) = new SharedRow(elems, hashRow elems)

let AssemblyRefRow(s1,s2,s3,s4,l1,b1,nameIdx,str2,b2) =

let hashCode = hash nameIdx

let genericRow = [| UShort s1; UShort s2; UShort s3; UShort s4; ULong l1; Blob b1; StringE nameIdx; StringE str2; Blob b2 |]

new SharedRow(genericRow, hashCode)

let MemberRefRow(mrp:RowElement,nmIdx:StringIndex,blobIdx:BlobIndex) =

let hashCode = combineHash (hash blobIdx) (combineHash (hash nmIdx) (hash mrp))

let genericRow = [| mrp; StringE nmIdx; Blob blobIdx |]

new SharedRow(genericRow, hashCode)

type UnsharedRow(elems: RowElement[]) =

member x.GenericRow = elems

override x.GetHashCode() = hashRow elems

override x.Equals(obj:obj) =

match obj with

| :? UnsharedRow as y -> equalRows elems y.GenericRow

| _ -> false

type ILTypeWriterEnv = { EnclosingTyparCount: int }

let envForTypeDef (td:ILTypeDef) = { EnclosingTyparCount=td.GenericParams.Length }

let envForMethodRef env (typ:ILType) = { EnclosingTyparCount=(match typ with ILType.Array _ -> env.EnclosingTyparCount | _ -> typ.GenericArgs.Length) }

let envForNonGenericMethodRef _mref = { EnclosingTyparCount=System.Int32.MaxValue }

let envForFieldSpec (fspec:ILFieldSpec) = { EnclosingTyparCount=fspec.EnclosingType.GenericArgs.Length }

let envForOverrideSpec (ospec:ILOverridesSpec) = { EnclosingTyparCount=ospec.EnclosingType.GenericArgs.Length }

type MetadataTable<'T> =

{ name: string

dict: Dictionary<'T, int> // given a row, find its entry number

#if DEBUG

mutable lookups: int

mutable rows: ResizeArray<'T> }

member x.Count = x.rows.Count

static member New(nm,hashEq) =

{ name=nm

#if DEBUG

lookups=0

dict = new Dictionary<_,_>(100, hashEq)

rows= new ResizeArray<_>() }

member tbl.EntriesAsArray =

#if DEBUG

if showEntryLookups then dprintf "--> table %s had %d entries and %d lookups\n" tbl.name tbl.Count tbl.lookups

tbl.rows |> ResizeArray.toArray

member tbl.Entries =

#if DEBUG

if showEntryLookups then dprintf "--> table %s had %d entries and %d lookups\n" tbl.name tbl.Count tbl.lookups

tbl.rows |> ResizeArray.toList

member tbl.AddSharedEntry x =

let n = tbl.rows.Count + 1

tbl.dict.[x] <- n

tbl.rows.Add(x)

n

member tbl.AddUnsharedEntry x =

let n = tbl.rows.Count + 1

tbl.rows.Add(x)

n

member tbl.FindOrAddSharedEntry x =

#if DEBUG

tbl.lookups <- tbl.lookups + 1

let mutable res = Unchecked.defaultof<_>

let ok = tbl.dict.TryGetValue(x,&res)

if ok then res

else tbl.AddSharedEntry x

/// This is only used in one special place - see further below.

member tbl.SetRowsOfTable t =

tbl.rows <- ResizeArray.ofArray t

let h = tbl.dict

h.Clear()

t |> Array.iteri (fun i x -> h.[x] <- (i+1))

member tbl.AddUniqueEntry nm geterr x =

if tbl.dict.ContainsKey x then failwith ("duplicate entry '"+geterr x+"' in "+nm+" table")

else tbl.AddSharedEntry x

member tbl.GetTableEntry x = tbl.dict.[x]

type MethodDefKey(tidx:int,garity:int,nm:string,rty:ILType,argtys:ILTypes,isStatic:bool) =

// Precompute the hash. The hash doesn't include the return type or

// argument types (only argument type count). This is very important, since

// hashing these is way too expensive

let hashCode =

hash tidx

|> combineHash (hash garity)

|> combineHash (hash nm)

|> combineHash (hash argtys.Length)

|> combineHash (hash isStatic)

member key.TypeIdx = tidx

member key.GenericArity = garity

member key.Name = nm

member key.ReturnType = rty

member key.ArgTypes = argtys

member key.IsStatic = isStatic

override x.GetHashCode() = hashCode

override x.Equals(obj:obj) =

match obj with

| :? MethodDefKey as y ->

tidx = y.TypeIdx &&

garity = y.GenericArity &&

nm = y.Name &&

// note: these next two use structural equality on AbstractIL ILType values

rty = y.ReturnType &&

List.lengthsEqAndForall2 (fun a b -> a = b) argtys y.ArgTypes &&

isStatic = y.IsStatic

| _ -> false

type FieldDefKey(tidx:int,nm:string,ty:ILType) =

// precompute the hash. hash doesn't include the type

let hashCode = hash tidx |> combineHash (hash nm)

member key.TypeIdx = tidx

member key.Name = nm

member key.Type = ty

override x.GetHashCode() = hashCode

override x.Equals(obj:obj) =

match obj with

| :? FieldDefKey as y ->

tidx = y.TypeIdx &&

nm = y.Name &&

ty = y.Type

| _ -> false

type PropertyTableKey = PropKey of int (* type. def. idx. *) * string * ILType * ILTypes

type EventTableKey = EventKey of int (* type. def. idx. *) * string

type TypeDefTableKey = TdKey of string list (* enclosing *) * string (* type name *)

type MetadataTable =

| Shared of MetadataTable<SharedRow>

| Unshared of MetadataTable<UnsharedRow>

member t.FindOrAddSharedEntry(x) = match t with Shared u -> u.FindOrAddSharedEntry(x) | Unshared u -> failwithf "FindOrAddSharedEntry: incorrect table kind, u.name = %s" u.name

member t.AddSharedEntry(x) = match t with | Shared u -> u.AddSharedEntry(x) | Unshared u -> failwithf "AddSharedEntry: incorrect table kind, u.name = %s" u.name

member t.AddUnsharedEntry(x) = match t with Unshared u -> u.AddUnsharedEntry(x) | Shared u -> failwithf "AddUnsharedEntry: incorrect table kind, u.name = %s" u.name

member t.GenericRowsOfTable = match t with Unshared u -> u.EntriesAsArray |> Array.map (fun x -> x.GenericRow) | Shared u -> u.EntriesAsArray |> Array.map (fun x -> x.GenericRow)

member t.SetRowsOfSharedTable rows = match t with Shared u -> u.SetRowsOfTable (Array.map SharedRow rows) | Unshared u -> failwithf "SetRowsOfSharedTable: incorrect table kind, u.name = %s" u.name

member t.Count = match t with Unshared u -> u.Count | Shared u -> u.Count

type cenv =

{ ilg: ILGlobals

emitTailcalls: bool

showTimes: bool

desiredMetadataVersion: ILVersionInfo

requiredDataFixups: (int32 * (int * bool)) list ref

/// References to strings in codestreams: offset of code and a (fixup-location , string token) list)

mutable requiredStringFixups: (int32 * (int * int) list) list

codeChunks: ByteBuffer

mutable nextCodeAddr: int32

// Collected debug information

mutable moduleGuid: byte[]

generatePdb: bool

pdbinfo: ResizeArray<PdbMethodData>

documents: MetadataTable<PdbDocumentData>

/// Raw data, to go into the data section

data: ByteBuffer

/// Raw resource data, to go into the data section

resources: ByteBuffer

mutable entrypoint: (bool * int) option

/// Caches

trefCache: Dictionary<ILTypeRef,int>

/// The following are all used to generate unique items in the output

tables: MetadataTable[]

AssemblyRefs: MetadataTable<SharedRow>

fieldDefs: MetadataTable<FieldDefKey>

methodDefIdxsByKey: MetadataTable<MethodDefKey>

methodDefIdxs: Dictionary<ILMethodDef,int>

propertyDefs: MetadataTable<PropertyTableKey>

eventDefs: MetadataTable<EventTableKey>

typeDefs: MetadataTable<TypeDefTableKey>

guids: MetadataTable<byte[]>

blobs: MetadataTable<byte[]>

strings: MetadataTable<string>

userStrings: MetadataTable<string>

}

member cenv.GetTable (tab:TableName) = cenv.tables.[tab.Index]

member cenv.AddCode ((reqdStringFixupsOffset,requiredStringFixups),code) =

if align 4 cenv.nextCodeAddr <> cenv.nextCodeAddr then dprintn "warning: code not 4-byte aligned"

cenv.requiredStringFixups <- (cenv.nextCodeAddr + reqdStringFixupsOffset, requiredStringFixups) :: cenv.requiredStringFixups

cenv.codeChunks.EmitBytes code

cenv.nextCodeAddr <- cenv.nextCodeAddr + code.Length

member cenv.GetCode() = cenv.codeChunks.Close()

let FindOrAddSharedRow (cenv:cenv) tbl x = cenv.GetTable(tbl).FindOrAddSharedEntry x

let AddSharedRow (cenv:cenv) tbl x = cenv.GetTable(tbl).AddSharedEntry x

let AddUnsharedRow (cenv:cenv) tbl (x:UnsharedRow) = cenv.GetTable(tbl).AddUnsharedEntry x

let metadataSchemaVersionSupportedByCLRVersion v =

// Whidbey Beta 1 version numbers are between 2.0.40520.0 and 2.0.40607.0

// Later Whidbey versions are post 2.0.40607.0.. However we assume

// internal builds such as 2.0.x86chk are Whidbey Beta 2 or later

if compareILVersions v (parseILVersion ("2.0.40520.0")) >= 0 &&

compareILVersions v (parseILVersion ("2.0.40608.0")) < 0 then 1,1

elif compareILVersions v (parseILVersion ("2.0.0.0")) >= 0 then 2,0

else 1,0

let headerVersionSupportedByCLRVersion v =

// The COM20HEADER version number

// Whidbey version numbers are 2.5

// Earlier are 2.0

// From an email from jeffschw: "Be built with a compiler that marks the COM20HEADER with Major >=2 and Minor >= 5. The V2.0 compilers produce images with 2.5, V1.x produces images with 2.0."

if compareILVersions v (parseILVersion ("2.0.0.0")) >= 0 then 2,5

else 2,0

let peOptionalHeaderByteByCLRVersion v =

// A flag in the PE file optional header seems to depend on CLI version

// Whidbey version numbers are 8

// Earlier are 6

// Tools are meant to ignore this, but the VS Profiler wants it to have the right value

if compareILVersions v (parseILVersion ("2.0.0.0")) >= 0 then 8

else 6

type ILTokenMappings =

{ TypeDefTokenMap: ILTypeDef list * ILTypeDef -> int32

FieldDefTokenMap: ILTypeDef list * ILTypeDef -> ILFieldDef -> int32

MethodDefTokenMap: ILTypeDef list * ILTypeDef -> ILMethodDef -> int32

PropertyTokenMap: ILTypeDef list * ILTypeDef -> ILPropertyDef -> int32

EventTokenMap: ILTypeDef list * ILTypeDef -> ILEventDef -> int32 }

let recordRequiredDataFixup requiredDataFixups (buf: ByteBuffer) pos lab =

requiredDataFixups := (pos,lab) :: !requiredDataFixups

// Write a special value in that we check later when applying the fixup

buf.EmitInt32 0xdeaddddd

let GetUserStringHeapIdx cenv s =

cenv.userStrings.FindOrAddSharedEntry s

let GetBytesAsBlobIdx cenv (bytes:byte[]) =

if bytes.Length = 0 then 0

else cenv.blobs.FindOrAddSharedEntry bytes

let GetStringHeapIdx cenv s =

if s = "" then 0

else cenv.strings.FindOrAddSharedEntry s

let GetGuidIdx cenv info = cenv.guids.FindOrAddSharedEntry info

let GetStringHeapIdxOption cenv sopt =

match sopt with

| Some ns -> GetStringHeapIdx cenv ns

| None -> 0

let GetTypeNameAsElemPair cenv n =

let (n1,n2) = splitTypeNameRight n

StringE (GetStringHeapIdxOption cenv n1),

StringE (GetStringHeapIdx cenv n2)

let rec GenTypeDefPass1 enc cenv (td:ILTypeDef) =

ignore (cenv.typeDefs.AddUniqueEntry "type index" (fun (TdKey (_,n)) -> n) (TdKey (enc,td.Name)))

GenTypeDefsPass1 (enc@[td.Name]) cenv td.NestedTypes.AsList

and GenTypeDefsPass1 enc cenv tds = List.iter (GenTypeDefPass1 enc cenv) tds

let rec GetIdxForTypeDef cenv key =

try cenv.typeDefs.GetTableEntry key

with

:? KeyNotFoundException ->

let (TdKey (enc,n) ) = key

errorR(InternalError("One of your modules expects the type '"+String.concat "." (enc@[n])+"' to be defined within the module being emitted. You may be missing an input file",range0))

0

let rec GetAssemblyRefAsRow cenv (aref:ILAssemblyRef) =

AssemblyRefRow

((match aref.Version with None -> 0us | Some (x,_,_,_) -> x),

(match aref.Version with None -> 0us | Some (_,y,_,_) -> y),

(match aref.Version with None -> 0us | Some (_,_,z,_) -> z),

(match aref.Version with None -> 0us | Some (_,_,_,w) -> w),

((match aref.PublicKey with Some (PublicKey _) -> 0x0001 | _ -> 0x0000)

||| (if aref.Retargetable then 0x0100 else 0x0000)),

BlobIndex (match aref.PublicKey with

| None -> 0

| Some (PublicKey b | PublicKeyToken b) -> GetBytesAsBlobIdx cenv b),

StringIndex (GetStringHeapIdx cenv aref.Name),

StringIndex (match aref.Locale with None -> 0 | Some s -> GetStringHeapIdx cenv s),

BlobIndex (match aref.Hash with None -> 0 | Some s -> GetBytesAsBlobIdx cenv s))

and GetAssemblyRefAsIdx cenv aref =

FindOrAddSharedRow cenv TableNames.AssemblyRef (GetAssemblyRefAsRow cenv aref)

and GetModuleRefAsRow cenv (mref:ILModuleRef) =

SharedRow

[| StringE (GetStringHeapIdx cenv mref.Name) |]

and GetModuleRefAsFileRow cenv (mref:ILModuleRef) =

SharedRow

[| ULong (if mref.HasMetadata then 0x0000 else 0x0001)

StringE (GetStringHeapIdx cenv mref.Name)

(match mref.Hash with None -> Blob 0 | Some s -> Blob (GetBytesAsBlobIdx cenv s)) |]

and GetModuleRefAsIdx cenv mref =

FindOrAddSharedRow cenv TableNames.ModuleRef (GetModuleRefAsRow cenv mref)

and GetModuleRefAsFileIdx cenv mref =

FindOrAddSharedRow cenv TableNames.File (GetModuleRefAsFileRow cenv mref)

let isScopeRefLocal scoref = (scoref = ILScopeRef.Local)

let isTypeRefLocal (tref:ILTypeRef) = isScopeRefLocal tref.Scope

let isTypeLocal (typ:ILType) = typ.IsNominal && isNil typ.GenericArgs && isTypeRefLocal typ.TypeRef

let GetScopeRefAsImplementationElem cenv scoref =

match scoref with

| ILScopeRef.Local -> (i_AssemblyRef, 0)

| ILScopeRef.Assembly aref -> (i_AssemblyRef, GetAssemblyRefAsIdx cenv aref)

| ILScopeRef.Module mref -> (i_File, GetModuleRefAsFileIdx cenv mref)

let rec GetTypeRefAsTypeRefRow cenv (tref:ILTypeRef) =

let nselem,nelem = GetTypeNameAsElemPair cenv tref.Name

let rs1,rs2 = GetResolutionScopeAsElem cenv (tref.Scope,tref.Enclosing)

SharedRow [| ResolutionScope (rs1,rs2); nelem; nselem |]

and GetTypeRefAsTypeRefIdx cenv tref =

let mutable res = 0

if cenv.trefCache.TryGetValue(tref,&res) then res else

let res = FindOrAddSharedRow cenv TableNames.TypeRef (GetTypeRefAsTypeRefRow cenv tref)

cenv.trefCache.[tref] <- res

res

and GetTypeDescAsTypeRefIdx cenv (scoref,enc,n) =

GetTypeRefAsTypeRefIdx cenv (mkILNestedTyRef (scoref,enc,n))

and GetResolutionScopeAsElem cenv (scoref,enc) =

if isNil enc then

match scoref with

| ILScopeRef.Local -> (rs_Module, 1)

| ILScopeRef.Assembly aref -> (rs_AssemblyRef, GetAssemblyRefAsIdx cenv aref)

| ILScopeRef.Module mref -> (rs_ModuleRef, GetModuleRefAsIdx cenv mref)

else

let enc2,n2 = List.frontAndBack enc

(rs_TypeRef, GetTypeDescAsTypeRefIdx cenv (scoref,enc2,n2))

let emitTypeInfoAsTypeDefOrRefEncoded cenv (bb: ByteBuffer) (scoref,enc,nm) =

if isScopeRefLocal scoref then

let idx = GetIdxForTypeDef cenv (TdKey(enc,nm))

bb.EmitZ32 (idx <<< 2) // ECMA 22.2.8 TypeDefOrRefEncoded - ILTypeDef

else

let idx = GetTypeDescAsTypeRefIdx cenv (scoref,enc,nm)

bb.EmitZ32 ((idx <<< 2) ||| 0x01) // ECMA 22.2.8 TypeDefOrRefEncoded - ILTypeRef

let getTypeDefOrRefAsUncodedToken (tag,idx) =

let tab =

if tag = tdor_TypeDef then TableNames.TypeDef

elif tag = tdor_TypeRef then TableNames.TypeRef

elif tag = tdor_TypeSpec then TableNames.TypeSpec

else failwith "getTypeDefOrRefAsUncodedToken"

getUncodedToken tab idx

let EmitArrayShape (bb: ByteBuffer) (ILArrayShape shape) =

let sized = List.filter (function (_,Some _) -> true | _ -> false) shape

let lobounded = List.filter (function (Some _,_) -> true | _ -> false) shape

bb.EmitZ32 shape.Length

bb.EmitZ32 sized.Length

sized |> List.iter (function (_,Some sz) -> bb.EmitZ32 sz | _ -> failwith "?")

bb.EmitZ32 lobounded.Length

lobounded |> List.iter (function (Some low,_) -> bb.EmitZ32 low | _ -> failwith "?")

let hasthisToByte hasthis =

match hasthis with

| ILThisConvention.Instance -> e_IMAGE_CEE_CS_CALLCONV_INSTANCE

| ILThisConvention.InstanceExplicit -> e_IMAGE_CEE_CS_CALLCONV_INSTANCE_EXPLICIT

| ILThisConvention.Static -> 0x00uy

let callconvToByte ntypars (Callconv (hasthis,bcc)) =

hasthisToByte hasthis |||

(if ntypars > 0 then e_IMAGE_CEE_CS_CALLCONV_GENERIC else 0x00uy) |||

(match bcc with

| ILArgConvention.FastCall -> e_IMAGE_CEE_CS_CALLCONV_FASTCALL

| ILArgConvention.StdCall -> e_IMAGE_CEE_CS_CALLCONV_STDCALL

| ILArgConvention.ThisCall -> e_IMAGE_CEE_CS_CALLCONV_THISCALL

| ILArgConvention.CDecl -> e_IMAGE_CEE_CS_CALLCONV_CDECL

| ILArgConvention.Default -> 0x00uy

| ILArgConvention.VarArg -> e_IMAGE_CEE_CS_CALLCONV_VARARG)

let rec EmitTypeSpec cenv env (bb: ByteBuffer) (et,tspec:ILTypeSpec) =

if isNil tspec.GenericArgs then

bb.EmitByte et

emitTypeInfoAsTypeDefOrRefEncoded cenv bb (tspec.Scope,tspec.Enclosing,tspec.Name)

else

bb.EmitByte et_WITH

bb.EmitByte et

emitTypeInfoAsTypeDefOrRefEncoded cenv bb (tspec.Scope,tspec.Enclosing,tspec.Name)

bb.EmitZ32 tspec.GenericArgs.Length

EmitTypes cenv env bb tspec.GenericArgs

and GetTypeAsTypeDefOrRef cenv env (ty:ILType) =

if isTypeLocal ty then

let tref = ty.TypeRef

(tdor_TypeDef, GetIdxForTypeDef cenv (TdKey(tref.Enclosing,tref.Name)))

elif ty.IsNominal && isNil ty.GenericArgs then

(tdor_TypeRef, GetTypeRefAsTypeRefIdx cenv ty.TypeRef)

else

(tdor_TypeSpec, GetTypeAsTypeSpecIdx cenv env ty)

and GetTypeAsBytes cenv env ty = emitBytesViaBuffer (fun bb -> EmitType cenv env bb ty)

and GetTypeOfLocalAsBytes cenv env (l: ILLocal) =

emitBytesViaBuffer (fun bb -> EmitLocalInfo cenv env bb l)

and GetTypeAsBlobIdx cenv env (ty:ILType) =

GetBytesAsBlobIdx cenv (GetTypeAsBytes cenv env ty)

and GetTypeAsTypeSpecRow cenv env (ty:ILType) =

SharedRow [| Blob (GetTypeAsBlobIdx cenv env ty) |]

and GetTypeAsTypeSpecIdx cenv env ty =

FindOrAddSharedRow cenv TableNames.TypeSpec (GetTypeAsTypeSpecRow cenv env ty)

and EmitType cenv env bb ty =

match ty with

// REVIEW: what are these doing here?

| ILType.Value tspec when tspec.Name = "System.String" -> bb.EmitByte et_STRING

| ILType.Value tspec when tspec.Name = "System.Object" -> bb.EmitByte et_OBJECT

| typ when isILSByteTy typ -> bb.EmitByte et_I1

| typ when isILInt16Ty typ -> bb.EmitByte et_I2

| typ when isILInt32Ty typ -> bb.EmitByte et_I4

| typ when isILInt64Ty typ -> bb.EmitByte et_I8

| typ when isILByteTy typ -> bb.EmitByte et_U1

| typ when isILUInt16Ty typ -> bb.EmitByte et_U2

| typ when isILUInt32Ty typ -> bb.EmitByte et_U4

| typ when isILUInt64Ty typ -> bb.EmitByte et_U8

| typ when isILDoubleTy typ -> bb.EmitByte et_R8

| typ when isILSingleTy typ -> bb.EmitByte et_R4

| typ when isILBoolTy typ -> bb.EmitByte et_BOOLEAN

| typ when isILCharTy typ -> bb.EmitByte et_CHAR

| typ when isILStringTy typ -> bb.EmitByte et_STRING

| typ when isILObjectTy typ -> bb.EmitByte et_OBJECT

| typ when isILIntPtrTy typ -> bb.EmitByte et_I

| typ when isILUIntPtrTy typ -> bb.EmitByte et_U

| typ when isILTypedReferenceTy typ -> bb.EmitByte et_TYPEDBYREF

| ILType.Boxed tspec -> EmitTypeSpec cenv env bb (et_CLASS,tspec)

| ILType.Value tspec -> EmitTypeSpec cenv env bb (et_VALUETYPE,tspec)

| ILType.Array (shape,ty) ->

if shape = ILArrayShape.SingleDimensional then (bb.EmitByte et_SZARRAY ; EmitType cenv env bb ty)

else (bb.EmitByte et_ARRAY; EmitType cenv env bb ty; EmitArrayShape bb shape)

| ILType.TypeVar tv ->

let cgparams = env.EnclosingTyparCount

if int32 tv < cgparams then

bb.EmitByte et_VAR

bb.EmitZ32 (int32 tv)

else

bb.EmitByte et_MVAR

bb.EmitZ32 (int32 tv - cgparams)

| ILType.Byref typ ->

bb.EmitByte et_BYREF

EmitType cenv env bb typ

| ILType.Ptr typ ->

bb.EmitByte et_PTR

EmitType cenv env bb typ

| ILType.Void ->

bb.EmitByte et_VOID

| ILType.FunctionPointer x ->

bb.EmitByte et_FNPTR

EmitCallsig cenv env bb (x.CallingConv,x.ArgTypes,x.ReturnType,None,0)

| ILType.Modified (req,tref,ty) ->

bb.EmitByte (if req then et_CMOD_REQD else et_CMOD_OPT)

emitTypeInfoAsTypeDefOrRefEncoded cenv bb (tref.Scope, tref.Enclosing,tref.Name)

EmitType cenv env bb ty

| _ -> failwith "EmitType"

and EmitLocalInfo cenv env (bb:ByteBuffer) (l:ILLocal) =

if l.IsPinned then

bb.EmitByte et_PINNED

EmitType cenv env bb l.Type

and EmitCallsig cenv env bb (callconv,args:ILTypes,ret,varargs:ILVarArgs,genarity) =

bb.EmitByte (callconvToByte genarity callconv)

if genarity > 0 then bb.EmitZ32 genarity

bb.EmitZ32 ((args.Length + (match varargs with None -> 0 | Some l -> l.Length)))

EmitType cenv env bb ret

args |> List.iter (EmitType cenv env bb)

match varargs with

| None -> ()// no extra arg = no sentinel

| Some tys ->

if isNil tys then () // no extra arg = no sentinel

else

bb.EmitByte et_SENTINEL

List.iter (EmitType cenv env bb) tys

and GetCallsigAsBytes cenv env x = emitBytesViaBuffer (fun bb -> EmitCallsig cenv env bb x)

and EmitTypes cenv env bb (inst: ILTypes) =