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.DiagnosticMessage

open Microsoft.FSharp.Compiler.ErrorLogger

open Microsoft.FSharp.Compiler.Range

open System.Collections.Generic

open System.IO

#if DEBUG

let showEntryLookups = false

let reportTime =

let tFirst = ref None

let tPrev = ref None

fun showTimes descr ->

if showTimes then

let t = System.Diagnostics.Process.GetCurrentProcess().UserProcessorTime.TotalSeconds

let prev = match !tPrev with None -> 0.0 | Some t -> t

let first = match !tFirst with None -> (tFirst := Some t; t) | Some t -> t

dprintf "ilwrite: TIME %10.3f (total) %10.3f (delta) - %s\n" (t - first) (t - prev) descr;

tPrev := Some t

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 PdbDocumentData = ILSourceDocument

type PdbLocalVar =

{ Name: string;

Signature: byte[];

/// the local index the name corresponds to

Index: int32 }

type PdbMethodScope =

{ Children: PdbMethodScope array;

StartOffset: int;

EndOffset: int;

Locals: PdbLocalVar array;

(* REVIEW open_namespaces: pdb_namespace array; *) }

type PdbSourceLoc =

{ Document: int;

Line: int;

Column: int; }

type PdbSequencePoint =

{ Document: int;

Offset: int;

Line: int;

Column: int;

EndLine: int;

EndColumn: int; }

override x.ToString() = sprintf "(%d,%d)-(%d,%d)" x.Line x.Column x.EndLine x.EndColumn

type PdbMethodData =

{ MethToken: int32;

MethName:string;

Params: PdbLocalVar array;

RootScope: PdbMethodScope;

Range: (PdbSourceLoc * PdbSourceLoc) option;

SequencePoints: PdbSequencePoint array; }

module SequencePoint =

let orderBySource sp1 sp2 =

let c1 = compare sp1.Document sp2.Document

if c1 <> 0 then c1 else

let c1 = compare sp1.Line sp2.Line

if c1 <> 0 then c1 else

compare sp1.Column sp2.Column

let orderByOffset sp1 sp2 =

compare sp1.Offset sp2.Offset

let sizeof_IMAGE_DEBUG_DIRECTORY = 28

type PdbData =

{ EntryPoint: int32 option;

// MVID of the generated .NET module (used by MDB files to identify debug info)

ModuleID: byte[];

Documents: PdbDocumentData[];

Methods: PdbMethodData[] }

let WritePdbInfo fixupOverlappingSequencePoints showTimes f fpdb info =

(try FileSystem.FileDelete fpdb with _ -> ());

let pdbw = ref Unchecked.defaultof<PdbWriter>

try

pdbw := pdbInitialize f fpdb

with _ -> error(Error(FSComp.SR.ilwriteErrorCreatingPdb(fpdb), rangeCmdArgs))

match info.EntryPoint with

| None -> ()

| Some x -> pdbSetUserEntryPoint !pdbw x

let docs = info.Documents |> Array.map (fun doc -> pdbDefineDocument !pdbw doc.File)

let getDocument i =

if i < 0 || i > docs.Length then failwith "getDocument: bad doc number";

docs.[i]

reportTime showTimes (sprintf "PDB: Defined %d documents" info.Documents.Length);

Array.sortInPlaceBy (fun x -> x.MethToken) info.Methods;

reportTime showTimes (sprintf "PDB: Sorted %d methods" info.Methods.Length);

// This next bit is a workaround. The sequence points we get

// from F# (which has nothing to do with this module) are actually expression

// marks, i.e. the source ranges they denote are typically

// nested, and each point indicates where the

// code for an expression with a particular range begins.

// This is in many ways a much more convenient form to emit.

// However, it is not the form that debug tools accept nicely.

// However, sequence points are really a non-overlapping, non-nested

// partition of the source code of a method. So here we shorten the

// length of all sequence point marks so they do not go further than

// the next sequence point in the source.

let spCounts = info.Methods |> Array.map (fun x -> x.SequencePoints.Length)

