From f4bd2211d871ce82c4ea3a6355f63d6a14da4aa8 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 29 Mar 2019 23:55:45 +0000 Subject: [PATCH 01/45] use proto on mac and linux --- .vsts-pr.yaml | 6 ++--- FSharpBuild.Directory.Build.props | 4 +-- FSharpTests.Directory.Build.props | 4 +++ eng/Build.ps1 | 2 +- eng/build-utils.ps1 | 4 --- eng/build.sh | 43 ++++++++++++++++++++++++------- fcs/Directory.Build.props | 6 +---- fcs/build.fsx | 10 ++++--- proto.proj | 2 +- src/buildtools/buildtools.proj | 13 +++++----- 10 files changed, 59 insertions(+), 35 deletions(-) diff --git a/.vsts-pr.yaml b/.vsts-pr.yaml index b7d3862888d..b0186db4e1e 100644 --- a/.vsts-pr.yaml +++ b/.vsts-pr.yaml @@ -11,7 +11,7 @@ jobs: _configuration: Release _testKind: testcoreclr steps: - - script: ./eng/cibuild.sh --configuration $(_configuration) --$(_testKind) + - script: ./eng/cibuild.sh --configuration $(_configuration) --$(_testKind) --verbosity normal - task: PublishBuildArtifacts@1 displayName: Publish Build Logs inputs: @@ -55,7 +55,7 @@ jobs: _configuration: Release _testKind: testcoreclr steps: - - script: ./eng/cibuild.sh --configuration $(_configuration) --$(_testKind) + - script: ./eng/cibuild.sh --configuration $(_configuration) --$(_testKind) --verbosity normal - task: PublishBuildArtifacts@1 displayName: Publish Build Logs inputs: @@ -108,7 +108,7 @@ jobs: _configuration: Release _testKind: testVs steps: - - script: eng\CIBuild.cmd -configuration $(_configuration) -$(_testKind) + - script: eng\CIBuild.cmd -configuration $(_configuration) -$(_testKind) -verbosity normal - task: PublishBuildArtifacts@1 displayName: Publish Build Logs inputs: diff --git a/FSharpBuild.Directory.Build.props b/FSharpBuild.Directory.Build.props index 31d24301299..9d1161037b8 100644 --- a/FSharpBuild.Directory.Build.props +++ b/FSharpBuild.Directory.Build.props @@ -12,7 +12,7 @@ $(RepoRoot)src $(ArtifactsDir)\SymStore $(ArtifactsDir)\Bootstrap - $(ArtifactsDir)/fsc/Proto/netcoreapp2.1 + $(ArtifactsDir)/bin/fsc/Proto/netcoreapp2.1 4.4.0 1182;0025;$(WarningsAsErrors) @@ -80,7 +80,7 @@ - + $(ProtoOutputPath)\Microsoft.FSharp.Targets $(ProtoOutputPath)\Microsoft.FSharp.NetSdk.props $(ProtoOutputPath)\Microsoft.FSharp.NetSdk.targets diff --git a/FSharpTests.Directory.Build.props b/FSharpTests.Directory.Build.props index 6c298fe4426..d62503cea93 100644 --- a/FSharpTests.Directory.Build.props +++ b/FSharpTests.Directory.Build.props @@ -35,6 +35,10 @@ <_FSharpBuildTargetFramework Condition="'$(FSharpTestCompilerVersion)' == 'net40'">net46 <_FSharpBuildTargetFramework Condition="'$(FSharpTestCompilerVersion)' == 'coreclr'">netstandard2.0 <_FSharpBuildBinPath>$(MSBuildThisFileDirectory)artifacts\bin\FSharp.Build\$(Configuration)\$(_FSharpBuildTargetFramework) + $(_FSharpBuildBinPath)\FSharp.Build.dll diff --git a/eng/Build.ps1 b/eng/Build.ps1 index 865cf231575..e93d735e44b 100644 --- a/eng/Build.ps1 +++ b/eng/Build.ps1 @@ -155,10 +155,10 @@ function BuildSolution() { /p:Publish=$publish ` /p:ContinuousIntegrationBuild=$ci ` /p:OfficialBuildId=$officialBuildId ` - /p:BootstrapBuildPath=$bootstrapDir ` /p:QuietRestore=$quietRestore ` /p:QuietRestoreBinaryLog=$binaryLog ` /p:TestTargetFrameworks=$testTargetFrameworks ` + /v:$verbosity ` $suppressExtensionDeployment ` @properties } diff --git a/eng/build-utils.ps1 b/eng/build-utils.ps1 index 304eac5a3e5..26b0c0ad8ab 100644 --- a/eng/build-utils.ps1 +++ b/eng/build-utils.ps1 @@ -216,10 +216,6 @@ function Run-MSBuild([string]$projectFilePath, [string]$buildArgs = "", [string] $args += " /p:ContinuousIntegrationBuild=true" } - if ($bootstrapDir -ne "") { - $args += " /p:BootstrapBuildPath=$bootstrapDir" - } - $args += " $buildArgs" $args += " $projectFilePath" $args += " $properties" diff --git a/eng/build.sh b/eng/build.sh index d814dcd04d4..43803435b56 100755 --- a/eng/build.sh +++ b/eng/build.sh @@ -13,6 +13,7 @@ usage() echo " --binaryLog Create MSBuild binary log (short: -bl)" echo "" echo "Actions:" + echo " --bootstrap Force the build of the bootstrap compiler" echo " --restore Restore projects required to build (short: -r)" echo " --build Build all projects (short: -b)" echo " --rebuild Rebuild all projects" @@ -44,7 +45,7 @@ while [[ -h "$source" ]]; do done scriptroot="$( cd -P "$( dirname "$source" )" && pwd )" -restore=false +restore=true build=false rebuild=false pack=false @@ -54,6 +55,7 @@ test_core_clr=false configuration="Debug" verbosity='minimal' binary_log=false +force_bootstrap=false ci=false skip_analyzers=false prepare_machine=false @@ -88,6 +90,9 @@ while [[ $# > 0 ]]; do --binarylog|-bl) binary_log=true ;; + --bootstrap) + force_bootstrap=true + ;; --restore|-r) restore=true ;; @@ -204,22 +209,42 @@ function BuildSolution { if [[ "$ci" != true ]]; then quiet_restore=true fi + fslexyacc_target_framework=netcoreapp2.0 + + # Node reuse fails because multiple different versions of FSharp.Build.dll get loaded into MSBuild nodes + node_reuse=false # build bootstrap tools bootstrap_config=Proto - MSBuild "$repo_root/src/buildtools/buildtools.proj" \ - /restore \ - /p:Configuration=$bootstrap_config \ - /t:Build - bootstrap_dir=$artifacts_dir/Bootstrap - mkdir -p "$bootstrap_dir" - cp $artifacts_dir/bin/fslex/$bootstrap_config/netcoreapp2.0/* $bootstrap_dir - cp $artifacts_dir/bin/fsyacc/$bootstrap_config/netcoreapp2.0/* $bootstrap_dir + if [[ "$force_bootstrap" == true ]]; then + rm -fr $bootstrap_dir + fi + if [ ! -f "$bootstrap_dir/fslex.dll" ]; then + MSBuild "$repo_root/src/buildtools/buildtools.proj" \ + /restore \ + /v:$verbosity \ + /p:Configuration=$bootstrap_config \ + /t:Build + + mkdir -p "$bootstrap_dir" + cp $artifacts_dir/bin/fslex/$bootstrap_config/$fslexyacc_target_framework/* $bootstrap_dir + cp $artifacts_dir/bin/fsyacc/$bootstrap_config/$fslexyacc_target_framework/* $bootstrap_dir + fi + if [ ! -f "$bootstrap_dir/fsc.exe" ]; then + MSBuild "$repo_root/proto.proj" \ + /restore \ + /v:$verbosity \ + /p:Configuration=$bootstrap_config \ + /t:Build + + cp $artifacts_dir/bin/fsc/$bootstrap_config/netcoreapp2.1/* $bootstrap_dir + fi # do real build MSBuild $toolset_build_proj \ $bl \ + /v:$verbosity \ /p:Configuration=$configuration \ /p:Projects="$projects" \ /p:RepoRoot="$repo_root" \ diff --git a/fcs/Directory.Build.props b/fcs/Directory.Build.props index 3179fe221f9..e09dc41a671 100644 --- a/fcs/Directory.Build.props +++ b/fcs/Directory.Build.props @@ -17,11 +17,7 @@ $(ArtifactsDir)\obj $(ArtifactsBinDir)\fcs $(ArtifactsObjDir)\fcs - true + true - - - $(ArtifactsBinDir)\FSharp.Build\Proto\net46 - diff --git a/fcs/build.fsx b/fcs/build.fsx index d1d575c4f76..d03f9664fe5 100644 --- a/fcs/build.fsx +++ b/fcs/build.fsx @@ -24,6 +24,8 @@ let isMono = false // Utilities // -------------------------------------------------------------------------------------- +let fslexyaccTargetFramework = "netcoreapp2.0" + let dotnetExePath = // Build.cmd normally downloads a dotnet cli to: \artifacts\toolset\dotnet // check if there is one there to avoid downloading an additional one here @@ -92,14 +94,14 @@ Target "BuildVersion" (fun _ -> Target "Build" (fun _ -> runDotnet __SOURCE_DIRECTORY__ "build ../src/buildtools/buildtools.proj -v n -c Proto" - let fslexPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fslex/Proto/netcoreapp2.0/fslex.dll" - let fsyaccPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fsyacc/Proto/netcoreapp2.0/fsyacc.dll" + let fslexPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fslex/Proto/" + fslexyaccTargetFramework + "/fslex.dll" + let fsyaccPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fsyacc/Proto/" + fslexyaccTargetFramework + "/fsyacc.dll" runDotnet __SOURCE_DIRECTORY__ (sprintf "build FSharp.Compiler.Service.sln -v n -c Release /p:FsLexPath=%s /p:FsYaccPath=%s" fslexPath fsyaccPath) ) Target "Test" (fun _ -> - // This project file is used for the netcoreapp2.0 tests to work out reference sets - runDotnet __SOURCE_DIRECTORY__ "build ../tests/projects/Sample_NETCoreSDK_FSharp_Library_netstandard2_0/Sample_NETCoreSDK_FSharp_Library_netstandard2_0.fsproj -v n /restore /p:DisableCompilerRedirection=true" + // This project file is used for the tests to work out reference sets + runDotnet __SOURCE_DIRECTORY__ "build ../tests/projects/Sample_NETCoreSDK_FSharp_Library_netstandard2_0/Sample_NETCoreSDK_FSharp_Library_netstandard2_0.fsproj -v n /restore /p:DisableProtoCompiler=true" // Now run the tests let logFilePath = Path.Combine(__SOURCE_DIRECTORY__, "..", "artifacts", "TestResults", "Release", "FSharp.Compiler.Service.Test.xml") diff --git a/proto.proj b/proto.proj index bbad2c34cc5..b0bff16a289 100644 --- a/proto.proj +++ b/proto.proj @@ -8,7 +8,7 @@ TargetFramework=net46 - TargetFramework=netcoreapp2.1 + TargetFramework=netstandard2.0 TargetFramework=net46 diff --git a/src/buildtools/buildtools.proj b/src/buildtools/buildtools.proj index 593f086dd07..d96cf6a8d8c 100644 --- a/src/buildtools/buildtools.proj +++ b/src/buildtools/buildtools.proj @@ -2,7 +2,8 @@ Debug - + true + @@ -10,23 +11,23 @@ - + - + - + - + - + From 8a4baf313be5834a729b26c843bdcac647e3e100 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 30 Mar 2019 12:21:44 +0000 Subject: [PATCH 02/45] reduce diff --- FSharpBuild.Directory.Build.props | 2 +- fcs/Directory.Build.props | 2 +- fcs/build.fsx | 2 +- src/buildtools/buildtools.proj | 12 ++++++------ 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/FSharpBuild.Directory.Build.props b/FSharpBuild.Directory.Build.props index 9d1161037b8..93b66901c80 100644 --- a/FSharpBuild.Directory.Build.props +++ b/FSharpBuild.Directory.Build.props @@ -80,7 +80,7 @@ - + $(ProtoOutputPath)\Microsoft.FSharp.Targets $(ProtoOutputPath)\Microsoft.FSharp.NetSdk.props $(ProtoOutputPath)\Microsoft.FSharp.NetSdk.targets diff --git a/fcs/Directory.Build.props b/fcs/Directory.Build.props index e09dc41a671..99ac310b2a3 100644 --- a/fcs/Directory.Build.props +++ b/fcs/Directory.Build.props @@ -17,7 +17,7 @@ $(ArtifactsDir)\obj $(ArtifactsBinDir)\fcs $(ArtifactsObjDir)\fcs - true + true diff --git a/fcs/build.fsx b/fcs/build.fsx index d03f9664fe5..39fb3070e74 100644 --- a/fcs/build.fsx +++ b/fcs/build.fsx @@ -101,7 +101,7 @@ Target "Build" (fun _ -> Target "Test" (fun _ -> // This project file is used for the tests to work out reference sets - runDotnet __SOURCE_DIRECTORY__ "build ../tests/projects/Sample_NETCoreSDK_FSharp_Library_netstandard2_0/Sample_NETCoreSDK_FSharp_Library_netstandard2_0.fsproj -v n /restore /p:DisableProtoCompiler=true" + runDotnet __SOURCE_DIRECTORY__ "build ../tests/projects/Sample_NETCoreSDK_FSharp_Library_netstandard2_0/Sample_NETCoreSDK_FSharp_Library_netstandard2_0.fsproj -v n /restore /p:DisableCompilerRedirection=true" // Now run the tests let logFilePath = Path.Combine(__SOURCE_DIRECTORY__, "..", "artifacts", "TestResults", "Release", "FSharp.Compiler.Service.Test.xml") diff --git a/src/buildtools/buildtools.proj b/src/buildtools/buildtools.proj index d96cf6a8d8c..630bb678561 100644 --- a/src/buildtools/buildtools.proj +++ b/src/buildtools/buildtools.proj @@ -2,7 +2,7 @@ Debug - true + true @@ -11,23 +11,23 @@ - + - + - + - + - + From 0474a23faf73ef71fc4ddb2313613dc480d9a3e0 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 30 Mar 2019 12:24:30 +0000 Subject: [PATCH 03/45] reduce diff --- fcs/Directory.Build.props | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/fcs/Directory.Build.props b/fcs/Directory.Build.props index 99ac310b2a3..3179fe221f9 100644 --- a/fcs/Directory.Build.props +++ b/fcs/Directory.Build.props @@ -20,4 +20,8 @@ true + + + $(ArtifactsBinDir)\FSharp.Build\Proto\net46 + From b96120e417c7131ac93fb46305a6770f5d5d2d75 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 30 Mar 2019 12:25:25 +0000 Subject: [PATCH 04/45] reduce diff --- fcs/build.fsx | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/fcs/build.fsx b/fcs/build.fsx index 39fb3070e74..dd5d3c64fc1 100644 --- a/fcs/build.fsx +++ b/fcs/build.fsx @@ -24,8 +24,6 @@ let isMono = false // Utilities // -------------------------------------------------------------------------------------- -let fslexyaccTargetFramework = "netcoreapp2.0" - let dotnetExePath = // Build.cmd normally downloads a dotnet cli to: \artifacts\toolset\dotnet // check if there is one there to avoid downloading an additional one here @@ -94,8 +92,8 @@ Target "BuildVersion" (fun _ -> Target "Build" (fun _ -> runDotnet __SOURCE_DIRECTORY__ "build ../src/buildtools/buildtools.proj -v n -c Proto" - let fslexPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fslex/Proto/" + fslexyaccTargetFramework + "/fslex.dll" - let fsyaccPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fsyacc/Proto/" + fslexyaccTargetFramework + "/fsyacc.dll" + let fslexPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fslex/Proto/netcoreapp2.0/fslex.dll" + let fsyaccPath = __SOURCE_DIRECTORY__ + "/../artifacts/bin/fsyacc/Proto/netcoreapp2.0/fsyacc.dll" runDotnet __SOURCE_DIRECTORY__ (sprintf "build FSharp.Compiler.Service.sln -v n -c Release /p:FsLexPath=%s /p:FsYaccPath=%s" fslexPath fsyaccPath) ) From cf9147bd2dd42febdea9e37082ff46fa34f0ed64 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 30 Mar 2019 12:26:18 +0000 Subject: [PATCH 05/45] reduce diff --- FSharpTests.Directory.Build.props | 4 ---- 1 file changed, 4 deletions(-) diff --git a/FSharpTests.Directory.Build.props b/FSharpTests.Directory.Build.props index d62503cea93..6c298fe4426 100644 --- a/FSharpTests.Directory.Build.props +++ b/FSharpTests.Directory.Build.props @@ -35,10 +35,6 @@ <_FSharpBuildTargetFramework Condition="'$(FSharpTestCompilerVersion)' == 'net40'">net46 <_FSharpBuildTargetFramework Condition="'$(FSharpTestCompilerVersion)' == 'coreclr'">netstandard2.0 <_FSharpBuildBinPath>$(MSBuildThisFileDirectory)artifacts\bin\FSharp.Build\$(Configuration)\$(_FSharpBuildTargetFramework) - $(_FSharpBuildBinPath)\FSharp.Build.dll From 286c336d7b0fe6e783edd42c2d02ac99cae083d9 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 30 Mar 2019 12:26:48 +0000 Subject: [PATCH 06/45] reduce diff --- fcs/build.fsx | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fcs/build.fsx b/fcs/build.fsx index dd5d3c64fc1..d1d575c4f76 100644 --- a/fcs/build.fsx +++ b/fcs/build.fsx @@ -98,7 +98,7 @@ Target "Build" (fun _ -> ) Target "Test" (fun _ -> - // This project file is used for the tests to work out reference sets + // This project file is used for the netcoreapp2.0 tests to work out reference sets runDotnet __SOURCE_DIRECTORY__ "build ../tests/projects/Sample_NETCoreSDK_FSharp_Library_netstandard2_0/Sample_NETCoreSDK_FSharp_Library_netstandard2_0.fsproj -v n /restore /p:DisableCompilerRedirection=true" // Now run the tests From 7a6448eda01bfe982c942b707c1110ac4a767d20 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sat, 30 Mar 2019 13:00:00 +0000 Subject: [PATCH 07/45] reduce diff --- FSharpBuild.Directory.Build.props | 2 +- eng/Build.ps1 | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/FSharpBuild.Directory.Build.props b/FSharpBuild.Directory.Build.props index 93b66901c80..1d456ec2d72 100644 --- a/FSharpBuild.Directory.Build.props +++ b/FSharpBuild.Directory.Build.props @@ -80,7 +80,7 @@ - + $(ProtoOutputPath)\Microsoft.FSharp.Targets $(ProtoOutputPath)\Microsoft.FSharp.NetSdk.props $(ProtoOutputPath)\Microsoft.FSharp.NetSdk.targets diff --git a/eng/Build.ps1 b/eng/Build.ps1 index e93d735e44b..0acdb67cdb7 100644 --- a/eng/Build.ps1 +++ b/eng/Build.ps1 @@ -99,6 +99,7 @@ function Process-Arguments() { Print-Usage exit 0 } + $script:nodeReuse = $False; if ($testAll) { $script:testDesktop = $True From aed6752ecc08695a95f50ef87286ae0f27d01a41 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sun, 14 Apr 2019 18:15:55 +0100 Subject: [PATCH 08/45] fix build --- .vsts-pr.yaml | 4 ++-- eng/build.sh | 3 ++- proto.proj | 2 +- src/fsharp/FSharp.Build/FSharp.Build.fsproj | 4 ++-- 4 files changed, 7 insertions(+), 6 deletions(-) diff --git a/.vsts-pr.yaml b/.vsts-pr.yaml index d33bdae439e..57446ed1e85 100644 --- a/.vsts-pr.yaml +++ b/.vsts-pr.yaml @@ -11,7 +11,7 @@ jobs: _configuration: Release _testKind: testcoreclr steps: - - script: ./eng/cibuild.sh --configuration $(_configuration) --$(_testKind) --verbosity normal + - script: ./eng/cibuild.sh --configuration $(_configuration) --$(_testKind) - task: PublishBuildArtifacts@1 displayName: Publish Build Logs inputs: @@ -55,7 +55,7 @@ jobs: _configuration: Release _testKind: testcoreclr steps: - - script: ./eng/cibuild.sh --configuration $(_configuration) --$(_testKind) --verbosity normal + - script: ./eng/cibuild.sh --configuration $(_configuration) --$(_testKind) - task: PublishBuildArtifacts@1 displayName: Publish Build Logs inputs: diff --git a/eng/build.sh b/eng/build.sh index b874fb842d6..ea44f9e9237 100755 --- a/eng/build.sh +++ b/eng/build.sh @@ -15,6 +15,7 @@ usage() echo "Actions:" echo " --bootstrap Force the build of the bootstrap compiler" echo " --restore Restore projects required to build (short: -r)" + echo " --norestore Don't restore projects required to build (short: -r)" echo " --build Build all projects (short: -b)" echo " --rebuild Rebuild all projects" echo " --pack Build nuget packages" @@ -45,7 +46,7 @@ while [[ -h "$source" ]]; do done scriptroot="$( cd -P "$( dirname "$source" )" && pwd )" -restore=true +restore=false build=false rebuild=false pack=false diff --git a/proto.proj b/proto.proj index e6f7a4f8cc0..84103f6fdf8 100644 --- a/proto.proj +++ b/proto.proj @@ -8,7 +8,7 @@ TargetFramework=net472 - TargetFramework=netstandard2.0 + TargetFramework=netcoreapp2.1 TargetFramework=net472 diff --git a/src/fsharp/FSharp.Build/FSharp.Build.fsproj b/src/fsharp/FSharp.Build/FSharp.Build.fsproj index f5f297bda75..0dad55058b0 100644 --- a/src/fsharp/FSharp.Build/FSharp.Build.fsproj +++ b/src/fsharp/FSharp.Build/FSharp.Build.fsproj @@ -4,8 +4,8 @@ Library - net472;netstandard2.0 - netstandard2.0 + net472;netcoreapp2.1 + netcoreapp2.1 FSharp.Build $(NoWarn);45;55;62;75;1204 true From bb78e5f53dbbf6addf82829cfad9f5614b36fb06 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sun, 14 Apr 2019 18:18:27 +0100 Subject: [PATCH 09/45] fix build --- .vsts-pr.yaml | 2 +- eng/Build.ps1 | 1 + eng/build.sh | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) diff --git a/.vsts-pr.yaml b/.vsts-pr.yaml index 57446ed1e85..eeebe57d085 100644 --- a/.vsts-pr.yaml +++ b/.vsts-pr.yaml @@ -108,7 +108,7 @@ jobs: _configuration: Release _testKind: testVs steps: - - script: eng\CIBuild.cmd -configuration $(_configuration) -$(_testKind) -verbosity normal + - script: eng\CIBuild.cmd -configuration $(_configuration) -$(_testKind) - task: PublishBuildArtifacts@1 displayName: Publish Build Logs inputs: diff --git a/eng/Build.ps1 b/eng/Build.ps1 index 352fd9e0583..993adc1d1e9 100644 --- a/eng/Build.ps1 +++ b/eng/Build.ps1 @@ -65,6 +65,7 @@ function Print-Usage() { Write-Host "" Write-Host "Actions:" Write-Host " -restore Restore packages (short: -r)" + Write-Host " -norestore Don't restore packages" Write-Host " -build Build main solution (short: -b)" Write-Host " -rebuild Rebuild main solution" Write-Host " -pack Build NuGet packages, VS insertion manifests and installer" diff --git a/eng/build.sh b/eng/build.sh index ea44f9e9237..6b0ddf324b3 100755 --- a/eng/build.sh +++ b/eng/build.sh @@ -15,7 +15,7 @@ usage() echo "Actions:" echo " --bootstrap Force the build of the bootstrap compiler" echo " --restore Restore projects required to build (short: -r)" - echo " --norestore Don't restore projects required to build (short: -r)" + echo " --norestore Don't restore projects required to build" echo " --build Build all projects (short: -b)" echo " --rebuild Rebuild all projects" echo " --pack Build nuget packages" From 1aa6a410178ba7f250372dfe170a1958b886ee27 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 15 Apr 2019 22:34:31 +0100 Subject: [PATCH 10/45] load right FSHarp.Build --- FSharpTests.Directory.Build.props | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/FSharpTests.Directory.Build.props b/FSharpTests.Directory.Build.props index 7c00805dda5..8a7a832a43e 100644 --- a/FSharpTests.Directory.Build.props +++ b/FSharpTests.Directory.Build.props @@ -32,9 +32,9 @@ - <_FSharpBuildTargetFramework Condition="'$(FSharpTestCompilerVersion)' == 'net40'">net472 - <_FSharpBuildTargetFramework Condition="'$(FSharpTestCompilerVersion)' == 'coreclr'">netcoreapp2.1 - <_FSharpBuildBinPath>$(MSBuildThisFileDirectory)artifacts\bin\FSharp.Build\$(Configuration)\$(_FSharpBuildTargetFramework) + <_FSharpBuildTargetFramework Condition="'$(MSBuildRuntimeType)'!='Core'">net472 + <_FSharpBuildTargetFramework Condition="'$(MSBuildRuntimeType)'=='Core'">netcoreapp2.1 + <_FSharpBuildBinPath>$(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\$(_FSharpBuildTargetFramework) $(_FSharpBuildBinPath)\FSharp.Build.dll From 058bdc9a5a5ab6d9906c80618ae6486dc739434a Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 15 Apr 2019 23:01:00 +0100 Subject: [PATCH 11/45] publish proto apps --- FSharpBuild.Directory.Build.props | 11 +++++------ FSharpTests.Directory.Build.props | 10 +++++----- eng/Build.ps1 | 2 +- eng/build-utils.ps1 | 12 ++++++------ eng/build.sh | 10 +++++----- fcs/Directory.Build.props | 5 ----- proto.proj | 4 ++++ src/buildtools/buildtools.targets | 4 ++-- 8 files changed, 28 insertions(+), 30 deletions(-) diff --git a/FSharpBuild.Directory.Build.props b/FSharpBuild.Directory.Build.props index 905ea66544f..515de9bbdc7 100644 --- a/FSharpBuild.Directory.Build.props +++ b/FSharpBuild.Directory.Build.props @@ -11,8 +11,7 @@ $(RepoRoot)src $(ArtifactsDir)\SymStore - $(ArtifactsDir)\Bootstrap - $(ArtifactsDir)/bin/fsc/Proto/netcoreapp2.1 + $(ArtifactsDir)\Bootstrap 4.4.0 1182;0025;$(WarningsAsErrors) @@ -96,10 +95,10 @@ - $(ProtoOutputPath)\Microsoft.FSharp.Targets - $(ProtoOutputPath)\Microsoft.FSharp.NetSdk.props - $(ProtoOutputPath)\Microsoft.FSharp.NetSdk.targets - $(ProtoOutputPath)\Microsoft.FSharp.Overrides.NetSdk.targets + $(ProtoOutputPath)\fsc\Microsoft.FSharp.Targets + $(ProtoOutputPath)\fsc\Microsoft.FSharp.NetSdk.props + $(ProtoOutputPath)\fsc\Microsoft.FSharp.NetSdk.targets + $(ProtoOutputPath)\fsc\Microsoft.FSharp.Overrides.NetSdk.targets diff --git a/FSharpTests.Directory.Build.props b/FSharpTests.Directory.Build.props index 8a7a832a43e..9ad765f036d 100644 --- a/FSharpTests.Directory.Build.props +++ b/FSharpTests.Directory.Build.props @@ -7,11 +7,11 @@ true - $(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\net472 + $(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\net472\publish fsc.exe - $(MSBuildThisFileDirectory)artifacts\bin\fsi\$(Configuration)\net472 + $(MSBuildThisFileDirectory)artifacts\bin\fsi\$(Configuration)\net472\publish fsi.exe @@ -22,19 +22,19 @@ $([System.IO.Path]::GetDirectoryName('$(DOTNET_HOST_PATH)')) dotnet.exe dotnet - $(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\netcoreapp2.1\fsc.exe + $(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\netcoreapp2.1\publish\fsc.exe $([System.IO.Path]::GetDirectoryName('$(DOTNET_HOST_PATH)')) dotnet.exe dotnet - $(MSBuildThisFileDirectory)artifacts\bin\fsi\$(Configuration)\netcoreapp2.1\fsi.exe + $(MSBuildThisFileDirectory)artifacts\bin\fsi\$(Configuration)\netcoreapp2.1\publish\fsi.exe <_FSharpBuildTargetFramework Condition="'$(MSBuildRuntimeType)'!='Core'">net472 <_FSharpBuildTargetFramework Condition="'$(MSBuildRuntimeType)'=='Core'">netcoreapp2.1 - <_FSharpBuildBinPath>$(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\$(_FSharpBuildTargetFramework) + <_FSharpBuildBinPath>$(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\$(_FSharpBuildTargetFramework)\publish $(_FSharpBuildBinPath)\FSharp.Build.dll diff --git a/eng/Build.ps1 b/eng/Build.ps1 index 993adc1d1e9..30ef852db76 100644 --- a/eng/Build.ps1 +++ b/eng/Build.ps1 @@ -196,7 +196,7 @@ function UpdatePath() { } function VerifyAssemblyVersions() { - $fsiPath = Join-Path $ArtifactsDir "bin\fsi\Proto\net472\fsi.exe" + $fsiPath = Join-Path $ArtifactsDir "bin\fsi\Proto\net472\publish\fsi.exe" # Only verify versions on CI or official build if ($ci -or $official) { diff --git a/eng/build-utils.ps1 b/eng/build-utils.ps1 index 9c626f7c8f3..c16e31ebfc2 100644 --- a/eng/build-utils.ps1 +++ b/eng/build-utils.ps1 @@ -237,15 +237,15 @@ function Make-BootstrapBuild() { Create-Directory $dir # prepare FsLex and Fsyacc - Run-MSBuild "$RepoRoot\src\buildtools\buildtools.proj" "/restore /t:Build" -logFileName "BuildTools" -configuration $bootstrapConfiguration - Copy-Item "$ArtifactsDir\bin\fslex\$bootstrapConfiguration\netcoreapp2.1\*" -Destination $dir - Copy-Item "$ArtifactsDir\bin\fsyacc\$bootstrapConfiguration\netcoreapp2.1\*" -Destination $dir + Run-MSBuild "$RepoRoot\src\buildtools\buildtools.proj" "/restore /t:Publish" -logFileName "BuildTools" -configuration $bootstrapConfiguration + Copy-Item "$ArtifactsDir\bin\fslex\$bootstrapConfiguration\netcoreapp2.1\publish" -Destination "$dir\fslex" -Force -Recurse + Copy-Item "$ArtifactsDir\bin\fsyacc\$bootstrapConfiguration\netcoreapp2.1\publish" -Destination "$dir\fsyacc" -Force -Recurse # prepare compiler $projectPath = "$RepoRoot\proto.proj" - Run-MSBuild $projectPath "/restore /t:Build" -logFileName "Bootstrap" -configuration $bootstrapConfiguration - Copy-Item "$ArtifactsDir\bin\fsc\$bootstrapConfiguration\$bootstrapTfm\*" -Destination $dir - Copy-Item "$ArtifactsDir\bin\fsi\$bootstrapConfiguration\$bootstrapTfm\*" -Destination $dir + Run-MSBuild $projectPath "/restore /t:Publish" -logFileName "Bootstrap" -configuration $bootstrapConfiguration + Copy-Item "$ArtifactsDir\bin\fsc\$bootstrapConfiguration\$bootstrapTfm\publish" -Destination "$dir\fsc" -Force -Recurse + Copy-Item "$ArtifactsDir\bin\fsi\$bootstrapConfiguration\$bootstrapTfm\publish" -Destination "$dir\fsi" -Force -Recurse return $dir } diff --git a/eng/build.sh b/eng/build.sh index 6b0ddf324b3..8a236373f37 100755 --- a/eng/build.sh +++ b/eng/build.sh @@ -225,20 +225,20 @@ function BuildSolution { /restore \ /v:$verbosity \ /p:Configuration=$bootstrap_config \ - /t:Build + /t:Publish mkdir -p "$bootstrap_dir" - cp $artifacts_dir/bin/fslex/$bootstrap_config/netcoreapp2.1/* $bootstrap_dir - cp $artifacts_dir/bin/fsyacc/$bootstrap_config/netcoreapp2.1/* $bootstrap_dir + cp -pr $artifacts_dir/bin/fslex/$bootstrap_config/netcoreapp2.1/publish $bootstrap_dir/fslex + cp -pr $artifacts_dir/bin/fsyacc/$bootstrap_config/netcoreapp2.1/publish $bootstrap_dir/fsyacc fi if [ ! -f "$bootstrap_dir/fsc.exe" ]; then MSBuild "$repo_root/proto.proj" \ /restore \ /v:$verbosity \ /p:Configuration=$bootstrap_config \ - /t:Build + /t:Publish - cp $artifacts_dir/bin/fsc/$bootstrap_config/netcoreapp2.1/* $bootstrap_dir + cp -pr $artifacts_dir/bin/fsc/$bootstrap_config/netcoreapp2.1/publish $bootstrap_dir/fsc fi # do real build diff --git a/fcs/Directory.Build.props b/fcs/Directory.Build.props index 596b06c0716..4c8aac0a5b6 100644 --- a/fcs/Directory.Build.props +++ b/fcs/Directory.Build.props @@ -20,9 +20,4 @@ $(ArtifactsObjDir)\fcs true - - - - $(ArtifactsBinDir)\FSharp.Build\Proto\net472 - diff --git a/proto.proj b/proto.proj index 84103f6fdf8..b0ee288977f 100644 --- a/proto.proj +++ b/proto.proj @@ -28,6 +28,10 @@ + + + + diff --git a/src/buildtools/buildtools.targets b/src/buildtools/buildtools.targets index 303ab00825d..185fd4d0599 100644 --- a/src/buildtools/buildtools.targets +++ b/src/buildtools/buildtools.targets @@ -20,7 +20,7 @@ BeforeTargets="CoreCompile"> - $(ArtifactsDir)\Bootstrap\fslex.dll + $(ArtifactsDir)\Bootstrap\fslex\fslex.dll @@ -43,7 +43,7 @@ BeforeTargets="CoreCompile"> - $(ArtifactsDir)\Bootstrap\fsyacc.dll + $(ArtifactsDir)\Bootstrap\fsyacc\fsyacc.dll From 688850f47922d2b9134331d7d4d3c2cf5a04a7e7 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 16 Apr 2019 00:13:17 +0100 Subject: [PATCH 12/45] revert test env changes --- FSharpTests.Directory.Build.props | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/FSharpTests.Directory.Build.props b/FSharpTests.Directory.Build.props index 9ad765f036d..7b9242dc0db 100644 --- a/FSharpTests.Directory.Build.props +++ b/FSharpTests.Directory.Build.props @@ -22,19 +22,19 @@ $([System.IO.Path]::GetDirectoryName('$(DOTNET_HOST_PATH)')) dotnet.exe dotnet - $(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\netcoreapp2.1\publish\fsc.exe + $(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\netcoreapp2.1\fsc.exe $([System.IO.Path]::GetDirectoryName('$(DOTNET_HOST_PATH)')) dotnet.exe dotnet - $(MSBuildThisFileDirectory)artifacts\bin\fsi\$(Configuration)\netcoreapp2.1\publish\fsi.exe + $(MSBuildThisFileDirectory)artifacts\bin\fsi\$(Configuration)\netcoreapp2.1\fsi.exe <_FSharpBuildTargetFramework Condition="'$(MSBuildRuntimeType)'!='Core'">net472 <_FSharpBuildTargetFramework Condition="'$(MSBuildRuntimeType)'=='Core'">netcoreapp2.1 - <_FSharpBuildBinPath>$(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\$(_FSharpBuildTargetFramework)\publish + <_FSharpBuildBinPath>$(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\$(_FSharpBuildTargetFramework) $(_FSharpBuildBinPath)\FSharp.Build.dll From c2c7213ed66f7d415db2c1a53249a325b74986bf Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 16 Apr 2019 01:27:25 +0100 Subject: [PATCH 13/45] revert testing changes --- FSharpTests.Directory.Build.props | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/FSharpTests.Directory.Build.props b/FSharpTests.Directory.Build.props index 7b9242dc0db..8a7a832a43e 100644 --- a/FSharpTests.Directory.Build.props +++ b/FSharpTests.Directory.Build.props @@ -7,11 +7,11 @@ true - $(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\net472\publish + $(MSBuildThisFileDirectory)artifacts\bin\fsc\$(Configuration)\net472 fsc.exe - $(MSBuildThisFileDirectory)artifacts\bin\fsi\$(Configuration)\net472\publish + $(MSBuildThisFileDirectory)artifacts\bin\fsi\$(Configuration)\net472 fsi.exe From e46dcd5681fdcf52b889c145799dc96a668613ee Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 16 Apr 2019 15:19:09 +0100 Subject: [PATCH 14/45] don't repeat bootstrap --- eng/Build.ps1 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/eng/Build.ps1 b/eng/Build.ps1 index 30ef852db76..04bee5a40d8 100644 --- a/eng/Build.ps1 +++ b/eng/Build.ps1 @@ -128,7 +128,7 @@ function Process-Arguments() { } function Update-Arguments() { - if (-Not (Test-Path "$ArtifactsDir\Bootstrap\fsc.exe")) { + if (-Not (Test-Path "$ArtifactsDir\Bootstrap\fsc\fsc.exe")) { $script:bootstrap = $True } } From 75e9cc3f7baa083aa3717a0a54bfa61ce0671bfc Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 17 Apr 2019 13:23:04 +0100 Subject: [PATCH 15/45] be systematic about verbosity --- eng/build-utils.ps1 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/eng/build-utils.ps1 b/eng/build-utils.ps1 index c16e31ebfc2..f85a9007296 100644 --- a/eng/build-utils.ps1 +++ b/eng/build-utils.ps1 @@ -178,7 +178,7 @@ function Get-PackageDir([string]$name, [string]$version = "") { return $p } -function Run-MSBuild([string]$projectFilePath, [string]$buildArgs = "", [string]$logFileName = "", [switch]$parallel = $true, [switch]$summary = $true, [switch]$warnAsError = $true, [string]$configuration = $script:configuration) { +function Run-MSBuild([string]$projectFilePath, [string]$buildArgs = "", [string]$logFileName = "", [switch]$parallel = $true, [switch]$summary = $true, [switch]$warnAsError = $true, [string]$configuration = $script:configuration, [string]$verbosity = $script:verbosity) { # Because we override the C#/VB toolset to build against our LKG package, it is important # that we do not reuse MSBuild nodes from other jobs/builds on the machine. Otherwise, # we'll run into issues such as https://github.com/dotnet/roslyn/issues/6211. @@ -190,9 +190,9 @@ function Run-MSBuild([string]$projectFilePath, [string]$buildArgs = "", [string] } if ($summary) { - $args += " /consoleloggerparameters:Verbosity=minimal;summary" + $args += " /consoleloggerparameters:Verbosity=$verbosity;summary" } else { - $args += " /consoleloggerparameters:Verbosity=minimal" + $args += " /consoleloggerparameters:Verbosity=$verbosity" } if ($parallel) { @@ -237,13 +237,13 @@ function Make-BootstrapBuild() { Create-Directory $dir # prepare FsLex and Fsyacc - Run-MSBuild "$RepoRoot\src\buildtools\buildtools.proj" "/restore /t:Publish" -logFileName "BuildTools" -configuration $bootstrapConfiguration + Run-MSBuild "$RepoRoot\src\buildtools\buildtools.proj" "/restore /t:Publish" -logFileName "BuildTools" -configuration $bootstrapConfiguration -verbosity $verbosity Copy-Item "$ArtifactsDir\bin\fslex\$bootstrapConfiguration\netcoreapp2.1\publish" -Destination "$dir\fslex" -Force -Recurse Copy-Item "$ArtifactsDir\bin\fsyacc\$bootstrapConfiguration\netcoreapp2.1\publish" -Destination "$dir\fsyacc" -Force -Recurse # prepare compiler $projectPath = "$RepoRoot\proto.proj" - Run-MSBuild $projectPath "/restore /t:Publish" -logFileName "Bootstrap" -configuration $bootstrapConfiguration + Run-MSBuild $projectPath "/restore /t:Publish" -logFileName "Bootstrap" -configuration $bootstrapConfiguration -verbosity $verbosity Copy-Item "$ArtifactsDir\bin\fsc\$bootstrapConfiguration\$bootstrapTfm\publish" -Destination "$dir\fsc" -Force -Recurse Copy-Item "$ArtifactsDir\bin\fsi\$bootstrapConfiguration\$bootstrapTfm\publish" -Destination "$dir\fsi" -Force -Recurse From 7b012b624f6b7bb67ab4641729b37b85e544d61d Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 24 Apr 2019 19:39:39 +0100 Subject: [PATCH 16/45] task builder insertion attempt --- src/fsharp/FSharp.Core/FSharp.Core.fsproj | 8 +- src/fsharp/FSharp.Core/tasks.fs | 307 ++++++++++++++++++++++ src/fsharp/FSharp.Core/tasks.fsi | 142 ++++++++++ 3 files changed, 456 insertions(+), 1 deletion(-) create mode 100644 src/fsharp/FSharp.Core/tasks.fs create mode 100644 src/fsharp/FSharp.Core/tasks.fsi diff --git a/src/fsharp/FSharp.Core/FSharp.Core.fsproj b/src/fsharp/FSharp.Core/FSharp.Core.fsproj index 440850ed55c..ead8bfcca18 100644 --- a/src/fsharp/FSharp.Core/FSharp.Core.fsproj +++ b/src/fsharp/FSharp.Core/FSharp.Core.fsproj @@ -1,4 +1,4 @@ - + @@ -170,6 +170,12 @@ Control/async.fs + + Control/tasks.fsi + + + Control/tasks.fs + Control/eventmodule.fsi diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs new file mode 100644 index 00000000000..0e9d7ba432a --- /dev/null +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -0,0 +1,307 @@ +// TaskBuilder.fs - TPL task computation expressions for F# +// +// Originally written in 2016 by Robert Peele (humbobst@gmail.com) +// New operator-based overload resolution for F# 4.0 compatibility by Gustavo Leon in 2018. +// Revised for insertion into FSHarp.Core by Microsoft, 2019. +// +// To the extent possible under law, the author(s) have dedicated all copyright and related and neighboring rights +// to this software to the public domain worldwide. This software is distributed without any warranty. + +namespace Mirosoft.FSharp.Control + +open System +open System.Runtime.CompilerServices +open System.Threading.Tasks +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators +open Microsoft.FSharp.Control +open Microsoft.FSharp.Collections + +[] +/// Represents the state of a computation: either awaiting something with a continuation, or completed with a return value. +type TaskStep<'T> = + | Await of ICriticalNotifyCompletion * (unit -> TaskStep<'T>) + | Return of 'T + | ReturnFrom of Task<'T> + +[] +module TaskHelpers = + + /// Implements the machinery of running a `TaskStep<'m, 'm>` as a task returning a continuation task. + type StepStateMachine<'T>(firstStep) as this = + let methodBuilder = AsyncTaskMethodBuilder>() + + /// The continuation we left off awaiting on our last MoveNext(). + let mutable continuation = fun () -> firstStep + + /// Returns next pending awaitable or null if exiting (including tail call). + let nextAwaitable() = + try + match continuation() with + | Return r -> + methodBuilder.SetResult(Task.FromResult(r)) + null + | ReturnFrom t -> + methodBuilder.SetResult(t) + null + | Await (await, next) -> + continuation <- next + await + with + | exn -> + methodBuilder.SetException(exn) + null + + let mutable self = this + + /// Start execution as a `Task>`. + member __.Run() = + methodBuilder.Start(&self) + methodBuilder.Task + + interface IAsyncStateMachine with + + /// Proceed to one of three states: result, failure, or awaiting. + /// If awaiting, MoveNext() will be called again when the awaitable completes. + member __.MoveNext() = + let mutable await = nextAwaitable() + if not (isNull await) then + // Tell the builder to call us again when this thing is done. + methodBuilder.AwaitUnsafeOnCompleted(&await, &self) + + member __.SetStateMachine(_) = () // Doesn'T really apply since we're a reference type. + + let unwrapException (agg : AggregateException) = + let inners = agg.InnerExceptions + if inners.Count = 1 then inners.[0] + else agg :> Exception + + /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. + let zero = Return () + + /// Used to return a value. + let ret (x : 'T) = Return x + + [] + type Binder<'T> = + // We put the output generic parameter up here at the class level, so it doesn'T get subject to + // inline rules. If we put it all in the inline function, then the compiler gets confused at the + // below and demands that the whole function either is limited to working with (x : obj), or must + // be inline itself. + // + // let yieldThenReturn (x : 'T) = + // task { + // do! Task.Yield() + // return x + // } + + static member inline GenericAwait< ^Awaitable, ^Awaiter, ^TResult + when ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter : (member get_IsCompleted : unit -> bool) + and ^Awaiter : (member GetResult : unit -> ^TResult) > + (abl : ^Awaitable, continuation : ^TResult -> TaskStep<'T>) : TaskStep<'T> = + let awaiter = (^Awaitable : (member GetAwaiter : unit -> ^Awaiter)(abl)) // get an awaiter from the awaitable + if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately + continuation (^Awaiter : (member GetResult : unit -> ^TResult)(awaiter)) + else + Await (awaiter, fun () -> continuation (^Awaiter : (member GetResult : unit -> ^TResult)(awaiter))) + + static member inline GenericAwaitConfigureFalse< ^Task, ^Awaitable, ^Awaiter, ^TResult + when ^Task : (member ConfigureAwait : bool -> ^Awaitable) + and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter : (member get_IsCompleted : unit -> bool) + and ^Awaiter : (member GetResult : unit -> ^TResult) > + (task : ^Task, continuation : ^TResult -> TaskStep<'T>) : TaskStep<'T> = + let abl = (^Task : (member ConfigureAwait : bool -> ^Awaitable)(task, false)) + Binder<'T>.GenericAwait(abl, continuation) + + /// Special case of the above for `Task<'T>`. Have to write this T by hand to avoid confusing the compiler + /// trying to decide between satisfying the constraints with `Task` or `Task<'T>`. + let bindTask (task : Task<'T>) (continuation : 'T -> TaskStep<'TResult>) = + let awaiter = task.GetAwaiter() + if awaiter.IsCompleted then // Proceed to the next step based on the result we already have. + continuation(awaiter.GetResult()) + else // Await and continue later when a result is available. + Await (awaiter, (fun () -> continuation(awaiter.GetResult()))) + + /// Special case of the above for `Task<'T>`, for the context-insensitive builder. + /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method + /// defined on the builder has fancy generic constraints on inp and T parameters. + let bindTaskConfigureFalse (task : Task<'T>) (continuation : 'T -> TaskStep<'TResult>) = + let awaiter = task.ConfigureAwait(false).GetAwaiter() + if awaiter.IsCompleted then // Proceed to the next step based on the result we already have. + continuation(awaiter.GetResult()) + else // Await and continue later when a result is available. + Await (awaiter, (fun () -> continuation(awaiter.GetResult()))) + + /// Chains together a step with its following step. + /// Note that this requires that the first step has no result. + /// This prevents constructs like `task { return 1; return 2; }`. + let rec combine (step : TaskStep) (continuation : unit -> TaskStep<'TResult>) = + match step with + | Return _ -> continuation() + | ReturnFrom t -> + Await (t.GetAwaiter(), continuation) + | Await (awaitable, next) -> + Await (awaitable, fun () -> combine (next()) continuation) + + /// Builds a step that executes the body while the condition predicate is true. + let whileLoop (cond : unit -> bool) (body : unit -> TaskStep) = + if cond() then + // Create a self-referencing closure to test whether to repeat the loop on future iterations. + let rec repeat () = + if cond() then + let body = body() + match body with + | Return _ -> repeat() + | ReturnFrom t -> Await(t.GetAwaiter(), repeat) + | Await (awaitable, next) -> + Await (awaitable, fun () -> combine (next()) repeat) + else zero + // Run the body the first time and chain it to the repeat logic. + combine (body()) repeat + else zero + + /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function + /// to retrieve the step, and in the continuation of the step (if any). + let rec tryWith(step : unit -> TaskStep<'T>) (catch : exn -> TaskStep<'T>) = + try + match step() with + | Return _ as i -> i + | ReturnFrom t -> + let awaitable = t.GetAwaiter() + Await(awaitable, fun () -> + try + awaitable.GetResult() |> Return + with + | exn -> catch exn) + | Await (awaitable, next) -> Await (awaitable, fun () -> tryWith next catch) + with + | exn -> catch exn + + /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function + /// to retrieve the step, and in the continuation of the step (if any). + let rec tryFinally (step : unit -> TaskStep<'T>) fin = + let step = + try step() + // Important point: we use a try/with, not a try/finally, to implement tryFinally. + // The reason for this is that if we're just building a continuation, we definitely *shouldn'T* + // execute the `fin()` part yet -- the actual execution of the asynchronous code hasn'T completed! + with + | _ -> + fin() + reraise() + match step with + | Return _ as i -> + fin() + i + | ReturnFrom t -> + let awaitable = t.GetAwaiter() + Await(awaitable, fun () -> + let result = + try + awaitable.GetResult() |> Return + with + | _ -> + fin() + reraise() + fin() // if we got here we haven'T run fin(), because we would've reraised after doing so + result) + | Await (awaitable, next) -> + Await (awaitable, fun () -> tryFinally next fin) + + /// Implements a using statement that disposes `disp` after `body` has completed. + let using (disp : #IDisposable) (body : _ -> TaskStep<'T>) = + // A using statement is just a try/finally with the finally block disposing if non-null. + tryFinally + (fun () -> body disp) + (fun () -> if not (isNull (box disp)) then disp.Dispose()) + + /// Implements a loop that runs `body` for each element in `sequence`. + let forLoop (sequence : 'T seq) (body : 'T -> TaskStep) = + // A for loop is just a using statement on the sequence's enumerator... + using (sequence.GetEnumerator()) + // ... and its body is a while loop that advances the enumerator and runs the body on each element. + (fun e -> whileLoop e.MoveNext (fun () -> body e.Current)) + + /// Runs a step as a task -- with a short-circuit for immediately completed steps. + let run (firstStep : unit -> TaskStep<'T>) = + try + match firstStep() with + | Return x -> Task.FromResult(x) + | ReturnFrom t -> t + | Await _ as step -> StepStateMachine<'T>(step).Run().Unwrap() // sadly can'T do tail recursion + // Any exceptions should go on the task, rather than being thrown from this call. + // This matches C# behavior where you won'T see an exception until awaiting the task, + // even if it failed before reaching the first "await". + with + | exn -> + let src = new TaskCompletionSource<_>() + src.SetException(exn) + src.Task + + type Priority3 = obj + type Priority2 = IComparable + type Bind<'T, 'TResult> = (('T -> TaskStep< 'TResult >) -> TaskStep< 'TResult >) + + [] + type BindSensitive = + | Priority1 + //static member inline (>>=) (_:Priority2, taskLike : ^TaskLike) : Bind< ^T, ^TResult> = fun k -> Binder<_>.GenericAwait (taskLike, k) + static member (>>=) ( Priority1, task: Task<'T>) : Bind<'T, 'TResult> = fun k -> bindTask task k + //static member (>>=) ( Priority1, a : Async<'T>) : Bind<'T, 'TResult> = fun k -> bindTask (Async.StartAsTask a) k + + [] + type ReturnFromSensitive = + | Priority1 + static member inline ($) (Priority1, taskLike: ^TaskLike) = Binder<_>.GenericAwait (taskLike, ret) + //static member ($) (Priority1, a : Async<'T>) = bindTask (Async.StartAsTask a) ret : TaskStep<'T> + + [] + type BindInsensitive = + | Priority1 + //static member inline (>>=) (_:Priority3, taskLike : 'T) : Bind<'T, 'TResult> = fun k -> Binder<'TResult>.GenericAwait (taskLike, k) : TaskStep<'TResult> + //static member inline (>>=) (_:Priority2, configurableTaskLike: 'T) = fun (k : _ -> TaskStep<'TResult>) -> Binder<'TResult>.GenericAwaitConfigureFalse (configurableTaskLike, k): TaskStep<'TResult> + static member (>>=) ( Priority1, task: Task<'T> ) = fun (k : 'T -> TaskStep<'TResult>) -> bindTaskConfigureFalse task k : TaskStep<'TResult> + //static member (>>=) ( Priority1, a : Async<'T> ) = fun (k : 'T -> TaskStep<'TResult>) -> bindTaskConfigureFalse (Async.StartAsTask a) k : TaskStep<'TResult> + + [] + type ReturnFromInsensitive = + | Priority1 with + static member inline ($) (_:Priority2, taskLike ) = Binder<_>.GenericAwait(taskLike, ret) + //static member inline ($) ( Priority1, configurableTaskLike) = Binder<_>.GenericAwaitConfigureFalse(configurableTaskLike, ret) + //static member ($) ( Priority1, a : Async<'T> ) = bindTaskConfigureFalse (Async.StartAsTask a) ret + +// New style task builder. +type TaskBuilder() = + // These methods are consistent between all builders. + member __.Delay(f : unit -> TaskStep<'T>) = f + member __.Run(f : unit -> TaskStep<'T>) = run f + member __.Zero() = zero + member __.Return(x) = ret x + member __.Combine(step : TaskStep, continuation) = combine step continuation + member __.While(condition : unit -> bool, body : unit -> TaskStep) = whileLoop condition body + member __.For(sequence : seq<'T>, body : 'T -> TaskStep) = forLoop sequence body + member __.TryWith(body : unit -> TaskStep<'T>, catch : exn -> TaskStep<'T>) = tryWith body catch + member __.TryFinally(body : unit -> TaskStep<'T>, fin : unit -> unit) = tryFinally body fin + member __.Using(disp : #IDisposable, body : #IDisposable -> TaskStep<'T>) = using disp body + member __.ReturnFrom a : TaskStep<'T> = ReturnFrom a + +[] +module ContextSensitiveTasks = + + let task = TaskBuilder() + + type TaskBuilder with + member inline __.Bind (task, continuation : 'T -> TaskStep<'TResult>) : TaskStep<'TResult> = (BindSensitive.Priority1 >>= task) continuation + member inline __.ReturnFrom a : TaskStep<'TResult> = ReturnFromSensitive.Priority1 $ a + +module ContextInsensitiveTasks = + + let task = TaskBuilder() + + type TaskBuilder with + member inline __.Bind (task, continuation : 'T -> TaskStep<'TResult>) : TaskStep<'TResult> = (BindInsensitive.Priority1 >>= task) continuation +// member inline __.ReturnFrom a : TaskStep<'TResult> = ReturnFromInsensitive.Priority1 $ a \ No newline at end of file diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi new file mode 100644 index 00000000000..102a66063ef --- /dev/null +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -0,0 +1,142 @@ +namespace Mirosoft.FSharp.Control + +open System +open System.Runtime.CompilerServices +open System.Threading.Tasks +open Microsoft.FSharp.Core +open Microsoft.FSharp.Control +open Microsoft.FSharp.Collections + +/// Represents the state of a computation: either awaiting something with a continuation, or completed with a return value. +[] +type TaskStep<'T> + +module TaskHelpers = + + val unwrapException: agg: AggregateException -> exn + + val zero: TaskStep + + val ret: x: 'T -> TaskStep<'T> + + val bindTask: task: Task<'T> -> continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> + + val bindTaskConfigureFalse: task: Task<'T> -> continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> + + val combine: step: TaskStep -> continuation: (unit -> TaskStep<'TResult>) -> TaskStep<'TResult> + + val whileLoop: cond: (unit -> bool) -> body: (unit -> TaskStep) -> TaskStep + + val tryWith: step: (unit -> TaskStep<'T>) -> catch: (exn -> TaskStep<'T>) -> TaskStep<'T> + + val tryFinally: step: (unit -> TaskStep<'T>) -> fin: (unit -> unit) -> TaskStep<'T> + + val using: disp: 'Resource -> body: ('Resource -> TaskStep<'T>) -> TaskStep<'T> when 'Resource :> IDisposable + + val forLoop: sequence: seq<'T> -> body: ('T -> TaskStep) -> TaskStep + + val run: firstStep: (unit -> TaskStep<'T>) -> Task<'T> + + type Priority3 = obj + + type Priority2 = IComparable + + [] + type BindSensitive = + //static member inline ( >>= ): Priority2 * taskLike: ^TaskLike -> (( ^TResult -> TaskStep<'TResult>) -> TaskStep<'TResult>) + // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) + // and ^Awaiter :> ICriticalNotifyCompletion + // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + // and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) + static member ( >>= ): Priority1: BindSensitive * task: Task<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + //static member ( >>= ): Priority1: BindSensitive * computation: Async<'T1> -> (('T1 -> TaskStep<'TResult1>) -> TaskStep<'TResult1>) + + [] + type ReturnFromSensitive = + static member inline ( $ ): Priority1: ReturnFromSensitive * taskLike: ^TaskLike -> TaskStep< ^T > + when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + and ^Awaiter: (member GetResult: ^Awaiter -> ^T) + //static member ( $ ): Priority1: ReturnFromSensitive * computation: Async<'T> -> TaskStep<'T> + + [] + type BindInsensitive = + //static member inline ( >>= ): Priority3 * taskLike: ^TaskLike -> (( ^TResult -> TaskStep<'TResult>) -> TaskStep<'TResult>) + // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) + // and ^Awaiter :> ICriticalNotifyCompletion + // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + // and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) + + //static member inline ( >>= ): Priority2 * configurableTaskLike: ^TaskLike -> (( ^TResult -> TaskStep<'TResult>) -> TaskStep<'TResult>) + // when ^TaskLike: (member ConfigureAwait: ^TaskLike * bool -> ^Awaitable) + // and ^Awaitable: (member GetAwaiter: ^Awaitable -> ^Awaiter) + // and ^Awaiter :> ICriticalNotifyCompletion + // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + // and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) + + static member ( >>= ): Priority1: BindInsensitive * task: Task<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + //static member ( >>= ): Priority1: BindInsensitive * computation: Async<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + + [] + type ReturnFromInsensitive = + static member inline ( $ ): Priority2 * taskLike: ^TaskLike -> TaskStep< ^T> + when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + and ^Awaiter: (member GetResult: ^Awaiter -> ^T) + + //static member inline ( $ ): Priority1: ReturnFromInsensitive * configurableTaskLike: ^TaskLike -> TaskStep< ^T> + // when ^TaskLike: (member ConfigureAwait: ^TaskLike * bool -> ^Awaitable) + // and ^Awaitable: (member GetAwaiter: ^Awaitable -> ^Awaiter) + // and ^Awaiter :> ICriticalNotifyCompletion + // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + // and ^Awaiter: (member GetResult: ^Awaiter -> ^T) + + //static member ( $ ): Priority1: ReturnFromInsensitive * computation: Async<'T> -> TaskStep<'T> + + +type TaskBuilder = + new: unit -> TaskBuilder + member Combine: step: TaskStep * continuation: (unit -> TaskStep<'T>) -> TaskStep<'T> + member Delay: f: (unit -> TaskStep<'T>) -> (unit -> TaskStep<'T>) + member For: sequence: seq<'T> * body: ('T -> TaskStep) -> TaskStep + member Return: x: 'c -> TaskStep<'c> + member ReturnFrom: task: Task<'T> -> TaskStep<'T> + member Run: f: (unit -> TaskStep<'T>) -> Task<'T> + member TryFinally: body: (unit -> TaskStep<'T>) * fin: (unit -> unit) -> TaskStep<'T> + member TryWith: body: (unit -> TaskStep<'T>) * catch: (exn -> TaskStep<'T>) -> TaskStep<'T> + member Using: disp: 'Resource * body: ('Resource -> TaskStep<'T>) -> TaskStep<'T> when 'Resource :> IDisposable + member While: condition: (unit -> bool) * body: (unit -> TaskStep) -> TaskStep + member Zero: unit -> TaskStep + +[] +module ContextSensitiveTasks = + /// Builds a `System.Threading.Tasks.Task<'T>` similarly to a C# async/await method. + /// Use this like `task { let! taskResult = someTask(); return taskResult.ToString(); }`. + val task: TaskBuilder + + type TaskBuilder with + member inline Bind: task: ^TaskLike * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> + when (TaskHelpers.BindSensitive or ^TaskLike): (static member ( >>= ): TaskHelpers.BindSensitive * ^TaskLike -> ('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + + member inline ReturnFrom: a: ^TaskLike -> TaskStep< ^TResult > + //when (TaskHelpers.ReturnFromSensitive or ^TaskLike): (static member ( $ ): TaskHelpers.ReturnFromSensitive * ^TaskLike -> TaskStep<'TResult>) + when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) + +module ContextInsensitiveTasks = + /// Builds a `System.Threading.Tasks.Task<'T>` similarly to a C# async/await method, but with + /// all awaited tasks automatically configured *not* to resume on the captured context. + /// This is often preferable when writing library code that is not context-aware, but undesirable when writing + /// e.g. code that must interact with user interface controls on the same thread as its caller. + val task: TaskBuilder + + type TaskBuilder with + member inline Bind: task: ^TaskLike * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> + when (TaskHelpers.BindInsensitive or ^TaskLike): (static member ( >>= ): TaskHelpers.BindInsensitive * ^TaskLike -> ('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + +// member inline ReturnFrom: a: ^TaskLike -> TaskStep<'TResult> +// when (TaskHelpers.ReturnFromInsensitive or ^TaskLike): (static member ( $ ): TaskHelpers.ReturnFromInsensitive * ^TaskLike -> TaskStep<'TResult>) From 67d481507f02817f3efb736ed333f62c9eaeb786 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 24 Apr 2019 20:11:41 +0100 Subject: [PATCH 17/45] fix build --- src/fsharp/FSharp.Core/tasks.fs | 40 +++++++++-------- src/fsharp/FSharp.Core/tasks.fsi | 74 +++++++++++++++++++------------- 2 files changed, 66 insertions(+), 48 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index 0e9d7ba432a..ec477de0112 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -244,35 +244,40 @@ module TaskHelpers = type Priority3 = obj type Priority2 = IComparable - type Bind<'T, 'TResult> = (('T -> TaskStep< 'TResult >) -> TaskStep< 'TResult >) [] type BindSensitive = | Priority1 - //static member inline (>>=) (_:Priority2, taskLike : ^TaskLike) : Bind< ^T, ^TResult> = fun k -> Binder<_>.GenericAwait (taskLike, k) - static member (>>=) ( Priority1, task: Task<'T>) : Bind<'T, 'TResult> = fun k -> bindTask task k - //static member (>>=) ( Priority1, a : Async<'T>) : Bind<'T, 'TResult> = fun k -> bindTask (Async.StartAsTask a) k + //static member inline (>>=) (_:Priority2, taskLike : ^TaskLike) : ((^T -> TaskStep< ^TResult >) -> TaskStep< ^TResult >) = fun k -> Binder<_>.GenericAwait (taskLike, k) + static member (>>=) (_: BindSensitive, task: Task<'T>) : (('T -> TaskStep< 'TResult >) -> TaskStep< 'TResult >) = fun k -> bindTask task k + //static member (>>=) (_:BindSensitive, computation : Async<'T>) : (('T -> TaskStep< 'TResult >) -> TaskStep< 'TResult >) = fun k -> bindTask (Async.StartAsTask computation) k [] type ReturnFromSensitive = | Priority1 - static member inline ($) (Priority1, taskLike: ^TaskLike) = Binder<_>.GenericAwait (taskLike, ret) - //static member ($) (Priority1, a : Async<'T>) = bindTask (Async.StartAsTask a) ret : TaskStep<'T> + static member inline ($) (_:ReturnFromSensitive, taskLike: ^TaskLike) : TaskStep< ^T > + // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) + // and ^Awaiter :> ICriticalNotifyCompletion + // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + // and ^Awaiter: (member GetResult: ^Awaiter -> ^T) + = Binder< ^T >.GenericAwait (taskLike, ret) + + //static member ($) (_:ReturnFromSensitive, computation : Async<'T>) = bindTask (Async.StartAsTask computation) ret : TaskStep<'T> [] type BindInsensitive = | Priority1 - //static member inline (>>=) (_:Priority3, taskLike : 'T) : Bind<'T, 'TResult> = fun k -> Binder<'TResult>.GenericAwait (taskLike, k) : TaskStep<'TResult> - //static member inline (>>=) (_:Priority2, configurableTaskLike: 'T) = fun (k : _ -> TaskStep<'TResult>) -> Binder<'TResult>.GenericAwaitConfigureFalse (configurableTaskLike, k): TaskStep<'TResult> - static member (>>=) ( Priority1, task: Task<'T> ) = fun (k : 'T -> TaskStep<'TResult>) -> bindTaskConfigureFalse task k : TaskStep<'TResult> - //static member (>>=) ( Priority1, a : Async<'T> ) = fun (k : 'T -> TaskStep<'TResult>) -> bindTaskConfigureFalse (Async.StartAsTask a) k : TaskStep<'TResult> + //static member inline (>>=) (_:Priority3, taskLike : 'T) : (('T -> TaskStep< 'TResult >) -> TaskStep< 'TResult >) = fun k -> Binder<'TResult>.GenericAwait (taskLike, k) + //static member inline (>>=) (_:Priority2, configurableTaskLike: 'T) = fun (k : _ -> TaskStep<'TResult>) -> Binder<'TResult>.GenericAwaitConfigureFalse (configurableTaskLike, k) + static member (>>=) (_:BindInsensitive, task: Task<'T>) : (('T -> TaskStep< 'TResult >) -> TaskStep< 'TResult >) = fun (k : 'T -> TaskStep<'TResult>) -> bindTaskConfigureFalse task k + //static member (>>=) (_:BindInsensitive, computation : Async<'T>) = fun (k : 'T -> TaskStep<'TResult>) -> bindTaskConfigureFalse (Async.StartAsTask computation) k [] type ReturnFromInsensitive = | Priority1 with static member inline ($) (_:Priority2, taskLike ) = Binder<_>.GenericAwait(taskLike, ret) - //static member inline ($) ( Priority1, configurableTaskLike) = Binder<_>.GenericAwaitConfigureFalse(configurableTaskLike, ret) - //static member ($) ( Priority1, a : Async<'T> ) = bindTaskConfigureFalse (Async.StartAsTask a) ret + //static member inline ($) (_:ReturnFromInsensitive, configurableTaskLike) = Binder<_>.GenericAwaitConfigureFalse(configurableTaskLike, ret) + //static member ($) (_:ReturnFromInsensitive, computation : Async<'T> ) = bindTaskConfigureFalse (Async.StartAsTask computation) ret // New style task builder. type TaskBuilder() = @@ -287,7 +292,7 @@ type TaskBuilder() = member __.TryWith(body : unit -> TaskStep<'T>, catch : exn -> TaskStep<'T>) = tryWith body catch member __.TryFinally(body : unit -> TaskStep<'T>, fin : unit -> unit) = tryFinally body fin member __.Using(disp : #IDisposable, body : #IDisposable -> TaskStep<'T>) = using disp body - member __.ReturnFrom a : TaskStep<'T> = ReturnFrom a + member __.ReturnFrom (task: Task<'T>) : TaskStep<'T> = ReturnFrom task [] module ContextSensitiveTasks = @@ -295,13 +300,14 @@ module ContextSensitiveTasks = let task = TaskBuilder() type TaskBuilder with - member inline __.Bind (task, continuation : 'T -> TaskStep<'TResult>) : TaskStep<'TResult> = (BindSensitive.Priority1 >>= task) continuation - member inline __.ReturnFrom a : TaskStep<'TResult> = ReturnFromSensitive.Priority1 $ a + member inline __.Bind (task: Task<'T>, continuation : 'T -> TaskStep<'TResult>) : TaskStep<'TResult> = (Unchecked.defaultof >>= task) continuation + //member inline __.ReturnFrom computation : TaskStep<'TResult> = Unchecked.defaultof $ computation module ContextInsensitiveTasks = let task = TaskBuilder() type TaskBuilder with - member inline __.Bind (task, continuation : 'T -> TaskStep<'TResult>) : TaskStep<'TResult> = (BindInsensitive.Priority1 >>= task) continuation -// member inline __.ReturnFrom a : TaskStep<'TResult> = ReturnFromInsensitive.Priority1 $ a \ No newline at end of file + member inline __.Bind (task: Task<'T>, continuation : 'T -> TaskStep<'TResult>) : TaskStep<'TResult> = (Unchecked.defaultof >>= task) continuation +// member inline __.Bind (task, continuation : 'T -> TaskStep<'TResult>) : TaskStep<'TResult> = (Unchecked.defaultof >>= task) continuation +// member inline __.ReturnFrom computation : TaskStep<'TResult> = Unchecked.defaultof $ computation \ No newline at end of file diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index 102a66063ef..3cfa73eed85 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -43,22 +43,26 @@ module TaskHelpers = [] type BindSensitive = + // TODO: restore these //static member inline ( >>= ): Priority2 * taskLike: ^TaskLike -> (( ^TResult -> TaskStep<'TResult>) -> TaskStep<'TResult>) // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) // and ^Awaiter :> ICriticalNotifyCompletion // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) // and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) - static member ( >>= ): Priority1: BindSensitive * task: Task<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) - //static member ( >>= ): Priority1: BindSensitive * computation: Async<'T1> -> (('T1 -> TaskStep<'TResult1>) -> TaskStep<'TResult1>) - [] - type ReturnFromSensitive = - static member inline ( $ ): Priority1: ReturnFromSensitive * taskLike: ^TaskLike -> TaskStep< ^T > - when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) - and ^Awaiter :> ICriticalNotifyCompletion - and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - and ^Awaiter: (member GetResult: ^Awaiter -> ^T) - //static member ( $ ): Priority1: ReturnFromSensitive * computation: Async<'T> -> TaskStep<'T> + static member ( >>= ): BindSensitive * task: Task<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + + // TODO: restore these + //static member ( >>= ): BindSensitive * computation: Async<'T1> -> (('T1 -> TaskStep<'TResult1>) -> TaskStep<'TResult1>) + + //[] + //type ReturnFromSensitive = + // static member inline ( $ ): ReturnFromSensitive * taskLike: ^TaskLike -> TaskStep< ^T > + // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) + // and ^Awaiter :> ICriticalNotifyCompletion + // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + // and ^Awaiter: (member GetResult: ^Awaiter -> ^T) + //static member ( $ ): ReturnFromSensitive * computation: Async<'T> -> TaskStep<'T> [] type BindInsensitive = @@ -75,25 +79,26 @@ module TaskHelpers = // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) // and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) - static member ( >>= ): Priority1: BindInsensitive * task: Task<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) - //static member ( >>= ): Priority1: BindInsensitive * computation: Async<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + static member ( >>= ): BindInsensitive * task: Task<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + //static member ( >>= ): BindInsensitive * computation: Async<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) - [] - type ReturnFromInsensitive = - static member inline ( $ ): Priority2 * taskLike: ^TaskLike -> TaskStep< ^T> - when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) - and ^Awaiter :> ICriticalNotifyCompletion - and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - and ^Awaiter: (member GetResult: ^Awaiter -> ^T) - - //static member inline ( $ ): Priority1: ReturnFromInsensitive * configurableTaskLike: ^TaskLike -> TaskStep< ^T> +// TODO: restore these + //[] + //type ReturnFromInsensitive = + // static member inline ( $ ): Priority2 * taskLike: ^TaskLike -> TaskStep< ^T> + // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) + // and ^Awaiter :> ICriticalNotifyCompletion + // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + // and ^Awaiter: (member GetResult: ^Awaiter -> ^T) + + //static member inline ( $ ): ReturnFromInsensitive * configurableTaskLike: ^TaskLike -> TaskStep< ^T> // when ^TaskLike: (member ConfigureAwait: ^TaskLike * bool -> ^Awaitable) // and ^Awaitable: (member GetAwaiter: ^Awaitable -> ^Awaiter) // and ^Awaiter :> ICriticalNotifyCompletion // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) // and ^Awaiter: (member GetResult: ^Awaiter -> ^T) - //static member ( $ ): Priority1: ReturnFromInsensitive * computation: Async<'T> -> TaskStep<'T> + //static member ( $ ): ReturnFromInsensitive * computation: Async<'T> -> TaskStep<'T> type TaskBuilder = @@ -117,15 +122,18 @@ module ContextSensitiveTasks = val task: TaskBuilder type TaskBuilder with - member inline Bind: task: ^TaskLike * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> - when (TaskHelpers.BindSensitive or ^TaskLike): (static member ( >>= ): TaskHelpers.BindSensitive * ^TaskLike -> ('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + member inline Bind: task: Task<'T> * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> + // TODO: restore these + //member inline Bind: task: ^TaskLike * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> + // when (TaskHelpers.BindSensitive or ^TaskLike): (static member ( >>= ): TaskHelpers.BindSensitive * ^TaskLike -> ('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) - member inline ReturnFrom: a: ^TaskLike -> TaskStep< ^TResult > + // TODO: restore these + //member inline ReturnFrom: a: ^TaskLike -> TaskStep< ^TResult > //when (TaskHelpers.ReturnFromSensitive or ^TaskLike): (static member ( $ ): TaskHelpers.ReturnFromSensitive * ^TaskLike -> TaskStep<'TResult>) - when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) - and ^Awaiter :> ICriticalNotifyCompletion - and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) + // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) + // and ^Awaiter :> ICriticalNotifyCompletion + // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) + // and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) module ContextInsensitiveTasks = /// Builds a `System.Threading.Tasks.Task<'T>` similarly to a C# async/await method, but with @@ -135,8 +143,12 @@ module ContextInsensitiveTasks = val task: TaskBuilder type TaskBuilder with - member inline Bind: task: ^TaskLike * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> - when (TaskHelpers.BindInsensitive or ^TaskLike): (static member ( >>= ): TaskHelpers.BindInsensitive * ^TaskLike -> ('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + member inline Bind: task: Task<'T> * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> + +// TODO: restore these +// member inline Bind: task: ^TaskLike * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> +// when (TaskHelpers.BindInsensitive or ^TaskLike): (static member ( >>= ): TaskHelpers.BindInsensitive * ^TaskLike -> ('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) +// TODO: restore these // member inline ReturnFrom: a: ^TaskLike -> TaskStep<'TResult> // when (TaskHelpers.ReturnFromInsensitive or ^TaskLike): (static member ( $ ): TaskHelpers.ReturnFromInsensitive * ^TaskLike -> TaskStep<'TResult>) From 4ab8297c768f110814b03c83067c5061012de2a0 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 25 Apr 2019 15:14:28 +0100 Subject: [PATCH 18/45] fix build, re-enable commented-out bits, hide representations --- src/fsharp/FSharp.Core/tasks.fs | 382 +++++++++++++++++------------ src/fsharp/FSharp.Core/tasks.fsi | 231 ++++++++--------- src/fsharp/SignatureConformance.fs | 1 - 3 files changed, 346 insertions(+), 268 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index ec477de0112..9d245f6858b 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -4,72 +4,99 @@ // New operator-based overload resolution for F# 4.0 compatibility by Gustavo Leon in 2018. // Revised for insertion into FSHarp.Core by Microsoft, 2019. // +// Original notice: // To the extent possible under law, the author(s) have dedicated all copyright and related and neighboring rights // to this software to the public domain worldwide. This software is distributed without any warranty. +// +// Updates: +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Core.CompilerServices + /// A marker interface to give priority to different available overloads + type IPriority3 = interface end + + /// A marker interface to give priority to different available overloads + type IPriority2 = interface inherit IPriority3 end -namespace Mirosoft.FSharp.Control + /// A marker interface to give priority to different available overloads + type IPriority1 = interface inherit IPriority2 end + +namespace Microsoft.FSharp.Control open System open System.Runtime.CompilerServices open System.Threading.Tasks open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open Microsoft.FSharp.Control open Microsoft.FSharp.Collections -[] -/// Represents the state of a computation: either awaiting something with a continuation, or completed with a return value. -type TaskStep<'T> = - | Await of ICriticalNotifyCompletion * (unit -> TaskStep<'T>) - | Return of 'T - | ReturnFrom of Task<'T> +/// Represents the state of a computation: either awaiting something with a +/// continuation, or completed with a return value. +// +// Uses a struct-around-single-reference to allow future changes in representation (the representation is +// not revealed in the signature) +[] +type TaskStep<'T>(contents: TaskStepContents<'T>) = + member __.Contents = contents + + static member Return x = TaskStep<'T>(Return x) + static member Await (completion, continuation) = TaskStep<'T>(Await (completion, continuation)) + static member ReturnFrom task = TaskStep<'T>(ReturnFrom task) + +and + [] + TaskStepContents<'T> = + | Await of ICriticalNotifyCompletion * (unit -> TaskStep<'T>) + | Return of 'T + | ReturnFrom of Task<'T> + + [] module TaskHelpers = - /// Implements the machinery of running a `TaskStep<'m, 'm>` as a task returning a continuation task. - type StepStateMachine<'T>(firstStep) as this = + /// Implements the machinery of running a `TaskStep` as a task returning a continuation task. + type StepStateMachine<'T>(firstStep: TaskStep<'T>) = let methodBuilder = AsyncTaskMethodBuilder>() /// The continuation we left off awaiting on our last MoveNext(). let mutable continuation = fun () -> firstStep - /// Returns next pending awaitable or null if exiting (including tail call). - let nextAwaitable() = - try - match continuation() with - | Return r -> - methodBuilder.SetResult(Task.FromResult(r)) - null - | ReturnFrom t -> - methodBuilder.SetResult(t) - null - | Await (await, next) -> - continuation <- next - await - with - | exn -> - methodBuilder.SetException(exn) - null - - let mutable self = this - /// Start execution as a `Task>`. - member __.Run() = - methodBuilder.Start(&self) + member this.Run() = + let mutable this = this + methodBuilder.Start(&this) methodBuilder.Task interface IAsyncStateMachine with /// Proceed to one of three states: result, failure, or awaiting. /// If awaiting, MoveNext() will be called again when the awaitable completes. - member __.MoveNext() = - let mutable await = nextAwaitable() + member this.MoveNext() = + let mutable await = + try + match continuation().Contents with + | Return r -> + methodBuilder.SetResult(Task.FromResult r) + null + | ReturnFrom t -> + methodBuilder.SetResult t + null + | Await (await, next) -> + continuation <- next + await + with exn -> + methodBuilder.SetException exn + null + if not (isNull await) then + let mutable this = this // Tell the builder to call us again when this thing is done. - methodBuilder.AwaitUnsafeOnCompleted(&await, &self) + methodBuilder.AwaitUnsafeOnCompleted(&await, &this) - member __.SetStateMachine(_) = () // Doesn'T really apply since we're a reference type. + member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. let unwrapException (agg : AggregateException) = let inners = agg.InnerExceptions @@ -77,140 +104,144 @@ module TaskHelpers = else agg :> Exception /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. - let zero = Return () + let zero = TaskStep.Return () /// Used to return a value. - let ret (x : 'T) = Return x + let inline ret (x : 'T) = TaskStep<'T>.Return x - [] - type Binder<'T> = - // We put the output generic parameter up here at the class level, so it doesn'T get subject to + let inline RequireCanBind< ^Priority, ^TaskLike, 'TResult1, ^TResult2 when (^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >)) > (x: ^Priority) (y: ^TaskLike) = + ((^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >)) (x,y)) + + let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'TResult when (^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep<'TResult>)> (x: ^Priority) (y: ^TaskLike) = + ((^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep< 'TResult >) (x,y)) + + type TaskLikeBind<'TResult2> = + // We put the output generic parameter up here at the class level, so it doesn't get subject to // inline rules. If we put it all in the inline function, then the compiler gets confused at the // below and demands that the whole function either is limited to working with (x : obj), or must // be inline itself. // - // let yieldThenReturn (x : 'T) = + // let yieldThenReturn (x : 'TResult2) = // task { // do! Task.Yield() // return x // } - static member inline GenericAwait< ^Awaitable, ^Awaiter, ^TResult + static member inline GenericAwait< ^Awaitable, ^Awaiter, ^TResult1 when ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^TResult) > - (abl : ^Awaitable, continuation : ^TResult -> TaskStep<'T>) : TaskStep<'T> = - let awaiter = (^Awaitable : (member GetAwaiter : unit -> ^Awaiter)(abl)) // get an awaiter from the awaitable + and ^Awaiter : (member GetResult : unit -> ^TResult1) > + (awaitable : ^Awaitable, continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = + let awaiter = (^Awaitable : (member GetAwaiter : unit -> ^Awaiter)(awaitable)) // get an awaiter from the awaitable if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately - continuation (^Awaiter : (member GetResult : unit -> ^TResult)(awaiter)) + continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter)) else - Await (awaiter, fun () -> continuation (^Awaiter : (member GetResult : unit -> ^TResult)(awaiter))) + TaskStep<_>.Await (awaiter, fun () -> continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter))) - static member inline GenericAwaitConfigureFalse< ^Task, ^Awaitable, ^Awaiter, ^TResult - when ^Task : (member ConfigureAwait : bool -> ^Awaitable) + static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 + when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^TResult) > - (task : ^Task, continuation : ^TResult -> TaskStep<'T>) : TaskStep<'T> = - let abl = (^Task : (member ConfigureAwait : bool -> ^Awaitable)(task, false)) - Binder<'T>.GenericAwait(abl, continuation) + and ^Awaiter : (member GetResult : unit -> ^TResult1) > + (task : ^TaskLike, continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = + let awaitable = (^TaskLike : (member ConfigureAwait : bool -> ^Awaitable)(task, false)) + TaskLikeBind<'TResult2>.GenericAwait(awaitable, continuation) /// Special case of the above for `Task<'T>`. Have to write this T by hand to avoid confusing the compiler /// trying to decide between satisfying the constraints with `Task` or `Task<'T>`. let bindTask (task : Task<'T>) (continuation : 'T -> TaskStep<'TResult>) = let awaiter = task.GetAwaiter() - if awaiter.IsCompleted then // Proceed to the next step based on the result we already have. - continuation(awaiter.GetResult()) - else // Await and continue later when a result is available. - Await (awaiter, (fun () -> continuation(awaiter.GetResult()))) + if awaiter.IsCompleted then + // Continue directly + continuation (awaiter.GetResult()) + else + // Await and continue later when a result is available. + TaskStep<_>.Await (awaiter, (fun () -> continuation (awaiter.GetResult()))) /// Special case of the above for `Task<'T>`, for the context-insensitive builder. /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method /// defined on the builder has fancy generic constraints on inp and T parameters. let bindTaskConfigureFalse (task : Task<'T>) (continuation : 'T -> TaskStep<'TResult>) = let awaiter = task.ConfigureAwait(false).GetAwaiter() - if awaiter.IsCompleted then // Proceed to the next step based on the result we already have. - continuation(awaiter.GetResult()) - else // Await and continue later when a result is available. - Await (awaiter, (fun () -> continuation(awaiter.GetResult()))) + if awaiter.IsCompleted then + // Continue directly + continuation (awaiter.GetResult()) + else + // Await and continue later when a result is available. + TaskStep<_>.Await (awaiter, (fun () -> continuation (awaiter.GetResult()))) /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. let rec combine (step : TaskStep) (continuation : unit -> TaskStep<'TResult>) = - match step with + match step.Contents with | Return _ -> continuation() - | ReturnFrom t -> - Await (t.GetAwaiter(), continuation) - | Await (awaitable, next) -> - Await (awaitable, fun () -> combine (next()) continuation) + | ReturnFrom t -> TaskStep<_>.Await (t.GetAwaiter(), continuation) + | Await (awaitable, next) -> TaskStep<_>.Await (awaitable, fun () -> combine (next()) continuation) /// Builds a step that executes the body while the condition predicate is true. let whileLoop (cond : unit -> bool) (body : unit -> TaskStep) = if cond() then // Create a self-referencing closure to test whether to repeat the loop on future iterations. - let rec repeat () = + let mutable repeat = Unchecked.defaultof<_> + repeat <- fun () -> if cond() then - let body = body() - match body with - | Return _ -> repeat() - | ReturnFrom t -> Await(t.GetAwaiter(), repeat) - | Await (awaitable, next) -> - Await (awaitable, fun () -> combine (next()) repeat) - else zero + combine (body()) repeat + else + zero // Run the body the first time and chain it to the repeat logic. combine (body()) repeat else zero /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - let rec tryWith(step : unit -> TaskStep<'T>) (catch : exn -> TaskStep<'T>) = + let rec tryWith (step : unit -> TaskStep<'T>) (catch : exn -> TaskStep<'T>) = try - match step() with - | Return _ as i -> i + let stepResult = step() + match stepResult.Contents with + | Return _ -> stepResult | ReturnFrom t -> let awaitable = t.GetAwaiter() - Await(awaitable, fun () -> + TaskStep<_>.Await(awaitable, fun () -> try - awaitable.GetResult() |> Return - with - | exn -> catch exn) - | Await (awaitable, next) -> Await (awaitable, fun () -> tryWith next catch) - with - | exn -> catch exn + awaitable.GetResult() |> TaskStep<_>.Return + with exn -> + catch exn) + | Await (awaitable, next) -> + TaskStep<_>.Await (awaitable, fun () -> tryWith next catch) + with exn -> catch exn /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). let rec tryFinally (step : unit -> TaskStep<'T>) fin = - let step = + let stepResult = try step() // Important point: we use a try/with, not a try/finally, to implement tryFinally. - // The reason for this is that if we're just building a continuation, we definitely *shouldn'T* - // execute the `fin()` part yet -- the actual execution of the asynchronous code hasn'T completed! - with - | _ -> + // The reason for this is that if we're just building a continuation, we definitely *shouldn't* + // execute the `fin()` part yet -- the actual execution of the asynchronous code hasn't completed! + with _ -> fin() reraise() - match step with - | Return _ as i -> + + match stepResult.Contents with + | Return _ -> fin() - i + stepResult | ReturnFrom t -> let awaitable = t.GetAwaiter() - Await(awaitable, fun () -> + TaskStep<_>.Await(awaitable, fun () -> let result = try - awaitable.GetResult() |> Return - with - | _ -> + awaitable.GetResult() |> TaskStep<_>.Return + with _ -> fin() reraise() - fin() // if we got here we haven'T run fin(), because we would've reraised after doing so + fin() // if we got here we haven't run fin(), because we would've reraised after doing so result) | Await (awaitable, next) -> - Await (awaitable, fun () -> tryFinally next fin) + TaskStep<_>.Await (awaitable, fun () -> tryFinally next fin) /// Implements a using statement that disposes `disp` after `body` has completed. let using (disp : #IDisposable) (body : _ -> TaskStep<'T>) = @@ -220,7 +251,7 @@ module TaskHelpers = (fun () -> if not (isNull (box disp)) then disp.Dispose()) /// Implements a loop that runs `body` for each element in `sequence`. - let forLoop (sequence : 'T seq) (body : 'T -> TaskStep) = + let forLoop (sequence : seq<'T>) (body : 'T -> TaskStep) = // A for loop is just a using statement on the sequence's enumerator... using (sequence.GetEnumerator()) // ... and its body is a while loop that advances the enumerator and runs the body on each element. @@ -229,56 +260,20 @@ module TaskHelpers = /// Runs a step as a task -- with a short-circuit for immediately completed steps. let run (firstStep : unit -> TaskStep<'T>) = try - match firstStep() with - | Return x -> Task.FromResult(x) - | ReturnFrom t -> t - | Await _ as step -> StepStateMachine<'T>(step).Run().Unwrap() // sadly can'T do tail recursion - // Any exceptions should go on the task, rather than being thrown from this call. - // This matches C# behavior where you won'T see an exception until awaiting the task, - // even if it failed before reaching the first "await". - with - | exn -> + let firstStepResult = firstStep() + match firstStepResult.Contents with + | Return x -> Task.FromResult x + | ReturnFrom task -> task + | Await _ -> StepStateMachine<'T>(firstStepResult).Run().Unwrap() // sadly can't do tail recursion + + with exn -> + // Any exceptions should go on the task, rather than being thrown from this call. + // This matches C# behavior where you won't see an exception until awaiting the task, + // even if it failed before reaching the first "await". let src = new TaskCompletionSource<_>() - src.SetException(exn) + src.SetException exn src.Task - type Priority3 = obj - type Priority2 = IComparable - - [] - type BindSensitive = - | Priority1 - //static member inline (>>=) (_:Priority2, taskLike : ^TaskLike) : ((^T -> TaskStep< ^TResult >) -> TaskStep< ^TResult >) = fun k -> Binder<_>.GenericAwait (taskLike, k) - static member (>>=) (_: BindSensitive, task: Task<'T>) : (('T -> TaskStep< 'TResult >) -> TaskStep< 'TResult >) = fun k -> bindTask task k - //static member (>>=) (_:BindSensitive, computation : Async<'T>) : (('T -> TaskStep< 'TResult >) -> TaskStep< 'TResult >) = fun k -> bindTask (Async.StartAsTask computation) k - - [] - type ReturnFromSensitive = - | Priority1 - static member inline ($) (_:ReturnFromSensitive, taskLike: ^TaskLike) : TaskStep< ^T > - // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) - // and ^Awaiter :> ICriticalNotifyCompletion - // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - // and ^Awaiter: (member GetResult: ^Awaiter -> ^T) - = Binder< ^T >.GenericAwait (taskLike, ret) - - //static member ($) (_:ReturnFromSensitive, computation : Async<'T>) = bindTask (Async.StartAsTask computation) ret : TaskStep<'T> - - [] - type BindInsensitive = - | Priority1 - //static member inline (>>=) (_:Priority3, taskLike : 'T) : (('T -> TaskStep< 'TResult >) -> TaskStep< 'TResult >) = fun k -> Binder<'TResult>.GenericAwait (taskLike, k) - //static member inline (>>=) (_:Priority2, configurableTaskLike: 'T) = fun (k : _ -> TaskStep<'TResult>) -> Binder<'TResult>.GenericAwaitConfigureFalse (configurableTaskLike, k) - static member (>>=) (_:BindInsensitive, task: Task<'T>) : (('T -> TaskStep< 'TResult >) -> TaskStep< 'TResult >) = fun (k : 'T -> TaskStep<'TResult>) -> bindTaskConfigureFalse task k - //static member (>>=) (_:BindInsensitive, computation : Async<'T>) = fun (k : 'T -> TaskStep<'TResult>) -> bindTaskConfigureFalse (Async.StartAsTask computation) k - - [] - type ReturnFromInsensitive = - | Priority1 with - static member inline ($) (_:Priority2, taskLike ) = Binder<_>.GenericAwait(taskLike, ret) - //static member inline ($) (_:ReturnFromInsensitive, configurableTaskLike) = Binder<_>.GenericAwaitConfigureFalse(configurableTaskLike, ret) - //static member ($) (_:ReturnFromInsensitive, computation : Async<'T> ) = bindTaskConfigureFalse (Async.StartAsTask computation) ret - // New style task builder. type TaskBuilder() = // These methods are consistent between all builders. @@ -292,22 +287,105 @@ type TaskBuilder() = member __.TryWith(body : unit -> TaskStep<'T>, catch : exn -> TaskStep<'T>) = tryWith body catch member __.TryFinally(body : unit -> TaskStep<'T>, fin : unit -> unit) = tryFinally body fin member __.Using(disp : #IDisposable, body : #IDisposable -> TaskStep<'T>) = using disp body - member __.ReturnFrom (task: Task<'T>) : TaskStep<'T> = ReturnFrom task + member __.ReturnFrom (task: Task<'T>) : TaskStep<'T> = TaskStep<_>.ReturnFrom task [] module ContextSensitiveTasks = let task = TaskBuilder() + [] + type Witnesses() = + + // Give the type arguments explicitly to make it match the signature precisely + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> ^TResult1)>(_priority: IPriority2, taskLike : ^TaskLike) + : ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) + = fun k -> TaskLikeBind< 'TResult2 >.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (taskLike, k) + + static member CanBind (_priority: IPriority1, task: Task<'TResult1>) + : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) + = fun k -> bindTask task k + + static member CanBind (_priority: IPriority1, computation : Async<'TResult1>) + : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) + = fun k -> bindTask (Async.StartAsTask computation) k + + // Give the type arguments explicitly to make it match the signature precisely + static member inline CanReturnFrom< ^TaskLike, ^T, ^Awaiter + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> ^T)> + (_priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T > + = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T> (taskLike, ret) + + static member CanReturnFrom (_priority: IPriority1, computation : Async<'T>) + = bindTask (Async.StartAsTask computation) ret : TaskStep<'T> + type TaskBuilder with - member inline __.Bind (task: Task<'T>, continuation : 'T -> TaskStep<'TResult>) : TaskStep<'TResult> = (Unchecked.defaultof >>= task) continuation - //member inline __.ReturnFrom computation : TaskStep<'TResult> = Unchecked.defaultof $ computation + member inline __.Bind< ^TaskLike, 'TResult1, ^TResult2 + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >))> + (task: ^TaskLike, continuation: 'TResult1 -> TaskStep< ^TResult2 >) : TaskStep< ^TResult2 > + = RequireCanBind< Witnesses, ^TaskLike, 'TResult1, ^TResult2> Unchecked.defaultof task continuation + + member inline __.ReturnFrom< ^TaskLike, 'TResult when (Witnesses or ^TaskLike): (static member CanReturnFrom : Witnesses * ^TaskLike -> TaskStep<'TResult>) > (task: ^TaskLike) : TaskStep<'TResult> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'TResult> Unchecked.defaultof task module ContextInsensitiveTasks = let task = TaskBuilder() + [] + type Witnesses() = + interface IPriority1 + interface IPriority2 + interface IPriority3 + + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority3, taskLike: ^TaskLike) : ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) + = fun k -> TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (taskLike, k) + + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter + when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) + and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority2, configurableTaskLike: ^TaskLike) : ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) + = fun k -> TaskLikeBind<'TResult2>.GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1> (configurableTaskLike, k) + + static member CanBind (_priority :IPriority1, task: Task<'TResult1>) : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) = fun k -> bindTaskConfigureFalse task k + + static member CanBind (_priority: IPriority1, computation : Async<'TResult1>) : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) = fun k -> bindTaskConfigureFalse (Async.StartAsTask computation) k + + static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T + when ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter : (member get_IsCompleted : unit -> bool) + and ^Awaiter : (member GetResult : unit -> ^T) > (_priority: IPriority2, taskLike: ^Awaitable) + = TaskLikeBind< ^T >.GenericAwait< ^Awaitable, ^Awaiter, ^T >(taskLike, ret) + + static member inline CanReturnFrom< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 + when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) + and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter : (member get_IsCompleted : unit -> bool) + and ^Awaiter : (member GetResult : unit -> ^TResult1) > (_: IPriority1, configurableTaskLike: ^TaskLike) = + TaskLikeBind< ^TResult1 >.GenericAwaitConfigureFalse(configurableTaskLike, ret) + + static member CanReturnFrom (_priority: IPriority1, computation : Async<'T> ) = bindTaskConfigureFalse (Async.StartAsTask computation) ret + type TaskBuilder with - member inline __.Bind (task: Task<'T>, continuation : 'T -> TaskStep<'TResult>) : TaskStep<'TResult> = (Unchecked.defaultof >>= task) continuation -// member inline __.Bind (task, continuation : 'T -> TaskStep<'TResult>) : TaskStep<'TResult> = (Unchecked.defaultof >>= task) continuation -// member inline __.ReturnFrom computation : TaskStep<'TResult> = Unchecked.defaultof $ computation \ No newline at end of file + member inline __.Bind< ^TaskLike, 'TResult1, ^TResult2 + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >))> + (task: ^TaskLike, continuation: 'TResult1 -> TaskStep< ^TResult2 >) : TaskStep< ^TResult2 > + = RequireCanBind< Witnesses, ^TaskLike, 'TResult1, ^TResult2> Unchecked.defaultof task continuation + + member inline __.ReturnFrom< ^TaskLike, 'TResult when (Witnesses or ^TaskLike): (static member CanReturnFrom : Witnesses * ^TaskLike -> TaskStep<'TResult>) > (task: ^TaskLike) : TaskStep<'TResult> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'TResult> Unchecked.defaultof task diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index 3cfa73eed85..aa03513adeb 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -1,112 +1,41 @@ -namespace Mirosoft.FSharp.Control +// TaskBuilder.fs - TPL task computation expressions for F# +// +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace Microsoft.FSharp.Core.CompilerServices + + /// A marker interface to give priority to different available overloads + type IPriority3 = interface end + + /// A marker interface to give priority to different available overloads + type IPriority2 = interface inherit IPriority3 end + + /// A marker interface to give priority to different available overloads + type IPriority1 = interface inherit IPriority2 end + +namespace Microsoft.FSharp.Control open System open System.Runtime.CompilerServices open System.Threading.Tasks open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Control open Microsoft.FSharp.Collections /// Represents the state of a computation: either awaiting something with a continuation, or completed with a return value. -[] -type TaskStep<'T> - -module TaskHelpers = - - val unwrapException: agg: AggregateException -> exn - - val zero: TaskStep - - val ret: x: 'T -> TaskStep<'T> - - val bindTask: task: Task<'T> -> continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> - - val bindTaskConfigureFalse: task: Task<'T> -> continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> - - val combine: step: TaskStep -> continuation: (unit -> TaskStep<'TResult>) -> TaskStep<'TResult> - - val whileLoop: cond: (unit -> bool) -> body: (unit -> TaskStep) -> TaskStep - - val tryWith: step: (unit -> TaskStep<'T>) -> catch: (exn -> TaskStep<'T>) -> TaskStep<'T> - - val tryFinally: step: (unit -> TaskStep<'T>) -> fin: (unit -> unit) -> TaskStep<'T> - - val using: disp: 'Resource -> body: ('Resource -> TaskStep<'T>) -> TaskStep<'T> when 'Resource :> IDisposable - - val forLoop: sequence: seq<'T> -> body: ('T -> TaskStep) -> TaskStep - - val run: firstStep: (unit -> TaskStep<'T>) -> Task<'T> - - type Priority3 = obj - - type Priority2 = IComparable - - [] - type BindSensitive = - // TODO: restore these - //static member inline ( >>= ): Priority2 * taskLike: ^TaskLike -> (( ^TResult -> TaskStep<'TResult>) -> TaskStep<'TResult>) - // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) - // and ^Awaiter :> ICriticalNotifyCompletion - // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - // and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) - - static member ( >>= ): BindSensitive * task: Task<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) - - // TODO: restore these - //static member ( >>= ): BindSensitive * computation: Async<'T1> -> (('T1 -> TaskStep<'TResult1>) -> TaskStep<'TResult1>) - - //[] - //type ReturnFromSensitive = - // static member inline ( $ ): ReturnFromSensitive * taskLike: ^TaskLike -> TaskStep< ^T > - // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) - // and ^Awaiter :> ICriticalNotifyCompletion - // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - // and ^Awaiter: (member GetResult: ^Awaiter -> ^T) - //static member ( $ ): ReturnFromSensitive * computation: Async<'T> -> TaskStep<'T> - - [] - type BindInsensitive = - //static member inline ( >>= ): Priority3 * taskLike: ^TaskLike -> (( ^TResult -> TaskStep<'TResult>) -> TaskStep<'TResult>) - // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) - // and ^Awaiter :> ICriticalNotifyCompletion - // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - // and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) - - //static member inline ( >>= ): Priority2 * configurableTaskLike: ^TaskLike -> (( ^TResult -> TaskStep<'TResult>) -> TaskStep<'TResult>) - // when ^TaskLike: (member ConfigureAwait: ^TaskLike * bool -> ^Awaitable) - // and ^Awaitable: (member GetAwaiter: ^Awaitable -> ^Awaiter) - // and ^Awaiter :> ICriticalNotifyCompletion - // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - // and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) - - static member ( >>= ): BindInsensitive * task: Task<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) - //static member ( >>= ): BindInsensitive * computation: Async<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) - -// TODO: restore these - //[] - //type ReturnFromInsensitive = - // static member inline ( $ ): Priority2 * taskLike: ^TaskLike -> TaskStep< ^T> - // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) - // and ^Awaiter :> ICriticalNotifyCompletion - // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - // and ^Awaiter: (member GetResult: ^Awaiter -> ^T) - - //static member inline ( $ ): ReturnFromInsensitive * configurableTaskLike: ^TaskLike -> TaskStep< ^T> - // when ^TaskLike: (member ConfigureAwait: ^TaskLike * bool -> ^Awaitable) - // and ^Awaitable: (member GetAwaiter: ^Awaitable -> ^Awaiter) - // and ^Awaiter :> ICriticalNotifyCompletion - // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - // and ^Awaiter: (member GetResult: ^Awaiter -> ^T) - - //static member ( $ ): ReturnFromInsensitive * computation: Async<'T> -> TaskStep<'T> - +[] +type TaskStep<'T> = + static member Return : 'T -> TaskStep<'T> + static member Await : ICriticalNotifyCompletion * (unit -> TaskStep<'T>) -> TaskStep<'T> + static member ReturnFrom : Task<'T> -> TaskStep<'T> type TaskBuilder = new: unit -> TaskBuilder member Combine: step: TaskStep * continuation: (unit -> TaskStep<'T>) -> TaskStep<'T> member Delay: f: (unit -> TaskStep<'T>) -> (unit -> TaskStep<'T>) member For: sequence: seq<'T> * body: ('T -> TaskStep) -> TaskStep - member Return: x: 'c -> TaskStep<'c> + member Return: x: 'T -> TaskStep<'T> member ReturnFrom: task: Task<'T> -> TaskStep<'T> member Run: f: (unit -> TaskStep<'T>) -> Task<'T> member TryFinally: body: (unit -> TaskStep<'T>) * fin: (unit -> unit) -> TaskStep<'T> @@ -117,38 +46,110 @@ type TaskBuilder = [] module ContextSensitiveTasks = + /// Builds a `System.Threading.Tasks.Task<'T>` similarly to a C# async/await method. /// Use this like `task { let! taskResult = someTask(); return taskResult.ToString(); }`. val task: TaskBuilder + /// Provides evidence that various types can be used in bind and return constructs in task computation expressions + [] + type Witnesses = + + /// Provides evidence that task-like types can be used in 'bind' in a task computation expression + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > + : priority: IPriority2 * taskLike: ^TaskLike -> (( ^TResult1 -> TaskStep< 'TResult2>) -> TaskStep< 'TResult2>) + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> ^TResult1) + + /// Provides evidence that tasks can be used in 'bind' in a task computation expression + static member CanBind: priority: IPriority1 * task: Task<'TResult1> -> (('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + + /// Provides evidence that F# Async computations can be used in 'bind' in a task computation expression + static member CanBind: priority: IPriority1 * computation: Async<'TResult1> -> (('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + + /// Provides evidence that task-like types can be used in 'return' in a task workflow + static member inline CanReturnFrom< ^TaskLike, ^T, ^Awaiter> : priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T > + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> ^T) + + /// Provides evidence that F# Async computations can be used in 'return' in a task computation expression + static member CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T> + type TaskBuilder with - member inline Bind: task: Task<'T> * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> - // TODO: restore these - //member inline Bind: task: ^TaskLike * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> - // when (TaskHelpers.BindSensitive or ^TaskLike): (static member ( >>= ): TaskHelpers.BindSensitive * ^TaskLike -> ('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) - - // TODO: restore these - //member inline ReturnFrom: a: ^TaskLike -> TaskStep< ^TResult > - //when (TaskHelpers.ReturnFromSensitive or ^TaskLike): (static member ( $ ): TaskHelpers.ReturnFromSensitive * ^TaskLike -> TaskStep<'TResult>) - // when ^TaskLike: (member GetAwaiter: ^TaskLike -> ^Awaiter) - // and ^Awaiter :> ICriticalNotifyCompletion - // and ^Awaiter: (member get_IsCompleted: ^Awaiter -> bool) - // and ^Awaiter: (member GetResult: ^Awaiter -> ^TResult) + /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics + member inline Bind : task: ^TaskLike * continuation: ('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 > + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >)) + + /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics + member inline ReturnFrom: a: ^TaskLike -> TaskStep< ^TResult > + when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult>) module ContextInsensitiveTasks = - /// Builds a `System.Threading.Tasks.Task<'T>` similarly to a C# async/await method, but with - /// all awaited tasks automatically configured *not* to resume on the captured context. + + /// Builds a `System.Threading.Tasks.Task<'T>` similarly to a C# async/await method, but where + /// awaited tasks are not automatically configured to resume on the captured context. + /// /// This is often preferable when writing library code that is not context-aware, but undesirable when writing /// e.g. code that must interact with user interface controls on the same thread as its caller. val task: TaskBuilder + /// Provides evidence that various types can be used in bind and return constructs in task computation expressions + [] + type Witnesses = + interface IPriority1 + interface IPriority2 + interface IPriority3 + + /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > : priority: IPriority3 * taskLike: ^TaskLike -> (( ^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> ^TResult1) + + /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter > : priority: IPriority2 * taskLike: ^TaskLike -> (( ^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) + and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> ^TResult1) + + /// Provides evidence that tasks can be used in 'bind' in a task computation expression + static member CanBind: priority: IPriority1 * task: Task<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + + /// Provides evidence that F# async computations can be used in 'bind' in a task computation expression + static member CanBind: priority: IPriority1 * computation: Async<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + + /// Provides evidence that types following the "awaitable" pattern can be used in 'return!' in a task computation expression + static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T> : IPriority2 * taskLike: ^Awaitable -> TaskStep< ^T> + when ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> 'T) + + /// Provides evidence that types following the task-like pattern can be used in 'return!' in a task computation expression + static member inline CanReturnFrom< ^TaskLike, ^Awaitable, ^Awaiter, ^T + when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) + and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter : (member get_IsCompleted : unit -> bool) + and ^Awaiter : (member GetResult : unit -> ^T) > : IPriority1 * configurableTaskLike: ^TaskLike -> TaskStep< ^T> + + /// Provides evidence that F# async computations can be used in 'return!' in a task computation expression + static member CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T> + type TaskBuilder with - member inline Bind: task: Task<'T> * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> -// TODO: restore these -// member inline Bind: task: ^TaskLike * continuation: ('T -> TaskStep<'TResult>) -> TaskStep<'TResult> -// when (TaskHelpers.BindInsensitive or ^TaskLike): (static member ( >>= ): TaskHelpers.BindInsensitive * ^TaskLike -> ('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics + member inline Bind : task: ^TaskLike * continuation: ('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 > + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >)) + + /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics + member inline ReturnFrom: a: ^TaskLike -> TaskStep< ^TResult > + when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult>) -// TODO: restore these -// member inline ReturnFrom: a: ^TaskLike -> TaskStep<'TResult> -// when (TaskHelpers.ReturnFromInsensitive or ^TaskLike): (static member ( $ ): TaskHelpers.ReturnFromInsensitive * ^TaskLike -> TaskStep<'TResult>) diff --git a/src/fsharp/SignatureConformance.fs b/src/fsharp/SignatureConformance.fs index 6ba6dad410c..d7bb17edb0d 100644 --- a/src/fsharp/SignatureConformance.fs +++ b/src/fsharp/SignatureConformance.fs @@ -29,7 +29,6 @@ exception ExnconstrNotContained of DisplayEnv * Tycon * Tycon * (string * stri exception FieldNotContained of DisplayEnv * RecdField * RecdField * (string * string -> string) exception InterfaceNotRevealed of DisplayEnv * TType * range - // Use a type to capture the constant, common parameters type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = From 4185ce6d529db6fadef2c3802f5895e2b26560df Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 25 Apr 2019 17:02:53 +0100 Subject: [PATCH 19/45] add tests (not yet in test dll) --- src/fsharp/FSharp.Core/tasks.fs | 52 +- src/fsharp/FSharp.Core/tasks.fsi | 23 +- .../Microsoft.FSharp.Control/Tasks.fs | 726 ++++++++++++++++++ 3 files changed, 765 insertions(+), 36 deletions(-) create mode 100644 tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index 9d245f6858b..f608a6315ee 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -52,8 +52,6 @@ and | Return of 'T | ReturnFrom of Task<'T> - - [] module TaskHelpers = @@ -109,11 +107,11 @@ module TaskHelpers = /// Used to return a value. let inline ret (x : 'T) = TaskStep<'T>.Return x - let inline RequireCanBind< ^Priority, ^TaskLike, 'TResult1, ^TResult2 when (^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >)) > (x: ^Priority) (y: ^TaskLike) = - ((^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >)) (x,y)) + let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2 when (^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >)) > (x: ^Priority) (y: ^TaskLike) = + ((^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >)) (x,y)) - let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'TResult when (^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep<'TResult>)> (x: ^Priority) (y: ^TaskLike) = - ((^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep< 'TResult >) (x,y)) + let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T when (^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep<'T>)> (x: ^Priority) (y: ^TaskLike) = + ((^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep< 'T >) (x,y)) type TaskLikeBind<'TResult2> = // We put the output generic parameter up here at the class level, so it doesn't get subject to @@ -151,7 +149,7 @@ module TaskHelpers = /// Special case of the above for `Task<'T>`. Have to write this T by hand to avoid confusing the compiler /// trying to decide between satisfying the constraints with `Task` or `Task<'T>`. - let bindTask (task : Task<'T>) (continuation : 'T -> TaskStep<'TResult>) = + let bindTask (task : Task<'T>) (continuation : 'T -> TaskStep<'TResult2>) = let awaiter = task.GetAwaiter() if awaiter.IsCompleted then // Continue directly @@ -163,7 +161,7 @@ module TaskHelpers = /// Special case of the above for `Task<'T>`, for the context-insensitive builder. /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method /// defined on the builder has fancy generic constraints on inp and T parameters. - let bindTaskConfigureFalse (task : Task<'T>) (continuation : 'T -> TaskStep<'TResult>) = + let bindTaskConfigureFalse (task : Task<'T>) (continuation : 'T -> TaskStep<'TResult2>) = let awaiter = task.ConfigureAwait(false).GetAwaiter() if awaiter.IsCompleted then // Continue directly @@ -175,7 +173,7 @@ module TaskHelpers = /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. - let rec combine (step : TaskStep) (continuation : unit -> TaskStep<'TResult>) = + let rec combine (step : TaskStep) (continuation : unit -> TaskStep<'T>) = match step.Contents with | Return _ -> continuation() | ReturnFrom t -> TaskStep<_>.Await (t.GetAwaiter(), continuation) @@ -297,6 +295,10 @@ module ContextSensitiveTasks = [] type Witnesses() = + interface IPriority1 + interface IPriority2 + interface IPriority3 + // Give the type arguments explicitly to make it match the signature precisely static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) @@ -306,16 +308,14 @@ module ContextSensitiveTasks = : ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) = fun k -> TaskLikeBind< 'TResult2 >.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (taskLike, k) - static member CanBind (_priority: IPriority1, task: Task<'TResult1>) - : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) + static member CanBind (_priority: IPriority1, task: Task<'TResult1>) : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) = fun k -> bindTask task k - static member CanBind (_priority: IPriority1, computation : Async<'TResult1>) - : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) + static member CanBind (_priority: IPriority1, computation : Async<'TResult1>) : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) = fun k -> bindTask (Async.StartAsTask computation) k // Give the type arguments explicitly to make it match the signature precisely - static member inline CanReturnFrom< ^TaskLike, ^T, ^Awaiter + static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) @@ -327,13 +327,13 @@ module ContextSensitiveTasks = = bindTask (Async.StartAsTask computation) ret : TaskStep<'T> type TaskBuilder with - member inline __.Bind< ^TaskLike, 'TResult1, ^TResult2 - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >))> - (task: ^TaskLike, continuation: 'TResult1 -> TaskStep< ^TResult2 >) : TaskStep< ^TResult2 > - = RequireCanBind< Witnesses, ^TaskLike, 'TResult1, ^TResult2> Unchecked.defaultof task continuation + member inline __.Bind< ^TaskLike, ^TResult1, 'TResult2 + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >))> + (task: ^TaskLike, continuation: ^TResult1 -> TaskStep< 'TResult2 >) : TaskStep< 'TResult2 > + = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> Unchecked.defaultof task continuation - member inline __.ReturnFrom< ^TaskLike, 'TResult when (Witnesses or ^TaskLike): (static member CanReturnFrom : Witnesses * ^TaskLike -> TaskStep<'TResult>) > (task: ^TaskLike) : TaskStep<'TResult> - = RequireCanReturnFrom< Witnesses, ^TaskLike, 'TResult> Unchecked.defaultof task + member inline __.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom : Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> Unchecked.defaultof task module ContextInsensitiveTasks = @@ -382,10 +382,10 @@ module ContextInsensitiveTasks = static member CanReturnFrom (_priority: IPriority1, computation : Async<'T> ) = bindTaskConfigureFalse (Async.StartAsTask computation) ret type TaskBuilder with - member inline __.Bind< ^TaskLike, 'TResult1, ^TResult2 - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >))> - (task: ^TaskLike, continuation: 'TResult1 -> TaskStep< ^TResult2 >) : TaskStep< ^TResult2 > - = RequireCanBind< Witnesses, ^TaskLike, 'TResult1, ^TResult2> Unchecked.defaultof task continuation + member inline __.Bind< ^TaskLike, ^TResult1, 'TResult2 + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >))> + (task: ^TaskLike, continuation: ^TResult1 -> TaskStep< 'TResult2 >) : TaskStep< 'TResult2 > + = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> Unchecked.defaultof task continuation - member inline __.ReturnFrom< ^TaskLike, 'TResult when (Witnesses or ^TaskLike): (static member CanReturnFrom : Witnesses * ^TaskLike -> TaskStep<'TResult>) > (task: ^TaskLike) : TaskStep<'TResult> - = RequireCanReturnFrom< Witnesses, ^TaskLike, 'TResult> Unchecked.defaultof task + member inline __.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom : Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> Unchecked.defaultof task diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index aa03513adeb..40d1f314605 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -54,6 +54,9 @@ module ContextSensitiveTasks = /// Provides evidence that various types can be used in bind and return constructs in task computation expressions [] type Witnesses = + interface IPriority1 + interface IPriority2 + interface IPriority3 /// Provides evidence that task-like types can be used in 'bind' in a task computation expression static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > @@ -70,7 +73,7 @@ module ContextSensitiveTasks = static member CanBind: priority: IPriority1 * computation: Async<'TResult1> -> (('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) /// Provides evidence that task-like types can be used in 'return' in a task workflow - static member inline CanReturnFrom< ^TaskLike, ^T, ^Awaiter> : priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T > + static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T> : priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T > when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) @@ -81,11 +84,11 @@ module ContextSensitiveTasks = type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: ('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 > - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >)) + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 > + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >)) /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics - member inline ReturnFrom: a: ^TaskLike -> TaskStep< ^TResult > + member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult > when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult>) module ContextInsensitiveTasks = @@ -120,17 +123,17 @@ module ContextInsensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression - static member CanBind: priority: IPriority1 * task: Task<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + static member CanBind: priority: IPriority1 * task: Task<'TResult1> -> (('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) /// Provides evidence that F# async computations can be used in 'bind' in a task computation expression - static member CanBind: priority: IPriority1 * computation: Async<'T> -> (('T -> TaskStep<'TResult>) -> TaskStep<'TResult>) + static member CanBind: priority: IPriority1 * computation: Async<'TResult1> -> (('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) /// Provides evidence that types following the "awaitable" pattern can be used in 'return!' in a task computation expression static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T> : IPriority2 * taskLike: ^Awaitable -> TaskStep< ^T> when ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> 'T) + and ^Awaiter: (member GetResult: unit -> ^T) /// Provides evidence that types following the task-like pattern can be used in 'return!' in a task computation expression static member inline CanReturnFrom< ^TaskLike, ^Awaitable, ^Awaiter, ^T @@ -146,10 +149,10 @@ module ContextInsensitiveTasks = type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: ('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 > - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> (('TResult1 -> TaskStep< ^TResult2 >) -> TaskStep< ^TResult2 >)) + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 > + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >)) /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics - member inline ReturnFrom: a: ^TaskLike -> TaskStep< ^TResult > + member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult > when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult>) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs new file mode 100644 index 00000000000..d4f45ae65f7 --- /dev/null +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs @@ -0,0 +1,726 @@ +// Tests for TaskBuilder.fs +// +// Written in 2016 by Robert Peele (humbobst@gmail.com) +// +// To the extent possible under law, the author(s) have dedicated all copyright and related and neighboring rights +// to this software to the public domain worldwide. This software is distributed without any warranty. +// +// You should have received a copy of the CC0 Public Domain Dedication along with this software. +// If not, see . + + +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +// Various tests for the: +// Microsoft.FSharp.Control.Async type + +module FSharp.Core.UnitTests.FSharp_Core.Microsoft_FSharp_Control.Tasks + +//open NUnit.Framework +open System +open System.Collections +open System.Collections.Generic +open System.Diagnostics +open System.Threading +open System.Threading.Tasks +open Microsoft.FSharp.Control + +exception TestException of string + +let require x msg = if not x then failwith msg + +let testShortCircuitResult() = + let t = + task { + let! x = Task.FromResult(1) + let! y = Task.FromResult(2) + return x + y + } + require t.IsCompleted "didn't short-circuit already completed tasks" + require (t.Result = 3) "wrong result" + +let testDelay() = + let mutable x = 0 + let t = + task { + do! Task.Delay(50) + x <- x + 1 + } + require (x = 0) "task already ran" + t.Wait() + +let testNoDelay() = + let mutable x = 0 + let t = + task { + x <- x + 1 + do! Task.Delay(5) + x <- x + 1 + } + require (x = 1) "first part didn't run yet" + t.Wait() + +let testNonBlocking() = + let sw = Stopwatch() + sw.Start() + let t = + task { + do! Task.Yield() + Thread.Sleep(100) + } + sw.Stop() + require (sw.ElapsedMilliseconds < 50L) "sleep blocked caller" + t.Wait() + +let failtest str = raise (TestException str) + +let testCatching1() = + let mutable x = 0 + let mutable y = 0 + let t = + task { + try + do! Task.Delay(0) + failtest "hello" + x <- 1 + do! Task.Delay(100) + with + | TestException msg -> + require (msg = "hello") "message tampered" + | _ -> + require false "other exn type" + y <- 1 + } + t.Wait() + require (y = 1) "bailed after exn" + require (x = 0) "ran past failure" + +let testCatching2() = + let mutable x = 0 + let mutable y = 0 + let t = + task { + try + do! Task.Yield() // can't skip through this + failtest "hello" + x <- 1 + do! Task.Delay(100) + with + | TestException msg -> + require (msg = "hello") "message tampered" + | _ -> + require false "other exn type" + y <- 1 + } + t.Wait() + require (y = 1) "bailed after exn" + require (x = 0) "ran past failure" + +let testNestedCatching() = + let mutable counter = 1 + let mutable caughtInner = 0 + let mutable caughtOuter = 0 + let t1() = + task { + try + do! Task.Yield() + failtest "hello" + with + | TestException msg as exn -> + caughtInner <- counter + counter <- counter + 1 + raise exn + } + let t2 = + task { + try + do! t1() + with + | TestException msg as exn -> + caughtOuter <- counter + raise exn + | e -> + require false (sprintf "invalid msg type %s" e.Message) + } + try + t2.Wait() + require false "ran past failed task wait" + with + | :? AggregateException as exn -> + require (exn.InnerExceptions.Count = 1) "more than 1 exn" + require (caughtInner = 1) "didn't catch inner" + require (caughtOuter = 2) "didn't catch outer" + +let testTryFinallyHappyPath() = + let mutable ran = false + let t = + task { + try + require (not ran) "ran way early" + do! Task.Delay(100) + require (not ran) "ran kinda early" + finally + ran <- true + } + t.Wait() + require ran "never ran" + +let testTryFinallySadPath() = + let mutable ran = false + let t = + task { + try + require (not ran) "ran way early" + do! Task.Delay(100) + require (not ran) "ran kinda early" + failtest "uhoh" + finally + ran <- true + } + try + t.Wait() + with + | _ -> () + require ran "never ran" + +let testTryFinallyCaught() = + let mutable ran = false + let t = + task { + try + try + require (not ran) "ran way early" + do! Task.Delay(100) + require (not ran) "ran kinda early" + failtest "uhoh" + finally + ran <- true + return 1 + with + | _ -> return 2 + } + require (t.Result = 2) "wrong return" + require ran "never ran" + +let testUsing() = + let mutable disposed = false + let t = + task { + use d = { new IDisposable with member __.Dispose() = disposed <- true } + require (not disposed) "disposed way early" + do! Task.Delay(100) + require (not disposed) "disposed kinda early" + } + t.Wait() + require disposed "never disposed" + +let testUsingFromTask() = + let mutable disposedInner = false + let mutable disposed = false + let t = + task { + use! d = + task { + do! Task.Delay(50) + use i = { new IDisposable with member __.Dispose() = disposedInner <- true } + require (not disposed && not disposedInner) "disposed inner early" + return { new IDisposable with member __.Dispose() = disposed <- true } + } + require disposedInner "did not dispose inner after task completion" + require (not disposed) "disposed way early" + do! Task.Delay(50) + require (not disposed) "disposed kinda early" + } + t.Wait() + require disposed "never disposed" + +let testUsingSadPath() = + let mutable disposedInner = false + let mutable disposed = false + let t = + task { + try + use! d = + task { + do! Task.Delay(50) + use i = { new IDisposable with member __.Dispose() = disposedInner <- true } + failtest "uhoh" + require (not disposed && not disposedInner) "disposed inner early" + return { new IDisposable with member __.Dispose() = disposed <- true } + } + () + with + | TestException msg -> + require disposedInner "did not dispose inner after task completion" + require (not disposed) "disposed way early" + do! Task.Delay(50) + require (not disposed) "disposed kinda early" + } + t.Wait() + require (not disposed) "disposed thing that never should've existed" + +let testForLoop() = + let mutable disposed = false + let wrapList = + let raw = ["a"; "b"; "c"] |> Seq.ofList + let getEnumerator() = + let raw = raw.GetEnumerator() + { new IEnumerator with + member __.MoveNext() = + require (not disposed) "moved next after disposal" + raw.MoveNext() + member __.Current = + require (not disposed) "accessed current after disposal" + raw.Current + member __.Current = + require (not disposed) "accessed current (boxed) after disposal" + box raw.Current + member __.Dispose() = + require (not disposed) "disposed twice" + disposed <- true + raw.Dispose() + member __.Reset() = + require (not disposed) "reset after disposal" + raw.Reset() + } + { new IEnumerable with + member __.GetEnumerator() : IEnumerator = getEnumerator() + member __.GetEnumerator() : IEnumerator = upcast getEnumerator() + } + let t = + task { + let mutable index = 0 + do! Task.Yield() + for x in wrapList do + do! Task.Yield() + match index with + | 0 -> require (x = "a") "wrong first value" + | 1 -> require (x = "b") "wrong second value" + | 2 -> require (x = "c") "wrong third value" + | _ -> require false "iterated too far!" + index <- index + 1 + do! Task.Yield() + do! Task.Yield() + return 1 + } + t.Wait() + require disposed "never disposed" + +let testForLoopSadPath() = + let mutable disposed = false + let wrapList = + let raw = ["a"; "b"; "c"] |> Seq.ofList + let getEnumerator() = + let raw = raw.GetEnumerator() + { new IEnumerator with + member __.MoveNext() = + require (not disposed) "moved next after disposal" + raw.MoveNext() + member __.Current = + require (not disposed) "accessed current after disposal" + raw.Current + member __.Current = + require (not disposed) "accessed current (boxed) after disposal" + box raw.Current + member __.Dispose() = + require (not disposed) "disposed twice" + disposed <- true + raw.Dispose() + member __.Reset() = + require (not disposed) "reset after disposal" + raw.Reset() + } + { new IEnumerable with + member __.GetEnumerator() : IEnumerator = getEnumerator() + member __.GetEnumerator() : IEnumerator = upcast getEnumerator() + } + let mutable caught = false + let t = + task { + try + let mutable index = 0 + do! Task.Yield() + for x in wrapList do + do! Task.Yield() + match index with + | 0 -> require (x = "a") "wrong first value" + | _ -> failtest "uhoh" + index <- index + 1 + do! Task.Yield() + do! Task.Yield() + return 1 + with + | TestException "uhoh" -> + caught <- true + return 2 + } + require (t.Result = 2) "wrong result" + require caught "didn't catch exception" + require disposed "never disposed" + +let testExceptionAttachedToTaskWithoutAwait() = + let mutable ranA = false + let mutable ranB = false + let t = + task { + ranA <- true + failtest "uhoh" + ranB <- true + } + require ranA "didn't run immediately" + require (not ranB) "ran past exception" + require (not (isNull t.Exception)) "didn't capture exception" + require (t.Exception.InnerExceptions.Count = 1) "captured more exceptions" + require (t.Exception.InnerException = TestException "uhoh") "wrong exception" + let mutable caught = false + let mutable ranCatcher = false + let catcher = + task { + try + ranCatcher <- true + let! result = t + return false + with + | TestException "uhoh" -> + caught <- true + return true + } + require ranCatcher "didn't run" + require catcher.Result "didn't catch" + require caught "didn't catch" + +let testExceptionAttachedToTaskWithAwait() = + let mutable ranA = false + let mutable ranB = false + let t = + task { + ranA <- true + failtest "uhoh" + do! Task.Delay(100) + ranB <- true + } + require ranA "didn't run immediately" + require (not ranB) "ran past exception" + require (not (isNull t.Exception)) "didn't capture exception" + require (t.Exception.InnerExceptions.Count = 1) "captured more exceptions" + require (t.Exception.InnerException = TestException "uhoh") "wrong exception" + let mutable caught = false + let mutable ranCatcher = false + let catcher = + task { + try + ranCatcher <- true + let! result = t + return false + with + | TestException "uhoh" -> + caught <- true + return true + } + require ranCatcher "didn't run" + require catcher.Result "didn't catch" + require caught "didn't catch" + +let testExceptionThrownInFinally() = + let mutable ranInitial = false + let mutable ranNext = false + let mutable ranFinally = 0 + let t = + task { + try + ranInitial <- true + do! Task.Yield() + Thread.Sleep(100) // shouldn't be blocking so we should get through to requires before this finishes + ranNext <- true + finally + ranFinally <- ranFinally + 1 + failtest "finally exn!" + } + require ranInitial "didn't run initial" + require (not ranNext) "ran next too early" + try + t.Wait() + require false "shouldn't get here" + with + | _ -> () + require ranNext "didn't run next" + require (ranFinally = 1) "didn't run finally exactly once" + +let test2ndExceptionThrownInFinally() = + let mutable ranInitial = false + let mutable ranNext = false + let mutable ranFinally = 0 + let t = + task { + try + ranInitial <- true + do! Task.Yield() + Thread.Sleep(100) // shouldn't be blocking so we should get through to requires before this finishes + ranNext <- true + failtest "uhoh" + finally + ranFinally <- ranFinally + 1 + failtest "2nd exn!" + } + require ranInitial "didn't run initial" + require (not ranNext) "ran next too early" + try + t.Wait() + require false "shouldn't get here" + with + | _ -> () + require ranNext "didn't run next" + require (ranFinally = 1) "didn't run finally exactly once" + +let testFixedStackWhileLoop() = + let bigNumber = 10000 + let t = + task { + let mutable maxDepth = Nullable() + let mutable i = 0 + while i < bigNumber do + i <- i + 1 + do! Task.Yield() + if i % 100 = 0 then + let stackDepth = StackTrace().FrameCount + if maxDepth.HasValue && stackDepth > maxDepth.Value then + failwith "Stack depth increased!" + maxDepth <- Nullable(stackDepth) + return i + } + t.Wait() + require (t.Result = bigNumber) "didn't get to big number" + +let testFixedStackForLoop() = + let bigNumber = 10000 + let mutable ran = false + let t = + task { + let mutable maxDepth = Nullable() + for i in Seq.init bigNumber id do + do! Task.Yield() + if i % 100 = 0 then + let stackDepth = StackTrace().FrameCount + if maxDepth.HasValue && stackDepth > maxDepth.Value then + failwith "Stack depth increased!" + maxDepth <- Nullable(stackDepth) + ran <- true + return () + } + t.Wait() + require ran "didn't run all" + +let testTypeInference() = + let t1 : string Task = + task { + return "hello" + } + let t2 = + task { + let! s = t1 + return s.Length + } + t2.Wait() + +let testNoStackOverflowWithImmediateResult() = + let longLoop = + task { + let mutable n = 0 + while n < 10_000 do + n <- n + 1 + return! Task.FromResult(()) + } + longLoop.Wait() + +let testNoStackOverflowWithYieldResult() = + let longLoop = + task { + let mutable n = 0 + while n < 10_000 do + let! _ = + task { + do! Task.Yield() + let! _ = Task.FromResult(0) + n <- n + 1 + } + n <- n + 1 + } + longLoop.Wait() + +let testSmallTailRecursion() = + let shortLoop = + task { + let rec loop n = + task { + // larger N would stack overflow on Mono, eat heap mem on MS .NET + if n < 1000 then + do! Task.Yield() + let! _ = Task.FromResult(0) + return! loop (n + 1) + else + return () + } + return! loop 0 + } + shortLoop.Wait() + +let testTryOverReturnFrom() = + let inner() = + task { + do! Task.Yield() + failtest "inner" + return 1 + } + let t = + task { + try + do! Task.Yield() + return! inner() + with + | TestException "inner" -> return 2 + } + require (t.Result = 2) "didn't catch" + +let testTryFinallyOverReturnFromWithException() = + let inner() = + task { + do! Task.Yield() + failtest "inner" + return 1 + } + let mutable m = 0 + let t = + task { + try + do! Task.Yield() + return! inner() + finally + m <- 1 + } + try + t.Wait() + with + | :? AggregateException -> () + require (m = 1) "didn't run finally" + +let testTryFinallyOverReturnFromWithoutException() = + let inner() = + task { + do! Task.Yield() + return 1 + } + let mutable m = 0 + let t = + task { + try + do! Task.Yield() + return! inner() + finally + m <- 1 + } + try + t.Wait() + with + | :? AggregateException -> () + require (m = 1) "didn't run finally" + +// no need to call this, we just want to check that it compiles w/o warnings +let testTrivialReturnCompiles (x : 'a) : 'a Task = + task { + do! Task.Yield() + return x + } + +// no need to call this, we just want to check that it compiles w/o warnings +let testTrivialTransformedReturnCompiles (x : 'a) (f : 'a -> 'b) : 'b Task = + task { + do! Task.Yield() + return f x + } + +type ITaskThing = + abstract member Taskify : 'a option -> 'a Task + +// no need to call this, we just want to check that it compiles w/o warnings +let testInterfaceUsageCompiles (iface : ITaskThing) (x : 'a) : 'a Task = + task { + let! xResult = iface.Taskify (Some x) + do! Task.Yield() + return xResult + } + +let testAsyncsMixedWithTasks() = + let t = + task { + do! Task.Delay(1) + do! Async.Sleep(1) + let! x = + async { + do! Async.Sleep(1) + return 5 + } + return! async { return x + 3 } + } + let result = t.Result + require (result = 8) "something weird happened" + +// no need to call this, we just want to check that it compiles w/o warnings +let testDefaultInferenceForReturnFrom() = + let t = task { return Some "x" } + task { + let! r = t + if r = None then + return! failwithf "Could not find x" + else + return r + } + +// no need to call this, just check that it compiles +let testCompilerInfersArgumentOfReturnFrom = + task { + if true then return 1 + else return! failwith "" + } + + +[] +let main argv = + printfn "Running tests..." + try + testShortCircuitResult() + testDelay() + testNoDelay() + testNonBlocking() + testCatching1() + testCatching2() + testNestedCatching() + testTryFinallyHappyPath() + testTryFinallySadPath() + testTryFinallyCaught() + testUsing() + testUsingFromTask() + testUsingSadPath() + testForLoop() + testForLoopSadPath() + testExceptionAttachedToTaskWithoutAwait() + testExceptionAttachedToTaskWithAwait() + testExceptionThrownInFinally() + test2ndExceptionThrownInFinally() + testFixedStackWhileLoop() + testFixedStackForLoop() + testTypeInference() + testNoStackOverflowWithImmediateResult() + testNoStackOverflowWithYieldResult() + // we don't support TCO, so large tail recursions will stack overflow + // or at least use O(n) heap. but small ones should at least function OK. + testSmallTailRecursion() + testTryOverReturnFrom() + testTryFinallyOverReturnFromWithException() + testTryFinallyOverReturnFromWithoutException() + testAsyncsMixedWithTasks() + printfn "Passed all tests!" + with exn -> + eprintfn "Exception: %O" exn + 0 + + \ No newline at end of file From b288b48ad172a9c0b29c5ecd3d76f8ef3774106c Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sun, 28 Apr 2019 21:45:51 +0100 Subject: [PATCH 20/45] butcher in state machine approximation --- src/fsharp/FSharp.Core/tasks.fs | 507 +++++++++++------- src/fsharp/FSharp.Core/tasks.fsi | 95 ++-- .../Microsoft.FSharp.Control/Tasks.fs | 43 +- 3 files changed, 394 insertions(+), 251 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index f608a6315ee..f99289b0695 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -21,12 +21,14 @@ namespace Microsoft.FSharp.Core.CompilerServices /// A marker interface to give priority to different available overloads type IPriority1 = interface inherit IPriority2 end +#if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE namespace Microsoft.FSharp.Control open System open System.Runtime.CompilerServices open System.Threading.Tasks open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.Printf open Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open Microsoft.FSharp.Control @@ -38,80 +40,64 @@ open Microsoft.FSharp.Collections // Uses a struct-around-single-reference to allow future changes in representation (the representation is // not revealed in the signature) [] -type TaskStep<'T>(contents: TaskStepContents<'T>) = - member __.Contents = contents - - static member Return x = TaskStep<'T>(Return x) - static member Await (completion, continuation) = TaskStep<'T>(Await (completion, continuation)) - static member ReturnFrom task = TaskStep<'T>(ReturnFrom task) - -and - [] - TaskStepContents<'T> = - | Await of ICriticalNotifyCompletion * (unit -> TaskStep<'T>) - | Return of 'T - | ReturnFrom of Task<'T> +type TaskStep<'T>(actionAndPc: int, data: obj) = + static member Return (x: 'T) = TaskStep<'T>(0, box x) + static member ReturnFrom (task: Task<'T>) = TaskStep<'T>(1, box task) + static member Await (completion: ICriticalNotifyCompletion, pc: int) = TaskStep<'T>(((pc <<< 2) ||| 2), box completion) + member __.IsReturn = ((actionAndPc &&& 0b11) = 0) + member __.IsReturnFrom = ((actionAndPc &&& 0b11) = 1) + member __.IsAwait = ((actionAndPc &&& 0b11) = 2) + member __.GetAwaitable() = (data :?> ICriticalNotifyCompletion) + member __.GetResumePoint() = (actionAndPc >>> 2) + member __.GetNextTask() = (data :?> Task<'T>) + member __.GetResult() = (data :?> 'T) + + //| Return of 'T + //| ReturnFrom of Task<'T> + //| Await of ICriticalNotifyCompletion * (unit -> TaskStep<'T>) [] module TaskHelpers = - - /// Implements the machinery of running a `TaskStep` as a task returning a continuation task. - type StepStateMachine<'T>(firstStep: TaskStep<'T>) = - let methodBuilder = AsyncTaskMethodBuilder>() - - /// The continuation we left off awaiting on our last MoveNext(). - let mutable continuation = fun () -> firstStep - - /// Start execution as a `Task>`. - member this.Run() = - let mutable this = this - methodBuilder.Start(&this) - methodBuilder.Task - - interface IAsyncStateMachine with - - /// Proceed to one of three states: result, failure, or awaiting. - /// If awaiting, MoveNext() will be called again when the awaitable completes. - member this.MoveNext() = - let mutable await = - try - match continuation().Contents with - | Return r -> - methodBuilder.SetResult(Task.FromResult r) - null - | ReturnFrom t -> - methodBuilder.SetResult t - null - | Await (await, next) -> - continuation <- next - await - with exn -> - methodBuilder.SetException exn - null - - if not (isNull await) then - let mutable this = this - // Tell the builder to call us again when this thing is done. - methodBuilder.AwaitUnsafeOnCompleted(&await, &this) - - member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. - - let unwrapException (agg : AggregateException) = - let inners = agg.InnerExceptions - if inners.Count = 1 then inners.[0] - else agg :> Exception + //let __jumptable (_x:int) = () + + type SM() = + let mutable conts = ResizeArray<(unit -> obj)>() + member __.__genlabel() = + let v = conts.Count + conts.Add(Unchecked.defaultof<_>) + v + member __.__setcode n (f: unit -> TaskStep<'T>) = + //printfn "conts.Capacity = %d, n = %d, counts.Count = %d" conts.Capacity n conts.Count + conts.[n] <- (f >> box) + member sm.__code (f: unit -> TaskStep<'T>) = + let n = sm.__genlabel () + sm.__setcode n f + n + member __.__goto<'T> n = + match conts.[n]() with + | :? TaskStep<'T> as t -> t + | res -> + printfn "T = %A" typeof<'T> + printfn "res.GetType() = %A" (res.GetType()) + failwith "invalid type" + //-> unit (* unit -> TasskStep<'T> *) + + //let inline unwrapException (agg : AggregateException) = + // let inners = agg.InnerExceptions + // if inners.Count = 1 then inners.[0] + // else agg :> Exception /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. - let zero = TaskStep.Return () + let inline zero() = TaskStep.Return () /// Used to return a value. let inline ret (x : 'T) = TaskStep<'T>.Return x - let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2 when (^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >)) > (x: ^Priority) (y: ^TaskLike) = - ((^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >)) (x,y)) + let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2 when (^Priority or ^TaskLike): (static member CanBind : SM * ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) > (sm: SM) (x: ^Priority) (y: ^TaskLike) k = + ((^Priority or ^TaskLike): (static member CanBind : SM * ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) (sm, x, y, k)) - let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T when (^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep<'T>)> (x: ^Priority) (y: ^TaskLike) = - ((^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep< 'T >) (x,y)) + let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T when (^Priority or ^TaskLike): (static member CanReturnFrom: SM * ^Priority * ^TaskLike -> TaskStep<'T>)> (sm: SM) (x: ^Priority) (y: ^TaskLike) = + ((^Priority or ^TaskLike): (static member CanReturnFrom : SM * ^Priority * ^TaskLike -> TaskStep<'T>) (sm, x, y)) type TaskLikeBind<'TResult2> = // We put the output generic parameter up here at the class level, so it doesn't get subject to @@ -130,12 +116,18 @@ module TaskHelpers = and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) and ^Awaiter : (member GetResult : unit -> ^TResult1) > - (awaitable : ^Awaitable, continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = + (sm: SM, awaitable : ^Awaitable, continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = let awaiter = (^Awaitable : (member GetAwaiter : unit -> ^Awaiter)(awaitable)) // get an awaiter from the awaitable - if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately - continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter)) - else - TaskStep<_>.Await (awaiter, fun () -> continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter))) + let ENTRY = sm.__genlabel () + let CONT = sm.__genlabel () + sm.__setcode ENTRY (fun () -> + if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately + sm.__goto<'TResult2> CONT + else + TaskStep<'TResult2>.Await (awaiter, CONT)) + sm.__setcode CONT (fun () -> + continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter))) + sm.__goto ENTRY static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) @@ -143,126 +135,227 @@ module TaskHelpers = and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) and ^Awaiter : (member GetResult : unit -> ^TResult1) > - (task : ^TaskLike, continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = + (sm, task : ^TaskLike, continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = let awaitable = (^TaskLike : (member ConfigureAwait : bool -> ^Awaitable)(task, false)) - TaskLikeBind<'TResult2>.GenericAwait(awaitable, continuation) + TaskLikeBind<'TResult2>.GenericAwait(sm, awaitable, continuation) - /// Special case of the above for `Task<'T>`. Have to write this T by hand to avoid confusing the compiler - /// trying to decide between satisfying the constraints with `Task` or `Task<'T>`. - let bindTask (task : Task<'T>) (continuation : 'T -> TaskStep<'TResult2>) = + /// Special case of the above for `Task<'TResult1>`. Have to write this T by hand to avoid confusing the compiler + /// trying to decide between satisfying the constraints with `Task` or `Task<'TResult1>`. + let inline bindTask (sm: SM) (task : Task<'TResult1>) (continuation : 'TResult1 -> TaskStep<'TResult2>) = let awaiter = task.GetAwaiter() + let mutable result = Unchecked.defaultof<_> + let CONT = sm.__code (fun () -> + result <- awaiter.GetResult() + continuation result) if awaiter.IsCompleted then // Continue directly - continuation (awaiter.GetResult()) + sm.__goto<'TResult2> CONT else // Await and continue later when a result is available. - TaskStep<_>.Await (awaiter, (fun () -> continuation (awaiter.GetResult()))) + TaskStep<'TResult2>.Await (awaiter, CONT) - /// Special case of the above for `Task<'T>`, for the context-insensitive builder. + /// Special case of the above for `Task<'TResult1>`, for the context-insensitive builder. /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method /// defined on the builder has fancy generic constraints on inp and T parameters. - let bindTaskConfigureFalse (task : Task<'T>) (continuation : 'T -> TaskStep<'TResult2>) = + let inline bindTaskConfigureFalse (sm: SM) (task : Task<'TResult1>) (continuation : 'TResult1 -> TaskStep<'TResult2>) = let awaiter = task.ConfigureAwait(false).GetAwaiter() - if awaiter.IsCompleted then - // Continue directly - continuation (awaiter.GetResult()) - else - // Await and continue later when a result is available. - TaskStep<_>.Await (awaiter, (fun () -> continuation (awaiter.GetResult()))) + let mutable result = Unchecked.defaultof<_> + // codegen + let ENTRY = sm.__genlabel () + let CONT = sm.__genlabel () + sm.__setcode ENTRY (fun () -> + if awaiter.IsCompleted then + // Continue directly + sm.__goto<'TResult2> CONT + else + // Await and continue later when a result is available. + TaskStep<'TResult2>.Await (awaiter, CONT) + ) + sm.__setcode CONT (fun () -> + result <- awaiter.GetResult() + continuation result + ) + // execute + sm.__goto ENTRY /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. - let rec combine (step : TaskStep) (continuation : unit -> TaskStep<'T>) = - match step.Contents with - | Return _ -> continuation() - | ReturnFrom t -> TaskStep<_>.Await (t.GetAwaiter(), continuation) - | Await (awaitable, next) -> TaskStep<_>.Await (awaitable, fun () -> combine (next()) continuation) + let inline combine (sm: SM) (step : TaskStep) (continuation : unit -> TaskStep<'T>) : TaskStep<'T> = + let mutable step = step + let CONT = sm.__genlabel () + let ENTRY = sm.__genlabel () + sm.__setcode ENTRY (fun () -> + if step.IsReturn then + sm.__goto<'T> CONT + elif step.IsReturnFrom then + printfn "*******************----- combine" + let t = step.GetNextTask() + TaskStep<'T>.Await (t.GetAwaiter(), CONT) + else + let pc = step.GetResumePoint() + TaskStep<'T>.Await (step.GetAwaitable(), sm.__code (fun () -> + step <- sm.__goto pc + sm.__goto<'T> ENTRY))) + sm.__setcode CONT (fun () -> + continuation ()) + sm.__goto ENTRY /// Builds a step that executes the body while the condition predicate is true. - let whileLoop (cond : unit -> bool) (body : unit -> TaskStep) = - if cond() then - // Create a self-referencing closure to test whether to repeat the loop on future iterations. - let mutable repeat = Unchecked.defaultof<_> - repeat <- fun () -> - if cond() then - combine (body()) repeat - else - zero - // Run the body the first time and chain it to the repeat logic. - combine (body()) repeat - else zero + let inline whileLoop (sm: SM) (cond : unit -> bool) (body : unit -> TaskStep) : TaskStep = + let ENTRY = sm.__genlabel() + sm.__setcode ENTRY (fun () -> + if cond() then + printfn "while loop step" + combine sm (body()) (fun () -> sm.__goto ENTRY) + else + zero()) + sm.__goto ENTRY /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - let rec tryWith (step : unit -> TaskStep<'T>) (catch : exn -> TaskStep<'T>) = - try - let stepResult = step() - match stepResult.Contents with - | Return _ -> stepResult - | ReturnFrom t -> - let awaitable = t.GetAwaiter() - TaskStep<_>.Await(awaitable, fun () -> - try - awaitable.GetResult() |> TaskStep<_>.Return - with exn -> - catch exn) - | Await (awaitable, next) -> - TaskStep<_>.Await (awaitable, fun () -> tryWith next catch) - with exn -> catch exn + let inline tryWith (sm: SM) (code : unit -> TaskStep<'T>) (catch : exn -> TaskStep<'T>) : TaskStep<'T> = + let ENTRY = sm.__genlabel() + // On resume, we have to go through into the INNER_ENTRY protected by the try/with + let mutable INNER_ENTRY = sm.__code code + sm.__setcode ENTRY (fun () -> + try + let step = sm.__goto<'T> INNER_ENTRY + if step.IsReturn then + step + elif step.IsReturnFrom then + printfn "*******************-----" + let t = step.GetNextTask() + let awaitable = t.GetAwaiter() + TaskStep<'T>.Await(awaitable, sm.__code (fun () -> + try + // note, this may raise exceptions, but the code is generated in the context of the try-with + awaitable.GetResult() |> TaskStep<_>.Return + with exn -> + catch exn)) + else + let rp = step.GetResumePoint() + TaskStep<_>.Await (step.GetAwaitable(), + sm.__code (fun () -> + INNER_ENTRY <- rp + sm.__goto<'T> ENTRY)) + with exn -> + printfn "*******************----- catch" + catch exn + ) + sm.__goto<'T> ENTRY /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - let rec tryFinally (step : unit -> TaskStep<'T>) fin = - let stepResult = - try step() - // Important point: we use a try/with, not a try/finally, to implement tryFinally. - // The reason for this is that if we're just building a continuation, we definitely *shouldn't* - // execute the `fin()` part yet -- the actual execution of the asynchronous code hasn't completed! - with _ -> - fin() - reraise() - - match stepResult.Contents with - | Return _ -> - fin() - stepResult - | ReturnFrom t -> - let awaitable = t.GetAwaiter() - TaskStep<_>.Await(awaitable, fun () -> - let result = - try - awaitable.GetResult() |> TaskStep<_>.Return - with _ -> - fin() - reraise() - fin() // if we got here we haven't run fin(), because we would've reraised after doing so - result) - | Await (awaitable, next) -> - TaskStep<_>.Await (awaitable, fun () -> tryFinally next fin) + let inline tryFinally (sm: SM) (code : unit -> TaskStep<'T>) compensation = + // codegen + let ENTRY = sm.__genlabel() + let mutable INNER_ENTRY = sm.__code code + sm.__setcode ENTRY (fun () -> + printfn "TF step" + let mutable step = + try + sm.__goto<'T> INNER_ENTRY + // Important point: we use a try/with, not a try/finally, to implement tryFinally. + // The reason for this is that if we're just building a continuation, we definitely *shouldn't* + // execute the `compensation()` part yet -- the actual execution of the asynchronous code hasn't completed! + with _ -> + printfn "************** TF exception" + compensation() + reraise() + + if step.IsReturn then + printfn "*******************" + compensation() + step + elif step.IsReturnFrom then + printfn "!!!!!!!!!!!!!!!!!!!!!" + let t = step.GetNextTask() + let awaitable = t.GetAwaiter() + TaskStep<_>.Await(awaitable, sm.__code (fun () -> + let result = + try + awaitable.GetResult() |> TaskStep<_>.Return + with _ -> + compensation() + reraise() + compensation() // if we got here we haven't run compensation(), because we would've reraised after doing so + result)) + else + let rp = step.GetResumePoint() + TaskStep<'T>.Await (step.GetAwaitable(), + sm.__code (fun () -> + // go back to get inside the try/finally again + INNER_ENTRY <- rp + sm.__goto<'T> ENTRY)) + ) + sm.__goto<'T> ENTRY /// Implements a using statement that disposes `disp` after `body` has completed. - let using (disp : #IDisposable) (body : _ -> TaskStep<'T>) = + let inline using (sm: SM) (disp : #IDisposable) (body : _ -> TaskStep<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. - tryFinally + tryFinally sm (fun () -> body disp) (fun () -> if not (isNull (box disp)) then disp.Dispose()) /// Implements a loop that runs `body` for each element in `sequence`. - let forLoop (sequence : seq<'T>) (body : 'T -> TaskStep) = + let inline forLoop sm (sequence : seq<'T>) (body : 'T -> TaskStep) = // A for loop is just a using statement on the sequence's enumerator... - using (sequence.GetEnumerator()) + using sm (sequence.GetEnumerator()) // ... and its body is a while loop that advances the enumerator and runs the body on each element. - (fun e -> whileLoop e.MoveNext (fun () -> body e.Current)) + (fun e -> whileLoop sm e.MoveNext (fun () -> body e.Current)) /// Runs a step as a task -- with a short-circuit for immediately completed steps. - let run (firstStep : unit -> TaskStep<'T>) = + let inline run (sm: SM) (code : unit -> TaskStep<'T>) = try - let firstStepResult = firstStep() - match firstStepResult.Contents with - | Return x -> Task.FromResult x - | ReturnFrom task -> task - | Await _ -> StepStateMachine<'T>(firstStepResult).Run().Unwrap() // sadly can't do tail recursion + printfn "run..." + let firstStep = code() + if firstStep.IsReturn then + printfn "first step is Return..." + Task.FromResult (firstStep.GetResult()) + elif firstStep.IsReturnFrom then + printfn "first step is ReturnFrom..." + firstStep.GetNextTask() + else + printfn "first step is Await..." + let mutable methodBuilder = AsyncTaskMethodBuilder>() + + let mutable pc = firstStep.GetResumePoint() + let mutable first = true + let mutable machine = + { new IAsyncStateMachine with + + /// Proceed to one of three states: result, failure, or awaiting. + /// If awaiting, MoveNext() will be called again when the awaitable completes. + member this.MoveNext() = + try + printfn "second step, pc = %d..." pc + let step = if first then (first <- false; firstStep) else sm.__goto<'T> pc + //__code + if step.IsReturn then + let res = step.GetResult() + printfn "step is Return(%A)..." res + methodBuilder.SetResult(Task.FromResult res) + printfn "result set..." + elif step.IsReturnFrom then + printfn "step is ReturnFrom..." + methodBuilder.SetResult (step.GetNextTask()) + else + pc <- step.GetResumePoint() + printfn "step is Await, next pc = %d..." pc + let mutable this = this + let mutable await = step.GetAwaitable() + assert (not (isNull await)) + // Tell the builder to call us again when done. + methodBuilder.AwaitUnsafeOnCompleted(&await, &this) + with exn -> + methodBuilder.SetException exn + + member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. + } + + methodBuilder.Start(&machine) + methodBuilder.Task.Unwrap() with exn -> // Any exceptions should go on the task, rather than being thrown from this call. @@ -274,23 +367,25 @@ module TaskHelpers = // New style task builder. type TaskBuilder() = + let _sm = SM() // These methods are consistent between all builders. - member __.Delay(f : unit -> TaskStep<'T>) = f - member __.Run(f : unit -> TaskStep<'T>) = run f - member __.Zero() = zero - member __.Return(x) = ret x - member __.Combine(step : TaskStep, continuation) = combine step continuation - member __.While(condition : unit -> bool, body : unit -> TaskStep) = whileLoop condition body - member __.For(sequence : seq<'T>, body : 'T -> TaskStep) = forLoop sequence body - member __.TryWith(body : unit -> TaskStep<'T>, catch : exn -> TaskStep<'T>) = tryWith body catch - member __.TryFinally(body : unit -> TaskStep<'T>, fin : unit -> unit) = tryFinally body fin - member __.Using(disp : #IDisposable, body : #IDisposable -> TaskStep<'T>) = using disp body - member __.ReturnFrom (task: Task<'T>) : TaskStep<'T> = TaskStep<_>.ReturnFrom task + member inline __.Delay(f : unit -> TaskStep<'T>) = f + member inline this.Run(f : unit -> TaskStep<'T>) = run this.SM f + member inline __.Zero() = zero() + member inline __.Return(x) = ret x + member inline this.Combine(step : TaskStep, continuation) = combine this.SM step continuation + member inline this.While(condition : unit -> bool, body : unit -> TaskStep) = whileLoop this.SM condition body + member inline this.For(sequence : seq<'T>, body : 'T -> TaskStep) = forLoop this.SM sequence body + member inline this.TryWith(body : unit -> TaskStep<'T>, catch : exn -> TaskStep<'T>) = tryWith this.SM body catch + member inline this.TryFinally(body : unit -> TaskStep<'T>, compensation : unit -> unit) = tryFinally this.SM body compensation + member inline this.Using(disp : #IDisposable, body : #IDisposable -> TaskStep<'T>) = using this.SM disp body + member inline __.ReturnFrom (task: Task<'T>) : TaskStep<'T> = TaskStep<_>.ReturnFrom task + member __.SM = _sm [] module ContextSensitiveTasks = - let task = TaskBuilder() + let task<'T> = TaskBuilder() [] type Witnesses() = @@ -304,15 +399,14 @@ module ContextSensitiveTasks = when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> ^TResult1)>(_priority: IPriority2, taskLike : ^TaskLike) - : ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) - = fun k -> TaskLikeBind< 'TResult2 >.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (taskLike, k) + and ^Awaiter: (member GetResult: unit -> ^TResult1)>(sm, _priority: IPriority2, taskLike : ^TaskLike, k: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (sm, taskLike, k) - static member CanBind (_priority: IPriority1, task: Task<'TResult1>) : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) - = fun k -> bindTask task k + static member inline CanBind (sm, _priority: IPriority1, task: Task<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = bindTask sm task k - static member CanBind (_priority: IPriority1, computation : Async<'TResult1>) : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) - = fun k -> bindTask (Async.StartAsTask computation) k + static member inline CanBind (sm, _priority: IPriority1, computation : Async<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = bindTask sm (Async.StartAsTask computation) k // Give the type arguments explicitly to make it match the signature precisely static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T @@ -320,24 +414,25 @@ module ContextSensitiveTasks = and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T)> - (_priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T > - = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T> (taskLike, ret) + (sm, _priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T > + = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T> (sm, taskLike, ret) - static member CanReturnFrom (_priority: IPriority1, computation : Async<'T>) - = bindTask (Async.StartAsTask computation) ret : TaskStep<'T> + static member inline CanReturnFrom (sm, _priority: IPriority1, computation : Async<'T>) + = bindTask sm (Async.StartAsTask computation) ret : TaskStep<'T> type TaskBuilder with - member inline __.Bind< ^TaskLike, ^TResult1, 'TResult2 - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >))> - (task: ^TaskLike, continuation: ^TResult1 -> TaskStep< 'TResult2 >) : TaskStep< 'TResult2 > - = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> Unchecked.defaultof task continuation + member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 + when (Witnesses or ^TaskLike): (static member CanBind: SM * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> + (task: ^TaskLike, continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> + = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> builder.SM Unchecked.defaultof task continuation + + member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: SM * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> builder.SM Unchecked.defaultof task - member inline __.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom : Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> - = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> Unchecked.defaultof task module ContextInsensitiveTasks = - let task = TaskBuilder() + let task<'T> = TaskBuilder() [] type Witnesses() = @@ -349,43 +444,49 @@ module ContextInsensitiveTasks = when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority3, taskLike: ^TaskLike) : ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) - = fun k -> TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (taskLike, k) + and ^Awaiter: (member GetResult: unit -> ^TResult1)> (sm, _priority: IPriority3, taskLike: ^TaskLike, k: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (sm, taskLike, k) static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority2, configurableTaskLike: ^TaskLike) : ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) - = fun k -> TaskLikeBind<'TResult2>.GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1> (configurableTaskLike, k) + and ^Awaiter: (member GetResult: unit -> ^TResult1)> (sm, _priority: IPriority2, configurableTaskLike: ^TaskLike, k: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = TaskLikeBind<'TResult2>.GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1> (sm, configurableTaskLike, k) - static member CanBind (_priority :IPriority1, task: Task<'TResult1>) : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) = fun k -> bindTaskConfigureFalse task k + static member inline CanBind (sm, _priority :IPriority1, task: Task<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> = bindTaskConfigureFalse sm task k - static member CanBind (_priority: IPriority1, computation : Async<'TResult1>) : (('TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >) = fun k -> bindTaskConfigureFalse (Async.StartAsTask computation) k + static member inline CanBind (sm, _priority: IPriority1, computation : Async<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> = bindTaskConfigureFalse sm (Async.StartAsTask computation) k +(* static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T when ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^T) > (_priority: IPriority2, taskLike: ^Awaitable) - = TaskLikeBind< ^T >.GenericAwait< ^Awaitable, ^Awaiter, ^T >(taskLike, ret) + and ^Awaiter : (member GetResult : unit -> ^T) > (sm, _priority: IPriority2, taskLike: ^Awaitable) + = TaskLikeBind< ^T >.GenericAwait< ^Awaitable, ^Awaiter, ^T >(sm, taskLike, ret) static member inline CanReturnFrom< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^TResult1) > (_: IPriority1, configurableTaskLike: ^TaskLike) = - TaskLikeBind< ^TResult1 >.GenericAwaitConfigureFalse(configurableTaskLike, ret) - - static member CanReturnFrom (_priority: IPriority1, computation : Async<'T> ) = bindTaskConfigureFalse (Async.StartAsTask computation) ret + and ^Awaiter : (member GetResult : unit -> ^TResult1) > (sm, _: IPriority1, configurableTaskLike: ^TaskLike) + = TaskLikeBind< ^TResult1 >.GenericAwaitConfigureFalse(sm, configurableTaskLike, ret) - type TaskBuilder with - member inline __.Bind< ^TaskLike, ^TResult1, 'TResult2 - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >))> - (task: ^TaskLike, continuation: ^TResult1 -> TaskStep< 'TResult2 >) : TaskStep< 'TResult2 > - = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> Unchecked.defaultof task continuation - member inline __.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom : Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> - = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> Unchecked.defaultof task + static member inline CanReturnFrom (sm, _priority: IPriority1, computation: Async<'T>) + = bindTaskConfigureFalse sm (Async.StartAsTask computation) ret +*) + + type TaskBuilder with + member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 + when (Witnesses or ^TaskLike): (static member CanBind: SM * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> + (task: ^TaskLike, continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> + = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> builder.SM Unchecked.defaultof task continuation +(* + member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: SM * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> builder.SM Unchecked.defaultof task +*) +#endif diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index 40d1f314605..3abe1f72c9f 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -13,6 +13,7 @@ namespace Microsoft.FSharp.Core.CompilerServices /// A marker interface to give priority to different available overloads type IPriority1 = interface inherit IPriority2 end +#if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE namespace Microsoft.FSharp.Control open System @@ -26,30 +27,51 @@ open Microsoft.FSharp.Collections /// Represents the state of a computation: either awaiting something with a continuation, or completed with a return value. [] type TaskStep<'T> = - static member Return : 'T -> TaskStep<'T> - static member Await : ICriticalNotifyCompletion * (unit -> TaskStep<'T>) -> TaskStep<'T> - static member ReturnFrom : Task<'T> -> TaskStep<'T> + static member Return : 'T -> TaskStep<'T> + static member Await : ICriticalNotifyCompletion * int -> TaskStep<'T> + static member ReturnFrom : Task<'T> -> TaskStep<'T> + member IsReturn : bool + member IsReturnFrom : bool + member IsAwait : bool + member GetAwaitable: unit -> ICriticalNotifyCompletion + member GetResumePoint: unit -> int + member GetNextTask: unit -> Task<'T> + member GetResult: unit -> 'T + +[] +module TaskHelpers = + type SM = + new : unit -> SM + member __genlabel: unit -> int + member __setcode: int -> (unit -> TaskStep<'T>) -> unit + member __code: (unit -> TaskStep<'T>) -> int + member __goto<'T> : int -> TaskStep<'T> +// val __jumptable : int -> unit +// val __goto : int -> 'T +// val __label : int -> unit +// val __resume: (unit -> TaskStep<_>) -> int type TaskBuilder = new: unit -> TaskBuilder - member Combine: step: TaskStep * continuation: (unit -> TaskStep<'T>) -> TaskStep<'T> - member Delay: f: (unit -> TaskStep<'T>) -> (unit -> TaskStep<'T>) - member For: sequence: seq<'T> * body: ('T -> TaskStep) -> TaskStep - member Return: x: 'T -> TaskStep<'T> - member ReturnFrom: task: Task<'T> -> TaskStep<'T> - member Run: f: (unit -> TaskStep<'T>) -> Task<'T> - member TryFinally: body: (unit -> TaskStep<'T>) * fin: (unit -> unit) -> TaskStep<'T> - member TryWith: body: (unit -> TaskStep<'T>) * catch: (exn -> TaskStep<'T>) -> TaskStep<'T> - member Using: disp: 'Resource * body: ('Resource -> TaskStep<'T>) -> TaskStep<'T> when 'Resource :> IDisposable - member While: condition: (unit -> bool) * body: (unit -> TaskStep) -> TaskStep - member Zero: unit -> TaskStep + member inline Combine: step: TaskStep * continuation: (unit -> TaskStep<'T>) -> TaskStep<'T> + member inline Delay: f: (unit -> TaskStep<'T>) -> (unit -> TaskStep<'T>) + member inline For: sequence: seq<'T> * body: ('T -> TaskStep) -> TaskStep + member inline Return: x: 'T -> TaskStep<'T> + member inline ReturnFrom: task: Task<'T> -> TaskStep<'T> + member inline Run: f: (unit -> TaskStep<'T>) -> Task<'T> + member inline TryFinally: body: (unit -> TaskStep<'T>) * fin: (unit -> unit) -> TaskStep<'T> + member inline TryWith: body: (unit -> TaskStep<'T>) * catch: (exn -> TaskStep<'T>) -> TaskStep<'T> + member inline Using: disp: 'Resource * body: ('Resource -> TaskStep<'T>) -> TaskStep<'T> when 'Resource :> IDisposable + member inline While: condition: (unit -> bool) * body: (unit -> TaskStep) -> TaskStep + member inline Zero: unit -> TaskStep + member SM: SM [] module ContextSensitiveTasks = /// Builds a `System.Threading.Tasks.Task<'T>` similarly to a C# async/await method. /// Use this like `task { let! taskResult = someTask(); return taskResult.ToString(); }`. - val task: TaskBuilder + val task<'T> : TaskBuilder /// Provides evidence that various types can be used in bind and return constructs in task computation expressions [] @@ -60,36 +82,36 @@ module ContextSensitiveTasks = /// Provides evidence that task-like types can be used in 'bind' in a task computation expression static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > - : priority: IPriority2 * taskLike: ^TaskLike -> (( ^TResult1 -> TaskStep< 'TResult2>) -> TaskStep< 'TResult2>) + : sm: SM * priority: IPriority2 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep< 'TResult2>) -> TaskStep< 'TResult2> when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression - static member CanBind: priority: IPriority1 * task: Task<'TResult1> -> (('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + static member inline CanBind: sm: SM * priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> /// Provides evidence that F# Async computations can be used in 'bind' in a task computation expression - static member CanBind: priority: IPriority1 * computation: Async<'TResult1> -> (('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + static member inline CanBind: sm: SM * priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> /// Provides evidence that task-like types can be used in 'return' in a task workflow - static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T> : priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T > + static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T> : sm: SM * priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T > when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T) /// Provides evidence that F# Async computations can be used in 'return' in a task computation expression - static member CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T> + static member inline CanReturnFrom: sm: SM * IPriority1 * computation: Async<'T> -> TaskStep<'T> type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 > - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >)) + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + when (Witnesses or ^TaskLike): (static member CanBind: SM * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult > - when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult>) + when (Witnesses or ^TaskLike): (static member CanReturnFrom: SM * Witnesses * ^TaskLike -> TaskStep<'TResult>) module ContextInsensitiveTasks = @@ -98,7 +120,7 @@ module ContextInsensitiveTasks = /// /// This is often preferable when writing library code that is not context-aware, but undesirable when writing /// e.g. code that must interact with user interface controls on the same thread as its caller. - val task: TaskBuilder + val task<'T> : TaskBuilder /// Provides evidence that various types can be used in bind and return constructs in task computation expressions [] @@ -108,14 +130,14 @@ module ContextInsensitiveTasks = interface IPriority3 /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > : priority: IPriority3 * taskLike: ^TaskLike -> (( ^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > : sm: SM * priority: IPriority3 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter > : priority: IPriority2 * taskLike: ^TaskLike -> (( ^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter > : sm: SM * priority: IPriority2 * taskLike: ^TaskLike * k: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion @@ -123,13 +145,14 @@ module ContextInsensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression - static member CanBind: priority: IPriority1 * task: Task<'TResult1> -> (('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + static member inline CanBind: sm: SM * priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> /// Provides evidence that F# async computations can be used in 'bind' in a task computation expression - static member CanBind: priority: IPriority1 * computation: Async<'TResult1> -> (('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + static member inline CanBind: sm: SM * priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> +(* /// Provides evidence that types following the "awaitable" pattern can be used in 'return!' in a task computation expression - static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T> : IPriority2 * taskLike: ^Awaitable -> TaskStep< ^T> + static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T> : sm: SM * IPriority2 * taskLike: ^Awaitable -> TaskStep< ^T> when ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) @@ -141,18 +164,22 @@ module ContextInsensitiveTasks = and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^T) > : IPriority1 * configurableTaskLike: ^TaskLike -> TaskStep< ^T> + and ^Awaiter : (member GetResult : unit -> ^T) > : sm: SM * IPriority1 * configurableTaskLike: ^TaskLike -> TaskStep< ^T> /// Provides evidence that F# async computations can be used in 'return!' in a task computation expression - static member CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T> + static member inline CanReturnFrom: sm: SM * IPriority1 * computation: Async<'T> -> TaskStep<'T> +*) type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 > - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike -> ((^TResult1 -> TaskStep< 'TResult2 >) -> TaskStep< 'TResult2 >)) + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + when (Witnesses or ^TaskLike): (static member CanBind: sm: SM * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) +(* /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult > - when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult>) + when (Witnesses or ^TaskLike): (static member CanReturnFrom: sm: SM * Witnesses * ^TaskLike -> TaskStep<'TResult>) +*) +#endif \ No newline at end of file diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs index d4f45ae65f7..7a127cafe6f 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs @@ -46,7 +46,9 @@ let testDelay() = do! Task.Delay(50) x <- x + 1 } + printfn "task created and first step run...." require (x = 0) "task already ran" + printfn "waiting...." t.Wait() let testNoDelay() = @@ -89,6 +91,7 @@ let testCatching1() = require (msg = "hello") "message tampered" | _ -> require false "other exn type" + require false "other exn type" y <- 1 } t.Wait() @@ -212,7 +215,7 @@ let testUsing() = require (not disposed) "disposed kinda early" } t.Wait() - require disposed "never disposed" + require disposed "never disposed B" let testUsingFromTask() = let mutable disposedInner = false @@ -232,7 +235,7 @@ let testUsingFromTask() = require (not disposed) "disposed kinda early" } t.Wait() - require disposed "never disposed" + require disposed "never disposed C" let testUsingSadPath() = let mutable disposedInner = false @@ -291,20 +294,29 @@ let testForLoop() = task { let mutable index = 0 do! Task.Yield() + printfn "entering loop..." for x in wrapList do + printfn "x = %A, index = %d" x index + do! Task.Yield() + printfn "back from yield" do! Task.Yield() + printfn "back from yield again" match index with | 0 -> require (x = "a") "wrong first value" | 1 -> require (x = "b") "wrong second value" | 2 -> require (x = "c") "wrong third value" | _ -> require false "iterated too far!" index <- index + 1 + printfn "yield again" do! Task.Yield() + printfn "yield again again" + do! Task.Yield() + printfn "looping again..." do! Task.Yield() return 1 } t.Wait() - require disposed "never disposed" + require disposed "never disposed D" let testForLoopSadPath() = let mutable disposed = false @@ -356,7 +368,7 @@ let testForLoopSadPath() = } require (t.Result = 2) "wrong result" require caught "didn't catch exception" - require disposed "never disposed" + require disposed "never disposed A" let testExceptionAttachedToTaskWithoutAwait() = let mutable ranA = false @@ -473,7 +485,7 @@ let test2ndExceptionThrownInFinally() = require (ranFinally = 1) "didn't run finally exactly once" let testFixedStackWhileLoop() = - let bigNumber = 10000 + let bigNumber = 10 // TODO: make this 10000 let t = task { let mutable maxDepth = Nullable() @@ -492,7 +504,7 @@ let testFixedStackWhileLoop() = require (t.Result = bigNumber) "didn't get to big number" let testFixedStackForLoop() = - let bigNumber = 10000 + let bigNumber = 10 // TODO: make this 10000 let mutable ran = false let t = task { @@ -523,20 +535,22 @@ let testTypeInference() = t2.Wait() let testNoStackOverflowWithImmediateResult() = + let bigNumber = 10 // TODO: make this 10000 let longLoop = task { let mutable n = 0 - while n < 10_000 do + while n < bigNumber do n <- n + 1 return! Task.FromResult(()) } longLoop.Wait() let testNoStackOverflowWithYieldResult() = + let bigNumber = 10 // TODO: make this 10000 let longLoop = task { let mutable n = 0 - while n < 10_000 do + while n < bigNumber do let! _ = task { do! Task.Yield() @@ -548,12 +562,13 @@ let testNoStackOverflowWithYieldResult() = longLoop.Wait() let testSmallTailRecursion() = + let bigNumber = 10 // TODO: make this 1000 let shortLoop = task { let rec loop n = task { // larger N would stack overflow on Mono, eat heap mem on MS .NET - if n < 1000 then + if n < bigNumber then do! Task.Yield() let! _ = Task.FromResult(0) return! loop (n + 1) @@ -642,11 +657,11 @@ type ITaskThing = abstract member Taskify : 'a option -> 'a Task // no need to call this, we just want to check that it compiles w/o warnings -let testInterfaceUsageCompiles (iface : ITaskThing) (x : 'a) : 'a Task = +let testInterfaceUsageCompiles (iface : 'a Task) (x : 'a) : 'a Task = task { - let! xResult = iface.Taskify (Some x) - do! Task.Yield() - return xResult + let! xResult = iface //.Taskify (Some x) + //do! Task.Yield() + return x //xResult } let testAsyncsMixedWithTasks() = @@ -676,7 +691,7 @@ let testDefaultInferenceForReturnFrom() = } // no need to call this, just check that it compiles -let testCompilerInfersArgumentOfReturnFrom = +let testCompilerInfersArgumentOfReturnFrom() = task { if true then return 1 else return! failwith "" From f43ec6591d8394e0bfa52fe1f6bab3428ef1915d Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sun, 28 Apr 2019 22:01:14 +0100 Subject: [PATCH 21/45] butcher in state machine approximation --- src/fsharp/FSharp.Core/tasks.fs | 97 +++++++++++++++++--------------- src/fsharp/FSharp.Core/tasks.fsi | 6 +- 2 files changed, 56 insertions(+), 47 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index f99289b0695..7ddf1d99d32 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -66,14 +66,17 @@ module TaskHelpers = let v = conts.Count conts.Add(Unchecked.defaultof<_>) v - member __.__setcode n (f: unit -> TaskStep<'T>) = + + member __.__gencode n (f: unit -> TaskStep<'T>) = //printfn "conts.Capacity = %d, n = %d, counts.Count = %d" conts.Capacity n conts.Count conts.[n] <- (f >> box) + member sm.__code (f: unit -> TaskStep<'T>) = let n = sm.__genlabel () - sm.__setcode n f + sm.__gencode n f n - member __.__goto<'T> n = + + member __.__jsr<'T> n = match conts.[n]() with | :? TaskStep<'T> as t -> t | res -> @@ -120,14 +123,14 @@ module TaskHelpers = let awaiter = (^Awaitable : (member GetAwaiter : unit -> ^Awaiter)(awaitable)) // get an awaiter from the awaitable let ENTRY = sm.__genlabel () let CONT = sm.__genlabel () - sm.__setcode ENTRY (fun () -> + sm.__gencode ENTRY (fun () -> if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately - sm.__goto<'TResult2> CONT + sm.__jsr<'TResult2> CONT else TaskStep<'TResult2>.Await (awaiter, CONT)) - sm.__setcode CONT (fun () -> + sm.__gencode CONT (fun () -> continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter))) - sm.__goto ENTRY + sm.__jsr ENTRY static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) @@ -144,73 +147,79 @@ module TaskHelpers = let inline bindTask (sm: SM) (task : Task<'TResult1>) (continuation : 'TResult1 -> TaskStep<'TResult2>) = let awaiter = task.GetAwaiter() let mutable result = Unchecked.defaultof<_> - let CONT = sm.__code (fun () -> + let ENTRY = sm.__genlabel() + let CONT = sm.__genlabel() + sm.__gencode ENTRY (fun () -> + if awaiter.IsCompleted then + // Continue directly + sm.__jsr<'TResult2> CONT + else + // Await and continue later when a result is available. + TaskStep<'TResult2>.Await (awaiter, CONT) + ) + sm.__gencode CONT (fun () -> result <- awaiter.GetResult() - continuation result) - if awaiter.IsCompleted then - // Continue directly - sm.__goto<'TResult2> CONT - else - // Await and continue later when a result is available. - TaskStep<'TResult2>.Await (awaiter, CONT) + continuation result + ) + sm.__jsr ENTRY /// Special case of the above for `Task<'TResult1>`, for the context-insensitive builder. /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method /// defined on the builder has fancy generic constraints on inp and T parameters. let inline bindTaskConfigureFalse (sm: SM) (task : Task<'TResult1>) (continuation : 'TResult1 -> TaskStep<'TResult2>) = let awaiter = task.ConfigureAwait(false).GetAwaiter() - let mutable result = Unchecked.defaultof<_> // codegen let ENTRY = sm.__genlabel () let CONT = sm.__genlabel () - sm.__setcode ENTRY (fun () -> + sm.__gencode ENTRY (fun () -> if awaiter.IsCompleted then // Continue directly - sm.__goto<'TResult2> CONT + sm.__jsr<'TResult2> CONT else // Await and continue later when a result is available. TaskStep<'TResult2>.Await (awaiter, CONT) ) - sm.__setcode CONT (fun () -> - result <- awaiter.GetResult() - continuation result + sm.__gencode CONT (fun () -> + continuation (awaiter.GetResult()) ) // execute - sm.__goto ENTRY + sm.__jsr ENTRY /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. let inline combine (sm: SM) (step : TaskStep) (continuation : unit -> TaskStep<'T>) : TaskStep<'T> = let mutable step = step - let CONT = sm.__genlabel () let ENTRY = sm.__genlabel () - sm.__setcode ENTRY (fun () -> + let CONT = sm.__genlabel () + let RESUME = sm.__genlabel () + sm.__gencode ENTRY (fun () -> if step.IsReturn then - sm.__goto<'T> CONT + sm.__jsr<'T> CONT elif step.IsReturnFrom then printfn "*******************----- combine" let t = step.GetNextTask() TaskStep<'T>.Await (t.GetAwaiter(), CONT) else - let pc = step.GetResumePoint() - TaskStep<'T>.Await (step.GetAwaitable(), sm.__code (fun () -> - step <- sm.__goto pc - sm.__goto<'T> ENTRY))) - sm.__setcode CONT (fun () -> - continuation ()) - sm.__goto ENTRY + TaskStep<'T>.Await (step.GetAwaitable(), RESUME)) + sm.__gencode RESUME (fun () -> + let pc = step.GetResumePoint() + step <- sm.__jsr pc + sm.__jsr<'T> ENTRY) + sm.__gencode CONT (fun () -> + continuation ()) + sm.__jsr ENTRY /// Builds a step that executes the body while the condition predicate is true. let inline whileLoop (sm: SM) (cond : unit -> bool) (body : unit -> TaskStep) : TaskStep = let ENTRY = sm.__genlabel() - sm.__setcode ENTRY (fun () -> + sm.__gencode ENTRY (fun () -> if cond() then printfn "while loop step" - combine sm (body()) (fun () -> sm.__goto ENTRY) + combine sm (body()) (fun () -> sm.__jsr ENTRY) else zero()) - sm.__goto ENTRY + sm.__jsr ENTRY /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). @@ -218,9 +227,9 @@ module TaskHelpers = let ENTRY = sm.__genlabel() // On resume, we have to go through into the INNER_ENTRY protected by the try/with let mutable INNER_ENTRY = sm.__code code - sm.__setcode ENTRY (fun () -> + sm.__gencode ENTRY (fun () -> try - let step = sm.__goto<'T> INNER_ENTRY + let step = sm.__jsr<'T> INNER_ENTRY if step.IsReturn then step elif step.IsReturnFrom then @@ -238,12 +247,12 @@ module TaskHelpers = TaskStep<_>.Await (step.GetAwaitable(), sm.__code (fun () -> INNER_ENTRY <- rp - sm.__goto<'T> ENTRY)) + sm.__jsr<'T> ENTRY)) with exn -> printfn "*******************----- catch" catch exn ) - sm.__goto<'T> ENTRY + sm.__jsr<'T> ENTRY /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). @@ -251,11 +260,11 @@ module TaskHelpers = // codegen let ENTRY = sm.__genlabel() let mutable INNER_ENTRY = sm.__code code - sm.__setcode ENTRY (fun () -> + sm.__gencode ENTRY (fun () -> printfn "TF step" let mutable step = try - sm.__goto<'T> INNER_ENTRY + sm.__jsr<'T> INNER_ENTRY // Important point: we use a try/with, not a try/finally, to implement tryFinally. // The reason for this is that if we're just building a continuation, we definitely *shouldn't* // execute the `compensation()` part yet -- the actual execution of the asynchronous code hasn't completed! @@ -287,9 +296,9 @@ module TaskHelpers = sm.__code (fun () -> // go back to get inside the try/finally again INNER_ENTRY <- rp - sm.__goto<'T> ENTRY)) + sm.__jsr<'T> ENTRY)) ) - sm.__goto<'T> ENTRY + sm.__jsr<'T> ENTRY /// Implements a using statement that disposes `disp` after `body` has completed. let inline using (sm: SM) (disp : #IDisposable) (body : _ -> TaskStep<'T>) = @@ -330,7 +339,7 @@ module TaskHelpers = member this.MoveNext() = try printfn "second step, pc = %d..." pc - let step = if first then (first <- false; firstStep) else sm.__goto<'T> pc + let step = if first then (first <- false; firstStep) else sm.__jsr<'T> pc //__code if step.IsReturn then let res = step.GetResult() diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index 3abe1f72c9f..96ee4e5180f 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -43,11 +43,11 @@ module TaskHelpers = type SM = new : unit -> SM member __genlabel: unit -> int - member __setcode: int -> (unit -> TaskStep<'T>) -> unit + member __gencode: int -> (unit -> TaskStep<'T>) -> unit member __code: (unit -> TaskStep<'T>) -> int - member __goto<'T> : int -> TaskStep<'T> + member __jsr<'T> : int -> TaskStep<'T> // val __jumptable : int -> unit -// val __goto : int -> 'T +// val __jsr : int -> 'T // val __label : int -> unit // val __resume: (unit -> TaskStep<_>) -> int From 07f9af0935f28679910ec05377cfbd42c337f44c Mon Sep 17 00:00:00 2001 From: Don Syme Date: Sun, 28 Apr 2019 23:08:28 +0100 Subject: [PATCH 22/45] butcher in state machine approximation --- src/fsharp/FSharp.Core/tasks.fs | 197 +++++++++++++++---------------- src/fsharp/FSharp.Core/tasks.fsi | 11 +- 2 files changed, 99 insertions(+), 109 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index 7ddf1d99d32..d34381ea33a 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -40,15 +40,14 @@ open Microsoft.FSharp.Collections // Uses a struct-around-single-reference to allow future changes in representation (the representation is // not revealed in the signature) [] -type TaskStep<'T>(actionAndPc: int, data: obj) = +type TaskStep<'T>(action: int, data: obj) = static member Return (x: 'T) = TaskStep<'T>(0, box x) static member ReturnFrom (task: Task<'T>) = TaskStep<'T>(1, box task) - static member Await (completion: ICriticalNotifyCompletion, pc: int) = TaskStep<'T>(((pc <<< 2) ||| 2), box completion) - member __.IsReturn = ((actionAndPc &&& 0b11) = 0) - member __.IsReturnFrom = ((actionAndPc &&& 0b11) = 1) - member __.IsAwait = ((actionAndPc &&& 0b11) = 2) + static member Await (completion: ICriticalNotifyCompletion) = TaskStep<'T>(2, box completion) + member __.IsReturn = (action = 0) + member __.IsReturnFrom = (action = 1) + member __.IsAwait = (action = 2) member __.GetAwaitable() = (data :?> ICriticalNotifyCompletion) - member __.GetResumePoint() = (actionAndPc >>> 2) member __.GetNextTask() = (data :?> Task<'T>) member __.GetResult() = (data :?> 'T) @@ -62,13 +61,13 @@ module TaskHelpers = type SM() = let mutable conts = ResizeArray<(unit -> obj)>() + let mutable pc = 0 member __.__genlabel() = let v = conts.Count conts.Add(Unchecked.defaultof<_>) v member __.__gencode n (f: unit -> TaskStep<'T>) = - //printfn "conts.Capacity = %d, n = %d, counts.Count = %d" conts.Capacity n conts.Count conts.[n] <- (f >> box) member sm.__code (f: unit -> TaskStep<'T>) = @@ -76,13 +75,15 @@ module TaskHelpers = sm.__gencode n f n - member __.__jsr<'T> n = + member __.__jmp<'T> n = match conts.[n]() with | :? TaskStep<'T> as t -> t | res -> printfn "T = %A" typeof<'T> printfn "res.GetType() = %A" (res.GetType()) failwith "invalid type" + member __.__setpc v = pc <- v + member __.__getpc = pc //-> unit (* unit -> TasskStep<'T> *) //let inline unwrapException (agg : AggregateException) = @@ -125,12 +126,13 @@ module TaskHelpers = let CONT = sm.__genlabel () sm.__gencode ENTRY (fun () -> if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately - sm.__jsr<'TResult2> CONT + sm.__jmp<'TResult2> CONT else - TaskStep<'TResult2>.Await (awaiter, CONT)) + sm.__setpc CONT + TaskStep<'TResult2>.Await (awaiter)) sm.__gencode CONT (fun () -> continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter))) - sm.__jsr ENTRY + sm.__jmp ENTRY static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) @@ -152,16 +154,17 @@ module TaskHelpers = sm.__gencode ENTRY (fun () -> if awaiter.IsCompleted then // Continue directly - sm.__jsr<'TResult2> CONT + sm.__jmp<'TResult2> CONT else // Await and continue later when a result is available. - TaskStep<'TResult2>.Await (awaiter, CONT) + sm.__setpc CONT + TaskStep<'TResult2>.Await (awaiter) ) sm.__gencode CONT (fun () -> result <- awaiter.GetResult() continuation result ) - sm.__jsr ENTRY + sm.__jmp ENTRY /// Special case of the above for `Task<'TResult1>`, for the context-insensitive builder. /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method @@ -174,16 +177,17 @@ module TaskHelpers = sm.__gencode ENTRY (fun () -> if awaiter.IsCompleted then // Continue directly - sm.__jsr<'TResult2> CONT + sm.__jmp<'TResult2> CONT else // Await and continue later when a result is available. - TaskStep<'TResult2>.Await (awaiter, CONT) + sm.__setpc CONT + TaskStep<'TResult2>.Await (awaiter) ) sm.__gencode CONT (fun () -> continuation (awaiter.GetResult()) ) // execute - sm.__jsr ENTRY + sm.__jmp ENTRY /// Chains together a step with its following step. /// Note that this requires that the first step has no result. @@ -192,34 +196,39 @@ module TaskHelpers = let mutable step = step let ENTRY = sm.__genlabel () let CONT = sm.__genlabel () - let RESUME = sm.__genlabel () sm.__gencode ENTRY (fun () -> if step.IsReturn then - sm.__jsr<'T> CONT + sm.__jmp<'T> CONT elif step.IsReturnFrom then - printfn "*******************----- combine" let t = step.GetNextTask() - TaskStep<'T>.Await (t.GetAwaiter(), CONT) + sm.__setpc CONT + TaskStep<'T>.Await (t.GetAwaiter()) else - TaskStep<'T>.Await (step.GetAwaitable(), RESUME)) - sm.__gencode RESUME (fun () -> - let pc = step.GetResumePoint() - step <- sm.__jsr pc - sm.__jsr<'T> ENTRY) + // CODEGEN: TODO: this doesn't feel right, we are not jumping to a label + // CODEGEN: instead, all code paths should end up executing the continuation + // + // Whenever an Await has been generated elsewhere, the pc has already been set to + // the resumption point. + let rp = sm.__getpc + sm.__setpc (sm.__code (fun () -> + step <- sm.__jmp rp + sm.__jmp<'T> ENTRY)) + TaskStep<'T>.Await (step.GetAwaitable())) + sm.__gencode CONT (fun () -> continuation ()) - sm.__jsr ENTRY + + sm.__jmp ENTRY /// Builds a step that executes the body while the condition predicate is true. let inline whileLoop (sm: SM) (cond : unit -> bool) (body : unit -> TaskStep) : TaskStep = let ENTRY = sm.__genlabel() sm.__gencode ENTRY (fun () -> if cond() then - printfn "while loop step" - combine sm (body()) (fun () -> sm.__jsr ENTRY) + combine sm (body()) (fun () -> sm.__jmp ENTRY) else zero()) - sm.__jsr ENTRY + sm.__jmp ENTRY /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). @@ -229,30 +238,32 @@ module TaskHelpers = let mutable INNER_ENTRY = sm.__code code sm.__gencode ENTRY (fun () -> try - let step = sm.__jsr<'T> INNER_ENTRY + let step = sm.__jmp<'T> INNER_ENTRY if step.IsReturn then step elif step.IsReturnFrom then - printfn "*******************-----" let t = step.GetNextTask() let awaitable = t.GetAwaiter() - TaskStep<'T>.Await(awaitable, sm.__code (fun () -> + sm.__setpc (sm.__code (fun () -> try // note, this may raise exceptions, but the code is generated in the context of the try-with awaitable.GetResult() |> TaskStep<_>.Return with exn -> catch exn)) + TaskStep<'T>.Await(awaitable) else - let rp = step.GetResumePoint() - TaskStep<_>.Await (step.GetAwaitable(), - sm.__code (fun () -> - INNER_ENTRY <- rp - sm.__jsr<'T> ENTRY)) + // CODEGEN: This can be: + // pc <- step.GetResumeLabel() + // TaskStep<_>.Await (step.GetAwaitable()) + let rp = sm.__getpc + sm.__setpc (sm.__code (fun () -> + INNER_ENTRY <- rp + sm.__jmp<'T> ENTRY)) + TaskStep<_>.Await (step.GetAwaitable()) with exn -> - printfn "*******************----- catch" catch exn ) - sm.__jsr<'T> ENTRY + sm.__jmp<'T> ENTRY /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). @@ -261,27 +272,23 @@ module TaskHelpers = let ENTRY = sm.__genlabel() let mutable INNER_ENTRY = sm.__code code sm.__gencode ENTRY (fun () -> - printfn "TF step" let mutable step = try - sm.__jsr<'T> INNER_ENTRY + sm.__jmp<'T> INNER_ENTRY // Important point: we use a try/with, not a try/finally, to implement tryFinally. // The reason for this is that if we're just building a continuation, we definitely *shouldn't* // execute the `compensation()` part yet -- the actual execution of the asynchronous code hasn't completed! with _ -> - printfn "************** TF exception" compensation() reraise() if step.IsReturn then - printfn "*******************" compensation() step elif step.IsReturnFrom then - printfn "!!!!!!!!!!!!!!!!!!!!!" let t = step.GetNextTask() let awaitable = t.GetAwaiter() - TaskStep<_>.Await(awaitable, sm.__code (fun () -> + sm.__setpc (sm.__code (fun () -> let result = try awaitable.GetResult() |> TaskStep<_>.Return @@ -290,15 +297,16 @@ module TaskHelpers = reraise() compensation() // if we got here we haven't run compensation(), because we would've reraised after doing so result)) + TaskStep<_>.Await(awaitable) else - let rp = step.GetResumePoint() - TaskStep<'T>.Await (step.GetAwaitable(), - sm.__code (fun () -> - // go back to get inside the try/finally again - INNER_ENTRY <- rp - sm.__jsr<'T> ENTRY)) + let rp = sm.__getpc + sm.__setpc (sm.__code (fun () -> + // go back to get inside the try/finally again + INNER_ENTRY <- rp + sm.__jmp<'T> ENTRY)) + TaskStep<'T>.Await (step.GetAwaitable()) ) - sm.__jsr<'T> ENTRY + sm.__jmp<'T> ENTRY /// Implements a using statement that disposes `disp` after `body` has completed. let inline using (sm: SM) (disp : #IDisposable) (body : _ -> TaskStep<'T>) = @@ -316,56 +324,41 @@ module TaskHelpers = /// Runs a step as a task -- with a short-circuit for immediately completed steps. let inline run (sm: SM) (code : unit -> TaskStep<'T>) = - try - printfn "run..." - let firstStep = code() - if firstStep.IsReturn then - printfn "first step is Return..." - Task.FromResult (firstStep.GetResult()) - elif firstStep.IsReturnFrom then - printfn "first step is ReturnFrom..." - firstStep.GetNextTask() - else - printfn "first step is Await..." - let mutable methodBuilder = AsyncTaskMethodBuilder>() - - let mutable pc = firstStep.GetResumePoint() - let mutable first = true - let mutable machine = - { new IAsyncStateMachine with - - /// Proceed to one of three states: result, failure, or awaiting. - /// If awaiting, MoveNext() will be called again when the awaitable completes. - member this.MoveNext() = - try - printfn "second step, pc = %d..." pc - let step = if first then (first <- false; firstStep) else sm.__jsr<'T> pc - //__code - if step.IsReturn then - let res = step.GetResult() - printfn "step is Return(%A)..." res - methodBuilder.SetResult(Task.FromResult res) - printfn "result set..." - elif step.IsReturnFrom then - printfn "step is ReturnFrom..." - methodBuilder.SetResult (step.GetNextTask()) - else - pc <- step.GetResumePoint() - printfn "step is Await, next pc = %d..." pc - let mutable this = this - let mutable await = step.GetAwaitable() - assert (not (isNull await)) - // Tell the builder to call us again when done. - methodBuilder.AwaitUnsafeOnCompleted(&await, &this) - with exn -> - methodBuilder.SetException exn - - member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. - } - - methodBuilder.Start(&machine) - methodBuilder.Task.Unwrap() + // CODEGEN: TODO: make this a field of the generated object + let mutable methodBuilder = AsyncTaskMethodBuilder>() + + // CODEGEN: generate the code and set the initial PC + do sm.__setpc (sm.__code code) + + let mutable machine = + { new IAsyncStateMachine with + + /// Proceed to one of three states: result, failure, or awaiting. + /// If awaiting, MoveNext() will be called again when the awaitable completes. + member this.MoveNext() = + try + // CODEGEN: this is a jumptable into the generated code + let step = sm.__jmp<'T> sm.__getpc + if step.IsReturn then + let res = step.GetResult() + methodBuilder.SetResult(Task.FromResult res) + elif step.IsReturnFrom then + methodBuilder.SetResult (step.GetNextTask()) + else + let mutable this = this + let mutable await = step.GetAwaitable() + assert (not (isNull await)) + // Tell the builder to call us again when done. + methodBuilder.AwaitUnsafeOnCompleted(&await, &this) + with exn -> + methodBuilder.SetException exn + + member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. + } + try + methodBuilder.Start(&machine) + methodBuilder.Task.Unwrap() with exn -> // Any exceptions should go on the task, rather than being thrown from this call. // This matches C# behavior where you won't see an exception until awaiting the task, diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index 96ee4e5180f..7a95c90be30 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -28,13 +28,12 @@ open Microsoft.FSharp.Collections [] type TaskStep<'T> = static member Return : 'T -> TaskStep<'T> - static member Await : ICriticalNotifyCompletion * int -> TaskStep<'T> + static member Await : ICriticalNotifyCompletion -> TaskStep<'T> static member ReturnFrom : Task<'T> -> TaskStep<'T> member IsReturn : bool member IsReturnFrom : bool member IsAwait : bool member GetAwaitable: unit -> ICriticalNotifyCompletion - member GetResumePoint: unit -> int member GetNextTask: unit -> Task<'T> member GetResult: unit -> 'T @@ -45,11 +44,9 @@ module TaskHelpers = member __genlabel: unit -> int member __gencode: int -> (unit -> TaskStep<'T>) -> unit member __code: (unit -> TaskStep<'T>) -> int - member __jsr<'T> : int -> TaskStep<'T> -// val __jumptable : int -> unit -// val __jsr : int -> 'T -// val __label : int -> unit -// val __resume: (unit -> TaskStep<_>) -> int + member __jmp<'T> : int -> TaskStep<'T> + member __getpc : int + member __setpc : int -> unit type TaskBuilder = new: unit -> TaskBuilder From 625170d2e7af00e06642c3df721401c0c010b835 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 30 Apr 2019 00:03:22 +0100 Subject: [PATCH 23/45] butcher code again for codegen approximation (does not run) --- src/fsharp/FSharp.Core/tasks.fs | 509 ++++++++---------- src/fsharp/FSharp.Core/tasks.fsi | 114 ++-- .../Microsoft.FSharp.Control/Tasks.fs | 15 +- 3 files changed, 285 insertions(+), 353 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index d34381ea33a..5873b2fb26c 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -12,6 +12,10 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. namespace Microsoft.FSharp.Core.CompilerServices + + open System.Runtime.CompilerServices + open Microsoft.FSharp.Core + /// A marker interface to give priority to different available overloads type IPriority3 = interface end @@ -21,6 +25,32 @@ namespace Microsoft.FSharp.Core.CompilerServices /// A marker interface to give priority to different available overloads type IPriority1 = interface inherit IPriority2 end + module CodeGenHelpers = + + [] + let __codeWithEntryPoints<'T> (_x:int) (_f: unit -> 'T) : 'T = Unchecked.defaultof<_> + + [] + let __newLabel() : int = 0 + + [] + let __newEntryPoint() : int = 0 + + [] + let __code<'T> (_f: unit -> 'T) : 'T = Unchecked.defaultof<_> + + [] + let __label (_n: int) : unit = Unchecked.defaultof<_> + + [] + let __return () : 'T = Unchecked.defaultof<_> + + [] + let __entryPoint<'T> (_n: int) (_f: unit -> 'T) : 'T = Unchecked.defaultof<_> + + [] + let __goto<'T> (_n: int) : 'T = Unchecked.defaultof<_> + #if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE namespace Microsoft.FSharp.Control @@ -30,6 +60,7 @@ open System.Threading.Tasks open Microsoft.FSharp.Core open Microsoft.FSharp.Core.Printf open Microsoft.FSharp.Core.CompilerServices +open Microsoft.FSharp.Core.CompilerServices.CodeGenHelpers open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators open Microsoft.FSharp.Control open Microsoft.FSharp.Collections @@ -40,68 +71,76 @@ open Microsoft.FSharp.Collections // Uses a struct-around-single-reference to allow future changes in representation (the representation is // not revealed in the signature) [] -type TaskStep<'T>(action: int, data: obj) = - static member Return (x: 'T) = TaskStep<'T>(0, box x) - static member ReturnFrom (task: Task<'T>) = TaskStep<'T>(1, box task) - static member Await (completion: ICriticalNotifyCompletion) = TaskStep<'T>(2, box completion) - member __.IsReturn = (action = 0) - member __.IsReturnFrom = (action = 1) - member __.IsAwait = (action = 2) - member __.GetAwaitable() = (data :?> ICriticalNotifyCompletion) - member __.GetNextTask() = (data :?> Task<'T>) - member __.GetResult() = (data :?> 'T) - - //| Return of 'T - //| ReturnFrom of Task<'T> - //| Await of ICriticalNotifyCompletion * (unit -> TaskStep<'T>) +type TaskStep<'T>(completed: bool) = + member __.IsCompleted = completed + +[] +type TaskStateMachine() = + member val ResumptionPoint : int = 0 with get, set + member val Completion : ICriticalNotifyCompletion = null with get, set + member val Current : obj = null with get, set + +[] +type TaskStateMachine<'T>() = + inherit TaskStateMachine() + + let mutable methodBuilder = AsyncTaskMethodBuilder>() + + /// Proceed to the next state or raise an exception + // CODEGEN: this is a jumptable into the generated code + abstract Step : pc: int -> TaskStep<'T> + + interface IAsyncStateMachine with + + member this.MoveNext() = + try + let step = this.Step this.ResumptionPoint + if step.IsCompleted then + let res = unbox<'T>(this.Current) + methodBuilder.SetResult(Task.FromResult res) + else + let mutable this = this + let mutable await = this.Completion + assert (not (isNull await)) + // Tell the builder to call us again when done. + methodBuilder .AwaitUnsafeOnCompleted(&await, &this) + with exn -> + methodBuilder.SetException exn + + member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. + + member this.Start() = + let mutable machine = (this :> IAsyncStateMachine) + try + methodBuilder.Start(&machine) + methodBuilder.Task.Unwrap() + with exn -> + // Any exceptions should go on the task, rather than being thrown from this call. + // This matches C# behavior where you won't see an exception until awaiting the task, + // even if it failed before reaching the first "await". + let src = new TaskCompletionSource<_>() + src.SetException exn + src.Task + [] module TaskHelpers = - //let __jumptable (_x:int) = () - - type SM() = - let mutable conts = ResizeArray<(unit -> obj)>() - let mutable pc = 0 - member __.__genlabel() = - let v = conts.Count - conts.Add(Unchecked.defaultof<_>) - v - - member __.__gencode n (f: unit -> TaskStep<'T>) = - conts.[n] <- (f >> box) - - member sm.__code (f: unit -> TaskStep<'T>) = - let n = sm.__genlabel () - sm.__gencode n f - n - - member __.__jmp<'T> n = - match conts.[n]() with - | :? TaskStep<'T> as t -> t - | res -> - printfn "T = %A" typeof<'T> - printfn "res.GetType() = %A" (res.GetType()) - failwith "invalid type" - member __.__setpc v = pc <- v - member __.__getpc = pc - //-> unit (* unit -> TasskStep<'T> *) //let inline unwrapException (agg : AggregateException) = // let inners = agg.InnerExceptions // if inners.Count = 1 then inners.[0] // else agg :> Exception - /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. - let inline zero() = TaskStep.Return () - /// Used to return a value. - let inline ret (x : 'T) = TaskStep<'T>.Return x + let inline ret<'T> (sm: TaskStateMachine) (x : 'T) = + sm.Current <- (box x) + TaskStep<'T>(true) - let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2 when (^Priority or ^TaskLike): (static member CanBind : SM * ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) > (sm: SM) (x: ^Priority) (y: ^TaskLike) k = - ((^Priority or ^TaskLike): (static member CanBind : SM * ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) (sm, x, y, k)) + let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2 when (^Priority or ^TaskLike): (static member CanBind : TaskStateMachine * ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) > (sm: TaskStateMachine) (x: ^Priority) (y: ^TaskLike) k = + ((^Priority or ^TaskLike): (static member CanBind : TaskStateMachine * ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) (sm, x, y, k)) - let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T when (^Priority or ^TaskLike): (static member CanReturnFrom: SM * ^Priority * ^TaskLike -> TaskStep<'T>)> (sm: SM) (x: ^Priority) (y: ^TaskLike) = - ((^Priority or ^TaskLike): (static member CanReturnFrom : SM * ^Priority * ^TaskLike -> TaskStep<'T>) (sm, x, y)) + let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T when (^Priority or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * ^Priority * ^TaskLike -> TaskStep<'T>)> (sm: TaskStateMachine) (x: ^Priority) (y: ^TaskLike) = + ((^Priority or ^TaskLike): (static member CanReturnFrom : TaskStateMachine * ^Priority * ^TaskLike -> TaskStep<'T>) (sm, x, y)) type TaskLikeBind<'TResult2> = // We put the output generic parameter up here at the class level, so it doesn't get subject to @@ -120,19 +159,16 @@ module TaskHelpers = and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) and ^Awaiter : (member GetResult : unit -> ^TResult1) > - (sm: SM, awaitable : ^Awaitable, continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = + (sm: TaskStateMachine, awaitable : ^Awaitable, continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = let awaiter = (^Awaitable : (member GetAwaiter : unit -> ^Awaiter)(awaitable)) // get an awaiter from the awaitable - let ENTRY = sm.__genlabel () - let CONT = sm.__genlabel () - sm.__gencode ENTRY (fun () -> - if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately - sm.__jmp<'TResult2> CONT - else - sm.__setpc CONT - TaskStep<'TResult2>.Await (awaiter)) - sm.__gencode CONT (fun () -> - continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter))) - sm.__jmp ENTRY + let CONT = __newEntryPoint () + if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately + __entryPoint> CONT (fun () -> + continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter))) + else + sm.ResumptionPoint <- CONT + sm.Completion <- awaiter + TaskStep<'TResult2>(false) static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) @@ -146,248 +182,137 @@ module TaskHelpers = /// Special case of the above for `Task<'TResult1>`. Have to write this T by hand to avoid confusing the compiler /// trying to decide between satisfying the constraints with `Task` or `Task<'TResult1>`. - let inline bindTask (sm: SM) (task : Task<'TResult1>) (continuation : 'TResult1 -> TaskStep<'TResult2>) = + let inline bindTask (sm: TaskStateMachine) (task : Task<'TResult1>) (continuation : 'TResult1 -> TaskStep<'TResult2>) = + let CONT = __newEntryPoint() let awaiter = task.GetAwaiter() - let mutable result = Unchecked.defaultof<_> - let ENTRY = sm.__genlabel() - let CONT = sm.__genlabel() - sm.__gencode ENTRY (fun () -> - if awaiter.IsCompleted then - // Continue directly - sm.__jmp<'TResult2> CONT - else - // Await and continue later when a result is available. - sm.__setpc CONT - TaskStep<'TResult2>.Await (awaiter) - ) - sm.__gencode CONT (fun () -> - result <- awaiter.GetResult() - continuation result - ) - sm.__jmp ENTRY + if awaiter.IsCompleted then + __entryPoint> CONT (fun () -> + continuation (awaiter.GetResult()) + ) + else + // Await and continue later when a result is available. + sm.ResumptionPoint <- CONT + sm.Completion <- awaiter + TaskStep<'TResult2>(false) /// Special case of the above for `Task<'TResult1>`, for the context-insensitive builder. /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method /// defined on the builder has fancy generic constraints on inp and T parameters. - let inline bindTaskConfigureFalse (sm: SM) (task : Task<'TResult1>) (continuation : 'TResult1 -> TaskStep<'TResult2>) = + let inline bindTaskConfigureFalse (sm: TaskStateMachine) (task : Task<'TResult1>) (continuation : 'TResult1 -> TaskStep<'TResult2>) = + let CONT = __newEntryPoint () let awaiter = task.ConfigureAwait(false).GetAwaiter() - // codegen - let ENTRY = sm.__genlabel () - let CONT = sm.__genlabel () - sm.__gencode ENTRY (fun () -> - if awaiter.IsCompleted then - // Continue directly - sm.__jmp<'TResult2> CONT - else - // Await and continue later when a result is available. - sm.__setpc CONT - TaskStep<'TResult2>.Await (awaiter) - ) - sm.__gencode CONT (fun () -> - continuation (awaiter.GetResult()) - ) - // execute - sm.__jmp ENTRY + if awaiter.IsCompleted then + __entryPoint> CONT (fun () -> + continuation (awaiter.GetResult()) + ) + else + // Await and continue later when a result is available. + sm.ResumptionPoint <- CONT + sm.Completion <- awaiter + TaskStep<'TResult2>(false) + +type TaskBuild<'T> = TaskStateMachine -> TaskStep<'T> + +// New style task builder. +type TaskBuilder() = + // These methods are consistent between all builders. + member inline __.Delay(f : unit -> TaskBuild<'T>) = (fun sm -> f () sm) + + member inline __.Run(code : TaskBuild<'T>) = + let sm = + { new TaskStateMachine<'T>() with + member sm.Step(pc) = __codeWithEntryPoints pc (fun () -> code sm) } + sm.Start() + + /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. + member inline __.Zero() : TaskBuild = (fun sm -> + sm.Current <- (box ()) + TaskStep(true)) + + member inline __.Return (x: 'T) : TaskBuild<'T> = (fun sm -> + sm.Current <- (box x) + TaskStep<'T>(true)) /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. - let inline combine (sm: SM) (step : TaskStep) (continuation : unit -> TaskStep<'T>) : TaskStep<'T> = - let mutable step = step - let ENTRY = sm.__genlabel () - let CONT = sm.__genlabel () - sm.__gencode ENTRY (fun () -> - if step.IsReturn then - sm.__jmp<'T> CONT - elif step.IsReturnFrom then - let t = step.GetNextTask() - sm.__setpc CONT - TaskStep<'T>.Await (t.GetAwaiter()) - else - // CODEGEN: TODO: this doesn't feel right, we are not jumping to a label - // CODEGEN: instead, all code paths should end up executing the continuation - // - // Whenever an Await has been generated elsewhere, the pc has already been set to - // the resumption point. - let rp = sm.__getpc - sm.__setpc (sm.__code (fun () -> - step <- sm.__jmp rp - sm.__jmp<'T> ENTRY)) - TaskStep<'T>.Await (step.GetAwaitable())) - - sm.__gencode CONT (fun () -> - continuation ()) - - sm.__jmp ENTRY + member inline __.Combine(step : TaskBuild, continuation: unit -> TaskBuild<'T>) : TaskBuild<'T> = (fun sm -> + let step = step sm + if step.IsCompleted then + continuation () sm + else + TaskStep<'T>(false)) /// Builds a step that executes the body while the condition predicate is true. - let inline whileLoop (sm: SM) (cond : unit -> bool) (body : unit -> TaskStep) : TaskStep = - let ENTRY = sm.__genlabel() - sm.__gencode ENTRY (fun () -> - if cond() then - combine sm (body()) (fun () -> sm.__jmp ENTRY) + member inline __.While(condition : unit -> bool, body : unit -> TaskBuild) : TaskBuild = (fun sm -> + let ENTRY = __newLabel() + __label ENTRY + let guard = __code condition + if guard then + let step = __code (fun () -> body () sm) + if step.IsCompleted then + __goto> ENTRY else - zero()) - sm.__jmp ENTRY + TaskStep(false) + else + sm.Current <- (box ()) + TaskStep(true)) /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - let inline tryWith (sm: SM) (code : unit -> TaskStep<'T>) (catch : exn -> TaskStep<'T>) : TaskStep<'T> = - let ENTRY = sm.__genlabel() - // On resume, we have to go through into the INNER_ENTRY protected by the try/with - let mutable INNER_ENTRY = sm.__code code - sm.__gencode ENTRY (fun () -> - try - let step = sm.__jmp<'T> INNER_ENTRY - if step.IsReturn then - step - elif step.IsReturnFrom then - let t = step.GetNextTask() - let awaitable = t.GetAwaiter() - sm.__setpc (sm.__code (fun () -> - try - // note, this may raise exceptions, but the code is generated in the context of the try-with - awaitable.GetResult() |> TaskStep<_>.Return - with exn -> - catch exn)) - TaskStep<'T>.Await(awaitable) - else - // CODEGEN: This can be: - // pc <- step.GetResumeLabel() - // TaskStep<_>.Await (step.GetAwaitable()) - let rp = sm.__getpc - sm.__setpc (sm.__code (fun () -> - INNER_ENTRY <- rp - sm.__jmp<'T> ENTRY)) - TaskStep<_>.Await (step.GetAwaitable()) - with exn -> - catch exn - ) - sm.__jmp<'T> ENTRY - - /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function - /// to retrieve the step, and in the continuation of the step (if any). - let inline tryFinally (sm: SM) (code : unit -> TaskStep<'T>) compensation = + member inline __.TryWith(body : unit -> TaskBuild<'T>, catch : exn -> TaskBuild<'T>) : TaskBuild<'T> = (fun sm -> + try + let CODE = __newLabel() + __label CODE + __code> (fun () -> body () sm) + with exn -> + catch exn sm) + + member inline __.TryFinally(body : unit -> TaskBuild<'T>, compensation : unit -> unit) = (fun sm -> + /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function + /// to retrieve the step, and in the continuation of the step (if any). // codegen - let ENTRY = sm.__genlabel() - let mutable INNER_ENTRY = sm.__code code - sm.__gencode ENTRY (fun () -> - let mutable step = - try - sm.__jmp<'T> INNER_ENTRY - // Important point: we use a try/with, not a try/finally, to implement tryFinally. - // The reason for this is that if we're just building a continuation, we definitely *shouldn't* - // execute the `compensation()` part yet -- the actual execution of the asynchronous code hasn't completed! - with _ -> - compensation() - reraise() - - if step.IsReturn then + let step = + try + let CODE = __newLabel() + __label CODE + __code> (fun () -> body () sm) + with _ -> compensation() - step - elif step.IsReturnFrom then - let t = step.GetNextTask() - let awaitable = t.GetAwaiter() - sm.__setpc (sm.__code (fun () -> - let result = - try - awaitable.GetResult() |> TaskStep<_>.Return - with _ -> - compensation() - reraise() - compensation() // if we got here we haven't run compensation(), because we would've reraised after doing so - result)) - TaskStep<_>.Await(awaitable) - else - let rp = sm.__getpc - sm.__setpc (sm.__code (fun () -> - // go back to get inside the try/finally again - INNER_ENTRY <- rp - sm.__jmp<'T> ENTRY)) - TaskStep<'T>.Await (step.GetAwaitable()) - ) - sm.__jmp<'T> ENTRY - - /// Implements a using statement that disposes `disp` after `body` has completed. - let inline using (sm: SM) (disp : #IDisposable) (body : _ -> TaskStep<'T>) = + reraise() + + if step.IsCompleted then + compensation() + step) + + member inline this.Using(disp : #IDisposable, body : #IDisposable -> TaskBuild<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. - tryFinally sm - (fun () -> body disp) - (fun () -> if not (isNull (box disp)) then disp.Dispose()) + this.TryFinally( + (fun () -> body disp), + (fun () -> if not (isNull (box disp)) then disp.Dispose())) - /// Implements a loop that runs `body` for each element in `sequence`. - let inline forLoop sm (sequence : seq<'T>) (body : 'T -> TaskStep) = + member inline this.For(sequence : seq<'T>, body : 'T -> TaskBuild) : TaskBuild = // A for loop is just a using statement on the sequence's enumerator... - using sm (sequence.GetEnumerator()) + this.Using (sequence.GetEnumerator(), // ... and its body is a while loop that advances the enumerator and runs the body on each element. - (fun e -> whileLoop sm e.MoveNext (fun () -> body e.Current)) + (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> body e.Current)))) - /// Runs a step as a task -- with a short-circuit for immediately completed steps. - let inline run (sm: SM) (code : unit -> TaskStep<'T>) = - // CODEGEN: TODO: make this a field of the generated object - let mutable methodBuilder = AsyncTaskMethodBuilder>() - - // CODEGEN: generate the code and set the initial PC - do sm.__setpc (sm.__code code) - - let mutable machine = - { new IAsyncStateMachine with - - /// Proceed to one of three states: result, failure, or awaiting. - /// If awaiting, MoveNext() will be called again when the awaitable completes. - member this.MoveNext() = - try - // CODEGEN: this is a jumptable into the generated code - let step = sm.__jmp<'T> sm.__getpc - if step.IsReturn then - let res = step.GetResult() - methodBuilder.SetResult(Task.FromResult res) - elif step.IsReturnFrom then - methodBuilder.SetResult (step.GetNextTask()) - else - let mutable this = this - let mutable await = step.GetAwaitable() - assert (not (isNull await)) - // Tell the builder to call us again when done. - methodBuilder.AwaitUnsafeOnCompleted(&await, &this) - with exn -> - methodBuilder.SetException exn - - member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. - } - - try - methodBuilder.Start(&machine) - methodBuilder.Task.Unwrap() - with exn -> - // Any exceptions should go on the task, rather than being thrown from this call. - // This matches C# behavior where you won't see an exception until awaiting the task, - // even if it failed before reaching the first "await". - let src = new TaskCompletionSource<_>() - src.SetException exn - src.Task + member inline __.ReturnFrom (task: Task<'T>) : TaskBuild<'T> = (fun sm -> + let CONT = __newEntryPoint () + if task.IsCompleted then + __entryPoint CONT (fun () -> + sm.Current <- (box task.Result) + TaskStep<'T>(true)) + else + sm.ResumptionPoint <- CONT + sm.Completion <- task.GetAwaiter() + TaskStep<'T>(false)) -// New style task builder. -type TaskBuilder() = - let _sm = SM() - // These methods are consistent between all builders. - member inline __.Delay(f : unit -> TaskStep<'T>) = f - member inline this.Run(f : unit -> TaskStep<'T>) = run this.SM f - member inline __.Zero() = zero() - member inline __.Return(x) = ret x - member inline this.Combine(step : TaskStep, continuation) = combine this.SM step continuation - member inline this.While(condition : unit -> bool, body : unit -> TaskStep) = whileLoop this.SM condition body - member inline this.For(sequence : seq<'T>, body : 'T -> TaskStep) = forLoop this.SM sequence body - member inline this.TryWith(body : unit -> TaskStep<'T>, catch : exn -> TaskStep<'T>) = tryWith this.SM body catch - member inline this.TryFinally(body : unit -> TaskStep<'T>, compensation : unit -> unit) = tryFinally this.SM body compensation - member inline this.Using(disp : #IDisposable, body : #IDisposable -> TaskStep<'T>) = using this.SM disp body - member inline __.ReturnFrom (task: Task<'T>) : TaskStep<'T> = TaskStep<_>.ReturnFrom task - member __.SM = _sm [] module ContextSensitiveTasks = - let task<'T> = TaskBuilder() + let task = TaskBuilder() [] type Witnesses() = @@ -417,24 +342,24 @@ module ContextSensitiveTasks = and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T)> (sm, _priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T > - = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T> (sm, taskLike, ret) + = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T> (sm, taskLike, ret< ^T > sm) static member inline CanReturnFrom (sm, _priority: IPriority1, computation : Async<'T>) - = bindTask sm (Async.StartAsTask computation) ret : TaskStep<'T> + = bindTask sm (Async.StartAsTask computation) (ret< 'T > sm) : TaskStep<'T> type TaskBuilder with member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 - when (Witnesses or ^TaskLike): (static member CanBind: SM * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> - (task: ^TaskLike, continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> - = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> builder.SM Unchecked.defaultof task continuation + when (Witnesses or ^TaskLike): (static member CanBind: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> + (task: ^TaskLike, continuation: ^TResult1 -> TaskBuild<'TResult2>) : TaskBuild<'TResult2> + = (fun sm -> RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> sm Unchecked.defaultof task (fun x -> continuation x sm)) - member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: SM * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> - = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> builder.SM Unchecked.defaultof task + member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskBuild<'T> + = (fun sm -> RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> sm Unchecked.defaultof task) module ContextInsensitiveTasks = - let task<'T> = TaskBuilder() + let task = TaskBuilder() [] type Witnesses() = @@ -457,9 +382,11 @@ module ContextInsensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1)> (sm, _priority: IPriority2, configurableTaskLike: ^TaskLike, k: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> = TaskLikeBind<'TResult2>.GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1> (sm, configurableTaskLike, k) - static member inline CanBind (sm, _priority :IPriority1, task: Task<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> = bindTaskConfigureFalse sm task k + static member inline CanBind (sm, _priority :IPriority1, task: Task<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = bindTaskConfigureFalse sm task k - static member inline CanBind (sm, _priority: IPriority1, computation : Async<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> = bindTaskConfigureFalse sm (Async.StartAsTask computation) k + static member inline CanBind (sm, _priority: IPriority1, computation : Async<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = bindTaskConfigureFalse sm (Async.StartAsTask computation) k (* static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T @@ -484,11 +411,11 @@ module ContextInsensitiveTasks = type TaskBuilder with member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 - when (Witnesses or ^TaskLike): (static member CanBind: SM * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> - (task: ^TaskLike, continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> - = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> builder.SM Unchecked.defaultof task continuation + when (Witnesses or ^TaskLike): (static member CanBind: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> + (task: ^TaskLike, continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskBuild<'TResult2> + = (fun sm -> RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> sm Unchecked.defaultof task continuation) (* - member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: SM * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> - = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> builder.SM Unchecked.defaultof task + member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> builder.TaskStateMachine Unchecked.defaultof task *) #endif diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index 7a95c90be30..18dd7e5b90a 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -4,6 +4,8 @@ namespace Microsoft.FSharp.Core.CompilerServices + open Microsoft.FSharp.Core + /// A marker interface to give priority to different available overloads type IPriority3 = interface end @@ -13,6 +15,15 @@ namespace Microsoft.FSharp.Core.CompilerServices /// A marker interface to give priority to different available overloads type IPriority1 = interface inherit IPriority2 end + module CodeGenHelpers = + val __codeWithEntryPoints<'T> : int -> (unit -> 'T) -> 'T + val __newLabel: unit -> int + val __newEntryPoint: unit -> int + val __entryPoint: int -> (unit -> 'T) -> 'T + val __code: (unit -> 'T) -> 'T + val __goto : int -> 'T + val __return : unit -> 'T + #if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE namespace Microsoft.FSharp.Control @@ -27,48 +38,45 @@ open Microsoft.FSharp.Collections /// Represents the state of a computation: either awaiting something with a continuation, or completed with a return value. [] type TaskStep<'T> = - static member Return : 'T -> TaskStep<'T> - static member Await : ICriticalNotifyCompletion -> TaskStep<'T> - static member ReturnFrom : Task<'T> -> TaskStep<'T> - member IsReturn : bool - member IsReturnFrom : bool - member IsAwait : bool - member GetAwaitable: unit -> ICriticalNotifyCompletion - member GetNextTask: unit -> Task<'T> - member GetResult: unit -> 'T - -[] -module TaskHelpers = - type SM = - new : unit -> SM - member __genlabel: unit -> int - member __gencode: int -> (unit -> TaskStep<'T>) -> unit - member __code: (unit -> TaskStep<'T>) -> int - member __jmp<'T> : int -> TaskStep<'T> - member __getpc : int - member __setpc : int -> unit + new : bool -> TaskStep<'T> + member IsCompleted : bool + +[] +type TaskStateMachine = + new : unit -> TaskStateMachine + member ResumptionPoint : int with get, set + member Completion : ICriticalNotifyCompletion with get, set + member Current : obj with get, set + +[] +type TaskStateMachine<'T> = + inherit TaskStateMachine + new : unit -> TaskStateMachine<'T> + abstract Step : pc: int -> TaskStep<'T> + interface IAsyncStateMachine + +type TaskBuild<'T> = TaskStateMachine -> TaskStep<'T> type TaskBuilder = new: unit -> TaskBuilder - member inline Combine: step: TaskStep * continuation: (unit -> TaskStep<'T>) -> TaskStep<'T> - member inline Delay: f: (unit -> TaskStep<'T>) -> (unit -> TaskStep<'T>) - member inline For: sequence: seq<'T> * body: ('T -> TaskStep) -> TaskStep - member inline Return: x: 'T -> TaskStep<'T> - member inline ReturnFrom: task: Task<'T> -> TaskStep<'T> - member inline Run: f: (unit -> TaskStep<'T>) -> Task<'T> - member inline TryFinally: body: (unit -> TaskStep<'T>) * fin: (unit -> unit) -> TaskStep<'T> - member inline TryWith: body: (unit -> TaskStep<'T>) * catch: (exn -> TaskStep<'T>) -> TaskStep<'T> - member inline Using: disp: 'Resource * body: ('Resource -> TaskStep<'T>) -> TaskStep<'T> when 'Resource :> IDisposable - member inline While: condition: (unit -> bool) * body: (unit -> TaskStep) -> TaskStep - member inline Zero: unit -> TaskStep - member SM: SM + member inline Combine: step: TaskBuild * continuation: (unit -> TaskBuild<'T>) -> TaskBuild<'T> + member inline Delay: f: (unit -> TaskBuild<'T>) -> TaskBuild<'T> + member inline For: sequence: seq<'T> * body: ('T -> TaskBuild) -> TaskBuild + member inline Return: x: 'T -> TaskBuild<'T> + member inline ReturnFrom: task: Task<'T> -> TaskBuild<'T> + member inline Run: code: TaskBuild<'T> -> Task<'T> + member inline TryFinally: body: (unit -> TaskBuild<'T>) * fin: (unit -> unit) -> TaskBuild<'T> + member inline TryWith: body: (unit -> TaskBuild<'T>) * catch: (exn -> TaskBuild<'T>) -> TaskBuild<'T> + member inline Using: disp: 'Resource * body: ('Resource -> TaskBuild<'T>) -> TaskBuild<'T> when 'Resource :> IDisposable + member inline While: condition: (unit -> bool) * body: (unit -> TaskBuild) -> TaskBuild + member inline Zero: unit -> TaskBuild [] module ContextSensitiveTasks = /// Builds a `System.Threading.Tasks.Task<'T>` similarly to a C# async/await method. /// Use this like `task { let! taskResult = someTask(); return taskResult.ToString(); }`. - val task<'T> : TaskBuilder + val task : TaskBuilder /// Provides evidence that various types can be used in bind and return constructs in task computation expressions [] @@ -79,36 +87,36 @@ module ContextSensitiveTasks = /// Provides evidence that task-like types can be used in 'bind' in a task computation expression static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > - : sm: SM * priority: IPriority2 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep< 'TResult2>) -> TaskStep< 'TResult2> + : sm: TaskStateMachine * priority: IPriority2 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep< 'TResult2>) -> TaskStep< 'TResult2> when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression - static member inline CanBind: sm: SM * priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: sm: TaskStateMachine * priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> /// Provides evidence that F# Async computations can be used in 'bind' in a task computation expression - static member inline CanBind: sm: SM * priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: sm: TaskStateMachine * priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> /// Provides evidence that task-like types can be used in 'return' in a task workflow - static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T> : sm: SM * priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T > + static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T> : sm: TaskStateMachine * priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T > when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T) /// Provides evidence that F# Async computations can be used in 'return' in a task computation expression - static member inline CanReturnFrom: sm: SM * IPriority1 * computation: Async<'T> -> TaskStep<'T> + static member inline CanReturnFrom: sm: TaskStateMachine * IPriority1 * computation: Async<'T> -> TaskStep<'T> type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> - when (Witnesses or ^TaskLike): (static member CanBind: SM * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskBuild<'TResult2>) -> TaskBuild<'TResult2> + when (Witnesses or ^TaskLike): (static member CanBind: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics - member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult > - when (Witnesses or ^TaskLike): (static member CanReturnFrom: SM * Witnesses * ^TaskLike -> TaskStep<'TResult>) + member inline ReturnFrom: a: ^TaskLike -> TaskBuild< 'TResult > + when (Witnesses or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'TResult>) module ContextInsensitiveTasks = @@ -117,7 +125,7 @@ module ContextInsensitiveTasks = /// /// This is often preferable when writing library code that is not context-aware, but undesirable when writing /// e.g. code that must interact with user interface controls on the same thread as its caller. - val task<'T> : TaskBuilder + val task : TaskBuilder /// Provides evidence that various types can be used in bind and return constructs in task computation expressions [] @@ -127,14 +135,14 @@ module ContextInsensitiveTasks = interface IPriority3 /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > : sm: SM * priority: IPriority3 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > : sm: TaskStateMachine * priority: IPriority3 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter > : sm: SM * priority: IPriority2 * taskLike: ^TaskLike * k: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter > : sm: TaskStateMachine * priority: IPriority2 * taskLike: ^TaskLike * k: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion @@ -142,14 +150,14 @@ module ContextInsensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression - static member inline CanBind: sm: SM * priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: sm: TaskStateMachine * priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> /// Provides evidence that F# async computations can be used in 'bind' in a task computation expression - static member inline CanBind: sm: SM * priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: sm: TaskStateMachine * priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> (* /// Provides evidence that types following the "awaitable" pattern can be used in 'return!' in a task computation expression - static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T> : sm: SM * IPriority2 * taskLike: ^Awaitable -> TaskStep< ^T> + static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T> : sm: TaskStateMachine * IPriority2 * taskLike: ^Awaitable -> TaskStep< ^T> when ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) @@ -161,22 +169,22 @@ module ContextInsensitiveTasks = and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^T) > : sm: SM * IPriority1 * configurableTaskLike: ^TaskLike -> TaskStep< ^T> + and ^Awaiter : (member GetResult : unit -> ^T) > : sm: TaskStateMachine * IPriority1 * configurableTaskLike: ^TaskLike -> TaskStep< ^T> /// Provides evidence that F# async computations can be used in 'return!' in a task computation expression - static member inline CanReturnFrom: sm: SM * IPriority1 * computation: Async<'T> -> TaskStep<'T> + static member inline CanReturnFrom: sm: TaskStateMachine * IPriority1 * computation: Async<'T> -> TaskStep<'T> *) type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> - when (Witnesses or ^TaskLike): (static member CanBind: sm: SM * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskBuild<'TResult2> + when (Witnesses or ^TaskLike): (static member CanBind: sm: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) (* /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult > - when (Witnesses or ^TaskLike): (static member CanReturnFrom: sm: SM * Witnesses * ^TaskLike -> TaskStep<'TResult>) + when (Witnesses or ^TaskLike): (static member CanReturnFrom: sm: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'TResult>) *) #endif \ No newline at end of file diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs index 7a127cafe6f..cbcc6d69e93 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs @@ -300,7 +300,7 @@ let testForLoop() = do! Task.Yield() printfn "back from yield" do! Task.Yield() - printfn "back from yield again" + printfn "back from yield" match index with | 0 -> require (x = "a") "wrong first value" | 1 -> require (x = "b") "wrong second value" @@ -485,7 +485,7 @@ let test2ndExceptionThrownInFinally() = require (ranFinally = 1) "didn't run finally exactly once" let testFixedStackWhileLoop() = - let bigNumber = 10 // TODO: make this 10000 + let bigNumber = 10000 let t = task { let mutable maxDepth = Nullable() @@ -504,7 +504,7 @@ let testFixedStackWhileLoop() = require (t.Result = bigNumber) "didn't get to big number" let testFixedStackForLoop() = - let bigNumber = 10 // TODO: make this 10000 + let bigNumber = 10000 let mutable ran = false let t = task { @@ -535,22 +535,20 @@ let testTypeInference() = t2.Wait() let testNoStackOverflowWithImmediateResult() = - let bigNumber = 10 // TODO: make this 10000 let longLoop = task { let mutable n = 0 - while n < bigNumber do + while n < 10_000 do n <- n + 1 return! Task.FromResult(()) } longLoop.Wait() let testNoStackOverflowWithYieldResult() = - let bigNumber = 10 // TODO: make this 10000 let longLoop = task { let mutable n = 0 - while n < bigNumber do + while n < 10_000 do let! _ = task { do! Task.Yield() @@ -562,13 +560,12 @@ let testNoStackOverflowWithYieldResult() = longLoop.Wait() let testSmallTailRecursion() = - let bigNumber = 10 // TODO: make this 1000 let shortLoop = task { let rec loop n = task { // larger N would stack overflow on Mono, eat heap mem on MS .NET - if n < bigNumber then + if n < 1000 then do! Task.Yield() let! _ = Task.FromResult(0) return! loop (n + 1) From 126a9cc3911874a33ff20504b13a179022b15bc9 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 30 Apr 2019 18:20:21 +0100 Subject: [PATCH 24/45] sketch of generalized state machine compilation --- src/fsharp/FSharp.Core/tasks.fs | 88 ++-- src/fsharp/FSharp.Core/tasks.fsi | 40 +- src/fsharp/IlxGen.fs | 25 +- src/fsharp/LowerCallsAndSeqs.fs | 485 +++++++++++++++++- src/fsharp/LowerCallsAndSeqs.fsi | 4 + src/fsharp/TcGlobals.fs | 21 + .../Microsoft.FSharp.Control/Tasks.fs | 12 + 7 files changed, 589 insertions(+), 86 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index 5873b2fb26c..d1ab1569043 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -28,7 +28,10 @@ namespace Microsoft.FSharp.Core.CompilerServices module CodeGenHelpers = [] - let __codeWithEntryPoints<'T> (_x:int) (_f: unit -> 'T) : 'T = Unchecked.defaultof<_> + let __jumptable<'T> (_x:int) (_code: 'T) : 'T = Unchecked.defaultof<_> + + [] + let __stateMachine<'T> (x: 'T) : 'T = x [] let __newLabel() : int = 0 @@ -43,7 +46,7 @@ namespace Microsoft.FSharp.Core.CompilerServices let __label (_n: int) : unit = Unchecked.defaultof<_> [] - let __return () : 'T = Unchecked.defaultof<_> + let __return (_v: 'T) : 'U = Unchecked.defaultof<_> [] let __entryPoint<'T> (_n: int) (_f: unit -> 'T) : 'T = Unchecked.defaultof<_> @@ -77,9 +80,11 @@ type TaskStep<'T>(completed: bool) = [] type TaskStateMachine() = member val ResumptionPoint : int = 0 with get, set - member val Completion : ICriticalNotifyCompletion = null with get, set member val Current : obj = null with get, set + /// Await the given awaiter and resume at the given entry point + abstract Await: awaiter : ICriticalNotifyCompletion * pc: int -> unit + [] type TaskStateMachine<'T>() = inherit TaskStateMachine() @@ -87,9 +92,16 @@ type TaskStateMachine<'T>() = let mutable methodBuilder = AsyncTaskMethodBuilder>() /// Proceed to the next state or raise an exception - // CODEGEN: this is a jumptable into the generated code abstract Step : pc: int -> TaskStep<'T> + override sm.Await(awaiter, pc) = + sm.ResumptionPoint <- pc + let mutable sm = sm + let mutable awaiter = awaiter + assert (not (isNull awaiter)) + // Tell the builder to call us again when done. + methodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + interface IAsyncStateMachine with member this.MoveNext() = @@ -98,12 +110,6 @@ type TaskStateMachine<'T>() = if step.IsCompleted then let res = unbox<'T>(this.Current) methodBuilder.SetResult(Task.FromResult res) - else - let mutable this = this - let mutable await = this.Completion - assert (not (isNull await)) - // Tell the builder to call us again when done. - methodBuilder .AwaitUnsafeOnCompleted(&await, &this) with exn -> methodBuilder.SetException exn @@ -166,8 +172,7 @@ module TaskHelpers = __entryPoint> CONT (fun () -> continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter))) else - sm.ResumptionPoint <- CONT - sm.Completion <- awaiter + sm.Await(awaiter, CONT) TaskStep<'TResult2>(false) static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 @@ -190,9 +195,7 @@ module TaskHelpers = continuation (awaiter.GetResult()) ) else - // Await and continue later when a result is available. - sm.ResumptionPoint <- CONT - sm.Completion <- awaiter + sm.Await(awaiter, CONT) TaskStep<'TResult2>(false) /// Special case of the above for `Task<'TResult1>`, for the context-insensitive builder. @@ -206,50 +209,49 @@ module TaskHelpers = continuation (awaiter.GetResult()) ) else - // Await and continue later when a result is available. - sm.ResumptionPoint <- CONT - sm.Completion <- awaiter + sm.Await(awaiter, CONT) TaskStep<'TResult2>(false) -type TaskBuild<'T> = TaskStateMachine -> TaskStep<'T> +type TaskSpec<'T> = TaskStateMachine -> TaskStep<'T> // New style task builder. type TaskBuilder() = // These methods are consistent between all builders. - member inline __.Delay(f : unit -> TaskBuild<'T>) = (fun sm -> f () sm) + member inline __.Delay(f : unit -> TaskSpec<'T>) = (fun sm -> f () sm) - member inline __.Run(code : TaskBuild<'T>) = + member inline __.Run(code : TaskSpec<'T>) = let sm = - { new TaskStateMachine<'T>() with - member sm.Step(pc) = __codeWithEntryPoints pc (fun () -> code sm) } + __stateMachine + { new TaskStateMachine<'T>() with + member sm.Step(pc) = __jumptable pc (code sm) } sm.Start() /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. - member inline __.Zero() : TaskBuild = (fun sm -> + member inline __.Zero() : TaskSpec = (fun sm -> sm.Current <- (box ()) TaskStep(true)) - member inline __.Return (x: 'T) : TaskBuild<'T> = (fun sm -> + member inline __.Return (x: 'T) : TaskSpec<'T> = (fun sm -> sm.Current <- (box x) TaskStep<'T>(true)) /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. - member inline __.Combine(step : TaskBuild, continuation: unit -> TaskBuild<'T>) : TaskBuild<'T> = (fun sm -> - let step = step sm + member inline __.Combine(task1: TaskSpec, task2: TaskSpec<'T>) : TaskSpec<'T> = (fun sm -> + let step = task1 sm if step.IsCompleted then - continuation () sm + task2 sm else TaskStep<'T>(false)) /// Builds a step that executes the body while the condition predicate is true. - member inline __.While(condition : unit -> bool, body : unit -> TaskBuild) : TaskBuild = (fun sm -> + member inline __.While(condition : unit -> bool, body : TaskSpec) : TaskSpec = (fun sm -> let ENTRY = __newLabel() __label ENTRY let guard = __code condition if guard then - let step = __code (fun () -> body () sm) + let step = __code (fun () -> body sm) if step.IsCompleted then __goto> ENTRY else @@ -260,15 +262,15 @@ type TaskBuilder() = /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - member inline __.TryWith(body : unit -> TaskBuild<'T>, catch : exn -> TaskBuild<'T>) : TaskBuild<'T> = (fun sm -> + member inline __.TryWith(body : TaskSpec<'T>, catch : exn -> TaskSpec<'T>) : TaskSpec<'T> = (fun sm -> try let CODE = __newLabel() __label CODE - __code> (fun () -> body () sm) + __code> (fun () -> body sm) with exn -> catch exn sm) - member inline __.TryFinally(body : unit -> TaskBuild<'T>, compensation : unit -> unit) = (fun sm -> + member inline __.TryFinally(body : TaskSpec<'T>, compensation : unit -> unit) = (fun sm -> /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). // codegen @@ -276,7 +278,7 @@ type TaskBuilder() = try let CODE = __newLabel() __label CODE - __code> (fun () -> body () sm) + __code> (fun () -> body sm) with _ -> compensation() reraise() @@ -285,27 +287,27 @@ type TaskBuilder() = compensation() step) - member inline this.Using(disp : #IDisposable, body : #IDisposable -> TaskBuild<'T>) = + member inline this.Using(disp : #IDisposable, body : #IDisposable -> TaskSpec<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. this.TryFinally( - (fun () -> body disp), + (body disp), (fun () -> if not (isNull (box disp)) then disp.Dispose())) - member inline this.For(sequence : seq<'T>, body : 'T -> TaskBuild) : TaskBuild = + member inline this.For(sequence : seq<'T>, body : 'T -> TaskSpec) : TaskSpec = // A for loop is just a using statement on the sequence's enumerator... this.Using (sequence.GetEnumerator(), // ... and its body is a while loop that advances the enumerator and runs the body on each element. - (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> body e.Current)))) + (fun e -> this.While((fun () -> e.MoveNext()), this.Delay (fun () -> body e.Current)))) - member inline __.ReturnFrom (task: Task<'T>) : TaskBuild<'T> = (fun sm -> + member inline __.ReturnFrom (task: Task<'T>) : TaskSpec<'T> = (fun sm -> let CONT = __newEntryPoint () if task.IsCompleted then __entryPoint CONT (fun () -> sm.Current <- (box task.Result) TaskStep<'T>(true)) else + sm.Await(task.GetAwaiter(), CONT) sm.ResumptionPoint <- CONT - sm.Completion <- task.GetAwaiter() TaskStep<'T>(false)) @@ -350,10 +352,10 @@ module ContextSensitiveTasks = type TaskBuilder with member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 when (Witnesses or ^TaskLike): (static member CanBind: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> - (task: ^TaskLike, continuation: ^TResult1 -> TaskBuild<'TResult2>) : TaskBuild<'TResult2> + (task: ^TaskLike, continuation: ^TResult1 -> TaskSpec<'TResult2>) : TaskSpec<'TResult2> = (fun sm -> RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> sm Unchecked.defaultof task (fun x -> continuation x sm)) - member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskBuild<'T> + member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskSpec<'T> = (fun sm -> RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> sm Unchecked.defaultof task) @@ -412,7 +414,7 @@ module ContextInsensitiveTasks = type TaskBuilder with member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 when (Witnesses or ^TaskLike): (static member CanBind: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> - (task: ^TaskLike, continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskBuild<'TResult2> + (task: ^TaskLike, continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskSpec<'TResult2> = (fun sm -> RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> sm Unchecked.defaultof task continuation) (* member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index 18dd7e5b90a..c38751052db 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -16,13 +16,15 @@ namespace Microsoft.FSharp.Core.CompilerServices type IPriority1 = interface inherit IPriority2 end module CodeGenHelpers = - val __codeWithEntryPoints<'T> : int -> (unit -> 'T) -> 'T + val __jumptable : int -> 'T -> 'T + val __stateMachine : 'T -> 'T val __newLabel: unit -> int val __newEntryPoint: unit -> int val __entryPoint: int -> (unit -> 'T) -> 'T val __code: (unit -> 'T) -> 'T + val __return : 'T -> 'U + val __label: int -> unit val __goto : int -> 'T - val __return : unit -> 'T #if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE namespace Microsoft.FSharp.Control @@ -45,8 +47,8 @@ type TaskStep<'T> = type TaskStateMachine = new : unit -> TaskStateMachine member ResumptionPoint : int with get, set - member Completion : ICriticalNotifyCompletion with get, set member Current : obj with get, set + abstract Await: awaiter : ICriticalNotifyCompletion * pc: int -> unit [] type TaskStateMachine<'T> = @@ -54,22 +56,24 @@ type TaskStateMachine<'T> = new : unit -> TaskStateMachine<'T> abstract Step : pc: int -> TaskStep<'T> interface IAsyncStateMachine + override Await: awaiter : ICriticalNotifyCompletion * pc: int -> unit + member Start: unit -> Task<'T> -type TaskBuild<'T> = TaskStateMachine -> TaskStep<'T> +type TaskSpec<'T> = TaskStateMachine -> TaskStep<'T> type TaskBuilder = new: unit -> TaskBuilder - member inline Combine: step: TaskBuild * continuation: (unit -> TaskBuild<'T>) -> TaskBuild<'T> - member inline Delay: f: (unit -> TaskBuild<'T>) -> TaskBuild<'T> - member inline For: sequence: seq<'T> * body: ('T -> TaskBuild) -> TaskBuild - member inline Return: x: 'T -> TaskBuild<'T> - member inline ReturnFrom: task: Task<'T> -> TaskBuild<'T> - member inline Run: code: TaskBuild<'T> -> Task<'T> - member inline TryFinally: body: (unit -> TaskBuild<'T>) * fin: (unit -> unit) -> TaskBuild<'T> - member inline TryWith: body: (unit -> TaskBuild<'T>) * catch: (exn -> TaskBuild<'T>) -> TaskBuild<'T> - member inline Using: disp: 'Resource * body: ('Resource -> TaskBuild<'T>) -> TaskBuild<'T> when 'Resource :> IDisposable - member inline While: condition: (unit -> bool) * body: (unit -> TaskBuild) -> TaskBuild - member inline Zero: unit -> TaskBuild + member inline Combine: task1: TaskSpec * task2: TaskSpec<'T> -> TaskSpec<'T> + member inline Delay: f: (unit -> TaskSpec<'T>) -> TaskSpec<'T> + member inline For: sequence: seq<'T> * body: ('T -> TaskSpec) -> TaskSpec + member inline Return: x: 'T -> TaskSpec<'T> + member inline ReturnFrom: task: Task<'T> -> TaskSpec<'T> + member inline Run: code: TaskSpec<'T> -> Task<'T> + member inline TryFinally: body: TaskSpec<'T> * fin: (unit -> unit) -> TaskSpec<'T> + member inline TryWith: body: TaskSpec<'T> * catch: (exn -> TaskSpec<'T>) -> TaskSpec<'T> + member inline Using: disp: 'Resource * body: ('Resource -> TaskSpec<'T>) -> TaskSpec<'T> when 'Resource :> IDisposable + member inline While: condition: (unit -> bool) * body: TaskSpec -> TaskSpec + member inline Zero: unit -> TaskSpec [] module ContextSensitiveTasks = @@ -111,11 +115,11 @@ module ContextSensitiveTasks = type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskBuild<'TResult2>) -> TaskBuild<'TResult2> + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskSpec<'TResult2>) -> TaskSpec<'TResult2> when (Witnesses or ^TaskLike): (static member CanBind: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics - member inline ReturnFrom: a: ^TaskLike -> TaskBuild< 'TResult > + member inline ReturnFrom: a: ^TaskLike -> TaskSpec< 'TResult > when (Witnesses or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'TResult>) module ContextInsensitiveTasks = @@ -178,7 +182,7 @@ module ContextInsensitiveTasks = type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskBuild<'TResult2> + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskSpec<'TResult2> when (Witnesses or ^TaskLike): (static member CanBind: sm: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) (* diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 09750c4f32d..909efe0af37 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -2151,6 +2151,11 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = GenSequenceExpr cenv cgbuf eenv info sequel | None -> + match LowerCallsAndSeqs.LowerStateMachineExpr g expr with + | Some (objExpr, ty, basev, basecall, overrides, interfaceImpls, stateVars, m) -> + GenObjectExpr cenv cgbuf eenv objExpr (ty, basev, basecall, overrides, interfaceImpls, stateVars, m) sequel + | None -> + match expr with | Expr.Const (c, m, ty) -> GenConstant cenv cgbuf eenv (c, m, ty) sequel @@ -2301,7 +2306,7 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = | Expr.Obj (_, ty, _, _, [meth], [], m) when isDelegateTy g ty -> GenDelegateExpr cenv cgbuf eenv expr (meth, m) sequel | Expr.Obj (_, ty, basev, basecall, overrides, interfaceImpls, m) -> - GenObjectExpr cenv cgbuf eenv expr (ty, basev, basecall, overrides, interfaceImpls, m) sequel + GenObjectExpr cenv cgbuf eenv expr (ty, basev, basecall, overrides, interfaceImpls, [], m) sequel | Expr.Quote (ast, conv, _, m, ty) -> GenQuotation cenv cgbuf eenv (ast, conv, m, ty) sequel | Expr.Link _ -> failwith "Unexpected reclink" @@ -4038,8 +4043,16 @@ and GenObjectMethod cenv eenvinner (cgbuf: CodeGenBuffer) useMethodImpl tmethod let mdef = mdef.With(customAttrs = mkILCustomAttrs ilAttribs) [(useMethodImpl, methodImplGenerator, methTyparsOfOverridingMethod), mdef] -and GenObjectExpr cenv cgbuf eenvouter expr (baseType, baseValOpt, basecall, overrides, interfaceImpls, m) sequel = +and GenObjectExpr cenv cgbuf eenvouter expr (baseType, baseValOpt, basecall, overrides, interfaceImpls, stateVars: ValRef list, m) sequel = let g = cenv.g + + let stateVarsSet = stateVars |> List.map (fun vref -> vref.Deref) |> Zset.ofList valOrder + let eenvouter = eenvouter |> AddStorageForLocalVals g (stateVars |> List.map (fun v -> v.Deref, Local(0, false, None))) + + // Find the free variables of the closure, to make them fields of the object. + // + // Note, the 'let' bindings for the stateVars have already been transformed to 'set' expressions, and thus the stateVars are now + // free variables of the expression. let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m false None eenvouter expr let cloAttribs = cloinfo.cloAttribs @@ -4084,7 +4097,13 @@ and GenObjectExpr cenv cgbuf eenvouter expr (baseType, baseValOpt, basecall, ove for cloTypeDef in cloTypeDefs do cgbuf.mgbuf.AddTypeDef(ilCloTypeRef, cloTypeDef, false, false, None) CountClosure() - GenGetLocalVals cenv cgbuf eenvouter m cloFreeVars + for fv in cloFreeVars do + /// State variables always get zero-initialized + if stateVarsSet.Contains fv then + GenDefaultValue cenv cgbuf eenvouter (fv.Type, m) + else + GenGetLocalVal cenv cgbuf eenvouter m fv None + CG.EmitInstr cgbuf (pop ilCloFreeVars.Length) (Push [ EraseClosures.mkTyOfLambdas g.ilxPubCloEnv ilCloLambdas]) (I_newobj (ilxCloSpec.Constructor, None)) GenSequel cenv eenvouter.cloc cgbuf sequel diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 6bc583faae1..80ca23479e8 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -107,6 +107,12 @@ type LoweredSeqFirstPhaseResult = let isVarFreeInExpr v e = Zset.contains v (freeInExpr CollectTyparsAndLocals e).FreeLocals +let (|ValApp|_|) g vref expr = + match expr with + // use 'seq { ... }' as an indicator + | Expr.App (Expr.Val (vref2, _, _), _f0ty, tyargs, args, m) when valRefEq g vref vref2 -> Some (tyargs, args, m) + | _ -> None + /// Analyze a TAST expression to detect the elaborated form of a sequence expression. /// Then compile it to a state machine represented as a TAST containing goto, return and label nodes. /// The returned state machine will also contain references to state variables (from internal 'let' bindings), @@ -121,42 +127,35 @@ let LowerSeqExpr g amap overallExpr = /// Detect a 'yield x' within a 'seq { ... }' let (|SeqYield|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, _tyargsl, [arg], m) when valRefEq g vref g.seq_singleton_vref -> - Some (arg, m) - | _ -> - None + | ValApp g g.seq_singleton_vref (_, [arg], m) -> Some (arg, m) + | _ -> None /// Detect a 'expr; expr' within a 'seq { ... }' let (|SeqAppend|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, _tyargsl, [arg1;arg2], m) when valRefEq g vref g.seq_append_vref -> - Some (arg1, arg2, m) - | _ -> - None + | ValApp g g.seq_append_vref (_, [arg1; arg2], m) -> Some (arg1, arg2, m) + | _ -> None /// Detect a 'while gd do expr' within a 'seq { ... }' let (|SeqWhile|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, _tyargsl, [Expr.Lambda (_, _, _, [dummyv], gd, _, _);arg2], m) - when valRefEq g vref g.seq_generated_vref && - not (isVarFreeInExpr dummyv gd) -> + | ValApp g g.seq_generated_vref (_, [Expr.Lambda (_, _, _, [dummyv], gd, _, _);arg2], m) + when not (isVarFreeInExpr dummyv gd) -> Some (gd, arg2, m) | _ -> None let (|SeqTryFinally|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, _tyargsl, [arg1;Expr.Lambda (_, _, _, [dummyv], compensation, _, _)], m) - when valRefEq g vref g.seq_finally_vref && - not (isVarFreeInExpr dummyv compensation) -> + | ValApp g g.seq_finally_vref (_, [arg1;Expr.Lambda (_, _, _, [dummyv], compensation, _, _)], m) + when not (isVarFreeInExpr dummyv compensation) -> Some (arg1, compensation, m) | _ -> None let (|SeqUsing|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, [_;_;elemTy], [resource;Expr.Lambda (_, _, _, [v], body, _, _)], m) - when valRefEq g vref g.seq_using_vref -> + | ValApp g g.seq_using_vref ([_;_;elemTy], [resource;Expr.Lambda (_, _, _, [v], body, _, _)], m) -> Some (resource, v, body, elemTy, m) | _ -> None @@ -164,27 +163,29 @@ let LowerSeqExpr g amap overallExpr = let (|SeqFor|_|) expr = match expr with // Nested for loops are represented by calls to Seq.collect - | Expr.App (Expr.Val (vref, _, _), _f0ty, [_inpElemTy;_enumty2;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) when valRefEq g vref g.seq_collect_vref -> + | ValApp g g.seq_collect_vref ([_inpElemTy;_enumty2;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) -> Some (inp, v, body, genElemTy, m) // "for x in e -> e2" is converted to a call to Seq.map by the F# type checker. This could be removed, except it is also visible in F# quotations. - | Expr.App (Expr.Val (vref, _, _), _f0ty, [_inpElemTy;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) when valRefEq g vref g.seq_map_vref -> + | ValApp g g.seq_map_vref ([_inpElemTy;genElemTy], [Expr.Lambda (_, _, _, [v], body, _, _); inp], m) -> Some (inp, v, mkCallSeqSingleton g body.Range genElemTy body, genElemTy, m) | _ -> None let (|SeqDelay|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, [elemTy], [Expr.Lambda (_, _, _, [v], e, _, _)], _m) when valRefEq g vref g.seq_delay_vref && not (isVarFreeInExpr v e) -> Some (e, elemTy) + | ValApp g g.seq_delay_vref ([elemTy], [Expr.Lambda (_, _, _, [v], e, _, _)], _m) + when not (isVarFreeInExpr v e) -> + Some (e, elemTy) | _ -> None let (|SeqEmpty|_|) expr = match expr with - | Expr.App (Expr.Val (vref, _, _), _f0ty, _tyargsl, [], m) when valRefEq g vref g.seq_empty_vref -> Some (m) + | ValApp g g.seq_empty_vref (_, [], m) -> Some (m) | _ -> None let (|Seq|_|) expr = match expr with // use 'seq { ... }' as an indicator - | Expr.App (Expr.Val (vref, _, _), _f0ty, [elemTy], [e], _m) when valRefEq g vref g.seq_vref -> Some (e, elemTy) + | ValApp g g.seq_vref ([elemTy], [e], _m) -> Some (e, elemTy) | _ -> None /// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) @@ -587,7 +588,7 @@ let LowerSeqExpr g amap overallExpr = // Perform phase1 match Lower true true noDisposeContinuationLabel noDisposeContinuationLabel e with | Some res -> - + // After phase1, create the variables for the state machine and work out a program counter for each label. let labs = res.labels let stateVars = res.stateVars @@ -774,3 +775,443 @@ let LowerSeqExpr g amap overallExpr = | _ -> None + +//--------------------------------------------------------------------------------------------- + +type LoweredStateMachineFirstPhaseResult = + { + /// The second phase of the transformation. It is run after all code labels and their mapping to program counters have been determined + /// after the first phase. + /// + phase2 : (Map -> Expr) + + /// The labels allocated for one portion of the sequence expression + labels : int list + + /// The state variables allocated for one portion of the sequence expression (i.e. the local let-bound variables which become state variables) + stateVars: ValRef list + + /// The vars captured by the non-synchronous path + capturedVars: FreeVars + } + + + + +let (|StateMachine|_|) g expr = + match expr with + | ValApp g g.cgh_stateMachine_vref (_, [e], _m) -> Some e + | _ -> None + +let (|JumpTable|_|) g expr = + match expr with + | ValApp g g.cgh_jumptable_vref (_, [pcExpr; codeExpr], _m) -> Some (pcExpr, codeExpr) + | _ -> None + +let LowerStateMachineExpr g overallExpr = + + let rec Lower expr = + Some { phase2 = (fun _ctxt -> expr) + labels=[] + stateVars = [] + capturedVars = emptyFreeVars } + +(* let rec Lower + isWholeExpr + isTailCall // is this sequence in tailcall position? + noDisposeContinuationLabel // represents the label for the code where there is effectively nothing to do to dispose the iterator for the current state + currentDisposeContinuationLabel // represents the label for the code we have to run to dispose the iterator given the current state + expr = + + match expr with + | SeqYield(e, m) -> + // printfn "found Seq.singleton" + //this.pc <- NEXT + //curr <- e + //return true + //NEXT: + let label = IL.generateCodeLabel() + Some { phase2 = (fun (pcVar, currVar, _nextv, pcMap) -> + let generate = + mkCompGenSequential m + (mkValSet m pcVar (mkInt32 g m pcMap.[label])) + (mkSequential SequencePointsAtSeq m + (mkValSet m currVar e) + (mkCompGenSequential m + (Expr.Op (TOp.Return, [], [mkOne g m], m)) + (Expr.Op (TOp.Label label, [], [], m)))) + let dispose = + mkCompGenSequential m + (Expr.Op (TOp.Label label, [], [], m)) + (Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m)) + let checkDispose = + mkCompGenSequential m + (Expr.Op (TOp.Label label, [], [], m)) + (Expr.Op (TOp.Return, [], [mkBool g m (not (noDisposeContinuationLabel = currentDisposeContinuationLabel))], m)) + generate, dispose, checkDispose) + labels=[label] + stateVars=[] + significantClose = false + capturedVars = emptyFreeVars + } + + | SeqDelay(delayedExpr, _elemTy) -> + // printfn "found Seq.delay" + // note, using 'isWholeExpr' here prevents 'seq { yield! e }' and 'seq { 0 .. 1000 }' from being compiled + Lower isWholeExpr isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel delayedExpr + + | SeqAppend(e1, e2, m) -> + // printfn "found Seq.append" + let res1 = Lower false false noDisposeContinuationLabel currentDisposeContinuationLabel e1 + let res2 = Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 + match res1, res2 with + | Some res1, Some res2 -> + + let capturedVars = + if res1.labels.IsEmpty then + res2.capturedVars + else + // All of 'e2' is needed after resuming at any of the labels + unionFreeVars res1.capturedVars (freeInExpr CollectLocals e2) + + Some { phase2 = (fun ctxt -> + let generate1, dispose1, checkDispose1 = res1.phase2 ctxt + let generate2, dispose2, checkDispose2 = res2.phase2 ctxt + let generate = mkCompGenSequential m generate1 generate2 + // Order shouldn't matter here, since disposals actions are linked together by goto's (each ends in a goto). + // However leaving as is for now. + let dispose = mkCompGenSequential m dispose2 dispose1 + let checkDispose = mkCompGenSequential m checkDispose2 checkDispose1 + generate, dispose, checkDispose) + labels= res1.labels @ res2.labels + stateVars = res1.stateVars @ res2.stateVars + significantClose = res1.significantClose || res2.significantClose + capturedVars = capturedVars } + | _ -> + None + + | SeqWhile(guardExpr, bodyExpr, m) -> + // printfn "found Seq.while" + let resBody = Lower false false noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr + match resBody with + | Some res2 -> + let capturedVars = + if res2.labels.IsEmpty then + res2.capturedVars // the whole loopis synchronous, no labels + else + freeInExpr CollectLocals expr // everything is needed on subsequent iterations + + Some { phase2 = (fun ctxt -> + let generate2, dispose2, checkDispose2 = res2.phase2 ctxt + let generate = mkWhile g (SequencePointAtWhileLoop guardExpr.Range, NoSpecialWhileLoopMarker, guardExpr, generate2, m) + let dispose = dispose2 + let checkDispose = checkDispose2 + generate, dispose, checkDispose) + labels = res2.labels + stateVars = res2.stateVars + significantClose = res2.significantClose + capturedVars = capturedVars } + | _ -> + None + + | SeqUsing(resource, v, body, elemTy, m) -> + // printfn "found Seq.using" + let reduction = + mkLet (SequencePointAtBinding body.Range) m v resource + (mkCallSeqFinally g m elemTy body + (mkUnitDelayLambda g m + (mkCallDispose g m v.Type (exprForVal m v)))) + Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction + + | SeqFor(inp, v, body, genElemTy, m) -> + // printfn "found Seq.for" + let inpElemTy = v.Type + let inpEnumTy = mkIEnumeratorTy g inpElemTy + let enumv, enume = mkCompGenLocal m "enum" inpEnumTy + // [[ use enum = inp.GetEnumerator() + // while enum.MoveNext() do + // let v = enum.Current + // body ]] + let reduction = + mkCallSeqUsing g m inpEnumTy genElemTy (callNonOverloadedMethod g amap m "GetEnumerator" (mkSeqTy g inpElemTy) [inp]) + (mkLambdaNoType g m enumv + (mkCallSeqGenerated g m genElemTy (mkUnitDelayLambda g m (callNonOverloadedMethod g amap m "MoveNext" inpEnumTy [enume])) + (mkInvisibleLet m v (callNonOverloadedMethod g amap m "get_Current" inpEnumTy [enume]) + (mkCoerceIfNeeded g (mkSeqTy g genElemTy) (tyOfExpr g body) body)))) + Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction + + | SeqTryFinally(e1, compensation, m) -> + // printfn "found Seq.try/finally" + let innerDisposeContinuationLabel = IL.generateCodeLabel() + let resBody = Lower false false noDisposeContinuationLabel innerDisposeContinuationLabel e1 + match resBody with + | Some res1 -> + let capturedVars = unionFreeVars res1.capturedVars (freeInExpr CollectLocals compensation) + Some { phase2 = (fun ((pcVar, _currv, _, pcMap) as ctxt) -> + let generate1, dispose1, checkDispose1 = res1.phase2 ctxt + let generate = + // copy the compensation expression - one copy for the success continuation and one for the exception + let compensation = copyExpr g CloneAllAndMarkExprValsAsCompilerGenerated compensation + mkCompGenSequential m + // set the PC to the inner finally, so that if an exception happens we run the right finally + (mkCompGenSequential m + (mkValSet m pcVar (mkInt32 g m pcMap.[innerDisposeContinuationLabel])) + generate1 ) + // set the PC past the try/finally before trying to run it, to make sure we only run it once + (mkCompGenSequential m + (Expr.Op (TOp.Label innerDisposeContinuationLabel, [], [], m)) + (mkCompGenSequential m + (mkValSet m pcVar (mkInt32 g m pcMap.[currentDisposeContinuationLabel])) + compensation)) + let dispose = + // generate inner try/finallys, then outer try/finallys + mkCompGenSequential m + dispose1 + // set the PC past the try/finally before trying to run it, to make sure we only run it once + (mkCompGenSequential m + (Expr.Op (TOp.Label innerDisposeContinuationLabel, [], [], m)) + (mkCompGenSequential m + (mkValSet m pcVar (mkInt32 g m pcMap.[currentDisposeContinuationLabel])) + (mkCompGenSequential m + compensation + (Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m))))) + let checkDispose = + mkCompGenSequential m + checkDispose1 + (mkCompGenSequential m + (Expr.Op (TOp.Label innerDisposeContinuationLabel, [], [], m)) + (Expr.Op (TOp.Return, [], [mkTrue g m (* yes, we must dispose!!! *) ], m))) + + generate, dispose, checkDispose) + labels = innerDisposeContinuationLabel :: res1.labels + stateVars = res1.stateVars + significantClose = true + capturedVars = capturedVars } + | _ -> + None + + | SeqEmpty m -> + // printfn "found Seq.empty" + Some { phase2 = (fun _ -> + let generate = mkUnit g m + let dispose = Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m) + let checkDispose = Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m) + generate, dispose, checkDispose) + labels = [] + stateVars = [] + significantClose = false + capturedVars = emptyFreeVars } + + | Expr.Sequential (x1, x2, NormalSeq, ty, m) -> + match Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel x2 with + | Some res2-> + // printfn "found sequential execution" + Some { res2 with + phase2 = (fun ctxt -> + let generate2, dispose2, checkDispose2 = res2.phase2 ctxt + let generate = Expr.Sequential (x1, generate2, NormalSeq, ty, m) + let dispose = dispose2 + let checkDispose = checkDispose2 + generate, dispose, checkDispose) } + | None -> None + + | Expr.Let (bind, bodyExpr, m, _) + // Restriction: compilation of sequence expressions containing non-toplevel constrained generic functions is not supported + when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericContraints g bind.Var) -> + + let resBody = Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr + match resBody with + | Some res2 -> + if bind.Var.IsCompiledAsTopLevel then + Some (RepresentBindingsAsLifted (mkLetBind m bind) res2) + elif not (res2.capturedVars.FreeLocals.Contains(bind.Var)) then + // printfn "found state variable %s" bind.Var.DisplayName + Some (RepresentBindingAsLocal bind res2 m) + else + // printfn "found state variable %s" bind.Var.DisplayName + Some (RepresentBindingAsStateMachineLocal bind res2 m) + | None -> + None + +(* + | Expr.LetRec (binds, e2, m, _) + when // Restriction: only limited forms of "let rec" in sequence expressions can be handled by assignment to state local values + + (let recvars = valsOfBinds binds |> List.map (fun v -> (v, 0)) |> ValMap.OfList + binds |> List.forall (fun bind -> + // Rule 1 - IsCompiledAsTopLevel require no state local value + bind.Var.IsCompiledAsTopLevel || + // Rule 2 - funky constrained local funcs not allowed + not (IsGenericValWithGenericContraints g bind.Var)) && + binds |> List.count (fun bind -> + // Rule 3 - Recursive non-lambda and repack values are allowed + match stripExpr bind.Expr with + | Expr.Lambda _ + | Expr.TyLambda _ -> false + // "let v = otherv" bindings get produced for environment packing by InnerLambdasToTopLevelFuncs.fs, we can accept and compiler these ok + | Expr.Val (v, _, _) when not (recvars.ContainsVal v.Deref) -> false + | _ -> true) <= 1) -> + + match Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 with + | Some res2 -> + let topLevelBinds, nonTopLevelBinds = binds |> List.partition (fun bind -> bind.Var.IsCompiledAsTopLevel) + // Represent the closure-capturing values as state machine locals. They may still be recursively-referential + let res3 = (res2, nonTopLevelBinds) ||> List.fold (fun acc bind -> RepresentBindingAsStateMachineLocal bind acc m) + // Represent the non-closure-capturing values as ordinary bindings on the expression. + let res4 = if topLevelBinds.IsEmpty then res3 else RepresentBindingsAsLifted (mkLetRecBinds m topLevelBinds) res3 + Some res4 + | None -> + None +*) + | Expr.Match (spBind, exprm, pt, targets, m, ty) when targets |> Array.forall (fun (TTarget(vs, _e, _spTarget)) -> isNil vs) -> + // lower all the targets. abandon if any fail to lower + let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel targetExpr) + // LIMITATION: non-trivial pattern matches involving or-patterns or active patterns where bindings can't be + // transferred to the r.h.s. are not yet compiled. + if tglArray |> Array.forall Option.isSome then + let tglArray = Array.map Option.get tglArray + let tgl = Array.toList tglArray + let labs = tgl |> List.collect (fun res -> res.labels) + let (capturedVars, _) = + ((emptyFreeVars, false), Array.zip targets tglArray) + ||> Array.fold (fun (fvs, seenLabel) ((TTarget(_vs, e, _spTarget)), res) -> + if seenLabel then unionFreeVars fvs (freeInExpr CollectLocals e), true + else res.capturedVars, not res.labels.IsEmpty) + let stateVars = tgl |> List.collect (fun res -> res.stateVars) + let significantClose = tgl |> List.exists (fun res -> res.significantClose) + Some { phase2 = (fun ctxt -> + let gtgs, disposals, checkDisposes = + (Array.toList targets, tgl) + ||> List.map2 (fun (TTarget(vs, _, spTarget)) res -> + let generate, dispose, checkDispose = res.phase2 ctxt + let gtg = TTarget(vs, generate, spTarget) + gtg, dispose, checkDispose) + |> List.unzip3 + let generate = primMkMatch (spBind, exprm, pt, Array.ofList gtgs, m, ty) + let dispose = if isNil disposals then mkUnit g m else List.reduce (mkCompGenSequential m) disposals + let checkDispose = if isNil checkDisposes then mkFalse g m else List.reduce (mkCompGenSequential m) checkDisposes + generate, dispose, checkDispose) + labels=labs + stateVars = stateVars + significantClose = significantClose + capturedVars = capturedVars } + else + None + + // yield! e ---> (for x in e -> x) + // + // Design choice: we compile 'yield! e' as 'for x in e do yield x'. + // + // Note, however, this leads to a loss of tailcalls: the case not + // handled correctly yet is sequence expressions that use yield! in the last position + // This can give rise to infinite iterator chains when implemented by the naive expansion to + // 'for x in e yield e'. For example consider this: + // + // let rec rwalk x = { yield x + // yield! rwalk (x + rand()) } + // + // This is the moral equivalent of a tailcall optimization. These also don't compile well + // in the C# compilation model + + | arbitrarySeqExpr -> + let m = arbitrarySeqExpr.Range + if isWholeExpr then + // printfn "FAILED - not worth compiling an unrecognized immediate yield! %s " (stringOfRange m) + None + else + let tyConfirmsToSeq g ty = isAppTy g ty && tyconRefEq g (tcrefOfAppTy g ty) g.tcref_System_Collections_Generic_IEnumerable + match SearchEntireHierarchyOfType (tyConfirmsToSeq g) g amap m (tyOfExpr g arbitrarySeqExpr) with + | None -> + // printfn "FAILED - yield! did not yield a sequence! %s" (stringOfRange m) + None + | Some ty -> + // printfn "found yield!" + let inpElemTy = List.head (argsOfAppTy g ty) + if isTailCall then + //this.pc <- NEXT + //nextEnumerator <- e + //return 2 + //NEXT: + let label = IL.generateCodeLabel() + Some { phase2 = (fun (pcVar, _currv, nextVar, pcMap) -> + let generate = + mkCompGenSequential m + (mkValSet m pcVar (mkInt32 g m pcMap.[label])) + (mkSequential SequencePointsAtSeq m + (mkAddrSet m nextVar arbitrarySeqExpr) + (mkCompGenSequential m + (Expr.Op (TOp.Return, [], [mkTwo g m], m)) + (Expr.Op (TOp.Label label, [], [], m)))) + let dispose = + mkCompGenSequential m + (Expr.Op (TOp.Label label, [], [], m)) + (Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m)) + let checkDispose = + mkCompGenSequential m + (Expr.Op (TOp.Label label, [], [], m)) + (Expr.Op (TOp.Return, [], [mkFalse g m], m)) + generate, dispose, checkDispose) + labels=[label] + stateVars=[] + significantClose = false + capturedVars = emptyFreeVars } + else + let v, ve = mkCompGenLocal m "v" inpElemTy + Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel (mkCallSeqCollect g m inpElemTy inpElemTy (mkLambdaNoType g m v (mkCallSeqSingleton g m inpElemTy ve)) arbitrarySeqExpr) + *) + + + match overallExpr with + | StateMachine g objExpr -> + printfn "Found state machine..." + match objExpr with + | Expr.Obj (_, ty, basev, basecall, overrides, interfaceImpls, _m) -> + printfn "Found state machine object..." + match overrides with + | [ (TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, (JumpTable g (pcExpr, codeExpr)), m)) ] -> + printfn "Found state machine override method..." + // printfn "found seq { ... } or Seq.delay (fun () -> ...) in FSharp.Core.dll" + //let m = e.Range + let initLabel = IL.generateCodeLabel() + let noDisposeContinuationLabel = IL.generateCodeLabel() + + // Perform phase1 + match Lower codeExpr with + | Some res -> + let labs = res.labels + let stateVars = res.stateVars + let pcs = labs |> List.mapi (fun i _ -> i + 1) + let pcDone = labs.Length + 1 + let pcInit = 0 + let pc2lab = Map.ofList ((pcInit, initLabel) :: (pcDone, noDisposeContinuationLabel) :: List.zip pcs labs) + let lab2pc = Map.ofList ((initLabel, pcInit) :: (noDisposeContinuationLabel, pcDone) :: List.zip labs pcs) + + // A utility to add a jump table to the three generated methods + let addJumpTable pcExpr expr = + let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding, m ) + let mkGotoLabelTarget lab = mbuilder.AddResultTarget(Expr.Op (TOp.Goto lab, [], [], m), SuppressSequencePointAtTarget) + let dtree = + TDSwitch(pcExpr, + [ + // Yield one target for each PC, where the action of the target is to goto the appropriate label + for pc in pcs do + yield mkCase(DecisionTreeTest.Const(Const.Int32 pc), mkGotoLabelTarget pc2lab.[pc]) + + // Yield one target for the 'done' program counter, where the action of the target is to continuation label + yield mkCase(DecisionTreeTest.Const(Const.Int32 pcDone), mkGotoLabelTarget noDisposeContinuationLabel) ], + Some(mkGotoLabelTarget pc2lab.[pcInit]), + m) + + let table = mbuilder.Close(dtree, m, g.int_ty) + mkCompGenSequential m table (mkCompGenSequential m (Expr.Op (TOp.Label initLabel, [], [], m)) expr) + + // Execute phase2, building the core of the the GenerateNext, Dispose and CheckDispose methods + let methodBodyExprR = res.phase2 lab2pc + let methodBodyExprWithJumpTable = addJumpTable pcExpr methodBodyExprR + let overrideR = TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, methodBodyExprWithJumpTable, m) + Some (objExpr, ty, basev, basecall, [overrideR], interfaceImpls, stateVars, m) + | None -> None + | _ -> None + | _ -> None + | _ -> None + diff --git a/src/fsharp/LowerCallsAndSeqs.fsi b/src/fsharp/LowerCallsAndSeqs.fsi index 5abcb8288dc..c8522b1f21f 100644 --- a/src/fsharp/LowerCallsAndSeqs.fsi +++ b/src/fsharp/LowerCallsAndSeqs.fsi @@ -20,3 +20,7 @@ val LowerImplFile: g: TcGlobals -> assembly: TypedImplFile -> TypedImplFile /// All these variables are then represented as fields in a hosting closure object along with any additional /// free variables of the sequence expression. val LowerSeqExpr: g: TcGlobals -> amap: ImportMap -> overallExpr: Expr -> (ValRef * ValRef * ValRef * ValRef list * Expr * Expr * Expr * TType * range) option + +/// Analyze a TAST expression to detect the elaborated form of a state machine expression, a special kind +/// of object expression that uses special code generation constructs. +val LowerStateMachineExpr: g: TcGlobals -> overallExpr: Expr -> (Expr * TType * Val option * Expr * ObjExprMethod list * (TType * ObjExprMethod list) list * ValRef list * range) option diff --git a/src/fsharp/TcGlobals.fs b/src/fsharp/TcGlobals.fs index 337205632e3..e85e040213d 100755 --- a/src/fsharp/TcGlobals.fs +++ b/src/fsharp/TcGlobals.fs @@ -438,6 +438,7 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d let fslib_MFStringModule_nleref = mkNestedNonLocalEntityRef fslib_MFCollections_nleref "StringModule" let fslib_MFNativePtrModule_nleref = mkNestedNonLocalEntityRef fslib_MFNativeInterop_nleref "NativePtrModule" let fslib_MFOptionModule_nleref = mkNestedNonLocalEntityRef fslib_MFCore_nleref "OptionModule" + let fslib_MFCodeGenHelpers_nleref = mkNestedNonLocalEntityRef fslib_MFCompilerServices_nleref "CodeGenHelpers" let fslib_MFRuntimeHelpers_nleref = mkNestedNonLocalEntityRef fslib_MFCompilerServices_nleref "RuntimeHelpers" let fslib_MFQuotations_nleref = mkNestedNonLocalEntityRef fslib_MF_nleref "Quotations" @@ -502,6 +503,7 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d fslib_MFStringModule_nleref fslib_MFNativePtrModule_nleref fslib_MFOptionModule_nleref + fslib_MFCodeGenHelpers_nleref fslib_MFRuntimeHelpers_nleref ] do yield nleref.LastItemMangledName, ERefNonLocal nleref ] @@ -690,6 +692,15 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d let v_seq_finally_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "EnumerateThenFinally" , None , None , [varb], ([[mkSeqTy varbTy]; [v_unit_ty --> v_unit_ty]], mkSeqTy varbTy)) let v_seq_of_functions_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "EnumerateFromFunctions" , None , None , [vara;varb], ([[v_unit_ty --> varaTy]; [varaTy --> v_bool_ty]; [varaTy --> varbTy]], mkSeqTy varbTy)) let v_create_event_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "CreateEvent" , None , None , [vara;varb], ([[varaTy --> v_unit_ty]; [varaTy --> v_unit_ty]; [(v_obj_ty --> (varbTy --> v_unit_ty)) --> varaTy]], TType_app (v_fslib_IEvent2_tcr, [varaTy;varbTy]))) + let v_cgh_stateMachine_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__stateMachine" , None , None , [vara], ([[varaTy]], varaTy)) + let v_cgh_jumptable_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__jumptable" , None , None , [vara], ([[v_int_ty]; [v_unit_ty --> varaTy]], varaTy)) + let v_cgh_newLabel_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__newLabel" , None , None , [], ([[v_unit_ty]], v_int_ty)) + let v_cgh_label_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__label" , None , None , [], ([[v_int_ty]], v_unit_ty)) + let v_cgh_newEntryPoint_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__newEntryPoint" , None , None , [], ([[v_unit_ty]], v_int_ty)) + let v_cgh_entryPoint_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__entryPoint" , None , None , [vara], ([[v_int_ty]; [v_unit_ty --> varaTy]], varaTy)) + let v_cgh_code_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__code" , None , None , [vara], ([[v_unit_ty --> varaTy]], varaTy)) + let v_cgh_goto_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__goto" , None , None , [vara], ([[v_int_ty]], varaTy)) + let v_cgh_return_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__return" , None , None , [vara;varb],([[varaTy]], varbTy)) let v_seq_to_array_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "toArray" , None , Some "ToArray", [varb], ([[mkSeqTy varbTy]], mkArrayType 1 varbTy)) let v_seq_to_list_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "toList" , None , Some "ToList" , [varb], ([[mkSeqTy varbTy]], mkListTy varbTy)) let v_seq_map_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "map" , None , Some "Map" , [vara;varb], ([[varaTy --> varbTy]; [mkSeqTy varaTy]], mkSeqTy varbTy)) @@ -1422,6 +1433,16 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d member __.quote_to_linq_lambda_info = v_quote_to_linq_lambda_info + member val cgh_stateMachine_vref = ValRefForIntrinsic v_cgh_stateMachine_info + member val cgh_jumptable_vref = ValRefForIntrinsic v_cgh_jumptable_info + member val cgh_newLabel_vref = ValRefForIntrinsic v_cgh_newLabel_info + member val cgh_label_vref = ValRefForIntrinsic v_cgh_label_info + member val cgh_newEntryPoint_vref = ValRefForIntrinsic v_cgh_newEntryPoint_info + member val cgh_entryPoint_vref = ValRefForIntrinsic v_cgh_entryPoint_info + member val cgh_code_vref = ValRefForIntrinsic v_cgh_code_info + member val cgh_goto_vref = ValRefForIntrinsic v_cgh_goto_info + member val cgh_return_vref = ValRefForIntrinsic v_cgh_return_info + member val generic_hash_withc_tuple2_vref = ValRefForIntrinsic v_generic_hash_withc_tuple2_info member val generic_hash_withc_tuple3_vref = ValRefForIntrinsic v_generic_hash_withc_tuple3_info member val generic_hash_withc_tuple4_vref = ValRefForIntrinsic v_generic_hash_withc_tuple4_info diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs index cbcc6d69e93..81b9d565f7a 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs @@ -76,6 +76,18 @@ let testNonBlocking() = let failtest str = raise (TestException str) +let tmp() = + let mutable y = 0 + task { + try + do! Task.Delay(0) + () + do! Task.Delay(100) + with e -> + () + y <- 1 + } + let testCatching1() = let mutable x = 0 let mutable y = 0 From 547c0e9bb8241dbf52613715ecd08204508b2452 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 8 May 2019 17:25:29 +0100 Subject: [PATCH 25/45] some codegen for state machine tasks --- src/fsharp/DotNetFrameworkDependencies.fs | 5 +- src/fsharp/FSharp.Core/tasks.fs | 255 +++--- src/fsharp/FSharp.Core/tasks.fsi | 93 +-- src/fsharp/FindUnsolved.fs | 2 +- src/fsharp/IlxGen.fs | 123 +-- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 14 +- src/fsharp/LowerCallsAndSeqs.fs | 758 +++++++++--------- src/fsharp/LowerCallsAndSeqs.fsi | 2 +- src/fsharp/Optimizer.fs | 4 +- src/fsharp/PostInferenceChecks.fs | 2 +- src/fsharp/QuotationTranslator.fs | 4 +- src/fsharp/TastOps.fs | 28 +- src/fsharp/TastPickle.fs | 4 +- src/fsharp/TcGlobals.fs | 24 +- src/fsharp/TypeChecker.fs | 4 +- src/fsharp/autobox.fs | 2 +- src/fsharp/range.fs | 10 +- src/fsharp/symbols/Exprs.fs | 4 +- src/fsharp/tast.fs | 101 ++- .../Microsoft.FSharp.Control/Tasks.fs | 139 +++- 20 files changed, 846 insertions(+), 732 deletions(-) diff --git a/src/fsharp/DotNetFrameworkDependencies.fs b/src/fsharp/DotNetFrameworkDependencies.fs index 504bde5fa37..ec5b74b506c 100644 --- a/src/fsharp/DotNetFrameworkDependencies.fs +++ b/src/fsharp/DotNetFrameworkDependencies.fs @@ -82,7 +82,10 @@ module internal FSharp.Compiler.DotNetFrameworkDependencies let file = try let depsJsonPath = Path.ChangeExtension(Assembly.GetEntryAssembly().Location, "deps.json") - File.ReadAllText(depsJsonPath) + if File.Exists depsJsonPath then + File.ReadAllText(depsJsonPath) + else + "" with _ -> "" let tfmPrefix=".NETCoreApp,Version=v" diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index d1ab1569043..923e2b04f1c 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -28,31 +28,22 @@ namespace Microsoft.FSharp.Core.CompilerServices module CodeGenHelpers = [] - let __jumptable<'T> (_x:int) (_code: 'T) : 'T = Unchecked.defaultof<_> + let __jumptable<'T> (_x:int) (_code: unit -> 'T) : 'T = Unchecked.defaultof<_> [] let __stateMachine<'T> (x: 'T) : 'T = x - [] - let __newLabel() : int = 0 - [] let __newEntryPoint() : int = 0 [] - let __code<'T> (_f: unit -> 'T) : 'T = Unchecked.defaultof<_> - - [] - let __label (_n: int) : unit = Unchecked.defaultof<_> + let __machine<'T> : 'T = Unchecked.defaultof<'T> [] - let __return (_v: 'T) : 'U = Unchecked.defaultof<_> + let __entryPoint (_n: int) : unit= Unchecked.defaultof<_> [] - let __entryPoint<'T> (_n: int) (_f: unit -> 'T) : 'T = Unchecked.defaultof<_> - - [] - let __goto<'T> (_n: int) : 'T = Unchecked.defaultof<_> + let __return<'T> (_v: 'T) : 'T = Unchecked.defaultof<_> #if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE namespace Microsoft.FSharp.Control @@ -73,13 +64,10 @@ open Microsoft.FSharp.Collections // // Uses a struct-around-single-reference to allow future changes in representation (the representation is // not revealed in the signature) -[] -type TaskStep<'T>(completed: bool) = - member __.IsCompleted = completed +type TaskStep<'T> = (# "bool" #) [] type TaskStateMachine() = - member val ResumptionPoint : int = 0 with get, set member val Current : obj = null with get, set /// Await the given awaiter and resume at the given entry point @@ -88,14 +76,15 @@ type TaskStateMachine() = [] type TaskStateMachine<'T>() = inherit TaskStateMachine() + let mutable resumptionPoint = 0 let mutable methodBuilder = AsyncTaskMethodBuilder>() /// Proceed to the next state or raise an exception abstract Step : pc: int -> TaskStep<'T> - override sm.Await(awaiter, pc) = - sm.ResumptionPoint <- pc + override sm.Await (awaiter, pc) = + resumptionPoint <- pc let mutable sm = sm let mutable awaiter = awaiter assert (not (isNull awaiter)) @@ -106,8 +95,8 @@ type TaskStateMachine<'T>() = member this.MoveNext() = try - let step = this.Step this.ResumptionPoint - if step.IsCompleted then + let step = this.Step resumptionPoint + if (# "" step : bool #) then let res = unbox<'T>(this.Current) methodBuilder.SetResult(Task.FromResult res) with exn -> @@ -116,7 +105,7 @@ type TaskStateMachine<'T>() = member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. member this.Start() = - let mutable machine = (this :> IAsyncStateMachine) + let mutable machine = this try methodBuilder.Start(&machine) methodBuilder.Task.Unwrap() @@ -138,15 +127,15 @@ module TaskHelpers = // else agg :> Exception /// Used to return a value. - let inline ret<'T> (sm: TaskStateMachine) (x : 'T) = - sm.Current <- (box x) - TaskStep<'T>(true) + let inline ret<'T> (x : 'T) = + __machine.Current <- (box x) + (# "" true : TaskStep<'T> #) - let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2 when (^Priority or ^TaskLike): (static member CanBind : TaskStateMachine * ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) > (sm: TaskStateMachine) (x: ^Priority) (y: ^TaskLike) k = - ((^Priority or ^TaskLike): (static member CanBind : TaskStateMachine * ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) (sm, x, y, k)) + let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2 when (^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) > (x: ^Priority) (y: ^TaskLike) __expand_continuation = + ((^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) (x, y, __expand_continuation)) - let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T when (^Priority or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * ^Priority * ^TaskLike -> TaskStep<'T>)> (sm: TaskStateMachine) (x: ^Priority) (y: ^TaskLike) = - ((^Priority or ^TaskLike): (static member CanReturnFrom : TaskStateMachine * ^Priority * ^TaskLike -> TaskStep<'T>) (sm, x, y)) + let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T when (^Priority or ^TaskLike): (static member CanReturnFrom: ^Priority * ^TaskLike -> TaskStep<'T>)> (x: ^Priority) (y: ^TaskLike) = + ((^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep<'T>) (x, y)) type TaskLikeBind<'TResult2> = // We put the output generic parameter up here at the class level, so it doesn't get subject to @@ -165,15 +154,15 @@ module TaskHelpers = and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) and ^Awaiter : (member GetResult : unit -> ^TResult1) > - (sm: TaskStateMachine, awaitable : ^Awaitable, continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = + (awaitable : ^Awaitable, __expand_continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = let awaiter = (^Awaitable : (member GetAwaiter : unit -> ^Awaiter)(awaitable)) // get an awaiter from the awaitable let CONT = __newEntryPoint () if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately - __entryPoint> CONT (fun () -> - continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter))) + __entryPoint CONT + __expand_continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter)) else - sm.Await(awaiter, CONT) - TaskStep<'TResult2>(false) + __machine.Await (awaiter, CONT) + __return (# "" false : TaskStep<'TResult2> #) static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) @@ -181,135 +170,112 @@ module TaskHelpers = and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) and ^Awaiter : (member GetResult : unit -> ^TResult1) > - (sm, task : ^TaskLike, continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = + (task : ^TaskLike, __expand_continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = let awaitable = (^TaskLike : (member ConfigureAwait : bool -> ^Awaitable)(task, false)) - TaskLikeBind<'TResult2>.GenericAwait(sm, awaitable, continuation) + TaskLikeBind<'TResult2>.GenericAwait(awaitable, __expand_continuation) /// Special case of the above for `Task<'TResult1>`. Have to write this T by hand to avoid confusing the compiler /// trying to decide between satisfying the constraints with `Task` or `Task<'TResult1>`. - let inline bindTask (sm: TaskStateMachine) (task : Task<'TResult1>) (continuation : 'TResult1 -> TaskStep<'TResult2>) = + let inline bindTask (task : Task<'TResult1>) (__expand_continuation : 'TResult1 -> TaskStep<'TResult2>) = let CONT = __newEntryPoint() let awaiter = task.GetAwaiter() if awaiter.IsCompleted then - __entryPoint> CONT (fun () -> - continuation (awaiter.GetResult()) - ) + __entryPoint CONT + __expand_continuation (awaiter.GetResult()) else - sm.Await(awaiter, CONT) - TaskStep<'TResult2>(false) + __machine.Await (awaiter, CONT) + __return (# "" false : TaskStep<'TResult2> #) /// Special case of the above for `Task<'TResult1>`, for the context-insensitive builder. /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method /// defined on the builder has fancy generic constraints on inp and T parameters. - let inline bindTaskConfigureFalse (sm: TaskStateMachine) (task : Task<'TResult1>) (continuation : 'TResult1 -> TaskStep<'TResult2>) = + let inline bindTaskConfigureFalse (task : Task<'TResult1>) (__expand_continuation : 'TResult1 -> TaskStep<'TResult2>) = let CONT = __newEntryPoint () let awaiter = task.ConfigureAwait(false).GetAwaiter() if awaiter.IsCompleted then - __entryPoint> CONT (fun () -> - continuation (awaiter.GetResult()) - ) + __entryPoint CONT + __expand_continuation (awaiter.GetResult()) else - sm.Await(awaiter, CONT) - TaskStep<'TResult2>(false) - -type TaskSpec<'T> = TaskStateMachine -> TaskStep<'T> + __machine.Await (awaiter, CONT) + __return (# "" false : TaskStep<'TResult2> #) // New style task builder. type TaskBuilder() = - // These methods are consistent between all builders. - member inline __.Delay(f : unit -> TaskSpec<'T>) = (fun sm -> f () sm) + + member inline __.Delay(__expand_f : unit -> TaskStep<'T>) = __expand_f - member inline __.Run(code : TaskSpec<'T>) = - let sm = - __stateMachine - { new TaskStateMachine<'T>() with - member sm.Step(pc) = __jumptable pc (code sm) } - sm.Start() + member inline __.Run(__expand_code : unit -> TaskStep<'T>) : Task<'T> = + (__stateMachine + { new TaskStateMachine<'T>() with + member __.Step pc = __jumptable pc __expand_code }).Start() /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. - member inline __.Zero() : TaskSpec = (fun sm -> - sm.Current <- (box ()) - TaskStep(true)) + member inline __.Zero() : TaskStep = + __machine.Current <- (box ()) + (# "" true : TaskStep #) - member inline __.Return (x: 'T) : TaskSpec<'T> = (fun sm -> - sm.Current <- (box x) - TaskStep<'T>(true)) + member inline __.Return (x: 'T) : TaskStep<'T> = + __machine.Current <- (box x) + (# "" true : TaskStep<'T> #) /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. - member inline __.Combine(task1: TaskSpec, task2: TaskSpec<'T>) : TaskSpec<'T> = (fun sm -> - let step = task1 sm - if step.IsCompleted then - task2 sm - else - TaskStep<'T>(false)) + member inline __.Combine(_step: TaskStep, __expand_task2: unit -> TaskStep<'T>) : TaskStep<'T> = + // _step is ignored, as elsewhere, we only get here is the step completed + __expand_task2() /// Builds a step that executes the body while the condition predicate is true. - member inline __.While(condition : unit -> bool, body : TaskSpec) : TaskSpec = (fun sm -> - let ENTRY = __newLabel() - __label ENTRY - let guard = __code condition - if guard then - let step = __code (fun () -> body sm) - if step.IsCompleted then - __goto> ENTRY - else - TaskStep(false) - else - sm.Current <- (box ()) - TaskStep(true)) + member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskStep) : TaskStep = + while __expand_condition() do + let _step = __expand_body () + () + __machine.Current <- (box ()) + (# "" true : TaskStep #) /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - member inline __.TryWith(body : TaskSpec<'T>, catch : exn -> TaskSpec<'T>) : TaskSpec<'T> = (fun sm -> + member inline __.TryWith(__expand_body : unit -> TaskStep<'T>, __expand_catch : exn -> TaskStep<'T>) : TaskStep<'T> = try - let CODE = __newLabel() - __label CODE - __code> (fun () -> body sm) + __expand_body() with exn -> - catch exn sm) + __expand_catch exn - member inline __.TryFinally(body : TaskSpec<'T>, compensation : unit -> unit) = (fun sm -> + member inline __.TryFinally(__expand_body: unit -> TaskStep<'T>, compensation : unit -> unit) : TaskStep<'T> = /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). // codegen - let step = - try - let CODE = __newLabel() - __label CODE - __code> (fun () -> body sm) - with _ -> - compensation() - reraise() - - if step.IsCompleted then + try + let _step = __expand_body () + () + with _ -> compensation() - step) + reraise() - member inline this.Using(disp : #IDisposable, body : #IDisposable -> TaskSpec<'T>) = + compensation() + (# "" true : TaskStep<'T> #) + + member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> TaskStep<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. this.TryFinally( - (body disp), + (fun () -> __expand_body disp), (fun () -> if not (isNull (box disp)) then disp.Dispose())) - member inline this.For(sequence : seq<'T>, body : 'T -> TaskSpec) : TaskSpec = + member inline this.For(sequence : seq<'T>, __expand_body : 'T -> TaskStep) : TaskStep = // A for loop is just a using statement on the sequence's enumerator... this.Using (sequence.GetEnumerator(), // ... and its body is a while loop that advances the enumerator and runs the body on each element. - (fun e -> this.While((fun () -> e.MoveNext()), this.Delay (fun () -> body e.Current)))) + (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) - member inline __.ReturnFrom (task: Task<'T>) : TaskSpec<'T> = (fun sm -> + member inline __.ReturnFrom (task: Task<'T>) : TaskStep<'T> = let CONT = __newEntryPoint () if task.IsCompleted then - __entryPoint CONT (fun () -> - sm.Current <- (box task.Result) - TaskStep<'T>(true)) + __entryPoint CONT + __machine.Current <- box task.Result + (# "" true : TaskStep<'T> #) else - sm.Await(task.GetAwaiter(), CONT) - sm.ResumptionPoint <- CONT - TaskStep<'T>(false)) - + __machine.Await(task.GetAwaiter(), CONT) + __return (# "" false : TaskStep<'T> #) [] module ContextSensitiveTasks = @@ -328,14 +294,14 @@ module ContextSensitiveTasks = when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> ^TResult1)>(sm, _priority: IPriority2, taskLike : ^TaskLike, k: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> - = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (sm, taskLike, k) + and ^Awaiter: (member GetResult: unit -> ^TResult1)>(_priority: IPriority2, taskLike : ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (taskLike, __expand_continuation) - static member inline CanBind (sm, _priority: IPriority1, task: Task<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> - = bindTask sm task k + static member inline CanBind (_priority: IPriority1, task: Task<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = bindTask task __expand_continuation - static member inline CanBind (sm, _priority: IPriority1, computation : Async<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> - = bindTask sm (Async.StartAsTask computation) k + static member inline CanBind (_priority: IPriority1, computation : Async<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = bindTask (Async.StartAsTask computation) __expand_continuation // Give the type arguments explicitly to make it match the signature precisely static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T @@ -343,21 +309,20 @@ module ContextSensitiveTasks = and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T)> - (sm, _priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T > - = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T> (sm, taskLike, ret< ^T > sm) + (_priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T > + = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T> (taskLike, ret< ^T >) - static member inline CanReturnFrom (sm, _priority: IPriority1, computation : Async<'T>) - = bindTask sm (Async.StartAsTask computation) (ret< 'T > sm) : TaskStep<'T> + static member inline CanReturnFrom (_priority: IPriority1, computation : Async<'T>) + = bindTask (Async.StartAsTask computation) (ret< 'T >) : TaskStep<'T> type TaskBuilder with member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 - when (Witnesses or ^TaskLike): (static member CanBind: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> - (task: ^TaskLike, continuation: ^TResult1 -> TaskSpec<'TResult2>) : TaskSpec<'TResult2> - = (fun sm -> RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> sm Unchecked.defaultof task (fun x -> continuation x sm)) - - member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskSpec<'T> - = (fun sm -> RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> sm Unchecked.defaultof task) + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> + (task: ^TaskLike, __expand_continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> + = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> Unchecked.defaultof task __expand_continuation + member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> Unchecked.defaultof task module ContextInsensitiveTasks = @@ -373,51 +338,51 @@ module ContextInsensitiveTasks = when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> ^TResult1)> (sm, _priority: IPriority3, taskLike: ^TaskLike, k: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> - = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (sm, taskLike, k) + and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority3, taskLike: ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (taskLike, __expand_continuation) static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> ^TResult1)> (sm, _priority: IPriority2, configurableTaskLike: ^TaskLike, k: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> - = TaskLikeBind<'TResult2>.GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1> (sm, configurableTaskLike, k) + and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority2, configurableTaskLike: ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = TaskLikeBind<'TResult2>.GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1> (configurableTaskLike, __expand_continuation) - static member inline CanBind (sm, _priority :IPriority1, task: Task<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> - = bindTaskConfigureFalse sm task k + static member inline CanBind (_priority :IPriority1, task: Task<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = bindTaskConfigureFalse task __expand_continuation - static member inline CanBind (sm, _priority: IPriority1, computation : Async<'TResult1>, k: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> - = bindTaskConfigureFalse sm (Async.StartAsTask computation) k + static member inline CanBind (_priority: IPriority1, computation : Async<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + = bindTaskConfigureFalse (Async.StartAsTask computation) __expand_continuation (* static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T when ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^T) > (sm, _priority: IPriority2, taskLike: ^Awaitable) - = TaskLikeBind< ^T >.GenericAwait< ^Awaitable, ^Awaiter, ^T >(sm, taskLike, ret) + and ^Awaiter : (member GetResult : unit -> ^T) > (_priority: IPriority2, taskLike: ^Awaitable) + = TaskLikeBind< ^T >.GenericAwait< ^Awaitable, ^Awaiter, ^T >(taskLike, ret) static member inline CanReturnFrom< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^TResult1) > (sm, _: IPriority1, configurableTaskLike: ^TaskLike) - = TaskLikeBind< ^TResult1 >.GenericAwaitConfigureFalse(sm, configurableTaskLike, ret) + and ^Awaiter : (member GetResult : unit -> ^TResult1) > (_: IPriority1, configurableTaskLike: ^TaskLike) + = TaskLikeBind< ^TResult1 >.GenericAwaitConfigureFalse(configurableTaskLike, ret) - static member inline CanReturnFrom (sm, _priority: IPriority1, computation: Async<'T>) + static member inline CanReturnFrom (_priority: IPriority1, computation: Async<'T>) = bindTaskConfigureFalse sm (Async.StartAsTask computation) ret *) type TaskBuilder with member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 - when (Witnesses or ^TaskLike): (static member CanBind: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> - (task: ^TaskLike, continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskSpec<'TResult2> - = (fun sm -> RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> sm Unchecked.defaultof task continuation) + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> + (task: ^TaskLike, __expand_continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> + = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> Unchecked.defaultof task __expand_continuation (* - member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> + member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> builder.TaskStateMachine Unchecked.defaultof task *) #endif diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index c38751052db..51f649fa7aa 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -5,6 +5,7 @@ namespace Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Core + open System.Runtime.CompilerServices /// A marker interface to give priority to different available overloads type IPriority3 = interface end @@ -16,15 +17,23 @@ namespace Microsoft.FSharp.Core.CompilerServices type IPriority1 = interface inherit IPriority2 end module CodeGenHelpers = - val __jumptable : int -> 'T -> 'T + [] + val __jumptable : int -> (unit -> 'T) -> 'T + + [] val __stateMachine : 'T -> 'T - val __newLabel: unit -> int + + [] val __newEntryPoint: unit -> int - val __entryPoint: int -> (unit -> 'T) -> 'T - val __code: (unit -> 'T) -> 'T - val __return : 'T -> 'U - val __label: int -> unit - val __goto : int -> 'T + + [] + val __machine<'T> : 'T + + [] + val __entryPoint: int -> unit + + [] + val __return : 'T -> 'T #if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE namespace Microsoft.FSharp.Control @@ -37,16 +46,12 @@ open Microsoft.FSharp.Core.CompilerServices open Microsoft.FSharp.Control open Microsoft.FSharp.Collections -/// Represents the state of a computation: either awaiting something with a continuation, or completed with a return value. -[] -type TaskStep<'T> = - new : bool -> TaskStep<'T> - member IsCompleted : bool +/// Represents the result of a computation, a value of true indicates completion +type TaskStep<'T> = (# "bool" #) [] type TaskStateMachine = new : unit -> TaskStateMachine - member ResumptionPoint : int with get, set member Current : obj with get, set abstract Await: awaiter : ICriticalNotifyCompletion * pc: int -> unit @@ -59,21 +64,19 @@ type TaskStateMachine<'T> = override Await: awaiter : ICriticalNotifyCompletion * pc: int -> unit member Start: unit -> Task<'T> -type TaskSpec<'T> = TaskStateMachine -> TaskStep<'T> - type TaskBuilder = new: unit -> TaskBuilder - member inline Combine: task1: TaskSpec * task2: TaskSpec<'T> -> TaskSpec<'T> - member inline Delay: f: (unit -> TaskSpec<'T>) -> TaskSpec<'T> - member inline For: sequence: seq<'T> * body: ('T -> TaskSpec) -> TaskSpec - member inline Return: x: 'T -> TaskSpec<'T> - member inline ReturnFrom: task: Task<'T> -> TaskSpec<'T> - member inline Run: code: TaskSpec<'T> -> Task<'T> - member inline TryFinally: body: TaskSpec<'T> * fin: (unit -> unit) -> TaskSpec<'T> - member inline TryWith: body: TaskSpec<'T> * catch: (exn -> TaskSpec<'T>) -> TaskSpec<'T> - member inline Using: disp: 'Resource * body: ('Resource -> TaskSpec<'T>) -> TaskSpec<'T> when 'Resource :> IDisposable - member inline While: condition: (unit -> bool) * body: TaskSpec -> TaskSpec - member inline Zero: unit -> TaskSpec + member inline Combine: task1: TaskStep * task2: (unit -> TaskStep<'T>) -> TaskStep<'T> + member inline Delay: f: (unit -> TaskStep<'T>) -> (unit -> TaskStep<'T>) + member inline For: sequence: seq<'T> * body: ('T -> TaskStep) -> TaskStep + member inline Return: x: 'T -> TaskStep<'T> + member inline ReturnFrom: task: Task<'T> -> TaskStep<'T> + member inline Run: code: (unit -> TaskStep<'T>) -> Task<'T> + member inline TryFinally: body: (unit -> TaskStep<'T>) * fin: (unit -> unit) -> TaskStep<'T> + member inline TryWith: body: (unit -> TaskStep<'T>) * catch: (exn -> TaskStep<'T>) -> TaskStep<'T> + member inline Using: disp: 'Resource * body: ('Resource -> TaskStep<'T>) -> TaskStep<'T> when 'Resource :> IDisposable + member inline While: condition: (unit -> bool) * body: (unit -> TaskStep) -> TaskStep + member inline Zero: unit -> TaskStep [] module ContextSensitiveTasks = @@ -91,36 +94,36 @@ module ContextSensitiveTasks = /// Provides evidence that task-like types can be used in 'bind' in a task computation expression static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > - : sm: TaskStateMachine * priority: IPriority2 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep< 'TResult2>) -> TaskStep< 'TResult2> + : priority: IPriority2 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep< 'TResult2>) -> TaskStep< 'TResult2> when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression - static member inline CanBind: sm: TaskStateMachine * priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> /// Provides evidence that F# Async computations can be used in 'bind' in a task computation expression - static member inline CanBind: sm: TaskStateMachine * priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> /// Provides evidence that task-like types can be used in 'return' in a task workflow - static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T> : sm: TaskStateMachine * priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T > + static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T> : priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T > when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T) /// Provides evidence that F# Async computations can be used in 'return' in a task computation expression - static member inline CanReturnFrom: sm: TaskStateMachine * IPriority1 * computation: Async<'T> -> TaskStep<'T> + static member inline CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T> type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskSpec<'TResult2>) -> TaskSpec<'TResult2> - when (Witnesses or ^TaskLike): (static member CanBind: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics - member inline ReturnFrom: a: ^TaskLike -> TaskSpec< 'TResult > - when (Witnesses or ^TaskLike): (static member CanReturnFrom: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'TResult>) + member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult > + when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult>) module ContextInsensitiveTasks = @@ -139,14 +142,14 @@ module ContextInsensitiveTasks = interface IPriority3 /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > : sm: TaskStateMachine * priority: IPriority3 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > : priority: IPriority3 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter > : sm: TaskStateMachine * priority: IPriority2 * taskLike: ^TaskLike * k: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter > : priority: IPriority2 * taskLike: ^TaskLike * k: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion @@ -154,14 +157,14 @@ module ContextInsensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression - static member inline CanBind: sm: TaskStateMachine * priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> /// Provides evidence that F# async computations can be used in 'bind' in a task computation expression - static member inline CanBind: sm: TaskStateMachine * priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> (* /// Provides evidence that types following the "awaitable" pattern can be used in 'return!' in a task computation expression - static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T> : sm: TaskStateMachine * IPriority2 * taskLike: ^Awaitable -> TaskStep< ^T> + static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T> : IPriority2 * taskLike: ^Awaitable -> TaskStep< ^T> when ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) @@ -173,22 +176,22 @@ module ContextInsensitiveTasks = and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^T) > : sm: TaskStateMachine * IPriority1 * configurableTaskLike: ^TaskLike -> TaskStep< ^T> + and ^Awaiter : (member GetResult : unit -> ^T) > : IPriority1 * configurableTaskLike: ^TaskLike -> TaskStep< ^T> /// Provides evidence that F# async computations can be used in 'return!' in a task computation expression - static member inline CanReturnFrom: sm: TaskStateMachine * IPriority1 * computation: Async<'T> -> TaskStep<'T> + static member inline CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T> *) type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskSpec<'TResult2> - when (Witnesses or ^TaskLike): (static member CanBind: sm: TaskStateMachine * Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) (* /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult > - when (Witnesses or ^TaskLike): (static member CanReturnFrom: sm: TaskStateMachine * Witnesses * ^TaskLike -> TaskStep<'TResult>) + when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult>) *) #endif \ No newline at end of file diff --git a/src/fsharp/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index ac64aa6c1df..a2e4230d085 100644 --- a/src/fsharp/FindUnsolved.fs +++ b/src/fsharp/FindUnsolved.fs @@ -52,7 +52,7 @@ let rec accExpr (cenv:cenv) (env:env) expr = accExpr cenv env ast accTy cenv env ty - | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, _m) -> + | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, _stateVars, _m) -> accTy cenv env ty accExpr cenv env basecall accMethods cenv env basev overrides diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 909efe0af37..17ebd2d3415 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -795,6 +795,42 @@ and Mark = | Mark of ILCodeLabel member x.CodeLabel = (let (Mark lab) = x in lab) + +//-------------------------------------------------------------------------- +// We normally generate in the context of a "what to do next" continuation +//-------------------------------------------------------------------------- + +and sequel = + | EndFilter + + /// Exit a 'handler' block. The integer says which local to save result in + | LeaveHandler of (bool (* finally? *) * int * Mark) + + /// Branch to the given mark + | Br of Mark + + /// Compare then branch to the given mark or continue + | CmpThenBrOrContinue of Pops * ILInstr list + + /// Continue and leave the value on the IL computation stack + | Continue + + /// The value then do something else + | DiscardThen of sequel + + /// Return from the method + | Return + + /// End a scope of local variables. Used at end of 'let' and 'let rec' blocks to get tail recursive setting + /// of end-of-scope marks + | EndLocalScope of sequel * Mark + + /// Return from a method whose return type is void + | ReturnVoid + +and Pushes = ILType list +and Pops = int + /// The overall environment at a particular point in an expression tree. and IlxGenEnv = { /// The representation decisions for the (non-erased) type parameters that are in scope @@ -809,6 +845,10 @@ and IlxGenEnv = /// Indicates the default "place" for stuff we're currently generating cloc: CompileLocation + /// The sequel to use for an "early exit" in a state machine, e.g. a return fro the middle of an + /// async block + exitSequel: sequel + /// Hiding information down the signature chain, used to compute what's public to the assembly sigToImplRemapInfo: (Remap * SignatureHidingInfo) list @@ -830,6 +870,10 @@ and IlxGenEnv = withinSEH: bool } +let discard = DiscardThen Continue + +let discardAndReturnVoid = DiscardThen ReturnVoid + let ReplaceTyenv tyenv (eenv: IlxGenEnv) = {eenv with tyenv = tyenv } let EnvForTypars tps eenv = {eenv with tyenv = TypeReprEnv.ForTypars tps } @@ -1583,8 +1627,6 @@ type AssemblyBuilder(cenv: cenv, anonTypeTable: AnonTypeGenerationTable) as mgbu /// Record the types of the things on the evaluation stack. /// Used for the few times we have to flush the IL evaluation stack and to compute maxStack. -type Pushes = ILType list -type Pops = int let pop (i: int) : Pops = i let Push tys: Pushes = tys let Push0 = Push [] @@ -1846,34 +1888,6 @@ let GenConstArray cenv (cgbuf: CodeGenBuffer) eenv ilElementType (data:'a[]) (wr [ mkNormalCall (mkInitializeArrayMethSpec g) ] -//-------------------------------------------------------------------------- -// We normally generate in the context of a "what to do next" continuation -//-------------------------------------------------------------------------- - -type sequel = - | EndFilter - /// Exit a 'handler' block - /// The integer says which local to save result in - | LeaveHandler of (bool (* finally? *) * int * Mark) - /// Branch to the given mark - | Br of Mark - | CmpThenBrOrContinue of Pops * ILInstr list - /// Continue and leave the value on the IL computation stack - | Continue - /// The value then do something else - | DiscardThen of sequel - /// Return from the method - | Return - /// End a scope of local variables. Used at end of 'let' and 'let rec' blocks to get tail recursive setting - /// of end-of-scope marks - | EndLocalScope of sequel * Mark - /// Return from a method whose return type is void - | ReturnVoid - -let discard = DiscardThen Continue -let discardAndReturnVoid = DiscardThen ReturnVoid - - //------------------------------------------------------------------------- // This is the main code generation routine. It is used to generate // the bodies of methods in a couple of places @@ -2152,8 +2166,8 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = | None -> match LowerCallsAndSeqs.LowerStateMachineExpr g expr with - | Some (objExpr, ty, basev, basecall, overrides, interfaceImpls, stateVars, m) -> - GenObjectExpr cenv cgbuf eenv objExpr (ty, basev, basecall, overrides, interfaceImpls, stateVars, m) sequel + | Some objExpr -> + GenExpr cenv cgbuf eenv sp objExpr sequel | None -> match expr with @@ -2189,6 +2203,7 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = | Expr.Lambda _ | Expr.TyLambda _ -> GenLambda cenv cgbuf eenv false None expr sequel + | Expr.App (Expr.Val (vref, _, m) as v, _, tyargs, [], _) when List.forall (isMeasureTy g) tyargs && ( @@ -2199,8 +2214,10 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = ) -> // application of local type functions with type parameters = measure types and body = local value - inine the body GenExpr cenv cgbuf eenv sp v sequel + | Expr.App (f,fty, tyargs, args, m) -> GenApp cenv cgbuf eenv (f, fty, tyargs, args, m) sequel + | Expr.Val (v, _, m) -> GenGetVal cenv cgbuf eenv (v, m) sequel @@ -2292,7 +2309,7 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = CG.EmitInstr cgbuf (pop 0) Push0 (I_br label) // NOTE: discard sequel | TOp.Return, [e], _ -> - GenExpr cenv cgbuf eenv SPSuppress e Return + GenExpr cenv cgbuf eenv SPSuppress e eenv.exitSequel // NOTE: discard sequel | TOp.Return, [], _ -> GenSequel cenv eenv.cloc cgbuf ReturnVoid @@ -2301,12 +2318,15 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = cgbuf.SetMarkToHere (Mark label) GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel | _ -> error(InternalError("Unexpected operator node expression", expr.Range)) + | Expr.StaticOptimization (constraints, e2, e3, m) -> GenStaticOptimization cenv cgbuf eenv (constraints, e2, e3, m) sequel - | Expr.Obj (_, ty, _, _, [meth], [], m) when isDelegateTy g ty -> + + | Expr.Obj (_, ty, _, _, [meth], [], [], m) when isDelegateTy g ty -> GenDelegateExpr cenv cgbuf eenv expr (meth, m) sequel - | Expr.Obj (_, ty, basev, basecall, overrides, interfaceImpls, m) -> - GenObjectExpr cenv cgbuf eenv expr (ty, basev, basecall, overrides, interfaceImpls, [], m) sequel + + | Expr.Obj (_, ty, basev, basecall, overrides, interfaceImpls, stateVars, m) -> + GenObjectExpr cenv cgbuf eenv expr (ty, basev, basecall, overrides, interfaceImpls, stateVars, m) sequel | Expr.Quote (ast, conv, _, m, ty) -> GenQuotation cenv cgbuf eenv (ast, conv, m, ty) sequel | Expr.Link _ -> failwith "Unexpected reclink" @@ -2316,6 +2336,7 @@ and GenExprs cenv cgbuf eenv es = List.iter (fun e -> GenExpr cenv cgbuf eenv SPSuppress e Continue) es and CodeGenMethodForExpr cenv mgbuf (spReq, entryPointInfo, methodName, eenv, alreadyUsedArgs, expr0, sequel0) = + let eenv = { eenv with exitSequel = sequel0 } let _, code = CodeGenMethod cenv mgbuf (entryPointInfo, methodName, eenv, alreadyUsedArgs, (fun cgbuf eenv -> GenExpr cenv cgbuf eenv spReq expr0 sequel0), @@ -3223,17 +3244,19 @@ and GenTry cenv cgbuf eenv scopeMarks (e1, m, resty, spTry) = let startTryMark = CG.GenerateMark cgbuf "startTryMark" let endTryMark = CG.GenerateDelayMark cgbuf "endTryMark" let afterHandler = CG.GenerateDelayMark cgbuf "afterHandler" - let eenvinner = {eenvinner with withinSEH = true} let ilResultTy = GenType cenv.amap m eenvinner.tyenv resty let whereToSave, _realloc, eenvinner = AllocLocal cenv cgbuf eenvinner true (ilxgenGlobalNng.FreshCompilerGeneratedName ("tryres", m), ilResultTy, false) (startTryMark, endTryMark) + let exitSequel = LeaveHandler (false, whereToSave, afterHandler) + let eenvinner = {eenvinner with withinSEH = true; exitSequel = exitSequel} + // Generate the body of the try. In the normal case (SequencePointAtTry) we generate a sequence point // both on the 'try' keyword and on the start of the expression in the 'try'. For inlined code and // compiler generated 'try' blocks (i.e. NoSequencePointAtTry, used for the try/finally implicit // in a 'use' or 'foreach'), we suppress the sequence point - GenExpr cenv cgbuf eenvinner sp e1 (LeaveHandler (false, whereToSave, afterHandler)) + GenExpr cenv cgbuf eenvinner sp e1 exitSequel CG.SetMarkToHere cgbuf endTryMark let tryMarks = (startTryMark.CodeLabel, endTryMark.CodeLabel) whereToSave, eenvinner, stack, tryMarks, afterHandler, ilResultTy @@ -3253,6 +3276,7 @@ and GenTryCatch cenv cgbuf eenv (e1, vf: Val, ef, vh: Val, eh, m, resty, spTry, let startOfFilter = CG.GenerateMark cgbuf "startOfFilter" let afterFilter = CG.GenerateDelayMark cgbuf "afterFilter" let (sequelOnBranches, afterJoin, stackAfterJoin, sequelAfterJoin) = GenJoinPoint cenv cgbuf "filter" eenv g.int_ty m EndFilter + let eenvinner = { eenvinner with exitSequel = sequelOnBranches } begin // We emit the sequence point for the 'with' keyword span on the start of the filter // block. However the targets of the filter block pattern matching should not get any @@ -3310,7 +3334,9 @@ and GenTryCatch cenv cgbuf eenv (e1, vf: Val, ef, vh: Val, eh, m, resty, spTry, GenStoreVal cgbuf eenvinner m vh - GenExpr cenv cgbuf eenvinner SPAlways eh (LeaveHandler (false, whereToSave, afterHandler)) + let exitSequel = (LeaveHandler (false, whereToSave, afterHandler)) + let eenvinner = { eenvinner with exitSequel = exitSequel } + GenExpr cenv cgbuf eenvinner SPAlways eh exitSequel end let endOfHandler = CG.GenerateMark cgbuf "endOfHandler" let handlerMarks = (startOfHandler.CodeLabel, endOfHandler.CodeLabel) @@ -4043,17 +4069,22 @@ and GenObjectMethod cenv eenvinner (cgbuf: CodeGenBuffer) useMethodImpl tmethod let mdef = mdef.With(customAttrs = mkILCustomAttrs ilAttribs) [(useMethodImpl, methodImplGenerator, methTyparsOfOverridingMethod), mdef] -and GenObjectExpr cenv cgbuf eenvouter expr (baseType, baseValOpt, basecall, overrides, interfaceImpls, stateVars: ValRef list, m) sequel = +and GenObjectExpr cenv cgbuf eenvouter objExpr (baseType, baseValOpt, basecall, overrides, interfaceImpls, stateVars: ValRef list, m) sequel = let g = cenv.g let stateVarsSet = stateVars |> List.map (fun vref -> vref.Deref) |> Zset.ofList valOrder + + // State vars are only populated for state machine objects made via `__stateMachine` and LowerCallsAndSeqs. + // + // Like in GenSequenceExpression we pretend any stateVars are bound in the outer environment. This prevents the being + // considered true free variables that need to be passed to the constructor. let eenvouter = eenvouter |> AddStorageForLocalVals g (stateVars |> List.map (fun v -> v.Deref, Local(0, false, None))) - // Find the free variables of the closure, to make them fields of the object. + // Find the free variables of the closure, to make them further fields of the object. // // Note, the 'let' bindings for the stateVars have already been transformed to 'set' expressions, and thus the stateVars are now // free variables of the expression. - let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m false None eenvouter expr + let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m false None eenvouter objExpr let cloAttribs = cloinfo.cloAttribs let cloFreeVars = cloinfo.cloFreeVars @@ -4096,9 +4127,10 @@ and GenObjectExpr cenv cgbuf eenvouter expr (baseType, baseValOpt, basecall, ove for cloTypeDef in cloTypeDefs do cgbuf.mgbuf.AddTypeDef(ilCloTypeRef, cloTypeDef, false, false, None) + CountClosure() for fv in cloFreeVars do - /// State variables always get zero-initialized + // State variables always get zero-initialized if stateVarsSet.Contains fv then GenDefaultValue cenv cgbuf eenvouter (fv.Type, m) else @@ -4357,7 +4389,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = // Get a unique stamp for the closure. This must be stable for things that can be part of a let rec. let uniq = match expr with - | Expr.Obj (uniq, _, _, _, _, _, _) + | Expr.Obj (uniq, _, _, _, _, _, _, _) | Expr.Lambda (uniq, _, _, _, _, _, _) | Expr.TyLambda (uniq, _, _, _, _) -> uniq | _ -> newUnique() @@ -4444,7 +4476,7 @@ and GetIlxClosureInfo cenv m isLocalTypeFunc selfv eenvouter expr = let returnTy = match expr with | Expr.Lambda (_, _, _, _, _, _, returnTy) | Expr.TyLambda (_, _, _, _, returnTy) -> returnTy - | Expr.Obj (_, ty, _, _, _, _, _) -> ty + | Expr.Obj (_, ty, _, _, _, _, _, _) -> ty | _ -> failwith "GetIlxClosureInfo: not a lambda expression" // Determine the structure of the closure. We do this before analyzing free variables to @@ -7457,6 +7489,7 @@ let GetEmptyIlxGenEnv (ilg: ILGlobals) ccu = let thisCompLoc = CompLocForCcu ccu { tyenv=TypeReprEnv.Empty cloc = thisCompLoc + exitSequel = Return valsInScope=ValMap<_>.Empty someTypeInThisAssembly=ilg.typ_Object (* dummy value *) isFinalFile = false diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 1ff7ed3c7c1..103b27a3d31 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -1119,14 +1119,14 @@ module Pass4_RewriteAssembly = TransExpr penv z (!r) // ilobj - has implicit lambda exprs and recursive/base references - | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, m) -> - let basecall, z = TransExpr penv z basecall - let overrides, z = List.mapFold (TransMethod penv) z overrides - let (iimpls:(TType*ObjExprMethod list)list), (z: RewriteState) = - List.mapFold (fun z (tType, objExprs) -> + | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, stateVars, m) -> + let basecall, z = TransExpr penv z basecall + let overrides, z = List.mapFold (TransMethod penv) z overrides + let iimpls, z = + (z, iimpls) ||> List.mapFold (fun z (tType, objExprs) -> let objExprs', z' = List.mapFold (TransMethod penv) z objExprs - (tType, objExprs'), z') z iimpls - let expr = Expr.Obj (newUnique(), ty, basev, basecall, overrides, iimpls, m) + (tType, objExprs'), z') + let expr = Expr.Obj (newUnique(), ty, basev, basecall, overrides, iimpls, stateVars, m) let pds, z = ExtractPreDecs z MakePreDecs m pds expr, z (* if TopLevel, lift preDecs over the ilobj expr *) diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 80ca23479e8..2ab7ef6f045 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -93,7 +93,7 @@ type LoweredSeqFirstPhaseResult = phase2 : ((* pc: *) ValRef * (* current: *) ValRef * (* nextVar: *) ValRef * Map -> Expr * Expr * Expr) /// The labels allocated for one portion of the sequence expression - labels : int list + entryPoints : int list /// Indicates if any actual work is done in dispose, i.e. is there a 'try-finally' (or 'use') in the computation. significantClose : bool @@ -267,7 +267,7 @@ let LowerSeqExpr g amap overallExpr = (Expr.Op (TOp.Label label, [], [], m)) (Expr.Op (TOp.Return, [], [mkBool g m (not (noDisposeContinuationLabel = currentDisposeContinuationLabel))], m)) generate, dispose, checkDispose) - labels=[label] + entryPoints=[label] stateVars=[] significantClose = false capturedVars = emptyFreeVars @@ -286,7 +286,7 @@ let LowerSeqExpr g amap overallExpr = | Some res1, Some res2 -> let capturedVars = - if res1.labels.IsEmpty then + if res1.entryPoints.IsEmpty then res2.capturedVars else // All of 'e2' is needed after resuming at any of the labels @@ -301,7 +301,7 @@ let LowerSeqExpr g amap overallExpr = let dispose = mkCompGenSequential m dispose2 dispose1 let checkDispose = mkCompGenSequential m checkDispose2 checkDispose1 generate, dispose, checkDispose) - labels= res1.labels @ res2.labels + entryPoints= res1.entryPoints @ res2.entryPoints stateVars = res1.stateVars @ res2.stateVars significantClose = res1.significantClose || res2.significantClose capturedVars = capturedVars } @@ -314,8 +314,8 @@ let LowerSeqExpr g amap overallExpr = match resBody with | Some res2 -> let capturedVars = - if res2.labels.IsEmpty then - res2.capturedVars // the whole loopis synchronous, no labels + if res2.entryPoints.IsEmpty then + res2.capturedVars // the whole loop is synchronous, no labels else freeInExpr CollectLocals expr // everything is needed on subsequent iterations @@ -325,7 +325,7 @@ let LowerSeqExpr g amap overallExpr = let dispose = dispose2 let checkDispose = checkDispose2 generate, dispose, checkDispose) - labels = res2.labels + entryPoints = res2.entryPoints stateVars = res2.stateVars significantClose = res2.significantClose capturedVars = capturedVars } @@ -401,7 +401,7 @@ let LowerSeqExpr g amap overallExpr = (Expr.Op (TOp.Return, [], [mkTrue g m (* yes, we must dispose!!! *) ], m))) generate, dispose, checkDispose) - labels = innerDisposeContinuationLabel :: res1.labels + entryPoints = innerDisposeContinuationLabel :: res1.entryPoints stateVars = res1.stateVars significantClose = true capturedVars = capturedVars } @@ -415,7 +415,7 @@ let LowerSeqExpr g amap overallExpr = let dispose = Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m) let checkDispose = Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m) generate, dispose, checkDispose) - labels = [] + entryPoints = [] stateVars = [] significantClose = false capturedVars = emptyFreeVars } @@ -489,12 +489,12 @@ let LowerSeqExpr g amap overallExpr = if tglArray |> Array.forall Option.isSome then let tglArray = Array.map Option.get tglArray let tgl = Array.toList tglArray - let labs = tgl |> List.collect (fun res -> res.labels) + let labs = tgl |> List.collect (fun res -> res.entryPoints) let (capturedVars, _) = ((emptyFreeVars, false), Array.zip targets tglArray) ||> Array.fold (fun (fvs, seenLabel) ((TTarget(_vs, e, _spTarget)), res) -> if seenLabel then unionFreeVars fvs (freeInExpr CollectLocals e), true - else res.capturedVars, not res.labels.IsEmpty) + else res.capturedVars, not res.entryPoints.IsEmpty) let stateVars = tgl |> List.collect (fun res -> res.stateVars) let significantClose = tgl |> List.exists (fun res -> res.significantClose) Some { phase2 = (fun ctxt -> @@ -509,7 +509,7 @@ let LowerSeqExpr g amap overallExpr = let dispose = if isNil disposals then mkUnit g m else List.reduce (mkCompGenSequential m) disposals let checkDispose = if isNil checkDisposes then mkFalse g m else List.reduce (mkCompGenSequential m) checkDisposes generate, dispose, checkDispose) - labels=labs + entryPoints=labs stateVars = stateVars significantClose = significantClose capturedVars = capturedVars } @@ -569,7 +569,7 @@ let LowerSeqExpr g amap overallExpr = (Expr.Op (TOp.Label label, [], [], m)) (Expr.Op (TOp.Return, [], [mkFalse g m], m)) generate, dispose, checkDispose) - labels=[label] + entryPoints=[label] stateVars=[] significantClose = false capturedVars = emptyFreeVars } @@ -590,7 +590,7 @@ let LowerSeqExpr g amap overallExpr = | Some res -> // After phase1, create the variables for the state machine and work out a program counter for each label. - let labs = res.labels + let labs = res.entryPoints let stateVars = res.stateVars // printfn "successfully lowered, found %d state variables and %d labels!" stateVars.Length labs.Length let pcVar, pcExpr = mkMutableCompGenLocal m "pc" g.int32_ty @@ -783,10 +783,10 @@ type LoweredStateMachineFirstPhaseResult = /// The second phase of the transformation. It is run after all code labels and their mapping to program counters have been determined /// after the first phase. /// - phase2 : (Map -> Expr) + phase2 : (Map -> Expr) - /// The labels allocated for one portion of the sequence expression - labels : int list + /// The labels allocated for this portion of the computation + entryPoints : int list /// The state variables allocated for one portion of the sequence expression (i.e. the local let-bound variables which become state variables) stateVars: ValRef list @@ -798,420 +798,392 @@ type LoweredStateMachineFirstPhaseResult = -let (|StateMachine|_|) g expr = +let (|StateMachineExpr|_|) g expr = match expr with | ValApp g g.cgh_stateMachine_vref (_, [e], _m) -> Some e | _ -> None -let (|JumpTable|_|) g expr = +let (|NewEntryPointExpr|_|) g expr = match expr with - | ValApp g g.cgh_jumptable_vref (_, [pcExpr; codeExpr], _m) -> Some (pcExpr, codeExpr) + | ValApp g g.cgh_newEntryPoint_vref (_, [_], _m) -> Some () | _ -> None -let LowerStateMachineExpr g overallExpr = - - let rec Lower expr = - Some { phase2 = (fun _ctxt -> expr) - labels=[] - stateVars = [] - capturedVars = emptyFreeVars } - -(* let rec Lower - isWholeExpr - isTailCall // is this sequence in tailcall position? - noDisposeContinuationLabel // represents the label for the code where there is effectively nothing to do to dispose the iterator for the current state - currentDisposeContinuationLabel // represents the label for the code we have to run to dispose the iterator given the current state - expr = +let (|ReturnExpr|_|) g expr = + match expr with + | ValApp g g.cgh_return_vref (_, [e], m) -> Some (e, m) + | _ -> None - match expr with - | SeqYield(e, m) -> - // printfn "found Seq.singleton" - //this.pc <- NEXT - //curr <- e - //return true - //NEXT: - let label = IL.generateCodeLabel() - Some { phase2 = (fun (pcVar, currVar, _nextv, pcMap) -> - let generate = - mkCompGenSequential m - (mkValSet m pcVar (mkInt32 g m pcMap.[label])) - (mkSequential SequencePointsAtSeq m - (mkValSet m currVar e) - (mkCompGenSequential m - (Expr.Op (TOp.Return, [], [mkOne g m], m)) - (Expr.Op (TOp.Label label, [], [], m)))) - let dispose = - mkCompGenSequential m - (Expr.Op (TOp.Label label, [], [], m)) - (Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m)) - let checkDispose = - mkCompGenSequential m - (Expr.Op (TOp.Label label, [], [], m)) - (Expr.Op (TOp.Return, [], [mkBool g m (not (noDisposeContinuationLabel = currentDisposeContinuationLabel))], m)) - generate, dispose, checkDispose) - labels=[label] - stateVars=[] - significantClose = false - capturedVars = emptyFreeVars - } +let (|MachineExpr|_|) g expr = + match expr with + | ValApp g g.cgh_machine_vref ([ty], _, m) -> Some (ty, m) + | _ -> None - | SeqDelay(delayedExpr, _elemTy) -> - // printfn "found Seq.delay" - // note, using 'isWholeExpr' here prevents 'seq { yield! e }' and 'seq { 0 .. 1000 }' from being compiled - Lower isWholeExpr isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel delayedExpr +let (|EntryPointExpr|_|) g expr = + match expr with + | ValApp g g.cgh_entryPoint_vref (_, [e], m) -> Some (e, m) + | _ -> None - | SeqAppend(e1, e2, m) -> - // printfn "found Seq.append" - let res1 = Lower false false noDisposeContinuationLabel currentDisposeContinuationLabel e1 - let res2 = Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 - match res1, res2 with - | Some res1, Some res2 -> +let (|JumpTableExpr|_|) g expr = + match expr with + | ValApp g g.cgh_jumptable_vref (_, [pcExpr; codeExpr], _m) -> Some (pcExpr, codeExpr) + | _ -> None - let capturedVars = - if res1.labels.IsEmpty then - res2.capturedVars - else - // All of 'e2' is needed after resuming at any of the labels - unionFreeVars res1.capturedVars (freeInExpr CollectLocals e2) +/// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) +let RepresentBindingAsLiftedOrLocal (bind: Binding) (res2: LoweredStateMachineFirstPhaseResult) m = + // printfn "LowerSeq: found local variable %s" bind.Var.DisplayName + { res2 with + phase2 = (fun ctxt -> mkLetBind m bind (res2.phase2 ctxt)) } + +/// Implement a decision to represent a 'let' binding as a state machine variable +let RepresentBindingAsStateVar (bind: Binding) (res2: LoweredStateMachineFirstPhaseResult) m = + // printfn "LowerSeq: found state variable %s" bind.Var.DisplayName + let (TBind(v, e, sp)) = bind + let sp, spm = + match sp with + | SequencePointAtBinding m -> SequencePointsAtSeq, m + | _ -> SuppressSequencePointOnExprOfSequential, e.Range + let vref = mkLocalValRef v + { res2 with + phase2 = (fun ctxt -> + let generate2 = res2.phase2 ctxt + let generate = + //mkCompGenSequential m + (mkSequential sp m + (mkValSet spm vref e) + generate2) + // TODO: zero out the current value to free up its memory - but return type is not unit... + // (mkValSet m vref (mkDefault (m, vref.Type))) + generate ) + stateVars = vref :: res2.stateVars } + +// We look ahead one binding to find the binding of the code +// +// GIVEN: +// member inline __.Run(code : unit -> TaskStep<'T>) = +// (__stateMachine +// { new TaskStateMachine<'T>() with +// member __.Step(pc) = __jumptable pc code }).Start() +// +// THEN +// task { ... } +// +// IN DEBUG: +// +// let builder@ = task +// let code = +// let builder@ = task +// (fun ....) +// (__stateMachine code).Start() +// +// IN RELEASE: +// +// let code = (fun ...) +// (__stateMachine code).Start() + +// TODO: this is too adhoc +let isMustExpandVar (v: Val) = + let nm = v.LogicalName + nm.StartsWith "__expand_" + || nm.StartsWith "builder@" + || (v.BaseOrThisInfo = MemberThisVal) + +let isExpandVar (v: Val) = + isMustExpandVar v + || (v.BaseOrThisInfo = MemberThisVal) - Some { phase2 = (fun ctxt -> - let generate1, dispose1, checkDispose1 = res1.phase2 ctxt - let generate2, dispose2, checkDispose2 = res2.phase2 ctxt - let generate = mkCompGenSequential m generate1 generate2 - // Order shouldn't matter here, since disposals actions are linked together by goto's (each ends in a goto). - // However leaving as is for now. - let dispose = mkCompGenSequential m dispose2 dispose1 - let checkDispose = mkCompGenSequential m checkDispose2 checkDispose1 - generate, dispose, checkDispose) - labels= res1.labels @ res2.labels - stateVars = res1.stateVars @ res2.stateVars - significantClose = res1.significantClose || res2.significantClose - capturedVars = capturedVars } - | _ -> - None - | SeqWhile(guardExpr, bodyExpr, m) -> - // printfn "found Seq.while" - let resBody = Lower false false noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr - match resBody with - | Some res2 -> - let capturedVars = - if res2.labels.IsEmpty then - res2.capturedVars // the whole loopis synchronous, no labels - else - freeInExpr CollectLocals expr // everything is needed on subsequent iterations +let LowerStateMachineExpr g overallExpr = - Some { phase2 = (fun ctxt -> - let generate2, dispose2, checkDispose2 = res2.phase2 ctxt - let generate = mkWhile g (SequencePointAtWhileLoop guardExpr.Range, NoSpecialWhileLoopMarker, guardExpr, generate2, m) - let dispose = dispose2 - let checkDispose = checkDispose2 - generate, dispose, checkDispose) - labels = res2.labels - stateVars = res2.stateVars - significantClose = res2.significantClose - capturedVars = capturedVars } - | _ -> - None + let mutable pcCount = 0 + let genPC() = + pcCount <- pcCount + 1 + pcCount - | SeqUsing(resource, v, body, elemTy, m) -> - // printfn "found Seq.using" - let reduction = - mkLet (SequencePointAtBinding body.Range) m v resource - (mkCallSeqFinally g m elemTy body - (mkUnitDelayLambda g m - (mkCallDispose g m v.Type (exprForVal m v)))) - Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction + // Evaluate __expand_ABC and __newEntryPoint bindings at compile-time + let rec BindExpansions g (env: ValMap<_>) expr = - | SeqFor(inp, v, body, genElemTy, m) -> - // printfn "found Seq.for" - let inpElemTy = v.Type - let inpEnumTy = mkIEnumeratorTy g inpElemTy - let enumv, enume = mkCompGenLocal m "enum" inpEnumTy - // [[ use enum = inp.GetEnumerator() - // while enum.MoveNext() do - // let v = enum.Current - // body ]] - let reduction = - mkCallSeqUsing g m inpEnumTy genElemTy (callNonOverloadedMethod g amap m "GetEnumerator" (mkSeqTy g inpElemTy) [inp]) - (mkLambdaNoType g m enumv - (mkCallSeqGenerated g m genElemTy (mkUnitDelayLambda g m (callNonOverloadedMethod g amap m "MoveNext" inpEnumTy [enume])) - (mkInvisibleLet m v (callNonOverloadedMethod g amap m "get_Current" inpEnumTy [enume]) - (mkCoerceIfNeeded g (mkSeqTy g genElemTy) (tyOfExpr g body) body)))) - Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction + match expr with + // Bind 'let __expand_ABC = bindExpr in bodyExpr' + | Expr.Let (bind, bodyExpr, _, _) when isExpandVar bind.Var -> + let envR = env.Add bind.Var bind.Expr + BindExpansions g envR bodyExpr - | SeqTryFinally(e1, compensation, m) -> - // printfn "found Seq.try/finally" - let innerDisposeContinuationLabel = IL.generateCodeLabel() - let resBody = Lower false false noDisposeContinuationLabel innerDisposeContinuationLabel e1 - match resBody with - | Some res1 -> - let capturedVars = unionFreeVars res1.capturedVars (freeInExpr CollectLocals compensation) - Some { phase2 = (fun ((pcVar, _currv, _, pcMap) as ctxt) -> - let generate1, dispose1, checkDispose1 = res1.phase2 ctxt - let generate = - // copy the compensation expression - one copy for the success continuation and one for the exception - let compensation = copyExpr g CloneAllAndMarkExprValsAsCompilerGenerated compensation - mkCompGenSequential m - // set the PC to the inner finally, so that if an exception happens we run the right finally - (mkCompGenSequential m - (mkValSet m pcVar (mkInt32 g m pcMap.[innerDisposeContinuationLabel])) - generate1 ) - // set the PC past the try/finally before trying to run it, to make sure we only run it once - (mkCompGenSequential m - (Expr.Op (TOp.Label innerDisposeContinuationLabel, [], [], m)) - (mkCompGenSequential m - (mkValSet m pcVar (mkInt32 g m pcMap.[currentDisposeContinuationLabel])) - compensation)) - let dispose = - // generate inner try/finallys, then outer try/finallys - mkCompGenSequential m - dispose1 - // set the PC past the try/finally before trying to run it, to make sure we only run it once - (mkCompGenSequential m - (Expr.Op (TOp.Label innerDisposeContinuationLabel, [], [], m)) - (mkCompGenSequential m - (mkValSet m pcVar (mkInt32 g m pcMap.[currentDisposeContinuationLabel])) - (mkCompGenSequential m - compensation - (Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m))))) - let checkDispose = - mkCompGenSequential m - checkDispose1 - (mkCompGenSequential m - (Expr.Op (TOp.Label innerDisposeContinuationLabel, [], [], m)) - (Expr.Op (TOp.Return, [], [mkTrue g m (* yes, we must dispose!!! *) ], m))) + // Bind 'let CODE = __newEntryPoint() in bodyExpr' + | Expr.Let (TBind(v, NewEntryPointExpr g (), _sp), bodyExpr, m, _) -> + printfn "found __newEntryPoint()" + let envR = env.Add v (mkInt g m (genPC())) + BindExpansions g envR bodyExpr - generate, dispose, checkDispose) - labels = innerDisposeContinuationLabel :: res1.labels - stateVars = res1.stateVars - significantClose = true - capturedVars = capturedVars } - | _ -> - None + | _ -> + (env, expr) - | SeqEmpty m -> - // printfn "found Seq.empty" - Some { phase2 = (fun _ -> - let generate = mkUnit g m - let dispose = Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m) - let checkDispose = Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m) - generate, dispose, checkDispose) - labels = [] - stateVars = [] - significantClose = false - capturedVars = emptyFreeVars } + let (|SequentialCode|_|) expr = + match expr with - | Expr.Sequential (x1, x2, NormalSeq, ty, m) -> - match Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel x2 with - | Some res2-> - // printfn "found sequential execution" - Some { res2 with - phase2 = (fun ctxt -> - let generate2, dispose2, checkDispose2 = res2.phase2 ctxt - let generate = Expr.Sequential (x1, generate2, NormalSeq, ty, m) - let dispose = dispose2 - let checkDispose = checkDispose2 - generate, dispose, checkDispose) } - | None -> None + // e1; e2 + | Expr.Sequential(e1, e2, NormalSeq, _, m) -> + Some (e1, e2, m, (fun e1 e2 -> mkCompGenSequential m e1 e2)) - | Expr.Let (bind, bodyExpr, m, _) - // Restriction: compilation of sequence expressions containing non-toplevel constrained generic functions is not supported - when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericContraints g bind.Var) -> + // let _step = e1 in e2 + | Expr.Let(bind, e2, m, _) when bind.Var.CompiledName = "_step" -> // TODO this is way too adhoc + Some (bind.Expr, e2, m, (fun e1 e2 -> mkLet bind.SequencePointInfo m bind.Var e1 e2)) - let resBody = Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr - match resBody with - | Some res2 -> - if bind.Var.IsCompiledAsTopLevel then - Some (RepresentBindingsAsLifted (mkLetBind m bind) res2) - elif not (res2.capturedVars.FreeLocals.Contains(bind.Var)) then - // printfn "found state variable %s" bind.Var.DisplayName - Some (RepresentBindingAsLocal bind res2 m) - else - // printfn "found state variable %s" bind.Var.DisplayName - Some (RepresentBindingAsStateMachineLocal bind res2 m) - | None -> - None + | _ -> None -(* - | Expr.LetRec (binds, e2, m, _) - when // Restriction: only limited forms of "let rec" in sequence expressions can be handled by assignment to state local values + let rec (|ApplyExpansions|) g (env: ValMap<_>) expr = + let env, expr = BindExpansions g env expr + match expr with + // __machine --> ldarg.0 + | MachineExpr g (ty, m) -> + mkGetArg0 m ty + + // __expand_code --> [expand_code] + | Expr.Val (vref, _, _) when env.ContainsVal vref.Deref -> + let expandedExpr = env.[vref.Deref] + printfn "expanded %A --> %A..." expr expandedExpr + (|ApplyExpansions|) g env expandedExpr + + // __expand_code x --> let arg = x in expand_code[arg/x] + | Expr.App (Expr.Val (vref, _, _), fty, [], args, m) when env.ContainsVal vref.Deref -> + let f0 = env.[vref.Deref] + let expandedExpr = MakeApplicationAndBetaReduce g (f0, fty, [], args, m) + printfn "expanded %A --> %A..." expr expandedExpr + (|ApplyExpansions|) g env expandedExpr + + | _ -> expr + + let rec (|StateMachineInContext|_|) g (env: ValMap<_>) overallExpr = + let env, expr = BindExpansions g env overallExpr + match expr with + | Expr.App (f0, f0ty, tyargsl, (StateMachineExpr g objExpr :: args), mApp) -> + Some (env, objExpr, (fun objExprR -> Expr.App (f0, f0ty, tyargsl, (objExprR :: args), mApp))) + | StateMachineExpr g objExpr -> + Some (env, objExpr, id) + | _ -> None - (let recvars = valsOfBinds binds |> List.map (fun v -> (v, 0)) |> ValMap.OfList - binds |> List.forall (fun bind -> - // Rule 1 - IsCompiledAsTopLevel require no state local value - bind.Var.IsCompiledAsTopLevel || - // Rule 2 - funky constrained local funcs not allowed - not (IsGenericValWithGenericContraints g bind.Var)) && - binds |> List.count (fun bind -> - // Rule 3 - Recursive non-lambda and repack values are allowed - match stripExpr bind.Expr with - | Expr.Lambda _ - | Expr.TyLambda _ -> false - // "let v = otherv" bindings get produced for environment packing by InnerLambdasToTopLevelFuncs.fs, we can accept and compiler these ok - | Expr.Val (v, _, _) when not (recvars.ContainsVal v.Deref) -> false - | _ -> true) <= 1) -> + let (|SingleMethodStateMachineInContext|_|) g overallExpr = + match overallExpr with + | StateMachineInContext g ValMap.Empty (env, objExpr, remake) -> + printfn "Found state machine..." + match objExpr with + | Expr.Obj (objExprStamp, ty, basev, basecall, overrides, iimpls, stateVars, objExprRange) -> + printfn "Found state machine object..." + match overrides with + | [ (TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, + (JumpTableExpr g (pcExpr, ApplyExpansions g env (Expr.Lambda (_, _, _, [_dummyv], codeExpr, _, _)))), m)) ] -> + Some (env, objExprStamp, objExprRange, remake, ty, basev, basecall, slotsig, attribs, methTyparsOfOverridingMethod, methodParams, pcExpr, codeExpr, iimpls, stateVars, m) + | _ -> None + | _ -> None + | _ -> None - match Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 with - | Some res2 -> - let topLevelBinds, nonTopLevelBinds = binds |> List.partition (fun bind -> bind.Var.IsCompiledAsTopLevel) - // Represent the closure-capturing values as state machine locals. They may still be recursively-referential - let res3 = (res2, nonTopLevelBinds) ||> List.fold (fun acc bind -> RepresentBindingAsStateMachineLocal bind acc m) - // Represent the non-closure-capturing values as ordinary bindings on the expression. - let res4 = if topLevelBinds.IsEmpty then res3 else RepresentBindingsAsLifted (mkLetRecBinds m topLevelBinds) res3 - Some res4 - | None -> - None -*) + // A utility to add a jump table an expression + let addPcJumpTable (g: TcGlobals) m (pcs: int list) (pc2lab: Map) pcExpr expr = + if pcs.IsEmpty then + expr + else + let initLabel = IL.generateCodeLabel() + let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding, m ) + let mkGotoLabelTarget lab = mbuilder.AddResultTarget(Expr.Op (TOp.Goto lab, [], [], m), SuppressSequencePointAtTarget) + let dtree = + TDSwitch(pcExpr, + [ // Yield one target for each PC, where the action of the target is to goto the appropriate label + for pc in pcs do + yield mkCase(DecisionTreeTest.Const(Const.Int32 pc), mkGotoLabelTarget pc2lab.[pc]) ], + // The default is to go to pcInit + Some(mkGotoLabelTarget initLabel), + m) + + let table = mbuilder.Close(dtree, m, g.int_ty) + mkCompGenSequential m table (mkCompGenSequential m (Expr.Op (TOp.Label initLabel, [], [], m)) expr) + + let rec Lower env pcExpr expr = + printfn "Lowering %A" expr + let env, expr = BindExpansions g env expr + let expr = (|ApplyExpansions|) g env expr + printfn "Expanded to %A" expr + match expr with + // __entryPoint --> label: + | EntryPointExpr g (ApplyExpansions g env (Int32Expr pc), m) -> + { phase2 = (fun pc2lab -> Expr.Op (TOp.Label pc2lab.[pc], [], [], m)) + entryPoints=[pc] + stateVars = [] + capturedVars = emptyFreeVars } + + // __return v --> return + | ReturnExpr g (v, m) -> + let expr = Expr.Op (TOp.Return, [], [v], m) + { phase2 = (fun _ctxt -> expr) + entryPoints = [] + stateVars = [] + capturedVars = emptyFreeVars } + + // control-flow sequential + // let _step = e1 in e2 + // e1; e2 + | SequentialCode(e1, e2, _m, recreate) -> + // printfn "found sequential" + let res1 = Lower env pcExpr e1 + let res2 = Lower env pcExpr e2 + let capturedVars = + if res1.entryPoints.IsEmpty then + // res1 is synchronous + res2.capturedVars + else + // res1 is not synchronous. All of 'e2' is needed after resuming at any of the labels + unionFreeVars res1.capturedVars (freeInExpr CollectLocals e2) + + { phase2 = (fun ctxt -> + let generate1 = res1.phase2 ctxt + let generate2 = res2.phase2 ctxt + let generate = recreate generate1 generate2 + generate) + entryPoints= res1.entryPoints @ res2.entryPoints + stateVars = res1.stateVars @ res2.stateVars + capturedVars = capturedVars } + + //| TOp.While _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _)] -> + // exprF (exprF z e1) e2 + + //| TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)] -> + // exprF (exprF z e1) e2 + + //| TOp.For (_), _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [_], e3, _, _)] -> + // exprF (exprF (exprF z e1) e2) e3 + + // Note: residue code of state machine implementations is allowed to use 'TryCatch'... + | Expr.Op (TOp.TryCatch (spTry, spWith), [resty], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [vf], ef, _, _); Expr.Lambda (_, _, _, [vh], eh, _, _)], m) -> + let res1 = Lower env pcExpr e1 + let resf = Lower env pcExpr ef + let resh = Lower env pcExpr eh + { phase2 = (fun ctxt -> + // We can't jump into a try/catch block. So we jump to the start of the try/catch and add a new jump table + let pcsAndLabs = ctxt |> Map.toList + let innerPcs = res1.entryPoints + if innerPcs.IsEmpty then + let e1R = res1.phase2 ctxt + let efR = resf.phase2 ctxt + let ehR = resh.phase2 ctxt + mkTryWith g (e1R, vf, efR, vh, ehR, m, resty, spTry, spWith) + else + let innerPcSet = innerPcs |> Set.ofList + let outerLabsForInnerPcs = pcsAndLabs |> List.filter (fun (pc, _outerLab) -> innerPcSet.Contains pc) |> List.map snd + // generate the inner labels + let pcsAndInnerLabs = pcsAndLabs |> List.map (fun (pc, l) -> (pc, if innerPcSet.Contains pc then IL.generateCodeLabel() else l)) + let innerPc2Lab = Map.ofList pcsAndInnerLabs + + let e1R = res1.phase2 innerPc2Lab + let efR = resf.phase2 ctxt + let ehR = resh.phase2 ctxt + + let e1RWithJumpTable = addPcJumpTable g m innerPcs innerPc2Lab pcExpr e1R + let coreExpr = mkTryWith g (e1RWithJumpTable, vf, efR, vh, ehR, m, resty, spTry, spWith) + // place all the outer labels just before the try + let labelledExpr = (coreExpr, outerLabsForInnerPcs) ||> List.fold (fun e l -> mkCompGenSequential m (Expr.Op (TOp.Label l, [], [], m)) e) + + + //((pcInit, initLabel) :: List.zip pcs labs) + + labelledExpr) + entryPoints= res1.entryPoints @ resf.entryPoints @ resh.entryPoints + stateVars = res1.stateVars @ resf.stateVars @ resh.stateVars + capturedVars = unionFreeVars res1.capturedVars (unionFreeVars(freeInExpr CollectLocals ef) (freeInExpr CollectLocals eh)) } + + // control-flow match | Expr.Match (spBind, exprm, pt, targets, m, ty) when targets |> Array.forall (fun (TTarget(vs, _e, _spTarget)) -> isNil vs) -> // lower all the targets. abandon if any fail to lower - let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel targetExpr) + let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> Lower env pcExpr targetExpr) // LIMITATION: non-trivial pattern matches involving or-patterns or active patterns where bindings can't be // transferred to the r.h.s. are not yet compiled. - if tglArray |> Array.forall Option.isSome then - let tglArray = Array.map Option.get tglArray - let tgl = Array.toList tglArray - let labs = tgl |> List.collect (fun res -> res.labels) - let (capturedVars, _) = - ((emptyFreeVars, false), Array.zip targets tglArray) - ||> Array.fold (fun (fvs, seenLabel) ((TTarget(_vs, e, _spTarget)), res) -> - if seenLabel then unionFreeVars fvs (freeInExpr CollectLocals e), true - else res.capturedVars, not res.labels.IsEmpty) - let stateVars = tgl |> List.collect (fun res -> res.stateVars) - let significantClose = tgl |> List.exists (fun res -> res.significantClose) - Some { phase2 = (fun ctxt -> - let gtgs, disposals, checkDisposes = + let tgl = Array.toList tglArray + let entyPoints = tgl |> List.collect (fun res -> res.entryPoints) + let (capturedVars, _) = + ((emptyFreeVars, false), Array.zip targets tglArray) + ||> Array.fold (fun (fvs, seenLabel) ((TTarget(_vs, e, _spTarget)), res) -> + if seenLabel then unionFreeVars fvs (freeInExpr CollectLocals e), true + else res.capturedVars, not res.entryPoints.IsEmpty) + let stateVars = tgl |> List.collect (fun res -> res.stateVars) + { phase2 = (fun ctxt -> + let gtgs = (Array.toList targets, tgl) ||> List.map2 (fun (TTarget(vs, _, spTarget)) res -> - let generate, dispose, checkDispose = res.phase2 ctxt + let generate = res.phase2 ctxt let gtg = TTarget(vs, generate, spTarget) - gtg, dispose, checkDispose) - |> List.unzip3 + gtg) let generate = primMkMatch (spBind, exprm, pt, Array.ofList gtgs, m, ty) - let dispose = if isNil disposals then mkUnit g m else List.reduce (mkCompGenSequential m) disposals - let checkDispose = if isNil checkDisposes then mkFalse g m else List.reduce (mkCompGenSequential m) checkDisposes - generate, dispose, checkDispose) - labels=labs - stateVars = stateVars - significantClose = significantClose - capturedVars = capturedVars } - else - None + generate) + entryPoints=entyPoints + stateVars = stateVars + capturedVars = capturedVars } - // yield! e ---> (for x in e -> x) - // - // Design choice: we compile 'yield! e' as 'for x in e do yield x'. - // - // Note, however, this leads to a loss of tailcalls: the case not - // handled correctly yet is sequence expressions that use yield! in the last position - // This can give rise to infinite iterator chains when implemented by the naive expansion to - // 'for x in e yield e'. For example consider this: - // - // let rec rwalk x = { yield x - // yield! rwalk (x + rand()) } - // - // This is the moral equivalent of a tailcall optimization. These also don't compile well - // in the C# compilation model + // Non-control-flow let binding + | Expr.Let (bind, bodyExpr, m, _) + // Restriction: compilation of sequence expressions containing non-toplevel constrained generic functions is not supported + when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericContraints g bind.Var) -> - | arbitrarySeqExpr -> - let m = arbitrarySeqExpr.Range - if isWholeExpr then - // printfn "FAILED - not worth compiling an unrecognized immediate yield! %s " (stringOfRange m) - None - else - let tyConfirmsToSeq g ty = isAppTy g ty && tyconRefEq g (tcrefOfAppTy g ty) g.tcref_System_Collections_Generic_IEnumerable - match SearchEntireHierarchyOfType (tyConfirmsToSeq g) g amap m (tyOfExpr g arbitrarySeqExpr) with - | None -> - // printfn "FAILED - yield! did not yield a sequence! %s" (stringOfRange m) - None - | Some ty -> - // printfn "found yield!" - let inpElemTy = List.head (argsOfAppTy g ty) - if isTailCall then - //this.pc <- NEXT - //nextEnumerator <- e - //return 2 - //NEXT: - let label = IL.generateCodeLabel() - Some { phase2 = (fun (pcVar, _currv, nextVar, pcMap) -> - let generate = - mkCompGenSequential m - (mkValSet m pcVar (mkInt32 g m pcMap.[label])) - (mkSequential SequencePointsAtSeq m - (mkAddrSet m nextVar arbitrarySeqExpr) - (mkCompGenSequential m - (Expr.Op (TOp.Return, [], [mkTwo g m], m)) - (Expr.Op (TOp.Label label, [], [], m)))) - let dispose = - mkCompGenSequential m - (Expr.Op (TOp.Label label, [], [], m)) - (Expr.Op (TOp.Goto currentDisposeContinuationLabel, [], [], m)) - let checkDispose = - mkCompGenSequential m - (Expr.Op (TOp.Label label, [], [], m)) - (Expr.Op (TOp.Return, [], [mkFalse g m], m)) - generate, dispose, checkDispose) - labels=[label] - stateVars=[] - significantClose = false - capturedVars = emptyFreeVars } - else - let v, ve = mkCompGenLocal m "v" inpElemTy - Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel (mkCallSeqCollect g m inpElemTy inpElemTy (mkLambdaNoType g m v (mkCallSeqSingleton g m inpElemTy ve)) arbitrarySeqExpr) - *) + // Rewrite the expression on the r.h.s. of the binding + let bind = mkBind bind.SequencePointInfo bind.Var ((|ApplyExpansions|) g env bind.Expr) + let resBody = Lower env pcExpr bodyExpr + if bind.Var.IsCompiledAsTopLevel || not (resBody.capturedVars.FreeLocals.Contains(bind.Var)) then + (RepresentBindingAsLiftedOrLocal bind resBody m) + else + // printfn "found state variable %s" bind.Var.DisplayName + (RepresentBindingAsStateVar bind resBody m) + + // Arbitrary expression + | _ -> + let expr = + RewriteExpr { PreIntercept = None + PostTransform = (fun e -> Some ((|ApplyExpansions|) g env e)) + PreInterceptBinding = None + IsUnderQuotations=true } expr + { phase2 = (fun _ctxt -> expr) + entryPoints=[] + stateVars = [] + capturedVars = emptyFreeVars } match overallExpr with - | StateMachine g objExpr -> - printfn "Found state machine..." - match objExpr with - | Expr.Obj (_, ty, basev, basecall, overrides, interfaceImpls, _m) -> - printfn "Found state machine object..." - match overrides with - | [ (TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, (JumpTable g (pcExpr, codeExpr)), m)) ] -> - printfn "Found state machine override method..." - // printfn "found seq { ... } or Seq.delay (fun () -> ...) in FSharp.Core.dll" - //let m = e.Range - let initLabel = IL.generateCodeLabel() - let noDisposeContinuationLabel = IL.generateCodeLabel() - - // Perform phase1 - match Lower codeExpr with - | Some res -> - let labs = res.labels - let stateVars = res.stateVars - let pcs = labs |> List.mapi (fun i _ -> i + 1) - let pcDone = labs.Length + 1 - let pcInit = 0 - let pc2lab = Map.ofList ((pcInit, initLabel) :: (pcDone, noDisposeContinuationLabel) :: List.zip pcs labs) - let lab2pc = Map.ofList ((initLabel, pcInit) :: (noDisposeContinuationLabel, pcDone) :: List.zip labs pcs) - - // A utility to add a jump table to the three generated methods - let addJumpTable pcExpr expr = - let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding, m ) - let mkGotoLabelTarget lab = mbuilder.AddResultTarget(Expr.Op (TOp.Goto lab, [], [], m), SuppressSequencePointAtTarget) - let dtree = - TDSwitch(pcExpr, - [ - // Yield one target for each PC, where the action of the target is to goto the appropriate label - for pc in pcs do - yield mkCase(DecisionTreeTest.Const(Const.Int32 pc), mkGotoLabelTarget pc2lab.[pc]) - - // Yield one target for the 'done' program counter, where the action of the target is to continuation label - yield mkCase(DecisionTreeTest.Const(Const.Int32 pcDone), mkGotoLabelTarget noDisposeContinuationLabel) ], - Some(mkGotoLabelTarget pc2lab.[pcInit]), - m) - - let table = mbuilder.Close(dtree, m, g.int_ty) - mkCompGenSequential m table (mkCompGenSequential m (Expr.Op (TOp.Label initLabel, [], [], m)) expr) + // TODO: use appInfo + | SingleMethodStateMachineInContext g (env, objExprStamp, objExprRange, remake, ty, basev, basecall, slotsig, attribs, methTyparsOfOverridingMethod, methodParams, pcExpr, codeExpr, iimpls, origStateVars, m) -> + printfn "Found state machine override method and code expression..." + printfn "----------- BEFORE LOWER ----------------------" + printfn "%s" (DebugPrint.showExpr codeExpr) + printfn "----------- LOWER ----------------------" + // printfn "found seq { ... } or Seq.delay (fun () -> ...) in FSharp.Core.dll" + //let m = e.Range - // Execute phase2, building the core of the the GenerateNext, Dispose and CheckDispose methods - let methodBodyExprR = res.phase2 lab2pc - let methodBodyExprWithJumpTable = addJumpTable pcExpr methodBodyExprR - let overrideR = TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, methodBodyExprWithJumpTable, m) - Some (objExpr, ty, basev, basecall, [overrideR], interfaceImpls, stateVars, m) - | None -> None - | _ -> None - | _ -> None + // Perform phase1 + let res = Lower env pcExpr codeExpr + let pcs = [ 1 .. pcCount ] + let stateVars = res.stateVars + let labs = pcs |> List.map (fun _ -> IL.generateCodeLabel()) + let pc2lab = Map.ofList (List.zip pcs labs) + + // Execute phase2, building the core of the method + printfn "----------- PHASE2 ----------------------" + let methodBodyExprR = res.phase2 pc2lab + printfn "----------- ADDING JUMP TABLE ----------------------" + let methodBodyExprWithJumpTable = addPcJumpTable g m pcs pc2lab pcExpr methodBodyExprR + let overrideR = TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, methodBodyExprWithJumpTable, m) + let objExprR = Expr.Obj (objExprStamp, ty, basev, basecall, [overrideR], iimpls, origStateVars @ stateVars, objExprRange) + printfn "----------- REMAKE ----------------------" + let overallExprR = remake objExprR + printfn "----------- AFTER REWRITE ----------------------" + printfn "%s" (DebugPrint.showExpr overallExprR) + printfn "----------- CHECKING ----------------------" + let mutable failed = false + let _expr = + overallExprR |> RewriteExpr + { PreIntercept = None + PostTransform = (fun e -> + match e with + | Expr.Val(vref, _, _) when isMustExpandVar vref.Deref -> + System.Diagnostics.Debug.Assert(false, "FAILED: unexpected expand var") + failed <- true + None + | _ -> None) + PreInterceptBinding = None + IsUnderQuotations=true } + if failed then None else Some overallExprR | _ -> None diff --git a/src/fsharp/LowerCallsAndSeqs.fsi b/src/fsharp/LowerCallsAndSeqs.fsi index c8522b1f21f..be2ff03c5c7 100644 --- a/src/fsharp/LowerCallsAndSeqs.fsi +++ b/src/fsharp/LowerCallsAndSeqs.fsi @@ -23,4 +23,4 @@ val LowerSeqExpr: g: TcGlobals -> amap: ImportMap -> overallExpr: Expr -> (ValRe /// Analyze a TAST expression to detect the elaborated form of a state machine expression, a special kind /// of object expression that uses special code generation constructs. -val LowerStateMachineExpr: g: TcGlobals -> overallExpr: Expr -> (Expr * TType * Val option * Expr * ObjExprMethod list * (TType * ObjExprMethod list) list * ValRef list * range) option +val LowerStateMachineExpr: g: TcGlobals -> overallExpr: Expr -> Expr option diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 2eea2ef8db4..321c1e2e585 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -1874,7 +1874,7 @@ let rec OptimizeExpr cenv (env: IncrementalOptimizationEnv) expr = MightMakeCriticalTailcall=false Info=UnknownValue } - | Expr.Obj (_, ty, basev, createExpr, overrides, iimpls, m) -> + | Expr.Obj (_, ty, basev, createExpr, overrides, iimpls, _stateVars, m) -> OptimizeObjectExpr cenv env (ty, basev, createExpr, overrides, iimpls, m) | Expr.Op (op, tyargs, args, m) -> @@ -1924,7 +1924,7 @@ and OptimizeObjectExpr cenv env (ty, baseValOpt, basecall, overrides, iimpls, m) let basecallR, basecallinfo = OptimizeExpr cenv env basecall let overridesR, overrideinfos = OptimizeMethods cenv env baseValOpt overrides let iimplsR, iimplsinfos = OptimizeInterfaceImpls cenv env baseValOpt iimpls - let exprR=mkObjExpr(ty, baseValOpt, basecallR, overridesR, iimplsR, m) + let exprR = mkObjExpr (ty, baseValOpt, basecallR, overridesR, iimplsR, m) exprR, { TotalSize=closureTotalSize + basecallinfo.TotalSize + AddTotalSizes overrideinfos + AddTotalSizes iimplsinfos FunctionSize=1 (* a newobj *) HasEffect=true diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index ddbad8f09eb..5f0c5ecaa89 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -954,7 +954,7 @@ and CheckExpr (cenv: cenv) (env: env) origExpr (context: PermitByRefExpr) : Limi CheckTypeNoByrefs cenv env m ty NoLimit - | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, m) -> + | Expr.Obj (_, ty, basev, superInitCall, overrides, iimpls, _stateVars, m) -> CheckExprNoByrefs cenv env superInitCall CheckMethods cenv env basev overrides CheckInterfaceImpls cenv env basev iimpls diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index ecbe10d5ad2..86a68e1c53f 100644 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -400,7 +400,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. // initialization check | Expr.Sequential (ObjectInitializationCheck cenv.g, x1, NormalSeq, _, _) -> ConvExpr cenv env x1 | Expr.Sequential (x0, x1, NormalSeq, _, _) -> QP.mkSequential(ConvExpr cenv env x0, ConvExpr cenv env x1) - | Expr.Obj (_, ty, _, _, [TObjExprMethod(TSlotSig(_, ctyp, _, _, _, _), _, tps, [tmvs], e, _) as tmethod], _, m) when isDelegateTy cenv.g ty -> + | Expr.Obj (_, ty, _, _, [TObjExprMethod(TSlotSig(_, ctyp, _, _, _, _), _, tps, [tmvs], e, _) as tmethod], _, _, m) when isDelegateTy cenv.g ty -> let f = mkLambdas m tps tmvs (e, GetFSharpViewOfReturnType cenv.g (returnTyOfMethod cenv.g tmethod)) let fR = ConvExpr cenv env f let tyargR = ConvType cenv env m ctyp @@ -409,7 +409,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. | Expr.StaticOptimization (_, _, x, _) -> ConvExpr cenv env x | Expr.TyChoose _ -> ConvExpr cenv env (TypeRelations.ChooseTyparSolutionsForFreeChoiceTypars cenv.g cenv.amap expr) | Expr.Sequential (x0, x1, ThenDoSeq, _, _) -> QP.mkSequential(ConvExpr cenv env x0, ConvExpr cenv env x1) - | Expr.Obj (_lambdaId, _typ, _basev, _basecall, _overrides, _iimpls, m) -> wfail(Error(FSComp.SR.crefQuotationsCantContainObjExprs(), m)) + | Expr.Obj (_lambdaId, _typ, _basev, _basecall, _overrides, _iimpls, _stateVars, m) -> wfail(Error(FSComp.SR.crefQuotationsCantContainObjExprs(), m)) | Expr.Op (op, tyargs, args, m) -> match op, tyargs, args with diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 4743ff03dfc..f309c1882f2 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1140,7 +1140,7 @@ let tryDestRefTupleExpr e = match e with Expr.Op (TOp.Tuple tupInfo, _, es, _) w let rec rangeOfExpr x = match x with | Expr.Val (_, _, m) | Expr.Op (_, _, _, m) | Expr.Const (_, m, _) | Expr.Quote (_, _, _, m, _) - | Expr.Obj (_, _, _, _, _, _, m) | Expr.App (_, _, _, _, m) | Expr.Sequential (_, _, _, _, m) + | Expr.Obj (_, _, _, _, _, _, _, m) | Expr.App (_, _, _, _, m) | Expr.Sequential (_, _, _, _, m) | Expr.StaticOptimization (_, _, _, m) | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _)| Expr.TyChoose (_, _, m) | Expr.LetRec (_, _, m, _) | Expr.Let (_, _, m, _) | Expr.Match (_, _, _, _, m, _) -> m | Expr.Link eref -> rangeOfExpr (!eref) @@ -1202,7 +1202,7 @@ let mkTypeLambda m vs (b, tau_ty) = match vs with [] -> b | _ -> Expr.TyLambda ( let mkTypeChoose m vs b = match vs with [] -> b | _ -> Expr.TyChoose (vs, b, m) let mkObjExpr (ty, basev, basecall, overrides, iimpls, m) = - Expr.Obj (newUnique(), ty, basev, basecall, overrides, iimpls, m) + Expr.Obj (newUnique(), ty, basev, basecall, overrides, iimpls, [], m) let mkLambdas m tps (vs: Val list) (b, rty) = mkTypeLambda m tps (List.foldBack (fun v (e, ty) -> mkLambda m v (e, ty), v.Type --> ty) vs (b, rty)) @@ -3795,9 +3795,11 @@ module DebugPrint = | Expr.Op (TOp.ExnFieldSet _, _tyargs, _args, _) -> wordL(tagText "TOp.ExnFieldSet...") | Expr.Op (TOp.TryFinally _, _tyargs, _args, _) -> wordL(tagText "TOp.TryFinally...") | Expr.Op (TOp.TryCatch _, _tyargs, _args, _) -> wordL(tagText "TOp.TryCatch...") + | Expr.Op (TOp.Goto l, _tys, args, _) -> wordL(tagText ("Expr.Goto " + string l)) ^^ bracketL (commaListL (List.map atomL args)) + | Expr.Op (TOp.Label l, _tys, args, _) -> wordL(tagText ("Expr.Label " + string l)) ^^ bracketL (commaListL (List.map atomL args)) | Expr.Op (_, _tys, args, _) -> wordL(tagText "Expr.Op ...") ^^ bracketL (commaListL (List.map atomL args)) | Expr.Quote (a, _, _, _, _) -> leftL(tagText "<@") ^^ atomL a ^^ rightL(tagText "@>") - | Expr.Obj (_lambdaId, ty, basev, ccall, overrides, iimpls, _) -> + | Expr.Obj (_lambdaId, ty, basev, ccall, overrides, iimpls, _stateVars, _) -> wordL(tagText "OBJ:") ^^ aboveListL [typeL ty exprL ccall @@ -3861,7 +3863,7 @@ module DebugPrint = and decisionTreeL x = match x with | TDBind (bind, body) -> - let bind = wordL(tagText "let") ^^ bindingL bind ^^ wordL(tagText "in") + let bind = wordL(tagText "let") ^^ bindingL bind //^^ wordL(tagText "in") (bind @@ decisionTreeL body) | TDSuccess (args, n) -> wordL(tagText "Success") ^^ leftL(tagText "T") ^^ intL n ^^ tupleL (args |> List.map exprL) @@ -4467,7 +4469,7 @@ and accFreeInExprNonLinear opts x acc = | Expr.Let _ -> failwith "unreachable - linear expr" - | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, _) -> + | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, _stateVars, _) -> unionFreeVars (boundProtect (Option.foldBack (boundLocalVal opts) basev @@ -5009,7 +5011,7 @@ and remapExpr (g: TcGlobals) (compgen: ValCopyFlag) (tmenv: Remap) expr = | Expr.Quote (a, {contents=None}, isFromQueryExpression, m, ty) -> Expr.Quote (remapExpr g (fixValCopyFlagForQuotations compgen) tmenv a, {contents=None}, isFromQueryExpression, m, remapType tmenv ty) - | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, m) -> + | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, _stateVars, m) -> let basev', tmenvinner = Option.mapFold (copyAndRemapAndBindVal g compgen) tmenv basev mkObjExpr (remapType tmenv ty, basev', remapExpr g compgen tmenv basecall, @@ -5486,10 +5488,10 @@ let rec remarkExpr m x = | Expr.Quote (a, conv, isFromQueryExpression, _, ty) -> Expr.Quote (remarkExpr m a, conv, isFromQueryExpression, m, ty) - | Expr.Obj (n, ty, basev, basecall, overrides, iimpls, _) -> + | Expr.Obj (n, ty, basev, basecall, overrides, iimpls, stateVars, _) -> Expr.Obj (n, ty, basev, remarkExpr m basecall, List.map (remarkObjExprMethod m) overrides, - List.map (remarkInterfaceImpl m) iimpls, m) + List.map (remarkInterfaceImpl m) iimpls, stateVars, m) | Expr.Op (op, tinst, args, _) -> let op = @@ -5627,7 +5629,7 @@ let mkByteArrayTy (g: TcGlobals) = mkArrayType g g.byte_ty let rec tyOfExpr g e = match e with | Expr.App (_, fty, tyargs, args, _) -> applyTys g fty (tyargs, args) - | Expr.Obj (_, ty, _, _, _, _, _) + | Expr.Obj (_, ty, _, _, _, _, _, _) | Expr.Match (_, _, _, _, _, ty) | Expr.Quote (_, _, _, _, ty) | Expr.Const (_, _, ty) -> (ty) @@ -6317,7 +6319,7 @@ type ExprFolders<'State> (folders: ExprFolder<'State>) = | Expr.Quote (e, {contents=None}, _, _m, _) -> exprF z e - | Expr.Obj (_n, _typ, _basev, basecall, overrides, iimpls, _m) -> + | Expr.Obj (_n, _typ, _basev, basecall, overrides, iimpls, _stateVars, _m) -> let z = exprF z basecall let z = List.fold tmethodF z overrides List.fold (foldOn snd (List.fold tmethodF)) z iimpls @@ -6980,7 +6982,9 @@ let destThrow = function let isThrow x = Option.isSome (destThrow x) // reraise - parsed as library call - internally represented as op form. -let mkReraiseLibCall (g: TcGlobals) ty m = let ve, vt = typedExprForIntrinsic g m g.reraise_info in Expr.App (ve, vt, [ty], [mkUnit g m], m) +let mkReraiseLibCall (g: TcGlobals) ty m = + let ve, vt = typedExprForIntrinsic g m g.reraise_info + Expr.App (ve, vt, [ty], [mkUnit g m], m) let mkReraise m returnTy = Expr.Op (TOp.Reraise, [returnTy], [], m) (* could suppress unitArg *) @@ -8222,7 +8226,7 @@ and rewriteExprStructure env expr = | Expr.Quote (ast, {contents=None}, isFromQueryExpression, m, ty) -> Expr.Quote ((if env.IsUnderQuotations then RewriteExpr env ast else ast), {contents=None}, isFromQueryExpression, m, ty) - | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, m) -> + | Expr.Obj (_, ty, basev, basecall, overrides, iimpls, _stateVars, m) -> mkObjExpr(ty, basev, RewriteExpr env basecall, List.map (rewriteObjExprOverride env) overrides, List.map (rewriteObjExprInterfaceImpl env) iimpls, m) | Expr.Link eref -> diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index da6906cf33c..a66f08acfd4 100644 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -2560,7 +2560,7 @@ and p_expr expr st = | Expr.LetRec (a, b, c, _) -> p_byte 7 st; p_tup3 p_binds p_expr p_dummy_range (a, b, c) st | Expr.Let (a, b, c, _) -> p_byte 8 st; p_tup3 p_bind p_expr p_dummy_range (a, b, c) st | Expr.Match (_, a, b, c, d, e) -> p_byte 9 st; p_tup5 p_dummy_range p_dtree p_targets p_dummy_range p_ty (a, b, c, d, e) st - | Expr.Obj (_, b, c, d, e, f, g) -> p_byte 10 st; p_tup6 p_ty (p_option p_Val) p_expr p_methods p_intfs p_dummy_range (b, c, d, e, f, g) st + | Expr.Obj (_, b, c, d, e, f, _stateVars, g) -> p_byte 10 st; p_tup6 p_ty (p_option p_Val) p_expr p_methods p_intfs p_dummy_range (b, c, d, e, f, g) st | Expr.StaticOptimization (a, b, c, d) -> p_byte 11 st; p_tup4 p_constraints p_expr p_expr p_dummy_range (a, b, c, d) st | Expr.TyChoose (a, b, c) -> p_byte 12 st; p_tup3 p_tyar_specs p_expr p_dummy_range (a, b, c) st | Expr.Quote (ast, _, _, m, ty) -> p_byte 13 st; p_tup3 p_expr p_dummy_range p_ty (ast, m, ty) st @@ -2624,7 +2624,7 @@ and u_expr st = let e = u_methods st let f = u_intfs st let g = u_dummy_range st - Expr.Obj (newUnique(), b, c, d, e, f, g) + Expr.Obj (newUnique(), b, c, d, e, f, [], g) | 11 -> let a = u_constraints st let b = u_expr st let c = u_expr st diff --git a/src/fsharp/TcGlobals.fs b/src/fsharp/TcGlobals.fs index e85e040213d..cf0f359b60a 100755 --- a/src/fsharp/TcGlobals.fs +++ b/src/fsharp/TcGlobals.fs @@ -692,15 +692,12 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d let v_seq_finally_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "EnumerateThenFinally" , None , None , [varb], ([[mkSeqTy varbTy]; [v_unit_ty --> v_unit_ty]], mkSeqTy varbTy)) let v_seq_of_functions_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "EnumerateFromFunctions" , None , None , [vara;varb], ([[v_unit_ty --> varaTy]; [varaTy --> v_bool_ty]; [varaTy --> varbTy]], mkSeqTy varbTy)) let v_create_event_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "CreateEvent" , None , None , [vara;varb], ([[varaTy --> v_unit_ty]; [varaTy --> v_unit_ty]; [(v_obj_ty --> (varbTy --> v_unit_ty)) --> varaTy]], TType_app (v_fslib_IEvent2_tcr, [varaTy;varbTy]))) + let v_cgh_machine_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__machine" , None , None , [vara], ([[]], varaTy)) let v_cgh_stateMachine_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__stateMachine" , None , None , [vara], ([[varaTy]], varaTy)) let v_cgh_jumptable_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__jumptable" , None , None , [vara], ([[v_int_ty]; [v_unit_ty --> varaTy]], varaTy)) - let v_cgh_newLabel_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__newLabel" , None , None , [], ([[v_unit_ty]], v_int_ty)) - let v_cgh_label_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__label" , None , None , [], ([[v_int_ty]], v_unit_ty)) - let v_cgh_newEntryPoint_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__newEntryPoint" , None , None , [], ([[v_unit_ty]], v_int_ty)) + let v_cgh_newEntryPoint_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__newEntryPoint" , None , None , [], ([[v_unit_ty]], v_int_ty)) let v_cgh_entryPoint_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__entryPoint" , None , None , [vara], ([[v_int_ty]; [v_unit_ty --> varaTy]], varaTy)) - let v_cgh_code_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__code" , None , None , [vara], ([[v_unit_ty --> varaTy]], varaTy)) - let v_cgh_goto_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__goto" , None , None , [vara], ([[v_int_ty]], varaTy)) - let v_cgh_return_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__return" , None , None , [vara;varb],([[varaTy]], varbTy)) + let v_cgh_return_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__return" , None , None , [vara], ([[varaTy]], varaTy)) let v_seq_to_array_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "toArray" , None , Some "ToArray", [varb], ([[mkSeqTy varbTy]], mkArrayType 1 varbTy)) let v_seq_to_list_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "toList" , None , Some "ToList" , [varb], ([[mkSeqTy varbTy]], mkListTy varbTy)) let v_seq_map_info = makeIntrinsicValRef(fslib_MFSeqModule_nleref, "map" , None , Some "Map" , [vara;varb], ([[varaTy --> varbTy]; [mkSeqTy varaTy]], mkSeqTy varbTy)) @@ -1433,15 +1430,12 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d member __.quote_to_linq_lambda_info = v_quote_to_linq_lambda_info - member val cgh_stateMachine_vref = ValRefForIntrinsic v_cgh_stateMachine_info - member val cgh_jumptable_vref = ValRefForIntrinsic v_cgh_jumptable_info - member val cgh_newLabel_vref = ValRefForIntrinsic v_cgh_newLabel_info - member val cgh_label_vref = ValRefForIntrinsic v_cgh_label_info - member val cgh_newEntryPoint_vref = ValRefForIntrinsic v_cgh_newEntryPoint_info - member val cgh_entryPoint_vref = ValRefForIntrinsic v_cgh_entryPoint_info - member val cgh_code_vref = ValRefForIntrinsic v_cgh_code_info - member val cgh_goto_vref = ValRefForIntrinsic v_cgh_goto_info - member val cgh_return_vref = ValRefForIntrinsic v_cgh_return_info + member val cgh_machine_vref = ValRefForIntrinsic v_cgh_machine_info + member val cgh_stateMachine_vref = ValRefForIntrinsic v_cgh_stateMachine_info + member val cgh_jumptable_vref = ValRefForIntrinsic v_cgh_jumptable_info + member val cgh_newEntryPoint_vref = ValRefForIntrinsic v_cgh_newEntryPoint_info + member val cgh_entryPoint_vref = ValRefForIntrinsic v_cgh_entryPoint_info + member val cgh_return_vref = ValRefForIntrinsic v_cgh_return_info member val generic_hash_withc_tuple2_vref = ValRefForIntrinsic v_generic_hash_withc_tuple2_info member val generic_hash_withc_tuple3_vref = ValRefForIntrinsic v_generic_hash_withc_tuple3_info diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 66267dbe148..5621866860b 100644 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2174,7 +2174,7 @@ module GeneralizationHelpers = | Expr.App (e1, _, _, [], _) -> IsGeneralizableValue g e1 | Expr.TyChoose (_, b, _) -> IsGeneralizableValue g b - | Expr.Obj (_, ty, _, _, _, _, _) -> isInterfaceTy g ty || isDelegateTy g ty + | Expr.Obj (_, ty, _, _, _, _, _, _) -> isInterfaceTy g ty || isDelegateTy g ty | Expr.Link eref -> IsGeneralizableValue g !eref | _ -> false @@ -3771,7 +3771,7 @@ let EliminateInitializationGraphs // because of type inference, which makes it reasonable to check generic bindings strictly. | Expr.TyLambda (_, _, b, _, _) -> CheckExpr st b - | Expr.Obj (_, ty, _, e, overrides, extraImpls, _) -> + | Expr.Obj (_, ty, _, e, overrides, extraImpls, _, _) -> // NOTE: we can't fixup recursive references inside delegates since the closure delegee of a delegate is not accessible // from outside. Object expressions implementing interfaces can, on the other hand, be fixed up. See FSharp 1.0 bug 1469 if isInterfaceTy g ty then diff --git a/src/fsharp/autobox.fs b/src/fsharp/autobox.fs index da6b5c1d648..129752ed4f1 100644 --- a/src/fsharp/autobox.fs +++ b/src/fsharp/autobox.fs @@ -78,7 +78,7 @@ let DecideExpr cenv exprF noInterceptF z expr = let ty = mkForallTyIfNeeded tps rty DecideLambda (Some exprF) cenv topValInfo expr ty z - | Expr.Obj (_, _, baseValOpt, superInitCall, overrides, iimpls, _m) -> + | Expr.Obj (_, _, baseValOpt, superInitCall, overrides, iimpls, _stateVars, _m) -> let CheckMethod z (TObjExprMethod(_, _attribs, _tps, vs, body, _m)) = let vs = List.concat vs let syntacticArgs = (match baseValOpt with Some x -> x :: vs | None -> vs) diff --git a/src/fsharp/range.fs b/src/fsharp/range.fs index 0b6d7d39639..1462f11d4ea 100755 --- a/src/fsharp/range.fs +++ b/src/fsharp/range.fs @@ -201,11 +201,7 @@ let fileOfFileIndex idx = fileIndexTable.IndexToFile idx let mkPos l c = pos (l, c) [] -#if DEBUG -[ {DebugCode}")>] -#else -[] -#endif +[ {DebugCode}")>] type range(code1:int64, code2: int64) = static member Zero = range(0L, 0L) new (fidx, bl, bc, el, ec) = @@ -241,13 +237,14 @@ type range(code1:int64, code2: int64) = member r.FileName = fileOfFileIndex r.FileIndex + member r.ShortFileName = Path.GetFileName(fileOfFileIndex r.FileIndex) + member r.MakeSynthetic() = range(code1, code2 ||| isSyntheticMask) member r.Code1 = code1 member r.Code2 = code2 -#if DEBUG member r.DebugCode = try let endCol = r.EndColumn - 1 @@ -262,7 +259,6 @@ type range(code1:int64, code2: int64) = |> fun s -> s.Substring(startCol + 1, s.LastIndexOf("\n", StringComparison.Ordinal) + 1 - startCol + endCol) with e -> e.ToString() -#endif member r.ToShortString() = sprintf "(%d,%d--%d,%d)" r.StartLine r.StartColumn r.EndLine r.EndColumn diff --git a/src/fsharp/symbols/Exprs.fs b/src/fsharp/symbols/Exprs.fs index e09e1d4df30..b8ca489fb09 100644 --- a/src/fsharp/symbols/Exprs.fs +++ b/src/fsharp/symbols/Exprs.fs @@ -533,7 +533,7 @@ module FSharpExprConvert = let env = env.BindTypars (Seq.zip tps gps |> Seq.toList) E.TypeLambda(gps, ConvExpr cenv env b) - | Expr.Obj (_, ty, _, _, [TObjExprMethod(TSlotSig(_, ctyp, _, _, _, _), _, tps, [tmvs], e, _) as tmethod], _, m) when isDelegateTy cenv.g ty -> + | Expr.Obj (_, ty, _, _, [TObjExprMethod(TSlotSig(_, ctyp, _, _, _, _), _, tps, [tmvs], e, _) as tmethod], _, _, m) when isDelegateTy cenv.g ty -> let f = mkLambdas m tps tmvs (e, GetFSharpViewOfReturnType cenv.g (returnTyOfMethod cenv.g tmethod)) let fR = ConvExpr cenv env f let tyargR = ConvType cenv ctyp @@ -545,7 +545,7 @@ module FSharpExprConvert = | Expr.TyChoose _ -> ConvExprPrim cenv env (ChooseTyparSolutionsForFreeChoiceTypars cenv.g cenv.amap expr) - | Expr.Obj (_lambdaId, ty, _basev, basecall, overrides, iimpls, _m) -> + | Expr.Obj (_lambdaId, ty, _basev, basecall, overrides, iimpls, _stateVars, _m) -> let basecallR = ConvExpr cenv env basecall let ConvertMethods methods = [ for (TObjExprMethod(slotsig, _, tps, tmvs, body, _)) in methods -> diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 98a8710afb0..3acea2cfc92 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -4413,7 +4413,7 @@ and override x.ToString() = sprintf "AttribNamedArg(...)" /// Constants in expressions -and [] +and [] Const = | Bool of bool | SByte of sbyte @@ -4434,6 +4434,30 @@ and [] | Unit | Zero // null/zero-bit-pattern + [] + member x.DebugText = x.ToString() + + override c.ToString() = + match c with + | Bool b -> (if b then "true" else "false") + | SByte x -> string x + "y" + | Byte x -> string x + "uy" + | Int16 x -> string x + "s" + | UInt16 x -> string x + "us" + | Int32 x -> string x + | UInt32 x -> string x + "u" + | Int64 x -> string x + "L" + | UInt64 x -> string x + "UL" + | IntPtr x -> string x + "n" + | UIntPtr x -> string x + "un" + | Single x -> string x + "f" + | Double x -> string x + | Char x -> "'" + string x + "'" + | String x -> "\"" + x + "\"" + | Decimal x -> string x + "M" + | Unit -> "()" + | Zero -> "Const.Zero" + /// Decision trees. Pattern matching has been compiled down to /// a decision tree by this point. The right-hand-sides (actions) of /// a decision tree by this point. The right-hand-sides (actions) of @@ -4659,7 +4683,7 @@ and Vals = Val list /// The big type of expressions. and - [] + [] Expr = /// A constant expression. | Const of Const * range * TType @@ -4697,6 +4721,7 @@ and // Object expressions: A closure that implements an interface or a base type. // The base object type might be a delegate type. + // stateVars are extra fields of the object and only populated during codegen. | Obj of unique: Unique * objTy: TType * (* <-- NOTE: specifies type parameters for base type *) @@ -4704,6 +4729,7 @@ and ctorCall: Expr * overrides: ObjExprMethod list * interfaceImpls: (TType * ObjExprMethod list) list * + stateVars: ValRef list * range: range /// Matches are a more complicated form of "let" with multiple possible destinations @@ -4739,6 +4765,31 @@ and /// appropriate type instantiation. These are immediately eliminated on subsequent rewrites. | Link of Expr ref + [] + member expr.DebugText = expr.ToDebugString(3) + + override expr.ToString() = expr.ToDebugString(3) + + member expr.ToDebugString(depth: int) = + if depth = 0 then ".." else + let depth = depth - 1 + match expr with + | Const (c, _, _) -> c.ToString() + | Val (v, _, _) -> v.LogicalName + | Sequential (e1, e2, _, _, _) -> "Sequential(" + e1.ToDebugString(depth) + ", " + e2.ToDebugString(depth) + ")" + | Lambda (_, _, _, vs, body, _, _) -> sprintf "Lambda(%+A, " vs + body.ToDebugString(depth) + ")" + | TyLambda _ -> "TyLambda(..)" + | App (f, _, _, args, _) -> "App(" + f.ToDebugString(depth) + ", [" + String.concat ", " (args |> List.map (fun e -> e.ToDebugString(depth))) + "])" + | LetRec _ -> "LetRec(..)" + | Let (bind, body, _, _) -> "Let(" + bind.Var.DisplayName + ", " + bind.Expr.ToDebugString(depth) + ", " + body.ToDebugString(depth) + ")" + | Obj (_, _objTy, _, _, _, _, _, _) -> "Obj(..)" + | Match (_, _, _dt, _tgs, _, _) -> "Match(..)" + | StaticOptimization (_, _, _, _) -> "StaticOptimization(..)" + | Op (op, _, args, _) -> "Op(" + op.ToString() + ", " + String.concat ", " (args |> List.map (fun e -> e.ToDebugString(depth))) + ")" + | Quote _ -> "Quote(..)" + | TyChoose _ -> "TyChoose(..)" + | Link e -> "Link(" + e.Value.ToDebugString(depth) + ")" + // Prefer to use the default formatting of this union type //[] //member x.DebugText = x.ToString() @@ -4746,7 +4797,7 @@ and //override __.ToString() = "Expr(...)" and - [] + [] TOp = /// An operation representing the creation of a union value of the particular union case @@ -4863,11 +4914,45 @@ and /// retTy -- the types of pushed values, if any | ILCall of bool * bool * bool * bool * ValUseFlag * bool * bool * ILMethodRef * TypeInst * TypeInst * TTypes - // Prefer to use the default formatting of this union type - //[] - //member x.DebugText = x.ToString() - // - //override __.ToString() = "TOp(...)" + [] + member x.DebugText = x.ToString() + + override op.ToString() = + match op with + | UnionCase ucref -> "UnionCase(" + ucref.CaseName + ")" + | ExnConstr ecref -> "ExnConstr(" + ecref.LogicalName + ")" + | Tuple _tupinfo -> "Tuple" + | AnonRecd _anonInfo -> "AnonRecd(..)" + | AnonRecdGet _ -> "AnonRecdGet(..)" + | Array -> "NewArray" + | Bytes _ -> "Bytes(..)" + | UInt16s _ -> "UInt16s(..)" + | While _ -> "While" + | For _ -> "For" + | TryCatch _ -> "TryCatch" + | TryFinally _ -> "TryFinally" + | Recd (_, tcref) -> "Recd(" + tcref.LogicalName + ")" + | ValFieldSet rfref -> "ValFieldSet(" + rfref.FieldName + ")" + | ValFieldGet rfref -> "ValFieldGet(" + rfref.FieldName + ")" + | ValFieldGetAddr (rfref, _) -> "ValFieldGetAddr(" + rfref.FieldName + ",..)" + | UnionCaseTagGet tcref -> "UnionCaseTagGet(" + tcref.LogicalName + ")" + | UnionCaseProof ucref -> "UnionCaseProof(" + ucref.CaseName + ")" + | UnionCaseFieldGet (ucref, _) -> "UnionCaseFieldGet(" + ucref.CaseName + ",..)" + | UnionCaseFieldGetAddr (ucref, _, _) -> "UnionCaseFieldGetAddr(" + ucref.CaseName + ",..)" + | UnionCaseFieldSet (ucref, _) -> "UnionCaseFieldSet(" + ucref.CaseName + ",..)" + | ExnFieldGet (tcref, _) -> "ExnFieldGet(" + tcref.LogicalName + ",..)" + | ExnFieldSet (tcref, _) -> "ExnFieldSet(" + tcref.LogicalName + ",..)" + | TupleFieldGet _ -> "TupleFieldGet(..)" + | ILAsm _ -> "ILAsm(..)" + | RefAddrGet _ -> "RefAddrGet(..)" + | Coerce -> "Coerce" + | Reraise -> "Reraise" + | Return -> "Return" + | Goto n -> "Goto(" + string n + ")" + | Label n -> "Label(" + string n + ")" + | TraitCall info -> "TraitCall(" + info.MemberName + ")" + | LValueOp (op, vref) -> sprintf "%+A(%s)" op vref.LogicalName + | ILCall (_,_,_,_,_,_,_,m,_,_,_) -> "ILCall(" + m.ToString() + ",..)" /// Indicates the kind of record construction operation. and RecordConstructionInfo = diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs index 81b9d565f7a..c5b3940b136 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs @@ -25,6 +25,73 @@ open System.Threading open System.Threading.Tasks open Microsoft.FSharp.Control +let tcatch0() = + task { + try + return 1 + with e -> + return 2 + } + +let tcatch1() = + task { + try + let! x = Task.FromResult 1 + return x + with e -> + return 2 + } + +let t() = + task { + return 1 + } + +let t2() = + task { + System.Console.WriteLine("hello") + return 1 + } + +let t3() = + task { + System.Console.WriteLine("hello") + let! x = t2() + System.Console.WriteLine("world") + return 1 + x + } + + +let t3a() = + task { + //System.Console.WriteLine("hello") + let! x = Task.FromResult(1) + //System.Console.WriteLine("world") + return 1 + x + } + +printfn "t3a().Result = %A" (t3a().Result) + +let t3b() = + task { + System.Console.WriteLine("hello") + let! x = Task.FromResult(1) + System.Console.WriteLine("world") + return 1 + x + } + +printfn "t3b().Result = %A" (t3b().Result) + +let t3c() = + task { + System.Console.WriteLine("hello") + do! Task.Delay(100) + System.Console.WriteLine("world") + return 1 + } + +printfn "t3c().Result = %A" (t3c().Result) + exception TestException of string let require x msg = if not x then failwith msg @@ -39,6 +106,7 @@ let testShortCircuitResult() = require t.IsCompleted "didn't short-circuit already completed tasks" require (t.Result = 3) "wrong result" + let testDelay() = let mutable x = 0 let t = @@ -76,17 +144,6 @@ let testNonBlocking() = let failtest str = raise (TestException str) -let tmp() = - let mutable y = 0 - task { - try - do! Task.Delay(0) - () - do! Task.Delay(100) - with e -> - () - y <- 1 - } let testCatching1() = let mutable x = 0 @@ -131,6 +188,7 @@ let testCatching2() = require (y = 1) "bailed after exn" require (x = 0) "ran past failure" + let testNestedCatching() = let mutable counter = 1 let mutable caughtInner = 0 @@ -166,6 +224,7 @@ let testNestedCatching() = require (caughtInner = 1) "didn't catch inner" require (caughtOuter = 2) "didn't catch outer" + let testTryFinallyHappyPath() = let mutable ran = false let t = @@ -216,7 +275,7 @@ let testTryFinallyCaught() = } require (t.Result = 2) "wrong return" require ran "never ran" - +(* let testUsing() = let mutable disposed = false let t = @@ -705,7 +764,7 @@ let testCompilerInfersArgumentOfReturnFrom() = if true then return 1 else return! failwith "" } - + *) [] let main argv = @@ -717,34 +776,34 @@ let main argv = testNonBlocking() testCatching1() testCatching2() - testNestedCatching() - testTryFinallyHappyPath() - testTryFinallySadPath() - testTryFinallyCaught() - testUsing() - testUsingFromTask() - testUsingSadPath() - testForLoop() - testForLoopSadPath() - testExceptionAttachedToTaskWithoutAwait() - testExceptionAttachedToTaskWithAwait() - testExceptionThrownInFinally() - test2ndExceptionThrownInFinally() - testFixedStackWhileLoop() - testFixedStackForLoop() - testTypeInference() - testNoStackOverflowWithImmediateResult() - testNoStackOverflowWithYieldResult() - // we don't support TCO, so large tail recursions will stack overflow - // or at least use O(n) heap. but small ones should at least function OK. - testSmallTailRecursion() - testTryOverReturnFrom() - testTryFinallyOverReturnFromWithException() - testTryFinallyOverReturnFromWithoutException() - testAsyncsMixedWithTasks() - printfn "Passed all tests!" + //testNestedCatching() + //testTryFinallyHappyPath() + //testTryFinallySadPath() + //testTryFinallyCaught() + //testUsing() + //testUsingFromTask() + //testUsingSadPath() + //testForLoop() + //testForLoopSadPath() + //testExceptionAttachedToTaskWithoutAwait() + //testExceptionAttachedToTaskWithAwait() + //testExceptionThrownInFinally() + //test2ndExceptionThrownInFinally() + //testFixedStackWhileLoop() + //testFixedStackForLoop() + //testTypeInference() + //testNoStackOverflowWithImmediateResult() + //testNoStackOverflowWithYieldResult() + //// we don't support TCO, so large tail recursions will stack overflow + //// or at least use O(n) heap. but small ones should at least function OK. + //testSmallTailRecursion() + //testTryOverReturnFrom() + //testTryFinallyOverReturnFromWithException() + //testTryFinallyOverReturnFromWithoutException() + //testAsyncsMixedWithTasks() + //printfn "Passed all tests!" with exn -> eprintfn "Exception: %O" exn + printfn "Tests passed ok..." 0 - \ No newline at end of file From b9ed10c2acd1f78856750cb56d48d86c95ad1075 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Wed, 8 May 2019 23:53:20 +0100 Subject: [PATCH 26/45] more fixes to state machines --- src/fsharp/FSharp.Core/tasks.fs | 39 +++++++++++++------ src/fsharp/LowerCallsAndSeqs.fs | 34 ++++++++-------- src/fsharp/TastOps.fs | 10 ++--- .../Microsoft.FSharp.Control/Tasks.fs | 20 ++++++---- 4 files changed, 63 insertions(+), 40 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index 923e2b04f1c..01671e07d57 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -89,17 +89,22 @@ type TaskStateMachine<'T>() = let mutable awaiter = awaiter assert (not (isNull awaiter)) // Tell the builder to call us again when done. + Console.WriteLine("[{0}] AwaitUnsafeOnCompleted", sm.GetHashCode()) methodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) interface IAsyncStateMachine with member this.MoveNext() = try + Console.WriteLine("[{0}] step from {1}", this.GetHashCode(), resumptionPoint) let step = this.Step resumptionPoint if (# "" step : bool #) then + Console.WriteLine("[{0}] unboxing result", this.GetHashCode()) let res = unbox<'T>(this.Current) + Console.WriteLine("[{0}] SetResult {1}", this.GetHashCode(), res) methodBuilder.SetResult(Task.FromResult res) with exn -> + Console.WriteLine("[{0}] exception {1}", this.GetHashCode(), exn) methodBuilder.SetException exn member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. @@ -107,9 +112,12 @@ type TaskStateMachine<'T>() = member this.Start() = let mutable machine = this try + Console.WriteLine("[{0}] start", this.GetHashCode()) methodBuilder.Start(&machine) + Console.WriteLine("[{0}] unwrap", this.GetHashCode()) methodBuilder.Task.Unwrap() with exn -> + Console.WriteLine("[{0}] start exception", this.GetHashCode()) // Any exceptions should go on the task, rather than being thrown from this call. // This matches C# behavior where you won't see an exception until awaiting the task, // even if it failed before reaching the first "await". @@ -221,17 +229,22 @@ type TaskBuilder() = /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. - member inline __.Combine(_step: TaskStep, __expand_task2: unit -> TaskStep<'T>) : TaskStep<'T> = - // _step is ignored, as elsewhere, we only get here is the step completed - __expand_task2() + member inline __.Combine(``__machine_step$cont``: TaskStep, __expand_task2: unit -> TaskStep<'T>) : TaskStep<'T> = + if (# "" ``__machine_step$cont`` : bool #) then + __expand_task2() + else + (# "" ``__machine_step$cont`` : TaskStep<'T> #) /// Builds a step that executes the body while the condition predicate is true. member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskStep) : TaskStep = - while __expand_condition() do - let _step = __expand_body () - () + let mutable step = (# "" true : TaskStep #) + while (# "" step : bool #) && __expand_condition() do + step <- (# "" false : TaskStep #) + let ``__machine_step$cont`` = __expand_body () + // If we make it to the assignment we prove we've made a step + step <- ``__machine_step$cont`` __machine.Current <- (box ()) - (# "" true : TaskStep #) + step /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). @@ -245,15 +258,19 @@ type TaskBuilder() = /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). // codegen + let mutable step = (# "" false : TaskStep<'T> #) try - let _step = __expand_body () - () + let ``__machine_step$cont`` = __expand_body () + // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with + // may skip this step. + step <- ``__machine_step$cont`` with _ -> compensation() reraise() - compensation() - (# "" true : TaskStep<'T> #) + if (# "" step : bool #) then + compensation() + step member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> TaskStep<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 2ab7ef6f045..60b231e6774 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -917,15 +917,16 @@ let LowerStateMachineExpr g overallExpr = | _ -> (env, expr) - let (|SequentialCode|_|) expr = + let (|SequentialStateMachineCode|_|) expr = match expr with // e1; e2 | Expr.Sequential(e1, e2, NormalSeq, _, m) -> Some (e1, e2, m, (fun e1 e2 -> mkCompGenSequential m e1 e2)) - // let _step = e1 in e2 - | Expr.Let(bind, e2, m, _) when bind.Var.CompiledName = "_step" -> // TODO this is way too adhoc + // let __machine_step$cont = e1 in e2 + // The $cont is used to prevent elimination in Optimizer.fs + | Expr.Let(bind, e2, m, _) when bind.Var.CompiledName = "__machine_step$cont" -> Some (bind.Expr, e2, m, (fun e1 e2 -> mkLet bind.SequencePointInfo m bind.Var e1 e2)) | _ -> None @@ -1020,7 +1021,7 @@ let LowerStateMachineExpr g overallExpr = // control-flow sequential // let _step = e1 in e2 // e1; e2 - | SequentialCode(e1, e2, _m, recreate) -> + | SequentialStateMachineCode(e1, e2, _m, recreate) -> // printfn "found sequential" let res1 = Lower env pcExpr e1 let res2 = Lower env pcExpr e2 @@ -1172,18 +1173,19 @@ let LowerStateMachineExpr g overallExpr = printfn "%s" (DebugPrint.showExpr overallExprR) printfn "----------- CHECKING ----------------------" let mutable failed = false - let _expr = - overallExprR |> RewriteExpr - { PreIntercept = None - PostTransform = (fun e -> - match e with - | Expr.Val(vref, _, _) when isMustExpandVar vref.Deref -> - System.Diagnostics.Debug.Assert(false, "FAILED: unexpected expand var") - failed <- true - None - | _ -> None) - PreInterceptBinding = None - IsUnderQuotations=true } + //let _expr = + // overallExprR |> RewriteExpr + // { PreIntercept = None + // PostTransform = (fun e -> + // match e with + // | Expr.Val(vref, _, _) when isMustExpandVar vref.Deref -> + // System.Diagnostics.Debug.Assert(false, "FAILED: unexpected expand var") + // failed <- true + // None + // | _ -> None) + // PreInterceptBinding = None + // IsUnderQuotations=true } + printfn "----------- DONE ----------------------" if failed then None else Some overallExprR | _ -> None diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index f309c1882f2..bf1c79e2099 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -3778,13 +3778,13 @@ module DebugPrint = |> wrap | Expr.Op (TOp.Array, [_], xs, _) -> leftL(tagText "[|") ^^ commaListL (List.map exprL xs) ^^ rightL(tagText "|]") - | Expr.Op (TOp.While _, [], [x1;x2], _) -> + | Expr.Op (TOp.While _, [], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _)], _) -> wordL(tagText "while") ^^ exprL x1 ^^ wordL(tagText "do") ^^ exprL x2 ^^ rightL(tagText "}") - | Expr.Op (TOp.For _, [], [x1;x2;x3], _) -> + | Expr.Op (TOp.For _, [], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _);Expr.Lambda (_, _, _, [_], x3, _, _)], _) -> wordL(tagText "for") ^^ aboveListL [(exprL x1 ^^ wordL(tagText "to") ^^ exprL x2 ^^ wordL(tagText "do")); exprL x3 ] ^^ rightL(tagText "done") - | Expr.Op (TOp.TryCatch _, [_], [x1;x2], _) -> - wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "with") ^^ exprL x2 ^^ rightL(tagText "}") - | Expr.Op (TOp.TryFinally _, [_], [x1;x2], _) -> + | Expr.Op (TOp.TryCatch _, [_], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], xf, _, _);Expr.Lambda (_, _, _, [_], xh, _, _)], _) -> + wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "with-filter") ^^ exprL xf ^^ wordL(tagText "with") ^^ exprL xh ^^ rightL(tagText "}") + | Expr.Op (TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _)], _) -> wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "finally") ^^ exprL x2 ^^ rightL(tagText "}") | Expr.Op (TOp.Bytes _, _, _, _) -> wordL(tagText "bytes++") diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs index c5b3940b136..9c26ec0a6b4 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs @@ -70,7 +70,7 @@ let t3a() = return 1 + x } -printfn "t3a().Result = %A" (t3a().Result) +//printfn "t3a().Result = %A" (t3a().Result) let t3b() = task { @@ -80,7 +80,7 @@ let t3b() = return 1 + x } -printfn "t3b().Result = %A" (t3b().Result) +//printfn "t3b().Result = %A" (t3b().Result) let t3c() = task { @@ -90,7 +90,7 @@ let t3c() = return 1 } -printfn "t3c().Result = %A" (t3c().Result) +//printfn "t3c().Result = %A" (t3c().Result) exception TestException of string @@ -275,6 +275,7 @@ let testTryFinallyCaught() = } require (t.Result = 2) "wrong return" require ran "never ran" + (* let testUsing() = let mutable disposed = false @@ -776,10 +777,10 @@ let main argv = testNonBlocking() testCatching1() testCatching2() - //testNestedCatching() - //testTryFinallyHappyPath() - //testTryFinallySadPath() - //testTryFinallyCaught() + testNestedCatching() + testTryFinallyHappyPath() + testTryFinallySadPath() + testTryFinallyCaught() //testUsing() //testUsingFromTask() //testUsingSadPath() @@ -804,6 +805,9 @@ let main argv = //printfn "Passed all tests!" with exn -> eprintfn "Exception: %O" exn - printfn "Tests passed ok..." + printfn "Tests passed ok..., sleeping a bit in case there are background delayed exceptions" + Thread.Sleep(500) + printfn "Exiting..." + //System.Console.ReadLine() 0 From 08363a712f36b707ad7858106f30b5701943ed53 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Thu, 9 May 2019 17:35:53 +0100 Subject: [PATCH 27/45] state machines now work --- src/fsharp/FSharp.Core/tasks.fs | 74 ++- src/fsharp/IlxGen.fs | 4 +- src/fsharp/LowerCallsAndSeqs.fs | 575 +++++++++++------- src/fsharp/LowerCallsAndSeqs.fsi | 4 +- src/fsharp/TastOps.fs | 53 +- .../Microsoft.FSharp.Control/Tasks.fs | 195 ++++-- 6 files changed, 573 insertions(+), 332 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index 01671e07d57..8a17cfc3ede 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -28,22 +28,22 @@ namespace Microsoft.FSharp.Core.CompilerServices module CodeGenHelpers = [] - let __jumptable<'T> (_x:int) (_code: unit -> 'T) : 'T = Unchecked.defaultof<_> + let __jumptable<'T> (_x:int) (_code: unit -> 'T) : 'T = failwith "__jumptable should always be removed from compiled code" [] - let __stateMachine<'T> (x: 'T) : 'T = x + let __stateMachine<'T> (_x: 'T) : 'T = failwith "__stateMachine should always be removed from compiled code" [] - let __newEntryPoint() : int = 0 + let __newEntryPoint() : int = failwith "__newEntryPoint should always be removed from compiled code" [] - let __machine<'T> : 'T = Unchecked.defaultof<'T> + let __machine<'T> : 'T = failwith "__machine should always be removed from compiled code" [] - let __entryPoint (_n: int) : unit= Unchecked.defaultof<_> + let __entryPoint (_n: int) : unit = failwith "__entryPoint should always be removed from compiled code" [] - let __return<'T> (_v: 'T) : 'T = Unchecked.defaultof<_> + let __return<'T> (_v: 'T) : 'T = failwith "__return should always be removed from compiled code" #if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE namespace Microsoft.FSharp.Control @@ -89,22 +89,22 @@ type TaskStateMachine<'T>() = let mutable awaiter = awaiter assert (not (isNull awaiter)) // Tell the builder to call us again when done. - Console.WriteLine("[{0}] AwaitUnsafeOnCompleted", sm.GetHashCode()) + //Console.WriteLine("[{0}] AwaitUnsafeOnCompleted", sm.GetHashCode()) methodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) interface IAsyncStateMachine with member this.MoveNext() = try - Console.WriteLine("[{0}] step from {1}", this.GetHashCode(), resumptionPoint) + //Console.WriteLine("[{0}] step from {1}", this.GetHashCode(), resumptionPoint) let step = this.Step resumptionPoint if (# "" step : bool #) then - Console.WriteLine("[{0}] unboxing result", this.GetHashCode()) + //Console.WriteLine("[{0}] unboxing result", this.GetHashCode()) let res = unbox<'T>(this.Current) - Console.WriteLine("[{0}] SetResult {1}", this.GetHashCode(), res) + //Console.WriteLine("[{0}] SetResult {1}", this.GetHashCode(), res) methodBuilder.SetResult(Task.FromResult res) with exn -> - Console.WriteLine("[{0}] exception {1}", this.GetHashCode(), exn) + //Console.WriteLine("[{0}] exception {1}", this.GetHashCode(), exn) methodBuilder.SetException exn member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. @@ -112,12 +112,12 @@ type TaskStateMachine<'T>() = member this.Start() = let mutable machine = this try - Console.WriteLine("[{0}] start", this.GetHashCode()) + //Console.WriteLine("[{0}] start", this.GetHashCode()) methodBuilder.Start(&machine) - Console.WriteLine("[{0}] unwrap", this.GetHashCode()) + //Console.WriteLine("[{0}] unwrap", this.GetHashCode()) methodBuilder.Task.Unwrap() with exn -> - Console.WriteLine("[{0}] start exception", this.GetHashCode()) + //Console.WriteLine("[{0}] start exception", this.GetHashCode()) // Any exceptions should go on the task, rather than being thrown from this call. // This matches C# behavior where you won't see an exception until awaiting the task, // even if it failed before reaching the first "await". @@ -237,40 +237,56 @@ type TaskBuilder() = /// Builds a step that executes the body while the condition predicate is true. member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskStep) : TaskStep = - let mutable step = (# "" true : TaskStep #) - while (# "" step : bool #) && __expand_condition() do - step <- (# "" false : TaskStep #) + let mutable completed = true + while (# "" completed : bool #) && __expand_condition() do + completed <- false + // The body of the 'while' may include an early exit, e.g. return from entire method let ``__machine_step$cont`` = __expand_body () // If we make it to the assignment we prove we've made a step - step <- ``__machine_step$cont`` + completed <- (# "" ``__machine_step$cont`` : bool #) __machine.Current <- (box ()) - step + (# "" completed : TaskStep #) /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). member inline __.TryWith(__expand_body : unit -> TaskStep<'T>, __expand_catch : exn -> TaskStep<'T>) : TaskStep<'T> = + let mutable completed = (# "" false : TaskStep<'T> #) + let mutable caught = false + let mutable savedExn = Unchecked.defaultof<_> try - __expand_body() + // The try block may contain resumption points. + // This is handled by the state machine rewriting + let ``__machine_step$cont`` = __expand_body () + // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with + // may skip this step. + completed <- ``__machine_step$cont`` with exn -> - __expand_catch exn + // The catch block may not contain resumption points. + caught <- true + savedExn <- exn + if caught then + // Place the catch code outside the catch block + __expand_catch savedExn + else + completed + + /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function + /// to retrieve the step, and in the continuation of the step (if any). member inline __.TryFinally(__expand_body: unit -> TaskStep<'T>, compensation : unit -> unit) : TaskStep<'T> = - /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function - /// to retrieve the step, and in the continuation of the step (if any). - // codegen - let mutable step = (# "" false : TaskStep<'T> #) + let mutable completed = (# "" false : TaskStep<'T> #) try let ``__machine_step$cont`` = __expand_body () // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with // may skip this step. - step <- ``__machine_step$cont`` + completed <- ``__machine_step$cont`` with _ -> compensation() reraise() - if (# "" step : bool #) then + if (# "" completed : bool #) then compensation() - step + completed member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> TaskStep<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. @@ -288,7 +304,7 @@ type TaskBuilder() = let CONT = __newEntryPoint () if task.IsCompleted then __entryPoint CONT - __machine.Current <- box task.Result + __machine.Current <- box (task.GetAwaiter().GetResult()) (# "" true : TaskStep<'T> #) else __machine.Await(task.GetAwaiter(), CONT) diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 17ebd2d3415..47b005bf2a8 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -2160,12 +2160,12 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = elif EmitHiddenCodeMarkerForWholeExpr g sp expr then cgbuf.EmitStartOfHiddenCode() - match (if compileSequenceExpressions then LowerCallsAndSeqs.LowerSeqExpr g cenv.amap expr else None) with + match (if compileSequenceExpressions then LowerCallsAndSeqs.ConvertSequenceExprToObject g cenv.amap expr else None) with | Some info -> GenSequenceExpr cenv cgbuf eenv info sequel | None -> - match LowerCallsAndSeqs.LowerStateMachineExpr g expr with + match LowerCallsAndSeqs.ConvertStateMachineExprToObject g expr with | Some objExpr -> GenExpr cenv cgbuf eenv sp objExpr sequel | None -> diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 60b231e6774..100f793e59d 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -102,7 +102,7 @@ type LoweredSeqFirstPhaseResult = stateVars: ValRef list /// The vars captured by the non-synchronous path - capturedVars: FreeVars + asyncVars: FreeVars } let isVarFreeInExpr v e = Zset.contains v (freeInExpr CollectTyparsAndLocals e).FreeLocals @@ -123,7 +123,7 @@ let (|ValApp|_|) g vref expr = /// The analysis is done in two phases. The first phase determines the state variables and state labels (as Abstract IL code labels). /// We then allocate an integer pc for each state label and proceed with the second phase, which builds two related state machine /// expressions: one for 'MoveNext' and one for 'Dispose'. -let LowerSeqExpr g amap overallExpr = +let ConvertSequenceExprToObject g amap overallExpr = /// Detect a 'yield x' within a 'seq { ... }' let (|SeqYield|_|) expr = match expr with @@ -190,7 +190,9 @@ let LowerSeqExpr g amap overallExpr = /// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) let RepresentBindingAsLocal (bind: Binding) res2 m = - // printfn "LowerSeq: found local variable %s" bind.Var.DisplayName + if verbose then + printfn "LowerSeq: found local variable %s" bind.Var.DisplayName + { res2 with phase2 = (fun ctxt -> let generate2, dispose2, checkDispose2 = res2.phase2 ctxt @@ -202,7 +204,9 @@ let LowerSeqExpr g amap overallExpr = /// Implement a decision to represent a 'let' binding as a state machine variable let RepresentBindingAsStateMachineLocal (bind: Binding) res2 m = - // printfn "LowerSeq: found state variable %s" bind.Var.DisplayName + if verbose then + printfn "LowerSeq: found state variable %s" bind.Var.DisplayName + let (TBind(v, e, sp)) = bind let sp, spm = match sp with @@ -225,7 +229,9 @@ let LowerSeqExpr g amap overallExpr = stateVars = vref :: res2.stateVars } let RepresentBindingsAsLifted mkBinds res2 = - // printfn "found top level let " + if verbose then + printfn "found top level let " + { res2 with phase2 = (fun ctxt -> let generate2, dispose2, checkDispose2 = res2.phase2 ctxt @@ -234,7 +240,7 @@ let LowerSeqExpr g amap overallExpr = let checkDispose = checkDispose2 generate, dispose, checkDispose) } - let rec Lower + let rec ConvertSeqExprCode isWholeExpr isTailCall // is this sequence in tailcall position? noDisposeContinuationLabel // represents the label for the code where there is effectively nothing to do to dispose the iterator for the current state @@ -270,27 +276,27 @@ let LowerSeqExpr g amap overallExpr = entryPoints=[label] stateVars=[] significantClose = false - capturedVars = emptyFreeVars + asyncVars = emptyFreeVars } | SeqDelay(delayedExpr, _elemTy) -> // printfn "found Seq.delay" // note, using 'isWholeExpr' here prevents 'seq { yield! e }' and 'seq { 0 .. 1000 }' from being compiled - Lower isWholeExpr isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel delayedExpr + ConvertSeqExprCode isWholeExpr isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel delayedExpr | SeqAppend(e1, e2, m) -> // printfn "found Seq.append" - let res1 = Lower false false noDisposeContinuationLabel currentDisposeContinuationLabel e1 - let res2 = Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 + let res1 = ConvertSeqExprCode false false noDisposeContinuationLabel currentDisposeContinuationLabel e1 + let res2 = ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 match res1, res2 with | Some res1, Some res2 -> - let capturedVars = + let asyncVars = if res1.entryPoints.IsEmpty then - res2.capturedVars + res2.asyncVars else // All of 'e2' is needed after resuming at any of the labels - unionFreeVars res1.capturedVars (freeInExpr CollectLocals e2) + unionFreeVars res1.asyncVars (freeInExpr CollectLocals e2) Some { phase2 = (fun ctxt -> let generate1, dispose1, checkDispose1 = res1.phase2 ctxt @@ -304,18 +310,18 @@ let LowerSeqExpr g amap overallExpr = entryPoints= res1.entryPoints @ res2.entryPoints stateVars = res1.stateVars @ res2.stateVars significantClose = res1.significantClose || res2.significantClose - capturedVars = capturedVars } + asyncVars = asyncVars } | _ -> None | SeqWhile(guardExpr, bodyExpr, m) -> // printfn "found Seq.while" - let resBody = Lower false false noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr + let resBody = ConvertSeqExprCode false false noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr match resBody with | Some res2 -> - let capturedVars = + let asyncVars = if res2.entryPoints.IsEmpty then - res2.capturedVars // the whole loop is synchronous, no labels + res2.asyncVars // the whole loop is synchronous, no labels else freeInExpr CollectLocals expr // everything is needed on subsequent iterations @@ -328,7 +334,7 @@ let LowerSeqExpr g amap overallExpr = entryPoints = res2.entryPoints stateVars = res2.stateVars significantClose = res2.significantClose - capturedVars = capturedVars } + asyncVars = asyncVars } | _ -> None @@ -339,7 +345,7 @@ let LowerSeqExpr g amap overallExpr = (mkCallSeqFinally g m elemTy body (mkUnitDelayLambda g m (mkCallDispose g m v.Type (exprForVal m v)))) - Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction + ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction | SeqFor(inp, v, body, genElemTy, m) -> // printfn "found Seq.for" @@ -356,15 +362,15 @@ let LowerSeqExpr g amap overallExpr = (mkCallSeqGenerated g m genElemTy (mkUnitDelayLambda g m (callNonOverloadedMethod g amap m "MoveNext" inpEnumTy [enume])) (mkInvisibleLet m v (callNonOverloadedMethod g amap m "get_Current" inpEnumTy [enume]) (mkCoerceIfNeeded g (mkSeqTy g genElemTy) (tyOfExpr g body) body)))) - Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction + ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel reduction | SeqTryFinally(e1, compensation, m) -> // printfn "found Seq.try/finally" let innerDisposeContinuationLabel = IL.generateCodeLabel() - let resBody = Lower false false noDisposeContinuationLabel innerDisposeContinuationLabel e1 + let resBody = ConvertSeqExprCode false false noDisposeContinuationLabel innerDisposeContinuationLabel e1 match resBody with | Some res1 -> - let capturedVars = unionFreeVars res1.capturedVars (freeInExpr CollectLocals compensation) + let asyncVars = unionFreeVars res1.asyncVars (freeInExpr CollectLocals compensation) Some { phase2 = (fun ((pcVar, _currv, _, pcMap) as ctxt) -> let generate1, dispose1, checkDispose1 = res1.phase2 ctxt let generate = @@ -404,7 +410,7 @@ let LowerSeqExpr g amap overallExpr = entryPoints = innerDisposeContinuationLabel :: res1.entryPoints stateVars = res1.stateVars significantClose = true - capturedVars = capturedVars } + asyncVars = asyncVars } | _ -> None @@ -418,10 +424,10 @@ let LowerSeqExpr g amap overallExpr = entryPoints = [] stateVars = [] significantClose = false - capturedVars = emptyFreeVars } + asyncVars = emptyFreeVars } | Expr.Sequential (x1, x2, NormalSeq, ty, m) -> - match Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel x2 with + match ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel x2 with | Some res2-> // printfn "found sequential execution" Some { res2 with @@ -437,12 +443,12 @@ let LowerSeqExpr g amap overallExpr = // Restriction: compilation of sequence expressions containing non-toplevel constrained generic functions is not supported when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericContraints g bind.Var) -> - let resBody = Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr + let resBody = ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel bodyExpr match resBody with | Some res2 -> if bind.Var.IsCompiledAsTopLevel then Some (RepresentBindingsAsLifted (mkLetBind m bind) res2) - elif not (res2.capturedVars.FreeLocals.Contains(bind.Var)) then + elif not (res2.asyncVars.FreeLocals.Contains(bind.Var)) then // printfn "found state variable %s" bind.Var.DisplayName Some (RepresentBindingAsLocal bind res2 m) else @@ -470,7 +476,7 @@ let LowerSeqExpr g amap overallExpr = | Expr.Val (v, _, _) when not (recvars.ContainsVal v.Deref) -> false | _ -> true) <= 1) -> - match Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 with + match ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel e2 with | Some res2 -> let topLevelBinds, nonTopLevelBinds = binds |> List.partition (fun bind -> bind.Var.IsCompiledAsTopLevel) // Represent the closure-capturing values as state machine locals. They may still be recursively-referential @@ -481,20 +487,21 @@ let LowerSeqExpr g amap overallExpr = | None -> None *) + // LIMITATION: non-trivial pattern matches involving or-patterns or active patterns where bindings can't be + // transferred to the r.h.s. are not yet compiled. + // + // TODO: remove this limitation | Expr.Match (spBind, exprm, pt, targets, m, ty) when targets |> Array.forall (fun (TTarget(vs, _e, _spTarget)) -> isNil vs) -> // lower all the targets. abandon if any fail to lower - let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel targetExpr) - // LIMITATION: non-trivial pattern matches involving or-patterns or active patterns where bindings can't be - // transferred to the r.h.s. are not yet compiled. + let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel targetExpr) if tglArray |> Array.forall Option.isSome then let tglArray = Array.map Option.get tglArray let tgl = Array.toList tglArray let labs = tgl |> List.collect (fun res -> res.entryPoints) - let (capturedVars, _) = - ((emptyFreeVars, false), Array.zip targets tglArray) - ||> Array.fold (fun (fvs, seenLabel) ((TTarget(_vs, e, _spTarget)), res) -> - if seenLabel then unionFreeVars fvs (freeInExpr CollectLocals e), true - else res.capturedVars, not res.entryPoints.IsEmpty) + let asyncVars = + (emptyFreeVars, Array.zip targets tglArray) + ||> Array.fold (fun fvs ((TTarget(_vs, _, _spTarget)), res) -> + if res.entryPoints.IsEmpty then fvs else unionFreeVars fvs res.asyncVars) let stateVars = tgl |> List.collect (fun res -> res.stateVars) let significantClose = tgl |> List.exists (fun res -> res.significantClose) Some { phase2 = (fun ctxt -> @@ -512,7 +519,7 @@ let LowerSeqExpr g amap overallExpr = entryPoints=labs stateVars = stateVars significantClose = significantClose - capturedVars = capturedVars } + asyncVars = asyncVars } else None @@ -572,10 +579,10 @@ let LowerSeqExpr g amap overallExpr = entryPoints=[label] stateVars=[] significantClose = false - capturedVars = emptyFreeVars } + asyncVars = emptyFreeVars } else let v, ve = mkCompGenLocal m "v" inpElemTy - Lower false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel (mkCallSeqCollect g m inpElemTy inpElemTy (mkLambdaNoType g m v (mkCallSeqSingleton g m inpElemTy ve)) arbitrarySeqExpr) + ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel (mkCallSeqCollect g m inpElemTy inpElemTy (mkLambdaNoType g m v (mkCallSeqSingleton g m inpElemTy ve)) arbitrarySeqExpr) match overallExpr with @@ -586,7 +593,7 @@ let LowerSeqExpr g amap overallExpr = let noDisposeContinuationLabel = IL.generateCodeLabel() // Perform phase1 - match Lower true true noDisposeContinuationLabel noDisposeContinuationLabel e with + match ConvertSeqExprCode true true noDisposeContinuationLabel noDisposeContinuationLabel e with | Some res -> // After phase1, create the variables for the state machine and work out a program counter for each label. @@ -778,8 +785,11 @@ let LowerSeqExpr g amap overallExpr = //--------------------------------------------------------------------------------------------- -type LoweredStateMachineFirstPhaseResult = +type StateMachineConversionFirstPhaseResult = { + // Represents the macro-expanded expression prior to decisions about labels + phase1: Expr + /// The second phase of the transformation. It is run after all code labels and their mapping to program counters have been determined /// after the first phase. /// @@ -792,7 +802,7 @@ type LoweredStateMachineFirstPhaseResult = stateVars: ValRef list /// The vars captured by the non-synchronous path - capturedVars: FreeVars + asyncVars: FreeVars } @@ -829,14 +839,19 @@ let (|JumpTableExpr|_|) g expr = | _ -> None /// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) -let RepresentBindingAsLiftedOrLocal (bind: Binding) (res2: LoweredStateMachineFirstPhaseResult) m = - // printfn "LowerSeq: found local variable %s" bind.Var.DisplayName +let RepresentBindingAsLiftedOrLocal (bind: Binding) (res2: StateMachineConversionFirstPhaseResult) m = + if verbose then + printfn "LowerStateMachine: found local variable %s" bind.Var.DisplayName + { res2 with + phase1 = mkLetBind m bind res2.phase1 phase2 = (fun ctxt -> mkLetBind m bind (res2.phase2 ctxt)) } /// Implement a decision to represent a 'let' binding as a state machine variable -let RepresentBindingAsStateVar (bind: Binding) (res2: LoweredStateMachineFirstPhaseResult) m = - // printfn "LowerSeq: found state variable %s" bind.Var.DisplayName +let RepresentBindingAsStateVar (bind: Binding) (res2: StateMachineConversionFirstPhaseResult) m = + if verbose then + printfn "LowerStateMachine: found state variable %s" bind.Var.DisplayName + let (TBind(v, e, sp)) = bind let sp, spm = match sp with @@ -844,6 +859,7 @@ let RepresentBindingAsStateVar (bind: Binding) (res2: LoweredStateMachineFirstPh | _ -> SuppressSequencePointOnExprOfSequential, e.Range let vref = mkLocalValRef v { res2 with + phase1 = mkSequential sp m (mkValSet spm vref e) res2.phase1 phase2 = (fun ctxt -> let generate2 = res2.phase2 ctxt let generate = @@ -892,14 +908,15 @@ let isExpandVar (v: Val) = || (v.BaseOrThisInfo = MemberThisVal) -let LowerStateMachineExpr g overallExpr = +let ConvertStateMachineExprToObject g overallExpr = let mutable pcCount = 0 let genPC() = pcCount <- pcCount + 1 pcCount - // Evaluate __expand_ABC and __newEntryPoint bindings at compile-time + // Evaluate __expand_ABC and __newEntryPoint bindings at compile-time. + // Here we record definitions for later use in TryApplyExpansions let rec BindExpansions g (env: ValMap<_>) expr = match expr with @@ -910,13 +927,14 @@ let LowerStateMachineExpr g overallExpr = // Bind 'let CODE = __newEntryPoint() in bodyExpr' | Expr.Let (TBind(v, NewEntryPointExpr g (), _sp), bodyExpr, m, _) -> - printfn "found __newEntryPoint()" + if verbose then printfn "found __newEntryPoint()" let envR = env.Add v (mkInt g m (genPC())) BindExpansions g envR bodyExpr | _ -> (env, expr) + // Detect sequencing constructs in state machine code let (|SequentialStateMachineCode|_|) expr = match expr with @@ -931,28 +949,44 @@ let LowerStateMachineExpr g overallExpr = | _ -> None - let rec (|ApplyExpansions|) g (env: ValMap<_>) expr = - let env, expr = BindExpansions g env expr + // Apply a single expansion of __expand_ABC and __newEntryPoint in an arbitrary expression + let TryApplyExpansions g (env: ValMap<_>) expr = match expr with // __machine --> ldarg.0 | MachineExpr g (ty, m) -> - mkGetArg0 m ty + Some (mkGetArg0 m ty) // __expand_code --> [expand_code] | Expr.Val (vref, _, _) when env.ContainsVal vref.Deref -> let expandedExpr = env.[vref.Deref] - printfn "expanded %A --> %A..." expr expandedExpr - (|ApplyExpansions|) g env expandedExpr + if verbose then printfn "expanded %A --> %A..." expr expandedExpr + Some expandedExpr // __expand_code x --> let arg = x in expand_code[arg/x] | Expr.App (Expr.Val (vref, _, _), fty, [], args, m) when env.ContainsVal vref.Deref -> let f0 = env.[vref.Deref] let expandedExpr = MakeApplicationAndBetaReduce g (f0, fty, [], args, m) - printfn "expanded %A --> %A..." expr expandedExpr - (|ApplyExpansions|) g env expandedExpr + if verbose then printfn "expanded %A --> %A..." expr expandedExpr + Some expandedExpr - | _ -> expr + | _ -> None + // Repeatedly apply expansions + let rec ApplyExpansions g env expr = + match TryApplyExpansions g env expr with + | Some res -> ApplyExpansions g env res + | None -> expr + + // Repeatedly find bindings and apply expansions + let rec RepeatBindAndApplyExpansions g env expr = + let env, expr = BindExpansions g env expr + match TryApplyExpansions g env expr with + | Some res -> RepeatBindAndApplyExpansions g env res + | None -> env, expr + + let (|ExpandsTo|) g env e = ApplyExpansions g env e + + // Detect a state machine or an application of a state machine to an method let rec (|StateMachineInContext|_|) g (env: ValMap<_>) overallExpr = let env, expr = BindExpansions g env overallExpr match expr with @@ -962,17 +996,22 @@ let LowerStateMachineExpr g overallExpr = Some (env, objExpr, id) | _ -> None + // Detect a state machine with a single method override let (|SingleMethodStateMachineInContext|_|) g overallExpr = match overallExpr with | StateMachineInContext g ValMap.Empty (env, objExpr, remake) -> - printfn "Found state machine..." + if verbose then printfn "Found state machine..." match objExpr with | Expr.Obj (objExprStamp, ty, basev, basecall, overrides, iimpls, stateVars, objExprRange) -> - printfn "Found state machine object..." + if verbose then printfn "Found state machine object..." match overrides with | [ (TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, - (JumpTableExpr g (pcExpr, ApplyExpansions g env (Expr.Lambda (_, _, _, [_dummyv], codeExpr, _, _)))), m)) ] -> - Some (env, objExprStamp, objExprRange, remake, ty, basev, basecall, slotsig, attribs, methTyparsOfOverridingMethod, methodParams, pcExpr, codeExpr, iimpls, stateVars, m) + (JumpTableExpr g (pcExpr, codeLambdaExpr)), m)) ] -> + let env, codeLambdaExpr = RepeatBindAndApplyExpansions g env codeLambdaExpr + match codeLambdaExpr with + | Expr.Lambda (_, _, _, [_dummyv], codeExpr, _, _) -> + Some (env, objExprStamp, objExprRange, remake, ty, basev, basecall, slotsig, attribs, methTyparsOfOverridingMethod, methodParams, pcExpr, codeExpr, iimpls, stateVars, m) + | _ -> None | _ -> None | _ -> None | _ -> None @@ -997,182 +1036,272 @@ let LowerStateMachineExpr g overallExpr = let table = mbuilder.Close(dtree, m, g.int_ty) mkCompGenSequential m table (mkCompGenSequential m (Expr.Op (TOp.Label initLabel, [], [], m)) expr) - let rec Lower env pcExpr expr = - printfn "Lowering %A" expr - let env, expr = BindExpansions g env expr - let expr = (|ApplyExpansions|) g env expr - printfn "Expanded to %A" expr - match expr with - // __entryPoint --> label: - | EntryPointExpr g (ApplyExpansions g env (Int32Expr pc), m) -> - { phase2 = (fun pc2lab -> Expr.Op (TOp.Label pc2lab.[pc], [], [], m)) - entryPoints=[pc] - stateVars = [] - capturedVars = emptyFreeVars } - - // __return v --> return - | ReturnExpr g (v, m) -> - let expr = Expr.Op (TOp.Return, [], [v], m) - { phase2 = (fun _ctxt -> expr) - entryPoints = [] - stateVars = [] - capturedVars = emptyFreeVars } - - // control-flow sequential - // let _step = e1 in e2 - // e1; e2 - | SequentialStateMachineCode(e1, e2, _m, recreate) -> - // printfn "found sequential" - let res1 = Lower env pcExpr e1 - let res2 = Lower env pcExpr e2 - let capturedVars = - if res1.entryPoints.IsEmpty then - // res1 is synchronous - res2.capturedVars - else - // res1 is not synchronous. All of 'e2' is needed after resuming at any of the labels - unionFreeVars res1.capturedVars (freeInExpr CollectLocals e2) - - { phase2 = (fun ctxt -> - let generate1 = res1.phase2 ctxt - let generate2 = res2.phase2 ctxt - let generate = recreate generate1 generate2 - generate) - entryPoints= res1.entryPoints @ res2.entryPoints - stateVars = res1.stateVars @ res2.stateVars - capturedVars = capturedVars } - - //| TOp.While _, _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _)] -> - // exprF (exprF z e1) e2 - - //| TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)] -> - // exprF (exprF z e1) e2 - - //| TOp.For (_), _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [_], e3, _, _)] -> - // exprF (exprF (exprF z e1) e2) e3 - - // Note: residue code of state machine implementations is allowed to use 'TryCatch'... - | Expr.Op (TOp.TryCatch (spTry, spWith), [resty], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [vf], ef, _, _); Expr.Lambda (_, _, _, [vh], eh, _, _)], m) -> - let res1 = Lower env pcExpr e1 - let resf = Lower env pcExpr ef - let resh = Lower env pcExpr eh - { phase2 = (fun ctxt -> - // We can't jump into a try/catch block. So we jump to the start of the try/catch and add a new jump table - let pcsAndLabs = ctxt |> Map.toList - let innerPcs = res1.entryPoints - if innerPcs.IsEmpty then - let e1R = res1.phase2 ctxt - let efR = resf.phase2 ctxt - let ehR = resh.phase2 ctxt - mkTryWith g (e1R, vf, efR, vh, ehR, m, resty, spTry, spWith) - else - let innerPcSet = innerPcs |> Set.ofList - let outerLabsForInnerPcs = pcsAndLabs |> List.filter (fun (pc, _outerLab) -> innerPcSet.Contains pc) |> List.map snd - // generate the inner labels - let pcsAndInnerLabs = pcsAndLabs |> List.map (fun (pc, l) -> (pc, if innerPcSet.Contains pc then IL.generateCodeLabel() else l)) - let innerPc2Lab = Map.ofList pcsAndInnerLabs - - let e1R = res1.phase2 innerPc2Lab - let efR = resf.phase2 ctxt - let ehR = resh.phase2 ctxt - - let e1RWithJumpTable = addPcJumpTable g m innerPcs innerPc2Lab pcExpr e1R - let coreExpr = mkTryWith g (e1RWithJumpTable, vf, efR, vh, ehR, m, resty, spTry, spWith) - // place all the outer labels just before the try - let labelledExpr = (coreExpr, outerLabsForInnerPcs) ||> List.fold (fun e l -> mkCompGenSequential m (Expr.Op (TOp.Label l, [], [], m)) e) + /// Detect constructs allowed in state machines + let rec ConvertStateMachineCode env pcExpr expr = + if verbose then + printfn "---------" + printfn "ConvertStateMachineCodeing %s" (DebugPrint.showExpr expr) + printfn "---------" + + let env, expr = RepeatBindAndApplyExpansions g env expr + + if verbose then + printfn "Expanded to %s" (DebugPrint.showExpr expr) + printfn "---------" + + // Detect the different permitted constructs in the expanded state machine + let res = + match expr with + + // The expanded code for state machines may use __entryPoint. This indicates a resumption point. + | EntryPointExpr g (ExpandsTo g env (Int32Expr pc), m) -> + { phase1 = expr + phase2 = (fun pc2lab -> Expr.Op (TOp.Label pc2lab.[pc], [], [], m)) + entryPoints=[pc] + stateVars = [] + asyncVars = emptyFreeVars } + + // The expanded code for state machines may use __return. This construct returns from the + // overall method of the state machine. + // + // If the return occurs inside a try/with the actual effect is to branch out of the try/with + // with the given result for that expression. Thus a 'return' is not guaranteed to be an early + // exit. + // + // __return v --> return + | ReturnExpr g (v, m) -> + let expr = Expr.Op (TOp.Return, [], [v], m) + { phase1 = expr + phase2 = (fun _ctxt -> expr) + entryPoints = [] + stateVars = [] + asyncVars = emptyFreeVars } + + // The expanded code for state machines may use sequential binding and sequential execution. + // + // let __machine_step$cont = e1 in e2 + // e1; e2 + // + // A binding 'let .. = ... in ... ' is considered part of the state machine logic + // if it uses a binding variable name of precisely '__machine_step$cont'. + // If this case 'e1' becomes part of the state machine too. + | SequentialStateMachineCode(e1, e2, _m, recreate) -> + // printfn "found sequential" + let res1 = ConvertStateMachineCode env pcExpr e1 + let res2 = ConvertStateMachineCode env pcExpr e2 + let asyncVars = + if res1.entryPoints.IsEmpty then + // res1 is synchronous + res2.asyncVars + else + // res1 is not synchronous. All of 'e2' is needed after resuming at any of the labels + unionFreeVars res1.asyncVars (freeInExpr CollectLocals res2.phase1) + + { phase1 = recreate res1.phase1 res2.phase1 + phase2 = (fun ctxt -> + let generate1 = res1.phase2 ctxt + let generate2 = res2.phase2 ctxt + let generate = recreate generate1 generate2 + generate) + entryPoints= res1.entryPoints @ res2.entryPoints + stateVars = res1.stateVars @ res2.stateVars + asyncVars = asyncVars } + + // The expanded code for state machines may use while loops... + | Expr.Op (TOp.While (sp1, sp2), _, [Expr.Lambda (_, _, _, [_gv], guardExpr, _, _);Expr.Lambda (_, _, _, [_bv], bodyExpr, _, _)], m) -> + let resg = ConvertStateMachineCode env pcExpr guardExpr + let resb = ConvertStateMachineCode env pcExpr bodyExpr + let eps = resg.entryPoints @ resb.entryPoints + // All free variables get captured if there are any entrypoints at all + let asyncVars = if eps.IsEmpty then emptyFreeVars else unionFreeVars (freeInExpr CollectLocals resg.phase1) (freeInExpr CollectLocals resb.phase1) + { phase1 = mkWhile g (sp1, sp2, resg.phase1, resb.phase1, m) + phase2 = (fun ctxt -> + let egR = resg.phase2 ctxt + let ebR = resb.phase2 ctxt + mkWhile g (sp1, sp2, egR, ebR, m)) + entryPoints= eps + stateVars = resg.stateVars @ resb.stateVars + asyncVars = asyncVars } + + // The expanded code for state machines shoud not normally contain try/finally as any resumptions will repeatedly execute the finally. + // Hoever we include the synchronous version of the construct here for completeness. + | Expr.Op (TOp.TryFinally (sp1, sp2), [ty], [Expr.Lambda (_, _, _, [_], e1, _, _); Expr.Lambda (_, _, _, [_], e2, _, _)], m) -> + let res1 = ConvertStateMachineCode env pcExpr e1 + let res2 = ConvertStateMachineCode env pcExpr e2 + let eps = res1.entryPoints @ res2.entryPoints + if eps.Length > 0 then + failwith "invalid state machine - try/finally may not contain resumption points" + { phase1 = mkTryFinally g (res1.phase1, res2.phase1, m, ty, sp1, sp2) + phase2 = (fun ctxt -> + let egR = res1.phase2 ctxt + let ebR = res2.phase2 ctxt + mkTryFinally g (egR, ebR, m, ty, sp1, sp2)) + entryPoints= eps + stateVars = res1.stateVars @ res2.stateVars + asyncVars = emptyFreeVars (* eps is empty, hence synchronous, no capture *) } + + | Expr.Op (TOp.For (sp1, sp2), _, [Expr.Lambda (_, _, _, [_], e1, _, _);Expr.Lambda (_, _, _, [_], e2, _, _);Expr.Lambda (_, _, _, [v], e3, _, _)], m) -> + let res1 = ConvertStateMachineCode env pcExpr e1 + let res2 = ConvertStateMachineCode env pcExpr e2 + let res3 = ConvertStateMachineCode env pcExpr e3 + let eps = res1.entryPoints @ res2.entryPoints @ res3.entryPoints + if eps.Length > 0 then + failwith "invalid state machine - try/finally may not contain asynchronous fast integer for loops" + { phase1 = mkFor g (sp1, v, res1.phase1, sp2, res2.phase1, res3.phase1, m) + phase2 = (fun ctxt -> + let e1R = res1.phase2 ctxt + let e2R = res2.phase2 ctxt + let e3R = res3.phase2 ctxt + mkFor g (sp1, v, e1R, sp2, e2R, e3R, m)) + entryPoints= eps + stateVars = res1.stateVars @ res2.stateVars @ res3.stateVars + asyncVars = emptyFreeVars (* eps is empty, hence synchronous, no capture *) } + + // The expanded code for state machines may use try/with.... + | Expr.Op (TOp.TryCatch (spTry, spWith), [resTy], [Expr.Lambda (_, _, _, [_], bodyExpr, _, _); Expr.Lambda (_, _, _, [filterVar], filterExpr, _, _); Expr.Lambda (_, _, _, [handlerVar], handlerExpr, _, _)], m) -> + let resBody = ConvertStateMachineCode env pcExpr bodyExpr + let resFilter = ConvertStateMachineCode env pcExpr filterExpr + let resHandler = ConvertStateMachineCode env pcExpr handlerExpr + { phase1 = mkTryWith g (resBody.phase1, filterVar, resFilter.phase1, handlerVar, resHandler.phase1, m, resTy, spTry, spWith) + phase2 = (fun ctxt -> + // We can't jump into a try/catch block. So we jump to the start of the try/catch and add a new jump table + let pcsAndLabs = ctxt |> Map.toList + let innerPcs = resBody.entryPoints + if innerPcs.IsEmpty then + let bodyExprR = resBody.phase2 ctxt + let filterExprR = resFilter.phase2 ctxt + let handlerExprR = resHandler.phase2 ctxt + mkTryWith g (bodyExprR, filterVar, filterExprR, handlerVar, handlerExprR, m, resTy, spTry, spWith) + else + let innerPcSet = innerPcs |> Set.ofList + let outerLabsForInnerPcs = pcsAndLabs |> List.filter (fun (pc, _outerLab) -> innerPcSet.Contains pc) |> List.map snd + // generate the inner labels + let pcsAndInnerLabs = pcsAndLabs |> List.map (fun (pc, l) -> (pc, if innerPcSet.Contains pc then IL.generateCodeLabel() else l)) + let innerPc2Lab = Map.ofList pcsAndInnerLabs + + let bodyExprR = resBody.phase2 innerPc2Lab + let filterExprR = resFilter.phase2 ctxt + let handlerExprR = resHandler.phase2 ctxt + + // Add a jump table at the entry to the try + let bodyExprRWithJumpTable = addPcJumpTable g m innerPcs innerPc2Lab pcExpr bodyExprR + let coreExpr = mkTryWith g (bodyExprRWithJumpTable, filterVar, filterExprR, handlerVar, handlerExprR, m, resTy, spTry, spWith) + // Place all the outer labels just before the try + let labelledExpr = (coreExpr, outerLabsForInnerPcs) ||> List.fold (fun e l -> mkCompGenSequential m (Expr.Op (TOp.Label l, [], [], m)) e) - //((pcInit, initLabel) :: List.zip pcs labs) - - labelledExpr) - entryPoints= res1.entryPoints @ resf.entryPoints @ resh.entryPoints - stateVars = res1.stateVars @ resf.stateVars @ resh.stateVars - capturedVars = unionFreeVars res1.capturedVars (unionFreeVars(freeInExpr CollectLocals ef) (freeInExpr CollectLocals eh)) } - - // control-flow match - | Expr.Match (spBind, exprm, pt, targets, m, ty) when targets |> Array.forall (fun (TTarget(vs, _e, _spTarget)) -> isNil vs) -> - // lower all the targets. abandon if any fail to lower - let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> Lower env pcExpr targetExpr) - // LIMITATION: non-trivial pattern matches involving or-patterns or active patterns where bindings can't be - // transferred to the r.h.s. are not yet compiled. - let tgl = Array.toList tglArray - let entyPoints = tgl |> List.collect (fun res -> res.entryPoints) - let (capturedVars, _) = - ((emptyFreeVars, false), Array.zip targets tglArray) - ||> Array.fold (fun (fvs, seenLabel) ((TTarget(_vs, e, _spTarget)), res) -> - if seenLabel then unionFreeVars fvs (freeInExpr CollectLocals e), true - else res.capturedVars, not res.entryPoints.IsEmpty) - let stateVars = tgl |> List.collect (fun res -> res.stateVars) - { phase2 = (fun ctxt -> - let gtgs = - (Array.toList targets, tgl) - ||> List.map2 (fun (TTarget(vs, _, spTarget)) res -> - let generate = res.phase2 ctxt - let gtg = TTarget(vs, generate, spTarget) - gtg) - let generate = primMkMatch (spBind, exprm, pt, Array.ofList gtgs, m, ty) - generate) - entryPoints=entyPoints - stateVars = stateVars - capturedVars = capturedVars } - - // Non-control-flow let binding - | Expr.Let (bind, bodyExpr, m, _) - // Restriction: compilation of sequence expressions containing non-toplevel constrained generic functions is not supported - when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericContraints g bind.Var) -> - - // Rewrite the expression on the r.h.s. of the binding - let bind = mkBind bind.SequencePointInfo bind.Var ((|ApplyExpansions|) g env bind.Expr) + //((pcInit, initLabel) :: List.zip pcs labs) - let resBody = Lower env pcExpr bodyExpr - if bind.Var.IsCompiledAsTopLevel || not (resBody.capturedVars.FreeLocals.Contains(bind.Var)) then - (RepresentBindingAsLiftedOrLocal bind resBody m) - else - // printfn "found state variable %s" bind.Var.DisplayName - (RepresentBindingAsStateVar bind resBody m) - - // Arbitrary expression - | _ -> - let expr = - RewriteExpr { PreIntercept = None - PostTransform = (fun e -> Some ((|ApplyExpansions|) g env e)) - PreInterceptBinding = None - IsUnderQuotations=true } expr - { phase2 = (fun _ctxt -> expr) - entryPoints=[] - stateVars = [] - capturedVars = emptyFreeVars } + labelledExpr) + entryPoints= resBody.entryPoints @ resFilter.entryPoints @ resHandler.entryPoints + stateVars = resBody.stateVars @ resFilter.stateVars @ resHandler.stateVars + asyncVars = unionFreeVars resBody.asyncVars (unionFreeVars(freeInExpr CollectLocals resFilter.phase1) (freeInExpr CollectLocals resHandler.phase1)) } + // control-flow match + | Expr.Match (spBind, exprm, pt, targets, m, ty) -> + // lower all the targets. + let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> ConvertStateMachineCode env pcExpr targetExpr) + let tgl = Array.toList tglArray + let entryPoints = tgl |> List.collect (fun res -> res.entryPoints) + let asyncVars = + (emptyFreeVars, Array.zip targets tglArray) + ||> Array.fold (fun fvs ((TTarget(_vs, _, _spTarget)), res) -> + if res.entryPoints.IsEmpty then fvs else unionFreeVars fvs res.asyncVars) + let stateVars = tgl |> List.collect (fun res -> res.stateVars) + { phase1 = + let gtgs = (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, spTarget)) res -> TTarget(vs, res.phase1, spTarget)) + primMkMatch (spBind, exprm, pt, gtgs, m, ty) + phase2 = (fun ctxt -> + let gtgs = (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, spTarget)) res -> TTarget(vs, res.phase2 ctxt, spTarget)) + let generate = primMkMatch (spBind, exprm, pt, gtgs, m, ty) + generate) + entryPoints = entryPoints + stateVars = stateVars + asyncVars = asyncVars } + + // Non-control-flow let binding can appear as part of state machine. The body is considered state-machine code, + // the expression being bound is not. + | Expr.Let (bind, bodyExpr, m, _) + // Restriction: compilation of sequence expressions containing non-toplevel constrained generic functions is not supported + when bind.Var.IsCompiledAsTopLevel || not (IsGenericValWithGenericContraints g bind.Var) -> + + // Rewrite the expression on the r.h.s. of the binding + // TODO: this outer use of ApplyExpansions looks wrong. + let bind = mkBind bind.SequencePointInfo bind.Var (ApplyExpansions g env bind.Expr) + + let resBody = ConvertStateMachineCode env pcExpr bodyExpr + if bind.Var.IsCompiledAsTopLevel || not (resBody.asyncVars.FreeLocals.Contains(bind.Var)) then + (RepresentBindingAsLiftedOrLocal bind resBody m) + else + // printfn "found state variable %s" bind.Var.DisplayName + (RepresentBindingAsStateVar bind resBody m) + + // LetRec bindings may not appear as part of state machine. + | Expr.LetRec _ -> + failwith "recursive bindings not allowed in state machine, please lift it out" + + // Arbitrary expression + | _ -> + // Reqrite all macro expansions + let expr = + expr |> RewriteExpr { PreIntercept = Some (fun cont e -> match TryApplyExpansions g env e with Some e2 -> Some (cont e2) | None -> None) + PostTransform = (fun _ -> None) + PreInterceptBinding = None + IsUnderQuotations=true } + { phase1 = expr + phase2 = (fun _ctxt -> expr) + entryPoints=[] + stateVars = [] + asyncVars = emptyFreeVars } + if verbose then + printfn "-------------------" + printfn "Phase 1 Done for %s" (DebugPrint.showExpr res.phase1) + printfn "Phase 1 Done, asyncVars = %A" (res.asyncVars.FreeLocals |> Zset.elements |> List.map (fun v -> v.CompiledName) |> String.concat ",") + printfn "-------------------" + res + + // Detect a state machine and convert it match overallExpr with - // TODO: use appInfo | SingleMethodStateMachineInContext g (env, objExprStamp, objExprRange, remake, ty, basev, basecall, slotsig, attribs, methTyparsOfOverridingMethod, methodParams, pcExpr, codeExpr, iimpls, origStateVars, m) -> - printfn "Found state machine override method and code expression..." - printfn "----------- BEFORE LOWER ----------------------" - printfn "%s" (DebugPrint.showExpr codeExpr) - printfn "----------- LOWER ----------------------" - // printfn "found seq { ... } or Seq.delay (fun () -> ...) in FSharp.Core.dll" - //let m = e.Range - - // Perform phase1 - let res = Lower env pcExpr codeExpr + if verbose then + printfn "Found state machine override method and code expression..." + printfn "----------- BEFORE LOWER ----------------------" + printfn "%s" (DebugPrint.showExpr codeExpr) + printfn "----------- LOWER ----------------------" + + // Perform phase1 of the conversion + let res = ConvertStateMachineCode env pcExpr codeExpr + + // Work out the initial mapping of pcs to labels let pcs = [ 1 .. pcCount ] let stateVars = res.stateVars let labs = pcs |> List.map (fun _ -> IL.generateCodeLabel()) let pc2lab = Map.ofList (List.zip pcs labs) // Execute phase2, building the core of the method - printfn "----------- PHASE2 ----------------------" + if verbose then printfn "----------- PHASE2 ----------------------" + + // Perform phase2 to build the final expression let methodBodyExprR = res.phase2 pc2lab - printfn "----------- ADDING JUMP TABLE ----------------------" + + if verbose then printfn "----------- ADDING JUMP TABLE ----------------------" + + // Add the jump table let methodBodyExprWithJumpTable = addPcJumpTable g m pcs pc2lab pcExpr methodBodyExprR + + if verbose then printfn "----------- REMAKE ----------------------" + + // Rebuild the object expression let overrideR = TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, methodBodyExprWithJumpTable, m) let objExprR = Expr.Obj (objExprStamp, ty, basev, basecall, [overrideR], iimpls, origStateVars @ stateVars, objExprRange) - printfn "----------- REMAKE ----------------------" let overallExprR = remake objExprR - printfn "----------- AFTER REWRITE ----------------------" - printfn "%s" (DebugPrint.showExpr overallExprR) - printfn "----------- CHECKING ----------------------" - let mutable failed = false + + if verbose then + printfn "----------- AFTER REWRITE ----------------------" + printfn "%s" (DebugPrint.showExpr overallExprR) + + //printfn "----------- CHECKING ----------------------" + //let mutable failed = false //let _expr = // overallExprR |> RewriteExpr // { PreIntercept = None @@ -1185,7 +1314,9 @@ let LowerStateMachineExpr g overallExpr = // | _ -> None) // PreInterceptBinding = None // IsUnderQuotations=true } - printfn "----------- DONE ----------------------" - if failed then None else Some overallExprR + if verbose then printfn "----------- DONE ----------------------" + + Some overallExprR + | _ -> None diff --git a/src/fsharp/LowerCallsAndSeqs.fsi b/src/fsharp/LowerCallsAndSeqs.fsi index be2ff03c5c7..b4661b22a40 100644 --- a/src/fsharp/LowerCallsAndSeqs.fsi +++ b/src/fsharp/LowerCallsAndSeqs.fsi @@ -19,8 +19,8 @@ val LowerImplFile: g: TcGlobals -> assembly: TypedImplFile -> TypedImplFile /// a program counter (pc) that records the current state, and a current generated value (current). /// All these variables are then represented as fields in a hosting closure object along with any additional /// free variables of the sequence expression. -val LowerSeqExpr: g: TcGlobals -> amap: ImportMap -> overallExpr: Expr -> (ValRef * ValRef * ValRef * ValRef list * Expr * Expr * Expr * TType * range) option +val ConvertSequenceExprToObject: g: TcGlobals -> amap: ImportMap -> overallExpr: Expr -> (ValRef * ValRef * ValRef * ValRef list * Expr * Expr * Expr * TType * range) option /// Analyze a TAST expression to detect the elaborated form of a state machine expression, a special kind /// of object expression that uses special code generation constructs. -val LowerStateMachineExpr: g: TcGlobals -> overallExpr: Expr -> Expr option +val ConvertStateMachineExprToObject: g: TcGlobals -> overallExpr: Expr -> Expr option diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index bf1c79e2099..4ae42db5ba4 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -3659,7 +3659,7 @@ module DebugPrint = reprL and bindingL (TBind(v, repr, _)) = - valAtBindL v --- (wordL(tagText "=") ^^ exprL repr) + (valAtBindL v ^^ wordL(tagText "=")) @@-- exprL repr and exprL expr = exprWrapL false expr @@ -3673,7 +3673,7 @@ module DebugPrint = (aboveListL eqnsL @@ bodyL) and letL bind bodyL = - let eqnL = wordL(tagText "let") ^^ bindingL bind ^^ wordL(tagText "in") + let eqnL = wordL(tagText "let") ^^ bindingL bind (eqnL @@ bodyL) and exprWrapL isAtomic expr = @@ -3694,8 +3694,8 @@ module DebugPrint = | Expr.Sequential (expr1, expr2, flag, _, _) -> let flag = match flag with - | NormalSeq -> "; (*Seq*)" - | ThenDoSeq -> "; (*ThenDo*)" + | NormalSeq -> ";" + | ThenDoSeq -> "; ThenDo" ((exprL expr1 ^^ rightL (tagText flag)) @@ exprL expr2) |> wrap | Expr.Lambda (_, _, baseValOpt, argvs, body, _, _) -> let formalsL = spaceListL (List.map valAtBindL argvs) in @@ -3770,22 +3770,22 @@ module DebugPrint = let meth = ilMethRef.Name wordL(tagText "ILCall") ^^ aboveListL - [ wordL(tagText "meth ") --- wordL (tagText ilMethRef.DeclaringTypeRef.FullName) ^^ sepL(tagText ".") ^^ wordL (tagText meth) - wordL(tagText "tinst ") --- listL typeL tinst - wordL(tagText "minst ") --- listL typeL minst - wordL(tagText "tyargs") --- listL typeL tyargs - wordL(tagText "args ") --- listL exprL args ] + [ yield wordL (tagText ilMethRef.DeclaringTypeRef.FullName) ^^ sepL(tagText ".") ^^ wordL (tagText meth) + if not tinst.IsEmpty then yield wordL(tagText "tinst ") --- listL typeL tinst + if not minst.IsEmpty then yield wordL (tagText "minst ") --- listL typeL minst + if not tyargs.IsEmpty then yield wordL (tagText "tyargs") --- listL typeL tyargs + if not args.IsEmpty then yield listL exprL args ] |> wrap | Expr.Op (TOp.Array, [_], xs, _) -> leftL(tagText "[|") ^^ commaListL (List.map exprL xs) ^^ rightL(tagText "|]") | Expr.Op (TOp.While _, [], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _)], _) -> - wordL(tagText "while") ^^ exprL x1 ^^ wordL(tagText "do") ^^ exprL x2 ^^ rightL(tagText "}") + (wordL(tagText "while") ^^ exprL x1 ^^ wordL(tagText "do")) @@-- exprL x2 | Expr.Op (TOp.For _, [], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _);Expr.Lambda (_, _, _, [_], x3, _, _)], _) -> wordL(tagText "for") ^^ aboveListL [(exprL x1 ^^ wordL(tagText "to") ^^ exprL x2 ^^ wordL(tagText "do")); exprL x3 ] ^^ rightL(tagText "done") | Expr.Op (TOp.TryCatch _, [_], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], xf, _, _);Expr.Lambda (_, _, _, [_], xh, _, _)], _) -> - wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "with-filter") ^^ exprL xf ^^ wordL(tagText "with") ^^ exprL xh ^^ rightL(tagText "}") + (wordL (tagText "try") @@-- exprL x1) @@ (wordL(tagText "with-filter") @@-- exprL xf) @@ (wordL(tagText "with") @@-- exprL xh) | Expr.Op (TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _)], _) -> - wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "finally") ^^ exprL x2 ^^ rightL(tagText "}") + (wordL (tagText "try") @@-- exprL x1) @@ (wordL(tagText "finally") @@-- exprL x2) | Expr.Op (TOp.Bytes _, _, _, _) -> wordL(tagText "bytes++") | Expr.Op (TOp.UInt16s _, _, _, _) -> wordL(tagText "uint16++") @@ -3800,12 +3800,16 @@ module DebugPrint = | Expr.Op (_, _tys, args, _) -> wordL(tagText "Expr.Op ...") ^^ bracketL (commaListL (List.map atomL args)) | Expr.Quote (a, _, _, _, _) -> leftL(tagText "<@") ^^ atomL a ^^ rightL(tagText "@>") | Expr.Obj (_lambdaId, ty, basev, ccall, overrides, iimpls, _stateVars, _) -> - wordL(tagText "OBJ:") ^^ - aboveListL [typeL ty - exprL ccall - optionL valAtBindL basev - aboveListL (List.map overrideL overrides) - aboveListL (List.map iimplL iimpls)] + (leftL (tagText "{") + @@-- + ((wordL(tagText "new ") ++ typeL ty) + @@-- + aboveListL [exprL ccall + optionL valAtBindL basev + aboveListL (List.map tmethodL overrides) + aboveListL (List.map iimplL iimpls)])) + @@ + rightL (tagText "}") | Expr.StaticOptimization (_tcs, csx, x, _) -> (wordL(tagText "opt") @@- (exprL x)) @@-- @@ -3821,8 +3825,8 @@ module DebugPrint = and appL flayout tys args = let z = flayout - let z = z ^^ instL typeL tys - let z = z --- sepL(tagText "`") --- (spaceListL (List.map atomL args)) + let z = if tys.Length > 0 then z ^^ instL typeL tys else z + let z = if args.Length > 0 then z --- spaceListL (List.map atomL args) else z z and implFileL (TImplFile (_, _, mexpr, _, _, _)) = @@ -3890,13 +3894,12 @@ module DebugPrint = and flatValsL vs = vs |> List.map valL and tmethodL (TObjExprMethod(TSlotSig(nm, _, _, _, _, _), _, tps, vs, e, _)) = - (wordL(tagText "TObjExprMethod") --- (wordL (tagText nm)) ^^ wordL(tagText "=")) -- - (wordL(tagText "METH-LAM") --- angleBracketListL (List.map typarL tps) ^^ rightL(tagText ".")) --- - (wordL(tagText "meth-lam") --- tupleL (List.map (List.map valAtBindL >> tupleL) vs) ^^ rightL(tagText ".")) --- + ((wordL(tagText "TObjExprMethod") --- (wordL (tagText nm)) ^^ wordL(tagText "=")) -- + (angleBracketListL (List.map typarL tps) ^^ rightL(tagText ".")) --- + (tupleL (List.map (List.map valAtBindL >> tupleL) vs) ^^ rightL(tagText "."))) + @@-- (atomL e) - and overrideL tmeth = wordL(tagText "with") ^^ tmethodL tmeth - and iimplL (ty, tmeths) = wordL(tagText "impl") ^^ aboveListL (typeL ty :: List.map tmethodL tmeths) let showType x = Layout.showL (typeL x) diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs index 9c26ec0a6b4..8a7a66d18a1 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs @@ -25,6 +25,19 @@ open System.Threading open System.Threading.Tasks open Microsoft.FSharp.Control +exception TestException of string + +let BIG = 10 +// TODO let BIG = 10000 +let require x msg = if not x then failwith msg +let failtest str = raise (TestException str) + +let tnested() = + task { + let! x = task { return 1 } + return x + } + let tcatch0() = task { try @@ -92,11 +105,9 @@ let t3c() = //printfn "t3c().Result = %A" (t3c().Result) -exception TestException of string - -let require x msg = if not x then failwith msg let testShortCircuitResult() = + printfn "Running testShortCircuitResult..." let t = task { let! x = Task.FromResult(1) @@ -108,6 +119,7 @@ let testShortCircuitResult() = let testDelay() = + printfn "Running testDelay..." let mutable x = 0 let t = task { @@ -120,6 +132,7 @@ let testDelay() = t.Wait() let testNoDelay() = + printfn "Running testNoDelay..." let mutable x = 0 let t = task { @@ -131,6 +144,7 @@ let testNoDelay() = t.Wait() let testNonBlocking() = + printfn "Running testNonBlocking..." let sw = Stopwatch() sw.Start() let t = @@ -142,10 +156,9 @@ let testNonBlocking() = require (sw.ElapsedMilliseconds < 50L) "sleep blocked caller" t.Wait() -let failtest str = raise (TestException str) - let testCatching1() = + printfn "Running testCatching1..." let mutable x = 0 let mutable y = 0 let t = @@ -168,6 +181,7 @@ let testCatching1() = require (x = 0) "ran past failure" let testCatching2() = + printfn "Running testCatching2..." let mutable x = 0 let mutable y = 0 let t = @@ -190,6 +204,7 @@ let testCatching2() = let testNestedCatching() = + printfn "Running testNestedCatching..." let mutable counter = 1 let mutable caughtInner = 0 let mutable caughtOuter = 0 @@ -226,6 +241,7 @@ let testNestedCatching() = let testTryFinallyHappyPath() = + printfn "Running testTryFinallyHappyPath..." let mutable ran = false let t = task { @@ -240,6 +256,7 @@ let testTryFinallyHappyPath() = require ran "never ran" let testTryFinallySadPath() = + printfn "Running testTryFinallySadPath..." let mutable ran = false let t = task { @@ -258,6 +275,7 @@ let testTryFinallySadPath() = require ran "never ran" let testTryFinallyCaught() = + printfn "Running testTryFinallyCaught..." let mutable ran = false let t = task { @@ -275,9 +293,10 @@ let testTryFinallyCaught() = } require (t.Result = 2) "wrong return" require ran "never ran" - -(* + + let testUsing() = + printfn "Running testUsing..." let mutable disposed = false let t = task { @@ -289,7 +308,9 @@ let testUsing() = t.Wait() require disposed "never disposed B" + let testUsingFromTask() = + printfn "Running testUsingFromTask..." let mutable disposedInner = false let mutable disposed = false let t = @@ -309,7 +330,9 @@ let testUsingFromTask() = t.Wait() require disposed "never disposed C" + let testUsingSadPath() = + printfn "Running testUsingSadPath..." let mutable disposedInner = false let mutable disposed = false let t = @@ -326,15 +349,60 @@ let testUsingSadPath() = () with | TestException msg -> + printfn "caught TestException" require disposedInner "did not dispose inner after task completion" require (not disposed) "disposed way early" do! Task.Delay(50) + printfn "resumed after delay" require (not disposed) "disposed kinda early" } t.Wait() require (not disposed) "disposed thing that never should've existed" -let testForLoop() = +let testWhileLoopAsync() = + printfn "Running testWhileLoopAsync..." + let t = + task { + let mutable i = 0 + while i < 10 do + i <- i + 1 + do! Task.Yield() + return i + } + t.Wait() + require (t.Result = 10) "didn't do while loop properly" + +let testWhileLoopSync() = + printfn "Running testWhileLoopSync..." + let t = + task { + let mutable i = 0 + while i < 10 do + i <- i + 1 + return i + } + //t.Wait() no wait required for sync loop + require (t.IsCompleted) "didn't do sync while loop properly - not completed" + require (t.Result = 10) "didn't do sync while loop properly - wrong result" + +let testForLoopA() = + printfn "Running testForLoopA..." + let list = ["a"; "b"; "c"] |> Seq.ofList + let t = + task { + printfn "entering loop..." + let mutable x = Unchecked.defaultof<_> + let e = list.GetEnumerator() + while e.MoveNext() do + x <- e.Current + printfn "x = %A" x + do! Task.Yield() + printfn "x = %A" x + } + t.Wait() + +let testForLoopComplex() = + printfn "Running testForLoopComplex..." let mutable disposed = false let wrapList = let raw = ["a"; "b"; "c"] |> Seq.ofList @@ -389,8 +457,25 @@ let testForLoop() = } t.Wait() require disposed "never disposed D" + require (t.Result = 1) "wrong result" + let testForLoopSadPath() = + printfn "Running testForLoopSadPath..." + let wrapList = ["a"; "b"; "c"] + let t = + task { + let mutable index = 0 + do! Task.Yield() + for x in wrapList do + do! Task.Yield() + index <- index + 1 + return 1 + } + require (t.Result = 1) "wrong result" + +let testForLoopSadPathComplex() = + printfn "Running testForLoopSadPathComplex..." let mutable disposed = false let wrapList = let raw = ["a"; "b"; "c"] |> Seq.ofList @@ -441,7 +526,7 @@ let testForLoopSadPath() = require (t.Result = 2) "wrong result" require caught "didn't catch exception" require disposed "never disposed A" - + let testExceptionAttachedToTaskWithoutAwait() = let mutable ranA = false let mutable ranB = false @@ -504,7 +589,7 @@ let testExceptionAttachedToTaskWithAwait() = require ranCatcher "didn't run" require catcher.Result "didn't catch" require caught "didn't catch" - + let testExceptionThrownInFinally() = let mutable ranInitial = false let mutable ranNext = false @@ -555,14 +640,13 @@ let test2ndExceptionThrownInFinally() = | _ -> () require ranNext "didn't run next" require (ranFinally = 1) "didn't run finally exactly once" - + let testFixedStackWhileLoop() = - let bigNumber = 10000 let t = task { let mutable maxDepth = Nullable() let mutable i = 0 - while i < bigNumber do + while i < BIG do i <- i + 1 do! Task.Yield() if i % 100 = 0 then @@ -573,15 +657,14 @@ let testFixedStackWhileLoop() = return i } t.Wait() - require (t.Result = bigNumber) "didn't get to big number" + require (t.Result = BIG) "didn't get to big number" let testFixedStackForLoop() = - let bigNumber = 10000 let mutable ran = false let t = task { let mutable maxDepth = Nullable() - for i in Seq.init bigNumber id do + for i in Seq.init BIG id do do! Task.Yield() if i % 100 = 0 then let stackDepth = StackTrace().FrameCount @@ -593,7 +676,7 @@ let testFixedStackForLoop() = } t.Wait() require ran "didn't run all" - + let testTypeInference() = let t1 : string Task = task { @@ -610,17 +693,17 @@ let testNoStackOverflowWithImmediateResult() = let longLoop = task { let mutable n = 0 - while n < 10_000 do + while n < BIG do n <- n + 1 return! Task.FromResult(()) } longLoop.Wait() - + let testNoStackOverflowWithYieldResult() = let longLoop = task { let mutable n = 0 - while n < 10_000 do + while n < BIG do let! _ = task { do! Task.Yield() @@ -632,22 +715,22 @@ let testNoStackOverflowWithYieldResult() = longLoop.Wait() let testSmallTailRecursion() = + let rec loop n = + task { + // larger N would stack overflow on Mono, eat heap mem on MS .NET + if n < 1000 then + do! Task.Yield() + let! _ = Task.FromResult(0) + return! loop (n + 1) + else + return () + } let shortLoop = task { - let rec loop n = - task { - // larger N would stack overflow on Mono, eat heap mem on MS .NET - if n < 1000 then - do! Task.Yield() - let! _ = Task.FromResult(0) - return! loop (n + 1) - else - return () - } return! loop 0 } shortLoop.Wait() - + let testTryOverReturnFrom() = let inner() = task { @@ -686,7 +769,7 @@ let testTryFinallyOverReturnFromWithException() = with | :? AggregateException -> () require (m = 1) "didn't run finally" - + let testTryFinallyOverReturnFromWithoutException() = let inner() = task { @@ -765,7 +848,7 @@ let testCompilerInfersArgumentOfReturnFrom() = if true then return 1 else return! failwith "" } - *) + [] let main argv = @@ -778,33 +861,41 @@ let main argv = testCatching1() testCatching2() testNestedCatching() + testWhileLoopSync() + testWhileLoopAsync() testTryFinallyHappyPath() testTryFinallySadPath() testTryFinallyCaught() - //testUsing() - //testUsingFromTask() - //testUsingSadPath() - //testForLoop() - //testForLoopSadPath() - //testExceptionAttachedToTaskWithoutAwait() - //testExceptionAttachedToTaskWithAwait() - //testExceptionThrownInFinally() - //test2ndExceptionThrownInFinally() - //testFixedStackWhileLoop() - //testFixedStackForLoop() - //testTypeInference() - //testNoStackOverflowWithImmediateResult() - //testNoStackOverflowWithYieldResult() + testUsing() + testUsingFromTask() + testUsingSadPath() + testForLoopA() + testForLoopSadPath() + testForLoopSadPathComplex() + testExceptionAttachedToTaskWithoutAwait() + testExceptionAttachedToTaskWithAwait() + testExceptionThrownInFinally() + test2ndExceptionThrownInFinally() + testFixedStackWhileLoop() + testFixedStackForLoop() + testTypeInference() + testNoStackOverflowWithImmediateResult() + testNoStackOverflowWithYieldResult() //// we don't support TCO, so large tail recursions will stack overflow //// or at least use O(n) heap. but small ones should at least function OK. //testSmallTailRecursion() - //testTryOverReturnFrom() - //testTryFinallyOverReturnFromWithException() - //testTryFinallyOverReturnFromWithoutException() - //testAsyncsMixedWithTasks() - //printfn "Passed all tests!" + testTryOverReturnFrom() + testTryFinallyOverReturnFromWithException() + testTryFinallyOverReturnFromWithoutException() + testAsyncsMixedWithTasks() + printfn "Passed all tests!" with exn -> + eprintfn "************************************" eprintfn "Exception: %O" exn + printfn "Test failed... exiting..." + eprintfn "************************************" + exit 1 + printfn "Tests passed ok..., sleeping a bit in case there are background delayed exceptions" Thread.Sleep(500) printfn "Exiting..." From d043d724f4c0f47dca81033f0aaf379504989f8e Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 10 May 2019 17:11:13 +0100 Subject: [PATCH 28/45] more examples - taskSeq and sync --- src/fsharp/FSharp.Core/tasks.fs | 2 +- src/fsharp/LowerCallsAndSeqs.fs | 36 +-- tests/fsharp/core/state-machines/sync.fs | 86 +++++++ tests/fsharp/core/state-machines/sync.fsi | 38 +++ tests/fsharp/core/state-machines/taskSeq.fs | 257 ++++++++++++++++++++ 5 files changed, 402 insertions(+), 17 deletions(-) create mode 100644 tests/fsharp/core/state-machines/sync.fs create mode 100644 tests/fsharp/core/state-machines/sync.fsi create mode 100644 tests/fsharp/core/state-machines/taskSeq.fs diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index 8a17cfc3ede..eb6c923d915 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -238,7 +238,7 @@ type TaskBuilder() = /// Builds a step that executes the body while the condition predicate is true. member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskStep) : TaskStep = let mutable completed = true - while (# "" completed : bool #) && __expand_condition() do + while completed && __expand_condition() do completed <- false // The body of the 'while' may include an early exit, e.g. return from entire method let ``__machine_step$cont`` = __expand_body () diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 100f793e59d..7aeda3c49dc 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -838,9 +838,11 @@ let (|JumpTableExpr|_|) g expr = | ValApp g g.cgh_jumptable_vref (_, [pcExpr; codeExpr], _m) -> Some (pcExpr, codeExpr) | _ -> None +let sm_verbose = false + /// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) let RepresentBindingAsLiftedOrLocal (bind: Binding) (res2: StateMachineConversionFirstPhaseResult) m = - if verbose then + if sm_verbose then printfn "LowerStateMachine: found local variable %s" bind.Var.DisplayName { res2 with @@ -849,7 +851,7 @@ let RepresentBindingAsLiftedOrLocal (bind: Binding) (res2: StateMachineConversio /// Implement a decision to represent a 'let' binding as a state machine variable let RepresentBindingAsStateVar (bind: Binding) (res2: StateMachineConversionFirstPhaseResult) m = - if verbose then + if sm_verbose then printfn "LowerStateMachine: found state variable %s" bind.Var.DisplayName let (TBind(v, e, sp)) = bind @@ -927,7 +929,7 @@ let ConvertStateMachineExprToObject g overallExpr = // Bind 'let CODE = __newEntryPoint() in bodyExpr' | Expr.Let (TBind(v, NewEntryPointExpr g (), _sp), bodyExpr, m, _) -> - if verbose then printfn "found __newEntryPoint()" + if sm_verbose then printfn "found __newEntryPoint()" let envR = env.Add v (mkInt g m (genPC())) BindExpansions g envR bodyExpr @@ -959,14 +961,14 @@ let ConvertStateMachineExprToObject g overallExpr = // __expand_code --> [expand_code] | Expr.Val (vref, _, _) when env.ContainsVal vref.Deref -> let expandedExpr = env.[vref.Deref] - if verbose then printfn "expanded %A --> %A..." expr expandedExpr + if sm_verbose then printfn "expanded %A --> %A..." expr expandedExpr Some expandedExpr // __expand_code x --> let arg = x in expand_code[arg/x] | Expr.App (Expr.Val (vref, _, _), fty, [], args, m) when env.ContainsVal vref.Deref -> let f0 = env.[vref.Deref] let expandedExpr = MakeApplicationAndBetaReduce g (f0, fty, [], args, m) - if verbose then printfn "expanded %A --> %A..." expr expandedExpr + if sm_verbose then printfn "expanded %A --> %A..." expr expandedExpr Some expandedExpr | _ -> None @@ -1000,16 +1002,18 @@ let ConvertStateMachineExprToObject g overallExpr = let (|SingleMethodStateMachineInContext|_|) g overallExpr = match overallExpr with | StateMachineInContext g ValMap.Empty (env, objExpr, remake) -> - if verbose then printfn "Found state machine..." + if sm_verbose then printfn "Found state machine..." match objExpr with | Expr.Obj (objExprStamp, ty, basev, basecall, overrides, iimpls, stateVars, objExprRange) -> - if verbose then printfn "Found state machine object..." + if sm_verbose then printfn "Found state machine object..." match overrides with | [ (TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, (JumpTableExpr g (pcExpr, codeLambdaExpr)), m)) ] -> + if sm_verbose then printfn "Found override and jump table call..." let env, codeLambdaExpr = RepeatBindAndApplyExpansions g env codeLambdaExpr match codeLambdaExpr with | Expr.Lambda (_, _, _, [_dummyv], codeExpr, _, _) -> + if sm_verbose then printfn "Found code lambda..." Some (env, objExprStamp, objExprRange, remake, ty, basev, basecall, slotsig, attribs, methTyparsOfOverridingMethod, methodParams, pcExpr, codeExpr, iimpls, stateVars, m) | _ -> None | _ -> None @@ -1038,14 +1042,14 @@ let ConvertStateMachineExprToObject g overallExpr = /// Detect constructs allowed in state machines let rec ConvertStateMachineCode env pcExpr expr = - if verbose then + if sm_verbose then printfn "---------" printfn "ConvertStateMachineCodeing %s" (DebugPrint.showExpr expr) printfn "---------" let env, expr = RepeatBindAndApplyExpansions g env expr - if verbose then + if sm_verbose then printfn "Expanded to %s" (DebugPrint.showExpr expr) printfn "---------" @@ -1253,7 +1257,7 @@ let ConvertStateMachineExprToObject g overallExpr = entryPoints=[] stateVars = [] asyncVars = emptyFreeVars } - if verbose then + if sm_verbose then printfn "-------------------" printfn "Phase 1 Done for %s" (DebugPrint.showExpr res.phase1) printfn "Phase 1 Done, asyncVars = %A" (res.asyncVars.FreeLocals |> Zset.elements |> List.map (fun v -> v.CompiledName) |> String.concat ",") @@ -1263,7 +1267,7 @@ let ConvertStateMachineExprToObject g overallExpr = // Detect a state machine and convert it match overallExpr with | SingleMethodStateMachineInContext g (env, objExprStamp, objExprRange, remake, ty, basev, basecall, slotsig, attribs, methTyparsOfOverridingMethod, methodParams, pcExpr, codeExpr, iimpls, origStateVars, m) -> - if verbose then + if sm_verbose then printfn "Found state machine override method and code expression..." printfn "----------- BEFORE LOWER ----------------------" printfn "%s" (DebugPrint.showExpr codeExpr) @@ -1279,24 +1283,24 @@ let ConvertStateMachineExprToObject g overallExpr = let pc2lab = Map.ofList (List.zip pcs labs) // Execute phase2, building the core of the method - if verbose then printfn "----------- PHASE2 ----------------------" + if sm_verbose then printfn "----------- PHASE2 ----------------------" // Perform phase2 to build the final expression let methodBodyExprR = res.phase2 pc2lab - if verbose then printfn "----------- ADDING JUMP TABLE ----------------------" + if sm_verbose then printfn "----------- ADDING JUMP TABLE ----------------------" // Add the jump table let methodBodyExprWithJumpTable = addPcJumpTable g m pcs pc2lab pcExpr methodBodyExprR - if verbose then printfn "----------- REMAKE ----------------------" + if sm_verbose then printfn "----------- REMAKE ----------------------" // Rebuild the object expression let overrideR = TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, methodBodyExprWithJumpTable, m) let objExprR = Expr.Obj (objExprStamp, ty, basev, basecall, [overrideR], iimpls, origStateVars @ stateVars, objExprRange) let overallExprR = remake objExprR - if verbose then + if sm_verbose then printfn "----------- AFTER REWRITE ----------------------" printfn "%s" (DebugPrint.showExpr overallExprR) @@ -1314,7 +1318,7 @@ let ConvertStateMachineExprToObject g overallExpr = // | _ -> None) // PreInterceptBinding = None // IsUnderQuotations=true } - if verbose then printfn "----------- DONE ----------------------" + if sm_verbose then printfn "----------- DONE ----------------------" Some overallExprR diff --git a/tests/fsharp/core/state-machines/sync.fs b/tests/fsharp/core/state-machines/sync.fs new file mode 100644 index 00000000000..42c659c50a1 --- /dev/null +++ b/tests/fsharp/core/state-machines/sync.fs @@ -0,0 +1,86 @@ + +module Sync + +open System +open FSharp.Core.CompilerServices.CodeGenHelpers + +type SyncStep<'T> = 'T + +[] +type SyncMachine<'T>() = + + abstract Step : unit -> SyncStep<'T> + + member this.Start() = this.Step() + +type SyncBuilder() = + + member inline __.Delay(__expand_f : unit -> SyncStep<'T>) = __expand_f + + member inline __.Run(__expand_code : unit -> SyncStep<'T>) : 'T = + (__stateMachine + { new SyncMachine<'T>() with + member __.Step () = __jumptable 0 __expand_code }).Start() + + member inline __.Zero() : SyncStep = () + + member inline __.Return (x: 'T) : SyncStep<'T> = x + + member inline __.Combine(``__machine_step$cont``: SyncStep, __expand_step2: unit -> SyncStep<'T>) : SyncStep<'T> = + __expand_step2() + + member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> SyncStep) : SyncStep = + while __expand_condition() do + __expand_body () + + member inline __.TryWith(__expand_body : unit -> SyncStep<'T>, __expand_catch : exn -> SyncStep<'T>) : SyncStep<'T> = + try + __expand_body () + with exn -> + __expand_catch exn + + member inline __.TryFinally(__expand_body: unit -> SyncStep<'T>, compensation : unit -> unit) : SyncStep<'T> = + let ``__machine_step$cont`` = + try + __expand_body () + with _ -> + compensation() + reraise() + compensation() + ``__machine_step$cont`` + + member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> SyncStep<'T>) = + this.TryFinally( + (fun () -> __expand_body disp), + (fun () -> if not (isNull (box disp)) then disp.Dispose())) + + member inline this.For(sequence : seq<'T>, __expand_body : 'T -> SyncStep) : SyncStep = + this.Using (sequence.GetEnumerator(), + (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) + + member inline __.ReturnFrom (value: 'T) : SyncStep<'T> = + value + + member inline __.Bind (value: 'TResult1, __expand_continuation: ^TResult1 -> SyncStep<'TResult2>) = + __expand_continuation value + +let sync = SyncBuilder() + +module Examples = + + let t1 y = + sync { + printfn "in t1" + let x = 4 + 5 + y + return x + } + + let t2 y = + sync { + printfn "in t2" + let! x = t1 y + return x + y + } + + + printfn "t2 6 = %d" (t2 6) diff --git a/tests/fsharp/core/state-machines/sync.fsi b/tests/fsharp/core/state-machines/sync.fsi new file mode 100644 index 00000000000..e5ba40bfe76 --- /dev/null +++ b/tests/fsharp/core/state-machines/sync.fsi @@ -0,0 +1,38 @@ + +module Sync + +open System +open System.Runtime.CompilerServices +open System.Threading.Tasks +open Microsoft.FSharp.Core +open Microsoft.FSharp.Core.CompilerServices +open Microsoft.FSharp.Control +open Microsoft.FSharp.Collections + +/// Represents the result of a computation, a value of true indicates completion +type SyncStep<'T> = 'T + +[] +type SyncMachine<'T> = + new : unit -> SyncMachine<'T> + abstract Step : pc: int -> SyncStep<'T> + member Start: unit -> 'T + +type SyncBuilder = + new: unit -> SyncBuilder + member inline Combine: task1: SyncStep * task2: (unit -> SyncStep<'T>) -> SyncStep<'T> + member inline Delay: f: (unit -> SyncStep<'T>) -> (unit -> SyncStep<'T>) + member inline For: sequence: seq<'T> * body: ('T -> SyncStep) -> SyncStep + member inline Return: x: 'T -> SyncStep<'T> + member inline ReturnFrom: task: Task<'T> -> SyncStep<'T> + member inline Run: code: (unit -> SyncStep<'T>) -> Task<'T> + member inline TryFinally: body: (unit -> SyncStep<'T>) * fin: (unit -> unit) -> SyncStep<'T> + member inline TryWith: body: (unit -> SyncStep<'T>) * catch: (exn -> SyncStep<'T>) -> SyncStep<'T> + member inline Using: disp: 'Resource * body: ('Resource -> SyncStep<'T>) -> SyncStep<'T> when 'Resource :> IDisposable + member inline While: condition: (unit -> bool) * body: (unit -> SyncStep) -> SyncStep + member inline Zero: unit -> SyncStep + member inline Bind : v: 'TResult1 * continuation: ('TResult1 -> SyncStep<'TResult2>) -> SyncStep<'TResult2> + member inline ReturnFrom: a: 'TResult1 -> SyncStep< 'TResult > + +val sync : SyncBuilder + diff --git a/tests/fsharp/core/state-machines/taskSeq.fs b/tests/fsharp/core/state-machines/taskSeq.fs new file mode 100644 index 00000000000..dcf5c5bd0d0 --- /dev/null +++ b/tests/fsharp/core/state-machines/taskSeq.fs @@ -0,0 +1,257 @@ + +module TaskSeq + +open System +open System.Runtime.CompilerServices +open System.Threading +open System.Threading.Tasks +open FSharp.Core.CompilerServices.CodeGenHelpers + +let [] AWAIT = 1 +let [] YIELD = 2 +let [] DONE = 3 + +[] +type TaskSeqStep<'T>(res: int) = + member x.IsCompleted = (res <> 1) + member x.IsYield = (res = 2) + member x.IsDone = (res = 3) + +type IAsyncDisposable = + abstract DisposeAsync: unit -> Task + +type IAsyncEnumerator<'T> = + inherit IAsyncDisposable + abstract Current: 'T + abstract MoveNextAsync: unit -> Task + +type IAsyncEnumerable<'T> = + abstract GetAsyncEnumerator: ct: CancellationToken -> IAsyncEnumerator<'T> + +[] +type TaskSeqStateMachine<'T>() = + let mutable current : 'T = Unchecked.defaultof<'T> + let mutable resumptionPoint = 0 + let mutable tcs = Unchecked.defaultof> + let mutable cancellationToken = Unchecked.defaultof + let disposalStack = ResizeArray<(unit -> Task)>() + /// Proceed to the next state or raise an exception + abstract Step : pc: int -> TaskSeqStep<'T> + + interface IAsyncEnumerable<'T> with + member this.GetAsyncEnumerator(ct) = + cancellationToken <- ct + // TODO: make new object if needed + (this :> IAsyncEnumerator<'T>) + + interface IAsyncEnumerator<'T> with + + member __.Current = current + + // TODO: no early disposal yet - disposal only by driving sequence to the end + member __.DisposeAsync() = + task { + let mutable exn = None + for d in Seq.rev disposalStack do + try + do! d() + with e -> + if exn.IsNone then + exn <- Some e + match exn with + | None -> () + | Some e -> raise e + } + + member this.MoveNextAsync() = + tcs <- new TaskCompletionSource() + this.MoveNextAsync(tcs) + tcs.Task + + member __.PushDispose (f: unit -> Task) = disposalStack.Add(f) + member __.PopDispose () = disposalStack.RemoveAt(disposalStack.Count - 1) + + member __.CancellationToken = cancellationToken + + member __.Yield (v: 'T, pc: int) = + resumptionPoint <- pc + current <- v + TaskSeqStep<'T>(YIELD) + + member this.Await (awaiter: ICriticalNotifyCompletion, pc: int) = + resumptionPoint <- pc + assert (not (isNull awaiter)) + // Tell the builder to call us again when done. + Console.WriteLine("[{0}] UnsafeOnCompleted", this.GetHashCode()) + awaiter.UnsafeOnCompleted(Action(fun () -> this.MoveNextAsync(tcs))) + + member this.MoveNextAsync(tcs: TaskCompletionSource) : unit = + try + Console.WriteLine("[{0}] step from {1}", this.GetHashCode(), resumptionPoint) + let step = this.Step resumptionPoint + if step.IsCompleted then + tcs.SetResult (not step.IsDone) + with exn -> + Console.WriteLine("[{0}] exception {1}", this.GetHashCode(), exn) + tcs.SetException exn + + [] + member this.Start() = (this :> IAsyncEnumerable<'T>) + +type TaskSeqBuilder() = + + member inline __.Delay(__expand_f : unit -> TaskSeqStep<'T>) = __expand_f + + member inline __.Run(__expand_code : unit -> TaskSeqStep<'T>) : IAsyncEnumerable<'T> = + (__stateMachine + { new TaskSeqStateMachine<'T>() with + member __.Step pc = __jumptable pc __expand_code }).Start() + + member inline __.Zero() : TaskSeqStep<'T> = + TaskSeqStep<'T>(DONE) + + member inline __.Combine(``__machine_step$cont``: TaskSeqStep<'T>, __expand_task2: unit -> TaskSeqStep<'T>) : TaskSeqStep<'T> = + if ``__machine_step$cont``.IsDone then + __expand_task2() + else + ``__machine_step$cont`` + + member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskSeqStep<'T>) : TaskSeqStep<'T> = + let mutable step = TaskSeqStep<'T>(DONE) + while step.IsDone && __expand_condition() do + let ``__machine_step$cont`` = __expand_body () + step <- ``__machine_step$cont`` + step + + // Todo: async condition in while loop + //member inline __.WhileAsync(__expand_condition : unit -> Task, __expand_body : unit -> TaskSeqStep<'T>) : TaskSeqStep<'T> = + // let mutable step = TaskSeqStep<'T>(DONE) + // while step.IsDone && __expand_condition() do + // let ``__machine_step$cont`` = __expand_body () + // step <- ``__machine_step$cont`` + // step + + member inline __.TryWith(__expand_body : unit -> TaskSeqStep<'T>, __expand_catch : exn -> TaskSeqStep<'T>) : TaskSeqStep<'T> = + let mutable step = TaskSeqStep<'T>(DONE) + let mutable caught = false + let mutable savedExn = Unchecked.defaultof<_> + try + let ``__machine_step$cont`` = __expand_body () + step <- ``__machine_step$cont`` + with exn -> + caught <- true + savedExn <- exn + + if caught then + __expand_catch savedExn + else + step + + member inline __.TryFinallyAsync(__expand_body: unit -> TaskSeqStep<'T>, compensation : unit -> Task) : TaskSeqStep<'T> = + let mutable step = TaskSeqStep<'T>(DONE) + __machine>.PushDispose compensation + try + let ``__machine_step$cont`` = __expand_body () + // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with + // may skip this step. + step <- ``__machine_step$cont`` + with _ -> + __machine>.PopDispose() + compensation().Result // TODO: async execution of this + reraise() + + if step.IsDone then + __machine>.PopDispose() + compensation().Result // TODO: async execution of this + step + + member inline this.TryFinally(__expand_body: unit -> TaskSeqStep<'T>, compensation : unit -> unit) : TaskSeqStep<'T> = + this.TryFinallyAsync(__expand_body, fun () -> Task.FromResult(compensation())) + + member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> TaskSeqStep<'T>) = + // A using statement is just a try/finally with the finally block disposing if non-null. + this.TryFinally( + (fun () -> __expand_body disp), + (fun () -> if not (isNull (box disp)) then disp.Dispose())) + + member inline this.UsingAsync(disp : #IAsyncDisposable, __expand_body : #IAsyncDisposable -> TaskSeqStep<'T>) = + // A using statement is just a try/finally with the finally block disposing if non-null. + this.TryFinallyAsync( + (fun () -> __expand_body disp), + (fun () -> if not (isNull (box disp)) then disp.DisposeAsync() else Task.FromResult())) + + member inline this.For(sequence : seq<'T>, __expand_body : 'T -> TaskSeqStep) : TaskSeqStep = + // A for loop is just a using statement on the sequence's enumerator... + this.Using (sequence.GetEnumerator(), + // ... and its body is a while loop that advances the enumerator and runs the body on each element. + (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) + + member inline this.For(source : IAsyncEnumerable<'TElement>, __expand_body : 'TElement -> TaskSeqStep<'T>) : TaskSeqStep<'T> = + let mutable ct = Unchecked.defaultof<_> + ct <- __machine>.CancellationToken + this.UsingAsync (source.GetAsyncEnumerator(ct), + // TODO: This should call WhileAsync + (fun e -> this.While((fun () -> e.MoveNextAsync().Result), (fun () -> __expand_body e.Current)))) + + member inline __.Yield (``__machine_step$cont``: 'T) : TaskSeqStep<'T> = + let CONT = __newEntryPoint() + // A dummy to allow us to lay down the code for the continuation + let mutable afterYield = (# "nop nop" false : bool #) // stop optimization + if afterYield then + __entryPoint CONT + printfn "after yield" + TaskSeqStep<'T>(DONE) + else + __machine>.Yield(``__machine_step$cont``, CONT) + + member inline this.YieldFrom (source: IAsyncEnumerable<'T>) : TaskSeqStep<'T> = + this.For(source, (fun ``__machine_step$cont`` -> this.Yield(``__machine_step$cont``))) + + member inline __.Bind (task: Task<'TResult1>, __expand_continuation: ('TResult1 -> TaskSeqStep<'T>)) : TaskSeqStep<'T> = + let CONT = __newEntryPoint() + let awaiter = task.GetAwaiter() + if awaiter.IsCompleted then + __entryPoint CONT + __expand_continuation (awaiter.GetResult()) + else + __machine>.Await (awaiter, CONT) + TaskSeqStep<'T>(AWAIT) + +let taskSeq = TaskSeqBuilder() + +module Examples = + + let t1 () = + taskSeq { + printfn "in t1" + yield "a" + let x = 1 + let! v = task { printfn "hey" + do! Task.Delay(100) } + yield "b" + let! v = task { printfn "hey yo" + do! Task.Delay(100) } + yield "c" + } + + let t2 () = + taskSeq { + printfn "in t2" + yield "d" + for x in t1 () do + printfn "t2 - got %A" x + yield "e" + let! v = task { printfn "hey yo" + do! Task.Delay(100) } + yield "[T1]" + x + let! v = task { printfn "hey yo" + do! Task.Delay(100) } + yield "f" + } + + let dumpTaskSeq (t: IAsyncEnumerable<_>) = + let e = t.GetAsyncEnumerator(CancellationToken()) + while e.MoveNextAsync().Result do + printfn "yield %A" e.Current + dumpTaskSeq (t1()) + dumpTaskSeq (t2()) From 90fef0280e42b773dd8d4a200cd968bd9f1d30ec Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 10 May 2019 17:39:29 +0100 Subject: [PATCH 29/45] add seq2 { ... } example --- tests/fsharp/core/state-machines/seq2.fs | 198 ++++++++++++++++++++ tests/fsharp/core/state-machines/taskSeq.fs | 9 +- 2 files changed, 203 insertions(+), 4 deletions(-) create mode 100644 tests/fsharp/core/state-machines/seq2.fs diff --git a/tests/fsharp/core/state-machines/seq2.fs b/tests/fsharp/core/state-machines/seq2.fs new file mode 100644 index 00000000000..a50fe7f367e --- /dev/null +++ b/tests/fsharp/core/state-machines/seq2.fs @@ -0,0 +1,198 @@ + +module Seq + +open System +open System.Collections +open System.Collections.Generic +open System.Runtime.CompilerServices +open FSharp.Core.CompilerServices.CodeGenHelpers + +let [] YIELD = 2 +let [] DONE = 3 + +[] +type SeqStep<'T>(res: int) = + member x.IsYield = (res = 2) + member x.IsDone = (res = 3) + +[] +type SeqStateMachine<'T>() = + let mutable current : 'T = Unchecked.defaultof<'T> + let mutable resumptionPoint = 0 + let disposalStack = ResizeArray<(unit -> unit)>() + + /// Proceed to the next state or raise an exception + abstract Step : pc: int -> SeqStep<'T> + + interface IEnumerable with + member this.GetEnumerator() = + // TODO: make new object if needed + (this :> IEnumerator) + + interface IEnumerable<'T> with + member this.GetEnumerator() = + // TODO: make new object if needed + (this :> IEnumerator<'T>) + + interface IDisposable with + member __.Dispose() = + let mutable exn = None + for d in Seq.rev disposalStack do + try + d() + with e -> + exn <- Some e // keep the last exception - TODO - check this + match exn with + | None -> () + | Some e -> raise e + + interface IEnumerator with + + member __.Reset() = failwith "no reset supported" + member __.Current = box current + + member this.MoveNext() = + this.MoveNextImpl() + + interface IEnumerator<'T> with + member __.Current = current + + member __.PushDispose (f: unit -> unit) = disposalStack.Add(f) + member __.PopDispose () = disposalStack.RemoveAt(disposalStack.Count - 1) + + member __.Yield (v: 'T, pc: int) = + resumptionPoint <- pc + current <- v + SeqStep<'T>(YIELD) + + member this.MoveNextImpl() : bool = + Console.WriteLine("[{0}] step from {1}", this.GetHashCode(), resumptionPoint) + let step = this.Step resumptionPoint + step.IsYield + + [] + member this.Start() = (this :> IEnumerable<'T>) + +type SeqBuilder() = + + member inline __.Delay(__expand_f : unit -> SeqStep<'T>) = __expand_f + + member inline __.Run(__expand_code : unit -> SeqStep<'T>) : IEnumerable<'T> = + (__stateMachine + { new SeqStateMachine<'T>() with + member __.Step pc = __jumptable pc __expand_code }).Start() + + member inline __.Zero() : SeqStep<'T> = + SeqStep<'T>(DONE) + + member inline __.Combine(``__machine_step$cont``: SeqStep<'T>, __expand_task2: unit -> SeqStep<'T>) : SeqStep<'T> = + if ``__machine_step$cont``.IsDone then + __expand_task2() + else + ``__machine_step$cont`` + + member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> SeqStep<'T>) : SeqStep<'T> = + let mutable step = SeqStep<'T>(DONE) + while step.IsDone && __expand_condition() do + let ``__machine_step$cont`` = __expand_body () + step <- ``__machine_step$cont`` + step + + // Todo: async condition in while loop + //member inline __.While(__expand_condition : unit -> Task, __expand_body : unit -> SeqStep<'T>) : SeqStep<'T> = + // let mutable step = SeqStep<'T>(DONE) + // while step.IsDone && __expand_condition() do + // let ``__machine_step$cont`` = __expand_body () + // step <- ``__machine_step$cont`` + // step + + member inline __.TryWith(__expand_body : unit -> SeqStep<'T>, __expand_catch : exn -> SeqStep<'T>) : SeqStep<'T> = + let mutable step = SeqStep<'T>(DONE) + let mutable caught = false + let mutable savedExn = Unchecked.defaultof<_> + try + let ``__machine_step$cont`` = __expand_body () + step <- ``__machine_step$cont`` + with exn -> + caught <- true + savedExn <- exn + + if caught then + __expand_catch savedExn + else + step + + member inline __.TryFinally(__expand_body: unit -> SeqStep<'T>, compensation : unit -> unit) : SeqStep<'T> = + let mutable step = SeqStep<'T>(DONE) + __machine>.PushDispose compensation + try + let ``__machine_step$cont`` = __expand_body () + // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with + // may skip this step. + step <- ``__machine_step$cont`` + with _ -> + __machine>.PopDispose() + compensation() + reraise() + + if step.IsDone then + __machine>.PopDispose() + compensation() + step + + member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> SeqStep<'T>) = + // A using statement is just a try/finally with the finally block disposing if non-null. + this.TryFinally( + (fun () -> __expand_body disp), + (fun () -> if not (isNull (box disp)) then disp.Dispose())) + + member inline this.For(sequence : seq<'TElement>, __expand_body : 'TElement -> SeqStep<'T>) : SeqStep<'T> = + // A for loop is just a using statement on the sequence's enumerator... + this.Using (sequence.GetEnumerator(), + // ... and its body is a while loop that advances the enumerator and runs the body on each element. + (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) + + member inline __.Yield (``__machine_step$cont``: 'T) : SeqStep<'T> = + let CONT = __newEntryPoint() + // A dummy to allow us to lay down the code for the continuation + let mutable afterYield = (# "nop nop" false : bool #) // stop optimization + if afterYield then + __entryPoint CONT + printfn "after yield" + SeqStep<'T>(DONE) + else + __machine>.Yield(``__machine_step$cont``, CONT) + + member inline this.YieldFrom (source: IEnumerable<'T>) : SeqStep<'T> = + this.For(source, (fun ``__machine_step$cont`` -> this.Yield(``__machine_step$cont``))) + +let seq2 = SeqBuilder() + +module Examples = + + let t1 () = + seq2 { + printfn "in t1" + yield "a" + let x = 1 + yield "b" + yield "c" + } + + let t2 () = + seq2 { + printfn "in t2" + yield "d" + for x in t1 () do + printfn "t2 - got %A" x + yield "e" + yield "[T1]" + x + yield "f" + } + + let dumpSeq (t: IEnumerable<_>) = + let e = t.GetEnumerator() + while e.MoveNext() do + printfn "yield %A" e.Current + dumpSeq (t1()) + dumpSeq (t2()) diff --git a/tests/fsharp/core/state-machines/taskSeq.fs b/tests/fsharp/core/state-machines/taskSeq.fs index dcf5c5bd0d0..ce04683c11e 100644 --- a/tests/fsharp/core/state-machines/taskSeq.fs +++ b/tests/fsharp/core/state-machines/taskSeq.fs @@ -13,7 +13,6 @@ let [] DONE = 3 [] type TaskSeqStep<'T>(res: int) = - member x.IsCompleted = (res <> 1) member x.IsYield = (res = 2) member x.IsDone = (res = 3) @@ -89,8 +88,10 @@ type TaskSeqStateMachine<'T>() = try Console.WriteLine("[{0}] step from {1}", this.GetHashCode(), resumptionPoint) let step = this.Step resumptionPoint - if step.IsCompleted then - tcs.SetResult (not step.IsDone) + if step.IsDone then + tcs.SetResult false + elif step.IsYield then + tcs.SetResult true with exn -> Console.WriteLine("[{0}] exception {1}", this.GetHashCode(), exn) tcs.SetException exn @@ -180,7 +181,7 @@ type TaskSeqBuilder() = (fun () -> __expand_body disp), (fun () -> if not (isNull (box disp)) then disp.DisposeAsync() else Task.FromResult())) - member inline this.For(sequence : seq<'T>, __expand_body : 'T -> TaskSeqStep) : TaskSeqStep = + member inline this.For(sequence : seq<'TElement>, __expand_body : 'TElement -> TaskSeqStep<'T>) : TaskSeqStep<'T> = // A for loop is just a using statement on the sequence's enumerator... this.Using (sequence.GetEnumerator(), // ... and its body is a while loop that advances the enumerator and runs the body on each element. From e22648af584efffcb8cc3f9cd33c2b5b70c9a872 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 10 May 2019 17:44:06 +0100 Subject: [PATCH 30/45] add seq2 { ... } example --- tests/fsharp/core/state-machines/seq2.fs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/tests/fsharp/core/state-machines/seq2.fs b/tests/fsharp/core/state-machines/seq2.fs index a50fe7f367e..9ea9f655461 100644 --- a/tests/fsharp/core/state-machines/seq2.fs +++ b/tests/fsharp/core/state-machines/seq2.fs @@ -98,14 +98,6 @@ type SeqBuilder() = step <- ``__machine_step$cont`` step - // Todo: async condition in while loop - //member inline __.While(__expand_condition : unit -> Task, __expand_body : unit -> SeqStep<'T>) : SeqStep<'T> = - // let mutable step = SeqStep<'T>(DONE) - // while step.IsDone && __expand_condition() do - // let ``__machine_step$cont`` = __expand_body () - // step <- ``__machine_step$cont`` - // step - member inline __.TryWith(__expand_body : unit -> SeqStep<'T>, __expand_catch : exn -> SeqStep<'T>) : SeqStep<'T> = let mutable step = SeqStep<'T>(DONE) let mutable caught = false From 94504fa38f5c2cc415354588e09d16aaf580a62a Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 10 May 2019 18:02:53 +0100 Subject: [PATCH 31/45] add list/array/rsarray example --- tests/fsharp/core/state-machines/list.fs | 141 +++++++++++++++++++++++ 1 file changed, 141 insertions(+) create mode 100644 tests/fsharp/core/state-machines/list.fs diff --git a/tests/fsharp/core/state-machines/list.fs b/tests/fsharp/core/state-machines/list.fs new file mode 100644 index 00000000000..e6c1effb73b --- /dev/null +++ b/tests/fsharp/core/state-machines/list.fs @@ -0,0 +1,141 @@ + +module Seq + +open System +open System.Collections +open System.Collections.Generic +open System.Runtime.CompilerServices +open FSharp.Core.CompilerServices.CodeGenHelpers + +let [] DONE = 3 + +[] +type ListStep<'T>(res: int) = + member x.IsDone = (res = 3) + +[] +type ListStateMachine<'T>() = + let res = ResizeArray<'T>() + + abstract Compute : unit -> ListStep<'T> + + member __.Yield (v: 'T) = res.Add(v) + + [] + member this.StartAsResizeArray() = + this.Compute(0) + res + + [] + member this.StartAsList() = + this.Compute(0) + Seq.toList res + + [] + member this.StartAsArray() = + this.Compute(0) + res.ToArray() + +type ResizeArrayBuilderBase() = + + member inline __.Delay(__expand_f : unit -> ListStep<'T>) = __expand_f + + member inline __.Zero() : ListStep<'T> = + ListStep<'T>(DONE) + + member inline __.Combine(``__machine_step$cont``: ListStep<'T>, __expand_task2: unit -> ListStep<'T>) : ListStep<'T> = + __expand_task2() + + member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> ListStep<'T>) : ListStep<'T> = + while __expand_condition() do + let ``__machine_step$cont`` = __expand_body () + () + + member inline __.TryWith(__expand_body : unit -> ListStep<'T>, __expand_catch : exn -> ListStep<'T>) : ListStep<'T> = + try + let ``__machine_step$cont`` = __expand_body () + () + with exn -> + __expand_catch savedExn + + member inline __.TryFinally(__expand_body: unit -> ListStep<'T>, compensation : unit -> unit) : ListStep<'T> = + try + let ``__machine_step$cont`` = __expand_body () + () + with _ -> + compensation() + reraise() + + compensation() + + member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> ListStep<'T>) = + // A using statement is just a try/finally with the finally block disposing if non-null. + this.TryFinally( + (fun () -> __expand_body disp), + (fun () -> if not (isNull (box disp)) then disp.Dispose())) + + member inline this.For(sequence : seq<'TElement>, __expand_body : 'TElement -> ListStep<'T>) : ListStep<'T> = + this.Using (sequence.GetEnumerator(), + (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) + + member inline __.Yield (``__machine_step$cont``: 'T) : ListStep<'T> = + __machine>.Yield(``__machine_step$cont``) + + member inline this.YieldFrom (source: IEnumerable<'T>) : ListStep<'T> = + this.For(source, (fun ``__machine_step$cont`` -> this.Yield(``__machine_step$cont``))) + +type ResizeArrayBuilder() = + inherit ResizeArrayBuilderBase() + member inline __.Run(__expand_code : unit -> ListStep<'T>) : IEnumerable<'T> = + (__stateMachine + { new ListStateMachine<'T>() with + member __.Compute () = __jumptable 0 __expand_code }).StartAsResizeArray() + +let rsarray = ResizeArrayBuilder() + +type ListBuilder() = + inherit ResizeArrayBuilderBase() + member inline __.Run(__expand_code : unit -> ListStep<'T>) : 'T list = + (__stateMachine + { new ListStateMachine<'T>() with + member __.Compute () = __jumptable 0 __expand_code }).StartAsList() + +let list = ListBuilder() + +type ArrayBuilder() = + inherit ResizeArrayBuilderBase() + member inline __.Run(__expand_code : unit -> ListStep<'T>) : 'T[] = + (__stateMachine + { new ListStateMachine<'T>() with + member __.Compute () = __jumptable 0 __expand_code }).StartAsArray() + +let array = ArrayBuilder() + +module Examples = + + let t1 () = + list { + printfn "in t1" + yield "a" + let x = 1 + yield "b" + yield "c" + } + + let t2 () = + list { + printfn "in t2" + yield "d" + for x in t1 () do + printfn "t2 - got %A" x + yield "e" + yield "[T1]" + x + yield "f" + } + + let dumpSeq (t: IEnumerable<_>) = + let e = t.GetEnumerator() + while e.MoveNext() do + printfn "yield %A" e.Current + dumpSeq (t1()) + dumpSeq (t2()) From 27f51737417e9f8046fb6b2a9c5035f6eaf8d2b8 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 13 May 2019 16:53:19 +0100 Subject: [PATCH 32/45] add perf tests --- src/fsharp/FSharp.Core/tasks.fs | 39 ++- src/fsharp/FSharp.Core/tasks.fsi | 5 +- tests/fsharp/core/state-machines/list.fs | 64 +++- tests/fsharp/perf/tasks/TaskBuilder.fs | 416 +++++++++++++++++++++++ tests/fsharp/perf/tasks/benchmark.fs | 185 ++++++++++ tests/fsharp/perf/tasks/csbenchmark.cs | 65 ++++ 6 files changed, 745 insertions(+), 29 deletions(-) create mode 100644 tests/fsharp/perf/tasks/TaskBuilder.fs create mode 100644 tests/fsharp/perf/tasks/benchmark.fs create mode 100644 tests/fsharp/perf/tasks/csbenchmark.cs diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index eb6c923d915..e6aa7a9d327 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -64,7 +64,9 @@ open Microsoft.FSharp.Collections // // Uses a struct-around-single-reference to allow future changes in representation (the representation is // not revealed in the signature) -type TaskStep<'T> = (# "bool" #) +[] +type TaskStep<'T>(completed: bool) = + member x.IsCompleted = completed [] type TaskStateMachine() = @@ -83,6 +85,7 @@ type TaskStateMachine<'T>() = /// Proceed to the next state or raise an exception abstract Step : pc: int -> TaskStep<'T> + [] override sm.Await (awaiter, pc) = resumptionPoint <- pc let mutable sm = sm @@ -94,11 +97,12 @@ type TaskStateMachine<'T>() = interface IAsyncStateMachine with + [] member this.MoveNext() = try //Console.WriteLine("[{0}] step from {1}", this.GetHashCode(), resumptionPoint) let step = this.Step resumptionPoint - if (# "" step : bool #) then + if step.IsCompleted then //Console.WriteLine("[{0}] unboxing result", this.GetHashCode()) let res = unbox<'T>(this.Current) //Console.WriteLine("[{0}] SetResult {1}", this.GetHashCode(), res) @@ -109,6 +113,7 @@ type TaskStateMachine<'T>() = member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. + [] member this.Start() = let mutable machine = this try @@ -137,7 +142,7 @@ module TaskHelpers = /// Used to return a value. let inline ret<'T> (x : 'T) = __machine.Current <- (box x) - (# "" true : TaskStep<'T> #) + TaskStep<'T>(true) let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2 when (^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) > (x: ^Priority) (y: ^TaskLike) __expand_continuation = ((^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) (x, y, __expand_continuation)) @@ -170,7 +175,7 @@ module TaskHelpers = __expand_continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter)) else __machine.Await (awaiter, CONT) - __return (# "" false : TaskStep<'TResult2> #) + __return (TaskStep<'TResult2>(false)) static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) @@ -192,7 +197,7 @@ module TaskHelpers = __expand_continuation (awaiter.GetResult()) else __machine.Await (awaiter, CONT) - __return (# "" false : TaskStep<'TResult2> #) + __return (TaskStep<'TResult2>(false)) /// Special case of the above for `Task<'TResult1>`, for the context-insensitive builder. /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method @@ -205,7 +210,7 @@ module TaskHelpers = __expand_continuation (awaiter.GetResult()) else __machine.Await (awaiter, CONT) - __return (# "" false : TaskStep<'TResult2> #) + __return (TaskStep<'TResult2>(false)) // New style task builder. type TaskBuilder() = @@ -220,20 +225,20 @@ type TaskBuilder() = /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. member inline __.Zero() : TaskStep = __machine.Current <- (box ()) - (# "" true : TaskStep #) + TaskStep(true) member inline __.Return (x: 'T) : TaskStep<'T> = __machine.Current <- (box x) - (# "" true : TaskStep<'T> #) + TaskStep<'T>(true) /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. member inline __.Combine(``__machine_step$cont``: TaskStep, __expand_task2: unit -> TaskStep<'T>) : TaskStep<'T> = - if (# "" ``__machine_step$cont`` : bool #) then + if ``__machine_step$cont``.IsCompleted then __expand_task2() else - (# "" ``__machine_step$cont`` : TaskStep<'T> #) + TaskStep<'T>(``__machine_step$cont``.IsCompleted) /// Builds a step that executes the body while the condition predicate is true. member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskStep) : TaskStep = @@ -243,14 +248,14 @@ type TaskBuilder() = // The body of the 'while' may include an early exit, e.g. return from entire method let ``__machine_step$cont`` = __expand_body () // If we make it to the assignment we prove we've made a step - completed <- (# "" ``__machine_step$cont`` : bool #) + completed <- ``__machine_step$cont``.IsCompleted __machine.Current <- (box ()) - (# "" completed : TaskStep #) + TaskStep(completed) /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). member inline __.TryWith(__expand_body : unit -> TaskStep<'T>, __expand_catch : exn -> TaskStep<'T>) : TaskStep<'T> = - let mutable completed = (# "" false : TaskStep<'T> #) + let mutable completed = TaskStep<'T>(false) let mutable caught = false let mutable savedExn = Unchecked.defaultof<_> try @@ -274,7 +279,7 @@ type TaskBuilder() = /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). member inline __.TryFinally(__expand_body: unit -> TaskStep<'T>, compensation : unit -> unit) : TaskStep<'T> = - let mutable completed = (# "" false : TaskStep<'T> #) + let mutable completed = TaskStep<'T>(false) try let ``__machine_step$cont`` = __expand_body () // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with @@ -284,7 +289,7 @@ type TaskBuilder() = compensation() reraise() - if (# "" completed : bool #) then + if completed.IsCompleted then compensation() completed @@ -305,10 +310,10 @@ type TaskBuilder() = if task.IsCompleted then __entryPoint CONT __machine.Current <- box (task.GetAwaiter().GetResult()) - (# "" true : TaskStep<'T> #) + TaskStep<'T>(true) else __machine.Await(task.GetAwaiter(), CONT) - __return (# "" false : TaskStep<'T> #) + __return (TaskStep<'T>(false)) [] module ContextSensitiveTasks = diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index 51f649fa7aa..c92c9abaf64 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -47,7 +47,10 @@ open Microsoft.FSharp.Control open Microsoft.FSharp.Collections /// Represents the result of a computation, a value of true indicates completion -type TaskStep<'T> = (# "bool" #) +[] +type TaskStep<'T> = + new : completed: bool -> TaskStep<'T> + member IsCompleted: bool [] type TaskStateMachine = diff --git a/tests/fsharp/core/state-machines/list.fs b/tests/fsharp/core/state-machines/list.fs index e6c1effb73b..09b695272f7 100644 --- a/tests/fsharp/core/state-machines/list.fs +++ b/tests/fsharp/core/state-machines/list.fs @@ -17,23 +17,23 @@ type ListStep<'T>(res: int) = type ListStateMachine<'T>() = let res = ResizeArray<'T>() - abstract Compute : unit -> ListStep<'T> + abstract Populate : unit -> ListStep<'T> member __.Yield (v: 'T) = res.Add(v) [] member this.StartAsResizeArray() = - this.Compute(0) + this.Populate() |> ignore res [] member this.StartAsList() = - this.Compute(0) + this.Populate() |> ignore Seq.toList res [] member this.StartAsArray() = - this.Compute(0) + this.Populate() |> ignore res.ToArray() type ResizeArrayBuilderBase() = @@ -50,13 +50,14 @@ type ResizeArrayBuilderBase() = while __expand_condition() do let ``__machine_step$cont`` = __expand_body () () + ListStep<'T>(DONE) member inline __.TryWith(__expand_body : unit -> ListStep<'T>, __expand_catch : exn -> ListStep<'T>) : ListStep<'T> = try - let ``__machine_step$cont`` = __expand_body () - () + __expand_body () with exn -> - __expand_catch savedExn + __expand_catch exn + ListStep<'T>(DONE) member inline __.TryFinally(__expand_body: unit -> ListStep<'T>, compensation : unit -> unit) : ListStep<'T> = try @@ -67,6 +68,7 @@ type ResizeArrayBuilderBase() = reraise() compensation() + ListStep<'T>(DONE) member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> ListStep<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. @@ -80,16 +82,17 @@ type ResizeArrayBuilderBase() = member inline __.Yield (``__machine_step$cont``: 'T) : ListStep<'T> = __machine>.Yield(``__machine_step$cont``) + ListStep<'T>(DONE) member inline this.YieldFrom (source: IEnumerable<'T>) : ListStep<'T> = this.For(source, (fun ``__machine_step$cont`` -> this.Yield(``__machine_step$cont``))) type ResizeArrayBuilder() = inherit ResizeArrayBuilderBase() - member inline __.Run(__expand_code : unit -> ListStep<'T>) : IEnumerable<'T> = + member inline __.Run(__expand_code : unit -> ListStep<'T>) : ResizeArray<'T> = (__stateMachine { new ListStateMachine<'T>() with - member __.Compute () = __jumptable 0 __expand_code }).StartAsResizeArray() + member __.Populate () = __jumptable 0 __expand_code }).StartAsResizeArray() let rsarray = ResizeArrayBuilder() @@ -98,7 +101,7 @@ type ListBuilder() = member inline __.Run(__expand_code : unit -> ListStep<'T>) : 'T list = (__stateMachine { new ListStateMachine<'T>() with - member __.Compute () = __jumptable 0 __expand_code }).StartAsList() + member __.Populate () = __jumptable 0 __expand_code }).StartAsList() let list = ListBuilder() @@ -107,7 +110,7 @@ type ArrayBuilder() = member inline __.Run(__expand_code : unit -> ListStep<'T>) : 'T[] = (__stateMachine { new ListStateMachine<'T>() with - member __.Compute () = __jumptable 0 __expand_code }).StartAsArray() + member __.Populate () = __jumptable 0 __expand_code }).StartAsArray() let array = ArrayBuilder() @@ -133,6 +136,45 @@ module Examples = yield "f" } + let perf1 () = + for i in 1 .. 1000000 do + list { + yield "a" + yield "b" + yield "b" + yield "b" + yield "b" + yield "b" + yield "b" + yield "b" + yield "b" + yield "c" + } |> Seq.length |> ignore + + let perf2 () = + for i in 1 .. 1000000 do + [ + yield "a" + yield "b" + yield "b" + yield "b" + yield "b" + yield "b" + yield "b" + yield "b" + yield "b" + yield "c" + ] |> Seq.length |> ignore + + let perf s f = + let t = System.Diagnostics.Stopwatch() + t.Start() + f() + t.Stop() + printfn "PERF: %s : %d" s t.ElapsedMilliseconds + + perf "perf1" perf1 + perf "perf2" perf2 let dumpSeq (t: IEnumerable<_>) = let e = t.GetEnumerator() while e.MoveNext() do diff --git a/tests/fsharp/perf/tasks/TaskBuilder.fs b/tests/fsharp/perf/tasks/TaskBuilder.fs new file mode 100644 index 00000000000..b8e0fec2e07 --- /dev/null +++ b/tests/fsharp/perf/tasks/TaskBuilder.fs @@ -0,0 +1,416 @@ +// TaskBuilder.fs - TPL task computation expressions for F# +// +// Written in 2016 by Robert Peele (humbobst@gmail.com) +// New operator-based overload resolution for F# 4.0 compatibility by Gustavo Leon in 2018. +// +// To the extent possible under law, the author(s) have dedicated all copyright and related and neighboring rights +// to this software to the public domain worldwide. This software is distributed without any warranty. +// +// You should have received a copy of the CC0 Public Domain Dedication along with this software. +// If not, see . + +namespace FSharp.Control.Tasks +open System +open System.Threading.Tasks +open System.Runtime.CompilerServices + +// This module is not really obsolete, but it's not intended to be referenced directly from user code. +// However, it can't be private because it is used within inline functions that *are* user-visible. +// Marking it as obsolete is a workaround to hide it from auto-completion tools. +[] +module TaskBuilder = + /// Represents the state of a computation: + /// either awaiting something with a continuation, + /// or completed with a return value. + type Step<'a> = + | Await of ICriticalNotifyCompletion * (unit -> Step<'a>) + | Return of 'a + /// We model tail calls explicitly, but still can't run them without O(n) memory usage. + | ReturnFrom of 'a Task + /// Implements the machinery of running a `Step<'m, 'm>` as a task returning a continuation task. + and StepStateMachine<'a>(firstStep) as this = + let methodBuilder = AsyncTaskMethodBuilder<'a Task>() + /// The continuation we left off awaiting on our last MoveNext(). + let mutable continuation = fun () -> firstStep + /// Returns next pending awaitable or null if exiting (including tail call). + let nextAwaitable() = + try + match continuation() with + | Return r -> + methodBuilder.SetResult(Task.FromResult(r)) + null + | ReturnFrom t -> + methodBuilder.SetResult(t) + null + | Await (await, next) -> + continuation <- next + await + with + | exn -> + methodBuilder.SetException(exn) + null + let mutable self = this + + /// Start execution as a `Task>`. + member __.Run() = + methodBuilder.Start(&self) + methodBuilder.Task + + interface IAsyncStateMachine with + /// Proceed to one of three states: result, failure, or awaiting. + /// If awaiting, MoveNext() will be called again when the awaitable completes. + member __.MoveNext() = + let mutable await = nextAwaitable() + if not (isNull await) then + // Tell the builder to call us again when this thing is done. + methodBuilder.AwaitUnsafeOnCompleted(&await, &self) + member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. + + let unwrapException (agg : AggregateException) = + let inners = agg.InnerExceptions + if inners.Count = 1 then inners.[0] + else agg :> Exception + + /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. + let zero = Return () + + /// Used to return a value. + let ret (x : 'a) = Return x + + type Binder<'out> = + // We put the output generic parameter up here at the class level, so it doesn't get subject to + // inline rules. If we put it all in the inline function, then the compiler gets confused at the + // below and demands that the whole function either is limited to working with (x : obj), or must + // be inline itself. + // + // let yieldThenReturn (x : 'a) = + // task { + // do! Task.Yield() + // return x + // } + + static member inline GenericAwait< ^abl, ^awt, ^inp + when ^abl : (member GetAwaiter : unit -> ^awt) + and ^awt :> ICriticalNotifyCompletion + and ^awt : (member get_IsCompleted : unit -> bool) + and ^awt : (member GetResult : unit -> ^inp) > + (abl : ^abl, continuation : ^inp -> 'out Step) : 'out Step = + let awt = (^abl : (member GetAwaiter : unit -> ^awt)(abl)) // get an awaiter from the awaitable + if (^awt : (member get_IsCompleted : unit -> bool)(awt)) then // shortcut to continue immediately + continuation (^awt : (member GetResult : unit -> ^inp)(awt)) + else + Await (awt, fun () -> continuation (^awt : (member GetResult : unit -> ^inp)(awt))) + + static member inline GenericAwaitConfigureFalse< ^tsk, ^abl, ^awt, ^inp + when ^tsk : (member ConfigureAwait : bool -> ^abl) + and ^abl : (member GetAwaiter : unit -> ^awt) + and ^awt :> ICriticalNotifyCompletion + and ^awt : (member get_IsCompleted : unit -> bool) + and ^awt : (member GetResult : unit -> ^inp) > + (tsk : ^tsk, continuation : ^inp -> 'out Step) : 'out Step = + let abl = (^tsk : (member ConfigureAwait : bool -> ^abl)(tsk, false)) + Binder<'out>.GenericAwait(abl, continuation) + + /// Special case of the above for `Task<'a>`. Have to write this out by hand to avoid confusing the compiler + /// trying to decide between satisfying the constraints with `Task` or `Task<'a>`. + let bindTask (task : 'a Task) (continuation : 'a -> Step<'b>) = + let awt = task.GetAwaiter() + if awt.IsCompleted then // Proceed to the next step based on the result we already have. + continuation(awt.GetResult()) + else // Await and continue later when a result is available. + Await (awt, (fun () -> continuation(awt.GetResult()))) + + /// Special case of the above for `Task<'a>`, for the context-insensitive builder. + /// Have to write this out by hand to avoid confusing the compiler thinking our built-in bind method + /// defined on the builder has fancy generic constraints on inp and out parameters. + let bindTaskConfigureFalse (task : 'a Task) (continuation : 'a -> Step<'b>) = + let awt = task.ConfigureAwait(false).GetAwaiter() + if awt.IsCompleted then // Proceed to the next step based on the result we already have. + continuation(awt.GetResult()) + else // Await and continue later when a result is available. + Await (awt, (fun () -> continuation(awt.GetResult()))) + + /// Chains together a step with its following step. + /// Note that this requires that the first step has no result. + /// This prevents constructs like `task { return 1; return 2; }`. + let rec combine (step : Step) (continuation : unit -> Step<'b>) = + match step with + | Return _ -> continuation() + | ReturnFrom t -> + Await (t.GetAwaiter(), continuation) + | Await (awaitable, next) -> + Await (awaitable, fun () -> combine (next()) continuation) + + /// Builds a step that executes the body while the condition predicate is true. + let whileLoop (cond : unit -> bool) (body : unit -> Step) = + if cond() then + // Create a self-referencing closure to test whether to repeat the loop on future iterations. + let rec repeat () = + if cond() then + let body = body() + match body with + | Return _ -> repeat() + | ReturnFrom t -> Await(t.GetAwaiter(), repeat) + | Await (awaitable, next) -> + Await (awaitable, fun () -> combine (next()) repeat) + else zero + // Run the body the first time and chain it to the repeat logic. + combine (body()) repeat + else zero + + /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function + /// to retrieve the step, and in the continuation of the step (if any). + let rec tryWith(step : unit -> Step<'a>) (catch : exn -> Step<'a>) = + try + match step() with + | Return _ as i -> i + | ReturnFrom t -> + let awaitable = t.GetAwaiter() + Await(awaitable, fun () -> + try + awaitable.GetResult() |> Return + with + | exn -> catch exn) + | Await (awaitable, next) -> Await (awaitable, fun () -> tryWith next catch) + with + | exn -> catch exn + + /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function + /// to retrieve the step, and in the continuation of the step (if any). + let rec tryFinally (step : unit -> Step<'a>) fin = + let step = + try step() + // Important point: we use a try/with, not a try/finally, to implement tryFinally. + // The reason for this is that if we're just building a continuation, we definitely *shouldn't* + // execute the `fin()` part yet -- the actual execution of the asynchronous code hasn't completed! + with + | _ -> + fin() + reraise() + match step with + | Return _ as i -> + fin() + i + | ReturnFrom t -> + let awaitable = t.GetAwaiter() + Await(awaitable, fun () -> + let result = + try + awaitable.GetResult() |> Return + with + | _ -> + fin() + reraise() + fin() // if we got here we haven't run fin(), because we would've reraised after doing so + result) + | Await (awaitable, next) -> + Await (awaitable, fun () -> tryFinally next fin) + + /// Implements a using statement that disposes `disp` after `body` has completed. + let using (disp : #IDisposable) (body : _ -> Step<'a>) = + // A using statement is just a try/finally with the finally block disposing if non-null. + tryFinally + (fun () -> body disp) + (fun () -> if not (isNull (box disp)) then disp.Dispose()) + + /// Implements a loop that runs `body` for each element in `sequence`. + let forLoop (sequence : 'a seq) (body : 'a -> Step) = + // A for loop is just a using statement on the sequence's enumerator... + using (sequence.GetEnumerator()) + // ... and its body is a while loop that advances the enumerator and runs the body on each element. + (fun e -> whileLoop e.MoveNext (fun () -> body e.Current)) + + /// Runs a step as a task -- with a short-circuit for immediately completed steps. + let run (firstStep : unit -> Step<'a>) = + try + match firstStep() with + | Return x -> Task.FromResult(x) + | ReturnFrom t -> t + | Await _ as step -> StepStateMachine<'a>(step).Run().Unwrap() // sadly can't do tail recursion + // Any exceptions should go on the task, rather than being thrown from this call. + // This matches C# behavior where you won't see an exception until awaiting the task, + // even if it failed before reaching the first "await". + with + | exn -> + let src = new TaskCompletionSource<_>() + src.SetException(exn) + src.Task + + // We have to have a dedicated overload for Task<'a> so the compiler doesn't get confused with Convenience overloads for Asyncs + // Everything else can use bindGenericAwaitable via an extension member + + type Priority3 = obj + type Priority2 = IComparable + + type BindS = Priority1 with + static member inline (>>=) (_:Priority2, taskLike : 't) = fun (k: _ -> 'b Step) -> Binder<'b>.GenericAwait (taskLike, k): 'b Step + static member (>>=) ( Priority1, task: 'a Task) = fun (k: 'a -> 'b Step) -> bindTask task k : 'b Step + static member (>>=) ( Priority1, a : 'a Async) = fun (k: 'a -> 'b Step) -> bindTask (Async.StartAsTask a) k : 'b Step + + type ReturnFromS = Priority1 with + static member inline ($) (Priority1, taskLike ) = Binder<_>.GenericAwait (taskLike, ret) + static member ($) (Priority1, a : 'a Async) = bindTask (Async.StartAsTask a) ret : Step<'a> + + type BindI = Priority1 with + static member inline (>>=) (_:Priority3, taskLike : 't) = fun (k : _ -> 'b Step) -> Binder<'b>.GenericAwait (taskLike, k) : 'b Step + static member inline (>>=) (_:Priority2, configurableTaskLike: 't) = fun (k : _ -> 'b Step) -> Binder<'b>.GenericAwaitConfigureFalse (configurableTaskLike, k): 'b Step + static member (>>=) ( Priority1, task: 'a Task ) = fun (k : 'a -> 'b Step) -> bindTaskConfigureFalse task k : 'b Step + static member (>>=) ( Priority1, a : 'a Async ) = fun (k : 'a -> 'b Step) -> bindTaskConfigureFalse (Async.StartAsTask a) k : 'b Step + + type ReturnFromI = Priority1 with + static member inline ($) (_:Priority2, taskLike ) = Binder<_>.GenericAwait(taskLike, ret) + static member inline ($) ( Priority1, configurableTaskLike) = Binder<_>.GenericAwaitConfigureFalse(configurableTaskLike, ret) + static member ($) ( Priority1, a : 'a Async ) = bindTaskConfigureFalse (Async.StartAsTask a) ret + + // New style task builder. + type TaskBuilderV2() = + // These methods are consistent between all builders. + member __.Delay(f : unit -> Step<_>) = f + member __.Run(f : unit -> Step<'m>) = run f + member __.Zero() = zero + member __.Return(x) = ret x + member __.Combine(step : unit Step, continuation) = combine step continuation + member __.While(condition : unit -> bool, body : unit -> unit Step) = whileLoop condition body + member __.For(sequence : _ seq, body : _ -> unit Step) = forLoop sequence body + member __.TryWith(body : unit -> _ Step, catch : exn -> _ Step) = tryWith body catch + member __.TryFinally(body : unit -> _ Step, fin : unit -> unit) = tryFinally body fin + member __.Using(disp : #IDisposable, body : #IDisposable -> _ Step) = using disp body + member __.ReturnFrom a : _ Step = ReturnFrom a + + // Old style task builder. Retained for binary compatibility. + type TaskBuilder() = + // These methods are consistent between the two builders. + // Unfortunately, inline members do not work with inheritance. + member inline __.Delay(f : unit -> Step<_>) = f + member inline __.Run(f : unit -> Step<'m>) = run f + member inline __.Zero() = zero + member inline __.Return(x) = ret x + member inline __.Combine(step : unit Step, continuation) = combine step continuation + member inline __.While(condition : unit -> bool, body : unit -> unit Step) = whileLoop condition body + member inline __.For(sequence : _ seq, body : _ -> unit Step) = forLoop sequence body + member inline __.TryWith(body : unit -> _ Step, catch : exn -> _ Step) = tryWith body catch + member inline __.TryFinally(body : unit -> _ Step, fin : unit -> unit) = tryFinally body fin + member inline __.Using(disp : #IDisposable, body : #IDisposable -> _ Step) = using disp body + // End of consistent methods -- the following methods are different between + // `TaskBuilder` and `ContextInsensitiveTaskBuilder`! + + // We have to have a dedicated overload for Task<'a> so the compiler doesn't get confused. + // Everything else can use bindGenericAwaitable via an extension member (defined later). + member inline __.ReturnFrom(task : _ Task) = ReturnFrom task + member inline __.Bind(task : 'a Task, continuation : 'a -> 'b Step) : 'b Step = + bindTask task continuation + + // Old style task builder. Retained for binary compatibility. + type ContextInsensitiveTaskBuilder() = + // These methods are consistent between the two builders. + // Unfortunately, inline members do not work with inheritance. + member inline __.Delay(f : unit -> Step<_>) = f + member inline __.Run(f : unit -> Step<'m>) = run f + member inline __.Zero() = zero + member inline __.Return(x) = ret x + member inline __.Combine(step : unit Step, continuation) = combine step continuation + member inline __.While(condition : unit -> bool, body : unit -> unit Step) = whileLoop condition body + member inline __.For(sequence : _ seq, body : _ -> unit Step) = forLoop sequence body + member inline __.TryWith(body : unit -> _ Step, catch : exn -> _ Step) = tryWith body catch + member inline __.TryFinally(body : unit -> _ Step, fin : unit -> unit) = tryFinally body fin + member inline __.Using(disp : #IDisposable, body : #IDisposable -> _ Step) = using disp body + // End of consistent methods -- the following methods are different between + // `TaskBuilder` and `ContextInsensitiveTaskBuilder`! + + // We have to have a dedicated overload for Task<'a> so the compiler doesn't get confused. + // Everything else can use bindGenericAwaitable via an extension member (defined later). + member inline __.ReturnFrom(task : _ Task) = ReturnFrom task + member inline __.Bind(task : 'a Task, continuation : 'a -> 'b Step) : 'b Step = + bindTaskConfigureFalse task continuation + + +// Don't warn about our use of the "obsolete" module we just defined (see notes at start of file). +#nowarn "44" + +[] +module ContextSensitive = + /// Builds a `System.Threading.Tasks.Task<'a>` similarly to a C# async/await method. + /// Use this like `task { let! taskResult = someTask(); return taskResult.ToString(); }`. + let task = TaskBuilder.TaskBuilder() + + [] + let inline unitTask t = t :> Task + + // These are fallbacks when the Bind and ReturnFrom on the builder object itself don't apply. + // This is how we support binding arbitrary task-like types. + type TaskBuilder.TaskBuilder with + member inline this.ReturnFrom(taskLike) = + TaskBuilder.Binder<_>.GenericAwait(taskLike, TaskBuilder.ret) + member inline this.Bind(taskLike, continuation : _ -> 'a TaskBuilder.Step) : 'a TaskBuilder.Step = + TaskBuilder.Binder<'a>.GenericAwait(taskLike, continuation) + // Convenience overloads for Asyncs. + member __.ReturnFrom(a : 'a Async) = + TaskBuilder.bindTask (Async.StartAsTask a) TaskBuilder.ret + member __.Bind(a : 'a Async, continuation : 'a -> 'b TaskBuilder.Step) : 'b TaskBuilder.Step = + TaskBuilder.bindTask (Async.StartAsTask a) continuation + +module ContextInsensitive = + /// Builds a `System.Threading.Tasks.Task<'a>` similarly to a C# async/await method, but with + /// all awaited tasks automatically configured *not* to resume on the captured context. + /// This is often preferable when writing library code that is not context-aware, but undesirable when writing + /// e.g. code that must interact with user interface controls on the same thread as its caller. + let task = TaskBuilder.ContextInsensitiveTaskBuilder() + + [] + let inline unitTask (t : Task) = t.ConfigureAwait(false) + + // These are fallbacks when the Bind and ReturnFrom on the builder object itself don't apply. + // This is how we support binding arbitrary task-like types. + type TaskBuilder.ContextInsensitiveTaskBuilder with + member inline this.ReturnFrom(taskLike) = + TaskBuilder.Binder<_>.GenericAwait(taskLike, TaskBuilder.ret) + member inline this.Bind(taskLike, continuation : _ -> 'a TaskBuilder.Step) : 'a TaskBuilder.Step = + TaskBuilder.Binder<'a>.GenericAwait(taskLike, continuation) + + // Convenience overloads for Asyncs. + member __.ReturnFrom(a : 'a Async) = + TaskBuilder.bindTaskConfigureFalse (Async.StartAsTask a) TaskBuilder.ret + member __.Bind(a : 'a Async, continuation : 'a -> 'b TaskBuilder.Step) : 'b TaskBuilder.Step = + TaskBuilder.bindTaskConfigureFalse (Async.StartAsTask a) continuation + + [] + module HigherPriorityBinds = + // When it's possible for these to work, the compiler should prefer them since they shadow the ones above. + type TaskBuilder.ContextInsensitiveTaskBuilder with + member inline this.ReturnFrom(configurableTaskLike) = + TaskBuilder.Binder<_>.GenericAwaitConfigureFalse(configurableTaskLike, TaskBuilder.ret) + member inline this.Bind(configurableTaskLike, continuation : _ -> 'a TaskBuilder.Step) : 'a TaskBuilder.Step = + TaskBuilder.Binder<'a>.GenericAwaitConfigureFalse(configurableTaskLike, continuation) + + +module V2 = + [] + module ContextSensitive = + open TaskBuilder + + /// Builds a `System.Threading.Tasks.Task<'a>` similarly to a C# async/await method. + /// Use this like `task { let! taskResult = someTask(); return taskResult.ToString(); }`. + let task = TaskBuilderV2() + + [] + let unitTask (t : Task) = t + + type TaskBuilderV2 with + member inline __.Bind (task, continuation : 'a -> 'b Step) : 'b Step = (BindS.Priority1 >>= task) continuation + member inline __.ReturnFrom a : 'b Step = ReturnFromS.Priority1 $ a + + module ContextInsensitive = + open TaskBuilder + + /// Builds a `System.Threading.Tasks.Task<'a>` similarly to a C# async/await method, but with + /// all awaited tasks automatically configured *not* to resume on the captured context. + /// This is often preferable when writing library code that is not context-aware, but undesirable when writing + /// e.g. code that must interact with user interface controls on the same thread as its caller. + let task = TaskBuilderV2() + + [] + let unitTask (t : Task) = t.ConfigureAwait(false) + + type TaskBuilderV2 with + member inline __.Bind (task, continuation : 'a -> 'b Step) : 'b Step = (BindI.Priority1 >>= task) continuation + member inline __.ReturnFrom a : 'b Step = ReturnFromI.Priority1 $ a \ No newline at end of file diff --git a/tests/fsharp/perf/tasks/benchmark.fs b/tests/fsharp/perf/tasks/benchmark.fs new file mode 100644 index 00000000000..62a34b95361 --- /dev/null +++ b/tests/fsharp/perf/tasks/benchmark.fs @@ -0,0 +1,185 @@ +(* +csc /optimize /target:library tests\fsharp\perf\tasks\csbenchmark.cs +artifacts\bin\fsc\Debug\net472\fsc.exe tests\fsharp\perf\tasks\TaskBuilder.fs tests\fsharp\perf\tasks\benchmark.fs --optimize -g -r:csbenchmark.dll +*) + +//open FSharp.Control.Tasks +open System.Diagnostics +open System.Threading.Tasks +open System.IO + +module RepeatedAsyncWrite = + [] + let bufferSize = RepeatedAsyncWriteCSharp.BufferSize + + let writeIterations() = RepeatedAsyncWriteCSharp.WriteIterations + + [] + let executionIterations = RepeatedAsyncWriteCSharp.ExecutionIterations + + module TaskVersion = + let writeFile path = + task { + let junk = Array.zeroCreate bufferSize + use file = File.Create(path) + for i = 1 to writeIterations() do + match RepeatedAsyncWriteCSharp.Operation with + | Operation.WRITE_ASYNC -> + do! file.WriteAsync(junk, 0, junk.Length) + | Operation.FROM_RESULT -> + let! v = Task.FromResult(100) + () // file.WriteAsync(junk, 0, junk.Length) + | _ -> () + } + + let readFile path = + task { + let buffer = Array.zeroCreate bufferSize + use file = File.OpenRead(path) + let mutable reading = true + while reading do + let! countRead = file.ReadAsync(buffer, 0, buffer.Length) + reading <- countRead > 0 + } + + let bench() = + let tmp = "tmp" + task { + let sw = Stopwatch() + sw.Start() + for i = 1 to executionIterations do + do! writeFile tmp + do! readFile tmp + sw.Stop() + printfn "task { .. } completed in %d ms" sw.ElapsedMilliseconds + File.Delete(tmp) + } + + module TaskBuilderVersion = + open FSharp.Control.Tasks + + let writeFile path = + task { + let junk = Array.zeroCreate bufferSize + use file = File.Create(path) + for i = 1 to writeIterations() do + match RepeatedAsyncWriteCSharp.Operation with + | Operation.WRITE_ASYNC -> + do! file.WriteAsync(junk, 0, junk.Length) + | Operation.FROM_RESULT -> + let! v = Task.FromResult(100) + () // file.WriteAsync(junk, 0, junk.Length) + | _ -> () + } + + let readFile path = + task { + let buffer = Array.zeroCreate bufferSize + use file = File.OpenRead(path) + let mutable reading = true + while reading do + let! countRead = file.ReadAsync(buffer, 0, buffer.Length) + reading <- countRead > 0 + } + + let bench() = + let tmp = "tmp" + task { + let sw = Stopwatch() + sw.Start() + for i = 1 to executionIterations do + do! writeFile tmp + do! readFile tmp + sw.Stop() + printfn "TaskBuilder task { .. } completed in %d ms" sw.ElapsedMilliseconds + File.Delete(tmp) + } + + module FSharpAsyncVersion = + let writeFile path = + async { + let junk = Array.zeroCreate bufferSize + use file = File.Create(path) + for i = 1 to writeIterations() do + match RepeatedAsyncWriteCSharp.Operation with + | Operation.WRITE_ASYNC -> + do! file.AsyncWrite(junk, 0, junk.Length) + | Operation.FROM_RESULT -> + let! v = async.Return 100 + () + | _ -> () + } + + let readFile path = + async { + let buffer = Array.zeroCreate bufferSize + use file = File.OpenRead(path) + let mutable reading = true + while reading do + let! countRead = file.AsyncRead(buffer, 0, buffer.Length) + reading <- countRead > 0 + } + + let bench() = + let tmp = "tmp" + async { + let sw = Stopwatch() + sw.Start() + for i = 1 to executionIterations do + do! writeFile tmp + do! readFile tmp + sw.Stop() + printfn "F# async completed in %d ms" sw.ElapsedMilliseconds + File.Delete(tmp) + } + + module FSharpAsyncAwaitTaskVersion = + let writeFile path = + async { + let junk = Array.zeroCreate bufferSize + use file = File.Create(path) + for i = 1 to writeIterations() do + match RepeatedAsyncWriteCSharp.Operation with + | Operation.WRITE_ASYNC -> + do! Async.AwaitTask(file.WriteAsync(junk, 0, junk.Length)) + | Operation.FROM_RESULT -> + let! v = async.Return 100 + () + | _ -> () + } + + let readFile path = + async { + let buffer = Array.zeroCreate bufferSize + use file = File.OpenRead(path) + let mutable reading = true + while reading do + let! countRead = Async.AwaitTask(file.ReadAsync(buffer, 0, buffer.Length)) + reading <- countRead > 0 + } + + let bench() = + let tmp = "tmp" + async { + let sw = Stopwatch() + sw.Start() + for i = 1 to executionIterations do + do! writeFile tmp + do! readFile tmp + sw.Stop() + printfn "F# async (AwaitTask) completed in %d ms" sw.ElapsedMilliseconds + File.Delete(tmp) + } + +[] +let main argv = + for (op, n) in [(Operation.WRITE_ASYNC, 5000); (Operation.FROM_RESULT, 300000)] do + RepeatedAsyncWriteCSharp.Operation <- op + RepeatedAsyncWriteCSharp.WriteIterations <- n + printfn "-------- operation = %A ------" op + RepeatedAsyncWriteCSharp.Bench().Wait() + RepeatedAsyncWrite.TaskVersion.bench().Wait() + RepeatedAsyncWrite.TaskBuilderVersion.bench().Wait() + RepeatedAsyncWrite.FSharpAsyncVersion.bench() |> Async.RunSynchronously + RepeatedAsyncWrite.FSharpAsyncAwaitTaskVersion.bench() |> Async.RunSynchronously + 0 // return an integer exit code \ No newline at end of file diff --git a/tests/fsharp/perf/tasks/csbenchmark.cs b/tests/fsharp/perf/tasks/csbenchmark.cs new file mode 100644 index 00000000000..5ac742f1fb3 --- /dev/null +++ b/tests/fsharp/perf/tasks/csbenchmark.cs @@ -0,0 +1,65 @@ +using System; +using System.Diagnostics; +using System.IO; +using System.Threading.Tasks; + +public enum Operation { WRITE_ASYNC, FROM_RESULT } +public static class RepeatedAsyncWriteCSharp +{ + public const int BufferSize = 128; + public static int WriteIterations = 10000; + public const int ExecutionIterations = 50; + public static Operation Operation = Operation.WRITE_ASYNC; + + private static async Task WriteFile(string path) + { + var junk = new byte[BufferSize]; + using (var file = File.Create(path)) + { + for (var i = 1; i <= WriteIterations; i++) + { + switch (Operation) + { + case Operation.WRITE_ASYNC: + await file.WriteAsync(junk, 0, junk.Length); + break; + case Operation.FROM_RESULT: + await Task.FromResult(100); + break; + default: + break; + } + } + } + } + + private static async Task ReadFile(string path) + { + var buffer = new byte[BufferSize]; + using (var file = File.OpenRead(path)) + { + var reading = true; + while (reading) + { + var countRead = await file.ReadAsync(buffer, 0, buffer.Length); + reading = countRead > 0; + } + } + } + + public static async Task Bench() + { + const string tmp = "tmp"; + var sw = new Stopwatch(); + sw.Start(); + for (var i = 1; i <= ExecutionIterations; i++) + { + await WriteFile(tmp); + await ReadFile(tmp); + } + sw.Stop(); + File.Delete(tmp); + Console.WriteLine($"C# methods completed in {sw.ElapsedMilliseconds} ms"); + } +} + From 24c0962f7c79ab0b7398055ad1cacd9953a31fa1 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 13 May 2019 17:37:07 +0100 Subject: [PATCH 33/45] revist perf --- tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs | 28 +++++++ .../perf/tasks/CS/TaskPerfCSharp.csproj | 13 +++ .../fsharp/perf/tasks/{ => FS}/TaskBuilder.fs | 0 .../tasks/{benchmark.fs => FS/TaskPerf.fs} | 82 ++++++++++++++++--- tests/fsharp/perf/tasks/FS/TaskPerf.fsproj | 15 ++++ tests/fsharp/perf/tasks/csbenchmark.cs | 65 --------------- 6 files changed, 127 insertions(+), 76 deletions(-) create mode 100644 tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs create mode 100644 tests/fsharp/perf/tasks/CS/TaskPerfCSharp.csproj rename tests/fsharp/perf/tasks/{ => FS}/TaskBuilder.fs (100%) rename tests/fsharp/perf/tasks/{benchmark.fs => FS/TaskPerf.fs} (73%) create mode 100644 tests/fsharp/perf/tasks/FS/TaskPerf.fsproj delete mode 100644 tests/fsharp/perf/tasks/csbenchmark.cs diff --git a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs new file mode 100644 index 00000000000..5bfb1c98c51 --- /dev/null +++ b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs @@ -0,0 +1,28 @@ +using System; +using System.Diagnostics; +using System.IO; +using System.Threading.Tasks; +using BenchmarkDotNet.Attributes; +using BenchmarkDotNet.Running; + +public static class TaskPerf +{ + public const int BufferSize = 128; + public const int WriteIterations = 10000; + + private static async Task ManyWriteFile(string path) + { + const string tmp = "tmp"; + var junk = new byte[BufferSize]; + using (var file = File.Create(path)) + { + for (var i = 1; i <= WriteIterations; i++) + { + await file.WriteAsync(junk, 0, junk.Length); + } + } + File.Delete(tmp); + } + +} + diff --git a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.csproj b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.csproj new file mode 100644 index 00000000000..ef45cab595b --- /dev/null +++ b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.csproj @@ -0,0 +1,13 @@ + + + + netcoreapp2.1 + Library + + + + + + + + diff --git a/tests/fsharp/perf/tasks/TaskBuilder.fs b/tests/fsharp/perf/tasks/FS/TaskBuilder.fs similarity index 100% rename from tests/fsharp/perf/tasks/TaskBuilder.fs rename to tests/fsharp/perf/tasks/FS/TaskBuilder.fs diff --git a/tests/fsharp/perf/tasks/benchmark.fs b/tests/fsharp/perf/tasks/FS/TaskPerf.fs similarity index 73% rename from tests/fsharp/perf/tasks/benchmark.fs rename to tests/fsharp/perf/tasks/FS/TaskPerf.fs index 62a34b95361..bf9c45ac6b9 100644 --- a/tests/fsharp/perf/tasks/benchmark.fs +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fs @@ -3,12 +3,15 @@ csc /optimize /target:library tests\fsharp\perf\tasks\csbenchmark.cs artifacts\bin\fsc\Debug\net472\fsc.exe tests\fsharp\perf\tasks\TaskBuilder.fs tests\fsharp\perf\tasks\benchmark.fs --optimize -g -r:csbenchmark.dll *) +namespace TaskPerf + //open FSharp.Control.Tasks open System.Diagnostics open System.Threading.Tasks open System.IO +open BenchmarkDotNet.Attributes +open BenchmarkDotNet.Running -module RepeatedAsyncWrite = [] let bufferSize = RepeatedAsyncWriteCSharp.BufferSize @@ -82,6 +85,7 @@ module RepeatedAsyncWrite = reading <- countRead > 0 } + let bench() = let tmp = "tmp" task { @@ -171,15 +175,71 @@ module RepeatedAsyncWrite = File.Delete(tmp) } +module AllocTests = + + let syncTask() = Task.FromResult 100 + let asyncTask() = Task.Yield() + + let tenBindSynchronous() = + task { + let! res1 = syncTask() + let! res2 = syncTask() + let! res3 = syncTask() + let! res4 = syncTask() + let! res5 = syncTask() + let! res6 = syncTask() + let! res7 = syncTask() + let! res8 = syncTask() + let! res9 = syncTask() + let! res10 = syncTask() + return res1 + res2 + res3 + res4 + res5 + res6 + res7 + res8 + res9 + res10 + } + + let tenBindAsynchronous() = + task { + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + } + + let singleTask() = task { return 1 } + + let numIterations = 10000 + + let allocTestSyncBinds() = + for i in 1 .. numIterations do + tenBindSynchronous().Wait() + + let allocTestAsyncBinds() = + for i in 1 .. numIterations do + tenBindAsynchronous().Wait() + + let allocTestSingleTask() = + for i in 1 .. numIterations*100 do + singleTask().Wait() + + [] let main argv = - for (op, n) in [(Operation.WRITE_ASYNC, 5000); (Operation.FROM_RESULT, 300000)] do - RepeatedAsyncWriteCSharp.Operation <- op - RepeatedAsyncWriteCSharp.WriteIterations <- n - printfn "-------- operation = %A ------" op - RepeatedAsyncWriteCSharp.Bench().Wait() - RepeatedAsyncWrite.TaskVersion.bench().Wait() - RepeatedAsyncWrite.TaskBuilderVersion.bench().Wait() - RepeatedAsyncWrite.FSharpAsyncVersion.bench() |> Async.RunSynchronously - RepeatedAsyncWrite.FSharpAsyncAwaitTaskVersion.bench() |> Async.RunSynchronously - 0 // return an integer exit code \ No newline at end of file + match argv.[0] with + | "allocSingleTask" -> AllocTests.allocTestSingleTask() + | "allocSyncBinds" -> AllocTests.allocTestSyncBinds() + | "allocAsyncBinds" -> AllocTests.allocTestAsyncBinds() + | _ -> + for (op, n) in [(Operation.WRITE_ASYNC, 5000); (Operation.FROM_RESULT, 300000)] do + RepeatedAsyncWriteCSharp.Operation <- op + RepeatedAsyncWriteCSharp.WriteIterations <- n + printfn "-------- operation = %A ------" op + RepeatedAsyncWriteCSharp.Bench().Wait() + RepeatedAsyncWrite.TaskVersion.bench().Wait() + RepeatedAsyncWrite.TaskBuilderVersion.bench().Wait() + RepeatedAsyncWrite.FSharpAsyncVersion.bench() |> Async.RunSynchronously + RepeatedAsyncWrite.FSharpAsyncAwaitTaskVersion.bench() |> Async.RunSynchronously + 0 \ No newline at end of file diff --git a/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj b/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj new file mode 100644 index 00000000000..cb74e40b09f --- /dev/null +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj @@ -0,0 +1,15 @@ + + + + netcoreapp2.1 + Exe + + + + + + + + + + diff --git a/tests/fsharp/perf/tasks/csbenchmark.cs b/tests/fsharp/perf/tasks/csbenchmark.cs deleted file mode 100644 index 5ac742f1fb3..00000000000 --- a/tests/fsharp/perf/tasks/csbenchmark.cs +++ /dev/null @@ -1,65 +0,0 @@ -using System; -using System.Diagnostics; -using System.IO; -using System.Threading.Tasks; - -public enum Operation { WRITE_ASYNC, FROM_RESULT } -public static class RepeatedAsyncWriteCSharp -{ - public const int BufferSize = 128; - public static int WriteIterations = 10000; - public const int ExecutionIterations = 50; - public static Operation Operation = Operation.WRITE_ASYNC; - - private static async Task WriteFile(string path) - { - var junk = new byte[BufferSize]; - using (var file = File.Create(path)) - { - for (var i = 1; i <= WriteIterations; i++) - { - switch (Operation) - { - case Operation.WRITE_ASYNC: - await file.WriteAsync(junk, 0, junk.Length); - break; - case Operation.FROM_RESULT: - await Task.FromResult(100); - break; - default: - break; - } - } - } - } - - private static async Task ReadFile(string path) - { - var buffer = new byte[BufferSize]; - using (var file = File.OpenRead(path)) - { - var reading = true; - while (reading) - { - var countRead = await file.ReadAsync(buffer, 0, buffer.Length); - reading = countRead > 0; - } - } - } - - public static async Task Bench() - { - const string tmp = "tmp"; - var sw = new Stopwatch(); - sw.Start(); - for (var i = 1; i <= ExecutionIterations; i++) - { - await WriteFile(tmp); - await ReadFile(tmp); - } - sw.Stop(); - File.Delete(tmp); - Console.WriteLine($"C# methods completed in {sw.ElapsedMilliseconds} ms"); - } -} - From a7690e9c56a7abf6d1038fc9a5b77487b04d794f Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 13 May 2019 19:15:46 +0100 Subject: [PATCH 34/45] improve benchmarks --- src/fsharp/xlf/FSComp.txt.es.xlf | 2 +- tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs | 58 ++- tests/fsharp/perf/tasks/FS/TaskBuilder.fs | 2 +- tests/fsharp/perf/tasks/FS/TaskPerf.fs | 386 +++++++++---------- tests/fsharp/perf/tasks/FS/TaskPerf.fsproj | 1 + 5 files changed, 241 insertions(+), 208 deletions(-) diff --git a/src/fsharp/xlf/FSComp.txt.es.xlf b/src/fsharp/xlf/FSComp.txt.es.xlf index f3c85065ce9..9709b6c3abf 100644 --- a/src/fsharp/xlf/FSComp.txt.es.xlf +++ b/src/fsharp/xlf/FSComp.txt.es.xlf @@ -109,7 +109,7 @@ All branches of a pattern match expression must return values of the same type as the first branch, which here is '{0}'. This branch returns a value of type '{1}'. - Todas las ramas de una expresión de coincidencia de patrón deben devolver valores del mismo tipo. La primera rama devolvió un valor de tipo "{0}", pero esta rama devolvió un valor de tipo "\{1 \}". + All branches of a pattern match expression must return values of the same type as the first branch, which here is '{0}'. This branch returns a value of type '{1}'. diff --git a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs index 5bfb1c98c51..a62adab9017 100644 --- a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs +++ b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs @@ -5,23 +5,69 @@ using BenchmarkDotNet.Attributes; using BenchmarkDotNet.Running; -public static class TaskPerf +public static class TaskPerfCSharp { public const int BufferSize = 128; - public const int WriteIterations = 10000; + public const int ManyIterations = 10000; - private static async Task ManyWriteFile(string path) + public static async Task ManyWriteFileAsync() { - const string tmp = "tmp"; + const string path = "tmp"; var junk = new byte[BufferSize]; using (var file = File.Create(path)) { - for (var i = 1; i <= WriteIterations; i++) + for (var i = 1; i <= ManyIterations; i++) { await file.WriteAsync(junk, 0, junk.Length); } } - File.Delete(tmp); + File.Delete(path); + } + + public static async Task AsyncTask() + { + await Task.Yield(); + return 100; + } + + public static Task SyncTask() + { + return Task.FromResult(100); + } + + public static async Task TenBindsSync_CSharp() + { + var x1 = await SyncTask(); + var x2 = await SyncTask(); + var x3 = await SyncTask(); + var x4 = await SyncTask(); + var x5 = await SyncTask(); + var x6 = await SyncTask(); + var x7 = await SyncTask(); + var x8 = await SyncTask(); + var x9 = await SyncTask(); + var x10 = await SyncTask(); + return x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10; + } + + public static async Task TenBindsAsync_CSharp() + { + var x1 = await AsyncTask(); + var x2 = await AsyncTask(); + var x3 = await AsyncTask(); + var x4 = await AsyncTask(); + var x5 = await AsyncTask(); + var x6 = await AsyncTask(); + var x7 = await AsyncTask(); + var x8 = await AsyncTask(); + var x9 = await AsyncTask(); + var x10 = await AsyncTask(); + return x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10; + } + + public static async Task SingleTask_CSharp() + { + return 1; } } diff --git a/tests/fsharp/perf/tasks/FS/TaskBuilder.fs b/tests/fsharp/perf/tasks/FS/TaskBuilder.fs index b8e0fec2e07..2adebfd8f41 100644 --- a/tests/fsharp/perf/tasks/FS/TaskBuilder.fs +++ b/tests/fsharp/perf/tasks/FS/TaskBuilder.fs @@ -9,7 +9,7 @@ // You should have received a copy of the CC0 Public Domain Dedication along with this software. // If not, see . -namespace FSharp.Control.Tasks +namespace TaskBuilderTasks open System open System.Threading.Tasks open System.Runtime.CompilerServices diff --git a/tests/fsharp/perf/tasks/FS/TaskPerf.fs b/tests/fsharp/perf/tasks/FS/TaskPerf.fs index bf9c45ac6b9..dad140b665b 100644 --- a/tests/fsharp/perf/tasks/FS/TaskPerf.fs +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fs @@ -11,176 +11,21 @@ open System.Threading.Tasks open System.IO open BenchmarkDotNet.Attributes open BenchmarkDotNet.Running +open TaskBuilderTasks.ContextSensitive // TaskBuilder.fs extension members +open FSharp.Control.ContextSensitiveTasks // the default - [] - let bufferSize = RepeatedAsyncWriteCSharp.BufferSize - - let writeIterations() = RepeatedAsyncWriteCSharp.WriteIterations - - [] - let executionIterations = RepeatedAsyncWriteCSharp.ExecutionIterations - - module TaskVersion = - let writeFile path = - task { - let junk = Array.zeroCreate bufferSize - use file = File.Create(path) - for i = 1 to writeIterations() do - match RepeatedAsyncWriteCSharp.Operation with - | Operation.WRITE_ASYNC -> - do! file.WriteAsync(junk, 0, junk.Length) - | Operation.FROM_RESULT -> - let! v = Task.FromResult(100) - () // file.WriteAsync(junk, 0, junk.Length) - | _ -> () - } - - let readFile path = - task { - let buffer = Array.zeroCreate bufferSize - use file = File.OpenRead(path) - let mutable reading = true - while reading do - let! countRead = file.ReadAsync(buffer, 0, buffer.Length) - reading <- countRead > 0 - } - - let bench() = - let tmp = "tmp" - task { - let sw = Stopwatch() - sw.Start() - for i = 1 to executionIterations do - do! writeFile tmp - do! readFile tmp - sw.Stop() - printfn "task { .. } completed in %d ms" sw.ElapsedMilliseconds - File.Delete(tmp) - } - - module TaskBuilderVersion = - open FSharp.Control.Tasks - - let writeFile path = - task { - let junk = Array.zeroCreate bufferSize - use file = File.Create(path) - for i = 1 to writeIterations() do - match RepeatedAsyncWriteCSharp.Operation with - | Operation.WRITE_ASYNC -> - do! file.WriteAsync(junk, 0, junk.Length) - | Operation.FROM_RESULT -> - let! v = Task.FromResult(100) - () // file.WriteAsync(junk, 0, junk.Length) - | _ -> () - } - - let readFile path = - task { - let buffer = Array.zeroCreate bufferSize - use file = File.OpenRead(path) - let mutable reading = true - while reading do - let! countRead = file.ReadAsync(buffer, 0, buffer.Length) - reading <- countRead > 0 - } - - - let bench() = - let tmp = "tmp" - task { - let sw = Stopwatch() - sw.Start() - for i = 1 to executionIterations do - do! writeFile tmp - do! readFile tmp - sw.Stop() - printfn "TaskBuilder task { .. } completed in %d ms" sw.ElapsedMilliseconds - File.Delete(tmp) - } - - module FSharpAsyncVersion = - let writeFile path = - async { - let junk = Array.zeroCreate bufferSize - use file = File.Create(path) - for i = 1 to writeIterations() do - match RepeatedAsyncWriteCSharp.Operation with - | Operation.WRITE_ASYNC -> - do! file.AsyncWrite(junk, 0, junk.Length) - | Operation.FROM_RESULT -> - let! v = async.Return 100 - () - | _ -> () - } - - let readFile path = - async { - let buffer = Array.zeroCreate bufferSize - use file = File.OpenRead(path) - let mutable reading = true - while reading do - let! countRead = file.AsyncRead(buffer, 0, buffer.Length) - reading <- countRead > 0 - } - - let bench() = - let tmp = "tmp" - async { - let sw = Stopwatch() - sw.Start() - for i = 1 to executionIterations do - do! writeFile tmp - do! readFile tmp - sw.Stop() - printfn "F# async completed in %d ms" sw.ElapsedMilliseconds - File.Delete(tmp) - } - - module FSharpAsyncAwaitTaskVersion = - let writeFile path = - async { - let junk = Array.zeroCreate bufferSize - use file = File.Create(path) - for i = 1 to writeIterations() do - match RepeatedAsyncWriteCSharp.Operation with - | Operation.WRITE_ASYNC -> - do! Async.AwaitTask(file.WriteAsync(junk, 0, junk.Length)) - | Operation.FROM_RESULT -> - let! v = async.Return 100 - () - | _ -> () - } - - let readFile path = - async { - let buffer = Array.zeroCreate bufferSize - use file = File.OpenRead(path) - let mutable reading = true - while reading do - let! countRead = Async.AwaitTask(file.ReadAsync(buffer, 0, buffer.Length)) - reading <- countRead > 0 - } - - let bench() = - let tmp = "tmp" - async { - let sw = Stopwatch() - sw.Start() - for i = 1 to executionIterations do - do! writeFile tmp - do! readFile tmp - sw.Stop() - printfn "F# async (AwaitTask) completed in %d ms" sw.ElapsedMilliseconds - File.Delete(tmp) - } - -module AllocTests = +//[] +type TaskPerfTests() = + let bufferSize = 128 + let manyIterations = 10000 let syncTask() = Task.FromResult 100 + let syncTask_FSharpAsync() = async.Return 100 let asyncTask() = Task.Yield() - let tenBindSynchronous() = + let taskBuilder = TaskBuilderTasks.ContextSensitive.task + + let tenBindSync_Task() = task { let! res1 = syncTask() let! res2 = syncTask() @@ -195,7 +40,37 @@ module AllocTests = return res1 + res2 + res3 + res4 + res5 + res6 + res7 + res8 + res9 + res10 } - let tenBindAsynchronous() = + let tenBindSync_TaskBuilder() = + taskBuilder { + let! res1 = syncTask() + let! res2 = syncTask() + let! res3 = syncTask() + let! res4 = syncTask() + let! res5 = syncTask() + let! res6 = syncTask() + let! res7 = syncTask() + let! res8 = syncTask() + let! res9 = syncTask() + let! res10 = syncTask() + return res1 + res2 + res3 + res4 + res5 + res6 + res7 + res8 + res9 + res10 + } + + let tenBindSync_FSharpAsync() = + async { + let! res1 = syncTask_FSharpAsync() + let! res2 = syncTask_FSharpAsync() + let! res3 = syncTask_FSharpAsync() + let! res4 = syncTask_FSharpAsync() + let! res5 = syncTask_FSharpAsync() + let! res6 = syncTask_FSharpAsync() + let! res7 = syncTask_FSharpAsync() + let! res8 = syncTask_FSharpAsync() + let! res9 = syncTask_FSharpAsync() + let! res10 = syncTask_FSharpAsync() + return res1 + res2 + res3 + res4 + res5 + res6 + res7 + res8 + res9 + res10 + } + + let tenBindAsync_Task() = task { do! asyncTask() do! asyncTask() @@ -209,37 +84,148 @@ module AllocTests = do! asyncTask() } - let singleTask() = task { return 1 } - - let numIterations = 10000 - - let allocTestSyncBinds() = - for i in 1 .. numIterations do - tenBindSynchronous().Wait() - - let allocTestAsyncBinds() = - for i in 1 .. numIterations do - tenBindAsynchronous().Wait() - - let allocTestSingleTask() = - for i in 1 .. numIterations*100 do - singleTask().Wait() - - -[] -let main argv = - match argv.[0] with - | "allocSingleTask" -> AllocTests.allocTestSingleTask() - | "allocSyncBinds" -> AllocTests.allocTestSyncBinds() - | "allocAsyncBinds" -> AllocTests.allocTestAsyncBinds() - | _ -> - for (op, n) in [(Operation.WRITE_ASYNC, 5000); (Operation.FROM_RESULT, 300000)] do - RepeatedAsyncWriteCSharp.Operation <- op - RepeatedAsyncWriteCSharp.WriteIterations <- n - printfn "-------- operation = %A ------" op - RepeatedAsyncWriteCSharp.Bench().Wait() - RepeatedAsyncWrite.TaskVersion.bench().Wait() - RepeatedAsyncWrite.TaskBuilderVersion.bench().Wait() - RepeatedAsyncWrite.FSharpAsyncVersion.bench() |> Async.RunSynchronously - RepeatedAsyncWrite.FSharpAsyncAwaitTaskVersion.bench() |> Async.RunSynchronously - 0 \ No newline at end of file + let tenBindAsync_TaskBuilder() = + taskBuilder { + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + } + +(* + let tenBindAsync_FSharpAsync() = + taskBuilder { + do! Async.Sleep(0) + do! Async.Sleep(0) + do! Async.Sleep(0) + do! Async.Sleep(0) + do! Async.Sleep(0) + do! Async.Sleep(0) + do! Async.Sleep(0) + do! Async.Sleep(0) + do! Async.Sleep(0) + do! Async.Sleep(0) + } +*) + + let singleTask_Task() = + task { return 1 } + + let singleTask_TaskBuilder() = + taskBuilder { return 1 } + + let singleTask_FSharpAsync() = + async { return 1 } + + [] + member __.ManyWriteFile_CSharpAsync () = + TaskPerfCSharp.ManyWriteFileAsync().Wait(); + + [] + member __.ManyWriteFile_Task () = + let path = Path.GetTempFileName() + task { + let junk = Array.zeroCreate bufferSize + use file = File.Create(path) + for i = 1 to manyIterations do + do! file.WriteAsync(junk, 0, junk.Length) + } + |> fun t -> t.Wait() + File.Delete(path) + + [] + member __.ManyWriteFile_TaskBuilder () = + let path = Path.GetTempFileName() + TaskBuilderTasks.ContextSensitive.task { + let junk = Array.zeroCreate bufferSize + use file = File.Create(path) + for i = 1 to manyIterations do + do! file.WriteAsync(junk, 0, junk.Length) + } + |> fun t -> t.Wait() + File.Delete(path) + + [] + member __.ManyWriteFile_FSharpAsync () = + let path = Path.GetTempFileName() + async { + let junk = Array.zeroCreate bufferSize + use file = File.Create(path) + for i = 1 to manyIterations do + do! Async.AwaitTask(file.WriteAsync(junk, 0, junk.Length)) + } + |> Async.RunSynchronously + File.Delete(path) + + [] + member __.SyncBinds_CSharpAsync() = + for i in 1 .. manyIterations*100 do + TaskPerfCSharp.TenBindsSync_CSharp().Wait() + + [] + member __.SyncBinds_Task() = + for i in 1 .. manyIterations*100 do + tenBindSync_Task().Wait() + + [] + member __.SyncBinds_TaskBuilder() = + for i in 1 .. manyIterations*100 do + tenBindSync_TaskBuilder().Wait() + + [] + member __.SyncBinds_FSharpAsync() = + for i in 1 .. manyIterations*100 do + tenBindSync_FSharpAsync() |> Async.RunSynchronously |> ignore + + [] + member __.AsyncBinds_CSharpAsync() = + for i in 1 .. manyIterations do + TaskPerfCSharp.TenBindsAsync_CSharp().Wait() + + [] + member __.AsyncBinds_Task() = + for i in 1 .. manyIterations do + tenBindAsync_Task().Wait() + + [] + member __.AsyncBinds_TaskBuilder() = + for i in 1 .. manyIterations do + tenBindAsync_TaskBuilder().Wait() + + //[] + //member __.AsyncBinds_FSharpAsync() = + // for i in 1 .. manyIterations do + // tenBindAsync_FSharpAsync() |> Async.RunSynchronously + + [] + member __.SingleTask_CSharpAsync() = + for i in 1 .. manyIterations*500 do + TaskPerfCSharp.SingleTask_CSharp().Wait() + + [] + member __.SingleTask_Task() = + for i in 1 .. manyIterations*500 do + singleTask_Task().Wait() + + [] + member __.SingleTask_TaskBuilder() = + for i in 1 .. manyIterations*500 do + singleTask_TaskBuilder().Wait() + + [] + member __.SingleTask_FSharpAsync() = + for i in 1 .. manyIterations*500 do + singleTask_FSharpAsync() |> Async.RunSynchronously |> ignore + +module Main = + + [] + let main argv = + let summary = BenchmarkRunner.Run(); + 0 \ No newline at end of file diff --git a/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj b/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj index cb74e40b09f..1460872d5fd 100644 --- a/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj @@ -8,6 +8,7 @@ + From 71a9d5331f79b5295d9f17309aa7c47d18bc6206 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 13 May 2019 19:27:34 +0100 Subject: [PATCH 35/45] improve benchmarks --- tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs | 3 ++- tests/fsharp/perf/tasks/FS/TaskPerf.fs | 10 +++++----- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs index a62adab9017..dfee8494d23 100644 --- a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs +++ b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs @@ -26,6 +26,7 @@ public static async Task ManyWriteFileAsync() public static async Task AsyncTask() { + // This may be a bit unfair on C#, the F# one is doing just Task.Yield await Task.Yield(); return 100; } @@ -65,7 +66,7 @@ public static async Task TenBindsAsync_CSharp() return x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10; } - public static async Task SingleTask_CSharp() + public static async Task SingleSyncTask_CSharp() { return 1; } diff --git a/tests/fsharp/perf/tasks/FS/TaskPerf.fs b/tests/fsharp/perf/tasks/FS/TaskPerf.fs index dad140b665b..8169e3aa306 100644 --- a/tests/fsharp/perf/tasks/FS/TaskPerf.fs +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fs @@ -204,22 +204,22 @@ type TaskPerfTests() = // tenBindAsync_FSharpAsync() |> Async.RunSynchronously [] - member __.SingleTask_CSharpAsync() = + member __.SingleSyncTask_CSharpAsync() = for i in 1 .. manyIterations*500 do - TaskPerfCSharp.SingleTask_CSharp().Wait() + TaskPerfCSharp.SingleSyncTask_CSharp().Wait() [] - member __.SingleTask_Task() = + member __.SingleSyncTask_Task() = for i in 1 .. manyIterations*500 do singleTask_Task().Wait() [] - member __.SingleTask_TaskBuilder() = + member __.SingleSyncTask_TaskBuilder() = for i in 1 .. manyIterations*500 do singleTask_TaskBuilder().Wait() [] - member __.SingleTask_FSharpAsync() = + member __.SingleSyncTask_FSharpAsync() = for i in 1 .. manyIterations*500 do singleTask_FSharpAsync() |> Async.RunSynchronously |> ignore From 13bb169482760ae0442137b9783e1df357579675 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 14 May 2019 17:43:00 +0100 Subject: [PATCH 36/45] remove unwrap --- src/fsharp/FSharp.Core/tasks.fs | 33 +++++++++----------- tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs | 12 +++++-- 2 files changed, 24 insertions(+), 21 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index e6aa7a9d327..864ead1f502 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -11,6 +11,7 @@ // Updates: // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. +#if FSHARP_CORE namespace Microsoft.FSharp.Core.CompilerServices open System.Runtime.CompilerServices @@ -44,6 +45,7 @@ namespace Microsoft.FSharp.Core.CompilerServices [] let __return<'T> (_v: 'T) : 'T = failwith "__return should always be removed from compiled code" +#endif #if !BUILDING_WITH_LKG && !BUILD_FROM_SOURCE namespace Microsoft.FSharp.Control @@ -80,20 +82,20 @@ type TaskStateMachine<'T>() = inherit TaskStateMachine() let mutable resumptionPoint = 0 - let mutable methodBuilder = AsyncTaskMethodBuilder>() + let mutable methodBuilder = AsyncTaskMethodBuilder<'T>.Create() /// Proceed to the next state or raise an exception abstract Step : pc: int -> TaskStep<'T> [] - override sm.Await (awaiter, pc) = + override this.Await (awaiter, pc) = resumptionPoint <- pc - let mutable sm = sm + let mutable this = this let mutable awaiter = awaiter assert (not (isNull awaiter)) // Tell the builder to call us again when done. //Console.WriteLine("[{0}] AwaitUnsafeOnCompleted", sm.GetHashCode()) - methodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + methodBuilder.AwaitUnsafeOnCompleted(&awaiter, &this) interface IAsyncStateMachine with @@ -106,29 +108,22 @@ type TaskStateMachine<'T>() = //Console.WriteLine("[{0}] unboxing result", this.GetHashCode()) let res = unbox<'T>(this.Current) //Console.WriteLine("[{0}] SetResult {1}", this.GetHashCode(), res) - methodBuilder.SetResult(Task.FromResult res) + methodBuilder.SetResult(res) with exn -> //Console.WriteLine("[{0}] exception {1}", this.GetHashCode(), exn) methodBuilder.SetException exn - member __.SetStateMachine(_) = () // Doesn't really apply since we're a reference type. + member __.SetStateMachine(_machine) = + () + //methodBuilder.SetStateMachine(machine) // Doesn't apply since we're a reference type. [] member this.Start() = let mutable machine = this - try - //Console.WriteLine("[{0}] start", this.GetHashCode()) - methodBuilder.Start(&machine) - //Console.WriteLine("[{0}] unwrap", this.GetHashCode()) - methodBuilder.Task.Unwrap() - with exn -> - //Console.WriteLine("[{0}] start exception", this.GetHashCode()) - // Any exceptions should go on the task, rather than being thrown from this call. - // This matches C# behavior where you won't see an exception until awaiting the task, - // even if it failed before reaching the first "await". - let src = new TaskCompletionSource<_>() - src.SetException exn - src.Task + //Console.WriteLine("[{0}] start", this.GetHashCode()) + methodBuilder.Start(&machine) + //Console.WriteLine("[{0}] unwrap", this.GetHashCode()) + methodBuilder.Task [] diff --git a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs index dfee8494d23..627aec1f838 100644 --- a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs +++ b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs @@ -2,8 +2,6 @@ using System.Diagnostics; using System.IO; using System.Threading.Tasks; -using BenchmarkDotNet.Attributes; -using BenchmarkDotNet.Running; public static class TaskPerfCSharp { @@ -71,5 +69,15 @@ public static async Task SingleSyncTask_CSharp() return 1; } + public static async Task SingleSyncExceptionTask_CSharp() + { + throw (new System.Exception("fail")); + } +#if MAIN + public static void Main() { + var t = SingleSyncExceptionTask_CSharp(); + System.Console.WriteLine("t = {0}", t); + } +#endif } From 58cf03b6b3002b509ed4d1460ac0d6b7e4bddbb5 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 17 May 2019 15:33:16 +0100 Subject: [PATCH 37/45] struct state machines --- src/fsharp/FSharp.Core/tasks.fs | 265 ++++++++++--------- src/fsharp/FSharp.Core/tasks.fsi | 93 ++++--- src/fsharp/IlxGen.fs | 218 ++++++++++++++- src/fsharp/LowerCallsAndSeqs.fs | 138 +++++++--- src/fsharp/LowerCallsAndSeqs.fsi | 2 +- src/fsharp/TcGlobals.fs | 4 + tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs | 28 +- 7 files changed, 510 insertions(+), 238 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index 864ead1f502..7ab3c6c0045 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -34,11 +34,19 @@ namespace Microsoft.FSharp.Core.CompilerServices [] let __stateMachine<'T> (_x: 'T) : 'T = failwith "__stateMachine should always be removed from compiled code" + [] + // The template is written to a new struct type. Any mention of the template in any of the code is rewritten to that + // new struct type. Meth1 and Meth2 are used to implement the methods on the interface implemented by the struct type. + let __stateMachineStruct<'Template, 'Meth1, 'Meth2, 'Result> (_meth1: 'Meth1) (_meth2: 'Meth2) (_after: unit -> 'Result): 'Result = failwith "__stateMachineStruct should always be removed from compiled code" + [] let __newEntryPoint() : int = failwith "__newEntryPoint should always be removed from compiled code" [] - let __machine<'T> : 'T = failwith "__machine should always be removed from compiled code" + let __machine<'T> : 'T = failwith "__newEntryPoint should always be removed from compiled code" + + [] + let __machineAddr<'T> : byref<'T> = (# "ldnull throw" : byref<'T> #) [] let __entryPoint (_n: int) : unit = failwith "__entryPoint should always be removed from compiled code" @@ -67,64 +75,44 @@ open Microsoft.FSharp.Collections // Uses a struct-around-single-reference to allow future changes in representation (the representation is // not revealed in the signature) [] -type TaskStep<'T>(completed: bool) = +type TaskStep<'T, 'TOverall>(completed: bool) = member x.IsCompleted = completed -[] -type TaskStateMachine() = - member val Current : obj = null with get, set +[] +type TaskStateMachineTemplate<'T> = - /// Await the given awaiter and resume at the given entry point - abstract Await: awaiter : ICriticalNotifyCompletion * pc: int -> unit + [] + val mutable Current : obj -[] -type TaskStateMachine<'T>() = - inherit TaskStateMachine() - let mutable resumptionPoint = 0 + [] + val mutable ResumptionPoint : int - let mutable methodBuilder = AsyncTaskMethodBuilder<'T>.Create() - - /// Proceed to the next state or raise an exception - abstract Step : pc: int -> TaskStep<'T> + [] + val mutable MethodBuilder : AsyncTaskMethodBuilder<'T> - [] - override this.Await (awaiter, pc) = - resumptionPoint <- pc - let mutable this = this + interface IAsyncStateMachine with + member this.MoveNext() = failwith "template" + member this.SetStateMachine(_machine) = failwith "template" + +module Helpers = + let inline Start (sm: byref>) = + //Console.WriteLine("[{0}] start", sm.GetHashCode()) + sm.Current <- null + sm.ResumptionPoint <- 0 + sm.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() + sm.MethodBuilder.Start(&sm) + //Console.WriteLine("[{0}] unwrap", sm.GetHashCode()) + sm.MethodBuilder.Task + + let inline Await (sm: byref>) (awaiter, pc) = + sm.ResumptionPoint <- pc let mutable awaiter = awaiter assert (not (isNull awaiter)) // Tell the builder to call us again when done. //Console.WriteLine("[{0}] AwaitUnsafeOnCompleted", sm.GetHashCode()) - methodBuilder.AwaitUnsafeOnCompleted(&awaiter, &this) - - interface IAsyncStateMachine with - - [] - member this.MoveNext() = - try - //Console.WriteLine("[{0}] step from {1}", this.GetHashCode(), resumptionPoint) - let step = this.Step resumptionPoint - if step.IsCompleted then - //Console.WriteLine("[{0}] unboxing result", this.GetHashCode()) - let res = unbox<'T>(this.Current) - //Console.WriteLine("[{0}] SetResult {1}", this.GetHashCode(), res) - methodBuilder.SetResult(res) - with exn -> - //Console.WriteLine("[{0}] exception {1}", this.GetHashCode(), exn) - methodBuilder.SetException exn - - member __.SetStateMachine(_machine) = - () - //methodBuilder.SetStateMachine(machine) // Doesn't apply since we're a reference type. - - [] - member this.Start() = - let mutable machine = this - //Console.WriteLine("[{0}] start", this.GetHashCode()) - methodBuilder.Start(&machine) - //Console.WriteLine("[{0}] unwrap", this.GetHashCode()) - methodBuilder.Task + sm.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + let inline SetCurrent (sm: byref>) (v: obj) = sm.Current <- v [] module TaskHelpers = @@ -135,15 +123,15 @@ module TaskHelpers = // else agg :> Exception /// Used to return a value. - let inline ret<'T> (x : 'T) = - __machine.Current <- (box x) - TaskStep<'T>(true) + let inline ret<'T, 'TOverall> (x : 'T) = + Helpers.SetCurrent __machineAddr> (box x) + TaskStep<'T, 'TOverall>(true) - let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2 when (^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) > (x: ^Priority) (y: ^TaskLike) __expand_continuation = - ((^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) (x, y, __expand_continuation)) + let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2, 'TOverall when (^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) > (x: ^Priority) (y: ^TaskLike) __expand_continuation = + ((^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) (x, y, __expand_continuation)) - let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T when (^Priority or ^TaskLike): (static member CanReturnFrom: ^Priority * ^TaskLike -> TaskStep<'T>)> (x: ^Priority) (y: ^TaskLike) = - ((^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep<'T>) (x, y)) + let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T, 'TOverall when (^Priority or ^TaskLike): (static member CanReturnFrom: ^Priority * ^TaskLike -> TaskStep<'T, 'TOverall>)> (x: ^Priority) (y: ^TaskLike) = + ((^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep<'T, 'TOverall>) (x, y)) type TaskLikeBind<'TResult2> = // We put the output generic parameter up here at the class level, so it doesn't get subject to @@ -157,86 +145,109 @@ module TaskHelpers = // return x // } - static member inline GenericAwait< ^Awaitable, ^Awaiter, ^TResult1 + static member inline GenericAwait< ^Awaitable, ^Awaiter, ^TResult1, 'TOverall when ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) and ^Awaiter : (member GetResult : unit -> ^TResult1) > - (awaitable : ^Awaitable, __expand_continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = + (awaitable : ^Awaitable, __expand_continuation : ^TResult1 -> TaskStep<'TResult2, 'TOverall>) : TaskStep<'TResult2, 'TOverall> = let awaiter = (^Awaitable : (member GetAwaiter : unit -> ^Awaiter)(awaitable)) // get an awaiter from the awaitable let CONT = __newEntryPoint () if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately __entryPoint CONT __expand_continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter)) else - __machine.Await (awaiter, CONT) - __return (TaskStep<'TResult2>(false)) + Helpers.Await __machineAddr> ((awaiter :> ICriticalNotifyCompletion), CONT) + TaskStep<'TResult2, 'TOverall>(false) - static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 + static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1, 'TOverall when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) and ^Awaiter : (member GetResult : unit -> ^TResult1) > - (task : ^TaskLike, __expand_continuation : ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> = + (task : ^TaskLike, __expand_continuation : ^TResult1 -> TaskStep<'TResult2, 'TOverall>) : TaskStep<'TResult2, 'TOverall> = let awaitable = (^TaskLike : (member ConfigureAwait : bool -> ^Awaitable)(task, false)) - TaskLikeBind<'TResult2>.GenericAwait(awaitable, __expand_continuation) + TaskLikeBind<'TResult2>.GenericAwait< ^Awaitable, ^Awaiter, ^TResult1, 'TOverall>(awaitable, __expand_continuation) /// Special case of the above for `Task<'TResult1>`. Have to write this T by hand to avoid confusing the compiler /// trying to decide between satisfying the constraints with `Task` or `Task<'TResult1>`. - let inline bindTask (task : Task<'TResult1>) (__expand_continuation : 'TResult1 -> TaskStep<'TResult2>) = + let inline bindTask (task : Task<'TResult1>) (__expand_continuation : 'TResult1 -> TaskStep<'TResult2, 'TOverall>) = let CONT = __newEntryPoint() let awaiter = task.GetAwaiter() if awaiter.IsCompleted then __entryPoint CONT __expand_continuation (awaiter.GetResult()) else - __machine.Await (awaiter, CONT) - __return (TaskStep<'TResult2>(false)) + Helpers.Await __machineAddr> ((awaiter :> ICriticalNotifyCompletion), CONT) + TaskStep<'TResult2, 'TOverall>(false) /// Special case of the above for `Task<'TResult1>`, for the context-insensitive builder. /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method /// defined on the builder has fancy generic constraints on inp and T parameters. - let inline bindTaskConfigureFalse (task : Task<'TResult1>) (__expand_continuation : 'TResult1 -> TaskStep<'TResult2>) = + let inline bindTaskConfigureFalse (task : Task<'TResult1>) (__expand_continuation : 'TResult1 -> TaskStep<'TResult2, 'TOverall>) = let CONT = __newEntryPoint () let awaiter = task.ConfigureAwait(false).GetAwaiter() if awaiter.IsCompleted then __entryPoint CONT __expand_continuation (awaiter.GetResult()) else - __machine.Await (awaiter, CONT) - __return (TaskStep<'TResult2>(false)) + Helpers.Await __machineAddr> ((awaiter :> ICriticalNotifyCompletion), CONT) + TaskStep<'TResult2, 'TOverall>(false) // New style task builder. type TaskBuilder() = - member inline __.Delay(__expand_f : unit -> TaskStep<'T>) = __expand_f - - member inline __.Run(__expand_code : unit -> TaskStep<'T>) : Task<'T> = - (__stateMachine - { new TaskStateMachine<'T>() with - member __.Step pc = __jumptable pc __expand_code }).Start() + member inline __.Delay(__expand_f : unit -> TaskStep<'T, 'TOverall>) = __expand_f + + member inline __.Run(__expand_code : unit -> TaskStep<'T, 'T>) : Task<'T> = + __stateMachineStruct, (unit -> unit), (IAsyncStateMachine -> unit), Task<'T>> + // MoveNext + (fun () -> + __jumptable + (let v = __machineAddr> in v.ResumptionPoint) + (fun () -> + try + //Console.WriteLine("[{0}] step from {1}", sm.GetHashCode(), resumptionPoint) + let ``__machine_step$cont`` = __expand_code() + let v = __machineAddr> + if ``__machine_step$cont``.IsCompleted then + //Console.WriteLine("[{0}] unboxing result", sm.GetHashCode()) + let res = unbox<'T>(v.Current) + //Console.WriteLine("[{0}] SetResult {1}", sm.GetHashCode(), res) + v.MethodBuilder.SetResult(res) + with exn -> + //Console.WriteLine("[{0}] exception {1}", sm.GetHashCode(), exn) + let v = __machineAddr> + v.MethodBuilder.SetException exn)) + // SetStateMachine + (fun machine -> + let v = __machineAddr> + v.MethodBuilder.SetStateMachine(machine)) + // Start + (fun () -> Helpers.Start __machineAddr>) + /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. - member inline __.Zero() : TaskStep = - __machine.Current <- (box ()) - TaskStep(true) + member inline __.Zero() : TaskStep = + Helpers.SetCurrent __machineAddr> (box ()) + TaskStep(true) - member inline __.Return (x: 'T) : TaskStep<'T> = - __machine.Current <- (box x) - TaskStep<'T>(true) + member inline __.Return (x: 'T) : TaskStep<'T, 'TOverall> = + Helpers.SetCurrent __machineAddr> (box x) + TaskStep<'T, 'TOverall>(true) /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. - member inline __.Combine(``__machine_step$cont``: TaskStep, __expand_task2: unit -> TaskStep<'T>) : TaskStep<'T> = + member inline __.Combine(``__machine_step$cont``: TaskStep, __expand_task2: unit -> TaskStep<'T, 'TOverall>) : TaskStep<'T, 'TOverall> = if ``__machine_step$cont``.IsCompleted then __expand_task2() else - TaskStep<'T>(``__machine_step$cont``.IsCompleted) + TaskStep<'T, 'TOverall>(``__machine_step$cont``.IsCompleted) /// Builds a step that executes the body while the condition predicate is true. - member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskStep) : TaskStep = + member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskStep) : TaskStep = let mutable completed = true while completed && __expand_condition() do completed <- false @@ -244,13 +255,13 @@ type TaskBuilder() = let ``__machine_step$cont`` = __expand_body () // If we make it to the assignment we prove we've made a step completed <- ``__machine_step$cont``.IsCompleted - __machine.Current <- (box ()) - TaskStep(completed) + Helpers.SetCurrent __machineAddr> (box ()) + TaskStep(completed) /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - member inline __.TryWith(__expand_body : unit -> TaskStep<'T>, __expand_catch : exn -> TaskStep<'T>) : TaskStep<'T> = - let mutable completed = TaskStep<'T>(false) + member inline __.TryWith(__expand_body : unit -> TaskStep<'T, 'TOverall>, __expand_catch : exn -> TaskStep<'T, 'TOverall>) : TaskStep<'T, 'TOverall> = + let mutable completed = TaskStep<'T, 'TOverall>(false) let mutable caught = false let mutable savedExn = Unchecked.defaultof<_> try @@ -273,8 +284,8 @@ type TaskBuilder() = /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). - member inline __.TryFinally(__expand_body: unit -> TaskStep<'T>, compensation : unit -> unit) : TaskStep<'T> = - let mutable completed = TaskStep<'T>(false) + member inline __.TryFinally(__expand_body: unit -> TaskStep<'T, 'TOverall>, compensation : unit -> unit) : TaskStep<'T, 'TOverall> = + let mutable completed = TaskStep<'T, 'TOverall>(false) try let ``__machine_step$cont`` = __expand_body () // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with @@ -288,27 +299,27 @@ type TaskBuilder() = compensation() completed - member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> TaskStep<'T>) = + member inline builder.Using(disp : #IDisposable, __expand_body : #IDisposable -> TaskStep<'T, 'TOverall>) = // A using statement is just a try/finally with the finally block disposing if non-null. - this.TryFinally( + builder.TryFinally( (fun () -> __expand_body disp), (fun () -> if not (isNull (box disp)) then disp.Dispose())) - member inline this.For(sequence : seq<'T>, __expand_body : 'T -> TaskStep) : TaskStep = + member inline builder.For(sequence : seq<'T>, __expand_body : 'T -> TaskStep) : TaskStep = // A for loop is just a using statement on the sequence's enumerator... - this.Using (sequence.GetEnumerator(), + builder.Using (sequence.GetEnumerator(), // ... and its body is a while loop that advances the enumerator and runs the body on each element. - (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) + (fun e -> builder.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) - member inline __.ReturnFrom (task: Task<'T>) : TaskStep<'T> = + member inline __.ReturnFrom (task: Task<'T>) : TaskStep<'T, 'TOverall> = let CONT = __newEntryPoint () if task.IsCompleted then __entryPoint CONT - __machine.Current <- box (task.GetAwaiter().GetResult()) - TaskStep<'T>(true) + Helpers.SetCurrent __machineAddr> (box (task.GetAwaiter().GetResult())) + TaskStep<'T, 'TOverall>(true) else - __machine.Await(task.GetAwaiter(), CONT) - __return (TaskStep<'T>(false)) + Helpers.Await __machineAddr> ((task.GetAwaiter() :> ICriticalNotifyCompletion), CONT) + TaskStep<'T, 'TOverall>(false) [] module ContextSensitiveTasks = @@ -323,39 +334,39 @@ module ContextSensitiveTasks = interface IPriority3 // Give the type arguments explicitly to make it match the signature precisely - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter , 'TOverall when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> ^TResult1)>(_priority: IPriority2, taskLike : ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> - = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (taskLike, __expand_continuation) + and ^Awaiter: (member GetResult: unit -> ^TResult1)>(_priority: IPriority2, taskLike : ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> + = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1, 'TOverall> (taskLike, __expand_continuation) - static member inline CanBind (_priority: IPriority1, task: Task<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + static member inline CanBind (_priority: IPriority1, task: Task<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = bindTask task __expand_continuation - static member inline CanBind (_priority: IPriority1, computation : Async<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + static member inline CanBind (_priority: IPriority1, computation : Async<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = bindTask (Async.StartAsTask computation) __expand_continuation // Give the type arguments explicitly to make it match the signature precisely - static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T + static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T, 'TOverall when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T)> - (_priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T > - = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T> (taskLike, ret< ^T >) + (_priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T, 'TOverall > + = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T, 'TOverall> (taskLike, ret< ^T, 'TOverall >) static member inline CanReturnFrom (_priority: IPriority1, computation : Async<'T>) - = bindTask (Async.StartAsTask computation) (ret< 'T >) : TaskStep<'T> + = bindTask (Async.StartAsTask computation) (ret< 'T, 'TOverall >) : TaskStep<'T, 'TOverall> type TaskBuilder with - member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> - (task: ^TaskLike, __expand_continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> - = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> Unchecked.defaultof task __expand_continuation + member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 , 'TOverall + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>)> + (task: ^TaskLike, __expand_continuation: ^TResult1 -> TaskStep<'TResult2, 'TOverall>) : TaskStep<'TResult2, 'TOverall> + = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2, 'TOverall> Unchecked.defaultof task __expand_continuation - member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> - = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> Unchecked.defaultof task + member inline builder.ReturnFrom< ^TaskLike, 'T, 'TOverall when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T, 'TOverall>) > (task: ^TaskLike) : TaskStep<'T, 'TOverall> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T, 'TOverall> Unchecked.defaultof task module ContextInsensitiveTasks = @@ -367,25 +378,25 @@ module ContextInsensitiveTasks = interface IPriority2 interface IPriority3 - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter, 'TOverall when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority3, taskLike: ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> - = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1> (taskLike, __expand_continuation) + and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority3, taskLike: ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> + = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1, 'TOverall> (taskLike, __expand_continuation) - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter , 'TOverall when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) - and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority2, configurableTaskLike: ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> - = TaskLikeBind<'TResult2>.GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1> (configurableTaskLike, __expand_continuation) + and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority2, configurableTaskLike: ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> + = TaskLikeBind<'TResult2>.GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1, 'TOverall> (configurableTaskLike, __expand_continuation) - static member inline CanBind (_priority :IPriority1, task: Task<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + static member inline CanBind (_priority :IPriority1, task: Task<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = bindTaskConfigureFalse task __expand_continuation - static member inline CanBind (_priority: IPriority1, computation : Async<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2>)) : TaskStep<'TResult2> + static member inline CanBind (_priority: IPriority1, computation : Async<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = bindTaskConfigureFalse (Async.StartAsTask computation) __expand_continuation (* @@ -410,12 +421,12 @@ module ContextInsensitiveTasks = *) type TaskBuilder with - member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>)> - (task: ^TaskLike, __expand_continuation: ^TResult1 -> TaskStep<'TResult2>) : TaskStep<'TResult2> - = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2> Unchecked.defaultof task __expand_continuation + member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 , 'TOverall + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>)> + (task: ^TaskLike, __expand_continuation: ^TResult1 -> TaskStep<'TResult2, 'TOverall>) : TaskStep<'TResult2, 'TOverall> + = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2, 'TOverall> Unchecked.defaultof task __expand_continuation (* member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> - = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> builder.TaskStateMachine Unchecked.defaultof task + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> builder.TaskStateMachineTemplate Unchecked.defaultof task *) #endif diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index c92c9abaf64..4cfcab4d706 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -21,7 +21,10 @@ namespace Microsoft.FSharp.Core.CompilerServices val __jumptable : int -> (unit -> 'T) -> 'T [] - val __stateMachine : 'T -> 'T + val __stateMachineStruct<'Template, 'Meth1, 'Meth2, 'Result> : meth1: 'Meth1 -> meth2: 'Meth2 -> after: (unit -> 'Result) -> 'Result + + [] + val __stateMachine<'T> : _obj: 'T -> 'T [] val __newEntryPoint: unit -> int @@ -29,6 +32,9 @@ namespace Microsoft.FSharp.Core.CompilerServices [] val __machine<'T> : 'T + [] + val __machineAddr<'T> : byref<'T> + [] val __entryPoint: int -> unit @@ -48,43 +54,42 @@ open Microsoft.FSharp.Collections /// Represents the result of a computation, a value of true indicates completion [] -type TaskStep<'T> = - new : completed: bool -> TaskStep<'T> +type TaskStep<'T, 'TOverall> = + new : completed: bool -> TaskStep<'T, 'TOverall> member IsCompleted: bool -[] -type TaskStateMachine = - new : unit -> TaskStateMachine - member Current : obj with get, set - abstract Await: awaiter : ICriticalNotifyCompletion * pc: int -> unit - -[] -type TaskStateMachine<'T> = - inherit TaskStateMachine - new : unit -> TaskStateMachine<'T> - abstract Step : pc: int -> TaskStep<'T> +[] +/// This is used by the compiler as a template for creating state machine structs +type TaskStateMachineTemplate<'T> = + [] + val mutable Current : obj + + [] + val mutable ResumptionPoint : int + + [] + val mutable MethodBuilder : AsyncTaskMethodBuilder<'T> + interface IAsyncStateMachine - override Await: awaiter : ICriticalNotifyCompletion * pc: int -> unit - member Start: unit -> Task<'T> type TaskBuilder = new: unit -> TaskBuilder - member inline Combine: task1: TaskStep * task2: (unit -> TaskStep<'T>) -> TaskStep<'T> - member inline Delay: f: (unit -> TaskStep<'T>) -> (unit -> TaskStep<'T>) - member inline For: sequence: seq<'T> * body: ('T -> TaskStep) -> TaskStep - member inline Return: x: 'T -> TaskStep<'T> - member inline ReturnFrom: task: Task<'T> -> TaskStep<'T> - member inline Run: code: (unit -> TaskStep<'T>) -> Task<'T> - member inline TryFinally: body: (unit -> TaskStep<'T>) * fin: (unit -> unit) -> TaskStep<'T> - member inline TryWith: body: (unit -> TaskStep<'T>) * catch: (exn -> TaskStep<'T>) -> TaskStep<'T> - member inline Using: disp: 'Resource * body: ('Resource -> TaskStep<'T>) -> TaskStep<'T> when 'Resource :> IDisposable - member inline While: condition: (unit -> bool) * body: (unit -> TaskStep) -> TaskStep - member inline Zero: unit -> TaskStep + member inline Combine: task1: TaskStep * task2: (unit -> TaskStep<'T, 'TOverall>) -> TaskStep<'T, 'TOverall> + member inline Delay: f: (unit -> TaskStep<'T, 'TOverall>) -> (unit -> TaskStep<'T, 'TOverall>) + member inline For: sequence: seq<'T> * body: ('T -> TaskStep) -> TaskStep + member inline Return: x: 'T -> TaskStep<'T, 'TOverall> + member inline ReturnFrom: task: Task<'T> -> TaskStep<'T, 'TOverall> + member inline Run: code: (unit -> TaskStep<'T, 'T>) -> Task<'T> + member inline TryFinally: body: (unit -> TaskStep<'T, 'TOverall>) * fin: (unit -> unit) -> TaskStep<'T, 'TOverall> + member inline TryWith: body: (unit -> TaskStep<'T, 'TOverall>) * catch: (exn -> TaskStep<'T, 'TOverall>) -> TaskStep<'T, 'TOverall> + member inline Using: disp: 'Resource * body: ('Resource -> TaskStep<'T, 'TOverall>) -> TaskStep<'T, 'TOverall> when 'Resource :> IDisposable + member inline While: condition: (unit -> bool) * body: (unit -> TaskStep) -> TaskStep + member inline Zero: unit -> TaskStep [] module ContextSensitiveTasks = - /// Builds a `System.Threading.Tasks.Task<'T>` similarly to a C# async/await method. + /// Builds a `System.Th`reading.Tasks.Task<'T>` similarly to a C# async/await method. /// Use this like `task { let! taskResult = someTask(); return taskResult.ToString(); }`. val task : TaskBuilder @@ -96,37 +101,37 @@ module ContextSensitiveTasks = interface IPriority3 /// Provides evidence that task-like types can be used in 'bind' in a task computation expression - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > - : priority: IPriority2 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep< 'TResult2>) -> TaskStep< 'TResult2> + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter, 'TOverall > + : priority: IPriority2 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep< 'TResult2, 'TOverall>) -> TaskStep< 'TResult2, 'TOverall> when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression - static member inline CanBind: priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> /// Provides evidence that F# Async computations can be used in 'bind' in a task computation expression - static member inline CanBind: priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> /// Provides evidence that task-like types can be used in 'return' in a task workflow - static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T> : priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T > + static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T, 'TOverall> : priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T, 'TOverall > when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T) /// Provides evidence that F# Async computations can be used in 'return' in a task computation expression - static member inline CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T> + static member inline CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T, 'TOverall> type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics - member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult > - when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult>) + member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult, 'TOverall > + when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult, 'TOverall>) module ContextInsensitiveTasks = @@ -145,14 +150,14 @@ module ContextInsensitiveTasks = interface IPriority3 /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter > : priority: IPriority3 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter, 'TOverall > : priority: IPriority3 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression - static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter > : priority: IPriority2 * taskLike: ^TaskLike * k: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter, 'TOverall > : priority: IPriority2 * taskLike: ^TaskLike * k: (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion @@ -160,10 +165,10 @@ module ContextInsensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression - static member inline CanBind: priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> /// Provides evidence that F# async computations can be used in 'bind' in a task computation expression - static member inline CanBind: priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> + static member inline CanBind: priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> (* /// Provides evidence that types following the "awaitable" pattern can be used in 'return!' in a task computation expression @@ -188,8 +193,8 @@ module ContextInsensitiveTasks = type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2> - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2>) -> TaskStep<'TResult2>) + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) (* /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 489bd98fdf2..b2e9edf378d 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -378,7 +378,19 @@ let ComputeTypeAccess (tref: ILTypeRef) hidden = /// Indicates how type parameters are mapped to IL type variables [] -type TypeReprEnv(reprs: Map, count: int) = +type TypeReprEnv(reprs: Map, count: int, templateReplacement: (TyconRef * ILType * TyparInst) option) = + + /// Get the template replacement information used when using struct types for state machines based on a "template" struct + /// + /// When generating code for tasks, the mapping is + /// TaskStateMachineTemplate --> NewStructClosureType + /// When processing the copied metadata of TaskStateMachineTemplate: + /// TaskStateMachineTemplate<...> --> NewStructClosureType + /// T --> int32 + /// AsyncTaskMethodBuilder --> AsyncTaskMethodBuilder + member __.TemplateReplacement = templateReplacement + + member __.WithTemplateReplacement(tcref, ilty, tpinst) = TypeReprEnv(reprs, count, Some (tcref, ilty, tpinst)) /// Lookup a type parameter member __.Item (tp: Typar, m: range) = @@ -392,7 +404,7 @@ type TypeReprEnv(reprs: Map, count: int) = /// then it is ignored, since it doesn't corespond to a .NET type parameter. member tyenv.AddOne (tp: Typar) = if IsNonErasedTypar tp then - TypeReprEnv(reprs.Add (tp.Stamp, uint16 count), count + 1) + TypeReprEnv(reprs.Add (tp.Stamp, uint16 count), count + 1, templateReplacement) else tyenv @@ -405,7 +417,7 @@ type TypeReprEnv(reprs: Map, count: int) = /// Get the empty environment, where no type parameters are in scope. static member Empty = - TypeReprEnv(count = 0, reprs = Map.empty) + TypeReprEnv(count = 0, reprs = Map.empty, templateReplacement = None) /// Get the environment for a fixed set of type parameters static member ForTypars tps = @@ -486,10 +498,12 @@ and GenILTyAppAux amap m tyenv (tref, boxity, ilTypeOpt) tinst = | Some ilType -> ilType // monomorphic types include a cached ilType to avoid reallocation of an ILType node -and GenNamedTyAppAux (amap: ImportMap) m tyenv ptrsOK tcref tinst = +and GenNamedTyAppAux (amap: ImportMap) m (tyenv: TypeReprEnv) ptrsOK tcref tinst = let g = amap.g + match tyenv.TemplateReplacement with + | Some (tcref2, ilty, _) when tyconRefEq g tcref tcref2 -> ilty + | _ -> let tinst = DropErasedTyargs tinst - // See above note on ptrsOK if ptrsOK = PtrTypesOK && tyconRefEq g tcref g.nativeptr_tcr && (freeInTypes CollectTypars tinst).FreeTypars.IsEmpty then GenNamedTyAppAux amap m tyenv ptrsOK g.ilsigptr_tcr tinst @@ -655,9 +669,18 @@ let GenFieldSpecForStaticField (isInteractive, g, ilContainerTy, vspec: Val, nm, let ilFieldContainerTy = mkILTyForCompLoc (CompLocForInitClass cloc) mkILFieldSpecInTy (ilFieldContainerTy, fieldName, ilTy) -let GenRecdFieldRef m cenv tyenv (rfref: RecdFieldRef) tyargs = - let tyenvinner = TypeReprEnv.ForTycon rfref.Tycon - mkILFieldSpecInTy(GenTyApp cenv.amap m tyenv rfref.TyconRef.CompiledRepresentation tyargs, + +let GenRecdFieldRef m cenv (tyenv: TypeReprEnv) (rfref: RecdFieldRef) tyargs = + // Fixup references to the fields of a struct machine template + match tyenv.TemplateReplacement with + | Some (tcref2, ilty, inst) when tyconRefEq cenv.g rfref.TyconRef tcref2 -> + mkILFieldSpecInTy(ilty, + ComputeFieldName rfref.Tycon rfref.RecdField, + GenType cenv.amap m tyenv (instType inst rfref.RecdField.FormalType)) + | _ -> + let tyenvinner = TypeReprEnv.ForTycon rfref.Tycon + let ilty = GenTyApp cenv.amap m tyenv rfref.TyconRef.CompiledRepresentation tyargs + mkILFieldSpecInTy(ilty, ComputeFieldName rfref.Tycon rfref.RecdField, GenType cenv.amap m tyenvinner rfref.RecdField.FormalType) @@ -922,6 +945,8 @@ let AddStorageForVal (g: TcGlobals) (v, s) eenv = let AddStorageForLocalVals g vals eenv = List.foldBack (fun (v, s) acc -> AddStorageForVal g (v, notlazy s) acc) vals eenv +let AddTemplateReplacement eenv (tcref, ilty, inst) = { eenv with tyenv = eenv.tyenv.WithTemplateReplacement (tcref, ilty, inst) } + //-------------------------------------------------------------------------- // Lookup eenv //-------------------------------------------------------------------------- @@ -2164,8 +2189,11 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = | None -> match LowerCallsAndSeqs.ConvertStateMachineExprToObject g expr with - | Some objExpr -> - GenExpr cenv cgbuf eenv sp objExpr sequel + | Some res -> + match res with + | Choice1Of2 objExpr -> GenExpr cenv cgbuf eenv sp objExpr sequel + | Choice2Of2 (structTy, stateVars, methodBodyExprWithJumpTable, meth2Expr, machineAddrVar, startExpr) -> + GenStructStateMachine cenv cgbuf eenv (structTy, methodBodyExprWithJumpTable, stateVars, meth2Expr, machineAddrVar, startExpr) sequel | None -> match expr with @@ -4077,6 +4105,174 @@ and GenObjectMethod cenv eenvinner (cgbuf: CodeGenBuffer) useMethodImpl tmethod let mdef = mdef.With(customAttrs = mkILCustomAttrs ilAttribs) [(useMethodImpl, methodImplGenerator, methTyparsOfOverridingMethod), mdef] +and GenStructStateMachine cenv cgbuf eenvouter (templateStructTy, moveNextExpr, stateVars, setStateMachineExpr, machineAddrVar, startExpr) sequel = + + let m = startExpr.Range + let g = cenv.g + + let stateVarsSet = stateVars |> List.map (fun vref -> vref.Deref) |> Zset.ofList valOrder + + // State vars are only populated for state machine objects made via `__stateMachine` and LowerCallsAndSeqs. + // + // Like in GenSequenceExpression we pretend any stateVars are bound in the outer environment. This prevents the being + // considered true free variables that need to be passed to the constructor. + let eenvouter = eenvouter |> AddStorageForLocalVals g (stateVars |> List.map (fun v -> v.Deref, Local(0, false, None))) + + // Find the free variables of the closure, to make them further fields of the object. + // + // Note, the 'let' bindings for the stateVars have already been transformed to 'set' expressions, and thus the stateVars are now + // free variables of the expression. + let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m false None eenvouter moveNextExpr + + let cloAttribs = cloinfo.cloAttribs + let cloFreeVars = cloinfo.cloFreeVars + //let ilCloLambdas = cloinfo.ilCloLambdas + //let cloName = cloinfo.cloName + + //let ilxCloSpec = cloinfo.cloSpec + let ilCloFreeVars = cloinfo.cloILFreeVars + let ilCloGenericFormals = cloinfo.cloILGenericParams + assert (isNil cloinfo.localTypeFuncDirectILGenericParams) + let ilCloGenericActuals = cloinfo.cloSpec.GenericArgs + //let ilCloRetTy = cloinfo.cloILFormalRetTy + let ilCloTypeRef = cloinfo.cloSpec.TypeRef + let ilCloTy = mkILValueTy ilCloTypeRef ilCloGenericActuals + + // The closure implements what ever interfaces the template implements. TODO: currently limiting to precisely 1 for tasks + let interfaceTy = GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g cenv.amap m templateStructTy |> List.head + // genMethodAndOptionalMethodImpl tmethod true + + let ilInterfaceTy = GenType cenv.amap m eenvinner.tyenv interfaceTy + let attrs = GenAttrs cenv eenvinner cloAttribs + + let super = g.iltyp_ValueType + + let templateTyconRef, templateTypeArgs = destAppTy g templateStructTy + let templateTypeInst = mkTyconRefInst templateTyconRef templateTypeArgs + let eenvinner = AddTemplateReplacement eenvinner (templateTyconRef, ilCloTy, templateTypeInst) + + //let cloInfo = + // { cloFreeVars=ilCloFreeVars + // cloStructure=ilCloLambdas + // cloCode=notlazy ilCtorBody } + + let infoReader = InfoReader.InfoReader(g, cenv.amap) + let moveNextMethod = + let ilCode = CodeGenMethodForExpr cenv cgbuf.mgbuf (SPSuppress, [], "MoveNext", eenvinner, 1, moveNextExpr, discardAndReturnVoid) + mkILNonGenericVirtualMethod("MoveNext", ILMemberAccess.Public, [], mkILReturn ILType.Void, MethodBody.IL ilCode) + + let setStateMachineMethod = + let v, e = match setStateMachineExpr with Expr.Lambda (_, _, _, [v], e, _, _) -> v,e | _ -> failwith "invalid setStateMachineExpr, expected a lambda of one var" + let meth = + InfoReader.TryFindIntrinsicMethInfo infoReader m AccessibilityLogic.AccessorDomain.AccessibleFromSomewhere "SetStateMachine" interfaceTy + |> List.head + let argTys = meth.GetParamTypes(cenv.amap, m, []) + let ilArgTys = argTys |> List.concat |> GenTypes cenv.amap m eenvinner.tyenv + let eenvinner = AddStorageForLocalVals g [(v, Arg 1)] eenvinner + let ilCode = CodeGenMethodForExpr cenv cgbuf.mgbuf (SPSuppress, [], "SetStateMachine", eenvinner, 1, e, discardAndReturnVoid) + let ilParams = ilArgTys |> List.map (fun ty -> mkILParamNamed("machine", ty)) + mkILNonGenericVirtualMethod("SetStateMachine", ILMemberAccess.Public, ilParams, mkILReturn ILType.Void, MethodBody.IL ilCode) + + let mdefs = [moveNextMethod; setStateMachineMethod] + + let moveNextMethImpl = + let ilOverrideMethRef = mkILMethRef(ilInterfaceTy.TypeRef, ILCallingConv.Instance, "MoveNext", 0, [], ILType.Void) + let ilOverrideBy = mkILInstanceMethSpecInTy(ilCloTy, "MoveNext", [], ILType.Void, []) + { Overrides = OverridesSpec(ilOverrideMethRef, ilInterfaceTy) + OverrideBy = ilOverrideBy } + + let setStateMachineMethImpl = + let ilOverrideMethRef = mkILMethRef(ilInterfaceTy.TypeRef, ILCallingConv.Instance, "SetStateMachine", 0, setStateMachineMethod.ParameterTypes, ILType.Void) + let ilOverrideBy = mkILInstanceMethSpecInTy(ilCloTy, "SetStateMachine", setStateMachineMethod.ParameterTypes, ILType.Void, []) + { Overrides = OverridesSpec(ilOverrideMethRef, ilInterfaceTy) + OverrideBy = ilOverrideBy } + + let mimpls = [moveNextMethImpl; setStateMachineMethImpl] + + let fdefs = + [ // Fields copied from the template struct + for templateFld in infoReader.GetRecordOrClassFieldsOfType (None, AccessibilityLogic.AccessorDomain.AccessibleFromSomewhere, m, templateStructTy) do + let access = ComputeMemberAccess false + let fty = GenType cenv.amap m eenvinner.tyenv templateFld.FieldType + let fdef = + ILFieldDef(name = templateFld.Name, fieldType = fty, attributes = enum 0, data = None, literalValue = None, offset = None, marshal = None, customAttrs = mkILCustomAttrs []) + .WithAccess(access) + .WithStatic(false) + yield fdef + + // Fields for captured variables + for ilCloFreeVar in ilCloFreeVars do + let access = ComputeMemberAccess false + let fdef = + ILFieldDef(name = ilCloFreeVar.fvName, fieldType = ilCloFreeVar.fvType, attributes = enum 0, + data = None, literalValue = None, offset = None, marshal = None, customAttrs = mkILCustomAttrs []) + .WithAccess(access) + .WithStatic(false) + yield fdef ] + + let cloTypeDef = + ILTypeDef(name = ilCloTypeRef.Name, + layout = ILTypeDefLayout.Auto, + attributes = enum 0, + genericParams = ilCloGenericFormals, + customAttrs = mkILCustomAttrs(attrs @ [mkCompilationMappingAttr g (int SourceConstructFlags.Closure) ]), + fields = mkILFields fdefs, + events= emptyILEvents, + properties = emptyILProperties, + methods= mkILMethods mdefs, + methodImpls= mkILMethodImpls mimpls, + nestedTypes=emptyILTypeDefs, + implements = [ilInterfaceTy], + extends= Some super, + securityDecls= emptyILSecurityDecls) + .WithSealed(true) + .WithSpecialName(true) + .WithAccess(ComputeTypeAccess ilCloTypeRef true) + .WithLayout(ILTypeDefLayout.Auto) + .WithEncoding(ILDefaultPInvokeEncoding.Auto) + .WithInitSemantics(ILTypeInit.BeforeField) + + cgbuf.mgbuf.AddTypeDef(ilCloTypeRef, cloTypeDef, false, false, None) + + CountClosure() + LocalScope "machine" cgbuf (fun scopeMarks -> + let ilMachineAddrTy = ILType.Byref ilCloTy + + // The local for the state machine + let locIdx, realloc, _ = AllocLocal cenv cgbuf eenvinner true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName ("machine", m), ilCloTy, false) scopeMarks + + // The local for the state machine address + let locIdx2, _realloc2, _ = AllocLocal cenv cgbuf eenvinner true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName (machineAddrVar.DisplayName, m), ILType.Byref ilCloTy, false) scopeMarks + + // Zero-initialize the machine if necessary + if realloc then + EmitInitLocal cgbuf ilCloTy locIdx + + // Initialize the address-of-machine local + CG.EmitInstr cgbuf (pop 0) (Push [ ilMachineAddrTy ]) (I_ldloca (uint16 locIdx) ) + CG.EmitInstr cgbuf (pop 1) (Push [ ]) (I_stloc (uint16 locIdx2) ) + + let eenvinner = AddStorageForLocalVals g [(machineAddrVar, Local (locIdx2, realloc, None)) ] eenvinner + + // Initialize the closure variables + for (fv, ilv) in Seq.zip cloFreeVars cloinfo.cloILFreeVars do + if stateVarsSet.Contains fv then + // zero-initialize the state var + if realloc then + CG.EmitInstr cgbuf (pop 0) (Push [ ilMachineAddrTy ]) (I_ldloc (uint16 locIdx2) ) + GenDefaultValue cenv cgbuf eenvouter (fv.Type, m) + CG.EmitInstr cgbuf (pop 0) (Push [ ilMachineAddrTy ]) (mkNormalStfld (mkILFieldSpecInTy (ilCloTy, ilv.fvName, ilv.fvType))) + else + // initialize the captured var + CG.EmitInstr cgbuf (pop 0) (Push [ ilMachineAddrTy ]) (I_ldloc (uint16 locIdx2) ) + GenGetLocalVal cenv cgbuf eenvouter m fv None + CG.EmitInstr cgbuf (pop 0) (Push [ ilMachineAddrTy ]) (mkNormalStfld (mkILFieldSpecInTy (ilCloTy, ilv.fvName, ilv.fvType))) + + // Generate the start expression - eenvinner is used as it contains the binding for machineAddrVar + GenExpr cenv cgbuf eenvinner SPSuppress startExpr sequel + + ) + and GenObjectExpr cenv cgbuf eenvouter objExpr (baseType, baseValOpt, basecall, overrides, interfaceImpls, stateVars: ValRef list, m) sequel = let g = cenv.g @@ -4488,7 +4684,7 @@ and GetIlxClosureInfo cenv m isLocalTypeFunc selfv eenvouter expr = match expr with | Expr.Lambda (_, _, _, _, _, _, returnTy) | Expr.TyLambda (_, _, _, _, returnTy) -> returnTy | Expr.Obj (_, ty, _, _, _, _, _, _) -> ty - | _ -> failwith "GetIlxClosureInfo: not a lambda expression" + | _ -> tyOfExpr g expr //failwith "GetIlxClosureInfo: not a lambda expression" // Determine the structure of the closure. We do this before analyzing free variables to // determine the taken argument names. diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 350c1c77e88..191eca2ea38 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -808,11 +808,16 @@ type StateMachineConversionFirstPhaseResult = -let (|StateMachineExpr|_|) g expr = +let (|RefStateMachineExpr|_|) g expr = match expr with | ValApp g g.cgh_stateMachine_vref (_, [e], _m) -> Some e | _ -> None +let (|StructStateMachineExpr|_|) g expr = + match expr with + | ValApp g g.cgh_stateMachineStruct_vref ([templateStructTy; _ty2; _ty3; _afterTy], [meth1Expr; meth2Expr; afterExpr], _m) -> Some (templateStructTy, meth1Expr, meth2Expr, afterExpr) + | _ -> None + let (|NewEntryPointExpr|_|) g expr = match expr with | ValApp g g.cgh_newEntryPoint_vref (_, [_], _m) -> Some () @@ -828,6 +833,11 @@ let (|MachineExpr|_|) g expr = | ValApp g g.cgh_machine_vref ([ty], _, m) -> Some (ty, m) | _ -> None +let (|MachineAddrExpr|_|) g expr = + match expr with + | ValApp g g.cgh_machineAddr_vref ([ty], _, m) -> Some (ty, m) + | _ -> None + let (|EntryPointExpr|_|) g expr = match expr with | ValApp g g.cgh_entryPoint_vref (_, [e], m) -> Some (e, m) @@ -838,7 +848,7 @@ let (|JumpTableExpr|_|) g expr = | ValApp g g.cgh_jumptable_vref (_, [pcExpr; codeExpr], _m) -> Some (pcExpr, codeExpr) | _ -> None -let sm_verbose = false +let sm_verbose = true /// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) let RepresentBindingAsLiftedOrLocal (bind: Binding) (res2: StateMachineConversionFirstPhaseResult) m = @@ -909,6 +919,11 @@ let isExpandVar (v: Val) = isMustExpandVar v || (v.BaseOrThisInfo = MemberThisVal) +type env = + { Macros: ValMap + MachineAddrExpr: Expr option } + + static member Empty = { Macros = ValMap.Empty; MachineAddrExpr = None } let ConvertStateMachineExprToObject g overallExpr = @@ -919,18 +934,18 @@ let ConvertStateMachineExprToObject g overallExpr = // Evaluate __expand_ABC and __newEntryPoint bindings at compile-time. // Here we record definitions for later use in TryApplyExpansions - let rec BindExpansions g (env: ValMap<_>) expr = + let rec BindExpansions g (env: env) expr = match expr with // Bind 'let __expand_ABC = bindExpr in bodyExpr' | Expr.Let (bind, bodyExpr, _, _) when isExpandVar bind.Var -> - let envR = env.Add bind.Var bind.Expr + let envR = { env with Macros = env.Macros.Add bind.Var bind.Expr } BindExpansions g envR bodyExpr // Bind 'let CODE = __newEntryPoint() in bodyExpr' | Expr.Let (TBind(v, NewEntryPointExpr g (), _sp), bodyExpr, m, _) -> if sm_verbose then printfn "found __newEntryPoint()" - let envR = env.Add v (mkInt g m (genPC())) + let envR = { env with Macros = env.Macros.Add v (mkInt g m (genPC())) } BindExpansions g envR bodyExpr | _ -> @@ -952,22 +967,27 @@ let ConvertStateMachineExprToObject g overallExpr = | _ -> None // Apply a single expansion of __expand_ABC and __newEntryPoint in an arbitrary expression - let TryApplyExpansions g (env: ValMap<_>) expr = + let TryApplyExpansions g (env: env) expr = match expr with // __machine --> ldarg.0 | MachineExpr g (ty, m) -> Some (mkGetArg0 m ty) + | MachineAddrExpr g (ty, m) -> + match env.MachineAddrExpr with + | None -> Some (mkGetArg0 m (mkByrefTy g ty)) + | Some e -> Some e + // __expand_code --> [expand_code] - | Expr.Val (vref, _, _) when env.ContainsVal vref.Deref -> - let expandedExpr = env.[vref.Deref] + | Expr.Val (vref, _, _) when env.Macros.ContainsVal vref.Deref -> + let expandedExpr = env.Macros.[vref.Deref] if sm_verbose then printfn "expanded %A --> %A..." expr expandedExpr Some expandedExpr // __expand_code x --> let arg = x in expand_code[arg/x] - | Expr.App (Expr.Val (vref, _, _), fty, [], args, m) when env.ContainsVal vref.Deref -> - let f0 = env.[vref.Deref] - let expandedExpr = MakeApplicationAndBetaReduce g (f0, fty, [], args, m) + | Expr.App (Expr.Val (vref, _, _), fty, tyargs, args, m) when env.Macros.ContainsVal vref.Deref -> + let f0 = env.Macros.[vref.Deref] + let expandedExpr = MakeApplicationAndBetaReduce g (f0, fty, [tyargs], args, m) if sm_verbose then printfn "expanded %A --> %A..." expr expandedExpr Some expandedExpr @@ -980,7 +1000,7 @@ let ConvertStateMachineExprToObject g overallExpr = | None -> expr // Repeatedly find bindings and apply expansions - let rec RepeatBindAndApplyExpansions g env expr = + let rec RepeatBindAndApplyExpansions g (env: env) expr = let env, expr = BindExpansions g env expr match TryApplyExpansions g env expr with | Some res -> RepeatBindAndApplyExpansions g env res @@ -988,20 +1008,34 @@ let ConvertStateMachineExprToObject g overallExpr = let (|ExpandsTo|) g env e = ApplyExpansions g env e - // Detect a state machine or an application of a state machine to an method - let rec (|StateMachineInContext|_|) g (env: ValMap<_>) overallExpr = + let ConvertStateMachineLeafExpression g (env: env) expr = + expr |> RewriteExpr { PreIntercept = Some (fun cont e -> match TryApplyExpansions g env e with Some e2 -> Some (cont e2) | None -> None) + PostTransform = (fun _ -> None) + PreInterceptBinding = None + IsUnderQuotations=true } + + // Detect a reference-type state machine (or an application of a reference type state machine to a method) + let rec (|RefStateMachineInContext|_|) g (env: env) overallExpr = let env, expr = BindExpansions g env overallExpr match expr with - | Expr.App (f0, f0ty, tyargsl, (StateMachineExpr g objExpr :: args), mApp) -> + | Expr.App (f0, f0ty, tyargsl, (RefStateMachineExpr g objExpr :: args), mApp) -> Some (env, objExpr, (fun objExprR -> Expr.App (f0, f0ty, tyargsl, (objExprR :: args), mApp))) - | StateMachineExpr g objExpr -> + | RefStateMachineExpr g objExpr -> Some (env, objExpr, id) | _ -> None + // Detect a struct-type state machine (or an application of a reference type state machine to a method) + let rec (|StructStateMachineInContext|_|) g (env: env) overallExpr = + let env, expr = BindExpansions g env overallExpr + match expr with + | StructStateMachineExpr g (templateStructTy, meth1Expr, meth2Expr, afterExpr) -> + Some (env, templateStructTy, meth1Expr, meth2Expr, afterExpr) + | _ -> None + // Detect a state machine with a single method override let (|SingleMethodStateMachineInContext|_|) g overallExpr = match overallExpr with - | StateMachineInContext g ValMap.Empty (env, objExpr, remake) -> + | RefStateMachineInContext g env.Empty (env, objExpr, remake) -> if sm_verbose then printfn "Found state machine..." match objExpr with | Expr.Obj (objExprStamp, ty, basev, basecall, overrides, iimpls, stateVars, objExprRange) -> @@ -1014,10 +1048,44 @@ let ConvertStateMachineExprToObject g overallExpr = match codeLambdaExpr with | Expr.Lambda (_, _, _, [_dummyv], codeExpr, _, _) -> if sm_verbose then printfn "Found code lambda..." - Some (env, objExprStamp, objExprRange, remake, ty, basev, basecall, slotsig, attribs, methTyparsOfOverridingMethod, methodParams, pcExpr, codeExpr, iimpls, stateVars, m) + + let remake2 (methodBodyExprWithJumpTable, furtherStateVars) = + let overrideR = TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, methodBodyExprWithJumpTable, m) + let objExprR = Expr.Obj (objExprStamp, ty, basev, basecall, [overrideR], iimpls, stateVars @ furtherStateVars, objExprRange) + let overallExprR = remake objExprR + if sm_verbose then + printfn "----------- AFTER REWRITE ----------------------" + printfn "%s" (DebugPrint.showExpr g overallExprR) + + Choice1Of2 overallExprR + + Some (env, remake2, pcExpr, codeExpr, m) | _ -> None | _ -> None | _ -> None + + | StructStateMachineInContext g env.Empty (env, templateStructTy, meth1Expr, meth2Expr, afterExpr) -> + if sm_verbose then printfn "Found struct machine call..." + match meth1Expr, afterExpr with + | Expr.Lambda (_, _, _, [_], meth1BodyExpr, _, _), Expr.Lambda (_, _, _, [_], startExpr, _, _) -> + if sm_verbose then printfn "Found struct machine lambda..." + match meth1BodyExpr with + | JumpTableExpr g (pcExpr, codeLambdaExpr) -> + if sm_verbose then printfn "Found struct machine jump table call..." + let env, codeLambdaExpr = RepeatBindAndApplyExpansions g env codeLambdaExpr + match codeLambdaExpr with + | Expr.Lambda (_, _, _, [_dummyv], codeExpr, m, _) -> + if sm_verbose then printfn "Found code lambda..." + let meth2ExprR = ConvertStateMachineLeafExpression g env meth2Expr + let machineAddrVar, machineAddrExpr = mkCompGenLocal m "machineAddr" (mkByrefTy g templateStructTy) + let startExprR = ConvertStateMachineLeafExpression g { env with MachineAddrExpr = Some machineAddrExpr } startExpr + let remake2 (methodBodyExprWithJumpTable, stateVars) = + Choice2Of2 (templateStructTy, stateVars, methodBodyExprWithJumpTable, meth2ExprR, machineAddrVar, startExprR) + Some (env, remake2, pcExpr, codeExpr, m) + | _ -> None + | _ -> None + | _ -> None + | _ -> None // A utility to add a jump table an expression @@ -1043,8 +1111,8 @@ let ConvertStateMachineExprToObject g overallExpr = /// Detect constructs allowed in state machines let rec ConvertStateMachineCode env pcExpr expr = if sm_verbose then - printfn "---------" - printfn "ConvertStateMachineCodeing %s" (DebugPrint.showExpr g expr) + printfn "---------ConvertStateMachineCode" + printfn "%s" (DebugPrint.showExpr g expr) printfn "---------" let env, expr = RepeatBindAndApplyExpansions g env expr @@ -1246,17 +1314,13 @@ let ConvertStateMachineExprToObject g overallExpr = // Arbitrary expression | _ -> - // Reqrite all macro expansions - let expr = - expr |> RewriteExpr { PreIntercept = Some (fun cont e -> match TryApplyExpansions g env e with Some e2 -> Some (cont e2) | None -> None) - PostTransform = (fun _ -> None) - PreInterceptBinding = None - IsUnderQuotations=true } - { phase1 = expr - phase2 = (fun _ctxt -> expr) + let exprR = ConvertStateMachineLeafExpression g env expr + { phase1 = exprR + phase2 = (fun _ctxt -> exprR) entryPoints=[] stateVars = [] asyncVars = emptyFreeVars } + if sm_verbose then printfn "-------------------" printfn "Phase 1 Done for %s" (DebugPrint.showExpr g res.phase1) @@ -1266,7 +1330,7 @@ let ConvertStateMachineExprToObject g overallExpr = // Detect a state machine and convert it match overallExpr with - | SingleMethodStateMachineInContext g (env, objExprStamp, objExprRange, remake, ty, basev, basecall, slotsig, attribs, methTyparsOfOverridingMethod, methodParams, pcExpr, codeExpr, iimpls, origStateVars, m) -> + | SingleMethodStateMachineInContext g (env, remake, pcExpr, codeExpr, m) -> if sm_verbose then printfn "Found state machine override method and code expression..." printfn "----------- BEFORE LOWER ----------------------" @@ -1278,7 +1342,7 @@ let ConvertStateMachineExprToObject g overallExpr = // Work out the initial mapping of pcs to labels let pcs = [ 1 .. pcCount ] - let stateVars = res.stateVars + let furtherStateVars = res.stateVars let labs = pcs |> List.map (fun _ -> IL.generateCodeLabel()) let pc2lab = Map.ofList (List.zip pcs labs) @@ -1295,15 +1359,9 @@ let ConvertStateMachineExprToObject g overallExpr = if sm_verbose then printfn "----------- REMAKE ----------------------" - // Rebuild the object expression - let overrideR = TObjExprMethod(slotsig, attribs, methTyparsOfOverridingMethod, methodParams, methodBodyExprWithJumpTable, m) - let objExprR = Expr.Obj (objExprStamp, ty, basev, basecall, [overrideR], iimpls, origStateVars @ stateVars, objExprRange) - let overallExprR = remake objExprR + // Build the result + Some (remake (methodBodyExprWithJumpTable, furtherStateVars)) - if sm_verbose then - printfn "----------- AFTER REWRITE ----------------------" - printfn "%s" (DebugPrint.showExpr g overallExprR) - //printfn "----------- CHECKING ----------------------" //let mutable failed = false //let _expr = @@ -1318,9 +1376,9 @@ let ConvertStateMachineExprToObject g overallExpr = // | _ -> None) // PreInterceptBinding = None // IsUnderQuotations=true } - if sm_verbose then printfn "----------- DONE ----------------------" + //if sm_verbose then printfn "----------- DONE ----------------------" - Some overallExprR + //Some overallExprR | _ -> None diff --git a/src/fsharp/LowerCallsAndSeqs.fsi b/src/fsharp/LowerCallsAndSeqs.fsi index b4661b22a40..05a9003066a 100644 --- a/src/fsharp/LowerCallsAndSeqs.fsi +++ b/src/fsharp/LowerCallsAndSeqs.fsi @@ -23,4 +23,4 @@ val ConvertSequenceExprToObject: g: TcGlobals -> amap: ImportMap -> overallExpr: /// Analyze a TAST expression to detect the elaborated form of a state machine expression, a special kind /// of object expression that uses special code generation constructs. -val ConvertStateMachineExprToObject: g: TcGlobals -> overallExpr: Expr -> Expr option +val ConvertStateMachineExprToObject: g: TcGlobals -> overallExpr: Expr -> (Choice) option diff --git a/src/fsharp/TcGlobals.fs b/src/fsharp/TcGlobals.fs index 49ef217ad4d..229f7604a3d 100755 --- a/src/fsharp/TcGlobals.fs +++ b/src/fsharp/TcGlobals.fs @@ -693,6 +693,8 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d let v_seq_of_functions_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "EnumerateFromFunctions" , None , None , [vara;varb], ([[v_unit_ty --> varaTy]; [varaTy --> v_bool_ty]; [varaTy --> varbTy]], mkSeqTy varbTy)) let v_create_event_info = makeIntrinsicValRef(fslib_MFRuntimeHelpers_nleref, "CreateEvent" , None , None , [vara;varb], ([[varaTy --> v_unit_ty]; [varaTy --> v_unit_ty]; [(v_obj_ty --> (varbTy --> v_unit_ty)) --> varaTy]], TType_app (v_fslib_IEvent2_tcr, [varaTy;varbTy]))) let v_cgh_machine_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__machine" , None , None , [vara], ([[]], varaTy)) + let v_cgh_machineAddr_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__machineAddr" , None , None , [vara], ([[]], mkByrefTy varaTy)) + let v_cgh_stateMachineStruct_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__stateMachineStruct" , None , None , [vara; varb; varc; vard], ([[varbTy; varcTy; (v_unit_ty --> vardTy)]], vardTy)) let v_cgh_stateMachine_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__stateMachine" , None , None , [vara], ([[varaTy]], varaTy)) let v_cgh_jumptable_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__jumptable" , None , None , [vara], ([[v_int_ty]; [v_unit_ty --> varaTy]], varaTy)) let v_cgh_newEntryPoint_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__newEntryPoint" , None , None , [], ([[v_unit_ty]], v_int_ty)) @@ -1430,6 +1432,8 @@ type public TcGlobals(compilingFslib: bool, ilg:ILGlobals, fslibCcu: CcuThunk, d member val cgh_machine_vref = ValRefForIntrinsic v_cgh_machine_info + member val cgh_machineAddr_vref = ValRefForIntrinsic v_cgh_machineAddr_info + member val cgh_stateMachineStruct_vref = ValRefForIntrinsic v_cgh_stateMachineStruct_info member val cgh_stateMachine_vref = ValRefForIntrinsic v_cgh_stateMachine_info member val cgh_jumptable_vref = ValRefForIntrinsic v_cgh_jumptable_info member val cgh_newEntryPoint_vref = ValRefForIntrinsic v_cgh_newEntryPoint_info diff --git a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs index 627aec1f838..d350c94c5e5 100644 --- a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs +++ b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs @@ -22,11 +22,9 @@ public static async Task ManyWriteFileAsync() File.Delete(path); } - public static async Task AsyncTask() + public static System.Runtime.CompilerServices.YieldAwaitable AsyncTask() { - // This may be a bit unfair on C#, the F# one is doing just Task.Yield - await Task.Yield(); - return 100; + return Task.Yield(); } public static Task SyncTask() @@ -51,17 +49,17 @@ public static async Task TenBindsSync_CSharp() public static async Task TenBindsAsync_CSharp() { - var x1 = await AsyncTask(); - var x2 = await AsyncTask(); - var x3 = await AsyncTask(); - var x4 = await AsyncTask(); - var x5 = await AsyncTask(); - var x6 = await AsyncTask(); - var x7 = await AsyncTask(); - var x8 = await AsyncTask(); - var x9 = await AsyncTask(); - var x10 = await AsyncTask(); - return x1 + x2 + x3 + x4 + x5 + x6 + x7 + x8 + x9 + x10; + await AsyncTask(); + await AsyncTask(); + await AsyncTask(); + await AsyncTask(); + await AsyncTask(); + await AsyncTask(); + await AsyncTask(); + await AsyncTask(); + await AsyncTask(); + await AsyncTask(); + return 100; } public static async Task SingleSyncTask_CSharp() From f0f848e9c3da2509598e9e250a9b614ca87c59d0 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 17 May 2019 16:27:36 +0100 Subject: [PATCH 38/45] struct state machines --- src/fsharp/IlxGen.fs | 28 +++++++++++----------- src/fsharp/LowerCallsAndSeqs.fs | 42 +++++++++++++++++++++++---------- src/fsharp/TastOps.fs | 12 +++++----- src/fsharp/TastOps.fsi | 2 ++ 4 files changed, 51 insertions(+), 33 deletions(-) diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index b2e9edf378d..e22856e0cf9 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -4122,7 +4122,7 @@ and GenStructStateMachine cenv cgbuf eenvouter (templateStructTy, moveNextExpr, // // Note, the 'let' bindings for the stateVars have already been transformed to 'set' expressions, and thus the stateVars are now // free variables of the expression. - let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m false None eenvouter moveNextExpr + let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m ILBoxity.AsValue false None eenvouter moveNextExpr let cloAttribs = cloinfo.cloAttribs let cloFreeVars = cloinfo.cloFreeVars @@ -4242,7 +4242,7 @@ and GenStructStateMachine cenv cgbuf eenvouter (templateStructTy, moveNextExpr, let locIdx, realloc, _ = AllocLocal cenv cgbuf eenvinner true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName ("machine", m), ilCloTy, false) scopeMarks // The local for the state machine address - let locIdx2, _realloc2, _ = AllocLocal cenv cgbuf eenvinner true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName (machineAddrVar.DisplayName, m), ILType.Byref ilCloTy, false) scopeMarks + let locIdx2, _realloc2, _ = AllocLocal cenv cgbuf eenvinner true (g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.FreshCompilerGeneratedName (machineAddrVar.DisplayName, m), ilMachineAddrTy, false) scopeMarks // Zero-initialize the machine if necessary if realloc then @@ -4261,12 +4261,12 @@ and GenStructStateMachine cenv cgbuf eenvouter (templateStructTy, moveNextExpr, if realloc then CG.EmitInstr cgbuf (pop 0) (Push [ ilMachineAddrTy ]) (I_ldloc (uint16 locIdx2) ) GenDefaultValue cenv cgbuf eenvouter (fv.Type, m) - CG.EmitInstr cgbuf (pop 0) (Push [ ilMachineAddrTy ]) (mkNormalStfld (mkILFieldSpecInTy (ilCloTy, ilv.fvName, ilv.fvType))) + CG.EmitInstr cgbuf (pop 2) (Push [ ]) (mkNormalStfld (mkILFieldSpecInTy (ilCloTy, ilv.fvName, ilv.fvType))) else // initialize the captured var CG.EmitInstr cgbuf (pop 0) (Push [ ilMachineAddrTy ]) (I_ldloc (uint16 locIdx2) ) GenGetLocalVal cenv cgbuf eenvouter m fv None - CG.EmitInstr cgbuf (pop 0) (Push [ ilMachineAddrTy ]) (mkNormalStfld (mkILFieldSpecInTy (ilCloTy, ilv.fvName, ilv.fvType))) + CG.EmitInstr cgbuf (pop 2) (Push [ ]) (mkNormalStfld (mkILFieldSpecInTy (ilCloTy, ilv.fvName, ilv.fvType))) // Generate the start expression - eenvinner is used as it contains the binding for machineAddrVar GenExpr cenv cgbuf eenvinner SPSuppress startExpr sequel @@ -4288,7 +4288,7 @@ and GenObjectExpr cenv cgbuf eenvouter objExpr (baseType, baseValOpt, basecall, // // Note, the 'let' bindings for the stateVars have already been transformed to 'set' expressions, and thus the stateVars are now // free variables of the expression. - let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m false None eenvouter objExpr + let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m ILBoxity.AsObject false None eenvouter objExpr let cloAttribs = cloinfo.cloAttribs let cloFreeVars = cloinfo.cloFreeVars @@ -4359,7 +4359,7 @@ and GenSequenceExpr // Get the free variables. Make a lambda to pretend that the 'nextEnumeratorValRef' is bound (it is an argument to GenerateNext) let (cloAttribs, _, _, cloFreeTyvars, cloFreeVars, ilCloTypeRef: ILTypeRef, ilCloFreeVars, eenvinner) = - GetIlxClosureFreeVars cenv m None eenvouter [] (mkLambda m nextEnumeratorValRef.Deref (generateNextExpr, g.int32_ty)) + GetIlxClosureFreeVars cenv m None ILBoxity.AsObject eenvouter [] (mkLambda m nextEnumeratorValRef.Deref (generateNextExpr, g.int32_ty)) let ilCloSeqElemTy = GenType cenv.amap m eenvinner.tyenv seqElemTy let cloRetTy = mkSeqTy g seqElemTy @@ -4491,7 +4491,7 @@ and GenLambdaClosure cenv (cgbuf: CodeGenBuffer) eenv isLocalTypeFunc selfv expr | Expr.Lambda (_, _, _, _, _, m, _) | Expr.TyLambda (_, _, _, m, _) -> - let cloinfo, body, eenvinner = GetIlxClosureInfo cenv m isLocalTypeFunc selfv eenv expr + let cloinfo, body, eenvinner = GetIlxClosureInfo cenv m ILBoxity.AsObject isLocalTypeFunc selfv eenv expr let entryPointInfo = match selfv with @@ -4580,7 +4580,7 @@ and GenFreevar cenv m eenvouter tyenvinner (fv: Val) = #endif | _ -> GenType cenv.amap m tyenvinner fv.Type -and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = +and GetIlxClosureFreeVars cenv m selfv boxity eenvouter takenNames expr = let g = cenv.g // Choose a base name for the closure @@ -4649,7 +4649,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = let ilCloTyInner = let ilCloGenericParams = GenGenericParams cenv eenvinner cloFreeTyvars - mkILFormalBoxedTy ilCloTypeRef ilCloGenericParams + mkILFormalNamedTy boxity ilCloTypeRef ilCloGenericParams // If generating a named closure, add the closure itself as a var, available via "arg0" . // The latter doesn't apply for the delegate implementation of closures. @@ -4678,7 +4678,7 @@ and GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr = (cloAttribs, cloInternalFreeTyvars, cloContractFreeTyvars, cloFreeTyvars, cloFreeVars, ilCloTypeRef, Array.ofList ilCloFreeVars, eenvinner) -and GetIlxClosureInfo cenv m isLocalTypeFunc selfv eenvouter expr = +and GetIlxClosureInfo cenv m boxity isLocalTypeFunc selfv eenvouter expr = let g = cenv.g let returnTy = match expr with @@ -4705,7 +4705,7 @@ and GetIlxClosureInfo cenv m isLocalTypeFunc selfv eenvouter expr = let takenNames = vs |> List.map (fun v -> v.CompiledName g.CompilerGlobalState) // Get the free variables and the information about the closure, add the free variables to the environment - let (cloAttribs, cloInternalFreeTyvars, cloContractFreeTyvars, _, cloFreeVars, ilCloTypeRef, ilCloFreeVars, eenvinner) = GetIlxClosureFreeVars cenv m selfv eenvouter takenNames expr + let (cloAttribs, cloInternalFreeTyvars, cloContractFreeTyvars, _, cloFreeVars, ilCloTypeRef, ilCloFreeVars, eenvinner) = GetIlxClosureFreeVars cenv m selfv boxity eenvouter takenNames expr // Put the type and value arguments into the environment let rec getClosureArgs eenv ntmargs tvsl (vs: Val list) = @@ -4862,7 +4862,7 @@ and GenDelegateExpr cenv cgbuf eenvouter expr (TObjExprMethod((TSlotSig(_, deleg // Work out the free type variables for the morphing thunk let takenNames = List.map nameOfVal tmvs - let (cloAttribs, _, _, cloFreeTyvars, cloFreeVars, ilDelegeeTypeRef, ilCloFreeVars, eenvinner) = GetIlxClosureFreeVars cenv m None eenvouter takenNames expr + let (cloAttribs, _, _, cloFreeTyvars, cloFreeVars, ilDelegeeTypeRef, ilCloFreeVars, eenvinner) = GetIlxClosureFreeVars cenv m None ILBoxity.AsObject eenvouter takenNames expr let ilDelegeeGenericParams = GenGenericParams cenv eenvinner cloFreeTyvars let ilDelegeeGenericActualsInner = mkILFormalGenericArgs 0 ilDelegeeGenericParams @@ -5346,7 +5346,7 @@ and GenLetRecBindings cenv (cgbuf: CodeGenBuffer) eenv (allBinds: Bindings, m) = | Expr.Lambda _ | Expr.TyLambda _ | Expr.Obj _ -> let isLocalTypeFunc = Option.isSome selfv && (IsNamedLocalTypeFuncVal cenv.g (Option.get selfv) e) let selfv = (match e with Expr.Obj _ -> None | _ when isLocalTypeFunc -> None | _ -> Option.map mkLocalValRef selfv) - let clo, _, eenvclo = GetIlxClosureInfo cenv m isLocalTypeFunc selfv {eenv with letBoundVars=(mkLocalValRef boundv) :: eenv.letBoundVars} e + let clo, _, eenvclo = GetIlxClosureInfo cenv m ILBoxity.AsObject isLocalTypeFunc selfv {eenv with letBoundVars=(mkLocalValRef boundv) :: eenv.letBoundVars} e clo.cloFreeVars |> List.iter (fun fv -> if Zset.contains fv forwardReferenceSet then match StorageForVal cenv.g m fv eenvclo with @@ -6347,7 +6347,7 @@ and AllocLocalVal cenv cgbuf v eenv repr scopeMarks = let eenvinner = {eenv with letBoundVars=(mkLocalValRef v) :: eenv.letBoundVars} - let cloinfo, _, _ = GetIlxClosureInfo cenv v.Range true None eenvinner (Option.get repr) + let cloinfo, _, _ = GetIlxClosureInfo cenv v.Range ILBoxity.AsObject true None eenvinner (Option.get repr) cloinfo let idx, realloc, eenv = AllocLocal cenv cgbuf eenv v.IsCompilerGenerated (v.CompiledName g.CompilerGlobalState, g.ilg.typ_Object, false) scopeMarks diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 191eca2ea38..36204dd666f 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -1008,11 +1008,17 @@ let ConvertStateMachineExprToObject g overallExpr = let (|ExpandsTo|) g env e = ApplyExpansions g env e - let ConvertStateMachineLeafExpression g (env: env) expr = - expr |> RewriteExpr { PreIntercept = Some (fun cont e -> match TryApplyExpansions g env e with Some e2 -> Some (cont e2) | None -> None) - PostTransform = (fun _ -> None) - PreInterceptBinding = None - IsUnderQuotations=true } + let makeRewriteEnv (env: env) = + { PreIntercept = Some (fun cont e -> match TryApplyExpansions g env e with Some e2 -> Some (cont e2) | None -> None) + PostTransform = (fun _ -> None) + PreInterceptBinding = None + IsUnderQuotations=true } + + let ConvertStateMachineLeafExpression (env: env) expr = + expr |> RewriteExpr (makeRewriteEnv env) + + let ConvertStateMachineLeafDecisionTree (env: env) expr = + expr |> RewriteDecisionTree (makeRewriteEnv env) // Detect a reference-type state machine (or an application of a reference type state machine to a method) let rec (|RefStateMachineInContext|_|) g (env: env) overallExpr = @@ -1076,10 +1082,17 @@ let ConvertStateMachineExprToObject g overallExpr = match codeLambdaExpr with | Expr.Lambda (_, _, _, [_dummyv], codeExpr, m, _) -> if sm_verbose then printfn "Found code lambda..." - let meth2ExprR = ConvertStateMachineLeafExpression g env meth2Expr + let meth2ExprR = ConvertStateMachineLeafExpression env meth2Expr let machineAddrVar, machineAddrExpr = mkCompGenLocal m "machineAddr" (mkByrefTy g templateStructTy) - let startExprR = ConvertStateMachineLeafExpression g { env with MachineAddrExpr = Some machineAddrExpr } startExpr + let startExprR = ConvertStateMachineLeafExpression { env with MachineAddrExpr = Some machineAddrExpr } startExpr let remake2 (methodBodyExprWithJumpTable, stateVars) = + if sm_verbose then + printfn "----------- AFTER REWRITE methodBodyExprWithJumpTable ----------------------" + printfn "%s" (DebugPrint.showExpr g methodBodyExprWithJumpTable) + printfn "----------- AFTER REWRITE meth2ExprR ----------------------" + printfn "%s" (DebugPrint.showExpr g meth2ExprR) + printfn "----------- AFTER REWRITE startExprR ----------------------" + printfn "%s" (DebugPrint.showExpr g startExprR) Choice2Of2 (templateStructTy, stateVars, methodBodyExprWithJumpTable, meth2ExprR, machineAddrVar, startExprR) Some (env, remake2, pcExpr, codeExpr, m) | _ -> None @@ -1270,8 +1283,9 @@ let ConvertStateMachineExprToObject g overallExpr = asyncVars = unionFreeVars resBody.asyncVars (unionFreeVars(freeInExpr CollectLocals resFilter.phase1) (freeInExpr CollectLocals resHandler.phase1)) } // control-flow match - | Expr.Match (spBind, exprm, pt, targets, m, ty) -> + | Expr.Match (spBind, exprm, dtree, targets, m, ty) -> // lower all the targets. + let dtreeR = ConvertStateMachineLeafDecisionTree env dtree let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> ConvertStateMachineCode env pcExpr targetExpr) let tgl = Array.toList tglArray let entryPoints = tgl |> List.collect (fun res -> res.entryPoints) @@ -1282,10 +1296,10 @@ let ConvertStateMachineExprToObject g overallExpr = let stateVars = tgl |> List.collect (fun res -> res.stateVars) { phase1 = let gtgs = (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, spTarget)) res -> TTarget(vs, res.phase1, spTarget)) - primMkMatch (spBind, exprm, pt, gtgs, m, ty) + primMkMatch (spBind, exprm, dtreeR, gtgs, m, ty) phase2 = (fun ctxt -> let gtgs = (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, spTarget)) res -> TTarget(vs, res.phase2 ctxt, spTarget)) - let generate = primMkMatch (spBind, exprm, pt, gtgs, m, ty) + let generate = primMkMatch (spBind, exprm, dtreeR, gtgs, m, ty) generate) entryPoints = entryPoints stateVars = stateVars @@ -1314,7 +1328,7 @@ let ConvertStateMachineExprToObject g overallExpr = // Arbitrary expression | _ -> - let exprR = ConvertStateMachineLeafExpression g env expr + let exprR = ConvertStateMachineLeafExpression env expr { phase1 = exprR phase2 = (fun _ctxt -> exprR) entryPoints=[] @@ -1331,6 +1345,8 @@ let ConvertStateMachineExprToObject g overallExpr = // Detect a state machine and convert it match overallExpr with | SingleMethodStateMachineInContext g (env, remake, pcExpr, codeExpr, m) -> + let pcExprR = ConvertStateMachineLeafExpression env pcExpr + if sm_verbose then printfn "Found state machine override method and code expression..." printfn "----------- BEFORE LOWER ----------------------" @@ -1338,7 +1354,7 @@ let ConvertStateMachineExprToObject g overallExpr = printfn "----------- LOWER ----------------------" // Perform phase1 of the conversion - let res = ConvertStateMachineCode env pcExpr codeExpr + let res = ConvertStateMachineCode env pcExprR codeExpr // Work out the initial mapping of pcs to labels let pcs = [ 1 .. pcCount ] @@ -1355,7 +1371,7 @@ let ConvertStateMachineExprToObject g overallExpr = if sm_verbose then printfn "----------- ADDING JUMP TABLE ----------------------" // Add the jump table - let methodBodyExprWithJumpTable = addPcJumpTable g m pcs pc2lab pcExpr methodBodyExprR + let methodBodyExprWithJumpTable = addPcJumpTable g m pcs pc2lab pcExprR methodBodyExprR if sm_verbose then printfn "----------- REMAKE ----------------------" diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index e8a1d10554b..2afb3803e2a 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -8256,7 +8256,7 @@ and rewriteExprStructure env expr = mkTypeLambda m argtyvs (body, rty) | Expr.Match (spBind, exprm, dtree, targets, m, ty) -> - let dtree' = rewriteDecisionTree env dtree + let dtree' = RewriteDecisionTree env dtree let targets' = rewriteTargets env targets mkAndSimplifyMatch spBind exprm m ty dtree' targets' @@ -8305,7 +8305,7 @@ and rewriteLinearExpr env expr contf = else rebuildLinearOpExpr (op, tyargs, argsFront', argLast', m))) | LinearMatchExpr (spBind, exprm, dtree, tg1, expr2, sp2, m2, ty) -> - let dtree = rewriteDecisionTree env dtree + let dtree = RewriteDecisionTree env dtree let tg1' = rewriteTarget env tg1 // tailcall rewriteLinearExpr env expr2 (contf << (fun expr2' -> @@ -8318,7 +8318,7 @@ and rewriteExprs env exprs = List.mapq (RewriteExpr env) exprs and rewriteFlatExprs env exprs = List.mapq (RewriteExpr env) exprs -and rewriteDecisionTree env x = +and RewriteDecisionTree env x = match x with | TDSuccess (es, n) -> let es' = rewriteFlatExprs env es @@ -8327,13 +8327,13 @@ and rewriteDecisionTree env x = | TDSwitch (e, cases, dflt, m) -> let e' = RewriteExpr env e - let cases' = List.map (fun (TCase(discrim, e)) -> TCase(discrim, rewriteDecisionTree env e)) cases - let dflt' = Option.map (rewriteDecisionTree env) dflt + let cases' = List.map (fun (TCase(discrim, e)) -> TCase(discrim, RewriteDecisionTree env e)) cases + let dflt' = Option.map (RewriteDecisionTree env) dflt TDSwitch (e', cases', dflt', m) | TDBind (bind, body) -> let bind' = rewriteBind env bind - let body = rewriteDecisionTree env body + let body = RewriteDecisionTree env body TDBind (bind', body) and rewriteTarget env (TTarget(vs, e, spTarget)) = TTarget(vs, RewriteExpr env e, spTarget) diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index 8c71736a844..04ef2df36fc 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -2202,6 +2202,8 @@ type ExprRewritingEnv = PreInterceptBinding: ((Expr -> Expr) -> Binding -> Binding option) option IsUnderQuotations: bool } +val RewriteDecisionTree : ExprRewritingEnv -> DecisionTree -> DecisionTree + val RewriteExpr : ExprRewritingEnv -> Expr -> Expr val RewriteImplFile : ExprRewritingEnv -> TypedImplFile -> TypedImplFile From 17154b98e230268e21c33592206efaa1a202edc4 Mon Sep 17 00:00:00 2001 From: Phillip Carter Date: Mon, 13 May 2019 17:11:39 -0700 Subject: [PATCH 39/45] run perf benchmarks --- src/fsharp/LowerCallsAndSeqs.fs | 2 +- tests/fsharp/perf/tasks/FS/TaskPerf.fs | 37 +++++++++++++++++++++----- 2 files changed, 31 insertions(+), 8 deletions(-) diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 36204dd666f..aeb84c1b5d5 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -848,7 +848,7 @@ let (|JumpTableExpr|_|) g expr = | ValApp g g.cgh_jumptable_vref (_, [pcExpr; codeExpr], _m) -> Some (pcExpr, codeExpr) | _ -> None -let sm_verbose = true +let sm_verbose = try System.Environment.GetEnvironmentVariable("FSharp_StateMachineVerbose") <> null with _ -> false /// Implement a decision to represent a 'let' binding as a non-escaping local variable (rather than a state machine variable) let RepresentBindingAsLiftedOrLocal (bind: Binding) (res2: StateMachineConversionFirstPhaseResult) m = diff --git a/tests/fsharp/perf/tasks/FS/TaskPerf.fs b/tests/fsharp/perf/tasks/FS/TaskPerf.fs index 8169e3aa306..23157159021 100644 --- a/tests/fsharp/perf/tasks/FS/TaskPerf.fs +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fs @@ -14,8 +14,8 @@ open BenchmarkDotNet.Running open TaskBuilderTasks.ContextSensitive // TaskBuilder.fs extension members open FSharp.Control.ContextSensitiveTasks // the default -//[] -type TaskPerfTests() = +[] +module Helpers = let bufferSize = 128 let manyIterations = 10000 @@ -123,7 +123,8 @@ type TaskPerfTests() = let singleTask_FSharpAsync() = async { return 1 } - [] +type ManyWriteFile() = + [] member __.ManyWriteFile_CSharpAsync () = TaskPerfCSharp.ManyWriteFileAsync().Wait(); @@ -163,7 +164,8 @@ type TaskPerfTests() = |> Async.RunSynchronously File.Delete(path) - [] +type SyncBinds() = + [] member __.SyncBinds_CSharpAsync() = for i in 1 .. manyIterations*100 do TaskPerfCSharp.TenBindsSync_CSharp().Wait() @@ -183,7 +185,8 @@ type TaskPerfTests() = for i in 1 .. manyIterations*100 do tenBindSync_FSharpAsync() |> Async.RunSynchronously |> ignore - [] +type AsyncBinds() = + [] member __.AsyncBinds_CSharpAsync() = for i in 1 .. manyIterations do TaskPerfCSharp.TenBindsAsync_CSharp().Wait() @@ -203,7 +206,8 @@ type TaskPerfTests() = // for i in 1 .. manyIterations do // tenBindAsync_FSharpAsync() |> Async.RunSynchronously - [] +type SingleSyncTask() = + [] member __.SingleSyncTask_CSharpAsync() = for i in 1 .. manyIterations*500 do TaskPerfCSharp.SingleSyncTask_CSharp().Wait() @@ -227,5 +231,24 @@ module Main = [] let main argv = - let summary = BenchmarkRunner.Run(); + ManyWriteFile().ManyWriteFile_CSharpAsync() + ManyWriteFile().ManyWriteFile_Task () + ManyWriteFile().ManyWriteFile_TaskBuilder () + ManyWriteFile().ManyWriteFile_FSharpAsync () + SyncBinds().SyncBinds_CSharpAsync() + SyncBinds().SyncBinds_Task() + SyncBinds().SyncBinds_TaskBuilder() + SyncBinds().SyncBinds_FSharpAsync() + AsyncBinds().AsyncBinds_CSharpAsync() + AsyncBinds().AsyncBinds_Task() + AsyncBinds().AsyncBinds_TaskBuilder() + SingleSyncTask().SingleSyncTask_CSharpAsync() + SingleSyncTask().SingleSyncTask_Task() + SingleSyncTask().SingleSyncTask_TaskBuilder() + SingleSyncTask().SingleSyncTask_FSharpAsync() + + let summary = BenchmarkRunner.Run() + let summary = BenchmarkRunner.Run() + let summary = BenchmarkRunner.Run() + let summary = BenchmarkRunner.Run() 0 \ No newline at end of file From b5101de02557c69af9c6b109e0bb8526844b5077 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 17 May 2019 17:06:38 +0100 Subject: [PATCH 40/45] run perf benchmarks --- tests/fsharp/perf/tasks/FS/TaskPerf.fs | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/tests/fsharp/perf/tasks/FS/TaskPerf.fs b/tests/fsharp/perf/tasks/FS/TaskPerf.fs index 23157159021..278c6a63e58 100644 --- a/tests/fsharp/perf/tasks/FS/TaskPerf.fs +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fs @@ -231,6 +231,7 @@ module Main = [] let main argv = + printfn "Testing that the tests run..." ManyWriteFile().ManyWriteFile_CSharpAsync() ManyWriteFile().ManyWriteFile_Task () ManyWriteFile().ManyWriteFile_TaskBuilder () @@ -246,9 +247,15 @@ module Main = SingleSyncTask().SingleSyncTask_Task() SingleSyncTask().SingleSyncTask_TaskBuilder() SingleSyncTask().SingleSyncTask_FSharpAsync() + printfn "Running becnhmarks..." - let summary = BenchmarkRunner.Run() - let summary = BenchmarkRunner.Run() - let summary = BenchmarkRunner.Run() - let summary = BenchmarkRunner.Run() + let manyWriteFileResult = BenchmarkRunner.Run() + let syncBindsResult = BenchmarkRunner.Run() + let asyncBindsResult = BenchmarkRunner.Run() + let singleTaskResult = BenchmarkRunner.Run() + + printfn "%A" manyWriteFileResult + printfn "%A" syncBindsResult + printfn "%A" asyncBindsResult + printfn "%A" singleTaskResult 0 \ No newline at end of file From 3cf5a58bc62f6375eabf68028fca864e75caa5ec Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 20 May 2019 12:10:40 +0100 Subject: [PATCH 41/45] remove boxing of result --- VisualFSharp.sln | 36 ++++++++++++++++++ src/fsharp/FSharp.Core/tasks.fs | 52 +++++++++++--------------- src/fsharp/FSharp.Core/tasks.fsi | 16 ++++---- tests/fsharp/perf/tasks/FS/TaskPerf.fs | 4 ++ 4 files changed, 70 insertions(+), 38 deletions(-) diff --git a/VisualFSharp.sln b/VisualFSharp.sln index 41d5424b810..3409c1d337d 100644 --- a/VisualFSharp.sln +++ b/VisualFSharp.sln @@ -154,6 +154,14 @@ Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "TutorialProject", "vsintegr EndProject Project("{9A19103F-16F7-4668-BE54-9A1E7A4F7556}") = "FSharp.Core.nuget", "src\fsharp\FSharp.Core.nuget\FSharp.Core.nuget.csproj", "{8EC30B2E-F1F9-4A98-BBB5-DD0CF6C84DDC}" EndProject +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Perf", "Perf", "{D3DE4E8F-DD05-4D58-BCFC-848988878640}" +EndProject +Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Tasks", "Tasks", "{E071023E-4D10-406F-9D31-0A02522D2779}" +EndProject +Project("{9A19103F-16F7-4668-BE54-9A1E7A4F7556}") = "TaskPerfCSharp", "tests\fsharp\perf\tasks\CS\TaskPerfCSharp.csproj", "{218BD16B-D9BB-402A-970B-72A86E30AA41}" +EndProject +Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "TaskPerf", "tests\fsharp\perf\tasks\FS\TaskPerf.fsproj", "{0018B20C-1AE7-4E81-8E9E-A273FCA10A70}" +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -884,6 +892,30 @@ Global {8EC30B2E-F1F9-4A98-BBB5-DD0CF6C84DDC}.Release|Any CPU.Build.0 = Release|Any CPU {8EC30B2E-F1F9-4A98-BBB5-DD0CF6C84DDC}.Release|x86.ActiveCfg = Release|Any CPU {8EC30B2E-F1F9-4A98-BBB5-DD0CF6C84DDC}.Release|x86.Build.0 = Release|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Debug|Any CPU.Build.0 = Debug|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Debug|x86.ActiveCfg = Debug|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Debug|x86.Build.0 = Debug|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Proto|Any CPU.ActiveCfg = Debug|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Proto|Any CPU.Build.0 = Debug|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Proto|x86.ActiveCfg = Debug|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Proto|x86.Build.0 = Debug|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Release|Any CPU.ActiveCfg = Release|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Release|Any CPU.Build.0 = Release|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Release|x86.ActiveCfg = Release|Any CPU + {218BD16B-D9BB-402A-970B-72A86E30AA41}.Release|x86.Build.0 = Release|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Debug|Any CPU.Build.0 = Debug|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Debug|x86.ActiveCfg = Debug|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Debug|x86.Build.0 = Debug|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Proto|Any CPU.ActiveCfg = Debug|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Proto|Any CPU.Build.0 = Debug|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Proto|x86.ActiveCfg = Debug|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Proto|x86.Build.0 = Debug|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Release|Any CPU.ActiveCfg = Release|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Release|Any CPU.Build.0 = Release|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Release|x86.ActiveCfg = Release|Any CPU + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70}.Release|x86.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE @@ -956,6 +988,10 @@ Global {C32806E0-71C2-40E4-AEC4-517F73F6A18A} = {BED74F9E-A0D2-48E2-9EE7-449832100487} {7B345E51-F2C0-4D4B-B0E0-05432EC9D5E1} = {BED74F9E-A0D2-48E2-9EE7-449832100487} {8EC30B2E-F1F9-4A98-BBB5-DD0CF6C84DDC} = {647810D0-5307-448F-99A2-E83917010DAE} + {D3DE4E8F-DD05-4D58-BCFC-848988878640} = {CFE3259A-2D30-4EB0-80D5-E8B5F3D01449} + {E071023E-4D10-406F-9D31-0A02522D2779} = {D3DE4E8F-DD05-4D58-BCFC-848988878640} + {218BD16B-D9BB-402A-970B-72A86E30AA41} = {E071023E-4D10-406F-9D31-0A02522D2779} + {0018B20C-1AE7-4E81-8E9E-A273FCA10A70} = {E071023E-4D10-406F-9D31-0A02522D2779} EndGlobalSection GlobalSection(ExtensibilityGlobals) = postSolution SolutionGuid = {48EDBBBE-C8EE-4E3C-8B19-97184A487B37} diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index 7ab3c6c0045..a0323040a30 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -81,8 +81,8 @@ type TaskStep<'T, 'TOverall>(completed: bool) = [] type TaskStateMachineTemplate<'T> = - [] - val mutable Current : obj + [] + val mutable Result : 'T [] val mutable ResumptionPoint : int @@ -97,8 +97,6 @@ type TaskStateMachineTemplate<'T> = module Helpers = let inline Start (sm: byref>) = //Console.WriteLine("[{0}] start", sm.GetHashCode()) - sm.Current <- null - sm.ResumptionPoint <- 0 sm.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() sm.MethodBuilder.Start(&sm) //Console.WriteLine("[{0}] unwrap", sm.GetHashCode()) @@ -112,7 +110,8 @@ module Helpers = //Console.WriteLine("[{0}] AwaitUnsafeOnCompleted", sm.GetHashCode()) sm.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) - let inline SetCurrent (sm: byref>) (v: obj) = sm.Current <- v + let inline SetResult (sm: byref>) (v: 'T) = + sm.Result <- v [] module TaskHelpers = @@ -123,15 +122,15 @@ module TaskHelpers = // else agg :> Exception /// Used to return a value. - let inline ret<'T, 'TOverall> (x : 'T) = - Helpers.SetCurrent __machineAddr> (box x) - TaskStep<'T, 'TOverall>(true) + let inline ret<'T> (x : 'T) = + Helpers.SetResult __machineAddr> x + TaskStep<'T, 'T>(true) let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2, 'TOverall when (^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) > (x: ^Priority) (y: ^TaskLike) __expand_continuation = ((^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) (x, y, __expand_continuation)) - let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T, 'TOverall when (^Priority or ^TaskLike): (static member CanReturnFrom: ^Priority * ^TaskLike -> TaskStep<'T, 'TOverall>)> (x: ^Priority) (y: ^TaskLike) = - ((^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep<'T, 'TOverall>) (x, y)) + let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T when (^Priority or ^TaskLike): (static member CanReturnFrom: ^Priority * ^TaskLike -> TaskStep<'T, 'T>)> (x: ^Priority) (y: ^TaskLike) = + ((^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep<'T, 'T>) (x, y)) type TaskLikeBind<'TResult2> = // We put the output generic parameter up here at the class level, so it doesn't get subject to @@ -213,9 +212,8 @@ type TaskBuilder() = let v = __machineAddr> if ``__machine_step$cont``.IsCompleted then //Console.WriteLine("[{0}] unboxing result", sm.GetHashCode()) - let res = unbox<'T>(v.Current) //Console.WriteLine("[{0}] SetResult {1}", sm.GetHashCode(), res) - v.MethodBuilder.SetResult(res) + v.MethodBuilder.SetResult(v.Result) with exn -> //Console.WriteLine("[{0}] exception {1}", sm.GetHashCode(), exn) let v = __machineAddr> @@ -229,13 +227,9 @@ type TaskBuilder() = /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. - member inline __.Zero() : TaskStep = - Helpers.SetCurrent __machineAddr> (box ()) - TaskStep(true) + member inline __.Zero() : TaskStep = TaskStep(true) - member inline __.Return (x: 'T) : TaskStep<'T, 'TOverall> = - Helpers.SetCurrent __machineAddr> (box x) - TaskStep<'T, 'TOverall>(true) + member inline __.Return (x: 'T) : TaskStep<'T, 'T> = ret x /// Chains together a step with its following step. /// Note that this requires that the first step has no result. @@ -255,7 +249,6 @@ type TaskBuilder() = let ``__machine_step$cont`` = __expand_body () // If we make it to the assignment we prove we've made a step completed <- ``__machine_step$cont``.IsCompleted - Helpers.SetCurrent __machineAddr> (box ()) TaskStep(completed) /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function @@ -311,15 +304,14 @@ type TaskBuilder() = // ... and its body is a while loop that advances the enumerator and runs the body on each element. (fun e -> builder.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) - member inline __.ReturnFrom (task: Task<'T>) : TaskStep<'T, 'TOverall> = + member inline __.ReturnFrom (task: Task<'T>) : TaskStep<'T, 'T> = let CONT = __newEntryPoint () if task.IsCompleted then __entryPoint CONT - Helpers.SetCurrent __machineAddr> (box (task.GetAwaiter().GetResult())) - TaskStep<'T, 'TOverall>(true) + ret (task.GetAwaiter().GetResult()) else - Helpers.Await __machineAddr> ((task.GetAwaiter() :> ICriticalNotifyCompletion), CONT) - TaskStep<'T, 'TOverall>(false) + Helpers.Await __machineAddr> ((task.GetAwaiter() :> ICriticalNotifyCompletion), CONT) + TaskStep<'T, 'T>(false) [] module ContextSensitiveTasks = @@ -348,16 +340,16 @@ module ContextSensitiveTasks = = bindTask (Async.StartAsTask computation) __expand_continuation // Give the type arguments explicitly to make it match the signature precisely - static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T, 'TOverall + static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T)> - (_priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T, 'TOverall > - = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T, 'TOverall> (taskLike, ret< ^T, 'TOverall >) + (_priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T, ^T > + = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T, ^T > (taskLike, ret< ^T >) static member inline CanReturnFrom (_priority: IPriority1, computation : Async<'T>) - = bindTask (Async.StartAsTask computation) (ret< 'T, 'TOverall >) : TaskStep<'T, 'TOverall> + = bindTask (Async.StartAsTask computation) (ret<'T>) : TaskStep<'T, 'T> type TaskBuilder with member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 , 'TOverall @@ -365,8 +357,8 @@ module ContextSensitiveTasks = (task: ^TaskLike, __expand_continuation: ^TResult1 -> TaskStep<'TResult2, 'TOverall>) : TaskStep<'TResult2, 'TOverall> = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2, 'TOverall> Unchecked.defaultof task __expand_continuation - member inline builder.ReturnFrom< ^TaskLike, 'T, 'TOverall when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T, 'TOverall>) > (task: ^TaskLike) : TaskStep<'T, 'TOverall> - = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T, 'TOverall> Unchecked.defaultof task + member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T, 'T>) > (task: ^TaskLike) : TaskStep<'T, 'T> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> Unchecked.defaultof task module ContextInsensitiveTasks = diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index 4cfcab4d706..db256e3324d 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -61,8 +61,8 @@ type TaskStep<'T, 'TOverall> = [] /// This is used by the compiler as a template for creating state machine structs type TaskStateMachineTemplate<'T> = - [] - val mutable Current : obj + [] + val mutable Result : 'T [] val mutable ResumptionPoint : int @@ -77,8 +77,8 @@ type TaskBuilder = member inline Combine: task1: TaskStep * task2: (unit -> TaskStep<'T, 'TOverall>) -> TaskStep<'T, 'TOverall> member inline Delay: f: (unit -> TaskStep<'T, 'TOverall>) -> (unit -> TaskStep<'T, 'TOverall>) member inline For: sequence: seq<'T> * body: ('T -> TaskStep) -> TaskStep - member inline Return: x: 'T -> TaskStep<'T, 'TOverall> - member inline ReturnFrom: task: Task<'T> -> TaskStep<'T, 'TOverall> + member inline Return: x: 'T -> TaskStep<'T, 'T> + member inline ReturnFrom: task: Task<'T> -> TaskStep<'T, 'T> member inline Run: code: (unit -> TaskStep<'T, 'T>) -> Task<'T> member inline TryFinally: body: (unit -> TaskStep<'T, 'TOverall>) * fin: (unit -> unit) -> TaskStep<'T, 'TOverall> member inline TryWith: body: (unit -> TaskStep<'T, 'TOverall>) * catch: (exn -> TaskStep<'T, 'TOverall>) -> TaskStep<'T, 'TOverall> @@ -115,14 +115,14 @@ module ContextSensitiveTasks = static member inline CanBind: priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> /// Provides evidence that task-like types can be used in 'return' in a task workflow - static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T, 'TOverall> : priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T, 'TOverall > + static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T> : priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T, ^T > when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T) /// Provides evidence that F# Async computations can be used in 'return' in a task computation expression - static member inline CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T, 'TOverall> + static member inline CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T, 'T> type TaskBuilder with /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics @@ -130,8 +130,8 @@ module ContextSensitiveTasks = when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics - member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult, 'TOverall > - when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult, 'TOverall>) + member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'T, 'T > + when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T, 'T>) module ContextInsensitiveTasks = diff --git a/tests/fsharp/perf/tasks/FS/TaskPerf.fs b/tests/fsharp/perf/tasks/FS/TaskPerf.fs index 278c6a63e58..f73abe141ed 100644 --- a/tests/fsharp/perf/tasks/FS/TaskPerf.fs +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fs @@ -123,6 +123,7 @@ module Helpers = let singleTask_FSharpAsync() = async { return 1 } +[] type ManyWriteFile() = [] member __.ManyWriteFile_CSharpAsync () = @@ -164,6 +165,7 @@ type ManyWriteFile() = |> Async.RunSynchronously File.Delete(path) +[] type SyncBinds() = [] member __.SyncBinds_CSharpAsync() = @@ -185,6 +187,7 @@ type SyncBinds() = for i in 1 .. manyIterations*100 do tenBindSync_FSharpAsync() |> Async.RunSynchronously |> ignore +[] type AsyncBinds() = [] member __.AsyncBinds_CSharpAsync() = @@ -206,6 +209,7 @@ type AsyncBinds() = // for i in 1 .. manyIterations do // tenBindAsync_FSharpAsync() |> Async.RunSynchronously +[] type SingleSyncTask() = [] member __.SingleSyncTask_CSharpAsync() = From 171c40be8efbff988b4b9553ac8ab72041276924 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 20 May 2019 16:05:50 +0100 Subject: [PATCH 42/45] update for code review --- src/fsharp/FSComp.txt | 1 + src/fsharp/FSharp.Core/prim-types.fs | 2 +- src/fsharp/FSharp.Core/prim-types.fsi | 2 +- src/fsharp/FSharp.Core/tasks.fs | 83 ++++++++++++++------ src/fsharp/FSharp.Core/tasks.fsi | 74 ++++++++++++----- src/fsharp/IlxGen.fs | 11 +++ src/fsharp/TypeChecker.fs | 25 ++++-- src/fsharp/xlf/FSComp.txt.cs.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.de.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.es.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.fr.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.it.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.ja.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.ko.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.pl.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.pt-BR.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.ru.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.tr.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.zh-Hans.xlf | 5 ++ src/fsharp/xlf/FSComp.txt.zh-Hant.xlf | 5 ++ tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs | 2 + 21 files changed, 213 insertions(+), 52 deletions(-) diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index c28343c01bc..91b89df70cb 100644 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -1459,6 +1459,7 @@ notAFunctionButMaybeDeclaration,"This value is not a function and cannot be appl 3243,parsInvalidAnonRecdExpr,"Invalid anonymous record expression" 3244,parsInvalidAnonRecdType,"Invalid anonymous record type" 3245,tcCopyAndUpdateNeedsRecordType,"The input to a copy-and-update expression that creates an anonymous record must be either an anonymous record or a record" +3246,ilxgenInvalidConstructInStateMachineDuringCodegen,"State machine constructs may only be used inlined code whose composition forms a valid state machine." 3300,chkInvalidFunctionParameterType,"The parameter '%s' has an invalid type '%s'. This is not permitted by the rules of Common IL." 3301,chkInvalidFunctionReturnType,"The function or method has an invalid return type '%s'. This is not permitted by the rules of Common IL." useSdkRefs,"Use reference assemblies for .NET framework references when available (Enabled by default)." diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index 2e91dec124f..f3d9c0d9576 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -108,7 +108,7 @@ namespace Microsoft.FSharp.Core inherit System.Attribute() member x.Value = value - [] + [] [] type DefaultValueAttribute(check:bool) = inherit System.Attribute() diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi index c977af45417..382f45c8079 100644 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -437,7 +437,7 @@ namespace Microsoft.FSharp.Core /// Adding this attribute to a field declaration means that the field is /// not initialized. During type checking a constraint is asserted that the field type supports 'null'. /// If the 'check' value is false then the constraint is not asserted. - [] + [] [] type DefaultValueAttribute = inherit Attribute diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index a0323040a30..59111f2b58b 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -43,7 +43,7 @@ namespace Microsoft.FSharp.Core.CompilerServices let __newEntryPoint() : int = failwith "__newEntryPoint should always be removed from compiled code" [] - let __machine<'T> : 'T = failwith "__newEntryPoint should always be removed from compiled code" + let __machine<'T> : 'T = failwith "__machine should always be removed from compiled code" [] let __machineAddr<'T> : byref<'T> = (# "ldnull throw" : byref<'T> #) @@ -95,6 +95,7 @@ type TaskStateMachineTemplate<'T> = member this.SetStateMachine(_machine) = failwith "template" module Helpers = + [] let inline Start (sm: byref>) = //Console.WriteLine("[{0}] start", sm.GetHashCode()) sm.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() @@ -102,14 +103,16 @@ module Helpers = //Console.WriteLine("[{0}] unwrap", sm.GetHashCode()) sm.MethodBuilder.Task - let inline Await (sm: byref>) (awaiter, pc) = + [] + let inline Await (sm: byref>) (awaiter: ('Awaiter :> ICriticalNotifyCompletion), pc) = sm.ResumptionPoint <- pc let mutable awaiter = awaiter - assert (not (isNull awaiter)) + //assert (not (isNull awaiter)) // Tell the builder to call us again when done. //Console.WriteLine("[{0}] AwaitUnsafeOnCompleted", sm.GetHashCode()) sm.MethodBuilder.AwaitUnsafeOnCompleted(&awaiter, &sm) + [] let inline SetResult (sm: byref>) (v: 'T) = sm.Result <- v @@ -122,13 +125,16 @@ module TaskHelpers = // else agg :> Exception /// Used to return a value. + [] let inline ret<'T> (x : 'T) = Helpers.SetResult __machineAddr> x TaskStep<'T, 'T>(true) + [] let inline RequireCanBind< ^Priority, ^TaskLike, ^TResult1, 'TResult2, 'TOverall when (^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) > (x: ^Priority) (y: ^TaskLike) __expand_continuation = ((^Priority or ^TaskLike): (static member CanBind : ^Priority * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) (x, y, __expand_continuation)) + [] let inline RequireCanReturnFrom< ^Priority, ^TaskLike, 'T when (^Priority or ^TaskLike): (static member CanReturnFrom: ^Priority * ^TaskLike -> TaskStep<'T, 'T>)> (x: ^Priority) (y: ^TaskLike) = ((^Priority or ^TaskLike): (static member CanReturnFrom : ^Priority * ^TaskLike -> TaskStep<'T, 'T>) (x, y)) @@ -144,6 +150,7 @@ module TaskHelpers = // return x // } + [] static member inline GenericAwait< ^Awaitable, ^Awaiter, ^TResult1, 'TOverall when ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion @@ -156,9 +163,10 @@ module TaskHelpers = __entryPoint CONT __expand_continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter)) else - Helpers.Await __machineAddr> ((awaiter :> ICriticalNotifyCompletion), CONT) + Helpers.Await __machineAddr> (awaiter, CONT) TaskStep<'TResult2, 'TOverall>(false) + [] static member inline GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1, 'TOverall when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) @@ -171,6 +179,7 @@ module TaskHelpers = /// Special case of the above for `Task<'TResult1>`. Have to write this T by hand to avoid confusing the compiler /// trying to decide between satisfying the constraints with `Task` or `Task<'TResult1>`. + [] let inline bindTask (task : Task<'TResult1>) (__expand_continuation : 'TResult1 -> TaskStep<'TResult2, 'TOverall>) = let CONT = __newEntryPoint() let awaiter = task.GetAwaiter() @@ -178,12 +187,13 @@ module TaskHelpers = __entryPoint CONT __expand_continuation (awaiter.GetResult()) else - Helpers.Await __machineAddr> ((awaiter :> ICriticalNotifyCompletion), CONT) + Helpers.Await __machineAddr> (awaiter, CONT) TaskStep<'TResult2, 'TOverall>(false) /// Special case of the above for `Task<'TResult1>`, for the context-insensitive builder. /// Have to write this T by hand to avoid confusing the compiler thinking our built-in bind method /// defined on the builder has fancy generic constraints on inp and T parameters. + [] let inline bindTaskConfigureFalse (task : Task<'TResult1>) (__expand_continuation : 'TResult1 -> TaskStep<'TResult2, 'TOverall>) = let CONT = __newEntryPoint () let awaiter = task.ConfigureAwait(false).GetAwaiter() @@ -191,14 +201,16 @@ module TaskHelpers = __entryPoint CONT __expand_continuation (awaiter.GetResult()) else - Helpers.Await __machineAddr> ((awaiter :> ICriticalNotifyCompletion), CONT) + Helpers.Await __machineAddr> (awaiter, CONT) TaskStep<'TResult2, 'TOverall>(false) // New style task builder. type TaskBuilder() = + [] member inline __.Delay(__expand_f : unit -> TaskStep<'T, 'TOverall>) = __expand_f + [] member inline __.Run(__expand_code : unit -> TaskStep<'T, 'T>) : Task<'T> = __stateMachineStruct, (unit -> unit), (IAsyncStateMachine -> unit), Task<'T>> // MoveNext @@ -209,9 +221,8 @@ type TaskBuilder() = try //Console.WriteLine("[{0}] step from {1}", sm.GetHashCode(), resumptionPoint) let ``__machine_step$cont`` = __expand_code() - let v = __machineAddr> if ``__machine_step$cont``.IsCompleted then - //Console.WriteLine("[{0}] unboxing result", sm.GetHashCode()) + let v = __machineAddr> //Console.WriteLine("[{0}] SetResult {1}", sm.GetHashCode(), res) v.MethodBuilder.SetResult(v.Result) with exn -> @@ -227,13 +238,16 @@ type TaskBuilder() = /// Used to represent no-ops like the implicit empty "else" branch of an "if" expression. + [] member inline __.Zero() : TaskStep = TaskStep(true) + [] member inline __.Return (x: 'T) : TaskStep<'T, 'T> = ret x /// Chains together a step with its following step. /// Note that this requires that the first step has no result. /// This prevents constructs like `task { return 1; return 2; }`. + [] member inline __.Combine(``__machine_step$cont``: TaskStep, __expand_task2: unit -> TaskStep<'T, 'TOverall>) : TaskStep<'T, 'TOverall> = if ``__machine_step$cont``.IsCompleted then __expand_task2() @@ -241,6 +255,7 @@ type TaskBuilder() = TaskStep<'T, 'TOverall>(``__machine_step$cont``.IsCompleted) /// Builds a step that executes the body while the condition predicate is true. + [] member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskStep) : TaskStep = let mutable completed = true while completed && __expand_condition() do @@ -253,6 +268,7 @@ type TaskBuilder() = /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). + [] member inline __.TryWith(__expand_body : unit -> TaskStep<'T, 'TOverall>, __expand_catch : exn -> TaskStep<'T, 'TOverall>) : TaskStep<'T, 'TOverall> = let mutable completed = TaskStep<'T, 'TOverall>(false) let mutable caught = false @@ -277,6 +293,7 @@ type TaskBuilder() = /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). + [] member inline __.TryFinally(__expand_body: unit -> TaskStep<'T, 'TOverall>, compensation : unit -> unit) : TaskStep<'T, 'TOverall> = let mutable completed = TaskStep<'T, 'TOverall>(false) try @@ -292,25 +309,29 @@ type TaskBuilder() = compensation() completed + [] member inline builder.Using(disp : #IDisposable, __expand_body : #IDisposable -> TaskStep<'T, 'TOverall>) = // A using statement is just a try/finally with the finally block disposing if non-null. builder.TryFinally( (fun () -> __expand_body disp), (fun () -> if not (isNull (box disp)) then disp.Dispose())) + [] member inline builder.For(sequence : seq<'T>, __expand_body : 'T -> TaskStep) : TaskStep = // A for loop is just a using statement on the sequence's enumerator... builder.Using (sequence.GetEnumerator(), // ... and its body is a while loop that advances the enumerator and runs the body on each element. (fun e -> builder.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) + [] member inline __.ReturnFrom (task: Task<'T>) : TaskStep<'T, 'T> = let CONT = __newEntryPoint () + let awaiter = task.GetAwaiter() if task.IsCompleted then __entryPoint CONT - ret (task.GetAwaiter().GetResult()) + ret (awaiter.GetResult()) else - Helpers.Await __machineAddr> ((task.GetAwaiter() :> ICriticalNotifyCompletion), CONT) + Helpers.Await __machineAddr> (awaiter, CONT) TaskStep<'T, 'T>(false) [] @@ -326,6 +347,7 @@ module ContextSensitiveTasks = interface IPriority3 // Give the type arguments explicitly to make it match the signature precisely + [] static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter , 'TOverall when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion @@ -333,13 +355,16 @@ module ContextSensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1)>(_priority: IPriority2, taskLike : ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1, 'TOverall> (taskLike, __expand_continuation) + [] static member inline CanBind (_priority: IPriority1, task: Task<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = bindTask task __expand_continuation + [] static member inline CanBind (_priority: IPriority1, computation : Async<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = bindTask (Async.StartAsTask computation) __expand_continuation // Give the type arguments explicitly to make it match the signature precisely + [] static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion @@ -348,16 +373,19 @@ module ContextSensitiveTasks = (_priority: IPriority1, taskLike: ^TaskLike) : TaskStep< ^T, ^T > = TaskLikeBind< ^T >.GenericAwait< ^TaskLike, ^Awaiter, ^T, ^T > (taskLike, ret< ^T >) + [] static member inline CanReturnFrom (_priority: IPriority1, computation : Async<'T>) = bindTask (Async.StartAsTask computation) (ret<'T>) : TaskStep<'T, 'T> type TaskBuilder with - member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 , 'TOverall + [] + member inline __.Bind< ^TaskLike, ^TResult1, 'TResult2 , 'TOverall when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>)> (task: ^TaskLike, __expand_continuation: ^TResult1 -> TaskStep<'TResult2, 'TOverall>) : TaskStep<'TResult2, 'TOverall> = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2, 'TOverall> Unchecked.defaultof task __expand_continuation - member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T, 'T>) > (task: ^TaskLike) : TaskStep<'T, 'T> + [] + member inline __.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T, 'T>) > (task: ^TaskLike) : TaskStep<'T, 'T> = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> Unchecked.defaultof task module ContextInsensitiveTasks = @@ -370,6 +398,7 @@ module ContextInsensitiveTasks = interface IPriority2 interface IPriority3 + [] static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter, 'TOverall when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion @@ -377,6 +406,7 @@ module ContextInsensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority3, taskLike: ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = TaskLikeBind<'TResult2>.GenericAwait< ^TaskLike, ^Awaiter, ^TResult1, 'TOverall> (taskLike, __expand_continuation) + [] static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter , 'TOverall when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) @@ -385,40 +415,43 @@ module ContextInsensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1)> (_priority: IPriority2, configurableTaskLike: ^TaskLike, __expand_continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = TaskLikeBind<'TResult2>.GenericAwaitConfigureFalse< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1, 'TOverall> (configurableTaskLike, __expand_continuation) + [] static member inline CanBind (_priority :IPriority1, task: Task<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = bindTaskConfigureFalse task __expand_continuation + [] static member inline CanBind (_priority: IPriority1, computation : Async<'TResult1>, __expand_continuation: ('TResult1 -> TaskStep<'TResult2, 'TOverall>)) : TaskStep<'TResult2, 'TOverall> = bindTaskConfigureFalse (Async.StartAsTask computation) __expand_continuation -(* + [] static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T when ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) and ^Awaiter : (member GetResult : unit -> ^T) > (_priority: IPriority2, taskLike: ^Awaitable) - = TaskLikeBind< ^T >.GenericAwait< ^Awaitable, ^Awaiter, ^T >(taskLike, ret) + = TaskLikeBind< ^T >.GenericAwait< ^Awaitable, ^Awaiter, ^T, ^T >(taskLike, ret< ^T > ) - static member inline CanReturnFrom< ^TaskLike, ^Awaitable, ^Awaiter, ^TResult1 + [] + static member inline CanReturnFrom< ^TaskLike, ^Awaitable, ^Awaiter, ^T when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^TResult1) > (_: IPriority1, configurableTaskLike: ^TaskLike) - = TaskLikeBind< ^TResult1 >.GenericAwaitConfigureFalse(configurableTaskLike, ret) - + and ^Awaiter : (member GetResult : unit -> ^T ) > (_: IPriority1, configurableTaskLike: ^TaskLike) + = TaskLikeBind< ^T >.GenericAwaitConfigureFalse(configurableTaskLike, ret< ^T >) + [] static member inline CanReturnFrom (_priority: IPriority1, computation: Async<'T>) - = bindTaskConfigureFalse sm (Async.StartAsTask computation) ret -*) + = bindTaskConfigureFalse (Async.StartAsTask computation) ret type TaskBuilder with - member inline builder.Bind< ^TaskLike, ^TResult1, 'TResult2 , 'TOverall + [] + member inline __.Bind< ^TaskLike, ^TResult1, 'TResult2 , 'TOverall when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>)> (task: ^TaskLike, __expand_continuation: ^TResult1 -> TaskStep<'TResult2, 'TOverall>) : TaskStep<'TResult2, 'TOverall> = RequireCanBind< Witnesses, ^TaskLike, ^TResult1, 'TResult2, 'TOverall> Unchecked.defaultof task __expand_continuation -(* - member inline builder.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T>) > (task: ^TaskLike) : TaskStep<'T> - = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> builder.TaskStateMachineTemplate Unchecked.defaultof task -*) + + [] + member inline __.ReturnFrom< ^TaskLike, 'T when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T, 'T>) > (task: ^TaskLike) : TaskStep<'T, 'T> + = RequireCanReturnFrom< Witnesses, ^TaskLike, 'T> Unchecked.defaultof task #endif diff --git a/src/fsharp/FSharp.Core/tasks.fsi b/src/fsharp/FSharp.Core/tasks.fsi index db256e3324d..bf2ef8b0eef 100644 --- a/src/fsharp/FSharp.Core/tasks.fsi +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -72,18 +72,40 @@ type TaskStateMachineTemplate<'T> = interface IAsyncStateMachine +[] type TaskBuilder = - new: unit -> TaskBuilder + + [] member inline Combine: task1: TaskStep * task2: (unit -> TaskStep<'T, 'TOverall>) -> TaskStep<'T, 'TOverall> + + [] member inline Delay: f: (unit -> TaskStep<'T, 'TOverall>) -> (unit -> TaskStep<'T, 'TOverall>) + + [] member inline For: sequence: seq<'T> * body: ('T -> TaskStep) -> TaskStep + + [] member inline Return: x: 'T -> TaskStep<'T, 'T> + + [] member inline ReturnFrom: task: Task<'T> -> TaskStep<'T, 'T> + + [] member inline Run: code: (unit -> TaskStep<'T, 'T>) -> Task<'T> + + [] member inline TryFinally: body: (unit -> TaskStep<'T, 'TOverall>) * fin: (unit -> unit) -> TaskStep<'T, 'TOverall> + + [] member inline TryWith: body: (unit -> TaskStep<'T, 'TOverall>) * catch: (exn -> TaskStep<'T, 'TOverall>) -> TaskStep<'T, 'TOverall> + + [] member inline Using: disp: 'Resource * body: ('Resource -> TaskStep<'T, 'TOverall>) -> TaskStep<'T, 'TOverall> when 'Resource :> IDisposable + + [] member inline While: condition: (unit -> bool) * body: (unit -> TaskStep) -> TaskStep + + [] member inline Zero: unit -> TaskStep [] @@ -101,6 +123,7 @@ module ContextSensitiveTasks = interface IPriority3 /// Provides evidence that task-like types can be used in 'bind' in a task computation expression + [] static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter, 'TOverall > : priority: IPriority2 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep< 'TResult2, 'TOverall>) -> TaskStep< 'TResult2, 'TOverall> when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) @@ -109,12 +132,15 @@ module ContextSensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression + [] static member inline CanBind: priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> /// Provides evidence that F# Async computations can be used in 'bind' in a task computation expression + [] static member inline CanBind: priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> /// Provides evidence that task-like types can be used in 'return' in a task workflow + [] static member inline CanReturnFrom< ^TaskLike, ^Awaiter, ^T> : priority: IPriority1 * taskLike: ^TaskLike -> TaskStep< ^T, ^T > when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion @@ -122,16 +148,19 @@ module ContextSensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^T) /// Provides evidence that F# Async computations can be used in 'return' in a task computation expression + [] static member inline CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T, 'T> type TaskBuilder with - /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) + /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics + [] + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) - /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics - member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'T, 'T > - when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T, 'T>) + /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics + [] + member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'T, 'T > + when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T, 'T>) module ContextInsensitiveTasks = @@ -150,6 +179,7 @@ module ContextInsensitiveTasks = interface IPriority3 /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression + [] static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaiter, 'TOverall > : priority: IPriority3 * taskLike: ^TaskLike * k: ( ^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> when ^TaskLike: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion @@ -157,6 +187,7 @@ module ContextInsensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that task-like computations can be used in 'bind' in a task computation expression + [] static member inline CanBind< ^TaskLike, ^TResult1, 'TResult2, ^Awaitable, ^Awaiter, 'TOverall > : priority: IPriority2 * taskLike: ^TaskLike * k: (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> when ^TaskLike: (member ConfigureAwait: bool -> ^Awaitable) and ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) @@ -165,41 +196,44 @@ module ContextInsensitiveTasks = and ^Awaiter: (member GetResult: unit -> ^TResult1) /// Provides evidence that tasks can be used in 'bind' in a task computation expression + [] static member inline CanBind: priority: IPriority1 * task: Task<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> /// Provides evidence that F# async computations can be used in 'bind' in a task computation expression + [] static member inline CanBind: priority: IPriority1 * computation: Async<'TResult1> * k: ('TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> -(* /// Provides evidence that types following the "awaitable" pattern can be used in 'return!' in a task computation expression - static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T> : IPriority2 * taskLike: ^Awaitable -> TaskStep< ^T> + [] + static member inline CanReturnFrom< ^Awaitable, ^Awaiter, ^T> : IPriority2 * taskLike: ^Awaitable -> TaskStep< ^T, ^T> when ^Awaitable: (member GetAwaiter: unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter: (member get_IsCompleted: unit -> bool) and ^Awaiter: (member GetResult: unit -> ^T) /// Provides evidence that types following the task-like pattern can be used in 'return!' in a task computation expression + [] static member inline CanReturnFrom< ^TaskLike, ^Awaitable, ^Awaiter, ^T when ^TaskLike : (member ConfigureAwait : bool -> ^Awaitable) and ^Awaitable : (member GetAwaiter : unit -> ^Awaiter) and ^Awaiter :> ICriticalNotifyCompletion and ^Awaiter : (member get_IsCompleted : unit -> bool) - and ^Awaiter : (member GetResult : unit -> ^T) > : IPriority1 * configurableTaskLike: ^TaskLike -> TaskStep< ^T> + and ^Awaiter : (member GetResult : unit -> ^T) > : IPriority1 * configurableTaskLike: ^TaskLike -> TaskStep< ^T, ^T> /// Provides evidence that F# async computations can be used in 'return!' in a task computation expression - static member inline CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T> -*) + [] + static member inline CanReturnFrom: IPriority1 * computation: Async<'T> -> TaskStep<'T, 'T> type TaskBuilder with - /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics - member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> - when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) + /// Provides the ability to bind to a variety of tasks, using context-sensitive semantics + [] + member inline Bind : task: ^TaskLike * continuation: (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall> + when (Witnesses or ^TaskLike): (static member CanBind: Witnesses * ^TaskLike * (^TResult1 -> TaskStep<'TResult2, 'TOverall>) -> TaskStep<'TResult2, 'TOverall>) -(* - /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics - member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'TResult > - when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'TResult>) -*) + /// Provides the ability to return results from a variety of tasks, using context-sensitive semantics + [] + member inline ReturnFrom: a: ^TaskLike -> TaskStep< 'T, 'T > + when (Witnesses or ^TaskLike): (static member CanReturnFrom: Witnesses * ^TaskLike -> TaskStep<'T, 'T>) #endif \ No newline at end of file diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index e22856e0cf9..6080ccd032f 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -2989,6 +2989,17 @@ and GenApp cenv cgbuf eenv (f, fty, tyargs, args, m) sequel = CG.EmitInstr cgbuf (pop 2) (Push [g.ilg.typ_Bool]) AI_ceq GenSequel cenv eenv.cloc cgbuf sequel + | Expr.Val (v, _, m), _, _ + when valRefEq g v g.cgh_entryPoint_vref || + valRefEq g v g.cgh_jumptable_vref || + valRefEq g v g.cgh_machine_vref || + valRefEq g v g.cgh_machineAddr_vref || + valRefEq g v g.cgh_newEntryPoint_vref || + valRefEq g v g.cgh_return_vref || + valRefEq g v g.cgh_stateMachineStruct_vref|| + valRefEq g v g.cgh_stateMachine_vref -> + errorR(Error(FSComp.SR.ilxgenInvalidConstructInStateMachineDuringCodegen(), m)) + // Emit "methodhandleof" calls as ldtoken instructions // // The token for the "GenericMethodDefinition" is loaded diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index c5e91ebfa5a..a167818cdea 100644 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -8338,17 +8338,21 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv | None -> // This only occurs in final position in a sequence match comp with + // "do! expr;" in final position is treated as { let! () = expr in return () } when Return is provided or as { let! () = expr in zero } otherwise | SynExpr.DoBang (rhsExpr, m) -> let mUnit = rhsExpr.Range let rhsExpr = mkSourceExpr rhsExpr if isQuery then error(Error(FSComp.SR.tcBindMayNotBeUsedInQueries(), m)) let bodyExpr = - if isNil (TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Return" builderTy) then - SynExpr.ImplicitZero m - else - SynExpr.YieldOrReturn ((false, true), SynExpr.Const (SynConst.Unit, m), m) + match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Return" builderTy with + | [] -> SynExpr.ImplicitZero m + | _ -> + match TryFindIntrinsicOrExtensionMethInfo ResultCollectionSettings.AtMostOneResult cenv env m ad "Zero" builderTy with + | minfo :: _ when MethInfoHasAttribute cenv.g m cenv.g.attrib_DefaultValueAttribute minfo -> SynExpr.ImplicitZero m + | _ -> SynExpr.YieldOrReturn ((false, true), SynExpr.Const (SynConst.Unit, m), m) trans true q varSpace (SynExpr.LetOrUseBang (NoSequencePointAtDoBinding, false, false, SynPat.Const(SynConst.Unit, mUnit), rhsExpr, bodyExpr, m)) translatedCtxt + // "expr;" in final position is treated as { expr; zero } // Suppress the sequence point on the "zero" | _ -> @@ -10768,7 +10772,18 @@ and TcNormalizedBinding declKind (cenv: cenv) env tpenv overallTy safeThisValOpt let argAndRetAttribs = ArgAndRetAttribs(argAttribs, retAttribs) - if HasFSharpAttribute cenv.g cenv.g.attrib_DefaultValueAttribute valAttribs then + let isZeroMethod = + match declKind, pat with + | ModuleOrMemberBinding, SynPat.Named(_, name, _, _, _) when name.idText = "Zero" -> + match memberFlagsOpt with + | Some memberFlags -> + match memberFlags.MemberKind with + | MemberKind.Member -> true + | _ -> false + | _ -> false + | _ -> false + + if HasFSharpAttribute cenv.g cenv.g.attrib_DefaultValueAttribute valAttribs && not isZeroMethod then errorR(Error(FSComp.SR.tcDefaultValueAttributeRequiresVal(), mBinding)) let isThreadStatic = isThreadOrContextStatic cenv.g valAttribs diff --git a/src/fsharp/xlf/FSComp.txt.cs.xlf b/src/fsharp/xlf/FSComp.txt.cs.xlf index 23ea06f75a8..4fe6477366e 100644 --- a/src/fsharp/xlf/FSComp.txt.cs.xlf +++ b/src/fsharp/xlf/FSComp.txt.cs.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. Není definovaný obor názvů {0}. diff --git a/src/fsharp/xlf/FSComp.txt.de.xlf b/src/fsharp/xlf/FSComp.txt.de.xlf index 7c13cf3c311..8f23d4459a0 100644 --- a/src/fsharp/xlf/FSComp.txt.de.xlf +++ b/src/fsharp/xlf/FSComp.txt.de.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. Der Namespace "{0}" ist nicht definiert. diff --git a/src/fsharp/xlf/FSComp.txt.es.xlf b/src/fsharp/xlf/FSComp.txt.es.xlf index 9709b6c3abf..1782cd9a498 100644 --- a/src/fsharp/xlf/FSComp.txt.es.xlf +++ b/src/fsharp/xlf/FSComp.txt.es.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. El espacio de nombres "{0}" no está definido. diff --git a/src/fsharp/xlf/FSComp.txt.fr.xlf b/src/fsharp/xlf/FSComp.txt.fr.xlf index f7a5bc43329..3e27521e9e7 100644 --- a/src/fsharp/xlf/FSComp.txt.fr.xlf +++ b/src/fsharp/xlf/FSComp.txt.fr.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. L'espace de noms '{0}' n'est pas défini. diff --git a/src/fsharp/xlf/FSComp.txt.it.xlf b/src/fsharp/xlf/FSComp.txt.it.xlf index 8e4eccbd9cd..d204138b08d 100644 --- a/src/fsharp/xlf/FSComp.txt.it.xlf +++ b/src/fsharp/xlf/FSComp.txt.it.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. Lo spazio dei nomi '{0}' non è definito. diff --git a/src/fsharp/xlf/FSComp.txt.ja.xlf b/src/fsharp/xlf/FSComp.txt.ja.xlf index b49ebd63d94..c30a392c612 100644 --- a/src/fsharp/xlf/FSComp.txt.ja.xlf +++ b/src/fsharp/xlf/FSComp.txt.ja.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. 名前空間 '{0}' が定義されていません。 diff --git a/src/fsharp/xlf/FSComp.txt.ko.xlf b/src/fsharp/xlf/FSComp.txt.ko.xlf index 4f106b57958..144db2e8e57 100644 --- a/src/fsharp/xlf/FSComp.txt.ko.xlf +++ b/src/fsharp/xlf/FSComp.txt.ko.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. '{0}' 네임스페이스가 정의되지 않았습니다. diff --git a/src/fsharp/xlf/FSComp.txt.pl.xlf b/src/fsharp/xlf/FSComp.txt.pl.xlf index 15ac9b912c6..cc27d4266c6 100644 --- a/src/fsharp/xlf/FSComp.txt.pl.xlf +++ b/src/fsharp/xlf/FSComp.txt.pl.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. Nie zdefiniowano przestrzeni nazw „{0}”. diff --git a/src/fsharp/xlf/FSComp.txt.pt-BR.xlf b/src/fsharp/xlf/FSComp.txt.pt-BR.xlf index 1d50b7356cf..047f41790b2 100644 --- a/src/fsharp/xlf/FSComp.txt.pt-BR.xlf +++ b/src/fsharp/xlf/FSComp.txt.pt-BR.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. O namespace '{0}' não está definido. diff --git a/src/fsharp/xlf/FSComp.txt.ru.xlf b/src/fsharp/xlf/FSComp.txt.ru.xlf index 5e54c71aa4d..4b36b623a19 100644 --- a/src/fsharp/xlf/FSComp.txt.ru.xlf +++ b/src/fsharp/xlf/FSComp.txt.ru.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. Пространство имен "{0}" не определено. diff --git a/src/fsharp/xlf/FSComp.txt.tr.xlf b/src/fsharp/xlf/FSComp.txt.tr.xlf index c3f580ec6b4..100228f0780 100644 --- a/src/fsharp/xlf/FSComp.txt.tr.xlf +++ b/src/fsharp/xlf/FSComp.txt.tr.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. '{0}' ad alanı tanımlı değil. diff --git a/src/fsharp/xlf/FSComp.txt.zh-Hans.xlf b/src/fsharp/xlf/FSComp.txt.zh-Hans.xlf index 99e41ca6b93..a6915232c50 100644 --- a/src/fsharp/xlf/FSComp.txt.zh-Hans.xlf +++ b/src/fsharp/xlf/FSComp.txt.zh-Hans.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. 未定义命名空间“{0}”。 diff --git a/src/fsharp/xlf/FSComp.txt.zh-Hant.xlf b/src/fsharp/xlf/FSComp.txt.zh-Hant.xlf index 70b7a400f45..7493c17b150 100644 --- a/src/fsharp/xlf/FSComp.txt.zh-Hant.xlf +++ b/src/fsharp/xlf/FSComp.txt.zh-Hant.xlf @@ -2,6 +2,11 @@ + + State machine constructs may only be used inlined code whose composition forms a valid state machine. + State machine constructs may only be used inlined code whose composition forms a valid state machine. + + The namespace '{0}' is not defined. 未定義命名空間 '{0}'。 diff --git a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs index d350c94c5e5..675ff226111 100644 --- a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs +++ b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs @@ -3,6 +3,8 @@ using System.IO; using System.Threading.Tasks; +#pragma warning disable 1998 + public static class TaskPerfCSharp { public const int BufferSize = 128; From bbe118dcd59c08ff31e4a4efb4e302ebe5e25400 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Mon, 20 May 2019 22:51:21 +0100 Subject: [PATCH 43/45] updates --- src/fsharp/FSharp.Core/tasks.fs | 55 +++++++++-------- src/fsharp/LowerCallsAndSeqs.fs | 2 +- .../Microsoft.FSharp.Control/Tasks.fs | 59 ++++++++++++++----- 3 files changed, 71 insertions(+), 45 deletions(-) diff --git a/src/fsharp/FSharp.Core/tasks.fs b/src/fsharp/FSharp.Core/tasks.fs index 59111f2b58b..babe2442708 100644 --- a/src/fsharp/FSharp.Core/tasks.fs +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -104,9 +104,8 @@ module Helpers = sm.MethodBuilder.Task [] - let inline Await (sm: byref>) (awaiter: ('Awaiter :> ICriticalNotifyCompletion), pc) = + let inline Await (sm: byref>) (awaiter: byref<('Awaiter :> ICriticalNotifyCompletion)>, pc) = sm.ResumptionPoint <- pc - let mutable awaiter = awaiter //assert (not (isNull awaiter)) // Tell the builder to call us again when done. //Console.WriteLine("[{0}] AwaitUnsafeOnCompleted", sm.GetHashCode()) @@ -157,13 +156,13 @@ module TaskHelpers = and ^Awaiter : (member get_IsCompleted : unit -> bool) and ^Awaiter : (member GetResult : unit -> ^TResult1) > (awaitable : ^Awaitable, __expand_continuation : ^TResult1 -> TaskStep<'TResult2, 'TOverall>) : TaskStep<'TResult2, 'TOverall> = - let awaiter = (^Awaitable : (member GetAwaiter : unit -> ^Awaiter)(awaitable)) // get an awaiter from the awaitable + let mutable awaiter = (^Awaitable : (member GetAwaiter : unit -> ^Awaiter)(awaitable)) // get an awaiter from the awaitable let CONT = __newEntryPoint () if (^Awaiter : (member get_IsCompleted : unit -> bool)(awaiter)) then // shortcut to continue immediately __entryPoint CONT __expand_continuation (^Awaiter : (member GetResult : unit -> ^TResult1)(awaiter)) else - Helpers.Await __machineAddr> (awaiter, CONT) + Helpers.Await __machineAddr> (&awaiter, CONT) TaskStep<'TResult2, 'TOverall>(false) [] @@ -182,12 +181,12 @@ module TaskHelpers = [] let inline bindTask (task : Task<'TResult1>) (__expand_continuation : 'TResult1 -> TaskStep<'TResult2, 'TOverall>) = let CONT = __newEntryPoint() - let awaiter = task.GetAwaiter() + let mutable awaiter = task.GetAwaiter() if awaiter.IsCompleted then __entryPoint CONT __expand_continuation (awaiter.GetResult()) else - Helpers.Await __machineAddr> (awaiter, CONT) + Helpers.Await __machineAddr> (&awaiter, CONT) TaskStep<'TResult2, 'TOverall>(false) /// Special case of the above for `Task<'TResult1>`, for the context-insensitive builder. @@ -196,12 +195,12 @@ module TaskHelpers = [] let inline bindTaskConfigureFalse (task : Task<'TResult1>) (__expand_continuation : 'TResult1 -> TaskStep<'TResult2, 'TOverall>) = let CONT = __newEntryPoint () - let awaiter = task.ConfigureAwait(false).GetAwaiter() + let mutable awaiter = task.ConfigureAwait(false).GetAwaiter() if awaiter.IsCompleted then __entryPoint CONT __expand_continuation (awaiter.GetResult()) else - Helpers.Await __machineAddr> (awaiter, CONT) + Helpers.Await __machineAddr> (&awaiter, CONT) TaskStep<'TResult2, 'TOverall>(false) // New style task builder. @@ -257,57 +256,57 @@ type TaskBuilder() = /// Builds a step that executes the body while the condition predicate is true. [] member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskStep) : TaskStep = - let mutable completed = true - while completed && __expand_condition() do - completed <- false + let mutable __stack_completed = true + while __stack_completed && __expand_condition() do + __stack_completed <- false // The body of the 'while' may include an early exit, e.g. return from entire method let ``__machine_step$cont`` = __expand_body () // If we make it to the assignment we prove we've made a step - completed <- ``__machine_step$cont``.IsCompleted - TaskStep(completed) + __stack_completed <- ``__machine_step$cont``.IsCompleted + TaskStep(__stack_completed) /// Wraps a step in a try/with. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). [] member inline __.TryWith(__expand_body : unit -> TaskStep<'T, 'TOverall>, __expand_catch : exn -> TaskStep<'T, 'TOverall>) : TaskStep<'T, 'TOverall> = - let mutable completed = TaskStep<'T, 'TOverall>(false) - let mutable caught = false - let mutable savedExn = Unchecked.defaultof<_> + let mutable __stack_completed = false + let mutable __stack_caught = false + let mutable __stack_savedExn = Unchecked.defaultof<_> try // The try block may contain resumption points. // This is handled by the state machine rewriting let ``__machine_step$cont`` = __expand_body () // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with // may skip this step. - completed <- ``__machine_step$cont`` + __stack_completed <- ``__machine_step$cont``.IsCompleted with exn -> // The catch block may not contain resumption points. - caught <- true - savedExn <- exn + __stack_caught <- true + __stack_savedExn <- exn - if caught then + if __stack_caught then // Place the catch code outside the catch block - __expand_catch savedExn + __expand_catch __stack_savedExn else - completed + TaskStep<'T, 'TOverall>(__stack_completed) /// Wraps a step in a try/finally. This catches exceptions both in the evaluation of the function /// to retrieve the step, and in the continuation of the step (if any). [] member inline __.TryFinally(__expand_body: unit -> TaskStep<'T, 'TOverall>, compensation : unit -> unit) : TaskStep<'T, 'TOverall> = - let mutable completed = TaskStep<'T, 'TOverall>(false) + let mutable __stack_completed = false try let ``__machine_step$cont`` = __expand_body () // If we make it to the assignment we prove we've made a step, an early 'ret' exit out of the try/with // may skip this step. - completed <- ``__machine_step$cont`` + __stack_completed <- ``__machine_step$cont``.IsCompleted with _ -> compensation() reraise() - if completed.IsCompleted then + if __stack_completed then compensation() - completed + TaskStep<'T, 'TOverall>(__stack_completed) [] member inline builder.Using(disp : #IDisposable, __expand_body : #IDisposable -> TaskStep<'T, 'TOverall>) = @@ -326,12 +325,12 @@ type TaskBuilder() = [] member inline __.ReturnFrom (task: Task<'T>) : TaskStep<'T, 'T> = let CONT = __newEntryPoint () - let awaiter = task.GetAwaiter() + let mutable awaiter = task.GetAwaiter() if task.IsCompleted then __entryPoint CONT ret (awaiter.GetResult()) else - Helpers.Await __machineAddr> (awaiter, CONT) + Helpers.Await __machineAddr> (&awaiter, CONT) TaskStep<'T, 'T>(false) [] diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index aeb84c1b5d5..c3aef4962e8 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -1316,7 +1316,7 @@ let ConvertStateMachineExprToObject g overallExpr = let bind = mkBind bind.SequencePointInfo bind.Var (ApplyExpansions g env bind.Expr) let resBody = ConvertStateMachineCode env pcExpr bodyExpr - if bind.Var.IsCompiledAsTopLevel || not (resBody.asyncVars.FreeLocals.Contains(bind.Var)) then + if bind.Var.IsCompiledAsTopLevel || not (resBody.asyncVars.FreeLocals.Contains(bind.Var)) || bind.Var.LogicalName.StartsWith "__stack_" then (RepresentBindingAsLiftedOrLocal bind resBody m) else // printfn "found state variable %s" bind.Var.DisplayName diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs index 8a7a66d18a1..c7d14b63188 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs @@ -559,6 +559,7 @@ let testExceptionAttachedToTaskWithoutAwait() = require caught "didn't catch" let testExceptionAttachedToTaskWithAwait() = + printfn "running testExceptionAttachedToTaskWithAwait" let mutable ranA = false let mutable ranB = false let t = @@ -591,6 +592,7 @@ let testExceptionAttachedToTaskWithAwait() = require caught "didn't catch" let testExceptionThrownInFinally() = + printfn "running testExceptionThrownInFinally" let mutable ranInitial = false let mutable ranNext = false let mutable ranFinally = 0 @@ -616,6 +618,7 @@ let testExceptionThrownInFinally() = require (ranFinally = 1) "didn't run finally exactly once" let test2ndExceptionThrownInFinally() = + printfn "running test2ndExceptionThrownInFinally" let mutable ranInitial = false let mutable ranNext = false let mutable ranFinally = 0 @@ -642,6 +645,7 @@ let test2ndExceptionThrownInFinally() = require (ranFinally = 1) "didn't run finally exactly once" let testFixedStackWhileLoop() = + printfn "running testFixedStackWhileLoop" let t = task { let mutable maxDepth = Nullable() @@ -660,6 +664,7 @@ let testFixedStackWhileLoop() = require (t.Result = BIG) "didn't get to big number" let testFixedStackForLoop() = + printfn "running testFixedStackForLoop" let mutable ran = false let t = task { @@ -690,6 +695,7 @@ let testTypeInference() = t2.Wait() let testNoStackOverflowWithImmediateResult() = + printfn "running testNoStackOverflowWithImmediateResult" let longLoop = task { let mutable n = 0 @@ -700,6 +706,7 @@ let testNoStackOverflowWithImmediateResult() = longLoop.Wait() let testNoStackOverflowWithYieldResult() = + printfn "running testNoStackOverflowWithYieldResult" let longLoop = task { let mutable n = 0 @@ -715,6 +722,7 @@ let testNoStackOverflowWithYieldResult() = longLoop.Wait() let testSmallTailRecursion() = + printfn "running testSmallTailRecursion" let rec loop n = task { // larger N would stack overflow on Mono, eat heap mem on MS .NET @@ -732,6 +740,7 @@ let testSmallTailRecursion() = shortLoop.Wait() let testTryOverReturnFrom() = + printfn "running testTryOverReturnFrom" let inner() = task { do! Task.Yield() @@ -749,6 +758,7 @@ let testTryOverReturnFrom() = require (t.Result = 2) "didn't catch" let testTryFinallyOverReturnFromWithException() = + printfn "running testTryFinallyOverReturnFromWithException" let inner() = task { do! Task.Yield() @@ -771,6 +781,7 @@ let testTryFinallyOverReturnFromWithException() = require (m = 1) "didn't run finally" let testTryFinallyOverReturnFromWithoutException() = + printfn "running testTryFinallyOverReturnFromWithoutException" let inner() = task { do! Task.Yield() @@ -862,22 +873,38 @@ let main argv = testCatching2() testNestedCatching() testWhileLoopSync() - testWhileLoopAsync() - testTryFinallyHappyPath() - testTryFinallySadPath() - testTryFinallyCaught() - testUsing() - testUsingFromTask() - testUsingSadPath() - testForLoopA() - testForLoopSadPath() - testForLoopSadPathComplex() - testExceptionAttachedToTaskWithoutAwait() - testExceptionAttachedToTaskWithAwait() - testExceptionThrownInFinally() - test2ndExceptionThrownInFinally() - testFixedStackWhileLoop() - testFixedStackForLoop() + for i in 1 .. 100 do + testWhileLoopAsync() + for i in 1 .. 5 do + testTryFinallyHappyPath() + for i in 1 .. 5 do + testTryFinallySadPath() + for i in 1 .. 5 do + testTryFinallyCaught() + for i in 1 .. 5 do + testUsing() + for i in 1 .. 5 do + testUsingFromTask() + for i in 1 .. 5 do + testUsingSadPath() + for i in 1 .. 100 do + testForLoopA() + for i in 1 .. 5 do + testForLoopSadPath() + for i in 1 .. 5 do + testForLoopSadPathComplex() + for i in 1 .. 5 do + testExceptionAttachedToTaskWithoutAwait() + for i in 1 .. 5 do + testExceptionAttachedToTaskWithAwait() + for i in 1 .. 5 do + testExceptionThrownInFinally() + for i in 1 .. 5 do + test2ndExceptionThrownInFinally() + for i in 1 .. 100 do + testFixedStackWhileLoop() + for i in 1 .. 100 do + testFixedStackForLoop() testTypeInference() testNoStackOverflowWithImmediateResult() testNoStackOverflowWithYieldResult() From 37e9d3994278ff737c5915308b00f3984ded3831 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 21 May 2019 13:29:28 +0100 Subject: [PATCH 44/45] fix incremental build --- FSharpBuild.Directory.Build.targets | 4 ++-- fcs/Directory.Build.targets | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/FSharpBuild.Directory.Build.targets b/FSharpBuild.Directory.Build.targets index 742f43fb3f5..d87d68d36c7 100644 --- a/FSharpBuild.Directory.Build.targets +++ b/FSharpBuild.Directory.Build.targets @@ -22,7 +22,7 @@ - + @@ -51,7 +51,7 @@ - + diff --git a/fcs/Directory.Build.targets b/fcs/Directory.Build.targets index ea3d9bd8c42..19b6fcd667d 100644 --- a/fcs/Directory.Build.targets +++ b/fcs/Directory.Build.targets @@ -17,7 +17,7 @@ - + @@ -46,7 +46,7 @@ - + From 76250752adb4cc488602098bce4959716c9c70df Mon Sep 17 00:00:00 2001 From: Don Syme Date: Tue, 21 May 2019 22:36:40 +0100 Subject: [PATCH 45/45] lift restriction on union cases in state machines --- src/fsharp/DetupleArgs.fs | 2 +- src/fsharp/FindUnsolved.fs | 2 +- src/fsharp/IlxGen.fs | 87 +++++++++++++-------- src/fsharp/InnerLambdasToTopLevelFuncs.fs | 4 +- src/fsharp/LowerCallsAndSeqs.fs | 45 ++++++++--- src/fsharp/Optimizer.fs | 16 ++-- src/fsharp/PatternMatchCompilation.fs | 9 ++- src/fsharp/PostInferenceChecks.fs | 2 +- src/fsharp/QuotationTranslator.fs | 6 +- src/fsharp/TastOps.fs | 58 ++++++++------ src/fsharp/TastPickle.fs | 4 +- src/fsharp/TypeChecker.fs | 23 +++--- src/fsharp/symbols/Exprs.fs | 2 +- src/fsharp/tast.fs | 2 +- tests/fsharp/core/state-machines/list.fs | 27 +++++-- tests/fsharp/core/state-machines/seq2.fs | 14 +++- tests/fsharp/core/state-machines/sync.fs | 42 ++++++---- tests/fsharp/core/state-machines/sync.fsi | 39 ++++----- tests/fsharp/core/state-machines/taskSeq.fs | 30 +++++-- tests/fsharp/perf/tasks/FS/TaskPerf.fs | 52 ++++++++---- tests/fsharp/perf/tasks/FS/TaskPerf.fsproj | 5 ++ 21 files changed, 299 insertions(+), 172 deletions(-) diff --git a/src/fsharp/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index 8ae41acb317..02885ee9228 100644 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -295,7 +295,7 @@ module GlobalUsageAnalysis = let context = [] recognise context origExpr - let targetIntercept exprF z = function TTarget(_argvs, body, _) -> Some (foldUnderLambda exprF z body) + let targetIntercept exprF z = function TTarget(_argvs, body, _, _) -> Some (foldUnderLambda exprF z body) let tmethodIntercept exprF z = function TObjExprMethod(_, _, _, _, e, _m) -> Some (foldUnderLambda exprF z e) {ExprFolder0 with diff --git a/src/fsharp/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index a2e4230d085..90acab0f27a 100644 --- a/src/fsharp/FindUnsolved.fs +++ b/src/fsharp/FindUnsolved.fs @@ -162,7 +162,7 @@ and accExprs cenv env exprs = and accTargets cenv env m ty targets = Array.iter (accTarget cenv env m ty) targets -and accTarget cenv env _m _ty (TTarget(_vs, e, _)) = +and accTarget cenv env _m _ty (TTarget(_vs, e, _, _)) = accExpr cenv env e and accDTree cenv env x = diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 6080ccd032f..394b05e8c77 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -2211,7 +2211,7 @@ let rec GenExpr (cenv: cenv) (cgbuf: CodeGenBuffer) eenv sp expr sequel = let startScope, endScope as scopeMarks = StartDelayedLocalScope "let" cgbuf let eenv = AllocStorageForBind cenv cgbuf scopeMarks eenv bind let spBind = GenSequencePointForBind cenv cgbuf bind - GenBindingAfterSequencePoint cenv cgbuf eenv spBind bind (Some startScope) + GenBindingAfterSequencePoint cenv cgbuf eenv spBind bind false (Some startScope) // Work out if we need a sequence point for the body. For any "user" binding then the body gets SPAlways. // For invisible compiler-generated bindings we just use "sp", unless its body is another invisible binding @@ -2914,7 +2914,7 @@ and GenUntupledArgExpr cenv cgbuf eenv m argInfos expr sequel = let bind = mkCompGenBind locv expr LocalScope "untuple" cgbuf (fun scopeMarks -> let eenvinner = AllocStorageForBind cenv cgbuf scopeMarks eenv bind - GenBinding cenv cgbuf eenvinner bind + GenBinding cenv cgbuf eenvinner bind false let tys = destRefTupleTy g ty assert (tys.Length = numRequiredExprs) // TODO - tupInfoRef @@ -5050,7 +5050,7 @@ and GenDecisionTreeAndTargetsInner cenv cgbuf inplabOpt stackAtTargets eenv tree let startScope, endScope as scopeMarks = StartDelayedLocalScope "dtreeBind" cgbuf let eenv = AllocStorageForBind cenv cgbuf scopeMarks eenv bind let sp = GenSequencePointForBind cenv cgbuf bind - GenBindingAfterSequencePoint cenv cgbuf eenv sp bind (Some startScope) + GenBindingAfterSequencePoint cenv cgbuf eenv sp bind false (Some startScope) // We don't get the scope marks quite right for dtree-bound variables. This is because // we effectively lose an EndLocalScope for all dtrees that go to the same target // So we just pretend that the variable goes out of scope here. @@ -5068,9 +5068,9 @@ and GetTarget (targets:_[]) n = targets.[n] and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx targets repeatSP targetInfos sequel = - let (TTarget(vs, successExpr, spTarget)) = GetTarget targets targetIdx + let (TTarget(vs, successExpr, spTarget, flags)) = GetTarget targets targetIdx match TryFindTargetInfo targetInfos targetIdx with - | Some (_, targetMarkAfterBinds: Mark, eenvAtTarget, _, _, _, _, _, _, _) -> + | Some (_, targetMarkAfterBinds: Mark, eenvAtTarget, _, _, _, _, _, _, _, _) -> // If not binding anything we can go directly to the targetMarkAfterBinds point // This is useful to avoid lots of branches e.g. in match A | B | C -> e @@ -5082,11 +5082,17 @@ and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx else match inplabOpt with None -> () | Some inplab -> CG.SetMarkToHere cgbuf inplab repeatSP() - // It would be better not to emit any expressions here, and instead push these assignments into the postponed target - // However not all targets are currently postponed (we only postpone in debug code), pending further testing of the performance - // impact of postponing. - (vs, es) ||> List.iter2 (GenBindingRhs cenv cgbuf eenv SPSuppress) - vs |> List.rev |> List.iter (fun v -> GenStoreVal cenv cgbuf eenvAtTarget v.Range v) + + (vs, es) ||> List.iter2 (fun v e -> + + GetStoreValCtxt cenv cgbuf eenvAtTarget v + // Emit the expression + GenBindingRhs cenv cgbuf eenv SPSuppress v e) + + vs |> List.rev |> List.iter (fun v -> + // Store the results + GenStoreVal cenv cgbuf eenvAtTarget v.Range v) + CG.EmitInstr cgbuf (pop 0) Push0 (I_br targetMarkAfterBinds.CodeLabel) targetInfos @@ -5097,9 +5103,16 @@ and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx let targetMarkBeforeBinds = CG.GenerateDelayMark cgbuf "targetBeforeBinds" let targetMarkAfterBinds = CG.GenerateDelayMark cgbuf "targetAfterBinds" let startScope, endScope as scopeMarks = StartDelayedLocalScope "targetBinds" cgbuf - let binds = mkInvisibleBinds vs es + // Allocate storage for variables (except those lifted to be state machine variables) + let binds = + match flags with + | None -> mkInvisibleBinds vs es + | Some stateVarFlags -> + (vs, es, stateVarFlags) + |||> List.zip3 + |> List.choose (fun (v, e, flag) -> if flag then None else Some (mkInvisibleBind v e)) let eenvAtTarget = AllocStorageForBinds cenv cgbuf scopeMarks eenv binds - let targetInfo = (targetMarkBeforeBinds, targetMarkAfterBinds, eenvAtTarget, successExpr, spTarget, repeatSP, vs, binds, startScope, endScope) + let targetInfo = (targetMarkBeforeBinds, targetMarkAfterBinds, eenvAtTarget, successExpr, spTarget, repeatSP, vs, es, flags, startScope, endScope) // In debug mode push all decision tree targets to after the switching let isTargetPostponed = @@ -5119,7 +5132,7 @@ and GenPostponedDecisionTreeTargets cenv cgbuf stackAtTargets targetInfos sequel if isTargetPostponed then GenDecisionTreeTarget cenv cgbuf stackAtTargets targetIdx targetInfo sequel -and GenDecisionTreeTarget cenv cgbuf stackAtTargets _targetIdx (targetMarkBeforeBinds, targetMarkAfterBinds, eenvAtTarget, successExpr, spTarget, repeatSP, vs, binds, startScope, endScope) sequel = +and GenDecisionTreeTarget cenv cgbuf stackAtTargets _targetIdx (targetMarkBeforeBinds, targetMarkAfterBinds, eenvAtTarget, successExpr, spTarget, repeatSP, vs, es, flags, startScope, endScope) sequel = CG.SetMarkToHere cgbuf targetMarkBeforeBinds let spExpr = (match spTarget with SequencePointAtTarget -> SPAlways | SuppressSequencePointAtTarget _ -> SPSuppress) @@ -5137,12 +5150,12 @@ and GenDecisionTreeTarget cenv cgbuf stackAtTargets _targetIdx (targetMarkBefore | SuppressSequencePointAtTarget -> cgbuf.EmitStartOfHiddenCode() CG.SetMarkToHere cgbuf startScope - GenBindings cenv cgbuf eenvAtTarget binds + let binds = mkInvisibleBinds vs es + GenBindings cenv cgbuf eenvAtTarget binds flags CG.SetMarkToHere cgbuf targetMarkAfterBinds CG.SetStack cgbuf stackAtTargets GenExpr cenv cgbuf eenvAtTarget spExpr successExpr (EndLocalScope(sequel, endScope)) - and GenDecisionTreeSwitch cenv cgbuf inplabOpt stackAtTargets eenv e cases defaultTargetOpt switchm targets repeatSP targetInfos sequel = let g = cenv.g let m = e.Range @@ -5289,12 +5302,12 @@ and GenDecisionTreeTest cenv cloc cgbuf stackAtTargets e tester eenv successTree TDSuccess(es2, n2) when isNil es1 && isNil es2 && (match GetTarget targets n1, GetTarget targets n2 with - | TTarget(_, BoolExpr b1, _), TTarget(_, BoolExpr b2, _) -> b1 = not b2 + | TTarget(_, BoolExpr b1, _, _), TTarget(_, BoolExpr b2, _, _) -> b1 = not b2 | _ -> false) -> match GetTarget targets n1, GetTarget targets n2 with - | TTarget(_, BoolExpr b1, _), _ -> + | TTarget(_, BoolExpr b1, _, _), _ -> GenExpr cenv cgbuf eenv SPSuppress e Continue match tester with | Some (pops, pushes, i) -> @@ -5387,7 +5400,7 @@ and GenLetRecBindings cenv (cgbuf: CodeGenBuffer) eenv (allBinds: Bindings, m) = // Generate the actual bindings let _ = (recursiveVars, allBinds) ||> List.fold (fun forwardReferenceSet (bind: Binding) -> - GenBinding cenv cgbuf eenv bind + GenBinding cenv cgbuf eenv bind false // Record the variable as defined let forwardReferenceSet = Zset.remove bind.Var forwardReferenceSet // Execute and discard any fixups that can now be committed @@ -5410,9 +5423,9 @@ and GenSequencePointForBind cenv cgbuf bind = pt |> Option.iter (CG.EmitSeqPoint cgbuf) sp -and GenBinding cenv cgbuf eenv bind = +and GenBinding cenv cgbuf eenv (bind: Binding) (isStateVar: bool) = let sp = GenSequencePointForBind cenv cgbuf bind - GenBindingAfterSequencePoint cenv cgbuf eenv sp bind None + GenBindingAfterSequencePoint cenv cgbuf eenv sp bind isStateVar None and ComputeMemberAccessRestrictedBySig eenv vspec = let isHidden = @@ -5428,16 +5441,16 @@ and ComputeMethodAccessRestrictedBySig eenv vspec = vspec.IsIncrClassGeneratedMember // compiler generated members for class function 'let' bindings get assembly visibility ComputeMemberAccess isHidden -and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec, rhsExpr, _)) startScopeMarkOpt = +and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec, rhsExpr, _)) isStateVar startScopeMarkOpt = let g = cenv.g // Record the closed reflection definition if publishing // There is no real reason we're doing this so late in the day match vspec.PublicPath, vspec.ReflectedDefinition with - | Some _, Some e -> cgbuf.mgbuf.AddReflectedDefinition(vspec, e) + | Some _, Some e when not isStateVar -> cgbuf.mgbuf.AddReflectedDefinition(vspec, e) | _ -> () - let eenv = {eenv with letBoundVars= (mkLocalValRef vspec) :: eenv.letBoundVars} + let eenv = if isStateVar then eenv else {eenv with letBoundVars= (mkLocalValRef vspec) :: eenv.letBoundVars} let access = ComputeMethodAccessRestrictedBySig eenv vspec @@ -5458,19 +5471,19 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec, rhsExpr, _)) s CommitStartScope cgbuf startScopeMarkOpt // The initialization code for static 'let' and 'do' bindings gets compiled into the initialization .cctor for the whole file - | _ when vspec.IsClassConstructor && isNil vspec.TopValDeclaringEntity.TyparsNoRange -> + | _ when vspec.IsClassConstructor && isNil vspec.TopValDeclaringEntity.TyparsNoRange && not isStateVar -> let tps, _, _, _, cctorBody, _ = IteratedAdjustArityOfLambda g cenv.amap vspec.ValReprInfo.Value rhsExpr let eenv = EnvForTypars tps eenv CommitStartScope cgbuf startScopeMarkOpt GenExpr cenv cgbuf eenv SPSuppress cctorBody discard - | Method (topValInfo, _, mspec, _, paramInfos, methodArgTys, retInfo) -> + | Method (topValInfo, _, mspec, _, paramInfos, methodArgTys, retInfo) when not isStateVar -> let tps, ctorThisValOpt, baseValOpt, vsl, body', bodyty = IteratedAdjustArityOfLambda g cenv.amap topValInfo rhsExpr let methodVars = List.concat vsl CommitStartScope cgbuf startScopeMarkOpt GenMethodForBinding cenv cgbuf eenv (vspec, mspec, access, paramInfos, retInfo) (topValInfo, ctorThisValOpt, baseValOpt, tps, methodVars, methodArgTys, body', bodyty) - | StaticProperty (ilGetterMethSpec, optShadowLocal) -> + | StaticProperty (ilGetterMethSpec, optShadowLocal) when not isStateVar -> let ilAttribs = GenAttrs cenv eenv vspec.Attribs let ilTy = ilGetterMethSpec.FormalReturnType @@ -5586,10 +5599,17 @@ and GenBindingAfterSequencePoint cenv cgbuf eenv sp (TBind(vspec, rhsExpr, _)) s | Local (_, realloc, _), Expr.Const (Const.Zero, _, _) when not realloc -> CommitStartScope cgbuf startScopeMarkOpt | _ -> + GetStoreValCtxt cenv cgbuf eenv vspec GenBindingRhs cenv cgbuf eenv SPSuppress vspec rhsExpr CommitStartScope cgbuf startScopeMarkOpt GenStoreVal cenv cgbuf eenv vspec.Range vspec +and GetStoreValCtxt cenv cgbuf eenv (vspec: Val) = + // Emit the ldarg0 if needed + match StorageForVal cenv.g vspec.Range vspec eenv with + | Env (ilCloTy, _, _, _) -> CG.EmitInstr cgbuf (pop 0) (Push [ilCloTy]) mkLdarg0 + | _ -> () + //------------------------------------------------------------------------- // Generate method bindings //------------------------------------------------------------------------- @@ -6165,7 +6185,12 @@ and GenPInvokeMethod (nm, dll, namedArgs) = ThrowOnUnmappableChar= if (decoder.FindBool "ThrowOnUnmappableChar" false) then PInvokeThrowOnUnmappableChar.Enabled else PInvokeThrowOnUnmappableChar.UseAssembly CharBestFit=if (decoder.FindBool "BestFitMapping" false) then PInvokeCharBestFit.Enabled else PInvokeCharBestFit.UseAssembly } -and GenBindings cenv cgbuf eenv binds = List.iter (GenBinding cenv cgbuf eenv) binds +and GenBindings cenv cgbuf eenv binds flags = + match flags with + | None -> + binds |> List.iter (fun bind -> GenBinding cenv cgbuf eenv bind false) + | Some flags -> + (binds, flags) ||> List.iter2 (fun bind flag -> GenBinding cenv cgbuf eenv bind flag) //------------------------------------------------------------------------- // Generate locals and other storage of values @@ -6173,11 +6198,7 @@ and GenBindings cenv cgbuf eenv binds = List.iter (GenBinding cenv cgbuf eenv) b and GenSetVal cenv cgbuf eenv (vref, e, m) sequel = let storage = StorageForValRef cenv.g m vref eenv - match storage with - | Env (ilCloTy, _, _, _) -> - CG.EmitInstr cgbuf (pop 0) (Push [ilCloTy]) mkLdarg0 - | _ -> - () + GetStoreValCtxt cenv cgbuf eenv vref.Deref GenExpr cenv cgbuf eenv SPSuppress e Continue GenSetStorage vref.Range cgbuf storage GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel @@ -6634,7 +6655,7 @@ and GenModuleDef cenv (cgbuf: CodeGenBuffer) qname lazyInitInfo eenv x = mbinds |> List.iter (GenModuleBinding cenv cgbuf qname lazyInitInfo eenv m) | TMDefLet(bind, _) -> - GenBindings cenv cgbuf eenv [bind] + GenBindings cenv cgbuf eenv [bind] None | TMDefDo(e, _) -> GenExpr cenv cgbuf eenv SPAlways e discard diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index de6319b2702..ef5e5375181 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -1275,11 +1275,11 @@ module Pass4_RewriteAssembly = let dflt, z = Option.mapFold (TransDecisionTree penv) z dflt TDSwitch (e, cases, dflt, m), z - and TransDecisionTreeTarget penv z (TTarget(vs, e, spTarget)) = + and TransDecisionTreeTarget penv z (TTarget(vs, e, spTarget, flags)) = let z = EnterInner z let e, z = TransExpr penv z e let z = ExitInner z - TTarget(vs, e, spTarget), z + TTarget(vs, e, spTarget, flags), z and TransValBinding penv z bind = TransBindingRhs penv z bind and TransValBindings penv z binds = List.mapFold (TransValBinding penv) z binds diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index c3aef4962e8..75d804269fd 100644 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -491,25 +491,33 @@ let ConvertSequenceExprToObject g amap overallExpr = // transferred to the r.h.s. are not yet compiled. // // TODO: remove this limitation - | Expr.Match (spBind, exprm, pt, targets, m, ty) when targets |> Array.forall (fun (TTarget(vs, _e, _spTarget)) -> isNil vs) -> + | Expr.Match (spBind, exprm, pt, targets, m, ty) -> // lower all the targets. abandon if any fail to lower - let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel targetExpr) + let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget, _)) -> ConvertSeqExprCode false isTailCall noDisposeContinuationLabel currentDisposeContinuationLabel targetExpr) if tglArray |> Array.forall Option.isSome then let tglArray = Array.map Option.get tglArray let tgl = Array.toList tglArray let labs = tgl |> List.collect (fun res -> res.entryPoints) + let asyncVars = (emptyFreeVars, Array.zip targets tglArray) - ||> Array.fold (fun fvs ((TTarget(_vs, _, _spTarget)), res) -> + ||> Array.fold (fun fvs ((TTarget(_vs, _, _spTarget, _)), res) -> if res.entryPoints.IsEmpty then fvs else unionFreeVars fvs res.asyncVars) - let stateVars = tgl |> List.collect (fun res -> res.stateVars) + + let stateVars = + (targets, tglArray) ||> Array.zip |> Array.toList |> List.collect (fun (TTarget(vs, _, _, _), res) -> + let stateVars = vs |> List.filter (fun v -> res.asyncVars.FreeLocals.Contains(v)) |> List.map mkLocalValRef + stateVars @ res.stateVars) + let significantClose = tgl |> List.exists (fun res -> res.significantClose) + Some { phase2 = (fun ctxt -> let gtgs, disposals, checkDisposes = (Array.toList targets, tgl) - ||> List.map2 (fun (TTarget(vs, _, spTarget)) res -> + ||> List.map2 (fun (TTarget(vs, _, spTarget, _)) res -> + let flags = vs |> List.map (fun v -> res.asyncVars.FreeLocals.Contains(v)) let generate, dispose, checkDispose = res.phase2 ctxt - let gtg = TTarget(vs, generate, spTarget) + let gtg = TTarget(vs, generate, spTarget, Some flags) gtg, dispose, checkDispose) |> List.unzip3 let generate = primMkMatch (spBind, exprm, pt, Array.ofList gtgs, m, ty) @@ -1286,21 +1294,34 @@ let ConvertStateMachineExprToObject g overallExpr = | Expr.Match (spBind, exprm, dtree, targets, m, ty) -> // lower all the targets. let dtreeR = ConvertStateMachineLeafDecisionTree env dtree - let tglArray = targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget)) -> ConvertStateMachineCode env pcExpr targetExpr) + let tglArray = + targets |> Array.map (fun (TTarget(_vs, targetExpr, _spTarget, _)) -> + ConvertStateMachineCode env pcExpr targetExpr) let tgl = Array.toList tglArray let entryPoints = tgl |> List.collect (fun res -> res.entryPoints) let asyncVars = (emptyFreeVars, Array.zip targets tglArray) - ||> Array.fold (fun fvs ((TTarget(_vs, _, _spTarget)), res) -> + ||> Array.fold (fun fvs ((TTarget(_vs, _, _spTarget, _)), res) -> if res.entryPoints.IsEmpty then fvs else unionFreeVars fvs res.asyncVars) - let stateVars = tgl |> List.collect (fun res -> res.stateVars) + let stateVars = + (targets, tglArray) ||> Array.zip |> Array.toList |> List.collect (fun (TTarget(vs, _, _, _), res) -> + let stateVars = vs |> List.filter (fun v -> res.asyncVars.FreeLocals.Contains(v)) |> List.map mkLocalValRef + stateVars @ res.stateVars) { phase1 = - let gtgs = (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, spTarget)) res -> TTarget(vs, res.phase1, spTarget)) - primMkMatch (spBind, exprm, dtreeR, gtgs, m, ty) + let gtgs = + (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, spTarget, _)) res -> + let flags = vs |> List.map (fun v -> res.asyncVars.FreeLocals.Contains(v)) + TTarget(vs, res.phase1, spTarget, Some flags)) + primMkMatch (spBind, exprm, dtreeR, gtgs, m, ty) + phase2 = (fun ctxt -> - let gtgs = (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, spTarget)) res -> TTarget(vs, res.phase2 ctxt, spTarget)) + let gtgs = + (targets, tglArray) ||> Array.map2 (fun (TTarget(vs, _, spTarget, _)) res -> + let flags = vs |> List.map (fun v -> res.asyncVars.FreeLocals.Contains(v)) + TTarget(vs, res.phase2 ctxt, spTarget, Some flags)) let generate = primMkMatch (spBind, exprm, dtreeR, gtgs, m, ty) generate) + entryPoints = entryPoints stateVars = stateVars asyncVars = asyncVars } diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 9b18fb63c9b..c9153b3e48b 100644 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -1482,7 +1482,7 @@ let (|TDBoolSwitch|_|) dtree = /// Check target that have a constant bool value let (|ConstantBoolTarget|_|) target = match target with - | TTarget([], Expr.Const (Const.Bool b,_,_),_) -> Some b + | TTarget([], Expr.Const (Const.Bool b, _, _), _, _) -> Some b | _ -> None /// Is this a tree, where each decision is a two-way switch (to prevent later duplication of trees), and each branch returns or true/false, @@ -1496,7 +1496,7 @@ let rec CountBoolLogicTree ((targets: DecisionTreeTarget[], costOuterCaseTree, c | TDSuccess([], idx) -> match targets.[idx] with | ConstantBoolTarget result -> (if result = testBool then costOuterCaseTree else costOuterDefaultTree), 0 - | TTarget([], _exp, _) -> costOuterCaseTree + costOuterDefaultTree, 10 + | TTarget([], _exp, _, _) -> costOuterCaseTree + costOuterDefaultTree, 10 | _ -> 100, 100 | _ -> 100, 100 @@ -1512,7 +1512,7 @@ let rec RewriteBoolLogicTree ((targets: DecisionTreeTarget[], outerCaseTree, out | TDSuccess([], idx) -> match targets.[idx] with | ConstantBoolTarget result -> if result = testBool then outerCaseTree else outerDefaultTree - | TTarget([], exp, _) -> mkBoolSwitch exp.Range exp (if testBool then outerCaseTree else outerDefaultTree) (if testBool then outerDefaultTree else outerCaseTree) + | TTarget([], exp, _, _) -> mkBoolSwitch exp.Range exp (if testBool then outerCaseTree else outerDefaultTree) (if testBool then outerDefaultTree else outerCaseTree) | _ -> failwith "CountBoolLogicTree should exclude this case" | _ -> failwith "CountBoolLogicTree should exclude this case" @@ -1742,10 +1742,10 @@ let rec tryRewriteToSeqCombinators g (e: Expr) = // match --> match | Expr.Match (spBind, exprm, pt, targets, m, _ty) -> - let targets = targets |> Array.map (fun (TTarget(vs, e, spTarget)) -> match tryRewriteToSeqCombinators g e with None -> None | Some e -> Some(TTarget(vs, e, spTarget))) + let targets = targets |> Array.map (fun (TTarget(vs, e, spTarget, flags)) -> match tryRewriteToSeqCombinators g e with None -> None | Some e -> Some(TTarget(vs, e, spTarget, flags))) if targets |> Array.forall Option.isSome then let targets = targets |> Array.map Option.get - let ty = targets |> Array.pick (fun (TTarget(_, e, _)) -> Some(tyOfExpr g e)) + let ty = targets |> Array.pick (fun (TTarget(_, e, _, _)) -> Some(tyOfExpr g e)) Some (Expr.Match (spBind, exprm, pt, targets, m, ty)) else None @@ -2340,7 +2340,7 @@ and OptimizeLinearExpr cenv env expr contf = // This ConsiderSplitToMethod is performed because it is present in OptimizeDecisionTreeTarget let e2, e2info = ConsiderSplitToMethod cenv.settings.abstractBigTargets cenv.settings.bigTargetSize cenv env (e2, e2info) let tinfos = [tg1info; e2info] - let targetsR = [tg1; TTarget([], e2, spTarget2)] + let targetsR = [tg1; TTarget([], e2, spTarget2, None)] OptimizeMatchPart2 cenv (spMatch, exprm, dtreeR, targetsR, dinfo, tinfos, m, ty))) | LinearOpExpr (op, tyargs, argsHead, argLast, m) -> @@ -3060,12 +3060,12 @@ and RebuildOptimizedMatch (spMatch, exprm, m, ty, dtree, tgs, dinfo, tinfos) = expr, einfo /// Optimize/analyze a target of a decision tree -and OptimizeDecisionTreeTarget cenv env _m (TTarget(vs, expr, spTarget)) = +and OptimizeDecisionTreeTarget cenv env _m (TTarget(vs, expr, spTarget, flags)) = let env = BindInternalValsToUnknown cenv vs env let exprR, einfo = OptimizeExpr cenv env expr let exprR, einfo = ConsiderSplitToMethod cenv.settings.abstractBigTargets cenv.settings.bigTargetSize cenv env (exprR, einfo) let evalueR = AbstractExprInfoByVars (vs, []) einfo.Info - TTarget(vs, exprR, spTarget), + TTarget(vs, exprR, spTarget, flags), { TotalSize=einfo.TotalSize FunctionSize=einfo.FunctionSize HasEffect=einfo.HasEffect diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index ddd8fc129c7..7db6cb00f12 100644 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -71,7 +71,7 @@ and TypedMatchClause = member c.Pattern = let (TClause(p, _, _, _)) = c in p member c.Range = let (TClause(_, _, _, m)) = c in m member c.Target = let (TClause(_, _, tg, _)) = c in tg - member c.BoundVals = let (TClause(_p, _whenOpt, TTarget(vs, _, _), _m)) = c in vs + member c.BoundVals = let (TClause(_p, _whenOpt, TTarget(vs, _, _, _), _m)) = c in vs let debug = false @@ -803,7 +803,7 @@ let CompilePatternBasic // targets of filters since if the exception is filtered successfully then we // will run the handler and hit the sequence point there. // That sequence point will have the pattern variables bound, which is exactly what we want. - let tg = TTarget(List.empty, throwExpr, SuppressSequencePointAtTarget ) + let tg = TTarget([], throwExpr, SuppressSequencePointAtTarget, None) mbuilder.AddTarget tg |> ignore let clause = TClause(TPat_wild matchm, None, tg, matchm) incompleteMatchClauseOnce := Some clause @@ -814,12 +814,15 @@ let CompilePatternBasic // Helpers to get the variables bound at a target. We conceptually add a dummy clause that will always succeed with a "throw" let clausesA = Array.ofList clausesL let nclauses = clausesA.Length + let GetClause i refuted = if i < nclauses then clausesA.[i] elif i = nclauses then getIncompleteMatchClause refuted else failwith "GetClause" + let GetValsBoundByClause i refuted = (GetClause i refuted).BoundVals + let GetWhenGuardOfClause i refuted = (GetClause i refuted).GuardExpr // Different uses of parameterized active patterns have different identities as far as paths @@ -1355,7 +1358,7 @@ let rec CompilePattern g denv amap exprm matchm warnOnUnused actionOnFailure (o else SequencePointAtTarget // Make the clause that represents the remaining cases of the pattern match - let clauseForRestOfMatch = TClause(TPat_wild matchm, None, TTarget(List.empty, expr, spTarget), matchm) + let clauseForRestOfMatch = TClause(TPat_wild matchm, None, TTarget(List.empty, expr, spTarget, None), matchm) CompilePatternBasic g denv amap exprm matchm warnOnUnused warnOnIncomplete actionOnFailure (origInputVal, origInputValTypars, origInputExprOpt) (group @ [clauseForRestOfMatch]) inputTy resultTy diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 929dd704494..36373f3c6b1 100644 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -1526,7 +1526,7 @@ and CheckDecisionTreeTargets cenv env targets context = |> Array.map (CheckDecisionTreeTarget cenv env context) |> (CombineLimits << List.ofArray) -and CheckDecisionTreeTarget cenv env context (TTarget(vs, e, _)) = +and CheckDecisionTreeTarget cenv env context (TTarget(vs, e, _, _)) = BindVals cenv env vs vs |> List.iter (CheckValSpec PermitByRefType.All cenv env) CheckExpr cenv env e context diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index 6b445051319..15517f1b698 100644 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -165,7 +165,7 @@ let (|ObjectInitializationCheck|_|) g expr = ( Expr.Op (TOp.ILAsm ([AI_clt], _), _, [Expr.Op (TOp.ValFieldGet ((RFRef(_, name))), _, [Expr.Val (selfRef, NormalValUse, _)], _); Expr.Const (Const.Int32 1, _, _)], _), _, _, _ ), - [| TTarget([], Expr.App (Expr.Val (failInitRef, _, _), _, _, _, _), _); _ |], _, resultTy + [| TTarget([], Expr.App (Expr.Val (failInitRef, _, _), _, _, _, _), _, _); _ |], _, resultTy ) when IsCompilerGeneratedName name && name.StartsWithOrdinal("init") && @@ -679,7 +679,7 @@ and ConvLValueArgs cenv env args = | obj :: rest -> ConvLValueExpr cenv env obj :: ConvExprs cenv env rest | [] -> [] -and ConvLValueExpr cenv env expr = +and ConvLValueExpr cenv env (expr: Expr) = EmitDebugInfoIfNecessary cenv env expr.Range (ConvLValueExprCore cenv env expr) // This function has to undo the work of mkExprAddrOfExpr @@ -926,7 +926,7 @@ and ConvDecisionTree cenv env tgs typR x = EmitDebugInfoIfNecessary cenv env m converted | TDSuccess (args, n) -> - let (TTarget(vars, rhs, _)) = tgs.[n] + let (TTarget(vars, rhs, _, _)) = tgs.[n] // TAST stores pattern bindings in reverse order for some reason // Reverse them here to give a good presentation to the user let args = List.rev args diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 2afb3803e2a..8d1f8c6ed2d 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1163,7 +1163,7 @@ type MatchBuilder(spBind, inpRange: Range.range) = targets.Add tg n - member x.AddResultTarget(e, spTarget) = TDSuccess([], x.AddTarget(TTarget([], e, spTarget))) + member x.AddResultTarget(e, spTarget) = TDSuccess([], x.AddTarget(TTarget([], e, spTarget, None))) member x.CloseTargets() = targets |> ResizeArray.toList @@ -3892,7 +3892,8 @@ module DebugPrint = | (DecisionTreeTest.IsInst (_, ty)) -> wordL(tagText "isinst") ^^ typeL ty | (DecisionTreeTest.ActivePatternCase (exp, _, _, _, _)) -> wordL(tagText "query") ^^ exprL g exp - and targetL g i (TTarget (argvs, body, _)) = leftL(tagText "T") ^^ intL i ^^ tupleL (flatValsL argvs) ^^ rightL(tagText ":") --- exprL g body + and targetL g i (TTarget (argvs, body, _, _)) = + leftL(tagText "T") ^^ intL i ^^ tupleL (flatValsL argvs) ^^ rightL(tagText ":") --- exprL g body and flatValsL vs = vs |> List.map valL @@ -4267,11 +4268,11 @@ let freeTyvarsAllPublic tyvars = let (|LinearMatchExpr|_|) expr = match expr with - | Expr.Match (sp, m, dtree, [|tg1;(TTarget([], e2, sp2))|], m2, ty) -> Some(sp, m, dtree, tg1, e2, sp2, m2, ty) + | Expr.Match (sp, m, dtree, [|tg1;(TTarget([], e2, sp2, _))|], m2, ty) -> Some(sp, m, dtree, tg1, e2, sp2, m2, ty) | _ -> None let rebuildLinearMatchExpr (sp, m, dtree, tg1, e2, sp2, m2, ty) = - primMkMatch (sp, m, dtree, [|tg1;(TTarget([], e2, sp2))|], m2, ty) + primMkMatch (sp, m, dtree, [|tg1;(TTarget([], e2, sp2, None))|], m2, ty) /// Detect a subset of 'Expr.Op' expressions we process in a linear way (i.e. using tailcalls, rather than /// unbounded stack). Only covers Cons(args,Cons(args,Cons(args,Cons(args,...._)))). @@ -4617,8 +4618,10 @@ and accFreeInOp opts op acc = and accFreeInTargets opts targets acc = Array.foldBack (accFreeInTarget opts) targets acc -and accFreeInTarget opts (TTarget(vs, expr, _)) acc = - List.foldBack (boundLocalVal opts) vs (accFreeInExpr opts expr acc) +and accFreeInTarget opts (TTarget(vs, expr, _, flags)) acc = + match flags with + | None -> List.foldBack (boundLocalVal opts) vs (accFreeInExpr opts expr acc) + | Some xs -> List.foldBack2 (fun v isStateVar acc -> if isStateVar then acc else boundLocalVal opts v acc) vs xs (accFreeInExpr opts expr acc) and accFreeInFlatExprs opts (exprs: Exprs) acc = List.foldBack (accFreeInExpr opts) exprs acc @@ -5077,9 +5080,9 @@ and remapExpr (g: TcGlobals) (compgen: ValCopyFlag) (tmenv: Remap) expr = let ty' = remapType tmenv ty if ty === ty' then expr else Expr.Const (c, m, ty') -and remapTarget g compgen tmenv (TTarget(vs, e, spTarget)) = +and remapTarget g compgen tmenv (TTarget(vs, e, spTarget, flags)) = let vs', tmenvinner = copyAndRemapAndBindVals g compgen tmenv vs - TTarget(vs', remapExpr g compgen tmenvinner e, spTarget) + TTarget(vs', remapExpr g compgen tmenvinner e, spTarget, flags) and remapLinearExpr g compgen tmenv expr contf = @@ -5489,7 +5492,7 @@ let rec remarkExpr m x = Expr.Let (remarkBind m bind, remarkExpr m e, m, fvs) | Expr.Match (_, _, pt, targets, _, ty) -> - let targetsR = targets |> Array.map (fun (TTarget(vs, e, _)) -> TTarget(vs, remarkExpr m e, SuppressSequencePointAtTarget)) + let targetsR = targets |> Array.map (fun (TTarget(vs, e, _, flags)) -> TTarget(vs, remarkExpr m e, SuppressSequencePointAtTarget, flags)) primMkMatch (NoSequencePointAtInvisibleBinding, m, remarkDecisionTree m pt, targetsR, m, ty) | Expr.Val (x, valUseFlags, _) -> @@ -5860,7 +5863,7 @@ let foldLinearBindingTargetsOfMatch tree (targets: _[]) = /// rebuild the targets, replacing linear targets by ones that include all the 'let' bindings from the source let targets' = - targets |> Array.mapi (fun i (TTarget(vs, exprTarget, spTarget) as tg) -> + targets |> Array.mapi (fun i (TTarget(vs, exprTarget, spTarget, _) as tg) -> if isLinearTgtIdx i then let (binds, es) = getLinearTgtIdx i // The value bindings are moved to become part of the target. @@ -5868,7 +5871,7 @@ let foldLinearBindingTargetsOfMatch tree (targets: _[]) = let mTarget = exprTarget.Range let es = es |> List.map (remarkExpr mTarget) // These are non-sticky - any sequence point for 'exprTarget' goes on 'exprTarget' _after_ the bindings have been evaluated - TTarget(List.empty, mkLetsBind mTarget binds (mkInvisibleLetsFromBindings mTarget vs es exprTarget), spTarget) + TTarget(List.empty, mkLetsBind mTarget binds (mkInvisibleLetsFromBindings mTarget vs es exprTarget), spTarget, None) else tg ) tree', targets' @@ -5879,7 +5882,7 @@ let rec simplifyTrivialMatch spBind exprm matchm ty tree (targets : _[]) = | TDSuccess(es, n) -> if n >= targets.Length then failwith "simplifyTrivialMatch: target out of range" // REVIEW: should we use _spTarget here? - let (TTarget(vs, rhs, _spTarget)) = targets.[n] + let (TTarget(vs, rhs, _spTarget, _)) = targets.[n] if vs.Length <> es.Length then failwith ("simplifyTrivialMatch: invalid argument, n = " + string n + ", List.length targets = " + string targets.Length) // These are non-sticky - any sequence point for 'rhs' goes on 'rhs' _after_ the bindings have been made mkInvisibleLetsFromBindings rhs.Range vs es rhs @@ -6369,7 +6372,7 @@ type ExprFolders<'State> (folders: ExprFolder<'State>) = match folders.targetIntercept exprFClosure z x with | Some z -> z // intercepted | None -> // structurally recurse - let (TTarget (_, body, _)) = x + let (TTarget (_, body, _, _)) = x exprF z body and tmethodF z x = @@ -7643,11 +7646,10 @@ let LinearizeTopMatchAux g parent (spBind, m, tree, targets, m2, ty) = | [] -> failwith "itemsProj: no items?" | [_] -> x (* no projection needed *) | tys -> Expr.Op (TOp.TupleFieldGet (tupInfoRef, i), tys, [x], m) - let isThrowingTarget = function TTarget(_, x, _) -> isThrow x + let isThrowingTarget = function TTarget(_, x, _, _) -> isThrow x if 1 + List.count isThrowingTarget targetsL = targetsL.Length then - (* Have failing targets and ONE successful one, so linearize *) - let (TTarget (vs, rhs, spTarget)) = Option.get (List.tryFind (isThrowingTarget >> not) targetsL) - (* note - old code here used copy value to generate locals - this was not right *) + // Have failing targets and ONE successful one, so linearize + let (TTarget (vs, rhs, spTarget, _)) = List.find (isThrowingTarget >> not) targetsL let fvs = vs |> List.map (fun v -> fst(mkLocal v.Range v.LogicalName v.Type)) (* fresh *) let vtys = vs |> List.map (fun v -> v.Type) let tmpTy = mkRefTupledVarsTy g vs @@ -7655,12 +7657,12 @@ let LinearizeTopMatchAux g parent (spBind, m, tree, targets, m2, ty) = AdjustValToTopVal tmp parent ValReprInfo.emptyValData - let newTg = TTarget (fvs, mkRefTupledVars g m fvs, spTarget) - let fixup (TTarget (tvs, tx, spTarget)) = + let newTg = TTarget (fvs, mkRefTupledVars g m fvs, spTarget, None) + let fixup (TTarget (tvs, tx, spTarget, flags)) = match destThrow tx with | Some (m, _, e) -> let tx = mkThrow m tmpTy e - TTarget(tvs, tx, spTarget) (* Throwing targets, recast it's "return type" *) + TTarget(tvs, tx, spTarget, flags) (* Throwing targets, recast it's "return type" *) | None -> newTg (* Non-throwing target, replaced [new/old] *) let targets = Array.map fixup targets @@ -7989,7 +7991,7 @@ let mkIsInstConditional g m tgty vinpe v e2 e3 = else let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding, m) - let tg2 = TDSuccess([mkCallUnbox g m tgty vinpe], mbuilder.AddTarget(TTarget([v], e2, SuppressSequencePointAtTarget))) + let tg2 = TDSuccess([mkCallUnbox g m tgty vinpe], mbuilder.AddTarget(TTarget([v], e2, SuppressSequencePointAtTarget, None))) let tg3 = mbuilder.AddResultTarget(e3, SuppressSequencePointAtTarget) let dtree = TDSwitch(vinpe, [TCase(DecisionTreeTest.IsInst(tyOfExpr g vinpe, tgty), tg2)], Some tg3, m) let expr = mbuilder.Close(dtree, m, tyOfExpr g e2) @@ -8336,15 +8338,17 @@ and RewriteDecisionTree env x = let body = RewriteDecisionTree env body TDBind (bind', body) -and rewriteTarget env (TTarget(vs, e, spTarget)) = TTarget(vs, RewriteExpr env e, spTarget) +and rewriteTarget env (TTarget(vs, e, spTarget, flags)) = + TTarget(vs, RewriteExpr env e, spTarget, flags) -and rewriteTargets env targets = List.map (rewriteTarget env) (Array.toList targets) +and rewriteTargets env targets = + List.map (rewriteTarget env) (Array.toList targets) and rewriteObjExprOverride env (TObjExprMethod(slotsig, attribs, tps, vs, e, m)) = - TObjExprMethod(slotsig, attribs, tps, vs, RewriteExpr env e, m) + TObjExprMethod(slotsig, attribs, tps, vs, RewriteExpr env e, m) and rewriteObjExprInterfaceImpl env (ty, overrides) = - (ty, List.map (rewriteObjExprOverride env) overrides) + (ty, List.map (rewriteObjExprOverride env) overrides) and rewriteModuleOrNamespaceExpr env x = match x with @@ -8556,9 +8560,11 @@ let IsSimpleSyntacticConstantExpr g inputExpr = | TDSuccess (es, _n) -> es |> List.forall (checkExpr vrefs) | TDSwitch (e, cases, dflt, _m) -> checkExpr vrefs e && cases |> List.forall (checkDecisionTreeCase vrefs) && dflt |> Option.forall (checkDecisionTree vrefs) | TDBind (bind, body) -> checkExpr vrefs bind.Expr && checkDecisionTree (vrefs.Add bind.Var.Stamp) body + and checkDecisionTreeCase vrefs (TCase(discrim, dtree)) = (match discrim with DecisionTreeTest.Const _c -> true | _ -> false) && checkDecisionTree vrefs dtree - and checkDecisionTreeTarget vrefs (TTarget(vs, e, _)) = + + and checkDecisionTreeTarget vrefs (TTarget(vs, e, _, _)) = let vrefs = ((vrefs, vs) ||> List.fold (fun s v -> s.Add v.Stamp)) checkExpr vrefs e diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index a66f08acfd4..b403b7060c2 100644 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -2384,7 +2384,7 @@ and p_dtree_discrim x st = | DecisionTreeTest.ArrayLength (n, ty) -> p_byte 4 st; p_tup2 p_int p_ty (n, ty) st | DecisionTreeTest.ActivePatternCase _ -> pfailwith st "DecisionTreeTest.ActivePatternCase: only used during pattern match compilation" -and p_target (TTarget(a, b, _)) st = p_tup2 p_Vals p_expr (a, b) st +and p_target (TTarget(a, b, _, _)) st = p_tup2 p_Vals p_expr (a, b) st and p_bind (TBind(a, b, _)) st = p_tup2 p_Val p_expr (a, b) st and p_lval_op_kind x st = @@ -2415,7 +2415,7 @@ and u_dtree_discrim st = | 4 -> u_tup2 u_int u_ty st |> DecisionTreeTest.ArrayLength | _ -> ufailwith st "u_dtree_discrim" -and u_target st = let a, b = u_tup2 u_Vals u_expr st in (TTarget(a, b, SuppressSequencePointAtTarget)) +and u_target st = let a, b = u_tup2 u_Vals u_expr st in (TTarget(a, b, SuppressSequencePointAtTarget, None)) and u_bind st = let a = u_Val st in let b = u_expr st in TBind(a, b, NoSequencePointAtStickyBinding) diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index a167818cdea..3abeb53b5d8 100644 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -3254,8 +3254,9 @@ let CompilePatternForMatchClauses cenv env mExpr matchm warnOnUnused actionOnFai // Avoid creating a dummy in the common cases where we are about to bind a name for the expression // CLEANUP: avoid code duplication with code further below, i.e.all callers should call CompilePatternForMatch match tclauses with - | [TClause(TPat_as (pat1, PBind (asVal, TypeScheme(generalizedTypars, _)), _), None, TTarget(vs, e, spTarget), m2)] -> - let expr = CompilePatternForMatch cenv env mExpr matchm warnOnUnused actionOnFailure (asVal, generalizedTypars, None) [TClause(pat1, None, TTarget(ListSet.remove valEq asVal vs, e, spTarget), m2)] inputTy resultTy + | [TClause(TPat_as (pat1, PBind (asVal, TypeScheme(generalizedTypars, _)), _), None, TTarget(vs, e, spTarget, _), m2)] -> + let vs2 = ListSet.remove valEq asVal vs + let expr = CompilePatternForMatch cenv env mExpr matchm warnOnUnused actionOnFailure (asVal, generalizedTypars, None) [TClause(pat1, None, TTarget(vs2, e, spTarget, None), m2)] inputTy resultTy asVal, expr | _ -> let matchValueTmp, _ = Tastops.mkCompGenLocal mExpr "matchValue" inputTy @@ -3489,7 +3490,7 @@ let mkSeqFinally cenv env m genTy e1 e2 = mkCallSeqFinally cenv.g m genResultTy e1 e2 let mkSeqExprMatchClauses (pat', vspecs) innerExpr = - [TClause(pat', None, TTarget(vspecs, innerExpr, SequencePointAtTarget), pat'.Range) ] + [TClause(pat', None, TTarget(vspecs, innerExpr, SequencePointAtTarget, None), pat'.Range) ] let compileSeqExprMatchClauses cenv env inputExprMark (pat: Pattern, vspecs) innerExpr inputExprOpt bindPatTy genInnerTy = let patMark = pat.Range @@ -3818,11 +3819,13 @@ let EliminateInitializationGraphs | Expr.Quote _ -> () and CheckBinding st (TBind(_, e, _)) = CheckExpr st e + and CheckDecisionTree st = function | TDSwitch(e1, csl, dflt, _) -> CheckExpr st e1; List.iter (fun (TCase(_, d)) -> CheckDecisionTree st d) csl; Option.iter (CheckDecisionTree st) dflt | TDSuccess (es, _) -> es |> List.iter (CheckExpr st) | TDBind(bind, e) -> CheckBinding st bind; CheckDecisionTree st e - and CheckDecisionTreeTarget st (TTarget(_, e, _)) = CheckExpr st e + + and CheckDecisionTreeTarget st (TTarget(_, e, _, _)) = CheckExpr st e and CheckExprOp st op m = match op with @@ -3969,7 +3972,9 @@ let CheckAndRewriteObjectCtor g env (ctorLambaExpr: Expr) = | Expr.Let (bind, body, m, _) -> mkLetBind m bind (checkAndRewrite body) // The constructor is a sequence "let pat = expr in " - | Expr.Match (spBind, a, b, targets, c, d) -> Expr.Match (spBind, a, b, (targets |> Array.map (fun (TTarget(vs, body, spTarget)) -> TTarget(vs, checkAndRewrite body, spTarget))), c, d) + | Expr.Match (spBind, a, b, targets, c, d) -> + let targets = targets |> Array.map (fun (TTarget(vs, body, spTarget, flags)) -> TTarget(vs, checkAndRewrite body, spTarget, flags)) + Expr.Match (spBind, a, b, targets, c, d) // = "let rec binds in " | Expr.LetRec (a, body, _, _) -> Expr.LetRec (a, checkAndRewrite body, m, NewFreeVarsCache()) @@ -7282,7 +7287,7 @@ and TcForEachExpr cenv overallTy env tpenv (pat, enumSynExpr, bodySynExpr, mWhol let valsDefinedByMatching = ListSet.remove valEq elemVar vspecs CompilePatternForMatch cenv env enumSynExpr.Range pat.Range false IgnoreWithWarning (elemVar, [], None) - [TClause(pat, None, TTarget(valsDefinedByMatching, bodyExpr, SequencePointAtTarget), mForLoopStart)] + [TClause(pat, None, TTarget(valsDefinedByMatching, bodyExpr, SequencePointAtTarget, None), mForLoopStart)] enumElemTy overallTy @@ -8541,7 +8546,7 @@ and TcSequenceExpression cenv env tpenv comp overallTy m = (fun tpenv (Clause(pat, cond, innerComp, _, sp)) -> let pat', cond', vspecs, envinner, tpenv = TcMatchPattern cenv matchty env tpenv (pat, cond) let innerExpr, tpenv = tcSequenceExprBody envinner genOuterTy tpenv innerComp - TClause(pat', cond', TTarget(vspecs, innerExpr, sp), pat'.Range), tpenv) + TClause(pat', cond', TTarget(vspecs, innerExpr, sp, None), pat'.Range), tpenv) tpenv clauses let inputExprTy = tyOfExpr cenv.g inputExpr @@ -10623,7 +10628,7 @@ and TcMatchClause cenv inputTy resultTy env isFirst tpenv (Clause(pat, optWhenEx let pat', optWhenExpr', vspecs, envinner, tpenv = TcMatchPattern cenv inputTy env tpenv (pat, optWhenExpr) let resultEnv = if isFirst then envinner else { envinner with eContextInfo = ContextInfo.FollowingPatternMatchClause e.Range } let e', tpenv = TcExprThatCanBeCtorBody cenv resultTy resultEnv tpenv e - TClause(pat', optWhenExpr', TTarget(vspecs, e', spTgt), patm), tpenv + TClause(pat', optWhenExpr', TTarget(vspecs, e', spTgt, None), patm), tpenv and TcStaticOptimizationConstraint cenv env tpenv c = match c with @@ -11251,7 +11256,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (synBinds, synBinds // Add the compilation of the pattern to the bodyExpr we get from mkCleanup let mkPatBind (bodyExpr, bodyExprTy) = let valsDefinedByMatching = ListSet.remove valEq patternInputTmp allValsDefinedByPattern - let clauses = [TClause(checkedPat2, None, TTarget(valsDefinedByMatching, bodyExpr, SuppressSequencePointAtTarget), m)] + let clauses = [TClause(checkedPat2, None, TTarget(valsDefinedByMatching, bodyExpr, SuppressSequencePointAtTarget, None), m)] let matchx = CompilePatternForMatch cenv env m m true ThrowIncompleteMatchException (patternInputTmp, generalizedTypars, Some rhsExpr) clauses tauTy bodyExprTy let matchx = if (DeclKind.ConvertToLinearBindings declKind) then LinearizeTopMatch cenv.g altActualParent matchx else matchx matchx, bodyExprTy diff --git a/src/fsharp/symbols/Exprs.fs b/src/fsharp/symbols/Exprs.fs index 16332d84f82..c246f8bf32c 100644 --- a/src/fsharp/symbols/Exprs.fs +++ b/src/fsharp/symbols/Exprs.fs @@ -1108,7 +1108,7 @@ module FSharpExprConvert = and ConvTargetsLinear cenv env tgs contf = match tgs with | [] -> contf [] - | TTarget(vars, rhs, _) :: rest -> + | TTarget(vars, rhs, _, _) :: rest -> let varsR = (List.rev vars) |> List.map (ConvVal cenv) ConvExprLinear cenv env rhs (fun targetR -> ConvTargetsLinear cenv env rest (fun restR -> diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 700f61571d9..edebf7335ec 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -4548,7 +4548,7 @@ and and [] DecisionTreeTarget = - | TTarget of Vals * Expr * SequencePointInfoForTarget + | TTarget of Val list * Expr * SequencePointInfoForTarget * isStateVarFlags: bool list option [] member x.DebugText = x.ToString() diff --git a/tests/fsharp/core/state-machines/list.fs b/tests/fsharp/core/state-machines/list.fs index 09b695272f7..4ab8bd72d87 100644 --- a/tests/fsharp/core/state-machines/list.fs +++ b/tests/fsharp/core/state-machines/list.fs @@ -1,5 +1,5 @@ -module Seq +module Tests.ListAndArrayBuilder open System open System.Collections @@ -7,11 +7,11 @@ open System.Collections.Generic open System.Runtime.CompilerServices open FSharp.Core.CompilerServices.CodeGenHelpers -let [] DONE = 3 +let [] DONE = 3uy [] -type ListStep<'T>(res: int) = - member x.IsDone = (res = 3) +type ListStep<'T>(res: byte) = + member x.IsDone = (res = DONE) [] type ListStateMachine<'T>() = @@ -38,27 +38,35 @@ type ListStateMachine<'T>() = type ResizeArrayBuilderBase() = + [] member inline __.Delay(__expand_f : unit -> ListStep<'T>) = __expand_f + [] member inline __.Zero() : ListStep<'T> = ListStep<'T>(DONE) + [] member inline __.Combine(``__machine_step$cont``: ListStep<'T>, __expand_task2: unit -> ListStep<'T>) : ListStep<'T> = __expand_task2() + [] member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> ListStep<'T>) : ListStep<'T> = while __expand_condition() do let ``__machine_step$cont`` = __expand_body () () ListStep<'T>(DONE) + [] member inline __.TryWith(__expand_body : unit -> ListStep<'T>, __expand_catch : exn -> ListStep<'T>) : ListStep<'T> = try - __expand_body () + let ``__machine_step$cont`` = __expand_body () + () with exn -> - __expand_catch exn + let ``__machine_step$cont`` = __expand_catch exn + () ListStep<'T>(DONE) + [] member inline __.TryFinally(__expand_body: unit -> ListStep<'T>, compensation : unit -> unit) : ListStep<'T> = try let ``__machine_step$cont`` = __expand_body () @@ -70,25 +78,30 @@ type ResizeArrayBuilderBase() = compensation() ListStep<'T>(DONE) + [] member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> ListStep<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. this.TryFinally( (fun () -> __expand_body disp), (fun () -> if not (isNull (box disp)) then disp.Dispose())) + [] member inline this.For(sequence : seq<'TElement>, __expand_body : 'TElement -> ListStep<'T>) : ListStep<'T> = this.Using (sequence.GetEnumerator(), (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) + [] member inline __.Yield (``__machine_step$cont``: 'T) : ListStep<'T> = __machine>.Yield(``__machine_step$cont``) ListStep<'T>(DONE) + [] member inline this.YieldFrom (source: IEnumerable<'T>) : ListStep<'T> = this.For(source, (fun ``__machine_step$cont`` -> this.Yield(``__machine_step$cont``))) type ResizeArrayBuilder() = inherit ResizeArrayBuilderBase() + [] member inline __.Run(__expand_code : unit -> ListStep<'T>) : ResizeArray<'T> = (__stateMachine { new ListStateMachine<'T>() with @@ -98,6 +111,7 @@ let rsarray = ResizeArrayBuilder() type ListBuilder() = inherit ResizeArrayBuilderBase() + [] member inline __.Run(__expand_code : unit -> ListStep<'T>) : 'T list = (__stateMachine { new ListStateMachine<'T>() with @@ -107,6 +121,7 @@ let list = ListBuilder() type ArrayBuilder() = inherit ResizeArrayBuilderBase() + [] member inline __.Run(__expand_code : unit -> ListStep<'T>) : 'T[] = (__stateMachine { new ListStateMachine<'T>() with diff --git a/tests/fsharp/core/state-machines/seq2.fs b/tests/fsharp/core/state-machines/seq2.fs index 9ea9f655461..2dba9522006 100644 --- a/tests/fsharp/core/state-machines/seq2.fs +++ b/tests/fsharp/core/state-machines/seq2.fs @@ -1,6 +1,7 @@ -module Seq +module Tests.Seq2 +#nowarn "42" open System open System.Collections open System.Collections.Generic @@ -75,22 +76,27 @@ type SeqStateMachine<'T>() = type SeqBuilder() = + [] member inline __.Delay(__expand_f : unit -> SeqStep<'T>) = __expand_f + [] member inline __.Run(__expand_code : unit -> SeqStep<'T>) : IEnumerable<'T> = (__stateMachine { new SeqStateMachine<'T>() with member __.Step pc = __jumptable pc __expand_code }).Start() + [] member inline __.Zero() : SeqStep<'T> = SeqStep<'T>(DONE) + [] member inline __.Combine(``__machine_step$cont``: SeqStep<'T>, __expand_task2: unit -> SeqStep<'T>) : SeqStep<'T> = if ``__machine_step$cont``.IsDone then __expand_task2() else ``__machine_step$cont`` + [] member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> SeqStep<'T>) : SeqStep<'T> = let mutable step = SeqStep<'T>(DONE) while step.IsDone && __expand_condition() do @@ -98,6 +104,7 @@ type SeqBuilder() = step <- ``__machine_step$cont`` step + [] member inline __.TryWith(__expand_body : unit -> SeqStep<'T>, __expand_catch : exn -> SeqStep<'T>) : SeqStep<'T> = let mutable step = SeqStep<'T>(DONE) let mutable caught = false @@ -114,6 +121,7 @@ type SeqBuilder() = else step + [] member inline __.TryFinally(__expand_body: unit -> SeqStep<'T>, compensation : unit -> unit) : SeqStep<'T> = let mutable step = SeqStep<'T>(DONE) __machine>.PushDispose compensation @@ -132,18 +140,21 @@ type SeqBuilder() = compensation() step + [] member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> SeqStep<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. this.TryFinally( (fun () -> __expand_body disp), (fun () -> if not (isNull (box disp)) then disp.Dispose())) + [] member inline this.For(sequence : seq<'TElement>, __expand_body : 'TElement -> SeqStep<'T>) : SeqStep<'T> = // A for loop is just a using statement on the sequence's enumerator... this.Using (sequence.GetEnumerator(), // ... and its body is a while loop that advances the enumerator and runs the body on each element. (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) + [] member inline __.Yield (``__machine_step$cont``: 'T) : SeqStep<'T> = let CONT = __newEntryPoint() // A dummy to allow us to lay down the code for the continuation @@ -155,6 +166,7 @@ type SeqBuilder() = else __machine>.Yield(``__machine_step$cont``, CONT) + [] member inline this.YieldFrom (source: IEnumerable<'T>) : SeqStep<'T> = this.For(source, (fun ``__machine_step$cont`` -> this.Yield(``__machine_step$cont``))) diff --git a/tests/fsharp/core/state-machines/sync.fs b/tests/fsharp/core/state-machines/sync.fs index 42c659c50a1..5a87b69b583 100644 --- a/tests/fsharp/core/state-machines/sync.fs +++ b/tests/fsharp/core/state-machines/sync.fs @@ -1,45 +1,51 @@ -module Sync +module Tests.SyncBuilder open System open FSharp.Core.CompilerServices.CodeGenHelpers -type SyncStep<'T> = 'T - [] type SyncMachine<'T>() = - abstract Step : unit -> SyncStep<'T> + abstract Step : unit -> 'T member this.Start() = this.Step() type SyncBuilder() = - member inline __.Delay(__expand_f : unit -> SyncStep<'T>) = __expand_f + [] + member inline __.Delay(__expand_f : unit -> 'T) = __expand_f - member inline __.Run(__expand_code : unit -> SyncStep<'T>) : 'T = + [] + member inline __.Run(__expand_code : unit -> 'T) : 'T = (__stateMachine { new SyncMachine<'T>() with member __.Step () = __jumptable 0 __expand_code }).Start() - member inline __.Zero() : SyncStep = () + [] + member inline __.Zero() : unit = () - member inline __.Return (x: 'T) : SyncStep<'T> = x + [] + member inline __.Return (x: 'T) : 'T = x - member inline __.Combine(``__machine_step$cont``: SyncStep, __expand_step2: unit -> SyncStep<'T>) : SyncStep<'T> = + [] + member inline __.Combine(``__machine_step$cont``: unit, __expand_step2: unit -> 'T) : 'T = __expand_step2() - member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> SyncStep) : SyncStep = + [] + member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> unit) : unit = while __expand_condition() do __expand_body () - member inline __.TryWith(__expand_body : unit -> SyncStep<'T>, __expand_catch : exn -> SyncStep<'T>) : SyncStep<'T> = + [] + member inline __.TryWith(__expand_body : unit -> 'T, __expand_catch : exn -> 'T) : 'T = try __expand_body () with exn -> __expand_catch exn - member inline __.TryFinally(__expand_body: unit -> SyncStep<'T>, compensation : unit -> unit) : SyncStep<'T> = + [] + member inline __.TryFinally(__expand_body: unit -> 'T, compensation : unit -> unit) : 'T = let ``__machine_step$cont`` = try __expand_body () @@ -49,19 +55,23 @@ type SyncBuilder() = compensation() ``__machine_step$cont`` - member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> SyncStep<'T>) = + [] + member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> 'T) = this.TryFinally( (fun () -> __expand_body disp), (fun () -> if not (isNull (box disp)) then disp.Dispose())) - member inline this.For(sequence : seq<'T>, __expand_body : 'T -> SyncStep) : SyncStep = + [] + member inline this.For(sequence : seq<'T>, __expand_body : 'T -> unit) : unit = this.Using (sequence.GetEnumerator(), (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) - member inline __.ReturnFrom (value: 'T) : SyncStep<'T> = + [] + member inline __.ReturnFrom (value: 'T) : 'T = value - member inline __.Bind (value: 'TResult1, __expand_continuation: ^TResult1 -> SyncStep<'TResult2>) = + [] + member inline __.Bind (value: 'TResult1, __expand_continuation: 'TResult1 -> 'TResult2) = __expand_continuation value let sync = SyncBuilder() diff --git a/tests/fsharp/core/state-machines/sync.fsi b/tests/fsharp/core/state-machines/sync.fsi index e5ba40bfe76..e841b39450d 100644 --- a/tests/fsharp/core/state-machines/sync.fsi +++ b/tests/fsharp/core/state-machines/sync.fsi @@ -1,38 +1,33 @@ -module Sync +module Tests.SyncBuilder open System open System.Runtime.CompilerServices open System.Threading.Tasks -open Microsoft.FSharp.Core -open Microsoft.FSharp.Core.CompilerServices -open Microsoft.FSharp.Control -open Microsoft.FSharp.Collections - -/// Represents the result of a computation, a value of true indicates completion -type SyncStep<'T> = 'T +open FSharp.Core +open FSharp.Core.CompilerServices +open FSharp.Control +open FSharp.Collections [] type SyncMachine<'T> = new : unit -> SyncMachine<'T> - abstract Step : pc: int -> SyncStep<'T> + abstract Step : unit -> 'T member Start: unit -> 'T type SyncBuilder = new: unit -> SyncBuilder - member inline Combine: task1: SyncStep * task2: (unit -> SyncStep<'T>) -> SyncStep<'T> - member inline Delay: f: (unit -> SyncStep<'T>) -> (unit -> SyncStep<'T>) - member inline For: sequence: seq<'T> * body: ('T -> SyncStep) -> SyncStep - member inline Return: x: 'T -> SyncStep<'T> - member inline ReturnFrom: task: Task<'T> -> SyncStep<'T> - member inline Run: code: (unit -> SyncStep<'T>) -> Task<'T> - member inline TryFinally: body: (unit -> SyncStep<'T>) * fin: (unit -> unit) -> SyncStep<'T> - member inline TryWith: body: (unit -> SyncStep<'T>) * catch: (exn -> SyncStep<'T>) -> SyncStep<'T> - member inline Using: disp: 'Resource * body: ('Resource -> SyncStep<'T>) -> SyncStep<'T> when 'Resource :> IDisposable - member inline While: condition: (unit -> bool) * body: (unit -> SyncStep) -> SyncStep - member inline Zero: unit -> SyncStep - member inline Bind : v: 'TResult1 * continuation: ('TResult1 -> SyncStep<'TResult2>) -> SyncStep<'TResult2> - member inline ReturnFrom: a: 'TResult1 -> SyncStep< 'TResult > + member inline Combine: task1: unit * task2: (unit -> 'T) -> 'T + member inline Delay: f: (unit -> 'T) -> (unit -> 'T) + member inline For: sequence: seq<'T> * body: ('T -> unit) -> unit + member inline Return: x: 'T -> 'T + member inline Run: code: (unit -> 'T) -> 'T + member inline TryFinally: body: (unit -> 'T) * fin: (unit -> unit) -> 'T + member inline TryWith: body: (unit -> 'T) * catch: (exn -> 'T) -> 'T + member inline Using: disp: 'Resource * body: ('Resource -> 'T) -> 'T when 'Resource :> IDisposable + member inline While: condition: (unit -> bool) * body: (unit -> unit) -> unit + member inline Zero: unit -> unit + member inline Bind : v: 'TResult1 * continuation: ('TResult1 -> 'TResult2) -> 'TResult2 val sync : SyncBuilder diff --git a/tests/fsharp/core/state-machines/taskSeq.fs b/tests/fsharp/core/state-machines/taskSeq.fs index ce04683c11e..6a289c1fd6a 100644 --- a/tests/fsharp/core/state-machines/taskSeq.fs +++ b/tests/fsharp/core/state-machines/taskSeq.fs @@ -1,20 +1,21 @@ -module TaskSeq +module Tests.TaskSeqBuilder +#nowarn "42" open System open System.Runtime.CompilerServices open System.Threading open System.Threading.Tasks open FSharp.Core.CompilerServices.CodeGenHelpers -let [] AWAIT = 1 -let [] YIELD = 2 -let [] DONE = 3 +let [] AWAIT = 1uy +let [] YIELD = 2uy +let [] DONE = 3uy [] -type TaskSeqStep<'T>(res: int) = - member x.IsYield = (res = 2) - member x.IsDone = (res = 3) +type TaskSeqStep<'T>(res: byte) = + member x.IsYield = (res = YIELD) + member x.IsDone = (res = DONE) type IAsyncDisposable = abstract DisposeAsync: unit -> Task @@ -101,22 +102,27 @@ type TaskSeqStateMachine<'T>() = type TaskSeqBuilder() = + [] member inline __.Delay(__expand_f : unit -> TaskSeqStep<'T>) = __expand_f + [] member inline __.Run(__expand_code : unit -> TaskSeqStep<'T>) : IAsyncEnumerable<'T> = (__stateMachine { new TaskSeqStateMachine<'T>() with member __.Step pc = __jumptable pc __expand_code }).Start() + [] member inline __.Zero() : TaskSeqStep<'T> = TaskSeqStep<'T>(DONE) + [] member inline __.Combine(``__machine_step$cont``: TaskSeqStep<'T>, __expand_task2: unit -> TaskSeqStep<'T>) : TaskSeqStep<'T> = if ``__machine_step$cont``.IsDone then __expand_task2() else ``__machine_step$cont`` + [] member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> TaskSeqStep<'T>) : TaskSeqStep<'T> = let mutable step = TaskSeqStep<'T>(DONE) while step.IsDone && __expand_condition() do @@ -132,6 +138,7 @@ type TaskSeqBuilder() = // step <- ``__machine_step$cont`` // step + [] member inline __.TryWith(__expand_body : unit -> TaskSeqStep<'T>, __expand_catch : exn -> TaskSeqStep<'T>) : TaskSeqStep<'T> = let mutable step = TaskSeqStep<'T>(DONE) let mutable caught = false @@ -148,6 +155,7 @@ type TaskSeqBuilder() = else step + [] member inline __.TryFinallyAsync(__expand_body: unit -> TaskSeqStep<'T>, compensation : unit -> Task) : TaskSeqStep<'T> = let mutable step = TaskSeqStep<'T>(DONE) __machine>.PushDispose compensation @@ -166,27 +174,32 @@ type TaskSeqBuilder() = compensation().Result // TODO: async execution of this step + [] member inline this.TryFinally(__expand_body: unit -> TaskSeqStep<'T>, compensation : unit -> unit) : TaskSeqStep<'T> = this.TryFinallyAsync(__expand_body, fun () -> Task.FromResult(compensation())) + [] member inline this.Using(disp : #IDisposable, __expand_body : #IDisposable -> TaskSeqStep<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. this.TryFinally( (fun () -> __expand_body disp), (fun () -> if not (isNull (box disp)) then disp.Dispose())) + [] member inline this.UsingAsync(disp : #IAsyncDisposable, __expand_body : #IAsyncDisposable -> TaskSeqStep<'T>) = // A using statement is just a try/finally with the finally block disposing if non-null. this.TryFinallyAsync( (fun () -> __expand_body disp), (fun () -> if not (isNull (box disp)) then disp.DisposeAsync() else Task.FromResult())) + [] member inline this.For(sequence : seq<'TElement>, __expand_body : 'TElement -> TaskSeqStep<'T>) : TaskSeqStep<'T> = // A for loop is just a using statement on the sequence's enumerator... this.Using (sequence.GetEnumerator(), // ... and its body is a while loop that advances the enumerator and runs the body on each element. (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) + [] member inline this.For(source : IAsyncEnumerable<'TElement>, __expand_body : 'TElement -> TaskSeqStep<'T>) : TaskSeqStep<'T> = let mutable ct = Unchecked.defaultof<_> ct <- __machine>.CancellationToken @@ -194,6 +207,7 @@ type TaskSeqBuilder() = // TODO: This should call WhileAsync (fun e -> this.While((fun () -> e.MoveNextAsync().Result), (fun () -> __expand_body e.Current)))) + [] member inline __.Yield (``__machine_step$cont``: 'T) : TaskSeqStep<'T> = let CONT = __newEntryPoint() // A dummy to allow us to lay down the code for the continuation @@ -205,9 +219,11 @@ type TaskSeqBuilder() = else __machine>.Yield(``__machine_step$cont``, CONT) + [] member inline this.YieldFrom (source: IAsyncEnumerable<'T>) : TaskSeqStep<'T> = this.For(source, (fun ``__machine_step$cont`` -> this.Yield(``__machine_step$cont``))) + [] member inline __.Bind (task: Task<'TResult1>, __expand_continuation: ('TResult1 -> TaskSeqStep<'T>)) : TaskSeqStep<'T> = let CONT = __newEntryPoint() let awaiter = task.GetAwaiter() diff --git a/tests/fsharp/perf/tasks/FS/TaskPerf.fs b/tests/fsharp/perf/tasks/FS/TaskPerf.fs index f73abe141ed..cb3cd16c212 100644 --- a/tests/fsharp/perf/tasks/FS/TaskPerf.fs +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fs @@ -13,6 +13,7 @@ open BenchmarkDotNet.Attributes open BenchmarkDotNet.Running open TaskBuilderTasks.ContextSensitive // TaskBuilder.fs extension members open FSharp.Control.ContextSensitiveTasks // the default +open Tests.SyncBuilder [] module Helpers = @@ -166,24 +167,24 @@ type ManyWriteFile() = File.Delete(path) [] -type SyncBinds() = +type NonAsyncBinds() = [] - member __.SyncBinds_CSharpAsync() = + member __.NonAsyncBinds_CSharpAsync() = for i in 1 .. manyIterations*100 do TaskPerfCSharp.TenBindsSync_CSharp().Wait() [] - member __.SyncBinds_Task() = + member __.NonAsyncBinds_Task() = for i in 1 .. manyIterations*100 do tenBindSync_Task().Wait() [] - member __.SyncBinds_TaskBuilder() = + member __.NonAsyncBinds_TaskBuilder() = for i in 1 .. manyIterations*100 do tenBindSync_TaskBuilder().Wait() [] - member __.SyncBinds_FSharpAsync() = + member __.NonAsyncBinds_FSharpAsync() = for i in 1 .. manyIterations*100 do tenBindSync_FSharpAsync() |> Async.RunSynchronously |> ignore @@ -231,6 +232,22 @@ type SingleSyncTask() = for i in 1 .. manyIterations*500 do singleTask_FSharpAsync() |> Async.RunSynchronously |> ignore +[] +type SyncBuilderLoop() = + [] + member __.SyncBuilderLoop_NormalCode() = + for i in 1 .. manyIterations do + let mutable res = 0 + for i in Seq.init 1000 id do + res <- i + res + + [] + member __.SyncBuilderLoop_WorkflowCode() = + for i in 1 .. manyIterations do + sync { let mutable res = 0 + for i in Seq.init 1000 id do + res <- i + res } + module Main = [] @@ -240,10 +257,10 @@ module Main = ManyWriteFile().ManyWriteFile_Task () ManyWriteFile().ManyWriteFile_TaskBuilder () ManyWriteFile().ManyWriteFile_FSharpAsync () - SyncBinds().SyncBinds_CSharpAsync() - SyncBinds().SyncBinds_Task() - SyncBinds().SyncBinds_TaskBuilder() - SyncBinds().SyncBinds_FSharpAsync() + NonAsyncBinds().NonAsyncBinds_CSharpAsync() + NonAsyncBinds().NonAsyncBinds_Task() + NonAsyncBinds().NonAsyncBinds_TaskBuilder() + NonAsyncBinds().NonAsyncBinds_FSharpAsync() AsyncBinds().AsyncBinds_CSharpAsync() AsyncBinds().AsyncBinds_Task() AsyncBinds().AsyncBinds_TaskBuilder() @@ -253,13 +270,14 @@ module Main = SingleSyncTask().SingleSyncTask_FSharpAsync() printfn "Running becnhmarks..." - let manyWriteFileResult = BenchmarkRunner.Run() - let syncBindsResult = BenchmarkRunner.Run() - let asyncBindsResult = BenchmarkRunner.Run() - let singleTaskResult = BenchmarkRunner.Run() + //let manyWriteFileResult = BenchmarkRunner.Run() + //let syncBindsResult = BenchmarkRunner.Run() + //let asyncBindsResult = BenchmarkRunner.Run() + //let singleTaskResult = BenchmarkRunner.Run() - printfn "%A" manyWriteFileResult - printfn "%A" syncBindsResult - printfn "%A" asyncBindsResult - printfn "%A" singleTaskResult + //printfn "%A" manyWriteFileResult + //printfn "%A" syncBindsResult + //printfn "%A" asyncBindsResult + //printfn "%A" singleTaskResult + let syncBuilderLoopResult = BenchmarkRunner.Run() 0 \ No newline at end of file diff --git a/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj b/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj index 1460872d5fd..3a3c24f5368 100644 --- a/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj @@ -6,6 +6,11 @@ + + + + +