diff --git a/FSharpBuild.Directory.Build.props b/FSharpBuild.Directory.Build.props index a1ba7ab156d..515de9bbdc7 100644 --- a/FSharpBuild.Directory.Build.props +++ b/FSharpBuild.Directory.Build.props @@ -11,8 +11,7 @@ $(RepoRoot)src $(ArtifactsDir)\SymStore - $(ArtifactsDir)\Bootstrap - $(ArtifactsDir)/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/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/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 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/eng/Build.ps1 b/eng/Build.ps1 index 2c88012b376..9d8aef8952c 100644 --- a/eng/Build.ps1 +++ b/eng/Build.ps1 @@ -68,6 +68,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" @@ -106,6 +107,7 @@ function Process-Arguments() { Print-Usage exit 0 } + $script:nodeReuse = $False; if ($testAll) { $script:testDesktop = $True @@ -143,7 +145,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 } } @@ -177,7 +179,6 @@ function BuildSolution() { /p:Publish=$publish ` /p:ContinuousIntegrationBuild=$ci ` /p:OfficialBuildId=$officialBuildId ` - /p:BootstrapBuildPath=$bootstrapDir ` /p:QuietRestore=$quietRestore ` /p:QuietRestoreBinaryLog=$binaryLog ` /p:TestTargetFrameworks=$testTargetFrameworks ` @@ -211,7 +212,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 d1e5dd85d55..335379b2f73 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. @@ -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" @@ -241,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 23b00ef66a9..44d047e38b9 100755 --- a/eng/build.sh +++ b/eng/build.sh @@ -13,7 +13,9 @@ 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 " --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" @@ -54,6 +56,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 +91,9 @@ while [[ $# > 0 ]]; do --binarylog|-bl) binary_log=true ;; + --bootstrap) + force_bootstrap=true + ;; --restore|-r) restore=true ;; @@ -205,17 +211,33 @@ function BuildSolution { quiet_restore=true fi + # 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.1/* $bootstrap_dir - cp $artifacts_dir/bin/fsyacc/$bootstrap_config/netcoreapp2.1/* $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 \ + /p:Configuration=$bootstrap_config \ + /t:Publish + + mkdir -p "$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 \ + /p:Configuration=$bootstrap_config \ + /t:Publish + + cp -pr $artifacts_dir/bin/fsc/$bootstrap_config/netcoreapp2.1/publish $bootstrap_dir/fsc + fi # do real build MSBuild $toolset_build_proj \ diff --git a/fcs/Directory.Build.props b/fcs/Directory.Build.props index c56fd7cba6d..2841a5fb34f 100644 --- a/fcs/Directory.Build.props +++ b/fcs/Directory.Build.props @@ -31,7 +31,6 @@ $(FSharpSourcesRoot)\..\packages\FSharp.Compiler.Tools.4.1.27\tools fsi.exe - $(ArtifactsBinDir)\FSharp.Build\Proto\net472 4.6.2 net461 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 @@ - + 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.proj b/src/buildtools/buildtools.proj index 593f086dd07..630bb678561 100644 --- a/src/buildtools/buildtools.proj +++ b/src/buildtools/buildtools.proj @@ -2,7 +2,8 @@ Debug - + true + @@ -10,23 +11,23 @@ - + - + - + - + - + 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 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/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/FSComp.txt b/src/fsharp/FSComp.txt index ee2b41f2e9d..f877107b0de 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/FSharp.Core.fsproj b/src/fsharp/FSharp.Core/FSharp.Core.fsproj index 588f72eaedc..7520849f33f 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/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 new file mode 100644 index 00000000000..babe2442708 --- /dev/null +++ b/src/fsharp/FSharp.Core/tasks.fs @@ -0,0 +1,456 @@ +// 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. +// +// 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. + +#if FSHARP_CORE +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 + + /// 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 + + module CodeGenHelpers = + + [] + let __jumptable<'T> (_x:int) (_code: unit -> 'T) : 'T = failwith "__jumptable should always be removed from compiled code" + + [] + 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 __machineAddr<'T> : byref<'T> = (# "ldnull throw" : byref<'T> #) + + [] + let __entryPoint (_n: int) : unit = failwith "__entryPoint should always be removed from compiled code" + + [] + 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 + +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.CompilerServices.CodeGenHelpers +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. +// +// Uses a struct-around-single-reference to allow future changes in representation (the representation is +// not revealed in the signature) +[] +type TaskStep<'T, 'TOverall>(completed: bool) = + member x.IsCompleted = completed + +[] +type TaskStateMachineTemplate<'T> = + + [] + val mutable Result : 'T + + [] + val mutable ResumptionPoint : int + + [] + val mutable MethodBuilder : AsyncTaskMethodBuilder<'T> + + 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.MethodBuilder <- AsyncTaskMethodBuilder<'T>.Create() + sm.MethodBuilder.Start(&sm) + //Console.WriteLine("[{0}] unwrap", sm.GetHashCode()) + sm.MethodBuilder.Task + + [] + let inline Await (sm: byref>) (awaiter: byref<('Awaiter :> ICriticalNotifyCompletion)>, pc) = + sm.ResumptionPoint <- pc + //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 + +[] +module TaskHelpers = + + //let inline unwrapException (agg : AggregateException) = + // let inners = agg.InnerExceptions + // if inners.Count = 1 then inners.[0] + // 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)) + + 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 : 'TResult2) = + // task { + // do! Task.Yield() + // return x + // } + + [] + 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, 'TOverall>) : TaskStep<'TResult2, 'TOverall> = + 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) + 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) + and ^Awaiter :> ICriticalNotifyCompletion + and ^Awaiter : (member get_IsCompleted : unit -> bool) + and ^Awaiter : (member GetResult : unit -> ^TResult1) > + (task : ^TaskLike, __expand_continuation : ^TResult1 -> TaskStep<'TResult2, 'TOverall>) : TaskStep<'TResult2, 'TOverall> = + let awaitable = (^TaskLike : (member ConfigureAwait : bool -> ^Awaitable)(task, false)) + 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, 'TOverall>) = + let CONT = __newEntryPoint() + let mutable awaiter = task.GetAwaiter() + if awaiter.IsCompleted then + __entryPoint CONT + __expand_continuation (awaiter.GetResult()) + else + 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 mutable awaiter = task.ConfigureAwait(false).GetAwaiter() + if awaiter.IsCompleted then + __entryPoint CONT + __expand_continuation (awaiter.GetResult()) + else + 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 + (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() + if ``__machine_step$cont``.IsCompleted then + let v = __machineAddr> + //Console.WriteLine("[{0}] SetResult {1}", sm.GetHashCode(), res) + v.MethodBuilder.SetResult(v.Result) + 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 = 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() + else + 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 __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 + __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 __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. + __stack_completed <- ``__machine_step$cont``.IsCompleted + with exn -> + // The catch block may not contain resumption points. + __stack_caught <- true + __stack_savedExn <- exn + + if __stack_caught then + // Place the catch code outside the catch block + __expand_catch __stack_savedExn + else + 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 __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. + __stack_completed <- ``__machine_step$cont``.IsCompleted + with _ -> + compensation() + reraise() + + if __stack_completed then + compensation() + TaskStep<'T, 'TOverall>(__stack_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 mutable awaiter = task.GetAwaiter() + if task.IsCompleted then + __entryPoint CONT + ret (awaiter.GetResult()) + else + Helpers.Await __machineAddr> (&awaiter, CONT) + TaskStep<'T, 'T>(false) + +[] +module ContextSensitiveTasks = + + let task = TaskBuilder() + + [] + 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 , '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, '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 + and ^Awaiter: (member get_IsCompleted: unit -> bool) + and ^Awaiter: (member GetResult: unit -> ^T)> + (_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 __.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 __.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 = + + let task = TaskBuilder() + + [] + type Witnesses() = + interface IPriority1 + interface IPriority2 + interface IPriority3 + + [] + 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, '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) + 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, '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, ^T >(taskLike, ret< ^T > ) + + [] + 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) + = TaskLikeBind< ^T >.GenericAwaitConfigureFalse(configurableTaskLike, ret< ^T >) + + [] + static member inline CanReturnFrom (_priority: IPriority1, computation: Async<'T>) + = bindTaskConfigureFalse (Async.StartAsTask computation) ret + + type TaskBuilder with + [] + 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 __.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 new file mode 100644 index 00000000000..bf2ef8b0eef --- /dev/null +++ b/src/fsharp/FSharp.Core/tasks.fsi @@ -0,0 +1,239 @@ +// 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 + + open Microsoft.FSharp.Core + open System.Runtime.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 + + module CodeGenHelpers = + [] + val __jumptable : int -> (unit -> '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 + + [] + val __machine<'T> : 'T + + [] + val __machineAddr<'T> : byref<'T> + + [] + val __entryPoint: int -> unit + + [] + val __return : 'T -> 'T + +#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.CompilerServices +open Microsoft.FSharp.Control +open Microsoft.FSharp.Collections + +/// Represents the result of a computation, a value of true indicates completion +[] +type TaskStep<'T, 'TOverall> = + new : completed: bool -> TaskStep<'T, 'TOverall> + member IsCompleted: bool + +[] +/// This is used by the compiler as a template for creating state machine structs +type TaskStateMachineTemplate<'T> = + [] + val mutable Result : 'T + + [] + val mutable ResumptionPoint : int + + [] + val mutable MethodBuilder : AsyncTaskMethodBuilder<'T> + + interface IAsyncStateMachine + +[] +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, '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 + +[] +module ContextSensitiveTasks = + + /// 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 + + /// 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, '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, '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 + 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, '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 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 = + + /// 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, '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, '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 + 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, '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, ^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, ^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 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/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index ac64aa6c1df..90acab0f27a 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 @@ -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 c188b548073..394b05e8c77 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) @@ -793,6 +816,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 @@ -807,6 +866,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 @@ -828,6 +891,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 } @@ -878,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 //-------------------------------------------------------------------------- @@ -1581,8 +1650,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 [] @@ -1844,34 +1911,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 @@ -2144,11 +2183,19 @@ 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.ConvertStateMachineExprToObject g expr with + | 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 | Expr.Const (c, m, ty) -> GenConstant cenv cgbuf eenv (c, m, ty) sequel @@ -2164,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 @@ -2182,6 +2229,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 && ( @@ -2192,8 +2240,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 @@ -2285,7 +2335,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 @@ -2294,12 +2344,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" @@ -2309,6 +2362,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), @@ -2860,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 @@ -2935,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 @@ -3219,7 +3284,6 @@ 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 = @@ -3227,11 +3291,14 @@ and GenTry cenv cgbuf eenv scopeMarks (e1, m, resty, spTry) = assert(cenv.g.CompilerGlobalState |> Option.isSome) AllocLocal cenv cgbuf eenvinner true (cenv.g.CompilerGlobalState.Value.IlxGenNiceNameGenerator.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 @@ -3251,6 +3318,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 @@ -3308,7 +3376,9 @@ and GenTryCatch cenv cgbuf eenv (e1, vf: Val, ef, vh: Val, eh, m, resty, spTry, GenStoreVal cenv 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) @@ -4046,9 +4116,190 @@ 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 GenStructStateMachine cenv cgbuf eenvouter (templateStructTy, moveNextExpr, stateVars, setStateMachineExpr, machineAddrVar, startExpr) sequel = + + let m = startExpr.Range let g = cenv.g - let cloinfo, _, eenvinner = GetIlxClosureInfo cenv m false None eenvouter expr + + 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 ILBoxity.AsValue 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), ilMachineAddrTy, 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 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 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 + + ) + +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 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 ILBoxity.AsObject false None eenvouter objExpr let cloAttribs = cloinfo.cloAttribs let cloFreeVars = cloinfo.cloFreeVars @@ -4091,8 +4342,15 @@ 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 @@ -4112,7 +4370,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 @@ -4244,7 +4502,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 @@ -4333,7 +4591,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 @@ -4346,7 +4604,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() @@ -4402,7 +4660,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. @@ -4431,13 +4689,13 @@ 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 | Expr.Lambda (_, _, _, _, _, _, returnTy) | Expr.TyLambda (_, _, _, _, returnTy) -> returnTy - | Expr.Obj (_, ty, _, _, _, _, _) -> ty - | _ -> failwith "GetIlxClosureInfo: not a lambda expression" + | Expr.Obj (_, ty, _, _, _, _, _, _) -> ty + | _ -> 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. @@ -4458,7 +4716,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) = @@ -4615,7 +4873,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 @@ -4792,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. @@ -4810,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 @@ -4824,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 @@ -4839,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 = @@ -4861,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) @@ -4879,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 @@ -5031,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) -> @@ -5099,7 +5370,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 @@ -5129,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 @@ -5152,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 = @@ -5170,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 @@ -5200,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 @@ -5328,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 //------------------------------------------------------------------------- @@ -5907,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 @@ -5915,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 @@ -6100,7 +6379,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 @@ -6376,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 @@ -7456,6 +7735,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 fabd5583c23..ef5e5375181 100644 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -1125,14 +1125,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 *) @@ -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 6bc583faae1..75d804269fd 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 @@ -102,11 +102,17 @@ 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 +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), @@ -117,46 +123,39 @@ let isVarFreeInExpr v e = Zset.contains v (freeInExpr CollectTyparsAndLocals e). /// 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 - | 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,32 +163,36 @@ 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) 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 @@ -201,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 @@ -224,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 @@ -233,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 @@ -266,30 +273,30 @@ 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 + 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 = - if res1.labels.IsEmpty then - res2.capturedVars + let asyncVars = + if res1.entryPoints.IsEmpty then + 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 @@ -300,21 +307,21 @@ 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 } + 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 = - if res2.labels.IsEmpty then - res2.capturedVars // the whole loopis synchronous, no labels + let asyncVars = + if res2.entryPoints.IsEmpty then + res2.asyncVars // the whole loop is synchronous, no labels else freeInExpr CollectLocals expr // everything is needed on subsequent iterations @@ -324,10 +331,10 @@ 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 } + asyncVars = asyncVars } | _ -> None @@ -338,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" @@ -355,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 = @@ -400,10 +407,10 @@ 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 } + asyncVars = asyncVars } | _ -> None @@ -414,13 +421,13 @@ 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 } + 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 @@ -436,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 @@ -469,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 @@ -480,38 +487,47 @@ let LowerSeqExpr g amap overallExpr = | None -> None *) - | Expr.Match (spBind, exprm, pt, targets, m, ty) when targets |> Array.forall (fun (TTarget(vs, _e, _spTarget)) -> isNil vs) -> + // 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) -> // 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.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 labs = 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 = + (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) 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 } + asyncVars = asyncVars } else None @@ -568,13 +584,13 @@ 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 } + 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 @@ -585,11 +601,11 @@ 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. - 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 @@ -774,3 +790,632 @@ let LowerSeqExpr g amap overallExpr = | _ -> None + +//--------------------------------------------------------------------------------------------- + +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. + /// + phase2 : (Map -> Expr) + + /// 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 + + /// The vars captured by the non-synchronous path + asyncVars: FreeVars + } + + + + +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 () + | _ -> None + +let (|ReturnExpr|_|) g expr = + match expr with + | ValApp g g.cgh_return_vref (_, [e], m) -> Some (e, m) + | _ -> None + +let (|MachineExpr|_|) g expr = + match expr with + | 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) + | _ -> None + +let (|JumpTableExpr|_|) g expr = + match expr with + | ValApp g g.cgh_jumptable_vref (_, [pcExpr; codeExpr], _m) -> Some (pcExpr, codeExpr) + | _ -> None + +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 = + if sm_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: StateMachineConversionFirstPhaseResult) m = + if sm_verbose then + printfn "LowerStateMachine: 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 + phase1 = mkSequential sp m (mkValSet spm vref e) res2.phase1 + 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) + +type env = + { Macros: ValMap + MachineAddrExpr: Expr option } + + static member Empty = { Macros = ValMap.Empty; MachineAddrExpr = None } + +let ConvertStateMachineExprToObject g overallExpr = + + let mutable pcCount = 0 + let genPC() = + pcCount <- pcCount + 1 + pcCount + + // Evaluate __expand_ABC and __newEntryPoint bindings at compile-time. + // Here we record definitions for later use in TryApplyExpansions + 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 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 with Macros = env.Macros.Add v (mkInt g m (genPC())) } + BindExpansions g envR bodyExpr + + | _ -> + (env, expr) + + // Detect sequencing constructs in state machine code + let (|SequentialStateMachineCode|_|) (g: TcGlobals) expr = + match expr with + + // e1; e2 + | Expr.Sequential(e1, e2, NormalSeq, _, m) -> + Some (e1, e2, m, (fun e1 e2 -> mkCompGenSequential m e1 e2)) + + // 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(g.CompilerGlobalState) = "__machine_step$cont" -> + Some (bind.Expr, e2, m, (fun e1 e2 -> mkLet bind.SequencePointInfo m bind.Var e1 e2)) + + | _ -> None + + // Apply a single expansion of __expand_ABC and __newEntryPoint in an arbitrary expression + 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.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, 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 + + | _ -> 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: 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 + + 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 = + let env, expr = BindExpansions g env overallExpr + match expr with + | Expr.App (f0, f0ty, tyargsl, (RefStateMachineExpr g objExpr :: args), mApp) -> + Some (env, objExpr, (fun objExprR -> Expr.App (f0, f0ty, tyargsl, (objExprR :: args), mApp))) + | 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 + | 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) -> + 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..." + + 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 env meth2Expr + let machineAddrVar, machineAddrExpr = mkCompGenLocal m "machineAddr" (mkByrefTy g templateStructTy) + 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 + | _ -> None + | _ -> 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) + + /// Detect constructs allowed in state machines + let rec ConvertStateMachineCode env pcExpr expr = + if sm_verbose then + printfn "---------ConvertStateMachineCode" + printfn "%s" (DebugPrint.showExpr g expr) + printfn "---------" + + let env, expr = RepeatBindAndApplyExpansions g env expr + + if sm_verbose then + printfn "Expanded to %s" (DebugPrint.showExpr g 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 g (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= 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, 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) + 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 = + (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 -> + 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 -> + 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 } + + // 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)) || bind.Var.LogicalName.StartsWith "__stack_" 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 + | _ -> + let exprR = ConvertStateMachineLeafExpression 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) + printfn "Phase 1 Done, asyncVars = %A" (res.asyncVars.FreeLocals |> Zset.elements |> List.map (fun v -> v.CompiledName(g.CompilerGlobalState)) |> String.concat ",") + printfn "-------------------" + res + + // 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 ----------------------" + printfn "%s" (DebugPrint.showExpr g codeExpr) + printfn "----------- LOWER ----------------------" + + // Perform phase1 of the conversion + let res = ConvertStateMachineCode env pcExprR codeExpr + + // Work out the initial mapping of pcs to labels + let pcs = [ 1 .. pcCount ] + let furtherStateVars = 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 + if sm_verbose then printfn "----------- PHASE2 ----------------------" + + // Perform phase2 to build the final expression + let methodBodyExprR = res.phase2 pc2lab + + if sm_verbose then printfn "----------- ADDING JUMP TABLE ----------------------" + + // Add the jump table + let methodBodyExprWithJumpTable = addPcJumpTable g m pcs pc2lab pcExprR methodBodyExprR + + if sm_verbose then printfn "----------- REMAKE ----------------------" + + // Build the result + Some (remake (methodBodyExprWithJumpTable, furtherStateVars)) + + //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 sm_verbose then printfn "----------- DONE ----------------------" + + //Some overallExprR + + | _ -> None + diff --git a/src/fsharp/LowerCallsAndSeqs.fsi b/src/fsharp/LowerCallsAndSeqs.fsi index 5abcb8288dc..05a9003066a 100644 --- a/src/fsharp/LowerCallsAndSeqs.fsi +++ b/src/fsharp/LowerCallsAndSeqs.fsi @@ -19,4 +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 ConvertStateMachineExprToObject: g: TcGlobals -> overallExpr: Expr -> (Choice) option diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index ecc24b91317..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 @@ -1875,7 +1875,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) -> @@ -1925,7 +1925,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 @@ -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 b6a286c5d79..36373f3c6b1 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 @@ -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 cf4e4e17456..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") && @@ -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 @@ -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/SignatureConformance.fs b/src/fsharp/SignatureConformance.fs index b367987e173..2a057269d4f 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) = diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 00fb9a08278..8d1f8c6ed2d 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) @@ -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 @@ -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)) @@ -3657,7 +3657,7 @@ module DebugPrint = reprL and bindingL g (TBind(v, repr, _)) = - valAtBindL g v --- (wordL(tagText "=") ^^ exprL g repr) + (valAtBindL g v ^^ wordL(tagText "=")) @@-- exprL g repr and exprL g expr = exprWrapL g false expr @@ -3671,15 +3671,13 @@ module DebugPrint = (aboveListL eqnsL @@ bodyL) and letL g bind bodyL = - let eqnL = wordL(tagText "let") ^^ bindingL g bind ^^ wordL(tagText "in") + let eqnL = wordL(tagText "let") ^^ bindingL g bind (eqnL @@ bodyL) and exprWrapL g isAtomic expr = let atomL args = atomL g args let exprL expr = exprL g expr - let iimplL iimpls = iimplL g iimpls let valAtBindL v = valAtBindL g v - let overrideL tmeth = overrideL g tmeth let targetL targets = targetL g targets let wrap = bracketIfL isAtomic // wrap iff require atomic expr let lay = @@ -3698,8 +3696,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 @@ -3774,22 +3772,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 _, [], [x1;x2], _) -> - wordL(tagText "while") ^^ exprL x1 ^^ wordL(tagText "do") ^^ exprL x2 ^^ rightL(tagText "}") - | Expr.Op (TOp.For _, [], [x1;x2;x3], _) -> + | Expr.Op (TOp.While _, [], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _)], _) -> + (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 _, [_], [x1;x2], _) -> - wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "with") ^^ exprL x2 ^^ rightL(tagText "}") - | Expr.Op (TOp.TryFinally _, [_], [x1;x2], _) -> - wordL(tagText "try") ^^ exprL x1 ^^ wordL(tagText "finally") ^^ exprL x2 ^^ rightL(tagText "}") + | 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) + | Expr.Op (TOp.TryFinally _, [_], [Expr.Lambda (_, _, _, [_], x1, _, _);Expr.Lambda (_, _, _, [_], x2, _, _)], _) -> + (wordL (tagText "try") @@-- exprL x1) @@ (wordL(tagText "finally") @@-- exprL x2) | Expr.Op (TOp.Bytes _, _, _, _) -> wordL(tagText "bytes++") | Expr.Op (TOp.UInt16s _, _, _, _) -> wordL(tagText "uint16++") @@ -3799,15 +3797,21 @@ 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, _) -> - wordL(tagText "OBJ:") ^^ - aboveListL [typeL ty - exprL ccall - optionL valAtBindL basev - aboveListL (List.map overrideL overrides) - aboveListL (List.map iimplL iimpls)] + | Expr.Obj (_lambdaId, ty, basev, ccall, overrides, iimpls, _stateVars, _) -> + (leftL (tagText "{") + @@-- + ((wordL(tagText "new ") ++ typeL ty) + @@-- + aboveListL [exprL ccall + optionL valAtBindL basev + aboveListL (List.map (tmethodL g) overrides) + aboveListL (List.map (iimplL g) iimpls)])) + @@ + rightL (tagText "}") | Expr.StaticOptimization (_tcs, csx, x, _) -> (wordL(tagText "opt") @@- (exprL x)) @@-- @@ -3819,14 +3823,12 @@ module DebugPrint = else lay and implFilesL g implFiles = - let implFileL implFiles = implFileL g implFiles - aboveListL (List.map implFileL implFiles) + aboveListL (List.map (implFileL g) implFiles) and appL g flayout tys args = - let atomL args = atomL g 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 g) args) else z z and implFileL g (TImplFile (_, _, mexpr, _, _, _)) = @@ -3837,14 +3839,11 @@ module DebugPrint = | ModuleOrNamespaceExprWithSig(mtyp, defs, _) -> mdefL g defs @@- (wordL(tagText ":") @@- entityTypeL g mtyp) and mdefsL g defs = - let mdefL x = mdefL g x - wordL(tagText "Module Defs") @@-- aboveListL(List.map mdefL defs) + wordL(tagText "Module Defs") @@-- aboveListL(List.map (mdefL g) defs) and mdefL g x = - let tyconL tycon = tyconL g tycon - let mbindL x = mbindL g x match x with - | TMDefRec(_, tycons, mbinds, _) -> aboveListL ((tycons |> List.map tyconL) @ List.map mbindL mbinds) + | TMDefRec(_, tycons, mbinds, _) -> aboveListL ((tycons |> List.map (tyconL g)) @ (mbinds |> List.map (mbindL g))) | TMDefLet(bind, _) -> letL g bind emptyL | TMDefDo(e, _) -> exprL g e | TMDefs defs -> mdefsL g defs @@ -3857,9 +3856,8 @@ module DebugPrint = (wordL (tagText (if mspec.IsNamespace then "namespace" else "module")) ^^ (wordL (tagText mspec.DemangledModuleOrNamespaceName) |> stampL mspec.Stamp)) @@-- mdefL g rhs and entityTypeL g (mtyp: ModuleOrNamespaceType) = - let tyconL tycon = tyconL g tycon aboveListL [jlistL typeOfValL mtyp.AllValsAndMembers - jlistL tyconL mtyp.AllEntities] + jlistL (tyconL g) mtyp.AllEntities] and entityL g (ms: ModuleOrNamespace) = let header = wordL(tagText "module") ^^ (wordL (tagText ms.DemangledModuleOrNamespaceName) |> stampL ms.Stamp) ^^ wordL(tagText ":") @@ -3870,17 +3868,15 @@ module DebugPrint = and ccuL g (ccu: CcuThunk) = entityL g ccu.Contents and decisionTreeL g x = - let exprL expr = exprL g expr - let dcaseL dcases = dcaseL g dcases match x with | TDBind (bind, body) -> - let bind = wordL(tagText "let") ^^ bindingL g bind ^^ wordL(tagText "in") + let bind = wordL(tagText "let") ^^ bindingL g bind //^^ wordL(tagText "in") (bind @@ decisionTreeL g body) | TDSuccess (args, n) -> - wordL(tagText "Success") ^^ leftL(tagText "T") ^^ intL n ^^ tupleL (args |> List.map exprL) + wordL(tagText "Success") ^^ leftL(tagText "T") ^^ intL n ^^ tupleL (args |> List.map (exprL g)) | TDSwitch (test, dcases, dflt, _) -> - (wordL(tagText "Switch") --- exprL test) @@-- - (aboveListL (List.map dcaseL dcases) @@ + (wordL(tagText "Switch") --- exprL g test) @@-- + (aboveListL (List.map (dcaseL g) dcases) @@ match dflt with | None -> emptyL | Some dtree -> wordL(tagText "dflt:") --- decisionTreeL g dtree) @@ -3896,22 +3892,19 @@ 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 and tmethodL g (TObjExprMethod(TSlotSig(nm, _, _, _, _, _), _, tps, vs, e, _)) = - let valAtBindL v = valAtBindL g v - (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 g) >> tupleL) vs) ^^ rightL(tagText "."))) + @@-- (atomL g e) - and overrideL g tmeth = wordL(tagText "with") ^^ tmethodL g tmeth - - and iimplL g (ty, tmeths) = - let tmethodL p = tmethodL g p - wordL(tagText "impl") ^^ aboveListL (typeL ty :: List.map tmethodL tmeths) + and iimplL g (ty, tmeths) = wordL(tagText "impl") ^^ aboveListL (typeL ty :: List.map (tmethodL g) tmeths) let showType x = Layout.showL (typeL x) @@ -4275,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,...._)))). @@ -4487,7 +4480,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 @@ -4625,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 @@ -5029,7 +5024,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, @@ -5085,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 = @@ -5497,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, _) -> @@ -5506,10 +5501,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 = @@ -5647,7 +5642,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) @@ -5868,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. @@ -5876,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' @@ -5887,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 @@ -6337,7 +6332,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 @@ -6377,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 = @@ -7000,7 +6995,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 *) @@ -7649,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 @@ -7661,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 @@ -7995,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) @@ -8242,7 +8238,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 -> @@ -8262,7 +8258,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' @@ -8311,7 +8307,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' -> @@ -8324,7 +8320,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 @@ -8333,24 +8329,26 @@ 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) +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 @@ -8562,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/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 diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index da6906cf33c..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) @@ -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 1aa14c5794d..229f7604a3d 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,14 @@ 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_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)) + let v_cgh_entryPoint_info = makeIntrinsicValRef(fslib_MFCodeGenHelpers_nleref, "__entryPoint" , None , None , [vara], ([[v_int_ty]; [v_unit_ty --> varaTy]], varaTy)) + 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)) @@ -1421,6 +1431,15 @@ 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_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 + 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 member val generic_hash_withc_tuple4_vref = ValRefForIntrinsic v_generic_hash_withc_tuple4_info diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index 485b367aed4..3abeb53b5d8 100644 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -2177,7 +2177,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 @@ -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 @@ -3774,7 +3775,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 @@ -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 @@ -8338,17 +8343,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" | _ -> @@ -8537,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 @@ -10619,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 @@ -10768,7 +10777,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 @@ -11236,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/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 7941a6be577..c246f8bf32c 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 -> @@ -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 dd8f0506f70..edebf7335ec 100644 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -4404,7 +4404,7 @@ and override x.ToString() = sprintf "AttribNamedArg(...)" /// Constants in expressions -and [] +and [] Const = | Bool of bool | SByte of sbyte @@ -4425,6 +4425,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 @@ -4524,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() @@ -4650,7 +4674,7 @@ and Vals = Val list /// The big type of expressions. and - [] + [] Expr = /// A constant expression. | Const of Const * range * TType @@ -4688,6 +4712,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 *) @@ -4695,6 +4720,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 @@ -4730,6 +4756,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() @@ -4737,7 +4788,7 @@ and //override __.ToString() = "Expr(...)" and - [] + [] TOp = /// An operation representing the creation of a union value of the particular union case @@ -4854,11 +4905,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/src/fsharp/xlf/FSComp.txt.cs.xlf b/src/fsharp/xlf/FSComp.txt.cs.xlf index b3d508d0825..66cfbef7297 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.de.xlf b/src/fsharp/xlf/FSComp.txt.de.xlf index 41c117c7854..17b85a5a61a 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.es.xlf b/src/fsharp/xlf/FSComp.txt.es.xlf index 0afc48bb2c6..465866fbf80 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.fr.xlf b/src/fsharp/xlf/FSComp.txt.fr.xlf index 32d85d1e78a..1a0d50d3360 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.it.xlf b/src/fsharp/xlf/FSComp.txt.it.xlf index a7e0a7b48d7..fbc2bc0d82e 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.ja.xlf b/src/fsharp/xlf/FSComp.txt.ja.xlf index 328322d38cc..e45bf51b9d3 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.ko.xlf b/src/fsharp/xlf/FSComp.txt.ko.xlf index 720db8bff68..344e8a6b4b4 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.pl.xlf b/src/fsharp/xlf/FSComp.txt.pl.xlf index ef4db0d67c1..351d9f276a4 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.pt-BR.xlf b/src/fsharp/xlf/FSComp.txt.pt-BR.xlf index 504db8484b2..4f9a3c4f602 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.ru.xlf b/src/fsharp/xlf/FSComp.txt.ru.xlf index 978ab1c59e9..92407e7e2f3 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.tr.xlf b/src/fsharp/xlf/FSComp.txt.tr.xlf index 2e884168dd5..319bd173a45 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.zh-Hans.xlf b/src/fsharp/xlf/FSComp.txt.zh-Hans.xlf index e87d047a133..7bfa21593b2 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. + + {0} for F# {1} {0} for F# {1} diff --git a/src/fsharp/xlf/FSComp.txt.zh-Hant.xlf b/src/fsharp/xlf/FSComp.txt.zh-Hant.xlf index 98ed811142c..1744fa60f9f 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. + + {0} for F# {1} {0} for F# {1} 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..c7d14b63188 --- /dev/null +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs @@ -0,0 +1,931 @@ +// 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 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 + 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) + + +let testShortCircuitResult() = + printfn "Running 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() = + printfn "Running testDelay..." + let mutable x = 0 + let t = + task { + 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() = + printfn "Running 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() = + printfn "Running 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 testCatching1() = + printfn "Running 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" + require false "other exn type" + y <- 1 + } + t.Wait() + require (y = 1) "bailed after exn" + require (x = 0) "ran past failure" + +let testCatching2() = + printfn "Running 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() = + printfn "Running 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() = + printfn "Running 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() = + printfn "Running 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() = + printfn "Running 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() = + printfn "Running 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 B" + + +let testUsingFromTask() = + printfn "Running 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 C" + + +let testUsingSadPath() = + printfn "Running 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 -> + 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 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 + 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() + 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" + 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 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 + 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 A" + +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() = + printfn "running 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() = + printfn "running 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() = + printfn "running 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() = + printfn "running testFixedStackWhileLoop" + let t = + task { + let mutable maxDepth = Nullable() + let mutable i = 0 + while i < BIG 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 = BIG) "didn't get to big number" + +let testFixedStackForLoop() = + printfn "running testFixedStackForLoop" + let mutable ran = false + let t = + task { + let mutable maxDepth = Nullable() + for i in Seq.init BIG 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() = + printfn "running testNoStackOverflowWithImmediateResult" + let longLoop = + task { + let mutable n = 0 + while n < BIG do + n <- n + 1 + return! Task.FromResult(()) + } + longLoop.Wait() + +let testNoStackOverflowWithYieldResult() = + printfn "running testNoStackOverflowWithYieldResult" + let longLoop = + task { + let mutable n = 0 + while n < BIG do + let! _ = + task { + do! Task.Yield() + let! _ = Task.FromResult(0) + n <- n + 1 + } + n <- n + 1 + } + 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 + if n < 1000 then + do! Task.Yield() + let! _ = Task.FromResult(0) + return! loop (n + 1) + else + return () + } + let shortLoop = + task { + return! loop 0 + } + shortLoop.Wait() + +let testTryOverReturnFrom() = + printfn "running 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() = + printfn "running 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() = + printfn "running 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 : 'a Task) (x : 'a) : 'a Task = + task { + let! xResult = iface //.Taskify (Some x) + //do! Task.Yield() + return x //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() + testWhileLoopSync() + 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() + //// 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 "************************************" + 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..." + //System.Console.ReadLine() + 0 + diff --git a/tests/fsharp/core/state-machines/list.fs b/tests/fsharp/core/state-machines/list.fs new file mode 100644 index 00000000000..4ab8bd72d87 --- /dev/null +++ b/tests/fsharp/core/state-machines/list.fs @@ -0,0 +1,198 @@ + +module Tests.ListAndArrayBuilder + +open System +open System.Collections +open System.Collections.Generic +open System.Runtime.CompilerServices +open FSharp.Core.CompilerServices.CodeGenHelpers + +let [] DONE = 3uy + +[] +type ListStep<'T>(res: byte) = + member x.IsDone = (res = DONE) + +[] +type ListStateMachine<'T>() = + let res = ResizeArray<'T>() + + abstract Populate : unit -> ListStep<'T> + + member __.Yield (v: 'T) = res.Add(v) + + [] + member this.StartAsResizeArray() = + this.Populate() |> ignore + res + + [] + member this.StartAsList() = + this.Populate() |> ignore + Seq.toList res + + [] + member this.StartAsArray() = + this.Populate() |> ignore + 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 () + () + 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 () + () + with 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 () + () + with _ -> + compensation() + 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. + 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 + member __.Populate () = __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 __.Populate () = __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 __.Populate () = __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 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 + printfn "yield %A" e.Current + dumpSeq (t1()) + dumpSeq (t2()) diff --git a/tests/fsharp/core/state-machines/seq2.fs b/tests/fsharp/core/state-machines/seq2.fs new file mode 100644 index 00000000000..2dba9522006 --- /dev/null +++ b/tests/fsharp/core/state-machines/seq2.fs @@ -0,0 +1,202 @@ + +module Tests.Seq2 + +#nowarn "42" +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 + + [] + 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/sync.fs b/tests/fsharp/core/state-machines/sync.fs new file mode 100644 index 00000000000..5a87b69b583 --- /dev/null +++ b/tests/fsharp/core/state-machines/sync.fs @@ -0,0 +1,96 @@ + +module Tests.SyncBuilder + +open System +open FSharp.Core.CompilerServices.CodeGenHelpers + +[] +type SyncMachine<'T>() = + + abstract Step : unit -> 'T + + member this.Start() = this.Step() + +type SyncBuilder() = + + [] + member inline __.Delay(__expand_f : unit -> 'T) = __expand_f + + [] + member inline __.Run(__expand_code : unit -> 'T) : 'T = + (__stateMachine + { new SyncMachine<'T>() with + member __.Step () = __jumptable 0 __expand_code }).Start() + + [] + member inline __.Zero() : unit = () + + [] + member inline __.Return (x: 'T) : 'T = x + + [] + member inline __.Combine(``__machine_step$cont``: unit, __expand_step2: unit -> 'T) : 'T = + __expand_step2() + + [] + member inline __.While(__expand_condition : unit -> bool, __expand_body : unit -> unit) : unit = + while __expand_condition() do + __expand_body () + + [] + 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 -> 'T, compensation : unit -> unit) : 'T = + let ``__machine_step$cont`` = + try + __expand_body () + with _ -> + compensation() + reraise() + compensation() + ``__machine_step$cont`` + + [] + 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 -> unit) : unit = + this.Using (sequence.GetEnumerator(), + (fun e -> this.While((fun () -> e.MoveNext()), (fun () -> __expand_body e.Current)))) + + [] + member inline __.ReturnFrom (value: 'T) : 'T = + value + + [] + member inline __.Bind (value: 'TResult1, __expand_continuation: 'TResult1 -> '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..e841b39450d --- /dev/null +++ b/tests/fsharp/core/state-machines/sync.fsi @@ -0,0 +1,33 @@ + +module Tests.SyncBuilder + +open System +open System.Runtime.CompilerServices +open System.Threading.Tasks +open FSharp.Core +open FSharp.Core.CompilerServices +open FSharp.Control +open FSharp.Collections + +[] +type SyncMachine<'T> = + new : unit -> SyncMachine<'T> + abstract Step : unit -> 'T + member Start: unit -> 'T + +type SyncBuilder = + new: unit -> SyncBuilder + 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 new file mode 100644 index 00000000000..6a289c1fd6a --- /dev/null +++ b/tests/fsharp/core/state-machines/taskSeq.fs @@ -0,0 +1,274 @@ + +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 = 1uy +let [] YIELD = 2uy +let [] DONE = 3uy + +[] +type TaskSeqStep<'T>(res: byte) = + member x.IsYield = (res = YIELD) + member x.IsDone = (res = DONE) + +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.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 + + [] + 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<'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 + 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()) diff --git a/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs new file mode 100644 index 00000000000..675ff226111 --- /dev/null +++ b/tests/fsharp/perf/tasks/CS/TaskPerfCSharp.cs @@ -0,0 +1,83 @@ +using System; +using System.Diagnostics; +using System.IO; +using System.Threading.Tasks; + +#pragma warning disable 1998 + +public static class TaskPerfCSharp +{ + public const int BufferSize = 128; + public const int ManyIterations = 10000; + + public static async Task ManyWriteFileAsync() + { + const string path = "tmp"; + var junk = new byte[BufferSize]; + using (var file = File.Create(path)) + { + for (var i = 1; i <= ManyIterations; i++) + { + await file.WriteAsync(junk, 0, junk.Length); + } + } + File.Delete(path); + } + + public static System.Runtime.CompilerServices.YieldAwaitable AsyncTask() + { + return Task.Yield(); + } + + 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() + { + 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() + { + 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 +} + 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/FS/TaskBuilder.fs b/tests/fsharp/perf/tasks/FS/TaskBuilder.fs new file mode 100644 index 00000000000..2adebfd8f41 --- /dev/null +++ b/tests/fsharp/perf/tasks/FS/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 TaskBuilderTasks +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/FS/TaskPerf.fs b/tests/fsharp/perf/tasks/FS/TaskPerf.fs new file mode 100644 index 00000000000..cb3cd16c212 --- /dev/null +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fs @@ -0,0 +1,283 @@ +(* +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 +open TaskBuilderTasks.ContextSensitive // TaskBuilder.fs extension members +open FSharp.Control.ContextSensitiveTasks // the default +open Tests.SyncBuilder + +[] +module Helpers = + let bufferSize = 128 + let manyIterations = 10000 + + let syncTask() = Task.FromResult 100 + let syncTask_FSharpAsync() = async.Return 100 + let asyncTask() = Task.Yield() + + let taskBuilder = TaskBuilderTasks.ContextSensitive.task + + let tenBindSync_Task() = + 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 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() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + do! asyncTask() + } + + 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 } + +[] +type ManyWriteFile() = + [] + 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) + +[] +type NonAsyncBinds() = + [] + member __.NonAsyncBinds_CSharpAsync() = + for i in 1 .. manyIterations*100 do + TaskPerfCSharp.TenBindsSync_CSharp().Wait() + + [] + member __.NonAsyncBinds_Task() = + for i in 1 .. manyIterations*100 do + tenBindSync_Task().Wait() + + [] + member __.NonAsyncBinds_TaskBuilder() = + for i in 1 .. manyIterations*100 do + tenBindSync_TaskBuilder().Wait() + + [] + member __.NonAsyncBinds_FSharpAsync() = + 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() + + [] + 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 + +[] +type SingleSyncTask() = + [] + member __.SingleSyncTask_CSharpAsync() = + for i in 1 .. manyIterations*500 do + TaskPerfCSharp.SingleSyncTask_CSharp().Wait() + + [] + member __.SingleSyncTask_Task() = + for i in 1 .. manyIterations*500 do + singleTask_Task().Wait() + + [] + member __.SingleSyncTask_TaskBuilder() = + for i in 1 .. manyIterations*500 do + singleTask_TaskBuilder().Wait() + + [] + member __.SingleSyncTask_FSharpAsync() = + 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 = + + [] + let main argv = + printfn "Testing that the tests run..." + ManyWriteFile().ManyWriteFile_CSharpAsync() + ManyWriteFile().ManyWriteFile_Task () + ManyWriteFile().ManyWriteFile_TaskBuilder () + ManyWriteFile().ManyWriteFile_FSharpAsync () + NonAsyncBinds().NonAsyncBinds_CSharpAsync() + NonAsyncBinds().NonAsyncBinds_Task() + NonAsyncBinds().NonAsyncBinds_TaskBuilder() + NonAsyncBinds().NonAsyncBinds_FSharpAsync() + AsyncBinds().AsyncBinds_CSharpAsync() + AsyncBinds().AsyncBinds_Task() + AsyncBinds().AsyncBinds_TaskBuilder() + SingleSyncTask().SingleSyncTask_CSharpAsync() + SingleSyncTask().SingleSyncTask_Task() + SingleSyncTask().SingleSyncTask_TaskBuilder() + SingleSyncTask().SingleSyncTask_FSharpAsync() + printfn "Running becnhmarks..." + + //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 + 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 new file mode 100644 index 00000000000..3a3c24f5368 --- /dev/null +++ b/tests/fsharp/perf/tasks/FS/TaskPerf.fsproj @@ -0,0 +1,21 @@ + + + + netcoreapp2.1 + Exe + + + + + + + + + + + + + + + +