#light // (c) Microsoft Corporation 2005-2009. module Microsoft.FSharp.Compiler.AbstractIL.Internal.Support open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal module Ildiag = Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Ildiag open Bytes open System open System.IO open System.Text open System.Reflection open System.Diagnostics.SymbolStore open System.Runtime.InteropServices #if FX_ATLEAST_40 open System.Runtime.CompilerServices #endif // Force inline, so GetLastWin32Error calls are immediately after interop calls as seen by FxCop under Debug build. let inline ignore x = () // Native Resource linking/unlinking type IStream = System.Runtime.InteropServices.ComTypes.IStream type clr_kind = | SSCLI | Microsoft | Mono | Neutral let supported_configurations = [Microsoft;Mono;Neutral] let current_configuration () = Microsoft (* REVIEW: this should detect which CLR we are running *) let configure k = if k <> current_configuration() then dprintn ("configure: cannot change the current configuration for the Abstract IL managed libraries - it is determined by the CLR you are using to run your application") let check action (hresult) = if uint32 hresult >= 0x80000000ul then System.Runtime.InteropServices.Marshal.ThrowExceptionForHR(hresult) //Printf.printf "action = %s, hresult = 0x%nx \n" action hresult let pdb_suffix_for_configuration = function | Microsoft -> "pdb" | _ -> "ildb" type PEFileType = X86 | X64 let MAX_PATH = 260 let E_FAIL = 0x80004005 let bytesToWord ((b0 : byte) , (b1 : byte)) = (int16)b0 ||| ((int16)b1 <<< 8) let bytesToDWord ((b0 : byte) , (b1 : byte) , (b2 : byte) , (b3 : byte)) = (int)b0 ||| ((int)b1 <<< 8) ||| ((int)b2 <<< 16) ||| ((int)b3 <<< 24) let bytesToQWord ((b0 : byte) , (b1 : byte) , (b2 : byte) , (b3 : byte) , (b4 : byte) , (b5 : byte) , (b6 : byte) , (b7 : byte)) = (int64)b0 ||| ((int64)b1 <<< 8) ||| ((int64)b2 <<< 16) ||| ((int64)b3 <<< 24) ||| ((int64)b4 <<< 32) ||| ((int64)b5 <<< 40) ||| ((int64)b6 <<< 48) ||| ((int64)b7 <<< 56) let dwToBytes n = [| (byte)(n &&& 0xff) ; (byte)((n >>> 8) &&& 0xff) ; (byte)((n >>> 16) &&& 0xff) ; (byte)((n >>> 24) &&& 0xff) |], 4 let wToBytes (n : int16) = [| (byte)(n &&& 0xffs) ; (byte)((n >>> 8) &&& 0xffs) |], 2 // REVIEW: factor these classes under one hierarchy, use reflection for creation from buffer and toBytes() // Though, everything I'd like to unify is static - metaclasses? type IMAGE_FILE_HEADER (m:int16, secs:int16, tds:int32, ptst:int32, nos:int32, soh:int16, c:int16) = let mutable machine = m let mutable numberOfSections = secs let mutable timeDateStamp = tds let mutable pointerToSymbolTable = ptst let mutable numberOfSymbols = nos let mutable sizeOfOptionalHeader = soh let mutable characteristics = c member x.Machine with get() = machine and set(value) = machine <- value member x.NumberOfSections with get() = numberOfSections and set(value) = numberOfSections <- value member x.TimeDateStamp with get() = timeDateStamp and set(value) = timeDateStamp <- value member x.PointerToSymbolTable with get() = pointerToSymbolTable and set(value) = pointerToSymbolTable <- value member x.NumberOfSymbols with get() = numberOfSymbols and set(value) = numberOfSymbols <- value member x.SizeOfOptionalHeader with get() = sizeOfOptionalHeader and set(value) = sizeOfOptionalHeader <- value member x.Characteristics with get() = characteristics and set(value) = characteristics <- value static member Width with get() = 20 member x.toBytes () = let buf = Bytebuf.create IMAGE_FILE_HEADER.Width Bytebuf.emit_u16 buf ((uint16)machine) Bytebuf.emit_u16 buf ((uint16)numberOfSections) Bytebuf.emit_i32 buf timeDateStamp Bytebuf.emit_i32 buf pointerToSymbolTable Bytebuf.emit_i32 buf numberOfSymbols Bytebuf.emit_u16 buf ((uint16)sizeOfOptionalHeader) Bytebuf.emit_u16 buf ((uint16)characteristics) Bytebuf.close buf let bytesToIFH (buffer : byte[]) (offset : int) = if (buffer.Length - offset) < IMAGE_FILE_HEADER.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_FILE_HEADER" IMAGE_FILE_HEADER( bytesToWord(buffer.[offset], buffer.[offset+1]), // Machine bytesToWord(buffer.[offset+2], buffer.[offset+3]), // NumberOfSections bytesToDWord(buffer.[offset+4], buffer.[offset+5], buffer.[offset+6], buffer.[offset+7]), // TimeDateStamp bytesToDWord(buffer.[offset+8], buffer.[offset+9], buffer.[offset+10], buffer.[offset+11]), // PointerToSymbolTable bytesToDWord(buffer.[offset+12], buffer.[offset+13], buffer.[offset+14], buffer.[offset+15]), // NumberOfSymbols bytesToWord(buffer.[offset+16], buffer.[offset+17]), // SizeOfOptionalHeader bytesToWord(buffer.[offset+18], buffer.[offset+19])) // Characteristics type IMAGE_SECTION_HEADER(n:int64, ai:int32, va:int32, srd:int32, prd:int32, pr:int32, pln:int32, nr:int16, nl:int16, c:int32) = let mutable name = n let mutable addressInfo = ai // PhysicalAddress / VirtualSize let mutable virtualAddress = va let mutable sizeOfRawData = srd let mutable pointerToRawData = prd let mutable pointerToRelocations = pr let mutable pointerToLineNumbers = pln let mutable numberOfRelocations = nr let mutable numberOfLineNumbers = nl let mutable characteristics = c member x.Name with get() = name and set(value) = name <- value member x.PhysicalAddress with get() = addressInfo and set(value) = addressInfo <- value member x.VirtualSize with get() = addressInfo and set(value) = addressInfo <- value member x.VirtualAddress with get() = virtualAddress and set(value) = virtualAddress <- value member x.SizeOfRawData with get() = sizeOfRawData and set(value) = sizeOfRawData <- value member x.PointerToRawData with get() = pointerToRawData and set(value) = pointerToRawData <- value member x.PointerToRelocations with get() = pointerToRelocations and set(value) = pointerToRelocations <- value member x.PointerToLineNumbers with get() = pointerToLineNumbers and set(value) = pointerToLineNumbers <- value member x.NumberOfRelocations with get() = numberOfRelocations and set(value) = numberOfRelocations <- value member x.NumberOfLineNumbers with get() = numberOfLineNumbers and set(value) = numberOfLineNumbers <- value member x.Characteristics with get() = characteristics and set(value) = characteristics <- value static member Width with get() = 40 member x.toBytes () = let buf = Bytebuf.create IMAGE_SECTION_HEADER.Width Bytebuf.emit_i64 buf name Bytebuf.emit_i32 buf addressInfo Bytebuf.emit_i32 buf virtualAddress Bytebuf.emit_i32 buf sizeOfRawData Bytebuf.emit_i32 buf pointerToRawData Bytebuf.emit_i32 buf pointerToRelocations Bytebuf.emit_i32 buf pointerToLineNumbers Bytebuf.emit_u16 buf ((uint16)numberOfRelocations) Bytebuf.emit_u16 buf ((uint16)numberOfLineNumbers) Bytebuf.emit_i32 buf characteristics Bytebuf.close buf let bytesToISH (buffer : byte[]) (offset : int) = if (buffer.Length - offset) < IMAGE_SECTION_HEADER.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_SECTION_HEADER" IMAGE_SECTION_HEADER(bytesToQWord(buffer.[offset], buffer.[offset+1], buffer.[offset+2], buffer.[offset+3], buffer.[offset+4], buffer.[offset+5], buffer.[offset+6], buffer.[offset+7]), // Name bytesToDWord(buffer.[offset+8], buffer.[offset+9], buffer.[offset+10], buffer.[offset+11]), // AddressInfo bytesToDWord(buffer.[offset+12], buffer.[offset+13], buffer.[offset+14], buffer.[offset+15]), // VirtualAddress bytesToDWord(buffer.[offset+16], buffer.[offset+17], buffer.[offset+18], buffer.[offset+19]), // SizeOfRawData bytesToDWord(buffer.[offset+20], buffer.[offset+21], buffer.[offset+22], buffer.[offset+23]), // PointerToRawData bytesToDWord(buffer.[offset+24], buffer.[offset+25], buffer.[offset+26], buffer.[offset+27]), // PointerToRelocations bytesToDWord(buffer.[offset+28], buffer.[offset+29], buffer.[offset+30], buffer.[offset+31]), // PointerToLineNumbers bytesToWord(buffer.[offset+32], buffer.[offset+33]), // NumberOfRelocations bytesToWord(buffer.[offset+34], buffer.[offset+35]), // NumberOfLineNumbers bytesToDWord(buffer.[offset+36], buffer.[offset+37], buffer.[offset+38], buffer.[offset+39])) // Characteristics type IMAGE_SYMBOL(n:int64, v:int32, sn:int16, t:int16, sc:byte, nas:byte) = let mutable name = n let mutable value = v let mutable sectionNumber = sn let mutable stype = t let mutable storageClass = sc let mutable numberOfAuxSymbols = nas member x.Name with get() = name and set(v) = name <- v member x.Value with get() = value and set(v) = value <- v member x.SectionNumber with get() = sectionNumber and set(v) = sectionNumber <- v member x.Type with get() = stype and set(v) = stype <- v member x.StorageClass with get() = storageClass and set(v) = storageClass <- v member x.NumberOfAuxSymbols with get() = numberOfAuxSymbols and set(v) = numberOfAuxSymbols <- v static member Width with get() = 18 member x.toBytes() = let buf = Bytebuf.create IMAGE_SYMBOL.Width Bytebuf.emit_i64 buf name Bytebuf.emit_i32 buf value Bytebuf.emit_u16 buf ((uint16)sectionNumber) Bytebuf.emit_u16 buf ((uint16)stype) Bytebuf.emit_byte buf storageClass Bytebuf.emit_byte buf numberOfAuxSymbols Bytebuf.close buf let bytesToIS (buffer : byte[]) (offset : int) = if (buffer.Length - offset) < IMAGE_SYMBOL.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_SYMBOL" IMAGE_SYMBOL( bytesToQWord(buffer.[offset], buffer.[offset+1], buffer.[offset+2], buffer.[offset+3], buffer.[offset+4], buffer.[offset+5], buffer.[offset+6], buffer.[offset+7]), // Name bytesToDWord(buffer.[offset+8], buffer.[offset+9], buffer.[offset+10], buffer.[offset+11]), // Value bytesToWord(buffer.[offset+12], buffer.[offset+13]), // SectionNumber bytesToWord(buffer.[offset+14], buffer.[offset+15]), // Type buffer.[offset+16], // StorageClass buffer.[offset+17]) // NumberOfAuxSymbols type IMAGE_RELOCATION(va:int32, sti:int32, t:int16) = let mutable virtualAddress = va // Also RelocCount let mutable symbolTableIndex = sti let mutable ty = t // type member x.VirtualAddress with get() = virtualAddress and set(v) = virtualAddress <- v member x.RelocCount with get() = virtualAddress and set(v) = virtualAddress <- v member x.SymbolTableIndex with get() = symbolTableIndex and set(v) = symbolTableIndex <- v member x.Type with get() = ty and set(v) = ty <- v static member Width with get() = 10 member x.toBytes() = let buf = Bytebuf.create IMAGE_RELOCATION.Width Bytebuf.emit_i32 buf virtualAddress Bytebuf.emit_i32 buf symbolTableIndex Bytebuf.emit_u16 buf ((uint16)ty) Bytebuf.close buf let bytesToIR (buffer : byte[]) (offset : int) = if (buffer.Length - offset) < IMAGE_RELOCATION.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_RELOCATION" IMAGE_RELOCATION( bytesToDWord(buffer.[offset], buffer.[offset+1], buffer.[offset+2], buffer.[offset+3]), bytesToDWord(buffer.[offset+4], buffer.[offset+5], buffer.[offset+6], buffer.[offset+7]), bytesToWord(buffer.[offset+8], buffer.[offset+9])) type IMAGE_RESOURCE_DIRECTORY(c:int32, tds:int32, mjv:int16, mnv:int16, nne:int16, nie:int16) = let mutable characteristics = c let mutable timeDateStamp = tds let mutable majorVersion = mjv let mutable minorVersion = mnv let mutable numberOfNamedEntries = nne let mutable numberOfIdEntries = nie member x.Characteristics with get() = characteristics and set(v) = characteristics <- v member x.TimeDateStamp with get() = timeDateStamp and set(v) = timeDateStamp <- v member x.MajorVersion with get() = majorVersion and set(v) = majorVersion <- v member x.MinorVersion with get() = minorVersion and set(v) = minorVersion <- v member x.NumberOfNamedEntries with get() = numberOfNamedEntries and set(v) = numberOfNamedEntries <- v member x.NumberOfIdEntries with get() = numberOfIdEntries and set(v) = numberOfIdEntries <- v static member Width = 16 member x.toBytes () = let buf = Bytebuf.create IMAGE_RESOURCE_DIRECTORY.Width Bytebuf.emit_i32 buf characteristics Bytebuf.emit_i32 buf timeDateStamp Bytebuf.emit_u16 buf ((uint16)majorVersion) Bytebuf.emit_u16 buf ((uint16)minorVersion) Bytebuf.emit_u16 buf ((uint16)numberOfNamedEntries) Bytebuf.emit_u16 buf ((uint16)numberOfIdEntries) Bytebuf.close buf let bytesToIRD (buffer:byte[]) (offset:int) = if (buffer.Length - offset) < IMAGE_RESOURCE_DIRECTORY.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_RESOURCE_DIRECTORY" IMAGE_RESOURCE_DIRECTORY( bytesToDWord(buffer.[offset], buffer.[offset+1], buffer.[offset+2], buffer.[offset+3]), // Characteristics bytesToDWord(buffer.[offset+4], buffer.[offset+5], buffer.[offset+6], buffer.[offset+7]), // TimeDateStamp bytesToWord(buffer.[offset+8], buffer.[offset+9]), // MajorVersion bytesToWord(buffer.[offset+10], buffer.[offset+11]), // MinorVersion bytesToWord(buffer.[offset+12], buffer.[offset+13]), // NumberOfNamedEntries bytesToWord(buffer.[offset+14], buffer.[offset+15])) // NumberOfIdEntries type IMAGE_RESOURCE_DIRECTORY_ENTRY(n:int32, o:int32) = let mutable name = n let mutable offset = o member x.Name with get() = name and set(v) = name <- v member x.OffsetToData with get() = offset and set(v) = offset <- v member x.OffsetToDirectory with get() = offset &&& 0x7fffffff member x.DataIsDirectory with get() = (offset &&& 0x80000000) <> 0 static member Width = 8 member x.toBytes () = let buf = Bytebuf.create IMAGE_RESOURCE_DIRECTORY_ENTRY.Width Bytebuf.emit_i32 buf name Bytebuf.emit_i32 buf offset Bytebuf.close buf let bytesToIRDE (buffer:byte[]) (offset:int) = if (buffer.Length - offset) < IMAGE_RESOURCE_DIRECTORY_ENTRY.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_RESOURCE_DIRECTORY_ENTRY" IMAGE_RESOURCE_DIRECTORY_ENTRY( bytesToDWord(buffer.[offset], buffer.[offset+1], buffer.[offset+2], buffer.[offset+3]), // Name bytesToDWord(buffer.[offset+4], buffer.[offset+5], buffer.[offset+6], buffer.[offset+7])) // Offset type IMAGE_RESOURCE_DATA_ENTRY(o:int32, s:int32, c:int32, r:int32) = let mutable offsetToData = o let mutable size = s let mutable codePage = c let mutable reserved = r member x.OffsetToData with get() = offsetToData and set(v) = offsetToData <- v member x.Size with get() = size and set(v) = size <- v member x.CodePage with get() = codePage and set(v) = codePage <- v member x.Reserved with get() = reserved and set(v) = reserved <- v static member Width = 16 member x.toBytes() = let buf = Bytebuf.create IMAGE_RESOURCE_DATA_ENTRY.Width Bytebuf.emit_i32 buf offsetToData Bytebuf.emit_i32 buf size Bytebuf.emit_i32 buf codePage Bytebuf.emit_i32 buf reserved let bytesToIRDataE (buffer:byte[]) (offset:int) = if (buffer.Length - offset) < IMAGE_RESOURCE_DATA_ENTRY.Width then invalidArg "buffer" "buffer too small to fit an IMAGE_RESOURCE_DATA_ENTRY" IMAGE_RESOURCE_DATA_ENTRY(bytesToDWord(buffer.[offset], buffer.[offset+1], buffer.[offset+2], buffer.[offset+3]), // OffsetToData bytesToDWord(buffer.[offset+4], buffer.[offset+5], buffer.[offset+6], buffer.[offset+7]), // Size bytesToDWord(buffer.[offset+8], buffer.[offset+9], buffer.[offset+10], buffer.[offset+11]), // CodePage bytesToDWord(buffer.[offset+12], buffer.[offset+13], buffer.[offset+14], buffer.[offset+15])) // Reserved type ResFormatHeader() = let mutable dwDataSize = 0 let mutable dwHeaderSize = 32 // The eventual supposed size of this structure in memory let mutable dwTypeID = 0xffff let mutable dwNameID = 0xffff let mutable dwDataVersion = 0 let mutable wMemFlags = 0s let mutable wLangID = 0s let mutable dwVersion = 0 let mutable dwCharacteristics = 0 member x.DataSize with get() = dwDataSize and set(v) = dwDataSize <- v member x.HeaderSize with get() = dwHeaderSize and set(v) = dwHeaderSize <- v member x.TypeID with get() = dwTypeID and set(v) = dwTypeID <- v member x.NameID with get() = dwNameID and set(v) = dwNameID <- v member x.DataVersion with get() = dwDataVersion and set(v) = dwDataVersion <- v member x.MemFlags with get() = wMemFlags and set(v) = wMemFlags <- v member x.LangID with get() = wLangID and set(v) = wLangID <- v member x.Version with get() = dwVersion and set(v) = dwVersion <- v member x.Characteristics with get() = dwCharacteristics and set(v) = dwCharacteristics <- v static member Width = 32 member x.toBytes() = let buf = Bytebuf.create ResFormatHeader.Width Bytebuf.emit_i32 buf dwDataSize Bytebuf.emit_i32 buf dwHeaderSize Bytebuf.emit_i32 buf dwTypeID Bytebuf.emit_i32 buf dwNameID Bytebuf.emit_i32 buf dwDataVersion Bytebuf.emit_u16 buf ((uint16)wMemFlags) Bytebuf.emit_u16 buf ((uint16)wLangID) Bytebuf.emit_i32 buf dwVersion Bytebuf.emit_i32 buf dwCharacteristics Bytebuf.close buf type ResFormatNode(tid:int32, nid:int32, lid:int32, dataOffset:int32, pbLinkedResource:byte[]) = let mutable resHdr = ResFormatHeader() let mutable dataEntry = Unchecked.defaultof let mutable cType = 0 let mutable wzType = Unchecked.defaultof let mutable cName = 0 let mutable wzName = Unchecked.defaultof do if (tid &&& 0x80000000) <> 0 then // REVIEW: Are names and types mutually exclusive? The C++ code didn't seem to think so, but I can't find any documentation resHdr.TypeID <- 0 ; let mtid = tid &&& 0x7fffffff cType <- bytesToDWord(pbLinkedResource.[mtid], pbLinkedResource.[mtid+1], pbLinkedResource.[mtid+2], pbLinkedResource.[mtid+3]) ; wzType <- Bytes.zero_create ((cType + 1) * 2) ; Bytes.blit pbLinkedResource 4 wzType 0 (cType * 2) else resHdr.TypeID <- (0xffff ||| ((tid &&& 0xffff) <<< 16)) ; if (nid &&& 0x80000000) <> 0 then resHdr.NameID <- 0 ; let mnid = nid &&& 0x7fffffff cName <- bytesToDWord(pbLinkedResource.[mnid], pbLinkedResource.[mnid+1], pbLinkedResource.[mnid+2], pbLinkedResource.[mnid+3]) ; wzName <- Bytes.zero_create ((cName + 1) * 2) ; Bytes.blit pbLinkedResource 4 wzName 0 (cName * 2) else resHdr.NameID <- (0xffff ||| ((nid &&& 0xffff) <<< 16)) resHdr.LangID <- (int16)lid ; dataEntry <- bytesToIRDataE pbLinkedResource dataOffset ; resHdr.DataSize <- dataEntry.Size member x.ResHdr with get() = resHdr member x.DataEntry with get() = dataEntry member x.Type with get() = wzType member x.Name with get() = wzName member x.Save(ulLinkedResourceBaseRVA:int32, pbLinkedResource:byte[], pUnlinkedResource:byte[], offset:int) = // Dump them to pUnlinkedResource // For each resource write header and data let size = ref 0 let unlinkedResourceOffset = ref 0 //resHdr.HeaderSize <- 32 if Unchecked.defaultof <> wzType then resHdr.HeaderSize <- resHdr.HeaderSize + ((cType + 1) * 2) - 4 if Unchecked.defaultof <> wzName then resHdr.HeaderSize <- resHdr.HeaderSize + ((cName + 1) * 2) - 4 let SaveChunk(p : byte[], sz : int) = if Unchecked.defaultof <> pUnlinkedResource then Bytes.blit p 0 pUnlinkedResource (!unlinkedResourceOffset + offset) sz unlinkedResourceOffset := !unlinkedResourceOffset + sz ; size := !size + sz ; () // ---- Constant part of the header : DWORD, DWORD SaveChunk(dwToBytes resHdr.DataSize) SaveChunk(dwToBytes resHdr.HeaderSize) let mutable dwFiller = 0 if Unchecked.defaultof <> wzType then SaveChunk(wzType,((cType + 1) * 2)) dwFiller <- dwFiller + cType + 1 else SaveChunk(dwToBytes resHdr.TypeID) if Unchecked.defaultof <> wzName then SaveChunk(wzName, ((cName + 1) * 2)) dwFiller <- dwFiller + cName + 1 else SaveChunk(dwToBytes resHdr.NameID) let bNil = Bytes.zero_create 3 // Align remaining fields on DWORD (nb. poor bit twiddling code taken from ildasm's dres.cpp) if (dwFiller &&& 0x1) <> 0 then SaveChunk(bNil, 2) //---- Constant part of the header: DWORD,WORD,WORD,DWORD,DWORD SaveChunk(dwToBytes resHdr.DataVersion) SaveChunk(wToBytes resHdr.MemFlags) SaveChunk(wToBytes resHdr.LangID) SaveChunk(dwToBytes resHdr.Version) SaveChunk(dwToBytes resHdr.Characteristics) //---- Header done, now data // just copying to make the code a bit cleaner - can blit if this ends up being a liability let pbData = pbLinkedResource.[(dataEntry.OffsetToData - ulLinkedResourceBaseRVA) ..] SaveChunk(pbData, dataEntry.Size) dwFiller <- dataEntry.Size &&& 0x3 ; if dwFiller <> 0 then SaveChunk(bNil, 4 - dwFiller) !size let linkNativeResources (unlinkedResources:byte[] list) (ulLinkedResourceBaseRVA:int32) (fileType:PEFileType) (outputFilePath:string) = let nPEFileType = match fileType with X86 -> 0 | X64 -> 2 let mutable tempResFiles : string list = [] let mutable objBytes : byte[] = [||] let unlinkedResources = unlinkedResources |> List.filter (fun arr -> arr.Length > 0) if unlinkedResources.Length = 0 then // bail if there's nothing to link objBytes else // Part 1: Write unlinked resources to an object file for linking // check if the first dword is 0x0 let firstDWord = bytesToDWord(unlinkedResources.[0].[0], unlinkedResources.[0].[1], unlinkedResources.[0].[2], unlinkedResources.[0].[3]) if firstDWord = 0 then // build the command line invocation string for cvtres.exe let corSystemDir = System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() // We'll use the current dir and a random file name rather than System.IO.Path.GetTempFileName // to try and prevent the command line invocation string from being > MAX_PATH let outputFilePaths = if outputFilePath = "" then [ Path.GetTempPath() ] else [ Path.GetTempPath() ; (outputFilePath ^ "\\") ] // Get a unique random file let rec GetUniqueRandomFileName(path) = let tfn = path ^ System.IO.Path.GetRandomFileName() if System.IO.File.Exists(tfn) then GetUniqueRandomFileName(path) else tfn let machine = if 2 = nPEFileType then "X64" else "X86" let cmdLineArgsPreamble = sprintf "/NOLOGO /READONLY /MACHINE:%s" machine let cvtres = corSystemDir^"cvtres.exe " let create_cvtres_args path = let tempObjFileName = GetUniqueRandomFileName(path) let mutable cmdLineArgs = sprintf "%s \"/Out:%s\"" cmdLineArgsPreamble tempObjFileName let mutable resFiles : string list = [] for ulr in unlinkedResources do let tempResFileName = GetUniqueRandomFileName(path) resFiles <- tempResFileName :: resFiles ; cmdLineArgs <- cmdLineArgs ^ " \"" ^ tempResFileName ^ "\"" let trf = resFiles let cmd = cmdLineArgs cmd,tempObjFileName,trf let cmdLineArgs,tempObjFileName,tempResFileNames = let attempts = outputFilePaths |> List.map (fun path -> create_cvtres_args path) |> List.filter (fun ((argstring:string),(t:string),(f:string list)) -> (cvtres.Length + argstring.Length) < MAX_PATH) match attempts with | [] -> create_cvtres_args ".\\" // hope for the best... | (invoc,tmp,files) :: rest -> tempResFiles <- files ; (invoc,tmp,files) // use the first one, since they're listed in order of precedence let cvtres_invocation = cvtres ^ cmdLineArgs try let mutable iFiles = 0 for ulr in unlinkedResources do // REVIEW: What can go wrong here? What happens when the various file calls fail // dump the unlinked resource bytes into the temp file System.IO.File.WriteAllBytes(tempResFileNames.[iFiles], ulr) ; iFiles <- iFiles + 1 // call cvtres.exe using the full cmd line string we've generated // check to see if the generated string is too long - if it is, fail with E_FAIL if cvtres_invocation.Length >= MAX_PATH then System.Runtime.InteropServices.Marshal.ThrowExceptionForHR(E_FAIL) // REVIEW: We really shouldn't be calling out to cvtres let mutable psi = System.Diagnostics.ProcessStartInfo(cvtres) psi.Arguments <- cmdLineArgs ; psi.CreateNoWindow <- true ; // REVIEW: For some reason, this still creates a window unless WindowStyle is set to hidden psi.WindowStyle <- System.Diagnostics.ProcessWindowStyle.Hidden ; let p = System.Diagnostics.Process.Start(psi) // Wait for the process to finish p.WaitForExit() check "Process.Start" p.ExitCode // TODO: really need to check against 0 // Conversion was successful, so read the object file objBytes <- System.IO.File.ReadAllBytes(tempObjFileName) ; //Array.Copy(objBytes, pbUnlinkedResource, pbUnlinkedResource.Length) System.IO.File.Delete(tempObjFileName) finally // clean up the temp files List.iter (fun tempResFileName -> System.IO.File.Delete(tempResFileName)) tempResFiles // Part 2: Read the COFF file held in pbUnlinkedResource, spit it out into pResBuffer and apply the COFF fixups // pResBuffer will become the .rsrc section of the PE file if (objBytes = Unchecked.defaultof) then System.Runtime.InteropServices.Marshal.ThrowExceptionForHR(E_FAIL) let hMod = bytesToIFH objBytes 0 if hMod.SizeOfOptionalHeader <> 0s then System.Runtime.InteropServices.Marshal.ThrowExceptionForHR(E_FAIL) let rsrc01Name = 0x313024637273722eL // ".rsrc$01" let rsrc02Name = 0x323024637273722eL // ".rsrc$02" let nullHdr = Unchecked.defaultof let mutable rsrc01 = nullHdr let mutable rsrc02 = nullHdr for i = 0 to (int)hMod.NumberOfSections do let pSection = bytesToISH objBytes (IMAGE_FILE_HEADER.Width + (IMAGE_SECTION_HEADER.Width * i)) if pSection.Name = rsrc01Name then rsrc01 <- pSection else if pSection.Name = rsrc02Name then rsrc02 <- pSection if (nullHdr = rsrc01) || (nullHdr = rsrc02) then // One of the rsrc sections wasn't found System.Runtime.InteropServices.Marshal.ThrowExceptionForHR(E_FAIL) let size = rsrc01.SizeOfRawData + rsrc02.SizeOfRawData let pResBuffer = Bytes.zero_create size // Copy over the raw data Bytes.blit objBytes rsrc01.PointerToRawData pResBuffer 0 rsrc01.SizeOfRawData // map all the relocs in .rsrc$01 using the reloc and symbol tables in the COFF object let symbolTableHead = hMod.PointerToSymbolTable let IMAGE_SYM_CLASS_STATIC = 0x3uy let IMAGE_SYM_TYPE_NULL = 0x0s let GetSymbolEntry (buffer : byte[]) (idx : int) = bytesToIS buffer (symbolTableHead + (idx * IMAGE_SYMBOL.Width) ) for iReloc = 0 to (int)(rsrc01.NumberOfRelocations - 1s) do let pReloc = bytesToIR objBytes (rsrc01.PointerToRelocations + (iReloc * IMAGE_RELOCATION.Width)) let IdxSymbol = pReloc.SymbolTableIndex let pSymbolEntry = GetSymbolEntry objBytes IdxSymbol // Ensure the symbol entry is valid for a resource if ((pSymbolEntry.StorageClass <> IMAGE_SYM_CLASS_STATIC) || (pSymbolEntry.Type <> IMAGE_SYM_TYPE_NULL) || (pSymbolEntry.SectionNumber <> 3s)) then System.Runtime.InteropServices.Marshal.ThrowExceptionForHR(E_FAIL) // Ensure that RVA is a valid address inside rsrc02 if pSymbolEntry.Value >= rsrc02.SizeOfRawData then // pSymbolEntry.Value is too big System.Runtime.InteropServices.Marshal.ThrowExceptionForHR(E_FAIL) // store the value let vBuff, vSize = dwToBytes (ulLinkedResourceBaseRVA + rsrc01.SizeOfRawData + pSymbolEntry.Value) //Bytes.blit objBytes rsrc02.PointerToRawData pResBuffer pReloc.VirtualAddress rsrc02.SizeOfRawData Bytes.blit vBuff 0 pResBuffer pReloc.VirtualAddress vSize // Copy $02 (resource raw into pResBuffer Bytes.blit objBytes rsrc02.PointerToRawData pResBuffer rsrc01.SizeOfRawData rsrc02.SizeOfRawData // return the buffer pResBuffer let DateTime1970Jan01 = new System.DateTime(1970,1,1,0,0,0,System.DateTimeKind.Utc) (* ECMA Spec (Oct2002), Part II, 24.2.2 PE File Header. *) let absilWriteGetTimeStamp () = (System.DateTime.UtcNow - DateTime1970Jan01).TotalSeconds |> int let clrInstallationDirectory () = System.Runtime.InteropServices.RuntimeEnvironment.GetRuntimeDirectory() let clrVersion () = System.Runtime.InteropServices.RuntimeEnvironment.GetSystemVersion() let unlinkResource (ulLinkedResourceBaseRVA:int32) (pbLinkedResource:byte[]) = let mutable nResNodes = 0 let pirdType = bytesToIRD pbLinkedResource 0 let mutable pirdeType = Unchecked.defaultof let nEntries = pirdType.NumberOfNamedEntries + pirdType.NumberOfIdEntries // determine entry buffer size // TODO: coalesce these two loops for iEntry = 0 to ((int)nEntries - 1) do pirdeType <- bytesToIRDE pbLinkedResource (IMAGE_RESOURCE_DIRECTORY.Width + (iEntry * IMAGE_RESOURCE_DIRECTORY_ENTRY.Width)) ; if pirdeType.DataIsDirectory then let nameBase = pirdeType.OffsetToDirectory let pirdName = bytesToIRD pbLinkedResource nameBase let mutable pirdeName = Unchecked.defaultof let nEntries2 = pirdName.NumberOfNamedEntries + pirdName.NumberOfIdEntries for iEntry2 = 0 to ((int)nEntries2 - 1) do pirdeName <- bytesToIRDE pbLinkedResource (nameBase + (iEntry2 * IMAGE_RESOURCE_DIRECTORY_ENTRY.Width)) ; let dwNameID = pirdeName.Name if pirdeName.DataIsDirectory then let langBase = pirdeName.OffsetToDirectory let pirdLang = bytesToIRD pbLinkedResource langBase let nEntries3 = pirdLang.NumberOfNamedEntries + pirdLang.NumberOfIdEntries nResNodes <- nResNodes + ((int)nEntries3) ; else nResNodes <- nResNodes + 1 ; else nResNodes <- nResNodes + 1 ; let pResNodes : ResFormatNode [] = Array.zeroCreate nResNodes nResNodes <- 0 ; // fill out the entry buffer for iEntry = 0 to ((int)nEntries - 1) do pirdeType <- bytesToIRDE pbLinkedResource (IMAGE_RESOURCE_DIRECTORY.Width + (iEntry * IMAGE_RESOURCE_DIRECTORY_ENTRY.Width)) ; let dwTypeID = pirdeType.Name // Need to skip VERSION and RT_MANIFEST resources // REVIEW: ideally we shouldn't allocate space for these, or rename properly so we don't get the naming conflict let skipResource = (0x10 = dwTypeID) || (0x18 = dwTypeID) if pirdeType.DataIsDirectory then let nameBase = pirdeType.OffsetToDirectory let pirdName = bytesToIRD pbLinkedResource nameBase let mutable pirdeName = Unchecked.defaultof let nEntries2 = pirdName.NumberOfNamedEntries + pirdName.NumberOfIdEntries for iEntry2 = 0 to ((int)nEntries2 - 1) do pirdeName <- bytesToIRDE pbLinkedResource (nameBase + (iEntry2 * IMAGE_RESOURCE_DIRECTORY_ENTRY.Width)) ; let dwNameID = pirdeName.Name if pirdeName.DataIsDirectory then let langBase = pirdeName.OffsetToDirectory let pirdLang = bytesToIRD pbLinkedResource langBase let mutable pirdeLang = Unchecked.defaultof let nEntries3 = pirdLang.NumberOfNamedEntries + pirdLang.NumberOfIdEntries for iEntry3 = 0 to ((int)nEntries3 - 1) do pirdeLang <- bytesToIRDE pbLinkedResource (langBase + (iEntry3 * IMAGE_RESOURCE_DIRECTORY_ENTRY.Width)) ; let dwLangID = pirdeLang.Name if pirdeLang.DataIsDirectory then // Resource hierarchy exceeds three levels System.Runtime.InteropServices.Marshal.ThrowExceptionForHR(E_FAIL) else if (not skipResource) then let rfn = ResFormatNode(dwTypeID, dwNameID, dwLangID, pirdeLang.OffsetToData, pbLinkedResource) pResNodes.[nResNodes] <- rfn ; nResNodes <- nResNodes + 1 ; else if (not skipResource) then let rfn = ResFormatNode(dwTypeID, dwNameID, 0, pirdeName.OffsetToData, pbLinkedResource) pResNodes.[nResNodes] <- rfn ; nResNodes <- nResNodes + 1 ; else if (not skipResource) then let rfn = ResFormatNode(dwTypeID, 0, 0, pirdeType.OffsetToData, pbLinkedResource) // REVIEW: I believe these 0s are what's causing the duplicate res naming problems pResNodes.[nResNodes] <- rfn ; nResNodes <- nResNodes + 1 ; // Ok, all tree leaves are in ResFormatNode structs, and nResNodes ptrs are in pResNodes let mutable size = 0 if nResNodes <> 0 then size <- size + ResFormatHeader.Width ; // sizeof(ResFormatHeader) for i = 0 to (nResNodes - 1) do size <- size + pResNodes.[i].Save(ulLinkedResourceBaseRVA, pbLinkedResource, Unchecked.defaultof, 0) ; let pResBuffer = Bytes.zero_create size if nResNodes <> 0 then let mutable resBufferOffset = 0 // Write a dummy header let rfh = ResFormatHeader() let rfhBytes = rfh.toBytes() Bytes.blit rfhBytes 0 pResBuffer 0 ResFormatHeader.Width resBufferOffset <- resBufferOffset + ResFormatHeader.Width ; for i = 0 to (nResNodes - 1) do resBufferOffset <- resBufferOffset + pResNodes.[i].Save(ulLinkedResourceBaseRVA, pbLinkedResource, pResBuffer, resBufferOffset) ; pResBuffer // PDB Writing [] [] [] type IMetaDataDispenser = interface abstract DefineScope : unit -> unit // need this here to fill the first vtable slot abstract OpenScope : [] szScope : string * [] dwOpenFlags:Int32 * [] riid : System.Guid byref * [] punk:Object byref -> unit end [] [] [] [] type IMetadataImport = interface abstract Placeholder : unit -> unit end [] [] [] [] type IMetadataEmit = interface abstract Placeholder : unit -> unit end [] [< Guid("B01FAFEB-C450-3A4D-BEEC-B4CEEC01E006") ; InterfaceType(ComInterfaceType.InterfaceIsIUnknown) >] [< ComVisible(false) >] type ISymUnmanagedDocumentWriter = interface abstract SetSource : sourceSize : int * source : byte[] -> unit abstract SetCheckSum : algorithmId : System.Guid * checkSumSize : int * checkSum : byte [] -> unit end // Struct used to retrieve info on the debug output [] // REVIEW - can we infer this from the use of StructLayout? [] type ImageDebugDirectory = struct val Characteristics : int32 val TimeDateStamp : int32 val MajorVersion : int16 val MinorVersion : int16 val Type : int32 val SizeOfData : int32 val AddressOfRawData : int32 val PointerToRawData : int32 end [] [] [] type ISymUnmanagedWriter2 = interface abstract DefineDocument : [] url : string * language : System.Guid byref * languageVendor : System.Guid byref * documentType : System.Guid byref * [] RetVal : ISymUnmanagedDocumentWriter byref -> unit abstract SetUserEntryPoint : entryMethod : uint32 -> unit abstract OpenMethod : meth : int -> unit abstract CloseMethod : unit -> unit abstract OpenScope : startOffset : int * pRetVal : int byref -> unit abstract CloseScope : endOffset : int -> unit abstract SetScopeRange : scopeID : int * startOffset : int * endOffset : int -> unit abstract DefineLocalVariable : [] varname : string * attributes : int * cSig : int * []signature : byte[] * addressKind : int * addr1 : int * addr2 : int * addr3 : int * startOffset : int * endOffset : int -> unit abstract DefineParameter : [] paramname : string * attributes : int * sequence : int * addressKind : int * addr1 : int * addr2 : int * addr3 : int -> unit abstract DefineField : parent : int * [] fieldname : string * attributes : int * cSig : int * []signature : byte[] * addressKind : int * addr1 : int * addr2 : int * addr3 : int -> unit abstract DefineGlobalVariable : [] globalvarname : string * attributes : int * cSig : int * []signature : byte[] * addressKind : int * addr1 : int * addr2 : int * addr3 : int -> unit abstract Close : unit -> unit abstract SetSymAttribute : parent : int * [] attname : string * cData : int * []data : byte[] -> unit abstract OpenNamespace : [] nsname : string -> unit abstract CloseNamespace : unit -> unit abstract UsingNamespace : [] fullName : string -> unit abstract SetMethodSourceRange : startDoc : ISymUnmanagedDocumentWriter * startLine : int * startColumn : int * endDoc : ISymUnmanagedDocumentWriter * endLine : int * endColumn : int -> unit abstract Initialize : emitter : nativeint * [] filename : string * stream : IStream * fullBuild : bool -> unit abstract GetDebugInfo : iDD : ImageDebugDirectory byref * cData : int * pcData : int byref * []data : byte[] -> unit abstract DefineSequencePoints : document : ISymUnmanagedDocumentWriter * spCount : int * []offsets : int [] * []lines : int [] * []columns : int [] * []endLines : int [] * []endColumns : int [] -> unit abstract RemapToken : oldToken : int * newToken : int -> unit abstract Initialize2 : emitter : nativeint * [] tempfilename : string * stream : IStream * fullBuild : bool * [] finalfilename : string -> unit abstract DefineConstant : [] constname : string * value : Object * cSig : int * []signature : byte[] -> unit abstract Abort : unit -> unit abstract DefineLocalVariable2 : [] localvarname2 : string * attributes : int * sigToken : int * addressKind : int * addr1 : int * addr2 : int * addr3 : int * startOffset : int * endOffset : int -> unit abstract DefineGlobalVariable2 : [] globalvarname2 : string * attributes : int * sigToken : int * addressKind : int * addr1 : int * addr2 : int * addr3 : int -> unit abstract DefineConstant2 : [] constantname2 : string * value : Object * sigToken : int -> unit abstract OpenMethod2 : method2 : int * isect : int * offset : int -> unit end type pdb_writer = { symWriter : ISymUnmanagedWriter2 } type pdb_document_writer = { symDocWriter : ISymUnmanagedDocumentWriter } (* pointer to pDocumentWriter COM object *) type idd = { iddCharacteristics: int32; iddMajorVersion: int32; (* actually u16 in IMAGE_DEBUG_DIRECTORY *) iddMinorVersion: int32; (* acutally u16 in IMAGE_DEBUG_DIRECTORY *) iddType: int32; iddData: byte[];} let pdbInitialize (binaryName:string) (pdbName:string) = // collect necessary COM types let CorMetaDataDispenser = System.Type.GetTypeFromProgID("CLRMetaData.CorMetaDataDispenser") let CorSymWriter = System.Type.GetTypeFromProgID("CorSymWriter_SxS") // get the importer pointer let mdd = System.Activator.CreateInstance(CorMetaDataDispenser) :?> IMetaDataDispenser let mutable IID_IMetaDataEmit = new Guid("BA3FEE4C-ECB9-4E41-83B7-183FA41CD859"); let mutable o = Object() mdd.OpenScope(binaryName, 0x1, &IID_IMetaDataEmit, &o) // 0x1 = ofWrite let emitterPtr = Marshal.GetComInterfaceForObject(o, typeof) let writer = try let writer = Activator.CreateInstance(System.Type.GetTypeFromProgID("CorSymWriter_SxS")) :?> ISymUnmanagedWriter2 writer.Initialize(emitterPtr, pdbName, Unchecked.defaultof, true) writer finally // Marshal.GetComInterfaceForObject adds an extra ref for emitterPtr if IntPtr.Zero <> emitterPtr then Marshal.Release(emitterPtr) |> ignore { symWriter = writer } [] do() [] let pdbClose (writer:pdb_writer) = writer.symWriter.Close() // REVIEW: // Ok, this is really ugly: // CorSymWriter objects (ISymUnmanagedWriter) lock the files they're operating // on (both the pdb and the binary). The locks are released only when their ref // count reaches zero, but since we're dealing with RCWs, there's no telling when // that will be. The result is that sometimes, the pdb and object files will // still be locked well after the call to this function. // The SymReader class gets around this problem by implementing the ISymUnmanagedDispose // interface, which the SymWriter class, unfortunately, does not. // Right now, I'm taking the same approach as mdbg, and manually forcing a collection // This is ghastly but, it seems at this point, necessary. let rc = Marshal.ReleaseComObject(writer.symWriter) for i = 0 to (rc - 1) do Marshal.ReleaseComObject(writer.symWriter) |> ignore System.GC.Collect(); System.GC.Collect(); System.GC.WaitForPendingFinalizers(); System.GC.Collect(); System.GC.Collect(); System.GC.WaitForPendingFinalizers(); System.GC.Collect(); System.GC.Collect(); System.GC.WaitForPendingFinalizers() let pdbSetUserEntryPoint (writer:pdb_writer) (entryMethodToken:int32) = writer.symWriter.SetUserEntryPoint((uint32)entryMethodToken) let pdbDefineDocument (writer:pdb_writer) (url:string) = //3F5162F8-07C6-11D3-9053-00C04FA302A1 let mutable corSymLanguageTypeCSharp = System.Guid(0x3F5162F8u, 0x07C6us, 0x11D3us, 0x90uy, 0x53uy, 0x00uy, 0xC0uy, 0x4Fuy, 0xA3uy, 0x02uy, 0xA1uy) let mutable corSymLanguageTypeFSharp = System.Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy) let mutable corSymLanguageVendorMicrosoft = System.Guid(0x994b45c4u, 0xe6e9us, 0x11d2us, 0x90uy, 0x3fuy, 0x00uy, 0xc0uy, 0x4fuy, 0xa3uy, 0x02uy, 0xa1uy) let mutable corSymDocumentTypeText = System.Guid(0x5a869d0bu, 0x6611us, 0x11d3us, 0xbduy, 0x2auy, 0x0uy, 0x0uy, 0xf8uy, 0x8uy, 0x49uy, 0xbduy) let mutable docWriter = Unchecked.defaultof writer.symWriter.DefineDocument(url, &corSymLanguageTypeFSharp, &corSymLanguageVendorMicrosoft, &corSymDocumentTypeText, &docWriter) { symDocWriter = docWriter } let pdbOpenMethod (writer:pdb_writer) (methodToken:int32) = writer.symWriter.OpenMethod(methodToken) let pdbCloseMethod (writer:pdb_writer) = writer.symWriter.CloseMethod() let pdbOpenScope (writer:pdb_writer) (startOffset:int32) = let mutable retInt = 0 writer.symWriter.OpenScope(startOffset, &retInt) check "action" (retInt) let pdbCloseScope (writer:pdb_writer) (endOffset:int32) = writer.symWriter.CloseScope(endOffset) let pdbDefineLocalVariable (writer:pdb_writer) (name:string) (signature:byte[]) (addr1:int32) = writer.symWriter.DefineLocalVariable(name, 0, signature.Length, signature, (int)System.Diagnostics.SymbolStore.SymAddressKind.ILOffset, addr1, 0, 0, 0, 0) let pdbSetMethodRange (writer:pdb_writer) (docWriter1: pdb_document_writer) (startLine:int) (startCol:int) (docWriter2: pdb_document_writer) (endLine:int) (endCol:int) = writer.symWriter.SetMethodSourceRange(docWriter1.symDocWriter, startLine, startCol, docWriter2.symDocWriter, endLine, endCol) let pdbDefineSequencePoints (writer:pdb_writer) (docWriter: pdb_document_writer) (pts: (int * int * int * int * int) array) = let offsets = (Array.map (fun (x,_,_,_,_) -> x) pts) in let lines = (Array.map (fun (_,x,_,_,_) -> x) pts) in let columns = (Array.map (fun (_,_,x,_,_) -> x) pts) in let endLines = (Array.map (fun (_,_,_,x,_) -> x) pts) in let endColumns = (Array.map (fun (_,_,_,_,x) -> x) pts) in writer.symWriter.DefineSequencePoints(docWriter.symDocWriter, pts.Length, offsets, lines, columns, endLines, endColumns) let pdbGetDebugInfo (writer: pdb_writer) = let mutable iDD = new ImageDebugDirectory() let mutable length = 0 writer.symWriter.GetDebugInfo(&iDD, 0, &length, null) let mutable data : byte [] = Array.zeroCreate length writer.symWriter.GetDebugInfo(&iDD, length, &length, data) { iddCharacteristics = iDD.Characteristics; iddMajorVersion = (int32)iDD.MajorVersion; iddMinorVersion = (int32)iDD.MinorVersion; iddType = iDD.Type; iddData = data} // PDB reading type pdb_reader = { symReader: ISymbolReader } type pdb_document = { symDocument: ISymbolDocument } type pdb_method = { symMethod: ISymbolMethod } type pdb_variable = { symVariable: ISymbolVariable } type pdb_method_scope = { symScope: ISymbolScope } type pdb_sequence_point = { pdbSeqPointOffset: int; pdbSeqPointDocument: pdb_document; pdbSeqPointLine: int; pdbSeqPointColumn: int; pdbSeqPointEndLine: int; pdbSeqPointEndColumn: int; } let pdbReadOpen (moduleName:string) (path:string) : pdb_reader = let CorMetaDataDispenser = System.Type.GetTypeFromProgID("CLRMetaData.CorMetaDataDispenser") let mutable IID_IMetaDataImport = new Guid("7DAC8207-D3AE-4c75-9B67-92801A497D44"); let mdd = System.Activator.CreateInstance(CorMetaDataDispenser) :?> IMetaDataDispenser let mutable o : Object = new Object() mdd.OpenScope(moduleName, 0, &IID_IMetaDataImport, &o) ; let importerPtr = Marshal.GetComInterfaceForObject(o, typeof) try let symbolBinder = System.Diagnostics.SymbolStore.SymBinder() { symReader = symbolBinder.GetReader(importerPtr, moduleName, path) } finally // Marshal.GetComInterfaceForObject adds an extra ref for importerPtr if IntPtr.Zero <> importerPtr then Marshal.Release(importerPtr) |> ignore // REVIEW: // The symbol reader's finalize method will clean up any unmanaged resources. // If file locks persist, we may want to manually invoke finalize let pdbReadClose (reader:pdb_reader) : unit = () let pdbReaderGetMethod (reader:pdb_reader) (token:int32) : pdb_method = { symMethod = reader.symReader.GetMethod(System.Diagnostics.SymbolStore.SymbolToken(token)) } let pdbReaderGetMethodFromDocumentPosition (reader:pdb_reader) (document:pdb_document) (line:int) (column:int) : pdb_method = { symMethod = reader.symReader.GetMethodFromDocumentPosition(document.symDocument, line, column) } let pdbReaderGetDocuments (reader:pdb_reader) : pdb_document array = let arr = reader.symReader.GetDocuments() Array.map (fun i -> { symDocument=i }) arr let pdbReaderGetDocument (reader:pdb_reader) (url:string) (language:byte[]) (languageVendor:byte[]) (documentType:byte[]) : pdb_document = { symDocument = reader.symReader.GetDocument(url, System.Guid(language), System.Guid(languageVendor), System.Guid(documentType)) } let pdbDocumentGetURL (document:pdb_document) : string = document.symDocument.URL let pdbDocumentGetType (document:pdb_document) : byte[] (* guid *) = let guid = document.symDocument.DocumentType guid.ToByteArray() let pdbDocumentGetLanguage (document:pdb_document) : byte[] (* guid *) = let guid = document.symDocument.Language guid.ToByteArray() let pdbDocumentGetLanguageVendor (document:pdb_document) : byte[] = let guid = document.symDocument.LanguageVendor guid.ToByteArray() let pdbDocumentFindClosestLine (document:pdb_document) (line:int) : int = document.symDocument.FindClosestLine(line) let pdbMethodGetToken (meth:pdb_method) : int32 = let token = meth.symMethod.Token token.GetToken() let pdbMethodGetRootScope (meth:pdb_method) : pdb_method_scope = { symScope = meth.symMethod.RootScope } let pdbMethodGetSequencePoints (meth:pdb_method) : pdb_sequence_point array = let pSize = meth.symMethod.SequencePointCount let offsets = Array.zeroCreate pSize let docs = Array.zeroCreate pSize let lines = Array.zeroCreate pSize let cols = Array.zeroCreate pSize let endLines = Array.zeroCreate pSize let endColumns = Array.zeroCreate pSize meth.symMethod.GetSequencePoints(offsets, docs, lines, cols, endLines, endColumns) Array.init pSize (fun i -> { pdbSeqPointOffset = offsets.[i]; pdbSeqPointDocument = { symDocument = docs.[i] }; pdbSeqPointLine = lines.[i]; pdbSeqPointColumn = cols.[i]; pdbSeqPointEndLine = endLines.[i]; pdbSeqPointEndColumn = endColumns.[i]; }) let pdbScopeGetChildren (scope:pdb_method_scope) : pdb_method_scope array = let arr = scope.symScope.GetChildren() Array.map (fun i -> { symScope=i }) arr let pdbScopeGetOffsets (scope:pdb_method_scope) : int * int = (scope.symScope.StartOffset, scope.symScope.EndOffset) let pdbScopeGetLocals (scope:pdb_method_scope) : pdb_variable array = let arr = scope.symScope.GetLocals() Array.map (fun i -> { symVariable=i }) arr let pdbVariableGetName (variable:pdb_variable) : string = variable.symVariable.Name let pdbVariableGetSignature (variable:pdb_variable) : byte[] = variable.symVariable.GetSignature() // the tuple is (AddressKind, AddressField1) let pdbVariableGetAddressAttributes (variable:pdb_variable) : (int32 * int32) = ((int32)variable.symVariable.AddressKind,variable.symVariable.AddressField1) // Key signing type keyContainerName = string type keyPair = byte[] type pubkey = byte[] #if FX_ATLEAST_40 // new mscoree functionality // This type represents methods that we don't currently need, so I'm leaving unimplemented type UnusedCOMMethod = unit -> unit [] [] type ICLRMetaHost = interface [] abstract GetRuntime : [] version : string * [] interfaceId : System.Guid -> [] System.Object // REVIEW: Methods that we don't need will be stubbed out for now... abstract GetVersionFromFile : UnusedCOMMethod abstract EnumerateInstalledRuntimes : UnusedCOMMethod abstract EnumerateLoadedRuntimes : UnusedCOMMethod abstract Reserved01 : UnusedCOMMethod end // REVIEW: We don't currently support ComConversionLoss [] [] type ICLRStrongName = interface // REVIEW: Methods that we don't need will be stubbed out for now... abstract GetHashFromAssemblyFile : UnusedCOMMethod abstract GetHashFromAssemblyFileW : UnusedCOMMethod abstract GetHashFromBlob : UnusedCOMMethod abstract GetHashFromFile : UnusedCOMMethod abstract GetHashFromFileW : UnusedCOMMethod abstract GetHashFromHandle : UnusedCOMMethod abstract StrongNameCompareAssemblies : UnusedCOMMethod [] abstract StrongNameFreeBuffer : [] pbMemory : nativeint -> unit abstract StrongNameGetBlob : UnusedCOMMethod abstract StrongNameGetBlobFromImage : UnusedCOMMethod [] abstract StrongNameGetPublicKey : [] pwzKeyContainer : string * [] pbKeyBlob : byte[] * [] cbKeyBlob : uint32 * [] ppbPublicKeyBlob : nativeint byref * [] pcbPublicKeyBlob : uint32 byref -> unit abstract StrongNameHashSize : UnusedCOMMethod [] abstract StrongNameKeyDelete : [] pwzKeyContainer : string -> unit abstract StrongNameKeyGen : UnusedCOMMethod abstract StrongNameKeyGenEx : UnusedCOMMethod abstract StrongNameKeyInstall : UnusedCOMMethod [] abstract StrongNameSignatureGeneration : [] pwzFilePath : string * [] pwzKeyContainer : string * [] pbKeyBlob : byte [] * [] cbKeyBlob : uint32 * [] ppbSignatureBlob : nativeint byref * [] pcbSignatureBlob : uint32 byref -> unit abstract StrongNameSignatureGenerationEx : UnusedCOMMethod [] abstract StrongNameSignatureSize : [] pbPublicKeyBlob : byte[] * [] cbPublicKeyBlob : uint32 * [] pcbSize : uint32 byref -> unit abstract StrongNameSignatureVerification : UnusedCOMMethod [] abstract StrongNameSignatureVerificationEx : [] pwzFilePath : string * [] fForceVerification : bool -> [] bool abstract StrongNameSignatureVerificationFromImage : UnusedCOMMethod abstract StrongNameTokenFromAssembly : UnusedCOMMethod abstract StrongNameTokenFromAssemblyEx : UnusedCOMMethod abstract StrongNameTokenFromPublicKey : UnusedCOMMethod end [] [] type ICLRRuntimeInfo = interface // REVIEW: Methods that we don't need will be stubbed out for now... abstract GetVersionString : unit -> unit abstract GetRuntimeDirectory : unit -> unit abstract IsLoaded : unit -> unit abstract LoadErrorString : unit -> unit abstract LoadLibrary : unit -> unit abstract GetProcAddress : unit -> unit [] abstract GetInterface : [] coClassId : System.Guid * [] interfaceId : System.Guid -> []System.Object end [] [] let GetCLRMetaHost (([] guid : System.Guid), ([] metaHost : ICLRMetaHost byref)) : unit = failwith "GetCLRMetaHost" #else [< DllImport("mscoree.dll", SetLastError = true, CharSet = CharSet.Unicode) >] let StrongNameGetPublicKey ((wszKeyContainer : string), (keyBlob : byte[]), (cbKeyBlob : uint32), (ppbPublicKeyBlob : nativeint byref), (pcbPublicKeyBlob : uint32 byref)) : bool = failwith "" [< DllImport("mscoree.dll", SetLastError = true, CharSet = CharSet.Unicode) >] let StrongNameFreeBuffer (pbMemory : nativeint) : bool = failwith "" [< DllImport("mscoree.dll", SetLastError = true, CharSet = CharSet.Unicode) >] let StrongNameKeyDelete (wszKeyContainer : string) : bool = failwith "" [< DllImport("mscoree.dll", SetLastError = true, CharSet = CharSet.Unicode) >] let StrongNameSignatureSize ( (pbPublicKeyBlob : byte []), (cbPublicKeyBlob : uint32), (pcbSize : uint32 byref)) : bool = failwith "" [< DllImport("mscoree.dll", SetLastError = true, CharSet = CharSet.Unicode) >] // Review: Should use the "Ex" version? let StrongNameSignatureGeneration ( (wszFilePath : string), (wszKeyContainer : string), (pbKeyBlob : byte []), (cbKeyBlob : uint32), (ppbSignatureBlob : nativeint), (pcbSignatureBlob : uint32 byref)) : bool = failwith "" [< DllImport("mscoree.dll", SetLastError = true, CharSet = CharSet.Unicode) >] let StrongNameSignatureVerificationEx ( ([] wszFilePath : string), ([] fForceVerification : bool), ([] pfWasVerified : bool byref) ) : [] bool = failwith "" #endif let signerOpenPublicKeyFile filePath = System.IO.File.ReadAllBytes(filePath) let signerOpenKeyPairFile filePath = System.IO.File.ReadAllBytes(filePath) #if FX_ATLEAST_40 let mutable iclrsn : ICLRStrongName option = None let getICLRStrongName () = match iclrsn with | None -> let CLSID_CLRStrongName = System.Guid(0xB79B0ACDu, 0xF5CDus, 0x409bus, 0xB5uy, 0xA5uy, 0xA1uy, 0x62uy, 0x44uy, 0x61uy, 0x0Buy, 0x92uy) let IID_ICLRStrongName = System.Guid(0x9FD93CCFu, 0x3280us, 0x4391us, 0xB3uy, 0xA9uy, 0x96uy, 0xE1uy, 0xCDuy, 0xE7uy, 0x7Cuy, 0x8Duy) let IID_ICLRMetaHost = System.Guid(0xD332DB9Eu, 0xB9B3us, 0x4125us, 0x82uy, 0x07uy, 0xA1uy, 0x48uy, 0x84uy, 0xF5uy, 0x32uy, 0x15uy) let clrRuntimeInfoGuid = System.Guid(0xBD39D1D2u, 0xBA2Fus, 0x486aus, 0x89uy, 0xB0uy, 0xB4uy, 0xB0uy, 0xCBuy, 0x46uy, 0x68uy, 0x91uy) let runtimeVer = System.Runtime.InteropServices.RuntimeEnvironment.GetSystemVersion() let mutable metaHost = Unchecked.defaultof GetCLRMetaHost(IID_ICLRMetaHost, &metaHost) if Unchecked.defaultof = metaHost then failwith "Unable to obtain ICLRMetaHost object - check freshness of mscoree.dll" let runtimeInfo = metaHost.GetRuntime(runtimeVer, clrRuntimeInfoGuid) :?> ICLRRuntimeInfo let sn = runtimeInfo.GetInterface(CLSID_CLRStrongName, IID_ICLRStrongName) :?> ICLRStrongName if Unchecked.defaultof = sn then failwith "Unable to obtain ICLRStrongName object" iclrsn <- Some(sn) sn | Some(sn) -> sn #endif let signerGetPublicKeyForKeyPair kp = let mutable pSize = 0u let mutable pBuffer : nativeint = (nativeint)0 #if FX_ATLEAST_40 let iclrSN = getICLRStrongName() iclrSN.StrongNameGetPublicKey(Unchecked.defaultof, kp, (uint32) (Bytes.length kp), &pBuffer, &pSize) |> ignore #else StrongNameGetPublicKey(Unchecked.defaultof, kp, (uint32) (Bytes.length kp), &pBuffer, &pSize) |> ignore check "action" (Marshal.GetLastWin32Error()) #endif let mutable keybuffer : byte [] = Bytes.zero_create ((int)pSize) // Copy the marshalled data over - we'll have to free this ourselves Marshal.Copy(pBuffer, keybuffer, 0, (int)pSize) #if FX_ATLEAST_40 iclrSN.StrongNameFreeBuffer(pBuffer) |> ignore #else StrongNameFreeBuffer(pBuffer) |> ignore check "signerGetPublicKeyForKeyPair" (Marshal.GetLastWin32Error()) #endif keybuffer let signerGetPublicKeyForKeyContainer kc = let mutable pSize = 0u let mutable pBuffer : nativeint = (nativeint)0 #if FX_ATLEAST_40 let iclrSN = getICLRStrongName() iclrSN.StrongNameGetPublicKey(kc, Unchecked.defaultof, 0u, &pBuffer, &pSize) |> ignore #else StrongNameGetPublicKey(kc, Unchecked.defaultof, 0u, &pBuffer, &pSize) |> ignore check "action" (Marshal.GetLastWin32Error()) #endif let mutable keybuffer : byte [] = Bytes.zero_create ((int)pSize) // Copy the marshalled data over - we'll have to free this ourselves later Marshal.Copy(pBuffer, keybuffer, 0, (int)pSize) #if FX_ATLEAST_40 iclrSN.StrongNameFreeBuffer(pBuffer) |> ignore #else StrongNameFreeBuffer(pBuffer) |> ignore check "signerGetPublicKeyForKeyContainer" (Marshal.GetLastWin32Error()) #endif keybuffer let signerCloseKeyContainer kc = #if FX_ATLEAST_40 let iclrSN = getICLRStrongName() iclrSN.StrongNameKeyDelete(kc) |> ignore #else StrongNameKeyDelete(kc) |> ignore check "signerCloseKeyContainer" (Marshal.GetLastWin32Error()) #endif let signerSignatureSize pk = let mutable pSize = 0u #if FX_ATLEAST_40 let iclrSN = getICLRStrongName() iclrSN.StrongNameSignatureSize(pk, (uint32)(Bytes.length pk), &pSize) |> ignore #else StrongNameSignatureSize(pk, (uint32)(Bytes.length pk), &pSize) |> ignore check "signerSignatureSize" (Marshal.GetLastWin32Error()) #endif (int)pSize let signerSignFileWithKeyPair fileName kp = let mutable pcb = 0u let mutable ppb = (nativeint)0 let mutable ok = false #if FX_ATLEAST_40 let iclrSN = getICLRStrongName() iclrSN.StrongNameSignatureGeneration(fileName, Unchecked.defaultof, kp, (uint32)(Bytes.length kp), &ppb, &pcb) |> ignore #else StrongNameSignatureGeneration(fileName, Unchecked.defaultof, kp, (uint32)(Bytes.length kp), ppb, &pcb) |> ignore check "action" (Marshal.GetLastWin32Error()) #endif #if FX_ATLEAST_40 iclrSN.StrongNameSignatureVerificationEx(fileName, true) |> ignore #else StrongNameSignatureVerificationEx(fileName, true, &ok) |> ignore check "signerSignFileWithKeyPair" (Marshal.GetLastWin32Error()) #endif let signerSignFileWithKeyContainer fileName kcName = let mutable pcb = 0u let mutable ppb = (nativeint)0 let mutable ok = false #if FX_ATLEAST_40 let iclrSN = getICLRStrongName() iclrSN.StrongNameSignatureGeneration(fileName, kcName, Unchecked.defaultof, 0u, &ppb, &pcb) |> ignore #else StrongNameSignatureGeneration(fileName, kcName, Unchecked.defaultof, 0u, ppb, &pcb) |> ignore check "action" (Marshal.GetLastWin32Error()) #endif #if FX_ATLEAST_40 iclrSN.StrongNameSignatureVerificationEx(fileName, true) |> ignore #else StrongNameSignatureVerificationEx(fileName, true, &ok) |> ignore check "signerSignFileWithKeyPair" (Marshal.GetLastWin32Error()) #endif