Enable hash algorithm selection (#7252)

* Enable hash algorithm selection

* Feedback

* More feedback

* Revert "Feedback"

This reverts commit 6ab1b077b413712f552bad9b2562aeb63994ad4c.

* feedback

Author: KevinRansom

src/absil/ilwrite.fs

@@ -3025,7 +3025,8 @@ let generateIL requiredDataFixups (desiredMetadataVersion, generatePdb, ilg : IL
 //=====================================================================
 // TABLES+BLOBS --> PHYSICAL METADATA+BLOBS
 //=====================================================================
-let chunk sz next = ({addr=next; size=sz}, next + sz) 
+let chunk sz next = ({addr=next; size=sz}, next + sz)
+let emptychunk next = ({addr=next; size=0}, next)
 let nochunk next = ({addr= 0x0;size= 0x0; }, next)
 
 let count f arr = 
@@ -3516,7 +3517,7 @@ let writeBytes (os: BinaryWriter) (chunk: byte[]) = os.Write(chunk, 0, chunk.Len
 
 let writeBinaryAndReportMappings (outfile, 
                                   ilg: ILGlobals, pdbfile: string option, signer: ILStrongNameSigner option, portablePDB, embeddedPDB,
-                                  embedAllSource, embedSourceList, sourceLink, emitTailcalls, deterministic, showTimes, dumpDebugInfo, pathMap)
+                                  embedAllSource, embedSourceList, sourceLink, checksumAlgorithm, emitTailcalls, deterministic, showTimes, dumpDebugInfo, pathMap)
                                   modul normalizeAssemblyRefs =
     // Store the public key from the signer into the manifest. This means it will be written 
     // to the binary and also acts as an indicator to leave space for delay sign 
@@ -3565,7 +3566,7 @@ let writeBinaryAndReportMappings (outfile,
         with e -> 
             failwith ("Could not open file for writing (binary mode): " + outfile)    
 
-    let pdbData, pdbOpt, debugDirectoryChunk, debugDataChunk, debugEmbeddedPdbChunk, textV2P, mappings =
+    let pdbData, pdbOpt, debugDirectoryChunk, debugDataChunk, debugChecksumPdbChunk, debugEmbeddedPdbChunk, debugDeterministicPdbChunk, textV2P, mappings =
         try 
 
           let imageBaseReal = modul.ImageBase // FIXED CHOICE
@@ -3670,42 +3671,61 @@ let writeBinaryAndReportMappings (outfile,
           let pdbOpt =
             match portablePDB with
             | true -> 
-                let (uncompressedLength, contentId, stream) as pdbStream = 
-                    generatePortablePdb embedAllSource embedSourceList sourceLink showTimes pdbData deterministic pathMap
+                let (uncompressedLength, contentId, stream, algorithmName, checkSum) as pdbStream = 
+                    generatePortablePdb embedAllSource embedSourceList sourceLink checksumAlgorithm showTimes pdbData pathMap
 
-                if embeddedPDB then Some (compressPortablePdbStream uncompressedLength contentId stream)
+                if embeddedPDB then
+                    let uncompressedLength, contentId, stream = compressPortablePdbStream uncompressedLength contentId stream
+                    Some (uncompressedLength, contentId, stream, algorithmName, checkSum)
                 else Some pdbStream
 
             | _ -> None
 
-          let debugDirectoryChunk, next = 
-            chunk (if pdbfile = None then 
-                       0x0
-                   else if embeddedPDB && portablePDB then
-                       sizeof_IMAGE_DEBUG_DIRECTORY * 2
+          let debugDirectoryChunk, next =
+            chunk (if pdbfile = None then
+                        0x0
                    else
-                       sizeof_IMAGE_DEBUG_DIRECTORY
+                        sizeof_IMAGE_DEBUG_DIRECTORY * 2 +
+                        (if embeddedPDB then sizeof_IMAGE_DEBUG_DIRECTORY else 0) +
+                        (if deterministic then sizeof_IMAGE_DEBUG_DIRECTORY else 0)
                   ) next
+
           // The debug data is given to us by the PDB writer and appears to 
           // typically be the type of the data plus the PDB file name. We fill 
           // this in after we've written the binary. We approximate the size according 
           // to what PDB writers seem to require and leave extra space just in case... 
           let debugDataJustInCase = 40
-          let debugDataChunk, next = 
+          let debugDataChunk, next =
               chunk (align 0x4 (match pdbfile with 
                                 | None -> 0
                                 | Some f -> (24 
                                             + System.Text.Encoding.Unicode.GetByteCount f // See bug 748444
                                             + debugDataJustInCase))) next
 
-          let debugEmbeddedPdbChunk, next = 
-              let streamLength = 
-                    match pdbOpt with
-                    | Some (_, _, stream) -> int stream.Length
-                    | None -> 0
-              chunk (align 0x4 (match embeddedPDB with 
-                                | true -> 8 + streamLength
-                                | _ -> 0 )) next
+          let debugChecksumPdbChunk, next =
+              chunk (align 0x4 (match pdbOpt with
+                                | Some (_, _, _, algorithmName, checkSum) ->
+                                    let alg = System.Text.Encoding.UTF8.GetBytes(algorithmName)
+                                    let size = alg.Length + 1 + checkSum.Length
+                                    size
+                                | None -> 0)) next
+
+          let debugEmbeddedPdbChunk, next =
+              if embeddedPDB then
+                  let streamLength = 
+                      match pdbOpt with
+                      | Some (_, _, stream, _, _) -> int stream.Length
+                      | None -> 0
+                  chunk (align 0x4 (match embeddedPDB with 
+                                     | true -> 8 + streamLength
+                                     | _ -> 0 )) next
+              else
+                  nochunk next
+
+          let debugDeterministicPdbChunk, next =
+              if deterministic then emptychunk next 
+              else nochunk next
+
 
           let textSectionSize = next - textSectionAddr
           let nextPhys = align alignPhys (textSectionPhysLoc + textSectionSize)
@@ -3804,35 +3824,39 @@ let writeBinaryAndReportMappings (outfile,
                   if pCurrent <> pExpected then 
                     failwith ("warning: "+chunkName+" not where expected, pCurrent = "+string pCurrent+", p.addr = "+string pExpected) 
               writeBytes os chunk 
-          
+
           let writePadding (os: BinaryWriter) _comment sz =
               if sz < 0 then failwith "writePadding: size < 0"
               for i = 0 to sz - 1 do 
                   os.Write 0uy
-          
+
           // Now we've computed all the offsets, write the image 
-          
+
           write (Some msdosHeaderChunk.addr) os "msdos header" msdosHeader
-          
+
           write (Some peSignatureChunk.addr) os "pe signature" [| |]
-          
+
           writeInt32 os 0x4550
-          
+
           write (Some peFileHeaderChunk.addr) os "pe file header" [| |]
-          
+
           if (modul.Platform = Some AMD64) then
             writeInt32AsUInt16 os 0x8664    // Machine - IMAGE_FILE_MACHINE_AMD64 
           elif isItanium then
             writeInt32AsUInt16 os 0x200
           else
             writeInt32AsUInt16 os 0x014c   // Machine - IMAGE_FILE_MACHINE_I386 
-            
+
           writeInt32AsUInt16 os numSections
 
-          let pdbData = 
+          let pdbData =
+            // Hash code, data and metadata
             if deterministic then
-              // Hash code, data and metadata
-              use sha = System.Security.Cryptography.SHA1.Create()    // IncrementalHash is core only
+              use sha =
+                  match checksumAlgorithm with
+                  | HashAlgorithm.Sha1 -> System.Security.Cryptography.SHA1.Create() :> System.Security.Cryptography.HashAlgorithm
+                  | HashAlgorithm.Sha256 -> System.Security.Cryptography.SHA256.Create() :> System.Security.Cryptography.HashAlgorithm
+
               let hCode = sha.ComputeHash code
               let hData = sha.ComputeHash data
               let hMeta = sha.ComputeHash metadata
@@ -3848,6 +3872,7 @@ let writeBinaryAndReportMappings (outfile,
               // Use last 4 bytes for timestamp - High bit set, to stop tool chains becoming confused
               let timestamp = int final.[16] ||| (int final.[17] <<< 8) ||| (int final.[18] <<< 16) ||| (int (final.[19] ||| 128uy) <<< 24) 
               writeInt32 os timestamp
+
               // Update pdbData with new guid and timestamp. Portable and embedded PDBs don't need the ModuleID
               // Full and PdbOnly aren't supported under deterministic builds currently, they rely on non-determinsitic Windows native code
               { pdbData with ModuleID = final.[0..15] ; Timestamp = timestamp }
@@ -4133,10 +4158,14 @@ let writeBinaryAndReportMappings (outfile,
           if pdbfile.IsSome then 
               write (Some (textV2P debugDirectoryChunk.addr)) os "debug directory" (Array.create debugDirectoryChunk.size 0x0uy)
               write (Some (textV2P debugDataChunk.addr)) os "debug data" (Array.create debugDataChunk.size 0x0uy)
+              write (Some (textV2P debugChecksumPdbChunk.addr)) os "debug checksum" (Array.create debugChecksumPdbChunk.size 0x0uy)
 
           if embeddedPDB then
               write (Some (textV2P debugEmbeddedPdbChunk.addr)) os "debug data" (Array.create debugEmbeddedPdbChunk.size 0x0uy)
 
+          if deterministic then
+              write (Some (textV2P debugDeterministicPdbChunk.addr)) os "debug deterministic" Array.empty
+
           writePadding os "end of .text" (dataSectionPhysLoc - textSectionPhysLoc - textSectionSize)
 
           // DATA SECTION 
@@ -4182,7 +4211,7 @@ let writeBinaryAndReportMappings (outfile,
               FileSystemUtilites.setExecutablePermission outfile
           with _ -> 
               ()
-          pdbData, pdbOpt, debugDirectoryChunk, debugDataChunk, debugEmbeddedPdbChunk, textV2P, mappings
+          pdbData, pdbOpt, debugDirectoryChunk, debugDataChunk, debugChecksumPdbChunk, debugEmbeddedPdbChunk, debugDeterministicPdbChunk, textV2P, mappings
 
         // Looks like a finally
         with e ->   
@@ -4207,11 +4236,11 @@ let writeBinaryAndReportMappings (outfile,
         try 
             let idd = 
                 match pdbOpt with 
-                | Some (originalLength, contentId, stream) ->
+                | Some (originalLength, contentId, stream, algorithmName, checkSum) ->
                     if embeddedPDB then
-                        embedPortablePdbInfo originalLength contentId stream showTimes fpdb debugDataChunk debugEmbeddedPdbChunk
+                        embedPortablePdbInfo originalLength contentId stream showTimes fpdb debugDataChunk debugEmbeddedPdbChunk debugDeterministicPdbChunk debugChecksumPdbChunk algorithmName checkSum embeddedPDB deterministic
                     else
-                        writePortablePdbInfo contentId stream showTimes fpdb pathMap debugDataChunk
+                        writePortablePdbInfo contentId stream showTimes fpdb pathMap debugDataChunk debugDeterministicPdbChunk debugChecksumPdbChunk algorithmName checkSum embeddedPDB deterministic
                 | None ->
 #if FX_NO_PDB_WRITER
                     Array.empty<idd>
@@ -4232,16 +4261,17 @@ let writeBinaryAndReportMappings (outfile,
                     writeInt32AsUInt16 os2 i.iddMajorVersion
                     writeInt32AsUInt16 os2 i.iddMinorVersion
                     writeInt32 os2 i.iddType
-                    writeInt32 os2 i.iddData.Length               // IMAGE_DEBUG_DIRECTORY.SizeOfData 
-                    writeInt32 os2 i.iddChunk.addr                // IMAGE_DEBUG_DIRECTORY.AddressOfRawData 
-                    writeInt32 os2 (textV2P i.iddChunk.addr)      // IMAGE_DEBUG_DIRECTORY.PointerToRawData 
+                    writeInt32 os2 i.iddData.Length               // IMAGE_DEBUG_DIRECTORY.SizeOfData
+                    writeInt32 os2 i.iddChunk.addr                // IMAGE_DEBUG_DIRECTORY.AddressOfRawData
+                    writeInt32 os2 (textV2P i.iddChunk.addr)      // IMAGE_DEBUG_DIRECTORY.PointerToRawData
 
                 // Write the Debug Data
                 for i in idd do
-                    // write the debug raw data as given us by the PDB writer 
-                    os2.BaseStream.Seek (int64 (textV2P i.iddChunk.addr), SeekOrigin.Begin) |> ignore
-                    if i.iddChunk.size < i.iddData.Length then failwith "Debug data area is not big enough. Debug info may not be usable"
-                    writeBytes os2 i.iddData
+                    if i.iddChunk.size <> 0 then
+                        // write the debug raw data as given us by the PDB writer 
+                        os2.BaseStream.Seek (int64 (textV2P i.iddChunk.addr), SeekOrigin.Begin) |> ignore
+                        if i.iddChunk.size < i.iddData.Length then failwith "Debug data area is not big enough. Debug info may not be usable"
+                        writeBytes os2 i.iddData
                 os2.Dispose()
             with e -> 
                 failwith ("Error while writing debug directory entry: "+e.Message)
@@ -4250,9 +4280,7 @@ let writeBinaryAndReportMappings (outfile,
         with e -> 
             reraise()
 
-    end      
-    ignore debugDataChunk
-    ignore debugEmbeddedPdbChunk
+    end
     reportTime showTimes "Finalize PDB"
 
     /// Sign the binary. No further changes to binary allowed past this point! 
@@ -4280,15 +4308,16 @@ type options =
      embedAllSource: bool
      embedSourceList: string list
      sourceLink: string
+     checksumAlgorithm: HashAlgorithm
      signer: ILStrongNameSigner option
-     emitTailcalls : bool
-     deterministic : bool
+     emitTailcalls: bool
+     deterministic: bool
      showTimes: bool
      dumpDebugInfo: bool
      pathMap: PathMap }
 
 let WriteILBinary (outfile, (args: options), modul, normalizeAssemblyRefs) =
     writeBinaryAndReportMappings (outfile, 
                                   args.ilg, args.pdbfile, args.signer, args.portablePDB, args.embeddedPDB, args.embedAllSource, 
-                                  args.embedSourceList, args.sourceLink, args.emitTailcalls, args.deterministic, args.showTimes, args.dumpDebugInfo, args.pathMap) modul normalizeAssemblyRefs
+                                  args.embedSourceList, args.sourceLink, args.checksumAlgorithm, args.emitTailcalls, args.deterministic, args.showTimes, args.dumpDebugInfo, args.pathMap) modul normalizeAssemblyRefs
     |> ignore

src/absil/ilwrite.fsi

@@ -1,12 +1,13 @@
 // Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
 
 /// The IL Binary writer.
-module internal FSharp.Compiler.AbstractIL.ILBinaryWriter 
+module internal FSharp.Compiler.AbstractIL.ILBinaryWriter
 
 open Internal.Utilities
-open FSharp.Compiler.AbstractIL 
-open FSharp.Compiler.AbstractIL.Internal 
-open FSharp.Compiler.AbstractIL.IL 
+open FSharp.Compiler.AbstractIL
+open FSharp.Compiler.AbstractIL.Internal
+open FSharp.Compiler.AbstractIL.IL
+open FSharp.Compiler.AbstractIL.ILPdbWriter
 
 [<Sealed>]
 type ILStrongNameSigner =
@@ -24,6 +25,7 @@ type options =
    embedAllSource: bool
    embedSourceList: string list
    sourceLink: string
+   checksumAlgorithm: HashAlgorithm
    signer : ILStrongNameSigner option
    emitTailcalls: bool
    deterministic: bool