diff --git a/azure-pipelines-PR.yml b/azure-pipelines-PR.yml index 9a359b41c23..f880268814e 100644 --- a/azure-pipelines-PR.yml +++ b/azure-pipelines-PR.yml @@ -494,8 +494,15 @@ stages: steps: - checkout: self clean: true - - script: ./eng/cibuild.sh --configuration $(_BuildConfig) --testcoreclr + - script: ./eng/cibuild.sh --configuration $(_BuildConfig) --testcoreclr --mt true displayName: Build / Test + - script: ./eng/common/dotnet.sh fsi tests/EndToEndBuildTests/MultithreadedTasks/run.fsx -- --configuration $(_BuildConfig) --repetitions 3 + displayName: Real SDK MP / MT integration + - task: PublishPipelineArtifact@1 + condition: always() + inputs: + targetPath: '$(Build.SourcesDirectory)/artifacts/MultithreadedTasks' + artifact: Linux SDK MT evidence - task: PublishTestResults@2 displayName: Publish Test Results inputs: @@ -543,7 +550,7 @@ stages: steps: - template: /eng/templates/batched-test-steps.yml parameters: - buildCommand: ./eng/cibuild.sh --configuration $(_BuildConfig) --testcoreclrbatch $(batchNumber) + buildCommand: ./eng/cibuild.sh --configuration $(_BuildConfig) --testcoreclrbatch $(batchNumber) --mt true buildEnv: COMPlus_DefaultStackSize: 1000000 testRunTitlePrefix: 'MacOS' @@ -566,6 +573,13 @@ stages: displayName: Verify FSharp.Core package assets - script: .\tests\EndToEndBuildTests\EndToEndBuildTests.cmd -c Release displayName: End to end build tests + - script: .\eng\common\dotnet.cmd fsi tests\EndToEndBuildTests\MultithreadedTasks\run.fsx -- --configuration Release --repetitions 3 + displayName: Real SDK MP / MT integration + - task: PublishPipelineArtifact@1 + condition: always() + inputs: + targetPath: '$(Build.SourcesDirectory)/artifacts/MultithreadedTasks' + artifact: Windows SDK MT evidence # Publish artifacts for regression testing - task: PublishPipelineArtifact@1 @@ -637,7 +651,7 @@ stages: clean: true - script: dotnet --list-sdks displayName: Report dotnet SDK versions - - script: .\eng\common\dotnet.cmd build .\FSharp.Compiler.Service.slnx /bl:\"artifacts/log/$(_BuildConfig)/ServiceRegularBuild.binlog\" + - script: .\eng\common\dotnet.cmd build .\FSharp.Compiler.Service.slnx -mt /bl:\"artifacts/log/$(_BuildConfig)/ServiceRegularBuild.binlog\" workingDirectory: $(Build.SourcesDirectory) displayName: Regular rebuild of FSharp.Compiler.Service.slnx continueOnError: false @@ -656,7 +670,7 @@ stages: clean: true - script: dotnet --list-sdks displayName: Report dotnet SDK versions - - script: ./eng/common/dotnet.sh build ./FSharp.Compiler.Service.slnx /bl:\"artifacts/log/$(_BuildConfig)/ServiceRegularBuild.binlog\" + - script: ./eng/common/dotnet.sh build ./FSharp.Compiler.Service.slnx -mt /bl:\"artifacts/log/$(_BuildConfig)/ServiceRegularBuild.binlog\" workingDirectory: $(Build.SourcesDirectory) displayName: Regular rebuild of FSharp.Compiler.Service.slnx continueOnError: false @@ -674,7 +688,7 @@ stages: clean: true - script: dotnet --list-sdks displayName: Report dotnet SDK versions - - script: ./eng/common/dotnet.sh build ./FSharp.Compiler.Service.slnx /bl:\"artifacts/log/$(_BuildConfig)/ServiceRegularBuild.binlog\" + - script: ./eng/common/dotnet.sh build ./FSharp.Compiler.Service.slnx -mt /bl:\"artifacts/log/$(_BuildConfig)/ServiceRegularBuild.binlog\" workingDirectory: $(Build.SourcesDirectory) displayName: Regular rebuild of FSharp.Compiler.Service.slnx continueOnError: false diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index ed1e382d6c7..0422578c138 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md @@ -205,6 +205,7 @@ * `Async.RunImmediate` renamed and replaced with impl of `FSharp.Core`'s `Async.RunSynchronouslyImmediate`, wherein `Exception`s are unwrapped (i.e., no egregious `AggregateException` wrapping). ([Issue #1042](https://github.com/fsharp/fslang-suggestions/issues/1042), [PR #19804](https://github.com/dotnet/fsharp/pull/19804), [PR #20245](https://github.com/dotnet/fsharp/pull/20245)) * Lower string-typed interpolated strings to `System.String.Concat` rather than the reflection-based `printf` engine, making them trim- and NativeAOT-compatible. This generalizes and ungates the previous all-string `String.Concat` optimization, so it now applies to every string-typed interpolation. ([Language suggestion #1108](https://github.com/fsharp/fslang-suggestions/issues/1108), [PR #19971](https://github.com/dotnet/fsharp/pull/19971)) * Stabilized several `preview` language features into F# 11.0 (`--langversion:11.0`, enabled by default with a .NET 11 SDK): `MethodOverloadsCache`, `ErrorOnMissingSignatureAttribute`, `DirectDelegateConstruction`, `AccessProtectedBaseFieldFromClosure`, and `RecordSpreads`. `FromEndSlicing` intentionally remains in `preview`. ([PR #20199](https://github.com/dotnet/fsharp/pull/20199)) +* F# build tasks use MSBuild's per-task environment for in-process multithreaded builds. The build host must provide `IMultiThreadableTask`, `TaskEnvironment`, and `ToolTask.TaskEnvironment`. ([PR #20506](https://github.com/dotnet/fsharp/pull/20506)) * Interpolated string holes (e.g. `$"{x}"`) are now formatted with invariant culture (via the `string` operator) instead of the current thread culture. ([PR #19971](https://github.com/dotnet/fsharp/pull/19971)) * Lines starting with `#:` are now ignored ([Language suggestion 1440](https://github.com/fsharp/fslang-suggestions/issues/1440), [RFC FS-1337](https://github.com/fsharp/fslang-design/pull/830), [PR #20212](https://github.com/dotnet/fsharp/pull/20212)) * `[]` attributes written in front of a binding are again reported by `SynBinding.attributes` in the untyped syntax tree, with their original grouping and `[< >]` ranges. The rotation into `SynValInfo.retInfo` added by [PR #19738](https://github.com/dotnet/fsharp/pull/19738) now happens while normalizing a binding for checking instead of in the parser, so both fixes from that PR are unchanged while tools reading the parse tree (formatters, analyzers, source generators) again see what was written. ([PR #20356](https://github.com/dotnet/fsharp/pull/20356)) diff --git a/src/Compiler/Facilities/CompilerLocation.fs b/src/Compiler/Facilities/CompilerLocation.fs index 9284daac23a..c789f7386d4 100644 --- a/src/Compiler/Facilities/CompilerLocation.fs +++ b/src/Compiler/Facilities/CompilerLocation.fs @@ -67,12 +67,12 @@ module internal FSharpEnvironment = // - default F# binaries directory in service.fs (REVIEW: check this) // - default location of fsi.exe in FSharp.VS.FSI.dll (REVIEW: check this) // - default F# binaries directory in (project system) Project.fs - let BinFolderOfDefaultFSharpCompiler (probePoint: string option) = + let BinFolderOfDefaultFSharpCompilerUsingEnvironment (getEnvironmentVariable: string -> string | null) (probePoint: string option) = // Check for an app.config setting to redirect the default compiler location // Like fsharp-compiler-location try // We let you set FSHARP_COMPILER_BIN. I've rarely seen this used and its not documented in the install instructions. - match Environment.GetEnvironmentVariable("FSHARP_COMPILER_BIN") with + match getEnvironmentVariable "FSHARP_COMPILER_BIN" with | result when not (String.IsNullOrWhiteSpace result) -> Some !!result | _ -> let safeExists f = @@ -96,6 +96,9 @@ module internal FSharpEnvironment = with e -> None + let BinFolderOfDefaultFSharpCompiler (probePoint: string option) = + BinFolderOfDefaultFSharpCompilerUsingEnvironment Environment.GetEnvironmentVariable probePoint + // Specify the tooling-compatible fragments of a path such as: // typeproviders/fsharp41/net461/MyProvider.DesignTime.dll // tools/fsharp41/net461/MyProvider.DesignTime.dll diff --git a/src/Compiler/Facilities/CompilerLocation.fsi b/src/Compiler/Facilities/CompilerLocation.fsi index 57549d3a32f..429c7740e27 100644 --- a/src/Compiler/Facilities/CompilerLocation.fsi +++ b/src/Compiler/Facilities/CompilerLocation.fsi @@ -28,6 +28,11 @@ module internal FSharpEnvironment = // - default F# binaries directory in (project system) Project.fs val BinFolderOfDefaultFSharpCompiler: probePoint: string option -> string option + // As BinFolderOfDefaultFSharpCompiler, but FSHARP_COMPILER_BIN is read via the given accessor so + // multi-threadable tasks resolve against their own TaskEnvironment. + val BinFolderOfDefaultFSharpCompilerUsingEnvironment: + getEnvironmentVariable: (string -> string | null) -> probePoint: string option -> string option + val toolingCompatiblePaths: unit -> string list val searchToolPaths: path: string option -> compilerToolPaths: seq -> seq diff --git a/src/FSharp.Build/CreateFSharpManifestResourceName.fs b/src/FSharp.Build/CreateFSharpManifestResourceName.fs index bb91742a7b4..4b31ed0d56f 100644 --- a/src/FSharp.Build/CreateFSharpManifestResourceName.fs +++ b/src/FSharp.Build/CreateFSharpManifestResourceName.fs @@ -4,8 +4,10 @@ namespace FSharp.Build open System open System.IO +open Microsoft.Build.Framework open Microsoft.Build.Tasks +[] type CreateFSharpManifestResourceName public () = inherit CreateCSharpManifestResourceName() diff --git a/src/FSharp.Build/FSharp.Build.fsproj b/src/FSharp.Build/FSharp.Build.fsproj index 90912e95fe2..73571acd032 100644 --- a/src/FSharp.Build/FSharp.Build.fsproj +++ b/src/FSharp.Build/FSharp.Build.fsproj @@ -33,11 +33,13 @@ + + diff --git a/src/FSharp.Build/FSharpEmbedResXSource.fs b/src/FSharp.Build/FSharpEmbedResXSource.fs index 219ae5a4f2c..13a40aeed7c 100644 --- a/src/FSharp.Build/FSharpEmbedResXSource.fs +++ b/src/FSharp.Build/FSharpEmbedResXSource.fs @@ -10,6 +10,7 @@ open System.Xml.Linq open Microsoft.Build.Framework open Microsoft.Build.Utilities +[] type FSharpEmbedResXSource() as this = inherit Task() let mutable _embeddedText: ITaskItem[] = [||] @@ -17,6 +18,10 @@ type FSharpEmbedResXSource() as this = let mutable _outputPath: string = "" let mutable _targetFramework: string = "" + // Bound against `this` once; each call reads the injected TaskEnvironment late. + let rootedPath = TaskEnvironmentPaths.rootedPath this + let restorePaths = TaskEnvironmentPaths.restoreTaskPaths this + let failTask fmt = Printf.ksprintf (fun msg -> @@ -41,16 +46,24 @@ module internal {1} = " let GetObject(name:System.String) : System.Object = ResourceManager.GetObject(name, CultureInfo.CurrentUICulture)" let generateSource (resx: string) (fullModuleName: string) (generateLegacy: bool) (generateLiteral: bool) = + // Record paths inside the try so failures during derivation still reach the shared handler below. + let mutable originalPaths = [ resx ] + try - let printMessage fmt = Printf.ksprintf this.Log.LogMessage fmt let justFileName = Path.GetFileNameWithoutExtension(resx) let sourcePath = Path.Combine(_outputPath, justFileName + ".fs") + originalPaths <- [ resx; sourcePath ] + + let rootedResx = rootedPath resx + let rootedSource = rootedPath sourcePath + + let printMessage fmt = Printf.ksprintf this.Log.LogMessage fmt // simple up-to-date check if - File.Exists(resx) - && File.Exists(sourcePath) - && File.GetLastWriteTimeUtc(resx) <= File.GetLastWriteTimeUtc(sourcePath) + File.Exists rootedResx + && File.Exists rootedSource + && File.GetLastWriteTimeUtc rootedResx <= File.GetLastWriteTimeUtc rootedSource then printMessage "Skipping generation: '%s' since it is up-to-date." sourcePath Some(sourcePath) @@ -82,7 +95,7 @@ module internal {1} = let body = let xname = XName.op_Implicit - XDocument.Load(resx).Descendants(xname "data") + XDocument.Load(rootedResx).Descendants(xname "data") |> Seq.fold (fun (sb: StringBuilder) (node: XElement) -> let name = @@ -120,13 +133,21 @@ module internal {1} = sb.AppendLine().Append(commentBody).AppendLine(accessorBody)) sb - File.WriteAllText(sourcePath, body.ToString()) + File.WriteAllText(rootedSource, body.ToString()) printMessage "Done: %s" sourcePath Some(sourcePath) - with e -> - printf "An exception occurred when processing '%s'\n%s" resx (e.ToString()) + with + | TaskFailed -> + // failTask already logged the error; re-logging would duplicate the diagnostic. + None + | e -> + this.Log.LogError(sprintf "An exception occurred when processing '%s': %s" resx (restorePaths (e.ToString()) originalPaths)) + None + interface IMultiThreadableTask with + member val TaskEnvironment = TaskEnvironment.Fallback with get, set + [] member _.EmbeddedResource with get () = _embeddedText @@ -155,9 +176,7 @@ module internal {1} = | "false" -> false | _ -> failTask "Expected boolean value for '%s' found '%s'" metadataName value - let mutable success = true - - let generatedSource = + let generationResults = [| for item in this.EmbeddedResource do if getBooleanMetadata "GenerateSource" false item then @@ -170,12 +189,12 @@ module internal {1} = let generateLegacy = getBooleanMetadata "GenerateLegacyCode" false item let generateLiteral = getBooleanMetadata "GenerateLiterals" true item - match generateSource item.ItemSpec moduleName generateLegacy generateLiteral with - | Some(source) -> yield TaskItem(source) :> ITaskItem - | None -> success <- false + yield + generateSource item.ItemSpec moduleName generateLegacy generateLiteral + |> Option.map (fun source -> TaskItem(source) :> ITaskItem) |] - _generatedSource <- generatedSource - success && not this.Log.HasLoggedErrors + _generatedSource <- generationResults |> Array.choose id + Array.forall Option.isSome generationResults && not this.Log.HasLoggedErrors with TaskFailed -> false diff --git a/src/FSharp.Build/FSharpEmbedResourceText.fs b/src/FSharp.Build/FSharpEmbedResourceText.fs index 85ed65710de..bd21842153c 100644 --- a/src/FSharp.Build/FSharpEmbedResourceText.fs +++ b/src/FSharp.Build/FSharpEmbedResourceText.fs @@ -11,6 +11,7 @@ open Microsoft.Build.Utilities /// the task has already emitted the error message. exception TaskFailed +[] type FSharpEmbedResourceText() as this = inherit Task() let mutable _embeddedText: ITaskItem[] = [||] @@ -18,6 +19,10 @@ type FSharpEmbedResourceText() as this = let mutable _generatedResx: ITaskItem[] = [||] let mutable _outputPath: string = "" + // Bound against `this` once; each call reads the injected TaskEnvironment late. + let rootedPath = TaskEnvironmentPaths.rootedPath this + let restorePaths = TaskEnvironmentPaths.restoreTaskPaths this + let PrintErr (fileName, line, msg) = this.Log.LogError(null, null, null, fileName, line, 0, 0, 0, msg, Array.empty) @@ -400,7 +405,21 @@ open Printf let generateResxAndSource (item: ITaskItem) = let fileName = item.ItemSpec + // Record paths inside the try so failures during derivation still reach the shared handler below. + let mutable originalPaths = [ fileName ] + try + let justFileName = Path.GetFileNameWithoutExtension(fileName) // .txt + let outFileName = Path.Combine(_outputPath, justFileName + ".fs") + let outFileSignatureName = Path.Combine(_outputPath, justFileName + ".fsi") + let outXmlFileName = Path.Combine(_outputPath, justFileName + ".resx") + originalPaths <- [ fileName; outFileName; outFileSignatureName; outXmlFileName ] + + let rootedInput = rootedPath fileName + let rootedOut = rootedPath outFileName + let rootedSignature = rootedPath outFileSignatureName + let rootedXml = rootedPath outXmlFileName + let printMessage fmt = Printf.ksprintf this.Log.LogMessage fmt // Opt in with true on the EmbeddedText item. Only assemblies that can @@ -408,8 +427,6 @@ open Printf let richText = System.String.Equals(item.GetMetadata "RichText", "true", System.StringComparison.OrdinalIgnoreCase) - let justFileName = Path.GetFileNameWithoutExtension(fileName) // .txt - if justFileName |> Seq.exists (System.Char.IsLetterOrDigit >> not) then Err( fileName, @@ -419,50 +436,45 @@ open Printf justFileName ) - let outFileName = Path.Combine(_outputPath, justFileName + ".fs") - let outFileSignatureName = Path.Combine(_outputPath, justFileName + ".fsi") - let outXmlFileName = Path.Combine(_outputPath, justFileName + ".resx") - - let condition1 = File.Exists(outFileName) - let condition2 = condition1 && File.Exists(outXmlFileName) - let condition3 = condition2 && File.Exists(fileName) - - let condition4 = - condition3 - && (File.GetLastWriteTimeUtc(fileName) <= File.GetLastWriteTimeUtc(outFileName)) - - let condition5 = - condition4 - && (File.GetLastWriteTimeUtc(fileName) <= File.GetLastWriteTimeUtc(outXmlFileName)) - // A generated file does not record whether it was generated with RichText, so the flag has // to be recovered from the open the generator emits for it, or an existing file would be // taken as up-to-date after the flag changed - let condition6 = - condition5 - && (richText = (File.ReadLines(outFileName) |> Seq.truncate 40 |> Seq.contains richTextOpen)) + let failedCondition = + if not (File.Exists rootedOut) then + Some 1 + elif not (File.Exists rootedXml) then + Some 2 + elif not (File.Exists rootedInput) then + Some 3 + elif File.GetLastWriteTimeUtc rootedInput > File.GetLastWriteTimeUtc rootedOut then + Some 4 + elif File.GetLastWriteTimeUtc rootedInput > File.GetLastWriteTimeUtc rootedXml then + Some 5 + elif + richText + <> (File.ReadLines rootedOut |> Seq.truncate 40 |> Seq.contains richTextOpen) + then + Some 6 + else + None - if condition6 then + match failedCondition with + | None -> printMessage "Skipping generation of %s and %s from %s since up-to-date" outFileName outXmlFileName fileName Some(fileName, outFileSignatureName, outFileName, outXmlFileName) - else + | Some failedCondition -> printMessage "Generating %s and %s from %s, because condition %d is false, see FSharpEmbedResourceText.fs in the F# source" outFileName outXmlFileName fileName - (if not condition1 then 1 - elif not condition2 then 2 - elif not condition3 then 3 - elif not condition4 then 4 - elif not condition5 then 5 - else 6) + failedCondition printMessage "Reading %s" fileName let lines = - File.ReadAllLines(fileName) + File.ReadAllLines rootedInput |> Array.mapi (fun i s -> i, s) // keep line numbers |> Array.filter (fun (_i, s) -> not (s.StartsWith "#")) // filter out comments @@ -508,9 +520,11 @@ open Printf allStrs.Add(str, (line, ident)) printMessage "Generating %s" outFileName - use outStream = File.Create outFileName + use outStream = File.Create rootedOut use out = new StreamWriter(outStream) - use outSignatureStream = File.Create outFileSignatureName + + use outSignatureStream = File.Create rootedSignature + use outSignature = new StreamWriter(outSignatureStream) fprintfn out "// This is a generated file; the original input is '%s'" fileName fprintfn outSignature "// This is a generated file; the original input is '%s'" fileName @@ -689,14 +703,24 @@ open Printf xnc.AppendChild(xd.CreateTextNode netFormatString) |> ignore xd.LastChild.AppendChild xn |> ignore) - use outXmlStream = File.Create outXmlFileName + use outXmlStream = File.Create rootedXml xd.Save outXmlStream printMessage "Done %s" outFileName Some(fileName, outFileSignatureName, outFileName, outXmlFileName) - with e -> - PrintErr(fileName, 0, sprintf "An exception occurred when processing '%s'\n%s" fileName (e.ToString())) + with + | TaskFailed -> None + | e -> + PrintErr( + fileName, + 0, + sprintf "An exception occurred when processing '%s'\n%s" fileName (restorePaths (e.ToString()) originalPaths) + ) + None + interface IMultiThreadableTask with + member val TaskEnvironment = TaskEnvironment.Fallback with get, set + [] member _.EmbeddedText with get () = _embeddedText diff --git a/src/FSharp.Build/Fsc.fs b/src/FSharp.Build/Fsc.fs index 173792f0711..0b2e16f58b2 100644 --- a/src/FSharp.Build/Fsc.fs +++ b/src/FSharp.Build/Fsc.fs @@ -16,6 +16,7 @@ open Internal.Utilities //The goal is to have the most common/important flags available via the Fsc class, and the //rest can be "backdoored" through the .OtherFlags property. +[] type public Fsc() as this = inherit ToolTask() @@ -73,15 +74,7 @@ type public Fsc() as this = let mutable targetType: string | null = null let defaultToolPath = - let locationOfThisDll = - try - Some(Path.GetDirectoryName(typeof.Assembly.Location)) - with _ -> - None - - match FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(locationOfThisDll) with - | Some s -> s - | None -> "" + lazy (TaskEnvironmentPaths.defaultCompilerToolPath this.TaskEnvironment typeof) let mutable treatWarningsAsErrors: bool = false let mutable useStandardResourceNames: bool = false @@ -727,10 +720,12 @@ type public Fsc() as this = base.StandardOutputEncoding override fsc.GenerateFullPathToTool() = + let defaultToolPath = defaultToolPath.Value + if defaultToolPath = "" then raise (new System.InvalidOperationException(FSBuild.SR.toolpathUnknown ())) - System.IO.Path.Combine(defaultToolPath, fsc.ToolExe) + TaskEnvironmentPaths.normalizePathToTool fsc.TaskEnvironment (System.IO.Path.Combine(defaultToolPath, fsc.ToolExe)) override fsc.LogToolCommand(message: string) = fsc.Log.LogMessageFromText(message, MessageImportance.Normal) |> ignore @@ -751,6 +746,10 @@ type public Fsc() as this = if skipCompilerExecution then 0 else + // Root once so both the base call and the HostObject delegate use the same rooted path. + let pathToTool = + TaskEnvironmentPaths.normalizePathToTool fsc.TaskEnvironment pathToTool + let host = box fsc.HostObject match host with diff --git a/src/FSharp.Build/Fsi.fs b/src/FSharp.Build/Fsi.fs index 312c1f31a9f..3238b844e7a 100644 --- a/src/FSharp.Build/Fsi.fs +++ b/src/FSharp.Build/Fsi.fs @@ -17,6 +17,7 @@ open Internal.Utilities //The goal is to have the most common/important flags available via the Fsi class, and the //rest can be "backdoored" through the .OtherFlags property. +[] type public Fsi() as this = inherit ToolTask() @@ -44,16 +45,10 @@ type public Fsi() as this = let mutable tailcalls: bool = true let mutable targetProfile: string | null = null - let mutable toolPath: string = - let locationOfThisDll = - try - Some(Path.GetDirectoryName(typeof.Assembly.Location)) - with _ -> - None + let defaultToolPath = + lazy (TaskEnvironmentPaths.defaultCompilerToolPath this.TaskEnvironment typeof) - match FSharpEnvironment.BinFolderOfDefaultFSharpCompiler(locationOfThisDll) with - | Some s -> s - | None -> "" + let mutable toolPath: string option = None let mutable treatWarningsAsErrors: bool = false let mutable warningsAsErrors: string | null = null @@ -276,8 +271,8 @@ type public Fsi() as this = // For targeting other folders for "fsi.exe" (or ToolExe if different) member _.ToolPath - with get () = toolPath - and set value = toolPath <- value + with get () = Option.defaultWith (fun () -> defaultToolPath.Value) toolPath + and set value = toolPath <- Some value // --use:: execute an F# source file on startup member _.UseSources @@ -322,10 +317,12 @@ type public Fsi() as this = base.StandardOutputEncoding override fsi.GenerateFullPathToTool() = + let toolPath = fsi.ToolPath + if toolPath = "" then raise (new System.InvalidOperationException(FSBuild.SR.toolpathUnknown ())) - System.IO.Path.Combine(toolPath, fsi.ToolExe) + TaskEnvironmentPaths.normalizePathToTool fsi.TaskEnvironment (System.IO.Path.Combine(toolPath, fsi.ToolExe)) override fsi.LogToolCommand(message: string) = fsi.Log.LogMessageFromText(message, MessageImportance.Normal) |> ignore @@ -346,6 +343,10 @@ type public Fsi() as this = if skipCompilerExecution then 0 else + // Root once so both the base call and the HostObject delegate use the same rooted path. + let pathToTool = + TaskEnvironmentPaths.normalizePathToTool fsi.TaskEnvironment pathToTool + let host = box fsi.HostObject match host with diff --git a/src/FSharp.Build/GenerateILLinkSubstitutions.fs b/src/FSharp.Build/GenerateILLinkSubstitutions.fs index 0478d36201d..dd6e497742e 100644 --- a/src/FSharp.Build/GenerateILLinkSubstitutions.fs +++ b/src/FSharp.Build/GenerateILLinkSubstitutions.fs @@ -11,9 +11,13 @@ open Microsoft.Build.Utilities /// /// MSBuild task that generates ILLink.Substitutions.xml file to remove F# metadata resources during IL linking. /// +[] type GenerateILLinkSubstitutions() = inherit Task() + interface IMultiThreadableTask with + member val TaskEnvironment = TaskEnvironment.Fallback with get, set + /// /// Assembly name to use when generating resource names to be removed. /// @@ -33,6 +37,8 @@ type GenerateILLinkSubstitutions() = member val GeneratedItems = [||]: ITaskItem[] with get, set override this.Execute() = + let rootedPath = TaskEnvironmentPaths.rootedPath this + try // Define the resource prefixes that need to be removed let resourcePrefixes = @@ -79,8 +85,12 @@ type GenerateILLinkSubstitutions() = let outputFileName = Path.Combine(this.IntermediateOutputPath, "ILLink.Substitutions.xml") - Directory.CreateDirectory(this.IntermediateOutputPath) |> ignore - File.WriteAllText(outputFileName, xmlContent) + Directory.CreateDirectory(rootedPath this.IntermediateOutputPath) |> ignore + + let outputPath = rootedPath outputFileName + + if not (File.Exists outputPath) || File.ReadAllText(outputPath) <> xmlContent then + File.WriteAllText(outputPath, xmlContent) // Create a TaskItem for the generated file let item = TaskItem(outputFileName) :> ITaskItem diff --git a/src/FSharp.Build/MapSourceRoots.fs b/src/FSharp.Build/MapSourceRoots.fs index 8ea92c02197..6b2f9396fdd 100644 --- a/src/FSharp.Build/MapSourceRoots.fs +++ b/src/FSharp.Build/MapSourceRoots.fs @@ -37,6 +37,7 @@ module Utilities = /// The MappedPath is either the path (ItemSpec) itself, when is false, /// or a calculated deterministic source path (starting with prefix '/_/', '/_1/', etc.), otherwise. /// +[] type MapSourceRoots() = inherit Task() diff --git a/src/FSharp.Build/SubstituteText.fs b/src/FSharp.Build/SubstituteText.fs index 97e8758ce55..7c7520d2389 100644 --- a/src/FSharp.Build/SubstituteText.fs +++ b/src/FSharp.Build/SubstituteText.fs @@ -7,12 +7,16 @@ open System.IO open Microsoft.Build.Framework open Microsoft.Build.Utilities +[] type SubstituteText() = inherit Task() - let mutable copiedFiles = new ResizeArray() + let copiedFiles = ResizeArray() let mutable embeddedResources: ITaskItem[] = [||] + interface IMultiThreadableTask with + member val TaskEnvironment = TaskEnvironment.Fallback with get, set + [] member _.EmbeddedResources with get () = embeddedResources @@ -21,7 +25,8 @@ type SubstituteText() = [] member _.CopiedFiles = copiedFiles.ToArray() - override _.Execute() = + override this.Execute() = + let rootedPath = TaskEnvironmentPaths.rootedPath this copiedFiles.Clear() if not (isNull (box embeddedResources)) then // this check can't fail, the type is non-nullable @@ -61,22 +66,24 @@ type SubstituteText() = item.ItemSpec <- targetPath // Transform file - let mutable contents = File.ReadAllText(sourcePath) - - if not (String.IsNullOrWhiteSpace(pattern1)) then - let replacement = item.GetMetadata("Replacement1") - contents <- contents.Replace(pattern1, replacement) + let replaceFromMetadata pattern replacementName (contents: string) = + if String.IsNullOrWhiteSpace pattern then + contents + else + contents.Replace(pattern, item.GetMetadata replacementName) - if not (String.IsNullOrWhiteSpace(pattern2)) then - let replacement = item.GetMetadata("Replacement2") - contents <- contents.Replace(pattern2, replacement) + let contents = + File.ReadAllText(rootedPath sourcePath) + |> replaceFromMetadata pattern1 "Replacement1" + |> replaceFromMetadata pattern2 "Replacement2" let directory = Path.GetDirectoryName(targetPath) + let rootedDirectory = rootedPath directory - if not (Directory.Exists(directory)) then - Directory.CreateDirectory(directory) |> ignore + if not (Directory.Exists rootedDirectory) then + Directory.CreateDirectory rootedDirectory |> ignore - File.WriteAllText(targetPath, contents) + File.WriteAllText(rootedPath targetPath, contents) with _ -> () diff --git a/src/FSharp.Build/TaskEnvironmentPaths.fs b/src/FSharp.Build/TaskEnvironmentPaths.fs new file mode 100644 index 00000000000..70492a99172 --- /dev/null +++ b/src/FSharp.Build/TaskEnvironmentPaths.fs @@ -0,0 +1,142 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Build + +open System +open System.IO +open System.Text +open Microsoft.Build.Framework +open Internal.Utilities +open Internal.Utilities.Library + +module internal TaskEnvironmentPaths = + + let pathComparison = + if FSharpEnvironment.isWindows then + StringComparison.OrdinalIgnoreCase + else + StringComparison.Ordinal + + // ProcessStartInfo resolves relative tool paths against the host process current directory. + let normalizePathToTool (taskEnvironment: TaskEnvironment) (pathToTool: string) = + if String.IsNullOrWhiteSpace pathToTool then + pathToTool + else + match Path.GetDirectoryName pathToTool with + | NonEmptyString _ -> taskEnvironment.GetAbsolutePath(pathToTool).Value + | _ -> pathToTool + + let defaultCompilerToolPath (taskEnvironment: TaskEnvironment) (taskType: Type) = + let probePoint = + try + Some(Path.GetDirectoryName(taskType.Assembly.Location)) + with _ -> + None + + FSharpEnvironment.BinFolderOfDefaultFSharpCompilerUsingEnvironment taskEnvironment.GetEnvironmentVariable probePoint + |> Option.defaultValue "" + + // Quoted filenames can contain whitespace and punctuation that delimit unquoted diagnostics. + let private isPathToken (source: string) start finish = + let preceding = + if start = 0 then + ' ' + else + source[start - 1] + + let startsToken = + Char.IsWhiteSpace preceding + || (match preceding with + | '\'' + | '"' + | '(' + | '[' + | '{' + | '=' + | '>' -> true + | _ -> false) + + startsToken + && (finish = source.Length + || (match source[finish] with + | '/' + | '\\' -> true + | c when preceding = '\'' || preceding = '"' -> c = preceding + | c -> + Char.IsWhiteSpace c + || (match c with + | '\'' + | '"' + | ':' + | ';' + | ',' + | ')' + | ']' + | '}' + | '>' -> true + | _ -> false))) + + // netstandard2.0 has no String.Replace(string, string, StringComparison) overload, and a plain replace + // would also ignore the path-token boundary above, so both are handled here. + let private replacePathToken (source: string) (oldValue: string) (newValue: string) = + if String.IsNullOrEmpty oldValue then + source + else + let builder = StringBuilder() + + let rec loop searchStart = + match source.IndexOf(oldValue, searchStart, pathComparison) with + | -1 -> builder.Append(source, searchStart, source.Length - searchStart) + | matchIndex -> + let afterMatch = matchIndex + oldValue.Length + builder.Append(source, searchStart, matchIndex - searchStart) |> ignore + + if isPathToken source matchIndex afterMatch then + builder.Append(newValue) |> ignore + else + builder.Append(source, matchIndex, oldValue.Length) |> ignore + + loop afterMatch + + (loop 0).ToString() + + let restoreOriginalPaths (taskEnvironment: TaskEnvironment) (message: string) (originalPaths: string list) = + let rootedFormsOf (original: string) = + try + if String.IsNullOrEmpty original then + [] + else + let rooted = taskEnvironment.GetAbsolutePath(original).Value + + if String.IsNullOrEmpty rooted || String.Equals(rooted, original, pathComparison) then + [] + else + let canonical = + try + Path.GetFullPath rooted + with _ -> + rooted + + [ + (rooted, original) + if not (String.IsNullOrEmpty canonical) then + (canonical, original) + ] + with _ -> + [] + + let replacements = + originalPaths + |> List.collect rootedFormsOf + |> List.distinct + |> List.sortByDescending (fun (rooted, _) -> rooted.Length) + + (message, replacements) + ||> List.fold (fun message (rooted, original) -> replacePathToken message rooted original) + + // Task-facing helpers that read the injected TaskEnvironment late (partially apply against `this`). + let rootedPath (task: #IMultiThreadableTask) path = + task.TaskEnvironment.GetAbsolutePath(path).Value + + let restoreTaskPaths (task: #IMultiThreadableTask) message paths = + restoreOriginalPaths task.TaskEnvironment message paths diff --git a/src/FSharp.Build/WriteCodeFragment.fs b/src/FSharp.Build/WriteCodeFragment.fs index 2e0d96b7f3e..f0b92f76102 100644 --- a/src/FSharp.Build/WriteCodeFragment.fs +++ b/src/FSharp.Build/WriteCodeFragment.fs @@ -12,6 +12,7 @@ open Microsoft.Build.Utilities [] type EscapedValue = { Escaped: string; Raw: string } +[] type WriteCodeFragment() as this = inherit Task() let mutable _outputDirectory: ITaskItem | null = null @@ -202,8 +203,11 @@ type WriteCodeFragment() as this = TaskItem(Path.Combine(outputDirectory.ItemSpec, fileName)) :> ITaskItem let codeText = code.ToString() - File.WriteAllText(fileName, codeText) + File.WriteAllText(TaskEnvironmentPaths.rootedPath this fileName, codeText) _outputFile <- outputFileItem not this.Log.HasLoggedErrors with TaskFailed -> false + + interface IMultiThreadableTask with + member val TaskEnvironment = TaskEnvironment.Fallback with get, set diff --git a/tests/EndToEndBuildTests/MultithreadedTasks/Fixture.fsproj b/tests/EndToEndBuildTests/MultithreadedTasks/Fixture.fsproj new file mode 100644 index 00000000000..c6386be1144 --- /dev/null +++ b/tests/EndToEndBuildTests/MultithreadedTasks/Fixture.fsproj @@ -0,0 +1,33 @@ + + + net11.0 + Exe + false + true + true + true + false + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/EndToEndBuildTests/MultithreadedTasks/Probe.cs b/tests/EndToEndBuildTests/MultithreadedTasks/Probe.cs new file mode 100644 index 00000000000..fbaa610d562 --- /dev/null +++ b/tests/EndToEndBuildTests/MultithreadedTasks/Probe.cs @@ -0,0 +1,77 @@ +using System; +using System.Diagnostics; +using System.IO; +using Microsoft.Build.Framework; +using Microsoft.Build.Utilities; + +// This unmarked control must use a TaskHost in MT builds. It verifies that routing diagnostics are enabled. +public sealed class SerialControl : Task +{ + public override bool Execute() => true; +} + +[MSBuildMultiThreadableTask] +public sealed class ProjectEnvironment : Task, IMultiThreadableTask +{ + public TaskEnvironment TaskEnvironment { get; set; } = TaskEnvironment.Fallback; + [Required] public string Marker { get; set; } + public string LoadedTasks { get; set; } + public override bool Execute() + { + var environment = typeof(ToolTask).GetProperty("TaskEnvironment"); + if (environment?.PropertyType != typeof(TaskEnvironment) || !typeof(IMultiThreadableTask).IsAssignableFrom(typeof(ToolTask))) + throw new InvalidOperationException("This MSBuild host does not expose the required ToolTask.TaskEnvironment API"); + if (!string.IsNullOrEmpty(LoadedTasks)) + { + var framework = typeof(IMultiThreadableTask).Assembly.Location; + var utilities = typeof(ToolTask).Assembly.Location; + File.WriteAllText(TaskEnvironment.GetAbsolutePath("host.txt").ToString(), + $"{framework}\t{FileVersionInfo.GetVersionInfo(framework).FileVersion}\t{utilities}\t{FileVersionInfo.GetVersionInfo(utilities).FileVersion}"); + bool found = false; + foreach (var assembly in AppDomain.CurrentDomain.GetAssemblies()) + if (assembly.GetName().Name == "FSharp.Build") + { + if (!string.Equals(Path.GetFullPath(assembly.Location), Path.GetFullPath(LoadedTasks), StringComparison.OrdinalIgnoreCase)) + throw new InvalidOperationException("Loaded SDK tasks instead of local tasks: " + assembly.Location); + found = true; + } + if (!found) throw new InvalidOperationException("No FSharp.Build assembly loaded in the project process"); + } + TaskEnvironment.SetEnvironmentVariable("FSHARP_MT_MARKER", Marker); + File.WriteAllText(TaskEnvironment.GetAbsolutePath("environment.txt").ToString(), + $"{Environment.ProcessId}\t{TaskEnvironment.ProjectDirectory}\t{Marker}\t{LoadedTasks}"); + return true; + } +} + +public sealed class EvidenceLogger : ILogger +{ + public LoggerVerbosity Verbosity { get; set; } = LoggerVerbosity.Diagnostic; + public string Parameters { get; set; } + private StreamWriter writer; + private readonly object gate = new object(); + + public void Initialize(IEventSource source) + { + writer = new StreamWriter(Parameters); + source.TaskStarted += (_, e) => Write("start", e.Timestamp, e.BuildEventContext, e.TaskName, e.ProjectFile, e.TaskAssemblyLocation); + source.TaskFinished += (_, e) => Write("finish", e.Timestamp, e.BuildEventContext, e.TaskName, e.ProjectFile, e.Succeeded.ToString()); + source.ErrorRaised += (_, e) => Write("error", e.Timestamp, e.BuildEventContext, e.Code, e.ProjectFile, $"{e.File}:{e.LineNumber}:{e.ColumnNumber} {e.Message}"); + source.MessageRaised += (_, e) => + { + // Fsc and Fsi emit ordinary messages instead of ToolTask's typed command events. + if (e.Importance == MessageImportance.Normal && (e.Message.Contains("fsc.dll") || e.Message.Contains("fsi.dll"))) + Write("command", e.Timestamp, e.BuildEventContext, "", "", e.Message); + if (e.Message.Contains("ran in TaskHost process")) + Write("route", e.Timestamp, e.BuildEventContext, "", "", e.Message); + }; + } + + private void Write(string kind, DateTime time, BuildEventContext context, string task, string project, string detail) + { + lock (gate) + writer.WriteLine($"{kind}\t{time.Ticks}\t{context.NodeId}:{context.ProjectContextId}:{context.TaskId}\t{task}\t{project}\t{detail?.Replace('\t', ' ').Replace('\r', ' ').Replace('\n', ' ')}"); + } + + public void Shutdown() => writer?.Dispose(); +} diff --git a/tests/EndToEndBuildTests/MultithreadedTasks/Program.fs b/tests/EndToEndBuildTests/MultithreadedTasks/Program.fs new file mode 100644 index 00000000000..beac0b2958b --- /dev/null +++ b/tests/EndToEndBuildTests/MultithreadedTasks/Program.fs @@ -0,0 +1,30 @@ +module Program + +open System +open System.IO +open System.Reflection +open System.Resources + +[] +let main _ = + let assembly = Assembly.GetExecutingAssembly() + let name = assembly.GetName().Name + let marker = assembly.GetCustomAttributes() |> Seq.exactlyOne + if marker.Key <> "ProjectMarker" || marker.Value <> name then failwith "Assembly metadata leaked" + let names = assembly.GetManifestResourceNames() + let values = + [ for resource in names do + if resource.EndsWith(".resources", StringComparison.Ordinal) then + use reader = new ResourceReader(assembly.GetManifestResourceStream resource) + for entry in reader |> Seq.cast do + match entry.Value with + | :? string as value -> yield value + | _ -> () ] + for prefix in [ "RESX_"; "TEXT_" ] do + if not (List.contains (prefix + name) values) then failwithf "Missing %s%s: %A" prefix name names + if values |> List.exists (fun value -> not (value.EndsWith(name, StringComparison.Ordinal))) then + failwithf "Foreign resource marker: %A" values + use dependent = new StreamReader(assembly.GetManifestResourceStream(name + ".dependent.txt")) + if dependent.ReadToEnd() <> "DEPENDENT_" + name then failwith "Dependent resource mismatch" + printfn "PASS %s resources=%d" name names.Length + 0 diff --git a/tests/EndToEndBuildTests/MultithreadedTasks/README.md b/tests/EndToEndBuildTests/MultithreadedTasks/README.md new file mode 100644 index 00000000000..7118311bcfb --- /dev/null +++ b/tests/EndToEndBuildTests/MultithreadedTasks/README.md @@ -0,0 +1,71 @@ +# SDK multithreaded task integration + +Use the pinned repository SDK, not Visual Studio MSBuild or a system `dotnet`. +The host must expose `IMultiThreadableTask`, `TaskEnvironment`, and `ToolTask.TaskEnvironment`. +The validated SDK is `11.0.100-rc.1.26420.103`, with runtime MSBuild `18.11.0.42103`. +The `Microsoft.Build.*` package version (`18.12.0-1.26454.5`) is not the runtime host version. +This does not establish support for all MSBuild 18.x hosts. +The production tasks retain their parameterless constructors and existing base types. + +Build the local products: + +```sh +./build.sh -c Release --mt true +``` + +On Windows, use `.\build.cmd -configuration Release -noVisualStudio`. + +Run the focused task tests: + +```sh +./eng/common/dotnet.sh test --project tests/FSharp.Build.UnitTests/FSharp.Build.UnitTests.fsproj -c Release --report-spekt-xunit --report-spekt-xunit-filename FSharp.Build.UnitTests.Linux-MT.xml --results-directory artifacts/TestResults/Release +``` + +Run the SDK E2E from the repository root: + +```sh +./eng/common/dotnet.sh fsi tests/EndToEndBuildTests/MultithreadedTasks/run.fsx -- --configuration Release --repetitions 3 +``` + +On Windows, replace `./eng/common/dotnet.sh` with `.\eng\common\dotnet.cmd`. +CI runs this harness as required steps in the existing `Linux` and Windows `EndToEndBuildTests` jobs. +Both reuse their built products and publish the SDK evidence. There are no separate MT jobs. +The existing Linux and macOS build jobs use Arcade's `--mt true` option. +The three `Plain_Build_*` SDK jobs pass `-mt` directly to MSBuild. +Those plain builds use SDK-shipped tasks; the redirected product builds and this harness exercise the migrated tasks. +VS/MSBuild.exe jobs and Arcade-managed source-build configuration are unchanged. +No repository-wide environment override or replacement for Arcade's MT controls is added. + +Use `--repetitions 10` for local stress runs. +Each repetition compares `/m:4 -mt:false` and `/m:4 -mt` builds of 16 independent SDK F# executables. +The child processes clear `MSBUILDFORCEMULTITHREADED` so an enclosing CI setting cannot override the MP control. +An inherited `MSBUILDENABLEMULTITHREADED` default is overridden by the explicit mode switch. +Each clean build is followed by an unchanged incremental build. Fsi validation reruns, but Fsc must not execute. +The minimum project count is four. +The harness needs access to the repository NuGet feeds for self-contained runtime and ILLink packs. +It adds no package references. + +The fixture uses relative source, resource, intermediate, and output paths from an unrelated invocation directory. +It redirects the tasks, targets, Fsc, Fsi, and FSharp.Core to local products. +It loads `artifacts/bin/FSharp.Build//netstandard2.0/FSharp.Build.dll` directly, not the compiler directory's potentially stale copy. +It checks these nine tasks: Fsc, Fsi, WriteCodeFragment, FSharpEmbedResourceText, FSharpEmbedResXSource, CreateFSharpManifestResourceName, MapSourceRoots, GenerateILLinkSubstitutions, and SubstituteText. + +Evidence includes: + +- Exact task assembly paths from task-start events, loaded-assembly checks, and the assembly SHA-256. +- Runtime API checks and assembly paths/file versions from each execution host, not the NuGet reference assemblies. +- Four live Fsi processes at a barrier, overlapping Fsc intervals, and project-specific environment and resource assertions. +- One MT project-process PID matching the SDK routing caller, versus multiple MP PIDs. +- Mandatory out-of-process routing diagnostics for an unmarked control task, with none for the nine migrated tasks. +- Matching artifact hashes and executed resource checks across clean and incremental builds, with zero incremental Fsc executions. +- Expected malformed-resource and type errors, with baseline-identical, runnable sibling projects. +- Self-contained `PublishTrimmed` builds in both modes, with substitutions enabled and disabled. + Both settings must retain the original application metadata, matching the existing target scheduling. + All four published executables must pass resource checks. + +Generated ILLink XML alone is not evidence of trimming. These publish checks establish MP/MT parity, not activation of metadata stripping. +A trimming failure fails the harness, even when the generated XML and build hashes match. +Missing concurrency, task-loading, or routing evidence fails the run. +Logs, binlogs, event records, generated fixtures, and hash manifests remain under `artifacts/MultithreadedTasks//`. + +The Windows SDK E2E step uses the SDK host. This harness does not start Visual Studio or exercise its HostObject integration. diff --git a/tests/EndToEndBuildTests/MultithreadedTasks/check.fsx b/tests/EndToEndBuildTests/MultithreadedTasks/check.fsx new file mode 100644 index 00000000000..397901a52b5 --- /dev/null +++ b/tests/EndToEndBuildTests/MultithreadedTasks/check.fsx @@ -0,0 +1,17 @@ +open System +open System.IO +open System.Threading + +let marker = File.ReadAllText("sentinel.txt") +for variable in [ "FSHARP_MT_MARKER"; "FSHARP_MT_TOOL_MARKER" ] do + if Environment.GetEnvironmentVariable variable <> marker then + failwithf "%s did not reach the Fsi child for %s" variable marker + +// Four live Fsi processes must enter before any can leave. +Directory.CreateDirectory("../barrier") |> ignore +File.WriteAllText("../barrier/" + marker, string Environment.ProcessId) +let deadline = DateTime.UtcNow.AddSeconds 90 +while Directory.GetFiles("../barrier").Length < 4 do + if DateTime.UtcNow > deadline then failwith "Fsi project concurrency barrier timed out" + Thread.Sleep 50 +File.WriteAllText("fsi.txt", marker) diff --git a/tests/EndToEndBuildTests/MultithreadedTasks/run.fsx b/tests/EndToEndBuildTests/MultithreadedTasks/run.fsx new file mode 100644 index 00000000000..57e20ac4d8e --- /dev/null +++ b/tests/EndToEndBuildTests/MultithreadedTasks/run.fsx @@ -0,0 +1,298 @@ +open System +open System.Diagnostics +open System.IO +open System.Reflection.Metadata +open System.Reflection.PortableExecutable +open System.Runtime.InteropServices +open System.Security +open System.Security.Cryptography +open System.Text.RegularExpressions + +let args = fsi.CommandLineArgs |> Array.skip 1 +let option name fallback = + match Array.tryFindIndex ((=) name) args with + | Some index when index + 1 < args.Length -> args[index + 1] + | _ -> fallback + +let configuration = option "--configuration" "Debug" +let repetitions = int (option "--repetitions" "3") +let projectCount = int (option "--projects" "16") +if projectCount < 4 || repetitions < 1 then failwith "Require --projects >= 4 and --repetitions >= 1" +let repo = Path.GetFullPath(Path.Combine(__SOURCE_DIRECTORY__, "../../..")) +let dotnet = Path.Combine(repo, ".dotnet", if OperatingSystem.IsWindows() then "dotnet.exe" else "dotnet") +let root = Path.Combine(repo, "artifacts", "MultithreadedTasks", DateTime.UtcNow.ToString("yyyyMMdd-HHmmss-fff")) +let cwd = Path.Combine(root, "unrelated-cwd") +Directory.CreateDirectory cwd |> ignore +let write (path: string) (text: string) = + Directory.CreateDirectory(Path.GetDirectoryName path) |> ignore + File.WriteAllText(path, text) +let xml (text: string) = SecurityElement.Escape text +let hash path = File.ReadAllBytes path |> SHA256.HashData |> Convert.ToHexString +let run label arguments = + let start = ProcessStartInfo(dotnet, WorkingDirectory = cwd, UseShellExecute = false, RedirectStandardOutput = true, RedirectStandardError = true) + for argument in arguments do start.ArgumentList.Add argument + start.Environment["DOTNET_CLI_UI_LANGUAGE"] <- "en-US" + start.Environment["MSBUILDLOGALLASSEMBLYLOADS"] <- "1" + // Each comparison selects its own mode, independently of an enclosing CI build. + start.Environment.Remove("MSBUILDFORCEMULTITHREADED") |> ignore + use child = Process.Start start + let pid = child.Id + let output = child.StandardOutput.ReadToEndAsync() + let errors = child.StandardError.ReadToEndAsync() + if not (child.WaitForExit(600_000)) then + child.Kill(true) + failwithf "%s exceeded ten minutes" label + let text = output.Result + errors.Result + write (Path.Combine(root, label + ".log")) text + if child.ExitCode <> 0 then printfn "%s: exit %d (see retained log)" label child.ExitCode + child.ExitCode, pid, text +let succeed label arguments = + let code, pid, output = run label arguments + if code <> 0 then failwithf "%s failed. See %s" label root + pid, output + +let _, sdk = succeed "sdk" [ "--version" ] +let _, msbuild = succeed "msbuild" [ "msbuild"; "-version"; "-nologo" ] +let sdkPath = Path.Combine(repo, ".dotnet", "sdk", sdk.Trim()) +let product = Path.Combine(repo, "artifacts", "bin", "fsc", configuration, "net11.0") +let taskProduct = Path.Combine(repo, "artifacts", "bin", "FSharp.Build", configuration, "netstandard2.0") +let taskAssembly = Path.Combine(taskProduct, "FSharp.Build.dll") +let compiler = Path.Combine(product, "fsc.dll") +let localFsi = Path.Combine(repo, "artifacts", "bin", "fsi", configuration, "net11.0", "fsi.dll") +for path in [ taskAssembly; compiler; localFsi ] do + if not (File.Exists path) then failwithf "Build local product bits first: missing %s" path +let taskHash = hash taskAssembly +printfn "SDK %sMSBuild %sLocal tasks: %s\nSHA256 %s\nEvidence: %s" sdk msbuild taskAssembly taskHash root +write (Path.Combine(root, "versions.txt")) $"SDK {sdk}MSBuild {msbuild}Tasks {taskAssembly}\nSHA256 {taskHash}\nCompiler {compiler}\nFsi {localFsi}\n" + +// An ordinary SDK helper project uses only assemblies supplied by the running SDK, without NuGet packages. +let helper = Path.Combine(root, "probe") +write (Path.Combine(root, "Directory.Build.props")) "false" +write (Path.Combine(root, "Directory.Build.targets")) "" +write (Path.Combine(helper, "Probe.cs")) (File.ReadAllText(Path.Combine(__SOURCE_DIRECTORY__, "Probe.cs"))) +write (Path.Combine(helper, "Probe.csproj")) $""" + net11.0false + + {xml sdkPath}/Microsoft.Build.Framework.dllfalse + {xml sdkPath}/Microsoft.Build.Utilities.Core.dllfalse + +""" +succeed "probe-build" [ "build"; Path.Combine(helper, "Probe.csproj"); "-nologo"; "-v:minimal"; "-nr:false" ] |> ignore +let probeAssembly = Path.Combine(helper, "bin", "Debug", "net11.0", "Probe.dll") +let graph = Path.Combine(root, "graph") +let projects = [| for index in 1 .. projectCount -> sprintf "P%02d" index |] +write (Path.Combine(graph, "Directory.Build.props")) $""" + + True + {configuration} + {xml repo} + {xml probeAssembly}{xml localFsi} + falsefalse + + + + {xml taskAssembly} + {xml taskProduct}/Microsoft.FSharp.Targets + {xml taskProduct}/Microsoft.FSharp.NetSdk.props + {xml taskProduct}/Microsoft.FSharp.NetSdk.targets + {xml taskProduct}/Microsoft.FSharp.Overrides.NetSdk.targets + +""" +write (Path.Combine(graph, "Directory.Build.targets")) "" +for name in projects do + let directory = Path.Combine(graph, name) + for source, target in [ "Fixture.fsproj", name + ".fsproj"; "Program.fs", "Program.fs"; "check.fsx", "check.fsx" ] do + write (Path.Combine(directory, target)) (File.ReadAllText(Path.Combine(__SOURCE_DIRECTORY__, source))) + write (Path.Combine(directory, "sentinel.txt")) name + write (Path.Combine(directory, "Messages.txt")) $"marker,\"TEXT_{name}\"\n" + write (Path.Combine(directory, "Strings.resx")) $""" + text/microsoft-resx + 2.0 + RESX_{name} +""" + write (Path.Combine(directory, "dependent.txt")) $"DEPENDENT_{name}" + write (Path.Combine(directory, "template.txt")) "@MARKER@" +let solution = Path.Combine(graph, "Concurrent.slnx") +write solution ("\n" + String.concat "\n" [ for name in projects -> $" " ] + "\n") +let tasks = set [ "Fsc"; "Fsi"; "WriteCodeFragment"; "FSharpEmbedResourceText"; "FSharpEmbedResXSource"; "CreateFSharpManifestResourceName"; "MapSourceRoots"; "GenerateILLinkSubstitutions"; "SubstituteText" ] +let mutable baseline = Map.empty + +let clean () = + for name in projects do + for child in [ "bin"; "obj" ] do + let directory = Path.Combine(graph, name, child) + if Directory.Exists directory then Directory.Delete(directory, true) + let barrier = Path.Combine(graph, "barrier") + if Directory.Exists barrier then Directory.Delete(barrier, true) + +let validateEvidence label mt incremental pid = + let rows = File.ReadAllLines(Path.Combine(root, label + ".tsv")) |> Array.map (fun line -> line.Split('\t')) + let starts = rows |> Array.filter (fun row -> row[0] = "start") + let fscRuns = starts |> Array.filter (fun row -> row[3] = "Fsc") |> Array.length + if incremental && fscRuns <> 0 then failwithf "%s recompiled %d unchanged projects" label fscRuns + let requiredTasks = if incremental then set [ "Fsi"; "SubstituteText" ] else tasks + let commands = rows |> Array.filter (fun row -> row[0] = "command") |> Array.map (fun row -> row[2], row[5]) |> Map.ofArray + for task in tasks do + let matches = starts |> Array.filter (fun row -> row[3] = task) + let distinct = matches |> Array.map (fun row -> row[4]) |> Array.distinct + if requiredTasks.Contains task && distinct.Length <> projectCount then + failwithf "%s: %s ran in %d/%d projects" label task distinct.Length projectCount + for row in matches do + if not (String.Equals(Path.GetFullPath(row[5]), taskAssembly, StringComparison.OrdinalIgnoreCase)) then + failwithf "%s loaded the wrong %s: %s" label task row[5] + if task = "Fsc" || task = "Fsi" then + let tool = if task = "Fsc" then compiler else localFsi + if not (commands[row[2]].Replace('\\', '/').Contains(tool.Replace('\\', '/'), StringComparison.OrdinalIgnoreCase)) then + failwithf "%s did not execute local %s" label task + let routes = rows |> Array.filter (fun row -> row[0] = "route") + let controls = routes |> Array.filter (fun row -> row[5].Contains("Task \"SerialControl\"")) + if mt then + if controls.Length <> projectCount then failwithf "%s lacks TaskHost routing control evidence" label + for row in routes do + for task in tasks do + if row[5].Contains($"Task \"{task}\"") then failwithf "%s routed %s out of process: %s" label task row[5] + let pids = + projects |> Array.map (fun name -> + let proof = File.ReadAllText(Path.Combine(graph, name, "environment.txt")).Split('\t') + if Path.GetFullPath(proof[1]) <> Path.Combine(graph, name) || proof[2] <> name || proof[3] <> taskAssembly then + failwith "Project environment or loaded assembly proof differs" + int proof[0]) |> Array.distinct + let callers = controls |> Array.map (fun row -> int (Regex.Match(row[5], @"caller process (\d+)").Groups[1].Value)) |> Array.distinct + if mt && (pids.Length <> 1 || pids <> callers) then + failwithf "MT projects must execute in the routing caller: launcher=%d callers=%A projects=%A" pid callers pids + if not mt && pids.Length < 2 then failwith "MP did not use multiple processes" + let hosts = projects |> Array.map (fun name -> File.ReadAllText(Path.Combine(graph, name, "host.txt"))) |> Array.distinct + if hosts.Length <> 1 then failwithf "%s used inconsistent execution hosts" label + let host = hosts[0].Split('\t') + for index, assembly in [ 0, "Microsoft.Build.Framework.dll"; 2, "Microsoft.Build.Utilities.Core.dll" ] do + if Path.GetFullPath(host[index]) <> Path.Combine(sdkPath, assembly) || String.IsNullOrWhiteSpace(host[index + 1]) then + failwithf "%s did not execute against the SDK's %s: %A" label assembly host + write (Path.Combine(root, label + "-host.txt")) hosts[0] + printfn "%s: execution-host API verified, Framework=%s Utilities=%s" label host[1] host[3] + let finishes = rows |> Array.filter (fun row -> row[0] = "finish") |> Array.map (fun row -> row[2], int64 row[1]) |> Map.ofArray + let overlap task = + let points = + [| for row in starts do + if row[3] = task then + yield int64 row[1], 1 + yield finishes[row[2]], -1 |] |> Array.sort + points |> Array.scan (fun count (_, delta) -> count + delta) 0 |> Array.max + let fscOverlap, fsiOverlap = overlap "Fsc", overlap "Fsi" + if (not incremental && fscOverlap < 2) || fsiOverlap < 4 then + failwithf "Insufficient overlap: Fsc=%d Fsi=%d" fscOverlap fsiOverlap + let taskKinds = starts |> Array.map (fun row -> row[3]) |> Set.ofArray |> Set.intersect tasks |> Set.count + let proof = sprintf "%s: %d projects, %d local task kinds, PIDs=%A, Fsc executions=%d, overlap Fsc=%d Fsi=%d, routing controls=%d" label projectCount taskKinds pids fscRuns fscOverlap fsiOverlap controls.Length + write (Path.Combine(root, label + "-proof.txt")) proof + printfn "%s" proof + +let validateOutputs label = + let manifest = + [ for name in projects do + let directory = Path.Combine(graph, name) + for file in [ "fsi.txt"; "obj/substituted/template.txt" ] do + if File.ReadAllText(Path.Combine(directory, file)) <> name then failwithf "%s: wrong %s" name file + for file, marker in [ "Strings.fs", "RESX_" + name; "ILLink.Substitutions.xml", $"fullname=\"{name}\"" ] do + if not (File.ReadAllText(Path.Combine(directory, "obj/Release/net11.0", file)).Contains marker) then + failwithf "%s: generated %s has the wrong marker" name file + succeed (label + "-" + name) [ Path.Combine(directory, "bin", "Release", "net11.0", name + ".dll") ] |> ignore + for child in [ "bin/Release/net11.0"; "obj/Release/net11.0" ] do + for file in Directory.GetFiles(Path.Combine(directory, child), "*", SearchOption.AllDirectories) do + if [ ".dll"; ".pdb"; ".fs"; ".resx"; ".resources"; ".xml" ] |> List.contains (Path.GetExtension file) then + yield Path.GetRelativePath(graph, file), hash file ] |> Map.ofList + write (Path.Combine(root, label + ".sha256")) (manifest |> Map.toSeq |> Seq.map (fun (name, value) -> $"{value} {name}") |> String.concat "\n") + if baseline.IsEmpty then baseline <- manifest + elif manifest <> baseline then + let differences = manifest |> Map.filter (fun key value -> Map.tryFind key baseline <> Some value) |> Map.toSeq |> Seq.map fst + failwithf "%s differs from the first MP build: %A" label (Seq.toList differences) + printfn "%s: %d deterministic artifacts match" label manifest.Count + +let modeSwitch mt = if mt then "-mt" else "-mt:false" + +let build label mt = + run label ([ "msbuild"; solution; "-t:Build"; "-p:Configuration=Release"; "-m:4"; "-nr:false"; "-v:diag"; "-clp:ErrorsOnly;Summary"; + "-bl:" + Path.Combine(root, label + ".binlog"); "-logger:EvidenceLogger," + probeAssembly + ";" + Path.Combine(root, label + ".tsv"); + modeSwitch mt ]) + +for iteration in 1 .. repetitions do + for mt in [ false; true ] do + let label = sprintf "%02d-%s" iteration (if mt then "mt" else "mp") + clean () + succeed (label + "-restore") [ "restore"; solution; "-p:Configuration=Release"; "-nr:false"; "-v:minimal" ] |> ignore + let code, pid, _ = build label mt + if code <> 0 then failwithf "%s failed. Logs: %s" label root + validateEvidence label mt false pid + validateOutputs label + let noOp = label + "-noop" + Directory.Delete(Path.Combine(graph, "barrier"), true) + let code, pid, _ = build noOp mt + if code <> 0 then failwithf "%s failed. Logs: %s" noOp root + validateEvidence noOp mt true pid + validateOutputs noOp + +// A broken project must not contaminate its concurrently built siblings. +for mt in [ false; true ] do + for failure in [ "resource"; "type" ] do + let label = (if mt then "mt-" else "mp-") + failure + clean () + let file = Path.Combine(graph, projects[0], if failure = "resource" then "Messages.txt" else "Program.fs") + let original = File.ReadAllText file + try + File.WriteAllText(file, if failure = "resource" then "malformed resource\n" else "module Program\nlet value: int = \"wrong\"\n") + succeed (label + "-restore") [ "restore"; solution; "-p:Configuration=Release"; "-nr:false"; "-v:minimal" ] |> ignore + let code, _, output = build label mt + let expected = if failure = "type" then "FS0001" else "After the identifier 'malformed' there should be a comma" + if code = 0 || not (output.Contains expected) then failwithf "%s did not produce the expected failure" label + let errors = File.ReadAllLines(Path.Combine(root, label + ".tsv")) |> Array.filter (fun row -> row.StartsWith("error\t")) + if errors.Length = 0 || errors |> Array.exists (fun row -> row.Split('\t')[4] <> Path.Combine(graph, projects[0], projects[0] + ".fsproj")) then + failwithf "%s reported errors outside the broken project" label + if failure = "resource" && errors.Length <> 1 then + failwithf "%s reported %d errors for one malformed resource" label errors.Length + for name in projects |> Array.skip 1 do + let dll = Path.Combine(graph, name, "bin/Release/net11.0", name + ".dll") + succeed (label + "-" + name) [ dll ] |> ignore + if hash dll <> baseline[Path.GetRelativePath(graph, dll)] then failwithf "%s contaminated %s" label name + printfn "%s: expected failure; %d unaffected executables match baseline" label (projectCount - 1) + finally + File.WriteAllText(file, original) + +// Compare published behavior without changing the existing substitutions target scheduling. +let resourceNames file = + use stream = File.OpenRead file + use pe = new PEReader(stream) + let metadata = pe.GetMetadataReader() + [ for handle in metadata.ManifestResources -> metadata.GetString(metadata.GetManifestResource(handle).Name) ] +let trimProject = Path.Combine(graph, projects[1]) +let metadata names = names |> List.filter (fun (name: string) -> name.StartsWith("FSharpSignature") || name.StartsWith("FSharpOptimization")) |> Set.ofList +let untrimmed = Path.Combine(trimProject, "bin/Release/net11.0", projects[1] + ".dll") +let originalMetadata = metadata (resourceNames untrimmed) +if originalMetadata.IsEmpty then failwith "Trimming control has no F# metadata" +let trimFailures = ResizeArray() +for disabled in [ true; false ] do + let mutable trimmedHash = "" + for mt in [ false; true ] do + let label = (if mt then "publish-mt" else "publish-mp") + (if disabled then "-control" else "") + let publish = Path.Combine(trimProject, "published") + for child in [ "published"; "bin"; "obj" ] do + let directory = Path.Combine(trimProject, child) + if Directory.Exists directory then Directory.Delete(directory, true) + succeed label ([ "publish"; Path.Combine(trimProject, projects[1] + ".fsproj"); "-c"; "Release"; + "-r"; RuntimeInformation.RuntimeIdentifier; "--self-contained"; "true"; "-p:PublishTrimmed=true"; "-p:UseAppHost=true"; + "-p:DisableILLinkSubstitutions=" + string disabled; + "-p:PublishDir=published/"; "-nr:false"; "-v:minimal"; "-bl:" + Path.Combine(root, label + ".binlog"); + "-m:4"; modeSwitch mt ]) |> ignore + let dll = Path.Combine(publish, projects[1] + ".dll") + succeed (label + "-run") [ dll ] |> ignore + let names = resourceNames dll + write (Path.Combine(root, label + "-resources.txt")) (String.concat "\n" names) + let expected = originalMetadata + let actual = metadata names + if actual <> expected then trimFailures.Add(sprintf "%s: expected F# metadata %A, found %A" label expected actual) + if mt && hash dll <> trimmedHash then failwith "MP/MT trimmed assemblies differ" + trimmedHash <- hash dll + printfn "%s: executable passed; F# metadata resources=%d; SHA256 %s" label actual.Count trimmedHash +if hash taskAssembly <> taskHash then failwith "Local FSharp.Build changed during the run. Rerun against stable product bits." +let summary = sprintf "%d clean and no-op MP/MT pairs passed, %d projects, %d artifacts per build, four failure/isolation builds, four trimmed publishes (%d substitution failures). Logs: %s" repetitions projectCount baseline.Count trimFailures.Count root +write (Path.Combine(root, "summary.txt")) summary +printfn "%s" summary +if trimFailures.Count <> 0 then failwith (String.concat "\n" trimFailures) +printfn "PASS" diff --git a/tests/FSharp.Build.UnitTests/BuildTaskTestHelpers.fs b/tests/FSharp.Build.UnitTests/BuildTaskTestHelpers.fs new file mode 100644 index 00000000000..00c358419dd --- /dev/null +++ b/tests/FSharp.Build.UnitTests/BuildTaskTestHelpers.fs @@ -0,0 +1,100 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Build.UnitTests + +open System +open System.Threading +open System.Threading.Tasks +open Microsoft.Build.Framework +open Xunit +open FSharp.Test.ReflectionHelper + +#nowarn "1182" + +type MockEngine() = + member val Errors = ResizeArray() with get + member val Warnings = ResizeArray() with get + member val Custom = ResizeArray() with get + member val Messages = ResizeArray() with get + + interface IBuildEngine with + + member _.BuildProjectFile(projectFileName: string, targetNames: string [], globalProperties: System.Collections.IDictionary, targetOutputs: System.Collections.IDictionary): bool = + failwith "Not Implemented" + + member _.ColumnNumberOfTaskNode: int = 0 + + member _.ContinueOnError = true + + member _.LineNumberOfTaskNode: int = 0 + + member this.LogCustomEvent(e: CustomBuildEventArgs): unit = + this.Custom.Add e + + member this.LogErrorEvent(e: BuildErrorEventArgs): unit = + this.Errors.Add e + + member this.LogMessageEvent(e: BuildMessageEventArgs): unit = + this.Messages.Add e + + member this.LogWarningEvent(e: BuildWarningEventArgs): unit = + this.Warnings.Add e + + member _.ProjectFileOfTaskNode: string = "" + + interface IBuildEngine2 with + member _.IsRunningMultipleNodes = false + member _.BuildProjectFile(_, _, _, _, _) = failwith "Not Implemented" + member _.BuildProjectFilesInParallel(_, _, _, _, _, _, _) = failwith "Not Implemented" + + interface IBuildEngine3 with + member _.BuildProjectFilesInParallel(_, _, _, _, _, _) = failwith "Not Implemented" + member _.Yield() = () + member _.Reacquire() = () + +module BuildTaskTestHelpers = + + let createTaskEnvironmentInTemporaryDirectory () = + let directory = TestFramework.createTemporaryDirectory () + let environment = TaskEnvironment.CreateWithProjectDirectoryAndEnvironment(directory.FullName) + environment, directory + + // TaskEnvironment.Dispose (which releases the thread-local working-directory override) is internal + // and TaskEnvironment is not IDisposable, so reflection is the only deterministic way to invoke it. + let private taskEnvironmentDisposeMethod = + getPrivateInstanceMethod "Dispose" typeof + + let disposeTaskEnvironment (environment: TaskEnvironment) = + taskEnvironmentDisposeMethod.Invoke(environment, null) |> ignore + + let assignTaskEnvironment environment (task: #IMultiThreadableTask) = + (task :> IMultiThreadableTask).TaskEnvironment <- environment + task + + let withTaskEnvironmentUsing create body = + let environment, state = create () + + try + body environment state + finally + disposeTaskEnvironment environment + + let withTaskEnvironment body = + withTaskEnvironmentUsing createTaskEnvironmentInTemporaryDirectory body + + let withTaskEnvironmentPairUsing create body = + withTaskEnvironmentUsing create (fun environmentA stateA -> + withTaskEnvironmentUsing create (fun environmentB stateB -> body environmentA stateA environmentB stateB)) + + let runConcurrentlyWithBarrier scenario (actions: ((unit -> unit) -> 'T) list) = + use barrier = new Barrier(List.length actions) + let release () = + Assert.True(barrier.SignalAndWait(TimeSpan.FromSeconds 10.0), $"{scenario}: barrier timed out") + let tasks = [| for action in actions -> Task.Run(fun () -> action release) |] + + Assert.True( + Task.WaitAll([| for task in tasks -> task :> Task |], TimeSpan.FromSeconds 30.0), + $"{scenario}: concurrent executions timed out; possible deadlock." + ) + + [| for task in tasks -> task.Result |] diff --git a/tests/FSharp.Build.UnitTests/FSharp.Build.UnitTests.fsproj b/tests/FSharp.Build.UnitTests/FSharp.Build.UnitTests.fsproj index 0b489b6cc7c..d592ea26d50 100644 --- a/tests/FSharp.Build.UnitTests/FSharp.Build.UnitTests.fsproj +++ b/tests/FSharp.Build.UnitTests/FSharp.Build.UnitTests.fsproj @@ -15,7 +15,10 @@ XunitSetup.fs + + + diff --git a/tests/FSharp.Build.UnitTests/FileTaskEnvironmentTests.fs b/tests/FSharp.Build.UnitTests/FileTaskEnvironmentTests.fs new file mode 100644 index 00000000000..9047a1ac2af --- /dev/null +++ b/tests/FSharp.Build.UnitTests/FileTaskEnvironmentTests.fs @@ -0,0 +1,503 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Build.UnitTests + +open System +open System.IO +open System.Runtime.InteropServices +open Microsoft.Build.Framework +open Microsoft.Build.Utilities +open FSharp.Build +open Xunit +open BuildTaskTestHelpers + +type ResourceTaskKind = + | Resx + | Text + +type ResourcePathShape = + | Relative + | Absolute + | DotSegment + | Invalid + | RootRelative + | DriveRelative + +type private PathExpectation = + | Restored + | PreservedAbsolute + | PartiallyQualified + +[] +type FileTaskEnvironmentTests() = + + let assertContains scenario (needle: string) (text: string) = + Assert.True( + text.IndexOf(needle, StringComparison.Ordinal) >= 0, + $"{scenario}: expected '{text}' to contain '{needle}'" + ) + + let assertNotContains scenario (needle: string) (text: string) = + Assert.True( + text.IndexOf(needle, StringComparison.Ordinal) < 0, + $"{scenario}: expected '{text}' not to contain '{needle}'" + ) + + let assertFileExists scenario path = + Assert.True(File.Exists path, $"{scenario}: expected generated file at '{path}'") + + let withDecoyCurrentDirectory body = + let decoy = TestFramework.createTemporaryDirectory () + let original = Environment.CurrentDirectory + + try + Environment.CurrentDirectory <- decoy.FullName + body decoy + finally + Environment.CurrentDirectory <- original + + let runConcurrently scenario executeA executeB = + let results = + runConcurrentlyWithBarrier + scenario + [ + (fun release -> + release () + executeA ()) + (fun release -> + release () + executeB ()) + ] + + Assert.True(results[0], $"{scenario}: task A failed") + Assert.True(results[1], $"{scenario}: task B failed") + + let withIsolatedTaskEnvironmentPair body = + withDecoyCurrentDirectory (fun decoy -> + withTaskEnvironmentPairUsing + createTaskEnvironmentInTemporaryDirectory + (fun environmentA directoryA environmentB directoryB -> + body environmentA directoryA environmentB directoryB + Assert.Empty(Directory.GetFiles(decoy.FullName, "*", SearchOption.AllDirectories)))) + + let createResourceTask kind environment engine (input: string) (intermediate: string) : ITask * (unit -> ITaskItem[]) = + match kind with + | Resx -> + let item = TaskItem(input) :> ITaskItem + item.SetMetadata("GenerateSource", "true") + item.SetMetadata("GeneratedModuleName", "Resource") + + let task = + FSharpEmbedResXSource( + BuildEngine = engine, + EmbeddedResource = [| item |], + IntermediateOutputPath = intermediate + ) + |> assignTaskEnvironment environment + + (task :> ITask), (fun () -> task.GeneratedSource) + | Text -> + let task = + FSharpEmbedResourceText( + BuildEngine = engine, + EmbeddedText = [| TaskItem(input) :> ITaskItem |], + IntermediateOutputPath = intermediate + ) + |> assignTaskEnvironment environment + + (task :> ITask), (fun () -> Array.append task.GeneratedSource task.GeneratedResx) + + let resourceKindInfo = + function + | Resx -> "FSharpEmbedResXSource", ".resx" + | Text -> "FSharpEmbedResourceText", ".txt" + + let resourceContent kind marker = + match kind with + | Resx -> $"""{marker}""" + | Text -> $"greeting,\"{marker}\"\n" + + let countOccurrences (needle: string) (text: string) = + text.Split([| needle |], StringSplitOptions.None).Length - 1 + + static member ResourceKinds = [ for kind in [ Resx; Text ] -> [| box kind |] ] + + static member DiagnosticPaths = + [ + for kind in [ Resx; Text ] do + for shape in + [ + Relative; Absolute; DotSegment; Invalid + if RuntimeInformation.IsOSPlatform OSPlatform.Windows then + RootRelative + DriveRelative + ] do + yield [| box kind; box shape |] + ] + + static member OutputFailures = + [ for kind, extension in [ Resx, ".fs"; Text, ".fs"; Text, ".fsi"; Text, ".resx" ] -> + [| box kind; box extension |] ] + + [] + member _.``WriteCodeFragment isolates relative output paths per task``() = + withIsolatedTaskEnvironmentPair (fun environmentA directoryA environmentB directoryB -> + let makeTask (name: string) environment = + WriteCodeFragment( + BuildEngine = MockEngine(), + Language = "F#", + AssemblyAttributes = [| TaskItem(name) :> ITaskItem |], + OutputFile = (TaskItem("Generated.fs") :> ITaskItem) + ) + |> assignTaskEnvironment environment + + let taskA = makeTask "AssemblyMetadataA" environmentA + let taskB = makeTask "AssemblyMetadataB" environmentB + let scenario = "WriteCodeFragment isolates relative output paths per task" + runConcurrently scenario taskA.Execute taskB.Execute + + let check (directory: DirectoryInfo) own other (task: WriteCodeFragment) = + let path = Path.Combine(directory.FullName, "Generated.fs") + assertFileExists own path + let contents = File.ReadAllText path + assertContains own own contents + assertNotContains own other contents + Assert.Equal("Generated.fs", task.OutputFile.ItemSpec) + + check directoryA "AssemblyMetadataA" "AssemblyMetadataB" taskA + check directoryB "AssemblyMetadataB" "AssemblyMetadataA" taskB) + + [] + member _.``WriteCodeFragment preserves its OutputDirectory quirk``() = + withTaskEnvironment (fun environment directory -> + let task = + WriteCodeFragment( + BuildEngine = MockEngine(), + Language = "F#", + AssemblyAttributes = [| TaskItem("SomeAttribute") :> ITaskItem |], + OutputDirectory = (TaskItem("SubDir") :> ITaskItem), + OutputFile = (TaskItem("Generated2.fs") :> ITaskItem) + ) + |> assignTaskEnvironment environment + + Assert.True(task.Execute()) + assertFileExists "OutputDirectory quirk" (Path.Combine(directory.FullName, "Generated2.fs")) + Assert.False(File.Exists(Path.Combine(directory.FullName, "SubDir", "Generated2.fs"))) + Assert.Equal(Path.Combine("SubDir", "Generated2.fs"), task.OutputFile.ItemSpec)) + + [] + member _.``GenerateILLinkSubstitutions isolates relative output paths per task``() = + withIsolatedTaskEnvironmentPair (fun environmentA directoryA environmentB directoryB -> + let makeTask (assemblyName: string) (intermediate: string) environment = + GenerateILLinkSubstitutions( + BuildEngine = MockEngine(), + AssemblyName = assemblyName, + IntermediateOutputPath = intermediate + ) + |> assignTaskEnvironment environment + + let intermediateA = Path.Combine("obj", "DebugA") + let intermediateB = Path.Combine("obj", "DebugB") + let taskA = makeTask "AssemblyA" intermediateA environmentA + let taskB = makeTask "AssemblyB" intermediateB environmentB + let scenario = "GenerateILLinkSubstitutions isolates relative output paths per task" + runConcurrently scenario taskA.Execute taskB.Execute + + let check + (directory: DirectoryInfo) + (intermediate: string) + own + other + (task: GenerateILLinkSubstitutions) + = + let item = Assert.Single(task.GeneratedItems) + let expectedItemSpec = Path.Combine(intermediate, "ILLink.Substitutions.xml") + Assert.Equal(expectedItemSpec, item.ItemSpec) + Assert.Equal("ILLink.Substitutions.xml", item.GetMetadata("LogicalName")) + let path = Path.Combine(directory.FullName, expectedItemSpec) + assertFileExists own path + let contents = File.ReadAllText path + assertContains own own contents + assertNotContains own other contents + + check directoryA intermediateA "AssemblyA" "AssemblyB" taskA + check directoryB intermediateB "AssemblyB" "AssemblyA" taskB) + + [] + [] + [] + member _.``ILLink substitutions only rewrite changed content``(assemblyName: string, changed: bool) = + withTaskEnvironment (fun environment directory -> + let task = + GenerateILLinkSubstitutions(BuildEngine = MockEngine(), AssemblyName = "AssemblyA", IntermediateOutputPath = "obj") + |> assignTaskEnvironment environment + Assert.True(task.Execute()) + let output = Assert.Single(task.GeneratedItems).ItemSpec + let file = Path.Combine(directory.FullName, output) + let timestamp = DateTime(2001, 1, 1, 0, 0, 0, DateTimeKind.Utc) + File.SetLastWriteTimeUtc(file, timestamp) + task.AssemblyName <- assemblyName + Assert.True(task.Execute()) + Assert.Equal(changed, File.GetLastWriteTimeUtc(file) <> timestamp) + Assert.Contains($"fullname=\"{assemblyName}\"", File.ReadAllText file) + Assert.Equal(output, Assert.Single(task.GeneratedItems).ItemSpec)) + + [] + [] + member _.``Resource generators isolate relative input and output paths per task``(kind: ResourceTaskKind) = + withIsolatedTaskEnvironmentPair (fun environmentA directoryA environmentB directoryB -> + let scenario, extension = resourceKindInfo kind + let intermediate = Path.Combine("obj", "Debug") + let input = "Resource" + extension + + for directory in [ directoryA; directoryB ] do + Directory.CreateDirectory(Path.Combine(directory.FullName, intermediate)) + |> ignore + + File.WriteAllText(Path.Combine(directoryA.FullName, input), resourceContent kind "Hello from A") + File.WriteAllText(Path.Combine(directoryB.FullName, input), resourceContent kind "Hello from B") + + let taskA, outputA = createResourceTask kind environmentA (MockEngine()) input intermediate + let taskB, outputB = createResourceTask kind environmentB (MockEngine()) input intermediate + runConcurrently scenario taskA.Execute taskB.Execute + + let generatedSpecs (output: unit -> ITaskItem[]) = output () |> Array.map _.ItemSpec + + let source = Path.Combine(intermediate, "Resource.fs") + let expectedSpecs, contentSpecs = + match kind with + | Resx -> [ source ], [ source ] + | Text -> + let signature = Path.Combine(intermediate, "Resource.fsi") + let resx = Path.Combine(intermediate, "Resource.resx") + [ signature; source; resx ], [ source; resx ] + + for output in [ outputA; outputB ] do + Assert.Equal(List.toArray expectedSpecs, generatedSpecs output) + + for directory, own, other in + [ directoryA, "Hello from A", "Hello from B"; directoryB, "Hello from B", "Hello from A" ] do + for spec in expectedSpecs do + assertFileExists scenario (Path.Combine(directory.FullName, spec)) + + for spec in contentSpecs do + let contents = File.ReadAllText(Path.Combine(directory.FullName, spec)) + assertContains scenario own contents + assertNotContains scenario other contents) + + [] + [Oops", "Malformed.resx", false)>] + [Oops", "Missing resource name", true)>] + [", "Missing resource value", true)>] + [] + member _.``Resource failures log once without console output``(input: string, content: string, expected: string, taskFailed: bool) = + withTaskEnvironment (fun environment directory -> + File.WriteAllText(Path.Combine(directory.FullName, input), content) + let kind = if Path.GetExtension(input) = ".txt" then Text else Resx + let engine = MockEngine() + let task, _ = createResourceTask kind environment engine input "obj" + use capture = new FSharp.Test.TestConsole.ExecutionCapture() + Assert.False(task.Execute()) + Assert.Equal("", capture.OutText) + Assert.Equal("", capture.ErrorText) + let message = (Assert.Single(engine.Errors)).Message + assertContains input expected message + assertNotContains input directory.FullName message + + if taskFailed then + for leaked in [ "An exception occurred when processing"; "TaskFailed"; " at " ] do + assertNotContains input leaked message) + + [] + [] + member _.``Resource task diagnostics preserve every input path shape``(kind: ResourceTaskKind, shape: ResourcePathShape) = + withTaskEnvironment (fun environment directory -> + let kindName, extension = resourceKindInfo kind + let input, expectation = + match shape with + | Relative -> $"Missing{extension}", Restored + | Absolute -> Path.Combine(directory.FullName, $"AbsentUnderProject{extension}"), PreservedAbsolute + | DotSegment -> Path.Combine("sub", "..", $"Missing{extension}"), Restored + | Invalid -> $"in|valid{extension}", Restored + | RootRelative -> $@"\Missing{extension}", PartiallyQualified + | DriveRelative -> $@"C:Missing{extension}", PartiallyQualified + let scenario = $"{kindName}: {shape}" + let engine = MockEngine() + let task, _ = createResourceTask kind environment engine input "obj" + Assert.False(task.Execute(), scenario) + let error = Assert.Single(engine.Errors) + let message = error.Message + if kind = Text then Assert.Equal(input, error.File) + assertContains scenario input (message + "\n" + error.File) + + match expectation with + | PreservedAbsolute -> + Assert.True(countOccurrences input message >= 2, $"{scenario}: expected original path in prefix and exception") + | Restored -> assertNotContains scenario directory.FullName message + | PartiallyQualified -> + assertNotContains scenario (environment.GetAbsolutePath(input).Value) message + assertNotContains scenario directory.FullName message) + + [] + [] + member _.``Resource write failures preserve output paths``(kind: ResourceTaskKind, outputExtension: string) = + withTaskEnvironment (fun environment directory -> + let _, inputExtension = resourceKindInfo kind + let input = "Resource" + inputExtension + let output = Path.Combine("obj", "Resource" + outputExtension) + File.WriteAllText(Path.Combine(directory.FullName, input), resourceContent kind "Hello") + Directory.CreateDirectory(Path.Combine(directory.FullName, output)) |> ignore + let engine = MockEngine() + let task, _ = createResourceTask kind environment engine input "obj" + Assert.False(task.Execute()) + let message = (Assert.Single(engine.Errors)).Message + assertContains output output message + assertNotContains output directory.FullName message) + + [] + member _.``FSharpEmbedResourceText restores overlapping paths longest first``() = + withTaskEnvironment (fun environment directory -> + let shortOriginal = "p" + let longOriginal = Path.Combine("p", "deeper", "..", "deeper") + let canonicalLong = Path.GetFullPath(environment.GetAbsolutePath(longOriginal).Value) + + let message = $"Could not find a part of the path '{canonicalLong}'." + + let actual = + TaskEnvironmentPaths.restoreOriginalPaths environment message [ shortOriginal; longOriginal ] + + Assert.Equal($"Could not find a part of the path '{longOriginal}'.", actual) + assertNotContains "overlapping path restoration" directory.FullName actual) + + [] + member _.``FSharpEmbedResourceText leaves a rooted path that is only a lexical prefix untouched``() = + withTaskEnvironment (fun environment _ -> + // rooted "p" is a lexical prefix of rooted "parts/x"; restoration must not rewrite the latter. + let original = "p" + let unrelated = environment.GetAbsolutePath(Path.Combine("parts", "x")).Value + let message = $"Could not find a part of the path '{unrelated}'." + + let actual = + TaskEnvironmentPaths.restoreOriginalPaths environment message [ original ] + + Assert.Equal(message, actual)) + + [] + [] + [] + [] + [] + [] + [] + [] + [] + [] + [] + [] + [] + [] + [] + member _.``Path restoration respects diagnostic delimiters and quoted filenames``(format: string, restore: bool) = + withTaskEnvironment (fun environment _ -> + let original = "file.fs" + let rooted = environment.GetAbsolutePath(original).Value + let message = String.Format(format, rooted) + let expected = String.Format(format, if restore then original else rooted) + Assert.Equal(expected, TaskEnvironmentPaths.restoreOriginalPaths environment message [ original ])) + + [] + [] + [] + [] + [] + member _.``RichText incremental generation respects metadata changes``(before: bool, after: bool) = + withTaskEnvironment (fun environment directory -> + let input = "Toggle.txt" + let intermediate = "obj" + Directory.CreateDirectory(Path.Combine(directory.FullName, intermediate)) |> ignore + let source = Path.Combine(directory.FullName, input) + File.WriteAllText(source, "greeting,\"Hello\"\n") + File.SetLastWriteTimeUtc(source, DateTime(2000, 1, 1, 0, 0, 0, DateTimeKind.Utc)) + + let runWith richText = + let item = TaskItem(input) :> ITaskItem + item.SetMetadata("RichText", if richText then "true" else "false") + + let task = + FSharpEmbedResourceText( + BuildEngine = MockEngine(), + EmbeddedText = [| item |], + IntermediateOutputPath = intermediate + ) + |> assignTaskEnvironment environment + + Assert.True(task.Execute(), "RichText toggle: task should succeed") + + let generatedFs = Path.Combine(directory.FullName, intermediate, "Toggle.fs") + let richTextOpen = "open FSharp.Compiler.Text" + runWith before + Assert.Equal(before, File.ReadAllText(generatedFs).Contains richTextOpen) + let outputs = [ for ext in [ ".fs"; ".fsi"; ".resx" ] -> Path.ChangeExtension(generatedFs, ext) ] + let stamp = DateTime(2001, 1, 1, 0, 0, 0, DateTimeKind.Utc) + for output in outputs do File.SetLastWriteTimeUtc(output, stamp) + runWith after + Assert.Equal(after, File.ReadAllText(generatedFs).Contains richTextOpen) + for output in outputs do + Assert.Equal((before = after), (File.GetLastWriteTimeUtc(output) = stamp))) + + [] + [] + [] + [] + [] + member _.``SubstituteText isolates ordered replacements``(pattern1: string, replacement1: string, pattern2: string, replacement2: string, expected: string) = + withIsolatedTaskEnvironmentPair (fun environmentA directoryA environmentB directoryB -> + let input = "Source.txt" + let intermediate = Path.Combine("obj", "Debug") + File.WriteAllText(Path.Combine(directoryA.FullName, input), "Hello from A. Token: PLACEHOLDER") + File.WriteAllText(Path.Combine(directoryB.FullName, input), "Hello from B. Token: PLACEHOLDER") + + let makeTask environment = + let item = TaskItem(input) :> ITaskItem + item.SetMetadata("IntermediateTargetPath", intermediate) + item.SetMetadata("Pattern1", pattern1) + item.SetMetadata("Replacement1", replacement1) + item.SetMetadata("Pattern2", pattern2) + item.SetMetadata("Replacement2", replacement2) + SubstituteText(BuildEngine = MockEngine(), EmbeddedResources = [| item |]) + |> assignTaskEnvironment environment + + let taskA, taskB = makeTask environmentA, makeTask environmentB + let scenario = "SubstituteText isolates relative input and output paths per task" + runConcurrently scenario taskA.Execute taskB.Execute + + let noReplacement = String.IsNullOrWhiteSpace pattern1 && String.IsNullOrWhiteSpace pattern2 + let expectedItemSpec = if noReplacement then input else Path.Combine(intermediate, input) + + for directory, expected, task in + [ + directoryA, $"Hello from A. Token: {expected}", taskA + directoryB, $"Hello from B. Token: {expected}", taskB + ] do + Assert.Equal(expectedItemSpec, Assert.Single(task.CopiedFiles).ItemSpec) + let path = Path.Combine(directory.FullName, expectedItemSpec) + assertFileExists expected path + Assert.Equal(expected, File.ReadAllText path) + if noReplacement then Assert.False(Directory.Exists(Path.Combine(directory.FullName, intermediate)))) + + [] + member _.``SubstituteText preserves its missing-source success behavior``() = + withTaskEnvironment (fun environment directory -> + let item = TaskItem("Missing.txt") :> ITaskItem + item.SetMetadata("IntermediateTargetPath", "obj") + item.SetMetadata("Pattern1", "PLACEHOLDER") + item.SetMetadata("Replacement1", "REPLACED") + + let task = + SubstituteText(BuildEngine = MockEngine(), EmbeddedResources = [| item |]) + |> assignTaskEnvironment environment + + Assert.True(task.Execute()) + let expectedItemSpec = Path.Combine("obj", "Missing.txt") + Assert.Equal(expectedItemSpec, Assert.Single(task.CopiedFiles).ItemSpec) + Assert.False(File.Exists(Path.Combine(directory.FullName, expectedItemSpec)))) diff --git a/tests/FSharp.Build.UnitTests/MapSourceRootsTests.fs b/tests/FSharp.Build.UnitTests/MapSourceRootsTests.fs index ec590e52e42..dc2e3d95bc2 100644 --- a/tests/FSharp.Build.UnitTests/MapSourceRootsTests.fs +++ b/tests/FSharp.Build.UnitTests/MapSourceRootsTests.fs @@ -11,38 +11,6 @@ open FSharp.Test #nowarn "1182" //Unused arguments -type MockEngine() = - member val Errors = ResizeArray() with get - member val Warnings = ResizeArray() with get - member val Custom = ResizeArray() with get - member val Messages = ResizeArray() with get - - interface IBuildEngine with - - member _.BuildProjectFile(projectFileName: string, targetNames: string [], globalProperties: System.Collections.IDictionary, targetOutputs: System.Collections.IDictionary): bool = - failwith "Not Implemented" - - member _.ColumnNumberOfTaskNode: int = 0 - - member _.ContinueOnError = true - - member _.LineNumberOfTaskNode: int = 0 - - member this.LogCustomEvent(e: CustomBuildEventArgs): unit = - this.Custom.Add e - failwith "Not Implemented" - - member this.LogErrorEvent(e: BuildErrorEventArgs): unit = - this.Errors.Add e - - member this.LogMessageEvent(e: BuildMessageEventArgs): unit = - this.Messages.Add e - - member this.LogWarningEvent(e: BuildWarningEventArgs): unit = - this.Warnings.Add e - - member _.ProjectFileOfTaskNode: string = "" - type SourceRoot = SourceRoot of path: string * diff --git a/tests/FSharp.Build.UnitTests/MultiThreadedTaskTests.fs b/tests/FSharp.Build.UnitTests/MultiThreadedTaskTests.fs new file mode 100644 index 00000000000..d7277d46f72 --- /dev/null +++ b/tests/FSharp.Build.UnitTests/MultiThreadedTaskTests.fs @@ -0,0 +1,244 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace FSharp.Build.UnitTests + +open System +open System.IO +open System.Runtime.InteropServices +open System.Threading +open Microsoft.Build.Framework +open Microsoft.Build.Utilities +open FSharp.Build +open Xunit +open BuildTaskTestHelpers + +type FauxHostObject(?executeCompiler: bool) = + let mutable flags: string[] = [||] + let mutable sources: string[] = [||] + + member _.Compile(compile: Func, flagsIn: string[], sourcesIn: string[]) = + flags <- flagsIn + sources <- sourcesIn + if defaultArg executeCompiler false then compile.Invoke() else 0 + + member _.Flags = flags + member _.Sources = sources + + interface ITaskHost + +type MultiThreadedTaskTests() = + + static member MultiThreadableTaskTypes: obj[] seq = + [ + typeof + typeof + typeof + typeof + typeof + typeof + typeof + typeof + typeof + ] + |> Seq.map (fun taskType -> [| box taskType |]) + + [] + [] + member _.``task preserves its public shape and is marked directly multithreadable`` (taskType: Type) = + let attributes = taskType.GetCustomAttributes(typeof, false) + Assert.True(attributes.Length = 1, $"{taskType.Name}: expected one direct multithreadable attribute") + Assert.NotNull(taskType.GetConstructor(Type.EmptyTypes)) + Assert.Single(taskType.GetConstructors()) |> ignore + + let expectedBase = + if taskType = typeof || taskType = typeof then + typeof + elif taskType = typeof then + typeof + else + typeof + + Assert.Equal(expectedBase, taskType.BaseType) + if taskType <> typeof then + Assert.True(typeof.IsAssignableFrom(taskType)) + + [] + member _.``all concrete build tasks have a reviewed contract``() = + let discovered = + typeof.Assembly.GetTypes() + |> Seq.filter (fun taskType -> taskType.IsPublic && not taskType.IsAbstract && typeof.IsAssignableFrom taskType) + |> Seq.map _.FullName + |> Set.ofSeq + let reviewed = + MultiThreadedTaskTests.MultiThreadableTaskTypes + |> Seq.map (fun row -> (row[0] :?> Type).FullName) + |> Set.ofSeq + Assert.Equal>(reviewed, discovered) + + [] + member _.``failed preparation releases waiting workers``() = + use finished = new ManualResetEventSlim() + let errors = + Assert.Throws(fun () -> + runConcurrentlyWithBarrier + "failed preparation" + [ + (fun _ -> failwith "prepare failed") + (fun release -> + try release () + finally finished.Set()) + ] + |> ignore) + Assert.True(finished.IsSet, "The waiting worker must terminate before the helper returns") + Assert.True(errors.InnerExceptions |> Seq.exists (fun error -> error.Message = "prepare failed")) + +type CompilerTaskKind = + | Compiler + | Interactive + +type FscFsiMultiThreadedTaskTests() = + + static let environmentWithCompilerBin () = + let projectDirectory = TestFramework.createTemporaryDirectory().FullName + let relativeBin = "compilerBin" + let variables = dict [ "FSHARP_COMPILER_BIN", relativeBin ] + let environment = TaskEnvironment.CreateWithProjectDirectoryAndEnvironment(projectDirectory, variables) + environment, Path.Combine(projectDirectory, relativeBin) + + let toolPath kind environment = + match kind with + | Compiler -> + let task = Fsc() |> assignTaskEnvironment environment + "fsc.exe", task.InternalGenerateFullPathToTool() + | Interactive -> + let task = Fsi() |> assignTaskEnvironment environment + "fsi.exe", task.InternalGenerateFullPathToTool() + + static member CompilerPairs = + [ for first, second in [ Compiler, Interactive; Compiler, Compiler ] -> [| box first; box second |] ] + + [] + [] + member _.``compiler tasks resolve isolated compiler-bin environments``(first: CompilerTaskKind, second: CompilerTaskKind) = + withTaskEnvironmentPairUsing environmentWithCompilerBin (fun environmentA binA environmentB binB -> + let executableA, pathA = toolPath first environmentA + let executableB, pathB = toolPath second environmentB + Assert.Equal(Path.Combine(binA, executableA), pathA) + Assert.Equal(Path.Combine(binB, executableB), pathB)) + + [] + member _.``concurrent Fsc tasks route flags and sources to their own host objects``() = + let makeTask (flag: string) (sourceNames: string list) = + let host = FauxHostObject() + + let task = + Fsc( + BuildEngine = MockEngine(), + OtherFlags = flag, + Sources = [| for name in sourceNames -> TaskItem name :> ITaskItem |], + HostObject = host + ) + + task, host + + let firstTask, firstHost = makeTask "--firstflag" [ "first1.fs"; "first2.fs" ] + let secondTask, secondHost = makeTask "--secondflag" [ "second1.fs" ] + + let run (task: Fsc) release = + task.InternalGenerateResponseFileCommands() |> ignore + release () + Assert.Equal(0, task.InternalExecuteTool("", "", "")) + + runConcurrentlyWithBarrier "concurrent Fsc host objects" [ run firstTask; run secondTask ] + |> ignore + + Assert.Equal([| "first1.fs"; "first2.fs" |], firstHost.Sources) + Assert.Equal([| "second1.fs" |], secondHost.Sources) + + for own, other, host in + [ + "--firstflag", "--secondflag", firstHost + "--secondflag", "--firstflag", secondHost + ] do + Assert.Contains(own, host.Flags) + Assert.DoesNotContain(other, host.Flags) + + [] + [] + [] + member _.``tool-path normalization preserves every path shape``(executable: string) = + withTaskEnvironment (fun environment directory -> + let normalize path = TaskEnvironmentPaths.normalizePathToTool environment path + let relative = Path.Combine("tools", executable) + let absolute = Path.Combine(directory.FullName, relative) + Assert.Equal(absolute, normalize relative) + Assert.Equal(absolute, normalize absolute) + Assert.Equal(executable, normalize executable) + Assert.Null(normalize null) + Assert.Equal("", normalize "") + Assert.Equal(" ", normalize " ") + if RuntimeInformation.IsOSPlatform OSPlatform.Windows then + for input in [ $@"\tools\{executable}"; $@"C:tools\{executable}" ] do + Assert.Equal(environment.GetAbsolutePath(input).Value, normalize input)) + + static member HostCallbackCases = + [ for kind in [ Compiler; Interactive ] do + for exitCode in [ 0; 7 ] do + yield [| box kind; box exitCode |] ] + + [] + [] + member _.``host callbacks execute relative tools in isolated task environments``(kind: CompilerTaskKind, exitCode: int) = + withTaskEnvironmentPairUsing createTaskEnvironmentInTemporaryDirectory (fun environmentA directoryA environmentB directoryB -> + let run (environment: TaskEnvironment) (directory: DirectoryInfo) marker release = + let engine = MockEngine() + let toolPaths = ResizeArray() + let task: ToolTask = + match kind with + | Compiler -> + { new Fsc() with + override _.GenerateCommandLineCommands() = "fsi --exec probe.fsx" + override _.GenerateResponseFileCommands() = "" + override _.GetProcessStartInfo(pathToTool, commands, responseFileSwitch) = + toolPaths.Add pathToTool + base.GetProcessStartInfo(pathToTool, commands, responseFileSwitch) } + | Interactive -> + { new Fsi() with + override _.GenerateCommandLineCommands() = "fsi --exec probe.fsx" + override _.GenerateResponseFileCommands() = "" + override _.GetProcessStartInfo(pathToTool, commands, responseFileSwitch) = + toolPaths.Add pathToTool + base.GetProcessStartInfo(pathToTool, commands, responseFileSwitch) } + + let toolDirectory = Path.GetFullPath(Path.Combine(TestFramework.repoRoot, ".dotnet")) + string Path.DirectorySeparatorChar + let projectDirectory = Uri(directory.FullName + string Path.DirectorySeparatorChar) + task.ToolPath <- projectDirectory.MakeRelativeUri(Uri(toolDirectory)).ToString() |> Uri.UnescapeDataString + task.ToolExe <- if RuntimeInformation.IsOSPlatform OSPlatform.Windows then "dotnet.exe" else "dotnet" + task.BuildEngine <- engine + task.HostObject <- FauxHostObject(executeCompiler = true) + task.Timeout <- 20000 + assignTaskEnvironment environment task |> ignore + environment.SetEnvironmentVariable("FSHARP_MT_CALLBACK", marker) + File.WriteAllText(Path.Combine(directory.FullName, "input.txt"), marker) + File.WriteAllText( + Path.Combine(directory.FullName, "probe.fsx"), + String.concat "\n" [ + "open System" + "open System.IO" + """printfn "CALLBACK=%s|%s" (Environment.GetEnvironmentVariable "FSHARP_MT_CALLBACK") (File.ReadAllText "input.txt")""" + """File.WriteAllText("result.txt", Environment.CurrentDirectory)""" + $"exit {exitCode}" + ]) + Assert.False(Path.IsPathRooted task.ToolPath) + Assert.NotEqual(Environment.CurrentDirectory, directory.FullName) + release () + Assert.Equal((exitCode = 0), task.Execute()) + Assert.Equal(exitCode, task.ExitCode) + Assert.Equal(environment.GetAbsolutePath(Path.Combine(task.ToolPath, task.ToolExe)).Value, Assert.Single(toolPaths)) + Assert.Equal(directory.FullName, File.ReadAllText(Path.Combine(directory.FullName, "result.txt"))) + Assert.Contains(engine.Messages, fun message -> message.Message.Contains($"CALLBACK={marker}|{marker}")) + if exitCode = 0 then Assert.Empty(engine.Errors) + else Assert.Single(engine.Errors) |> ignore + + runConcurrentlyWithBarrier "compiler host callbacks" [ run environmentA directoryA "first"; run environmentB directoryB "second" ] + |> ignore)