let allSps = Array.concat (Array.map (fun x -> x.SequencePoints) info.Methods |> Array.toList)

let allSps = Array.mapi (fun i sp -> (i,sp)) allSps

if fixupOverlappingSequencePoints then

// sort the sequence points into source order

Array.sortInPlaceWith (fun (_,sp1) (_,sp2) -> SequencePoint.orderBySource sp1 sp2) allSps;

// shorten the ranges of any that overlap with following sequence points

// sort the sequence points back into offset order

for i = 0 to Array.length allSps - 2 do

let n,sp1 = allSps.[i]

let _,sp2 = allSps.[i+1]

if (sp1.Document = sp2.Document) &&

(sp1.EndLine > sp2.Line ||

(sp1.EndLine = sp2.Line &&

sp1.EndColumn >= sp2.Column)) then

let adjustToPrevLine = (sp1.Line < sp2.Line)

allSps.[i] <- n,{sp1 with EndLine = (if adjustToPrevLine then sp2.Line-1 else sp2.Line);

EndColumn = (if adjustToPrevLine then 80 else sp2.Column); }

Array.sortInPlaceBy fst allSps;

let spOffset = ref 0

info.Methods |> Array.iteri (fun i minfo ->

let sps = Array.sub allSps !spOffset spCounts.[i]

spOffset := !spOffset + spCounts.[i];

begin match minfo.Range with

| None -> ()

| Some (a,b) ->

pdbOpenMethod !pdbw minfo.MethToken;

pdbSetMethodRange !pdbw

(getDocument a.Document) a.Line a.Column

(getDocument b.Document) b.Line b.Column;

// Partition the sequence points by document

let spsets =

let res = (Map.empty : Map<int,PdbSequencePoint list ref>)

let add res (_,sp) =

let k = sp.Document

match Map.tryFind k res with

Some xsR -> xsR := sp :: !xsR; res

| None -> Map.add k (ref [sp]) res

let res = Array.fold add res sps

let res = Map.toList res // ordering may not be stable

List.map (fun (_,x) -> Array.ofList !x) res

spsets |> List.iter (fun spset ->

if spset.Length > 0 then

Array.sortInPlaceWith SequencePoint.orderByOffset spset;

let sps =

spset |> Array.map (fun sp ->

// Ildiag.dprintf "token 0x%08lx has an sp at offset 0x%08x\n" minfo.MethToken sp.Offset;

(sp.Offset, sp.Line, sp.Column,sp.EndLine, sp.EndColumn))

// Use of alloca in implementation of pdbDefineSequencePoints can give stack overflow here

if sps.Length < 5000 then

pdbDefineSequencePoints !pdbw (getDocument spset.[0].Document) sps;);

// Write the scopes

let rec writePdbScope top sco =

if top || sco.Locals.Length <> 0 || sco.Children.Length <> 0 then

pdbOpenScope !pdbw sco.StartOffset;

sco.Locals |> Array.iter (fun v -> pdbDefineLocalVariable !pdbw v.Name v.Signature v.Index);

sco.Children |> Array.iter (writePdbScope false);

pdbCloseScope !pdbw sco.EndOffset;

writePdbScope true minfo.RootScope;

pdbCloseMethod !pdbw

end);

reportTime showTimes "PDB: Wrote methods";

let res = pdbGetDebugInfo !pdbw

for pdbDoc in docs do

pdbCloseDocument pdbDoc

pdbClose !pdbw f fpdb;

reportTime showTimes "PDB: Closed";

res

open System.Reflection

open Microsoft.FSharp.Reflection

let (?) this memb (args:'Args) : 'R =

// Get array of 'obj' arguments for the reflection call

let args =

if typeof<'Args> = typeof<unit> then [| |]

elif FSharpType.IsTuple typeof<'Args> then Microsoft.FSharp.Reflection.FSharpValue.GetTupleFields(args)

else [| box args |]

// Get methods and perform overload resolution

let methods = this.GetType().GetMethods()

let bestMatch = methods |> Array.tryFind (fun mi -> mi.Name = memb && mi.GetParameters().Length = args.Length)

match bestMatch with

| Some(mi) -> unbox(mi.Invoke(this, args))

| None -> error(Error(FSComp.SR.ilwriteMDBMemberMissing(memb), rangeCmdArgs))

let monoCompilerSvc = "Mono.CompilerServices.SymbolWriter, Version=2.0.0.0, Culture=neutral, PublicKeyToken=0738eb9f132ed756"

let ctor (asmName:string) (clsName:string) (args:obj[]) =

let asm = Assembly.Load(asmName)

let ty = asm.GetType(clsName)

System.Activator.CreateInstance(ty, args)

let createSourceMethodImpl (name:string) (token:int) (namespaceID:int) =

ctor monoCompilerSvc "Mono.CompilerServices.SymbolWriter.SourceMethodImpl" [| box name; box token; box namespaceID |]

let createWriter (f:string) =

ctor monoCompilerSvc "Mono.CompilerServices.SymbolWriter.MonoSymbolWriter" [| box f |]

let WriteMdbInfo fmdb f info =

// Note, if we can’t delete it code will fail later

(try FileSystem.FileDelete fmdb with _ -> ());

// Try loading the MDB symbol writer from an assembly available on Mono dynamically

// Report an error if the assembly is not available.

let wr =

try createWriter f

with e -> error(Error(FSComp.SR.ilwriteErrorCreatingMdb(), rangeCmdArgs))

// NOTE: MonoSymbolWriter doesn't need information about entrypoints, so 'info.EntryPoint' is unused here.

// Write information about Documents. Returns '(SourceFileEntry*CompileUnitEntry)[]'

let docs =

[| for doc in info.Documents do

let doc = wr?DefineDocument(doc.File)

let unit = wr?DefineCompilationUnit(doc)

yield doc, unit |]

let getDocument i =

if i < 0 || i >= Array.length docs then failwith "getDocument: bad doc number" else docs.[i]

// Sort methods and write them to the MDB file

Array.sortInPlaceBy (fun x -> x.MethToken) info.Methods

for meth in info.Methods do

// Creates an instance of 'SourceMethodImpl' which is a private class that implements 'IMethodDef' interface

// We need this as an argument to 'OpenMethod' below. Using private class is ugly, but since we don't reference

// the assembly, the only way to implement 'IMethodDef' interface would be dynamically using Reflection.Emit...

let sm = createSourceMethodImpl meth.MethName meth.MethToken 0

match meth.Range with

| Some(mstart, _) ->

// NOTE: 'meth.Params' is not needed, Mono debugger apparently reads this from meta-data

let _, cue = getDocument mstart.Document

wr?OpenMethod(cue, 0, sm) |> ignore

// Write sequence points

for sp in meth.SequencePoints do

wr?MarkSequencePoint(sp.Offset, cue?get_SourceFile(), sp.Line, sp.Column, false)

// Walk through the tree of scopes and write all variables

let rec writeScope (scope:PdbMethodScope) =

wr?OpenScope(scope.StartOffset) |> ignore

for local in scope.Locals do

wr?DefineLocalVariable(local.Index, local.Name)

for child in scope.Children do

writeScope(child)

wr?CloseScope(scope.EndOffset)

writeScope(meth.RootScope)

// Finished generating debug information for the curretn method

wr?CloseMethod()

| _ -> ()

// Finalize - MDB requires the MVID of the generated .NET module

let moduleGuid = new System.Guid(info.ModuleID |> Array.map byte)

wr?WriteSymbolFile(moduleGuid)

open Printf

let DumpDebugInfo (outfile:string) (info:PdbData) =

use sw = new StreamWriter(outfile + ".debuginfo")

fprintfn sw "ENTRYPOINT\r\n %b\r\n" info.EntryPoint.IsSome

fprintfn sw "DOCUMENTS"

for i, doc in Seq.zip [0 .. info.Documents.Length-1] info.Documents do

fprintfn sw " [%d] %s" i doc.File

fprintfn sw " Type: %A" doc.DocumentType

fprintfn sw " Language: %A" doc.Language

fprintfn sw " Vendor: %A" doc.Vendor

// Sort methods (because they are sorted in PDBs/MDBs too)

fprintfn sw "\r\nMETHODS"

Array.sortInPlaceBy (fun x -> x.MethToken) info.Methods

for meth in info.Methods do

fprintfn sw " %s" meth.MethName

fprintfn sw " Params: %A" [ for p in meth.Params -> sprintf "%d: %s" p.Index p.Name ]

fprintfn sw " Range: %A" (meth.Range |> Option.map (fun (f, t) ->

sprintf "[%d,%d:%d] - [%d,%d:%d]" f.Document f.Line f.Column t.Document t.Line t.Column))

fprintfn sw " Points:"

for sp in meth.SequencePoints do

fprintfn sw " - Doc: %d Offset:%d [%d:%d]-[%d-%d]" sp.Document sp.Offset sp.Line sp.Column sp.EndLine sp.EndColumn

// Walk through the tree of scopes and write all variables

fprintfn sw " Scopes:"

let rec writeScope offs (scope:PdbMethodScope) =

fprintfn sw " %s- [%d-%d]" offs scope.StartOffset scope.EndOffset

if scope.Locals.Length > 0 then

fprintfn sw " %s Locals: %A" offs [ for p in scope.Locals -> sprintf "%d: %s" p.Index p.Name ]

for child in scope.Children do writeScope (offs + " ") child

writeScope "" meth.RootScope

fprintfn sw ""

type ILStrongNameSigner =

| PublicKeySigner of Support.pubkey

| KeyPair of Support.keyPair

| KeyContainer of Support.keyContainerName

static member OpenPublicKeyFile s = PublicKeySigner(Support.signerOpenPublicKeyFile s)

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 _

| KeyPair _ -> ()

| KeyContainer containerName -> Support.signerCloseKeyContainer(containerName)

member s.IsFullySigned =

match s with

| PublicKeySigner _ -> false

| KeyPair _ | KeyContainer _ -> true

member s.PublicKey =

match s with

| PublicKeySigner p -> p

| KeyPair kp -> Support.signerGetPublicKeyForKeyPair kp

| KeyContainer kn -> Support.signerGetPublicKeyForKeyContainer kn

member s.SignatureSize =

try Support.signerSignatureSize(s.PublicKey)

with e ->

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

0x80

member s.SignFile file =

match s with

| PublicKeySigner _ -> ()

| 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

type IGenericRow =

abstract GetGenericRow : unit -> RowElement[]

type ISharedRow =

inherit IGenericRow

type SimpleSharedRow(elems: RowElement[]) =

let hashCode = hash elems // precompute to give more efficient hashing and equality comparisons

interface ISharedRow with

member x.GetGenericRow() = elems

member x.GenericRow = elems

override x.GetHashCode() = hashCode

override x.Equals(obj:obj) =

match obj with

| :? SimpleSharedRow as y -> elems = y.GenericRow

| _ -> false

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 UnsharedRow(elems: RowElement[]) =

interface IGenericRow with

member x.GetGenericRow() = elems

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 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 |]

interface ISharedRow with

member x.GetGenericRow() = genericRow

member x.GenericRow = genericRow

override x.GetHashCode() = hashCode

override x.Equals(obj:obj) =

match obj with

| :? AssemblyRefRow as y -> equalRows genericRow y.GenericRow

| _ -> false

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

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

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

interface ISharedRow with

member x.GetGenericRow() = genericRow

member x.GenericRow = genericRow

override x.GetHashCode() = hash

override x.Equals(obj:obj) =

match obj with

| :? MemberRefRow as y -> equalRows genericRow 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 &&

ILList.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 cenv =

{ primaryAssembly: ILScopeRef;

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: array<MetadataTable<IGenericRow>>;

AssemblyRefs: MetadataTable<AssemblyRefRow>;

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 FindOrAddRow (cenv:cenv) tbl (x:IGenericRow) = cenv.GetTable(tbl).FindOrAddSharedEntry x

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

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

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