diff --git a/.gitignore b/.gitignore index 202a7991e0..335799f287 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,62 @@ +/packages +/Tools +/src/*.userprefs +/src/fsharp/FSStrings.resources +/src/fsharp/FSharp.Build/*.resx +/src/fsharp/FSharp.Build-proto/*.resx +/src/fsharp/FSharp.Build-proto/*.resources +/src/fsharp/FSharp.Compiler-proto/*.resx +/src/fsharp/FSharp.Compiler-proto/*.resources +/src/fsharp/FSharp.Compiler-proto/*.sln +/src/fsharp/FSharp.Compiler-proto/*.userprefs +/src/fsharp/fsi/*.resx +/src/fsharp/FSharp.Compiler.Interactive.Settings/*.resx +/src/fsharp/FSharp.Compiler.Server.Shared/*.resx +/src/fsharp/fsi/Fsi.sln +/src/fsharp/FSharp.Build/*.resources +/src/fsharp/FSharp.Compiler/*.resx +/src/fsharp/FSharp.Compiler/*.resources +/src/fsharp/FSharp.Compiler/*.sln +/src/fsharp/FSharp.Compiler/*.userprefs +/src/*.log +/src/fsharp/FSharp.Compiler/illex.fs +/src/fsharp/FSharp.Compiler/ilpars.fs +/src/fsharp/FSharp.Compiler/ilpars.fsi +/src/fsharp/FSharp.Compiler/lex.fs +/src/fsharp/FSharp.Compiler/pars.fs +/src/fsharp/FSharp.Compiler/pars.fsi +/src/fsharp/FSharp.Compiler/pplex.fs +/src/fsharp/FSharp.Compiler/pppars.fs +/src/fsharp/FSharp.Compiler/pppars.fsi +/src/fsharp/FSharp.Compiler-proto/illex.fs +/src/fsharp/FSharp.Compiler-proto/ilpars.fs +/src/fsharp/FSharp.Compiler-proto/ilpars.fsi +/src/fsharp/FSharp.Compiler-proto/lex.fs +/src/fsharp/FSharp.Compiler-proto/pars.fs +/src/fsharp/FSharp.Compiler-proto/pars.fsi +/src/fsharp/FSharp.Compiler-proto/pplex.fs +/src/fsharp/FSharp.Compiler-proto/pppars.fs +/src/fsharp/FSharp.Compiler-proto/pppars.fsi +/src/fsharp/FSharp.LanguageService.Compiler/illex.* +/src/fsharp/FSharp.LanguageService.Compiler/ilpars.* +/src/fsharp/FSharp.LanguageService.Compiler/lex.* +/src/fsharp/FSharp.LanguageService.Compiler/pars.* +/src/fsharp/FSharp.LanguageService.Compiler/pplex.fs +/src/fsharp/FSharp.LanguageService.Compiler/pppars.fs +/src/fsharp/FSharp.LanguageService.Compiler/pppars.fsi +/vsintegration/src/unittests/Unittests.fsi +/tests/*FSharp_Failures.env +/tests/*FSharp_Failures.lst +/tests/fsharpqa/Source/CodeGen/EmittedIL/StaticInit/StaticInit_Module01.dll +/tests/fsharpqa/Source/CodeGen/EmittedIL/StaticInit/StaticInit_Module01.pdb +/tests/XFSharpQA_Failures.log.* +/vsintegration/src/vs/FsPkgs/FSharp.Project/FS/FSharp.ProjectSystem.FSharp.fsi +/vsintegration/src/vs/FsPkgs/FSharp.Project/FS/ctofiles/ +/tests/fsharpqa/Source/CodeGen/EmittedIL/QueryExpressionStepping/Utils.dll +/tests/fsharpqa/Source/CodeGen/EmittedIL/ComputationExpressions/ComputationExprLibrary.dll +/tests/fsharpqa/Source/*FSharpQA_Failures.env +/tests/fsharpqa/Source/*FSharpQA_Failures.lst +/tests/**/FSharp.Core.dll lib/debug lib/release lib/proto @@ -28,8 +87,6 @@ src/fsharp/FSharp.Compiler/*.sln src/fsharp/FSharp.Compiler/*.userprefs Debug Release -vsdebug -vsrelease Proto sign_temp .libs @@ -63,8 +120,6 @@ src/fsharp/FSharp.Compiler-proto/pppars.fs src/fsharp/FSharp.Compiler-proto/pppars.fsi *~ -tests/projects/Sample_VS2012_FSharp_ConsoleApp_net45_with_resource/Sample_VS2012_FSharp_ConsoleApp_net45/Sample_VS2012_FSharp_ConsoleApp_net45.sln -tests/projects/Sample_VS2012_FSharp_ConsoleApp_net45_with_resource/Sample_VS2012_FSharp_ConsoleApp_net45/Sample_VS2012_FSharp_ConsoleApp_net45.userprefs *.suo obj src/fsharp/FSharp.Data.TypeProviders/FSData.resx @@ -134,7 +189,7 @@ src/fsharp/FSharp.Compiler.Service/pppars.fs src/fsharp/FSharp.Compiler.Service/pppars.fsi .fake *.cto -tests/**/FSharp.Core.dll +*.vstman project.lock.json src/fsharp/FSharp.Compiler.Service.netcore/FSComp.fs @@ -150,3 +205,5 @@ src/fsharp/FSharp.Compiler.Service.netcore/pars.fsi src/fsharp/FSharp.Compiler.Service.netcore/pplex.fs src/fsharp/FSharp.Compiler.Service.netcore/pppars.fs src/fsharp/FSharp.Compiler.Service.netcore/pppars.fsi +Tools/ +Backup/ diff --git a/RELEASE_NOTES.md b/RELEASE_NOTES.md index d44ba77532..748ba5fa33 100644 --- a/RELEASE_NOTES.md +++ b/RELEASE_NOTES.md @@ -1,3 +1,13 @@ +#### 5.0.0 +* Fixed empty symbol declared pdb #564 from kekyo/fix-empty-pdb +* .NET Core ProjectCracker - updated version and dependencies +* Properly embed 'FSIstrings' resource, fixes #591 +* make build.sh work on windows (git bash). +* Added default script references for .NET Core +* Store useMonoResolution flag +* Updated MSBuild version +* Assume FSharp.Core 4.4.0.0 + #### 4.0.1 * Integrate Microsoft\visualfsharp and fsharp\fsharp to master (including portable PDB) * Remove .NET Framework 4.0 support (now needs .NET Framework 4.5) diff --git a/build.fsx b/build.fsx index 91f3ffcc14..0b4b7d4013 100644 --- a/build.fsx +++ b/build.fsx @@ -80,7 +80,7 @@ Target "GenerateFSIStrings" (fun _ -> let dir = __SOURCE_DIRECTORY__ "src/fsharp/fsi" p.Arguments <- "FSIstrings.txt FSIstrings.fs FSIstrings.resx" p.WorkingDirectory <- dir - p.FileName <- !! "lib/bootstrap/4.0/fssrgen.exe" |> Seq.head ) TimeSpan.MaxValue + p.FileName <- !! "packages/FsSrGen/lib/net46/fssrgen.exe" |> Seq.head ) TimeSpan.MaxValue |> ignore ) diff --git a/lib/bootstrap/4.0/FSharp.SRGen.Build.Tasks.dll b/lib/bootstrap/4.0/FSharp.SRGen.Build.Tasks.dll deleted file mode 100755 index 52e485d4e5..0000000000 Binary files a/lib/bootstrap/4.0/FSharp.SRGen.Build.Tasks.dll and /dev/null differ diff --git a/lib/bootstrap/4.0/FSharp.SRGen.Build.Tasks.dll.config b/lib/bootstrap/4.0/FSharp.SRGen.Build.Tasks.dll.config deleted file mode 100644 index 96cd6e85a5..0000000000 --- a/lib/bootstrap/4.0/FSharp.SRGen.Build.Tasks.dll.config +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/lib/bootstrap/4.0/FSharp.SRGen.targets b/lib/bootstrap/4.0/FSharp.SRGen.targets deleted file mode 100644 index 0a85b1854d..0000000000 --- a/lib/bootstrap/4.0/FSharp.SRGen.targets +++ /dev/null @@ -1,73 +0,0 @@ - - - - - - - ProcessFsSrGen;$(PrepareForBuildDependsOn) - - - ProcessFsSrGen;$(BuildDependsOn) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - false - - - diff --git a/lib/bootstrap/4.0/fslex.exe b/lib/bootstrap/4.0/fslex.exe old mode 100755 new mode 100644 diff --git a/lib/bootstrap/4.0/fssrgen.exe b/lib/bootstrap/4.0/fssrgen.exe deleted file mode 100755 index 1d9c713dae..0000000000 Binary files a/lib/bootstrap/4.0/fssrgen.exe and /dev/null differ diff --git a/lib/bootstrap/4.0/fssrgen.exe.config b/lib/bootstrap/4.0/fssrgen.exe.config deleted file mode 100644 index 8a9f70e2b6..0000000000 --- a/lib/bootstrap/4.0/fssrgen.exe.config +++ /dev/null @@ -1,26 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/lib/bootstrap/4.0/fsyacc.exe b/lib/bootstrap/4.0/fsyacc.exe old mode 100755 new mode 100644 diff --git a/paket.dependencies b/paket.dependencies index 0ecb8bd2b9..fcbd8f39de 100644 --- a/paket.dependencies +++ b/paket.dependencies @@ -13,9 +13,9 @@ nuget SourceLink.Fake nuget fssrgen nuget FSharp.SRGen.Build.Tasks -nuget System.Collections.Immutable 1.2.0-rc3-23805 -nuget System.Reflection.Metadata 1.3.0-beta-23816 -nuget Microsoft.DiaSymReader.PortablePdb 1.0.0-rc-60301 -nuget Microsoft.DiaSymReader 1.0.7 +nuget System.Collections.Immutable 1.2.0 +nuget System.Reflection.Metadata 1.4.1-beta-24227-04 +nuget Microsoft.DiaSymReader.PortablePdb 1.1.0 +nuget Microsoft.DiaSymReader 1.0.8 github fsharp/FAKE modules/Octokit/Octokit.fsx \ No newline at end of file diff --git a/paket.lock b/paket.lock index d538b12511..4091acd3c4 100644 --- a/paket.lock +++ b/paket.lock @@ -1,10 +1,9 @@ NUGET remote: https://www.nuget.org/api/v2 - specs: - FAKE (4.25.4) + FAKE (4.29.2) FSharp.Compiler.Service (2.0.0.6) FSharp.Core (4.0.0.1) - framework: >= net46 - FSharp.Formatting (2.14.2) + FSharp.Formatting (2.14.4) FSharp.Compiler.Service (2.0.0.6) FSharpVSPowerTools.Core (>= 2.3 < 2.4) FSharp.SRGen.Build.Tasks (3.0) @@ -16,17 +15,36 @@ NUGET Microsoft.Bcl (1.1.10) - framework: net10, net11, net20, net30, net35, net40, net40-full Microsoft.Bcl.Build (>= 1.0.14) Microsoft.Bcl.Build (1.0.21) - import_targets: false, framework: net10, net11, net20, net30, net35, net40, net40-full - Microsoft.DiaSymReader (1.0.7) - Microsoft.DiaSymReader.PortablePdb (1.0.0-rc-60301) - Microsoft.DiaSymReader (>= 1.0.7) - System.Collections.Immutable (>= 1.1.37) - System.Reflection.Metadata (>= 1.2.0-rc2-23826) + Microsoft.DiaSymReader (1.0.8) + System.Diagnostics.Debug (>= 4.0.11) - framework: >= netstandard11 + System.Runtime (>= 4.1) - framework: >= netstandard11 + System.Runtime.InteropServices (>= 4.1) - framework: >= netstandard11 + Microsoft.DiaSymReader.PortablePdb (1.1) + Microsoft.DiaSymReader (>= 1.0.7) - framework: portable-net45+win8 + Microsoft.DiaSymReader (>= 1.0.8) - framework: >= netstandard11 + System.Collections (>= 4.0.11) - framework: >= netstandard11 + System.Collections.Immutable (>= 1.1.37) - framework: portable-net45+win8 + System.Collections.Immutable (>= 1.2) - framework: >= netstandard11 + System.Diagnostics.Debug (>= 4.0.11) - framework: >= netstandard11 + System.Globalization (>= 4.0) - framework: >= netstandard11 + System.IO (>= 4.1) - framework: >= netstandard11 + System.Linq (>= 4.1) - framework: >= netstandard11 + System.Reflection (>= 4.1) - framework: >= netstandard11 + System.Reflection.Metadata (>= 1.2) - framework: portable-net45+win8 + System.Reflection.Metadata (>= 1.3) - framework: >= netstandard11 + System.Reflection.Primitives (>= 4.0.1) - framework: >= netstandard11 + System.Runtime (>= 4.1) - framework: >= netstandard11 + System.Runtime.Extensions (>= 4.1) - framework: >= netstandard11 + System.Runtime.InteropServices (>= 4.1) - framework: >= netstandard11 + System.Text.Encoding (>= 4.0.11) - framework: >= netstandard11 + System.Threading (>= 4.0.11) - framework: >= netstandard11 + System.Xml.XDocument (>= 4.0.11) - framework: >= netstandard11 Microsoft.Net.Http (2.2.29) - framework: net10, net11, net20, net30, net35, net40, net40-full Microsoft.Bcl (>= 1.1.10) Microsoft.Bcl.Build (>= 1.0.14) NUnit (2.6.3) NUnit.Runners (2.6.3) - Octokit (0.19) + Octokit (0.20) Microsoft.Net.Http - framework: net10, net11, net20, net30, net35, net40, net40-full SourceLink.Fake (1.1) SQLite.Net.Platform.Generic (2.4.1) @@ -34,118 +52,170 @@ NUGET SQLite.Net-PCL (3.0.5) sqlite-net-wp8 (>= 3.8.5) - framework: wpv8.0 sqlite-net-wp8 (3.8.5) - framework: wpv8.0 + System.Collections.Immutable (1.2) + System.Collections (>= 4.0.11) - framework: >= netstandard10 + System.Diagnostics.Debug (>= 4.0.11) - framework: >= netstandard10 + System.Globalization (>= 4.0.11) - framework: >= netstandard10 + System.Linq (>= 4.1) - framework: >= netstandard10 + System.Resources.ResourceManager (>= 4.0.1) - framework: >= netstandard10 + System.Runtime (>= 4.1) - framework: >= netstandard10 + System.Runtime.Extensions (>= 4.1) - framework: >= netstandard10 + System.Threading (>= 4.0.11) - framework: >= netstandard10 remote: https://www.myget.org/F/dotnet-core - specs: - System.Collections (4.0.10) - framework: dnxcore50 - System.Diagnostics.Debug (>= 4.0) - framework: dnxcore50 - System.Resources.ResourceManager (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0.20) - framework: dnxcore50 - System.Runtime.Extensions (>= 4.0) - framework: dnxcore50 - System.Threading (>= 4.0) - framework: dnxcore50 - System.Collections.Immutable (1.2.0-rc3-23805) - System.Collections (>= 4.0) - framework: dnxcore50 - System.Diagnostics.Debug (>= 4.0) - framework: dnxcore50 - System.Globalization (>= 4.0) - framework: dnxcore50 - System.Linq (>= 4.0) - framework: dnxcore50 - System.Resources.ResourceManager (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Runtime.Extensions (>= 4.0) - framework: dnxcore50 - System.Threading (>= 4.0) - framework: dnxcore50 - System.Diagnostics.Contracts (4.0.0) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Diagnostics.Debug (4.0.10) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Globalization (4.0.10) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.IO (4.0.10) - framework: dnxcore50 - System.Globalization (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0.20) - framework: dnxcore50 - System.Text.Encoding (>= 4.0) - framework: dnxcore50 - System.Text.Encoding (>= 4.0.10) - framework: dnxcore50 - System.Text.Encoding.Extensions (>= 4.0) - framework: dnxcore50 - System.Threading (>= 4.0) - framework: dnxcore50 - System.Threading.Tasks (>= 4.0) - framework: dnxcore50 - System.Linq (4.0.0) - framework: dnxcore50 - System.Collections (>= 4.0.10) - framework: dnxcore50 - System.Diagnostics.Debug (>= 4.0.10) - framework: dnxcore50 - System.Resources.ResourceManager (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0.20) - framework: dnxcore50 - System.Runtime.Extensions (>= 4.0.10) - framework: dnxcore50 - System.Private.Uri (4.0.0) - framework: dnxcore50 - System.Reflection (4.0.10) - framework: dnxcore50 - System.IO (>= 4.0) - framework: dnxcore50 - System.Reflection.Primitives (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0.20) - framework: dnxcore50 - System.Reflection.Extensions (4.0.0) - framework: dnxcore50 - System.Diagnostics.Debug (>= 4.0.10) - framework: dnxcore50 - System.Reflection (>= 4.0) - framework: dnxcore50 - System.Reflection (>= 4.0.10) - framework: dnxcore50 - System.Reflection.Primitives (>= 4.0) - framework: dnxcore50 - System.Reflection.TypeExtensions (>= 4.0) - framework: dnxcore50 - System.Resources.ResourceManager (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0.20) - framework: dnxcore50 - System.Runtime.Extensions (>= 4.0.10) - framework: dnxcore50 - System.Reflection.Metadata (1.3.0-beta-23816) - System.Collections (>= 4.0) - framework: dnxcore50 - System.Collections.Immutable (>= 1.1.37) - framework: >= net45, dnxcore50, monoandroid, monotouch, portable-profile7, xamarinios, xamarinmac, winv4.5, wpav8.1 - System.Diagnostics.Debug (>= 4.0) - framework: dnxcore50 - System.IO (>= 4.0) - framework: dnxcore50 - System.Linq (>= 4.0) - framework: dnxcore50 - System.Reflection (>= 4.0) - framework: dnxcore50 - System.Reflection.Extensions (>= 4.0) - framework: dnxcore50 - System.Reflection.Primitives (>= 4.0) - framework: dnxcore50 - System.Resources.ResourceManager (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Runtime.Extensions (>= 4.0) - framework: dnxcore50 - System.Runtime.InteropServices (>= 4.0) - framework: dnxcore50 - System.Text.Encoding (>= 4.0) - framework: dnxcore50 - System.Text.Encoding.Extensions (>= 4.0) - framework: dnxcore50 - System.Threading (>= 4.0) - framework: dnxcore50 - System.Reflection.Primitives (4.0.0) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Threading (>= 4.0) - framework: dnxcore50 - System.Reflection.TypeExtensions (4.0.0) - framework: dnxcore50 - System.Diagnostics.Contracts (>= 4.0) - framework: dnxcore50 - System.Diagnostics.Debug (>= 4.0.10) - framework: dnxcore50 - System.Linq (>= 4.0) - framework: dnxcore50 - System.Reflection (>= 4.0) - framework: dnxcore50 - System.Reflection (>= 4.0.10) - framework: dnxcore50 - System.Reflection.Primitives (>= 4.0) - framework: dnxcore50 - System.Resources.ResourceManager (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0.20) - framework: dnxcore50 - System.Runtime.Extensions (>= 4.0.10) - framework: dnxcore50 - System.Resources.ResourceManager (4.0.0) - framework: dnxcore50 - System.Globalization (>= 4.0) - framework: dnxcore50 - System.Reflection (>= 4.0) - framework: dnxcore50 - System.Reflection (>= 4.0.10) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0.20) - framework: dnxcore50 - System.Runtime (4.0.20) - framework: dnxcore50 - System.Private.Uri (>= 4.0) - framework: dnxcore50 - System.Runtime.Extensions (4.0.10) - framework: dnxcore50 - System.Runtime (>= 4.0.20) - framework: dnxcore50 - System.Runtime.Handles (4.0.0) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Runtime.InteropServices (4.0.20) - framework: dnxcore50 - System.Reflection (>= 4.0) - framework: dnxcore50 - System.Reflection.Primitives (>= 4.0) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Runtime.Handles (>= 4.0) - framework: dnxcore50 - System.Text.Encoding (4.0.10) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Text.Encoding.Extensions (4.0.10) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Text.Encoding (>= 4.0.10) - framework: dnxcore50 - System.Threading (4.0.10) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 - System.Threading.Tasks (>= 4.0) - framework: dnxcore50 - System.Threading.Tasks (4.0.10) - framework: dnxcore50 - System.Runtime (>= 4.0) - framework: dnxcore50 + Microsoft.NETCore.Platforms (1.0.1) - framework: >= netstandard10 + Microsoft.NETCore.Targets (1.0.1) - framework: >= netstandard10 + System.Collections (4.0.11) - framework: >= netstandard10 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Diagnostics.Debug (4.0.11) - framework: >= netstandard10 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Diagnostics.Tools (4.0.1) - framework: >= netstandard13 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, >= netstandard10 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, >= netstandard10 + System.Runtime (>= 4.1) - framework: dnxcore50, >= netstandard10 + System.Globalization (4.0.11) - framework: >= netstandard10 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.IO (4.1.0) - framework: >= netstandard10 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.Text.Encoding (>= 4.0.11) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.Threading.Tasks (>= 4.0.11) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.IO.FileSystem (4.0.1) - framework: >= netstandard13 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: >= netstandard13 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: >= netstandard13 + System.IO (>= 4.1) - framework: >= netstandard13 + System.IO.FileSystem.Primitives (>= 4.0.1) - framework: >= net46, >= netstandard13 + System.Runtime (>= 4.1) - framework: >= netstandard13 + System.Runtime.Handles (>= 4.0.1) - framework: >= netstandard13 + System.Text.Encoding (>= 4.0.11) - framework: >= netstandard13 + System.Threading.Tasks (>= 4.0.11) - framework: >= netstandard13 + System.IO.FileSystem.Primitives (4.0.1) - framework: >= netstandard13 + System.Runtime (>= 4.1) - framework: >= netstandard13 + System.Linq (4.1.0) - framework: >= netstandard10 + System.Collections (>= 4.0.11) - framework: dnxcore50, netstandard10, >= netstandard15 + System.Diagnostics.Debug (>= 4.0.11) - framework: dnxcore50, >= netstandard15 + System.Resources.ResourceManager (>= 4.0.1) - framework: dnxcore50, >= netstandard15 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard15 + System.Runtime.Extensions (>= 4.1) - framework: dnxcore50, >= netstandard15 + System.Reflection (4.1.0) - framework: >= netstandard10 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.IO (>= 4.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.Reflection.Primitives (>= 4.0.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.Reflection.Extensions (4.0.1) - framework: >= netstandard11 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, >= netstandard10 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, >= netstandard10 + System.Reflection (>= 4.1) - framework: dnxcore50, >= netstandard10 + System.Runtime (>= 4.1) - framework: dnxcore50, >= netstandard10 + System.Reflection.Metadata (1.4.1-beta-24227-04) + System.Collections (>= 4.0.11) - framework: >= netstandard11 + System.Collections.Immutable (>= 1.1.37) - framework: portable-net45+win8 + System.Collections.Immutable (>= 1.2) - framework: >= net45, >= netstandard11, monoandroid, monotouch, xamarinios, xamarinmac, winv4.5, wpav8.1 + System.Diagnostics.Debug (>= 4.0.11) - framework: >= netstandard11 + System.IO (>= 4.1) - framework: >= netstandard11 + System.Linq (>= 4.1) - framework: >= netstandard11 + System.Reflection (>= 4.1) - framework: >= netstandard11 + System.Reflection.Extensions (>= 4.0.1) - framework: >= netstandard11 + System.Reflection.Primitives (>= 4.0.1) - framework: >= netstandard11 + System.Resources.ResourceManager (>= 4.0.1) - framework: >= netstandard11 + System.Runtime (>= 4.1) - framework: >= netstandard11 + System.Runtime.Extensions (>= 4.1) - framework: >= netstandard11 + System.Runtime.InteropServices (>= 4.1) - framework: >= netstandard11 + System.Text.Encoding (>= 4.0.11) - framework: >= netstandard11 + System.Text.Encoding.Extensions (>= 4.0.11) - framework: >= netstandard11 + System.Threading (>= 4.0.11) - framework: >= netstandard11 + System.Reflection.Primitives (4.0.1) - framework: >= netstandard10 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, >= netstandard10 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, >= netstandard10 + System.Runtime (>= 4.1) - framework: dnxcore50, >= netstandard10 + System.Resources.ResourceManager (4.0.1) - framework: >= netstandard10 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, >= netstandard10 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, >= netstandard10 + System.Globalization (>= 4.0.11) - framework: dnxcore50, >= netstandard10 + System.Reflection (>= 4.1) - framework: dnxcore50, >= netstandard10 + System.Runtime (>= 4.1) - framework: dnxcore50, >= netstandard10 + System.Runtime (4.1.0) - framework: >= netstandard10 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard10, netstandard12, netstandard13, >= netstandard15 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard10, netstandard12, netstandard13, >= netstandard15 + System.Runtime.Extensions (4.1.0) - framework: >= netstandard10 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.Runtime.Handles (4.0.1) - framework: >= netstandard13 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: >= netstandard13 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: >= netstandard13 + System.Runtime (>= 4.1) - framework: >= netstandard13 + System.Runtime.InteropServices (4.1.0) - framework: >= netstandard11 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard11, netstandard12, netstandard13, >= netstandard15 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard11, netstandard12, netstandard13, >= netstandard15 + System.Reflection (>= 4.1) - framework: dnxcore50, netstandard11, netstandard12, netstandard13, >= netstandard15 + System.Reflection.Primitives (>= 4.0.1) - framework: dnxcore50, netstandard11, netstandard12, netstandard13, >= netstandard15 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard11, netstandard12, netstandard13, >= netstandard15 + System.Runtime.Handles (>= 4.0.1) - framework: dnxcore50, netstandard13, >= netstandard15 + System.Text.Encoding (4.0.11) - framework: >= netstandard10 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Text.Encoding.Extensions (4.0.11) - framework: >= netstandard11 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Text.Encoding (>= 4.0.11) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Text.RegularExpressions (4.1.0) - framework: >= netstandard13 + System.Collections (>= 4.0.11) - framework: dnxcore50, >= netstandard15 + System.Globalization (>= 4.0.11) - framework: dnxcore50, >= netstandard15 + System.Resources.ResourceManager (>= 4.0.1) - framework: dnxcore50, >= netstandard15 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, netstandard13, >= netstandard15 + System.Runtime.Extensions (>= 4.1) - framework: dnxcore50, >= netstandard15 + System.Threading (>= 4.0.11) - framework: dnxcore50, >= netstandard15 + System.Threading (4.0.11) - framework: >= netstandard10 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Threading.Tasks (>= 4.0.11) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Threading.Tasks (4.0.11) - framework: netstandard10, >= netstandard13 + Microsoft.NETCore.Platforms (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + Microsoft.NETCore.Targets (>= 1.0.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Threading.Tasks.Extensions (4.0.0) - framework: >= netstandard13 + System.Collections (>= 4.0.11) - framework: >= netstandard10 + System.Runtime (>= 4.1) - framework: >= netstandard10 + System.Threading.Tasks (>= 4.0.11) - framework: >= netstandard10 + System.Xml.ReaderWriter (4.0.11) - framework: >= netstandard13 + System.Collections (>= 4.0.11) - framework: dnxcore50, >= netstandard13 + System.Diagnostics.Debug (>= 4.0.11) - framework: dnxcore50, >= netstandard13 + System.Globalization (>= 4.0.11) - framework: dnxcore50, >= netstandard13 + System.IO (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.IO.FileSystem (>= 4.0.1) - framework: dnxcore50, >= netstandard13 + System.IO.FileSystem.Primitives (>= 4.0.1) - framework: dnxcore50, >= netstandard13 + System.Resources.ResourceManager (>= 4.0.1) - framework: dnxcore50, >= netstandard13 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Runtime.Extensions (>= 4.1) - framework: dnxcore50, >= netstandard13 + System.Runtime.InteropServices (>= 4.1) - framework: dnxcore50, >= netstandard13 + System.Text.Encoding (>= 4.0.11) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Text.Encoding.Extensions (>= 4.0.11) - framework: dnxcore50, >= netstandard13 + System.Text.RegularExpressions (>= 4.1) - framework: dnxcore50, >= netstandard13 + System.Threading.Tasks (>= 4.0.11) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Threading.Tasks.Extensions (>= 4.0) - framework: dnxcore50, >= netstandard13 + System.Xml.XDocument (4.0.11) - framework: >= netstandard11 + System.Collections (>= 4.0.11) - framework: dnxcore50, >= netstandard13 + System.Diagnostics.Debug (>= 4.0.11) - framework: dnxcore50, >= netstandard13 + System.Diagnostics.Tools (>= 4.0.1) - framework: dnxcore50, >= netstandard13 + System.Globalization (>= 4.0.11) - framework: dnxcore50, >= netstandard13 + System.IO (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Reflection (>= 4.1) - framework: dnxcore50, >= netstandard13 + System.Resources.ResourceManager (>= 4.0.1) - framework: dnxcore50, >= netstandard13 + System.Runtime (>= 4.1) - framework: dnxcore50, netstandard10, >= netstandard13 + System.Runtime.Extensions (>= 4.1) - framework: dnxcore50, >= netstandard13 + System.Text.Encoding (>= 4.0.11) - framework: dnxcore50, >= netstandard13 + System.Threading (>= 4.0.11) - framework: dnxcore50, >= netstandard13 + System.Xml.ReaderWriter (>= 4.0.11) - framework: dnxcore50, netstandard10, >= netstandard13 GITHUB remote: fsharp/FAKE - specs: - modules/Octokit/Octokit.fsx (3bf706bd6058733a1a034755741076b3953aaf09) - Octokit \ No newline at end of file + modules/Octokit/Octokit.fsx (c56456abac6b744c3bb95b217687db19fd19b367) + Octokit (>= 0.20) \ No newline at end of file diff --git a/src/absil/bytes.fs b/src/absil/bytes.fs index 87ea6c0c3c..380d5f4f93 100755 --- a/src/absil/bytes.fs +++ b/src/absil/bytes.fs @@ -33,26 +33,26 @@ module internal Bytes = Array.append (System.Text.Encoding.Unicode.GetBytes s) (ofInt32Array [| 0x0;0x0 |]) type internal ByteStream = - { bytes: byte[]; - mutable pos: int; + { bytes: byte[] + mutable pos: int max: int } member b.ReadByte() = - if b.pos >= b.max then failwith "end of stream"; + if b.pos >= b.max then failwith "end of stream" let res = b.bytes.[b.pos] - b.pos <- b.pos + 1; + b.pos <- b.pos + 1 res member b.ReadUtf8String n = let res = System.Text.Encoding.UTF8.GetString(b.bytes,b.pos,n) b.pos <- b.pos + n; res static member FromBytes (b:byte[],n,len) = - if n < 0 || (n+len) > b.Length then failwith "FromBytes"; + if n < 0 || (n+len) > b.Length then failwith "FromBytes" { bytes = b; pos = n; max = n+len } member b.ReadBytes n = - if b.pos + n > b.max then failwith "ReadBytes: end of stream"; + if b.pos + n > b.max then failwith "ReadBytes: end of stream" let res = Bytes.sub b.bytes b.pos n - b.pos <- b.pos + n; + b.pos <- b.pos + n res member b.Position = b.pos @@ -63,21 +63,21 @@ type internal ByteStream = type internal ByteBuffer = - { mutable bbArray: byte[]; + { mutable bbArray: byte[] mutable bbCurrent: int } member buf.Ensure newSize = let oldBufSize = buf.bbArray.Length if newSize > oldBufSize then let old = buf.bbArray - buf.bbArray <- Bytes.zeroCreate (max newSize (oldBufSize * 2)); - Bytes.blit old 0 buf.bbArray 0 buf.bbCurrent; + buf.bbArray <- Bytes.zeroCreate (max newSize (oldBufSize * 2)) + Bytes.blit old 0 buf.bbArray 0 buf.bbCurrent member buf.Close () = Bytes.sub buf.bbArray 0 buf.bbCurrent member buf.EmitIntAsByte (i:int) = let newSize = buf.bbCurrent + 1 - buf.Ensure newSize; + buf.Ensure newSize buf.bbArray.[buf.bbCurrent] <- byte i buf.bbCurrent <- newSize @@ -86,7 +86,7 @@ type internal ByteBuffer = member buf.EmitIntsAsBytes (arr:int[]) = let n = arr.Length let newSize = buf.bbCurrent + n - buf.Ensure newSize; + buf.Ensure newSize let bbarr = buf.bbArray let bbbase = buf.bbCurrent for i = 0 to n - 1 do @@ -94,29 +94,29 @@ type internal ByteBuffer = buf.bbCurrent <- newSize member bb.FixupInt32 pos n = - bb.bbArray.[pos] <- (Bytes.b0 n |> byte); - bb.bbArray.[pos + 1] <- (Bytes.b1 n |> byte); - bb.bbArray.[pos + 2] <- (Bytes.b2 n |> byte); - bb.bbArray.[pos + 3] <- (Bytes.b3 n |> byte); + bb.bbArray.[pos] <- (Bytes.b0 n |> byte) + bb.bbArray.[pos + 1] <- (Bytes.b1 n |> byte) + bb.bbArray.[pos + 2] <- (Bytes.b2 n |> byte) + bb.bbArray.[pos + 3] <- (Bytes.b3 n |> byte) member buf.EmitInt32 n = let newSize = buf.bbCurrent + 4 - buf.Ensure newSize; - buf.FixupInt32 buf.bbCurrent n; + buf.Ensure newSize + buf.FixupInt32 buf.bbCurrent n buf.bbCurrent <- newSize member buf.EmitBytes (i:byte[]) = let n = i.Length let newSize = buf.bbCurrent + n - buf.Ensure newSize; - Bytes.blit i 0 buf.bbArray buf.bbCurrent n; + buf.Ensure newSize + Bytes.blit i 0 buf.bbArray buf.bbCurrent n buf.bbCurrent <- newSize member buf.EmitInt32AsUInt16 n = let newSize = buf.bbCurrent + 2 - buf.Ensure newSize; - buf.bbArray.[buf.bbCurrent] <- (Bytes.b0 n |> byte); - buf.bbArray.[buf.bbCurrent + 1] <- (Bytes.b1 n |> byte); + buf.Ensure newSize + buf.bbArray.[buf.bbCurrent] <- (Bytes.b0 n |> byte) + buf.bbArray.[buf.bbCurrent + 1] <- (Bytes.b1 n |> byte) buf.bbCurrent <- newSize member buf.EmitBoolAsByte (b:bool) = buf.EmitIntAsByte (if b then 1 else 0) @@ -124,13 +124,13 @@ type internal ByteBuffer = member buf.EmitUInt16 (x:uint16) = buf.EmitInt32AsUInt16 (int32 x) member buf.EmitInt64 x = - buf.EmitInt32 (Bytes.dWw0 x); + buf.EmitInt32 (Bytes.dWw0 x) buf.EmitInt32 (Bytes.dWw1 x) member buf.Position = buf.bbCurrent static member Create sz = - { bbArray=Bytes.zeroCreate sz; - bbCurrent = 0; } + { bbArray=Bytes.zeroCreate sz + bbCurrent = 0 } diff --git a/src/absil/il.fs b/src/absil/il.fs index 955d779c55..9e034f706b 100755 --- a/src/absil/il.fs +++ b/src/absil/il.fs @@ -3,16 +3,15 @@ module (*internal*) Microsoft.FSharp.Compiler.AbstractIL.IL #nowarn "49" -#nowarn "44" // This construct is deprecated. please use List.item #nowarn "343" // The type 'ILAssemblyRef' implements 'System.IComparable' explicitly but provides no corresponding override for 'Object.Equals'. #nowarn "346" // The struct, record or union type 'IlxExtensionType' has an explicit implementation of 'Object.Equals'. ... open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open System.Collections open System.Collections.Generic open System.Collections.Concurrent @@ -169,8 +168,6 @@ let splitTypeNameRight nm = // -------------------------------------------------------------------- /// This is used to store event, property and field maps. -/// -/// Review: this is not such a great data structure. type LazyOrderedMultiMap<'Key,'Data when 'Key : equality>(keyf : 'Data -> 'Key, lazyItems : Lazy<'Data list>) = let quickMap= @@ -315,9 +312,9 @@ let sha1HashBytes s = SHA1.sha1HashBytes s // THis is because many allocations of these small lists appear in memory logs. // // The "obviouos" step is to use arrays instead of lists. However, this is routinely and surprisingly disappointing. -// As a result, we haven’t enabled the use of arrays: we had expected this change to give a perf gain, +// As a result, we haven't enabled the use of arrays: we had expected this change to give a perf gain, // but it does not! It even gives a small perf loss. We've tried this approach on several other occasions -// for other data structures and each time been surprised that there’s no perf gain. It's possible that +// for other data structures and each time been surprised that there's no perf gain. It's possible that // arrays-of-references are just not as fast as we expect here: either the runtime check on assignment // into the array, or some kind of write barrier may be degrading performance. // @@ -350,7 +347,9 @@ module ILList = let inline isEmpty (x:ILList<_>) = x.Length <> 0 let inline toArray (x:ILList<_>) = x let inline ofArray (x:'T[]) = x - let inline nth n (x:'T[]) = x.[n] + [] + let inline nth n (x:'T[]) = x.[n] + let inline item n (x:'T[]) = x.[n] let inline toList (x:ILList<_>) = Array.toList x let inline ofList (x:'T list) = Array.ofList x let inline lengthsEqAndForall2 f x1 x2 = Array.lengthsEqAndForall2 f x1 x2 @@ -374,7 +373,9 @@ module ILList = let inline ofArray (x:'T[]) = List.ofArray x let inline iter f (x:'T list) = List.iter f x let inline iteri f (x:'T list) = List.iteri f x - let inline nth (x:'T list) n = List.nth x n + [] + let inline nth (x:'T list) n = List.item n x + let inline item n (x:'T list) = List.item n x let inline toList (x:ILList<_>) = x let inline ofList (x:'T list) = x let inline lengthsEqAndForall2 f x1 x2 = List.lengthsEqAndForall2 f x1 x2 @@ -397,7 +398,9 @@ module ILList = let inline iter f (x:ILList<'T>) = ThreeList.iter f x let inline iteri f (x:ILList<'T>) = ThreeList.iteri f x let inline toList (x:ILList<_>) = ThreeList.toList x + [] let inline nth (x:ILList<'T>) n = ThreeList.nth x n + let inline item n (x:ILList<'T>) = ThreeList.nth n x let inline ofList (x:'T list) = ThreeList.ofList x let inline lengthsEqAndForall2 f x1 x2 = ThreeList.lengthsEqAndForall2 f x1 x2 let inline init n f = ThreeList.init n f @@ -438,7 +441,7 @@ type AssemblyRefData = assemRefVersion: ILVersionInfo option; assemRefLocale: Locale option; } -/// Global state: table of all assembly references keyed by AssemblyRefData +/// Global state: table of all assembly references keyed by AssemblyRefData. let AssemblyRefUniqueStampGenerator = new UniqueStampGenerator() let compareVersions x y = @@ -612,7 +615,7 @@ and ILArrayShapeStatics() = static let singleDimensional = ILArrayShape [(Some 0, None)] static member SingleDimensional = singleDimensional -/// Calling conventions. These are used in method pointer types. +/// Calling conventions. These are used in method pointer types. [] type ILArgConvention = | Default @@ -640,7 +643,7 @@ type ILCallingConv = static member Instance = ILCallingConvStatics.Instance static member Static = ILCallingConvStatics.Static -/// Static storage to amortize the allocation of ILCallingConv.Instance and ILCallingConv.Static +/// Static storage to amortize the allocation of ILCallingConv.Instance and ILCallingConv.Static. and ILCallingConvStatics() = static let instanceCallConv = Callconv(ILThisConvention.Instance,ILArgConvention.Default) static let staticCallConv = Callconv(ILThisConvention.Static,ILArgConvention.Default) @@ -729,7 +732,7 @@ and [] ILTypeSpec = { tspecTypeRef: ILTypeRef; - /// The type instantiation if the type is generic + /// The type instantiation if the type is generic. tspecInst: ILGenericArgs } member x.TypeRef=x.tspecTypeRef member x.Scope=x.TypeRef.Scope @@ -787,15 +790,6 @@ and [] member x.QualifiedNameWithNoShortPrimaryAssembly = x.AddQualifiedNameExtensionWithNoShortPrimaryAssembly(x.BasicQualifiedName) -and - [] - IlxExtensionType = - | Ext_typ of obj - member x.Value = (let (Ext_typ(v)) = x in v) - override x.Equals(yobj) = match yobj with :? IlxExtensionType as y -> Unchecked.equals x.Value y.Value | _ -> false - interface System.IComparable with - override x.CompareTo(yobj) = match yobj with :? IlxExtensionType as y -> Unchecked.compare x.Value y.Value | _ -> invalidOp "bad comparison" - and [] ILCallingSignature = { CallingConv: ILCallingConv; @@ -1068,8 +1062,8 @@ type ILInstr = | I_br of ILCodeLabel | I_jmp of ILMethodSpec - | I_brcmp of ILComparisonInstr * ILCodeLabel * ILCodeLabel (* second label is fall-through *) - | I_switch of (ILCodeLabel list * ILCodeLabel) (* last label is fallthrough *) + | I_brcmp of ILComparisonInstr * ILCodeLabel + | I_switch of ILCodeLabel list | I_ret | I_call of ILTailcall * ILMethodSpec * ILVarArgs @@ -1130,87 +1124,42 @@ type ILInstr = (* FOR EXTENSIONS, e.g. MS-ILX *) | EI_ilzero of ILType | EI_ldlen_multi of int32 * int32 - | I_other of IlxExtensionInstr -and IlxExtensionInstr = Ext_instr of obj -// -------------------------------------------------------------------- -// Helpers for the ILX extensions -// -------------------------------------------------------------------- - -type internal_instr_extension = - { internalInstrExtIs: IlxExtensionInstr -> bool; - internalInstrExtDests: IlxExtensionInstr -> ILCodeLabel list; - internalInstrExtFallthrough: IlxExtensionInstr -> ILCodeLabel option; - internalInstrExtIsTailcall: IlxExtensionInstr -> bool; - internalInstrExtRelabel: (ILCodeLabel -> ILCodeLabel) -> IlxExtensionInstr -> IlxExtensionInstr; } - -type ILInstrSetExtension<'T> = - { instrExtDests: 'T -> ILCodeLabel list; - instrExtFallthrough: 'T -> ILCodeLabel option; - instrExtIsTailcall: 'T -> bool; - instrExtRelabel: (ILCodeLabel -> ILCodeLabel) -> 'T -> 'T; } - -let instrExtensions = ref [] - -let RegisterInstructionSetExtension (ext: ILInstrSetExtension<'T>) = - if nonNil !instrExtensions then failwith "RegisterInstructionSetExtension: only one extension currently allowed"; - let mk (x: 'T) = Ext_instr (box x) - let test (Ext_instr _x) = true - let dest (Ext_instr x) = (unbox x : 'T) - instrExtensions := - { internalInstrExtIs=test; - internalInstrExtDests=(fun x -> ext.instrExtDests (dest x)); - internalInstrExtFallthrough=(fun x -> ext.instrExtFallthrough (dest x)); - internalInstrExtIsTailcall=(fun x -> ext.instrExtIsTailcall (dest x)); - internalInstrExtRelabel=(fun f x -> mk (ext.instrExtRelabel f (dest x))); } - :: !instrExtensions; - mk,test,dest - -let rec find_extension s f l = - let rec look l1 = - match l1 with - | [] -> failwith ("extension for "+s+" not found") - | (h::t) -> match f h with None -> look t | Some res -> res - look l - +[] +type ILExceptionClause = + | Finally of (ILCodeLabel * ILCodeLabel) + | Fault of (ILCodeLabel * ILCodeLabel) + | FilterCatch of (ILCodeLabel * ILCodeLabel) * (ILCodeLabel * ILCodeLabel) + | TypeCatch of ILType * (ILCodeLabel * ILCodeLabel) -type ILDebugMapping = +[] +type ILExceptionSpec = + { Range: (ILCodeLabel * ILCodeLabel); + Clause: ILExceptionClause } + +/// Indicates that a particular local variable has a particular source +/// language name within a given set of ranges. This does not effect local +/// variable numbering, which is global over the whole method. +[] +type ILLocalDebugMapping = { LocalIndex: int; LocalName: string; } -type ILBasicBlock = - { Label: ILCodeLabel; - Instructions: ILInstr[] } - member bb.LastInstruction = - let n = bb.Instructions.Length - if n = 0 then failwith "last_of_bblock: empty bblock"; - bb.Instructions.[n - 1] - - member x.Fallthrough = - match x.LastInstruction with - | I_br l | I_brcmp (_,_,l) | I_switch (_,l) -> Some l - | I_other e -> find_extension "instr" (fun ext -> if ext.internalInstrExtIs e then Some (ext.internalInstrExtFallthrough e) else None) !instrExtensions - | _ -> None - +[] +type ILLocalDebugInfo = + { Range: (ILCodeLabel * ILCodeLabel); + DebugMappings: ILLocalDebugMapping list } +[] type ILCode = - | ILBasicBlock of ILBasicBlock - | GroupBlock of ILDebugMapping list * ILCode list - | RestrictBlock of ILCodeLabel list * ILCode - | TryBlock of ILCode * ILExceptionBlock + { Labels: Dictionary + Instrs:ILInstr[] + Exceptions: ILExceptionSpec list + Locals: ILLocalDebugInfo list } -and ILExceptionBlock = - | FaultBlock of ILCode - | FinallyBlock of ILCode - | FilterCatchBlock of (ILFilterBlock * ILCode) list - -and ILFilterBlock = - | TypeFilter of ILType - | CodeFilter of ILCode - -[] +[] type ILLocal = { Type: ILType; IsPinned: bool; @@ -1220,7 +1169,7 @@ type ILLocals = ILList let emptyILLocals = (ILList.empty : ILLocals) let mkILLocals xs = (match xs with [] -> emptyILLocals | _ -> ILList.ofList xs) -[] +[] type ILMethodBody = { IsZeroInit: bool; MaxStack: int32; @@ -1239,8 +1188,7 @@ type ILMemberAccess = | Private | Public -[] -[] +[] type ILFieldInit = | String of string | Bool of bool @@ -1263,8 +1211,7 @@ type ILFieldInit = // correspond yet to the ECMA Spec (Partition II, 7.4). // -------------------------------------------------------------------- -[] -[] +[] type ILNativeType = | Empty | Custom of Guid * string * string * byte[] (* guid,nativeTypeName,custMarshallerName,cookieString *) @@ -1305,7 +1252,9 @@ type ILNativeType = | VariantBool -and ILNativeVariant = +and + [] + ILNativeVariant = | Empty | Null | Variant @@ -1351,7 +1300,9 @@ and ILNativeVariant = | Int | UInt -type ILSecurityAction = +type + [] + ILSecurityAction = | Request | Demand | Assert @@ -1371,9 +1322,11 @@ type ILSecurityAction = | InheritanceDemandChoice | DemandChoice +[] type ILPermission = | PermissionSet of ILSecurityAction * byte[] +[] type ILPermissions = | SecurityDecls of ILPermission list | SecurityDeclsLazy of Lazy @@ -1407,7 +1360,7 @@ type PInvokeCharEncoding = | Unicode | Auto -[] +[] type PInvokeMethod = { Where: ILModuleRef; Name: string; @@ -1418,6 +1371,7 @@ type PInvokeMethod = ThrowOnUnmappableChar: PInvokeThrowOnUnmappableChar; CharBestFit: PInvokeCharBestFit } +[] type ILParameter = { Name: string option; Type: ILType; @@ -1433,6 +1387,7 @@ let emptyILParameters = (ILList.empty : ILParameters) let mkILParametersRaw x = (match x with [] -> emptyILParameters | _ -> ILList.ofList x) +[] type ILReturn = { Marshal: ILNativeType option; Type: ILType; @@ -1690,12 +1645,6 @@ type ILTypeDefKind = | Interface | Enum | Delegate - | Other of IlxExtensionTypeKind - -and IlxExtensionTypeKind = Ext_type_def_kind of obj - -type internal_type_def_kind_extension = - { internalTypeDefKindExtIs: IlxExtensionTypeKind -> bool; } [] @@ -1876,8 +1825,6 @@ type ILModuleDef = // when clashes occur... // -------------------------------------------------------------------- - - let mkILEmptyGenericParams = ([]: ILGenericParameterDefs) let emptyILGenericArgsList = ([ ]: ILType list) @@ -1940,22 +1887,6 @@ let mkILBoxedTyRaw tref tinst = mkILNamedTyRaw AsObject tref tinst let mkILNonGenericValueTy tref = mkILNamedTy AsValue tref [] let mkILNonGenericBoxedTy tref = mkILNamedTy AsObject tref [] - -type ILTypeDefKindExtension<'T> = - | TypeDefKindExtension - -let type_def_kind_extensions = ref [] - -let RegisterTypeDefKindExtension (TypeDefKindExtension : ILTypeDefKindExtension<'T>) = - if nonNil !type_def_kind_extensions then failwith "define_type_extension: only one extension currently allowed"; - let mk (x:'T) = Ext_type_def_kind (box x) - let test (Ext_type_def_kind _x) = true - let dest (Ext_type_def_kind x) = (unbox x: 'T) - type_def_kind_extensions := - { internalTypeDefKindExtIs=test;} - :: !type_def_kind_extensions; - mk,test,dest - // -------------------------------------------------------------------- // Making assembly, module and file references // -------------------------------------------------------------------- @@ -1966,10 +1897,6 @@ let mkSimpleAssRef n = let mkSimpleModRef n = ILModuleRef.Create(n, true, None) -let module_name_of_scoref = function - | ILScopeRef.Module(mref) -> mref.Name - | _ -> failwith "module_name_of_scoref" - // -------------------------------------------------------------------- // The toplevel class of a module is called "" // @@ -2071,194 +1998,11 @@ let mkILComputedCustomAttrs f = ILAttributes f let andTailness x y = match x with Tailcall when y -> Tailcall | _ -> Normalcall -// -------------------------------------------------------------------- -// ILAttributes on code blocks (esp. debug info) -// -------------------------------------------------------------------- - -let formatCodeLabel (x:int) = "L"+string x - -module CodeLabels = - let insert (e:ILCodeLabel) l = Zset.add e l - let remove e l = Zset.remove e l - let fold f s acc = Zset.fold f s acc - let add s x = Zset.add s x - let addList s xs = Zset.addList s xs - let diff l1 l2 = Zset.diff l1 l2 - let union l1 l2 = Zset.union l1 l2 - let inter (l1:Zset) l2 = Zset.inter l1 l2 - let subset (l1:Zset) l2 = Zset.subset l1 l2 - let empty = Zset.empty int_order - let isNonEmpty s = not (Zset.isEmpty s) - let ofList l = Zset.addList l empty - let toList l = Zset.elements l - // -------------------------------------------------------------------- // Basic operations on code. // -------------------------------------------------------------------- -let destinationsOfInstr i = - match i with - | I_leave l | I_br l -> [l] - | I_brcmp (_,l1,l2) -> [l1; l2] - | I_switch (ls,l) -> CodeLabels.toList (CodeLabels.ofList (l::ls)) - | I_endfinally | I_endfilter | I_ret | I_throw | I_rethrow - | I_call (Tailcall,_,_)| I_callvirt (Tailcall,_,_)| I_callconstraint (Tailcall,_,_,_) - | I_calli (Tailcall,_,_) -> [] - | I_other e -> find_extension "instr" (fun ext -> if ext.internalInstrExtIs e then Some (ext.internalInstrExtDests e) else None) !instrExtensions - | _ -> [] - -let destinationsOfBasicBlock (bblock:ILBasicBlock) = destinationsOfInstr bblock.LastInstruction - -let instrIsTailcall i = - match i with - | I_call (Tailcall,_,_)| I_callvirt (Tailcall,_,_) | I_callconstraint (Tailcall,_,_,_) | I_calli (Tailcall,_,_) -> true - | I_other e -> find_extension "instr" (fun ext -> if ext.internalInstrExtIs e then Some (ext.internalInstrExtIsTailcall e) else None) !instrExtensions - | _ -> false - -let instrIsBasicBlockEnd i = - instrIsTailcall i || - match i with - | I_leave _ | I_br _ | I_brcmp _ | I_switch _ | I_endfinally - | I_endfilter | I_ret | I_throw | I_rethrow -> true - | I_other e -> find_extension "instr" (fun ext -> if ext.internalInstrExtIs e then Some (nonNil (ext.internalInstrExtDests e)) else None) !instrExtensions - | _ -> false - -let checks = false -let _ = if checks then dprintn "Warning - Il.checks is on" - -let rec accEntriesOfCode c acc = - match c with - | ILBasicBlock bb -> CodeLabels.add bb.Label acc - | GroupBlock (_,l) -> List.foldBack accEntriesOfCode l acc - | RestrictBlock (ls,c) -> CodeLabels.union acc (CodeLabels.diff (entriesOfCodeAsSet c) (CodeLabels.ofList ls)) - | TryBlock (l,_r) -> accEntriesOfCode l acc - -and entriesOfCodeAsSet c = - accEntriesOfCode c CodeLabels.empty - -let rec accExitsOfCode c acc = - let basicOutsideLabels = - match c with - | ILBasicBlock bblock -> CodeLabels.addList (destinationsOfBasicBlock bblock) acc - | GroupBlock (_,l) -> List.foldBack accExitsOfCode l acc - | RestrictBlock (ls,c) -> CodeLabels.union acc (CodeLabels.diff (exitsOfCodeAsSet c) (CodeLabels.ofList ls)) - | TryBlock (l,_r) -> accExitsOfCode l acc - CodeLabels.diff basicOutsideLabels (entriesOfCodeAsSet c) - -and exitsOfCodeAsSet c = accExitsOfCode c CodeLabels.empty - -let entriesOfCode c = CodeLabels.toList (entriesOfCodeAsSet c) -let exitsOfCode c = CodeLabels.toList (exitsOfCodeAsSet c) - -/// Finds all labels defined within this code block, seeing through restrictions. -/// This assumes that labels are unique within the code blocks, even if hidden behind restrictions. -/// -// Note: Repeats in the list indicate this invariant is broken. -let rec accLabelsOfCode acc c = - match c with - | ILBasicBlock bb -> bb.Label::acc - | GroupBlock (_,l) -> List.fold accLabelsOfCode acc l - | RestrictBlock (_ls,c) -> accLabelsOfCode acc c - | TryBlock (l,r) -> let acc = accLabelsOfCode acc l - let acc = accLabelsOfSEH acc r - acc -and accLabelsOfSEH acc = function - | FaultBlock code -> accLabelsOfCode acc code - | FinallyBlock code -> accLabelsOfCode acc code - | FilterCatchBlock fcodes -> List.fold accLabelsOfFilterCode acc fcodes - -and accLabelsOfFilterCode acc = function - | TypeFilter _,code -> accLabelsOfCode acc code - | CodeFilter test,code -> let accA = accLabelsOfCode acc code - let accB = accLabelsOfCode accA test - accB - -let labelsOfCode code = accLabelsOfCode [] code - -(* - -From the ECMA spec: - -There are only two ways to enter a try block from outside its lexical body: - - Branching to or falling into the try block’s first instruction. The branch may be made using a 37 -conditional branch, an unconditional branch, or a leave instruction. 38 - - Using a leave instruction from that try’s catch block. In this case, correct CIL code may 39 -branch to any instruction within the try block, not just its first instruction, so long as that 40 -branch target is not protected by yet another try, nested withing the first -*) - - -let checkILCode code = - if checks then - match code with - | RestrictBlock (ls,c') -> - (* - if not (CodeLabels.subset ls (entriesOfCode c')) then begin - dprintn ("* warning: Restricting labels that are not declared in block, e.g. "+ (List.head (CodeLabels.diff ls (entriesOfCode c')))); - dprintn ("* warning: Labels in block are: "+ (String.concat "," (entriesOfCode c'))); - dprintn ("* warning: Labels being restricted are: "+ (String.concat "," ls)); - end; - *) - let cls = (CodeLabels.inter (CodeLabels.ofList ls) (exitsOfCodeAsSet c')) - if (CodeLabels.isNonEmpty cls) then - dprintn ("* warning: restricting unsatisfied exits from a block, e.g. "+ formatCodeLabel (List.head (CodeLabels.toList cls))); - | TryBlock (_l,r) -> - begin match r with - | FaultBlock b | FinallyBlock b -> - if (CodeLabels.isNonEmpty (CodeLabels.inter (exitsOfCodeAsSet b) (entriesOfCodeAsSet b))) then - dprintn "* warning: exits from fault or finally blocks must leave the block"; - let n = List.length (entriesOfCode b) - if not (n = 1) then dprintn "* warning: zero or more than one entry to a fault or finally block"; - | FilterCatchBlock r -> - List.iter - (fun (flt,z) -> - let m = List.length (entriesOfCode z) - if not (m = 1) then dprintn "* warning: zero or more than one entry to a catch block"; - match flt with - | CodeFilter y -> - if (CodeLabels.isNonEmpty (exitsOfCodeAsSet y)) then dprintn "* warning: exits exist from filter block - you must always exit using endfinally"; - let n = List.length (entriesOfCode y) - if not (n = 1) then dprintn "* warning: zero or more than one entry to a filter block"; - | TypeFilter _ty -> ()) - r; - end; - | ILBasicBlock bb -> - if (Array.length bb.Instructions) = 0 then dprintn ("* warning: basic block " + formatCodeLabel bb.Label + " is empty") - elif not (instrIsBasicBlockEnd (bb.Instructions.[Array.length bb.Instructions - 1])) then failwith "* warning: bblock does not end in an appropriate instruction"; - - | _ -> () - match code with - | RestrictBlock (labs,c) when (isNil labs) -> c - | GroupBlock ([],[c]) -> c - | _ -> code - - -let mkBasicBlock bb = ILBasicBlock bb -let mkScopeBlock (a,b) = GroupBlock (a,[checkILCode b]) -let mkGroupBlockFromCode (internals,codes) = RestrictBlock (internals,checkILCode (GroupBlock ([],codes))) -let mkGroupBlock (internals,blocks) = mkGroupBlockFromCode (internals,List.map checkILCode blocks) - -let mkRestrictBlock lab c = RestrictBlock (CodeLabels.toList (CodeLabels.remove lab (entriesOfCodeAsSet c)),c) -let mkTryFinallyBlock (tryblock, enterFinallyLab, finallyBlock) = - TryBlock(checkILCode tryblock, FinallyBlock (checkILCode (mkRestrictBlock enterFinallyLab (checkILCode finallyBlock)))) - -let mkTryFaultBlock (tryblock, entarFaultLab, faultBlock) = - TryBlock(checkILCode tryblock, FaultBlock (checkILCode (mkRestrictBlock entarFaultLab (checkILCode faultBlock)))) - -let mkTryMultiFilterCatchBlock (tryblock, clauses) = - TryBlock - (checkILCode tryblock, - FilterCatchBlock - (clauses |> List.map (fun (flt, (enter_catch_lab, catchblock)) -> - let fltcode = - match flt with - | Choice1Of2 (enter_filter_lab, filterblock) -> - CodeFilter (checkILCode (mkRestrictBlock enter_filter_lab (checkILCode filterblock))) - | Choice2Of2 ty -> - TypeFilter ty - fltcode, - checkILCode (mkRestrictBlock enter_catch_lab (checkILCode catchblock))))) - +let formatCodeLabel (x:int) = "L"+string x let new_generator () = let i = ref 0 @@ -2269,61 +2013,34 @@ let new_generator () = let codeLabelGenerator = (new_generator () : unit -> ILCodeLabel) let generateCodeLabel x = codeLabelGenerator x -let uniqueEntryOfCode c = - match entriesOfCode c with - | [] -> failwith ("uniqueEntryOfCode: no entries to code") - | [inlab] -> inlab - | labs -> failwith ("uniqueEntryOfCode: need one entry to code, found: "+String.concat "," (List.map formatCodeLabel labs)) - -let uniqueExitOfCode c = - match exitsOfCode c with - | [] -> failwith ("uniqueExitOfCode: no exits from code") - | [outlab] -> outlab - | labs -> failwith ("uniqueExitOfCode: need one exit from code, found: "+String.concat "," (List.map formatCodeLabel labs)) -let mkNonBranchingInstrs inplab instrs = - checkILCode (mkBasicBlock {Label=inplab; Instructions= Array.ofList instrs}) - -let mkNonBranchingInstrsThen inplab instrs instr = - if nonNil instrs && instrIsBasicBlockEnd (List.last instrs) then failwith "mkNonBranchingInstrsThen: bblock already terminates with a control flow instruction"; - mkNonBranchingInstrs inplab (instrs @ [ instr ]) - -let mkNonBranchingInstrsThenRet inplab instrs = - mkNonBranchingInstrsThen inplab instrs I_ret +let instrIsRet i = + match i with + | I_ret -> true + | _ -> false -let mkNonBranchingInstrsThenBr inplab instrs lab = - mkNonBranchingInstrsThen inplab instrs (I_br lab) +let nonBranchingInstrsToCode instrs : ILCode = + let instrs = Array.ofList instrs + let instrs = + if instrs.Length <> 0 && instrIsRet (Array.last instrs) then instrs + else Array.append instrs [| I_ret |] -let nonBranchingInstrsToCode instrs = - let inplab = generateCodeLabel () - if nonNil instrs && instrIsBasicBlockEnd (List.last instrs) then - mkNonBranchingInstrs inplab instrs - else - mkNonBranchingInstrsThenRet inplab instrs + { Labels = Dictionary() + Instrs = instrs + Exceptions = [] + Locals = [] } -let joinCode code1 code2 = - if not (uniqueExitOfCode code1 = uniqueEntryOfCode code2) then - dprintn "* warning: joinCode: exit of code1 is not entry of code 2"; - checkILCode - (RestrictBlock ([uniqueExitOfCode code1], - (checkILCode (mkGroupBlock ([],[ code1; code2 ]))))) // -------------------------------------------------------------------- -// Security declarations (2) +// // -------------------------------------------------------------------- -let emptyILSecurityDecls = SecurityDecls [] -let mkILSecurityDecls l = match l with [] -> emptyILSecurityDecls | _ -> SecurityDecls l -let mkILLazySecurityDecls l = SecurityDeclsLazy l - - -// -------------------------------------------------------------------- -// ILX stuff -// -------------------------------------------------------------------- +let emptyILSecurityDecls = ILPermissions.SecurityDecls [] +let mkILSecurityDecls l = match l with [] -> emptyILSecurityDecls | _ -> ILPermissions.SecurityDecls l +let mkILLazySecurityDecls l = ILPermissions.SecurityDeclsLazy l let mkILTyvarTy tv = ILType.TypeVar tv - let mkILSimpleTypar nm = { Name=nm; Constraints=emptyILTypes; @@ -2346,6 +2063,8 @@ let mkILFormalGenericArgs (gparams:ILGenericParameterDefs) = let mkILFormalBoxedTy tref gparams = mkILBoxedTy tref (mkILFormalGenericArgs gparams) +let mkILFormalNamedTy bx tref gparams = mkILNamedTy bx tref (mkILFormalGenericArgs gparams) + // -------------------------------------------------------------------- // Operations on class etc. defs. // -------------------------------------------------------------------- @@ -2370,8 +2089,6 @@ let emptyILTypeDefs = mkILTypeDefsFromArray [| |] // -------------------------------------------------------------------- // Operations on method tables. -// -// REVIEW: this data structure looks substandard // -------------------------------------------------------------------- let mkILMethodsFromArray xs = ILMethodDefs (fun () -> xs) @@ -2382,7 +2099,6 @@ let emptyILMethods = mkILMethodsFromArray [| |] let filterILMethodDefs f (mdefs: ILMethodDefs) = ILMethodDefs (fun () -> mdefs.AsArray |> Array.filter f) - // -------------------------------------------------------------------- // Operations and defaults for modules, assemblies etc. // -------------------------------------------------------------------- @@ -2481,7 +2197,7 @@ let tname_RuntimeMethodHandle = "System.RuntimeMethodHandle" let tname_RuntimeFieldHandle = "System.RuntimeFieldHandle" /// Represents the capabilities of target framework profile. -/// Different profiles may omit some types or contain them in different assemblies +/// Different profiles may omit some types or contain them in different assemblies. type IPrimaryAssemblyTraits = abstract TypedReferenceTypeScopeRef : ILScopeRef option @@ -2589,9 +2305,9 @@ let mkNormalCallconstraint (ty,mspec) = I_callconstraint (Normalcall, ty, mspec, let mkNormalNewobj mspec = I_newobj (mspec, None) /// Comment on common object cache sizes: -/// mkLdArg - I can’t imagine any IL method we generate needing more than this -/// mkLdLoc - I tried 256, and there were LdLoc allocations left, so I upped it o 512. I didn’t check again. -/// mkStLoc - it should be the same as LdLoc (where there’s a LdLoc there must be a StLoc) +/// mkLdArg - I can't imagine any IL method we generate needing more than this +/// mkLdLoc - I tried 256, and there were LdLoc allocations left, so I upped it o 512. I didn't check again. +/// mkStLoc - it should be the same as LdLoc (where there's a LdLoc there must be a StLoc) /// mkLdcInt32 - just a guess let ldargs = [| for i in 0 .. 128 -> I_ldarg (uint16 i) |] @@ -2912,7 +2628,6 @@ let isILDoubleTy ty = typ_is_value_mscorlib_typ ty tname_Double // Rescoping // -------------------------------------------------------------------- - let qrescope_scoref scoref scoref_old = match scoref,scoref_old with | _,ILScopeRef.Local -> Some scoref @@ -3006,7 +2721,7 @@ and instILTypeAux numFree (inst:ILGenericArgs) typ = if v - numFree >= top then ILType.TypeVar (uint16 (v - top)) else - ILList.nth inst (v - numFree) + ILList.item (v - numFree) inst | x -> x and instILGenericArgsAux numFree inst i = ILList.map (instILTypeAux numFree inst) i @@ -3020,7 +2735,7 @@ let instILType i t = instILTypeAux 0 i t // MS-IL: Parameters, Return types and Locals // -------------------------------------------------------------------- -let mkILParam (name,ty) = +let mkILParam (name,ty) : ILParameter = { Name=name; Default=None; Marshal=None; @@ -3037,7 +2752,7 @@ let mkILReturn ty : ILReturn = Type=ty; CustomAttrs=emptyILCustomAttrs } -let mkILLocal ty dbgInfo = +let mkILLocal ty dbgInfo : ILLocal = { IsPinned=false; Type=ty; DebugInfo=dbgInfo } @@ -3051,13 +2766,12 @@ type ILFieldSpec with // Make a method mbody // -------------------------------------------------------------------- - -let mkILMethodBody (zeroinit,locals,maxstack,code,tag) = - { IsZeroInit=zeroinit; - MaxStack=maxstack; - NoInlining=false; - Locals= locals ; - Code= code; +let mkILMethodBody (zeroinit,locals,maxstack,code,tag) : ILMethodBody = + { IsZeroInit=zeroinit + MaxStack=maxstack + NoInlining=false + Locals= locals + Code= code SourceMarker=tag } let mkMethodBody (zeroinit,locals,maxstack,code,tag) = MethodBody.IL (mkILMethodBody (zeroinit,locals,maxstack,code,tag)) @@ -3120,6 +2834,7 @@ let mkILNonGenericEmptyCtor tag superTy = // Make a static, top level monomophic method - very useful for // creating helper ILMethodDefs for internal use. // -------------------------------------------------------------------- + let mkILStaticMethod (genparams,nm,access,args,ret,impl) = { GenericParams=genparams; Name=nm; @@ -3253,7 +2968,7 @@ let mkILNonGenericInstanceMethod (nm,access,args,ret,impl) = // if one doesn't exist already. // -------------------------------------------------------------------- -let ilmbody_code2code f il = +let ilmbody_code2code f (il: ILMethodBody) = {il with Code = f il.Code} let mdef_code2code f md = @@ -3264,10 +2979,11 @@ let mdef_code2code f md = let b = MethodBody.IL (ilmbody_code2code f il) {md with mdBody= mkMethBodyAux b } -let prependInstrsToCode c1 c2 = - let internalLab = generateCodeLabel () - joinCode (checkILCode (mkBasicBlock {Label=internalLab; - Instructions=Array.ofList (c1 @ [ I_br (uniqueEntryOfCode c2)])})) c2 +let prependInstrsToCode (instrs: ILInstr list) (c2: ILCode) = + let instrs = Array.ofList instrs + let n = instrs.Length + { c2 with Labels = Dictionary.ofList [ for kvp in c2.Labels -> (kvp.Key, kvp.Value + n) ] + Instrs = Array.append instrs c2.Instrs } let prependInstrsToMethod new_code md = mdef_code2code (prependInstrsToCode new_code) md @@ -3515,22 +3231,6 @@ let mkILSimpleModule assname modname dll subsystemVersion useHighEntropyVA tdefs } -//----------------------------------------------------------------------- -// Intermediate parsing structure for exception tables.... -//----------------------------------------------------------------------- - -type ILExceptionClause = - | Finally of (ILCodeLabel * ILCodeLabel) - | Fault of (ILCodeLabel * ILCodeLabel) - | FilterCatch of (ILCodeLabel * ILCodeLabel) * (ILCodeLabel * ILCodeLabel) - | TypeCatch of ILType * (ILCodeLabel * ILCodeLabel) - -type ILExceptionSpec = - { exnRange: (ILCodeLabel * ILCodeLabel); - exnClauses: ILExceptionClause list } - -type exceptions = ILExceptionSpec list - //----------------------------------------------------------------------- // [instructions_to_code] makes the basic block structure of code from // a primitive array of instructions. We @@ -3539,537 +3239,16 @@ type exceptions = ILExceptionSpec list // [bbstartToCodeLabelMap]. //----------------------------------------------------------------------- -type ILLocalSpec = - { locRange: (ILCodeLabel * ILCodeLabel); - locInfos: ILDebugMapping list } - -type structspec = SEH of ILExceptionSpec | LOCAL of ILLocalSpec - -let delayInsertedToWorkaroundKnownNgenBug _s f = - (* Some random code to prevent inlining of this function *) - let mutable res = 10 - for i = 0 to 2 do - res <- res + 1; - //printf "------------------------executing NGEN bug delay '%s', calling 'f' --------------\n" s; - let res = f() - //printf "------------------------exiting NGEN bug delay '%s' --------------\n" s; - res - - -let popRangeM lo hi (m:Zmap<'Key,'U>) = - let collect k v (rvs,m) = (v :: rvs) , Zmap.remove k m - let rvs,m = Zmap.foldSection lo hi collect m ([],m) - List.rev rvs,m - -type BasicBlockStartsToCodeLabelsMap(instrs,tryspecs,localspecs,lab2pc) = - - // Find all the interesting looking labels that form the boundaries of basic blocks. - // These are the destinations of branches and the boundaries of both exceptions and - // those blocks where locals are live. - let bbstartToCodeLabelMap = - let res = ref CodeLabels.empty - let add_range (a,b) = res := CodeLabels.insert a (CodeLabels.insert b !res) - instrs |> Array.iter (fun i -> res := CodeLabels.addList (destinationsOfInstr i) !res); - - tryspecs |> List.iter (fun espec -> - add_range espec.exnRange; - List.iter (function - | Finally r1 | Fault r1 | TypeCatch (_,r1)-> add_range r1 - | FilterCatch (r1,r2) -> add_range r1; add_range r2) espec.exnClauses); - - localspecs |> List.iter (fun l -> add_range l.locRange) ; - - !res - - // Construct a map that gives a unique ILCodeLabel for each label that - // might be a boundary of a basic block. These will be the labels - // for the basic blocks we end up creating. - let lab2clMap = Dictionary<_,_>(10, HashIdentity.Structural) - let pc2clMap = Dictionary<_,_>(10, HashIdentity.Structural) - let addBBstartPc pc pcs cls = - if pc2clMap.ContainsKey pc then - pc2clMap.[pc], pcs, cls - else - let cl = generateCodeLabel () - pc2clMap.[pc] <- cl; - cl, pc::pcs, CodeLabels.insert cl cls - - let bbstartPcs, bbstart_code_labs = - CodeLabels.fold - (fun bbstart_lab (pcs, cls) -> - let pc = lab2pc bbstart_lab - if logging then dprintf "bblock starts with label %s at pc %d\n" (formatCodeLabel bbstart_lab) pc; - let cl,pcs',cls' = addBBstartPc pc pcs cls - lab2clMap.[bbstart_lab] <- cl; - pcs', - cls') - bbstartToCodeLabelMap - ([], CodeLabels.empty) - let cl0,bbstartPcs, bbstart_code_labs = addBBstartPc 0 bbstartPcs bbstart_code_labs - - - member c.InitialCodeLabel = cl0 - member c.BasicBlockStartPositions = bbstartPcs - member c.BasicBlockStartCodeLabels = bbstart_code_labs - - member c.lab2cl bbLab = - try - lab2clMap.[bbLab] - with :? KeyNotFoundException -> failwith ("basic block label "+formatCodeLabel bbLab+" not declared") - - member c.pc2cl pc = - try - pc2clMap.[pc] - with :? KeyNotFoundException -> - failwith ("internal error while mapping pc "+string pc+" to code label") - - member c.remapLabels i = - match i with - | I_leave l -> I_leave(c.lab2cl l) - | I_br l -> I_br (c.lab2cl l) - | I_other e -> I_other (find_extension "instr" (fun ext -> if ext.internalInstrExtIs e then Some (ext.internalInstrExtRelabel c.lab2cl e) else None) !instrExtensions) - | I_brcmp (x,l1,l2) -> I_brcmp(x,c.lab2cl l1, c.lab2cl l2) - | I_switch (ls,l) -> I_switch(List.map c.lab2cl ls, c.lab2cl l) - | _ -> i - -let disjoint_range (start_pc1,end_pc1) (start_pc2,end_pc2) = - ((start_pc1 : int) < start_pc2 && end_pc1 <= start_pc2) || - (start_pc1 >= end_pc2 && end_pc1 > end_pc2) - -let merge_ranges (start_pc1,end_pc1) (start_pc2,end_pc2) = - (min (start_pc1:int) start_pc2, max (end_pc1:int) end_pc2) - -let rangeInsideRange (start_pc1,end_pc1) (start_pc2,end_pc2) = - (start_pc1:int) >= start_pc2 && start_pc1 < end_pc2 && - (end_pc1:int) > start_pc2 && end_pc1 <= end_pc2 - -let lranges_of_clause cl = - match cl with - | Finally r1 -> [r1] - | Fault r1 -> [r1] - | FilterCatch (r1,r2) -> [r1;r2] - | TypeCatch (_ty,r1) -> [r1] - - -type CodeOffsetViewOfLabelledItems(lab2pc) = - member x.labelsToRange p = let (l1,l2) = p in lab2pc l1, lab2pc l2 - - member x.lrange_inside_lrange ls1 ls2 = - rangeInsideRange (x.labelsToRange ls1) (x.labelsToRange ls2) - - member x.disjoint_lranges ls1 ls2 = - disjoint_range (x.labelsToRange ls1) (x.labelsToRange ls2) - - member x.clause_inside_lrange cl lr = - List.forall (fun lr1 -> x.lrange_inside_lrange lr1 lr) (lranges_of_clause cl) - - member x.clauses_inside_lrange cls lr = - List.forall - (fun cl -> x.clause_inside_lrange cl lr) - cls - - member x.tryspec_inside_lrange tryspec1 lr = - (x.lrange_inside_lrange tryspec1.exnRange lr && - x.clauses_inside_lrange tryspec1.exnClauses lr) - - member x.tryspec_inside_clause tryspec1 cl = - List.exists (fun lr -> x.tryspec_inside_lrange tryspec1 lr) (lranges_of_clause cl) - - member x.locspec_inside_clause locspec1 cl = - List.exists (fun lr -> x.lrange_inside_lrange locspec1.locRange lr) (lranges_of_clause cl) - - member x.tryspec_inside_tryspec tryspec1 tryspec2 = - x.tryspec_inside_lrange tryspec1 tryspec2.exnRange || - List.exists (fun c2 -> x.tryspec_inside_clause tryspec1 c2) tryspec2.exnClauses - - member x.locspec_inside_tryspec locspec1 tryspec2 = - x.lrange_inside_lrange locspec1.locRange tryspec2.exnRange || - List.exists (fun c2 -> x.locspec_inside_clause locspec1 c2) tryspec2.exnClauses - - member x.tryspec_inside_locspec tryspec1 locspec2 = - x.tryspec_inside_lrange tryspec1 locspec2.locRange - - member x.disjoint_clause_and_lrange cl lr = - List.forall (fun lr1 -> x.disjoint_lranges lr1 lr) (lranges_of_clause cl) - - member x.disjoint_clauses_and_lrange cls lr = - List.forall (fun cl -> x.disjoint_clause_and_lrange cl lr) cls - - member x.disjoint_tryspec_and_lrange tryspec1 lr = - (x.disjoint_lranges tryspec1.exnRange lr && - x.disjoint_clauses_and_lrange tryspec1.exnClauses lr) - - member x.disjoint_tryspec_and_clause tryspec1 cl = - List.forall (fun lr -> x.disjoint_tryspec_and_lrange tryspec1 lr) (lranges_of_clause cl) - - member x.tryspec_disjoint_from_tryspec tryspec1 tryspec2 = - x.disjoint_tryspec_and_lrange tryspec1 tryspec2.exnRange && - List.forall (fun c2 -> x.disjoint_tryspec_and_clause tryspec1 c2) tryspec2.exnClauses - - member x.tryspec_disjoint_from_locspec tryspec1 locspec2 = - x.disjoint_tryspec_and_lrange tryspec1 locspec2.locRange - - member x.locspec_disjoint_from_locspec locspec1 locspec2 = - x.disjoint_lranges locspec1.locRange locspec2.locRange - - member x.locspec_inside_locspec locspec1 locspec2 = - x.lrange_inside_lrange locspec1.locRange locspec2.locRange - - member x.structspec_inside_structspec specA specB = (* only for sanity checks, then can be removed *) - match specA,specB with - | SEH tryspecA,SEH tryspecB -> x.tryspec_inside_tryspec tryspecA tryspecB - | SEH tryspecA,LOCAL locspecB -> x.tryspec_inside_locspec tryspecA locspecB - | LOCAL locspecA,SEH tryspecB -> x.locspec_inside_tryspec locspecA tryspecB - | LOCAL locspecA,LOCAL locspecB -> x.locspec_inside_locspec locspecA locspecB - - // extent (or size) is the sum of range extents - // We want to build in increasing containment-order, that's a partial order. - // Size-order implies containment-order, and size-order is a total order. - member x.extent_structspec ss = - let extent_range (start_pc,end_pc) = end_pc - start_pc - let extent_lrange lrange = extent_range (x.labelsToRange lrange) - let extent_locspec locspec = extent_lrange locspec.locRange - let extent_list extent_item items = List.fold (fun acc item -> acc + extent_item item) 0 items - let extent_list2 extent_item items = List.fold (fun acc item -> acc + extent_item item) 0 items - let extent_clause cl = extent_list extent_lrange (lranges_of_clause cl) - let extent_tryspec tryspec = extent_lrange tryspec.exnRange + (extent_list2 extent_clause tryspec.exnClauses) - - match ss with - | LOCAL locspec -> extent_locspec locspec - | SEH tryspec -> extent_tryspec tryspec - - (* DIAGNOSTICS: START ------------------------------ *) - member x.string_of_structspec ss = - let stringOfRange (l1,l2) = - let pc1,pc2 = x.labelsToRange ((l1,l2)) - formatCodeLabel l1+"("+string pc1+")-"+ formatCodeLabel l2+"("+string pc2+")" - let string_of_clause cl = String.concat "+" (List.map stringOfRange (lranges_of_clause cl)) - let string_of_tryspec tryspec = "tryspec"+ stringOfRange tryspec.exnRange + "--" + String.concat " / " (List.map string_of_clause tryspec.exnClauses) - let string_of_locspec locspec = "local "+(String.concat ";" (locspec.locInfos |> List.map (fun l -> l.LocalName)))+": "+ stringOfRange locspec.locRange - match ss with - | SEH tryspec -> string_of_tryspec tryspec - | LOCAL locspec -> string_of_locspec locspec - - - -// Stage 2b - Given an innermost tryspec, collect together the -// blocks covered by it. Preserve the essential ordering of blocks. -let blockForInnerTrySpec (codeOffsetView:CodeOffsetViewOfLabelledItems, - coverageOfCodes, - addBlocks, - computeCoveredBlocks, - bbstartToCodeLabelMap:BasicBlockStartsToCodeLabelsMap) tryspec state0 = - - let (blocks, remainingBasicBlockStarts) = state0 - let tryBlocks, otherBlocks = computeCoveredBlocks (codeOffsetView.labelsToRange tryspec.exnRange) blocks - if isNil tryBlocks then (dprintn "try block specification covers no real code"; state0) else - let getClause r otherBlocks = - let clauseBlocks, otherBlocks = computeCoveredBlocks (codeOffsetView.labelsToRange r) otherBlocks - if isNil clauseBlocks then - failwith "clause block specification covers no real code"; - (* The next line computes the code label for the entry to the clause *) - let clauseEntryLabel = bbstartToCodeLabelMap.lab2cl (fst r) - // Now compute the overall clause, with labels still visible. - let clauseBlock = mkGroupBlock ([],List.map snd clauseBlocks) - (* if logging then dprintf "-- clause entry label is %s" clauseEntryLabel; *) - (clauseEntryLabel, clauseBlocks, clauseBlock), otherBlocks - let tryCodeBlocks = List.map snd tryBlocks - let tryEntryLabel = bbstartToCodeLabelMap.lab2cl (fst tryspec.exnRange) - let tryHiddn = CodeLabels.remove tryEntryLabel (List.foldBack (entriesOfCodeAsSet >> CodeLabels.union) tryCodeBlocks CodeLabels.empty) - let tryBlock = mkGroupBlock (CodeLabels.toList tryHiddn,tryCodeBlocks) - - match tryspec.exnClauses with - | Finally _ :: _ :: _ -> failwith "finally clause combined with others" - | [ Finally r ] | [ Fault r ] -> - - let maker = - match tryspec.exnClauses with - [ Finally _ ] -> mkTryFinallyBlock - | [ Fault _ ] -> mkTryFaultBlock - | _ -> failwith "" - - let (clauseEntryLabel, clauseBlocks, clauseBlock), otherBlocks = getClause r otherBlocks - let newBlockRange = coverageOfCodes (tryBlocks@clauseBlocks) - // The next construction joins the blocks together. - // It automatically hides any internal labels used in the - // clause blocks. Only the entry to the clause is kept visible. - // We hide the entries to the try block up above. - let newBlock = maker (tryBlock,clauseEntryLabel,clauseBlock) - // None of the entries to the clause block are visible outside the - // entire try-clause construct, nor the other entries to the try block - // apart from the one at the. top - let newStarts = CodeLabels.diff remainingBasicBlockStarts (CodeLabels.union tryHiddn (entriesOfCodeAsSet clauseBlock)) - // Now return the new block, the remaining blocks and the new set - // of entries. - addBlocks otherBlocks [(newBlockRange, newBlock)], newStarts - - | clauses when clauses |> List.forall (function | FilterCatch _ -> true | TypeCatch _ -> true | _ -> false) -> - - let clause_infos, otherBlocks (*(prior,posterior)*) = - List.fold - (fun (sofar,otherBlocks) cl -> - match cl with - | FilterCatch(r1,r2) -> - let ((lab1,_,bl1) as _info1),otherBlocks = getClause r1 otherBlocks - let info2,otherBlocks = getClause r2 otherBlocks - (sofar@[(Choice1Of2 (lab1,bl1),info2)]), otherBlocks - | TypeCatch(typ,r2) -> - let info2,otherBlocks = getClause r2 otherBlocks - (sofar@[(Choice2Of2 typ,info2)]), otherBlocks - | _ -> failwith "internal error") - ([],otherBlocks) - clauses - let newBlockRange = - // Ignore filter blocks when computing this range - // REVIEW: They must always come before the catch blocks. - coverageOfCodes - (tryBlocks@ - ((List.collect (fun (_,(_,blocks2,_)) -> blocks2) clause_infos))) - - // The next construction joins the blocks together. - // It automatically hides any internal labels used in the - // clause blocks. Only the entry to the clause is kept visible. - let newBlock = - mkTryMultiFilterCatchBlock - (tryBlock, - List.map - (fun (choice,(lab2,_,bl2)) -> choice, (lab2,bl2)) - clause_infos) - // None of the entries to the filter or catch blocks are - // visible outside the entire exception construct. - let newStarts = - CodeLabels.diff remainingBasicBlockStarts - (CodeLabels.union tryHiddn - (List.foldBack - (fun (flt,(_,_,ctch_blck)) acc -> - CodeLabels.union - (match flt with - | Choice1Of2 (_,flt_block) -> entriesOfCodeAsSet flt_block - | Choice2Of2 _ -> CodeLabels.empty) - (CodeLabels.union (entriesOfCodeAsSet ctch_blck) acc)) - clause_infos - CodeLabels.empty)) - // Now return the new block, the remaining blocks and the new set - // of entries. - addBlocks otherBlocks [ (newBlockRange, newBlock)], newStarts - | _ -> failwith "invalid pattern of exception constructs" - - - -let doStructure' (codeOffsetView:CodeOffsetViewOfLabelledItems, - computeCoveredBlocks, - coverageOfCodes, - addBlocks, - bbstartToCodeLabelMap:BasicBlockStartsToCodeLabelsMap) - structspecs - blockState = - - (* Stage 2b - Given an innermost tryspec, collect together the *) - (* blocks covered by it. Preserve the essential ordering of blocks. *) - let blockForInnerLocSpec locspec ((blocks, remainingBasicBlockStarts) as state0) = - let scopeBlocks, otherBlocks (*(prior,posterior)*) = computeCoveredBlocks (codeOffsetView.labelsToRange locspec.locRange) blocks - if isNil scopeBlocks then (dprintn "scope block specification covers no real code"; state0) else - let newBlock = mkScopeBlock (locspec.locInfos,mkGroupBlock ([],List.map snd scopeBlocks)) - let newBlockRange = coverageOfCodes scopeBlocks - addBlocks otherBlocks [ (newBlockRange, newBlock)], remainingBasicBlockStarts - - // Require items by increasing inclusion-order. - // Order by size/extent. - // a) size-ordering implies containment-ordering. - // b) size-ordering is total, so works with List.sort - let buildOrder = Order.orderOn codeOffsetView.extent_structspec int_order - - (* checkOrder: checking is O(n^2) *) -(* - let rec checkOrder = function - | [] -> () - | sA::sBs -> List.iter (fun sB -> - if codeOffsetView.structspec_inside_structspec sB sA && not (codeOffsetView.structspec_inside_structspec sA sB) then ( - dprintf "sA = %s\n" (codeOffsetView.string_of_structspec sA); - dprintf "sB = %s\n" (codeOffsetView.string_of_structspec sB); - assert false - )) sBs; - checkOrder sBs -*) - - let structspecs = List.sortWithOrder buildOrder structspecs - - (* if sanity_check_order then checkOrder structspecs; *) (* note: this check is n^2 *) - let buildBlock blockState = function - | SEH tryspec -> blockForInnerTrySpec (codeOffsetView,coverageOfCodes,addBlocks,computeCoveredBlocks,bbstartToCodeLabelMap) tryspec blockState - | LOCAL locspec -> blockForInnerLocSpec locspec blockState - List.fold buildBlock blockState structspecs - // REVIEW: this function shows up on performance traces. If we eliminated the last ILX->IL rewrites from the -// F# compiler we could get rid of this structured code representation from Abstract IL altogether, and +// F# compiler we could get rid of this structured code representation from Abstract IL altogether and // never convert F# code into this form. -let buildILCode methName lab2pc instrs tryspecs localspecs = +let buildILCode (_methName:string) lab2pc instrs tryspecs localspecs : ILCode = + { Labels = lab2pc + Instrs = instrs + Exceptions = tryspecs + Locals = localspecs } - let bbstartToCodeLabelMap = BasicBlockStartsToCodeLabelsMap(instrs,tryspecs,localspecs,lab2pc) - let codeOffsetView = CodeOffsetViewOfLabelledItems(lab2pc) - - let basicInstructions = Array.map bbstartToCodeLabelMap.remapLabels instrs - - (* DIAGNOSTICS: END -------------------------------- *) - - let buildCodeFromInstructionArray instrs = - - // Consume instructions until we hit the end of the basic block, either - // by hitting a control-flow instruction or by hitting the start of the - // next basic block by fall-through. - let rec consumeBBlockInstrs instrs rinstrs (pc:int) nextBBstartPc = - (* rinstrs = accumulates instructions in reverse order *) - if pc = (Array.length instrs) then - dprintn "* WARNING: basic block at end of method ends without a leave, branch, return or throw. Adding throw\n"; - pc,List.rev (I_throw :: rinstrs) - // The next test is for drop-through at end of bblock, when we just insert - // a branch to the next bblock. - elif (match nextBBstartPc with Some pc' -> pc = pc' | _ -> false) then - if logging then dprintf "-- pushing br, pc = nextBBstartPc = %d\n" pc; - pc,List.rev (I_br (bbstartToCodeLabelMap.pc2cl pc) :: rinstrs) - else - // Otherwise bblocks end with control-flow. - let i = instrs.[pc] - let pc' = pc + 1 - if instrIsBasicBlockEnd i then - if instrIsTailcall i then - if pc' = instrs.Length || (match instrs.[pc'] with I_ret -> false | _ -> true) then - failwithf "a tailcall must be followed by a return, instrs = %A" instrs - elif (match nextBBstartPc with Some pc'' -> pc' = pc'' | _ -> false) then - // In this obscure case, someone branches to the return instruction - // following the tailcall, so we'd better build a basic block - // containing just that return instruction. - pc', List.rev (i :: rinstrs) - else - // Otherwise skip the return instruction, but keep the tailcall. - pc'+1, List.rev (i :: rinstrs) - else - pc', List.rev (i :: rinstrs) - else - // recursive case - consumeBBlockInstrs instrs (i::rinstrs) pc' nextBBstartPc - - (* type block = (int * int) * Code // a local type (alias) would be good, good for intelisense too *) - let rec consumeOneBlock bbstartPc nextBBstartPc currentPc = - if currentPc = (Array.length instrs) then None - elif bbstartPc < currentPc then failwith "internal error: bad basic block structure (missing bblock start marker?)" - elif bbstartPc > currentPc then - (* dprintn ("* ignoring unreachable instruction in method: "^ methName); *) - consumeOneBlock bbstartPc nextBBstartPc (currentPc + 1) - else - let pc', bblockInstrs = consumeBBlockInstrs instrs [] bbstartPc nextBBstartPc - if logging then dprintf "-- making bblock, entry label is %s, length = %d, bbstartPc = %d\n" (formatCodeLabel (bbstartToCodeLabelMap.pc2cl bbstartPc)) (List.length bblockInstrs) bbstartPc; - let bblock = mkBasicBlock {Label= bbstartToCodeLabelMap.pc2cl bbstartPc; Instructions=Array.ofList bblockInstrs} - - let bblockRange = (bbstartPc, pc') - // Return the bblock and the range of instructions that the bblock covered. - // Also return any remaining instructions and the pc' for the first - // such instruction. - Some ((bblockRange, bblock), pc') - - let fetchBasicBlocks bbstartToCodeLabelMap currentPc = - let rec loop bbstartToCodeLabelMap currentPc acc = - match bbstartToCodeLabelMap with - | [] -> - (* if currentPc <> Array.length instrs then - dprintn ("* ignoring instructions at end of method: "+ methName); *) - List.rev acc - | h::t -> - let h2 = match t with [] -> None | h2:: _ -> assert (not (h = h2)); Some h2 - match consumeOneBlock h h2 currentPc with - | None -> List.rev acc - | Some (bblock, currentPc') -> loop t currentPc' (bblock :: acc) - loop bbstartToCodeLabelMap currentPc [] - - let inside range (brange,_) = - if rangeInsideRange brange range then true else - if disjoint_range brange range then false else - failwith "exception block specification overlaps the range of a basic block" - - (* A "blocks" contain blocks, ordered on startPC. - * Recall, a block is (range,code) where range=(pcStart,pcLast+1). *) - let addBlock m (((startPC,_endPC),_code) as block) = - match Zmap.tryFind startPC m with - | None -> Zmap.add startPC [block] m - | Some blocks -> Zmap.add startPC (block :: blocks) m in (* NOTE: may reverse block *) - - let addBlocks m blocks = List.fold addBlock m blocks - - let mkBlocks blocks = - let emptyBlocks = (Zmap.empty int_order : Zmap) - List.fold addBlock emptyBlocks blocks - - let sanityCheck = false (* linear check - REVIEW: set false and elim checks *) - - let computeCoveredBlocks ((start_pc,end_pc) as range) (blocks: Zmap ) = - // It is assumed that scopes never overlap. - // locinfo scopes could overlap if there is a bug elsewhere. - // If overlaps are discovered, an exception is raised. see NOTE#overlap. - let pcCovered,blocks = popRangeM start_pc (end_pc - 1) blocks - let coveredBlocks = pcCovered |> List.concat - // Look for bad input, e.g. overlapping locinfo scopes. - let overlapBlocks = List.filter (inside range >> not) coveredBlocks - if not (isNil overlapBlocks) then notFound(); (* see NOTE#overlap *) - if sanityCheck then ( - let assertIn block = assert (inside range block) - let assertOut block = assert (not (inside range block)) - List.iter assertIn coveredBlocks; - Zmap.iter (fun _ bs -> List.iter assertOut bs) blocks - ); - coveredBlocks,blocks - - let coverageOfCodes blocks = - match blocks with - | [] -> failwith "start_of_codes" - | [(r,_)] -> r - | ((r,_)::t) -> List.foldBack (fun (x,_) acc -> merge_ranges x acc) t r - - delayInsertedToWorkaroundKnownNgenBug "Delay4i3" <| fun () -> - - let doStructure = doStructure' (codeOffsetView, computeCoveredBlocks,coverageOfCodes,addBlocks,bbstartToCodeLabelMap) - - (* Apply stage 1. Compute the blocks not taking exceptions into account. *) - let bblocks = - fetchBasicBlocks (List.sort bbstartToCodeLabelMap.BasicBlockStartPositions) 0 - - let bblocks = mkBlocks bblocks - (* Apply stage 2. Compute the overall morphed blocks. *) - let morphedBlocks,remaining_entries = - let specs1 = List.map (fun x -> SEH x) tryspecs - let specs2 = List.map (fun x -> LOCAL x) localspecs - - try - doStructure (specs1 @ specs2) (bblocks,bbstartToCodeLabelMap.BasicBlockStartCodeLabels) - with :? KeyNotFoundException-> - // NOTE#overlap. - // Here, "Not_found" indicates overlapping scopes were found. - // Maybe the calling code got the locspecs scopes wrong. - // Try recovery by discarding locspec info... - let string_of_tryspec _tryspec = "tryspec" - let stringOfRange (l1,l2) = - let pc1,pc2 = codeOffsetView.labelsToRange ((l1,l2)) - formatCodeLabel l1+"("+string pc1+")-"+ formatCodeLabel l2+"("+string pc2+")" - let string_of_locspec locspec = "local "+(String.concat ";" (locspec.locInfos |> List.map (fun l -> l.LocalName)))+": "+ stringOfRange locspec.locRange - - dprintf "\nERROR: could not find an innermost exception block or local scope, specs = \n%s\nTrying again without locals." - (String.concat "\n" (List.map string_of_tryspec tryspecs @ List.map string_of_locspec localspecs)); - doStructure specs1 (bblocks,bbstartToCodeLabelMap.BasicBlockStartCodeLabels) - - delayInsertedToWorkaroundKnownNgenBug "Delay4k" <| fun () -> - - let morphedBlocks = Zmap.values morphedBlocks |> List.concat in (* NOTE: may mixup order *) - (* Now join up all the remaining blocks into one block with one entry. *) - if logging then dprintn "-- computing entry label"; - if logging then dprintn ("-- entry label is "+formatCodeLabel bbstartToCodeLabelMap.InitialCodeLabel); - mkGroupBlock - (CodeLabels.toList (CodeLabels.remove bbstartToCodeLabelMap.InitialCodeLabel remaining_entries),List.map snd morphedBlocks) - - - try buildCodeFromInstructionArray basicInstructions - with e -> - dprintn ("* error while converting instructions to code for method: " + methName); - reraise() // -------------------------------------------------------------------- // Detecting Delegates @@ -4223,7 +3402,6 @@ let sigptr_get_serstring_possibly_null bytes sigptr = // Get the public key token from the public key. //--------------------------------------------------------------------- - let mkRefToILAssembly (m: ILAssemblyManifest) = ILAssemblyRef.Create(m.Name, None, (match m.PublicKey with Some k -> Some (PublicKey.KeyAsToken(k)) | None -> None), m.Retargetable, m.Version, m.Locale) @@ -4328,7 +3506,7 @@ let rec encodeCustomAttrElemType x = Array.append [| et_SZARRAY |] (encodeCustomAttrElemType elemType) | _ -> failwith "encodeCustomAttrElemType: unrecognized custom element type" -/// Given a custom attribute element, work out the type of the .NET argument for that element +/// Given a custom attribute element, work out the type of the .NET argument for that element. let rec encodeCustomAttrElemTypeForObject x = match x with | ILAttribElem.String _ -> [| et_STRING |] @@ -4519,7 +3697,7 @@ type ILGlobals with member this.mkCompilerGeneratedAttribute () = mkILCustomAttribute this (tref_CompilerGeneratedAttribute this, [], [], []) -// Bug 2129. Requests attributes to be added to compiler generated methods +// Requests attributes to be added to compiler generated methods. let addGeneratedAttrs ilg (attrs: ILAttributes) = let attribs = match ilg.generatedAttribsCache with @@ -4542,13 +3720,13 @@ let addFieldNeverAttrs ilg (fdef:ILFieldDef) = {fdef with CustomAttrs = add_neve // PermissionSet is a 'blob' having the following format: -// • A byte containing a period (.). -// • A compressed int32 containing the number of attributes encoded in the blob. -// • An array of attributes each containing the following: -// o A String, which is the fully-qualified type name of the attribute. (Strings are encoded -// as a compressed int to indicate the size followed by an array of UTF8 characters.) -// o A set of properties, encoded as the named arguments to a custom attribute would be (as -// in §23.3, beginning with NumNamed). +// - A byte containing a period (.). +// - A compressed int32 containing the number of attributes encoded in the blob. +// - An array of attributes each containing the following: +// - A String, which is the fully-qualified type name of the attribute. (Strings are encoded +// as a compressed int to indicate the size followed by an array of UTF8 characters.) +// - A set of properties, encoded as the named arguments to a custom attribute would be (as +// in §23.3, beginning with NumNamed). let mkPermissionSet (ilg: ILGlobals) (action,attributes: list<(ILTypeRef * (string * ILType * ILAttribElem) list)>) = let bytes = [| yield (byte '.'); @@ -4562,7 +3740,7 @@ let mkPermissionSet (ilg: ILGlobals) (action,attributes: list<(ILTypeRef * (stri yield! z_unsigned_int bytes.Length; yield! bytes |] - PermissionSet(action,bytes) + ILPermission.PermissionSet(action,bytes) // Parse an IL type signature argument within a custom attribute blob @@ -4601,9 +3779,9 @@ type ILTypeSigParser(tstring : string) = // mscorlib, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089" // // Note that - // • Since we're only reading valid IL, we assume that the signature is properly formed - // • For type parameters, if the type is non-local, it will be wrapped in brackets ([]) - // • Still needs testing with jagged arrays and byref parameters + // Since we're only reading valid IL, we assume that the signature is properly formed + // For type parameters, if the type is non-local, it will be wrapped in brackets ([]) + // Still needs testing with jagged arrays and byref parameters member private x.ParseType() = // Does the type name start with a leading '['? If so, ignore it @@ -4642,7 +3820,7 @@ type ILTypeSigParser(tstring : string) = step() drop() - Some(ILArrayShape(List.repeat rank (Some 0, None))) + Some(ILArrayShape(List.replicate rank (Some 0, None))) else None @@ -4833,16 +4011,16 @@ type ILReferences = ModuleReferences: ILModuleRef list; } type ILReferencesAccumulator = - { refsA: Hashset; - refsM: Hashset; } + { refsA: HashSet; + refsM: HashSet; } let emptyILRefs = { AssemblyReferences=[]; ModuleReferences = []; } (* Now find references. *) -let refs_of_assref s x = Hashset.add s.refsA x -let refs_of_modref s x = Hashset.add s.refsM x +let refs_of_assref (s:ILReferencesAccumulator) x = s.refsA.Add x |> ignore +let refs_of_modref (s:ILReferencesAccumulator) x = s.refsM.Add x |> ignore let refs_of_scoref s x = match x with @@ -4923,7 +4101,7 @@ and refs_of_instr s x = | I_ldarga _|I_ldarg _|I_leave _|I_br _ | I_brcmp _|I_rethrow|I_refanytype|I_ldlen|I_throw|I_initblk _ |I_cpblk _ | I_localloc|I_ret |I_endfilter|I_endfinally|I_arglist - | I_other _ | I_break + | I_break | AI_add | AI_add_ovf | AI_add_ovf_un | AI_and | AI_div | AI_div_un | AI_ceq | AI_cgt | AI_cgt_un | AI_clt | AI_clt_un | AI_conv _ | AI_conv_ovf _ | AI_conv_ovf_un _ | AI_mul | AI_mul_ovf | AI_mul_ovf_un | AI_rem | AI_rem_un | AI_shl | AI_shr | AI_shr_un | AI_sub | AI_sub_ovf | AI_sub_ovf_un | AI_xor | AI_or | AI_neg | AI_not @@ -4931,27 +4109,14 @@ and refs_of_instr s x = | I_seqpoint _ | EI_ldlen_multi _ -> () -and refs_of_il_block s c = - match c with - | ILBasicBlock bb -> Array.iter (refs_of_instr s) bb.Instructions - | GroupBlock (_,l) -> List.iter (refs_of_il_code s) l - | RestrictBlock (_nms,c) -> refs_of_il_code s c - | TryBlock (l,r) -> - refs_of_il_code s l; - match r with - | FaultBlock flt -> refs_of_il_code s flt - | FinallyBlock flt -> refs_of_il_code s flt - | FilterCatchBlock clauses -> - clauses |> List.iter (fun (flt,ctch) -> - refs_of_il_code s ctch; - match flt with - | CodeFilter fltcode -> refs_of_il_code s fltcode - | TypeFilter ty -> refs_of_typ s ty) - -and refs_of_il_code s c = refs_of_il_block s c - -and refs_of_ilmbody s il = - ILList.iter (refs_of_local s) il.Locals; +and refs_of_il_code s (c: ILCode) = + c.Instrs |> Array.iter (refs_of_instr s) + c.Exceptions |> List.iter (fun e -> e.Clause |> (function + | ILExceptionClause.TypeCatch (ilty, _) -> refs_of_typ s ilty + | _ -> ())) + +and refs_of_ilmbody s (il: ILMethodBody) = + ILList.iter (refs_of_local s) il.Locals refs_of_il_code s il.Code and refs_of_local s loc = refs_of_typ s loc.Type @@ -5050,11 +4215,12 @@ and refs_of_manifest s m = let computeILRefs modul = let s = - { refsA = Hashset.create 10; - refsM = Hashset.create 5; } + { refsA = HashSet<_>(HashIdentity.Structural) + refsM = HashSet<_>(HashIdentity.Structural) } + refs_of_modul s modul; - { AssemblyReferences = Hashset.fold (fun x acc -> x::acc) s.refsA []; - ModuleReferences = Hashset.fold (fun x acc -> x::acc) s.refsM [] } + { AssemblyReferences = Seq.fold (fun acc x -> x::acc) [] s.refsA + ModuleReferences = Seq.fold (fun acc x -> x::acc) [] s.refsM } let tspan = System.TimeSpan(System.DateTime.Now.Ticks - System.DateTime(2000,1,1).Ticks) diff --git a/src/absil/il.fsi b/src/absil/il.fsi index 187babced9..6a24738cda 100755 --- a/src/absil/il.fsi +++ b/src/absil/il.fsi @@ -98,18 +98,6 @@ type ILSourceMarker = member EndLine: int member EndColumn: int -/// Extensibility: ignore these unless you are generating ILX -/// structures directly. -[] -type IlxExtensionType = - interface System.IComparable - -/// Represents an extension to the algebra of type kinds -type IlxExtensionTypeKind - -/// Represents an extension to the algebra of instructions -type IlxExtensionInstr - [] type PublicKey = | PublicKey of byte[] @@ -286,18 +274,18 @@ type ILGenericVariance = /// Type refs, i.e. references to types in some .NET assembly [] type ILTypeRef = - /// Create a ILTypeRef + /// Create a ILTypeRef. static member Create : scope: ILScopeRef * enclosing: string list * name: string -> ILTypeRef /// Where is the type, i.e. is it in this module, in another module in this assembly or in another assembly? member Scope: ILScopeRef /// The list of enclosing type names for a nested type. If non-nil then the first of these also contains the namespace. member Enclosing: string list - /// The name of the type. This also contains the namespace if Enclosing is empty + /// The name of the type. This also contains the namespace if Enclosing is empty. member Name: string - /// The name of the type in the assembly using the '.' notation for nested types + /// The name of the type in the assembly using the '.' notation for nested types. member FullName: string - /// The name of the type in the assembly using the '+' notation for nested types + /// The name of the type in the assembly using the '+' notation for nested types. member BasicQualifiedName : string member QualifiedName: string #if EXTENSIONTYPING @@ -349,7 +337,7 @@ and | TypeVar of uint16 /// Custom modifiers. | Modified of - /// True if modifier is "required" + /// True if modifier is "required". bool * /// The class of the custom modifier. ILTypeRef * @@ -428,7 +416,7 @@ type ILFieldRef = /// The information at the callsite of a method // // A ILMethodSpec is everything given at the callsite (apart from whether the call is a tailcall and whether it is passing -// varargs - see the instruction set below). It is made up of +// varargs - see the instruction set below). It is made up of: // 1) a (possibly generic) ILMethodRef // 2) a "usage type" that indicates the how the type containing the declaration is being used (as // a value class, a boxed value class, an instantiated generic class or whatever - see below) @@ -589,8 +577,8 @@ type ILInstr = // Control transfer | I_br of ILCodeLabel | I_jmp of ILMethodSpec - | I_brcmp of ILComparisonInstr * ILCodeLabel * ILCodeLabel // second label is fall-through - | I_switch of (ILCodeLabel list * ILCodeLabel) // last label is fallthrough + | I_brcmp of ILComparisonInstr * ILCodeLabel + | I_switch of ILCodeLabel list | I_ret // Method call @@ -633,11 +621,12 @@ type ILInstr = // Generalized array instructions. In AbsIL these instructions include // both the single-dimensional variants (with ILArrayShape == ILArrayShape.SingleDimensional) - // and calls to the "special" multi-dimensional "methods" such as + // and calls to the "special" multi-dimensional "methods" such as: // newobj void string[,]::.ctor(int32, int32) // call string string[,]::Get(int32, int32) // call string& string[,]::Address(int32, int32) // call void string[,]::Set(int32, int32,string) + // // The IL reader transforms calls of this form to the corresponding // generalized instruction with the corresponding ILArrayShape // argument. This is done to simplify the IL and make it more uniform. @@ -677,185 +666,39 @@ type ILInstr = // EXTENSIONS, e.g. MS-ILX | EI_ilzero of ILType | EI_ldlen_multi of int32 * int32 - | I_other of IlxExtensionInstr -// REVIEW: remove this open-ended way of extending the IL and just combine with ILX -type ILInstrSetExtension<'Extension> = - { instrExtDests: ('Extension -> ILCodeLabel list); - instrExtFallthrough: ('Extension -> ILCodeLabel option); - instrExtIsTailcall: ('Extension -> bool); - instrExtRelabel: (ILCodeLabel -> ILCodeLabel) -> 'Extension -> 'Extension; } -val RegisterInstructionSetExtension: ILInstrSetExtension<'Extension> -> ('Extension -> IlxExtensionInstr) * (IlxExtensionInstr -> bool) * (IlxExtensionInstr -> 'Extension) - -/// A list of instructions ending in an unconditionally -/// branching instruction. A basic block has a label which must be unique -/// within the method it is located in. Only the first instruction of -/// a basic block can be the target of a branch. -// -// Details: The last instruction is always a control flow instruction, -// i.e. branch, tailcall, throw etc. -// -// For example -// B1: ldarg 1 -// pop -// ret -// -// will be one basic block: -// ILBasicBlock("B1", [| I_ldarg(1); I_arith(AI_pop); I_ret |]) - -type ILBasicBlock = - { Label: ILCodeLabel; - Instructions: ILInstr[] } - member Fallthrough: ILCodeLabel option +[] +type ILExceptionClause = + | Finally of (ILCodeLabel * ILCodeLabel) + | Fault of (ILCodeLabel * ILCodeLabel) + | FilterCatch of (ILCodeLabel * ILCodeLabel) * (ILCodeLabel * ILCodeLabel) + | TypeCatch of ILType * (ILCodeLabel * ILCodeLabel) +[] +type ILExceptionSpec = + { Range: (ILCodeLabel * ILCodeLabel); + Clause: ILExceptionClause } /// Indicates that a particular local variable has a particular source -/// language name within a GroupBlock. This does not effect local +/// language name within a given set of ranges. This does not effect local /// variable numbering, which is global over the whole method. -type ILDebugMapping = +[] +type ILLocalDebugMapping = { LocalIndex: int; LocalName: string; } -/// ILCode -/// -/// The code for a method is made up of a "code" object. Each "code" -/// object gives the contents of the method in a "semi-structured" form, i.e. -/// 1. The structure implicit in the IL exception handling tables -/// has been made explicit -/// 2. No relative offsets are used in the code: all branches and -/// switch targets are made explicit as labels. -/// 3. All "fallthroughs" from one basic block to the next have -/// been made explicit, by adding extra "branch" instructions to -/// the end of basic blocks which simply fallthrough to another basic -/// block. -/// -/// You can convert a straight-line sequence of instructions to structured -/// code by using buildILCode and -/// Most of the interesting code is contained in BasicBlocks. If you're -/// just interested in getting started with the format then begin -/// by simply considering methods which do not contain any branch -/// instructions, or methods which do not contain any exception handling -/// constructs. -/// -/// The above format has the great advantage that you can insert and -/// delete new code blocks without needing to fixup relative offsets -/// or exception tables. -/// -/// ILBasicBlock(bblock) -/// See above -/// -/// GroupBlock(localDebugInfo, blocks) -/// A set of blocks, with interior branching between the blocks. For example -/// B1: ldarg 1 -/// br B2 -/// -/// B2: pop -/// ret -/// -/// will be two basic blocks -/// let b1 = ILBasicBlock("B1", [| I_ldarg(1); I_br("B2") |]) -/// let b2 = ILBasicBlock("B2", [| I_arith(AI_pop); I_ret |]) -/// GroupBlock([], [b1; b2]) -/// -/// A GroupBlock can include a list of debug info records for locally -/// scoped local variables. These indicate that within the given blocks -/// the given local variables are used for the given Debug info -/// will only be recorded for local variables -/// declared in these nodes, and the local variable will only appear live -/// in the debugger for the instructions covered by this node. So if you -/// omit or erase these nodes then no debug info will be emitted for local -/// variables. If necessary you can have one outer ScopeBlock which specifies -/// the information for all the local variables -/// -/// Not all the destination labels used within a group of blocks need -/// be satisfied by that group alone. For example, the interior "try" code -/// of "try"-"catch" construct may be: -/// B1: ldarg 1 -/// br B2 -/// -/// B2: pop -/// leave B3 -/// -/// Again there will be two basic blocks grouped together: -/// let b1 = ILBasicBlock("B1", [| I_ldarg(1); I_br("B2") |]) -/// let b2 = ILBasicBlock("B2", [| I_arith(AI_pop); I_leave("B3") |]) -/// GroupBlock([], [b1; b2]) -/// Here the code must be embedded in a method where "B3" is a label -/// somewhere in the method. -/// -/// RestrictBlock(labels,code) -/// This block hides labels, i.e. the given set of labels represent -/// wiring which is purely internal to the given code block, and may not -/// be used as the target of a branch by any blocks which this block -/// is placed alongside. -/// -/// For example, if a method is made up of: -/// B1: ldarg 1 -/// br B2 -/// -/// B2: ret -/// -/// then the label "B2" is internal. The overall code will -/// be two basic blocks grouped together, surrounded by a RestrictBlock. -/// The label "B1" is then the only remaining visible entry to the method -/// and execution will begin at that label. -/// -/// let b1 = ILBasicBlock("B1", [| I_ldarg(1); I_br("B2") |]) -/// let b2 = ILBasicBlock("B2", [| I_arith(AI_pop); I_leave("B3") |]) -/// let gb1 = GroupBlock([], [b1; b2]) -/// RestrictBlock(["B2"], gb1) -/// -/// RestrictBlock is necessary to build well-formed code. -/// -/// TryBlock(trycode,seh) -/// -/// A try-catch, try-finally or try-fault block. -/// If an exception is raised while executing -/// an instruction in 'trycode' then the exception handler given by -/// 'seh' is executed. -/// -/// Well-formedness conditions for code: -/// -/// Well-formed code includes nodes which explicitly "hide" interior labels. -/// For example, the code object for a method may have only one entry -/// label which is not hidden, and this label will be the label where -/// execution begins. -/// -/// Both filter and catch blocks must have one -/// and only one entry. These entry labels are not visible -/// outside the filter and catch blocks. Filter has no -/// exits (it always uses endfilter), catch may have exits. -/// The "try" block can have multiple entries, i.e. you can branch -/// into a try from outside. They can have multiple exits, each of -/// which will be a "leave". -/// -type ILCode = - | ILBasicBlock of ILBasicBlock - | GroupBlock of ILDebugMapping list * ILCode list - | RestrictBlock of ILCodeLabel list * ILCode - | TryBlock of ILCode * ILExceptionBlock - -/// The 'seh' specification can have several forms: -/// -/// FilterCatchBlock -/// A multi-try-filter-catch block. Execute the -/// filters in order to determine which 'catch' block to catch the -/// exception with. There are two kinds of filters - one for -/// filtering exceptions by type and one by an instruction sequence. -/// Note that filter blocks can't contain any exception blocks. -/// -and ILExceptionBlock = - | FaultBlock of ILCode - | FinallyBlock of ILCode - | FilterCatchBlock of (ILFilterBlock * ILCode) list +[] +type ILLocalDebugInfo = + { Range: (ILCodeLabel * ILCodeLabel); + DebugMappings: ILLocalDebugMapping list } -and ILFilterBlock = - | TypeFilter of ILType - | CodeFilter of ILCode - -val labelsOfCode: ILCode -> ILCodeLabel list -val uniqueEntryOfCode: ILCode -> ILCodeLabel +[] +type ILCode = + { Labels: Dictionary + Instrs:ILInstr[] + Exceptions: ILExceptionSpec list + Locals: ILLocalDebugInfo list } /// Field Init @@ -876,7 +719,7 @@ type ILFieldInit = | Double of double | Null -[] +[] type ILNativeVariant = | Empty | Null @@ -968,7 +811,7 @@ type ILNativeType = /// Local variables -[] +[] type ILLocal = { Type: ILType; IsPinned: bool; @@ -978,7 +821,7 @@ type ILLocal = type ILLocals = ILList /// IL method bodies -[] +[] type ILMethodBody = { IsZeroInit: bool; /// strictly speakin should be a uint16 @@ -1021,7 +864,7 @@ type ILAttribElem = | TypeRef of ILTypeRef option | Array of ILType * ILAttribElem list -/// Named args: values and flags indicating if they are fields or properties +/// Named args: values and flags indicating if they are fields or properties. type ILAttributeNamedArg = string * ILType * bool * ILAttribElem /// Custom attributes. See 'decodeILAttribData' for a helper to parse the byte[] @@ -1034,8 +877,9 @@ type ILAttribute = type ILAttributes = member AsList : ILAttribute list -/// Method parameters and return values +/// Method parameters and return values. +[] type ILParameter = { Name: string option; Type: ILType; @@ -1052,16 +896,15 @@ type ILParameters = ILList val typesOfILParamsRaw : ILParameters -> ILTypes val typesOfILParamsList : ILParameter list -> ILType list -/// Method return values +/// Method return values. +[] type ILReturn = { Marshal: ILNativeType option; Type: ILType; CustomAttrs: ILAttributes } /// Security ILPermissions -/// /// Attached to various structures... - [] type ILSecurityAction = | Request @@ -1087,7 +930,7 @@ type ILPermission = | PermissionSet of ILSecurityAction * byte[] /// Abstract type equivalent to ILPermission list - use helpers -/// below to construct/destruct these +/// below to construct/destruct these. [] type ILPermissions = member AsList : ILPermission list @@ -1121,7 +964,7 @@ type PInvokeThrowOnUnmappableChar = | Enabled | Disabled -[] +[] type PInvokeMethod = { Where: ILModuleRef; Name: string; @@ -1144,7 +987,7 @@ type ILOverridesSpec = member MethodRef: ILMethodRef member EnclosingType: ILType -// REVIEW: fold this into ILMethodDef +// REVIEW: fold this into ILMethodDef. type ILMethodVirtualInfo = { IsFinal: bool; IsNewSlot: bool; @@ -1159,7 +1002,7 @@ type MethodKind = | NonVirtual | Virtual of ILMethodVirtualInfo -// REVIEW: fold this into ILMethodDef +// REVIEW: fold this into ILMethodDef. [] type MethodBody = | IL of ILMethodBody @@ -1167,7 +1010,7 @@ type MethodBody = | Abstract | Native -// REVIEW: fold this into ILMethodDef +// REVIEW: fold this into ILMethodDef. [] type MethodCodeKind = | IL @@ -1178,16 +1021,16 @@ type MethodCodeKind = /// may include the bounds, if any, on the generic parameter. type ILGenericParameterDef = { Name: string; - /// At most one is the parent type, the others are interface types + /// At most one is the parent type, the others are interface types. Constraints: ILTypes; - /// Variance of type parameters, only applicable to generic parameters for generic interfaces and delegates + /// Variance of type parameters, only applicable to generic parameters for generic interfaces and delegates. Variance: ILGenericVariance; - /// Indicates the type argument must be a reference type + /// Indicates the type argument must be a reference type. HasReferenceTypeConstraint: bool; CustomAttrs : ILAttributes; - /// Indicates the type argument must be a value type, but not Nullable + /// Indicates the type argument must be a value type, but not Nullable. HasNotNullableValueTypeConstraint: bool; - /// Indicates the type argument must have a public nullary constructor + /// Indicates the type argument must have a public nullary constructor. HasDefaultConstructorConstraint: bool; } @@ -1218,7 +1061,7 @@ type ILMethodDef = IsManaged: bool; IsForwardRef: bool; SecurityDecls: ILPermissions; - /// Note: some methods are marked "HasSecurity" even if there are no permissions attached, e.g. if they use SuppressUnmanagedCodeSecurityAttribute + /// Some methods are marked "HasSecurity" even if there are no permissions attached, e.g. if they use SuppressUnmanagedCodeSecurityAttribute HasSecurity: bool; IsEntryPoint:bool; IsReqSecObj: bool; @@ -1228,7 +1071,7 @@ type ILMethodDef = IsUnmanagedExport: bool; IsSynchronized: bool; IsPreserveSig: bool; - /// .NET 2.0 feature: SafeHandle finalizer must be run + /// .NET 2.0 feature: SafeHandle finalizer must be run. IsMustRun: bool; IsNoInline: bool; @@ -1242,15 +1085,21 @@ type ILMethodDef = member MaxStack : int32 member IsZeroInit : bool - /// .cctor methods. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) form a complete, non-overlapping classification of this type + /// .cctor methods. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) + /// form a complete, non-overlapping classification of this type. member IsClassInitializer: bool - /// .ctor methods. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) form a complete, non-overlapping classification of this type + /// .ctor methods. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) + /// form a complete, non-overlapping classification of this type. member IsConstructor: bool - /// static methods. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) form a complete, non-overlapping classification of this type + /// static methods. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) + /// form a complete, non-overlapping classification of this type. member IsStatic: bool - /// instance methods that are not virtual. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) form a complete, non-overlapping classification of this type + /// instance methods that are not virtual. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) + /// form a complete, non-overlapping classification of this type. member IsNonVirtualInstance: bool - /// instance methods that are virtual or abstract or implement an interface slot. The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) form a complete, non-overlapping classification of this type + /// instance methods that are virtual or abstract or implement an interface slot. + /// The predicates (IsClassInitializer,IsConstructor,IsStatic,IsNonVirtualInstance,IsVirtual) + /// form a complete, non-overlapping classification of this type. member IsVirtual: bool member IsFinal: bool @@ -1272,7 +1121,7 @@ type ILMethodDefs = member AsList : ILMethodDef list member FindByName : string -> ILMethodDef list -/// Field definitions +/// Field definitions. [] type ILFieldDef = { Name: string; @@ -1298,7 +1147,7 @@ type ILFieldDefs = member AsList : ILFieldDef list member LookupByName : string -> ILFieldDef list -/// Event definitions +/// Event definitions. [] type ILEventDef = { Type: ILType option; @@ -1317,7 +1166,7 @@ type ILEventDefs = member AsList : ILEventDef list member LookupByName : string -> ILEventDef list -/// Property definitions +/// Property definitions. [] type ILPropertyDef = { Name: string; @@ -1351,7 +1200,7 @@ type ILMethodImplDef = type ILMethodImplDefs = member AsList : ILMethodImplDef list -/// Type Layout information +/// Type Layout information. [] type ILTypeDefLayout = | Auto @@ -1362,20 +1211,20 @@ and ILTypeDefLayoutInfo = { Size: int32 option; Pack: uint16 option } -/// Indicate the initialization semantics of a type +/// Indicate the initialization semantics of a type. [] type ILTypeInit = | BeforeField | OnAny -/// Default Unicode encoding for P/Invoke within a type +/// Default Unicode encoding for P/Invoke within a type. [] type ILDefaultPInvokeEncoding = | Ansi | Auto | Unicode -/// Type Access +/// Type Access. [] type ILTypeDefAccess = | Public @@ -1404,15 +1253,13 @@ type ILTypeDefKind = | Interface | Enum | Delegate - (* FOR EXTENSIONS, e.g. MS-ILX *) - | Other of IlxExtensionTypeKind /// Tables of named type definitions. The types and table may contain on-demand /// (lazy) computations, e.g. the actual reading of some aspects /// of a type definition may be delayed if the reader being used supports /// this. /// -/// This is an abstract type equivalent to "ILTypeDef list" +/// This is an abstract type equivalent to "ILTypeDef list". [] [] type ILTypeDefs = @@ -1420,10 +1267,10 @@ type ILTypeDefs = member AsArray : ILTypeDef[] member AsList : ILTypeDef list - /// Get some information about the type defs, but do not force the read of the type defs themselves + /// Get some information about the type defs, but do not force the read of the type defs themselves. member AsArrayOfLazyTypeDefs : (string list * string * ILAttributes * Lazy) array - /// Calls to [FindByName] will result in any laziness in the overall + /// Calls to FindByName will result in any laziness in the overall /// set of ILTypeDefs being read in in addition /// to the details for the type found, but the remaining individual /// type definitions will not be read. @@ -1444,7 +1291,7 @@ and [] IsAbstract: bool; IsSealed: bool; IsSerializable: bool; - /// Class or interface generated for COM interop + /// Class or interface generated for COM interop. IsComInterop: bool; Layout: ILTypeDefLayout; IsSpecialName: bool; @@ -1454,7 +1301,8 @@ and [] Extends: ILType option; Methods: ILMethodDefs; SecurityDecls: ILPermissions; - /// Note: some classes are marked "HasSecurity" even if there are no permissions attached, e.g. if they use SuppressUnmanagedCodeSecurityAttribute + /// Some classes are marked "HasSecurity" even if there are no permissions attached, + /// e.g. if they use SuppressUnmanagedCodeSecurityAttribute HasSecurity: bool; Fields: ILFieldDefs; MethodImpls: ILMethodImplDefs; @@ -1534,8 +1382,8 @@ type ILResourceLocation = | Assembly of ILAssemblyRef /// "Manifest ILResources" are chunks of resource data, being one of: -/// - the data section of the current module (byte[] of resource given directly) -/// - in an external file in this assembly (offset given in the ILResourceLocation field) +/// - the data section of the current module (byte[] of resource given directly). +/// - in an external file in this assembly (offset given in the ILResourceLocation field). /// - as a resources in another assembly of the same name. type ILResource = { Name: string; @@ -1543,7 +1391,7 @@ type ILResource = Access: ILResourceAccess; CustomAttrs: ILAttributes } -/// Table of resources in a module +/// Table of resources in a module. [] [] type ILResources = @@ -1561,11 +1409,11 @@ type ILAssemblyLongevity = /// The main module of an assembly is a module plus some manifest information. type ILAssemblyManifest = { Name: string; - /// This is ID of the algorithm used for the hashes of auxiliary + /// This is the ID of the algorithm used for the hashes of auxiliary /// files in the assembly. These hashes are stored in the - /// ILModuleRef.Hash fields of this assembly. These are not cryptographic - /// hashes: they are simple file hashes. The algorithm is normally - /// 0x00008004 indicating the SHA1 hash algorithm. + /// ILModuleRef.Hash fields of this assembly. These are not + /// cryptographic hashes: they are simple file hashes. The algorithm + /// is normally 0x00008004 indicating the SHA1 hash algorithm. AuxModuleHashAlgorithm: int32; SecurityDecls: ILPermissions; /// This is the public key used to sign this @@ -1613,7 +1461,7 @@ type ILModuleDef = ImageBase: int32; MetadataVersion: string; Resources: ILResources; - /// e.g. win86 resources, as the exact contents of a .res or .obj file + /// e.g. win86 resources, as the exact contents of a .res or .obj file. NativeResources: Lazy list; } member ManifestOfAssembly: ILAssemblyManifest member HasManifest : bool @@ -1640,7 +1488,7 @@ val splitNamespace: string -> string list val splitNamespaceToArray: string -> string[] -/// The splitILTypeName utility helps you split a string representing +/// The splitILTypeName utility helps you split a string representing /// a type name into the leading namespace elements (if any), the /// names of any nested types and the type name itself. This function /// memoizes and interns the splitting of the namespace portion of @@ -1649,7 +1497,7 @@ val splitILTypeName: string -> string list * string val splitILTypeNameWithPossibleStaticArguments: string -> string[] * string -/// splitTypeNameRight is like splitILTypeName except the +/// splitTypeNameRight is like splitILTypeName except the /// namespace is kept as a whole string, rather than split at dots. val splitTypeNameRight: string -> string option * string @@ -1660,7 +1508,7 @@ val isTypeNameForGlobalFunctions: string -> bool val ungenericizeTypeName: string -> string (* e.g. List`1 --> List *) /// Represents the capabilities of target framework profile. -/// Different profiles may omit some types or contain them in different assemblies +/// Different profiles may omit some types or contain them in different assemblies. type IPrimaryAssemblyTraits = abstract TypedReferenceTypeScopeRef : ILScopeRef option @@ -1692,8 +1540,8 @@ type IPrimaryAssemblyTraits = // ==================================================================== *) /// A table of common references to items in primary assebly (System.Runtime or mscorlib). -/// If you have already loaded a particular version of system runtime assembly you should reference items via an ILGlobals for that particular -/// version of system runtime assembly built using mkILGlobals. +/// If a particular version of System.Runtime.dll has been loaded then you should +/// reference items from it via an ILGlobals for that specific version built using mkILGlobals. [] type ILGlobals = { @@ -1785,7 +1633,7 @@ type ILGlobals = member mkDebuggerTypeProxyAttribute : ILType -> ILAttribute member mkDebuggerBrowsableNeverAttribute : unit -> ILAttribute -/// Build the table of commonly used references given a ILScopeRef for system runtime assembly. +/// Build the table of commonly used references given an ILScopeRef for system runtime assembly. val mkILGlobals : IPrimaryAssemblyTraits -> string option -> bool -> ILGlobals val mkMscorlibBasedTraits : ILScopeRef -> IPrimaryAssemblyTraits @@ -1793,11 +1641,11 @@ val mkMscorlibBasedTraits : ILScopeRef -> IPrimaryAssemblyTraits val EcmaILGlobals : ILGlobals /// When writing a binary the fake "toplevel" type definition (called ) -/// must come first. This function puts it first, and creates it in the returned list as an empty typedef if it -/// doesn't already exist. +/// must come first. This function puts it first, and creates it in the returned +/// list as an empty typedef if it doesn't already exist. val destTypeDefsWithGlobalFunctionsFirst: ILGlobals -> ILTypeDefs -> ILTypeDef list -/// Note: not all custom attribute data can be decoded without binding types. In particular +/// Not all custom attribute data can be decoded without binding types. In particular /// enums must be bound in order to discover the size of the underlying integer. /// The following assumes enums have size int32. val decodeILAttribData: @@ -1806,28 +1654,29 @@ val decodeILAttribData: ILAttribElem list * (* fixed args *) ILAttributeNamedArg list (* named args: values and flags indicating if they are fields or properties *) -/// Generate simple references to assemblies and modules +/// Generate simple references to assemblies and modules. val mkSimpleAssRef: string -> ILAssemblyRef val mkSimpleModRef: string -> ILModuleRef val emptyILGenericArgs: ILGenericArgs val mkILTyvarTy: uint16 -> ILType -/// Make type refs +/// Make type refs. val mkILNestedTyRef: ILScopeRef * string list * string -> ILTypeRef val mkILTyRef: ILScopeRef * string -> ILTypeRef val mkILTyRefInTyRef: ILTypeRef * string -> ILTypeRef type ILGenericArgsList = ILType list val mkILGenericArgs : ILGenericArgsList -> ILGenericArgs -/// Make type specs +/// Make type specs. val mkILNonGenericTySpec: ILTypeRef -> ILTypeSpec val mkILTySpec: ILTypeRef * ILGenericArgsList -> ILTypeSpec val mkILTySpecRaw: ILTypeRef * ILGenericArgs -> ILTypeSpec -/// Make types +/// Make types. val mkILTy: ILBoxity -> ILTypeSpec -> ILType val mkILNamedTy: ILBoxity -> ILTypeRef -> ILGenericArgsList -> ILType +val mkILNamedTyRaw: ILBoxity -> ILTypeRef -> ILGenericArgs -> ILType val mkILBoxedTy: ILTypeRef -> ILGenericArgsList -> ILType val mkILBoxedTyRaw: ILTypeRef -> ILGenericArgs -> ILType val mkILValueTy: ILTypeRef -> ILGenericArgsList -> ILType @@ -1841,7 +1690,7 @@ val mkILBoxedType : ILTypeSpec -> ILType val mkILTypes : ILType list -> ILTypes -/// Make method references and specs +/// Make method references and specs. val mkILMethRefRaw: ILTypeRef * ILCallingConv * string * int * ILTypes * ILType -> ILMethodRef val mkILMethRef: ILTypeRef * ILCallingConv * string * int * ILType list * ILType -> ILMethodRef val mkILMethSpec: ILMethodRef * ILBoxity * ILGenericArgsList * ILGenericArgsList -> ILMethodSpec @@ -1850,25 +1699,25 @@ val mkILMethSpecForMethRefInTy: ILMethodRef * ILType * ILGenericArgsList -> ILMe val mkILMethSpecInTy: ILType * ILCallingConv * string * ILType list * ILType * ILGenericArgsList -> ILMethodSpec val mkILMethSpecInTyRaw: ILType * ILCallingConv * string * ILTypes * ILType * ILGenericArgs -> ILMethodSpec -/// Construct references to methods on a given type +/// Construct references to methods on a given type . val mkILNonGenericMethSpecInTy: ILType * ILCallingConv * string * ILType list * ILType -> ILMethodSpec -/// Construct references to instance methods +/// Construct references to instance methods. val mkILInstanceMethSpecInTy: ILType * string * ILType list * ILType * ILGenericArgsList -> ILMethodSpec -/// Construct references to instance methods +/// Construct references to instance methods. val mkILNonGenericInstanceMethSpecInTy: ILType * string * ILType list * ILType -> ILMethodSpec -/// Construct references to static methods +/// Construct references to static methods. val mkILStaticMethSpecInTy: ILType * string * ILType list * ILType * ILGenericArgsList -> ILMethodSpec -/// Construct references to static, non-generic methods +/// Construct references to static, non-generic methods. val mkILNonGenericStaticMethSpecInTy: ILType * string * ILType list * ILType -> ILMethodSpec -/// Construct references to constructors +/// Construct references to constructors. val mkILCtorMethSpecForTy: ILType * ILType list -> ILMethodSpec -/// Construct references to fields +/// Construct references to fields. val mkILFieldRef: ILTypeRef * string * ILType -> ILFieldRef val mkILFieldSpec: ILFieldRef * ILType -> ILFieldSpec val mkILFieldSpecInTy: ILType * string * ILType -> ILFieldSpec @@ -1878,15 +1727,15 @@ val mkILCallSig: ILCallingConv * ILType list * ILType -> ILCallingSignature /// Make generalized verions of possibly-generic types, /// e.g. Given the ILTypeDef for List, return the type "List". - val mkILFormalBoxedTy: ILTypeRef -> ILGenericParameterDef list -> ILType +val mkILFormalNamedTy: ILBoxity -> ILTypeRef -> ILGenericParameterDef list -> ILType val mkILFormalTyparsRaw: ILTypes -> ILGenericParameterDefs val mkILFormalTypars: ILType list -> ILGenericParameterDefs val mkILFormalGenericArgsRaw: ILGenericParameterDefs -> ILGenericArgs val mkILFormalGenericArgs: ILGenericParameterDefs -> ILGenericArgsList val mkILSimpleTypar : string -> ILGenericParameterDef -/// Make custom attributes +/// Make custom attributes. val mkILCustomAttribMethRef: ILGlobals -> ILMethodSpec @@ -1904,33 +1753,20 @@ val mkILCustomAttribute: val mkPermissionSet : ILGlobals -> ILSecurityAction * (ILTypeRef * (string * ILType * ILAttribElem) list) list -> ILPermission /// Making code. -val checkILCode: ILCode -> ILCode val generateCodeLabel: unit -> ILCodeLabel val formatCodeLabel : ILCodeLabel -> string /// Make some code that is a straight line sequence of instructions. -/// The function will add a "return" if the last instruction is not an exiting instruction +/// The function will add a "return" if the last instruction is not an exiting instruction. val nonBranchingInstrsToCode: ILInstr list -> ILCode -/// Make some code that is a straight line sequence of instructions, then do -/// some control flow. The first code label is the entry label of the generated code. -val mkNonBranchingInstrsThen: ILCodeLabel -> ILInstr list -> ILInstr -> ILCode -val mkNonBranchingInstrsThenBr: ILCodeLabel -> ILInstr list -> ILCodeLabel -> ILCode - -/// Make a basic block. The final instruction must be control flow -val mkNonBranchingInstrs: ILCodeLabel -> ILInstr list -> ILCode - -/// Some more primitive helpers -val mkBasicBlock: ILBasicBlock -> ILCode -val mkGroupBlock: ILCodeLabel list * ILCode list -> ILCode - /// Helpers for codegen: scopes for allocating new temporary variables. type ILLocalsAllocator = new : preAlloc: int -> ILLocalsAllocator member AllocLocal : ILLocal -> uint16 member Close : unit -> ILLocal list -/// Derived functions for making some common patterns of instructions +/// Derived functions for making some common patterns of instructions. val mkNormalCall: ILMethodSpec -> ILInstr val mkNormalCallvirt: ILMethodSpec -> ILInstr val mkNormalCallconstraint: ILType * ILMethodSpec -> ILInstr @@ -1961,10 +1797,10 @@ val mkILLocal: ILType -> (string * int * int) option -> ILLocal val mkILLocals : ILLocal list -> ILLocals val emptyILLocals : ILLocals -/// Make a formal generic parameters +/// Make a formal generic parameters. val mkILEmptyGenericParams: ILGenericParameterDefs -/// Make method definitions +/// Make method definitions. val mkILMethodBody: initlocals:bool * ILLocals * int * ILCode * ILSourceMarker option -> ILMethodBody val mkMethodBody: bool * ILLocals * int * ILCode * ILSourceMarker option -> MethodBody @@ -1979,12 +1815,12 @@ val mkILNonGenericVirtualMethod: string * ILMemberAccess * ILParameter list * IL val mkILNonGenericInstanceMethod: string * ILMemberAccess * ILParameter list * ILReturn * MethodBody -> ILMethodDef -/// Make field definitions +/// Make field definitions. val mkILInstanceField: string * ILType * ILFieldInit option * ILMemberAccess -> ILFieldDef val mkILStaticField: string * ILType * ILFieldInit option * byte[] option * ILMemberAccess -> ILFieldDef val mkILLiteralField: string * ILType * ILFieldInit * byte[] option * ILMemberAccess -> ILFieldDef -/// Make a type definition +/// Make a type definition. val mkILGenericClass: string * ILTypeDefAccess * ILGenericParameterDefs * ILType * ILType list * ILMethodDefs * ILFieldDefs * ILTypeDefs * ILPropertyDefs * ILEventDefs * ILAttributes * ILTypeInit -> ILTypeDef val mkILSimpleClass: ILGlobals -> string * ILTypeDefAccess * ILMethodDefs * ILFieldDefs * ILTypeDefs * ILPropertyDefs * ILEventDefs * ILAttributes * ILTypeInit -> ILTypeDef val mkILTypeDefForGlobalFunctions: ILGlobals -> ILMethodDefs * ILFieldDefs -> ILTypeDef @@ -2018,7 +1854,7 @@ val mkILSimpleStorageCtorWithParamNames: ILSourceMarker option * ILTypeSpec opti val mkILDelegateMethods: ILGlobals -> ILParameter list * ILReturn -> ILMethodDef list /// Given a delegate type definition which lies in a particular scope, -/// make a reference to its constructor +/// make a reference to its constructor. val mkCtorMethSpecForDelegate: ILGlobals -> ILType * bool -> ILMethodSpec /// The toplevel "class" for a module or assembly. @@ -2082,7 +1918,7 @@ val mkILExportedTypesLazy: Lazy -> ILExportedT val mkILResources: ILResource list -> ILResources val mkILResourcesLazy: Lazy -> ILResources -/// Making modules +/// Making modules. val mkILSimpleModule: assemblyName:string -> moduleName:string -> dll:bool -> subsystemVersion : (int * int) -> useHighEntropyVA : bool -> ILTypeDefs -> int32 option -> string option -> int -> ILExportedTypesAndForwarders -> string -> ILModuleDef /// Generate references to existing type definitions, method definitions @@ -2142,20 +1978,6 @@ val rescopeILFieldRef: ILScopeRef -> ILFieldRef -> ILFieldRef // The ILCode Builder utility. //---------------------------------------------------------------------- -[] -type ILExceptionClause = - | Finally of (ILCodeLabel * ILCodeLabel) - | Fault of (ILCodeLabel * ILCodeLabel) - | FilterCatch of (ILCodeLabel * ILCodeLabel) * (ILCodeLabel * ILCodeLabel) - | TypeCatch of ILType * (ILCodeLabel * ILCodeLabel) - -type ILExceptionSpec = - { exnRange: (ILCodeLabel * ILCodeLabel); - exnClauses: ILExceptionClause list } - -type ILLocalSpec = - { locRange: (ILCodeLabel * ILCodeLabel); - locInfos: ILDebugMapping list } /// buildILCode: Build code from a sequence of instructions. /// @@ -2183,13 +2005,7 @@ type ILLocalSpec = /// The input can be badly formed in many ways: exception handlers might /// overlap, or scopes of local variables may overlap badly with /// exception handlers. -val buildILCode: - string -> - (ILCodeLabel -> int) -> - ILInstr[] -> - ILExceptionSpec list -> - ILLocalSpec list -> - ILCode +val buildILCode: string -> lab2pc: Dictionary -> instrs:ILInstr[] -> ILExceptionSpec list -> ILLocalDebugInfo list -> ILCode // -------------------------------------------------------------------- // The instantiation utilities. @@ -2208,7 +2024,7 @@ val instILType: ILGenericArgs -> ILType -> ILType /// This is a 'vendor neutral' way of referencing mscorlib. val ecmaPublicKey: PublicKey -/// Some commonly used methods +/// Some commonly used methods. val mkInitializeArrayMethSpec: ILGlobals -> ILMethodSpec val mkPrimaryAssemblyExnNewobj: ILGlobals -> string -> ILInstr @@ -2220,7 +2036,7 @@ val addFieldGeneratedAttrs : ILGlobals -> ILFieldDef -> ILFieldDef val addPropertyNeverAttrs : ILGlobals -> ILPropertyDef -> ILPropertyDef val addFieldNeverAttrs : ILGlobals -> ILFieldDef -> ILFieldDef -/// Discriminating different important built-in types +/// Discriminating different important built-in types. val isILObjectTy: ILType -> bool val isILStringTy: ILType -> bool val isILSByteTy: ILType -> bool @@ -2282,13 +2098,7 @@ type ILReferences = { AssemblyReferences: ILAssemblyRef list; ModuleReferences: ILModuleRef list; } -/// Find the full set of assemblies referenced by a module +/// Find the full set of assemblies referenced by a module. val computeILRefs: ILModuleDef -> ILReferences val emptyILRefs: ILReferences -// -------------------------------------------------------------------- -// The following functions are used to define an extension to the In reality the only extension is ILX - -type ILTypeDefKindExtension<'Extension> = TypeDefKindExtension - -val RegisterTypeDefKindExtension: ILTypeDefKindExtension<'Extension> -> ('Extension -> IlxExtensionTypeKind) * (IlxExtensionTypeKind -> bool) * (IlxExtensionTypeKind -> 'Extension) diff --git a/src/absil/ilascii.fs b/src/absil/ilascii.fs index 695b0340f7..42f63f21ee 100755 --- a/src/absil/ilascii.fs +++ b/src/absil/ilascii.fs @@ -8,7 +8,6 @@ open Internal.Utilities.Collections open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types open Microsoft.FSharp.Compiler.AbstractIL.IL diff --git a/src/absil/ilbinary.fs b/src/absil/ilbinary.fs index 01aa8161eb..157a28f180 100755 --- a/src/absil/ilbinary.fs +++ b/src/absil/ilbinary.fs @@ -62,27 +62,27 @@ module TableNames = let UserStrings = TableName 0x70 (* Special encoding of embedded UserString tokens - See 1.9 Partition III *) -/// Which tables are sorted and by which column +/// Which tables are sorted and by which column. // // Sorted bit-vector as stored by CLR V1: 00fa 0133 0002 0000 // But what does this mean? The ECMA spec does not say! // Metainfo -schema reports sorting as shown below. // But some sorting, e.g. EventMap does not seem to show let sortedTableInfo = - [ (TableNames.InterfaceImpl,0); - (TableNames.Constant, 1); - (TableNames.CustomAttribute, 0); - (TableNames.FieldMarshal, 0); - (TableNames.Permission, 1); - (TableNames.ClassLayout, 2); - (TableNames.FieldLayout, 1); - (TableNames.MethodSemantics, 2); - (TableNames.MethodImpl, 0); - (TableNames.ImplMap, 1); - (TableNames.FieldRVA, 1); - (TableNames.Nested, 0); - (TableNames.GenericParam, 2); - (TableNames.GenericParamConstraint, 0); ] + [ (TableNames.InterfaceImpl,0) + (TableNames.Constant, 1) + (TableNames.CustomAttribute, 0) + (TableNames.FieldMarshal, 0) + (TableNames.Permission, 1) + (TableNames.ClassLayout, 2) + (TableNames.FieldLayout, 1) + (TableNames.MethodSemantics, 2) + (TableNames.MethodImpl, 0) + (TableNames.ImplMap, 1) + (TableNames.FieldRVA, 1) + (TableNames.Nested, 0) + (TableNames.GenericParam, 2) + (TableNames.GenericParamConstraint, 0) ] [] type TypeDefOrRefTag(tag: int32) = member x.Tag = tag @@ -540,127 +540,127 @@ let i_ldelem_any = 0xa3 let i_stelem_any = 0xa4 let i_unbox_any = 0xa5 -let mk_ldc i = (((mkLdcInt32 (i)))) +let mk_ldc i = mkLdcInt32 i let noArgInstrs = - lazy [ i_ldc_i4_0, mk_ldc 0; - i_ldc_i4_1, mk_ldc 1; - i_ldc_i4_2, mk_ldc 2; - i_ldc_i4_3, mk_ldc 3; - i_ldc_i4_4, mk_ldc 4; - i_ldc_i4_5, mk_ldc 5; - i_ldc_i4_6, mk_ldc 6; - i_ldc_i4_7, mk_ldc 7; - i_ldc_i4_8, mk_ldc 8; - i_ldc_i4_m1, mk_ldc (0-1); - 0x0a, (mkStloc (uint16 ( 0))); - 0x0b, (mkStloc (uint16 ( 1))); - 0x0c, (mkStloc (uint16 ( 2))); - 0x0d, (mkStloc (uint16 ( 3))); - 0x06, (mkLdloc (uint16 ( 0))); - 0x07, (mkLdloc (uint16 ( 1))); - 0x08, (mkLdloc (uint16 ( 2))); - 0x09, (mkLdloc (uint16 ( 3))); - 0x02, (mkLdarg (uint16 ( 0))); - 0x03, (mkLdarg (uint16 ( 1))); - 0x04, (mkLdarg (uint16 ( 2))); - 0x05, (mkLdarg (uint16 ( 3))); - 0x2a, (I_ret); - 0x58, (AI_add); - 0xd6, (AI_add_ovf); - 0xd7, (AI_add_ovf_un); - 0x5f, (AI_and); - 0x5b, (AI_div); - 0x5c, (AI_div_un); - 0xfe01, (AI_ceq); - 0xfe02, (AI_cgt ); - 0xfe03, (AI_cgt_un); - 0xfe04, (AI_clt); - 0xfe05, (AI_clt_un); - 0x67, ((AI_conv DT_I1)); - 0x68, ((AI_conv DT_I2)); - 0x69, ((AI_conv DT_I4)); - 0x6a, ((AI_conv DT_I8)); - 0xd3, ((AI_conv DT_I)); - 0x6b, ((AI_conv DT_R4)); - 0x6c, ((AI_conv DT_R8)); - 0xd2, ((AI_conv DT_U1)); - 0xd1, ((AI_conv DT_U2)); - 0x6d, ((AI_conv DT_U4)); - 0x6e, ((AI_conv DT_U8)); - 0xe0, ((AI_conv DT_U)); - 0x76, ((AI_conv DT_R)); - 0xb3, ((AI_conv_ovf DT_I1)); - 0xb5, ((AI_conv_ovf DT_I2)); - 0xb7, ((AI_conv_ovf DT_I4)); - 0xb9, ((AI_conv_ovf DT_I8)); - 0xd4, ((AI_conv_ovf DT_I)); - 0xb4, ((AI_conv_ovf DT_U1)); - 0xb6, ((AI_conv_ovf DT_U2)); - 0xb8, ((AI_conv_ovf DT_U4)); - 0xba, ((AI_conv_ovf DT_U8)); - 0xd5, ((AI_conv_ovf DT_U)); - 0x82, ((AI_conv_ovf_un DT_I1)); - 0x83, ((AI_conv_ovf_un DT_I2)); - 0x84, ((AI_conv_ovf_un DT_I4)); - 0x85, ((AI_conv_ovf_un DT_I8)); - 0x8a, ((AI_conv_ovf_un DT_I)); - 0x86, ((AI_conv_ovf_un DT_U1)); - 0x87, ((AI_conv_ovf_un DT_U2)); - 0x88, ((AI_conv_ovf_un DT_U4)); - 0x89, ((AI_conv_ovf_un DT_U8)); - 0x8b, ((AI_conv_ovf_un DT_U)); - 0x9c, (I_stelem DT_I1); - 0x9d, (I_stelem DT_I2); - 0x9e, (I_stelem DT_I4); - 0x9f, (I_stelem DT_I8); - 0xa0, (I_stelem DT_R4); - 0xa1, (I_stelem DT_R8); - 0x9b, (I_stelem DT_I); - 0xa2, (I_stelem DT_REF); - 0x90, (I_ldelem DT_I1); - 0x92, (I_ldelem DT_I2); - 0x94, (I_ldelem DT_I4); - 0x96, (I_ldelem DT_I8); - 0x91, (I_ldelem DT_U1); - 0x93, (I_ldelem DT_U2); - 0x95, (I_ldelem DT_U4); - 0x98, (I_ldelem DT_R4); - 0x99, (I_ldelem DT_R8); - 0x97, (I_ldelem DT_I); - 0x9a, (I_ldelem DT_REF); - 0x5a, (AI_mul ); - 0xd8, (AI_mul_ovf); - 0xd9, (AI_mul_ovf_un); - 0x5d, (AI_rem ); - 0x5e, (AI_rem_un ); - 0x62, (AI_shl ); - 0x63, (AI_shr ); - 0x64, (AI_shr_un); - 0x59, (AI_sub ); - 0xda, (AI_sub_ovf); - 0xdb, (AI_sub_ovf_un); - 0x61, (AI_xor); - 0x60, (AI_or); - 0x65, (AI_neg); - 0x66, (AI_not); - i_ldnull, (AI_ldnull); - i_dup, (AI_dup); - i_pop, (AI_pop); - i_ckfinite, (AI_ckfinite); - i_nop, AI_nop; - i_break, I_break; - i_arglist, I_arglist; - i_endfilter, I_endfilter; - i_endfinally, I_endfinally; - i_refanytype, I_refanytype; - i_localloc, I_localloc; - i_throw, I_throw; - i_ldlen, I_ldlen; - i_rethrow, I_rethrow; ];; + lazy [ i_ldc_i4_0, mk_ldc 0 + i_ldc_i4_1, mk_ldc 1 + i_ldc_i4_2, mk_ldc 2 + i_ldc_i4_3, mk_ldc 3 + i_ldc_i4_4, mk_ldc 4 + i_ldc_i4_5, mk_ldc 5 + i_ldc_i4_6, mk_ldc 6 + i_ldc_i4_7, mk_ldc 7 + i_ldc_i4_8, mk_ldc 8 + i_ldc_i4_m1, mk_ldc -1 + 0x0a, mkStloc 0us + 0x0b, mkStloc 1us + 0x0c, mkStloc 2us + 0x0d, mkStloc 3us + 0x06, mkLdloc 0us + 0x07, mkLdloc 1us + 0x08, mkLdloc 2us + 0x09, mkLdloc 3us + 0x02, mkLdarg 0us + 0x03, mkLdarg 1us + 0x04, mkLdarg 2us + 0x05, mkLdarg 3us + 0x2a, I_ret + 0x58, AI_add + 0xd6, AI_add_ovf + 0xd7, AI_add_ovf_un + 0x5f, AI_and + 0x5b, AI_div + 0x5c, AI_div_un + 0xfe01, AI_ceq + 0xfe02, AI_cgt + 0xfe03, AI_cgt_un + 0xfe04, AI_clt + 0xfe05, AI_clt_un + 0x67, AI_conv DT_I1 + 0x68, AI_conv DT_I2 + 0x69, AI_conv DT_I4 + 0x6a, AI_conv DT_I8 + 0xd3, AI_conv DT_I + 0x6b, AI_conv DT_R4 + 0x6c, AI_conv DT_R8 + 0xd2, AI_conv DT_U1 + 0xd1, AI_conv DT_U2 + 0x6d, AI_conv DT_U4 + 0x6e, AI_conv DT_U8 + 0xe0, AI_conv DT_U + 0x76, AI_conv DT_R + 0xb3, AI_conv_ovf DT_I1 + 0xb5, AI_conv_ovf DT_I2 + 0xb7, AI_conv_ovf DT_I4 + 0xb9, AI_conv_ovf DT_I8 + 0xd4, AI_conv_ovf DT_I + 0xb4, AI_conv_ovf DT_U1 + 0xb6, AI_conv_ovf DT_U2 + 0xb8, AI_conv_ovf DT_U4 + 0xba, AI_conv_ovf DT_U8 + 0xd5, AI_conv_ovf DT_U + 0x82, AI_conv_ovf_un DT_I1 + 0x83, AI_conv_ovf_un DT_I2 + 0x84, AI_conv_ovf_un DT_I4 + 0x85, AI_conv_ovf_un DT_I8 + 0x8a, AI_conv_ovf_un DT_I + 0x86, AI_conv_ovf_un DT_U1 + 0x87, AI_conv_ovf_un DT_U2 + 0x88, AI_conv_ovf_un DT_U4 + 0x89, AI_conv_ovf_un DT_U8 + 0x8b, AI_conv_ovf_un DT_U + 0x9c, I_stelem DT_I1 + 0x9d, I_stelem DT_I2 + 0x9e, I_stelem DT_I4 + 0x9f, I_stelem DT_I8 + 0xa0, I_stelem DT_R4 + 0xa1, I_stelem DT_R8 + 0x9b, I_stelem DT_I + 0xa2, I_stelem DT_REF + 0x90, I_ldelem DT_I1 + 0x92, I_ldelem DT_I2 + 0x94, I_ldelem DT_I4 + 0x96, I_ldelem DT_I8 + 0x91, I_ldelem DT_U1 + 0x93, I_ldelem DT_U2 + 0x95, I_ldelem DT_U4 + 0x98, I_ldelem DT_R4 + 0x99, I_ldelem DT_R8 + 0x97, I_ldelem DT_I + 0x9a, I_ldelem DT_REF + 0x5a, AI_mul + 0xd8, AI_mul_ovf + 0xd9, AI_mul_ovf_un + 0x5d, AI_rem + 0x5e, AI_rem_un + 0x62, AI_shl + 0x63, AI_shr + 0x64, AI_shr_un + 0x59, AI_sub + 0xda, AI_sub_ovf + 0xdb, AI_sub_ovf_un + 0x61, AI_xor + 0x60, AI_or + 0x65, AI_neg + 0x66, AI_not + i_ldnull, AI_ldnull + i_dup, AI_dup + i_pop, AI_pop + i_ckfinite, AI_ckfinite + i_nop, AI_nop + i_break, I_break + i_arglist, I_arglist + i_endfilter, I_endfilter + i_endfinally, I_endfinally + i_refanytype, I_refanytype + i_localloc, I_localloc + i_throw, I_throw + i_ldlen, I_ldlen + i_rethrow, I_rethrow ] let isNoArgInstr i = match i with - | (AI_ldc (DT_I4, ILConst.I4 n)) when (-1) <= n && n <= 8 -> true + | AI_ldc (DT_I4, ILConst.I4 n) when -1 <= n && n <= 8 -> true | I_stloc n | I_ldloc n | I_ldarg n when n <= 3us -> true | I_ret | AI_add @@ -789,7 +789,7 @@ let ILCmpInstrRevMap = BI_brfalse , i_brfalse_s BI_brtrue , i_brtrue_s ]) -(* From corhdr.h *) +// From corhdr.h let nt_VOID = 0x1uy let nt_BOOLEAN = 0x2uy @@ -836,7 +836,7 @@ let nt_CUSTOMMARSHALER = 0x2Cuy let nt_ERROR = 0x2Duy let nt_MAX = 0x50uy -(* From c:/clrenv.i386/Crt/Inc/i386/hs.h *) +// From c:/clrenv.i386/Crt/Inc/i386/hs.h let vt_EMPTY = 0 let vt_NULL = 1 diff --git a/src/absil/illex.fsl b/src/absil/illex.fsl index ed6494092f..478126cac2 100755 --- a/src/absil/illex.fsl +++ b/src/absil/illex.fsl @@ -12,15 +12,13 @@ open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiParser open Microsoft.FSharp.Compiler.AbstractIL.Internal.AsciiConstants let lexeme (lexbuf : LexBuffer) = new System.String(lexbuf.Lexeme) -let unexpectedChar lexbuf = - dprintf "Unexpected character '%s'" (lexeme lexbuf); +let unexpectedChar _lexbuf = raise Parsing.RecoverableParseError ;; // -------------------------------------------------------------------- diff --git a/src/absil/illib.fs b/src/absil/illib.fs index d501df742d..d61b538b53 100755 --- a/src/absil/illib.fs +++ b/src/absil/illib.fs @@ -84,8 +84,6 @@ module Order = module Array = - let take n xs = xs |> Seq.take n |> Array.ofSeq - let mapq f inp = match inp with | [| |] -> inp @@ -99,13 +97,6 @@ module Array = i <- i + 1 if eq then inp else res - let forall2 f (arr1:'T array) (arr2:'T array) = - let len1 = arr1.Length - let len2 = arr2.Length - if len1 <> len2 then invalidArg "Array.forall2" "len1" - let rec loop i = (i >= len1) || (f arr1.[i] arr2.[i] && loop (i+1)) - loop 0 - let lengthsEqAndForall2 p l1 l2 = Array.length l1 = Array.length l2 && Array.forall2 p l1 l2 @@ -120,19 +111,6 @@ module Array = acc <- s' res, acc - - // REVIEW: systematically eliminate foldMap/mapFold duplication. - // They only differ by the tuple returned by the function. - let foldMap f s l = - let mutable acc = s - let n = Array.length l - let mutable res = Array.zeroCreate n - for i = 0 to n - 1 do - let s',h' = f acc l.[i] - res.[i] <- h' - acc <- s' - acc, res - let order (eltOrder: IComparer<'T>) = { new IComparer> with member __.Compare(xs,ys) = @@ -192,13 +170,6 @@ module Option = | None -> dflt() | res -> res - // REVIEW: systematically eliminate foldMap/mapFold duplication - let foldMap f z l = - match l with - | None -> z,None - | Some x -> let z,x = f z x - z,Some x - let fold f z x = match x with | None -> z @@ -339,15 +310,10 @@ module List = | x::xs,y::ys -> let cxy = eltOrder.Compare(x,y) if cxy=0 then loop xs ys else cxy loop xs ys } - - - let rec last l = match l with [] -> failwith "last" | [h] -> h | _::t -> last t + module FrontAndBack = let (|NonEmpty|Empty|) l = match l with [] -> Empty | _ -> NonEmpty(frontAndBack l) - let replicate x n = - Array.toList (Array.create x n) - let range n m = [ n .. m ] let indexNotFound() = raise (new System.Collections.Generic.KeyNotFoundException("An index satisfying the predicate was not found in the collection")) @@ -362,32 +328,23 @@ module List = | [] -> false | ((h,_)::t) -> x = h || memAssoc x t - let rec contains x l = match l with [] -> false | h::t -> x = h || contains x t - let rec memq x l = match l with | [] -> false | h::t -> LanguagePrimitives.PhysicalEquality x h || memq x t - let mem x l = contains x l - // must be tail recursive - let mapFold f s l = + let mapFold (f:'a -> 'b -> 'c * 'a) (s:'a) (l:'b list) : 'c list * 'a = // microbenchmark suggested this implementation is faster than the simpler recursive one, and this function is called a lot let mutable s = s let mutable r = [] - let mutable l = l - let mutable finished = false - while not finished do - match l with - | x::xs -> let x',s' = f s x - s <- s' - r <- x' :: r - l <- xs - | _ -> finished <- true + for x in l do + let x',s' = f s x + s <- s' + r <- x' :: r List.rev r, s - // note: not tail recursive + // Not tail recursive let rec mapFoldBack f l s = match l with | [] -> ([],s) @@ -407,9 +364,6 @@ module List = let count pred xs = List.fold (fun n x -> if pred x then n+1 else n) 0 xs - let rec private repeatAux n x acc = if n <= 0 then acc else repeatAux (n-1) x (x::acc) - let repeat n x = repeatAux n x [] - // WARNING: not tail-recursive let mapHeadTail fhead ftail = function | [] -> [] @@ -420,19 +374,6 @@ module List = let l, s = mapFold f s l List.concat l, s - let singleton x = [x] - - // note: must be tail-recursive - let rec private foldMapAux f z l acc = - match l with - | [] -> z,List.rev acc - | x::xs -> let z,x = f z x - foldMapAux f z xs (x::acc) - - // note: must be tail-recursive - // REVIEW: systematically eliminate foldMap/mapFold duplication - let foldMap f z l = foldMapAux f z l [] - let collect2 f xs ys = List.concat (List.map2 f xs ys) let toArraySquared xss = xss |> List.map List.toArray |> List.toArray @@ -508,31 +449,10 @@ module Dictionary = let dict = new System.Collections.Generic.Dictionary<_,_>(List.length l, HashIdentity.Structural) l |> List.iter (fun (k,v) -> dict.Add(k,v)) dict - - -// FUTURE CLEANUP: remove this adhoc collection -type Hashset<'T> = Dictionary<'T,int> - -[] -module Hashset = - let create (n:int) = new Hashset<'T>(n, HashIdentity.Structural) - let add (t: Hashset<'T>) x = if not (t.ContainsKey x) then t.[x] <- 0 - let fold f (t:Hashset<'T>) acc = Seq.fold (fun z (KeyValue(x,_)) -> f x z) acc t - let ofList l = - let t = new Hashset<'T>(List.length l, HashIdentity.Structural) - l |> List.iter (fun x -> t.[x] <- 0) - t module Lazy = let force (x: Lazy<'T>) = x.Force() -//--------------------------------------------------- -// Lists as sets. This is almost always a bad data structure and should be eliminated from the compiler. - -module ListSet = - let insert e l = - if List.mem e l then l else e::l - //--------------------------------------------------- // Misc @@ -602,14 +522,6 @@ module FlatList = let arr,acc = Array.mapFold f acc x.array FlatList(arr),acc - // REVIEW: systematically eliminate foldMap/mapFold duplication - let foldMap f acc (x:FlatList<_>) = - match x.array with - | null -> - acc,FlatList.Empty - | arr -> - let acc,arr = Array.foldMap f acc x.array - acc,FlatList(arr) #endif #if FLAT_LIST_AS_LIST @@ -621,7 +533,6 @@ module FlatList = let order eltOrder = List.order eltOrder let mapq f (x:FlatList<_>) = List.mapq f x let mapFold f acc (x:FlatList<_>) = List.mapFold f acc x - let foldMap f acc (x:FlatList<_>) = List.foldMap f acc x #endif @@ -631,7 +542,6 @@ module FlatList = let order eltOrder = Array.order eltOrder let mapq f x = Array.mapq f x let mapFold f acc x = Array.mapFold f acc x - let foldMap f acc x = Array.foldMap f acc x #endif @@ -968,7 +878,6 @@ type Map<'Key,'Value when 'Key : comparison> with | Some r -> res <- r; true member x.Values = [ for (KeyValue(_,v)) in x -> v ] - member x.Elements = [ for kvp in x -> kvp ] member x.AddAndMarkAsCollapsible (kvs: _[]) = (x,kvs) ||> Array.fold (fun x (KeyValue(k,v)) -> x.Add(k,v)) member x.LinearTryModifyThenLaterFlatten (key, f: 'Value option -> 'Value) = x.Add (key, f (x.TryFind key)) member x.MarkAsCollapsible () = x @@ -983,7 +892,7 @@ type LayeredMultiMap<'Key,'Value when 'Key : equality and 'Key : comparison>(con x.MarkAsCollapsible() member x.MarkAsCollapsible() = LayeredMultiMap(contents.MarkAsCollapsible()) member x.TryFind k = contents.TryFind k - member x.Values = contents.Values |> Seq.concat + member x.Values = contents.Values |> List.concat static member Empty : LayeredMultiMap<'Key,'Value> = LayeredMultiMap LayeredMap.Empty [] diff --git a/src/absil/ilmorph.fs b/src/absil/ilmorph.fs index 9c2cd85ea8..b166a1303d 100755 --- a/src/absil/ilmorph.fs +++ b/src/absil/ilmorph.fs @@ -2,203 +2,48 @@ module internal Microsoft.FSharp.Compiler.AbstractIL.Morphs +open System.Collections.Generic open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types open Microsoft.FSharp.Compiler.AbstractIL.IL -type 'T morph = 'T -> 'T - -type EnclosingTypeDefs = ILTypeDef list * ILTypeDef - -let checking = false -let notlazy v = Lazy.CreateFromValue v - -// REVIEW: Consider removing Post-Dev11 M3 let mutable morphCustomAttributeData = false -let enablemorphCustomAttributeData() = +let enableMorphCustomAttributeData() = morphCustomAttributeData <- true -let disablemorphCustomAttributeData() = +let disableMorphCustomAttributeData() = morphCustomAttributeData <- false -let mdef_code2code f md = - let code = - match md.mdBody.Contents with - | MethodBody.IL il-> il - | _ -> failwith "mdef_code2code - method not IL" - let code' = MethodBody.IL {code with Code = f code.Code} - {md with mdBody= mkMethBodyAux code'} - -let code_block2block f (c:ILCode) = checkILCode (f c) - -let bblock_instr2instr f bb = - let instrs = bb.Instructions - let len = Array.length instrs - let res = Array.zeroCreate len - for i = 0 to len - 1 do - res.[i] <- f instrs.[i] - {bb with Instructions=res} - -// This is quite performance critical -let nonNil x = match x with [] -> false | _ -> true -let bblock_instr2instrs f bb = - let instrs = bb.Instructions - let codebuf = ref (Array.zeroCreate (Array.length instrs)) - let codebuf_size = ref 0 - for i = 0 to Array.length instrs - 1 do - let instr = instrs.[i] - let instrs = f instr - let curr = ref instrs - while nonNil !curr do - match !curr with - | instr2::t -> - let sz = !codebuf_size - let old_buf_size = Array.length !codebuf - let new_size = sz + 1 - if new_size > old_buf_size then begin - let old = !codebuf - let new' = Array.zeroCreate (max new_size (old_buf_size * 4)) - Array.blit old 0 new' 0 sz; - codebuf := new'; - end; - (!codebuf).[sz] <- instr2; - incr codebuf_size; - curr := t; - | [] -> () - {bb with Instructions = Array.sub !codebuf 0 !codebuf_size} - -// Map each instruction in a basic block to a more complicated block that -// may involve internal branching, but which will still have one entry -// label and one exit label. This is used, for example, when macro-expanding -// complicated high-level ILX instructions. -// The morphing function is told the name of the input and output labels -// that must be used for the generated block. -// Optimize the case where an instruction gets mapped to a -// straightline sequence of instructions by allowing the morphing -// function to return a special result for this case. -// -// Let [i] be the instruction being morphed. If [i] is a control-flow -// then instruction then [f] must return either a control-flow terminated -// sequence of instructions or a block both of which must targets the same labels -// (or a subset of the labels) targeted in [i]. If [i] -// is not a if not a control-flow instruction then [f] -// must return a block targeting the given output label. - -let rec countAccInstrs (xss:ILInstr list list) acc = - match xss with - | [] -> acc - | xs :: rest -> countAccInstrs rest (acc + List.length xs) - -let rec commitAccInstrsAux (xs:ILInstr list) (arr:ILInstr[]) i = - match xs with - | [] -> () - | x :: rest -> arr.[i] <- x; commitAccInstrsAux rest arr (i+1) - -// Fill in the array chunk by chunk from the end and work backwards -let rec commitAccInstrs xss arr i = - match xss with - | [] -> assert (i = 0) - | xs :: rest -> - let n = List.length xs - commitAccInstrsAux xs arr (i - n) - commitAccInstrs rest arr (i - n) - -// Write the accumulated instructions into an array. The fragments come in in reverse order. -let commitAccBasicBlock (sofar: ILInstr list list) = - let n = countAccInstrs sofar 0 - let arr = Array.zeroCreate n - commitAccInstrs sofar arr n - arr - -[] -type InstrMorph(isInstrs:bool, instrs:ILInstr list, code: ILCode) = - new (instrs:ILInstr list) = InstrMorph(true,instrs,Unchecked.defaultof<_>) - new (code:ILCode) = InstrMorph(false,Unchecked.defaultof<_>,code) - member x.IsInstrs = isInstrs - member x.Instrs = instrs - member x.Code = code - -let rec bblockLoop f bb currBBlockInpLabel currInpLabel currOutLabel sofar instrs = - match instrs with - | (i::rest) -> - let res : InstrMorph = f currInpLabel currOutLabel i - if res.IsInstrs then - // First possibility: return a list of instructions. No addresses get consumed. - bblockLoop f bb currBBlockInpLabel currInpLabel currOutLabel (res.Instrs :: sofar) rest - else - let middle_bblock = res.Code - let before_bblock = - let instrs = commitAccBasicBlock ([I_br currInpLabel] :: sofar) - mkBasicBlock {Label=currBBlockInpLabel;Instructions=instrs} - if checking && uniqueEntryOfCode middle_bblock <> currInpLabel then - dprintn ("*** warning when transforming bblock "^formatCodeLabel bb.Label^": bblock2code_instr2code: input label of returned block does not match the expected label while converting an instruction to a block."); - let afterBlocks = - match rest with - | [] -> [] // the bblock has already been transformed - | _ -> - let newInLab = generateCodeLabel () - let newOutLab = generateCodeLabel () - [ bblockLoop f bb currOutLabel newInLab newOutLab [] rest ] - - checkILCode - (mkGroupBlock - ( currInpLabel :: (match rest with [] -> [] | _ -> [ currOutLabel ]), - before_bblock :: middle_bblock :: afterBlocks)) - | [] -> - let instrs = commitAccBasicBlock sofar - mkBasicBlock {Label=currBBlockInpLabel;Instructions=instrs} - -let bblock2code_instr2code (f:ILCodeLabel -> ILCodeLabel -> ILInstr -> InstrMorph) bb = - bblockLoop f bb bb.Label (generateCodeLabel ()) (generateCodeLabel ()) [] (Array.toList bb.Instructions) - -let rec block_bblock2code_typ2typ ((fbb,fty) as f) x = - match x with - | ILBasicBlock bblock -> fbb bblock - | GroupBlock (locs,l) -> GroupBlock(locs,List.map (code_bblock2code_typ2typ f) l) - | TryBlock (tryb,seh) -> - let seh = - match seh with - | FaultBlock b -> FaultBlock (code_bblock2code_typ2typ f b) - | FinallyBlock b -> FinallyBlock (code_bblock2code_typ2typ f b) - | FilterCatchBlock clsl -> - FilterCatchBlock - (List.map (fun (flt,ctch) -> - (match flt with - CodeFilter fltcode -> CodeFilter (code_bblock2code_typ2typ f fltcode) - | TypeFilter ty -> TypeFilter (fty ty)), - code_bblock2code_typ2typ f ctch) clsl) - TryBlock (code_bblock2code_typ2typ f tryb,seh) - | RestrictBlock (ls,c) -> RestrictBlock (ls,code_bblock2code_typ2typ f c) - -and code_bblock2code_typ2typ f (c:ILCode) = checkILCode (block_bblock2code_typ2typ f c) -let topcode_bblock2code_typ2typ f (c:ILCode) = code_bblock2code_typ2typ f c - -let rec block_bblock2code f x = - match x with - | ILBasicBlock bblock -> f bblock - | GroupBlock (locs,l) -> GroupBlock(locs,List.map (code_bblock2code f) l) - | TryBlock (tryb,seh) -> - TryBlock (code_bblock2code f tryb, - begin match seh with - | FaultBlock b -> FaultBlock (code_bblock2code f b) - | FinallyBlock b -> FinallyBlock (code_bblock2code f b) - | FilterCatchBlock clsl -> - FilterCatchBlock - (List.map (fun (flt,ctch) -> - (match flt with - |CodeFilter fltcode -> CodeFilter (code_bblock2code f fltcode) - | TypeFilter _ty -> flt), - code_bblock2code f ctch) clsl) - end) - | RestrictBlock (ls,c) -> RestrictBlock (ls,code_bblock2code f c) - -and code_bblock2code f (c:ILCode) = checkILCode (block_bblock2code f c) -let topcode_bblock2code f (c:ILCode) = code_bblock2code f c +let code_instr2instr f (code: ILCode) = {code with Instrs= Array.map f code.Instrs} + +let code_instr2instrs f (code: ILCode) = + let instrs = code.Instrs + let codebuf = ResizeArray() + let adjust = Dictionary() + let mutable old = 0 + let mutable nw = 0 + for instr in instrs do + adjust.[old] <- nw + let instrs : list<_> = f instr + for instr2 in instrs do + codebuf.Add instr2 + nw <- nw + 1 + old <- old + 1 + adjust.[old] <- nw + { code with + Instrs = codebuf.ToArray() + Labels = Dictionary.ofList [ for kvp in code.Labels -> kvp.Key, adjust.[kvp.Value] ] } + + + +let code_instr2instr_typ2typ (finstr,fty) (c:ILCode) = + let c = code_instr2instr finstr c + { c with + Exceptions = c.Exceptions |> List.map (fun e -> { e with Clause = e.Clause |> (function ILExceptionClause.TypeCatch (ilty, b) -> ILExceptionClause.TypeCatch (fty ilty, b) | cl -> cl) }) } // -------------------------------------------------------------------- // Standard morphisms - mapping types etc. @@ -262,10 +107,10 @@ let mref_typ2typ (f: ILType -> ILType) (x:ILMethodRef) = returnType= f x.ReturnType) -type formal_scopeCtxt = Choice +type formal_scopeCtxt = Choice let mspec_typ2typ (((factualty : ILType -> ILType) , (fformalty: formal_scopeCtxt -> ILType -> ILType))) (x: ILMethodSpec) = - mkILMethSpecForMethRefInTyRaw(mref_typ2typ (fformalty (Choice1Of3 x)) x.MethodRef, + mkILMethSpecForMethRefInTyRaw(mref_typ2typ (fformalty (Choice1Of2 x)) x.MethodRef, factualty x.EnclosingType, typs_typ2typ factualty x.GenericArgs) @@ -274,7 +119,7 @@ let fref_typ2typ (f: ILType -> ILType) x = Type= f x.Type } let fspec_typ2typ ((factualty,(fformalty : formal_scopeCtxt -> ILType -> ILType))) x = - { FieldRef=fref_typ2typ (fformalty (Choice2Of3 x)) x.FieldRef; + { FieldRef=fref_typ2typ (fformalty (Choice2Of2 x)) x.FieldRef; EnclosingType= factualty x.EnclosingType } let rec celem_typ2typ f celem = @@ -308,18 +153,8 @@ let cattrs_typ2typ ilg f (cs: ILAttributes) = let fdef_typ2typ ilg ftype (fd: ILFieldDef) = {fd with Type=ftype fd.Type; CustomAttrs=cattrs_typ2typ ilg ftype fd.CustomAttrs} -let altfdef_typ2typ ilg ftype (fd: IlxUnionField) = - IlxUnionField( fdef_typ2typ ilg ftype fd.ILField) - -let alts_typ2typ ilg f alts = - Array.map (fun alt -> { alt with altFields = Array.map (altfdef_typ2typ ilg f) alt.altFields; - altCustomAttrs = cattrs_typ2typ ilg f alt.altCustomAttrs }) alts - -let curef_typ2typ ilg f (IlxUnionRef(s,alts,nullPermitted,helpers)) = - IlxUnionRef(s,alts_typ2typ ilg f alts,nullPermitted,helpers) let local_typ2typ f (l: ILLocal) = {l with Type = f l.Type} -let freevar_typ2typ f l = {l with fvType = f l.fvType} let varargs_typ2typ f (varargs: ILVarArgs) = Option.map (ILList.map f) varargs (* REVIEW: convert varargs *) let morphILTypesInILInstr ((factualty,fformalty)) i = @@ -370,20 +205,12 @@ let fdefs_fdef2fdef f (m:ILFieldDefs) = mkILFields (List.map f m.AsList) (* use this when the conversion produces just one type... *) let morphILTypeDefs f (m: ILTypeDefs) = mkILTypeDefsFromArray (Array.map f m.AsArray) -let morphExpandILTypeDefs f (m:ILTypeDefs) = - mkILTypeDefs (List.collect f m.AsList) - -let morphILTypeDefsInILModule typesf m = - {m with TypeDefs=typesf m.TypeDefs} - let locals_typ2typ f ls = ILList.map (local_typ2typ f) ls -let freevars_typ2typ f ls = Array.map (freevar_typ2typ f) ls -let ilmbody_bblock2code_typ2typ_maxstack2maxstack fs il = - let (finstr,ftype,fmaxstack) = fs - {il with Code=topcode_bblock2code_typ2typ (finstr,ftype) il.Code; - Locals = locals_typ2typ ftype il.Locals; - MaxStack = fmaxstack il.MaxStack } +let ilmbody_instr2instr_typ2typ fs (il: ILMethodBody) = + let (finstr,ftype) = fs + {il with Code=code_instr2instr_typ2typ (finstr,ftype) il.Code; + Locals = locals_typ2typ ftype il.Locals } let morphILMethodBody (filmbody) (x: ILLazyMethodBody) = let c = @@ -409,20 +236,6 @@ let fdefs_typ2typ ilg f x = fdefs_fdef2fdef (fdef_typ2typ ilg f) x let mdefs_typ2typ_ilmbody2ilmbody ilg fs x = morphILMethodDefs (mdef_typ2typ_ilmbody2ilmbody ilg fs) x -let cuinfo_typ2typ ilg ftype cud = - { cud with cudAlternatives = alts_typ2typ ilg ftype cud.cudAlternatives; } - - -let cloinfo_typ2typ_ilmbody2ilmbody fs clo = - let (ftype,filmbody) = fs - let c' = filmbody None (Lazy.force clo.cloCode) - { clo with cloFreeVars = freevars_typ2typ ftype clo.cloFreeVars; - cloCode=notlazy c' } - -let morphIlxClosureInfo f clo = - let c' = f (Lazy.force clo.cloCode) - { clo with cloCode=notlazy c' } - let mimpl_typ2typ f e = { Overrides = ospec_typ2typ f e.Overrides; OverrideBy = mspec_typ2typ (f,(fun _ -> f)) e.OverrideBy; } @@ -450,7 +263,7 @@ let edefs_typ2typ ilg f (edefs: ILEventDefs) = mkILEvents (List.map (edef_typ2ty let mimpls_typ2typ f (mimpls : ILMethodImplDefs) = mkILMethodImpls (List.map (mimpl_typ2typ f) mimpls.AsList) let rec tdef_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg enc fs td = - let (ftype,filmbody,fmdefs) = fs + let (ftype,fmdefs) = fs let ftype' = ftype (Some (enc,td)) None let mdefs' = fmdefs (enc,td) td.Methods let fdefs' = fdefs_typ2typ ilg ftype' td.Fields @@ -464,13 +277,6 @@ let rec tdef_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg enc fs td = Events = edefs_typ2typ ilg ftype' td.Events; Properties = pdefs_typ2typ ilg ftype' td.Properties; CustomAttrs = cattrs_typ2typ ilg ftype' td.CustomAttrs; - tdKind = - match td.tdKind with - | ILTypeDefKind.Other e when isIlxExtTypeDefKind e -> - match destIlxExtTypeDefKind e with - | IlxTypeDefKind.Closure i -> mkIlxTypeDefKind (IlxTypeDefKind.Closure (cloinfo_typ2typ_ilmbody2ilmbody (ftype',filmbody (enc,td)) i)) - | IlxTypeDefKind.Union i -> mkIlxTypeDefKind (IlxTypeDefKind.Union (cuinfo_typ2typ ilg ftype' i)) - | _ -> td.tdKind } and tdefs_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg enc fs tdefs = @@ -483,38 +289,24 @@ and tdefs_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg enc fs tdefs = let manifest_typ2typ ilg f (m : ILAssemblyManifest) = { m with CustomAttrs = cattrs_typ2typ ilg f m.CustomAttrs } -let morphILTypeInILModule_ilmbody2ilmbody_mdefs2mdefs ilg - ((ftype: ILModuleDef -> (ILTypeDef list * ILTypeDef) option -> ILMethodDef option -> ILType -> ILType), - (filmbody: ILModuleDef -> ILTypeDef list * ILTypeDef -> ILMethodDef option -> ILMethodBody -> ILMethodBody), - fmdefs) m = +let morphILTypeInILModule_ilmbody2ilmbody_mdefs2mdefs ilg ((ftype: ILModuleDef -> (ILTypeDef list * ILTypeDef) option -> ILMethodDef option -> ILType -> ILType),fmdefs) m = - let ftdefs = - tdefs_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg [] - (ftype m, - filmbody m, - fmdefs m) + let ftdefs = tdefs_typ2typ_ilmbody2ilmbody_mdefs2mdefs ilg [] (ftype m,fmdefs m) { m with TypeDefs=ftdefs m.TypeDefs; CustomAttrs=cattrs_typ2typ ilg (ftype m None None) m.CustomAttrs; Manifest=Option.map (manifest_typ2typ ilg (ftype m None None)) m.Manifest } -let module_bblock2code_typ2typ_maxstack2maxstack ilg fs x = - let (fbblock,ftype,fmaxstack) = fs - let filmbody modCtxt tdefCtxt mdefCtxt = - ilmbody_bblock2code_typ2typ_maxstack2maxstack - (fbblock modCtxt tdefCtxt mdefCtxt, - ftype modCtxt (Some tdefCtxt) mdefCtxt, - fmaxstack modCtxt tdefCtxt mdefCtxt) +let module_instr2instr_typ2typ ilg fs x = + let (fcode,ftype) = fs + let filmbody modCtxt tdefCtxt mdefCtxt = ilmbody_instr2instr_typ2typ (fcode modCtxt tdefCtxt mdefCtxt, ftype modCtxt (Some tdefCtxt) mdefCtxt) let fmdefs modCtxt tdefCtxt = mdefs_typ2typ_ilmbody2ilmbody ilg (ftype modCtxt (Some tdefCtxt), filmbody modCtxt tdefCtxt) - morphILTypeInILModule_ilmbody2ilmbody_mdefs2mdefs ilg (ftype, filmbody, fmdefs) x + morphILTypeInILModule_ilmbody2ilmbody_mdefs2mdefs ilg (ftype, fmdefs) x -let module_bblock2code_typ2typ ilg (f1,f2) x = - module_bblock2code_typ2typ_maxstack2maxstack ilg (f1, f2, (fun _modCtxt _tdefCtxt _mdefCtxt x -> x)) x let morphILInstrsAndILTypesInILModule ilg (f1,f2) x = - module_bblock2code_typ2typ ilg ((fun modCtxt tdefCtxt mdefCtxt i -> mkBasicBlock (bblock_instr2instr (f1 modCtxt tdefCtxt mdefCtxt) i)), f2) x + module_instr2instr_typ2typ ilg (f1, f2) x -let morphILInstrsInILCode f x = topcode_bblock2code (fun i -> mkBasicBlock (bblock_instr2instrs f i)) x -let morphExpandILInstrsInILCode f x = topcode_bblock2code (bblock2code_instr2code f) x +let morphILInstrsInILCode f x = code_instr2instrs f x let morphILTypeInILModule ilg ftype y = let finstr modCtxt tdefCtxt mdefCtxt = diff --git a/src/absil/ilmorph.fsi b/src/absil/ilmorph.fsi index 3dd1355d5c..953025cec3 100755 --- a/src/absil/ilmorph.fsi +++ b/src/absil/ilmorph.fsi @@ -8,42 +8,18 @@ /// the ILMethodDef (if any) where the item occurs. etc. module internal Microsoft.FSharp.Compiler.AbstractIL.Morphs -open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL -open Microsoft.FSharp.Compiler.AbstractIL.Internal -open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types open Microsoft.FSharp.Compiler.AbstractIL.IL -type 'T morph = 'T -> 'T - -/// Morph each scope reference inside a type signature -val morphILScopeRefsInILTypeRef: ILScopeRef morph -> ILTypeRef -> ILTypeRef - -val morphILMethodDefs: ILMethodDef morph -> ILMethodDefs -> ILMethodDefs -/// nb. does not do nested tdefs -val morphILTypeDefs: ILTypeDef morph -> ILTypeDefs -> ILTypeDefs - -val morphExpandILTypeDefs: (ILTypeDef -> ILTypeDef list) -> ILTypeDefs -> ILTypeDefs - -/// Morph all tables of ILTypeDefs in "ILModuleDef" -val morphILTypeDefsInILModule: ILTypeDefs morph -> ILModuleDef -> ILModuleDef +/// Morph each scope reference inside a type signature. +val morphILScopeRefsInILTypeRef: (ILScopeRef -> ILScopeRef) -> ILTypeRef -> ILTypeRef /// Morph all type references throughout an entire module. -val morphILTypeRefsInILModuleMemoized: ILGlobals -> ILTypeRef morph -> ILModuleDef -> ILModuleDef +val morphILTypeRefsInILModuleMemoized: ILGlobals -> (ILTypeRef -> ILTypeRef) -> ILModuleDef -> ILModuleDef -val morphILScopeRefsInILModuleMemoized: ILGlobals -> ILScopeRef morph -> ILModuleDef -> ILModuleDef +val morphILScopeRefsInILModuleMemoized: ILGlobals -> (ILScopeRef -> ILScopeRef) -> ILModuleDef -> ILModuleDef -val morphILMethodBody: ILMethodBody morph -> ILLazyMethodBody -> ILLazyMethodBody -val morphIlxClosureInfo: ILMethodBody morph -> IlxClosureInfo -> IlxClosureInfo val morphILInstrsInILCode: (ILInstr -> ILInstr list) -> ILCode -> ILCode -[] -type InstrMorph = - new : ILInstr list -> InstrMorph - new : ILCode -> InstrMorph - -val morphExpandILInstrsInILCode: (ILCodeLabel -> ILCodeLabel -> ILInstr -> InstrMorph) -> ILCode -> ILCode - -// REVIEW: Consider removing Post-Dev11 M3 -val enablemorphCustomAttributeData : unit -> unit -val disablemorphCustomAttributeData : unit -> unit +val enableMorphCustomAttributeData : unit -> unit +val disableMorphCustomAttributeData : unit -> unit diff --git a/src/absil/ilprint.fs b/src/absil/ilprint.fs index 7b70513d85..b8289f30b0 100755 --- a/src/absil/ilprint.fs +++ b/src/absil/ilprint.fs @@ -21,7 +21,6 @@ let pretty () = true // Pretty printing // -------------------------------------------------------------------- - let tyvar_generator = let i = ref 0 fun n -> @@ -440,12 +439,12 @@ let goutput_alternative_ref env os (alt: IlxUnionAlternative) = output_id os alt.Name; alt.FieldDefs |> Array.toList |> output_parens (output_seq "," (fun os fdef -> goutput_typ env os fdef.Type)) os -let goutput_curef env os (IlxUnionRef(tref,alts,_,_)) = +let goutput_curef env os (IlxUnionRef(_,tref,alts,_,_)) = output_string os " .classunion import "; goutput_tref env os tref; output_parens (output_seq "," (goutput_alternative_ref env)) os (Array.toList alts) -let goutput_cuspec env os (IlxUnionSpec(IlxUnionRef(tref,_,_,_),i)) = +let goutput_cuspec env os (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_),i)) = output_string os "class /* classunion */ "; goutput_tref env os tref; goutput_gactuals env os i @@ -529,7 +528,7 @@ let rec goutput_apps env os = function output_string os "--> "; goutput_typ env os ty -/// utilities to help print out short forms of instructions +/// Print the short form of instructions let output_short_u16 os (x:uint16) = if int x < 256 then (output_string os ".s "; output_u16 os x) else (output_string os " "; output_u16 os x) @@ -578,7 +577,7 @@ let rec goutput_instr env os inst = match inst with | si when isNoArgInstr si -> output_lid os (wordsOfNoArgInstr si) - | I_brcmp (cmp,tg1,_tg2) -> + | I_brcmp (cmp,tg1) -> output_string os (match cmp with | BI_beq -> "beq" @@ -641,7 +640,7 @@ let rec goutput_instr env os inst = output_string os "stind."; output_basic_type os dt | I_stloc u16 -> output_string os "stloc"; output_short_u16 os u16 - | I_switch (l,_dflt) -> output_string os "switch "; output_parens (output_seq "," output_code_label) os l + | I_switch l -> output_string os "switch "; output_parens (output_seq "," output_code_label) os l | I_callvirt (tl,mspec,varargs) -> output_tailness os tl; output_string os "callvirt "; @@ -755,141 +754,21 @@ let rec goutput_instr env os inst = | I_cpobj tok -> output_string os "cpobj "; goutput_typ env os tok | I_sizeof tok -> output_string os "sizeof "; goutput_typ env os tok | I_seqpoint s -> output_source os s - | (EI_ilzero ty) -> output_string os "ilzero "; goutput_typ env os ty - | I_other e when isIlxExtInstr e -> - match (destIlxExtInstr e) with - | EI_castdata (check,ty,n) -> - if not check then output_string os "/* unchecked. */ "; - output_string os "castdata "; - goutput_cuspec env os ty; - output_string os ","; - output_int os n - | (EI_isdata (_,ty,n)) -> - output_string os "isdata "; - goutput_cuspec env os ty; - output_string os ","; - output_int os n - | (EI_brisdata (_,ty,n,tg1,_)) -> - output_string os "brisdata "; - goutput_cuspec env os ty; - output_string os ","; - output_string os "("; - output_int os n; - output_string os ","; - output_code_label os tg1; - output_string os ")" - | (EI_lddata (_,ty,n,m)) -> - output_string os "lddata "; - goutput_cuspec env os ty; - output_string os ","; - output_int os n; - output_string os ","; - output_int os m - | (EI_lddatatag (_,ty)) -> - output_string os "lddatatag "; - goutput_cuspec env os ty - | (EI_stdata (ty,n,m)) -> - output_string os "stdata "; - goutput_cuspec env os ty; - output_string os ","; - output_int os n; - output_string os ","; - output_int os m - | (EI_newdata (ty,n)) -> - output_string os "newdata "; - goutput_cuspec env os ty; - output_string os ","; - output_int os n - | (EI_datacase (_,ty,l,_)) -> - output_string os "datacase"; - output_string os " "; - goutput_cuspec env os ty; - output_string os ","; - output_parens (output_seq "," (fun os (x,y) -> output_int os x; output_string os ","; output_code_label os y)) os l - | (EI_callfunc (tl,cs)) -> - output_tailness os tl; - output_string os "callfunc "; - goutput_apps env os cs; - output_after_tailcall os tl; + | EI_ilzero ty -> output_string os "ilzero "; goutput_typ env os ty | _ -> output_string os "" -let goutput_ilmbody env os il = +let goutput_ilmbody env os (il: ILMethodBody) = if il.IsZeroInit then output_string os " .zeroinit\n"; output_string os " .maxstack "; output_i32 os il.MaxStack; output_string os "\n"; - let output_susp os susp = - match susp with - | Some s -> - output_string os "\nbr "; output_code_label os s; output_string os "\n" - | _ -> () - let commit_susp os susp lab = - match susp with - | Some s when s <> lab -> output_susp os susp - | _ -> () if il.Locals.Length <> 0 then output_string os " .locals("; output_seq ",\n " (goutput_local env) os il.Locals output_string os ")\n" - // Print the code by left-to-right traversal - let rec goutput_block env os (susp,block) = - match block with - | ILBasicBlock bb -> - commit_susp os susp bb.Label; - output_code_label os bb.Label; output_string os ": \n" ; - Array.iter (fun i -> goutput_instr env os i; output_string os "\n") bb.Instructions; - bb.Fallthrough - | GroupBlock (_,l) -> - let new_susp = ref susp - List.iter (fun c -> new_susp := goutput_code env os (!new_susp,c)) l; - !new_susp - | RestrictBlock (_,c) -> goutput_code env os (susp,c) - | TryBlock (c,seh) -> - - commit_susp os susp (uniqueEntryOfCode c); - output_string os " .try {\n"; - let susp = goutput_code env os (None,c) - if (susp <> None) then output_string os "// warning: fallthrough at end of try\n"; - output_string os "\n}"; - match seh with - | FaultBlock flt -> - output_string os "fault {\n"; - output_susp os (goutput_code env os (None,flt)); - output_string os "\n}" - | FinallyBlock flt -> - output_string os "finally {\n"; - output_susp os (goutput_code env os (None,flt)); - output_string os "\n}"; - | FilterCatchBlock clauses -> - List.iter - (fun (flt,ctch) -> - match flt with - | TypeFilter typ -> - output_string os " catch "; - goutput_typ_with_shortened_class_syntax env os typ; - output_string os "{\n"; - output_susp os (goutput_code env os (None,ctch)); - output_string os "\n}" - | CodeFilter fltcode -> - output_string os "filter {\n"; - output_susp os (goutput_code env os (None,fltcode)); - output_string os "\n} catch {\n"; - output_susp os (goutput_code env os (None,ctch)); - output_string os "\n}";) - clauses - None - - and goutput_code env os (susp,code) = - goutput_block env os (susp,code) - - let goutput_topcode env os code = - let final_susp = goutput_code env os (Some (uniqueEntryOfCode code),code) - (match final_susp with Some s -> output_string os "\nbr "; output_code_label os s; output_string os "\n" | _ -> ()) - - goutput_topcode env os il.Code; let goutput_mbody is_entrypoint env os md = match md.mdCodeKind with @@ -1024,30 +903,10 @@ let rec goutput_tdef (enc) env contents os cd = goutput_fdefs tref env os cd.Fields; goutput_pdefs env os cd.Properties; else - let isclo = - match cd.tdKind with - | ILTypeDefKind.Other e when isIlxExtTypeDefKind e -> - match destIlxExtTypeDefKind e with - | IlxTypeDefKind.Closure _ -> true - | _ -> false - | _ -> false - let isclassunion = - match cd.tdKind with - | ILTypeDefKind.Other e when isIlxExtTypeDefKind e -> - match destIlxExtTypeDefKind e with - | IlxTypeDefKind.Union _ -> true - | _ -> false - | _ -> false - if not (isclo || isclassunion) || contents then output_string os "\n"; match cd.tdKind with | ILTypeDefKind.Class | ILTypeDefKind.Enum | ILTypeDefKind.Delegate | ILTypeDefKind.ValueType -> output_string os ".class " | ILTypeDefKind.Interface -> output_string os ".class interface " - | ILTypeDefKind.Other e when isIlxExtTypeDefKind e -> - match destIlxExtTypeDefKind e with - | IlxTypeDefKind.Closure _ -> output_string os ".closure " - | IlxTypeDefKind.Union _ -> output_string os ".classunion " - | ILTypeDefKind.Other _ -> failwith "unknown extension" output_init_semantics os cd.InitSemantics; output_string os " "; output_type_access os cd.Access; @@ -1063,17 +922,8 @@ let rec goutput_tdef (enc) env contents os cd = output_sqstring os cd.Name ; goutput_gparams env os cd.GenericParams; output_string os "\n\t"; - if isclo then - match cd.tdKind with - | ILTypeDefKind.Other e when isIlxExtTypeDefKind e -> - match destIlxExtTypeDefKind e with - | IlxTypeDefKind.Closure _cloinfo -> - () //goutput_freevars env os cloinfo.cloFreeVars - | _ -> () - | _ -> () - else - goutput_superclass env os cd.Extends; - output_string os "\n\t"; + goutput_superclass env os cd.Extends; + output_string os "\n\t"; goutput_implements env os cd.Implements; output_string os "\n{\n "; if contents then @@ -1083,19 +933,6 @@ let rec goutput_tdef (enc) env contents os cd = pp_layout_decls os (); goutput_fdefs tref env os cd.Fields; goutput_mdefs env os cd.Methods; - match cd.tdKind with - | ILTypeDefKind.Other e when isIlxExtTypeDefKind e -> - match destIlxExtTypeDefKind e with - | IlxTypeDefKind.Closure x -> - output_string os "\n.apply "; - (goutput_lambdas env) os x.cloStructure; - output_string os "\n { "; - (goutput_ilmbody env) os (Lazy.force x.cloCode); - output_string os "}\n"; - | IlxTypeDefKind.Union x -> - Array.iter (fun x -> output_string os " .alternative "; - goutput_alternative_ref env os x) x.cudAlternatives; - | _ -> () goutput_tdefs contents (enc@[cd.Name]) env os cd.NestedTypes; output_string os "\n}"; diff --git a/src/absil/ilread.fs b/src/absil/ilread.fs index 1833b27b2c..d44d70e70e 100755 --- a/src/absil/ilread.fs +++ b/src/absil/ilread.fs @@ -8,7 +8,6 @@ module internal Microsoft.FSharp.Compiler.AbstractIL.ILBinaryReader #nowarn "42" // This construct is deprecated: it is only for use in the F# library -#nowarn "44" // This construct is deprecated. please use List.item open System open System.IO @@ -105,7 +104,7 @@ type BinaryFile() = abstract CountUtf8String : addr:int -> int abstract ReadUTF8String : addr: int -> string -/// Read file from memory mapped files +/// Read from memory mapped files. module MemoryMapping = type HANDLE = nativeint @@ -484,10 +483,10 @@ type ILInstrDecoder = | I_method_instr of (ILInstrPrefixesRegister -> ILMethodSpec * ILVarArgs -> ILInstr) | I_unconditional_i32_instr of (ILInstrPrefixesRegister -> ILCodeLabel -> ILInstr) | I_unconditional_i8_instr of (ILInstrPrefixesRegister -> ILCodeLabel -> ILInstr) - | I_conditional_i32_instr of (ILInstrPrefixesRegister -> ILCodeLabel * ILCodeLabel -> ILInstr) - | I_conditional_i8_instr of (ILInstrPrefixesRegister -> ILCodeLabel * ILCodeLabel -> ILInstr) + | I_conditional_i32_instr of (ILInstrPrefixesRegister -> ILCodeLabel -> ILInstr) + | I_conditional_i8_instr of (ILInstrPrefixesRegister -> ILCodeLabel -> ILInstr) | I_string_instr of (ILInstrPrefixesRegister -> string -> ILInstr) - | I_switch_instr of (ILInstrPrefixesRegister -> ILCodeLabel list * ILCodeLabel -> ILInstr) + | I_switch_instr of (ILInstrPrefixesRegister -> ILCodeLabel list -> ILInstr) | I_tok_instr of (ILInstrPrefixesRegister -> ILToken -> ILInstr) | I_sig_instr of (ILInstrPrefixesRegister -> ILCallingSignature * ILVarArgs -> ILInstr) | I_type_instr of (ILInstrPrefixesRegister -> ILType -> ILInstr) @@ -550,30 +549,30 @@ let instrs () = i_br_s, I_unconditional_i8_instr (noPrefixes I_br); i_leave, I_unconditional_i32_instr (noPrefixes (fun x -> I_leave x)); i_br, I_unconditional_i32_instr (noPrefixes I_br); - i_brtrue_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_brtrue,x,y))); - i_brfalse_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_brfalse,x,y))); - i_beq_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_beq,x,y))); - i_blt_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_blt,x,y))); - i_blt_un_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_blt_un,x,y))); - i_ble_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_ble,x,y))); - i_ble_un_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_ble_un,x,y))); - i_bgt_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_bgt,x,y))); - i_bgt_un_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_bgt_un,x,y))); - i_bge_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_bge,x,y))); - i_bge_un_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_bge_un,x,y))); - i_bne_un_s, I_conditional_i8_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_bne_un,x,y))); - i_brtrue, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_brtrue,x,y))); - i_brfalse, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_brfalse,x,y))); - i_beq, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_beq,x,y))); - i_blt, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_blt,x,y))); - i_blt_un, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_blt_un,x,y))); - i_ble, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_ble,x,y))); - i_ble_un, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_ble_un,x,y))); - i_bgt, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_bgt,x,y))); - i_bgt_un, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_bgt_un,x,y))); - i_bge, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_bge,x,y))); - i_bge_un, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_bge_un,x,y))); - i_bne_un, I_conditional_i32_instr (noPrefixes (fun (x,y) -> I_brcmp (BI_bne_un,x,y))); + i_brtrue_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_brtrue,x))); + i_brfalse_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_brfalse,x))); + i_beq_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_beq,x))); + i_blt_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_blt,x))); + i_blt_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_blt_un,x))); + i_ble_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_ble,x))); + i_ble_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_ble_un,x))); + i_bgt_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bgt,x))); + i_bgt_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bgt_un,x))); + i_bge_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bge,x))); + i_bge_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bge_un,x))); + i_bne_un_s, I_conditional_i8_instr (noPrefixes (fun x -> I_brcmp (BI_bne_un,x))); + i_brtrue, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_brtrue,x))); + i_brfalse, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_brfalse,x))); + i_beq, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_beq,x))); + i_blt, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_blt,x))); + i_blt_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_blt_un,x))); + i_ble, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_ble,x))); + i_ble_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_ble_un,x))); + i_bgt, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bgt,x))); + i_bgt_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bgt_un,x))); + i_bge, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bge,x))); + i_bge_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bge_un,x))); + i_bne_un, I_conditional_i32_instr (noPrefixes (fun x -> I_brcmp (BI_bne_un,x))); i_ldstr, I_string_instr (noPrefixes I_ldstr); i_switch, I_switch_instr (noPrefixes I_switch); i_ldtoken, I_tok_instr (noPrefixes I_ldtoken); @@ -1086,7 +1085,7 @@ let seekReadModuleRow ctxt idx = let encbaseidIdx = seekReadGuidIdx ctxt &addr (generation, nameIdx, mvidIdx, encidIdx, encbaseidIdx) -/// Read Table ILTypeRef +/// Read Table ILTypeRef. let seekReadTypeRefRow ctxt idx = count ctxt.countTypeRef; let mutable addr = ctxt.rowAddr TableNames.TypeRef idx @@ -1095,7 +1094,7 @@ let seekReadTypeRefRow ctxt idx = let namespaceIdx = seekReadStringIdx ctxt &addr (scopeIdx,nameIdx,namespaceIdx) -/// Read Table ILTypeDef +/// Read Table ILTypeDef. let seekReadTypeDefRow ctxt idx = ctxt.seekReadTypeDefRow idx let seekReadTypeDefRowUncached ctxtH idx = let ctxt = getHole ctxtH @@ -1109,7 +1108,7 @@ let seekReadTypeDefRowUncached ctxtH idx = let methodsIdx = seekReadUntaggedIdx TableNames.Method ctxt &addr (flags, nameIdx, namespaceIdx, extendsIdx, fieldsIdx, methodsIdx) -/// Read Table Field +/// Read Table Field. let seekReadFieldRow ctxt idx = count ctxt.countField; let mutable addr = ctxt.rowAddr TableNames.Field idx @@ -1118,7 +1117,7 @@ let seekReadFieldRow ctxt idx = let typeIdx = seekReadBlobIdx ctxt &addr (flags,nameIdx,typeIdx) -/// Read Table Method +/// Read Table Method. let seekReadMethodRow ctxt idx = count ctxt.countMethod; let mutable addr = ctxt.rowAddr TableNames.Method idx @@ -1130,7 +1129,7 @@ let seekReadMethodRow ctxt idx = let paramIdx = seekReadUntaggedIdx TableNames.Param ctxt &addr (codeRVA, implflags, flags, nameIdx, typeIdx, paramIdx) -/// Read Table Param +/// Read Table Param. let seekReadParamRow ctxt idx = count ctxt.countParam; let mutable addr = ctxt.rowAddr TableNames.Param idx @@ -1139,7 +1138,7 @@ let seekReadParamRow ctxt idx = let nameIdx = seekReadStringIdx ctxt &addr (flags,seq,nameIdx) -/// Read Table InterfaceImpl +/// Read Table InterfaceImpl. let seekReadInterfaceImplRow ctxt idx = ctxt.seekReadInterfaceImplRow idx let seekReadInterfaceImplRowUncached ctxtH idx = let ctxt = getHole ctxtH @@ -1149,7 +1148,7 @@ let seekReadInterfaceImplRowUncached ctxtH idx = let intfIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr (tidx,intfIdx) -/// Read Table MemberRef +/// Read Table MemberRef. let seekReadMemberRefRow ctxt idx = count ctxt.countMemberRef; let mutable addr = ctxt.rowAddr TableNames.MemberRef idx @@ -1158,7 +1157,7 @@ let seekReadMemberRefRow ctxt idx = let typeIdx = seekReadBlobIdx ctxt &addr (mrpIdx,nameIdx,typeIdx) -/// Read Table Constant +/// Read Table Constant. let seekReadConstantRow ctxt idx = ctxt.seekReadConstantRow idx let seekReadConstantRowUncached ctxtH idx = let ctxt = getHole ctxtH @@ -1169,7 +1168,7 @@ let seekReadConstantRowUncached ctxtH idx = let valIdx = seekReadBlobIdx ctxt &addr (kind, parentIdx, valIdx) -/// Read Table CustomAttribute +/// Read Table CustomAttribute. let seekReadCustomAttributeRow ctxt idx = count ctxt.countCustomAttribute; let mutable addr = ctxt.rowAddr TableNames.CustomAttribute idx @@ -1178,7 +1177,7 @@ let seekReadCustomAttributeRow ctxt idx = let valIdx = seekReadBlobIdx ctxt &addr (parentIdx, typeIdx, valIdx) -/// Read Table FieldMarshal +/// Read Table FieldMarshal. let seekReadFieldMarshalRow ctxt idx = ctxt.seekReadFieldMarshalRow idx let seekReadFieldMarshalRowUncached ctxtH idx = let ctxt = getHole ctxtH @@ -1188,7 +1187,7 @@ let seekReadFieldMarshalRowUncached ctxtH idx = let typeIdx = seekReadBlobIdx ctxt &addr (parentIdx, typeIdx) -/// Read Table Permission +/// Read Table Permission. let seekReadPermissionRow ctxt idx = count ctxt.countPermission; let mutable addr = ctxt.rowAddr TableNames.Permission idx @@ -1197,7 +1196,7 @@ let seekReadPermissionRow ctxt idx = let typeIdx = seekReadBlobIdx ctxt &addr (action, parentIdx, typeIdx) -/// Read Table ClassLayout +/// Read Table ClassLayout. let seekReadClassLayoutRow ctxt idx = count ctxt.countClassLayout; let mutable addr = ctxt.rowAddr TableNames.ClassLayout idx @@ -1206,7 +1205,7 @@ let seekReadClassLayoutRow ctxt idx = let tidx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr (pack,size,tidx) -/// Read Table FieldLayout +/// Read Table FieldLayout. let seekReadFieldLayoutRow ctxt idx = count ctxt.countFieldLayout; let mutable addr = ctxt.rowAddr TableNames.FieldLayout idx @@ -1214,14 +1213,14 @@ let seekReadFieldLayoutRow ctxt idx = let fidx = seekReadUntaggedIdx TableNames.Field ctxt &addr (offset,fidx) -//// Read Table StandAloneSig +//// Read Table StandAloneSig. let seekReadStandAloneSigRow ctxt idx = count ctxt.countStandAloneSig; let mutable addr = ctxt.rowAddr TableNames.StandAloneSig idx let sigIdx = seekReadBlobIdx ctxt &addr sigIdx -/// Read Table EventMap +/// Read Table EventMap. let seekReadEventMapRow ctxt idx = count ctxt.countEventMap; let mutable addr = ctxt.rowAddr TableNames.EventMap idx @@ -1229,7 +1228,7 @@ let seekReadEventMapRow ctxt idx = let eventsIdx = seekReadUntaggedIdx TableNames.Event ctxt &addr (tidx,eventsIdx) -/// Read Table Event +/// Read Table Event. let seekReadEventRow ctxt idx = count ctxt.countEvent; let mutable addr = ctxt.rowAddr TableNames.Event idx @@ -1238,7 +1237,7 @@ let seekReadEventRow ctxt idx = let typIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr (flags,nameIdx,typIdx) -/// Read Table PropertyMap +/// Read Table PropertyMap. let seekReadPropertyMapRow ctxt idx = ctxt.seekReadPropertyMapRow idx let seekReadPropertyMapRowUncached ctxtH idx = let ctxt = getHole ctxtH @@ -1248,7 +1247,7 @@ let seekReadPropertyMapRowUncached ctxtH idx = let propsIdx = seekReadUntaggedIdx TableNames.Property ctxt &addr (tidx,propsIdx) -/// Read Table Property +/// Read Table Property. let seekReadPropertyRow ctxt idx = count ctxt.countProperty; let mutable addr = ctxt.rowAddr TableNames.Property idx @@ -1257,7 +1256,7 @@ let seekReadPropertyRow ctxt idx = let typIdx = seekReadBlobIdx ctxt &addr (flags,nameIdx,typIdx) -/// Read Table MethodSemantics +/// Read Table MethodSemantics. let seekReadMethodSemanticsRow ctxt idx = ctxt.seekReadMethodSemanticsRow idx let seekReadMethodSemanticsRowUncached ctxtH idx = let ctxt = getHole ctxtH @@ -1268,7 +1267,7 @@ let seekReadMethodSemanticsRowUncached ctxtH idx = let assocIdx = seekReadHasSemanticsIdx ctxt &addr (flags,midx,assocIdx) -/// Read Table MethodImpl +/// Read Table MethodImpl. let seekReadMethodImplRow ctxt idx = count ctxt.countMethodImpl; let mutable addr = ctxt.rowAddr TableNames.MethodImpl idx @@ -1277,21 +1276,21 @@ let seekReadMethodImplRow ctxt idx = let mdeclIdx = seekReadMethodDefOrRefIdx ctxt &addr (tidx,mbodyIdx,mdeclIdx) -/// Read Table ILModuleRef +/// Read Table ILModuleRef. let seekReadModuleRefRow ctxt idx = count ctxt.countModuleRef; let mutable addr = ctxt.rowAddr TableNames.ModuleRef idx let nameIdx = seekReadStringIdx ctxt &addr nameIdx -/// Read Table ILTypeSpec +/// Read Table ILTypeSpec. let seekReadTypeSpecRow ctxt idx = count ctxt.countTypeSpec; let mutable addr = ctxt.rowAddr TableNames.TypeSpec idx let blobIdx = seekReadBlobIdx ctxt &addr blobIdx -/// Read Table ImplMap +/// Read Table ImplMap. let seekReadImplMapRow ctxt idx = count ctxt.countImplMap; let mutable addr = ctxt.rowAddr TableNames.ImplMap idx @@ -1301,7 +1300,7 @@ let seekReadImplMapRow ctxt idx = let scopeIdx = seekReadUntaggedIdx TableNames.ModuleRef ctxt &addr (flags, forwrdedIdx, nameIdx, scopeIdx) -/// Read Table FieldRVA +/// Read Table FieldRVA. let seekReadFieldRVARow ctxt idx = count ctxt.countFieldRVA; let mutable addr = ctxt.rowAddr TableNames.FieldRVA idx @@ -1309,7 +1308,7 @@ let seekReadFieldRVARow ctxt idx = let fidx = seekReadUntaggedIdx TableNames.Field ctxt &addr (rva,fidx) -/// Read Table Assembly +/// Read Table Assembly. let seekReadAssemblyRow ctxt idx = count ctxt.countAssembly; let mutable addr = ctxt.rowAddr TableNames.Assembly idx @@ -1324,7 +1323,7 @@ let seekReadAssemblyRow ctxt idx = let localeIdx = seekReadStringIdx ctxt &addr (hash,v1,v2,v3,v4,flags,publicKeyIdx, nameIdx, localeIdx) -/// Read Table ILAssemblyRef +/// Read Table ILAssemblyRef. let seekReadAssemblyRefRow ctxt idx = count ctxt.countAssemblyRef; let mutable addr = ctxt.rowAddr TableNames.AssemblyRef idx @@ -1339,7 +1338,7 @@ let seekReadAssemblyRefRow ctxt idx = let hashValueIdx = seekReadBlobIdx ctxt &addr (v1,v2,v3,v4,flags,publicKeyOrTokenIdx, nameIdx, localeIdx,hashValueIdx) -/// Read Table File +/// Read Table File. let seekReadFileRow ctxt idx = count ctxt.countFile; let mutable addr = ctxt.rowAddr TableNames.File idx @@ -1348,7 +1347,7 @@ let seekReadFileRow ctxt idx = let hashValueIdx = seekReadBlobIdx ctxt &addr (flags, nameIdx, hashValueIdx) -/// Read Table ILExportedTypeOrForwarder +/// Read Table ILExportedTypeOrForwarder. let seekReadExportedTypeRow ctxt idx = count ctxt.countExportedType; let mutable addr = ctxt.rowAddr TableNames.ExportedType idx @@ -1359,7 +1358,7 @@ let seekReadExportedTypeRow ctxt idx = let implIdx = seekReadImplementationIdx ctxt &addr (flags,tok,nameIdx,namespaceIdx,implIdx) -/// Read Table ManifestResource +/// Read Table ManifestResource. let seekReadManifestResourceRow ctxt idx = count ctxt.countManifestResource; let mutable addr = ctxt.rowAddr TableNames.ManifestResource idx @@ -1369,7 +1368,7 @@ let seekReadManifestResourceRow ctxt idx = let implIdx = seekReadImplementationIdx ctxt &addr (offset,flags,nameIdx,implIdx) -/// Read Table Nested +/// Read Table Nested. let seekReadNestedRow ctxt idx = ctxt.seekReadNestedRow idx let seekReadNestedRowUncached ctxtH idx = let ctxt = getHole ctxtH @@ -1379,7 +1378,7 @@ let seekReadNestedRowUncached ctxtH idx = let enclIdx = seekReadUntaggedIdx TableNames.TypeDef ctxt &addr (nestedIdx,enclIdx) -/// Read Table GenericParam +/// Read Table GenericParam. let seekReadGenericParamRow ctxt idx = count ctxt.countGenericParam; let mutable addr = ctxt.rowAddr TableNames.GenericParam idx @@ -1389,7 +1388,7 @@ let seekReadGenericParamRow ctxt idx = let nameIdx = seekReadStringIdx ctxt &addr (idx,seq,flags,ownerIdx,nameIdx) -// Read Table GenericParamConstraint +// Read Table GenericParamConstraint. let seekReadGenericParamConstraintRow ctxt idx = count ctxt.countGenericParamConstraint; let mutable addr = ctxt.rowAddr TableNames.GenericParamConstraint idx @@ -1397,7 +1396,7 @@ let seekReadGenericParamConstraintRow ctxt idx = let constraintIdx = seekReadTypeDefOrRefOrSpecIdx ctxt &addr (pidx,constraintIdx) -/// Read Table ILMethodSpec +/// Read Table ILMethodSpec. let seekReadMethodSpecRow ctxt idx = count ctxt.countMethodSpec; let mutable addr = ctxt.rowAddr TableNames.MethodSpec idx @@ -2040,8 +2039,8 @@ and sigptrGetTy ctxt numtypars bytes sigptr = let lobounds, sigptr = sigptrFold sigptrGetZInt32 numLoBounded bytes sigptr let shape = let dim i = - (if i < numLoBounded then Some (List.nth lobounds i) else None), - (if i < numSized then Some (List.nth sizes i) else None) + (if i < numLoBounded then Some (List.item i lobounds) else None), + (if i < numSized then Some (List.item i sizes) else None) ILArrayShape (Array.toList (Array.init rank dim)) mkILArrTy (typ, shape), sigptr @@ -2091,9 +2090,8 @@ and sigptrGetLocal ctxt numtypars bytes sigptr = else false, sigptr let typ, sigptr = sigptrGetTy ctxt numtypars bytes sigptr - { IsPinned = pinned; - Type = typ; - DebugInfo = None }, sigptr + let loc : ILLocal = { IsPinned = pinned; Type = typ; DebugInfo = None } + loc, sigptr and readBlobHeapAsMethodSig ctxt numtypars blobIdx = ctxt.readBlobHeapAsMethodSig (BlobAsMethodSigIdx (numtypars,blobIdx)) @@ -2363,7 +2361,7 @@ and seekReadMethod ctxt numtypars (idx:int) = and seekReadParams ctxt (retty,argtys) pidx1 pidx2 = let retRes : ILReturn ref = ref { Marshal=None; Type=retty; CustomAttrs=emptyILCustomAttrs } - let paramsRes = + let paramsRes : ILParameter [] = argtys |> ILList.toArray |> Array.map (fun ty -> @@ -2804,14 +2802,12 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = let offsDest = (seekReadInt32 ctxt.is (start + (!curr))) curr := !curr + 4; let dest = !curr + offsDest - let next = !curr - f prefixes (rawToLabel dest, rawToLabel next) + f prefixes (rawToLabel dest) | I_conditional_i8_instr f -> let offsDest = int (seekReadSByte ctxt.is (start + (!curr))) curr := !curr + 1; let dest = !curr + offsDest - let next = !curr - f prefixes (rawToLabel dest, rawToLabel next) + f prefixes (rawToLabel dest) | I_unconditional_i32_instr f -> let offsDest = (seekReadInt32 ctxt.is (start + (!curr))) curr := !curr + 4; @@ -2853,18 +2849,13 @@ and seekReadTopCode ctxt numtypars (sz:int) start seqpoints = curr := !curr + 4; i) let dests = List.map (fun offs -> rawToLabel (!curr + offs)) offsets - let next = rawToLabel !curr - f prefixes (dests,next) + f prefixes dests ibuf.Add instr done; // Finished reading instructions - mark the end of the instruction stream in case the PDB information refers to it. markAsInstructionStart !curr ibuf.Count; // Build the function that maps from raw labels (offsets into the bytecode stream) to indexes in the AbsIL instruction stream - let lab2pc lab = - try - ilOffsetsOfLabels.[lab] - with :? KeyNotFoundException-> - failwith ("branch destination "+formatCodeLabel lab+" not found in code") + let lab2pc = ilOffsetsOfLabels // Some offsets used in debug info refer to the end of an instruction, rather than the // start of the subsequent instruction. But all labels refer to instruction starts, @@ -2934,7 +2925,7 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = |> List.filter (fun l -> let k,_idx = pdbVariableGetAddressAttributes l k = 1 (* ADDR_IL_OFFSET *)) - let ilinfos = + let ilinfos : ILLocalDebugMapping list = ilvs |> List.map (fun ilv -> let _k,idx = pdbVariableGetAddressAttributes ilv let n = pdbVariableGetName ilv @@ -2943,9 +2934,8 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = let thisOne = (fun raw2nextLab -> - { locRange= (raw2nextLab a,raw2nextLab b); - locInfos = ilinfos }) - // this scope covers IL range: "+string a+"-"+string b) + { Range= (raw2nextLab a,raw2nextLab b); + DebugMappings = ilinfos } : ILLocalDebugInfo ) let others = List.foldBack (scopes >> (@)) (Array.toList (pdbScopeGetChildren scp)) [] thisOne :: others let localPdbInfos = [] (* scopes fail for mscorlib scopes rootScope *) @@ -2966,7 +2956,7 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = let instrs,_,lab2pc,raw2nextLab = seekReadTopCode ctxt numtypars codeSize codeBase seqpoints (* Convert the linear code format to the nested code format *) let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos - let code = checkILCode (buildILCode nm lab2pc instrs [] localPdbInfos2) + let code = buildILCode nm lab2pc instrs [] localPdbInfos2 MethodBody.IL { IsZeroInit=false; MaxStack= 8; @@ -3080,7 +3070,7 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = else sehMap.[key] <- [clause]) clauses; - Seq.fold (fun acc (KeyValue(key,bs)) -> {exnRange=key; exnClauses=bs} :: acc) [] sehMap + ([],sehMap) ||> Seq.fold (fun acc (KeyValue(key,bs)) -> [ for b in bs -> {Range=key; Clause=b} : ILExceptionSpec ] @ acc) seh := sehClauses; moreSections := (sectionFlag &&& e_CorILMethod_Sect_MoreSects) <> 0x0uy; nextSectionBase := sectionBase + sectionSize; @@ -3090,7 +3080,7 @@ and seekReadMethodRVA ctxt (idx,nm,_internalcall,noinline,numtypars) rva = if logging then dprintn ("doing localPdbInfos2"); let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos if logging then dprintn ("done localPdbInfos2, checking code..."); - let code = checkILCode (buildILCode nm lab2pc instrs !seh localPdbInfos2) + let code = buildILCode nm lab2pc instrs !seh localPdbInfos2 if logging then dprintn ("done checking code."); MethodBody.IL { IsZeroInit=initlocals; @@ -3170,7 +3160,7 @@ and sigptrGetILNativeType ctxt bytes sigptr = if (u = int nt_MAX) then ILNativeType.Empty, sigptr' else - (* note: go back to start and read native type *) + // NOTE: go back to start and read native type sigptrGetILNativeType ctxt bytes sigptr if sigptr >= bytes.Length then ILNativeType.Array (Some nt,None), sigptr diff --git a/src/absil/ilread.fsi b/src/absil/ilread.fsi index 9a508de17b..ccc4c72185 100755 --- a/src/absil/ilread.fsi +++ b/src/absil/ilread.fsi @@ -3,7 +3,7 @@ /// Binary reader. Read a .NET binary and concert it to Abstract IL data /// structures. /// -/// Notes: +/// NOTE: /// - The metadata in the loaded modules will be relative to /// those modules, e.g. ILScopeRef.Local will mean "local to /// that module". You must use [rescopeILType] etc. if you want to include @@ -14,7 +14,7 @@ /// This indicates if you want to search for PDB files and have the /// reader fold them in. You cannot currently name the pdb file /// directly - you can only name the path. Giving "None" says -/// "do not read the PDB file even if one exists" +/// "do not read the PDB file even if one exists". /// /// The debug info appears primarily as I_seqpoint annotations in /// the instruction streams. Unfortunately the PDB information does diff --git a/src/absil/ilreflect.fs b/src/absil/ilreflect.fs index 6593025da4..ce080f66b5 100755 --- a/src/absil/ilreflect.fs +++ b/src/absil/ilreflect.fs @@ -79,7 +79,7 @@ type System.Reflection.Emit.ModuleBuilder with #else member modB.DefineDocumentAndLog(file,lang,vendor,doctype) = let symDoc = modB.DefineDocument(file,lang,vendor,doctype) - if logRefEmitCalls then printfn "let docWriter%d = moduleBuilder%d.DefineDocument(%A,System.Guid(\"%A\"),System.Guid(\"%A\"),System.Guid(\"%A\"))" (abs <| hash symDoc) (abs <| hash modB) file lang vendor doctype + if logRefEmitCalls then printfn "let docWriter%d = moduleBuilder%d.DefineDocument(@%A,System.Guid(\"%A\"),System.Guid(\"%A\"),System.Guid(\"%A\"))" (abs <| hash symDoc) (abs <| hash modB) file lang vendor doctype symDoc #endif member modB.GetTypeAndLog(nameInModule,flag1,flag2) = @@ -170,19 +170,20 @@ type System.Reflection.Emit.TypeBuilder with member typB.DefineConstructorAndLog(attrs,cconv,parms) = let consB = typB.DefineConstructor(attrs,cconv,parms) - if logRefEmitCalls then printfn "let constructorBuilder%d = typeBuilder%d.DefineConstructor(enum %d,%A,%A)" (abs <| hash consB) (abs <| hash typB) (LanguagePrimitives.EnumToValue attrs) cconv parms + if logRefEmitCalls then printfn "let constructorBuilder%d = typeBuilder%d.DefineConstructor(enum %d,CallingConventions.%A,%A)" (abs <| hash consB) (abs <| hash typB) (LanguagePrimitives.EnumToValue attrs) cconv parms consB member typB.DefineFieldAndLog(nm,ty:System.Type,attrs) = - if logRefEmitCalls then printfn "typeBuilder%d.DefineField(\"%s\",typeof<%s>,enum %d)" (abs <| hash typB) nm ty.FullName (LanguagePrimitives.EnumToValue attrs) - typB.DefineField(nm,ty,attrs) + let fieldB = typB.DefineField(nm,ty,attrs) + if logRefEmitCalls then printfn "let fieldBuilder%d = typeBuilder%d.DefineField(\"%s\",typeof<%s>,enum %d)" (abs <| hash fieldB) (abs <| hash typB) nm ty.FullName (LanguagePrimitives.EnumToValue attrs) + fieldB - member typB.DefinePropertyAndLog(nm,attrs,ty,args) = - if logRefEmitCalls then printfn "typeBuilder%d.DefineProperty(\"%A\",enum %d,%A,%A)" (abs <| hash typB) nm (LanguagePrimitives.EnumToValue attrs) ty args + member typB.DefinePropertyAndLog(nm,attrs,ty:System.Type,args) = + if logRefEmitCalls then printfn "typeBuilder%d.DefineProperty(\"%A\",enum %d,typeof<%s>,%A)" (abs <| hash typB) nm (LanguagePrimitives.EnumToValue attrs) ty.FullName args typB.DefineProperty(nm,attrs,ty,args) - member typB.DefineEventAndLog(nm,attrs,ty) = - if logRefEmitCalls then printfn "typeBuilder%d.DefineEvent(\"%A\",enum %d,%A)" (abs <| hash typB) nm (LanguagePrimitives.EnumToValue attrs) ty + member typB.DefineEventAndLog(nm,attrs,ty:System.Type) = + if logRefEmitCalls then printfn "typeBuilder%d.DefineEvent(\"%A\",enum %d,typeof<%A>)" (abs <| hash typB) nm (LanguagePrimitives.EnumToValue attrs) ty.FullName typB.DefineEvent(nm,attrs,ty) member typB.SetParentAndLog(ty:System.Type) = @@ -271,16 +272,16 @@ type System.Reflection.Emit.ILGenerator with if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, %d)" (abs <| hash x) op.RefEmitName v; x.Emit(op,v) member x.EmitAndLog (op:OpCode,v:MethodInfo) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, meth_%s)" (abs <| hash x) op.RefEmitName v.Name; + if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, methodBuilder%d) // method %s" (abs <| hash x) op.RefEmitName (abs <| hash v) v.Name; x.Emit(op,v) member x.EmitAndLog (op:OpCode,v:string) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s,\"%s\")" (abs <| hash x) op.RefEmitName v; + if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s,\"@%s\")" (abs <| hash x) op.RefEmitName v; x.Emit(op,v) member x.EmitAndLog (op:OpCode,v:Type) = if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, typeof<%s>)" (abs <| hash x) op.RefEmitName v.FullName; x.Emit(op,v) member x.EmitAndLog (op:OpCode,v:FieldInfo) = - if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, field_%s)" (abs <| hash x) op.RefEmitName v.Name; + if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s, fieldBuilder%d) // field %s" (abs <| hash x) op.RefEmitName (abs <| hash v) v.Name; x.Emit(op,v) member x.EmitAndLog (op:OpCode,v:ConstructorInfo) = if logRefEmitCalls then printfn "ilg%d.Emit(OpCodes.%s,constructor_%s)" (abs <| hash x) op.RefEmitName v.DeclaringType.Name; @@ -329,14 +330,14 @@ let convAssemblyRef (aref:ILAssemblyRef) = #endif asmName -/// The global environment +/// The global environment. type cenv = { ilg: ILGlobals; generatePdb: bool; resolvePath: (ILAssemblyRef -> Choice option) } -/// Convert an Abstract IL type reference to Reflection.Emit System.Type value -// REVIEW: This ought to be an adequate substitute for this whole function, but it needs +/// Convert an Abstract IL type reference to Reflection.Emit System.Type value. +// This ought to be an adequate substitute for this whole function, but it needs // to be thoroughly tested. // Type.GetType(tref.QualifiedName) // [] ,name -> name @@ -545,7 +546,7 @@ and convTypeAux cenv emEnv preferCreated typ = | ILType.Byref eltType -> let baseT = convTypeAux cenv emEnv preferCreated eltType |> nonNull "convType: byref eltType" baseT.MakeByRefType() |> nonNull "convType: byref" | ILType.TypeVar tv -> envGetTyvar emEnv tv |> nonNull "convType: tyvar" - // XXX: REVIEW: complete the following cases. + // Consider completing the following cases: | ILType.Modified (false, _, modifiedTy) -> convTypeAux cenv emEnv preferCreated modifiedTy | ILType.Modified (true, _, _) -> failwith "convType: modreq" | ILType.FunctionPointer _callsig -> failwith "convType: fptr" @@ -567,7 +568,7 @@ and convTypeAux cenv emEnv preferCreated typ = // If convCreatedType replaced convType functions like convMethodRef, convConstructorSpec, ... (and more?) // will need to be fixed for emitted types to handle both TypeBuilder and later Type proper. -/// Uses TypeBuilder/TypeBuilderInstantiation for emitted types +/// Uses TypeBuilder/TypeBuilderInstantiation for emitted types. let convType cenv emEnv typ = convTypeAux cenv emEnv false typ // Used for ldtoken @@ -581,7 +582,7 @@ let convTypes cenv emEnv (typs:ILTypes) = ILList.map (convType cenv emEnv) typs let convTypesToArray cenv emEnv (typs:ILTypes) = convTypes cenv emEnv typs |> ILList.toArray -/// Uses the .CreateType() for emitted type (if available) +/// Uses the .CreateType() for emitted type if available. let convCreatedType cenv emEnv typ = convTypeAux cenv emEnv true typ let convCreatedTypeRef cenv emEnv typ = convTypeRef cenv emEnv true typ @@ -803,24 +804,18 @@ let convConstructorSpec cenv emEnv (mspec:ILMethodSpec) = queryableTypeGetConstructor cenv emEnv parentTI mref //---------------------------------------------------------------------------- -// emitLabelMark, defineLabel +// emitLabelMark //---------------------------------------------------------------------------- let emitLabelMark emEnv (ilG:ILGenerator) (label:ILCodeLabel) = let lab = envGetLabel emEnv label ilG.MarkLabelAndLog(lab) - -let defineLabel (ilG:ILGenerator) emEnv (label:ILCodeLabel) = - let lab = ilG.DefineLabelAndLog() - envSetLabel emEnv label lab - - //---------------------------------------------------------------------------- // emitInstr cenv - I_arith //---------------------------------------------------------------------------- -///Emit comparison instructions +///Emit comparison instructions. let emitInstrCompare emEnv (ilG:ILGenerator) comp targ = match comp with | BI_beq -> ilG.EmitAndLog(OpCodes.Beq,envGetLabel emEnv targ) @@ -1033,10 +1028,10 @@ let rec emitInstr cenv (modB : ModuleBuilder) emEnv (ilG:ILGenerator) instr = | DT_U8 -> ilG.EmitAndLog(OpCodes.Stind_I8) // NOTE: unsigned -> int conversion | DT_REF -> ilG.EmitAndLog(OpCodes.Stind_Ref)) | I_stloc u16 -> ilG.EmitAndLog(OpCodes.Stloc,int16 u16) - | I_br _ -> () + | I_br targ -> ilG.EmitAndLog(OpCodes.Br,envGetLabel emEnv targ) | I_jmp mspec -> ilG.EmitAndLog(OpCodes.Jmp,convMethodSpec cenv emEnv mspec) - | I_brcmp (comp,targ,_) -> emitInstrCompare emEnv ilG comp targ - | I_switch (labels,_) -> ilG.Emit(OpCodes.Switch,Array.ofList (List.map (envGetLabel emEnv) labels)); + | I_brcmp (comp,targ) -> emitInstrCompare emEnv ilG comp targ + | I_switch labels -> ilG.Emit(OpCodes.Switch,Array.ofList (List.map (envGetLabel emEnv) labels)); | I_ret -> ilG.EmitAndLog(OpCodes.Ret) | I_call (tail,mspec,varargs) -> emitSilverlightCheck ilG emitInstrCall cenv emEnv ilG OpCodes.Call tail mspec varargs @@ -1059,14 +1054,14 @@ let rec emitInstr cenv (modB : ModuleBuilder) emEnv (ilG:ILGenerator) instr = | I_ldftn mspec -> ilG.EmitAndLog(OpCodes.Ldftn,convMethodSpec cenv emEnv mspec) | I_newobj (mspec,varargs) -> emitInstrNewobj cenv emEnv ilG mspec varargs | I_throw -> ilG.EmitAndLog(OpCodes.Throw) - | I_endfinally -> ilG.EmitAndLog(OpCodes.Endfinally) (* capitalization! *) - | I_endfilter -> () (* ilG.EmitAndLog(OpCodes.Endfilter) *) + | I_endfinally -> ilG.EmitAndLog(OpCodes.Endfinally) + | I_endfilter -> ilG.EmitAndLog(OpCodes.Endfilter) | I_leave label -> ilG.EmitAndLog(OpCodes.Leave,envGetLabel emEnv label) - | I_ldsfld (vol,fspec) -> emitInstrVolatile ilG vol; ilG.EmitAndLog(OpCodes.Ldsfld ,convFieldSpec cenv emEnv fspec) + | I_ldsfld (vol,fspec) -> emitInstrVolatile ilG vol; ilG.EmitAndLog(OpCodes.Ldsfld ,convFieldSpec cenv emEnv fspec) | I_ldfld (align,vol,fspec) -> emitInstrAlign ilG align; emitInstrVolatile ilG vol; ilG.EmitAndLog(OpCodes.Ldfld ,convFieldSpec cenv emEnv fspec) - | I_ldsflda fspec -> ilG.EmitAndLog(OpCodes.Ldsflda,convFieldSpec cenv emEnv fspec) - | I_ldflda fspec -> ilG.EmitAndLog(OpCodes.Ldflda ,convFieldSpec cenv emEnv fspec) - | I_stsfld (vol,fspec) -> emitInstrVolatile ilG vol; ilG.EmitAndLog(OpCodes.Stsfld ,convFieldSpec cenv emEnv fspec) + | I_ldsflda fspec -> ilG.EmitAndLog(OpCodes.Ldsflda,convFieldSpec cenv emEnv fspec) + | I_ldflda fspec -> ilG.EmitAndLog(OpCodes.Ldflda ,convFieldSpec cenv emEnv fspec) + | I_stsfld (vol,fspec) -> emitInstrVolatile ilG vol; ilG.EmitAndLog(OpCodes.Stsfld ,convFieldSpec cenv emEnv fspec) | I_stfld (align,vol,fspec) -> emitInstrAlign ilG align; emitInstrVolatile ilG vol; ilG.EmitAndLog(OpCodes.Stfld ,convFieldSpec cenv emEnv fspec) | I_ldstr s -> ilG.EmitAndLog(OpCodes.Ldstr ,s) | I_isinst typ -> ilG.EmitAndLog(OpCodes.Isinst ,convType cenv emEnv typ) @@ -1179,9 +1174,11 @@ let rec emitInstr cenv (modB : ModuleBuilder) emEnv (ilG:ILGenerator) instr = | I_refanyval typ -> ilG.EmitAndLog(OpCodes.Refanyval,convType cenv emEnv typ) | I_rethrow -> ilG.EmitAndLog(OpCodes.Rethrow) | I_break -> ilG.EmitAndLog(OpCodes.Break) + | I_seqpoint src -> #if FX_RESHAPED_REFEMIT + ignore src + () #else - | I_seqpoint src -> if cenv.generatePdb && not (src.Document.File.EndsWith("stdin",StringComparison.Ordinal)) then let guid x = match x with None -> Guid.Empty | Some g -> Guid(g:byte[]) in let symDoc = modB.DefineDocumentAndLog(src.Document.File, guid src.Document.Language, guid src.Document.Vendor, guid src.Document.DocumentType) @@ -1198,77 +1195,60 @@ let rec emitInstr cenv (modB : ModuleBuilder) emEnv (ilG:ILGenerator) instr = | EI_ldlen_multi (_,m) -> emitInstr cenv modB emEnv ilG (mkLdcInt32 m); emitInstr cenv modB emEnv ilG (mkNormalCall(mkILNonGenericMethSpecInTy(cenv.ilg.typ_Array, ILCallingConv.Instance, "GetLength", [cenv.ilg.typ_int32], cenv.ilg.typ_int32))) - | I_other e when isIlxExtInstr e -> Printf.failwithf "the ILX instruction %s cannot be emitted" (e.ToString()) | i -> Printf.failwithf "the IL instruction %s cannot be emitted" (i.ToString()) -//---------------------------------------------------------------------------- -// emitCode -//---------------------------------------------------------------------------- -let emitBasicBlock cenv modB emEnv (ilG:ILGenerator) bblock = - emitLabelMark emEnv ilG bblock.Label; - Array.iter (emitInstr cenv modB emEnv ilG) bblock.Instructions; - -let emitCode cenv modB emEnv (ilG:ILGenerator) code = - // pre define labels pending determining their actual marks - let labels = labelsOfCode code - let emEnv = List.fold (defineLabel ilG) emEnv labels +let emitCode cenv modB emEnv (ilG:ILGenerator) (code: ILCode) = + // Pre-define the labels pending determining their actual marks + let pc2lab = Dictionary() + let emEnv = + (emEnv, code.Labels) ||> Seq.fold (fun emEnv (KeyValue(label,pc)) -> + let lab = ilG.DefineLabelAndLog() + pc2lab.[pc] <- (if pc2lab.ContainsKey pc then lab :: pc2lab.[pc] else [lab]) + envSetLabel emEnv label lab) - let emitSusp susp = - match susp with - | Some dest -> ilG.EmitAndLog(OpCodes.Br, envGetLabel emEnv dest) - | _ -> () - - let commitSusp susp lab = - match susp with - | Some dest when dest <> lab -> emitSusp susp - | _ -> () - - let rec emitter susp code = - match code with - | ILBasicBlock bblock -> - commitSusp susp bblock.Label; - emitBasicBlock cenv modB emEnv ilG bblock - bblock.Fallthrough - | GroupBlock (_localDebugInfos,codes)-> - List.fold emitter susp codes - | RestrictBlock (_labels,code) -> - code |> emitter susp (* restrictions ignorable: code_labels unique *) - | TryBlock (code,seh) -> - commitSusp susp (uniqueEntryOfCode code); - let _endExBlockL = ilG.BeginExceptionBlockAndLog() - code |> emitter None |> emitSusp - //ilG.MarkLabel endExBlockL; - emitHandler seh; - ilG.EndExceptionBlockAndLog(); - None - and emitHandler seh = - match seh with - | FaultBlock code -> - ilG.BeginFaultBlockAndLog(); - emitter None code |> emitSusp - | FinallyBlock code -> - ilG.BeginFinallyBlockAndLog(); - emitter None code |> emitSusp - | FilterCatchBlock fcodes -> - let emitFilter (filter,code) = - match filter with - | TypeFilter typ -> - ilG.BeginCatchBlockAndLog (convType cenv emEnv typ); - emitter None code |> emitSusp - - | CodeFilter test -> - ilG.BeginExceptFilterBlockAndLog(); - emitter None test |> emitSusp - ilG.BeginCatchBlockAndLog null; - emitter None code |> emitSusp - fcodes |> List.iter emitFilter - let initialSusp = Some (uniqueEntryOfCode code) - emitter initialSusp code |> emitSusp - -//---------------------------------------------------------------------------- -// emitILMethodBody -//---------------------------------------------------------------------------- + // Build a table that contains the operations that define where exception handlers are + let pc2action = Dictionary() + let lab2pc = code.Labels + let add lab action = + let pc = lab2pc.[lab] + pc2action.[pc] <- (if pc2action.ContainsKey pc then pc2action.[pc] @ [ action ] else [ action ]) + + for e in code.Exceptions do + let (startTry,_endTry) = e.Range + + add startTry (fun () -> ilG.BeginExceptionBlockAndLog() |> ignore) + + match e.Clause with + | ILExceptionClause.Finally(startHandler,endHandler) -> + add startHandler ilG.BeginFinallyBlockAndLog + add endHandler ilG.EndExceptionBlockAndLog + | ILExceptionClause.Fault(startHandler,endHandler) -> + add startHandler ilG.BeginFaultBlockAndLog + add endHandler ilG.EndExceptionBlockAndLog + | ILExceptionClause.FilterCatch((startFilter,_),(startHandler,endHandler)) -> + add startFilter ilG.BeginExceptFilterBlockAndLog + add startHandler (fun () -> ilG.BeginCatchBlockAndLog null) + add endHandler ilG.EndExceptionBlockAndLog + | ILExceptionClause.TypeCatch(typ, (startHandler,endHandler)) -> + add startHandler (fun () -> ilG.BeginCatchBlockAndLog (convType cenv emEnv typ)) + add endHandler ilG.EndExceptionBlockAndLog + + // Emit the instructions + let instrs = code.Instrs + + for pc = 0 to instrs.Length do + if pc2action.ContainsKey pc then + for action in pc2action.[pc] do + action() + if pc2lab.ContainsKey pc then + for lab in pc2lab.[pc] do + ilG.MarkLabelAndLog lab + if pc < instrs.Length then + match instrs.[pc] with + | I_br l when code.Labels.[l] = pc + 1 -> () // compress I_br to next instruction + | i -> emitInstr cenv modB emEnv ilG i + let emitLocal cenv emEnv (ilG : ILGenerator) (local: ILLocal) = let ty = convType cenv emEnv local.Type @@ -1281,20 +1261,12 @@ let emitLocal cenv emEnv (ilG : ILGenerator) (local: ILLocal) = #endif locBuilder -let emitILMethodBody cenv modB emEnv (ilG:ILGenerator) ilmbody = - // XXX - REVIEW: - // NoInlining: bool; - // SourceMarker: source option } - // emit locals and record emEnv +let emitILMethodBody cenv modB emEnv (ilG:ILGenerator) (ilmbody: ILMethodBody) = let localBs = Array.map (emitLocal cenv emEnv ilG) (ILList.toArray ilmbody.Locals) let emEnv = envSetLocals emEnv localBs emitCode cenv modB emEnv ilG ilmbody.Code -//---------------------------------------------------------------------------- -// emitMethodBody -//---------------------------------------------------------------------------- - let emitMethodBody cenv modB emEnv ilG _name (mbody: ILLazyMethodBody) = match mbody.Contents with | MethodBody.IL ilmbody -> emitILMethodBody cenv modB emEnv (ilG()) ilmbody @@ -1302,11 +1274,6 @@ let emitMethodBody cenv modB emEnv ilG _name (mbody: ILLazyMethodBody) = | MethodBody.Abstract -> () (* printf "EMIT: abstract method %s\n" name *) (* XXX - check *) | MethodBody.Native -> failwith "emitMethodBody cenv: native" (* XXX - gap *) - -//---------------------------------------------------------------------------- -// emitCustomAttrs -//---------------------------------------------------------------------------- - let convCustomAttr cenv emEnv cattr = let methInfo = match convConstructorSpec cenv emEnv cattr.Method with @@ -1368,16 +1335,17 @@ let buildGenParamsPass1b cenv emEnv (genArgs : Type array) (gps : ILGenericParam // emitParameter //---------------------------------------------------------------------------- -let emitParameter cenv emEnv (defineParameter : int * ParameterAttributes * string -> ParameterBuilder) i param = +let emitParameter cenv emEnv (defineParameter : int * ParameterAttributes * string -> ParameterBuilder) i (param: ILParameter) = // -Type: typ; // -Default: ILFieldInit option; // -Marshal: NativeType option; (* Marshalling map for parameters. COM Interop only. *) let attrs = flagsIf param.IsIn ParameterAttributes.In ||| flagsIf param.IsOut ParameterAttributes.Out ||| flagsIf param.IsOptional ParameterAttributes.Optional - let name = match param.Name with - | Some name -> name - | None -> "X"^string(i+1) + let name = + match param.Name with + | Some name -> name + | None -> "X" + string(i+1) let parB = defineParameter(i,attrs,name) emitCustomAttrs cenv emEnv (wrapCustomAttr parB.SetCustomAttribute) param.CustomAttrs @@ -1433,10 +1401,6 @@ let convMethodImplFlags mdef = //---------------------------------------------------------------------------- let rec buildMethodPass2 cenv tref (typB:TypeBuilder) emEnv (mdef : ILMethodDef) = - // remaining REVIEW: - // SecurityDecls: Permissions; - // IsUnmanagedExport: bool; (* -- The method is exported to unmanaged code using COM interop. *) - // IsMustRun: bool; (* Whidbey feature: SafeHandle finalizer must be run *) let attrs = convMethodAttributes mdef let implflags = convMethodImplFlags mdef let cconv = convCallConv mdef.CallingConv @@ -1499,7 +1463,7 @@ let rec buildMethodPass2 cenv tref (typB:TypeBuilder) emEnv (mdef : ILMethodDef) consB.SetImplementationFlagsAndLog(implflags); envBindConsRef emEnv mref consB | _name -> - // Note the return/argument types may involve the generic parameters + // The return/argument types may involve the generic parameters let methB = typB.DefineMethodAndLog(mdef.Name,attrs,cconv) // Method generic type parameters @@ -1507,7 +1471,7 @@ let rec buildMethodPass2 cenv tref (typB:TypeBuilder) emEnv (mdef : ILMethodDef) let genArgs = getGenericArgumentsOfMethod methB let emEnv = envPushTyvars emEnv (Array.append (getGenericArgumentsOfType (typB.AsType())) genArgs) buildGenParamsPass1b cenv emEnv genArgs mdef.GenericParams; - // set parameter and return types (may depend on generic args) + // Set parameter and return types (may depend on generic args) methB.SetParametersAndLog(convTypesToArray cenv emEnv mdef.ParameterTypes); methB.SetReturnTypeAndLog(convType cenv emEnv mdef.Return.Type); let emEnv = envPopTyvars emEnv @@ -1595,7 +1559,8 @@ let buildFieldPass2 cenv tref (typB:TypeBuilder) emEnv (fdef : ILFieldDef) = | Some initial -> if not fieldT.IsEnum #if FX_ATLEAST_45 - || not fieldT.Assembly.IsDynamic // it is ok to init fields with type = enum that are defined in other assemblies + // it is ok to init fields with type = enum that are defined in other assemblies + || not fieldT.Assembly.IsDynamic #endif then fieldB.SetConstant(convFieldInit initial) @@ -1681,7 +1646,6 @@ let typeAttrbutesOfTypeDefKind x = | ILTypeDefKind.Interface -> TypeAttributes.Interface | ILTypeDefKind.Enum -> TypeAttributes.Class | ILTypeDefKind.Delegate -> TypeAttributes.Class - | ILTypeDefKind.Other _xtdk -> failwith "typeAttributes of other external" let typeAttrbutesOfTypeAccess x = match x with diff --git a/src/absil/ilsign.fs b/src/absil/ilsign.fs index 5e7619c0dc..f8a31ffbf5 100644 --- a/src/absil/ilsign.fs +++ b/src/absil/ilsign.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Open Technologies, Inc. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. +// Copyright (c) Microsoft. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. module internal Microsoft.FSharp.Compiler.AbstractIL.Internal.StrongNameSign diff --git a/src/absil/ilsupp.fs b/src/absil/ilsupp.fs index f2b6f6fef6..71ed382519 100755 --- a/src/absil/ilsupp.fs +++ b/src/absil/ilsupp.fs @@ -784,7 +784,7 @@ let unlinkResource (ulLinkedResourceBaseRVA:int32) (pbLinkedResource:byte[]) = let pResNodes : ResFormatNode [] = Array.zeroCreate nResNodes nResNodes <- 0 ; - // fill out the entry buffer + // fill out the entry buffer for iEntry = 0 to ((int)nEntries - 1) do pirdeType <- bytesToIRDE pbLinkedResource (IMAGE_RESOURCE_DIRECTORY.Width + (iEntry * IMAGE_RESOURCE_DIRECTORY_ENTRY.Width)) ; let dwTypeID = pirdeType.Name @@ -1099,7 +1099,7 @@ let internal setCheckSum (url:string, writer:ISymUnmanagedDocumentWriter) = with _ -> () let pdbDefineDocument (writer:PdbWriter) (url:string) = - //3F5162F8-07C6-11D3-9053-00C04FA302A1 + //3F5162F8-07C6-11D3-9053-00C04FA302A1 //let mutable corSymLanguageTypeCSharp = System.Guid(0x3F5162F8u, 0x07C6us, 0x11D3us, 0x90uy, 0x53uy, 0x00uy, 0xC0uy, 0x4Fuy, 0xA3uy, 0x02uy, 0xA1uy) let mutable corSymLanguageTypeFSharp = System.Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy) let mutable corSymLanguageVendorMicrosoft = System.Guid(0x994b45c4u, 0xe6e9us, 0x11d2us, 0x90uy, 0x3fuy, 0x00uy, 0xc0uy, 0x4fuy, 0xa3uy, 0x02uy, 0xa1uy) @@ -1200,7 +1200,7 @@ let pdbReadOpen (moduleName:string) (path:string) : PdbReader = if IntPtr.Zero <> importerPtr then Marshal.Release(importerPtr) |> ignore -// Note, the symbol reader's finalize method will clean up any unmanaged resources. +// The symbol reader's finalize method will clean up any unmanaged resources. // If file locks persist, we may want to manually invoke finalize let pdbReadClose (_reader:PdbReader) : unit = () @@ -1278,7 +1278,7 @@ let pdbVariableGetName (variable:PdbVariable) : string = let pdbVariableGetSignature (variable:PdbVariable) : byte[] = variable.symVariable.GetSignature() -// the tuple is (AddressKind, AddressField1) +// The tuple is (AddressKind, AddressField1) let pdbVariableGetAddressAttributes (variable:PdbVariable) : (int32 * int32) = (int32 variable.symVariable.AddressKind,variable.symVariable.AddressField1) #endif @@ -1315,7 +1315,7 @@ let signerSignFileWithKeyContainer (_fileName:string) (_kcName:keyContainerName) raise (NotImplementedException("signerSignFileWithKeyContainer is not yet implemented")) #else -// new mscoree functionality +// New mscoree functionality // This type represents methods that we don't currently need, so I'm leaving unimplemented type UnusedCOMMethod = unit -> unit [] @@ -1326,17 +1326,17 @@ type ICLRMetaHost = [] version : string * [] interfaceId : System.Guid -> [] System.Object - // Note, methods that we don't need are stubbed out for now... + // Methods that we don't need are stubbed out for now... abstract GetVersionFromFile : UnusedCOMMethod abstract EnumerateInstalledRuntimes : UnusedCOMMethod abstract EnumerateLoadedRuntimes : UnusedCOMMethod abstract Reserved01 : UnusedCOMMethod -// Note, We don't currently support ComConversionLoss +// We don't currently support ComConversionLoss [] [] type ICLRStrongName = - // Note, methods that we don't need are stubbed out for now... + // Methods that we don't need are stubbed out for now... abstract GetHashFromAssemblyFile : UnusedCOMMethod abstract GetHashFromAssemblyFileW : UnusedCOMMethod abstract GetHashFromBlob : UnusedCOMMethod diff --git a/src/absil/ilwrite.fs b/src/absil/ilwrite.fs index 3fb502440c..993b78959b 100755 --- a/src/absil/ilwrite.fs +++ b/src/absil/ilwrite.fs @@ -334,29 +334,6 @@ type StringIndex = int let BlobIndex (x:BlobIndex) : int = x let StringIndex (x:StringIndex) : int = x -/// Abstract, general type of metadata table rows -type IGenericRow = - abstract GetGenericRow : unit -> RowElement[] - -/// Shared rows are used for the ILTypeRef, ILMethodRef, ILMethodSpec, etc. tables -/// where entries can be shared and need to be made unique through hash-cons'ing -type ISharedRow = - inherit IGenericRow - -/// This is the representation of shared rows is used for most shared row types. -/// Rows ILAssemblyRef and ILMethodRef are very common and are given their own -/// representations. -type SimpleSharedRow(elems: RowElement[]) = - let hashCode = hash elems // precompute to give more efficient hashing and equality comparisons - interface ISharedRow with - member x.GetGenericRow() = elems - member x.GenericRow = elems - override x.GetHashCode() = hashCode - override x.Equals(obj:obj) = - match obj with - | :? SimpleSharedRow as y -> elems = y.GenericRow - | _ -> false - let inline combineHash x2 acc = 37 * acc + x2 // (acc <<< 6 + acc >>> 2 + x2 + 0x9e3779b9) let hashRow (elems:RowElement[]) = @@ -375,44 +352,47 @@ let equalRows (elems:RowElement[]) (elems2:RowElement[]) = i <- i + 1 ok -/// Unshared rows are used for definitional tables where elements do not need to be made unique -/// e.g. ILMethodDef and ILTypeDef. Most tables are like this. We don't precompute a -/// hash code for these rows, and indeed the GetHashCode and Equals should not be needed. -type UnsharedRow(elems: RowElement[]) = - interface IGenericRow with - member x.GetGenericRow() = elems + +type GenericRow = RowElement[] + +/// This is the representation of shared rows is used for most shared row types. +/// Rows ILAssemblyRef and ILMethodRef are very common and are given their own +/// representations. +[] +type SharedRow(elems: RowElement[], hashCode: int) = member x.GenericRow = elems - override x.GetHashCode() = hashRow elems + override x.GetHashCode() = hashCode override x.Equals(obj:obj) = match obj with - | :? UnsharedRow as y -> equalRows elems y.GenericRow + | :? SharedRow as y -> equalRows elems y.GenericRow | _ -> false - -/// Special representation for ILAssemblyRef rows with pre-computed hash -type AssemblyRefRow(s1,s2,s3,s4,l1,b1,nameIdx,str2,b2) = + +let SharedRow(elems: RowElement[]) = new SharedRow(elems, hashRow elems) + +/// Special representation : Note, only hashing by name +let AssemblyRefRow(s1,s2,s3,s4,l1,b1,nameIdx,str2,b2) = let hashCode = hash nameIdx let genericRow = [| UShort s1; UShort s2; UShort s3; UShort s4; ULong l1; Blob b1; StringE nameIdx; StringE str2; Blob b2 |] - interface ISharedRow with - member x.GetGenericRow() = genericRow - member x.GenericRow = genericRow - override x.GetHashCode() = hashCode - override x.Equals(obj:obj) = - match obj with - | :? AssemblyRefRow as y -> equalRows genericRow y.GenericRow - | _ -> false + new SharedRow(genericRow, hashCode) -/// Special representation of a very common kind of row with pre-computed hash -type MemberRefRow(mrp:RowElement,nmIdx:StringIndex,blobIdx:BlobIndex) = - let hash = combineHash (hash blobIdx) (combineHash (hash nmIdx) (hash mrp)) +/// Special representation the computes the hash more efficiently +let MemberRefRow(mrp:RowElement,nmIdx:StringIndex,blobIdx:BlobIndex) = + let hashCode = combineHash (hash blobIdx) (combineHash (hash nmIdx) (hash mrp)) let genericRow = [| mrp; StringE nmIdx; Blob blobIdx |] - interface ISharedRow with - member x.GetGenericRow() = genericRow - member x.GenericRow = genericRow - override x.GetHashCode() = hash + new SharedRow(genericRow, hashCode) + +/// Unshared rows are used for definitional tables where elements do not need to be made unique +/// e.g. ILMethodDef and ILTypeDef. Most tables are like this. We don't precompute a +/// hash code for these rows, and indeed the GetHashCode and Equals should not be needed. +[] +type UnsharedRow(elems: RowElement[]) = + member x.GenericRow = elems + override x.GetHashCode() = hashRow elems override x.Equals(obj:obj) = match obj with - | :? MemberRefRow as y -> equalRows genericRow y.GenericRow + | :? UnsharedRow as y -> equalRows elems y.GenericRow | _ -> false + //===================================================================== //===================================================================== @@ -555,6 +535,18 @@ type TypeDefTableKey = TdKey of string list (* enclosing *) * string (* type nam // The Writer Context //--------------------------------------------------------------------- +[] +type MetadataTable = + | Shared of MetadataTable + | Unshared of MetadataTable + member t.FindOrAddSharedEntry(x) = match t with Shared u -> u.FindOrAddSharedEntry(x) | Unshared u -> failwithf "FindOrAddSharedEntry: incorrect table kind, u.name = %s" u.name + member t.AddSharedEntry(x) = match t with | Shared u -> u.AddSharedEntry(x) | Unshared u -> failwithf "AddSharedEntry: incorrect table kind, u.name = %s" u.name + member t.AddUnsharedEntry(x) = match t with Unshared u -> u.AddUnsharedEntry(x) | Shared u -> failwithf "AddUnsharedEntry: incorrect table kind, u.name = %s" u.name + member t.GenericRowsOfTable = match t with Unshared u -> u.EntriesAsArray |> Array.map (fun x -> x.GenericRow) | Shared u -> u.EntriesAsArray |> Array.map (fun x -> x.GenericRow) + member t.SetRowsOfSharedTable rows = match t with Shared u -> u.SetRowsOfTable (Array.map SharedRow rows) | Unshared u -> failwithf "SetRowsOfSharedTable: incorrect table kind, u.name = %s" u.name + member t.Count = match t with Unshared u -> u.Count | Shared u -> u.Count + + [] type cenv = { primaryAssembly: ILScopeRef @@ -583,8 +575,8 @@ type cenv = trefCache: Dictionary /// The following are all used to generate unique items in the output - tables: array> - AssemblyRefs: MetadataTable + tables: MetadataTable[] + AssemblyRefs: MetadataTable fieldDefs: MetadataTable methodDefIdxsByKey: MetadataTable methodDefIdxs: Dictionary @@ -608,13 +600,13 @@ type cenv = member cenv.GetCode() = cenv.codeChunks.Close() -let FindOrAddRow (cenv:cenv) tbl (x:IGenericRow) = cenv.GetTable(tbl).FindOrAddSharedEntry x +let FindOrAddSharedRow (cenv:cenv) tbl x = cenv.GetTable(tbl).FindOrAddSharedEntry x // Shared rows must be hash-cons'd to be made unique (no duplicates according to contents) -let AddSharedRow (cenv:cenv) tbl (x:ISharedRow) = cenv.GetTable(tbl).AddSharedEntry (x :> IGenericRow) +let AddSharedRow (cenv:cenv) tbl x = cenv.GetTable(tbl).AddSharedEntry x // Unshared rows correspond to definition elements (e.g. a ILTypeDef or a ILMethodDef) -let AddUnsharedRow (cenv:cenv) tbl (x:UnsharedRow) = cenv.GetTable(tbl).AddUnsharedEntry (x :> IGenericRow) +let AddUnsharedRow (cenv:cenv) tbl (x:UnsharedRow) = cenv.GetTable(tbl).AddUnsharedEntry x let metadataSchemaVersionSupportedByCLRVersion v = // Whidbey Beta 1 version numbers are between 2.0.40520.0 and 2.0.40607.0 @@ -724,23 +716,23 @@ let rec GetAssemblyRefAsRow cenv (aref:ILAssemblyRef) = BlobIndex (match aref.Hash with None -> 0 | Some s -> GetBytesAsBlobIdx cenv s)) and GetAssemblyRefAsIdx cenv aref = - FindOrAddRow cenv TableNames.AssemblyRef (GetAssemblyRefAsRow cenv aref) + FindOrAddSharedRow cenv TableNames.AssemblyRef (GetAssemblyRefAsRow cenv aref) and GetModuleRefAsRow cenv (mref:ILModuleRef) = - SimpleSharedRow + SharedRow [| StringE (GetStringHeapIdx cenv mref.Name) |] and GetModuleRefAsFileRow cenv (mref:ILModuleRef) = - SimpleSharedRow + SharedRow [| ULong (if mref.HasMetadata then 0x0000 else 0x0001) StringE (GetStringHeapIdx cenv mref.Name) (match mref.Hash with None -> Blob 0 | Some s -> Blob (GetBytesAsBlobIdx cenv s)) |] and GetModuleRefAsIdx cenv mref = - FindOrAddRow cenv TableNames.ModuleRef (GetModuleRefAsRow cenv mref) + FindOrAddSharedRow cenv TableNames.ModuleRef (GetModuleRefAsRow cenv mref) and GetModuleRefAsFileIdx cenv mref = - FindOrAddRow cenv TableNames.File (GetModuleRefAsFileRow cenv mref) + FindOrAddSharedRow cenv TableNames.File (GetModuleRefAsFileRow cenv mref) // -------------------------------------------------------------------- // Does a ILScopeRef point to this module? @@ -767,12 +759,12 @@ let GetScopeRefAsImplementationElem cenv scoref = let rec GetTypeRefAsTypeRefRow cenv (tref:ILTypeRef) = let nselem,nelem = GetTypeNameAsElemPair cenv tref.Name let rs1,rs2 = GetResolutionScopeAsElem cenv (tref.Scope,tref.Enclosing) - SimpleSharedRow [| ResolutionScope (rs1,rs2); nelem; nselem |] + SharedRow [| ResolutionScope (rs1,rs2); nelem; nselem |] and GetTypeRefAsTypeRefIdx cenv tref = let mutable res = 0 if cenv.trefCache.TryGetValue(tref,&res) then res else - let res = FindOrAddRow cenv TableNames.TypeRef (GetTypeRefAsTypeRefRow cenv tref) + let res = FindOrAddSharedRow cenv TableNames.TypeRef (GetTypeRefAsTypeRefRow cenv tref) cenv.trefCache.[tref] <- res res @@ -857,14 +849,17 @@ and GetTypeAsTypeDefOrRef cenv env (ty:ILType) = and GetTypeAsBytes cenv env ty = emitBytesViaBuffer (fun bb -> EmitType cenv env bb ty) +and GetTypeOfLocalAsBytes cenv env (l: ILLocal) = + emitBytesViaBuffer (fun bb -> EmitLocalInfo cenv env bb l) + and GetTypeAsBlobIdx cenv env (ty:ILType) = GetBytesAsBlobIdx cenv (GetTypeAsBytes cenv env ty) and GetTypeAsTypeSpecRow cenv env (ty:ILType) = - SimpleSharedRow [| Blob (GetTypeAsBlobIdx cenv env ty) |] + SharedRow [| Blob (GetTypeAsBlobIdx cenv env ty) |] and GetTypeAsTypeSpecIdx cenv env ty = - FindOrAddRow cenv TableNames.TypeSpec (GetTypeAsTypeSpecRow cenv env ty) + FindOrAddSharedRow cenv TableNames.TypeSpec (GetTypeAsTypeSpecRow cenv env ty) and EmitType cenv env bb ty = match ty with @@ -920,6 +915,11 @@ and EmitType cenv env bb ty = EmitType cenv env bb ty | _ -> failwith "EmitType" +and EmitLocalInfo cenv env (bb:ByteBuffer) (l:ILLocal) = + if l.IsPinned then + bb.EmitByte et_PINNED + EmitType cenv env bb l.Type + and EmitCallsig cenv env bb (callconv,args:ILTypes,ret,varargs:ILVarArgs,genarity) = bb.EmitByte (callconvToByte genarity callconv) if genarity > 0 then bb.EmitZ32 genarity @@ -1261,7 +1261,7 @@ let FindMethodDefIdx cenv mdkey = let (TdKey (tenc2,tname2)) = typeNameOfIdx mdkey2.TypeIdx dprintn ("A method in '"+(String.concat "." (tenc2@[tname2]))+"' had the right name but the wrong signature:") dprintn ("generic arity: "+string mdkey2.GenericArity) - dprintn (sprintf "mdkey2: %A" mdkey2)) + dprintn (sprintf "mdkey2: %+A" mdkey2)) raise MethodDefNotFound @@ -1305,8 +1305,7 @@ and GetMethodRefInfoAsBlobIdx cenv env info = let GetMethodRefInfoAsMemberRefIdx cenv env ((_,typ,_,_,_,_,_) as minfo) = let fenv = envForMethodRef env typ - FindOrAddRow cenv TableNames.MemberRef - (MethodRefInfoAsMemberRefRow cenv env fenv minfo) + FindOrAddSharedRow cenv TableNames.MemberRef (MethodRefInfoAsMemberRefRow cenv env fenv minfo) let GetMethodRefInfoAsMethodRefOrDef isAlwaysMethodDef cenv env ((nm,typ:ILType,cc,args,ret,varargs,genarity) as minfo) = if isNone varargs && (isAlwaysMethodDef || isTypeLocal typ) then @@ -1327,8 +1326,8 @@ let rec GetMethodSpecInfoAsMethodSpecIdx cenv env (nm,typ,cc,args,ret,varargs,mi bb.EmitByte e_IMAGE_CEE_CS_CALLCONV_GENERICINST bb.EmitZ32 minst.Length minst |> ILList.iter (EmitType cenv env bb)) - FindOrAddRow cenv TableNames.MethodSpec - (SimpleSharedRow + FindOrAddSharedRow cenv TableNames.MethodSpec + (SharedRow [| MethodDefOrRef (mdorTag,mdorRow) Blob (GetBytesAsBlobIdx cenv blob) |]) @@ -1374,16 +1373,8 @@ and InfoOfMethodSpec (mspec:ILMethodSpec,varargs) = let rec GetOverridesSpecAsMemberRefIdx cenv env ospec = let fenv = envForOverrideSpec ospec - let row = - MethodRefInfoAsMemberRefRow cenv env fenv - (ospec.MethodRef.Name, - ospec.EnclosingType, - ospec.MethodRef.CallingConv, - ospec.MethodRef.ArgTypes, - ospec.MethodRef.ReturnType, - None, - ospec.MethodRef.GenericArity) - FindOrAddRow cenv TableNames.MemberRef row + let row = MethodRefInfoAsMemberRefRow cenv env fenv (ospec.MethodRef.Name, ospec.EnclosingType, ospec.MethodRef.CallingConv, ospec.MethodRef.ArgTypes, ospec.MethodRef.ReturnType, None, ospec.MethodRef.GenericArity) + FindOrAddSharedRow cenv TableNames.MemberRef row and GetOverridesSpecAsMethodDefOrRef cenv env (ospec:ILOverridesSpec) = let typ = ospec.EnclosingType @@ -1401,16 +1392,8 @@ and GetOverridesSpecAsMethodDefOrRef cenv env (ospec:ILOverridesSpec) = // -------------------------------------------------------------------- let rec GetMethodRefAsMemberRefIdx cenv env fenv (mref:ILMethodRef) = - let row = - MethodRefInfoAsMemberRefRow cenv env fenv - (mref.Name, - mkILNonGenericBoxedTy mref.EnclosingTypeRef, - mref.CallingConv, - mref.ArgTypes, - mref.ReturnType, - None, - mref.GenericArity) - FindOrAddRow cenv TableNames.MemberRef row + let row = MethodRefInfoAsMemberRefRow cenv env fenv (mref.Name, mkILNonGenericBoxedTy mref.EnclosingTypeRef, mref.CallingConv, mref.ArgTypes, mref.ReturnType, None, mref.GenericArity) + FindOrAddSharedRow cenv TableNames.MemberRef row and GetMethodRefAsCustomAttribType cenv (mref:ILMethodRef) = let fenv = envForNonGenericMethodRef mref @@ -1468,7 +1451,7 @@ let rec GetFieldSpecAsMemberRefRow cenv env fenv (fspec:ILFieldSpec) = and GetFieldSpecAsMemberRefIdx cenv env fspec = let fenv = envForFieldSpec fspec - FindOrAddRow cenv TableNames.MemberRef (GetFieldSpecAsMemberRefRow cenv env fenv fspec) + FindOrAddSharedRow cenv TableNames.MemberRef (GetFieldSpecAsMemberRefRow cenv env fenv fspec) // REVIEW: write into an accumuating buffer and EmitFieldSpecSig cenv env (bb: ByteBuffer) (fspec:ILFieldSpec) = @@ -1507,10 +1490,10 @@ let GetCallsigAsBlobIdx cenv env (callsig:ILCallingSignature,varargs) = callsig.ReturnType,varargs,0)) let GetCallsigAsStandAloneSigRow cenv env x = - SimpleSharedRow [| Blob (GetCallsigAsBlobIdx cenv env x) |] + SharedRow [| Blob (GetCallsigAsBlobIdx cenv env x) |] let GetCallsigAsStandAloneSigIdx cenv env info = - FindOrAddRow cenv TableNames.StandAloneSig (GetCallsigAsStandAloneSigRow cenv env info) + FindOrAddSharedRow cenv TableNames.StandAloneSig (GetCallsigAsStandAloneSigRow cenv env info) // -------------------------------------------------------------------- // local signatures --> BlobHeap idx @@ -1519,13 +1502,13 @@ let GetCallsigAsStandAloneSigIdx cenv env info = let EmitLocalSig cenv env (bb: ByteBuffer) (locals: ILLocals) = bb.EmitByte e_IMAGE_CEE_CS_CALLCONV_LOCAL_SIG bb.EmitZ32 locals.Length - locals |> ILList.iter (fun l -> EmitType cenv env bb l.Type) + locals |> ILList.iter (EmitLocalInfo cenv env bb) let GetLocalSigAsBlobHeapIdx cenv env locals = GetBytesAsBlobIdx cenv (emitBytesViaBuffer (fun bb -> EmitLocalSig cenv env bb locals)) let GetLocalSigAsStandAloneSigIdx cenv env locals = - SimpleSharedRow [| Blob (GetLocalSigAsBlobHeapIdx cenv env locals) |] + SharedRow [| Blob (GetLocalSigAsBlobHeapIdx cenv env locals) |] @@ -1604,7 +1587,7 @@ type CodeBuffer = member codebuf.RecordAvailBrFixup tg = codebuf.availBrFixups.[tg] <- codebuf.code.Position -module Codebuf = begin +module Codebuf = // -------------------------------------------------------------------- // Applying branch fixups. Use short versions of instructions // wherever possible. Sadly we can only determine if we can use a short @@ -1785,8 +1768,7 @@ module Codebuf = begin // We then emit the exception handling specs separately. // nb. ECMA spec says the SEH blocks must be returned inside-out type SEHTree = - | Tip - | Node of (ExceptionClauseSpec option * SEHTree list) list + | Node of ExceptionClauseSpec option * SEHTree list // -------------------------------------------------------------------- @@ -1794,7 +1776,7 @@ module Codebuf = begin // for all instructions. // -------------------------------------------------------------------- - let encodingsForNoArgInstrs = System.Collections.Generic.Dictionary<_,_>(300, HashIdentity.Structural) + let encodingsForNoArgInstrs = Dictionary<_,_>(300, HashIdentity.Structural) let _ = List.iter (fun (x,mk) -> encodingsForNoArgInstrs.[mk] <- x) @@ -1850,8 +1832,8 @@ module Codebuf = begin let emitTailness (cenv: cenv) codebuf tl = if tl = Tailcall && cenv.emitTailcalls then emitInstrCode codebuf i_tail - let emitAfterTailcall codebuf tl = - if tl = Tailcall then emitInstrCode codebuf i_ret + //let emitAfterTailcall codebuf tl = + // if tl = Tailcall then emitInstrCode codebuf i_ret let emitVolatility codebuf tl = if tl = Volatile then emitInstrCode codebuf i_volatile @@ -1871,24 +1853,24 @@ module Codebuf = begin match instr with | si when isNoArgInstr si -> emitInstrCode codebuf (encodingsOfNoArgInstr si) - | I_brcmp (cmp,tg1,_) -> + | I_brcmp (cmp,tg1) -> codebuf.RecordReqdBrFixup ((Lazy.force ILCmpInstrMap).[cmp], Some (Lazy.force ILCmpInstrRevMap).[cmp]) tg1 - | I_br _ -> () + | I_br tg -> codebuf.RecordReqdBrFixup (i_br,Some i_br_s) tg | I_seqpoint s -> codebuf.EmitSeqPoint cenv s | I_leave tg -> codebuf.RecordReqdBrFixup (i_leave,Some i_leave_s) tg | I_call (tl,mspec,varargs) -> emitTailness cenv codebuf tl emitMethodSpecInstr cenv codebuf env i_call (mspec,varargs) - emitAfterTailcall codebuf tl + //emitAfterTailcall codebuf tl | I_callvirt (tl,mspec,varargs) -> emitTailness cenv codebuf tl emitMethodSpecInstr cenv codebuf env i_callvirt (mspec,varargs) - emitAfterTailcall codebuf tl + //emitAfterTailcall codebuf tl | I_callconstraint (tl,ty,mspec,varargs) -> emitTailness cenv codebuf tl emitConstrained cenv codebuf env ty emitMethodSpecInstr cenv codebuf env i_callvirt (mspec,varargs) - emitAfterTailcall codebuf tl + //emitAfterTailcall codebuf tl | I_newobj (mspec,varargs) -> emitMethodSpecInstr cenv codebuf env i_newobj (mspec,varargs) | I_ldftn mspec -> @@ -1900,7 +1882,7 @@ module Codebuf = begin emitTailness cenv codebuf tl emitInstrCode codebuf i_calli codebuf.EmitUncodedToken (getUncodedToken TableNames.StandAloneSig (GetCallsigAsStandAloneSigIdx cenv env (callsig,varargs))) - emitAfterTailcall codebuf tl + //emitAfterTailcall codebuf tl | I_ldarg u16 -> emitShortUInt16Instr codebuf (i_ldarg_s,i_ldarg) u16 | I_starg u16 -> emitShortUInt16Instr codebuf (i_starg_s,i_starg) u16 @@ -1992,7 +1974,7 @@ module Codebuf = begin | DT_REF -> i_stind_ref | _ -> failwith "stelem") - | I_switch (labs,_) -> codebuf.RecordReqdBrFixups (i_switch,None) labs + | I_switch labs -> codebuf.RecordReqdBrFixups (i_switch,None) labs | I_ldfld (al,vol,fspec) -> emitAlignment codebuf al @@ -2093,165 +2075,143 @@ module Codebuf = begin | _ -> failwith "an IL instruction cannot be emitted" - let mkScopeNode cenv (localSigs: _[]) (a,b,ls,ch) = - if (isNil ls || not cenv.generatePdb) then ch + let mkScopeNode cenv (localSigs: _[]) (startOffset,endOffset,ls: ILLocalDebugMapping list,childScopes) = + if (isNil ls || not cenv.generatePdb) then childScopes else - [ { Children= Array.ofList ch - StartOffset=a - EndOffset=b + [ { Children= Array.ofList childScopes + StartOffset=startOffset + EndOffset=endOffset Locals= - Array.ofList - (List.map - (fun x -> { Name=x.LocalName - Signature= (try localSigs.[x.LocalIndex] with _ -> failwith ("local variable index "+string x.LocalIndex+"in debug info does not reference a valid local")) - Index= x.LocalIndex } ) - (List.filter (fun v -> v.LocalName <> "") ls)) } ] + ls |> List.filter (fun v -> v.LocalName <> "") + |> List.map (fun x -> + { Name=x.LocalName + Signature= (try localSigs.[x.LocalIndex] with _ -> failwith ("local variable index "+string x.LocalIndex+"in debug info does not reference a valid local")) + Index= x.LocalIndex } ) + |> Array.ofList } ] - let rec emitCode cenv localSigs codebuf env (susp,code) = - match code with - | TryBlock (c,seh) -> - commitSusp codebuf susp (uniqueEntryOfCode c) - let tryStart = codebuf.code.Position - let susp,child1,scope1 = emitCode cenv localSigs codebuf env (None,c) - commitSuspNoDest codebuf susp - let tryFinish = codebuf.code.Position - let exnBranches = - match seh with - | FaultBlock flt -> - let handlerStart = codebuf.code.Position - let susp,child2,scope2 = emitCode cenv localSigs codebuf env (None,flt) - commitSuspNoDest codebuf susp - let handlerFinish = codebuf.code.Position - [ Some (tryStart,(tryFinish - tryStart), - handlerStart,(handlerFinish - handlerStart), - FaultClause), - [(child2,scope2)] ] - - | FinallyBlock flt -> - let handlerStart = codebuf.code.Position - let susp,child2,scope2 = emitCode cenv localSigs codebuf env (None,flt) - commitSuspNoDest codebuf susp - let handlerFinish = codebuf.code.Position - [ Some (tryStart,(tryFinish - tryStart), - handlerStart,(handlerFinish - handlerStart), - FinallyClause), - [(child2,scope2)] ] - - | FilterCatchBlock clauses -> - clauses |> List.map (fun (flt,ctch) -> - match flt with - | TypeFilter typ -> - let handlerStart = codebuf.code.Position - let susp,child2,scope2 = emitCode cenv localSigs codebuf env (None,ctch) - commitSuspNoDest codebuf susp - let handlerFinish = codebuf.code.Position - Some (tryStart,(tryFinish - tryStart), - handlerStart,(handlerFinish - handlerStart), - TypeFilterClause (getTypeDefOrRefAsUncodedToken (GetTypeAsTypeDefOrRef cenv env typ))), - [(child2,scope2)] - | CodeFilter fltcode -> - - let filterStart = codebuf.code.Position - let susp,child2,scope2 = emitCode cenv localSigs codebuf env (None,fltcode) - commitSuspNoDest codebuf susp - let handlerStart = codebuf.code.Position - let susp,child3,scope3 = emitCode cenv localSigs codebuf env (None,ctch) - commitSuspNoDest codebuf susp - let handlerFinish = codebuf.code.Position - - Some (tryStart, - (tryFinish - tryStart), - handlerStart, - (handlerFinish - handlerStart), - FilterClause filterStart), - [(child2,scope2); (child3,scope3)]) - - (None, - Node((None,[child1])::List.map (fun (a,b) -> (a,List.map fst b)) exnBranches), - scope1 @ List.concat ((List.collect (fun (_,b) -> List.map snd b) exnBranches))) - - | RestrictBlock _ | GroupBlock _ -> - // NOTE: ensure tailcalls for critical linear loop using standard continuation technique - let rec emitCodeLinear (susp,b) cont = - match b with - | RestrictBlock (_,code2) -> - emitCodeLinear (susp,code2) cont - | GroupBlock (locs,codes) -> - let start = codebuf.code.Position - - // Imperative collectors for the sub-blocks - let newSusp = ref susp - let childSEH = ref [] - let childScopes = ref [] - // Push the results of collecting one sub-block into the reference cells - let collect (susp,seh,scopes) = - newSusp := susp - childSEH := seh :: !childSEH - childScopes := scopes :: !childScopes - // Close the collection by generating the (susp,node,scope-node) triple - let close () = - let fin = codebuf.code.Position - (!newSusp, - Node([(None,(List.rev !childSEH))]), - mkScopeNode cenv localSigs (start,fin,locs,List.concat (List.rev !childScopes))) - - match codes with - | [c] -> - // emitCodeLinear sequence of nested blocks - emitCodeLinear (!newSusp,c) (fun results -> - collect results - cont (close())) - - | codes -> - // Multiple blocks: leave the linear sequence and process each seperately - codes |> List.iter (fun c -> collect (emitCode cenv localSigs codebuf env (!newSusp,c))) - cont(close()) - | c -> - // leave the linear sequence - cont (emitCode cenv localSigs codebuf env (susp,c)) - - // OK, process the linear sequence - emitCodeLinear (susp,code) (fun x -> x) - - | ILBasicBlock bb -> - // Leaf case: one basic block - commitSusp codebuf susp bb.Label - codebuf.RecordAvailBrFixup bb.Label - let instrs = bb.Instructions - for i = 0 to instrs.Length - 1 do - emitInstr cenv codebuf env instrs.[i] - bb.Fallthrough, Tip, [] - - and brToSusp (codebuf: CodeBuffer) dest = codebuf.RecordReqdBrFixup (i_br,Some i_br_s) dest - - and commitSusp codebuf susp lab = - match susp with - | Some dest when dest <> lab -> brToSusp codebuf dest - | _ -> () - - and commitSuspNoDest codebuf susp = - match susp with - | Some dest -> brToSusp codebuf dest - | _ -> () - - // Flatten the SEH tree - let rec emitExceptionHandlerTree codebuf sehTree = - match sehTree with - | Tip -> () - | Node clauses -> List.iter (emitExceptionHandlerTree2 codebuf) clauses - and emitExceptionHandlerTree2 (codebuf: CodeBuffer) (x,childSEH) = + // Used to put local debug scopes and exception handlers into a tree form + let rangeInsideRange (start_pc1,end_pc1) (start_pc2,end_pc2) = + (start_pc1:int) >= start_pc2 && start_pc1 < end_pc2 && + (end_pc1:int) > start_pc2 && end_pc1 <= end_pc2 + + let lranges_of_clause cl = + match cl with + | ILExceptionClause.Finally r1 -> [r1] + | ILExceptionClause.Fault r1 -> [r1] + | ILExceptionClause.FilterCatch (r1,r2) -> [r1;r2] + | ILExceptionClause.TypeCatch (_ty,r1) -> [r1] + + + let labelsToRange (lab2pc : Dictionary) p = let (l1,l2) = p in lab2pc.[l1], lab2pc.[l2] + + let lrange_inside_lrange lab2pc ls1 ls2 = + rangeInsideRange (labelsToRange lab2pc ls1) (labelsToRange lab2pc ls2) + + let findRoots contains vs = + // For each item, either make it a root or make it a child of an existing root + let addToRoot roots x = + // Look to see if 'x' is inside one of the roots + let roots, found = + (false, roots) ||> List.mapFold (fun found (r,children) -> + if found then ((r,children),true) + elif contains x r then ((r,x::children),true) + else ((r,children),false)) + + if found then roots + else + // Find the ones that 'x' encompasses and collapse them + let yes, others = roots |> List.partition (fun (r,_) -> contains r x) + (x, yes |> List.collect (fun (r,ch) -> r :: ch)) :: others + + ([], vs) ||> List.fold addToRoot + + let rec makeSEHTree cenv env (pc2pos: int[]) (lab2pc : Dictionary) (exs : ILExceptionSpec list) = + + let clause_inside_lrange cl lr = + List.forall (fun lr1 -> lrange_inside_lrange lab2pc lr1 lr) (lranges_of_clause cl) + + let tryspec_inside_lrange (tryspec1: ILExceptionSpec) lr = + (lrange_inside_lrange lab2pc tryspec1.Range lr && clause_inside_lrange tryspec1.Clause lr) + + let tryspec_inside_clause tryspec1 cl = + List.exists (fun lr -> tryspec_inside_lrange tryspec1 lr) (lranges_of_clause cl) + + let tryspec_inside_tryspec tryspec1 (tryspec2: ILExceptionSpec) = + tryspec_inside_lrange tryspec1 tryspec2.Range || + tryspec_inside_clause tryspec1 tryspec2.Clause + + let roots = findRoots tryspec_inside_tryspec exs + let trees = + roots |> List.map (fun (cl,ch) -> + let r1 = labelsToRange lab2pc cl.Range + let conv ((s1,e1),(s2,e2)) x = pc2pos.[s1], pc2pos.[e1] - pc2pos.[s1], pc2pos.[s2], pc2pos.[e2] - pc2pos.[s2], x + let children = makeSEHTree cenv env pc2pos lab2pc ch + let n = + match cl.Clause with + | ILExceptionClause.Finally r2 -> + conv (r1,labelsToRange lab2pc r2) ExceptionClauseKind.FinallyClause + | ILExceptionClause.Fault r2 -> + conv (r1,labelsToRange lab2pc r2) ExceptionClauseKind.FaultClause + | ILExceptionClause.FilterCatch ((filterStart,_),r3) -> + conv (r1,labelsToRange lab2pc r3) (ExceptionClauseKind.FilterClause (pc2pos.[lab2pc.[filterStart]])) + | ILExceptionClause.TypeCatch (typ,r2) -> + conv (r1,labelsToRange lab2pc r2) (TypeFilterClause (getTypeDefOrRefAsUncodedToken (GetTypeAsTypeDefOrRef cenv env typ))) + SEHTree.Node (Some n, children) ) + + trees + + let rec makeLocalsTree cenv localSigs (pc2pos: int[]) (lab2pc : Dictionary) (exs : ILLocalDebugInfo list) = + let locspec_inside_locspec (locspec1: ILLocalDebugInfo) (locspec2: ILLocalDebugInfo) = + lrange_inside_lrange lab2pc locspec1.Range locspec2.Range + + let roots = findRoots locspec_inside_locspec exs + + let trees = + roots |> List.collect (fun (cl,ch) -> + let (s1,e1) = labelsToRange lab2pc cl.Range + let (s1,e1) = pc2pos.[s1], pc2pos.[e1] + let children = makeLocalsTree cenv localSigs pc2pos lab2pc ch + mkScopeNode cenv localSigs (s1,e1,cl.DebugMappings,children)) + trees + + + // Emit the SEH tree + let rec emitExceptionHandlerTree (codebuf: CodeBuffer) (Node (x,childSEH)) = List.iter (emitExceptionHandlerTree codebuf) childSEH // internal first - match x with - | None -> () - | Some clause -> codebuf.EmitExceptionClause clause + x |> Option.iter codebuf.EmitExceptionClause + + let emitCode cenv localSigs (codebuf: CodeBuffer) env (code: ILCode) = + let instrs = code.Instrs + + // Build a table mapping Abstract IL pcs to positions in the generated code buffer + let pc2pos = Array.zeroCreate (instrs.Length+1) + let pc2labs = Dictionary() + for (KeyValue(lab,pc)) in code.Labels do + if pc2labs.ContainsKey pc then pc2labs.[pc] <- lab :: pc2labs.[pc] else pc2labs.[pc] <- [lab] + + // Emit the instructions + for pc = 0 to instrs.Length do + if pc2labs.ContainsKey pc then + for lab in pc2labs.[pc] do + codebuf.RecordAvailBrFixup lab + pc2pos.[pc] <- codebuf.code.Position + if pc < instrs.Length then + match instrs.[pc] with + | I_br l when code.Labels.[l] = pc + 1 -> () // compress I_br to next instruction + | i -> emitInstr cenv codebuf env i + + // Build the exceptions and locals information, ready to emit + let SEHTree = makeSEHTree cenv env pc2pos code.Labels code.Exceptions + List.iter (emitExceptionHandlerTree codebuf) SEHTree + + // Build the locals information, ready to emit + let localsTree = makeLocalsTree cenv localSigs pc2pos code.Labels code.Locals + localsTree let EmitTopCode cenv localSigs env nm code = let codebuf = CodeBuffer.Create nm - let finalSusp, SEHTree, origScopes = - emitCode cenv localSigs codebuf env (Some (uniqueEntryOfCode code),code) - (match finalSusp with Some dest -> brToSusp codebuf dest | _ -> ()) - emitExceptionHandlerTree codebuf SEHTree + let origScopes = emitCode cenv localSigs codebuf env code let origCode = codebuf.code.Close() let origExnClauses = List.rev codebuf.seh let origReqdStringFixups = codebuf.reqdStringFixupsInMethod @@ -2270,8 +2230,6 @@ module Codebuf = begin (newReqdStringFixups,newExnClauses, newCode, newSeqPoints, rootScope) -end - // -------------------------------------------------------------------- // ILMethodBody --> bytes // -------------------------------------------------------------------- @@ -2285,9 +2243,9 @@ let GenILMethodBody mname cenv env (il: ILMethodBody) = if cenv.generatePdb then il.Locals |> ILList.toArray |> Array.map (fun l -> // Write a fake entry for the local signature headed by e_IMAGE_CEE_CS_CALLCONV_FIELD. This is referenced by the PDB file - ignore (FindOrAddRow cenv TableNames.StandAloneSig (SimpleSharedRow [| Blob (GetFieldDefTypeAsBlobIdx cenv env l.Type) |])) + ignore (FindOrAddSharedRow cenv TableNames.StandAloneSig (SharedRow [| Blob (GetFieldDefTypeAsBlobIdx cenv env l.Type) |])) // Now write the type - GetTypeAsBytes cenv env l.Type) + GetTypeOfLocalAsBytes cenv env l) else [| |] @@ -2314,7 +2272,7 @@ let GenILMethodBody mname cenv env (il: ILMethodBody) = let localToken = if ILList.isEmpty il.Locals then 0x0 else getUncodedToken TableNames.StandAloneSig - (FindOrAddRow cenv TableNames.StandAloneSig (GetLocalSigAsStandAloneSigIdx cenv env il.Locals)) + (FindOrAddSharedRow cenv TableNames.StandAloneSig (GetLocalSigAsStandAloneSigIdx cenv env il.Locals)) let alignedCodeSize = align 0x4 codeSize let codePadding = (alignedCodeSize - codeSize) @@ -2453,14 +2411,14 @@ let rec GetGenericParamAsGenericParamRow cenv _env idx owner gp = let mdVersionMajor,_ = metadataSchemaVersionSupportedByCLRVersion cenv.desiredMetadataVersion if (mdVersionMajor = 1) then - SimpleSharedRow + SharedRow [| UShort (uint16 idx) UShort (uint16 flags) TypeOrMethodDef (fst owner, snd owner) StringE (GetStringHeapIdx cenv gp.Name) TypeDefOrRefOrSpec (tdor_TypeDef, 0) (* empty kind field in deprecated metadata *) |] else - SimpleSharedRow + SharedRow [| UShort (uint16 idx) UShort (uint16 flags) TypeOrMethodDef (fst owner, snd owner) @@ -2483,7 +2441,7 @@ and GenGenericParamPass3 cenv env idx owner gp = and GenGenericParamPass4 cenv env idx owner gp = - let gpidx = FindOrAddRow cenv TableNames.GenericParam (GetGenericParamAsGenericParamRow cenv env idx owner gp) + let gpidx = FindOrAddSharedRow cenv TableNames.GenericParam (GetGenericParamAsGenericParamRow cenv env idx owner gp) GenCustomAttrsPass3Or4 cenv (hca_GenericParam, gpidx) gp.CustomAttrs gp.Constraints |> ILList.iter (GenGenericParamConstraintPass4 cenv env gpidx) @@ -2491,7 +2449,7 @@ and GenGenericParamPass4 cenv env idx owner gp = // param and return --> Param Row // -------------------------------------------------------------------- -let rec GetParamAsParamRow cenv _env seq param = +let rec GetParamAsParamRow cenv _env seq (param: ILParameter) = let flags = (if param.IsIn then 0x0001 else 0x0000) ||| (if param.IsOut then 0x0002 else 0x0000) ||| @@ -2504,7 +2462,7 @@ let rec GetParamAsParamRow cenv _env seq param = UShort (uint16 seq) StringE (GetStringHeapIdxOption cenv param.Name) |] -and GenParamPass3 cenv env seq param = +and GenParamPass3 cenv env seq (param: ILParameter) = if param.IsIn=false && param.IsOut=false && param.IsOptional=false && isNone param.Default && isNone param.Name && isNone param.Marshal then () else @@ -2952,18 +2910,18 @@ let rowElemCompare (e1: RowElement) (e2: RowElement) = if c <> 0 then c else compare e1.Tag e2.Tag -let SortTableRows tab (rows:IGenericRow[]) = - if List.memAssoc tab sortedTableInfo then - let rows = rows |> Array.map (fun row -> row.GetGenericRow()) - let col = List.assoc tab sortedTableInfo - rows - // This needs to be a stable sort, so we use Lsit.sortWith - |> Array.toList - |> List.sortWith (fun r1 r2 -> rowElemCompare r1.[col] r2.[col]) - |> Array.ofList - |> Array.map (fun arr -> (SimpleSharedRow arr) :> IGenericRow) - else - rows +let TableRequiresSorting tab = + List.memAssoc tab sortedTableInfo + +let SortTableRows tab (rows:GenericRow[]) = + assert (TableRequiresSorting tab) + let col = List.assoc tab sortedTableInfo + rows + // This needs to be a stable sort, so we use Lsit.sortWith + |> Array.toList + |> List.sortWith (fun r1 r2 -> rowElemCompare r1.[col] r2.[col]) + |> Array.ofList + //|> Array.map SharedRow let timestamp = absilWriteGetTimeStamp () @@ -2984,7 +2942,7 @@ let GenModule (cenv : cenv) (modul: ILModuleDef) = // Hence we need to sort it before we emit any entries in GenericParamConstraint\CustomAttributes that are attached to generic params. // Note this mutates the rows in a table. 'SetRowsOfTable' clears // the key --> index map since it is no longer valid - cenv.GetTable(TableNames.GenericParam).SetRowsOfTable (SortTableRows TableNames.GenericParam (cenv.GetTable(TableNames.GenericParam).EntriesAsArray)) + cenv.GetTable(TableNames.GenericParam).SetRowsOfSharedTable (SortTableRows TableNames.GenericParam (cenv.GetTable(TableNames.GenericParam).GenericRowsOfTable)) GenTypeDefsPass4 [] cenv tds reportTime cenv.showTimes "Module Generation Pass 4" @@ -3003,35 +2961,50 @@ let generateIL requiredDataFixups (desiredMetadataVersion,generatePdb, ilg : ILG nextCodeAddr = cilStartAddress data = ByteBuffer.Create 200 resources = ByteBuffer.Create 200 - tables= Array.init 64 (fun i -> MetadataTable<_>.New ("row table "+string i,System.Collections.Generic.EqualityComparer.Default)) - AssemblyRefs = MetadataTable<_>.New("ILAssemblyRef",System.Collections.Generic.EqualityComparer.Default) - documents=MetadataTable<_>.New("pdbdocs",System.Collections.Generic.EqualityComparer.Default) + tables= + Array.init 64 (fun i -> + if (i = TableNames.AssemblyRef.Index || + i = TableNames.MemberRef.Index || + i = TableNames.ModuleRef.Index || + i = TableNames.File.Index || + i = TableNames.TypeRef.Index || + i = TableNames.TypeSpec.Index || + i = TableNames.MethodSpec.Index || + i = TableNames.StandAloneSig.Index || + i = TableNames.GenericParam.Index) then + MetadataTable.Shared (MetadataTable.New ("row table "+string i,EqualityComparer.Default)) + else + MetadataTable.Unshared (MetadataTable.New ("row table "+string i,EqualityComparer.Default))) + + AssemblyRefs = MetadataTable<_>.New("ILAssemblyRef",EqualityComparer.Default) + documents=MetadataTable<_>.New("pdbdocs",EqualityComparer.Default) trefCache=new Dictionary<_,_>(100) pdbinfo= new ResizeArray<_>(200) moduleGuid= Array.zeroCreate 16 - fieldDefs= MetadataTable<_>.New("field defs",System.Collections.Generic.EqualityComparer.Default) - methodDefIdxsByKey = MetadataTable<_>.New("method defs",System.Collections.Generic.EqualityComparer.Default) + fieldDefs= MetadataTable<_>.New("field defs",EqualityComparer.Default) + methodDefIdxsByKey = MetadataTable<_>.New("method defs",EqualityComparer.Default) // This uses reference identity on ILMethodDef objects methodDefIdxs = new Dictionary<_,_>(100, HashIdentity.Reference) - propertyDefs = MetadataTable<_>.New("property defs",System.Collections.Generic.EqualityComparer.Default) - eventDefs = MetadataTable<_>.New("event defs",System.Collections.Generic.EqualityComparer.Default) - typeDefs = MetadataTable<_>.New("type defs",System.Collections.Generic.EqualityComparer.Default) + propertyDefs = MetadataTable<_>.New("property defs",EqualityComparer.Default) + eventDefs = MetadataTable<_>.New("event defs",EqualityComparer.Default) + typeDefs = MetadataTable<_>.New("type defs",EqualityComparer.Default) entrypoint=None generatePdb=generatePdb // These must use structural comparison since they are keyed by arrays guids=MetadataTable<_>.New("guids",HashIdentity.Structural) blobs= MetadataTable<_>.New("blobs",HashIdentity.Structural) - strings= MetadataTable<_>.New("strings",System.Collections.Generic.EqualityComparer.Default) - userStrings= MetadataTable<_>.New("user strings",System.Collections.Generic.EqualityComparer.Default) } + strings= MetadataTable<_>.New("strings",EqualityComparer.Default) + userStrings= MetadataTable<_>.New("user strings",EqualityComparer.Default) } // Now the main compilation step GenModule cenv m - // Fetch out some of the results + // .exe files have a .entrypoint instruction. Do not write it to the entrypoint when writing dll. let entryPointToken = match cenv.entrypoint with | Some (epHere,tok) -> - getUncodedToken (if epHere then TableNames.Method else TableNames.File) tok + if isDll then 0x0 + else getUncodedToken (if epHere then TableNames.Method else TableNames.File) tok | None -> if not isDll then dprintn "warning: no entrypoint specified in executable binary" 0x0 @@ -3052,7 +3025,7 @@ let generateIL requiredDataFixups (desiredMetadataVersion,generatePdb, ilg : ILG let userStrings = cenv.userStrings.EntriesAsArray |> Array.map System.Text.Encoding.Unicode.GetBytes let blobs = cenv.blobs.EntriesAsArray let guids = cenv.guids.EntriesAsArray - let tables = cenv.tables |> Array.map (fun t -> t.EntriesAsArray) + let tables = cenv.tables let code = cenv.GetCode() // turn idx tbls into token maps let mappings = @@ -3129,7 +3102,7 @@ let writeILMetadataAndCode (generatePdb,desiredMetadataVersion,ilg,emitTailcalls generateIL requiredDataFixups (desiredMetadataVersion,generatePdb,ilg,emitTailcalls,showTimes) modul noDebugData cilStartAddress reportTime showTimes "Generated Tables and Code" - let tableSize (tab: TableName) = tables.[tab.Index].Length + let tableSize (tab: TableName) = tables.[tab.Index].Count // Now place the code let codeSize = code.Length @@ -3185,7 +3158,7 @@ let writeILMetadataAndCode (generatePdb,desiredMetadataVersion,ilg,emitTailcalls let (valid1,valid2),_ = (((0,0), 0), tables) ||> Array.fold (fun ((valid1,valid2) as valid,n) rows -> let valid = - if rows.Length = 0 then valid else + if rows.Count = 0 then valid else ( (if n < 32 then valid1 ||| (1 <<< n ) else valid1), (if n >= 32 then valid2 ||| (1 <<< (n-32)) else valid2) ) (valid,n+1)) @@ -3248,7 +3221,11 @@ let writeILMetadataAndCode (generatePdb,desiredMetadataVersion,ilg,emitTailcalls reportTime showTimes "Build String/Blob Address Tables" let sortedTables = - Array.init 64 (fun i -> tables.[i] |> SortTableRows (TableName.FromIndex i)) + Array.init 64 (fun i -> + let tab = tables.[i] + let tabName = TableName.FromIndex i + let rows = tab.GenericRowsOfTable + if TableRequiresSorting tabName then SortTableRows tabName rows else rows) reportTime showTimes "Sort Tables" @@ -3370,7 +3347,6 @@ let writeILMetadataAndCode (generatePdb,desiredMetadataVersion,ilg,emitTailcalls // The tables themselves for rows in sortedTables do for row in rows do - let row = row.GetGenericRow() for x in row do // Emit the coded token for the array element let t = x.Tag @@ -3855,7 +3831,7 @@ let writeBinaryAndReportMappings (outfile, ilg, pdbfile: string option, signer: writeInt32AsUInt16 os ((if isDll then 0x2000 else 0x0000) ||| 0x0002 ||| 0x0004 ||| 0x0008 ||| iMachineCharacteristic); - // Now comes optional header + // Now comes optional header let peOptionalHeaderByte = peOptionalHeaderByteByCLRVersion desiredMetadataVersion @@ -3866,7 +3842,7 @@ let writeBinaryAndReportMappings (outfile, ilg, pdbfile: string option, signer: writeInt32AsUInt16 os 0x010b; // Always 0x10B (see Section 23.1). writeInt32AsUInt16 os peOptionalHeaderByte; // ECMA spec says 6, some binaries, e.g. fscmanaged.exe say 7, Whidbey binaries say 8 writeInt32 os textSectionPhysSize; // Size of the code (text) section, or the sum of all code sections if there are multiple sections. - // 000000a0 + // 000000a0 writeInt32 os dataSectionPhysSize; // Size of the initialized data section, or the sum of all such sections if there are multiple data sections. writeInt32 os 0x00; // Size of the uninitialized data section, or the sum of all such sections if there are multiple unitinitalized data sections. writeInt32 os entrypointCodeChunk.addr; // RVA of entry point , needs to point to bytes 0xFF 0x25 followed by the RVA+!0x4000000 in a section marked execute/read for EXEs or 0 for DLLs e.g. 0x0000b57e diff --git a/src/absil/ilwrite.fsi b/src/absil/ilwrite.fsi index 771b7d483a..aab8b46221 100755 --- a/src/absil/ilwrite.fsi +++ b/src/absil/ilwrite.fsi @@ -1,6 +1,6 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. -/// The IL Binary writer +/// The IL Binary writer. module internal Microsoft.FSharp.Compiler.AbstractIL.ILBinaryWriter open Microsoft.FSharp.Compiler.AbstractIL diff --git a/src/absil/ilwritepdb.fs b/src/absil/ilwritepdb.fs index cf397a0041..c0cb29b776 100644 --- a/src/absil/ilwritepdb.fs +++ b/src/absil/ilwritepdb.fs @@ -9,7 +9,6 @@ open System.IO open System.Reflection open System.Reflection.Metadata open System.Reflection.Metadata.Ecma335 -open System.Reflection.Metadata.Ecma335.Blobs open System.Reflection.PortableExecutable open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL.IL @@ -222,10 +221,10 @@ let writePortablePdbInfo (fixupSPs:bool) showTimes fpdb (info:PdbData) = writer.WriteByte(byte(separator)) for part in name.Split( [| separator |] ) do - let partIndex = MetadataTokens.GetHeapOffset(BlobHandle.op_Implicit(metadata.GetBlobUtf8(part))) + let partIndex = MetadataTokens.GetHeapOffset(BlobHandle.op_Implicit(metadata.GetOrAddBlobUTF8(part))) writer.WriteCompressedInteger(int(partIndex)) - metadata.GetBlob(writer); + metadata.GetOrAddBlob(writer); let corSymLanguageTypeFSharp = System.Guid(0xAB4F38C9u, 0xB6E6us, 0x43baus, 0xBEuy, 0x3Buy, 0x58uy, 0x08uy, 0x0Buy, 0x2Cuy, 0xCCuy, 0xE3uy) let documentIndex = @@ -236,14 +235,14 @@ let writePortablePdbInfo (fixupSPs:bool) showTimes fpdb (info:PdbData) = match checkSum doc.File with | Some (hashAlg, checkSum) -> serializeDocumentName doc.File, - metadata.GetGuid(hashAlg), - metadata.GetBlob(checkSum.ToImmutableArray()), - metadata.GetGuid(corSymLanguageTypeFSharp) + metadata.GetOrAddGuid(hashAlg), + metadata.GetOrAddBlob(checkSum.ToImmutableArray()), + metadata.GetOrAddGuid(corSymLanguageTypeFSharp) | None -> serializeDocumentName doc.File, - metadata.GetGuid(System.Guid.Empty), - metadata.GetBlob(ImmutableArray.Empty), - metadata.GetGuid(corSymLanguageTypeFSharp) + metadata.GetOrAddGuid(System.Guid.Empty), + metadata.GetOrAddBlob(ImmutableArray.Empty), + metadata.GetOrAddGuid(corSymLanguageTypeFSharp) |> metadata.AddDocument index.Add(doc.File, handle) index @@ -332,7 +331,7 @@ let writePortablePdbInfo (fixupSPs:bool) showTimes fpdb (info:PdbData) = previousNonHiddenStartLine <- sps.[i].Line previousNonHiddenStartColumn <- sps.[i].Column - getDocumentHandle singleDocumentIndex, metadata.GetBlob(builder) + getDocumentHandle singleDocumentIndex, metadata.GetOrAddBlob(builder) // Write the scopes let mutable lastLocalVariableHandle = Unchecked.defaultof @@ -347,7 +346,7 @@ let writePortablePdbInfo (fixupSPs:bool) showTimes fpdb (info:PdbData) = scope.StartOffset, scope.EndOffset - scope.StartOffset) |>ignore for localVariable in scope.Locals do - lastLocalVariableHandle <- metadata.AddLocalVariable(LocalVariableAttributes.None, localVariable.Index, metadata.GetString(localVariable.Name)) + lastLocalVariableHandle <- metadata.AddLocalVariable(LocalVariableAttributes.None, localVariable.Index, metadata.GetOrAddString(localVariable.Name)) scope.Children |> Array.iter (writePdbScope false) writePdbScope true minfo.RootScope @@ -358,10 +357,9 @@ let writePortablePdbInfo (fixupSPs:bool) showTimes fpdb (info:PdbData) = | None -> MetadataTokens.MethodDefinitionHandle(0) | Some x -> MetadataTokens.MethodDefinitionHandle(x) - let pdbContentId = ContentId(info.ModuleID, BitConverter.GetBytes(info.Timestamp)) - let serializer = StandaloneDebugMetadataSerializer(metadata, externalRowCounts, entryPoint, false) + let serializer = PortablePdbBuilder(metadata, externalRowCounts, entryPoint, null ) let blobBuilder = new BlobBuilder() - serializer.SerializeMetadata(blobBuilder, (fun builder -> pdbContentId)) |> ignore + serializer.Serialize(blobBuilder) |> ignore reportTime showTimes "PDB: Created" use portablePdbStream = new FileStream(fpdb, FileMode.Create, FileAccess.ReadWrite) diff --git a/src/absil/ilx.fs b/src/absil/ilx.fs index dffa456a39..d183fe0796 100755 --- a/src/absil/ilx.fs +++ b/src/absil/ilx.fs @@ -28,8 +28,8 @@ type IlxUnionField(fd: ILFieldDef) = type IlxUnionAlternative = - { altName: string; - altFields: IlxUnionField[]; + { altName: string + altFields: IlxUnionField[] altCustomAttrs: ILAttributes } member x.FieldDefs = x.altFields @@ -45,16 +45,17 @@ type IlxUnionHasHelpers = | SpecialFSharpOptionHelpers type IlxUnionRef = - | IlxUnionRef of ILTypeRef * IlxUnionAlternative[] * bool * (* hasHelpers: *) IlxUnionHasHelpers + | IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionAlternative[] * bool * (* hasHelpers: *) IlxUnionHasHelpers type IlxUnionSpec = | IlxUnionSpec of IlxUnionRef * ILGenericArgs - member x.EnclosingType = let (IlxUnionSpec(IlxUnionRef(tref,_,_,_),inst)) = x in mkILBoxedTyRaw tref inst - member x.TypeRef = let (IlxUnionSpec(IlxUnionRef(tref,_,_,_),_)) = x in tref + member x.EnclosingType = let (IlxUnionSpec(IlxUnionRef(bx,tref,_,_,_),inst)) = x in mkILNamedTy bx tref inst + member x.Boxity = let (IlxUnionSpec(IlxUnionRef(bx,_,_,_,_),_)) = x in bx + member x.TypeRef = let (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_),_)) = x in tref member x.GenericArgs = let (IlxUnionSpec(_,inst)) = x in inst - member x.AlternativesArray = let (IlxUnionSpec(IlxUnionRef(_,alts,_,_),_)) = x in alts - member x.IsNullPermitted = let (IlxUnionSpec(IlxUnionRef(_,_,np,_),_)) = x in np - member x.HasHelpers = let (IlxUnionSpec(IlxUnionRef(_,_,_,b),_)) = x in b + member x.AlternativesArray = let (IlxUnionSpec(IlxUnionRef(_,_,alts,_,_),_)) = x in alts + member x.IsNullPermitted = let (IlxUnionSpec(IlxUnionRef(_,_,_,np,_),_)) = x in np + member x.HasHelpers = let (IlxUnionSpec(IlxUnionRef(_,_,_,_,b),_)) = x in b member x.Alternatives = Array.toList x.AlternativesArray member x.Alternative idx = x.AlternativesArray.[idx] member x.FieldDef idx fidx = x.Alternative(idx).FieldDef(fidx) @@ -85,14 +86,14 @@ let rec instLambdasAux n inst = function let instLambdas i t = instLambdasAux 0 i t type IlxClosureFreeVar = - { fvName: string ; - fvCompilerGenerated:bool; + { fvName: string + fvCompilerGenerated:bool fvType: ILType } let mkILFreeVar (name,compgen,ty) = - { fvName=name; - fvCompilerGenerated=compgen; - fvType=ty; } + { fvName=name + fvCompilerGenerated=compgen + fvType=ty } type IlxClosureRef = @@ -115,79 +116,27 @@ type IlxClosureSpec = mkILCtorMethSpecForTy (cloTy,fields |> Array.map (fun fv -> fv.fvType) |> Array.toList) -type IlxInstr = - // Discriminated unions - | EI_lddata of (* avoidHelpers: *) bool * IlxUnionSpec * int * int - | EI_isdata of (* avoidHelpers: *) bool * IlxUnionSpec * int - | EI_brisdata of (* avoidHelpers: *) bool * IlxUnionSpec * int * ILCodeLabel * ILCodeLabel - | EI_castdata of bool * IlxUnionSpec * int - | EI_stdata of IlxUnionSpec * int * int - | EI_datacase of (* avoidHelpers: *) bool * IlxUnionSpec * (int * ILCodeLabel) list * ILCodeLabel (* last label is fallthrough *) - | EI_lddatatag of (* avoidHelpers: *) bool * IlxUnionSpec - | EI_newdata of IlxUnionSpec * int - - // Closures - | EI_callfunc of ILTailcall * IlxClosureApps - -let destinations i = - match i with - | (EI_brisdata (_,_,_,l1,l2)) -> [l1; l2] - | (EI_callfunc (Tailcall,_)) -> [] - | (EI_datacase (_,_,ls,l)) -> l:: (List.foldBack (fun (_,l) acc -> ListSet.insert l acc) ls []) - | _ -> [] - -let fallthrough i = - match i with - | (EI_brisdata (_,_,_,_,l)) - | (EI_datacase (_,_,_,l)) -> Some l - | _ -> None - -let isTailcall i = - match i with - | (EI_callfunc (Tailcall,_)) -> true - | _ -> false - -let remapIlxLabels lab2cl i = - match i with - | EI_brisdata (z,a,b,l1,l2) -> EI_brisdata (z,a,b,lab2cl l1,lab2cl l2) - | EI_datacase (z,x,ls,l) -> EI_datacase (z,x,List.map (fun (y,l) -> (y,lab2cl l)) ls, lab2cl l) - | _ -> i - -let (mkIlxExtInstr,isIlxExtInstr,destIlxExtInstr) = - RegisterInstructionSetExtension - { instrExtDests=destinations; - instrExtFallthrough=fallthrough; - instrExtIsTailcall=isTailcall; - instrExtRelabel=remapIlxLabels; } - -let mkIlxInstr i = I_other (mkIlxExtInstr i) - // Define an extension of the IL algebra of type definitions type IlxClosureInfo = - { cloStructure: IlxClosureLambdas; - cloFreeVars: IlxClosureFreeVar[]; - cloCode: Lazy; + { cloStructure: IlxClosureLambdas + cloFreeVars: IlxClosureFreeVar[] + cloCode: Lazy cloSource: ILSourceMarker option} -and IlxUnionInfo = - { cudReprAccess: ILMemberAccess; (* is the representation public? *) - cudHelpersAccess: ILMemberAccess; (* are the representation public? *) - cudHasHelpers: IlxUnionHasHelpers; (* generate the helpers? *) - cudDebugProxies: bool; (* generate the helpers? *) - cudDebugDisplayAttributes: ILAttribute list; - cudAlternatives: IlxUnionAlternative array; - cudNullPermitted: bool; - (* debug info for generated code for classunions *) - cudWhere: ILSourceMarker option; } - -type IlxTypeDefKind = - | Closure of IlxClosureInfo - | Union of IlxUnionInfo - -let (mkIlxExtTypeDefKind,isIlxExtTypeDefKind,destIlxExtTypeDefKind) = - (RegisterTypeDefKindExtension TypeDefKindExtension : (IlxTypeDefKind -> IlxExtensionTypeKind) * (IlxExtensionTypeKind -> bool) * (IlxExtensionTypeKind -> IlxTypeDefKind) ) - -let mkIlxTypeDefKind i = ILTypeDefKind.Other (mkIlxExtTypeDefKind i) +type IlxUnionInfo = + { /// is the representation public? + cudReprAccess: ILMemberAccess + /// are the representation public? + cudHelpersAccess: ILMemberAccess + /// generate the helpers? + cudHasHelpers: IlxUnionHasHelpers + /// generate the helpers? + cudDebugProxies: bool + cudDebugDisplayAttributes: ILAttribute list + cudAlternatives: IlxUnionAlternative[] + cudNullPermitted: bool + /// debug info for generated code for classunions + cudWhere: ILSourceMarker option } // -------------------------------------------------------------------- // Define these as extensions of the IL types diff --git a/src/absil/ilx.fsi b/src/absil/ilx.fsi index 2c03a75262..b7413fbf69 100755 --- a/src/absil/ilx.fsi +++ b/src/absil/ilx.fsi @@ -17,13 +17,13 @@ type IlxUnionField = new : ILFieldDef -> IlxUnionField member Type : ILType member Name : string - /// The name used for the field in parameter or IL field position + /// The name used for the field in parameter or IL field position. member LowerName : string member ILField : ILFieldDef type IlxUnionAlternative = - { altName: string; - altFields: IlxUnionField[]; + { altName: string + altFields: IlxUnionField[] altCustomAttrs: ILAttributes } member FieldDefs : IlxUnionField[] @@ -40,7 +40,7 @@ type IlxUnionHasHelpers = | SpecialFSharpOptionHelpers type IlxUnionRef = - | IlxUnionRef of ILTypeRef * IlxUnionAlternative[] * bool (* cudNullPermitted *) * IlxUnionHasHelpers (* cudHasHelpers *) + | IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionAlternative[] * bool (* cudNullPermitted *) * IlxUnionHasHelpers (* cudHasHelpers *) type IlxUnionSpec = | IlxUnionSpec of IlxUnionRef * ILGenericArgs @@ -48,6 +48,7 @@ type IlxUnionSpec = member GenericArgs : ILGenericArgs member Alternatives : IlxUnionAlternative list member AlternativesArray : IlxUnionAlternative[] + member Boxity : ILBoxity member TypeRef : ILTypeRef member IsNullPermitted : bool member HasHelpers : IlxUnionHasHelpers @@ -64,8 +65,8 @@ type IlxClosureLambdas = | Lambdas_return of ILType type IlxClosureFreeVar = - { fvName: string ; - fvCompilerGenerated:bool; + { fvName: string + fvCompilerGenerated:bool fvType: ILType } type IlxClosureRef = @@ -83,67 +84,37 @@ type IlxClosureSpec = member Constructor : ILMethodSpec -/// IlxClosureApps - i.e. types being applied at a callsite +/// IlxClosureApps - i.e. types being applied at a callsite. type IlxClosureApps = | Apps_tyapp of ILType * IlxClosureApps | Apps_app of ILType * IlxClosureApps | Apps_done of ILType -/// ILX extensions to the instruction set -/// - -type IlxInstr = - | EI_lddata of (* avoidHelpers: *) bool * IlxUnionSpec * int * int - | EI_isdata of (* avoidHelpers: *) bool * IlxUnionSpec * int - | EI_brisdata of (* avoidHelpers: *) bool * IlxUnionSpec * int * ILCodeLabel * ILCodeLabel - | EI_castdata of bool * IlxUnionSpec * int - | EI_stdata of IlxUnionSpec * int * int - | EI_datacase of (* avoidHelpers: *) bool * IlxUnionSpec * (int * ILCodeLabel) list * ILCodeLabel (* last label is fallthrough *) - | EI_lddatatag of (* avoidHelpers: *) bool * IlxUnionSpec - | EI_newdata of IlxUnionSpec * int - | EI_callfunc of ILTailcall * IlxClosureApps - -val mkIlxExtInstr: (IlxInstr -> IlxExtensionInstr) -val isIlxExtInstr: (IlxExtensionInstr -> bool) -val destIlxExtInstr: (IlxExtensionInstr -> IlxInstr) - -val mkIlxInstr: IlxInstr -> ILInstr - // -------------------------------------------------------------------- // ILX extensions to the kinds of type definitions available // -------------------------------------------------------------------- type IlxClosureInfo = - { cloStructure: IlxClosureLambdas; - cloFreeVars: IlxClosureFreeVar[]; - cloCode: Lazy; + { cloStructure: IlxClosureLambdas + cloFreeVars: IlxClosureFreeVar[] + cloCode: Lazy cloSource: ILSourceMarker option} -and IlxUnionInfo = +type IlxUnionInfo = { /// Is the representation public? - cudReprAccess: ILMemberAccess; + cudReprAccess: ILMemberAccess /// Are the representation helpers public? - cudHelpersAccess: ILMemberAccess; + cudHelpersAccess: ILMemberAccess /// Generate the helpers? - cudHasHelpers: IlxUnionHasHelpers; - cudDebugProxies: bool; - cudDebugDisplayAttributes: ILAttribute list; - cudAlternatives: IlxUnionAlternative[]; - cudNullPermitted: bool; - /// Debug info for generated code for classunions - cudWhere: ILSourceMarker option; + cudHasHelpers: IlxUnionHasHelpers + cudDebugProxies: bool + cudDebugDisplayAttributes: ILAttribute list + cudAlternatives: IlxUnionAlternative[] + cudNullPermitted: bool + /// Debug info for generated code for classunions. + cudWhere: ILSourceMarker option } -type IlxTypeDefKind = - | Closure of IlxClosureInfo - | Union of IlxUnionInfo - -val mkIlxExtTypeDefKind: (IlxTypeDefKind -> IlxExtensionTypeKind) -val isIlxExtTypeDefKind: (IlxExtensionTypeKind -> bool) -val destIlxExtTypeDefKind: (IlxExtensionTypeKind -> IlxTypeDefKind) - -val mkIlxTypeDefKind: IlxTypeDefKind -> ILTypeDefKind - // -------------------------------------------------------------------- // MS-ILX constructs: Closures, thunks, classunions // -------------------------------------------------------------------- diff --git a/src/absil/zmap.fsi b/src/absil/zmap.fsi index 667de856d0..a6f0acabe3 100755 --- a/src/absil/zmap.fsi +++ b/src/absil/zmap.fsi @@ -26,7 +26,7 @@ module internal Zmap = val map : mapping:('T -> 'U) -> Zmap<'Key,'T> -> Zmap<'Key,'U> val mapi : ('Key -> 'T -> 'U) -> Zmap<'Key,'T> -> Zmap<'Key,'U> val fold : ('Key -> 'T -> 'U -> 'U) -> Zmap<'Key,'T> -> 'U -> 'U - val foldMap : ('State -> 'Key -> 'T -> 'State * 'U) -> 'State -> Zmap<'Key,'T> -> 'State * Zmap<'Key,'U> + val foldMap : ('State -> 'Key -> 'T -> 'State * 'U) -> 'State -> Zmap<'Key,'T> -> 'State * Zmap<'Key,'U> val iter : action:('T -> 'U -> unit) -> Zmap<'T, 'U> -> unit val foldSection: 'Key -> 'Key -> ('Key -> 'T -> 'U -> 'U) -> Zmap<'Key,'T> -> 'U -> 'U diff --git a/src/fsharp/AccessibilityLogic.fs b/src/fsharp/AccessibilityLogic.fs new file mode 100644 index 0000000000..38354e674e --- /dev/null +++ b/src/fsharp/AccessibilityLogic.fs @@ -0,0 +1,333 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +/// The basic logic of private/internal/protected/InternalsVisibleTo/public accessibility +module internal Microsoft.FSharp.Compiler.AccessibilityLogic + +open Internal.Utilities +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.TcGlobals + +#if EXTENSIONTYPING +open Microsoft.FSharp.Compiler.ExtensionTyping +#endif + +/// Represents the 'keys' a particular piece of code can use to access other constructs?. +[] +type AccessorDomain = + /// AccessibleFrom(cpaths, tyconRefOpt) + /// + /// cpaths: indicates we have the keys to access any members private to the given paths + /// tyconRefOpt: indicates we have the keys to access any protected members of the super types of 'TyconRef' + | AccessibleFrom of CompilationPath list * TyconRef option + + /// An AccessorDomain which returns public items + | AccessibleFromEverywhere + + /// An AccessorDomain which returns everything but .NET private/internal items. + /// This is used + /// - when solving member trait constraints, which are solved independently of accessibility + /// - for failure paths in error reporting, e.g. to produce an error that an F# item is not accessible + /// - an adhoc use in service.fs to look up a delegate signature + | AccessibleFromSomeFSharpCode + + /// An AccessorDomain which returns all items + | AccessibleFromSomewhere + + // Hashing and comparison is used for the memoization tables keyed by an accessor domain. + // It is dependent on a TcGlobals because of the TyconRef in the data structure + static member CustomGetHashCode(ad:AccessorDomain) = + match ad with + | AccessibleFrom _ -> 1 + | AccessibleFromEverywhere -> 2 + | AccessibleFromSomeFSharpCode -> 3 + | AccessibleFromSomewhere -> 4 + static member CustomEquals(g:TcGlobals, ad1:AccessorDomain, ad2:AccessorDomain) = + match ad1, ad2 with + | AccessibleFrom(cs1,tc1), AccessibleFrom(cs2,tc2) -> (cs1 = cs2) && (match tc1,tc2 with None,None -> true | Some tc1, Some tc2 -> tyconRefEq g tc1 tc2 | _ -> false) + | AccessibleFromEverywhere, AccessibleFromEverywhere -> true + | AccessibleFromSomeFSharpCode, AccessibleFromSomeFSharpCode -> true + | AccessibleFromSomewhere, AccessibleFromSomewhere -> true + | _ -> false + +/// Indicates if an F# item is accessible +let IsAccessible ad taccess = + match ad with + | AccessibleFromEverywhere -> canAccessFromEverywhere taccess + | AccessibleFromSomeFSharpCode -> canAccessFromSomewhere taccess + | AccessibleFromSomewhere -> true + | AccessibleFrom (cpaths,_tcrefViewedFromOption) -> + List.exists (canAccessFrom taccess) cpaths + +/// Indicates if an IL member is accessible (ignoring its enclosing type) +let private IsILMemberAccessible g amap m (tcrefOfViewedItem : TyconRef) ad access = + match ad with + | AccessibleFromEverywhere -> + access = ILMemberAccess.Public + | AccessibleFromSomeFSharpCode -> + (access = ILMemberAccess.Public || + access = ILMemberAccess.Family || + access = ILMemberAccess.FamilyOrAssembly) + | AccessibleFrom (cpaths,tcrefViewedFromOption) -> + let accessibleByFamily = + ((access = ILMemberAccess.Family || + access = ILMemberAccess.FamilyOrAssembly) && + match tcrefViewedFromOption with + | None -> false + | Some tcrefViewedFrom -> + ExistsHeadTypeInEntireHierarchy g amap m (generalizedTyconRef tcrefViewedFrom) tcrefOfViewedItem) + let accessibleByInternalsVisibleTo = + (access = ILMemberAccess.Assembly && canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath) + (access = ILMemberAccess.Public) || accessibleByFamily || accessibleByInternalsVisibleTo + | AccessibleFromSomewhere -> + true + +/// Indicates if tdef is accessible. If tdef.Access = ILTypeDefAccess.Nested then encTyconRefOpt s TyconRef of enclosing type +/// and visibility of tdef is obtained using member access rules +let private IsILTypeDefAccessible (amap : Import.ImportMap) m ad encTyconRefOpt (tdef: ILTypeDef) = + match tdef.Access with + | ILTypeDefAccess.Nested nestedAccess -> + match encTyconRefOpt with + | None -> assert false; true + | Some encTyconRef -> IsILMemberAccessible amap.g amap m encTyconRef ad nestedAccess + | _ -> + match ad with + | AccessibleFromSomewhere -> true + | AccessibleFromEverywhere + | AccessibleFromSomeFSharpCode + | AccessibleFrom _ -> tdef.Access = ILTypeDefAccess.Public + +/// Indicates if a TyconRef is visible through the AccessibleFrom(cpaths,_). +/// Note that InternalsVisibleTo extends those cpaths. +let private IsTyconAccessibleViaVisibleTo ad (tcrefOfViewedItem:TyconRef) = + match ad with + | AccessibleFromEverywhere + | AccessibleFromSomewhere + | AccessibleFromSomeFSharpCode -> false + | AccessibleFrom (cpaths,_tcrefViewedFromOption) -> + canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath + +/// Indicates if given IL based TyconRef is accessible. If TyconRef is nested then we'll +/// walk though the list of enclosing types and test if all of them are accessible +let private IsILTypeInfoAccessible amap m ad (tcrefOfViewedItem : TyconRef) = + let scoref, enc, tdef = tcrefOfViewedItem.ILTyconInfo + let rec check parentTycon path = + let ilTypeDefAccessible = + match parentTycon with + | None -> + match path with + | [] -> assert false; true // in this case path should have at least one element + | [x] -> IsILTypeDefAccessible amap m ad None x // shortcut for non-nested types + | x::xs -> + // check if enclosing type x is accessible. + // if yes - create parent tycon for type 'x' and continue with the rest of the path + IsILTypeDefAccessible amap m ad None x && + ( + let parentILTyRef = mkRefForNestedILTypeDef scoref ([], x) + let parentTycon = Import.ImportILTypeRef amap m parentILTyRef + check (Some (parentTycon, [x])) xs + ) + | (Some (parentTycon, parentPath)) -> + match path with + | [] -> true // end of path is reached - success + | x::xs -> + // check if x is accessible from the parent tycon + // if yes - create parent tycon for type 'x' and continue with the rest of the path + IsILTypeDefAccessible amap m ad (Some parentTycon) x && + ( + let parentILTyRef = mkRefForNestedILTypeDef scoref (parentPath, x) + let parentTycon = Import.ImportILTypeRef amap m parentILTyRef + check (Some (parentTycon, parentPath @ [x])) xs + ) + ilTypeDefAccessible || IsTyconAccessibleViaVisibleTo ad tcrefOfViewedItem + + check None (enc @ [tdef]) + +/// Indicates if an IL member associated with the given ILType is accessible +let private IsILTypeAndMemberAccessible g amap m adType ad (ILTypeInfo(tcrefOfViewedItem, _, _, _)) access = + IsILTypeInfoAccessible amap m adType tcrefOfViewedItem && IsILMemberAccessible g amap m tcrefOfViewedItem ad access + +/// Indicates if an entity is accessible +let IsEntityAccessible amap m ad (tcref:TyconRef) = + if tcref.IsILTycon then + IsILTypeInfoAccessible amap m ad tcref + else + tcref.Accessibility |> IsAccessible ad + +/// Check that an entity is accessible +let CheckTyconAccessible amap m ad tcref = + let res = IsEntityAccessible amap m ad tcref + if not res then + errorR(Error(FSComp.SR.typeIsNotAccessible tcref.DisplayName,m)) + res + +/// Indicates if a type definition and its representation contents are accessible +let IsTyconReprAccessible amap m ad tcref = + IsEntityAccessible amap m ad tcref && + IsAccessible ad tcref.TypeReprAccessibility + +/// Check that a type definition and its representation contents are accessible +let CheckTyconReprAccessible amap m ad tcref = + CheckTyconAccessible amap m ad tcref && + (let res = IsAccessible ad tcref.TypeReprAccessibility + if not res then + errorR (Error (FSComp.SR.unionCasesAreNotAccessible tcref.DisplayName,m)) + res) + +/// Indicates if a type is accessible (both definition and instantiation) +let rec IsTypeAccessible g amap m ad ty = + not (isAppTy g ty) || + let tcref,tinst = destAppTy g ty + IsEntityAccessible amap m ad tcref && IsTypeInstAccessible g amap m ad tinst + +and IsTypeInstAccessible g amap m ad tinst = + match tinst with + | [] -> true + | _ -> List.forall (IsTypeAccessible g amap m ad) tinst + +/// Indicate if a provided member is accessible +let IsProvidedMemberAccessible (amap:Import.ImportMap) m ad ty access = + let g = amap.g + let isTyAccessible = IsTypeAccessible g amap m ad ty + if not isTyAccessible then false + else + not (isAppTy g ty) || + let tcrefOfViewedItem,_ = destAppTy g ty + IsILMemberAccessible g amap m tcrefOfViewedItem ad access + +/// Compute the accessibility of a provided member +let ComputeILAccess isPublic isFamily isFamilyOrAssembly isFamilyAndAssembly = + if isPublic then ILMemberAccess.Public + elif isFamily then ILMemberAccess.Family + elif isFamilyOrAssembly then ILMemberAccess.FamilyOrAssembly + elif isFamilyAndAssembly then ILMemberAccess.FamilyAndAssembly + else ILMemberAccess.Private + +/// IndiCompute the accessibility of a provided member +let IsILFieldInfoAccessible g amap m ad x = + match x with + | ILFieldInfo (tinfo,fd) -> IsILTypeAndMemberAccessible g amap m ad ad tinfo fd.Access +#if EXTENSIONTYPING + | ProvidedField (amap, tpfi, m) as pfi -> + let access = tpfi.PUntaint((fun fi -> ComputeILAccess fi.IsPublic fi.IsFamily fi.IsFamilyOrAssembly fi.IsFamilyAndAssembly), m) + IsProvidedMemberAccessible amap m ad pfi.EnclosingType access +#endif + +let GetILAccessOfILEventInfo (ILEventInfo (tinfo,edef)) = + (resolveILMethodRef tinfo.RawMetadata edef.AddMethod).Access + +let IsILEventInfoAccessible g amap m ad einfo = + let access = GetILAccessOfILEventInfo einfo + IsILTypeAndMemberAccessible g amap m ad ad einfo.ILTypeInfo access + +let private IsILMethInfoAccessible g amap m adType ad ilminfo = + match ilminfo with + | ILMethInfo (_,typ,None,mdef,_) -> IsILTypeAndMemberAccessible g amap m adType ad (ILTypeInfo.FromType g typ) mdef.Access + | ILMethInfo (_,_,Some declaringTyconRef,mdef,_) -> IsILMemberAccessible g amap m declaringTyconRef ad mdef.Access + +let GetILAccessOfILPropInfo (ILPropInfo(tinfo,pdef)) = + let tdef = tinfo.RawMetadata + let ilAccess = + match pdef.GetMethod with + | Some mref -> (resolveILMethodRef tdef mref).Access + | None -> + match pdef.SetMethod with + | None -> ILMemberAccess.Public + | Some mref -> (resolveILMethodRef tdef mref).Access + ilAccess + +let IsILPropInfoAccessible g amap m ad pinfo = + let ilAccess = GetILAccessOfILPropInfo pinfo + IsILTypeAndMemberAccessible g amap m ad ad pinfo.ILTypeInfo ilAccess + +let IsValAccessible ad (vref:ValRef) = + vref.Accessibility |> IsAccessible ad + +let CheckValAccessible m ad (vref:ValRef) = + if not (IsValAccessible ad vref) then + errorR (Error (FSComp.SR.valueIsNotAccessible vref.DisplayName,m)) + +let IsUnionCaseAccessible amap m ad (ucref:UnionCaseRef) = + IsTyconReprAccessible amap m ad ucref.TyconRef && + IsAccessible ad ucref.UnionCase.Accessibility + +let CheckUnionCaseAccessible amap m ad (ucref:UnionCaseRef) = + CheckTyconReprAccessible amap m ad ucref.TyconRef && + (let res = IsAccessible ad ucref.UnionCase.Accessibility + if not res then + errorR (Error (FSComp.SR.unionCaseIsNotAccessible ucref.CaseName,m)) + res) + +let IsRecdFieldAccessible amap m ad (rfref:RecdFieldRef) = + IsTyconReprAccessible amap m ad rfref.TyconRef && + IsAccessible ad rfref.RecdField.Accessibility + +let CheckRecdFieldAccessible amap m ad (rfref:RecdFieldRef) = + CheckTyconReprAccessible amap m ad rfref.TyconRef && + (let res = IsAccessible ad rfref.RecdField.Accessibility + if not res then + errorR (Error (FSComp.SR.fieldIsNotAccessible rfref.FieldName,m)) + res) + +let CheckRecdFieldInfoAccessible amap m ad (rfinfo:RecdFieldInfo) = + CheckRecdFieldAccessible amap m ad rfinfo.RecdFieldRef |> ignore + +let CheckILFieldInfoAccessible g amap m ad finfo = + if not (IsILFieldInfoAccessible g amap m ad finfo) then + errorR (Error (FSComp.SR.structOrClassFieldIsNotAccessible finfo.FieldName,m)) + +/// Uses a separate accessibility domains for containing type and method itself +/// This makes sense cases like +/// type A() = +/// type protected B() = +/// member this.Public() = () +/// member protected this.Protected() = () +/// type C() = +/// inherit A() +/// let x = A.B() +/// do x.Public() +/// when calling x.SomeMethod() we need to use 'adTyp' do verify that type of x is accessible from C +/// and 'ad' to determine accessibility of SomeMethod. +/// I.e when calling x.Public() and x.Protected() -in both cases first check should succeed and second - should fail in the latter one. +let IsTypeAndMethInfoAccessible amap m adTyp ad = function + | ILMeth (g,x,_) -> IsILMethInfoAccessible g amap m adTyp ad x + | FSMeth (_,_,vref,_) -> IsValAccessible ad vref + | DefaultStructCtor(g,typ) -> IsTypeAccessible g amap m ad typ +#if EXTENSIONTYPING + | ProvidedMeth(amap,tpmb,_,m) as etmi -> + let access = tpmb.PUntaint((fun mi -> ComputeILAccess mi.IsPublic mi.IsFamily mi.IsFamilyOrAssembly mi.IsFamilyAndAssembly), m) + IsProvidedMemberAccessible amap m ad etmi.EnclosingType access +#endif +let IsMethInfoAccessible amap m ad minfo = IsTypeAndMethInfoAccessible amap m ad ad minfo + +let IsPropInfoAccessible g amap m ad = function + | ILProp (_,x) -> IsILPropInfoAccessible g amap m ad x + | FSProp (_,_,Some vref,_) + | FSProp (_,_,_,Some vref) -> IsValAccessible ad vref +#if EXTENSIONTYPING + | ProvidedProp (amap, tppi, m) as pp-> + let access = + let a = tppi.PUntaint((fun ppi -> + let tryGetILAccessForProvidedMethodBase (mi : ProvidedMethodBase) = + match mi with + | null -> None + | mi -> Some(ComputeILAccess mi.IsPublic mi.IsFamily mi.IsFamilyOrAssembly mi.IsFamilyAndAssembly) + match tryGetILAccessForProvidedMethodBase(ppi.GetGetMethod()) with + | None -> tryGetILAccessForProvidedMethodBase(ppi.GetSetMethod()) + | x -> x), m) + defaultArg a ILMemberAccess.Public + IsProvidedMemberAccessible amap m ad pp.EnclosingType access +#endif + | _ -> false + +let IsFieldInfoAccessible ad (rfref:RecdFieldInfo) = + IsAccessible ad rfref.RecdField.Accessibility + + + diff --git a/src/fsharp/AttributeChecking.fs b/src/fsharp/AttributeChecking.fs new file mode 100644 index 0000000000..661b5ede03 --- /dev/null +++ b/src/fsharp/AttributeChecking.fs @@ -0,0 +1,499 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +/// Logic associated with checking "ObsoleteAttribute" and other attributes +/// on items from name resolution +module internal Microsoft.FSharp.Compiler.AttributeChecking + +open Internal.Utilities +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.TcGlobals + +#if EXTENSIONTYPING +open Microsoft.FSharp.Compiler.ExtensionTyping +open Microsoft.FSharp.Core.CompilerServices +#endif + +exception ObsoleteWarning of string * range +exception ObsoleteError of string * range + +let fail() = failwith "This custom attribute has an argument that can not yet be converted using this API" + +let rec private evalILAttribElem e = + match e with + | ILAttribElem.String (Some x) -> box x + | ILAttribElem.String None -> null + | ILAttribElem.Bool x -> box x + | ILAttribElem.Char x -> box x + | ILAttribElem.SByte x -> box x + | ILAttribElem.Int16 x -> box x + | ILAttribElem.Int32 x -> box x + | ILAttribElem.Int64 x -> box x + | ILAttribElem.Byte x -> box x + | ILAttribElem.UInt16 x -> box x + | ILAttribElem.UInt32 x -> box x + | ILAttribElem.UInt64 x -> box x + | ILAttribElem.Single x -> box x + | ILAttribElem.Double x -> box x + | ILAttribElem.Null -> null + | ILAttribElem.Array (_, a) -> box [| for i in a -> evalILAttribElem i |] + // TODO: typeof<..> in attribute values + | ILAttribElem.Type (Some _t) -> fail() + | ILAttribElem.Type None -> null + | ILAttribElem.TypeRef (Some _t) -> fail() + | ILAttribElem.TypeRef None -> null + +let rec private evalFSharpAttribArg g e = + match e with + | Expr.Const(c,_,_) -> + match c with + | Const.Bool b -> box b + | Const.SByte i -> box i + | Const.Int16 i -> box i + | Const.Int32 i -> box i + | Const.Int64 i -> box i + | Const.Byte i -> box i + | Const.UInt16 i -> box i + | Const.UInt32 i -> box i + | Const.UInt64 i -> box i + | Const.Single i -> box i + | Const.Double i -> box i + | Const.Char i -> box i + | Const.Zero -> null + | Const.String s -> box s + | _ -> fail() + | Expr.Op (TOp.Array,_,a,_) -> box [| for i in a -> evalFSharpAttribArg g i |] + | TypeOfExpr g ty -> box ty + // TODO: | TypeDefOfExpr g ty + | _ -> fail() + +type AttribInfo = + | FSAttribInfo of TcGlobals * Attrib + | ILAttribInfo of TcGlobals * Import.ImportMap * ILScopeRef * ILAttribute * range + + member x.TyconRef = + match x with + | FSAttribInfo(_g,Attrib(tcref,_,_,_,_,_,_)) -> tcref + | ILAttribInfo (g, amap, scoref, a, m) -> + let ty = ImportILType scoref amap m [] a.Method.EnclosingType + tcrefOfAppTy g ty + + member x.ConstructorArguments = + match x with + | FSAttribInfo(g,Attrib(_,_,unnamedArgs,_,_,_,_)) -> + unnamedArgs + |> List.map (fun (AttribExpr(origExpr,evaluatedExpr)) -> + let ty = tyOfExpr g origExpr + let obj = evalFSharpAttribArg g evaluatedExpr + ty,obj) + | ILAttribInfo (g, amap, scoref, cattr, m) -> + let parms, _args = decodeILAttribData g.ilg cattr + [ for (argty,argval) in Seq.zip cattr.Method.FormalArgTypes parms -> + let ty = ImportILType scoref amap m [] argty + let obj = evalILAttribElem argval + ty,obj ] + + member x.NamedArguments = + match x with + | FSAttribInfo(g,Attrib(_,_,_,namedArgs,_,_,_)) -> + namedArgs + |> List.map (fun (AttribNamedArg(nm,_,isField,AttribExpr(origExpr,evaluatedExpr))) -> + let ty = tyOfExpr g origExpr + let obj = evalFSharpAttribArg g evaluatedExpr + ty, nm, isField, obj) + | ILAttribInfo (g, amap, scoref, cattr, m) -> + let _parms, namedArgs = decodeILAttribData g.ilg cattr + [ for (nm, argty, isProp, argval) in namedArgs -> + let ty = ImportILType scoref amap m [] argty + let obj = evalILAttribElem argval + let isField = not isProp + ty, nm, isField, obj ] + + +/// Check custom attributes. This is particularly messy because custom attributes come in in three different +/// formats. +let AttribInfosOfIL g amap scoref m (attribs: ILAttributes) = + attribs.AsList |> List.map (fun a -> ILAttribInfo (g, amap, scoref, a, m)) + +let AttribInfosOfFS g attribs = + attribs |> List.map (fun a -> FSAttribInfo (g, a)) + +let GetAttribInfosOfEntity g amap m (tcref:TyconRef) = + match metadataOfTycon tcref.Deref with +#if EXTENSIONTYPING + // TODO: provided attributes + | ProvidedTypeMetadata _info -> [] + //let provAttribs = info.ProvidedType.PApply((fun a -> (a :> IProvidedCustomAttributeProvider)),m) + //match provAttribs.PUntaint((fun a -> a. .GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), atref.FullName)),m) with + //| Some args -> f3 args + //| None -> None +#endif + | ILTypeMetadata (scoref,tdef) -> + tdef.CustomAttrs |> AttribInfosOfIL g amap scoref m + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> + tcref.Attribs |> List.map (fun a -> FSAttribInfo (g, a)) + + +let GetAttribInfosOfMethod amap m minfo = + match minfo with + | ILMeth (g,ilminfo,_) -> ilminfo.RawMetadata.CustomAttrs |> AttribInfosOfIL g amap ilminfo.MetadataScope m + | FSMeth (g,_,vref,_) -> vref.Attribs |> AttribInfosOfFS g + | DefaultStructCtor _ -> [] +#if EXTENSIONTYPING + // TODO: provided attributes + | ProvidedMeth (_,_mi,_,_m) -> + [] + +#endif + +let GetAttribInfosOfProp amap m pinfo = + match pinfo with + | ILProp(g,ilpinfo) -> ilpinfo.RawMetadata.CustomAttrs |> AttribInfosOfIL g amap ilpinfo.ILTypeInfo.ILScopeRef m + | FSProp(g,_,Some vref,_) + | FSProp(g,_,_,Some vref) -> vref.Attribs |> AttribInfosOfFS g + | FSProp _ -> failwith "GetAttribInfosOfProp: unreachable" +#if EXTENSIONTYPING + // TODO: provided attributes + | ProvidedProp _ -> [] +#endif + +let GetAttribInfosOfEvent amap m einfo = + match einfo with + | ILEvent(g, x) -> x.RawMetadata.CustomAttrs |> AttribInfosOfIL g amap x.ILTypeInfo.ILScopeRef m + | FSEvent(_, pi, _vref1, _vref2) -> GetAttribInfosOfProp amap m pi +#if EXTENSIONTYPING + // TODO: provided attributes + | ProvidedEvent _ -> [] +#endif + +/// Analyze three cases for attributes declared on type definitions: IL-declared attributes, F#-declared attributes and +/// provided attributes. +// +// This is used for AttributeUsageAttribute, DefaultMemberAttribute and ConditionalAttribute (on attribute types) +let TryBindTyconRefAttribute g m (AttribInfo (atref,_) as args) (tcref:TyconRef) f1 f2 f3 = + ignore m; ignore f3 + match metadataOfTycon tcref.Deref with +#if EXTENSIONTYPING + | ProvidedTypeMetadata info -> + let provAttribs = info.ProvidedType.PApply((fun a -> (a :> IProvidedCustomAttributeProvider)),m) + match provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), atref.FullName)),m) with + | Some args -> f3 args + | None -> None +#endif + | ILTypeMetadata (_,tdef) -> + match TryDecodeILAttribute g atref tdef.CustomAttrs with + | Some attr -> f1 attr + | _ -> None + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> + match TryFindFSharpAttribute g args tcref.Attribs with + | Some attr -> f2 attr + | _ -> None + +/// Analyze three cases for attributes declared on methods: IL-declared attributes, F#-declared attributes and +/// provided attributes. +let BindMethInfoAttributes m minfo f1 f2 f3 = + ignore m; ignore f3 + match minfo with + | ILMeth (_,x,_) -> f1 x.RawMetadata.CustomAttrs + | FSMeth (_,_,vref,_) -> f2 vref.Attribs + | DefaultStructCtor _ -> f2 [] +#if EXTENSIONTYPING + | ProvidedMeth (_,mi,_,_) -> f3 (mi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) +#endif + +/// Analyze three cases for attributes declared on methods: IL-declared attributes, F#-declared attributes and +/// provided attributes. +let TryBindMethInfoAttribute g m (AttribInfo(atref,_) as attribSpec) minfo f1 f2 f3 = +#if EXTENSIONTYPING +#else + // to prevent unused parameter warning + ignore f3 +#endif + BindMethInfoAttributes m minfo + (fun ilAttribs -> TryDecodeILAttribute g atref ilAttribs |> Option.bind f1) + (fun fsAttribs -> TryFindFSharpAttribute g attribSpec fsAttribs |> Option.bind f2) +#if EXTENSIONTYPING + (fun provAttribs -> + match provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), atref.FullName)),m) with + | Some args -> f3 args + | None -> None) +#else + (fun _provAttribs -> None) +#endif + +/// Try to find a specific attribute on a method, where the attribute accepts a string argument. +/// +/// This is just used for the 'ConditionalAttribute' attribute +let TryFindMethInfoStringAttribute g m attribSpec minfo = + TryBindMethInfoAttribute g m attribSpec minfo + (function ([ILAttribElem.String (Some msg) ],_) -> Some msg | _ -> None) + (function (Attrib(_,_,[ AttribStringArg msg ],_,_,_,_)) -> Some msg | _ -> None) + (function ([ Some ((:? string as msg) : obj) ],_) -> Some msg | _ -> None) + +/// Check if a method has a specific attribute. +let MethInfoHasAttribute g m attribSpec minfo = + TryBindMethInfoAttribute g m attribSpec minfo + (fun _ -> Some ()) + (fun _ -> Some ()) + (fun _ -> Some ()) + |> Option.isSome + + + +/// Check IL attributes for 'ObsoleteAttribute', returning errors and warnings as data +let private CheckILAttributes g cattrs m = + let (AttribInfo(tref,_)) = g.attrib_SystemObsolete + match TryDecodeILAttribute g tref cattrs with + | Some ([ILAttribElem.String (Some msg) ],_) -> + WarnD(ObsoleteWarning(msg,m)) + | Some ([ILAttribElem.String (Some msg); ILAttribElem.Bool isError ],_) -> + if isError then + ErrorD (ObsoleteError(msg,m)) + else + WarnD (ObsoleteWarning(msg,m)) + | Some ([ILAttribElem.String None ],_) -> + WarnD(ObsoleteWarning("",m)) + | Some _ -> + WarnD(ObsoleteWarning("",m)) + | None -> + CompleteD + +/// Check F# attributes for 'ObsoleteAttribute', 'CompilerMessageAttribute' and 'ExperimentalAttribute', +/// returning errors and warnings as data +let CheckFSharpAttributes g attribs m = + if isNil attribs then CompleteD + else + (match TryFindFSharpAttribute g g.attrib_SystemObsolete attribs with + | Some(Attrib(_,_,[ AttribStringArg s ],_,_,_,_)) -> + WarnD(ObsoleteWarning(s,m)) + | Some(Attrib(_,_,[ AttribStringArg s; AttribBoolArg(isError) ],_,_,_,_)) -> + if isError then + ErrorD (ObsoleteError(s,m)) + else + WarnD (ObsoleteWarning(s,m)) + | Some _ -> + WarnD(ObsoleteWarning("", m)) + | None -> + CompleteD + ) ++ (fun () -> + + match TryFindFSharpAttribute g g.attrib_CompilerMessageAttribute attribs with + | Some(Attrib(_,_,[ AttribStringArg s ; AttribInt32Arg n ],namedArgs,_,_,_)) -> + let msg = UserCompilerMessage(s,n,m) + let isError = + match namedArgs with + | ExtractAttribNamedArg "IsError" (AttribBoolArg v) -> v + | _ -> false + if isError then ErrorD msg else WarnD msg + + | _ -> + CompleteD + ) ++ (fun () -> + + match TryFindFSharpAttribute g g.attrib_ExperimentalAttribute attribs with + | Some(Attrib(_,_,[ AttribStringArg(s) ],_,_,_,_)) -> + WarnD(Experimental(s,m)) + | Some _ -> + WarnD(Experimental(FSComp.SR.experimentalConstruct (), m)) + | _ -> + CompleteD + ) ++ (fun () -> + + match TryFindFSharpAttribute g g.attrib_UnverifiableAttribute attribs with + | Some _ -> + WarnD(PossibleUnverifiableCode(m)) + | _ -> + CompleteD + ) + +#if EXTENSIONTYPING +/// Check a list of provided attributes for 'ObsoleteAttribute', returning errors and warnings as data +let private CheckProvidedAttributes g m (provAttribs: Tainted) = + let (AttribInfo(tref,_)) = g.attrib_SystemObsolete + match provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), tref.FullName)),m) with + | Some ([ Some (:? string as msg) ], _) -> WarnD(ObsoleteWarning(msg,m)) + | Some ([ Some (:? string as msg); Some (:?bool as isError) ], _) -> + if isError then + ErrorD (ObsoleteError(msg,m)) + else + WarnD (ObsoleteWarning(msg,m)) + | Some ([ None ], _) -> + WarnD(ObsoleteWarning("",m)) + | Some _ -> + WarnD(ObsoleteWarning("",m)) + | None -> + CompleteD +#endif + +/// Indicate if a list of IL attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. +let CheckILAttributesForUnseen g cattrs _m = + let (AttribInfo(tref,_)) = g.attrib_SystemObsolete + isSome (TryDecodeILAttribute g tref cattrs) + +/// Checks the attributes for CompilerMessageAttribute, which has an IsHidden argument that allows +/// items to be suppressed from intellisense. +let CheckFSharpAttributesForHidden g attribs = + nonNil attribs && + (match TryFindFSharpAttribute g g.attrib_CompilerMessageAttribute attribs with + | Some(Attrib(_,_,[AttribStringArg _; AttribInt32Arg messageNumber], + ExtractAttribNamedArg "IsHidden" (AttribBoolArg v),_,_,_)) -> + // Message number 62 is for "ML Compatibility". Items labelled with this are visible in intellisense + // when mlCompatibility is set. + v && not (messageNumber = 62 && g.mlCompatibility) + | _ -> false) + +/// Indicate if a list of F# attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. +let CheckFSharpAttributesForObsolete g attribs = + nonNil attribs && (HasFSharpAttribute g g.attrib_SystemObsolete attribs) + +/// Indicate if a list of F# attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. +/// Also check the attributes for CompilerMessageAttribute, which has an IsHidden argument that allows +/// items to be suppressed from intellisense. +let CheckFSharpAttributesForUnseen g attribs _m = + nonNil attribs && + (CheckFSharpAttributesForObsolete g attribs || + CheckFSharpAttributesForHidden g attribs) + +#if EXTENSIONTYPING +/// Indicate if a list of provided attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. +let CheckProvidedAttributesForUnseen (provAttribs: Tainted) m = + provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), typeof.FullName).IsSome),m) +#endif + +/// Check the attributes associated with a property, returning warnings and errors as data. +let CheckPropInfoAttributes pinfo m = + match pinfo with + | ILProp(g,ILPropInfo(_,pdef)) -> CheckILAttributes g pdef.CustomAttrs m + | FSProp(g,_,Some vref,_) + | FSProp(g,_,_,Some vref) -> CheckFSharpAttributes g vref.Attribs m + | FSProp _ -> failwith "CheckPropInfoAttributes: unreachable" +#if EXTENSIONTYPING + | ProvidedProp (amap,pi,m) -> + CheckProvidedAttributes amap.g m (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) + +#endif + + +/// Check the attributes associated with a IL field, returning warnings and errors as data. +let CheckILFieldAttributes g (finfo:ILFieldInfo) m = + match finfo with + | ILFieldInfo(_,pd) -> + CheckILAttributes g pd.CustomAttrs m |> CommitOperationResult +#if EXTENSIONTYPING + | ProvidedField (amap,fi,m) -> + CheckProvidedAttributes amap.g m (fi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) |> CommitOperationResult +#endif + +/// Check the attributes associated with a method, returning warnings and errors as data. +let CheckMethInfoAttributes g m tyargsOpt minfo = + let search = + BindMethInfoAttributes m minfo + (fun ilAttribs -> Some(CheckILAttributes g ilAttribs m)) + (fun fsAttribs -> + let res = + CheckFSharpAttributes g fsAttribs m ++ (fun () -> + if isNone tyargsOpt && HasFSharpAttribute g g.attrib_RequiresExplicitTypeArgumentsAttribute fsAttribs then + ErrorD(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(minfo.LogicalName),m)) + else + CompleteD) + Some res) +#if EXTENSIONTYPING + (fun provAttribs -> Some (CheckProvidedAttributes g m provAttribs)) +#else + (fun _provAttribs -> None) +#endif + match search with + | Some res -> res + | None -> CompleteD // no attribute = no errors + +/// Indicate if a method has 'Obsolete', 'CompilerMessageAttribute' or 'TypeProviderEditorHideMethodsAttribute'. +/// Used to suppress the item in intellisense. +let MethInfoIsUnseen g m typ minfo = + let isUnseenByObsoleteAttrib = + match BindMethInfoAttributes m minfo + (fun ilAttribs -> Some(CheckILAttributesForUnseen g ilAttribs m)) + (fun fsAttribs -> Some(CheckFSharpAttributesForUnseen g fsAttribs m)) +#if EXTENSIONTYPING + (fun provAttribs -> Some(CheckProvidedAttributesForUnseen provAttribs m)) +#else + (fun _provAttribs -> None) +#endif + with + | Some res -> res + | None -> false + + let isUnseenByHidingAttribute = +#if EXTENSIONTYPING + not (isObjTy g typ) && + isAppTy g typ && + isObjTy g minfo.EnclosingType && + let tcref = tcrefOfAppTy g typ + match tcref.TypeReprInfo with + | TProvidedTypeExtensionPoint info -> + info.ProvidedType.PUntaint((fun st -> (st :> IProvidedCustomAttributeProvider).GetHasTypeProviderEditorHideMethodsAttribute(info.ProvidedType.TypeProvider.PUntaintNoFailure(id))), m) + | _ -> + // This attribute check is done by name to ensure compilation doesn't take a dependency + // on Microsoft.FSharp.Core.CompilerServices.TypeProviderEditorHideMethodsAttribute. + // + // We are only interested in filtering out the method on System.Object, so it is sufficient + // just to look at the attributes on IL methods. + if tcref.IsILTycon then + tcref.ILTyconRawMetadata.CustomAttrs.AsList + |> List.exists (fun attr -> attr.Method.EnclosingType.TypeSpec.Name = typeof.FullName) + else + false +#else + typ |> ignore + false +#endif + isUnseenByObsoleteAttrib || isUnseenByHidingAttribute + +/// Indicate if a property has 'Obsolete' or 'CompilerMessageAttribute'. +/// Used to suppress the item in intellisense. +let PropInfoIsUnseen m pinfo = + match pinfo with + | ILProp (g,ILPropInfo(_,pdef)) -> CheckILAttributesForUnseen g pdef.CustomAttrs m + | FSProp (g,_,Some vref,_) + | FSProp (g,_,_,Some vref) -> CheckFSharpAttributesForUnseen g vref.Attribs m + | FSProp _ -> failwith "CheckPropInfoAttributes: unreachable" +#if EXTENSIONTYPING + | ProvidedProp (_amap,pi,m) -> + CheckProvidedAttributesForUnseen (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) m +#endif + +/// Check the attributes on an entity, returning errors and warnings as data. +let CheckEntityAttributes g (x:TyconRef) m = + if x.IsILTycon then + CheckILAttributes g x.ILTyconRawMetadata.CustomAttrs m + else + CheckFSharpAttributes g x.Attribs m + +/// Check the attributes on a union case, returning errors and warnings as data. +let CheckUnionCaseAttributes g (x:UnionCaseRef) m = + CheckEntityAttributes g x.TyconRef m ++ (fun () -> + CheckFSharpAttributes g x.Attribs m) + +/// Check the attributes on a record field, returning errors and warnings as data. +let CheckRecdFieldAttributes g (x:RecdFieldRef) m = + CheckEntityAttributes g x.TyconRef m ++ (fun () -> + CheckFSharpAttributes g x.PropertyAttribs m) + +/// Check the attributes on an F# value, returning errors and warnings as data. +let CheckValAttributes g (x:ValRef) m = + CheckFSharpAttributes g x.Attribs m + +/// Check the attributes on a record field, returning errors and warnings as data. +let CheckRecdFieldInfoAttributes g (x:RecdFieldInfo) m = + CheckRecdFieldAttributes g x.RecdFieldRef m + + diff --git a/src/fsharp/AugmentWithHashCompare.fs b/src/fsharp/AugmentWithHashCompare.fs index 3b4031007c..5199dc223c 100755 --- a/src/fsharp/AugmentWithHashCompare.fs +++ b/src/fsharp/AugmentWithHashCompare.fs @@ -110,28 +110,42 @@ let mkCombineHashGenerators g m exprs accv acce = // Build comparison functions for union, record and exception types. //------------------------------------------------------------------------- +let mkThatAddrLocal g m ty = mkCompGenLocal m "obj" (mkThisTy g ty) +let mkThatAddrLocalIfNeeded g m tcve ty = + if isStructTy g ty then + let thataddrv, thataddre = mkCompGenLocal m "obj" (mkThisTy g ty) + Some thataddrv, thataddre + else None,tcve + let mkThisVarThatVar g m ty = let thisv,thise = mkThisVar g m ty - let thatv,thate = mkCompGenLocal m "obj" (mkThisTy g ty) - thisv,thatv,thise,thate + let thataddrv,thataddre = mkThatAddrLocal g m ty + thisv,thataddrv,thise,thataddre -let mkThatVarBind g m ty thatv expr = +let mkThatVarBind g m ty thataddrv expr = if isStructTy g ty then let thatv2,_ = mkMutableCompGenLocal m "obj" ty - thatv2,mkCompGenLet m thatv (mkValAddr m (mkLocalValRef thatv2)) expr - else thatv,expr + thatv2,mkCompGenLet m thataddrv (mkValAddr m (mkLocalValRef thatv2)) expr + else thataddrv,expr -let mkThatAddrLocal g m ty = - if isStructTy g ty then - mkMutableCompGenLocal m "objCast" (mkByrefTy g ty) - else - mkCompGenLocal m "objCast" ty - let mkBindThatAddr g m ty thataddrv thatv thate expr = if isStructTy g ty then - mkCompGenLet m thataddrv (mkValAddr m (mkLocalValRef thatv)) expr + // let thataddrv = &thatv + mkCompGenLet m thataddrv (mkValAddr m (mkLocalValRef thatv)) expr else - mkCompGenLet m thataddrv thate expr + // let thataddrv = that + mkCompGenLet m thataddrv thate expr + +let mkBindThatAddrIfNeeded m thataddrvOpt thatv expr = + match thataddrvOpt with + | None -> expr + | Some thataddrv -> + // let thataddrv = &thatv + mkCompGenLet m thataddrv (mkValAddr m (mkLocalValRef thatv)) expr + +let mkDerefThis g m (thisv: Val) thise = + if isByrefTy g thisv.Type then mkAddrGet m (mkLocalValRef thisv) + else thise let mkCompareTestConjuncts g m exprs = match exprs with @@ -186,7 +200,7 @@ let mkRecdCompare g tcref (tycon:Tycon) = let m = tycon.Range let fields = tycon.AllInstanceFieldsAsList let tinst,ty = mkMinimalTy g tcref - let thisv,thatv,thise,thate = mkThisVarThatVar g m ty + let thisv,thataddrv,thise,thataddre = mkThisVarThatVar g m ty let compe = mkILCallGetComparer g m let mkTest (fspec:RecdField) = let fty = fspec.FormalType @@ -195,12 +209,12 @@ let mkRecdCompare g tcref (tycon:Tycon) = mkCallGenericComparisonWithComparerOuter g m fty compe (mkRecdFieldGetViaExprAddr(thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr(thate, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr(thataddre, fref, tinst, m)) let expr = mkCompareTestConjuncts g m (List.map mkTest fields) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thate expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thataddre expr - let thatv,expr = mkThatVarBind g m ty thatv expr + let thatv,expr = mkThatVarBind g m ty thataddrv expr thisv,thatv, expr @@ -235,19 +249,19 @@ let mkRecdEquality g tcref (tycon:Tycon) = let m = tycon.Range let fields = tycon.AllInstanceFieldsAsList let tinst,ty = mkMinimalTy g tcref - let thisv,thatv,thise,thate = mkThisVarThatVar g m ty + let thisv,thataddrv,thise,thataddre = mkThisVarThatVar g m ty let mkTest (fspec:RecdField) = let fty = fspec.FormalType let fref = tcref.MakeNestedRecdFieldRef fspec let m = fref.Range mkCallGenericEqualityEROuter g m fty (mkRecdFieldGetViaExprAddr(thise, fref, tinst, m)) - (mkRecdFieldGetViaExprAddr(thate, fref, tinst, m)) + (mkRecdFieldGetViaExprAddr(thataddre, fref, tinst, m)) let expr = mkEqualsTestConjuncts g m (List.map mkTest fields) - let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThatNullEquals g m thise thate expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThatNullEquals g m thise thataddre expr - let thatv,expr = mkThatVarBind g m ty thatv expr + let thatv,expr = mkThatVarBind g m ty thataddrv expr thisv,thatv,expr /// Build the equality implementation for a record type when parameterized by a comparer @@ -288,12 +302,11 @@ let mkExnEquality g exnref (exnc:Tycon) = let expr = mkEqualsTestConjuncts g m (List.mapi mkTest (exnc.AllInstanceFieldsAsList)) let expr = let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding,m ) - let dtree = - TDSwitch(thate, - [ mkCase(Test.IsInst(g.exn_ty,mkAppTy exnref []), - mbuilder.AddResultTarget(expr,SuppressSequencePointAtTarget)) ], - Some(mbuilder.AddResultTarget(mkFalse g m,SuppressSequencePointAtTarget)), - m) + let cases = + [ mkCase(Test.IsInst(g.exn_ty,mkAppTy exnref []), + mbuilder.AddResultTarget(expr,SuppressSequencePointAtTarget)) ] + let dflt = Some(mbuilder.AddResultTarget(mkFalse g m,SuppressSequencePointAtTarget)) + let dtree = TDSwitch(thate,cases,dflt,m) mbuilder.Close(dtree,m,g.bool_ty) let expr = mkBindThatNullEquals g m thise thate expr @@ -313,12 +326,11 @@ let mkExnEqualityWithComparer g exnref (exnc:Tycon) (_thisv,thise) thatobje (tha let expr = mkEqualsTestConjuncts g m (List.mapi mkTest (exnc.AllInstanceFieldsAsList)) let expr = let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding,m ) - let dtree = - TDSwitch(thataddre, - [ mkCase(Test.IsInst(g.exn_ty,mkAppTy exnref []), - mbuilder.AddResultTarget(expr,SuppressSequencePointAtTarget)) ], - Some(mbuilder.AddResultTarget(mkFalse g m,SuppressSequencePointAtTarget)), - m) + let cases = + [ mkCase(Test.IsInst(g.exn_ty,mkAppTy exnref []), + mbuilder.AddResultTarget(expr,SuppressSequencePointAtTarget)) ] + let dflt = mbuilder.AddResultTarget(mkFalse g m,SuppressSequencePointAtTarget) + let dtree = TDSwitch(thate,cases,Some dflt,m) mbuilder.Close(dtree,m,g.bool_ty) let expr = mkBindThatAddr g m g.exn_ty thataddrv thatv thate expr let expr = mkIsInstConditional g m g.exn_ty thatobje thatv expr (mkFalse g m) @@ -330,8 +342,7 @@ let mkUnionCompare g tcref (tycon:Tycon) = let m = tycon.Range let ucases = tycon.UnionCasesAsList let tinst,ty = mkMinimalTy g tcref - let thisv,thise = mkCompGenLocal m "this" ty - let thatv,thate = mkCompGenLocal m "obj" ty + let thisv,thataddrv,thise,thataddre = mkThisVarThatVar g m ty let thistagv,thistage = mkCompGenLocal m "thisTag" g.int_ty let thattagv,thattage = mkCompGenLocal m "thatTag" g.int_ty let compe = mkILCallGetComparer g m @@ -341,30 +352,29 @@ let mkUnionCompare g tcref (tycon:Tycon) = let mkCase ucase = let cref = tcref.MakeNestedUnionCaseRef ucase let m = cref.Range - let thisucv,thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) - let thatucv,thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) - let mkTest j (argty:RecdField) = - mkCallGenericComparisonWithComparerOuter g m argty.FormalType - compe - (mkUnionCaseFieldGetProven(thisucve, cref, tinst, j, m)) - (mkUnionCaseFieldGetProven(thatucve, cref, tinst, j, m)) let rfields = ucase.RecdFields if isNil rfields then None else - Some (mkCase(Test.UnionCase(cref,tinst), - mbuilder.AddResultTarget - (mkCompGenLet m thisucv (mkUnionCaseProof(thise,cref,tinst,m)) - (mkCompGenLet m thatucv (mkUnionCaseProof(thate,cref,tinst,m)) - (mkCompareTestConjuncts g m (List.mapi mkTest rfields))), - SuppressSequencePointAtTarget))) + let mkTest thise thataddre j (argty:RecdField) = + mkCallGenericComparisonWithComparerOuter g m argty.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr(thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr(thataddre, cref, tinst, j, m)) + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv,thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) + let thatucv,thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) + mkCompGenLet m thisucv (mkUnionCaseProof (thise,cref,tinst,m)) + (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre,cref,tinst,m)) + (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + Some (mkCase(Test.UnionCase(cref,tinst),mbuilder.AddResultTarget(test,SuppressSequencePointAtTarget))) let nullary,nonNullary = List.partition isNone (List.map mkCase ucases) if isNil nonNullary then mkZero g m else - let dtree = - TDSwitch(thise, - (nonNullary |> List.map (function (Some c) -> c | None -> failwith "mkUnionCompare")), - (if isNil nullary then None - else Some (mbuilder.AddResultTarget(mkZero g m,SuppressSequencePointAtTarget))), - m) + let cases = nonNullary |> List.map (function (Some c) -> c | None -> failwith "mkUnionCompare") + let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkZero g m,SuppressSequencePointAtTarget)) + let dtree = TDSwitch(thise, cases, dflt,m) mbuilder.Close(dtree,m,g.int_ty) let expr = @@ -375,53 +385,56 @@ let mkUnionCompare g tcref (tycon:Tycon) = expr (mkAsmExpr ([ IL.AI_sub ],[], [thistage; thattage],[g.int_ty],m))in mkCompGenLet m thistagv - (mkUnionCaseTagGet (thise,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thise,tcref,tinst,m)) (mkCompGenLet m thattagv - (mkUnionCaseTagGet (thate,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thataddre,tcref,tinst,m)) tagsEqTested) - let expr = mkBindNullComparison g m thise thate expr - thisv,thatv, expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thataddre expr + thisv,thataddrv, expr /// Build the comparison implementation for a union type when parameterized by a comparer -let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (thatv,thate) compe = +let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (_thatobjv,thatcaste) compe = let m = tycon.Range let ucases = tycon.UnionCasesAsList let tinst,ty = mkMinimalTy g tcref + let tcv,tce = mkCompGenLocal m "objTemp" ty // let tcv = (thatobj :?> ty) + let thataddrvOpt,thataddre = mkThatAddrLocalIfNeeded g m tce ty // let thataddrv = &tcv if struct, otherwise thataddre is just tce let thistagv,thistage = mkCompGenLocal m "thisTag" g.int_ty let thattagv,thattage = mkCompGenLocal m "thatTag" g.int_ty - let thataddrv,thataddre = mkThatAddrLocal g m ty let expr = let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding,m ) let mkCase ucase = let cref = tcref.MakeNestedUnionCaseRef ucase let m = cref.Range - let thisucv,thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) - let thatucv,thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) - let mkTest j (argty:RecdField) = - mkCallGenericComparisonWithComparerOuter g m argty.FormalType - compe - (mkUnionCaseFieldGetProven(thisucve, cref, tinst, j, m)) - (mkUnionCaseFieldGetProven(thatucve, cref, tinst, j, m)) let rfields = ucase.RecdFields if isNil rfields then None else - Some (mkCase(Test.UnionCase(cref,tinst), - mbuilder.AddResultTarget - (mkCompGenLet m thisucv (mkUnionCaseProof(thise,cref,tinst,m)) - (mkCompGenLet m thatucv (mkUnionCaseProof(thataddre,cref,tinst,m)) - (mkCompareTestConjuncts g m (List.mapi mkTest rfields))), - SuppressSequencePointAtTarget))) + + let mkTest thise thataddre j (argty:RecdField) = + mkCallGenericComparisonWithComparerOuter g m argty.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr(thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr(thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkCompareTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv,thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) + let thatucv,thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) + mkCompGenLet m thisucv (mkUnionCaseProof (thise,cref,tinst,m)) + (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre,cref,tinst,m)) + (mkCompareTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some (mkCase(Test.UnionCase(cref,tinst),mbuilder.AddResultTarget(test,SuppressSequencePointAtTarget))) let nullary,nonNullary = List.partition isNone (List.map mkCase ucases) if isNil nonNullary then mkZero g m else - let dtree = - TDSwitch(thise, - (nonNullary |> List.map (function (Some c) -> c | None -> failwith "mkUnionCompare")), - (if isNil nullary then None - else Some (mbuilder.AddResultTarget(mkZero g m,SuppressSequencePointAtTarget))), - m) + let cases = nonNullary |> List.map (function (Some c) -> c | None -> failwith "mkUnionCompare") + let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkZero g m,SuppressSequencePointAtTarget)) + let dtree = TDSwitch(thise, cases, dflt,m) mbuilder.Close(dtree,m,g.int_ty) let expr = @@ -432,13 +445,14 @@ let mkUnionCompareWithComparer g tcref (tycon:Tycon) (_thisv,thise) (thatv,thate expr (mkAsmExpr ([ IL.AI_sub ],[], [thistage; thattage],[g.int_ty],m))in mkCompGenLet m thistagv - (mkUnionCaseTagGet (thise,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thise,tcref,tinst,m)) (mkCompGenLet m thattagv - (mkUnionCaseTagGet (thataddre,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thataddre,tcref,tinst,m)) tagsEqTested) - let expr = mkBindNullComparison g m thise thate expr - let expr = mkBindThatAddr g m ty thataddrv thatv thate expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullComparison g m thise thatcaste expr + let expr = mkBindThatAddrIfNeeded m thataddrvOpt tcv expr + let expr = mkCompGenLet m tcv thatcaste expr expr @@ -447,8 +461,7 @@ let mkUnionEquality g tcref (tycon:Tycon) = let m = tycon.Range let ucases = tycon.UnionCasesAsList let tinst,ty = mkMinimalTy g tcref - let thisv,thise = mkCompGenLocal m "this" ty - let thatv,thate = mkCompGenLocal m "obj" ty + let thisv,thataddrv,thise,thataddre = mkThisVarThatVar g m ty let thistagv,thistage = mkCompGenLocal m "thisTag" g.int_ty let thattagv,thattage = mkCompGenLocal m "thatTag" g.int_ty @@ -457,27 +470,31 @@ let mkUnionEquality g tcref (tycon:Tycon) = let mkCase ucase = let cref = tcref.MakeNestedUnionCaseRef ucase let m = cref.Range - let thisucv,thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) - let thatucv,thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) - let mkTest j (argty:RecdField) = - mkCallGenericEqualityEROuter g m argty.FormalType - (mkUnionCaseFieldGetProven(thisucve, cref, tinst, j, m)) - (mkUnionCaseFieldGetProven(thatucve, cref, tinst, j, m)) let rfields = ucase.RecdFields if isNil rfields then None else - Some (mkCase(Test.UnionCase(cref,tinst), - mbuilder.AddResultTarget - (mkCompGenLet m thisucv (mkUnionCaseProof(thise,cref,tinst,m)) - (mkCompGenLet m thatucv (mkUnionCaseProof(thate,cref,tinst,m)) - (mkEqualsTestConjuncts g m (List.mapi mkTest rfields))), - SuppressSequencePointAtTarget))) + + let mkTest thise thataddre j (argty:RecdField) = + mkCallGenericEqualityEROuter g m argty.FormalType + (mkUnionCaseFieldGetProvenViaExprAddr(thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr(thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv,thisucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst) + let thatucv,thatucve = mkCompGenLocal m "objCast" (mkProvenUnionCaseTy cref tinst) + mkCompGenLet m thisucv (mkUnionCaseProof (thise,cref,tinst,m)) + (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre,cref,tinst,m)) + (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some (mkCase(Test.UnionCase(cref,tinst), mbuilder.AddResultTarget(test, SuppressSequencePointAtTarget))) let nullary,nonNullary = List.partition isNone (List.map mkCase ucases) if isNil nonNullary then mkTrue g m else - let dtree = - TDSwitch(thise,List.map (function (Some c) -> c | None -> failwith "mkUnionEquality") nonNullary, - (if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m,SuppressSequencePointAtTarget))), - m) + let cases = List.map (function (Some c) -> c | None -> failwith "mkUnionEquality") nonNullary + let dflt = (if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m,SuppressSequencePointAtTarget))) + let dtree = TDSwitch(thise, cases, dflt, m) mbuilder.Close(dtree,m,g.bool_ty) let expr = @@ -489,13 +506,14 @@ let mkUnionEquality g tcref (tycon:Tycon) = (mkFalse g m) mkCompGenLet m thistagv - (mkUnionCaseTagGet (thise,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thise,tcref,tinst,m)) (mkCompGenLet m thattagv - (mkUnionCaseTagGet (thate,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thataddre,tcref,tinst,m)) tagsEqTested) - let expr = mkBindThatNullEquals g m thise thate expr - thisv,thatv, expr + let thatv,expr = mkThatVarBind g m ty thataddrv expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindThatNullEquals g m thise thataddre expr + thisv,thatv,expr /// Build the equality implementation for a union type when parameterized by a comparer @@ -512,28 +530,34 @@ let mkUnionEqualityWithComparer g tcref (tycon:Tycon) (_thisv,thise) thatobje (t let mkCase ucase = let cref = tcref.MakeNestedUnionCaseRef ucase let m = cref.Range - let thisucv,thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) - let thatucv,thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) - let mkTest j (argty:RecdField) = - mkCallGenericEqualityWithComparerOuter g m argty.FormalType - compe - (mkUnionCaseFieldGetProven(thisucve, cref, tinst, j, m)) - (mkUnionCaseFieldGetProven(thatucve, cref, tinst, j, m)) + let rfields = ucase.RecdFields if isNil rfields then None else - Some (mkCase(Test.UnionCase(cref,tinst), - mbuilder.AddResultTarget - (mkCompGenLet m thisucv (mkUnionCaseProof(thise,cref,tinst,m)) - (mkCompGenLet m thatucv (mkUnionCaseProof(thataddre,cref,tinst,m)) - (mkEqualsTestConjuncts g m (List.mapi mkTest rfields))), - SuppressSequencePointAtTarget))) + + let mkTest thise thataddre j (argty:RecdField) = + mkCallGenericEqualityWithComparerOuter g m argty.FormalType + compe + (mkUnionCaseFieldGetProvenViaExprAddr(thise, cref, tinst, j, m)) + (mkUnionCaseFieldGetProvenViaExprAddr(thataddre, cref, tinst, j, m)) + + let test = + if cref.Tycon.IsStructOrEnumTycon then + mkEqualsTestConjuncts g m (List.mapi (mkTest thise thataddre) rfields) + else + let thisucv,thisucve = mkCompGenLocal m "thisCastu" (mkProvenUnionCaseTy cref tinst) + let thatucv,thatucve = mkCompGenLocal m "thatCastu" (mkProvenUnionCaseTy cref tinst) + + mkCompGenLet m thisucv (mkUnionCaseProof (thise,cref,tinst,m)) + (mkCompGenLet m thatucv (mkUnionCaseProof (thataddre,cref,tinst,m)) + (mkEqualsTestConjuncts g m (List.mapi (mkTest thisucve thatucve) rfields))) + + Some (mkCase(Test.UnionCase(cref,tinst), mbuilder.AddResultTarget (test, SuppressSequencePointAtTarget))) let nullary,nonNullary = List.partition isNone (List.map mkCase ucases) if isNil nonNullary then mkTrue g m else - let dtree = - TDSwitch(thise,List.map (function (Some c) -> c | None -> failwith "mkUnionEquality") nonNullary, - (if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m,SuppressSequencePointAtTarget))), - m) + let cases = List.map (function (Some c) -> c | None -> failwith "mkUnionEquality") nonNullary + let dflt = if isNil nullary then None else Some (mbuilder.AddResultTarget(mkTrue g m,SuppressSequencePointAtTarget)) + let dtree = TDSwitch(thise, cases, dflt, m) mbuilder.Close(dtree,m,g.bool_ty) let expr = @@ -545,9 +569,9 @@ let mkUnionEqualityWithComparer g tcref (tycon:Tycon) (_thisv,thise) thatobje (t (mkFalse g m) mkCompGenLet m thistagv - (mkUnionCaseTagGet (thise,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thise,tcref,tinst,m)) (mkCompGenLet m thattagv - (mkUnionCaseTagGet (thataddre,tcref,tinst,m)) + (mkUnionCaseTagGetViaExprAddr (thataddre,tcref,tinst,m)) tagsEqTested) let expr = mkBindThatAddr g m ty thataddrv thatv thate expr let expr = mkIsInstConditional g m ty thatobje thatv expr (mkFalse g m) @@ -605,25 +629,32 @@ let mkUnionHashWithComparer g tcref (tycon:Tycon) compe = let mbuilder = new MatchBuilder(NoSequencePointAtInvisibleBinding,m ) let accv,acce = mkMutableCompGenLocal m "i" g.int_ty let mkCase i ucase1 = - let c1ref = tcref.MakeNestedUnionCaseRef ucase1 - let ucv,ucve = mkCompGenLocal m "unionCase" (mkProvenUnionCaseTy c1ref tinst) - let m = c1ref.Range - let mkHash j (rfield:RecdField) = - let fty = rfield.FormalType - let e = mkUnionCaseFieldGetProven(ucve, c1ref, tinst, j, m) - mkCallGenericHashWithComparerOuter g m fty compe e - mkCase(Test.UnionCase(c1ref,tinst), - mbuilder.AddResultTarget - (mkCompGenLet m ucv - (mkUnionCaseProof(thise,c1ref,tinst,m)) + let c1ref = tcref.MakeNestedUnionCaseRef ucase1 + let m = c1ref.Range + let mkHash thise j (rfield:RecdField) = + let fty = rfield.FormalType + let e = mkUnionCaseFieldGetProvenViaExprAddr(thise, c1ref, tinst, j, m) + mkCallGenericHashWithComparerOuter g m fty compe e + + let test = + if tycon.IsStructOrEnumTycon then + mkCompGenSequential m + (mkValSet m (mkLocalValRef accv) (mkInt g m i)) + (mkCombineHashGenerators g m (List.mapi (mkHash thise) ucase1.RecdFields) (mkLocalValRef accv) acce) + else + let ucv,ucve = mkCompGenLocal m "unionCase" (mkProvenUnionCaseTy c1ref tinst) + mkCompGenLet m ucv + (mkUnionCaseProof (thise,c1ref,tinst,m)) (mkCompGenSequential m - (mkValSet m (mkLocalValRef accv) (mkInt g m i)) - (mkCombineHashGenerators g m (List.mapi mkHash ucase1.RecdFields) (mkLocalValRef accv) acce)), - SuppressSequencePointAtTarget)) - let dtree = TDSwitch(thise,List.mapi mkCase ucases, None,m) + (mkValSet m (mkLocalValRef accv) (mkInt g m i)) + (mkCombineHashGenerators g m (List.mapi (mkHash ucve) ucase1.RecdFields) (mkLocalValRef accv) acce)) + + mkCase(Test.UnionCase(c1ref,tinst),mbuilder.AddResultTarget(test,SuppressSequencePointAtTarget)) + + let dtree = TDSwitch(thise, List.mapi mkCase ucases, None,m) let stmt = mbuilder.Close(dtree,m,g.int_ty) let expr = mkCompGenLet m accv (mkZero g m) stmt - let expr = mkBindNullHash g m thise expr + let expr = if tycon.IsStructOrEnumTycon then expr else mkBindNullHash g m thise expr thisv,expr diff --git a/src/fsharp/CompileOps.fs b/src/fsharp/CompileOps.fs index 49c11ad003..7848de02e7 100755 --- a/src/fsharp/CompileOps.fs +++ b/src/fsharp/CompileOps.fs @@ -7,26 +7,29 @@ open System open System.Text open System.IO open System.Collections.Generic +open System.Runtime.CompilerServices + open Internal.Utilities open Internal.Utilities.Text -open Microsoft.FSharp.Compiler +open Internal.Utilities.Collections +open Internal.Utilities.Filename + open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics + +open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.TastPickle open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.TypeChecker open Microsoft.FSharp.Compiler.SR open Microsoft.FSharp.Compiler.DiagnosticMessage - -module Tc = Microsoft.FSharp.Compiler.TypeChecker - -open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.AttributeChecking open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops @@ -38,17 +41,17 @@ open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.ConstraintSolver open Microsoft.FSharp.Compiler.MSBuildResolver open Microsoft.FSharp.Compiler.TypeRelations +open Microsoft.FSharp.Compiler.SignatureConformance +open Microsoft.FSharp.Compiler.MethodOverrides open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.PrettyNaming -open Internal.Utilities.Collections -open Internal.Utilities.Filename open Microsoft.FSharp.Compiler.Import + #if EXTENSIONTYPING open Microsoft.FSharp.Compiler.ExtensionTyping open Microsoft.FSharp.Core.CompilerServices #endif -open System.Runtime.CompilerServices #if FX_RESHAPED_REFLECTION open Microsoft.FSharp.Core.ReflectionAdapters @@ -113,9 +116,9 @@ let GetRangeOfError(err:PhasedError) = #endif | ReservedKeyword(_,m) | IndentationProblem(_,m) - | ErrorFromAddingTypeEquation(_,_,_,_,_,m) + | ErrorFromAddingTypeEquation(_,_,_,_,_,_,m) | ErrorFromApplyingDefault(_,_,_,_,_,m) - | ErrorsFromAddingSubsumptionConstraint(_,_,_,_,_,m) + | ErrorsFromAddingSubsumptionConstraint(_,_,_,_,_,_,m) | FunctionExpected(_,_,m) | BakedInMemberConstraintName(_,m) | StandardOperatorRedefinitionWarning(_,m) @@ -197,9 +200,9 @@ let GetRangeOfError(err:PhasedError) = | NonVirtualAugmentationOnNullValuedType(m) | NonRigidTypar(_,_,_,_,_,m) | ConstraintSolverTupleDiffLengths(_,_,_,m,_) - | ConstraintSolverInfiniteTypes(_,_,_,m,_) + | ConstraintSolverInfiniteTypes(_,_,_,_,m,_) | ConstraintSolverMissingConstraint(_,_,_,m,_) - | ConstraintSolverTypesNotInEqualityRelation(_,_,_,m,_) + | ConstraintSolverTypesNotInEqualityRelation(_,_,_,m,_) | ConstraintSolverError(_,m,_) | ConstraintSolverTypesNotInSubsumptionRelation(_,_,_,m,_) | ConstraintSolverRelatedInformation(_,m,_) @@ -366,6 +369,7 @@ let GetErrorNumber(err:PhasedError) = #if EXTENSIONTYPING | :? TypeProviderError as e -> e.Number #endif + | ErrorsFromAddingSubsumptionConstraint (_,_,_,_,_,ContextInfo.DowncastUsedInsteadOfUpcast _,_) -> fst (FSComp.SR.considerUpcast("","")) | _ -> 193 GetFromException err.Exception @@ -388,7 +392,7 @@ let GetWarningLevel err = let warningOn err level specificWarnOn = let n = GetErrorNumber err - List.mem n specificWarnOn || + List.contains n specificWarnOn || // Some specific warnings are never on by default, i.e. unused variable warnings match n with | 1182 -> false // chkUnusedValue - off by default @@ -404,15 +408,15 @@ let SplitRelatedErrors(err:PhasedError) = | ConstraintSolverRelatedInformation(fopt,m2,e) -> let e,related = SplitRelatedException e ConstraintSolverRelatedInformation(fopt,m2,e.Exception)|>ToPhased, related - | ErrorFromAddingTypeEquation(g,denv,t1,t2,e,m) -> + | ErrorFromAddingTypeEquation(g,denv,t1,t2,e,specializedMessageF,m) -> let e,related = SplitRelatedException e - ErrorFromAddingTypeEquation(g,denv,t1,t2,e.Exception,m)|>ToPhased, related + ErrorFromAddingTypeEquation(g,denv,t1,t2,e.Exception,specializedMessageF,m)|>ToPhased, related | ErrorFromApplyingDefault(g,denv,tp,defaultType,e,m) -> let e,related = SplitRelatedException e ErrorFromApplyingDefault(g,denv,tp,defaultType,e.Exception,m)|>ToPhased, related - | ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e,m) -> + | ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e,contextInfo,m) -> let e,related = SplitRelatedException e - ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e.Exception,m)|>ToPhased, related + ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e.Exception,contextInfo,m)|>ToPhased, related | ErrorFromAddingConstraint(x,e,m) -> let e,related = SplitRelatedException e ErrorFromAddingConstraint(x,e.Exception,m)|>ToPhased, related @@ -527,7 +531,7 @@ let UseOfAddressOfOperatorE() = DeclareResourceString("UseOfAddressOfOperator"," let DefensiveCopyWarningE() = DeclareResourceString("DefensiveCopyWarning","%s") let DeprecatedThreadStaticBindingWarningE() = DeclareResourceString("DeprecatedThreadStaticBindingWarning","") let FunctionValueUnexpectedE() = DeclareResourceString("FunctionValueUnexpected","%s") -let UnitTypeExpected1E() = DeclareResourceString("UnitTypeExpected1","%s") +let UnitTypeExpected1E() = DeclareResourceString("UnitTypeExpected1","") let UnitTypeExpected2E() = DeclareResourceString("UnitTypeExpected2","%s") let RecursiveUseCheckedAtRuntimeE() = DeclareResourceString("RecursiveUseCheckedAtRuntime","") let LetRecUnsound1E() = DeclareResourceString("LetRecUnsound1","%s") @@ -551,7 +555,7 @@ let MatchIncomplete2E() = DeclareResourceString("MatchIncomplete2","%s") let MatchIncomplete3E() = DeclareResourceString("MatchIncomplete3","%s") let MatchIncomplete4E() = DeclareResourceString("MatchIncomplete4","") let RuleNeverMatchedE() = DeclareResourceString("RuleNeverMatched","") -let ValNotMutableE() = DeclareResourceString("ValNotMutable","") +let ValNotMutableE() = DeclareResourceString("ValNotMutable","%s") let ValNotLocalE() = DeclareResourceString("ValNotLocal","") let Obsolete1E() = DeclareResourceString("Obsolete1","") let Obsolete2E() = DeclareResourceString("Obsolete2","%s") @@ -598,10 +602,18 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = os.Append(ConstraintSolverTupleDiffLengthsE().Format tl1.Length tl2.Length) |> ignore (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore) - | ConstraintSolverInfiniteTypes(denv,t1,t2,m,m2) -> - // REVIEW: consider if we need to show _cxs (the type parameter constrants) + | ConstraintSolverInfiniteTypes(contextInfo,denv,t1,t2,m,m2) -> + // REVIEW: consider if we need to show _cxs (the type parameter constraints) let t1, t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 os.Append(ConstraintSolverInfiniteTypesE().Format t1 t2) |> ignore + + match contextInfo with + | ContextInfo.ReturnInComputationExpression -> + os.Append(" " + FSComp.SR.returnUsedInsteadOfReturnBang()) |> ignore + | ContextInfo.YieldInComputationExpression -> + os.Append(" " + FSComp.SR.yieldUsedInsteadOfYieldBang()) |> ignore + | _ -> () + (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore ) | ConstraintSolverMissingConstraint(denv,tpr,tpc,m,m2) -> @@ -609,9 +621,9 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore ) | ConstraintSolverTypesNotInEqualityRelation(denv,(TType_measure _ as t1),(TType_measure _ as t2),m,m2) -> - // REVIEW: consider if we need to show _cxs (the type parameter constrants) + // REVIEW: consider if we need to show _cxs (the type parameter constraints) let t1, t2, _cxs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 - os.Append(ConstraintSolverTypesNotInEqualityRelation1E().Format t1 t2) |> ignore + os.Append(ConstraintSolverTypesNotInEqualityRelation1E().Format t1 t2 ) |> ignore (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore) | ConstraintSolverTypesNotInEqualityRelation(denv,t1,t2,m,m2) -> @@ -621,7 +633,7 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = (if m.StartLine <> m2.StartLine then os.Append(SeeAlsoE().Format (stringOfRange m)) |> ignore) | ConstraintSolverTypesNotInSubsumptionRelation(denv,t1,t2,m,m2) -> - // REVIEW: consider if we need to show _cxs (the type parameter constrants) + // REVIEW: consider if we need to show _cxs (the type parameter constraints) let t1, t2, cxs= NicePrint.minimalStringsOfTwoTypes denv t1 t2 os.Append(ConstraintSolverTypesNotInSubsumptionRelationE().Format t2 t1 cxs) |> ignore (if m.StartLine <> m2.StartLine then @@ -635,14 +647,23 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = | ConstraintSolverError _ -> OutputExceptionR os e | _ -> () fopt |> Option.iter (Printf.bprintf os " %s") - | ErrorFromAddingTypeEquation(g,denv,t1,t2,ConstraintSolverTypesNotInEqualityRelation(_, t1', t2',_ ,_ ),_) + | ErrorFromAddingTypeEquation(g,denv,t1,t2,ConstraintSolverTypesNotInEqualityRelation(_, t1', t2',_ ,_ ),contextInfo,_) when typeEquiv g t1 t1' - && typeEquiv g t2 t2' -> + && typeEquiv g t2 t2' -> let t1,t2,tpcs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 - os.Append(ErrorFromAddingTypeEquation1E().Format t2 t1 tpcs) |> ignore - | ErrorFromAddingTypeEquation(_,_,_,_,((ConstraintSolverTypesNotInSubsumptionRelation _ | ConstraintSolverError _) as e),_) -> + match contextInfo with + | ContextInfo.OmittedElseBranch -> os.Append(FSComp.SR.missingElseBranch(t2)) |> ignore + | ContextInfo.ElseBranch -> os.Append(FSComp.SR.elseBranchHasWrongType(t1,t2)) |> ignore + | ContextInfo.TupleInRecordFields -> + os.Append(ErrorFromAddingTypeEquation1E().Format t2 t1 tpcs) |> ignore + os.Append(System.Environment.NewLine + FSComp.SR.commaInsteadOfSemicolonInRecord()) |> ignore + | _ when t2 = "bool" && t1.EndsWith " ref" -> + os.Append(ErrorFromAddingTypeEquation1E().Format t2 t1 tpcs) |> ignore + os.Append(System.Environment.NewLine + FSComp.SR.derefInsteadOfNot()) |> ignore + | _ -> os.Append(ErrorFromAddingTypeEquation1E().Format t2 t1 tpcs) |> ignore + | ErrorFromAddingTypeEquation(_,_,_,_,((ConstraintSolverTypesNotInSubsumptionRelation _ | ConstraintSolverError _) as e), _, _) -> OutputExceptionR os e - | ErrorFromAddingTypeEquation(g,denv,t1,t2,e,_) -> + | ErrorFromAddingTypeEquation(g,denv,t1,t2,e,_,_) -> if not (typeEquiv g t1 t2) then ( let t1,t2,tpcs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 if t1<>t2 + tpcs then os.Append(ErrorFromAddingTypeEquation2E().Format t1 t2 tpcs) |> ignore @@ -653,13 +674,23 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = os.Append(ErrorFromApplyingDefault1E().Format defaultType) |> ignore OutputExceptionR os e os.Append(ErrorFromApplyingDefault2E().Format) |> ignore - | ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e,_) -> - if not (typeEquiv g t1 t2) then ( - let t1,t2,tpcs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 - if t1 <> (t2 + tpcs) then - os.Append(ErrorsFromAddingSubsumptionConstraintE().Format t2 t1 tpcs) |> ignore - ) - OutputExceptionR os e + | ErrorsFromAddingSubsumptionConstraint(g,denv,t1,t2,e,contextInfo,_) -> + match contextInfo with + | ContextInfo.DowncastUsedInsteadOfUpcast isOperator -> + let t1,t2,_ = NicePrint.minimalStringsOfTwoTypes denv t1 t2 + if isOperator then + os.Append(FSComp.SR.considerUpcastOperator(t1,t2) |> snd) |> ignore + else + os.Append(FSComp.SR.considerUpcast(t1,t2) |> snd) |> ignore + | _ -> + if not (typeEquiv g t1 t2) then + let t1,t2,tpcs = NicePrint.minimalStringsOfTwoTypes denv t1 t2 + if t1 <> (t2 + tpcs) then + os.Append(ErrorsFromAddingSubsumptionConstraintE().Format t2 t1 tpcs) |> ignore + else + OutputExceptionR os e + else + OutputExceptionR os e | UpperCaseIdentifierInPattern(_) -> os.Append(UpperCaseIdentifierInPatternE().Format) |> ignore | NotUpperCaseConstructor(_) -> @@ -722,8 +753,12 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = os.Append(Duplicate1E().Format (DecompileOpName s)) |> ignore else os.Append(Duplicate2E().Format k (DecompileOpName s)) |> ignore - | UndefinedName(_,k,id,_) -> + | UndefinedName(_,k,id,predictions) -> os.Append(k (DecompileOpName id.idText)) |> ignore + if Set.isEmpty predictions |> not then + let filtered = ErrorResolutionHints.FilterPredictions id.idText predictions + os.Append(ErrorResolutionHints.FormatPredictions filtered) |> ignore + | InternalUndefinedItemRef(f,smr,ccuName,s) -> let _, errs = f(smr, ccuName, s) os.Append(errs) |> ignore @@ -1150,7 +1185,7 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = if perhapsProp then os.Append(UnitTypeExpected2E().Format (NicePrint.stringOfTy denv ty)) |> ignore else - os.Append(UnitTypeExpected1E().Format (NicePrint.stringOfTy denv ty)) |> ignore + os.Append(UnitTypeExpected1E().Format) |> ignore | RecursiveUseCheckedAtRuntime _ -> os.Append(RecursiveUseCheckedAtRuntimeE().Format) |> ignore | LetRecUnsound (_,[v],_) -> @@ -1209,7 +1244,7 @@ let OutputPhasedErrorR (os:System.Text.StringBuilder) (err:PhasedError) = if isComp then os.Append(MatchIncomplete4E().Format) |> ignore | PatternMatchCompilation.RuleNeverMatched _ -> os.Append(RuleNeverMatchedE().Format) |> ignore - | ValNotMutable _ -> os.Append(ValNotMutableE().Format) |> ignore + | ValNotMutable(_,valRef,_) -> os.Append(ValNotMutableE().Format(valRef.DisplayName)) |> ignore | ValNotLocal _ -> os.Append(ValNotLocalE().Format) |> ignore | ObsoleteError (s, _) | ObsoleteWarning (s, _) -> @@ -2358,7 +2393,7 @@ type TcConfigBuilder = if not exists then warning(Error(FSComp.SR.buildSearchDirectoryNotFound(absolutePath),m)); exists | None -> false - if ok && not (List.mem absolutePath tcConfigB.includes) then + if ok && not (List.contains absolutePath tcConfigB.includes) then tcConfigB.includes <- tcConfigB.includes ++ absolutePath member tcConfigB.AddLoadedSource(m,path,pathLoadedFrom) = @@ -2371,7 +2406,7 @@ type TcConfigBuilder = | None -> // File doesn't exist in the paths. Assume it will be in the load-ed from directory. ComputeMakePathAbsolute pathLoadedFrom path - if not (List.mem path (List.map snd tcConfigB.loadedSources)) then + if not (List.contains path (List.map snd tcConfigB.loadedSources)) then tcConfigB.loadedSources <- tcConfigB.loadedSources ++ (m,path) @@ -2772,7 +2807,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = member tcConfig.ComputeCanContainEntryPoint(sourceFiles:string list) = let n = sourceFiles.Length in - sourceFiles |> List.mapi (fun i _ -> (i = n-1) && tcConfig.target.IsExe) + (sourceFiles |> List.mapi (fun i _ -> (i = n-1)), tcConfig.target.IsExe) // This call can fail if no CLR is found (this is the path to mscorlib) member tcConfig.ClrRoot = @@ -2820,8 +2855,7 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = |> List.map resolveLoadedSource |> List.filter Option.isSome |> List.map Option.get - |> Seq.distinct - |> Seq.toList + |> List.distinct /// A closed set of assemblies where, for any subset S: /// - the TcImports object built for S (and thus the F# Compiler CCUs for the assemblies in S) @@ -3106,13 +3140,13 @@ type TcConfig private (data : TcConfigBuilder,validate:bool) = let ReportWarning (globalWarnLevel : int, specificWarnOff : int list, specificWarnOn : int list) err = let n = GetErrorNumber err - warningOn err globalWarnLevel specificWarnOn && not (List.mem n specificWarnOff) + warningOn err globalWarnLevel specificWarnOn && not (List.contains n specificWarnOff) let ReportWarningAsError (globalWarnLevel : int, specificWarnOff : int list, specificWarnOn : int list, specificWarnAsError : int list, specificWarnAsWarn : int list, globalWarnAsError : bool) err = warningOn err globalWarnLevel specificWarnOn && - not (List.mem (GetErrorNumber err) specificWarnAsWarn) && - ((globalWarnAsError && not (List.mem (GetErrorNumber err) specificWarnOff)) || - List.mem (GetErrorNumber err) specificWarnAsError) + not (List.contains (GetErrorNumber err) specificWarnAsWarn) && + ((globalWarnAsError && not (List.contains (GetErrorNumber err) specificWarnOff)) || + List.contains (GetErrorNumber err) specificWarnAsError) //---------------------------------------------------------------------------- // Scoped #nowarn pragmas @@ -3207,17 +3241,17 @@ let ComputeQualifiedNameOfFileFromUniquePath (m, p: string list) = QualifiedName let QualFileNameOfSpecs filename specs = match specs with - | [SynModuleOrNamespaceSig(modname,true,_,_,_,_,m)] -> QualFileNameOfModuleName m filename modname + | [SynModuleOrNamespaceSig(modname,_,true,_,_,_,_,m)] -> QualFileNameOfModuleName m filename modname | _ -> QualFileNameOfFilename (rangeN filename 1) filename let QualFileNameOfImpls filename specs = match specs with - | [SynModuleOrNamespace(modname,true,_,_,_,_,m)] -> QualFileNameOfModuleName m filename modname + | [SynModuleOrNamespace(modname,_,true,_,_,_,_,m)] -> QualFileNameOfModuleName m filename modname | _ -> QualFileNameOfFilename (rangeN filename 1) filename let PrepandPathToQualFileName x (QualifiedNameOfFile(q)) = ComputeQualifiedNameOfFileFromUniquePath (q.idRange,pathOfLid x@[q.idText]) -let PrepandPathToImpl x (SynModuleOrNamespace(p,c,d,e,f,g,h)) = SynModuleOrNamespace(x@p,c,d,e,f,g,h) -let PrepandPathToSpec x (SynModuleOrNamespaceSig(p,c,d,e,f,g,h)) = SynModuleOrNamespaceSig(x@p,c,d,e,f,g,h) +let PrepandPathToImpl x (SynModuleOrNamespace(p,b,c,d,e,f,g,h)) = SynModuleOrNamespace(x@p,b,c,d,e,f,g,h) +let PrepandPathToSpec x (SynModuleOrNamespaceSig(p,b,c,d,e,f,g,h)) = SynModuleOrNamespaceSig(x@p,b,c,d,e,f,g,h) let PrependPathToInput x inp = match inp with @@ -3241,54 +3275,64 @@ let ComputeAnonModuleName check defaultNamespace filename (m: range) = let PostParseModuleImpl (_i,defaultNamespace,isLastCompiland,filename,impl) = match impl with - | ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,isModule,decls,xmlDoc,attribs,access,m)) -> + | ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,isRec,isModule,decls,xmlDoc,attribs,access,m)) -> let lid = match lid with | [id] when isModule && id.idText = MangledGlobalName -> error(Error(FSComp.SR.buildInvalidModuleOrNamespaceName(),id.idRange)) | id :: rest when id.idText = MangledGlobalName -> rest | _ -> lid - SynModuleOrNamespace(lid,isModule,decls,xmlDoc,attribs,access,m) + SynModuleOrNamespace(lid,isRec,isModule,decls,xmlDoc,attribs,access,m) | ParsedImplFileFragment.AnonModule (defs,m)-> - if not isLastCompiland && not (doNotRequireNamespaceOrModuleSuffixes |> List.exists (Filename.checkSuffix (String.lowercase filename))) then - errorR(Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule(),trimRangeToLine m)) + let isLast, isExe = isLastCompiland + let lower = String.lowercase filename + if not (isLast && isExe) && not (doNotRequireNamespaceOrModuleSuffixes |> List.exists (Filename.checkSuffix lower)) then + match defs with + | SynModuleDecl.NestedModule(_) :: _ -> errorR(Error(FSComp.SR.noEqualSignAfterModule(),trimRangeToLine m)) + | _ -> errorR(Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule(),trimRangeToLine m)) + let modname = ComputeAnonModuleName (nonNil defs) defaultNamespace filename (trimRangeToLine m) - SynModuleOrNamespace(modname,true,defs,PreXmlDoc.Empty,[],None,m) + SynModuleOrNamespace(modname,false,true,defs,PreXmlDoc.Empty,[],None,m) - | ParsedImplFileFragment.NamespaceFragment (lid,b,c,d,e,m)-> + | ParsedImplFileFragment.NamespaceFragment (lid,a,b,c,d,e,m)-> let lid = match lid with | id :: rest when id.idText = MangledGlobalName -> rest | _ -> lid - SynModuleOrNamespace(lid,b,c,d,e,None,m) + SynModuleOrNamespace(lid,a,b,c,d,e,None,m) let PostParseModuleSpec (_i,defaultNamespace,isLastCompiland,filename,intf) = match intf with - | ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,isModule,decls,xmlDoc,attribs,access,m)) -> + | ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,isRec,isModule,decls,xmlDoc,attribs,access,m)) -> let lid = match lid with | [id] when isModule && id.idText = MangledGlobalName -> error(Error(FSComp.SR.buildInvalidModuleOrNamespaceName(),id.idRange)) | id :: rest when id.idText = MangledGlobalName -> rest | _ -> lid - SynModuleOrNamespaceSig(lid,isModule,decls,xmlDoc,attribs,access,m) + SynModuleOrNamespaceSig(lid,isRec,isModule,decls,xmlDoc,attribs,access,m) | ParsedSigFileFragment.AnonModule (defs,m) -> - if not isLastCompiland && not (doNotRequireNamespaceOrModuleSuffixes |> List.exists (Filename.checkSuffix (String.lowercase filename))) then - errorR(Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule(),m)) + let isLast, isExe = isLastCompiland + let lower = String.lowercase filename + if not (isLast && isExe) && not (doNotRequireNamespaceOrModuleSuffixes |> List.exists (Filename.checkSuffix lower)) then + match defs with + | SynModuleSigDecl.NestedModule(_) :: _ -> errorR(Error(FSComp.SR.noEqualSignAfterModule(),m)) + | _ -> errorR(Error(FSComp.SR.buildMultiFileRequiresNamespaceOrModule(),m)) + let modname = ComputeAnonModuleName (nonNil defs) defaultNamespace filename (trimRangeToLine m) - SynModuleOrNamespaceSig(modname,true,defs,PreXmlDoc.Empty,[],None,m) + SynModuleOrNamespaceSig(modname,false,true,defs,PreXmlDoc.Empty,[],None,m) - | ParsedSigFileFragment.NamespaceFragment (lid,b,c,d,e,m)-> + | ParsedSigFileFragment.NamespaceFragment (lid,a,b,c,d,e,m)-> let lid = match lid with | id :: rest when id.idText = MangledGlobalName -> rest | _ -> lid - SynModuleOrNamespaceSig(lid,b,c,d,e,None,m) + SynModuleOrNamespaceSig(lid,a,b,c,d,e,None,m) let PostParseModuleImpls (defaultNamespace,filename,isLastCompiland,ParsedImplFile(hashDirectives,impls)) = - match impls |> List.rev |> List.tryPick (function ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,_,_,_,_,_,_)) -> Some(lid) | _ -> None) with + match impls |> List.rev |> List.tryPick (function ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,_,_,_,_,_,_,_)) -> Some(lid) | _ -> None) with | Some lid when impls.Length > 1 -> errorR(Error(FSComp.SR.buildMultipleToplevelModules(),rangeOfLid lid)) | _ -> @@ -3298,7 +3342,7 @@ let PostParseModuleImpls (defaultNamespace,filename,isLastCompiland,ParsedImplFi let isScript = IsScript filename let scopedPragmas = - [ for (SynModuleOrNamespace(_,_,decls,_,_,_,_)) in impls do + [ for (SynModuleOrNamespace(_,_,_,decls,_,_,_,_)) in impls do for d in decls do match d with | SynModuleDecl.HashDirective (hd,_) -> yield! GetScopedPragmasForHashDirective hd @@ -3308,7 +3352,7 @@ let PostParseModuleImpls (defaultNamespace,filename,isLastCompiland,ParsedImplFi ParsedInput.ImplFile(ParsedImplFileInput(filename,isScript,qualName,scopedPragmas,hashDirectives,impls,isLastCompiland)) let PostParseModuleSpecs (defaultNamespace,filename,isLastCompiland,ParsedSigFile(hashDirectives,specs)) = - match specs |> List.rev |> List.tryPick (function ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,_,_,_,_,_,_)) -> Some(lid) | _ -> None) with + match specs |> List.rev |> List.tryPick (function ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,_,_,_,_,_,_,_)) -> Some(lid) | _ -> None) with | Some lid when specs.Length > 1 -> errorR(Error(FSComp.SR.buildMultipleToplevelModules(),rangeOfLid lid)) | _ -> @@ -3317,7 +3361,7 @@ let PostParseModuleSpecs (defaultNamespace,filename,isLastCompiland,ParsedSigFil let specs = specs |> List.mapi (fun i x -> PostParseModuleSpec(i,defaultNamespace,isLastCompiland,filename,x)) let qualName = QualFileNameOfSpecs filename specs let scopedPragmas = - [ for (SynModuleOrNamespaceSig(_,_,decls,_,_,_,_)) in specs do + [ for (SynModuleOrNamespaceSig(_,_,_,decls,_,_,_,_)) in specs do for d in decls do match d with | SynModuleSigDecl.HashDirective(hd,_) -> yield! GetScopedPragmasForHashDirective hd @@ -3396,12 +3440,12 @@ let ParseOneInputLexbuf (tcConfig:TcConfig,lexResourceManager,conditionalCompila if tcConfig.reportNumDecls then let rec flattenSpecs specs = - specs |> List.collect (function (SynModuleSigDecl.NestedModule (_,subDecls,_)) -> flattenSpecs subDecls | spec -> [spec]) + specs |> List.collect (function (SynModuleSigDecl.NestedModule (_,_,subDecls,_)) -> flattenSpecs subDecls | spec -> [spec]) let rec flattenDefns specs = - specs |> List.collect (function (SynModuleDecl.NestedModule (_,subDecls,_,_)) -> flattenDefns subDecls | defn -> [defn]) + specs |> List.collect (function (SynModuleDecl.NestedModule (_,_,subDecls,_,_)) -> flattenDefns subDecls | defn -> [defn]) - let flattenModSpec (SynModuleOrNamespaceSig(_,_,decls,_,_,_,_)) = flattenSpecs decls - let flattenModImpl (SynModuleOrNamespace(_,_,decls,_,_,_,_)) = flattenDefns decls + let flattenModSpec (SynModuleOrNamespaceSig(_,_,_,decls,_,_,_,_)) = flattenSpecs decls + let flattenModImpl (SynModuleOrNamespace(_,_,_,decls,_,_,_,_)) = flattenDefns decls match res with | ParsedInput.SigFile(ParsedSigFileInput(_,_,_,_,specs)) -> dprintf "parsing yielded %d specs" (List.collect flattenModSpec specs).Length @@ -4644,7 +4688,7 @@ let RequireDLL (tcImports:TcImports, tcEnv, thisAssemblyName, m, file) = let g = tcImports.GetTcGlobals() let amap = tcImports.GetImportMap() - let tcEnv = (tcEnv, asms) ||> List.fold (fun tcEnv asm -> Tc.AddCcuToTcEnv(g,amap,m,tcEnv,thisAssemblyName,asm.FSharpViewOfMetadata,asm.AssemblyAutoOpenAttributes,asm.AssemblyInternalsVisibleToAttributes)) + let tcEnv = (tcEnv, asms) ||> List.fold (fun tcEnv asm -> AddCcuToTcEnv(g,amap,m,tcEnv,thisAssemblyName,asm.FSharpViewOfMetadata,asm.AssemblyAutoOpenAttributes,asm.AssemblyInternalsVisibleToAttributes)) tcEnv,(dllinfos,asms) @@ -4724,30 +4768,30 @@ let ProcessMetaCommandsFromInput decls |> List.iter (fun d -> match d with | SynModuleSigDecl.HashDirective (_,m) -> warning(Error(FSComp.SR.buildDirectivesInModulesAreIgnored(),m)) - | SynModuleSigDecl.NestedModule (_,subDecls,_) -> WarnOnIgnoredSpecDecls subDecls + | SynModuleSigDecl.NestedModule (_,_,subDecls,_) -> WarnOnIgnoredSpecDecls subDecls | _ -> ()) let rec WarnOnIgnoredImplDecls decls = decls |> List.iter (fun d -> match d with | SynModuleDecl.HashDirective (_,m) -> warning(Error(FSComp.SR.buildDirectivesInModulesAreIgnored(),m)) - | SynModuleDecl.NestedModule (_,subDecls,_,_) -> WarnOnIgnoredImplDecls subDecls + | SynModuleDecl.NestedModule (_,_,subDecls,_,_) -> WarnOnIgnoredImplDecls subDecls | _ -> ()) - let ProcessMetaCommandsFromModuleSpec state (SynModuleOrNamespaceSig(_,_,decls,_,_,_,_)) = + let ProcessMetaCommandsFromModuleSpec state (SynModuleOrNamespaceSig(_,_,_,decls,_,_,_,_)) = List.fold (fun s d -> match d with | SynModuleSigDecl.HashDirective (h,_) -> ProcessMetaCommand s h - | SynModuleSigDecl.NestedModule (_,subDecls,_) -> WarnOnIgnoredSpecDecls subDecls; s + | SynModuleSigDecl.NestedModule (_,_,subDecls,_) -> WarnOnIgnoredSpecDecls subDecls; s | _ -> s) state decls - let ProcessMetaCommandsFromModuleImpl state (SynModuleOrNamespace(_,_,decls,_,_,_,_)) = + let ProcessMetaCommandsFromModuleImpl state (SynModuleOrNamespace(_,_,_,decls,_,_,_,_)) = List.fold (fun s d -> match d with | SynModuleDecl.HashDirective (h,_) -> ProcessMetaCommand s h - | SynModuleDecl.NestedModule (_,subDecls,_,_) -> WarnOnIgnoredImplDecls subDecls; s + | SynModuleDecl.NestedModule (_,_,subDecls,_,_) -> WarnOnIgnoredImplDecls subDecls; s | _ -> s) state decls @@ -4846,7 +4890,7 @@ module private ScriptPreprocessClosure = | CodeContext.Editing -> "EDITING" :: (if IsScript filename then ["INTERACTIVE"] else ["COMPILED"]) let lexbuf = UnicodeLexing.StringAsLexbuf source - let isLastCompiland = IsScript filename // The root compiland is last in the list of compilands. + let isLastCompiland = (IsScript filename), tcConfig.target.IsExe // The root compiland is last in the list of compilands. ParseOneInputLexbuf (tcConfig,lexResourceManager,defines,lexbuf,filename,isLastCompiland,errorLogger) /// Create a TcConfig for load closure starting from a single .fsx file @@ -4953,13 +4997,13 @@ module private ScriptPreprocessClosure = closureDirectives |> List.map FindClosure |> List.concat, !tcConfig /// Reduce the full directive closure into LoadClosure - let GetLoadClosure(rootFilename,closureDirectives,tcConfig,codeContext) = + let GetLoadClosure(rootFilename,closureDirectives,(tcConfig:TcConfig),codeContext) = // Mark the last file as isLastCompiland. closureDirectives is currently reversed. let closureDirectives = match closureDirectives with | ClosedSourceFile(filename,m,Some(ParsedInput.ImplFile(ParsedImplFileInput(name,isScript,qualNameOfFile,scopedPragmas,hashDirectives,implFileFlags,_))),errs,warns,nowarns)::rest -> - ClosedSourceFile(filename,m,Some(ParsedInput.ImplFile(ParsedImplFileInput(name,isScript,qualNameOfFile,scopedPragmas,hashDirectives,implFileFlags,true))),errs,warns,nowarns)::rest + ClosedSourceFile(filename,m,Some(ParsedInput.ImplFile(ParsedImplFileInput(name,isScript,qualNameOfFile,scopedPragmas,hashDirectives,implFileFlags,(true, tcConfig.target.IsExe)))),errs,warns,nowarns)::rest | x -> x // Get all source files. @@ -5073,11 +5117,11 @@ let GetInitialTcEnv (thisAssemblyName:string, initm:range, tcConfig:TcConfig, tc let amap = tcImports.GetImportMap() - let tcEnv = Tc.CreateInitialTcEnv(tcGlobals, amap, initm, thisAssemblyName, ccus) + let tcEnv = CreateInitialTcEnv(tcGlobals, amap, initm, thisAssemblyName, ccus) let tcEnv = if tcConfig.checkOverflow then - Tc.TcOpenDecl TcResultsSink.NoSink tcGlobals amap initm initm tcEnv (pathToSynLid initm (splitNamespace FSharpLib.CoreOperatorsCheckedName)) + TcOpenDecl TcResultsSink.NoSink tcGlobals amap initm initm tcEnv (pathToSynLid initm (splitNamespace FSharpLib.CoreOperatorsCheckedName)) else tcEnv tcEnv @@ -5205,7 +5249,7 @@ let TypeCheckOneInputEventually // Typecheck the signature file let! (tcEnvAtEnd,tcEnv,smodulTypeRoot) = - Tc.TypeCheckOneSigFile (tcGlobals,tcState.tcsNiceNameGen,amap,tcState.tcsCcu,checkForErrors,tcConfig.conditionalCompilationDefines,tcSink) tcState.tcsTcSigEnv file + TypeCheckOneSigFile (tcGlobals,tcState.tcsNiceNameGen,amap,tcState.tcsCcu,checkForErrors,tcConfig.conditionalCompilationDefines,tcSink) tcState.tcsTcSigEnv file let rootSigs = Zmap.add qualNameOfFile smodulTypeRoot rootSigs @@ -5235,7 +5279,7 @@ let TypeCheckOneInputEventually // Typecheck the implementation file let! topAttrs,implFile,tcEnvAtEnd = - Tc.TypeCheckOneImplFile (tcGlobals,tcState.tcsNiceNameGen,amap,tcState.tcsCcu,checkForErrors,tcConfig.conditionalCompilationDefines,tcSink) tcImplEnv rootSigOpt file + TypeCheckOneImplFile (tcGlobals,tcState.tcsNiceNameGen,amap,tcState.tcsCcu,checkForErrors,tcConfig.conditionalCompilationDefines,tcSink) tcImplEnv rootSigOpt file let hadSig = isSome rootSigOpt let implFileSigType = SigTypeOfImplFile implFile @@ -5247,12 +5291,12 @@ let TypeCheckOneInputEventually let m = qualNameOfFile.Range // Add the implementation as to the implementation env - let tcImplEnv = Tc.AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcImplEnv implFileSigType + let tcImplEnv = AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcImplEnv implFileSigType // Add the implementation as to the signature env (unless it had an explicit signature) let tcSigEnv = if hadSig then tcState.tcsTcSigEnv - else Tc.AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcState.tcsTcSigEnv implFileSigType + else AddLocalRootModuleOrNamespace TcResultsSink.NoSink tcGlobals amap m tcState.tcsTcSigEnv implFileSigType // Open the prefixPath for fsi.exe (tcImplEnv) let tcImplEnv = diff --git a/src/fsharp/CompileOps.fsi b/src/fsharp/CompileOps.fsi old mode 100644 new mode 100755 index 165745b0b0..5b4184cea4 --- a/src/fsharp/CompileOps.fsi +++ b/src/fsharp/CompileOps.fsi @@ -69,7 +69,7 @@ val ComputeQualifiedNameOfFileFromUniquePath : range * string list -> Ast.Qualif val PrependPathToInput : Ast.Ident list -> Ast.ParsedInput -> Ast.ParsedInput -val ParseInput : (UnicodeLexing.Lexbuf -> Parser.token) * ErrorLogger * UnicodeLexing.Lexbuf * string option * string * isLastCompiland: bool -> Ast.ParsedInput +val ParseInput : (UnicodeLexing.Lexbuf -> Parser.token) * ErrorLogger * UnicodeLexing.Lexbuf * string option * string * isLastCompiland:(bool * bool) -> Ast.ParsedInput //---------------------------------------------------------------------------- // Error and warnings @@ -519,7 +519,7 @@ type TcConfig = /// Get the loaded sources that exist and issue a warning for the ones that don't member GetAvailableLoadedSources : unit -> (range*string) list - member ComputeCanContainEntryPoint : sourceFiles:string list -> bool list + member ComputeCanContainEntryPoint : sourceFiles:string list -> bool list *bool /// File system query based on TcConfig settings member ResolveSourceFile : range * string * string -> string @@ -689,7 +689,7 @@ val DefaultBasicReferencesForOutOfProjectSources : string list //-------------------------------------------------------------------------- /// Parse one input file -val ParseOneInputFile : TcConfig * Lexhelp.LexResourceManager * string list * string * isLastCompiland: bool * ErrorLogger * (*retryLocked*) bool -> ParsedInput option +val ParseOneInputFile : TcConfig * Lexhelp.LexResourceManager * string list * string * isLastCompiland: (bool * bool) * ErrorLogger * (*retryLocked*) bool -> ParsedInput option //---------------------------------------------------------------------------- // Type checking and querying the type checking state diff --git a/src/fsharp/CompileOptions.fs b/src/fsharp/CompileOptions.fs index de7d14ac5b..11a178d9ce 100755 --- a/src/fsharp/CompileOptions.fs +++ b/src/fsharp/CompileOptions.fs @@ -33,7 +33,7 @@ open Microsoft.FSharp.Compiler.IlxGen #endif #if FX_RESHAPED_REFLECTION - open Microsoft.FSharp.Core.ReflectionAdapters +open Microsoft.FSharp.Core.ReflectionAdapters #endif module Attributes = @@ -891,7 +891,7 @@ let compilingFsLib20Flag (tcConfigB : TcConfigBuilder) = let compilingFsLib40Flag (tcConfigB : TcConfigBuilder) = CompilerOption("compiling-fslib-40", tagNone, OptionUnit (fun () -> tcConfigB.compilingFslib40 <- true; ), Some(InternalCommandLineOption("--compiling-fslib-40", rangeCmdArgs)), None) let mlKeywordsFlag = - CompilerOption("ml-keywords", tagNone, OptionUnit (fun () -> Lexhelp.Keywords.permitFsharpKeywords <- false), Some(DeprecatedCommandLineOptionNoDescription("--ml-keywords", rangeCmdArgs)), None) + CompilerOption("ml-keywords", tagNone, OptionUnit (fun () -> ()), Some(DeprecatedCommandLineOptionNoDescription("--ml-keywords", rangeCmdArgs)), None) let gnuStyleErrorsFlag tcConfigB = CompilerOption("gnu-style-errors", tagNone, OptionUnit (fun () -> tcConfigB.errorStyle <- ErrorStyle.EmacsErrors), Some(DeprecatedCommandLineOptionNoDescription("--gnu-style-errors", rangeCmdArgs)), None) diff --git a/src/fsharp/ConstraintSolver.fs b/src/fsharp/ConstraintSolver.fs index b8c1f83261..c34e18d20c 100755 --- a/src/fsharp/ConstraintSolver.fs +++ b/src/fsharp/ConstraintSolver.fs @@ -32,26 +32,28 @@ module internal Microsoft.FSharp.Compiler.ConstraintSolver open Internal.Utilities open Internal.Utilities.Collections + +open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler - -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open Microsoft.FSharp.Compiler.Range -open Microsoft.FSharp.Compiler.Rational open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.AttributeChecking +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.MethodCalls +open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Rational +open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Tastops.DebugPrint open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.Lib -open Microsoft.FSharp.Compiler.Infos -open Microsoft.FSharp.Compiler.Infos.AccessibilityLogic -open Microsoft.FSharp.Compiler.Infos.AttributeChecking open Microsoft.FSharp.Compiler.TypeRelations -open Microsoft.FSharp.Compiler.PrettyNaming //------------------------------------------------------------------------- // Generate type variables and record them in within the scope of the @@ -113,17 +115,39 @@ let FreshenMethInfo m (minfo:MethInfo) = // Subsumption of types: solve/record subtyping constraints //------------------------------------------------------------------------- +[] +/// Information about the context of a type equation. +type ContextInfo = +/// No context was given. +| NoContext +/// The type equation comes from an omitted else branch. +| OmittedElseBranch +/// The type equation comes from checking an else branch. +| ElseBranch +/// The type equation comes from the verification of record fields. +| RecordFields +/// The type equation comes from the verification of a tuple in record fields. +| TupleInRecordFields +/// The type equation comes from a return in a computation expression. +| ReturnInComputationExpression +/// The type equation comes from a yield in a computation expression. +| YieldInComputationExpression +/// The type equation comes from a runtime type test. +| RuntimeTypeTest of bool +/// The type equation comes from an downcast where a upcast could be used. +| DowncastUsedInsteadOfUpcast of bool + exception ConstraintSolverTupleDiffLengths of DisplayEnv * TType list * TType list * range * range -exception ConstraintSolverInfiniteTypes of DisplayEnv * TType * TType * range * range -exception ConstraintSolverTypesNotInEqualityRelation of DisplayEnv * TType * TType * range * range +exception ConstraintSolverInfiniteTypes of ContextInfo * DisplayEnv * TType * TType * range * range +exception ConstraintSolverTypesNotInEqualityRelation of DisplayEnv * TType * TType * range * range exception ConstraintSolverTypesNotInSubsumptionRelation of DisplayEnv * TType * TType * range * range exception ConstraintSolverMissingConstraint of DisplayEnv * Tast.Typar * Tast.TyparConstraint * range * range exception ConstraintSolverError of string * range * range exception ConstraintSolverRelatedInformation of string option * range * exn exception ErrorFromApplyingDefault of TcGlobals * DisplayEnv * Tast.Typar * TType * exn * range -exception ErrorFromAddingTypeEquation of TcGlobals * DisplayEnv * TType * TType * exn * range -exception ErrorsFromAddingSubsumptionConstraint of TcGlobals * DisplayEnv * TType * TType * exn * range +exception ErrorFromAddingTypeEquation of TcGlobals * DisplayEnv * TType * TType * exn * ContextInfo * range +exception ErrorsFromAddingSubsumptionConstraint of TcGlobals * DisplayEnv * TType * TType * exn * ContextInfo * range exception ErrorFromAddingConstraint of DisplayEnv * exn * range exception PossibleOverload of DisplayEnv * string * exn * range exception UnresolvedOverloading of DisplayEnv * exn list * string * range @@ -157,6 +181,7 @@ type ConstraintSolverState = type ConstraintSolverEnv = { SolverState: ConstraintSolverState; + eContextInfo: ContextInfo MatchingOnly : bool m: range; EquivEnv: TypeEquivEnv; @@ -166,9 +191,10 @@ type ConstraintSolverEnv = member csenv.g = csenv.SolverState.g member csenv.amap = csenv.SolverState.amap -let MakeConstraintSolverEnv css m denv = +let MakeConstraintSolverEnv contextInfo css m denv = { SolverState=css; m=m; + eContextInfo = contextInfo // Indicates that when unifiying ty1 = ty2, only type variables in ty1 may be solved MatchingOnly=false; EquivEnv=TypeEquivEnv.Empty; @@ -628,15 +654,15 @@ let CheckWarnIfRigid (csenv:ConstraintSolverEnv) ty1 (r:Typar) ty = /// Propagate all effects of adding this constraint, e.g. to solve other variables let rec SolveTyparEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 trace ty1 ty = let m = csenv.m - let denv = csenv.DisplayEnv + DepthCheck ndeep m ++ (fun () -> match ty1 with | TType_var r | TType_measure (MeasureVar r) -> // The types may still be equivalent due to abbreviations, which we are trying not to eliminate if typeEquiv csenv.g ty1 ty then CompleteD else - // The famous 'occursCheck' check to catch things like 'a = list<'a> - if occursCheck csenv.g r ty then ErrorD (ConstraintSolverInfiniteTypes(denv,ty1,ty,m,m2)) else + // The famous 'occursCheck' check to catch "infinite types" like 'a = list<'a> - see also https://github.com/Microsoft/visualfsharp/issues/1170 + if occursCheck csenv.g r ty then ErrorD (ConstraintSolverInfiniteTypes(csenv.eContextInfo,csenv.DisplayEnv,ty1,ty,m,m2)) else // Note: warn _and_ continue! CheckWarnIfRigid csenv ty1 r ty ++ (fun () -> @@ -741,12 +767,10 @@ and SolveTypEqualsTyp (csenv:ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace | _ -> localAbortD and SolveTypEqualsTypKeepAbbrevs csenv ndeep m2 trace ty1 ty2 = - let denv = csenv.DisplayEnv - // Back out of expansions of type abbreviations to give improved error messages. // Note: any "normalization" of equations on type variables must respect the trace parameter TryD (fun () -> SolveTypEqualsTyp csenv ndeep m2 trace ty1 ty2) - (function LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInEqualityRelation(denv,ty1,ty2,csenv.m,m2)) + (function LocallyAbortOperationThatLosesAbbrevs -> ErrorD(ConstraintSolverTypesNotInEqualityRelation(csenv.DisplayEnv,ty1,ty2,csenv.m,m2)) | err -> ErrorD err) and SolveTypEqualsTypEqns csenv ndeep m2 trace origl1 origl2 = @@ -1199,12 +1223,12 @@ and SolveMemberConstraint (csenv:ConstraintSolverEnv) permitWeakResolution ndeep let calledMethGroup = minfos // curried members may not be used to satisfy constraints - |> List.filter (fun minfo -> not minfo.IsCurried) - |> List.map (fun minfo -> - let callerArgs = argtys |> List.map (fun argty -> CallerArg(argty,m,false,dummyExpr)) - let minst = FreshenMethInfo m minfo - let objtys = minfo.GetObjArgTypes(amap, m, minst) - CalledMeth(csenv.InfoReader,None,false,FreshenMethInfo,m,AccessibleFromEverywhere,minfo,minst,minst,None,objtys,[(callerArgs,[])],false,false,None)) + |> List.choose (fun minfo -> + if minfo.IsCurried then None else + let callerArgs = argtys |> List.map (fun argty -> CallerArg(argty,m,false,dummyExpr)) + let minst = FreshenMethInfo m minfo + let objtys = minfo.GetObjArgTypes(amap, m, minst) + Some(CalledMeth(csenv.InfoReader,None,false,FreshenMethInfo,m,AccessibleFromEverywhere,minfo,minst,minst,None,objtys,[(callerArgs,[])],false,false,None))) let methOverloadResult,errors = CollectThenUndo (fun trace -> ResolveOverloading csenv (WithTrace(trace)) nm ndeep true (0,0) AccessibleFromEverywhere calledMethGroup false (Some rty)) @@ -1290,7 +1314,7 @@ and MemberConstraintSolutionOfMethInfo css m minfo minst = let minst = [] // GENERIC TYPE PROVIDERS: for generics, we would have an minst here let allArgVars, allArgs = minfo.GetParamTypes(amap, m, minst) |> List.concat |> List.mapi (fun i ty -> mkLocal m ("arg"+string i) ty) |> List.unzip let objArgVars, objArgs = (if minfo.IsInstance then [mkLocal m "this" minfo.EnclosingType] else []) |> List.unzip - let callMethInfoOpt, callExpr,callExprTy = TypeRelations.ProvidedMethodCalls.BuildInvokerExpressionForProvidedMethodCall css.TcVal (g, amap, mi, objArgs, NeverMutates, false, ValUseFlag.NormalValUse, allArgs, m) + let callMethInfoOpt, callExpr,callExprTy = ProvidedMethodCalls.BuildInvokerExpressionForProvidedMethodCall css.TcVal (g, amap, mi, objArgs, NeverMutates, false, ValUseFlag.NormalValUse, allArgs, m) let closedExprSln = ClosedExprSln (mkLambdas m [] (objArgVars@allArgVars) (callExpr, callExprTy) ) // If the call is a simple call to an IL method with all the arguments in the natural order, then revert to use ILMethSln. // This is important for calls to operators on generated provided types. There is an (unchecked) condition @@ -1777,8 +1801,7 @@ and SolveTypRequiresDefaultConstructor (csenv:ConstraintSolverEnv) ndeep m2 trac CompleteD elif GetIntrinsicConstructorInfosOfType csenv.InfoReader m ty - |> List.filter (IsMethInfoAccessible amap m AccessibleFromEverywhere) - |> List.exists (fun x -> x.IsNullary) + |> List.exists (fun x -> IsMethInfoAccessible amap m AccessibleFromEverywhere x && x.IsNullary) then if (isAppTy g ty && HasFSharpAttribute g g.attrib_AbstractClassAttribute (tcrefOfAppTy g ty).Attribs) then ErrorD (ConstraintSolverError(FSComp.SR.csGenericConstructRequiresNonAbstract(NicePrint.minimalStringOfType denv typ),m,m2)) @@ -1849,7 +1872,7 @@ and CanMemberSigsMatchUpToCheck if isArray1DTy g calledArg.CalledArgumentType then let paramArrayElemTy = destArrayTy g calledArg.CalledArgumentType let reflArgInfo = calledArg.ReflArgInfo // propgate the reflected-arg info to each param array argument - calledMeth.ParamArrayCallerArgs |> OptionD (IterateD (fun callerArg -> subsumeArg (CalledArg((0,0),false,NotOptional,false,None,reflArgInfo,paramArrayElemTy)) callerArg)) + calledMeth.ParamArrayCallerArgs |> OptionD (IterateD (fun callerArg -> subsumeArg (CalledArg((0,0),false,NotOptional,NoCallerInfo,false,None,reflArgInfo,paramArrayElemTy)) callerArg)) else CompleteD) @@ -1872,7 +1895,7 @@ and CanMemberSigsMatchUpToCheck let calledArgTy = rfinfo.FieldType rfinfo.Name, calledArgTy - subsumeArg (CalledArg((-1, 0), false, NotOptional, false, Some (mkSynId m name), ReflectedArgInfo.None, calledArgTy)) caller) )) ++ (fun () -> + subsumeArg (CalledArg((-1, 0), false, NotOptional, NoCallerInfo, false, Some (mkSynId m name), ReflectedArgInfo.None, calledArgTy)) caller) )) ++ (fun () -> // - Always take the return type into account for // -- op_Explicit, op_Implicit @@ -1906,13 +1929,20 @@ and private DefinitelyEquiv (csenv:ConstraintSolverEnv) isConstraint calledArg ( // Assert a subtype constraint, and wrap an ErrorsFromAddingSubsumptionConstraint error around any failure // to allow us to report the outer types involved in the constraint -and private SolveTypSubsumesTypWithReport (csenv:ConstraintSolverEnv) ndeep m trace ty1 ty2 = +and private SolveTypSubsumesTypWithReport (csenv:ConstraintSolverEnv) ndeep m trace ty1 ty2 = TryD (fun () -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m trace ty1 ty2) - (fun res -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g,csenv.DisplayEnv,ty1,ty2,res,m))) - -and private SolveTypEqualsTypWithReport (csenv:ConstraintSolverEnv) ndeep m trace ty1 ty2 = + (fun res -> + match csenv.eContextInfo with + | ContextInfo.RuntimeTypeTest isOperator -> + // test if we can cast other way around + match CollectThenUndo (fun newTrace -> SolveTypSubsumesTypKeepAbbrevs csenv ndeep m (OptionalTrace.WithTrace newTrace) ty2 ty1) with + | OkResult _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g,csenv.DisplayEnv,ty1,ty2,res,ContextInfo.DowncastUsedInsteadOfUpcast isOperator,m)) + | _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g,csenv.DisplayEnv,ty1,ty2,res,ContextInfo.NoContext,m)) + | _ -> ErrorD (ErrorsFromAddingSubsumptionConstraint(csenv.g,csenv.DisplayEnv,ty1,ty2,res,csenv.eContextInfo,m))) + +and private SolveTypEqualsTypWithReport contextInfo (csenv:ConstraintSolverEnv) ndeep m trace ty1 ty2 = TryD (fun () -> SolveTypEqualsTypKeepAbbrevs csenv ndeep m trace ty1 ty2) - (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g,csenv.DisplayEnv,ty1,ty2,res,m))) + (fun res -> ErrorD (ErrorFromAddingTypeEquation(csenv.g,csenv.DisplayEnv,ty1,ty2,res,contextInfo,m))) and ArgsMustSubsumeOrConvert (csenv:ConstraintSolverEnv) @@ -1924,7 +1954,7 @@ and ArgsMustSubsumeOrConvert let g = csenv.g let m = callerArg.Range - let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg + let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg SolveTypSubsumesTypWithReport csenv ndeep m trace calledArgTy callerArg.Type ++ (fun () -> if calledArg.IsParamArray && isArray1DTy g calledArgTy && not (isArray1DTy g callerArg.Type) @@ -1934,10 +1964,10 @@ and ArgsMustSubsumeOrConvert CompleteD) and MustUnify csenv ndeep trace ty1 ty2 = - SolveTypEqualsTypWithReport csenv ndeep csenv.m trace ty1 ty2 + SolveTypEqualsTypWithReport ContextInfo.NoContext csenv ndeep csenv.m trace ty1 ty2 and MustUnifyInsideUndo csenv ndeep trace ty1 ty2 = - SolveTypEqualsTypWithReport csenv ndeep csenv.m (WithTrace trace) ty1 ty2 + SolveTypEqualsTypWithReport ContextInfo.NoContext csenv ndeep csenv.m (WithTrace trace) ty1 ty2 and ArgsMustSubsumeOrConvertInsideUndo (csenv:ConstraintSolverEnv) ndeep trace isConstraint calledArg (CallerArg(callerArgTy,m,_,_) as callerArg) = let calledArgTy = AdjustCalledArgType csenv.InfoReader isConstraint calledArg callerArg @@ -2390,8 +2420,8 @@ let EliminateConstraintsForGeneralizedTypars csenv trace (generalizedTypars: Typ // No error recovery here : we do that on a per-expression basis. //------------------------------------------------------------------------- -let AddCxTypeEqualsType denv css m ty1 ty2 = - SolveTypEqualsTypWithReport (MakeConstraintSolverEnv css m denv) 0 m NoTrace ty1 ty2 +let AddCxTypeEqualsType contextInfo denv css m ty1 ty2 = + SolveTypEqualsTypWithReport contextInfo (MakeConstraintSolverEnv contextInfo css m denv) 0 m NoTrace ty1 ty2 |> RaiseOperationResult let UndoIfFailed f = @@ -2408,74 +2438,72 @@ let UndoIfFailed f = ReportWarnings warns; true let AddCxTypeEqualsTypeUndoIfFailed denv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv css m denv) 0 m (WithTrace(trace)) ty1 ty2) + UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace(trace)) ty1 ty2) let AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = - let csenv = MakeConstraintSolverEnv css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv let csenv = { csenv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypEqualsTypKeepAbbrevs csenv 0 m (WithTrace(trace)) ty1 ty2) let AddCxTypeMustSubsumeTypeUndoIfFailed denv css m ty1 ty2 = - UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv css m denv) 0 m (WithTrace(trace)) ty1 ty2) + UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace(trace)) ty1 ty2) let AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed denv css m ty1 ty2 = - let csenv = MakeConstraintSolverEnv css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv let csenv = { csenv with MatchingOnly = true } UndoIfFailed (fun trace -> SolveTypSubsumesTypKeepAbbrevs csenv 0 m (WithTrace(trace)) ty1 ty2) - - -let AddCxTypeMustSubsumeType denv css m trace ty1 ty2 = - SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv css m denv) 0 m trace ty1 ty2 +let AddCxTypeMustSubsumeType contextInfo denv css m trace ty1 ty2 = + SolveTypSubsumesTypWithReport (MakeConstraintSolverEnv contextInfo css m denv) 0 m trace ty1 ty2 |> RaiseOperationResult let AddCxMethodConstraint denv css m trace traitInfo = - TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv css m denv) false 0 m trace traitInfo ++ (fun _ -> CompleteD)) + TryD (fun () -> SolveMemberConstraint (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) false 0 m trace traitInfo ++ (fun _ -> CompleteD)) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeMustSupportNull denv css m trace ty = - TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypSupportsNull (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeMustSupportComparison denv css m trace ty = - TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypeSupportsComparison (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeMustSupportEquality denv css m trace ty = - TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypSupportsEquality (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeMustSupportDefaultCtor denv css m trace ty = - TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypRequiresDefaultConstructor (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeIsReferenceType denv css m trace ty = - TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypIsReferenceType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeIsValueType denv css m trace ty = - TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypIsNonNullableValueType (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeIsUnmanaged denv css m trace ty = - TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv css m denv) 0 m trace ty) + TryD (fun () -> SolveTypIsUnmanaged (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeIsEnum denv css m trace ty underlying = - TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv css m denv) 0 m trace ty underlying) + TryD (fun () -> SolveTypIsEnum (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty underlying) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult let AddCxTypeIsDelegate denv css m trace ty aty bty = - TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv css m denv) 0 m trace ty aty bty) + TryD (fun () -> SolveTypIsDelegate (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m trace ty aty bty) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult @@ -2484,7 +2512,7 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait TcVal = tcVal ExtraCxs=HashMultiMap(10, HashIdentity.Structural) InfoReader=new InfoReader(g,amap) } - let csenv = MakeConstraintSolverEnv css m (DisplayEnv.Empty g) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) SolveMemberConstraint csenv true 0 m NoTrace traitInfo ++ (fun _res -> let sln = match traitInfo.Solution with @@ -2539,7 +2567,7 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait let wrap,h' = mkExprAddrOfExpr g true false PossiblyMutates h None m ResultD (Some (wrap (Expr.Op(TOp.TraitCall(traitInfo), [], (h' :: t), m)))) else - ResultD (Some (Infos.MakeMethInfoCall amap m minfo methArgTys argExprs )) + ResultD (Some (MakeMethInfoCall amap m minfo methArgTys argExprs )) | Choice2Of4 (tinst,rfref,isSet) -> let res = @@ -2547,11 +2575,21 @@ let CodegenWitnessThatTypSupportsTraitConstraint tcVal g amap m (traitInfo:Trait | true, true, 1 -> Some (mkStaticRecdFieldSet (rfref, tinst, argExprs.[0], m)) | true, false, 2 -> - Some (mkRecdFieldSet g (argExprs.[0], rfref, tinst, argExprs.[1], m)) + // If we resolve to an instance field on a struct and we haven't yet taken + // the address of the object then go do that + if rfref.Tycon.IsStructOrEnumTycon && not (isByrefTy g (tyOfExpr g argExprs.[0])) then + let h = List.head argExprs + let wrap,h' = mkExprAddrOfExpr g true false DefinitelyMutates h None m + Some (wrap (mkRecdFieldSetViaExprAddr (h', rfref, tinst, argExprs.[1], m))) + else + Some (mkRecdFieldSetViaExprAddr (argExprs.[0], rfref, tinst, argExprs.[1], m)) | false, true, 0 -> Some (mkStaticRecdFieldGet (rfref, tinst, m)) | false, false, 1 -> - Some (mkRecdFieldGet g (argExprs.[0], rfref, tinst, m)) + if rfref.Tycon.IsStructOrEnumTycon && isByrefTy g (tyOfExpr g argExprs.[0]) then + Some (mkRecdFieldGetViaExprAddr (argExprs.[0], rfref, tinst, m)) + else + Some (mkRecdFieldGet g (argExprs.[0], rfref, tinst, m)) | _ -> None ResultD res | Choice3Of4 expr -> ResultD (Some (MakeApplicationAndBetaReduce g (expr, tyOfExpr g expr, [], argExprs, m))) @@ -2562,7 +2600,7 @@ let ChooseTyparSolutionAndSolve css denv tp = let g = css.g let amap = css.amap let max,m = ChooseTyparSolutionAndRange g amap tp - let csenv = MakeConstraintSolverEnv css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m denv TryD (fun () -> SolveTyparEqualsTyp csenv 0 m NoTrace (mkTyparTy tp) max) (fun err -> ErrorD(ErrorFromApplyingDefault(g,denv,tp,max,err,m))) |> RaiseOperationResult @@ -2572,7 +2610,7 @@ let ChooseTyparSolutionAndSolve css denv tp = let CheckDeclaredTypars denv css m typars1 typars2 = TryD (fun () -> CollectThenUndo (fun trace -> - SolveTypEqualsTypEqns (MakeConstraintSolverEnv css m denv) 0 m (WithTrace(trace)) + SolveTypEqualsTypEqns (MakeConstraintSolverEnv ContextInfo.NoContext css m denv) 0 m (WithTrace(trace)) (List.map mkTyparTy typars1) (List.map mkTyparTy typars2))) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) @@ -2590,7 +2628,7 @@ let IsApplicableMethApprox g amap m (minfo:MethInfo) availObjTy = TcVal = (fun _ -> failwith "should not be called") ExtraCxs=HashMultiMap(10, HashIdentity.Structural) InfoReader=new InfoReader(g,amap) } - let csenv = MakeConstraintSolverEnv css m (DisplayEnv.Empty g) + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext css m (DisplayEnv.Empty g) let minst = FreshenMethInfo m minfo match minfo.GetObjArgTypes(amap, m, minst) with | [reqdObjTy] -> diff --git a/src/fsharp/ConstraintSolver.fsi b/src/fsharp/ConstraintSolver.fsi index 75dda14923..63238ec1c4 100755 --- a/src/fsharp/ConstraintSolver.fsi +++ b/src/fsharp/ConstraintSolver.fsi @@ -9,6 +9,7 @@ open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Tast @@ -18,6 +19,8 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.MethodCalls +open Microsoft.FSharp.Compiler.InfoReader /// Create a type variable representing the use of a "_" in F# code val NewAnonTypar : TyparKind * range * TyparRigidity * TyparStaticReq * TyparDynamicReq -> Typar @@ -44,16 +47,38 @@ val FreshenTypars : range -> Typars -> TType list val FreshenMethInfo : range -> MethInfo -> TType list +[] +/// Information about the context of a type equation. +type ContextInfo = +/// No context was given. +| NoContext +/// The type equation comes from an omitted else branch. +| OmittedElseBranch +/// The type equation comes from checking an else branch. +| ElseBranch +/// The type equation comes from the verification of record fields. +| RecordFields +/// The type equation comes from the verification of a tuple in record fields. +| TupleInRecordFields +/// The type equation comes from a return in a computation expression. +| ReturnInComputationExpression +/// The type equation comes from a yield in a computation expression. +| YieldInComputationExpression +/// The type equation comes from a runtime type test. +| RuntimeTypeTest of bool +/// The type equation comes from an downcast where a upcast could be used. +| DowncastUsedInsteadOfUpcast of bool + exception ConstraintSolverTupleDiffLengths of DisplayEnv * TType list * TType list * range * range -exception ConstraintSolverInfiniteTypes of DisplayEnv * TType * TType * range * range +exception ConstraintSolverInfiniteTypes of ContextInfo * DisplayEnv * TType * TType * range * range exception ConstraintSolverTypesNotInEqualityRelation of DisplayEnv * TType * TType * range * range exception ConstraintSolverTypesNotInSubsumptionRelation of DisplayEnv * TType * TType * range * range exception ConstraintSolverMissingConstraint of DisplayEnv * Typar * TyparConstraint * range * range exception ConstraintSolverError of string * range * range exception ConstraintSolverRelatedInformation of string option * range * exn exception ErrorFromApplyingDefault of TcGlobals * DisplayEnv * Typar * TType * exn * range -exception ErrorFromAddingTypeEquation of TcGlobals * DisplayEnv * TType * TType * exn * range -exception ErrorsFromAddingSubsumptionConstraint of TcGlobals * DisplayEnv * TType * TType * exn * range +exception ErrorFromAddingTypeEquation of TcGlobals * DisplayEnv * TType * TType * exn * ContextInfo * range +exception ErrorsFromAddingSubsumptionConstraint of TcGlobals * DisplayEnv * TType * TType * exn * ContextInfo * range exception ErrorFromAddingConstraint of DisplayEnv * exn * range exception UnresolvedConversionOperator of DisplayEnv * TType * TType * range exception PossibleOverload of DisplayEnv * string * exn * range @@ -71,7 +96,7 @@ type ConstraintSolverEnv val BakedInTraitConstraintNames : string list -val MakeConstraintSolverEnv : ConstraintSolverState -> range -> DisplayEnv -> ConstraintSolverEnv +val MakeConstraintSolverEnv : ContextInfo -> ConstraintSolverState -> range -> DisplayEnv -> ConstraintSolverEnv type Trace = Trace of (unit -> unit) list ref @@ -83,17 +108,17 @@ val SimplifyMeasuresInTypeScheme : TcGlobals -> bool -> Typars -> TT val SolveTyparEqualsTyp : ConstraintSolverEnv -> int -> range -> OptionalTrace -> TType -> TType -> OperationResult val SolveTypEqualsTypKeepAbbrevs : ConstraintSolverEnv -> int -> range -> OptionalTrace -> TType -> TType -> OperationResult val CanonicalizeRelevantMemberConstraints : ConstraintSolverEnv -> int -> OptionalTrace -> Typars -> OperationResult -val ResolveOverloading : ConstraintSolverEnv -> OptionalTrace -> string -> ndeep: int -> bool -> int * int -> AccessorDomain -> TypeRelations.CalledMeth list -> bool -> TType option -> TypeRelations.CalledMeth option * OperationResult -val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> TypeRelations.CalledMeth list -> TType -> OperationResult +val ResolveOverloading : ConstraintSolverEnv -> OptionalTrace -> string -> ndeep: int -> bool -> int * int -> AccessorDomain -> CalledMeth list -> bool -> TType option -> CalledMeth option * OperationResult +val UnifyUniqueOverloading : ConstraintSolverEnv -> int * int -> string -> AccessorDomain -> CalledMeth list -> TType -> OperationResult val EliminateConstraintsForGeneralizedTypars : ConstraintSolverEnv -> OptionalTrace -> Typars -> unit val CheckDeclaredTypars : DisplayEnv -> ConstraintSolverState -> range -> Typars -> Typars -> unit val AddConstraint : ConstraintSolverEnv -> int -> Range.range -> OptionalTrace -> Typar -> TyparConstraint -> OperationResult -val AddCxTypeEqualsType : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit +val AddCxTypeEqualsType : ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> unit val AddCxTypeEqualsTypeUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool val AddCxTypeEqualsTypeMatchingOnlyUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool -val AddCxTypeMustSubsumeType : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit +val AddCxTypeMustSubsumeType : ContextInfo -> DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TType -> TType -> unit val AddCxTypeMustSubsumeTypeUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool val AddCxTypeMustSubsumeTypeMatchingOnlyUndoIfFailed : DisplayEnv -> ConstraintSolverState -> range -> TType -> TType -> bool val AddCxMethodConstraint : DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> TraitConstraintInfo -> unit diff --git a/src/fsharp/DetupleArgs.fs b/src/fsharp/DetupleArgs.fs index c0682f08ba..640459eb3a 100755 --- a/src/fsharp/DetupleArgs.fs +++ b/src/fsharp/DetupleArgs.fs @@ -383,16 +383,16 @@ let rebuildTS g m ts vs = let rec rebuild vs ts = match vs,ts with | [] ,UnknownTS -> internalError "rebuildTS: not enough fringe to build tuple" - | v::vs,UnknownTS -> vs,(exprForVal m v,v.Type) + | v::vs,UnknownTS -> (exprForVal m v,v.Type),vs | vs ,TupleTS tss -> - let vs,xtys = List.foldMap rebuild vs tss + let xtys,vs = List.mapFold rebuild vs tss let xs,tys = List.unzip xtys let x = mkTupled g m xs tys let ty = mkTupledTy g tys - vs,(x,ty) + (x,ty),vs - let vs,(x,_ty) = rebuild vs ts - if vs.Length <> 0 then internalError "rebuildTS: had move fringe vars than fringe. REPORT BUG" else (); + let (x,_ty),vs = rebuild vs ts + if vs.Length <> 0 then internalError "rebuildTS: had more fringe vars than fringe. REPORT BUG" else (); x /// CallPattern is tuple-structure for each argument position. diff --git a/src/fsharp/ErrorLogger.fs b/src/fsharp/ErrorLogger.fs index 7dcb116aa7..ff9fa79d13 100755 --- a/src/fsharp/ErrorLogger.fs +++ b/src/fsharp/ErrorLogger.fs @@ -14,7 +14,7 @@ open System // General error recovery mechanism //----------------------------------------------------------------------- -/// Thrown when want to add some range information to some .NET exception +/// Thrown when we want to add some range information to a .NET exception exception WrappedError of exn * range /// Thrown when immediate, local error recovery is not possible. This indicates @@ -60,7 +60,7 @@ exception Deprecated of string * range exception Experimental of string * range exception PossibleUnverifiableCode of range -// Range\NoRange Duals +// Range/NoRange Duals exception UnresolvedReferenceNoRange of (*assemblyname*) string exception UnresolvedReferenceError of (*assemblyname*) string * range exception UnresolvedPathReferenceNoRange of (*assemblyname*) string * (*path*) string @@ -181,7 +181,7 @@ type PhasedError = { Exception:exn; Phase:BuildPhase } with /// Return true if the textual phase given is from the compile part of the build process. /// This set needs to be equal to the set of subcategories that the language service can produce. static member IsSubcategoryOfCompile(subcategory:string) = - // Beware: This code logic is duplicated in DocumentTask.cs in the language service + // This code logic is duplicated in DocumentTask.cs in the language service. match subcategory with | BuildPhaseSubcategory.Compile | BuildPhaseSubcategory.Parameter @@ -224,7 +224,8 @@ type PhasedError = { Exception:exn; Phase:BuildPhase } with [] type ErrorLogger(nameForDebugging:string) = abstract ErrorCount: int - // the purpose of the 'Impl' factoring is so that you can put a breakpoint on the non-Impl code just below, and get a breakpoint for all implementations of error loggers + // The 'Impl' factoring enables a developer to place a breakpoint at the non-Impl + // code just below and get a breakpoint for all error logger implementations. abstract WarnSinkImpl: PhasedError -> unit abstract ErrorSinkImpl: PhasedError -> unit member this.WarnSink err = @@ -232,7 +233,7 @@ type ErrorLogger(nameForDebugging:string) = member this.ErrorSink err = this.ErrorSinkImpl err member this.DebugDisplay() = sprintf "ErrorLogger(%s)" nameForDebugging - // record the reported error/warning numbers for SQM purpose + // Record the reported error/warning numbers for SQM purpose abstract ErrorNumbers : int list abstract WarningNumbers : int list default this.ErrorNumbers = [] @@ -259,7 +260,7 @@ let AssertFalseErrorLogger = /// When no errorLogger is installed (on the thread) use this one. let uninitializedErrorLoggerFallback = ref AssertFalseErrorLogger -/// Type holds thread-static globals for use by the compile +/// Type holds thread-static globals for use by the compile. type internal CompileThreadStatic = [] static val mutable private buildPhase : BuildPhase @@ -282,8 +283,8 @@ module ErrorLoggerExtensions = open System.Reflection // Instruct the exception not to reset itself when thrown again. - // Why don?t we just not catch these in the first place? Because we made the design choice to ask the user to send mail to fsbugs@microsoft.com. - // To achieve this, we need to catch the exception, report the email address and stack trace, and then reraise. + // Design Note: This enables the compiler to prompt the user to send mail to fsbugs@microsoft.com, + // by catching the exception, prompting and then propagating the exception with reraise. let PreserveStackTrace(exn) = try let preserveStackTrace = typeof.GetMethod("InternalPreserveStackTrace", BindingFlags.Instance ||| BindingFlags.NonPublic) @@ -379,7 +380,7 @@ let SetThreadBuildPhaseNoUnwind(phase:BuildPhase) = CompileThreadStatic.BuildPha let SetThreadErrorLoggerNoUnwind(errorLogger) = CompileThreadStatic.ErrorLogger <- errorLogger let SetUninitializedErrorLoggerFallback errLogger = uninitializedErrorLoggerFallback := errLogger -// Global functions are still used by parser and TAST ops +// Global functions are still used by parser and TAST ops. let errorR exn = CompileThreadStatic.ErrorLogger.ErrorR exn let warning exn = CompileThreadStatic.ErrorLogger.Warning exn let error exn = CompileThreadStatic.ErrorLogger.Error exn diff --git a/src/fsharp/ErrorResolutionHints.fs b/src/fsharp/ErrorResolutionHints.fs new file mode 100644 index 0000000000..28bb2ff2d6 --- /dev/null +++ b/src/fsharp/ErrorResolutionHints.fs @@ -0,0 +1,29 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +/// Functions to format error message details +module internal Microsoft.FSharp.Compiler.ErrorResolutionHints + +/// Filters predictions based on edit distance to an unknown identifier. +let FilterPredictions unknownIdent allPredictions = + let rec take n predictions = + predictions + |> Seq.mapi (fun i x -> i,x) + |> Seq.takeWhile (fun (i,_) -> i < n) + |> Seq.map snd + |> Seq.toList + + allPredictions + |> Seq.toList + |> List.distinct + |> List.sortBy (fun s -> Internal.Utilities.EditDistance.CalcEditDistance(unknownIdent,s)) + |> take 5 + +let FormatPredictions predictions = + match predictions with + | [] -> System.String.Empty + | _ -> + let predictionText = + predictions + |> Seq.map (sprintf "%s %s" System.Environment.NewLine) + |> String.concat "" + System.Environment.NewLine + FSComp.SR.undefinedNameRecordLabelDetails() + predictionText diff --git a/src/fsharp/FSComp.txt b/src/fsharp/FSComp.txt index 7ea419e903..1b213afd72 100755 --- a/src/fsharp/FSComp.txt +++ b/src/fsharp/FSComp.txt @@ -9,18 +9,25 @@ undefinedNameValueOfConstructor,"The value or constructor '%s' is not defined" undefinedNameValueNamespaceTypeOrModule,"The value, namespace, type or module '%s' is not defined" undefinedNameConstructorModuleOrNamespace,"The constructor, module or namespace '%s' is not defined" undefinedNameType,"The type '%s' is not defined" +undefinedNameTypeIn,"The type '%s' is not defined in '%s'." undefinedNameRecordLabelOrNamespace,"The record label or namespace '%s' is not defined" -undefinedNameRecordLabel,"The record label '%s' is not defined" +undefinedNameRecordLabel,"The record label '%s' is not defined." +undefinedNameRecordLabelDetails,"Maybe you want one of the following:" undefinedNameTypeParameter,"The type parameter '%s' is not defined" undefinedNamePatternDiscriminator,"The pattern discriminator '%s' is not defined" +missingElseBranch,"The 'if' expression is missing an 'else' branch. The 'then' branch has type '%s'. Because 'if' is an expression, and not a statement, add an 'else' branch which returns a value of the same type." +elseBranchHasWrongType,"All branches of an 'if' expression must return the same type. This expression was expected to have type '%s' but here has type '%s'." +commaInsteadOfSemicolonInRecord,"A ';' is used to separate field values in records. Consider replacing ',' with ';'." +derefInsteadOfNot,"The '!' operator is used to dereference a ref cell. Consider using 'not expr' here." buildUnexpectedTypeArgs,"The non-generic type '%s' does not expect any type arguments, but here is given %d type argument(s)" +returnUsedInsteadOfReturnBang,"Consider using 'return!' instead of 'return'." +yieldUsedInsteadOfYieldBang,"Consider using 'yield!' instead of 'yield'." 203,buildInvalidWarningNumber,"Invalid warning number '%s'" 204,buildInvalidVersionString,"Invalid version string '%s'" 205,buildInvalidVersionFile,"Invalid version file '%s'" buildProductName,"F# Compiler for F# 4.0 %s" 206,buildProblemWithFilename,"Problem with filename '%s': %s" 207,buildNoInputsSpecified,"No inputs specified" -208,buildMismatchOutputExtension,"The output name extension doesn't match the options used. If '-a' or '--target:library' is used the output file name must end with '.dll', if '--target:module' is used the output extension must be '.netmodule', otherwise '.exe'." 209,buildPdbRequiresDebug,"The '--pdb' option requires the '--debug' option to be used" 210,buildInvalidSearchDirectory,"The search directory '%s' is invalid" 211,buildSearchDirectoryNotFound,"The search directory '%s' could not be found" @@ -36,6 +43,7 @@ buildCouldNotReadVersionInfoFromMscorlib,"Could not read version from mscorlib.d 220,buildAssemblyResolutionFailed,"Assembly resolution failure at or near this location" 221,buildImplicitModuleIsNotLegalIdentifier,"The declarations in this file will be placed in an implicit module '%s' based on the file name '%s'. However this is not a valid F# identifier, so the contents will not be accessible from other files. Consider renaming the file or adding a 'module' or 'namespace' declaration at the top of the file." 222,buildMultiFileRequiresNamespaceOrModule,"Files in libraries or multiple-file applications must begin with a namespace or module declaration, e.g. 'namespace SomeNamespace.SubNamespace' or 'module SomeNamespace.SomeModule'. Only the last source file of an application may omit such a declaration." +222,noEqualSignAfterModule,"Files in libraries or multiple-file applications must begin with a namespace or module declaration. When using a module declaration at the start of a file the '=' sign is not allowed. If this is a top-level module, consider removing the = to resolve this error." 223,buildMultipleToplevelModules,"This file contains multiple declarations of the form 'module SomeNamespace.SomeModule'. Only one declaration of this form is permitted in a file. Change your file to use an initial namespace declaration and/or use 'module ModuleName = ...' to define your modules." 224,buildOptionRequiresParameter,"Option requires parameter: %s" 225,buildCouldNotFindSourceFile,"Source file '%s' could not be found" @@ -214,7 +222,7 @@ forPrecisionMissingAfterDot,"Precision missing after the '.'" forFormatDoesntSupportPrecision,"'%s' format does not support precision" forBadFormatSpecifier,"Bad format specifier (after l or L): Expected ld,li,lo,lu,lx or lX. In F# code you can use %%d, %%x, %%o or %%u instead, which are overloaded to work with all basic integer types." forLIsUnnecessary,"The 'l' or 'L' in this format specifier is unnecessary. In F# code you can use %%d, %%x, %%o or %%u instead, which are overloaded to work with all basic integer types." -forHIsUnnecessary,"The 'h' or 'H' in this format specifier is unnecessary. You can use %%d, %%x, %%o or %%u instead, which are overloaded to work with all basic integer types.." +forHIsUnnecessary,"The 'h' or 'H' in this format specifier is unnecessary. You can use %%d, %%x, %%o or %%u instead, which are overloaded to work with all basic integer types." forDoesNotSupportPrefixFlag,"'%s' does not support prefix '%s' flag" forBadFormatSpecifierGeneral,"Bad format specifier: '%s'" elSysEnvExitDidntExit,"System.Environment.Exit did not exit" @@ -245,7 +253,7 @@ chkVariableUsedInInvalidWay,"The variable '%s' is used in an invalid way" 430,chkMemberUsedInInvalidWay,"The member '%s' is used in an invalid way. A use of '%s' has been inferred prior to its definition at or near '%s'. This is an invalid forward reference." 431,chkNoByrefAsTopValue,"A byref typed value would be stored here. Top-level let-bound byref values are not permitted." 432,chkReflectedDefCantSplice,"[] terms cannot contain uses of the prefix splice operator '%%'" -433,chkEntryPointUsage,"A function labeled with the 'EntryPointAttribute' attribute must be the last declaration in the last file in the compilation sequence, and can only be used when compiling to a .exe" +433,chkEntryPointUsage,"A function labeled with the 'EntryPointAttribute' attribute must be the last declaration in the last file in the compilation sequence." chkUnionCaseCompiledForm,"compiled form of the union case" chkUnionCaseDefaultAugmentation,"default augmentation of the union case" 434,chkPropertySameNameMethod,"Name clash. The property '%s' has the same name as a method in this type." @@ -256,7 +264,7 @@ chkUnionCaseDefaultAugmentation,"default augmentation of the union case" 438,chkDuplicateMethod,"Duplicate method. The method '%s' has the same name and signature as another method in this type." 438,chkDuplicateMethodWithSuffix,"Duplicate method. The method '%s' has the same name and signature as another method in this type once tuples, functions, units of measure and/or provided types are erased." 439,chkDuplicateMethodCurried,"The method '%s' has curried arguments but has the same name as another method in this type. Methods with curried arguments cannot be overloaded. Consider using a method taking tupled arguments." -440,chkCurriedMethodsCantHaveOutParams,"Methods with curried arguments cannot declare 'out', 'ParamArray', 'optional', 'ReflectedDefinition' or 'byref' arguments" +440,chkCurriedMethodsCantHaveOutParams,"Methods with curried arguments cannot declare 'out', 'ParamArray', 'optional', 'ReflectedDefinition', 'byref', 'CallerLineNumber', 'CallerMemberName', or 'CallerFilePath' arguments" 441,chkDuplicateProperty,"Duplicate property. The property '%s' has the same name and signature as another property in this type." 441,chkDuplicatePropertyWithSuffix,"Duplicate property. The property '%s' has the same name and signature as another property in this type once tuples, functions, units of measure and/or provided types are erased." 442,chkDuplicateMethodInheritedType,"Duplicate method. The abstract method '%s' has the same name and signature as an abstract method in an inherited type." @@ -410,7 +418,7 @@ parsConsiderUsingSeparateRecordType,"Consider using a separate record type inste 584,parsSuccessivePatternsShouldBeSpacedOrTupled,"Successive patterns should be separated by spaces or tupled" 586,parsNoMatchingInForLet,"No matching 'in' found for this 'let'" 587,parsErrorInReturnForLetIncorrectIndentation,"Error in the return expression for this 'let'. Possible incorrect indentation." -588,parsExpectedStatementAfterLet,"Block following this '%s' is unfinished. Expect an expression." +588,parsExpectedExpressionAfterLet,"The block following this '%s' is unfinished. Every code block is an expression and must have a result. '%s' cannot be the final code element in a block. Consider giving this block an explicit result." 589,parsIncompleteIf,"Incomplete conditional. Expected 'if then ' or 'if then else '." 590,parsAssertIsNotFirstClassValue,"'assert' may not be used as a first class value. Use 'assert ' instead." 594,parsIdentifierExpected,"Identifier expected" @@ -686,7 +694,7 @@ tcUnnamedArgumentsDoNotFormPrefix,"The unnamed arguments do not form a prefix of 871,tcConstructorsIllegalForThisType,"Constructors cannot be defined for this type" 872,tcRecursiveBindingsWithMembersMustBeDirectAugmentation,"Recursive bindings that include member specifications can only occur as a direct augmentation of a type" 873,tcOnlySimplePatternsInLetRec,"Only simple variable patterns can be bound in 'let rec' constructs" -874,tcOnlyRecordFieldsAndSimpleLetCanBeMutable,"Only record fields and simple 'let' bindings may be marked mutable" +874,tcOnlyRecordFieldsAndSimpleLetCanBeMutable,"Only record fields and simple, non-recursive 'let' bindings may be marked mutable" 875,tcMemberIsNotSufficientlyGeneric,"This member is not sufficiently generic" 876,tcLiteralAttributeRequiresConstantValue,"A declaration may only be the [] attribute if a constant value is also given, e.g. 'val x : int = 1'" 877,tcValueInSignatureRequiresLiteralAttribute,"A declaration may only be given a value in a signature if the declaration has the [] attribute" @@ -949,6 +957,7 @@ lexfltSeparatorTokensOfPatternMatchMisaligned,"The '|' tokens separating rules o 1127,nrIsNotConstructorOrLiteral,"This is not a constructor or literal, or a constructor is being used incorrectly" 1128,nrUnexpectedEmptyLongId,"Unexpected empty long identifier" 1129,nrTypeDoesNotContainSuchField,"The type '%s' does not contain a field '%s'" +1129,nrRecordDoesNotContainSuchLabel,"The record type '%s' does not contain a label '%s'." 1130,nrInvalidFieldLabel,"Invalid field label" 1132,nrInvalidExpression,"Invalid expression '%s'" 1133,nrNoConstructorsAvailableForType,"No constructors are available for the type '%s'" @@ -977,7 +986,7 @@ lexUnexpectedChar,"Unexpected character '%s'" 1153,lexInvalidFloat,"Invalid floating point number" 1154,lexOusideDecimal,"This number is outside the allowable range for decimal literals" 1155,lexOusideThirtyTwoBitFloat,"This number is outside the allowable range for 32-bit floats" -1156,lexInvalidNumericLiteral,"This is not a valid numeric literal. Sample formats include 4, 0x4, 0b0100, 4L, 4UL, 4u, 4s, 4us, 4y, 4uy, 4.0, 4.0f, 4I." +1156,lexInvalidNumericLiteral,"This is not a valid numeric literal. Valid numeric literals include 1, 0x1, 0b0001 (int), 1u (uint32), 1L (int64), 1UL (uint64), 1s (int16), 1y (sbyte), 1ui (byte), 1.0 (float), 1.0f (float32), 1.0m (decimal), 1I (BigInteger)." 1157,lexInvalidByteLiteral,"This is not a valid byte literal" 1158,lexInvalidCharLiteral,"This is not a valid character literal" 1159,lexThisUnicodeOnlyInStringLiterals,"This Unicode encoding is only valid in string literals" @@ -1068,6 +1077,8 @@ lexIndentOffForML,"Consider using a file with extension '.ml' or '.mli' instead" 1243,parsUnexpectedQuotationOperatorInTypeAliasDidYouMeanVerbatimString,"Unexpected quotation operator '<@' in type definition. If you intend to pass a verbatim string as a static argument to a type provider, put a space between the '<' and '@' characters." 1244,parsErrorParsingAsOperatorName,"Attempted to parse this as an operator name, but failed" 1245,lexInvalidUnicodeLiteral,"\U%s is not a valid Unicode character escape sequence" +1246,tcCallerInfoWrongType,"'%s' must be applied to an argument of type '%s', but has been applied to an argument of type '%s'" +1247,tcCallerInfoNotOptional,"'%s' can only be applied to optional arguments" # reshapedmsbuild.fs 1300,toolLocationHelperUnsupportedFrameworkVersion,"The specified .NET Framework version "%s" is not supported. Please specify a value from the enumeration Microsoft.Build.Utilities.TargetDotNetFrameworkVersion." # ----------------------------------------------------------------------------- @@ -1292,3 +1303,15 @@ estApplyStaticArgumentsForMethodNotImplemented,"A type provider implemented GetS 3195,optsResponseFileNameInvalid,"Response file name '%s' is empty, contains invalid characters, has a drive specification without an absolute path, or is too long" 3196,fsharpCoreNotFoundToBeCopied,"Cannot find FSharp.Core.dll in compiler's directory" 3197,etMissingStaticArgumentsToMethod,"This provided method requires static parameters" +3198,considerUpcast,"The conversion from %s to %s is a compile-time safe upcast, not a downcast. Consider using 'upcast' instead of 'downcast'." +3198,considerUpcastOperator,"The conversion from %s to %s is a compile-time safe upcast, not a downcast. Consider using the :> (upcast) operator instead of the :?> (downcast) operator." +3199,tcRecImplied,"The 'rec' on this module is implied by an outer 'rec' declaration and is being ignored" +3200,tcOpenFirstInMutRec,"In a recursive declaration group, 'open' declarations must come first in each module" +3201,tcModuleAbbrevFirstInMutRec,"In a recursive declaration group, module abbreviations must come after all 'open' declarations and before other declarations" +3202,tcUnsupportedMutRecDecl,"This declaration is not supported in recursive declaration groups" +3203,parsInvalidUseOfRec,"Invalid use of 'rec' keyword" +3204,tcStructUnionMultiCase,"A union type which is a struct must have only one case." +3205,tcUseMayNotBeMutable,"This feature is deprecated. A 'use' binding may not be marked 'mutable'." +3206,CallerMemberNameIsOverriden,"The CallerMemberNameAttribute applied to parameter '%s' will have no effect. It is overridden by the CallerFilePathAttribute." +3207,tcFixedNotAllowed,"Invalid use of 'fixed'. 'fixed' may only be used in a declaration of the form 'use x = fixed expr' where the expression is an array, the address of a field, the address of an array element or a string'" +3208,tcCouldNotFindOffsetToStringData,"Could not find method System.Runtime.CompilerServices.OffsetToStringData in references when building 'fixed' expression." diff --git a/src/fsharp/FSStrings.resx b/src/fsharp/FSStrings.resx index cee5e18dd2..f028e00b6f 100755 --- a/src/fsharp/FSStrings.resx +++ b/src/fsharp/FSStrings.resx @@ -124,7 +124,7 @@ The tuples have differing lengths of {0} and {1} - The resulting type would be infinite when unifying '{0}' and '{1}' + The types '{0}' and '{1}' cannot be unified. A type parameter is missing a constraint '{0}' @@ -145,10 +145,10 @@ {0} - This expression was expected to have type\n {1} \nbut here has type\n {0} {2} + This expression was expected to have type\n '{1}' \nbut here has type\n '{0}' {2} - Type mismatch. Expecting a\n {0} \nbut given a\n {1} {2}\n + Type mismatch. Expecting a\n '{0}' \nbut given a\n '{1}' {2}\n Type constraint mismatch when applying the default type '{0}' for a type inference variable. @@ -157,7 +157,7 @@ Consider adding further type constraints - Type constraint mismatch. The type \n {0} \nis not compatible with type\n {1} {2}\n + Type constraint mismatch. The type \n '{0}' \nis not compatible with type\n '{1}' {2}\n Uppercase variable identifiers should not generally be used in patterns, and may indicate a misspelt pattern name. @@ -892,7 +892,7 @@ This expression is a function value, i.e. is missing arguments. Its type is {0}. - This expression should have type 'unit', but has type '{0}'. Use 'ignore' to discard the result of the expression, or 'let' to bind the result to a name. + The result of this expression is implicitly ignored. Consider using 'ignore' to discard this value explicitly, e.g. 'expr |> ignore', or 'let' to bind the result to a name, e.g. 'let result = expr'. This expression should have type 'unit', but has type '{0}'. If assigning to a property use the syntax 'obj.Prop <- expr'. @@ -970,7 +970,7 @@ This rule will never be matched - This value is not mutable + This value is not mutable. Consider using the mutable keyword, e.g. 'let mutable {0} = expression'. This value is not local diff --git a/src/fsharp/FSharp.Build/project.json b/src/fsharp/FSharp.Build/project.json new file mode 100644 index 0000000000..40df883342 --- /dev/null +++ b/src/fsharp/FSharp.Build/project.json @@ -0,0 +1,22 @@ +{ + "dependencies": { + "Microsoft.Build": "0.1.0-preview-00022", + "Microsoft.Build.Framework": "0.1.0-preview-00022", + "Microsoft.Build.Tasks.Core": "0.1.0-preview-00022", + "Microsoft.Build.Utilities.Core": "0.1.0-preview-00022", + "Microsoft.NETCore.Platforms": "1.0.1-rc2-24027", + "Microsoft.Win32.Registry": { + "version": "4.0.0-rc2-24027", + "exclude": "Compile" + }, + "System.AppContext": "4.1.0-rc2-24027", + "System.Diagnostics.Tools": "4.0.1-rc2-24027", + "System.Reflection.Primitives": "4.0.1-rc2-24027", + "System.Resources.ResourceManager": "4.0.1-rc2-24027" + }, + "frameworks": { + "dnxcore50": { + "imports": "portable-net45+win8" + } + } +} \ No newline at end of file diff --git a/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj b/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj index 0404fc3fc9..4f0d8ec287 100644 --- a/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj +++ b/src/fsharp/FSharp.Compiler.Service/FSharp.Compiler.Service.fsproj @@ -44,19 +44,19 @@ $(DefineConstants);FX_RESIDENT_COMPILER $(DefineConstants);SHADOW_COPY_REFERENCES $(DefineConstants);EXTENSIONTYPING - $(DefineConstants);COMPILER_SERVICE_ASSUMES_FSHARP_CORE_4_3_0_0 + $(DefineConstants);COMPILER_SERVICE_ASSUMES_FSHARP_CORE_4_4_0_0 $(DefineConstants);COMPILER_SERVICE $(DefineConstants);NO_STRONG_NAMES $(DefineConstants);TRACE - 4.3.0.0 + 4.4.0.0 ..\..\..\ - ..\..\..\lib\bootstrap\4.0 - $(LkgPath) - $(LkgPath) - $(LkgPath) + ..\..\..\lib\bootstrap\4.0 + ..\..\..\packages\FsSrGen\lib\net46 + $(FsLexYaccPath) + $(FsLexYaccPath) fslex.exe fsyacc.exe false @@ -156,6 +156,9 @@ Utilities/HashMultiMap.fs + + Utilities\EditDistance.fs + Utilities/TaggedCollections.fsi @@ -204,6 +207,9 @@ Utilities/lib.fs + + Utilities/ErrorResolutionHints.fs + Utilities/InternalCollections.fsi @@ -426,6 +432,15 @@ Logic/infos.fs + + Logic/AccessibilityLogic.fs + + + Logic/AttributeChecking.fs + + + Logic/InfoReader.fs + Logic/NicePrint.fs @@ -444,6 +459,15 @@ Logic/TypeRelations.fs + + Logic/SignatureConformance.fs + + + Logic/MethodOverrides.fs + + + Logic/MethodCalls.fs + Logic/PatternMatchCompilation.fsi @@ -633,14 +657,18 @@ $(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets - - + + + + + + - + - ..\..\..\packages\Microsoft.DiaSymReader\lib\net20\Microsoft.DiaSymReader.dll + ..\..\..\packages\Microsoft.DiaSymReader\lib\netstandard1.1\Microsoft.DiaSymReader.dll True True @@ -655,9 +683,18 @@ + + + + ..\..\..\packages\Microsoft.DiaSymReader\lib\net20\Microsoft.DiaSymReader.dll + True + True + + + - + ..\..\..\packages\Microsoft.DiaSymReader.PortablePdb\lib\net45\Microsoft.DiaSymReader.PortablePdb.dll @@ -666,6 +703,15 @@ + + + + ..\..\..\packages\Microsoft.DiaSymReader.PortablePdb\lib\netstandard1.1\Microsoft.DiaSymReader.PortablePdb.dll + True + True + + + @@ -677,7 +723,16 @@ - + + + + ..\..\..\packages\System.Collections.Immutable\lib\netstandard1.0\System.Collections.Immutable.dll + True + True + + + + ..\..\..\packages\System.Collections.Immutable\lib\portable-net45+win8+wp8+wpa81\System.Collections.Immutable.dll @@ -688,7 +743,40 @@ - + + + + ..\..\..\packages\System.IO.FileSystem\lib\net46\System.IO.FileSystem.dll + True + True + + + + + + + + + ..\..\..\packages\System.IO.FileSystem.Primitives\lib\netstandard1.3\System.IO.FileSystem.Primitives.dll + True + True + + + + + + + + + ..\..\..\packages\System.Linq\lib\netstandard1.6\System.Linq.dll + True + True + + + + + + ..\..\..\packages\System.Reflection.Metadata\lib\portable-net45+win8\System.Reflection.Metadata.dll @@ -697,5 +785,85 @@ + + + + ..\..\..\packages\System.Reflection.Metadata\lib\netstandard1.1\System.Reflection.Metadata.dll + True + True + + + + + + + + + True + + + + + + + + + ..\..\..\packages\System.Text.RegularExpressions\lib\netstandard1.6\System.Text.RegularExpressions.dll + True + True + + + + + + + + + ..\..\..\packages\System.Threading\lib\netstandard1.3\System.Threading.dll + True + True + + + + + + + + + ..\..\..\packages\System.Threading.Tasks.Extensions\lib\netstandard1.0\System.Threading.Tasks.Extensions.dll + True + True + + + + + + + + + ..\..\..\packages\System.Xml.ReaderWriter\lib\netstandard1.3\System.Xml.ReaderWriter.dll + True + True + + + + + + + + + True + + + + + + + ..\..\..\packages\System.Xml.XDocument\lib\netstandard1.3\System.Xml.XDocument.dll + True + True + + + \ No newline at end of file diff --git a/src/fsharp/FindUnsolved.fs b/src/fsharp/FindUnsolved.fs index f682746abc..66f421f352 100755 --- a/src/fsharp/FindUnsolved.fs +++ b/src/fsharp/FindUnsolved.fs @@ -7,12 +7,12 @@ module internal Microsoft.FSharp.Compiler.FindUnsolved open Internal.Utilities + +open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler - open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast @@ -231,16 +231,18 @@ and accModuleOrNamespaceDefs cenv env x = List.iter (accModuleOrNamespaceDef cen and accModuleOrNamespaceDef cenv env x = match x with - | TMDefRec(tycons,binds,mbinds,_m) -> + | TMDefRec(_,tycons,mbinds,_m) -> accTycons cenv env tycons; - accBinds cenv env binds; accModuleOrNamespaceBinds cenv env mbinds | TMDefLet(bind,_m) -> accBind cenv env bind | TMDefDo(e,_m) -> accExpr cenv env e | TMAbstract(def) -> accModuleOrNamespaceExpr cenv env def | TMDefs(defs) -> accModuleOrNamespaceDefs cenv env defs and accModuleOrNamespaceBinds cenv env xs = List.iter (accModuleOrNamespaceBind cenv env) xs -and accModuleOrNamespaceBind cenv env (ModuleOrNamespaceBinding(mspec, rhs)) = accTycon cenv env mspec; accModuleOrNamespaceDef cenv env rhs +and accModuleOrNamespaceBind cenv env x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> accBind cenv env bind + | ModuleOrNamespaceBinding.Module(mspec, rhs) -> accTycon cenv env mspec; accModuleOrNamespaceDef cenv env rhs let UnsolvedTyparsOfModuleDef g amap denv (mdef, extraAttribs) = let cenv = diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index cd71408907..6a74f832f5 100755 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -6,8 +6,6 @@ module internal Microsoft.FSharp.Compiler.IlxGen -#nowarn "44" // This construct is deprecated. please use List.item - open System.IO open System.Collections.Generic open Internal.Utilities @@ -81,12 +79,8 @@ let ChooseParamNames fieldNamesAndTypes = let markup s = s |> Seq.mapi (fun i x -> i,x) // Approximation for purposes of optimization and giving a warning when compiling definition-only files as EXEs -let rec CheckCodeDoesSomething code = - match code with - | ILBasicBlock bb -> Array.fold (fun x i -> x || match i with (AI_ldnull | AI_nop | AI_pop) | I_ret | I_seqpoint _ -> false | _ -> true) false bb.Instructions - | GroupBlock (_,codes) -> List.exists CheckCodeDoesSomething codes - | RestrictBlock (_,code) -> CheckCodeDoesSomething code - | TryBlock _ -> true +let rec CheckCodeDoesSomething (code: ILCode) = + code.Instrs |> Array.exists (function AI_ldnull | AI_nop | AI_pop | I_ret | I_seqpoint _ -> false | _ -> true) let ChooseFreeVarNames takenNames ts = let tns = List.map (fun t -> (t,None)) ts @@ -96,9 +90,10 @@ let ChooseFreeVarNames takenNames ts = chooseName names (t,Some(match nOpt with None -> 0 | Some n -> (n+1))) else let names = Zset.add tn names - names,tn + tn,names + let names = Zset.empty String.order |> Zset.addList takenNames - let _names,ts = List.foldMap chooseName names tns + let ts,_names = List.mapFold chooseName names tns ts let ilxgenGlobalNng = NiceNameGenerator () @@ -351,6 +346,8 @@ type TypeReprEnv(reprs : Map, count: int) = member tyenv.Add tps = (tyenv,tps) ||> List.fold (fun tyenv tp -> tyenv.AddOne tp) + member tyenv.Count = count + static member Empty = TypeReprEnv(count = 0, reprs = Map.empty) @@ -476,7 +473,8 @@ and GenUnionRef amap m g (tcref: TyconRef) = altFields=GenUnionCaseRef amap m g tyenvinner i cspec.RecdFieldsArray }) let nullPermitted = IsUnionTypeWithNullAsTrueValue g tycon let hasHelpers = ComputeUnionHasHelpers g tcref - IlxUnionRef(tref,alternatives,nullPermitted,hasHelpers)) + let boxity = (if tcref.IsStructOrEnumTycon then ILBoxity.AsValue else ILBoxity.AsObject) + IlxUnionRef(boxity, tref,alternatives,nullPermitted,hasHelpers)) and ComputeUnionHasHelpers g (tcref : TyconRef) = if tyconRefEq g tcref g.unit_tcr_canon then NoHelpers @@ -967,11 +965,10 @@ let rec AddBindingsForModuleDefs allocVal (cloc:CompileLocation) eenv mdefs = and AddBindingsForModuleDef allocVal cloc eenv x = match x with - | TMDefRec(tycons,vbinds,mbinds,_) -> - let eenv = FlatList.foldBack (allocVal cloc) (valsOfBinds vbinds) eenv + | TMDefRec(_isRec,tycons,mbinds,_) -> (* Virtual don't have 'let' bindings and must be added to the environment *) let eenv = List.foldBack (AddBindingsForTycon allocVal cloc) tycons eenv - let eenv = List.foldBack (AddBindingsForSubModules allocVal cloc) mbinds eenv + let eenv = List.foldBack (AddBindingsForModule allocVal cloc) mbinds eenv eenv | TMDefLet(bind,_) -> allocVal cloc bind.Var eenv @@ -982,12 +979,16 @@ and AddBindingsForModuleDef allocVal cloc eenv x = | TMDefs(mdefs) -> AddBindingsForModuleDefs allocVal cloc eenv mdefs -and AddBindingsForSubModules allocVal cloc (ModuleOrNamespaceBinding(mspec, mdef)) eenv = - let cloc = - if mspec.IsNamespace then cloc - else CompLocForFixedModule cloc.clocQualifiedNameOfFile cloc.clocTopImplQualifiedName mspec +and AddBindingsForModule allocVal cloc x eenv = + match x with + | ModuleOrNamespaceBinding.Binding bind -> + allocVal cloc bind.Var eenv + | ModuleOrNamespaceBinding.Module (mspec, mdef) -> + let cloc = + if mspec.IsNamespace then cloc + else CompLocForFixedModule cloc.clocQualifiedNameOfFile cloc.clocTopImplQualifiedName mspec - AddBindingsForModuleDef allocVal cloc eenv mdef + AddBindingsForModuleDef allocVal cloc eenv mdef and AddBindingsForModuleTopVals _g allocVal _cloc eenv vs = FlatList.foldBack allocVal vs eenv @@ -1075,7 +1076,7 @@ let MergePropertyDefs m ilPropertyDefs = //-------------------------------------------------------------------------- /// Information collected imperatively for each type definition -type TypeDefBuilder(tdef) = +type TypeDefBuilder(tdef, tdefDiscards) = let gmethods = new ResizeArray(0) let gfields = new ResizeArray(0) let gproperties : Dictionary = new Dictionary<_,_>(3,HashIdentity.Structural) @@ -1093,13 +1094,25 @@ type TypeDefBuilder(tdef) = member b.AddEventDef(edef) = gevents.Add edef member b.AddFieldDef(ilFieldDef) = gfields.Add ilFieldDef - member b.AddMethodDef(ilMethodDef) = gmethods.Add ilMethodDef + member b.AddMethodDef(ilMethodDef) = + let discard = + match tdefDiscards with + | Some (mdefDiscard, _) -> mdefDiscard ilMethodDef + | None -> false + if not discard then + gmethods.Add ilMethodDef member b.NestedTypeDefs = gnested member b.GetCurrentFields() = gfields |> Seq.readonly /// Merge Get and Set property nodes, which we generate independently for F# code /// when we come across their corresponding methods. - member b.AddOrMergePropertyDef(pdef,m) = AddPropertyDefToHash m gproperties pdef + member b.AddOrMergePropertyDef(pdef,m) = + let discard = + match tdefDiscards with + | Some (_, pdefDiscard) -> pdefDiscard pdef + | None -> false + if not discard then + AddPropertyDefToHash m gproperties pdef member b.PrependInstructionsToSpecificMethodDef(cond,instrs,tag) = match ResizeArray.tryFindIndex cond gmethods with @@ -1137,9 +1150,9 @@ and TypeDefsBuilder() = member b.FindNestedTypeDefBuilder(tref:ILTypeRef) = b.FindNestedTypeDefsBuilder(tref.Enclosing).FindTypeDefBuilder(tref.Name) - member b.AddTypeDef(tdef:ILTypeDef, eliminateIfEmpty, addAtEnd) = + member b.AddTypeDef(tdef:ILTypeDef, eliminateIfEmpty, addAtEnd, tdefDiscards) = let idx = if addAtEnd then (countDown <- countDown - 1; countDown) else tdefs.Count - tdefs.Add (tdef.Name, (idx, (new TypeDefBuilder(tdef), eliminateIfEmpty))) + tdefs.Add (tdef.Name, (idx, (new TypeDefBuilder(tdef, tdefDiscards), eliminateIfEmpty))) /// Assembly generation buffers type AssemblyBuilder(cenv:cenv) as mgbuf = @@ -1156,7 +1169,7 @@ type AssemblyBuilder(cenv:cenv) as mgbuf = let vtref = NestedTypeRefForCompLoc cloc vtdef.Name let vtspec = mkILTySpec(vtref,[]) let vtdef = {vtdef with Access= ComputeTypeAccess vtref true} - mgbuf.AddTypeDef(vtref, vtdef, false, true); + mgbuf.AddTypeDef(vtref, vtdef, false, true, None); vtspec), keyComparer=HashIdentity.Structural) @@ -1188,8 +1201,8 @@ type AssemblyBuilder(cenv:cenv) as mgbuf = let cloc = CompLocForPrivateImplementationDetails cloc vtgenerator.Apply((cloc,size)) - member mgbuf.AddTypeDef(tref:ILTypeRef, tdef, eliminateIfEmpty, addAtEnd) = - gtdefs.FindNestedTypeDefsBuilder(tref.Enclosing).AddTypeDef(tdef, eliminateIfEmpty, addAtEnd) + member mgbuf.AddTypeDef(tref:ILTypeRef, tdef, eliminateIfEmpty, addAtEnd, tdefDiscards) = + gtdefs.FindNestedTypeDefsBuilder(tref.Enclosing).AddTypeDef(tdef, eliminateIfEmpty, addAtEnd, tdefDiscards) member mgbuf.GetCurrentFields(tref:ILTypeRef) = gtdefs.FindNestedTypeDefBuilder(tref).GetCurrentFields(); @@ -1265,7 +1278,7 @@ type CodeGenBuffer(m:range, alreadyUsedLocals:int, zapFirstSeqPointToStart:bool) = - let locals = new ResizeArray<((string * (Mark * Mark)) list * ILType)>(10) + let locals = new ResizeArray<((string * (Mark * Mark)) list * ILType * bool)>(10) let codebuf = new ResizeArray(200) let exnSpecs = new ResizeArray(10) @@ -1279,10 +1292,10 @@ type CodeGenBuffer(m:range, let codeLabelToPC : Dictionary = new Dictionary<_,_>(10) let codeLabelToCodeLabel : Dictionary = new Dictionary<_,_>(10) - let rec computeCodeLabelToPC n lbl = + let rec lab2pc n lbl = if n = System.Int32.MaxValue then error(InternalError("recursive label graph",m)) if codeLabelToCodeLabel.ContainsKey lbl then - computeCodeLabelToPC (n+1) codeLabelToCodeLabel.[lbl] + lab2pc (n+1) codeLabelToCodeLabel.[lbl] else codeLabelToPC.[lbl] @@ -1404,20 +1417,20 @@ type CodeGenBuffer(m:range, member cgbuf.MethodName = methodName member cgbuf.PreallocatedArgCount = alreadyUsedArgs - member cgbuf.AllocLocal(ranges,ty) = + member cgbuf.AllocLocal(ranges,ty,isFixed) = let j = locals.Count - locals.Add((ranges,ty)); + locals.Add((ranges,ty,isFixed)); j - member cgbuf.ReallocLocal(cond,ranges,ty) = + member cgbuf.ReallocLocal(cond,ranges,ty,isFixed) = let j = match ResizeArray.tryFindIndexi cond locals with | Some j -> - let (prevRanges,_) = locals.[j] - locals.[j] <- ((ranges@prevRanges),ty); + let (prevRanges,_,isFixed) = locals.[j] + locals.[j] <- ((ranges@prevRanges),ty,isFixed); j | None -> - cgbuf.AllocLocal(ranges,ty) + cgbuf.AllocLocal(ranges,ty,isFixed) let j = j + alreadyUsedLocals j @@ -1447,7 +1460,8 @@ type CodeGenBuffer(m:range, instrs ResizeArray.toList locals , maxStack, - (computeCodeLabelToPC 0), + (Dictionary.ofList [ for kvp in codeLabelToPC -> (kvp.Key, lab2pc 0 kvp.Key) + for kvp in codeLabelToCodeLabel -> (kvp.Key, lab2pc 0 kvp.Key) ] ), instrs, ResizeArray.toList exnSpecs, isSome seqpoint @@ -1512,7 +1526,7 @@ type sequel = | LeaveHandler of (bool (* finally? *) * int * Mark) /// Branch to the given mark | Br of Mark - | CmpThenBrOrContinue of Pops * ILInstr + | CmpThenBrOrContinue of Pops * ILInstr list /// Continue and leave the value on the IL computation stack | Continue /// The value then do something else @@ -1544,19 +1558,20 @@ let CodeGenThen cenv mgbuf (zapFirstSeqPointToStart,entryPointInfo,methodName,ee liveLocals=IntMap.empty(); innerVals = innerVals}; - let locals,maxStack,computeCodeLabelToPC,code,exnSpecs,hasSequencePoints = cgbuf.Close() + let locals,maxStack,lab2pc,code,exnSpecs,hasSequencePoints = cgbuf.Close() - let localDebugSpecs = + let localDebugSpecs : ILLocalDebugInfo list = locals - |> List.mapi (fun i (nms,_) -> List.map (fun nm -> (i,nm)) nms) + |> List.mapi (fun i (nms,_,_isFixed) -> List.map (fun nm -> (i,nm)) nms) |> List.concat |> List.map (fun (i,(nm,(start,finish))) -> - { locRange=(start.CodeLabel, finish.CodeLabel); - locInfos= [{ LocalIndex=i; LocalName=nm }] }) + { Range=(start.CodeLabel, finish.CodeLabel); + DebugMappings= [{ LocalIndex=i; LocalName=nm }] }) let ilLocals = locals - |> List.map (fun (infos, ty) -> + |> List.map (fun (infos, ty, isFixed) -> + let loc = // in interactive environment, attach name and range info to locals to improve debug experience if cenv.opts.isInteractive && cenv.opts.generateDebugSymbols then match infos with @@ -1566,35 +1581,31 @@ let CodeGenThen cenv mgbuf (zapFirstSeqPointToStart,entryPointInfo,methodName,ee | [] -> mkILLocal ty None // if not interactive, don't bother adding this info else - mkILLocal ty None) + mkILLocal ty None + if isFixed then { loc with IsPinned=true } else loc) (ilLocals, maxStack, - computeCodeLabelToPC, + lab2pc, code, exnSpecs, localDebugSpecs, hasSequencePoints) let CodeGenMethod cenv mgbuf (zapFirstSeqPointToStart,entryPointInfo,methodName,eenv,alreadyUsedArgs,alreadyUsedLocals,codeGenFunction,m) = - (* Codegen the method. REVIEW: change this to generate the AbsIL code tree directly... *) - let locals,maxStack,computeCodeLabelToPC,instrs,exns,localDebugSpecs,hasSequencePoints = + let locals,maxStack,lab2pc,instrs,exns,localDebugSpecs,hasSequencePoints = CodeGenThen cenv mgbuf (zapFirstSeqPointToStart,entryPointInfo,methodName,eenv,alreadyUsedArgs,alreadyUsedLocals,codeGenFunction,m) - let dump() = - instrs |> Array.iteri (fun i instr -> dprintf "%s: %d: %A\n" methodName i instr); - - let lab2pc lbl = try computeCodeLabelToPC lbl with _ -> errorR(Error(FSComp.SR.ilLabelNotFound(formatCodeLabel lbl),m)); dump(); 676767 - let code = IL.buildILCode methodName lab2pc instrs exns localDebugSpecs - let code = IL.checkILCode code - // Attach a source range to the method. Only do this is it has some sequence points, because .NET 2.0/3.5 // ILDASM has issues if you emit symbols with a source range but without any sequence points let sourceRange = if hasSequencePoints then GenPossibleILSourceMarker cenv m else None + // The old union erasure phase increased maxstack by 2 since the code pushes some items, we do the same here + let maxStack = maxStack + 2 + // Build an Abstract IL method instrs, mkILMethodBody (true,mkILLocals locals,maxStack,code, sourceRange) @@ -1746,6 +1757,8 @@ let rec GenExpr cenv (cgbuf:CodeGenBuffer) eenv sp expr sequel = GenGetExnField cenv cgbuf eenv (e,ecref,n,m) sequel | TOp.UnionCaseFieldGet(ucref,n),[e],_ -> GenGetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel + | TOp.UnionCaseFieldGetAddr(ucref,n),[e],_ -> + GenGetUnionCaseFieldAddr cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel | TOp.UnionCaseTagGet ucref,[e],_ -> GenGetUnionCaseTag cenv cgbuf eenv (e,ucref,tyargs,m) sequel | TOp.UnionCaseProof ucref,[e],_ -> @@ -1892,7 +1905,7 @@ and GenSequel cenv cloc cgbuf sequel = | ReturnVoid -> CG.EmitInstr cgbuf (pop 0) Push0 I_ret | CmpThenBrOrContinue(pops,bri) -> - CG.EmitInstr cgbuf pops Push0 bri + CG.EmitInstrs cgbuf pops Push0 bri | Return -> CG.EmitInstr cgbuf (pop 1) Push0 I_ret | EndLocalScope _ -> failwith "EndLocalScope unexpected" @@ -2025,7 +2038,7 @@ and GenAllocExn cenv cgbuf eenv (c,args,m) sequel = and GenAllocUnionCase cenv cgbuf eenv (c,tyargs,args,m) sequel = GenExprs cenv cgbuf eenv args; let cuspec,idx = GenUnionCaseSpec cenv.amap m cenv.g eenv.tyenv c tyargs - CG.EmitInstr cgbuf (pop args.Length) (Push [cuspec.EnclosingType]) (mkIlxInstr (EI_newdata (cuspec,idx))); + CG.EmitInstrs cgbuf (pop args.Length) (Push [cuspec.EnclosingType]) (EraseUnions.mkNewData cenv.g.ilg (cuspec, idx)); GenSequel cenv eenv.cloc cgbuf sequel and GenAllocRecd cenv cgbuf eenv ctorInfo (tcref,argtys,args,m) sequel = @@ -2143,7 +2156,7 @@ and GenGetExnField cenv cgbuf eenv (e,ecref,fieldNum,m) sequel = let typ = GenExnType cenv.amap m cenv.g eenv.tyenv ecref CG.EmitInstrs cgbuf (pop 0) Push0 [ I_castclass typ]; - let fld = List.nth (exnc.TrueInstanceFieldsAsList) fieldNum + let fld = List.item fieldNum exnc.TrueInstanceFieldsAsList let ftyp = GenType cenv.amap m cenv.g eenv.tyenv fld.FormalType let mspec = mkILNonGenericInstanceMethSpecInTy (typ,"get_" + fld.Name, [], ftyp) @@ -2156,45 +2169,67 @@ and GenSetExnField cenv cgbuf eenv (e,ecref,fieldNum,e2,m) sequel = let exnc = stripExnEqns ecref let typ = GenExnType cenv.amap m cenv.g eenv.tyenv ecref CG.EmitInstrs cgbuf (pop 0) Push0 [ I_castclass typ ]; - let fld = List.nth (exnc.TrueInstanceFieldsAsList) fieldNum + let fld = List.item fieldNum exnc.TrueInstanceFieldsAsList let ftyp = GenType cenv.amap m cenv.g eenv.tyenv fld.FormalType let ilFieldName = ComputeFieldName exnc fld GenExpr cenv cgbuf eenv SPSuppress e2 Continue; CG.EmitInstr cgbuf (pop 2) Push0 (mkNormalStfld(mkILFieldSpecInTy (typ,ilFieldName,ftyp))); GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel +and UnionCodeGen (cgbuf: CodeGenBuffer) = + { new EraseUnions.ICodeGen with + member __.CodeLabel(m) = m.CodeLabel + member __.GenerateDelayMark() = CG.GenerateDelayMark cgbuf "unionCodeGenMark" + member __.GenLocal(ilty) = cgbuf.AllocLocal([],ilty,false) |> uint16 + member __.SetMarkToHere(m) = CG.SetMarkToHere cgbuf m + member __.EmitInstr x = CG.EmitInstr cgbuf (pop 0) (Push []) x + member __.EmitInstrs xs = CG.EmitInstrs cgbuf (pop 0) (Push []) xs } and GenUnionCaseProof cenv cgbuf eenv (e,ucref,tyargs,m) sequel = GenExpr cenv cgbuf eenv SPSuppress e Continue; let cuspec,idx = GenUnionCaseSpec cenv.amap m cenv.g eenv.tyenv ucref tyargs let fty = EraseUnions.GetILTypeForAlternative cuspec idx - CG.EmitInstrs cgbuf (pop 1) (Push [fty]) - [ mkIlxInstr (EI_castdata(false,cuspec,idx)); ]; + let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef + EraseUnions.emitCastData cenv.g.ilg (UnionCodeGen cgbuf) (false,avoidHelpers,cuspec,idx) + CG.EmitInstrs cgbuf (pop 1) (Push [fty]) [ ] // push/pop to match the line above GenSequel cenv eenv.cloc cgbuf sequel and GenGetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel = - assert (isProvenUnionCaseTy (tyOfExpr cenv.g e)); + assert (ucref.Tycon.IsStructOrEnumTycon || isProvenUnionCaseTy (tyOfExpr cenv.g e)); GenExpr cenv cgbuf eenv SPSuppress e Continue; let cuspec,idx = GenUnionCaseSpec cenv.amap m cenv.g eenv.tyenv ucref tyargs let fty = actualTypOfIlxUnionField cuspec idx n let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef - CG.EmitInstrs cgbuf (pop 1) (Push [fty]) [ mkIlxInstr (EI_lddata(avoidHelpers, cuspec,idx,n)) ]; + CG.EmitInstrs cgbuf (pop 1) (Push [fty]) (EraseUnions.mkLdData (avoidHelpers, cuspec, idx, n)); + GenSequel cenv eenv.cloc cgbuf sequel + +and GenGetUnionCaseFieldAddr cenv cgbuf eenv (e,ucref,tyargs,n,m) sequel = + assert (ucref.Tycon.IsStructOrEnumTycon || isProvenUnionCaseTy (tyOfExpr cenv.g e)); + + GenExpr cenv cgbuf eenv SPSuppress e Continue; + let cuspec,idx = GenUnionCaseSpec cenv.amap m cenv.g eenv.tyenv ucref tyargs + let fty = actualTypOfIlxUnionField cuspec idx n + let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef + CG.EmitInstrs cgbuf (pop 1) (Push [ILType.Byref fty]) (EraseUnions.mkLdDataAddr (avoidHelpers, cuspec, idx, n)); GenSequel cenv eenv.cloc cgbuf sequel and GenGetUnionCaseTag cenv cgbuf eenv (e,tcref,tyargs,m) sequel = GenExpr cenv cgbuf eenv SPSuppress e Continue; let cuspec = GenUnionSpec cenv.amap m cenv.g eenv.tyenv tcref tyargs let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib tcref - CG.EmitInstrs cgbuf (pop 1) (Push [cenv.g.ilg.typ_int32]) [ mkIlxInstr (EI_lddatatag(avoidHelpers, cuspec)) ]; + EraseUnions.emitLdDataTag cenv.g.ilg (UnionCodeGen cgbuf) (avoidHelpers, cuspec) + CG.EmitInstrs cgbuf (pop 1) (Push [cenv.g.ilg.typ_int32]) [ ] // push/pop to match the line above GenSequel cenv eenv.cloc cgbuf sequel and GenSetUnionCaseField cenv cgbuf eenv (e,ucref,tyargs,n,e2,m) sequel = GenExpr cenv cgbuf eenv SPSuppress e Continue; let cuspec,idx = GenUnionCaseSpec cenv.amap m cenv.g eenv.tyenv ucref tyargs - CG.EmitInstr cgbuf (pop 1) (Push [cuspec.EnclosingType]) (mkIlxInstr (EI_castdata(false,cuspec,idx))); + let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib ucref.TyconRef + EraseUnions.emitCastData cenv.g.ilg (UnionCodeGen cgbuf) (false,avoidHelpers,cuspec,idx) + CG.EmitInstrs cgbuf (pop 1) (Push [cuspec.EnclosingType]) [ ] // push/pop to match the line above GenExpr cenv cgbuf eenv SPSuppress e2 Continue; - CG.EmitInstr cgbuf (pop 2) Push0 (mkIlxInstr (EI_stdata(cuspec,idx,n)) ); + CG.EmitInstrs cgbuf (pop 2) Push0 (EraseUnions.mkStData (cuspec, idx, n)); GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel and GenGetRecdFieldAddr cenv cgbuf eenv (e,f,tyargs,m) sequel = @@ -2347,9 +2382,10 @@ and GenApp cenv cgbuf eenv (f,fty,tyargs,args,m) sequel = else ntmargs for i = ntmargs - 1 downto 0 do - CG.EmitInstrs cgbuf (pop 1) Push0 [ I_starg (uint16 (i+cgbuf.PreallocatedArgCount)) ]; - done; - CG.EmitInstrs cgbuf (pop 0) Push0 [ I_br (mark.CodeLabel) ]; + CG.EmitInstrs cgbuf (pop 1) Push0 [ I_starg (uint16 (i+cgbuf.PreallocatedArgCount)) ] + + CG.EmitInstrs cgbuf (pop 0) Push0 [ I_br mark.CodeLabel ] + GenSequelEndScopes cgbuf sequel // PhysicalEquality becomes cheap reference equality once @@ -2485,7 +2521,7 @@ and GenApp cenv cgbuf eenv (f,fty,tyargs,args,m) sequel = // Only save arguments that have effects if Optimizer.ExprHasEffect cenv.g laterArg then let ilTy = laterArg |> tyOfExpr cenv.g |> GenType cenv.amap m cenv.g eenv.tyenv - let loc,eenv = AllocLocal cenv cgbuf eenv true (ilxgenGlobalNng.FreshCompilerGeneratedName ("arg",m), ilTy) scopeMarks + let loc,eenv = AllocLocal cenv cgbuf eenv true (ilxgenGlobalNng.FreshCompilerGeneratedName ("arg",m), ilTy, false) scopeMarks GenExpr cenv cgbuf eenv SPSuppress laterArg Continue EmitSetLocal cgbuf loc Choice1Of2 (ilTy,loc),eenv @@ -2617,10 +2653,9 @@ and GenIndirectCall cenv cgbuf eenv (functy,tyargs,args,m) sequel = let isTailCall = CanTailcall(false,None,eenv.withinSEH,hasByrefArg,false,false,false,false,sequel) CountCallFuncInstructions(); - // Generate an ILX callfunc instruction - // REVIEW: ILX-to-IL generation of callfunc is too complex. It would probably be better - // if we just got rid of callfunc and generated the IL code directly in ilxgen. - CG.EmitInstr cgbuf (pop (1+args.Length)) (Push [ilActualRetTy]) (mkIlxInstr (EI_callfunc(isTailCall,ilxClosureApps))); + // Generate the code code an ILX callfunc operation + let instrs = EraseClosures.mkCallFunc cenv.g.ilxPubCloEnv (fun ty -> cgbuf.AllocLocal([], ty,false) |> uint16) eenv.tyenv.Count isTailCall ilxClosureApps + CG.EmitInstrs cgbuf (pop (1+args.Length)) (Push [ilActualRetTy]) instrs; // Done compiling indirect call... GenSequel cenv eenv.cloc cgbuf sequel @@ -2642,7 +2677,7 @@ and GenTry cenv cgbuf eenv scopeMarks (e1,m,resty,spTry) = let afterHandler = CG.GenerateDelayMark cgbuf "afterHandler" let eenvinner = {eenvinner with withinSEH = true} let ilResultTy = GenType cenv.amap m cenv.g eenvinner.tyenv resty - let whereToSave,eenvinner = AllocLocal cenv cgbuf eenvinner true (ilxgenGlobalNng.FreshCompilerGeneratedName ("tryres",m),ilResultTy) (startTryMark,endTryMark) + let whereToSave,eenvinner = AllocLocal cenv cgbuf eenvinner true (ilxgenGlobalNng.FreshCompilerGeneratedName ("tryres",m),ilResultTy, false) (startTryMark,endTryMark) // 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 @@ -2730,8 +2765,8 @@ and GenTryCatch cenv cgbuf eenv (e1,vf:Val,ef,vh:Val,eh,m,resty,spTry,spWith) se ILExceptionClause.TypeCatch(cenv.g.ilg.typ_Object, handlerMarks) cgbuf.EmitExceptionClause - { exnClauses = [ seh ]; - exnRange= tryMarks } ; + { Clause = seh; + Range= tryMarks } ; CG.SetMarkToHere cgbuf afterHandler; CG.SetStack cgbuf []; @@ -2766,16 +2801,16 @@ and GenTryFinally cenv cgbuf eenv (bodyExpr,handlerExpr,m,resty,spTry,spFinally) let endOfHandler = CG.GenerateMark cgbuf "endOfHandler" let handlerMarks = (startOfHandler.CodeLabel, endOfHandler.CodeLabel) cgbuf.EmitExceptionClause - { exnClauses = [ ILExceptionClause.Finally(handlerMarks) ]; - exnRange = tryMarks } ; + { Clause = ILExceptionClause.Finally(handlerMarks) + Range = tryMarks } - CG.SetMarkToHere cgbuf afterHandler; - CG.SetStack cgbuf []; + CG.SetMarkToHere cgbuf afterHandler + CG.SetStack cgbuf [] // Restore the stack and load the result - cgbuf.EmitStartOfHiddenCode(); - EmitRestoreStack cgbuf stack; - EmitGetLocal cgbuf ilResultTy whereToSave; + cgbuf.EmitStartOfHiddenCode() + EmitRestoreStack cgbuf stack + EmitGetLocal cgbuf ilResultTy whereToSave GenSequel cenv eenv.cloc cgbuf sequel ) @@ -2802,7 +2837,7 @@ and GenForLoop cenv cgbuf eenv (spFor,v,e1,dir,e2,loopBody,m) sequel = let finishIdx,eenvinner = if isFSharpStyle then - let v,eenvinner = AllocLocal cenv cgbuf eenvinner true (ilxgenGlobalNng.FreshCompilerGeneratedName ("endLoop",m), cenv.g.ilg.typ_int32) (start,finish) + let v,eenvinner = AllocLocal cenv cgbuf eenvinner true (ilxgenGlobalNng.FreshCompilerGeneratedName ("endLoop",m), cenv.g.ilg.typ_int32, false) (start,finish) v, eenvinner else -1,eenvinner @@ -2819,7 +2854,7 @@ and GenForLoop cenv cgbuf eenv (spFor,v,e1,dir,e2,loopBody,m) sequel = EmitSetLocal cgbuf finishIdx EmitGetLocal cgbuf cenv.g.ilg.typ_int32 finishIdx GenGetLocalVal cenv cgbuf eenvinner e2.Range v None; - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp ((if isUp then BI_blt else BI_bgt),finish.CodeLabel,inner.CodeLabel)); + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp ((if isUp then BI_blt else BI_bgt),finish.CodeLabel)); else CG.EmitInstr cgbuf (pop 0) Push0 (I_br test.CodeLabel); @@ -2844,7 +2879,7 @@ and GenForLoop cenv cgbuf eenv (spFor,v,e1,dir,e2,loopBody,m) sequel = CG.EmitSeqPoint cgbuf e2.Range; GenGetLocalVal cenv cgbuf eenvinner e2.Range v None; let cmp = match dir with FSharpForLoopUp | FSharpForLoopDown -> BI_bne_un | CSharpForLoopUp -> BI_blt - let e2Sequel = (CmpThenBrOrContinue (pop 2, I_brcmp(cmp,inner.CodeLabel,finish.CodeLabel))); + let e2Sequel = (CmpThenBrOrContinue (pop 2, [ I_brcmp(cmp,inner.CodeLabel) ])); if isFSharpStyle then EmitGetLocal cgbuf cenv.g.ilg.typ_int32 finishIdx @@ -2867,7 +2902,6 @@ and GenForLoop cenv cgbuf eenv (spFor,v,e1,dir,e2,loopBody,m) sequel = and GenWhileLoop cenv cgbuf eenv (spWhile,e1,e2,m) sequel = let finish = CG.GenerateDelayMark cgbuf "while_finish" - let inner = CG.GenerateDelayMark cgbuf "while_inner" let startTest = CG.GenerateMark cgbuf "startTest" match spWhile with @@ -2875,8 +2909,7 @@ and GenWhileLoop cenv cgbuf eenv (spWhile,e1,e2,m) sequel = | NoSequencePointAtWhileLoop -> () // SEQUENCE POINTS: Emit a sequence point to cover all of 'while e do' - GenExpr cenv cgbuf eenv SPSuppress e1 (CmpThenBrOrContinue (pop 1, I_brcmp(BI_brfalse,finish.CodeLabel,inner.CodeLabel))); - CG.SetMarkToHere cgbuf inner; + GenExpr cenv cgbuf eenv SPSuppress e1 (CmpThenBrOrContinue (pop 1, [ I_brcmp(BI_brfalse,finish.CodeLabel) ])); GenExpr cenv cgbuf eenv SPAlways e2 (DiscardThen (Br startTest)); CG.SetMarkToHere cgbuf finish; @@ -2949,16 +2982,10 @@ and GenAsmCode cenv cgbuf eenv (il,tyargs,args,returnTys,m) sequel = | I_ldsfld (vol,fspec) ,_ -> I_ldsfld (vol,modFieldSpec fspec) | I_ldsflda (fspec) ,_ -> I_ldsflda (modFieldSpec fspec) | EI_ilzero(ILType.TypeVar _) ,[tyarg] -> EI_ilzero(tyarg) - | I_other e,_ when isIlxExtInstr e -> - begin match (destIlxExtInstr e),ilTyArgs with - | _ -> - if not (isNil tyargs) then err "Bad polymorphic ILX instruction"; - i - end | AI_nop,_ -> i - (* These are embedded in the IL for a an initonly ldfld, i.e. *) - (* here's the relevant comment from tc.fs *) - (* "Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr." *) + // These are embedded in the IL for a an initonly ldfld, i.e. + // here's the relevant comment from tc.fs + // "Add an I_nop if this is an initonly field to make sure we never recognize it as an lvalue. See mkExprAddrOfExpr." | _ -> if not (isNil tyargs) then err "Bad polymorphic IL instruction"; @@ -2977,11 +3004,11 @@ and GenAsmCode cenv cgbuf eenv (il,tyargs,args,returnTys,m) sequel = // For these we can just generate the argument and change the test (from a brfalse to a brtrue and vice versa) | ([ AI_ceq ], [arg1; Expr.Const((Const.Bool false | Const.SByte 0y| Const.Int16 0s | Const.Int32 0 | Const.Int64 0L | Const.Byte 0uy| Const.UInt16 0us | Const.UInt32 0u | Const.UInt64 0UL),_,_) ], - CmpThenBrOrContinue(1,I_brcmp (((BI_brfalse | BI_brtrue) as bi) , label1,label2)), + CmpThenBrOrContinue(1, [I_brcmp (((BI_brfalse | BI_brtrue) as bi),label1) ]), _) -> let bi = match bi with BI_brtrue -> BI_brfalse | _ -> BI_brtrue - GenExpr cenv cgbuf eenv SPSuppress arg1 (CmpThenBrOrContinue(pop 1,I_brcmp (bi, label1,label2))) + GenExpr cenv cgbuf eenv SPSuppress arg1 (CmpThenBrOrContinue(pop 1, [ I_brcmp (bi,label1) ])) // Query; when do we get a 'ret' in IL assembly code? | [ I_ret ], [arg1],sequel,[_ilRetTy] -> @@ -3011,8 +3038,7 @@ and GenAsmCode cenv cgbuf eenv (il,tyargs,args,returnTys,m) sequel = let after1 = CG.GenerateDelayMark cgbuf ("fake_join") let after2 = CG.GenerateDelayMark cgbuf ("fake_join") let after3 = CG.GenerateDelayMark cgbuf ("fake_join") - CG.EmitInstrs cgbuf (pop 0) Push0 [mkLdcInt32 0; - I_brcmp (BI_brfalse,after2.CodeLabel,after1.CodeLabel); ]; + CG.EmitInstrs cgbuf (pop 0) Push0 [mkLdcInt32 0; I_brcmp (BI_brfalse,after2.CodeLabel); ]; CG.SetMarkToHere cgbuf after1; CG.EmitInstrs cgbuf (pop 0) (Push [ilRetTy]) [AI_ldnull; I_unbox_any ilRetTy; I_br after3.CodeLabel ]; @@ -3033,29 +3059,29 @@ and GenAsmCode cenv cgbuf eenv (il,tyargs,args,returnTys,m) sequel = // NOTE: THESE ARE NOT VALID ON FLOATING POINT DUE TO NaN. Hence INLINE ASM ON FP. MUST BE CAREFULLY WRITTEN - | [ AI_clt ], CmpThenBrOrContinue(1,I_brcmp (BI_brfalse, label1,label2)) when not (anyfpType (tyOfExpr g args.Head)) -> - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bge,label1,label2)); - | [ AI_cgt ], CmpThenBrOrContinue(1,I_brcmp (BI_brfalse, label1,label2)) when not (anyfpType (tyOfExpr g args.Head)) -> - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_ble,label1, label2)); - | [ AI_clt_un ], CmpThenBrOrContinue(1,I_brcmp (BI_brfalse, label1,label2)) when not (anyfpType (tyOfExpr g args.Head)) -> - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bge_un,label1,label2)); - | [ AI_cgt_un ], CmpThenBrOrContinue(1,I_brcmp (BI_brfalse, label1,label2)) when not (anyfpType (tyOfExpr g args.Head)) -> - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_ble_un,label1, label2)); - | [ AI_ceq ], CmpThenBrOrContinue(1,I_brcmp (BI_brfalse, label1,label2)) when not (anyfpType (tyOfExpr g args.Head)) -> - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bne_un,label1, label2)); + | [ AI_clt ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brfalse, label1) ]) when not (anyfpType (tyOfExpr g args.Head)) -> + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bge,label1)); + | [ AI_cgt ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brfalse, label1) ]) when not (anyfpType (tyOfExpr g args.Head)) -> + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_ble,label1)); + | [ AI_clt_un ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brfalse, label1) ]) when not (anyfpType (tyOfExpr g args.Head)) -> + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bge_un,label1)); + | [ AI_cgt_un ], CmpThenBrOrContinue(1, [I_brcmp (BI_brfalse, label1) ]) when not (anyfpType (tyOfExpr g args.Head)) -> + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_ble_un,label1)); + | [ AI_ceq ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brfalse, label1) ]) when not (anyfpType (tyOfExpr g args.Head)) -> + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bne_un,label1)); // THESE ARE VALID ON FP w.r.t. NaN - | [ AI_clt ], CmpThenBrOrContinue(1,I_brcmp (BI_brtrue, label1,label2)) -> - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_blt,label1, label2)); - | [ AI_cgt ], CmpThenBrOrContinue(1,I_brcmp (BI_brtrue, label1,label2)) -> - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bgt,label1, label2)); - | [ AI_clt_un ], CmpThenBrOrContinue(1,I_brcmp (BI_brtrue, label1,label2)) -> - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_blt_un,label1, label2)); - | [ AI_cgt_un ], CmpThenBrOrContinue(1,I_brcmp (BI_brtrue, label1,label2)) -> - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bgt_un,label1, label2)); - | [ AI_ceq ], CmpThenBrOrContinue(1,I_brcmp (BI_brtrue, label1,label2)) -> - CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_beq,label1, label2)); + | [ AI_clt ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brtrue, label1) ]) -> + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_blt,label1)); + | [ AI_cgt ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brtrue, label1) ]) -> + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bgt,label1)); + | [ AI_clt_un ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brtrue, label1) ]) -> + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_blt_un,label1)); + | [ AI_cgt_un ], CmpThenBrOrContinue(1,[ I_brcmp (BI_brtrue, label1) ]) -> + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_bgt_un,label1)); + | [ AI_ceq ], CmpThenBrOrContinue(1, [ I_brcmp (BI_brtrue, label1) ]) -> + CG.EmitInstr cgbuf (pop 2) Push0 (I_brcmp(BI_beq,label1)); | _ -> // Failing that, generate the real IL leaving value(s) on the stack CG.EmitInstrs cgbuf (pop args.Length) (Push ilReturnTys) ilAfterInst; @@ -3244,7 +3270,7 @@ and GenDefaultValue cenv cgbuf eenv (ty,m) = | _ -> let ilTy = GenType cenv.amap m cenv.g eenv.tyenv ty LocalScope "ilzero" cgbuf (fun scopeMarks -> - let locIdx, _ = AllocLocal cenv cgbuf eenv true (ilxgenGlobalNng.FreshCompilerGeneratedName ("default",m), ilTy) scopeMarks + let locIdx, _ = AllocLocal cenv cgbuf eenv true (ilxgenGlobalNng.FreshCompilerGeneratedName ("default",m), ilTy, false) scopeMarks // "initobj" (Generated by EmitInitLocal) doesn't work on byref types // But ilzero(&ty) only gets generated in the built-in get-address function so // we can just rely on zeroinit of all IL locals. @@ -3295,7 +3321,7 @@ and GenGenericParam cenv eenv (tp:Typar) = // Generate object expressions as ILX "closures" //-------------------------------------------------------------------------- -and GenSlotParam m cenv eenv (TSlotParam(nm,ty,inFlag,outFlag,optionalFlag,attribs)) = +and GenSlotParam m cenv eenv (TSlotParam(nm,ty,inFlag,outFlag,optionalFlag,attribs)) : ILParameter = let inFlag2,outFlag2,optionalFlag2,paramMarshal2,attribs = GenParamAttribs cenv attribs { Name=nm; @@ -3450,9 +3476,10 @@ and GenObjectExpr cenv cgbuf eenvouter expr (baseType,baseValOpt,basecall,overri let attrs = GenAttrs cenv eenvinner cloAttribs let super = (if isInterfaceTy cenv.g baseType then cenv.g.ilg.typ_Object else ilCloRetTy) let interfaceTys = interfaceTys @ (if isInterfaceTy cenv.g baseType then [ilCloRetTy] else []) - let cloTypeDef = GenClosureTypeDef cenv (ilCloTypeRef,ilCloGenericFormals,attrs,ilCloFreeVars,ilCloLambdas,ilCtorBody,mdefs,mimpls,super,interfaceTys) + let cloTypeDefs = GenClosureTypeDefs cenv (ilCloTypeRef,ilCloGenericFormals,attrs,ilCloFreeVars,ilCloLambdas,ilCtorBody,mdefs,mimpls,super,interfaceTys) - cgbuf.mgbuf.AddTypeDef(ilCloTypeRef, cloTypeDef, false, false); + for cloTypeDef in cloTypeDefs do + cgbuf.mgbuf.AddTypeDef(ilCloTypeRef, cloTypeDef, false, false, None); CountClosure(); GenGetLocalVals cenv cgbuf eenvouter m cloFreeVars; CG.EmitInstr cgbuf (pop ilCloFreeVars.Length) (Push [ EraseClosures.mkTyOfLambdas cenv.g.ilxPubCloEnv ilCloLambdas]) (I_newobj (ilxCloSpec.Constructor,None)); @@ -3533,8 +3560,9 @@ and GenSequenceExpr cenv (cgbuf:CodeGenBuffer) eenvouter (nextEnumeratorValRef:V mkILSimpleStorageCtor(None, Some ilCloBaseTy.TypeSpec, ilCloTyInner, [], ILMemberAccess.Assembly).MethodBody let attrs = GenAttrs cenv eenvinner cloAttribs - let clo = GenClosureTypeDef cenv (ilCloTypeRef,ilCloGenericParams,attrs,ilCloFreeVars,ilCloLambdas,ilCtorBody,[generateNextMethod;closeMethod;checkCloseMethod;lastGeneratedMethod;getFreshMethod],[],ilCloBaseTy,[]) - cgbuf.mgbuf.AddTypeDef(ilCloTypeRef, clo, false, false); + let cloTypeDefs = GenClosureTypeDefs cenv (ilCloTypeRef,ilCloGenericParams,attrs,ilCloFreeVars,ilCloLambdas,ilCtorBody,[generateNextMethod;closeMethod;checkCloseMethod;lastGeneratedMethod;getFreshMethod],[],ilCloBaseTy,[]) + for cloTypeDef in cloTypeDefs do + cgbuf.mgbuf.AddTypeDef(ilCloTypeRef, cloTypeDef, false, false, None); CountClosure(); for fv in cloFreeVars do @@ -3550,8 +3578,15 @@ and GenSequenceExpr cenv (cgbuf:CodeGenBuffer) eenvouter (nextEnumeratorValRef:V /// Generate the class for a closure type definition -and GenClosureTypeDef cenv (tref:ILTypeRef, ilGenParams, attrs, ilCloFreeVars, ilCloLambdas, ilCtorBody, mdefs, mimpls,ext, ilIntfTys) = +and GenClosureTypeDefs cenv (tref:ILTypeRef, ilGenParams, attrs, ilCloFreeVars, ilCloLambdas, ilCtorBody, mdefs, mimpls,ext, ilIntfTys) = + let cloInfo = + { cloSource=None + cloFreeVars=ilCloFreeVars + cloStructure=ilCloLambdas + cloCode=notlazy ilCtorBody } + + let td = { Name = tref.Name; Layout = ILTypeDefLayout.Auto; Access = ComputeTypeAccess tref true; @@ -3561,10 +3596,7 @@ and GenClosureTypeDef cenv (tref:ILTypeRef, ilGenParams, attrs, ilCloFreeVars, i InitSemantics=ILTypeInit.BeforeField; IsSealed=true; IsAbstract=false; - tdKind=mkIlxTypeDefKind (IlxTypeDefKind.Closure { cloSource=None; - cloFreeVars=ilCloFreeVars; - cloStructure=ilCloLambdas; - cloCode=notlazy ilCtorBody }); + tdKind=ILTypeDefKind.Class; Events= emptyILEvents; Properties = emptyILProperties; Methods= mkILMethods mdefs; @@ -3579,6 +3611,8 @@ and GenClosureTypeDef cenv (tref:ILTypeRef, ilGenParams, attrs, ilCloFreeVars, i SecurityDecls= emptyILSecurityDecls; HasSecurity=false; } + let tdefs = EraseClosures.convIlxClosureDef cenv.g.ilxPubCloEnv tref.Enclosing td cloInfo + tdefs and GenGenericParams cenv eenv tps = tps |> DropErasedTypars |> List.map (GenGenericParam cenv eenv) and GenGenericArgs m (tyenv:TypeReprEnv) tps = tps |> DropErasedTypars |> List.map (fun c -> (mkILTyvarTy tyenv.[c,m])) @@ -3597,7 +3631,7 @@ and GenLambdaClosure cenv (cgbuf:CodeGenBuffer) eenv isLocalTypeFunc selfv expr | _ -> [] let ilCloBody = CodeGenMethodForExpr cenv cgbuf.mgbuf (SPAlways,entryPointInfo,cloinfo.cloName,eenvinner,1,0,body,Return) let ilCloTypeRef = cloinfo.cloSpec.TypeRef - let clo = + let cloTypeDefs = if isLocalTypeFunc then // Work out the contract type and generate a class with an abstract method for this type @@ -3632,17 +3666,18 @@ and GenLambdaClosure cenv (cgbuf:CodeGenBuffer) eenv isLocalTypeFunc selfv expr Extends= Some cenv.g.ilg.typ_Object; SecurityDecls= emptyILSecurityDecls; HasSecurity=false; } - cgbuf.mgbuf.AddTypeDef(ilContractTypeRef, ilContractTypeDef, false, false); + cgbuf.mgbuf.AddTypeDef(ilContractTypeRef, ilContractTypeDef, false, false, None); let ilCtorBody = mkILMethodBody (true,emptyILLocals,8,nonBranchingInstrsToCode (mkCallBaseConstructor(ilContractTy,[])), None ) let cloMethods = [ mkILGenericVirtualMethod("DirectInvoke",ILMemberAccess.Assembly,cloinfo.localTypeFuncDirectILGenericParams,[],mkILReturn (cloinfo.cloILFormalRetTy), MethodBody.IL ilCloBody) ] - let cloTypeDef = GenClosureTypeDef cenv (ilCloTypeRef,cloinfo.cloILGenericParams,[],cloinfo.cloILFreeVars,cloinfo.ilCloLambdas,ilCtorBody,cloMethods,[],ilContractTy,[]) - cloTypeDef + let cloTypeDefs = GenClosureTypeDefs cenv (ilCloTypeRef,cloinfo.cloILGenericParams,[],cloinfo.cloILFreeVars,cloinfo.ilCloLambdas,ilCtorBody,cloMethods,[],ilContractTy,[]) + cloTypeDefs else - GenClosureTypeDef cenv (ilCloTypeRef,cloinfo.cloILGenericParams,[],cloinfo.cloILFreeVars,cloinfo.ilCloLambdas,ilCloBody,[],[],cenv.g.ilg.typ_Object,[]) + GenClosureTypeDefs cenv (ilCloTypeRef,cloinfo.cloILGenericParams,[],cloinfo.cloILFreeVars,cloinfo.ilCloLambdas,ilCloBody,[],[],cenv.g.ilg.typ_Object,[]) CountClosure(); - cgbuf.mgbuf.AddTypeDef(ilCloTypeRef, clo, false, false); + for cloTypeDef in cloTypeDefs do + cgbuf.mgbuf.AddTypeDef(ilCloTypeRef, cloTypeDef, false, false, None); cloinfo,m | _ -> failwith "GenLambda: not a lambda" @@ -3976,8 +4011,9 @@ and GenDelegateExpr cenv cgbuf eenvouter expr (TObjExprMethod((TSlotSig(_,delega let ilCloLambdas = Lambdas_return ilCtxtDelTy let ilAttribs = GenAttrs cenv eenvinner cloAttribs - let clo = GenClosureTypeDef cenv (ilDelegeeTypeRef,ilDelegeeGenericParams,ilAttribs,ilCloFreeVars,ilCloLambdas,ilCtorBody,[delegeeInvokeMeth],[],cenv.g.ilg.typ_Object,[]) - cgbuf.mgbuf.AddTypeDef(ilDelegeeTypeRef, clo, false, false); + let cloTypeDefs = GenClosureTypeDefs cenv (ilDelegeeTypeRef,ilDelegeeGenericParams,ilAttribs,ilCloFreeVars,ilCloLambdas,ilCtorBody,[delegeeInvokeMeth],[],cenv.g.ilg.typ_Object,[]) + for cloTypeDef in cloTypeDefs do + cgbuf.mgbuf.AddTypeDef(ilDelegeeTypeRef, cloTypeDef, false, false, None); CountClosure(); let ctxtGenericArgsForDelegee = GenGenericArgs m eenvouter.tyenv cloFreeTyvars @@ -4106,7 +4142,7 @@ and GenMatch cenv cgbuf eenv (spBind,_exprm,tree,targets,m,ty) sequel = // Accumulate the decision graph as we go and GenDecisionTreeAndTargets cenv cgbuf stackAtTargets eenv tree targets repeatSP sequel = - let targetInfos = GenDecisionTreeAndTargetsInner cenv cgbuf (CG.GenerateDelayMark cgbuf "start_dtree") stackAtTargets eenv tree targets repeatSP (IntMap.empty()) sequel + let targetInfos = GenDecisionTreeAndTargetsInner cenv cgbuf None stackAtTargets eenv tree targets repeatSP (IntMap.empty()) sequel GenPostponedDecisionTreeTargets cenv cgbuf stackAtTargets targetInfos sequel and TryFindTargetInfo targetInfos n = @@ -4114,11 +4150,15 @@ and TryFindTargetInfo targetInfos n = | Some (targetInfo,_) -> Some targetInfo | None -> None -and GenDecisionTreeAndTargetsInner cenv cgbuf inplab stackAtTargets eenv tree targets repeatSP targetInfos sequel = +/// When inplabOpt is None, we are assuming a branch or fallthrough to the current code location +/// +/// When inplabOpt is "Some inplab", we are assuming an existing branch to "inplab" and can optionally +/// set inplab to point to another location if no codegen is required. +and GenDecisionTreeAndTargetsInner cenv cgbuf inplabOpt stackAtTargets eenv tree targets repeatSP targetInfos sequel = CG.SetStack cgbuf stackAtTargets; // Set the expected initial stack. match tree with | TDBind(bind,rest) -> - CG.SetMarkToHere cgbuf inplab; + match inplabOpt with Some inplab -> CG.SetMarkToHere cgbuf inplab | None -> () let startScope,endScope as scopeMarks = StartDelayedLocalScope "dtreeBind" cgbuf let eenv = AllocStorageForBind cenv cgbuf scopeMarks eenv bind let sp = GenSequencePointForBind cenv cgbuf eenv bind @@ -4128,32 +4168,32 @@ and GenDecisionTreeAndTargetsInner cenv cgbuf inplab stackAtTargets eenv tree ta // 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. CG.SetMarkToHere cgbuf endScope; - let bodyLabel = CG.GenerateDelayMark cgbuf "decisionTreeBindBody" - CG.EmitInstr cgbuf (pop 0) Push0 (I_br bodyLabel.CodeLabel); - GenDecisionTreeAndTargetsInner cenv cgbuf bodyLabel stackAtTargets eenv rest targets repeatSP targetInfos sequel + GenDecisionTreeAndTargetsInner cenv cgbuf None stackAtTargets eenv rest targets repeatSP targetInfos sequel | TDSuccess (es,targetIdx) -> - GenDecisionTreeSuccess cenv cgbuf inplab stackAtTargets eenv es targetIdx targets repeatSP targetInfos sequel + GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx targets repeatSP targetInfos sequel | TDSwitch(e, cases, dflt,m) -> - GenDecisionTreeSwitch cenv cgbuf inplab stackAtTargets eenv e cases dflt m targets repeatSP targetInfos sequel + GenDecisionTreeSwitch cenv cgbuf inplabOpt stackAtTargets eenv e cases dflt m targets repeatSP targetInfos sequel and GetTarget (targets:_[]) n = if n >= targets.Length then failwith "GetTarget: target not found in decision tree"; targets.[n] -and GenDecisionTreeSuccess cenv cgbuf inplab stackAtTargets eenv es targetIdx targets repeatSP targetInfos sequel = +and GenDecisionTreeSuccess cenv cgbuf inplabOpt stackAtTargets eenv es targetIdx targets repeatSP targetInfos sequel = let (TTarget(vs,successExpr,spTarget)) = GetTarget targets targetIdx match TryFindTargetInfo targetInfos targetIdx with - | Some (_,targetMarkAfterBinds,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 // In this case each case will just go straight to "e" if FlatList.isEmpty vs then - CG.SetMark cgbuf inplab targetMarkAfterBinds; + match inplabOpt with + | None -> CG.EmitInstr cgbuf (pop 0) Push0 (I_br targetMarkAfterBinds.CodeLabel); + | Some inplab -> CG.SetMark cgbuf inplab targetMarkAfterBinds; else - CG.SetMarkToHere cgbuf inplab; + 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 @@ -4166,7 +4206,7 @@ and GenDecisionTreeSuccess cenv cgbuf inplab stackAtTargets eenv es targetIdx ta | None -> - CG.SetMarkToHere cgbuf inplab; + match inplabOpt with None -> () | Some inplab -> CG.SetMarkToHere cgbuf inplab; let targetMarkBeforeBinds = CG.GenerateDelayMark cgbuf "targetBeforeBinds" let targetMarkAfterBinds = CG.GenerateDelayMark cgbuf "targetAfterBinds" let startScope,endScope as scopeMarks = StartDelayedLocalScope "targetBinds" cgbuf @@ -4216,9 +4256,9 @@ and GenDecisionTreeTarget cenv cgbuf stackAtTargets _targetIdx (targetMarkBefore GenExpr cenv cgbuf eenvAtTarget spExpr successExpr (EndLocalScope(sequel,endScope)); -and GenDecisionTreeSwitch cenv cgbuf inplab stackAtTargets eenv e cases defaultTargetOpt switchm targets repeatSP targetInfos sequel = +and GenDecisionTreeSwitch cenv cgbuf inplabOpt stackAtTargets eenv e cases defaultTargetOpt switchm targets repeatSP targetInfos sequel = let m = e.Range - CG.SetMarkToHere cgbuf inplab; + match inplabOpt with None -> () | Some inplab -> CG.SetMarkToHere cgbuf inplab; repeatSP(); match cases with @@ -4227,24 +4267,25 @@ and GenDecisionTreeSwitch cenv cgbuf inplab stackAtTargets eenv e cases defaultT let failureTree = (match defaultTargetOpt with None -> cases.Tail.Head.CaseTree | Some d -> d) GenDecisionTreeTest cenv eenv.cloc cgbuf stackAtTargets e None eenv (if b then successTree else failureTree) (if b then failureTree else successTree) targets repeatSP targetInfos sequel - // optimize a single test for a type constructor to an "isdata" test - much + // // Remove a single test for a union case . Union case tests are always exa + //| [ TCase(Test.UnionCase _, successTree) ] when (defaultTargetOpt.IsNone) -> + // GenDecisionTreeAndTargetsInner cenv cgbuf inplabOpt stackAtTargets eenv successTree targets repeatSP targetInfos sequel + // //GenDecisionTree cenv eenv.cloc cgbuf stackAtTargets e (Some (pop 1, Push [cenv.g.ilg.typ_bool], Choice1Of2 (avoidHelpers, cuspec, idx))) eenv successTree failureTree targets repeatSP targetInfos sequel + + // Optimize a single test for a union case to an "isdata" test - much // more efficient code, and this case occurs in the generated equality testers where perf is important - | TCase(Test.UnionCase(c,tyargs), successTree) :: rest when List.length rest = (match defaultTargetOpt with None -> 1 | Some _ -> 0) -> + | TCase(Test.UnionCase(c,tyargs), successTree) :: rest when rest.Length = (match defaultTargetOpt with None -> 1 | Some _ -> 0) -> let failureTree = match defaultTargetOpt with - | None -> cases.Tail.Head.CaseTree + | None -> rest.Head.CaseTree | Some tg -> tg let cuspec = GenUnionSpec cenv.amap m cenv.g eenv.tyenv c.TyconRef tyargs let idx = c.Index let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib c.TyconRef - GenDecisionTreeTest cenv eenv.cloc cgbuf stackAtTargets e (Some (pop 1, Push [cenv.g.ilg.typ_bool],(mkIlxInstr (EI_isdata (avoidHelpers, cuspec, idx))))) eenv successTree failureTree targets repeatSP targetInfos sequel + GenDecisionTreeTest cenv eenv.cloc cgbuf stackAtTargets e (Some (pop 1, Push [cenv.g.ilg.typ_bool], Choice1Of2 (avoidHelpers, cuspec, idx))) eenv successTree failureTree targets repeatSP targetInfos sequel | _ -> let caseLabels = List.map (fun _ -> CG.GenerateDelayMark cgbuf "switch_case") cases - let defaultLabel = - match defaultTargetOpt with - | None -> List.head caseLabels - | Some _ -> CG.GenerateDelayMark cgbuf "switch_dflt" let firstDiscrim = cases.Head.Discriminator match firstDiscrim with // Iterated tests, e.g. exception constructors, nulltests, typetests and active patterns. @@ -4271,8 +4312,8 @@ and GenDecisionTreeSwitch cenv cgbuf inplab stackAtTargets eenv e cases defaultT GenExpr cenv cgbuf eenv SPSuppress e Continue; BI_brtrue | _ -> failwith "internal error: GenDecisionTreeSwitch" - CG.EmitInstr cgbuf (pop 1) Push0 (I_brcmp (bi,(List.head caseLabels).CodeLabel,defaultLabel.CodeLabel)); - GenDecisionTreeCases cenv cgbuf stackAtTargets eenv targets repeatSP targetInfos caseLabels cases defaultTargetOpt defaultLabel sequel + CG.EmitInstr cgbuf (pop 1) Push0 (I_brcmp (bi,(List.head caseLabels).CodeLabel)); + GenDecisionTreeCases cenv cgbuf stackAtTargets eenv targets repeatSP targetInfos defaultTargetOpt caseLabels cases sequel | Test.ActivePatternCase _ -> error(InternalError("internal error in codegen: Test.ActivePatternCase",switchm)) | Test.UnionCase (hdc,tyargs) -> @@ -4286,8 +4327,9 @@ and GenDecisionTreeSwitch cenv cgbuf inplab stackAtTargets eenv e cases defaultT | _ -> failwith "error: mixed constructor/const test?") let avoidHelpers = entityRefInThisAssembly cenv.g.compilingFslib hdc.TyconRef - CG.EmitInstr cgbuf (pop 1) Push0 (mkIlxInstr (EI_datacase (avoidHelpers,cuspec,dests, defaultLabel.CodeLabel))); - GenDecisionTreeCases cenv cgbuf stackAtTargets eenv targets repeatSP targetInfos caseLabels cases defaultTargetOpt defaultLabel sequel + EraseUnions.emitDataSwitch cenv.g.ilg (UnionCodeGen cgbuf) (avoidHelpers,cuspec,dests); + CG.EmitInstrs cgbuf (pop 1) Push0 [ ] // push/pop to match the line above + GenDecisionTreeCases cenv cgbuf stackAtTargets eenv targets repeatSP targetInfos defaultTargetOpt caseLabels cases sequel | Test.Const c -> GenExpr cenv cgbuf eenv SPSuppress e Continue; @@ -4327,23 +4369,23 @@ and GenDecisionTreeSwitch cenv cgbuf inplab stackAtTargets eenv e cases defaultT if mn <> 0 then CG.EmitInstrs cgbuf (pop 0) (Push [cenv.g.ilg.typ_int32]) [ mkLdcInt32 mn]; CG.EmitInstrs cgbuf (pop 1) Push0 [ AI_sub ]; - CG.EmitInstr cgbuf (pop 1) Push0 (I_switch (destinationLabels, defaultLabel.CodeLabel)); + CG.EmitInstr cgbuf (pop 1) Push0 (I_switch destinationLabels); else error(InternalError("non-dense integer matches not implemented in codegen - these should have been removed by the pattern match compiler",switchm)); - GenDecisionTreeCases cenv cgbuf stackAtTargets eenv targets repeatSP targetInfos caseLabels cases defaultTargetOpt defaultLabel sequel + GenDecisionTreeCases cenv cgbuf stackAtTargets eenv targets repeatSP targetInfos defaultTargetOpt caseLabels cases sequel | _ -> error(InternalError("these matches should never be needed",switchm)) -and GenDecisionTreeCases cenv cgbuf stackAtTargets eenv targets repeatSP targetInfos caseLabels cases defaultTargetOpt defaultLabel sequel = +and GenDecisionTreeCases cenv cgbuf stackAtTargets eenv targets repeatSP targetInfos defaultTargetOpt caseLabels cases sequel = assert(cgbuf.GetCurrentStack() = stackAtTargets); // cgbuf stack should be unchanged over tests. [bug://1750]. let targetInfos = match defaultTargetOpt with - | Some defaultTarget -> GenDecisionTreeAndTargetsInner cenv cgbuf defaultLabel stackAtTargets eenv defaultTarget targets repeatSP targetInfos sequel + | Some defaultTarget -> GenDecisionTreeAndTargetsInner cenv cgbuf None stackAtTargets eenv defaultTarget targets repeatSP targetInfos sequel | None -> targetInfos let targetInfos = (targetInfos, caseLabels, cases) |||> List.fold2 (fun targetInfos caseLabel (TCase(_,caseTree)) -> - GenDecisionTreeAndTargetsInner cenv cgbuf caseLabel stackAtTargets eenv caseTree targets repeatSP targetInfos sequel) + GenDecisionTreeAndTargetsInner cenv cgbuf (Some caseLabel) stackAtTargets eenv caseTree targets repeatSP targetInfos sequel) targetInfos // Used for the peephole optimization below @@ -4366,7 +4408,12 @@ and GenDecisionTreeTest cenv cloc cgbuf stackAtTargets e tester eenv successTree | TTarget(_,BoolExpr(b1),_),_ -> GenExpr cenv cgbuf eenv SPSuppress e Continue; - (match tester with Some (pops,push,i) -> CG.EmitInstr cgbuf pops push i; | _ -> ()); + match tester with + | Some (pops,pushes,i) -> + match i with + | Choice1Of2 (avoidHelpers,cuspec,idx) -> CG.EmitInstrs cgbuf pops pushes (EraseUnions.mkIsData cenv.g.ilg (avoidHelpers, cuspec, idx)) + | Choice2Of2 i -> CG.EmitInstr cgbuf pops pushes i; + | _ -> (); if not b1 then CG.EmitInstrs cgbuf (pop 0) (Push [cenv.g.ilg.typ_bool]) [mkLdcInt32 (0); ]; CG.EmitInstrs cgbuf (pop 1) Push0 [AI_ceq]; @@ -4376,26 +4423,26 @@ and GenDecisionTreeTest cenv cloc cgbuf stackAtTargets e tester eenv successTree | _ -> failwith "internal error: GenDecisionTreeTest during bool elim" | _ -> - let success = CG.GenerateDelayMark cgbuf "testSuccess" let failure = CG.GenerateDelayMark cgbuf "testFailure" - (match tester with + match tester with | None -> - (* generate the expression, then test it for "false" *) - GenExpr cenv cgbuf eenv SPSuppress e (CmpThenBrOrContinue(pop 1,I_brcmp (BI_brfalse, failure.CodeLabel, success.CodeLabel))); + // generate the expression, then test it for "false" + GenExpr cenv cgbuf eenv SPSuppress e (CmpThenBrOrContinue(pop 1, [ I_brcmp (BI_brfalse, failure.CodeLabel) ])); - (* Turn "EI_isdata" tests that branch into EI_brisdata tests *) - | Some (_,_,I_other i) when isIlxExtInstr i && (match destIlxExtInstr i with EI_isdata _ -> true | _ -> false) -> - let (avoidHelpers,cuspec,idx) = match destIlxExtInstr i with EI_isdata (avoidHelpers,cuspec,idx) -> (avoidHelpers,cuspec,idx) | _ -> failwith "??" - GenExpr cenv cgbuf eenv SPSuppress e (CmpThenBrOrContinue(pop 1,mkIlxInstr (EI_brisdata (avoidHelpers,cuspec, idx, success.CodeLabel, failure.CodeLabel)))); + // Turn 'isdata' tests that branch into EI_brisdata tests + | Some (_,_,Choice1Of2 (avoidHelpers,cuspec,idx)) -> + GenExpr cenv cgbuf eenv SPSuppress e (CmpThenBrOrContinue(pop 1, EraseUnions.mkBrIsNotData cenv.g.ilg (avoidHelpers,cuspec, idx, failure.CodeLabel))); | Some (pops,pushes,i) -> - GenExpr cenv cgbuf eenv SPSuppress e Continue; - CG.EmitInstr cgbuf pops pushes i; - CG.EmitInstr cgbuf (pop 1) Push0 (I_brcmp (BI_brfalse, failure.CodeLabel, success.CodeLabel))); + GenExpr cenv cgbuf eenv SPSuppress e Continue + match i with + | Choice1Of2 (avoidHelpers,cuspec,idx) -> CG.EmitInstrs cgbuf pops pushes (EraseUnions.mkIsData cenv.g.ilg (avoidHelpers, cuspec, idx)) + | Choice2Of2 i -> CG.EmitInstr cgbuf pops pushes i + CG.EmitInstr cgbuf (pop 1) Push0 (I_brcmp (BI_brfalse, failure.CodeLabel)) - let targetInfos = GenDecisionTreeAndTargetsInner cenv cgbuf success stackAtTargets eenv successTree targets repeatSP targetInfos sequel + let targetInfos = GenDecisionTreeAndTargetsInner cenv cgbuf None stackAtTargets eenv successTree targets repeatSP targetInfos sequel - GenDecisionTreeAndTargetsInner cenv cgbuf failure stackAtTargets eenv failureTree targets repeatSP targetInfos sequel + GenDecisionTreeAndTargetsInner cenv cgbuf (Some failure) stackAtTargets eenv failureTree targets repeatSP targetInfos sequel //------------------------------------------------------------------------- // Generate letrec bindings @@ -4844,7 +4891,7 @@ and GenParams cenv eenv (mspec:ILMethodSpec) (attribs:ArgReprInfo list) (implVal | None -> None, takenNames - let param = + let param : ILParameter = { Name=nmOpt; Type= ilArgTy; Default=None; (* REVIEW: support "default" attributes *) @@ -5366,14 +5413,14 @@ and GenStoreVal cgbuf eenv m (vspec:Val) = // Allocate locals for values //-------------------------------------------------------------------------- -and AllocLocal cenv cgbuf eenv compgen (v,ty) (scopeMarks: Mark * Mark) = +and AllocLocal cenv cgbuf eenv compgen (v,ty,isFixed) (scopeMarks: Mark * Mark) = // The debug range for the local let ranges = if compgen then [] else [(v,scopeMarks)] // Get an index for the local let j = if cenv.opts.localOptimizationsAreOn - then cgbuf.ReallocLocal((fun i (_,ty') -> not (IntMap.mem i eenv.liveLocals) && (ty = ty')),ranges,ty) - else cgbuf.AllocLocal(ranges,ty) + then cgbuf.ReallocLocal((fun i (_,ty',isFixed') -> not isFixed' && not isFixed && not (IntMap.mem i eenv.liveLocals) && (ty = ty')),ranges,ty,isFixed) + else cgbuf.AllocLocal(ranges,ty,isFixed) j, { eenv with liveLocals = IntMap.add j () eenv.liveLocals } and AllocLocalVal cenv cgbuf v eenv repr scopeMarks = @@ -5389,11 +5436,11 @@ and AllocLocalVal cenv cgbuf v eenv repr scopeMarks = let cloinfo,_,_ = GetIlxClosureInfo cenv v.Range true None eenvinner (Option.get repr) cloinfo - let idx,eenv = AllocLocal cenv cgbuf eenv v.IsCompilerGenerated (v.CompiledName, cenv.g.ilg.typ_Object) scopeMarks + let idx,eenv = AllocLocal cenv cgbuf eenv v.IsCompilerGenerated (v.CompiledName, cenv.g.ilg.typ_Object, false) scopeMarks Local (idx,Some(ref (NamedLocalIlxClosureInfoGenerator cloinfoGenerate))),eenv else (* normal local *) - let idx,eenv = AllocLocal cenv cgbuf eenv v.IsCompilerGenerated (v.CompiledName, GenTypeOfVal cenv eenv v) scopeMarks + let idx,eenv = AllocLocal cenv cgbuf eenv v.IsCompilerGenerated (v.CompiledName, GenTypeOfVal cenv eenv v, v.IsFixed) scopeMarks Local (idx,None),eenv let eenv = AddStorageForVal cenv.g (v,notlazy repr) eenv Some repr, eenv @@ -5463,7 +5510,7 @@ and AllocTopValWithinExpr cenv cgbuf cloc scopeMarks v eenv = /// - and because IL requires empty stack following a forward br (jump). and EmitSaveStack cenv cgbuf eenv m scopeMarks = let savedStack = (cgbuf.GetCurrentStack()) - let savedStackLocals,eenvinner = List.mapFold (fun eenv ty -> AllocLocal cenv cgbuf eenv true (ilxgenGlobalNng.FreshCompilerGeneratedName ("spill",m), ty) scopeMarks) eenv savedStack + let savedStackLocals,eenvinner = List.mapFold (fun eenv ty -> AllocLocal cenv cgbuf eenv true (ilxgenGlobalNng.FreshCompilerGeneratedName ("spill",m), ty, false) scopeMarks) eenv savedStack List.iter (EmitSetLocal cgbuf) savedStackLocals; cgbuf.AssertEmptyStack(); (savedStack,savedStackLocals),eenvinner (* need to return, it marks locals "live" *) @@ -5619,12 +5666,12 @@ and GenTypeDefForCompLoc (cenv, eenv, mgbuf: AssemblyBuilder, cloc, hidden, attr emptyILEvents, mkILCustomAttrs (GenAttrs cenv eenv attribs @ - (if List.mem tref.Name [TypeNameForImplicitMainMethod cloc; TypeNameForInitClass cloc; TypeNameForPrivateImplementationDetails cloc] + (if List.contains tref.Name [TypeNameForImplicitMainMethod cloc; TypeNameForInitClass cloc; TypeNameForPrivateImplementationDetails cloc] then [ (* mkCompilerGeneratedAttribute *) ] else [mkCompilationMappingAttr cenv.g (int SourceConstructFlags.Module)])), initTrigger) let tdef = { tdef with IsSealed=true; IsAbstract=true } - mgbuf.AddTypeDef(tref, tdef, eliminateIfEmpty, addAtEnd) + mgbuf.AddTypeDef(tref, tdef, eliminateIfEmpty, addAtEnd, None) and GenModuleExpr cenv cgbuf qname lazyInitInfo eenv x = @@ -5647,13 +5694,12 @@ and GenModuleDefs cenv cgbuf qname lazyInitInfo eenv mdefs = and GenModuleDef cenv (cgbuf:CodeGenBuffer) qname lazyInitInfo eenv x = match x with - | TMDefRec(tycons,binds,mbinds,m) -> + | TMDefRec(_isRec,tycons,mbinds,m) -> tycons |> List.iter (fun tc -> if tc.IsExceptionDecl then GenExnDef cenv cgbuf.mgbuf eenv m tc - else GenTypeDef cenv cgbuf.mgbuf lazyInitInfo eenv m tc) ; - GenLetRecBinds cenv cgbuf eenv (binds,m); - mbinds |> List.iter (GenModuleBinding cenv cgbuf qname lazyInitInfo eenv) + else GenTypeDef cenv cgbuf.mgbuf lazyInitInfo eenv m tc) + mbinds |> List.iter (GenModuleBinding cenv cgbuf qname lazyInitInfo eenv m) | TMDefLet(bind,_) -> GenBindings cenv cgbuf eenv (FlatList.one bind) @@ -5669,7 +5715,11 @@ and GenModuleDef cenv (cgbuf:CodeGenBuffer) qname lazyInitInfo eenv x = // Generate a module binding -and GenModuleBinding cenv (cgbuf:CodeGenBuffer) (qname:QualifiedNameOfFile) lazyInitInfo eenv (ModuleOrNamespaceBinding (mspec, mdef)) = +and GenModuleBinding cenv (cgbuf:CodeGenBuffer) (qname:QualifiedNameOfFile) lazyInitInfo eenv m x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> + GenLetRecBinds cenv cgbuf eenv ([bind],m); + | ModuleOrNamespaceBinding.Module (mspec, mdef) -> let hidden = IsHiddenTycon eenv.sigToImplRemapInfo mspec let eenvinner = @@ -5963,8 +6013,8 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = | TProvidedTypeExtensionPoint _ -> () #endif | TNoRepr -> () - | TAsmRepr _ | TILObjModelRepr _ | TMeasureableRepr _ -> () - | TFsObjModelRepr _ | TRecdRepr _ | TFiniteUnionRepr _ -> + | TAsmRepr _ | TILObjectRepr _ | TMeasureableRepr _ -> () + | TFSharpObjectRepr _ | TRecdRepr _ | TUnionRepr _ -> let eenvinner = ReplaceTyenv (TypeReprEnv.ForTycon tycon) eenv let thisTy = generalizedTyconRef tcref @@ -5978,16 +6028,16 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let hiddenRepr = hidden || IsHiddenTyconRepr eenv.sigToImplRemapInfo tycon let access = ComputeTypeAccess tref hidden + // The implicit augmentation doesn't actually create CompareTo(object) or Object.Equals + // So we do it here. + // + // Note you only have to implement 'System.IComparable' to customize structural comparison AND equality on F# types + // See also FinalTypeDefinitionChecksAtEndOfInferenceScope in tc.fs + // + // Generate an Equals method implemented via IComparable if the type EXPLICITLY implements IComparable. + // HOWEVER, if the type doesn't override Object.Equals already. let augmentOverrideMethodDefs = - // The implicit augmentation doesn't actually create CompareTo(object) or Object.Equals - // So we do it here. - let specialCompareMethod = - // Note you only have to implement 'System.IComparable' to customize structural comparison AND equality on F# types - // See also FinalTypeDefinitionChecksAtEndOfInferenceScope in tc.fs - - // Generate an Equals method implemented via IComparable if the type EXPLICITLY implements IComparable. - // HOWEVER, if the type doesn't override Object.Equals already. (if isNone tycon.GeneratedCompareToValues && isNone tycon.GeneratedHashAndEqualsValues && tycon.HasInterface cenv.g cenv.g.mk_IComparable_ty && @@ -5997,11 +6047,6 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = [ GenEqualsOverrideCallingIComparable cenv (tcref,ilThisTy,ilThisTy) ] else []) - specialCompareMethod - // We can't reduce the accessibility because these implement virtual slots - (* |> List.map (fun md -> { md with Access=memberAccess }) *) - - // Generate the interface slots and abstract slots. let abstractMethodDefs,abstractPropDefs, abstractEventDefs = if tycon.IsFSharpDelegateTycon then @@ -6047,6 +6092,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = | _ -> () ] + // Try to add a DefaultMemberAttribute for the 'Item' property let defaultMemberAttrs = // REVIEW: this should be based off tcaug_adhoc_list, which is in declaration order tycon.MembersOfFSharpTyconSorted @@ -6079,7 +6125,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = yield cenv.g.ilg.mkDebuggerDisplayAttribute ("{" + debugDisplayMethodName + "(),nq}") ] - let CustomAttrs = + let ilCustomAttrs = [ yield! defaultMemberAttrs yield! normalAttrs |> List.filter (IsMatchingFSharpAttribute cenv.g cenv.g.attrib_StructLayoutAttribute >> not) @@ -6091,14 +6137,14 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let ilTypeDefKind = match tyconRepr with - | TFsObjModelRepr o -> + | TFSharpObjectRepr o -> match o.fsobjmodel_kind with | TTyconClass -> ILTypeDefKind.Class | TTyconStruct -> ILTypeDefKind.ValueType | TTyconInterface -> ILTypeDefKind.Interface | TTyconEnum -> ILTypeDefKind.Enum | TTyconDelegate _ -> ILTypeDefKind.Delegate - + | TRecdRepr _ | TUnionRepr _ when tycon.IsStructOrEnumTycon -> ILTypeDefKind.ValueType | _ -> ILTypeDefKind.Class let requiresExtraField = @@ -6260,20 +6306,23 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = // Instantiate with our own type let sprintfMethSpec = mkILMethSpec(sprintfMethSpec.MethodRef,AsObject,[],[funcTy]) // Here's the body of the method. Call printf, then invoke the function it returns + let callInstrs = EraseClosures.mkCallFunc cenv.g.ilxPubCloEnv (fun _ -> 0us) eenv.tyenv.Count Normalcall (Apps_app(ilThisTy, Apps_done cenv.g.ilg.typ_String)) let ilMethodDef = mkILNonGenericInstanceMethod (debugDisplayMethodName,ILMemberAccess.Assembly,[], mkILReturn cenv.g.ilg.typ_Object, mkMethodBody (true,emptyILLocals,2, nonBranchingInstrsToCode - [ // load the hardwired format string - I_ldstr "%+0.8A"; + ([ // load the hardwired format string + yield I_ldstr "%+0.8A"; // make the printf format object - mkNormalNewobj newFormatMethSpec; + yield mkNormalNewobj newFormatMethSpec; // call sprintf - mkNormalCall sprintfMethSpec; + yield mkNormalCall sprintfMethSpec; // call the function returned by sprintf - mkLdarg0; - mkIlxInstr (EI_callfunc(Normalcall,Apps_app(ilThisTy, Apps_done cenv.g.ilg.typ_String))) ], + yield mkLdarg0 + if ilThisTy.Boxity = ILBoxity.AsValue then + yield mkNormalLdobj ilThisTy ] @ + callInstrs), None)) yield ilMethodDef |> AddSpecialNameFlag |> AddNonUserCompilerGeneratedAttribs cenv.g | None,_ -> @@ -6300,15 +6349,20 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = relevantFields |> List.map (fun (_,ilFieldName,_,_,_,ilPropType,_,fspec) -> (fspec.Name,ilFieldName,ilPropType)) - let ilMethodDef = mkILSimpleStorageCtorWithParamNames(None, Some cenv.g.ilg.tspec_Object, ilThisTy, ChooseParamNames fieldNamesAndTypes, reprAccess) + let isStructRecord = tycon.IsStructRecordOrUnionTycon + + // No type spec if the record is a value type + let spec = if isStructRecord then None else Some(cenv.g.ilg.tspec_Object) + let ilMethodDef = mkILSimpleStorageCtorWithParamNames(None, spec, ilThisTy, ChooseParamNames fieldNamesAndTypes, reprAccess) yield ilMethodDef // FSharp 1.0 bug 1988: Explicitly setting the ComVisible(true) attribute on an F# type causes an F# record to be emitted in a way that enables mutation for COM interop scenarios // FSharp 3.0 feature: adding CLIMutable to a record type causes emit of default constructor, and all fields get property setters - if isCLIMutable || (TryFindFSharpBoolAttribute cenv.g cenv.g.attrib_ComVisibleAttribute tycon.Attribs = Some true) then + // Records that are value types do not create a default constructor with CLIMutable or ComVisible + if not isStructRecord && (isCLIMutable || (TryFindFSharpBoolAttribute cenv.g cenv.g.attrib_ComVisibleAttribute tycon.Attribs = Some true)) then yield mkILSimpleStorageCtor(None, Some cenv.g.ilg.tspec_Object, ilThisTy, [], reprAccess) - | TFsObjModelRepr r when tycon.IsFSharpDelegateTycon -> + | TFSharpObjectRepr r when tycon.IsFSharpDelegateTycon -> // Build all the methods that go with a delegate type match r.fsobjmodel_kind with @@ -6334,24 +6388,24 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let ilEvents = mkILEvents abstractEventDefs let ilFields = mkILFields ilFieldDefs - let tdef = - let IsSerializable = (TryFindFSharpBoolAttribute cenv.g cenv.g.attrib_AutoSerializableAttribute tycon.Attribs <> Some(false)) + let tdef, tdefDiscards = + let isSerializable = (TryFindFSharpBoolAttribute cenv.g cenv.g.attrib_AutoSerializableAttribute tycon.Attribs <> Some(false)) && cenv.opts.netFxHasSerializableAttribute match tycon.TypeReprInfo with - | TILObjModelRepr (_,_,td) -> - {td with Access = access; - CustomAttrs = mkILCustomAttrs CustomAttrs; - GenericParams = ilGenParams; } + | TILObjectRepr (_,_,td) -> + {td with Access = access + CustomAttrs = mkILCustomAttrs ilCustomAttrs + GenericParams = ilGenParams }, None - | TRecdRepr _ | TFsObjModelRepr _ as tyconRepr -> + | TRecdRepr _ | TFSharpObjectRepr _ as tyconRepr -> let super = superOfTycon cenv.g tycon let ilBaseTy = GenType cenv.amap m cenv.g eenvinner.tyenv super // Build a basic type definition - let isObjectType = (match tyconRepr with TFsObjModelRepr _ -> true | _ -> false) + let isObjectType = (match tyconRepr with TFSharpObjectRepr _ -> true | _ -> false) let ilAttrs = - CustomAttrs @ + ilCustomAttrs @ [mkCompilationMappingAttr cenv.g (int (if isObjectType then SourceConstructFlags.ObjectType @@ -6383,7 +6437,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let isTheSealedAttribute = tyconRefEq cenv.g tcref cenv.g.attrib_SealedAttribute.TyconRef let tdef = { tdef with IsSealed = isSealedTy cenv.g thisTy || isTheSealedAttribute; - IsSerializable = IsSerializable; + IsSerializable = isSerializable; MethodImpls=mkILMethodImpls methodImpls; IsAbstract=isAbstract; IsComInterop=isComInteropTy cenv.g thisTy } @@ -6451,58 +6505,74 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let tdef = { tdef with tdKind = ilTypeDefKind; Layout=tdLayout; Encoding=tdEncoding } let tdef = match ilTypeDefKind with ILTypeDefKind.Interface -> { tdef with Extends = None; IsAbstract=true } | _ -> tdef - tdef + tdef, None - | TFiniteUnionRepr _ -> + | TUnionRepr _ -> let alternatives = tycon.UnionCasesArray |> Array.mapi (fun i ucspec -> { altName=ucspec.CompiledName; altFields=GenUnionCaseRef cenv.amap m cenv.g eenvinner.tyenv i ucspec.RecdFieldsArray; altCustomAttrs= mkILCustomAttrs (GenAttrs cenv eenv ucspec.Attribs @ [mkCompilationMappingAttrWithSeqNum cenv.g (int SourceConstructFlags.UnionCase) i]) }) + let cuinfo = + { cudReprAccess=reprAccess; + cudNullPermitted=IsUnionTypeWithNullAsTrueValue cenv.g tycon; + cudHelpersAccess=reprAccess; + cudHasHelpers=ComputeUnionHasHelpers cenv.g tcref; + cudDebugProxies= generateDebugProxies; + cudDebugDisplayAttributes= ilDebugDisplayAttributes; + cudAlternatives= alternatives; + cudWhere = None}; + let tdef = + { Name = ilTypeName; + Layout = ILTypeDefLayout.Auto; + Access = access; + GenericParams = ilGenParams; + CustomAttrs = + mkILCustomAttrs (ilCustomAttrs @ + [mkCompilationMappingAttr cenv.g + (int (if hiddenRepr + then SourceConstructFlags.SumType ||| SourceConstructFlags.NonPublicRepresentation + else SourceConstructFlags.SumType)) ]); + InitSemantics=ILTypeInit.BeforeField; + IsSealed=true; + IsAbstract=false; + tdKind= (if tycon.IsStructOrEnumTycon then ILTypeDefKind.ValueType else ILTypeDefKind.Class) + Fields = ilFields; + Events= ilEvents; + Properties = ilProperties; + Methods= mkILMethods ilMethods; + MethodImpls= mkILMethodImpls methodImpls; + IsComInterop=false; + IsSerializable= isSerializable; + IsSpecialName= false; + NestedTypes=emptyILTypeDefs; + Encoding= ILDefaultPInvokeEncoding.Auto; + Implements= mkILTypes ilIntfTys; + Extends= Some (if tycon.IsStructOrEnumTycon then cenv.g.ilg.typ_ValueType else cenv.g.ilg.typ_Object) + SecurityDecls= emptyILSecurityDecls; + HasSecurity=false } + let tdef2 = EraseUnions.mkClassUnionDef cenv.g.ilg tref tdef cuinfo + + // Discard the user-supplied (i.e. prim-type.fs) implementations of the get_Empty, get_IsEmpty, get_Value and get_None and Some methods. + // This is because we will replace their implementations by ones that load the unique + // private static field for lists etc. + // + // Also discard the F#-compiler supplied implementation of the Empty, IsEmpty, Value and None properties. + let tdefDiscards = + Some ((fun (md: ILMethodDef) -> + (cuinfo.cudHasHelpers = SpecialFSharpListHelpers && (md.Name = "get_Empty" || md.Name = "Cons" || md.Name = "get_IsEmpty")) || + (cuinfo.cudHasHelpers = SpecialFSharpOptionHelpers && (md.Name = "get_Value" || md.Name = "get_None" || md.Name = "Some"))), + + (fun (pd: ILPropertyDef) -> + (cuinfo.cudHasHelpers = SpecialFSharpListHelpers && (pd.Name = "Empty" || pd.Name = "IsEmpty" )) || + (cuinfo.cudHasHelpers = SpecialFSharpOptionHelpers && (pd.Name = "Value" || pd.Name = "None")))) - { Name = ilTypeName; - Layout = ILTypeDefLayout.Auto; - Access = access; - GenericParams = ilGenParams; - CustomAttrs = - mkILCustomAttrs (CustomAttrs @ - [mkCompilationMappingAttr cenv.g - (int (if hiddenRepr - then SourceConstructFlags.SumType ||| SourceConstructFlags.NonPublicRepresentation - else SourceConstructFlags.SumType)) ]); - InitSemantics=ILTypeInit.BeforeField; - IsSealed=true; - IsAbstract=false; - tdKind= - mkIlxTypeDefKind - (IlxTypeDefKind.Union - { cudReprAccess=reprAccess; - cudNullPermitted=IsUnionTypeWithNullAsTrueValue cenv.g tycon; - cudHelpersAccess=reprAccess; - cudHasHelpers=ComputeUnionHasHelpers cenv.g tcref; - cudDebugProxies= generateDebugProxies; - cudDebugDisplayAttributes= ilDebugDisplayAttributes; - cudAlternatives= alternatives; - cudWhere = None}); - Fields = ilFields; - Events= ilEvents; - Properties = ilProperties; - Methods= mkILMethods ilMethods; - MethodImpls= mkILMethodImpls methodImpls; - IsComInterop=false; - IsSerializable= IsSerializable; - IsSpecialName= false; - NestedTypes=emptyILTypeDefs; - Encoding= ILDefaultPInvokeEncoding.Auto; - Implements= mkILTypes ilIntfTys; - Extends= Some cenv.g.ilg.typ_Object; - SecurityDecls= emptyILSecurityDecls; - HasSecurity=false } + tdef2, tdefDiscards | _ -> failwith "??" let tdef = {tdef with SecurityDecls= secDecls; HasSecurity=securityAttrs.Length > 0} - mgbuf.AddTypeDef(tref, tdef, false, false); + mgbuf.AddTypeDef(tref, tdef, false, false, tdefDiscards); // If a non-generic type is written with "static let" and "static do" (i.e. it has a ".cctor") // then the code for the .cctor is placed into .cctor for the backing static class for the file. @@ -6625,7 +6695,7 @@ and GenExnDef cenv mgbuf eenv m (exnc:Tycon) = mkILCustomAttrs [mkCompilationMappingAttr cenv.g (int SourceConstructFlags.Exception)], ILTypeInit.BeforeField) let tdef = { tdef with IsSerializable = cenv.opts.netFxHasSerializableAttribute } - mgbuf.AddTypeDef(tref, tdef, false, false) + mgbuf.AddTypeDef(tref, tdef, false, false, None) let CodegenAssembly cenv eenv mgbuf fileImpls = @@ -6710,16 +6780,6 @@ let GenerateCode (cenv, eenv, TAssembly fileImpls, assemAttribs, moduleAttribs) let defnsResourceBytes = defns |> QuotationPickler.PickleDefns -(* - let ilFieldName = CompilerGeneratedName ("field" + string(newUnique())) - let ilFieldTy = mkILArr1DTy cenv.g.ilg.typ_Type - let ilFieldDef = mkILStaticField (ilFieldName,ilFieldTy, None, None, ILMemberAccess.Assembly) - let ilFieldDef = { ilFieldDef with CustomAttrs = mkILCustomAttrs [ cenv.g.ilg.mkDebuggerBrowsableNeverAttribute() ] } - let fspec = mkILFieldSpecInTy (mkILTyForCompLoc (CompLocForPrivateImplementationDetails env.cloc),ilFieldName, ilFieldTy) - CountStaticFieldDef(); - cgbuf.mgbuf.AddFieldDef(fspec.EnclosingTypeRef,ilFieldDef); -*) - [ (referencedTypeDefs, defnsResourceBytes) ] let ilNetModuleAttrs = GenAttrs cenv eenv moduleAttribs diff --git a/src/fsharp/InfoReader.fs b/src/fsharp/InfoReader.fs new file mode 100644 index 0000000000..237c54ad20 --- /dev/null +++ b/src/fsharp/InfoReader.fs @@ -0,0 +1,727 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + + +/// Select members from a type by name, searching the type hierarchy if needed +module internal Microsoft.FSharp.Compiler.InfoReader + +open Internal.Utilities + +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.AttributeChecking +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.TcGlobals + +/// Use the given function to select some of the member values from the members of an F# type +let private SelectImmediateMemberVals g optFilter f (tcref:TyconRef) = + let chooser (vref:ValRef) = + match vref.MemberInfo with + // The 'when' condition is a workaround for the fact that values providing + // override and interface implementations are published in inferred module types + // These cannot be selected directly via the "." notation. + // However, it certainly is useful to be able to publish these values, as we can in theory + // optimize code to make direct calls to these methods. + | Some membInfo when not (ValRefIsExplicitImpl g vref) -> + f membInfo vref + | _ -> + None + + match optFilter with + | None -> tcref.MembersOfFSharpTyconByName |> NameMultiMap.chooseRange chooser + | Some nm -> tcref.MembersOfFSharpTyconByName |> NameMultiMap.find nm |> List.choose chooser + +/// Check whether a name matches an optional filter +let private checkFilter optFilter (nm:string) = match optFilter with None -> true | Some n2 -> nm = n2 + +/// Try to select an F# value when querying members, and if so return a MethInfo that wraps the F# value. +let TrySelectMemberVal g optFilter typ pri _membInfo (vref:ValRef) = + if checkFilter optFilter vref.LogicalName then + Some(FSMeth(g,typ,vref,pri)) + else + None + +/// Query the immediate methods of an F# type, not taking into account inherited methods. The optFilter +/// parameter is an optional name to restrict the set of properties returned. +let GetImmediateIntrinsicMethInfosOfType (optFilter,ad) g amap m typ = + let minfos = + + match metadataOfTy g typ with +#if EXTENSIONTYPING + | ProvidedTypeMetadata info -> + let st = info.ProvidedType + let meths = + match optFilter with + | Some name -> st.PApplyArray ((fun st -> st.GetMethods() |> Array.filter (fun mi -> mi.Name = name) ), "GetMethods", m) + | None -> st.PApplyArray ((fun st -> st.GetMethods()), "GetMethods", m) + [ for mi in meths -> ProvidedMeth(amap,mi.Coerce(m),None,m) ] +#endif + | ILTypeMetadata (_,tdef) -> + let mdefs = tdef.Methods + let mdefs = (match optFilter with None -> mdefs.AsList | Some nm -> mdefs.FindByName nm) + mdefs |> List.map (fun mdef -> MethInfo.CreateILMeth(amap, m, typ, mdef)) + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> + if not (isAppTy g typ) then [] + else SelectImmediateMemberVals g optFilter (TrySelectMemberVal g optFilter typ None) (tcrefOfAppTy g typ) + let minfos = minfos |> List.filter (IsMethInfoAccessible amap m ad) + minfos + +/// A helper type to help collect properties. +/// +/// Join up getters and setters which are not associated in the F# data structure +type PropertyCollector(g,amap,m,typ,optFilter,ad) = + + let hashIdentity = + Microsoft.FSharp.Collections.HashIdentity.FromFunctions + (fun (pinfo:PropInfo) -> hash pinfo.PropertyName) + (fun pinfo1 pinfo2 -> + pinfo1.IsStatic = pinfo2.IsStatic && + PropInfosEquivByNameAndPartialSig EraseNone g amap m pinfo1 pinfo2 && + pinfo1.IsDefiniteFSharpOverride = pinfo2.IsDefiniteFSharpOverride ) + let props = new System.Collections.Generic.Dictionary(hashIdentity) + let add pinfo = + if props.ContainsKey(pinfo) then + match props.[pinfo], pinfo with + | FSProp (_,typ,Some vref1,_), FSProp (_,_,_,Some vref2) + | FSProp (_,typ,_,Some vref2), FSProp (_,_,Some vref1,_) -> + let pinfo = FSProp (g,typ,Some vref1,Some vref2) + props.[pinfo] <- pinfo + | _ -> + // This assert fires while editing bad code. We will give a warning later in check.fs + //assert ("unexpected case"= "") + () + else + props.[pinfo] <- pinfo + + member x.Collect(membInfo:ValMemberInfo,vref:ValRef) = + match membInfo.MemberFlags.MemberKind with + | MemberKind.PropertyGet -> + let pinfo = FSProp(g,typ,Some vref,None) + if checkFilter optFilter vref.PropertyName && IsPropInfoAccessible g amap m ad pinfo then + add pinfo + | MemberKind.PropertySet -> + let pinfo = FSProp(g,typ,None,Some vref) + if checkFilter optFilter vref.PropertyName && IsPropInfoAccessible g amap m ad pinfo then + add pinfo + | _ -> + () + + member x.Close() = [ for KeyValue(_,pinfo) in props -> pinfo ] + +/// Query the immediate properties of an F# type, not taking into account inherited properties. The optFilter +/// parameter is an optional name to restrict the set of properties returned. +let GetImmediateIntrinsicPropInfosOfType (optFilter,ad) g amap m typ = + let pinfos = + + match metadataOfTy g typ with +#if EXTENSIONTYPING + | ProvidedTypeMetadata info -> + let st = info.ProvidedType + let matchingProps = + match optFilter with + | Some name -> + match st.PApply((fun st -> st.GetProperty name), m) with + | Tainted.Null -> [||] + | pi -> [|pi|] + | None -> + st.PApplyArray((fun st -> st.GetProperties()), "GetProperties", m) + matchingProps + |> Seq.map(fun pi -> ProvidedProp(amap,pi,m)) + |> List.ofSeq +#endif + | ILTypeMetadata (_,tdef) -> + let tinfo = ILTypeInfo.FromType g typ + let pdefs = tdef.Properties + let pdefs = match optFilter with None -> pdefs.AsList | Some nm -> pdefs.LookupByName nm + pdefs |> List.map (fun pd -> ILProp(g,ILPropInfo(tinfo,pd))) + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> + + if not (isAppTy g typ) then [] + else + let propCollector = new PropertyCollector(g,amap,m,typ,optFilter,ad) + SelectImmediateMemberVals g None + (fun membInfo vref -> propCollector.Collect(membInfo,vref); None) + (tcrefOfAppTy g typ) |> ignore + propCollector.Close() + + let pinfos = pinfos |> List.filter (IsPropInfoAccessible g amap m ad) + pinfos + + +/// Sets of methods up the hierarchy, ignoring duplicates by name and sig. +/// Used to collect sets of virtual methods, protected methods, protected +/// properties etc. +type HierarchyItem = + | MethodItem of MethInfo list list + | PropertyItem of PropInfo list list + | RecdFieldItem of RecdFieldInfo + | EventItem of EventInfo list + | ILFieldItem of ILFieldInfo list + +/// An InfoReader is an object to help us read and cache infos. +/// We create one of these for each file we typecheck. +type InfoReader(g:TcGlobals, amap:Import.ImportMap) = + + /// Get the declared IL fields of a type, not including inherited fields + let GetImmediateIntrinsicILFieldsOfType (optFilter,ad) m typ = + let infos = + match metadataOfTy g typ with +#if EXTENSIONTYPING + | ProvidedTypeMetadata info -> + let st = info.ProvidedType + match optFilter with + | None -> + [ for fi in st.PApplyArray((fun st -> st.GetFields()), "GetFields" , m) -> ProvidedField(amap,fi,m) ] + | Some name -> + match st.PApply ((fun st -> st.GetField name), m) with + | Tainted.Null -> [] + | fi -> [ ProvidedField(amap,fi,m) ] +#endif + | ILTypeMetadata (_,tdef) -> + let tinfo = ILTypeInfo.FromType g typ + let fdefs = tdef.Fields + let fdefs = match optFilter with None -> fdefs.AsList | Some nm -> fdefs.LookupByName nm + fdefs |> List.map (fun pd -> ILFieldInfo(tinfo,pd)) + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> + [] + let infos = infos |> List.filter (IsILFieldInfoAccessible g amap m ad) + infos + + /// Get the declared events of a type, not including inherited events + let ComputeImmediateIntrinsicEventsOfType (optFilter,ad) m typ = + let infos = + match metadataOfTy g typ with +#if EXTENSIONTYPING + | ProvidedTypeMetadata info -> + let st = info.ProvidedType + match optFilter with + | None -> + [ for ei in st.PApplyArray((fun st -> st.GetEvents()), "GetEvents" , m) -> ProvidedEvent(amap,ei,m) ] + | Some name -> + match st.PApply ((fun st -> st.GetEvent name), m) with + | Tainted.Null -> [] + | ei -> [ ProvidedEvent(amap,ei,m) ] +#endif + | ILTypeMetadata (_,tdef) -> + let tinfo = ILTypeInfo.FromType g typ + let edefs = tdef.Events + let edefs = match optFilter with None -> edefs.AsList | Some nm -> edefs.LookupByName nm + [ for edef in edefs do + let einfo = ILEventInfo(tinfo,edef) + if IsILEventInfoAccessible g amap m ad einfo then + yield ILEvent(g,einfo) ] + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> + [] + infos + + /// Make a reference to a record or class field + let MakeRecdFieldInfo g typ (tcref:TyconRef) fspec = + RecdFieldInfo(argsOfAppTy g typ,tcref.MakeNestedRecdFieldRef fspec) + + /// Get the F#-declared record fields or class 'val' fields of a type + let GetImmediateIntrinsicRecdOrClassFieldsOfType (optFilter,_ad) _m typ = + match tryDestAppTy g typ with + | None -> [] + | Some tcref -> + // Note;secret fields are not allowed in lookups here, as we're only looking + // up user-visible fields in name resolution. + match optFilter with + | Some nm -> + match tcref.GetFieldByName nm with + | Some rfield when not rfield.IsCompilerGenerated -> [MakeRecdFieldInfo g typ tcref rfield] + | _ -> [] + | None -> + [ for fdef in tcref.AllFieldsArray do + if not fdef.IsCompilerGenerated then + yield MakeRecdFieldInfo g typ tcref fdef ] + + + /// The primitive reader for the method info sets up a hierarchy + let GetIntrinsicMethodSetsUncached ((optFilter,ad,allowMultiIntfInst),m,typ) = + FoldPrimaryHierarchyOfType (fun typ acc -> GetImmediateIntrinsicMethInfosOfType (optFilter,ad) g amap m typ :: acc) g amap m allowMultiIntfInst typ [] + + /// The primitive reader for the property info sets up a hierarchy + let GetIntrinsicPropertySetsUncached ((optFilter,ad,allowMultiIntfInst),m,typ) = + FoldPrimaryHierarchyOfType (fun typ acc -> GetImmediateIntrinsicPropInfosOfType (optFilter,ad) g amap m typ :: acc) g amap m allowMultiIntfInst typ [] + + let GetIntrinsicILFieldInfosUncached ((optFilter,ad),m,typ) = + FoldPrimaryHierarchyOfType (fun typ acc -> GetImmediateIntrinsicILFieldsOfType (optFilter,ad) m typ @ acc) g amap m AllowMultiIntfInstantiations.Yes typ [] + + let GetIntrinsicEventInfosUncached ((optFilter,ad),m,typ) = + FoldPrimaryHierarchyOfType (fun typ acc -> ComputeImmediateIntrinsicEventsOfType (optFilter,ad) m typ @ acc) g amap m AllowMultiIntfInstantiations.Yes typ [] + + let GetIntrinsicRecdOrClassFieldInfosUncached ((optFilter,ad),m,typ) = + FoldPrimaryHierarchyOfType (fun typ acc -> GetImmediateIntrinsicRecdOrClassFieldsOfType (optFilter,ad) m typ @ acc) g amap m AllowMultiIntfInstantiations.Yes typ [] + + let GetEntireTypeHierachyUncached (allowMultiIntfInst,m,typ) = + FoldEntireHierarchyOfType (fun typ acc -> typ :: acc) g amap m allowMultiIntfInst typ [] + + let GetPrimaryTypeHierachyUncached (allowMultiIntfInst,m,typ) = + FoldPrimaryHierarchyOfType (fun typ acc -> typ :: acc) g amap m allowMultiIntfInst typ [] + + /// The primitive reader for the named items up a hierarchy + let GetIntrinsicNamedItemsUncached ((nm,ad),m,typ) = + if nm = ".ctor" then None else // '.ctor' lookups only ever happen via constructor syntax + let optFilter = Some nm + FoldPrimaryHierarchyOfType (fun typ acc -> + let minfos = GetImmediateIntrinsicMethInfosOfType (optFilter,ad) g amap m typ + let pinfos = GetImmediateIntrinsicPropInfosOfType (optFilter,ad) g amap m typ + let finfos = GetImmediateIntrinsicILFieldsOfType (optFilter,ad) m typ + let einfos = ComputeImmediateIntrinsicEventsOfType (optFilter,ad) m typ + let rfinfos = GetImmediateIntrinsicRecdOrClassFieldsOfType (optFilter,ad) m typ + match acc with + | Some(MethodItem(inheritedMethSets)) when nonNil minfos -> Some(MethodItem (minfos::inheritedMethSets)) + | _ when nonNil minfos -> Some(MethodItem ([minfos])) + | Some(PropertyItem(inheritedPropSets)) when nonNil pinfos -> Some(PropertyItem(pinfos::inheritedPropSets)) + | _ when nonNil pinfos -> Some(PropertyItem([pinfos])) + | _ when nonNil finfos -> Some(ILFieldItem(finfos)) + | _ when nonNil einfos -> Some(EventItem(einfos)) + | _ when nonNil rfinfos -> + match rfinfos with + | [single] -> Some(RecdFieldItem(single)) + | _ -> failwith "Unexpected multiple fields with the same name" // Because an explicit name (i.e., nm) was supplied, there will be only one element at most. + | _ -> acc) + g amap m + AllowMultiIntfInstantiations.Yes + typ + None + + /// Make a cache for function 'f' keyed by type (plus some additional 'flags') that only + /// caches computations for monomorphic types. + + let MakeInfoCache f (flagsEq : System.Collections.Generic.IEqualityComparer<_>) = + new MemoizationTable<_,_> + (compute=f, + // Only cache closed, monomorphic types (closed = all members for the type + // have been processed). Generic type instantiations could be processed if we had + // a decent hash function for these. + canMemoize=(fun (_flags,(_:range),typ) -> + match stripTyEqns g typ with + | TType_app(tcref,[]) -> tcref.TypeContents.tcaug_closed + | _ -> false), + + keyComparer= + { new System.Collections.Generic.IEqualityComparer<_> with + member x.Equals((flags1,_,typ1),(flags2,_,typ2)) = + // Ignoring the ranges - that's OK. + flagsEq.Equals(flags1,flags2) && + match stripTyEqns g typ1, stripTyEqns g typ2 with + | TType_app(tcref1,[]),TType_app(tcref2,[]) -> tyconRefEq g tcref1 tcref2 + | _ -> false + member x.GetHashCode((flags,_,typ)) = + // Ignoring the ranges - that's OK. + flagsEq.GetHashCode flags + + (match stripTyEqns g typ with + | TType_app(tcref,[]) -> hash tcref.LogicalName + | _ -> 0) }) + + + let hashFlags0 = + { new System.Collections.Generic.IEqualityComparer<_> with + member x.GetHashCode((filter: string option, ad: AccessorDomain, _allowMultiIntfInst1)) = hash filter + AccessorDomain.CustomGetHashCode ad + member x.Equals((filter1, ad1, allowMultiIntfInst1), (filter2,ad2, allowMultiIntfInst2)) = + (filter1 = filter2) && AccessorDomain.CustomEquals(g,ad1,ad2) && allowMultiIntfInst1 = allowMultiIntfInst2 } + + let hashFlags1 = + { new System.Collections.Generic.IEqualityComparer<_> with + member x.GetHashCode((filter: string option,ad: AccessorDomain)) = hash filter + AccessorDomain.CustomGetHashCode ad + member x.Equals((filter1,ad1), (filter2,ad2)) = (filter1 = filter2) && AccessorDomain.CustomEquals(g,ad1,ad2) } + + let hashFlags2 = + { new System.Collections.Generic.IEqualityComparer<_> with + member x.GetHashCode((nm: string,ad: AccessorDomain)) = hash nm + AccessorDomain.CustomGetHashCode ad + member x.Equals((nm1,ad1), (nm2,ad2)) = (nm1 = nm2) && AccessorDomain.CustomEquals(g,ad1,ad2) } + + let methodInfoCache = MakeInfoCache GetIntrinsicMethodSetsUncached hashFlags0 + let propertyInfoCache = MakeInfoCache GetIntrinsicPropertySetsUncached hashFlags0 + let recdOrClassFieldInfoCache = MakeInfoCache GetIntrinsicRecdOrClassFieldInfosUncached hashFlags1 + let ilFieldInfoCache = MakeInfoCache GetIntrinsicILFieldInfosUncached hashFlags1 + let eventInfoCache = MakeInfoCache GetIntrinsicEventInfosUncached hashFlags1 + let namedItemsCache = MakeInfoCache GetIntrinsicNamedItemsUncached hashFlags2 + + let entireTypeHierarchyCache = MakeInfoCache GetEntireTypeHierachyUncached HashIdentity.Structural + let primaryTypeHierarchyCache = MakeInfoCache GetPrimaryTypeHierachyUncached HashIdentity.Structural + + member x.g = g + member x.amap = amap + + /// Read the raw method sets of a type, including inherited ones. Cache the result for monomorphic types + member x.GetRawIntrinsicMethodSetsOfType (optFilter,ad,allowMultiIntfInst,m,typ) = + methodInfoCache.Apply(((optFilter,ad,allowMultiIntfInst),m,typ)) + + /// Read the raw property sets of a type, including inherited ones. Cache the result for monomorphic types + member x.GetRawIntrinsicPropertySetsOfType (optFilter,ad,allowMultiIntfInst,m,typ) = + propertyInfoCache.Apply(((optFilter,ad,allowMultiIntfInst),m,typ)) + + /// Read the record or class fields of a type, including inherited ones. Cache the result for monomorphic types. + member x.GetRecordOrClassFieldsOfType (optFilter,ad,m,typ) = + recdOrClassFieldInfoCache.Apply(((optFilter,ad),m,typ)) + + /// Read the IL fields of a type, including inherited ones. Cache the result for monomorphic types. + member x.GetILFieldInfosOfType (optFilter,ad,m,typ) = + ilFieldInfoCache.Apply(((optFilter,ad),m,typ)) + + member x.GetImmediateIntrinsicEventsOfType (optFilter,ad,m,typ) = ComputeImmediateIntrinsicEventsOfType (optFilter,ad) m typ + + /// Read the events of a type, including inherited ones. Cache the result for monomorphic types. + member x.GetEventInfosOfType (optFilter,ad,m,typ) = + eventInfoCache.Apply(((optFilter,ad),m,typ)) + + /// Try and find a record or class field for a type. + member x.TryFindRecdOrClassFieldInfoOfType (nm,m,typ) = + match recdOrClassFieldInfoCache.Apply((Some nm,AccessibleFromSomewhere),m,typ) with + | [] -> None + | [single] -> Some single + | flds -> + // multiple fields with the same name can come from different classes, + // so filter them by the given type name + match tryDestAppTy g typ with + | None -> None + | Some tcref -> + match flds |> List.filter (fun rfinfo -> tyconRefEq g tcref rfinfo.TyconRef) with + | [] -> None + | [single] -> Some single + | _ -> failwith "unexpected multiple fields with same name" // Because it should have been already reported as duplicate fields + + /// Try and find an item with the given name in a type. + member x.TryFindNamedItemOfType (nm,ad,m,typ) = + namedItemsCache.Apply(((nm,ad),m,typ)) + + /// Get the super-types of a type, including interface types. + member x.GetEntireTypeHierachy (allowMultiIntfInst,m,typ) = + entireTypeHierarchyCache.Apply((allowMultiIntfInst,m,typ)) + + /// Get the super-types of a type, excluding interface types. + member x.GetPrimaryTypeHierachy (allowMultiIntfInst,m,typ) = + primaryTypeHierarchyCache.Apply((allowMultiIntfInst,m,typ)) + + +//------------------------------------------------------------------------- +// Constructor infos + + +/// Get the declared constructors of any F# type +let GetIntrinsicConstructorInfosOfType (infoReader:InfoReader) m ty = + let g = infoReader.g + let amap = infoReader.amap + if isAppTy g ty then + match metadataOfTy g ty with +#if EXTENSIONTYPING + | ProvidedTypeMetadata info -> + let st = info.ProvidedType + [ for ci in st.PApplyArray((fun st -> st.GetConstructors()), "GetConstructors", m) do + yield ProvidedMeth(amap,ci.Coerce(m),None,m) ] +#endif + | ILTypeMetadata _ -> + let tinfo = ILTypeInfo.FromType g ty + tinfo.RawMetadata.Methods.FindByName ".ctor" + |> List.filter (fun md -> match md.mdKind with MethodKind.Ctor -> true | _ -> false) + |> List.map (fun mdef -> MethInfo.CreateILMeth (amap, m, ty, mdef)) + + | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> + let tcref = tcrefOfAppTy g ty + tcref.MembersOfFSharpTyconByName + |> NameMultiMap.find ".ctor" + |> List.choose(fun vref -> + match vref.MemberInfo with + | Some membInfo when (membInfo.MemberFlags.MemberKind = MemberKind.Constructor) -> Some vref + | _ -> None) + |> List.map (fun x -> FSMeth(g,ty,x,None)) + else [] + +//------------------------------------------------------------------------- +// Collecting methods and properties taking into account hiding rules in the hierarchy + + +/// Indicates if we prefer overrides or abstract slots. +type FindMemberFlag = + /// Prefer items toward the top of the hierarchy, which we do if the items are virtual + /// but not when resolving base calls. + | IgnoreOverrides + /// Get overrides instead of abstract slots when measuring whether a class/interface implements all its required slots. + | PreferOverrides + +/// The input list is sorted from most-derived to least-derived type, so any System.Object methods +/// are at the end of the list. Return a filtered list where prior/subsequent members matching by name and +/// that are in the same equivalence class have been removed. We keep a name-indexed table to +/// be more efficient when we check to see if we've already seen a particular named method. +type private IndexedList<'T>(itemLists: 'T list list, itemsByName: NameMultiMap<'T>) = + + /// Get the item sets + member x.Items = itemLists + + /// Get the items with a particular name + member x.ItemsWithName(nm) = NameMultiMap.find nm itemsByName + + /// Add new items, extracting the names using the given function. + member x.AddItems(items,nmf) = IndexedList<'T>(items::itemLists,List.foldBack (fun x acc -> NameMultiMap.add (nmf x) x acc) items itemsByName ) + + /// Get an empty set of items + static member Empty = IndexedList<'T>([],NameMultiMap.empty) + + /// Filter a set of new items to add according to the content of the list. Only keep an item + /// if it passes 'keepTest' for all matching items already in the list. + member x.FilterNewItems keepTest nmf itemsToAdd = + // Have we already seen an item with the same name and that is in the same equivalence class? + // If so, ignore this one. Note we can check against the original incoming 'ilist' because we are assuming that + // none the elements of 'itemsToAdd' are equivalent. + itemsToAdd |> List.filter (fun item -> List.forall (keepTest item) (x.ItemsWithName(nmf item))) + +/// Add all the items to the IndexedList, preferring the ones in the super-types. This is used to hide methods +/// in super classes and/or hide overrides of methods in subclasses. +/// +/// Assume no items in 'items' are equivalent according to 'equivTest'. This is valid because each step in a +/// .NET class hierarchy introduces a consistent set of methods, none of which hide each other within the +/// given set. This is an important optimization because it means we don't have filter for equivalence between the +/// large overload sets introduced by methods like System.WriteLine. +/// +/// Assume items can be given names by 'nmf', where two items with different names are +/// not equivalent. + +let private FilterItemsInSubTypesBasedOnItemsInSuperTypes nmf keepTest itemLists = + let rec loop itemLists = + match itemLists with + | [] -> IndexedList.Empty + | items :: itemsInSuperTypes -> + let ilist = loop itemsInSuperTypes + let itemsToAdd = ilist.FilterNewItems keepTest nmf items + ilist.AddItems(itemsToAdd,nmf) + (loop itemLists).Items + +/// Add all the items to the IndexedList, preferring the ones in the sub-types. +let private FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf keepTest itemLists = + let rec loop itemLists (indexedItemsInSubTypes:IndexedList<_>) = + match itemLists with + | [] -> List.rev indexedItemsInSubTypes.Items + | items :: itemsInSuperTypes -> + let itemsToAdd = items |> List.filter (fun item -> keepTest item (indexedItemsInSubTypes.ItemsWithName(nmf item))) + let ilist = indexedItemsInSubTypes.AddItems(itemsToAdd,nmf) + loop itemsInSuperTypes ilist + + loop itemLists IndexedList.Empty + +let private ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes nmf equivTest itemLists = + FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf (fun item1 items -> not (items |> List.exists (fun item2 -> equivTest item1 item2))) itemLists + +/// Filter the overrides of methods or properties, either keeping the overrides or keeping the dispatch slots. +let private FilterOverrides findFlag (isVirt:'a->bool,isNewSlot,isDefiniteOverride,isFinal,equivSigs,nmf:'a->string) items = + let equivVirts x y = isVirt x && isVirt y && equivSigs x y + + match findFlag with + | PreferOverrides -> + items + // For each F#-declared override, get rid of any equivalent abstract member in the same type + // This is because F# abstract members with default overrides give rise to two members with the + // same logical signature in the same type, e.g. + // type ClassType1() = + // abstract VirtualMethod1: string -> int + // default x.VirtualMethod1(s) = 3 + + |> List.map (fun items -> + let definiteOverrides = items |> List.filter isDefiniteOverride + items |> List.filter (fun item -> (isDefiniteOverride item || not (List.exists (equivVirts item) definiteOverrides)))) + + // only keep virtuals that are not signature-equivalent to virtuals in subtypes + |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes nmf equivVirts + | IgnoreOverrides -> + let equivNewSlots x y = isNewSlot x && isNewSlot y && equivSigs x y + items + // Remove any F#-declared overrides. THese may occur in the same type as the abstract member (unlike with .NET metadata) + // Include any 'newslot' declared methods. + |> List.map (List.filter (fun x -> not (isDefiniteOverride x))) + + // Remove any virtuals that are signature-equivalent to virtuals in subtypes, except for newslots + // That is, keep if it's + /// (a) not virtual + // (b) is a new slot or + // (c) not equivalent + // We keep virtual finals around for error detection later on + |> FilterItemsInSubTypesBasedOnItemsInSuperTypes nmf (fun newItem priorItem -> + (isVirt newItem && isFinal newItem) || not (isVirt newItem) || isNewSlot newItem || not (equivVirts newItem priorItem) ) + + // Remove any abstract slots in supertypes that are (a) hidden by another newslot and (b) implemented + // We leave unimplemented ones around to give errors, e.g. for + // [] + // type PA() = + // abstract M : int -> unit + // + // [] + // type PB<'a>() = + // inherit PA() + // abstract M : 'a -> unit + // + // [] + // type PC() = + // inherit PB() + // // Here, PA.M and PB.M have the same signature, so PA.M is unimplementable. + // // REVIEW: in future we may give a friendly error at this point + // + // type PD() = + // inherit PC() + // override this.M(x:int) = () + + |> FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf (fun item1 superTypeItems -> + not (isNewSlot item1 && + superTypeItems |> List.exists (equivNewSlots item1) && + superTypeItems |> List.exists (fun item2 -> isDefiniteOverride item1 && equivVirts item1 item2))) + + +/// Filter the overrides of methods, either keeping the overrides or keeping the dispatch slots. +let private FilterOverridesOfMethInfos findFlag g amap m minfos = + FilterOverrides findFlag ((fun (minfo:MethInfo) -> minfo.IsVirtual),(fun minfo -> minfo.IsNewSlot),(fun minfo -> minfo.IsDefiniteFSharpOverride),(fun minfo -> minfo.IsFinal),MethInfosEquivByNameAndSig EraseNone true g amap m,(fun minfo -> minfo.LogicalName)) minfos + +/// Filter the overrides of properties, either keeping the overrides or keeping the dispatch slots. +let private FilterOverridesOfPropInfos findFlag g amap m props = + FilterOverrides findFlag ((fun (pinfo:PropInfo) -> pinfo.IsVirtualProperty),(fun pinfo -> pinfo.IsNewSlot),(fun pinfo -> pinfo.IsDefiniteFSharpOverride),(fun _ -> false),PropInfosEquivByNameAndSig EraseNone g amap m, (fun pinfo -> pinfo.PropertyName)) props + +/// Exclude methods from super types which have the same signature as a method in a more specific type. +let ExcludeHiddenOfMethInfos g amap m (minfos:MethInfo list list) = + minfos + |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes + (fun minfo -> minfo.LogicalName) + (fun m1 m2 -> + // only hide those truly from super classes + not (tyconRefEq g (tcrefOfAppTy g m1.EnclosingType) (tcrefOfAppTy g m2.EnclosingType)) && + MethInfosEquivByNameAndPartialSig EraseNone true g amap m m1 m2) + + |> List.concat + +/// Exclude properties from super types which have the same name as a property in a more specific type. +let ExcludeHiddenOfPropInfos g amap m pinfos = + pinfos + |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes (fun (pinfo:PropInfo) -> pinfo.PropertyName) (PropInfosEquivByNameAndPartialSig EraseNone g amap m) + |> List.concat + +/// Get the sets of intrinsic methods in the hierarchy (not including extension methods) +let GetIntrinsicMethInfoSetsOfType (infoReader:InfoReader) (optFilter,ad,allowMultiIntfInst) findFlag m typ = + infoReader.GetRawIntrinsicMethodSetsOfType(optFilter,ad,allowMultiIntfInst,m,typ) + |> FilterOverridesOfMethInfos findFlag infoReader.g infoReader.amap m + +/// Get the sets intrinsic properties in the hierarchy (not including extension properties) +let GetIntrinsicPropInfoSetsOfType (infoReader:InfoReader) (optFilter,ad,allowMultiIntfInst) findFlag m typ = + infoReader.GetRawIntrinsicPropertySetsOfType(optFilter,ad,allowMultiIntfInst,m,typ) + |> FilterOverridesOfPropInfos findFlag infoReader.g infoReader.amap m + +/// Get the flattened list of intrinsic methods in the hierarchy +let GetIntrinsicMethInfosOfType infoReader (optFilter,ad,allowMultiIntfInst) findFlag m typ = + GetIntrinsicMethInfoSetsOfType infoReader (optFilter,ad,allowMultiIntfInst) findFlag m typ |> List.concat + +/// Get the flattened list of intrinsic properties in the hierarchy +let GetIntrinsicPropInfosOfType infoReader (optFilter,ad,allowMultiIntfInst) findFlag m typ = + GetIntrinsicPropInfoSetsOfType infoReader (optFilter,ad,allowMultiIntfInst) findFlag m typ |> List.concat + +/// Perform type-directed name resolution of a particular named member in an F# type +let TryFindIntrinsicNamedItemOfType (infoReader:InfoReader) (nm,ad) findFlag m typ = + match infoReader.TryFindNamedItemOfType(nm, ad, m, typ) with + | Some item -> + match item with + | PropertyItem psets -> Some(PropertyItem (psets |> FilterOverridesOfPropInfos findFlag infoReader.g infoReader.amap m)) + | MethodItem msets -> Some(MethodItem (msets |> FilterOverridesOfMethInfos findFlag infoReader.g infoReader.amap m)) + | _ -> Some(item) + | None -> None + +/// Try to detect the existence of a method on a type. +/// Used for +/// -- getting the GetEnumerator, get_Current, MoveNext methods for enumerable types +/// -- getting the Dispose method when resolving the 'use' construct +/// -- getting the various methods used to desugar the computation expression syntax +let TryFindIntrinsicMethInfo infoReader m ad nm ty = + GetIntrinsicMethInfosOfType infoReader (Some nm,ad,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m ty + +/// Try to find a particular named property on a type. Only used to ensure that local 'let' definitions and property names +/// are distinct, a somewhat adhoc check in tc.fs. +let TryFindPropInfo infoReader m ad nm ty = + GetIntrinsicPropInfosOfType infoReader (Some nm,ad,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m ty + +//------------------------------------------------------------------------- +// Helpers related to delegates and events - these use method searching hence are in this file +//------------------------------------------------------------------------- + +/// The Invoke MethInfo, the function argument types, the function return type +/// and the overall F# function type for the function type associated with a .NET delegate type +[] +type SigOfFunctionForDelegate = SigOfFunctionForDelegate of MethInfo * TType list * TType * TType + +/// Given a delegate type work out the minfo, argument types, return type +/// and F# function type by looking at the Invoke signature of the delegate. +let GetSigOfFunctionForDelegate (infoReader:InfoReader) delty m ad = + let g = infoReader.g + let amap = infoReader.amap + let invokeMethInfo = + match GetIntrinsicMethInfosOfType infoReader (Some "Invoke",ad,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m delty with + | [h] -> h + | [] -> error(Error(FSComp.SR.noInvokeMethodsFound (),m)) + | h :: _ -> warning(InternalError(FSComp.SR.moreThanOneInvokeMethodFound (),m)); h + + let minst = [] // a delegate's Invoke method is never generic + let compiledViewOfDelArgTys = + match invokeMethInfo.GetParamTypes(amap, m, minst) with + | [args] -> args + | _ -> error(Error(FSComp.SR.delegatesNotAllowedToHaveCurriedSignatures (),m)) + let fsharpViewOfDelArgTys = + match compiledViewOfDelArgTys with + | [] -> [g.unit_ty] + | _ -> compiledViewOfDelArgTys + let delRetTy = invokeMethInfo.GetFSharpReturnTy(amap, m, minst) + CheckMethInfoAttributes g m None invokeMethInfo |> CommitOperationResult + let fty = mkIteratedFunTy fsharpViewOfDelArgTys delRetTy + SigOfFunctionForDelegate(invokeMethInfo,compiledViewOfDelArgTys,delRetTy,fty) + +/// Try and interpret a delegate type as a "standard" .NET delegate type associated with an event, with a "sender" parameter. +let TryDestStandardDelegateTyp (infoReader:InfoReader) m ad delTy = + let g = infoReader.g + let (SigOfFunctionForDelegate(_,compiledViewOfDelArgTys,delRetTy,_)) = GetSigOfFunctionForDelegate infoReader delTy m ad + match compiledViewOfDelArgTys with + | senderTy :: argTys when (isObjTy g senderTy) && not (List.exists (isByrefTy g) argTys) -> Some(mkTupledTy g argTys,delRetTy) + | _ -> None + + +/// Indicates if an event info is associated with a delegate type that is a "standard" .NET delegate type +/// with a sender parameter. +// +/// In the F# design, we take advantage of the following idiom to simplify away the bogus "object" parameter of the +/// of the "Add" methods associated with events. If you want to access it you +/// can use AddHandler instead. + +/// The .NET Framework guidelines indicate that the delegate type used for +/// an event should take two parameters, an "object source" parameter +/// indicating the source of the event, and an "e" parameter that +/// encapsulates any additional information about the event. The type of +/// the "e" parameter should derive from the EventArgs class. For events +/// that do not use any additional information, the .NET Framework has +/// already defined an appropriate delegate type: EventHandler. +/// (from http://msdn.microsoft.com/library/default.asp?url=/library/en-us/csref/html/vcwlkEventsTutorial.asp) +let IsStandardEventInfo (infoReader:InfoReader) m ad (einfo:EventInfo) = + let dty = einfo.GetDelegateType(infoReader.amap,m) + match TryDestStandardDelegateTyp infoReader m ad dty with + | Some _ -> true + | None -> false + +/// Get the (perhaps tupled) argument type accepted by an event +let ArgsTypOfEventInfo (infoReader:InfoReader) m ad (einfo:EventInfo) = + let amap = infoReader.amap + let dty = einfo.GetDelegateType(amap,m) + match TryDestStandardDelegateTyp infoReader m ad dty with + | Some(argtys,_) -> argtys + | None -> error(nonStandardEventError einfo.EventName m) + +/// Get the type of the event when looked at as if it is a property +/// Used when displaying the property in Intellisense +let PropTypOfEventInfo (infoReader:InfoReader) m ad (einfo:EventInfo) = + let g = infoReader.g + let amap = infoReader.amap + let delTy = einfo.GetDelegateType(amap,m) + let argsTy = ArgsTypOfEventInfo infoReader m ad einfo + mkIEventType g delTy argsTy + + diff --git a/src/fsharp/InnerLambdasToTopLevelFuncs.fs b/src/fsharp/InnerLambdasToTopLevelFuncs.fs index 7495270e0e..5bbc36c6e1 100755 --- a/src/fsharp/InnerLambdasToTopLevelFuncs.fs +++ b/src/fsharp/InnerLambdasToTopLevelFuncs.fs @@ -782,14 +782,13 @@ let FlatEnvPacks g fclassM topValS declist (reqdItemsMap: Zmap @@ -1117,18 +1116,18 @@ module Pass4_RewriteAssembly = // - patch it. | Expr.App (f,fty,tys,args,m) -> // pass over f,args subexprs - let z,f = TransExpr penv z f - let z,args = List.foldMap (TransExpr penv) z args + let f,z = TransExpr penv z f + let args,z = List.mapFold (TransExpr penv) z args // match app, and fixup if needed let f,fty,tys,args,m = destApp (f,fty,tys,args,m) let expr = TransApp penv (f,fty,tys,args,m) - z,expr + expr,z | Expr.Val (v,_,m) -> // consider this a trivial app let fx,fty = expr,v.Type let expr = TransApp penv (fx,fty,[],[],m) - z,expr + expr,z // reclink - suppress | Expr.Link r -> @@ -1136,70 +1135,73 @@ module Pass4_RewriteAssembly = // ilobj - has implicit lambda exprs and recursive/base references | Expr.Obj (_,ty,basev,basecall,overrides,iimpls,m) -> - let z,basecall = TransExpr penv z basecall - let z,overrides = List.foldMap (TransMethod penv) z overrides - let z,iimpls = List.foldMap (fmap2Of2 (List.foldMap (TransMethod penv))) z iimpls + 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) -> + 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) - let z,pds = ExtractPreDecs z - z,WrapPreDecs m pds expr (* if TopLevel, lift preDecs over the ilobj expr *) + let pds,z = ExtractPreDecs z + WrapPreDecs m pds expr,z (* if TopLevel, lift preDecs over the ilobj expr *) // lambda, tlambda - explicit lambda terms | Expr.Lambda(_,ctorThisValOpt,baseValOpt,argvs,body,m,rty) -> let z = EnterInner z - let z,body = TransExpr penv z body + let body,z = TransExpr penv z body let z = ExitInner z - let z,pds = ExtractPreDecs z - z,WrapPreDecs m pds (rebuildLambda m ctorThisValOpt baseValOpt argvs (body,rty)) + let pds,z = ExtractPreDecs z + WrapPreDecs m pds (rebuildLambda m ctorThisValOpt baseValOpt argvs (body,rty)),z | Expr.TyLambda(_,argtyvs,body,m,rty) -> let z = EnterInner z - let z,body = TransExpr penv z body + let body,z = TransExpr penv z body let z = ExitInner z - let z,pds = ExtractPreDecs z - z,WrapPreDecs m pds (mkTypeLambda m argtyvs (body,rty)) + let pds,z = ExtractPreDecs z + WrapPreDecs m pds (mkTypeLambda m argtyvs (body,rty)),z /// Lifting TLR out over constructs (disabled) /// Lift minimally to ensure the defn is not lifted up and over defns on which it depends (disabled) | Expr.Match(spBind,exprm,dtree,targets,m,ty) -> let targets = Array.toList targets - let z,dtree = TransDecisionTree penv z dtree - let z,targets = List.foldMap (TransDecisionTreeTarget penv) z targets + let dtree,z = TransDecisionTree penv z dtree + let targets,z = List.mapFold (TransDecisionTreeTarget penv) z targets // TransDecisionTreeTarget wraps EnterInner/exitInnter, so need to collect any top decs - let z,pds = ExtractPreDecs z - z,WrapPreDecs m pds (mkAndSimplifyMatch spBind exprm m ty dtree targets) + let pds,z = ExtractPreDecs z + WrapPreDecs m pds (mkAndSimplifyMatch spBind exprm m ty dtree targets),z // all others - below - rewrite structurally - so boiler plate code after this point... - | Expr.Const _ -> z,expr (* constant wrt Val *) + | Expr.Const _ -> expr,z (* constant wrt Val *) | Expr.Quote (a,{contents=Some(typeDefs,argTypes,argExprs,data)},isFromQueryExpression,m,ty) -> - let z,argExprs = List.foldMap (TransExpr penv) z argExprs - z,Expr.Quote(a,{contents=Some(typeDefs,argTypes,argExprs,data)},isFromQueryExpression,m,ty) + let argExprs,z = List.mapFold (TransExpr penv) z argExprs + Expr.Quote(a,{contents=Some(typeDefs,argTypes,argExprs,data)},isFromQueryExpression,m,ty),z | Expr.Quote (a,{contents=None},isFromQueryExpression,m,ty) -> - z,Expr.Quote(a,{contents=None},isFromQueryExpression,m,ty) + Expr.Quote(a,{contents=None},isFromQueryExpression,m,ty),z | Expr.Op (c,tyargs,args,m) -> - let z,args = List.foldMap (TransExpr penv) z args - z,Expr.Op(c,tyargs,args,m) + let args,z = List.mapFold (TransExpr penv) z args + Expr.Op(c,tyargs,args,m),z | Expr.StaticOptimization (constraints,e2,e3,m) -> - let z,e2 = TransExpr penv z e2 - let z,e3 = TransExpr penv z e3 - z,Expr.StaticOptimization(constraints,e2,e3,m) + let e2,z = TransExpr penv z e2 + let e3,z = TransExpr penv z e3 + Expr.StaticOptimization(constraints,e2,e3,m),z | Expr.TyChoose (_,_,m) -> error(Error(FSComp.SR.tlrUnexpectedTExpr(),m)) /// Walk over linear structured terms in tail-recursive loop, using a continuation /// to represent the rebuild-the-term stack - and TransLinearExpr penv z expr contf = + and TransLinearExpr penv z expr (contf: Expr * RewriteState -> Expr * RewriteState) = match expr with | Expr.Sequential (e1,e2,dir,spSeq,m) -> - let z,e1 = TransExpr penv z e1 - TransLinearExpr penv z e2 (contf << (fun (z,e2) -> - z,Expr.Sequential(e1,e2,dir,spSeq,m))) + let e1,z = TransExpr penv z e1 + TransLinearExpr penv z e2 (contf << (fun (e2,z) -> + Expr.Sequential(e1,e2,dir,spSeq,m),z)) // letrec - pass_recbinds does the work | Expr.LetRec (binds,e,m,_) -> let z = EnterInner z // For letrec, preDecs from RHS must mutually recurse with those from the bindings let z,pdsPrior = PopPreDecs z - let z,binds = FlatList.foldMap (TransBindingRhs penv) z binds + let binds,z = FlatList.mapFold (TransBindingRhs penv) z binds let z,pdsRhs = PopPreDecs z let binds,rebinds = TransBindings IsRec penv binds let z,binds = LiftTopBinds IsRec penv z binds (* factor Top* repr binds *) @@ -1207,110 +1209,116 @@ module Pass4_RewriteAssembly = let z,pdsBind = PopPreDecs z let z = SetPreDecs z (TreeNode [pdsPrior;RecursivePreDecs pdsBind pdsRhs]) let z = ExitInner z - let z,pds = ExtractPreDecs z + let pds,z = ExtractPreDecs z // tailcall - TransLinearExpr penv z e (contf << (fun (z,e) -> + TransLinearExpr penv z e (contf << (fun (e,z) -> let e = mkLetsFromBindings m rebinds e - z,WrapPreDecs m pds (Expr.LetRec (binds,e,m,NewFreeVarsCache())))) + WrapPreDecs m pds (Expr.LetRec (binds,e,m,NewFreeVarsCache())),z)) // let - can consider the mu-let bindings as mu-letrec bindings - so like as above | Expr.Let (bind,e,m,_) -> // For let, preDecs from RHS go before those of bindings, which is collection order - let z,bind = TransBindingRhs penv z bind + let bind,z = TransBindingRhs penv z bind let binds,rebinds = TransBindings NotRec penv (FlatList.one bind) // factor Top* repr binds let z,binds = LiftTopBinds NotRec penv z binds let z,rebinds = LiftTopBinds NotRec penv z rebinds // any lifted PreDecs from binding, if so wrap them... - let z,pds = ExtractPreDecs z + let pds,z = ExtractPreDecs z // tailcall - TransLinearExpr penv z e (contf << (fun (z,e) -> + TransLinearExpr penv z e (contf << (fun (e,z) -> let e = mkLetsFromBindings m rebinds e - z,WrapPreDecs m pds (mkLetsFromBindings m binds e))) + WrapPreDecs m pds (mkLetsFromBindings m binds e),z)) | LinearMatchExpr (spBind,exprm,dtree,tg1,e2,sp2,m2,ty) -> - let z,dtree = TransDecisionTree penv z dtree - let z,tg1 = TransDecisionTreeTarget penv z tg1 + let dtree,z = TransDecisionTree penv z dtree + let tg1,z = TransDecisionTreeTarget penv z tg1 // tailcall - TransLinearExpr penv z e2 (contf << (fun (z,e2) -> - z,rebuildLinearMatchExpr (spBind,exprm,dtree,tg1,e2,sp2,m2,ty))) + TransLinearExpr penv z e2 (contf << (fun (e2,z) -> + rebuildLinearMatchExpr (spBind,exprm,dtree,tg1,e2,sp2,m2,ty),z)) | _ -> contf (TransExpr penv z expr) - and TransMethod penv z (TObjExprMethod(slotsig,attribs,tps,vs,e,m)) = + and TransMethod penv (z:RewriteState) (TObjExprMethod(slotsig,attribs,tps,vs,e,m)) = let z = EnterInner z - let z,e = TransExpr penv z e + let e,z = TransExpr penv z e let z = ExitInner z - z,TObjExprMethod(slotsig,attribs,tps,vs,e,m) + TObjExprMethod(slotsig,attribs,tps,vs,e,m),z - and TransBindingRhs penv z (TBind(v,e,letSeqPtOpt)) = + and TransBindingRhs penv z (TBind(v,e,letSeqPtOpt)) : Binding * RewriteState = let mustInline = v.MustInline let z,e = EnterMustInline mustInline z (fun z -> TransExpr penv z e) - z,TBind (v,e,letSeqPtOpt) + TBind (v,e,letSeqPtOpt),z - and TransDecisionTree penv z x = + and TransDecisionTree penv z x : DecisionTree * RewriteState = match x with | TDSuccess (es,n) -> - let z,es = FlatList.foldMap (TransExpr penv) z es - z,TDSuccess(es,n) + let es,z = FlatList.mapFold (TransExpr penv) z es + TDSuccess(es,n),z | TDBind (bind,rest) -> - let z,bind = TransBindingRhs penv z bind - let z,rest = TransDecisionTree penv z rest - z,TDBind(bind,rest) + let bind,z = TransBindingRhs penv z bind + let rest,z = TransDecisionTree penv z rest + TDBind(bind,rest),z | TDSwitch (e,cases,dflt,m) -> - let z,e = TransExpr penv z e + let e,z = TransExpr penv z e let TransDecisionTreeCase penv z (TCase (discrim,dtree)) = - let z,dtree = TransDecisionTree penv z dtree - z,TCase(discrim,dtree) + let dtree,z = TransDecisionTree penv z dtree + TCase(discrim,dtree),z - let z,cases = List.foldMap (TransDecisionTreeCase penv) z cases - let z,dflt = Option.foldMap (TransDecisionTree penv) z dflt - z,TDSwitch (e,cases,dflt,m) + let cases,z = List.mapFold (TransDecisionTreeCase penv) z cases + let dflt,z = Option.mapFold (TransDecisionTree penv) z dflt + TDSwitch (e,cases,dflt,m),z and TransDecisionTreeTarget penv z (TTarget(vs,e,spTarget)) = let z = EnterInner z - let z,e = TransExpr penv z e + let e,z = TransExpr penv z e let z = ExitInner z - z,TTarget(vs,e,spTarget) + TTarget(vs,e,spTarget),z and TransValBinding penv z bind = TransBindingRhs penv z bind - and TransValBindings penv z binds = FlatList.foldMap (TransValBinding penv) z binds + and TransValBindings penv z binds = FlatList.mapFold (TransValBinding penv) z binds and TransModuleExpr penv z x = match x with | ModuleOrNamespaceExprWithSig(mty,def,m) -> - let z,def = TransModuleDef penv z def - z,ModuleOrNamespaceExprWithSig(mty,def,m) + let def,z = TransModuleDef penv z def + ModuleOrNamespaceExprWithSig(mty,def,m),z - and TransModuleDefs penv z x = List.foldMap (TransModuleDef penv) z x - and TransModuleDef penv (z: RewriteState) x = + and TransModuleDefs penv z x = List.mapFold (TransModuleDef penv) z x + and TransModuleDef penv (z: RewriteState) x : ModuleOrNamespaceExpr * RewriteState = match x with - | TMDefRec(tycons,binds,mbinds,m) -> - let z,binds = TransValBindings penv z binds - let z,mbinds = TransModuleBindings penv z mbinds - z,TMDefRec(tycons,binds,mbinds,m) + | TMDefRec(isRec,tycons,mbinds,m) -> + let mbinds,z = TransModuleBindings penv z mbinds + TMDefRec(isRec,tycons,mbinds,m),z | TMDefLet(bind,m) -> - let z,bind = TransValBinding penv z bind - z,TMDefLet(bind,m) + let bind,z = TransValBinding penv z bind + TMDefLet(bind,m),z | TMDefDo(e,m) -> - let z,_bind = TransExpr penv z e - z,TMDefDo(e,m) + let _bind,z = TransExpr penv z e + TMDefDo(e,m),z | TMDefs(defs) -> - let z,defs = TransModuleDefs penv z defs - z,TMDefs(defs) + let defs,z = TransModuleDefs penv z defs + TMDefs(defs),z | TMAbstract(mexpr) -> - let z,mexpr = TransModuleExpr penv z mexpr - z,TMAbstract(mexpr) - and TransModuleBindings penv z binds = List.foldMap (TransModuleBinding penv) z binds - and TransModuleBinding penv z (ModuleOrNamespaceBinding(nm, rhs)) = - let z,rhs = TransModuleDef penv z rhs - z,ModuleOrNamespaceBinding(nm,rhs) + let mexpr,z = TransModuleExpr penv z mexpr + TMAbstract(mexpr),z + and TransModuleBindings penv z binds = List.mapFold (TransModuleBinding penv) z binds + and TransModuleBinding penv z x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> + let bind,z = TransValBinding penv z bind + ModuleOrNamespaceBinding.Binding bind,z + | ModuleOrNamespaceBinding.Module(nm, rhs) -> + let rhs,z = TransModuleDef penv z rhs + ModuleOrNamespaceBinding.Module(nm,rhs),z - let TransImplFile penv z mv = fmapTImplFile (TransModuleExpr penv) z mv + let TransImplFile penv z (TImplFile(fragName,pragmas,moduleExpr,hasExplicitEntryPoint,isScript)) = + let moduleExpr,z = TransModuleExpr penv z moduleExpr + TImplFile(fragName,pragmas,moduleExpr,hasExplicitEntryPoint,isScript),z let TransAssembly penv z (TAssembly(mvs)) = - let _z,mvs = List.foldMap (TransImplFile penv) z mvs + let mvs,_z = List.mapFold (TransImplFile penv) z mvs TAssembly(mvs) //------------------------------------------------------------------------- @@ -1338,7 +1346,7 @@ let MakeTLRDecisions ccu g expr = // pass4: rewrite if verboseTLR then dprintf "TransExpr(rw)------\n"; - let _,expr = + let expr,_ = let penv : Pass4_RewriteAssembly.RewriteContext = {ccu=ccu; g=g; tlrS=tlrS; topValS=topValS; arityM=arityM; fclassM=fclassM; recShortCallS=recShortCallS; envPackM=envPackM; fHatM=fHatM} let z = Pass4_RewriteAssembly.rewriteState0 diff --git a/src/fsharp/InternalCollections.fs b/src/fsharp/InternalCollections.fs index a18e592a1f..612011cad8 100755 --- a/src/fsharp/InternalCollections.fs +++ b/src/fsharp/InternalCollections.fs @@ -4,8 +4,6 @@ namespace Internal.Utilities.Collections open System open System.Collections.Generic -#nowarn "44" // This construct is deprecated. This F# library function has been renamed. Use 'isSome' instead - [] type internal ValueStrength<'T when 'T : not struct> = | Strong of 'T @@ -34,7 +32,7 @@ type internal AgedLookup<'TKey,'TValue when 'TValue : not struct>(keepStrongly:i let mutable keepMax = max keepStrongly keepMax let requiredToKeep = defaultArg requiredToKeep (fun _ -> false) - /// Look up a the given key, return None if not found. + /// Look up a the given key, return None if not found. let TryPeekKeyValueImpl(data,key) = let rec Lookup key = function // Treat a list of key-value pairs as a lookup collection. @@ -53,11 +51,11 @@ type internal AgedLookup<'TKey,'TValue when 'TValue : not struct>(keepStrongly:i let Add(data,key,value) = data @ [key,value] - /// Promote a particular key value + /// Promote a particular key value. let Promote (data, key, value) = (data |> List.filter (fun (key',_)-> not (areSame(key,key')))) @ [ (key, value) ] - /// Remove a particular key value + /// Remove a particular key value. let RemoveImpl (data, key) = let discard,keep = data |> List.partition (fun (key',_)-> areSame(key,key')) keep, discard @@ -69,7 +67,7 @@ type internal AgedLookup<'TKey,'TValue when 'TValue : not struct>(keepStrongly:i result,Promote (data,key',value) | None -> None,data - /// Remove weak entries from the list that have been collected + /// Remove weak entries from the list that have been collected. let FilterAndHold() = [ for (key,value) in refs do match value with @@ -154,7 +152,7 @@ type internal AgedLookup<'TKey,'TValue when 'TValue : not struct>(keepStrongly:i type internal MruCache<'TKey,'TValue when 'TValue : not struct>(keepStrongly, areSame, ?isStillValid : 'TKey*'TValue->bool, ?areSameForSubsumption, ?requiredToKeep, ?onStrongDiscard, ?keepMax) = - /// Default behavior of areSameForSubsumption function is areSame + /// Default behavior of areSameForSubsumption function is areSame. let areSameForSubsumption = defaultArg areSameForSubsumption areSame /// The list of items in the cache. Youngest is at the end of the list. @@ -194,7 +192,8 @@ type internal MruCache<'TKey,'TValue when 'TValue : not struct>(keepStrongly, ar /// List helpers [] type internal List = - /// Return a new list with one element for each unique 'TKey. Multiple 'TValues are flattened. The original order of the first instance of 'TKey is preserved. + /// Return a new list with one element for each unique 'TKey. Multiple 'TValues are flattened. + /// The original order of the first instance of 'TKey is preserved. static member groupByFirst( l : ('TKey * 'TValue) list) : ('TKey * 'TValue list) list = let nextIndex = ref 0 let result = System.Collections.Generic.List<'TKey * System.Collections.Generic.List<'TValue>>() diff --git a/src/fsharp/InternalCollections.fsi b/src/fsharp/InternalCollections.fsi index bf4c4a4395..77b3c4fb40 100755 --- a/src/fsharp/InternalCollections.fsi +++ b/src/fsharp/InternalCollections.fsi @@ -20,7 +20,7 @@ namespace Internal.Utilities.Collections /// Returns the original key value because the areSame function /// may have unified two different keys. member TryGetKeyValue : key:'TKey -> ('TKey*'TValue) option - /// Lookup a value and make it the most recent. Return None if it wasn't there. + /// Lookup a value and make it the most recent. Return None if it wasn't there. member TryGet : key:'TKey -> 'TValue option /// Add an element to the collection. Make it the most recent. member Put : 'TKey*'TValue -> unit @@ -31,7 +31,7 @@ namespace Internal.Utilities.Collections /// Resize member Resize : keepStrongly: int * ?keepMax : int -> unit - /// Simple priority caching for a small number of key\value associations. + /// Simple priority caching for a small number of key/value associations. /// This cache may age-out results that have been Set by the caller. /// Because of this, the caller must be able to tolerate values /// that aren't what was originally passed to the Set function. @@ -46,7 +46,7 @@ namespace Internal.Utilities.Collections -> MruCache<'TKey,'TValue> /// Clear out the cache. member Clear : unit -> unit - /// Get the value for the given key or None if not already available + /// Get the value for the given key or None if not already available. member TryGetAny : key:'TKey -> 'TValue option /// Get the value for the given key or None if not already available member TryGet : key:'TKey -> 'TValue option @@ -59,7 +59,8 @@ namespace Internal.Utilities.Collections [] type internal List = - /// Return a new list with one element for each unique 'TKey. Multiple 'TValues are flattened. The original order of the first instance of 'TKey is preserved. + /// Return a new list with one element for each unique 'TKey. Multiple 'TValues are flattened. + /// The original order of the first instance of 'TKey is preserved. static member groupByFirst : l:('TKey * 'TValue) list -> ('TKey * 'TValue list) list when 'TKey : equality /// Return each distinct item in the list using reference equality. static member referenceDistinct : 'T list -> 'T list when 'T : not struct diff --git a/src/fsharp/LexFilter.fs b/src/fsharp/LexFilter.fs index c8c0ba139f..e4ef817ca7 100755 --- a/src/fsharp/LexFilter.fs +++ b/src/fsharp/LexFilter.fs @@ -1316,10 +1316,7 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer, // Applied when a token other then a long identifier is seen | _, (CtxtNamespaceHead (namespaceTokenPos, prevToken) :: _) -> match prevToken, token with - | NAMESPACE, GLOBAL when namespaceTokenPos.Column < tokenStartPos.Column -> - replaceCtxt tokenTup (CtxtNamespaceHead (namespaceTokenPos, token)) - returnToken tokenLexbufState token - | (NAMESPACE | DOT), IDENT _ when namespaceTokenPos.Column < tokenStartPos.Column -> + | (NAMESPACE | DOT | REC | GLOBAL), (REC | IDENT _ | GLOBAL) when namespaceTokenPos.Column < tokenStartPos.Column -> replaceCtxt tokenTup (CtxtNamespaceHead (namespaceTokenPos, token)) returnToken tokenLexbufState token | IDENT _, DOT when namespaceTokenPos.Column < tokenStartPos.Column -> @@ -1348,7 +1345,7 @@ type LexFilterImpl (lightSyntaxStatus:LightSyntaxStatus, compilingFsLib, lexer, returnToken tokenLexbufState token | MODULE, (PUBLIC | PRIVATE | INTERNAL) when moduleTokenPos.Column < tokenStartPos.Column -> returnToken tokenLexbufState token - | (MODULE | DOT), IDENT _ when moduleTokenPos.Column < tokenStartPos.Column -> + | (MODULE | DOT | REC), (REC | IDENT _) when moduleTokenPos.Column < tokenStartPos.Column -> replaceCtxt tokenTup (CtxtModuleHead (moduleTokenPos, token)) returnToken tokenLexbufState token | IDENT _, DOT when moduleTokenPos.Column < tokenStartPos.Column -> diff --git a/src/fsharp/LowerCallsAndSeqs.fs b/src/fsharp/LowerCallsAndSeqs.fs index 9d6ea75deb..571997f761 100755 --- a/src/fsharp/LowerCallsAndSeqs.fs +++ b/src/fsharp/LowerCallsAndSeqs.fs @@ -4,21 +4,24 @@ module internal Microsoft.FSharp.Compiler.LowerCallsAndSeqs open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Infos -open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.MethodCalls //---------------------------------------------------------------------------- // Eta-expansion of calls to top-level-methods diff --git a/src/fsharp/MethodCalls.fs b/src/fsharp/MethodCalls.fs new file mode 100644 index 0000000000..f747e52490 --- /dev/null +++ b/src/fsharp/MethodCalls.fs @@ -0,0 +1,1212 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +/// Logic associated with resolving method calls. +module internal Microsoft.FSharp.Compiler.MethodCalls + +open Internal.Utilities +open System.Text + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.Tastops.DebugPrint +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.TypeRelations + +#if EXTENSIONTYPING +open Microsoft.FSharp.Compiler.ExtensionTyping +#endif + + + +//------------------------------------------------------------------------- +// Sets of methods involved in overload resolution and trait constraint +// satisfaction. +//------------------------------------------------------------------------- + +/// In the following, 'T gets instantiated to: +/// 1. the expression being supplied for an argument +/// 2. "unit", when simply checking for the existence of an overload that satisfies +/// a signature, or when finding the corresponding witness. +/// Note the parametricity helps ensure that overload resolution doesn't depend on the +/// expression on the callside (though it is in some circumstances allowed +/// to depend on some type information inferred syntactically from that +/// expression, e.g. a lambda expression may be converted to a delegate as +/// an adhoc conversion. +/// +/// The bool indicates if named using a '?' +type CallerArg<'T> = + /// CallerArg(ty, range, isOpt, exprInfo) + | CallerArg of TType * range * bool * 'T + member x.Type = (let (CallerArg(ty,_,_,_)) = x in ty) + member x.Range = (let (CallerArg(_,m,_,_)) = x in m) + member x.IsOptional = (let (CallerArg(_,_,isOpt,_)) = x in isOpt) + member x.Expr = (let (CallerArg(_,_,_,expr)) = x in expr) + +/// Represents the information about an argument in the method being called +type CalledArg = + { Position: (int * int) + IsParamArray : bool + OptArgInfo : OptionalArgInfo + CallerInfoInfo : CallerInfoInfo + IsOutArg: bool + ReflArgInfo: ReflectedArgInfo + NameOpt: Ident option + CalledArgumentType : TType } + +let CalledArg(pos,isParamArray,optArgInfo,callerInfoInfo,isOutArg,nameOpt,reflArgInfo,calledArgTy) = + { Position=pos + IsParamArray=isParamArray + OptArgInfo =optArgInfo + CallerInfoInfo = callerInfoInfo + IsOutArg=isOutArg + ReflArgInfo=reflArgInfo + NameOpt=nameOpt + CalledArgumentType = calledArgTy } + +/// Represents a match between a caller argument and a called argument, arising from either +/// a named argument or an unnamed argument. +type AssignedCalledArg<'T> = + { /// The identifier for a named argument, if any + NamedArgIdOpt : Ident option + /// The called argument in the method + CalledArg: CalledArg + /// The argument on the caller side + CallerArg: CallerArg<'T> } + member x.Position = x.CalledArg.Position + +/// Represents the possibilities for a named-setter argument (a property, field , or a record field setter) +type AssignedItemSetterTarget = + | AssignedPropSetter of PropInfo * MethInfo * TypeInst (* the MethInfo is a non-indexer setter property *) + | AssignedILFieldSetter of ILFieldInfo + | AssignedRecdFieldSetter of RecdFieldInfo + +/// Represents the resolution of a caller argument as a named-setter argument +type AssignedItemSetter<'T> = AssignedItemSetter of Ident * AssignedItemSetterTarget * CallerArg<'T> + +type CallerNamedArg<'T> = + | CallerNamedArg of Ident * CallerArg<'T> + member x.Ident = (let (CallerNamedArg(id,_)) = x in id) + member x.Name = x.Ident.idText + member x.CallerArg = (let (CallerNamedArg(_,a)) = x in a) + +//------------------------------------------------------------------------- +// Callsite conversions +//------------------------------------------------------------------------- + +// F# supports three adhoc conversions at method callsites (note C# supports more, though ones +// such as implicit conversions interact badly with type inference). +// +// 1. The use of "(fun x y -> ...)" when a delegate it expected. This is not part of +// the ":>" coercion relationship or inference constraint problem as +// such, but is a special rule applied only to method arguments. +// +// The function AdjustCalledArgType detects this case based on types and needs to know that the type being applied +// is a function type. +// +// 2. The use of "(fun x y -> ...)" when Expression it expected. This is similar to above. +// +// 3. Two ways to pass a value where a byref is expected. The first (default) +// is to use a reference cell, and the interior address is taken automatically +// The second is an explicit use of the "address-of" operator "&e". Here we detect the second case, +// and record the presence of the sytnax "&e" in the pre-inferred actual type for the method argument. +// The function AdjustCalledArgType detects this and refuses to apply the default byref-to-ref transformation. +// +// The function AdjustCalledArgType also adjusts for optional arguments. +let AdjustCalledArgType (infoReader:InfoReader) isConstraint (calledArg: CalledArg) (callerArg: CallerArg<_>) = + let g = infoReader.g + // #424218 - when overload resolution is part of constraint solving - do not perform type-directed conversions + let calledArgTy = calledArg.CalledArgumentType + let callerArgTy = callerArg.Type + let m = callerArg.Range + if isConstraint then calledArgTy else + // If the called method argument is a byref type, then the caller may provide a byref or ref + if isByrefTy g calledArgTy then + if isByrefTy g callerArgTy then + calledArgTy + else + mkRefCellTy g (destByrefTy g calledArgTy) + else + // If the called method argument is a delegate type, then the caller may provide a function + let calledArgTy = + let adjustDelegateTy calledTy = + let (SigOfFunctionForDelegate(_,delArgTys,_,fty)) = GetSigOfFunctionForDelegate infoReader calledTy m AccessibleFromSomeFSharpCode + let delArgTys = (if isNil delArgTys then [g.unit_ty] else delArgTys) + if (fst (stripFunTy g callerArgTy)).Length = delArgTys.Length + then fty + else calledArgTy + + if isDelegateTy g calledArgTy && isFunTy g callerArgTy then + adjustDelegateTy calledArgTy + + elif isLinqExpressionTy g calledArgTy && isFunTy g callerArgTy then + let origArgTy = calledArgTy + let calledArgTy = destLinqExpressionTy g calledArgTy + if isDelegateTy g calledArgTy then + adjustDelegateTy calledArgTy + else + // BUG 435170: called arg is Expr<'t> where 't is not delegate - such conversion is not legal -> return original type + origArgTy + + elif calledArg.ReflArgInfo.AutoQuote && isQuotedExprTy g calledArgTy && not (isQuotedExprTy g callerArgTy) then + destQuotedExprTy g calledArgTy + + else calledArgTy + + // Adjust the called argument type to take into account whether the caller's argument is M(?arg=Some(3)) or M(arg=1) + // If the called method argument is optional with type Option, then the caller may provide a T, unless their argument is propogating-optional (i.e. isOptCallerArg) + let calledArgTy = + match calledArg.OptArgInfo with + | NotOptional -> calledArgTy + | CalleeSide when not callerArg.IsOptional && isOptionTy g calledArgTy -> destOptionTy g calledArgTy + | CalleeSide | CallerSide _ -> calledArgTy + calledArgTy + + +//------------------------------------------------------------------------- +// CalledMeth +//------------------------------------------------------------------------- + +type CalledMethArgSet<'T> = + { /// The called arguments corresponding to "unnamed" arguments + UnnamedCalledArgs : CalledArg list + /// Any unnamed caller arguments not otherwise assigned + UnnamedCallerArgs : CallerArg<'T> list + /// The called "ParamArray" argument, if any + ParamArrayCalledArgOpt : CalledArg option + /// Any unnamed caller arguments assigned to a "param array" argument + ParamArrayCallerArgs : CallerArg<'T> list + /// Named args + AssignedNamedArgs: AssignedCalledArg<'T> list } + member x.NumUnnamedCallerArgs = x.UnnamedCallerArgs.Length + member x.NumAssignedNamedArgs = x.AssignedNamedArgs.Length + member x.NumUnnamedCalledArgs = x.UnnamedCalledArgs.Length + + +let MakeCalledArgs amap m (minfo:MethInfo) minst = + // Mark up the arguments with their position, so we can sort them back into order later + let paramDatas = minfo.GetParamDatas(amap, m, minst) + paramDatas |> List.mapiSquared (fun i j (ParamData(isParamArrayArg,isOutArg,optArgInfo,callerInfoFlags,nmOpt,reflArgInfo,typeOfCalledArg)) -> + { Position=(i,j) + IsParamArray=isParamArrayArg + OptArgInfo=optArgInfo + CallerInfoInfo = callerInfoFlags + IsOutArg=isOutArg + ReflArgInfo=reflArgInfo + NameOpt=nmOpt + CalledArgumentType=typeOfCalledArg }) + +/// Represents the syntactic matching between a caller of a method and the called method. +/// +/// The constructor takes all the information about the caller and called side of a method, match up named arguments, property setters etc., +/// and returns a CalledMeth object for further analysis. +type CalledMeth<'T> + (infoReader:InfoReader, + nameEnv: NameResolutionEnv option, + isCheckingAttributeCall, + freshenMethInfo,// a function to help generate fresh type variables the property setters methods in generic classes + m, + ad, // the access domain of the place where the call is taking place + minfo:MethInfo, // the method we're attempting to call + calledTyArgs, // the 'called type arguments', i.e. the fresh generic instantiation of the method we're attempting to call + callerTyArgs: TType list, // the 'caller type arguments', i.e. user-given generic instantiation of the method we're attempting to call + pinfoOpt: PropInfo option, // the property related to the method we're attempting to call, if any + callerObjArgTys: TType list, // the types of the actual object argument, if any + curriedCallerArgs: (CallerArg<'T> list * CallerNamedArg<'T> list) list, // the data about any arguments supplied by the caller + allowParamArgs:bool, // do we allow the use of a param args method in its "expanded" form? + allowOutAndOptArgs: bool, // do we allow the use of the transformation that converts out arguments as tuple returns? + tyargsOpt : TType option) // method parameters + = + let g = infoReader.g + let methodRetTy = minfo.GetFSharpReturnTy(infoReader.amap, m, calledTyArgs) + + let fullCurriedCalledArgs = MakeCalledArgs infoReader.amap m minfo calledTyArgs + do assert (fullCurriedCalledArgs.Length = fullCurriedCalledArgs.Length) + + let argSetInfos = + (curriedCallerArgs, fullCurriedCalledArgs) ||> List.map2 (fun (unnamedCallerArgs,namedCallerArgs) fullCalledArgs -> + // Find the arguments not given by name + let unnamedCalledArgs = + fullCalledArgs |> List.filter (fun calledArg -> + match calledArg.NameOpt with + | Some nm -> namedCallerArgs |> List.forall (fun (CallerNamedArg(nm2,_e)) -> nm.idText <> nm2.idText) + | None -> true) + + // See if any of them are 'out' arguments being returned as part of a return tuple + let unnamedCalledArgs, unnamedCalledOptArgs, unnamedCalledOutArgs = + let nUnnamedCallerArgs = unnamedCallerArgs.Length + if allowOutAndOptArgs && nUnnamedCallerArgs < unnamedCalledArgs.Length then + let unnamedCalledArgsTrimmed,unnamedCalledOptOrOutArgs = List.chop nUnnamedCallerArgs unnamedCalledArgs + + // Check if all optional/out arguments are byref-out args + if unnamedCalledOptOrOutArgs |> List.forall (fun x -> x.IsOutArg && isByrefTy g x.CalledArgumentType) then + unnamedCalledArgsTrimmed,[],unnamedCalledOptOrOutArgs + // Check if all optional/out arguments are optional args + elif unnamedCalledOptOrOutArgs |> List.forall (fun x -> x.OptArgInfo.IsOptional) then + unnamedCalledArgsTrimmed,unnamedCalledOptOrOutArgs,[] + // Otherwise drop them on the floor + else + unnamedCalledArgs,[],[] + else + unnamedCalledArgs,[],[] + + let (unnamedCallerArgs,paramArrayCallerArgs),unnamedCalledArgs,paramArrayCalledArgOpt = + let minArgs = unnamedCalledArgs.Length - 1 + let supportsParamArgs = + allowParamArgs && + minArgs >= 0 && + unnamedCalledArgs |> List.last |> (fun calledArg -> calledArg.IsParamArray && isArray1DTy g calledArg.CalledArgumentType) + + if supportsParamArgs && unnamedCallerArgs.Length >= minArgs then + let a,b = List.frontAndBack unnamedCalledArgs + List.chop minArgs unnamedCallerArgs, a, Some(b) + else + (unnamedCallerArgs, []),unnamedCalledArgs, None + + let assignedNamedArgs = + fullCalledArgs |> List.choose (fun calledArg -> + match calledArg.NameOpt with + | Some nm -> + namedCallerArgs |> List.tryPick (fun (CallerNamedArg(nm2,callerArg)) -> + if nm.idText = nm2.idText then Some { NamedArgIdOpt = Some nm2; CallerArg=callerArg; CalledArg=calledArg } + else None) + | _ -> None) + + let unassignedNamedItem = + namedCallerArgs |> List.filter (fun (CallerNamedArg(nm,_e)) -> + fullCalledArgs |> List.forall (fun calledArg -> + match calledArg.NameOpt with + | Some nm2 -> nm.idText <> nm2.idText + | None -> true)) + + let attributeAssignedNamedItems,unassignedNamedItem = + if isCheckingAttributeCall then + // the assignment of names to properties is substantially for attribute specifications + // permits bindings of names to non-mutable fields and properties, so we do that using the old + // reliable code for this later on. + unassignedNamedItem,[] + else + [],unassignedNamedItem + + let assignedNamedProps,unassignedNamedItem = + let returnedObjTy = if minfo.IsConstructor then minfo.EnclosingType else methodRetTy + unassignedNamedItem |> List.splitChoose (fun (CallerNamedArg(id,e) as arg) -> + let nm = id.idText + let pinfos = GetIntrinsicPropInfoSetsOfType infoReader (Some(nm),ad,AllowMultiIntfInstantiations.Yes) IgnoreOverrides id.idRange returnedObjTy + let pinfos = pinfos |> ExcludeHiddenOfPropInfos g infoReader.amap m + match pinfos with + | [pinfo] when pinfo.HasSetter && not pinfo.IsIndexer -> + let pminfo = pinfo.SetterMethod + let pminst = freshenMethInfo m pminfo + Choice1Of2(AssignedItemSetter(id,AssignedPropSetter(pinfo,pminfo, pminst), e)) + | _ -> + let epinfos = + match nameEnv with + | Some(ne) -> ExtensionPropInfosOfTypeInScope infoReader ne (Some(nm), ad) m returnedObjTy + | _ -> [] + match epinfos with + | [pinfo] when pinfo.HasSetter && not pinfo.IsIndexer -> + let pminfo = pinfo.SetterMethod + let pminst = match minfo with + | MethInfo.FSMeth(_,TType.TType_app(_,types),_,_) -> types + | _ -> freshenMethInfo m pminfo + + let pminst = match tyargsOpt with + | Some(TType.TType_app(_, types)) -> types + | _ -> pminst + Choice1Of2(AssignedItemSetter(id,AssignedPropSetter(pinfo,pminfo, pminst), e)) + | _ -> + match infoReader.GetILFieldInfosOfType(Some(nm),ad,m,returnedObjTy) with + | finfo :: _ -> + Choice1Of2(AssignedItemSetter(id,AssignedILFieldSetter(finfo), e)) + | _ -> + match infoReader.TryFindRecdOrClassFieldInfoOfType(nm,m,returnedObjTy) with + | Some rfinfo -> + Choice1Of2(AssignedItemSetter(id,AssignedRecdFieldSetter(rfinfo), e)) + | None -> + Choice2Of2(arg)) + + let names = namedCallerArgs |> List.map (fun (CallerNamedArg(nm,_)) -> nm.idText) + + if (List.noRepeats String.order names).Length <> namedCallerArgs.Length then + errorR(Error(FSComp.SR.typrelNamedArgumentHasBeenAssignedMoreThenOnce(),m)) + + let argSet = { UnnamedCalledArgs=unnamedCalledArgs; UnnamedCallerArgs=unnamedCallerArgs; ParamArrayCalledArgOpt=paramArrayCalledArgOpt; ParamArrayCallerArgs=paramArrayCallerArgs; AssignedNamedArgs=assignedNamedArgs } + + (argSet,assignedNamedProps,unassignedNamedItem,attributeAssignedNamedItems,unnamedCalledOptArgs,unnamedCalledOutArgs)) + + let argSets = argSetInfos |> List.map (fun (x,_,_,_,_,_) -> x) + let assignedNamedProps = argSetInfos |> List.collect (fun (_,x,_,_,_,_) -> x) + let unassignedNamedItems = argSetInfos |> List.collect (fun (_,_,x,_,_,_) -> x) + let attributeAssignedNamedItems = argSetInfos |> List.collect (fun (_,_,_,x,_,_) -> x) + let unnamedCalledOptArgs = argSetInfos |> List.collect (fun (_,_,_,_,x,_) -> x) + let unnamedCalledOutArgs = argSetInfos |> List.collect (fun (_,_,_,_,_,x) -> x) + + member x.infoReader = infoReader + member x.amap = infoReader.amap + + /// the method we're attempting to call + member x.Method=minfo + /// the instantiation of the method we're attempting to call + member x.CalledTyArgs=calledTyArgs + /// the formal instantiation of the method we're attempting to call + member x.CallerTyArgs=callerTyArgs + /// The types of the actual object arguments, if any + member x.CallerObjArgTys=callerObjArgTys + /// The argument analysis for each set of curried arguments + member x.ArgSets=argSets + /// return type + member x.ReturnType=methodRetTy + /// named setters + member x.AssignedItemSetters=assignedNamedProps + /// the property related to the method we're attempting to call, if any + member x.AssociatedPropertyInfo=pinfoOpt + /// unassigned args + member x.UnassignedNamedArgs=unassignedNamedItems + /// args assigned to specify values for attribute fields and properties (these are not necessarily "property sets") + member x.AttributeAssignedNamedArgs=attributeAssignedNamedItems + /// unnamed called optional args: pass defaults for these + member x.UnnamedCalledOptArgs=unnamedCalledOptArgs + /// unnamed called out args: return these as part of the return tuple + member x.UnnamedCalledOutArgs=unnamedCalledOutArgs + + static member GetMethod (x:CalledMeth<'T>) = x.Method + + member x.NumArgSets = x.ArgSets.Length + + member x.HasOptArgs = nonNil x.UnnamedCalledOptArgs + member x.HasOutArgs = nonNil x.UnnamedCalledOutArgs + member x.UsesParamArrayConversion = x.ArgSets |> List.exists (fun argSet -> argSet.ParamArrayCalledArgOpt.IsSome) + member x.ParamArrayCalledArgOpt = x.ArgSets |> List.tryPick (fun argSet -> argSet.ParamArrayCalledArgOpt) + member x.ParamArrayCallerArgs = x.ArgSets |> List.tryPick (fun argSet -> if isSome argSet.ParamArrayCalledArgOpt then Some argSet.ParamArrayCallerArgs else None ) + member x.ParamArrayElementType = + assert (x.UsesParamArrayConversion) + x.ParamArrayCalledArgOpt.Value.CalledArgumentType |> destArrayTy x.amap.g + member x.NumAssignedProps = x.AssignedItemSetters.Length + member x.CalledObjArgTys(m) = x.Method.GetObjArgTypes(x.amap, m, x.CalledTyArgs) + member x.NumCalledTyArgs = x.CalledTyArgs.Length + member x.NumCallerTyArgs = x.CallerTyArgs.Length + + member x.AssignsAllNamedArgs = isNil x.UnassignedNamedArgs + + member x.HasCorrectArity = + (x.NumCalledTyArgs = x.NumCallerTyArgs) && + x.ArgSets |> List.forall (fun argSet -> argSet.NumUnnamedCalledArgs = argSet.NumUnnamedCallerArgs) + + member x.HasCorrectGenericArity = + (x.NumCalledTyArgs = x.NumCallerTyArgs) + + member x.IsAccessible(m,ad) = + IsMethInfoAccessible x.amap m ad x.Method + + member x.HasCorrectObjArgs(m) = + x.CalledObjArgTys(m).Length = x.CallerObjArgTys.Length + + member x.IsCandidate(m,ad) = + x.IsAccessible(m,ad) && + x.HasCorrectArity && + x.HasCorrectObjArgs(m) && + x.AssignsAllNamedArgs + + member x.AssignedUnnamedArgs = + // We use Seq.map2 to tolerate there being mismatched caller/called args + x.ArgSets |> List.map (fun argSet -> + (argSet.UnnamedCalledArgs, argSet.UnnamedCallerArgs) ||> Seq.map2 (fun calledArg callerArg -> + { NamedArgIdOpt=None; CalledArg=calledArg; CallerArg=callerArg }) |> Seq.toList) + + member x.AssignedNamedArgs = + x.ArgSets |> List.map (fun argSet -> argSet.AssignedNamedArgs) + + member x.AllUnnamedCalledArgs = x.ArgSets |> List.collect (fun x -> x.UnnamedCalledArgs) + member x.TotalNumUnnamedCalledArgs = x.ArgSets |> List.sumBy (fun x -> x.NumUnnamedCalledArgs) + member x.TotalNumUnnamedCallerArgs = x.ArgSets |> List.sumBy (fun x -> x.NumUnnamedCallerArgs) + member x.TotalNumAssignedNamedArgs = x.ArgSets |> List.sumBy (fun x -> x.NumAssignedNamedArgs) + +let NamesOfCalledArgs (calledArgs: CalledArg list) = + calledArgs |> List.choose (fun x -> x.NameOpt) + +//------------------------------------------------------------------------- +// Helpers dealing with propagating type information in method overload resolution +//------------------------------------------------------------------------- + +type ArgumentAnalysis = + | NoInfo + | ArgDoesNotMatch + | CallerLambdaHasArgTypes of TType list + | CalledArgMatchesType of TType + +let InferLambdaArgsForLambdaPropagation origRhsExpr = + let rec loop e = + match e with + | SynExpr.Lambda(_,_,_,rest,_) -> 1 + loop rest + | SynExpr.MatchLambda _ -> 1 + | _ -> 0 + loop origRhsExpr + +let ExamineArgumentForLambdaPropagation (infoReader:InfoReader) (arg: AssignedCalledArg) = + let g = infoReader.g + // Find the explicit lambda arguments of the caller. Ignore parentheses. + let argExpr = match arg.CallerArg.Expr with SynExpr.Paren(x,_,_,_) -> x | x -> x + let countOfCallerLambdaArg = InferLambdaArgsForLambdaPropagation argExpr + // Adjust for Expression<_>, Func<_,_>, ... + let adjustedCalledArgTy = AdjustCalledArgType infoReader false arg.CalledArg arg.CallerArg + if countOfCallerLambdaArg > 0 then + // Decompose the explicit function type of the target + let calledLambdaArgTys,_calledLambdaRetTy = Tastops.stripFunTy g adjustedCalledArgTy + if calledLambdaArgTys.Length >= countOfCallerLambdaArg then + // success + CallerLambdaHasArgTypes calledLambdaArgTys + elif isDelegateTy g (if isLinqExpressionTy g adjustedCalledArgTy then destLinqExpressionTy g adjustedCalledArgTy else adjustedCalledArgTy) then + ArgDoesNotMatch // delegate arity mismatch + else + NoInfo // not a function type on the called side - no information + else CalledArgMatchesType(adjustedCalledArgTy) // not a lambda on the caller side - push information from caller to called + +let ExamineMethodForLambdaPropagation(x:CalledMeth) = + let unnamedInfo = x.AssignedUnnamedArgs |> List.mapSquared (ExamineArgumentForLambdaPropagation x.infoReader) + let namedInfo = x.AssignedNamedArgs |> List.mapSquared (fun arg -> (arg.NamedArgIdOpt.Value, ExamineArgumentForLambdaPropagation x.infoReader arg)) + if unnamedInfo |> List.existsSquared (function CallerLambdaHasArgTypes _ -> true | _ -> false) || + namedInfo |> List.existsSquared (function (_,CallerLambdaHasArgTypes _) -> true | _ -> false) then + Some (unnamedInfo, namedInfo) + else + None + +//------------------------------------------------------------------------- +// Additional helpers for building method calls and doing TAST generation +//------------------------------------------------------------------------- + +/// Is this a 'base' call (in the sense of C#) +let IsBaseCall objArgs = + match objArgs with + | [Expr.Val(v,_,_)] when v.BaseOrThisInfo = BaseVal -> true + | _ -> false + +/// Compute whether we insert a 'coerce' on the 'this' pointer for an object model call +/// For example, when calling an interface method on a struct, or a method on a constrained +/// variable type. +let ComputeConstrainedCallInfo g amap m (objArgs,minfo:MethInfo) = + match objArgs with + | [objArgExpr] when not minfo.IsExtensionMember -> + let methObjTy = minfo.EnclosingType + let objArgTy = tyOfExpr g objArgExpr + if TypeDefinitelySubsumesTypeNoCoercion 0 g amap m methObjTy objArgTy + // Constrained calls to class types can only ever be needed for the three class types that + // are base types of value types + || (isClassTy g methObjTy && + (not (typeEquiv g methObjTy g.system_Object_typ || + typeEquiv g methObjTy g.system_Value_typ || + typeEquiv g methObjTy g.system_Enum_typ))) then + None + else + // The object argument is a value type or variable type and the target method is an interface or System.Object + // type. A .NET 2.0 generic constrained call is required + Some objArgTy + | _ -> + None + + +/// Adjust the 'this' pointer before making a call +/// Take the address of a struct, and coerce to an interface/base/constraint type if necessary +let TakeObjAddrForMethodCall g amap (minfo:MethInfo) isMutable m objArgs f = + let ccallInfo = ComputeConstrainedCallInfo g amap m (objArgs,minfo) + let mustTakeAddress = + (minfo.IsStruct && not minfo.IsExtensionMember) // don't take the address of a struct when passing to an extension member + || + (match ccallInfo with + | Some _ -> true + | None -> false) + let wrap,objArgs = + match objArgs with + | [objArgExpr] -> + let objArgTy = tyOfExpr g objArgExpr + let wrap,objArgExpr' = mkExprAddrOfExpr g mustTakeAddress (isSome ccallInfo) isMutable objArgExpr None m + + // Extension members and calls to class constraints may need a coercion for their object argument + let objArgExpr' = + if isNone ccallInfo && // minfo.IsExtensionMember && minfo.IsStruct && + not (TypeDefinitelySubsumesTypeNoCoercion 0 g amap m minfo.EnclosingType objArgTy) then + mkCoerceExpr(objArgExpr',minfo.EnclosingType,m,objArgTy) + else + objArgExpr' + + wrap,[objArgExpr'] + + | _ -> + (fun x -> x), objArgs + let e,ety = f ccallInfo objArgs + wrap e,ety + +//------------------------------------------------------------------------- +// Build method calls. +//------------------------------------------------------------------------- + +//------------------------------------------------------------------------- +// Build calls +//------------------------------------------------------------------------- + + +/// Build an expression node that is a call to a .NET method. +let BuildILMethInfoCall g amap m isProp (minfo:ILMethInfo) valUseFlags minst direct args = + let valu = isStructTy g minfo.ApparentEnclosingType + let ctor = minfo.IsConstructor + if minfo.IsClassConstructor then + error (InternalError (minfo.ILName+": cannot call a class constructor",m)) + let useCallvirt = + not valu && not direct && minfo.IsVirtual + let isProtected = minfo.IsProtectedAccessibility + let ilMethRef = minfo.ILMethodRef + let newobj = ctor && (match valUseFlags with NormalValUse -> true | _ -> false) + let exprTy = if ctor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnTy(amap, m, minst) + let retTy = (if not ctor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprTy]) + let isDllImport = minfo.IsDllImport g + Expr.Op(TOp.ILCall(useCallvirt,isProtected,valu,newobj,valUseFlags,isProp,isDllImport,ilMethRef,minfo.DeclaringTypeInst,minst,retTy),[],args,m), + exprTy + +/// Build a call to the System.Object constructor taking no arguments, +let BuildObjCtorCall g m = + let ilMethRef = (mkILCtorMethSpecForTy(g.ilg.typ_Object,[])).MethodRef + Expr.Op(TOp.ILCall(false,false,false,false,CtorValUsedAsSuperInit,false,true,ilMethRef,[],[],[g.obj_ty]),[],[],m) + + +/// Build a call to an F# method. +/// +/// Consume the arguments in chunks and build applications. This copes with various F# calling signatures +/// all of which ultimately become 'methods'. +/// +/// QUERY: this looks overly complex considering that we are doing a fundamentally simple +/// thing here. +let BuildFSharpMethodApp g m (vref: ValRef) vexp vexprty (args: Exprs) = + let arities = (arityOfVal vref.Deref).AritiesOfArgs + + let args3,(leftover,retTy) = + ((args,vexprty), arities) ||> List.mapFold (fun (args,fty) arity -> + match arity,args with + | (0|1),[] when typeEquiv g (domainOfFunTy g fty) g.unit_ty -> mkUnit g m, (args, rangeOfFunTy g fty) + | 0,(arg::argst)-> + warning(InternalError(sprintf "Unexpected zero arity, args = %s" (Layout.showL (Layout.sepListL (Layout.rightL ";") (List.map exprL args))),m)); + arg, (argst, rangeOfFunTy g fty) + | 1,(arg :: argst) -> arg, (argst, rangeOfFunTy g fty) + | 1,[] -> error(InternalError("expected additional arguments here",m)) + | _ -> + if args.Length < arity then error(InternalError("internal error in getting arguments, n = "+string arity+", #args = "+string args.Length,m)); + let tupargs,argst = List.chop arity args + let tuptys = tupargs |> List.map (tyOfExpr g) + (mkTupled g m tupargs tuptys), + (argst, rangeOfFunTy g fty) ) + if not leftover.IsEmpty then error(InternalError("Unexpected "+string(leftover.Length)+" remaining arguments in method application",m)) + mkApps g ((vexp,vexprty),[],args3,m), + retTy + +/// Build a call to an F# method. +let BuildFSharpMethodCall g m (typ,vref:ValRef) valUseFlags minst args = + let vexp = Expr.Val (vref,valUseFlags,m) + let vexpty = vref.Type + let tpsorig,tau = vref.TypeScheme + let vtinst = argsOfAppTy g typ @ minst + if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected List.length mismatch",m)) + let expr = mkTyAppExpr m (vexp,vexpty) vtinst + let exprty = instType (mkTyparInst tpsorig vtinst) tau + BuildFSharpMethodApp g m vref expr exprty args + + +/// Make a call to a method info. Used by the optimizer and code generator to build +/// calls to the type-directed solutions to member constraints. +let MakeMethInfoCall amap m minfo minst args = + let valUseFlags = NormalValUse // correct unless if we allow wild trait constraints like "T has a ctor and can be used as a parent class" + match minfo with + | ILMeth(g,ilminfo,_) -> + let direct = not minfo.IsVirtual + let isProp = false // not necessarily correct, but this is only used post-creflect where this flag is irrelevant + BuildILMethInfoCall g amap m isProp ilminfo valUseFlags minst direct args |> fst + | FSMeth(g,typ,vref,_) -> + BuildFSharpMethodCall g m (typ,vref) valUseFlags minst args |> fst + | DefaultStructCtor(_,typ) -> + mkDefault (m,typ) +#if EXTENSIONTYPING + | ProvidedMeth(amap,mi,_,m) -> + let isProp = false // not necessarily correct, but this is only used post-creflect where this flag is irrelevant + let ilMethodRef = Import.ImportProvidedMethodBaseAsILMethodRef amap m mi + let isConstructor = mi.PUntaint((fun c -> c.IsConstructor), m) + let valu = mi.PUntaint((fun c -> c.DeclaringType.IsValueType), m) + let actualTypeInst = [] // GENERIC TYPE PROVIDERS: for generics, we would have something here + let actualMethInst = [] // GENERIC TYPE PROVIDERS: for generics, we would have something here + let ilReturnTys = Option.toList (minfo.GetCompiledReturnTy(amap, m, [])) // GENERIC TYPE PROVIDERS: for generics, we would have more here + // REVIEW: Should we allow protected calls? + Expr.Op(TOp.ILCall(false,false, valu, isConstructor,valUseFlags,isProp,false,ilMethodRef,actualTypeInst,actualMethInst, ilReturnTys),[],args,m) + +#endif + +#if EXTENSIONTYPING +// This imports a provided method, and checks if it is a known compiler intrinsic like "1 + 2" +let TryImportProvidedMethodBaseAsLibraryIntrinsic (amap:Import.ImportMap, m:range, mbase: Tainted) = + let methodName = mbase.PUntaint((fun x -> x.Name),m) + let declaringType = Import.ImportProvidedType amap m (mbase.PApply((fun x -> x.DeclaringType),m)) + if isAppTy amap.g declaringType then + let declaringEntity = tcrefOfAppTy amap.g declaringType + if not declaringEntity.IsLocalRef && ccuEq declaringEntity.nlr.Ccu amap.g.fslibCcu then + match amap.g.knownIntrinsics.TryGetValue ((declaringEntity.LogicalName, methodName)) with + | true,vref -> Some vref + | _ -> + match amap.g.knownFSharpCoreModules.TryGetValue(declaringEntity.LogicalName) with + | true,modRef -> + match modRef.ModuleOrNamespaceType.AllValsByLogicalName |> Seq.tryPick (fun (KeyValue(_,v)) -> if v.CompiledName = methodName then Some v else None) with + | Some v -> Some (mkNestedValRef modRef v) + | None -> None + | _ -> None + else + None + else + None +#endif + + +/// Build an expression that calls a given method info. +/// This is called after overload resolution, and also to call other +/// methods such as 'setters' for properties. +// tcVal: used to convert an F# value into an expression. See tc.fs. +// isProp: is it a property get? +// minst: the instantiation to apply for a generic method +// objArgs: the 'this' argument, if any +// args: the arguments, if any +let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objArgs args = + + let direct = IsBaseCall objArgs + + TakeObjAddrForMethodCall g amap minfo isMutable m objArgs (fun ccallInfo objArgs -> + let allArgs = (objArgs @ args) + let valUseFlags = + if (direct && (match valUseFlags with NormalValUse -> true | _ -> false)) then + VSlotDirectCall + else + match ccallInfo with + | Some ty -> + // printfn "possible constrained call to '%s' at %A" minfo.LogicalName m + PossibleConstrainedCall ty + | None -> + valUseFlags + + match minfo with +#if EXTENSIONTYPING + // By this time this is an erased method info, e.g. one returned from an expression + // REVIEW: copied from tastops, which doesn't allow protected methods + | ProvidedMeth (amap,providedMeth,_,_) -> + // TODO: there is a fair bit of duplication here with mk_il_minfo_call. We should be able to merge these + + /// Build an expression node that is a call to a extension method in a generated assembly + let enclTy = minfo.EnclosingType + // prohibit calls to methods that are declared in specific array types (Get,Set,Address) + // these calls are provided by the runtime and should not be called from the user code + if isArrayTy g enclTy then + let tpe = TypeProviderError(FSComp.SR.tcRuntimeSuppliedMethodCannotBeUsedInUserCode(minfo.DisplayName), providedMeth.TypeProviderDesignation, m) + error (tpe) + let valu = isStructTy g enclTy + let isCtor = minfo.IsConstructor + if minfo.IsClassConstructor then + error (InternalError (minfo.LogicalName ^": cannot call a class constructor",m)) + let useCallvirt = not valu && not direct && minfo.IsVirtual + let isProtected = minfo.IsProtectedAccessiblity + let exprTy = if isCtor then enclTy else minfo.GetFSharpReturnTy(amap, m, minst) + match TryImportProvidedMethodBaseAsLibraryIntrinsic (amap, m, providedMeth) with + | Some fsValRef -> + //reraise() calls are converted to TOp.Reraise in the type checker. So if a provided expression includes a reraise call + // we must put it in that form here. + if valRefEq amap.g fsValRef amap.g.reraise_vref then + mkReraise m exprTy, exprTy + else + let vexp, vexpty = tcVal fsValRef valUseFlags (minfo.DeclaringTypeInst @ minst) m + BuildFSharpMethodApp g m fsValRef vexp vexpty allArgs + | None -> + let ilMethRef = Import.ImportProvidedMethodBaseAsILMethodRef amap m providedMeth + let isNewObj = isCtor && (match valUseFlags with NormalValUse -> true | _ -> false) + let actualTypeInst = + if isTupleTy g enclTy then argsOfAppTy g (mkCompiledTupleTy g (destTupleTy g enclTy)) // provided expressions can include method calls that get properties of tuple types + elif isFunTy g enclTy then [ domainOfFunTy g enclTy; rangeOfFunTy g enclTy ] // provided expressions can call Invoke + else minfo.DeclaringTypeInst + let actualMethInst = minst + let retTy = (if not isCtor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprTy]) + let noTailCall = false + let expr = Expr.Op(TOp.ILCall(useCallvirt,isProtected,valu,isNewObj,valUseFlags,isProp,noTailCall,ilMethRef,actualTypeInst,actualMethInst, retTy),[],allArgs,m) + expr,exprTy + +#endif + + // Build a call to a .NET method + | ILMeth(_,ilMethInfo,_) -> + BuildILMethInfoCall g amap m isProp ilMethInfo valUseFlags minst direct allArgs + + // Build a call to an F# method + | FSMeth(_, _, vref, _) -> + + // Go see if this is a use of a recursive definition... Note we know the value instantiation + // we want to use so we pass that in order not to create a new one. + let vexp, vexpty = tcVal vref valUseFlags (minfo.DeclaringTypeInst @ minst) m + BuildFSharpMethodApp g m vref vexp vexpty allArgs + + // Build a 'call' to a struct default constructor + | DefaultStructCtor (g,typ) -> + if not (TypeHasDefaultValue g m typ) then + errorR(Error(FSComp.SR.tcDefaultStructConstructorCall(),m)) + mkDefault (m,typ), typ) + +//------------------------------------------------------------------------- +// Build delegate constructions (lambdas/functions to delegates) +//------------------------------------------------------------------------- + +/// Implements the elaborated form of adhoc conversions from functions to delegates at member callsites +let BuildNewDelegateExpr (eventInfoOpt:EventInfo option, g, amap, delegateTy, invokeMethInfo:MethInfo, delArgTys, f, fty, m) = + let slotsig = invokeMethInfo.GetSlotSig(amap, m) + let delArgVals,expr = + let topValInfo = ValReprInfo([],List.replicate (List.length delArgTys) ValReprInfo.unnamedTopArg, ValReprInfo.unnamedRetVal) + + // Try to pull apart an explicit lambda and use it directly + // Don't do this in the case where we're adjusting the arguments of a function used to build a .NET-compatible event handler + let lambdaContents = + if isSome eventInfoOpt then + None + else + tryDestTopLambda g amap topValInfo (f, fty) + match lambdaContents with + | None -> + + if List.exists (isByrefTy g) delArgTys then + error(Error(FSComp.SR.tcFunctionRequiresExplicitLambda(List.length delArgTys),m)) + + let delArgVals = delArgTys |> List.mapi (fun i argty -> fst (mkCompGenLocal m ("delegateArg"^string i) argty)) + let expr = + let args = + match eventInfoOpt with + | Some einfo -> + match delArgVals with + | [] -> error(nonStandardEventError einfo.EventName m) + | h :: _ when not (isObjTy g h.Type) -> error(nonStandardEventError einfo.EventName m) + | h :: t -> [exprForVal m h; mkTupledVars g m t] + | None -> + if isNil delArgTys then [mkUnit g m] else List.map (exprForVal m) delArgVals + mkApps g ((f,fty),[],args,m) + delArgVals,expr + + | Some _ -> + if isNil delArgTys then [], mkApps g ((f,fty),[],[mkUnit g m],m) + else + let _,_,_,vsl,body,_ = IteratedAdjustArityOfLambda g amap topValInfo f + List.concat vsl, body + + let meth = TObjExprMethod(slotsig, [], [], [delArgVals], expr, m) + mkObjExpr(delegateTy,None,BuildObjCtorCall g m,[meth],[],m) + +let CoerceFromFSharpFuncToDelegate g amap infoReader ad callerArgTy m callerArgExpr delegateTy = + let (SigOfFunctionForDelegate(invokeMethInfo,delArgTys,_,_)) = GetSigOfFunctionForDelegate infoReader delegateTy m ad + BuildNewDelegateExpr (None, g, amap, delegateTy, invokeMethInfo, delArgTys, callerArgExpr, callerArgTy, m) + + +//------------------------------------------------------------------------- +// Import provided expressions +//------------------------------------------------------------------------- + + +#if EXTENSIONTYPING +// This file is not a great place for this functionality to sit, it's here because of BuildMethodCall +module ProvidedMethodCalls = + + let private convertConstExpr g amap m (constant : Tainted) = + let (obj,objTy) = constant.PApply2(id,m) + let ty = Import.ImportProvidedType amap m objTy + let normTy = normalizeEnumTy g ty + obj.PUntaint((fun v -> + let fail() = raise <| TypeProviderError(FSComp.SR.etUnsupportedConstantType(v.GetType().ToString()), constant.TypeProviderDesignation, m) + try + match v with + | null -> mkNull m ty + | _ when typeEquiv g normTy g.bool_ty -> Expr.Const(Const.Bool(v :?> bool), m, ty) + | _ when typeEquiv g normTy g.sbyte_ty -> Expr.Const(Const.SByte(v :?> sbyte), m, ty) + | _ when typeEquiv g normTy g.byte_ty -> Expr.Const(Const.Byte(v :?> byte), m, ty) + | _ when typeEquiv g normTy g.int16_ty -> Expr.Const(Const.Int16(v :?> int16), m, ty) + | _ when typeEquiv g normTy g.uint16_ty -> Expr.Const(Const.UInt16(v :?> uint16), m, ty) + | _ when typeEquiv g normTy g.int32_ty -> Expr.Const(Const.Int32(v :?> int32), m, ty) + | _ when typeEquiv g normTy g.uint32_ty -> Expr.Const(Const.UInt32(v :?> uint32), m, ty) + | _ when typeEquiv g normTy g.int64_ty -> Expr.Const(Const.Int64(v :?> int64), m, ty) + | _ when typeEquiv g normTy g.uint64_ty -> Expr.Const(Const.UInt64(v :?> uint64), m, ty) + | _ when typeEquiv g normTy g.nativeint_ty -> Expr.Const(Const.IntPtr(v :?> int64), m, ty) + | _ when typeEquiv g normTy g.unativeint_ty -> Expr.Const(Const.UIntPtr(v :?> uint64), m, ty) + | _ when typeEquiv g normTy g.float32_ty -> Expr.Const(Const.Single(v :?> float32), m, ty) + | _ when typeEquiv g normTy g.float_ty -> Expr.Const(Const.Double(v :?> float), m, ty) + | _ when typeEquiv g normTy g.char_ty -> Expr.Const(Const.Char(v :?> char), m, ty) + | _ when typeEquiv g normTy g.string_ty -> Expr.Const(Const.String(v :?> string), m, ty) + | _ when typeEquiv g normTy g.decimal_ty -> Expr.Const(Const.Decimal(v :?> decimal), m, ty) + | _ when typeEquiv g normTy g.unit_ty -> Expr.Const(Const.Unit, m, ty) + | _ -> fail() + with _ -> + fail() + ), range=m) + + /// Erasure over System.Type. + /// + /// This is a reimplementation of the logic of provided-type erasure, working entirely over (tainted, provided) System.Type + /// values. This is used when preparing ParameterInfo objects to give to the provider in GetInvokerExpression. + /// These ParameterInfo have erased ParameterType - giving the provider an erased type makes it considerably easier + /// to implement a correct GetInvokerExpression. + /// + /// Ideally we would implement this operation by converting to an F# TType using ImportSystemType, and then erasing, and then converting + /// back to System.Type. However, there is currently no way to get from an arbitrary F# TType (even the TType for + /// System.Object) to a System.Type to give to the type provider. + let eraseSystemType (amap,m,inputType) = + let rec loop (st:Tainted) = + if st.PUntaint((fun st -> st.IsGenericParameter),m) then st + elif st.PUntaint((fun st -> st.IsArray),m) then + let et = st.PApply((fun st -> st.GetElementType()),m) + let rank = st.PUntaint((fun st -> st.GetArrayRank()),m) + (loop et).PApply((fun st -> ProvidedType.CreateNoContext(if rank = 1 then st.RawSystemType.MakeArrayType() else st.RawSystemType.MakeArrayType(rank))),m) + elif st.PUntaint((fun st -> st.IsByRef),m) then + let et = st.PApply((fun st -> st.GetElementType()),m) + (loop et).PApply((fun st -> ProvidedType.CreateNoContext(st.RawSystemType.MakeByRefType())),m) + elif st.PUntaint((fun st -> st.IsPointer),m) then + let et = st.PApply((fun st -> st.GetElementType()),m) + (loop et).PApply((fun st -> ProvidedType.CreateNoContext(st.RawSystemType.MakePointerType())),m) + else + let isGeneric = st.PUntaint((fun st -> st.IsGenericType),m) + let headType = if isGeneric then st.PApply((fun st -> st.GetGenericTypeDefinition()),m) else st + // We import in order to use IsProvidedErasedTycon, to make sure we at least don't reinvent that + let headTypeAsFSharpType = Import.ImportProvidedNamedType amap m headType + if headTypeAsFSharpType.IsProvidedErasedTycon then + let baseType = + st.PApply((fun st -> + match st.BaseType with + | null -> ProvidedType.CreateNoContext(typeof) // it might be an interface + | st -> st),m) + loop baseType + else + if isGeneric then + let genericArgs = st.PApplyArray((fun st -> st.GetGenericArguments()),"GetGenericArguments",m) + let typars = headTypeAsFSharpType.Typars(m) + // Drop the generic arguments that don't correspond to type arguments, i.e. are units-of-measure + let genericArgs = + [| for (genericArg,tp) in Seq.zip genericArgs typars do + if tp.Kind = TyparKind.Type then + yield genericArg |] + + if genericArgs.Length = 0 then + headType + else + let erasedArgTys = genericArgs |> Array.map loop + headType.PApply((fun st -> + let erasedArgTys = erasedArgTys |> Array.map (fun a -> a.PUntaintNoFailure (fun x -> x.RawSystemType)) + ProvidedType.CreateNoContext(st.RawSystemType.MakeGenericType erasedArgTys)),m) + else + st + loop inputType + + let convertProvidedExpressionToExprAndWitness tcVal (thisArg:Expr option, + allArgs:Exprs, + paramVars:Tainted[], + g,amap,mut,isProp,isSuperInit,m, + expr:Tainted) = + let varConv = + [ for (v,e) in Seq.zip (paramVars |> Seq.map (fun x -> x.PUntaint(id,m))) (Option.toList thisArg @ allArgs) do + yield (v,(None,e)) ] + |> Dictionary.ofList + + let rec exprToExprAndWitness top (ea:Tainted) = + let fail() = error(Error(FSComp.SR.etUnsupportedProvidedExpression(ea.PUntaint((fun etree -> etree.UnderlyingExpressionString), m)),m)) + match ea with + | Tainted.Null -> error(Error(FSComp.SR.etNullProvidedExpression(ea.TypeProviderDesignation),m)) + | _ -> + match ea.PApplyOption((function ProvidedTypeAsExpr x -> Some x | _ -> None), m) with + | Some info -> + let (expr,targetTy) = info.PApply2(id,m) + let srcExpr = exprToExpr expr + let targetTy = Import.ImportProvidedType amap m (targetTy.PApply(id,m)) + let sourceTy = Import.ImportProvidedType amap m (expr.PApply((fun e -> e.Type),m)) + let te = mkCoerceIfNeeded g targetTy sourceTy srcExpr + None, (te, tyOfExpr g te) + | None -> + match ea.PApplyOption((function ProvidedTypeTestExpr x -> Some x | _ -> None), m) with + | Some info -> + let (expr,targetTy) = info.PApply2(id,m) + let srcExpr = exprToExpr expr + let targetTy = Import.ImportProvidedType amap m (targetTy.PApply(id,m)) + let te = mkCallTypeTest g m targetTy srcExpr + None, (te, tyOfExpr g te) + | None -> + match ea.PApplyOption((function ProvidedIfThenElseExpr x -> Some x | _ -> None), m) with + | Some info -> + let test,thenBranch,elseBranch = info.PApply3(id,m) + let testExpr = exprToExpr test + let ifTrueExpr = exprToExpr thenBranch + let ifFalseExpr = exprToExpr elseBranch + let te = mkCond NoSequencePointAtStickyBinding SuppressSequencePointAtTarget m (tyOfExpr g ifTrueExpr) testExpr ifTrueExpr ifFalseExpr + None, (te, tyOfExpr g te) + | None -> + match ea.PApplyOption((function ProvidedVarExpr x -> Some x | _ -> None), m) with + | Some info -> + let _,vTe = varToExpr info + None, (vTe, tyOfExpr g vTe) + | None -> + match ea.PApplyOption((function ProvidedConstantExpr x -> Some x | _ -> None), m) with + | Some info -> + let ce = convertConstExpr g amap m info + None, (ce, tyOfExpr g ce) + | None -> + match ea.PApplyOption((function ProvidedNewTupleExpr x -> Some x | _ -> None), m) with + | Some info -> + let elems = info.PApplyArray(id, "GetInvokerExpresson",m) + let elemsT = elems |> Array.map exprToExpr |> Array.toList + let exprT = mkTupledNoTypes g m elemsT + None, (exprT, tyOfExpr g exprT) + | None -> + match ea.PApplyOption((function ProvidedNewArrayExpr x -> Some x | _ -> None), m) with + | Some info -> + let ty,elems = info.PApply2(id,m) + let tyT = Import.ImportProvidedType amap m ty + let elems = elems.PApplyArray(id, "GetInvokerExpresson",m) + let elemsT = elems |> Array.map exprToExpr |> Array.toList + let exprT = Expr.Op(TOp.Array, [tyT],elemsT,m) + None, (exprT, tyOfExpr g exprT) + | None -> + match ea.PApplyOption((function ProvidedTupleGetExpr x -> Some x | _ -> None), m) with + | Some info -> + let inp,n = info.PApply2(id, m) + let inpT = inp |> exprToExpr + // if type of expression is erased type then we need convert it to the underlying base type + let typeOfExpr = + let t = tyOfExpr g inpT + stripTyEqnsWrtErasure EraseMeasures g t + let tysT = tryDestTupleTy g typeOfExpr + let exprT = mkTupleFieldGet (inpT, tysT, n.PUntaint(id,m), m) + None, (exprT, tyOfExpr g exprT) + | None -> + match ea.PApplyOption((function ProvidedLambdaExpr x -> Some x | _ -> None), m) with + | Some info -> + let v,b = info.PApply2(id, m) + let vT = addVar v + let bT = exprToExpr b + removeVar v + let exprT = mkLambda m vT (bT, tyOfExpr g bT) + None, (exprT, tyOfExpr g exprT) + | None -> + match ea.PApplyOption((function ProvidedLetExpr x -> Some x | _ -> None), m) with + | Some info -> + let v,e,b = info.PApply3(id, m) + let eT = exprToExpr e + let vT = addVar v + let bT = exprToExpr b + removeVar v + let exprT = mkCompGenLet m vT eT bT + None, (exprT, tyOfExpr g exprT) + | None -> + match ea.PApplyOption((function ProvidedVarSetExpr x -> Some x | _ -> None), m) with + | Some info -> + let v,e = info.PApply2(id, m) + let eT = exprToExpr e + let vTopt,_ = varToExpr v + match vTopt with + | None -> + fail() + | Some vT -> + let exprT = mkValSet m (mkLocalValRef vT) eT + None, (exprT, tyOfExpr g exprT) + | None -> + match ea.PApplyOption((function ProvidedWhileLoopExpr x -> Some x | _ -> None), m) with + | Some info -> + let guardExpr,bodyExpr = info.PApply2(id, m) + let guardExprT = exprToExpr guardExpr + let bodyExprT = exprToExpr bodyExpr + let exprT = mkWhile g (SequencePointInfoForWhileLoop.NoSequencePointAtWhileLoop,SpecialWhileLoopMarker.NoSpecialWhileLoopMarker, guardExprT, bodyExprT, m) + None, (exprT, tyOfExpr g exprT) + | None -> + match ea.PApplyOption((function ProvidedForIntegerRangeLoopExpr x -> Some x | _ -> None), m) with + | Some info -> + let v,e1,e2,e3 = info.PApply4(id, m) + let e1T = exprToExpr e1 + let e2T = exprToExpr e2 + let vT = addVar v + let e3T = exprToExpr e3 + removeVar v + let exprT = mkFastForLoop g (SequencePointInfoForForLoop.NoSequencePointAtForLoop,m,vT,e1T,true,e2T,e3T) + None, (exprT, tyOfExpr g exprT) + | None -> + match ea.PApplyOption((function ProvidedNewDelegateExpr x -> Some x | _ -> None), m) with + | Some info -> + let delegateTy,boundVars,delegateBodyExpr = info.PApply3(id, m) + let delegateTyT = Import.ImportProvidedType amap m delegateTy + let vs = boundVars.PApplyArray(id, "GetInvokerExpresson",m) |> Array.toList + let vsT = List.map addVar vs + let delegateBodyExprT = exprToExpr delegateBodyExpr + List.iter removeVar vs + let lambdaExpr = mkLambdas m [] vsT (delegateBodyExprT, tyOfExpr g delegateBodyExprT) + let lambdaExprTy = tyOfExpr g lambdaExpr + let infoReader = InfoReader(g, amap) + let exprT = CoerceFromFSharpFuncToDelegate g amap infoReader AccessorDomain.AccessibleFromSomewhere lambdaExprTy m lambdaExpr delegateTyT + None, (exprT, tyOfExpr g exprT) + | None -> +#if PROVIDED_ADDRESS_OF + match ea.PApplyOption((function ProvidedAddressOfExpr x -> Some x | _ -> None), m) with + | Some e -> + let eT = exprToExpr e + let wrap,ce = mkExprAddrOfExpr g true false DefinitelyMutates eT None m + let ce = wrap ce + None, (ce, tyOfExpr g ce) + | None -> +#endif + match ea.PApplyOption((function ProvidedDefaultExpr x -> Some x | _ -> None), m) with + | Some pty -> + let ty = Import.ImportProvidedType amap m pty + let ce = mkDefault (m, ty) + None, (ce, tyOfExpr g ce) + | None -> + match ea.PApplyOption((function ProvidedCallExpr c -> Some c | _ -> None), m) with + | Some info -> + methodCallToExpr top ea info + | None -> + match ea.PApplyOption((function ProvidedSequentialExpr c -> Some c | _ -> None), m) with + | Some info -> + let e1,e2 = info.PApply2(id, m) + let e1T = exprToExpr e1 + let e2T = exprToExpr e2 + let ce = mkCompGenSequential m e1T e2T + None, (ce, tyOfExpr g ce) + | None -> + match ea.PApplyOption((function ProvidedTryFinallyExpr c -> Some c | _ -> None), m) with + | Some info -> + let e1,e2 = info.PApply2(id, m) + let e1T = exprToExpr e1 + let e2T = exprToExpr e2 + let ce = mkTryFinally g (e1T,e2T,m,tyOfExpr g e1T,SequencePointInfoForTry.NoSequencePointAtTry,SequencePointInfoForFinally.NoSequencePointAtFinally) + None, (ce, tyOfExpr g ce) + | None -> + match ea.PApplyOption((function ProvidedTryWithExpr c -> Some c | _ -> None), m) with + | Some info -> + let bT = exprToExpr (info.PApply((fun (x,_,_,_,_) -> x), m)) + let v1 = info.PApply((fun (_,x,_,_,_) -> x), m) + let v1T = addVar v1 + let e1T = exprToExpr (info.PApply((fun (_,_,x,_,_) -> x), m)) + removeVar v1 + let v2 = info.PApply((fun (_,_,_,x,_) -> x), m) + let v2T = addVar v2 + let e2T = exprToExpr (info.PApply((fun (_,_,_,_,x) -> x), m)) + removeVar v2 + let ce = mkTryWith g (bT,v1T,e1T,v2T,e2T,m,tyOfExpr g bT,SequencePointInfoForTry.NoSequencePointAtTry,SequencePointInfoForWith.NoSequencePointAtWith) + None, (ce, tyOfExpr g ce) + | None -> + match ea.PApplyOption((function ProvidedNewObjectExpr c -> Some c | _ -> None), m) with + | Some info -> + None, ctorCallToExpr info + | None -> + fail() + + + and ctorCallToExpr (ne:Tainted<_>) = + let (ctor,args) = ne.PApply2(id,m) + let targetMethInfo = ProvidedMeth(amap,ctor.PApply((fun ne -> upcast ne),m),None,m) + let objArgs = [] + let arguments = [ for ea in args.PApplyArray(id, "GetInvokerExpresson", m) -> exprToExpr ea ] + let callExpr = BuildMethodCall tcVal g amap Mutates.PossiblyMutates m false targetMethInfo isSuperInit [] objArgs arguments + callExpr + + and addVar (v:Tainted) = + let nm = v.PUntaint ((fun v -> v.Name),m) + let mut = v.PUntaint ((fun v -> v.IsMutable),m) + let vRaw = v.PUntaint (id,m) + let tyT = Import.ImportProvidedType amap m (v.PApply ((fun v -> v.Type),m)) + let vT,vTe = if mut then mkMutableCompGenLocal m nm tyT else mkCompGenLocal m nm tyT + varConv.[vRaw] <- (Some vT,vTe) + vT + + and removeVar (v:Tainted) = + let vRaw = v.PUntaint (id,m) + varConv.Remove vRaw |> ignore + + and methodCallToExpr top _origExpr (mce:Tainted<_>) = + let (objOpt,meth,args) = mce.PApply3(id,m) + let targetMethInfo = ProvidedMeth(amap,meth.PApply((fun mce -> upcast mce), m),None,m) + let objArgs = + match objOpt.PApplyOption(id, m) with + | None -> [] + | Some objExpr -> [exprToExpr objExpr] + + let arguments = [ for ea in args.PApplyArray(id, "GetInvokerExpresson", m) -> exprToExpr ea ] + let genericArguments = + if meth.PUntaint((fun m -> m.IsGenericMethod), m) then + meth.PApplyArray((fun m -> m.GetGenericArguments()), "GetGenericArguments", m) + else + [| |] + let replacementGenericArguments = genericArguments |> Array.map (fun t->Import.ImportProvidedType amap m t) |> List.ofArray + + let mut = if top then mut else PossiblyMutates + let isSuperInit = if top then isSuperInit else ValUseFlag.NormalValUse + let isProp = if top then isProp else false + let callExpr = BuildMethodCall tcVal g amap mut m isProp targetMethInfo isSuperInit replacementGenericArguments objArgs arguments + Some meth, callExpr + + and varToExpr (pe:Tainted) = + // sub in the appropriate argument + // REVIEW: "thisArg" pointer should be first, if present + let vRaw = pe.PUntaint(id,m) + if not (varConv.ContainsKey vRaw) then + let typeProviderDesignation = ExtensionTyping.DisplayNameOfTypeProvider (pe.TypeProvider, m) + error(NumberedError(FSComp.SR.etIncorrectParameterExpression(typeProviderDesignation,vRaw.Name), m)) + varConv.[vRaw] + + and exprToExpr expr = + let _, (resExpr, _) = exprToExprAndWitness false expr + resExpr + + exprToExprAndWitness true expr + + + // fill in parameter holes in the expression + let TranslateInvokerExpressionForProvidedMethodCall tcVal (g, amap, mut, isProp, isSuperInit, mi:Tainted, objArgs, allArgs, m) = + let parameters = + mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters", m) + let paramTys = + parameters + |> Array.map (fun p -> p.PApply((fun st -> st.ParameterType),m)) + let erasedParamTys = + paramTys + |> Array.map (fun pty -> eraseSystemType (amap,m,pty)) + let paramVars = + erasedParamTys + |> Array.mapi (fun i erasedParamTy -> erasedParamTy.PApply((fun ty -> ProvidedVar.Fresh("arg" + i.ToString(),ty)),m)) + + + // encode "this" as the first ParameterExpression, if applicable + let thisArg, paramVars = + match objArgs with + | [objArg] -> + let erasedThisTy = eraseSystemType (amap,m,mi.PApply((fun mi -> mi.DeclaringType),m)) + let thisVar = erasedThisTy.PApply((fun ty -> ProvidedVar.Fresh("this", ty)), m) + Some objArg , Array.append [| thisVar |] paramVars + | [] -> None , paramVars + | _ -> failwith "multiple objArgs?" + + let ea = mi.PApplyWithProvider((fun (methodInfo,provider) -> ExtensionTyping.GetInvokerExpression(provider, methodInfo, [| for p in paramVars -> p.PUntaintNoFailure id |])), m) + + convertProvidedExpressionToExprAndWitness tcVal (thisArg,allArgs,paramVars,g,amap,mut,isProp,isSuperInit,m,ea) + + + let BuildInvokerExpressionForProvidedMethodCall tcVal (g, amap, mi:Tainted, objArgs, mut, isProp, isSuperInit, allArgs, m) = + try + let methInfoOpt, (expr, retTy) = TranslateInvokerExpressionForProvidedMethodCall tcVal (g, amap, mut, isProp, isSuperInit, mi, objArgs, allArgs, m) + + let exprty = GetCompiledReturnTyOfProvidedMethodInfo amap m mi |> GetFSharpViewOfReturnType g + let expr = mkCoerceIfNeeded g exprty retTy expr + methInfoOpt, expr, exprty + with + | :? TypeProviderError as tpe -> + let typeName = mi.PUntaint((fun mb -> mb.DeclaringType.FullName), m) + let methName = mi.PUntaint((fun mb -> mb.Name), m) + raise( tpe.WithContext(typeName, methName) ) // loses original stack trace +#endif diff --git a/src/fsharp/MethodOverrides.fs b/src/fsharp/MethodOverrides.fs new file mode 100644 index 0000000000..cc210ade4c --- /dev/null +++ b/src/fsharp/MethodOverrides.fs @@ -0,0 +1,710 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +/// Primary logic related to method overrides. +module internal Microsoft.FSharp.Compiler.MethodOverrides + +open Internal.Utilities +open System.Text + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.Tastops.DebugPrint +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.TypeRelations + +//------------------------------------------------------------------------- +// Completeness of classes +//------------------------------------------------------------------------- + +type OverrideCanImplement = + | CanImplementAnyInterfaceSlot + | CanImplementAnyClassHierarchySlot + | CanImplementAnySlot + | CanImplementNoSlots + +/// The overall information about a method implementation in a class or object expression +type OverrideInfo = + | Override of OverrideCanImplement * TyconRef * Ident * (Typars * TyparInst) * TType list list * TType option * bool * bool + member x.CanImplement = let (Override(a,_,_,_,_,_,_,_)) = x in a + member x.BoundingTyconRef = let (Override(_,ty,_,_,_,_,_,_)) = x in ty + member x.LogicalName = let (Override(_,_,id,_,_,_,_,_)) = x in id.idText + member x.Range = let (Override(_,_,id,_,_,_,_,_)) = x in id.idRange + member x.IsFakeEventProperty = let (Override(_,_,_,_,_,_,b,_)) = x in b + member x.ArgTypes = let (Override(_,_,_,_,b,_,_,_)) = x in b + member x.ReturnType = let (Override(_,_,_,_,_,b,_,_)) = x in b + member x.IsCompilerGenerated = let (Override(_,_,_,_,_,_,_,b)) = x in b + +// If the bool is true then the slot is optional, i.e. is an interface slot +// which does not _have_ to be implemented, because an inherited implementation +// is available. +type RequiredSlot = RequiredSlot of MethInfo * (* isOptional: *) bool + +type SlotImplSet = SlotImplSet of RequiredSlot list * NameMultiMap * OverrideInfo list * PropInfo list + +exception TypeIsImplicitlyAbstract of range +exception OverrideDoesntOverride of DisplayEnv * OverrideInfo * MethInfo option * TcGlobals * Import.ImportMap * range + +module DispatchSlotChecking = + + /// Print the signature of an override to a buffer as part of an error message + let PrintOverrideToBuffer denv os (Override(_,_,id,(mtps,memberToParentInst),argTys,retTy,_,_)) = + let denv = { denv with showTyparBinding = true } + let retTy = (retTy |> GetFSharpViewOfReturnType denv.g) + let argInfos = + match argTys with + | [] -> [[(denv.g.unit_ty,ValReprInfo.unnamedTopArg1)]] + | _ -> argTys |> List.mapSquared (fun ty -> (ty, ValReprInfo.unnamedTopArg1)) + Layout.bufferL os (NicePrint.layoutMemberSig denv (memberToParentInst,id.idText,mtps, argInfos, retTy)) + + /// Print the signature of a MethInfo to a buffer as part of an error message + let PrintMethInfoSigToBuffer g amap m denv os minfo = + let denv = { denv with showTyparBinding = true } + let (CompiledSig(argTys,retTy,fmtps,ttpinst)) = CompiledSigOfMeth g amap m minfo + let retTy = (retTy |> GetFSharpViewOfReturnType g) + let argInfos = argTys |> List.mapSquared (fun ty -> (ty, ValReprInfo.unnamedTopArg1)) + let nm = minfo.LogicalName + Layout.bufferL os (NicePrint.layoutMemberSig denv (ttpinst,nm,fmtps, argInfos, retTy)) + + /// Format the signature of an override as a string as part of an error message + let FormatOverride denv d = bufs (fun buf -> PrintOverrideToBuffer denv buf d) + + /// Format the signature of a MethInfo as a string as part of an error message + let FormatMethInfoSig g amap m denv d = bufs (fun buf -> PrintMethInfoSigToBuffer g amap m denv buf d) + + /// Get the override info for an existing (inherited) method being used to implement a dispatch slot. + let GetInheritedMemberOverrideInfo g amap m parentType (minfo:MethInfo) = + let nm = minfo.LogicalName + let (CompiledSig (argTys,retTy,fmtps,ttpinst)) = CompiledSigOfMeth g amap m minfo + + let isFakeEventProperty = minfo.IsFSharpEventPropertyMethod + Override(parentType,tcrefOfAppTy g minfo.EnclosingType,mkSynId m nm, (fmtps,ttpinst),argTys,retTy,isFakeEventProperty,false) + + /// Get the override info for a value being used to implement a dispatch slot. + let GetTypeMemberOverrideInfo g reqdTy (overrideBy:ValRef) = + let _,argInfos,retTy,_ = GetTypeOfMemberInMemberForm g overrideBy + let nm = overrideBy.LogicalName + + let argTys = argInfos |> List.mapSquared fst + + let memberMethodTypars,memberToParentInst,argTys,retTy = + match PartitionValRefTypars g overrideBy with + | Some(_,_,memberMethodTypars,memberToParentInst,_tinst) -> + let argTys = argTys |> List.mapSquared (instType memberToParentInst) + let retTy = retTy |> Option.map (instType memberToParentInst) + memberMethodTypars, memberToParentInst,argTys, retTy + | None -> + error(Error(FSComp.SR.typrelMethodIsOverconstrained(),overrideBy.Range)) + let implKind = + if ValRefIsExplicitImpl g overrideBy then + + let belongsToReqdTy = + match overrideBy.MemberInfo.Value.ImplementedSlotSigs with + | [] -> false + | ss :: _ -> isInterfaceTy g ss.ImplementedType && typeEquiv g reqdTy ss.ImplementedType + if belongsToReqdTy then + CanImplementAnyInterfaceSlot + else + CanImplementNoSlots + else if overrideBy.IsDispatchSlotMember then + CanImplementNoSlots + // abstract slots can only implement interface slots + //CanImplementAnyInterfaceSlot <<----- Change to this to enable implicit interface implementation + + else + CanImplementAnyClassHierarchySlot + //CanImplementAnySlot <<----- Change to this to enable implicit interface implementation + + let isFakeEventProperty = overrideBy.IsFSharpEventProperty(g) + Override(implKind,overrideBy.MemberApparentParent, mkSynId overrideBy.Range nm, (memberMethodTypars,memberToParentInst),argTys,retTy,isFakeEventProperty, overrideBy.IsCompilerGenerated) + + /// Get the override information for an object expression method being used to implement dispatch slots + let GetObjectExprOverrideInfo g amap (implty, id:Ident, memberFlags, ty, arityInfo, bindingAttribs, rhsExpr) = + // Dissect the type + let tps, argInfos, retTy, _ = GetMemberTypeInMemberForm g memberFlags arityInfo ty id.idRange + let argTys = argInfos |> List.mapSquared fst + // Dissect the implementation + let _, ctorThisValOpt, baseValOpt, vsl, rhsExpr,_ = destTopLambda g amap arityInfo (rhsExpr,ty) + assert ctorThisValOpt.IsNone + + // Drop 'this' + match vsl with + | [thisv]::vs -> + // Check for empty variable list from a () arg + let vs = if vs.Length = 1 && argInfos.IsEmpty then [] else vs + let implKind = + if isInterfaceTy g implty then + CanImplementAnyInterfaceSlot + else + CanImplementAnyClassHierarchySlot + //CanImplementAnySlot <<----- Change to this to enable implicit interface implementation + let isFakeEventProperty = CompileAsEvent g bindingAttribs + let overrideByInfo = Override(implKind, tcrefOfAppTy g implty, id, (tps,[]), argTys, retTy, isFakeEventProperty, false) + overrideByInfo, (baseValOpt, thisv, vs, bindingAttribs, rhsExpr) + | _ -> + error(InternalError("Unexpected shape for object expression override",id.idRange)) + + /// Check if an override matches a dispatch slot by name + let IsNameMatch (dispatchSlot:MethInfo) (overrideBy: OverrideInfo) = + (overrideBy.LogicalName = dispatchSlot.LogicalName) + + /// Check if an override matches a dispatch slot by name + let IsImplMatch g (dispatchSlot:MethInfo) (overrideBy: OverrideInfo) = + // If the override is listed as only relevant to one type, and we're matching it against an abstract slot of an interface type, + // then check that interface type is the right type. + (match overrideBy.CanImplement with + | CanImplementNoSlots -> false + | CanImplementAnySlot -> true + | CanImplementAnyClassHierarchySlot -> not (isInterfaceTy g dispatchSlot.EnclosingType) + //| CanImplementSpecificInterfaceSlot parentTy -> isInterfaceTy g dispatchSlot.EnclosingType && typeEquiv g parentTy dispatchSlot.EnclosingType + | CanImplementAnyInterfaceSlot -> isInterfaceTy g dispatchSlot.EnclosingType) + + /// Check if the kinds of type parameters match between a dispatch slot and an override. + let IsTyparKindMatch g amap m (dispatchSlot:MethInfo) (Override(_,_,_,(mtps,_),_,_,_,_)) = + let (CompiledSig(_,_,fvmtps,_)) = CompiledSigOfMeth g amap m dispatchSlot + List.lengthsEqAndForall2 (fun (tp1:Typar) (tp2:Typar) -> tp1.Kind = tp2.Kind) mtps fvmtps + + /// Check if an override is a partial match for the requirements for a dispatch slot + let IsPartialMatch g amap m (dispatchSlot:MethInfo) (Override(_,_,_,(mtps,_),argTys,_retTy,_,_) as overrideBy) = + IsNameMatch dispatchSlot overrideBy && + let (CompiledSig (vargtys,_,fvmtps,_)) = CompiledSigOfMeth g amap m dispatchSlot + mtps.Length = fvmtps.Length && + IsTyparKindMatch g amap m dispatchSlot overrideBy && + argTys.Length = vargtys.Length && + IsImplMatch g dispatchSlot overrideBy + + /// Compute the reverse of a type parameter renaming. + let ReverseTyparRenaming g tinst = + tinst |> List.map (fun (tp,ty) -> (destTyparTy g ty, mkTyparTy tp)) + + /// Compose two instantiations of type parameters. + let ComposeTyparInsts inst1 inst2 = + inst1 |> List.map (map2Of2 (instType inst2)) + + /// Check if an override exactly matches the requirements for a dispatch slot + let IsExactMatch g amap m dispatchSlot (Override(_,_,_,(mtps,mtpinst),argTys,retTy,_,_) as overrideBy) = + IsPartialMatch g amap m dispatchSlot overrideBy && + let (CompiledSig (vargtys,vrty,fvmtps,ttpinst)) = CompiledSigOfMeth g amap m dispatchSlot + + // Compare the types. CompiledSigOfMeth, GetObjectExprOverrideInfo and GetTypeMemberOverrideInfo have already + // applied all relevant substitutions except the renamings from fvtmps <-> mtps + + let aenv = TypeEquivEnv.FromEquivTypars fvmtps mtps + + List.forall2 (List.lengthsEqAndForall2 (typeAEquiv g aenv)) vargtys argTys && + returnTypesAEquiv g aenv vrty retTy && + + // Comparing the method typars and their constraints is much trickier since the substitutions have not been applied + // to the constraints of these babies. This is partly because constraints are directly attached to typars so it's + // difficult to apply substitutions to them unless we separate them off at some point, which we don't as yet. + // + // Given C + // D + // dispatchSlot : C.M(...) + // overrideBy: parent: D value: ! (...) + // + // where X[dtps] indicates that X may involve free type variables dtps + // + // we have + // ttpinst maps ctps --> ctys[dtps] + // mtpinst maps ttps --> dtps + // + // compare fvtmps[ctps] and mtps[ttps] by + // fvtmps[ctps] @ ttpinst -- gives fvtmps[dtps] + // fvtmps[dtps] @ rev(mtpinst) -- gives fvtmps[ttps] + // + // Now fvtmps[ttps] and mtpinst[ttps] are comparable, i.e. have constraints w.r.t. the same set of type variables + // + // i.e. Compose the substitutions ttpinst and rev(mtpinst) + + let ttpinst = + // check we can reverse - in some error recovery situations we can't + if mtpinst |> List.exists (snd >> isTyparTy g >> not) then ttpinst + else ComposeTyparInsts ttpinst (ReverseTyparRenaming g mtpinst) + + // Compare under the composed substitutions + let aenv = TypeEquivEnv.FromTyparInst ttpinst + + typarsAEquiv g aenv fvmtps mtps + + /// Check if an override implements a dispatch slot + let OverrideImplementsDispatchSlot g amap m dispatchSlot availPriorOverride = + IsExactMatch g amap m dispatchSlot availPriorOverride && + // The override has to actually be in some subtype of the dispatch slot + ExistsHeadTypeInEntireHierarchy g amap m (generalizedTyconRef availPriorOverride.BoundingTyconRef) (tcrefOfAppTy g dispatchSlot.EnclosingType) + + /// Check if a dispatch slot is already implemented + let DispatchSlotIsAlreadyImplemented g amap m availPriorOverridesKeyed (dispatchSlot: MethInfo) = + availPriorOverridesKeyed + |> NameMultiMap.find dispatchSlot.LogicalName + |> List.exists (OverrideImplementsDispatchSlot g amap m dispatchSlot) + + + /// Check all dispatch slots are implemented by some override. + let CheckDispatchSlotsAreImplemented (denv,g,amap,m, + nenv,sink:TcResultsSink, + isOverallTyAbstract, + reqdTy, + dispatchSlots:RequiredSlot list, + availPriorOverrides:OverrideInfo list, + overrides:OverrideInfo list) = + + let isReqdTyInterface = isInterfaceTy g reqdTy + let showMissingMethodsAndRaiseErrors = (isReqdTyInterface || not isOverallTyAbstract) + let res = ref true + let fail exn = (res := false ; if showMissingMethodsAndRaiseErrors then errorR exn) + + // Index the availPriorOverrides and overrides by name + let availPriorOverridesKeyed = availPriorOverrides |> NameMultiMap.initBy (fun ov -> ov.LogicalName) + let overridesKeyed = overrides |> NameMultiMap.initBy (fun ov -> ov.LogicalName) + + dispatchSlots |> List.iter (fun (RequiredSlot(dispatchSlot,isOptional)) -> + + match NameMultiMap.find dispatchSlot.LogicalName overridesKeyed + |> List.filter (OverrideImplementsDispatchSlot g amap m dispatchSlot) with + | [ovd] -> + if not ovd.IsCompilerGenerated then + let item = Item.MethodGroup(ovd.LogicalName,[dispatchSlot],None) + CallNameResolutionSink sink (ovd.Range,nenv,item,item,ItemOccurence.Implemented,denv,AccessorDomain.AccessibleFromSomewhere) + sink |> ignore + () + | [] -> + if not isOptional && + // Check that no available prior override implements this dispatch slot + not (DispatchSlotIsAlreadyImplemented g amap m availPriorOverridesKeyed dispatchSlot) then + // error reporting path + let (CompiledSig (vargtys,_vrty,fvmtps,_)) = CompiledSigOfMeth g amap m dispatchSlot + let noimpl() = if isReqdTyInterface then fail(Error(FSComp.SR.typrelNoImplementationGivenWithSuggestion(NicePrint.stringOfMethInfo amap m denv dispatchSlot), m)) + else fail(Error(FSComp.SR.typrelNoImplementationGiven(NicePrint.stringOfMethInfo amap m denv dispatchSlot), m)) + match overrides |> List.filter (IsPartialMatch g amap m dispatchSlot) with + | [] -> + match overrides |> List.filter (fun overrideBy -> IsNameMatch dispatchSlot overrideBy && + IsImplMatch g dispatchSlot overrideBy) with + | [] -> + noimpl() + | [ Override(_,_,_,(mtps,_),argTys,_,_,_) as overrideBy ] -> + let error_msg = + if argTys.Length <> vargtys.Length then FSComp.SR.typrelMemberDoesNotHaveCorrectNumberOfArguments(FormatOverride denv overrideBy, FormatMethInfoSig g amap m denv dispatchSlot) + elif mtps.Length <> fvmtps.Length then FSComp.SR.typrelMemberDoesNotHaveCorrectNumberOfTypeParameters(FormatOverride denv overrideBy, FormatMethInfoSig g amap m denv dispatchSlot) + elif not (IsTyparKindMatch g amap m dispatchSlot overrideBy) then FSComp.SR.typrelMemberDoesNotHaveCorrectKindsOfGenericParameters(FormatOverride denv overrideBy, FormatMethInfoSig g amap m denv dispatchSlot) + else FSComp.SR.typrelMemberCannotImplement(FormatOverride denv overrideBy, NicePrint.stringOfMethInfo amap m denv dispatchSlot, FormatMethInfoSig g amap m denv dispatchSlot) + fail(Error(error_msg, overrideBy.Range)) + | overrideBy :: _ -> + errorR(Error(FSComp.SR.typrelOverloadNotFound(FormatMethInfoSig g amap m denv dispatchSlot, FormatMethInfoSig g amap m denv dispatchSlot),overrideBy.Range)) + + | [ overrideBy ] -> + if dispatchSlots |> List.exists (fun (RequiredSlot(dispatchSlot,_)) -> OverrideImplementsDispatchSlot g amap m dispatchSlot overrideBy) then + noimpl() + else + // Error will be reported below in CheckOverridesAreAllUsedOnce + () + + | _ -> + fail(Error(FSComp.SR.typrelOverrideWasAmbiguous(FormatMethInfoSig g amap m denv dispatchSlot),m)) + | _ -> fail(Error(FSComp.SR.typrelMoreThenOneOverride(FormatMethInfoSig g amap m denv dispatchSlot),m))) + !res + + /// Check all implementations implement some dispatch slot. + let CheckOverridesAreAllUsedOnce(denv, g, amap, isObjExpr, reqdTy, + dispatchSlotsKeyed: NameMultiMap, + availPriorOverrides: OverrideInfo list, + overrides: OverrideInfo list) = + let availPriorOverridesKeyed = availPriorOverrides |> NameMultiMap.initBy (fun ov -> ov.LogicalName) + for overrideBy in overrides do + if not overrideBy.IsFakeEventProperty then + let m = overrideBy.Range + let relevantVirts = NameMultiMap.find overrideBy.LogicalName dispatchSlotsKeyed + let relevantVirts = relevantVirts |> List.map (fun (RequiredSlot(dispatchSlot,_)) -> dispatchSlot) + + match relevantVirts |> List.filter (fun dispatchSlot -> OverrideImplementsDispatchSlot g amap m dispatchSlot overrideBy) with + | [] -> + // This is all error reporting + match relevantVirts |> List.filter (fun dispatchSlot -> IsPartialMatch g amap m dispatchSlot overrideBy) with + | [dispatchSlot] -> + errorR(OverrideDoesntOverride(denv,overrideBy,Some dispatchSlot,g,amap,m)) + | _ -> + match relevantVirts |> List.filter (fun dispatchSlot -> IsNameMatch dispatchSlot overrideBy) with + | [dispatchSlot] -> + errorR(OverrideDoesntOverride(denv, overrideBy, Some dispatchSlot, g, amap, m)) + | _ -> + errorR(OverrideDoesntOverride(denv,overrideBy,None,g,amap,m)) + + + | [dispatchSlot] -> + if dispatchSlot.IsFinal && (isObjExpr || not (typeEquiv g reqdTy dispatchSlot.EnclosingType)) then + errorR(Error(FSComp.SR.typrelMethodIsSealed(NicePrint.stringOfMethInfo amap m denv dispatchSlot),m)) + | dispatchSlots -> + match dispatchSlots |> List.filter (fun dispatchSlot -> + isInterfaceTy g dispatchSlot.EnclosingType || + not (DispatchSlotIsAlreadyImplemented g amap m availPriorOverridesKeyed dispatchSlot)) with + | h1 :: h2 :: _ -> + errorR(Error(FSComp.SR.typrelOverrideImplementsMoreThenOneSlot((FormatOverride denv overrideBy), (NicePrint.stringOfMethInfo amap m denv h1), (NicePrint.stringOfMethInfo amap m denv h2)),m)) + | _ -> + // dispatch slots are ordered from the derived classes to base + // so we can check the topmost dispatch slot if it is final + match dispatchSlots with + | meth::_ when meth.IsFinal -> errorR(Error(FSComp.SR.tcCannotOverrideSealedMethod((sprintf "%s::%s" (meth.EnclosingType.ToString()) (meth.LogicalName))), m)) + | _ -> () + + + + /// Get the slots of a type that can or must be implemented. This depends + /// partly on the full set of interface types that are being implemented + /// simultaneously, e.g. + /// { new C with interface I2 = ... interface I3 = ... } + /// allReqdTys = {C;I2;I3} + /// + /// allReqdTys can include one class/record/union type. + let GetSlotImplSets (infoReader:InfoReader) denv isObjExpr allReqdTys = + + let g = infoReader.g + let amap = infoReader.amap + + let availImpliedInterfaces : TType list = + [ for (reqdTy,m) in allReqdTys do + if not (isInterfaceTy g reqdTy) then + let baseTyOpt = if isObjExpr then Some reqdTy else GetSuperTypeOfType g amap m reqdTy + match baseTyOpt with + | None -> () + | Some baseTy -> yield! AllInterfacesOfType g amap m AllowMultiIntfInstantiations.Yes baseTy ] + + // For each implemented type, get a list containing the transitive closure of + // interface types implied by the type. This includes the implemented type itself if the implemented type + // is an interface type. + let intfSets = + allReqdTys |> List.mapi (fun i (reqdTy,m) -> + let interfaces = AllInterfacesOfType g amap m AllowMultiIntfInstantiations.Yes reqdTy + let impliedTys = (if isInterfaceTy g reqdTy then interfaces else reqdTy :: interfaces) + (i, reqdTy, impliedTys,m)) + + // For each implemented type, reduce its list of implied interfaces by subtracting out those implied + // by another implemented interface type. + // + // REVIEW: Note complexity O(ity*jty) + let reqdTyInfos = + intfSets |> List.map (fun (i,reqdTy,impliedTys,m) -> + let reduced = + (impliedTys,intfSets) ||> List.fold (fun acc (j,jty,impliedTys2,m) -> + if i <> j && TypeFeasiblySubsumesType 0 g amap m jty CanCoerce reqdTy + then ListSet.subtract (TypesFeasiblyEquiv 0 g amap m) acc impliedTys2 + else acc ) + (i, reqdTy, m, reduced)) + + // Check that, for each implemented type, at least one implemented type is implied. This is enough to capture + // duplicates. + for (_i, reqdTy, m, impliedTys) in reqdTyInfos do + if isInterfaceTy g reqdTy && isNil impliedTys then + errorR(Error(FSComp.SR.typrelDuplicateInterface(),m)) + + // Check that no interface type is implied twice + // + // Note complexity O(reqdTy*reqdTy) + for (i, _reqdTy, reqdTyRange, impliedTys) in reqdTyInfos do + for (j,_,_,impliedTys2) in reqdTyInfos do + if i > j then + let overlap = ListSet.intersect (TypesFeasiblyEquiv 0 g amap reqdTyRange) impliedTys impliedTys2 + overlap |> List.iter (fun overlappingTy -> + if nonNil(GetImmediateIntrinsicMethInfosOfType (None,AccessibleFromSomewhere) g amap reqdTyRange overlappingTy |> List.filter (fun minfo -> minfo.IsVirtual)) then + errorR(Error(FSComp.SR.typrelNeedExplicitImplementation(NicePrint.minimalStringOfType denv (List.head overlap)),reqdTyRange))) + + // Get the SlotImplSet for each implemented type + // This contains the list of required members and the list of available members + [ for (_,reqdTy,reqdTyRange,impliedTys) in reqdTyInfos do + + // Build a set of the implied interface types, for quicker lookup, by nominal type + let isImpliedInterfaceTable = + impliedTys + |> List.filter (isInterfaceTy g) + |> List.map (fun ty -> tcrefOfAppTy g ty, ()) + |> TyconRefMap.OfList + + // Is a member an abstract slot of one of the implied interface types? + let isImpliedInterfaceType ty = + isImpliedInterfaceTable.ContainsKey (tcrefOfAppTy g ty) && + impliedTys |> List.exists (TypesFeasiblyEquiv 0 g amap reqdTyRange ty) + + //let isSlotImpl (minfo:MethInfo) = + // not minfo.IsAbstract && minfo.IsVirtual + + // Compute the abstract slots that require implementations + let dispatchSlots = + [ if isInterfaceTy g reqdTy then + for impliedTy in impliedTys do + // Check if the interface has an inherited implementation + // If so, you do not have to implement all the methods - each + // specific method is "optionally" implemented. + let isOptional = + ListSet.contains (typeEquiv g) impliedTy availImpliedInterfaces + for reqdSlot in GetImmediateIntrinsicMethInfosOfType (None,AccessibleFromSomewhere) g amap reqdTyRange impliedTy do + yield RequiredSlot(reqdSlot, isOptional) + else + + // In the normal case, the requirements for a class are precisely all the abstract slots up the whole hierarchy. + // So here we get and yield all of those. + for minfo in reqdTy |> GetIntrinsicMethInfosOfType infoReader (None,AccessibleFromSomewhere,AllowMultiIntfInstantiations.Yes) IgnoreOverrides reqdTyRange do + if minfo.IsDispatchSlot then + yield RequiredSlot(minfo,(*isOptional=*)false) ] + + + // Compute the methods that are available to implement abstract slots from the base class + // + // This is used in CheckDispatchSlotsAreImplemented when we think a dispatch slot may not + // have been implemented. + let availPriorOverrides : OverrideInfo list = + if isInterfaceTy g reqdTy then + [] + else + let reqdTy = + let baseTyOpt = if isObjExpr then Some reqdTy else GetSuperTypeOfType g amap reqdTyRange reqdTy + match baseTyOpt with + | None -> reqdTy + | Some baseTy -> baseTy + [ // Get any class hierarchy methods on this type + // + // NOTE: What we have below is an over-approximation that will get too many methods + // and not always correctly relate them to the slots they implement. For example, + // we may get an override from a base class and believe it implements a fresh, new abstract + // slot in a subclass. + for minfos in infoReader.GetRawIntrinsicMethodSetsOfType(None,AccessibleFromSomewhere,AllowMultiIntfInstantiations.Yes,reqdTyRange,reqdTy) do + for minfo in minfos do + if not minfo.IsAbstract then + yield GetInheritedMemberOverrideInfo g amap reqdTyRange CanImplementAnyClassHierarchySlot minfo ] + + // We also collect up the properties. This is used for abstract slot inference when overriding properties + let isRelevantRequiredProperty (x:PropInfo) = + (x.IsVirtualProperty && not (isInterfaceTy g reqdTy)) || + isImpliedInterfaceType x.EnclosingType + + let reqdProperties = + GetIntrinsicPropInfosOfType infoReader (None,AccessibleFromSomewhere,AllowMultiIntfInstantiations.Yes) IgnoreOverrides reqdTyRange reqdTy + |> List.filter isRelevantRequiredProperty + + let dispatchSlotsKeyed = dispatchSlots |> NameMultiMap.initBy (fun (RequiredSlot(v,_)) -> v.LogicalName) + yield SlotImplSet(dispatchSlots, dispatchSlotsKeyed, availPriorOverrides, reqdProperties) ] + + + /// Check that a type definition implements all its required interfaces after processing all declarations + /// within a file. + let CheckImplementationRelationAtEndOfInferenceScope (infoReader :InfoReader,denv,nenv,sink,tycon:Tycon,isImplementation) = + + let g = infoReader.g + let amap = infoReader.amap + + let tcaug = tycon.TypeContents + let interfaces = tycon.ImmediateInterfacesOfFSharpTycon |> List.map (fun (ity,_compgen,m) -> (ity,m)) + + let overallTy = generalizedTyconRef (mkLocalTyconRef tycon) + + let allReqdTys = (overallTy,tycon.Range) :: interfaces + + // Get all the members that are immediately part of this type + // Include the auto-generated members + let allImmediateMembers = tycon.MembersOfFSharpTyconSorted @ tycon.AllGeneratedValues + + // Get all the members we have to implement, organized by each type we explicitly implement + let slotImplSets = GetSlotImplSets infoReader denv false allReqdTys + + let allImpls = List.zip allReqdTys slotImplSets + + // Find the methods relevant to implementing the abstract slots listed under the reqdType being checked. + let allImmediateMembersThatMightImplementDispatchSlots = + allImmediateMembers |> List.filter (fun overrideBy -> + overrideBy.IsInstanceMember && // exclude static + overrideBy.IsVirtualMember && // exclude non virtual (e.g. keep override/default). [4469] + not overrideBy.IsDispatchSlotMember) + + let mustOverrideSomething reqdTy (overrideBy:ValRef) = + let memberInfo = overrideBy.MemberInfo.Value + not (overrideBy.IsFSharpEventProperty(g)) && + memberInfo.MemberFlags.IsOverrideOrExplicitImpl && + + match memberInfo.ImplementedSlotSigs with + | [] -> + // Are we looking at the implementation of the class hierarchy? If so include all the override members + not (isInterfaceTy g reqdTy) + | ss -> + ss |> List.forall (fun ss -> + let ty = ss.ImplementedType + if isInterfaceTy g ty then + // Is this a method impl listed under the reqdTy? + typeEquiv g ty reqdTy + else + not (isInterfaceTy g reqdTy) ) + + + // We check all the abstracts related to the class hierarchy and then check each interface implementation + for ((reqdTy,m),slotImplSet) in allImpls do + let (SlotImplSet(dispatchSlots, dispatchSlotsKeyed, availPriorOverrides,_)) = slotImplSet + try + + // Now extract the information about each overriding method relevant to this SlotImplSet + let allImmediateMembersThatMightImplementDispatchSlots = + allImmediateMembersThatMightImplementDispatchSlots + |> List.map (fun overrideBy -> overrideBy,GetTypeMemberOverrideInfo g reqdTy overrideBy) + + // Now check the implementation + // We don't give missing method errors for abstract classes + + if isImplementation && not (isInterfaceTy g overallTy) then + let overrides = allImmediateMembersThatMightImplementDispatchSlots |> List.map snd + let allCorrect = CheckDispatchSlotsAreImplemented (denv,g,amap,m,nenv,sink,tcaug.tcaug_abstract,reqdTy,dispatchSlots,availPriorOverrides,overrides) + + // Tell the user to mark the thing abstract if it was missing implementations + if not allCorrect && not tcaug.tcaug_abstract && not (isInterfaceTy g reqdTy) then + errorR(TypeIsImplicitlyAbstract(m)) + + let overridesToCheck = + allImmediateMembersThatMightImplementDispatchSlots + |> List.filter (fst >> mustOverrideSomething reqdTy) + |> List.map snd + + CheckOverridesAreAllUsedOnce (denv, g, amap, false, reqdTy, dispatchSlotsKeyed, availPriorOverrides, overridesToCheck) + + with e -> errorRecovery e m + + // Now record the full slotsigs of the abstract members implemented by each override. + // This is used to generate IL MethodImpls in the code generator. + allImmediateMembersThatMightImplementDispatchSlots |> List.iter (fun overrideBy -> + + let isFakeEventProperty = overrideBy.IsFSharpEventProperty(g) + let overriden = + if isFakeEventProperty then + let slotsigs = overrideBy.MemberInfo.Value.ImplementedSlotSigs + slotsigs |> List.map (ReparentSlotSigToUseMethodTypars g overrideBy.Range overrideBy) + else + [ for ((reqdTy,m),(SlotImplSet(_dispatchSlots,dispatchSlotsKeyed,_,_))) in allImpls do + let overrideByInfo = GetTypeMemberOverrideInfo g reqdTy overrideBy + let overridenForThisSlotImplSet = + [ for (RequiredSlot(dispatchSlot,_)) in NameMultiMap.find overrideByInfo.LogicalName dispatchSlotsKeyed do + if OverrideImplementsDispatchSlot g amap m dispatchSlot overrideByInfo then + if tyconRefEq g overrideByInfo.BoundingTyconRef (tcrefOfAppTy g dispatchSlot.EnclosingType) then + match dispatchSlot.ArbitraryValRef with + | Some virtMember -> + if virtMember.MemberInfo.Value.IsImplemented then errorR(Error(FSComp.SR.tcDefaultImplementationAlreadyExists(),overrideByInfo.Range)) + virtMember.MemberInfo.Value.IsImplemented <- true + | None -> () // not an F# slot + + // Get the slotsig of the overridden method + let slotsig = dispatchSlot.GetSlotSig(amap, m) + + // The slotsig from the overridden method is in terms of the type parameters on the parent type of the overriding method, + // Modify map the slotsig so it is in terms of the type parameters for the overriding method + let slotsig = ReparentSlotSigToUseMethodTypars g m overrideBy slotsig + + // Record the slotsig via mutation + yield slotsig ] + //if mustOverrideSomething reqdTy overrideBy then + // assert nonNil overridenForThisSlotImplSet + yield! overridenForThisSlotImplSet ] + + overrideBy.MemberInfo.Value.ImplementedSlotSigs <- overriden) + + + +//------------------------------------------------------------------------- +// "Type Completion" inference and a few other checks at the end of the inference scope +//------------------------------------------------------------------------- + + +/// "Type Completion" inference and a few other checks at the end of the inference scope +let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader:InfoReader, nenv, sink, isImplementation, denv) (tycon:Tycon) = + + let g = infoReader.g + let amap = infoReader.amap + + let tcaug = tycon.TypeContents + tcaug.tcaug_closed <- true + + // Note you only have to explicitly implement 'System.IComparable' to customize structural comparison AND equality on F# types + if isImplementation && +#if EXTENSIONTYPING + not tycon.IsProvidedGeneratedTycon && +#endif + isNone tycon.GeneratedCompareToValues && + tycon.HasInterface g g.mk_IComparable_ty && + not (tycon.HasOverride g "Equals" [g.obj_ty]) && + not tycon.IsFSharpInterfaceTycon + then + (* Warn when we're doing this for class types *) + if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then + warning(Error(FSComp.SR.typrelTypeImplementsIComparableShouldOverrideObjectEquals(tycon.DisplayName),tycon.Range)) + else + warning(Error(FSComp.SR.typrelTypeImplementsIComparableDefaultObjectEqualsProvided(tycon.DisplayName),tycon.Range)) + + AugmentWithHashCompare.CheckAugmentationAttribs isImplementation g amap tycon + // Check some conditions about generic comparison and hashing. We can only check this condition after we've done the augmentation + if isImplementation +#if EXTENSIONTYPING + && not tycon.IsProvidedGeneratedTycon +#endif + then + let tcaug = tycon.TypeContents + let m = tycon.Range + let hasExplicitObjectGetHashCode = tycon.HasOverride g "GetHashCode" [] + let hasExplicitObjectEqualsOverride = tycon.HasOverride g "Equals" [g.obj_ty] + + if (isSome tycon.GeneratedHashAndEqualsWithComparerValues) && + (hasExplicitObjectGetHashCode || hasExplicitObjectEqualsOverride) then + errorR(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCodeOrEquals(tycon.DisplayName),m)) + + if not hasExplicitObjectEqualsOverride && hasExplicitObjectGetHashCode then + warning(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCode(tycon.DisplayName),m)) + + if hasExplicitObjectEqualsOverride && not hasExplicitObjectGetHashCode then + warning(Error(FSComp.SR.typrelExplicitImplementationOfEquals(tycon.DisplayName),m)) + + + // remember these values to ensure we don't generate these methods during codegen + tcaug.SetHasObjectGetHashCode hasExplicitObjectGetHashCode + + if not tycon.IsHiddenReprTycon + && not tycon.IsTypeAbbrev + && not tycon.IsMeasureableReprTycon + && not tycon.IsAsmReprTycon + && not tycon.IsFSharpInterfaceTycon + && not tycon.IsFSharpDelegateTycon then + + DispatchSlotChecking.CheckImplementationRelationAtEndOfInferenceScope (infoReader,denv,nenv,sink,tycon,isImplementation) + +/// Get the methods relevant to determining if a uniquely-identified-override exists based on the syntactic information +/// at the member signature prior to type inference. This is used to pre-assign type information if it does +let GetAbstractMethInfosForSynMethodDecl(infoReader:InfoReader,ad,memberName:Ident,bindm,typToSearchForAbstractMembers,valSynData) = + let minfos = + match typToSearchForAbstractMembers with + | _,Some(SlotImplSet(_, dispatchSlotsKeyed,_,_)) -> + NameMultiMap.find memberName.idText dispatchSlotsKeyed |> List.map (fun (RequiredSlot(dispatchSlot,_)) -> dispatchSlot) + | ty, None -> + GetIntrinsicMethInfosOfType infoReader (Some(memberName.idText), ad, AllowMultiIntfInstantiations.Yes) IgnoreOverrides bindm ty + let dispatchSlots = minfos |> List.filter (fun minfo -> minfo.IsDispatchSlot) + let topValSynArities = SynInfo.AritiesOfArgs valSynData + let topValSynArities = if topValSynArities.Length > 0 then topValSynArities.Tail else topValSynArities + let dispatchSlotsArityMatch = dispatchSlots |> List.filter (fun minfo -> minfo.NumArgs = topValSynArities) + dispatchSlots,dispatchSlotsArityMatch + +/// Get the properties relevant to determining if a uniquely-identified-override exists based on the syntactic information +/// at the member signature prior to type inference. This is used to pre-assign type information if it does +let GetAbstractPropInfosForSynPropertyDecl(infoReader:InfoReader,ad,memberName:Ident,bindm,typToSearchForAbstractMembers,_k,_valSynData) = + let pinfos = + match typToSearchForAbstractMembers with + | _,Some(SlotImplSet(_,_,_,reqdProps)) -> + reqdProps |> List.filter (fun pinfo -> pinfo.PropertyName = memberName.idText) + | ty, None -> + GetIntrinsicPropInfosOfType infoReader (Some(memberName.idText), ad, AllowMultiIntfInstantiations.Yes) IgnoreOverrides bindm ty + + let dispatchSlots = pinfos |> List.filter (fun pinfo -> pinfo.IsVirtualProperty) + dispatchSlots + diff --git a/src/fsharp/NameResolution.fs b/src/fsharp/NameResolution.fs index cfc4940af4..0f8669be9f 100755 --- a/src/fsharp/NameResolution.fs +++ b/src/fsharp/NameResolution.fs @@ -24,8 +24,9 @@ open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library.ResultOrException open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.IL // Abstract IL open Microsoft.FSharp.Compiler.Infos -open Microsoft.FSharp.Compiler.Infos.AccessibilityLogic -open Microsoft.FSharp.Compiler.Infos.AttributeChecking +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.AttributeChecking +open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.Layout open Microsoft.FSharp.Compiler.PrettyNaming open System.Collections.Generic @@ -693,25 +694,33 @@ let rec AddModuleOrNamespaceRefsToNameEnv g amap m root ad nenv (modrefs: Module /// Add the contents of a module or namespace to the name resolution environment and AddModuleOrNamespaceContentsToNameEnv (g:TcGlobals) amap (ad:AccessorDomain) m root nenv (modref:ModuleOrNamespaceRef) = - let pri = NextExtensionMethodPriority() - let mty = modref.ModuleOrNamespaceType - let tycons = mty.TypeAndExceptionDefinitions - - let exncs = mty.ExceptionDefinitions - let nenv = { nenv with eDisplayEnv= nenv.eDisplayEnv.AddOpenModuleOrNamespace modref } - let tcrefs = tycons |> List.map modref.NestedTyconRef |> List.filter (IsEntityAccessible amap m ad) - let exrefs = exncs |> List.map modref.NestedTyconRef |> List.filter (IsEntityAccessible amap m ad) - let nenv = (nenv,exrefs) ||> List.fold (AddExceptionDeclsToNameEnv BulkAdd.Yes) - let nenv = (nenv,tcrefs) ||> AddTyconRefsToNameEnv BulkAdd.Yes false g amap m false - let vrefs = - mty.AllValsAndMembers.ToFlatList() - |> FlatList.choose (fun x -> - if IsAccessible ad x.Accessibility then TryMkValRefInModRef modref x - else None) - |> FlatList.toArray - let nenv = AddValRefsToNameEnvWithPriority BulkAdd.Yes pri nenv vrefs - let nenv = (nenv,MakeNestedModuleRefs modref) ||> AddModuleOrNamespaceRefsToNameEnv g amap m root ad - nenv + let pri = NextExtensionMethodPriority() + let mty = modref.ModuleOrNamespaceType + + let nenv = + let mutable state = { nenv with eDisplayEnv = nenv.eDisplayEnv.AddOpenModuleOrNamespace modref } + + for exnc in mty.ExceptionDefinitions do + let tcref = modref.NestedTyconRef exnc + if IsEntityAccessible amap m ad tcref then + state <- AddExceptionDeclsToNameEnv BulkAdd.Yes state tcref + + state + + let tcrefs = + mty.TypeAndExceptionDefinitions + |> List.choose (fun tycon -> + let tcref = modref.NestedTyconRef tycon + if IsEntityAccessible amap m ad tcref then Some(tcref) else None) + + let nenv = (nenv,tcrefs) ||> AddTyconRefsToNameEnv BulkAdd.Yes false g amap m false + let vrefs = + mty.AllValsAndMembers.ToFlatList() + |> FlatList.choose (fun x -> if IsAccessible ad x.Accessibility then TryMkValRefInModRef modref x else None) + |> FlatList.toArray + let nenv = AddValRefsToNameEnvWithPriority BulkAdd.Yes pri nenv vrefs + let nenv = (nenv,MakeNestedModuleRefs modref) ||> AddModuleOrNamespaceRefsToNameEnv g amap m root ad + nenv /// Add a set of modules or namespaces to the name resolution environment // @@ -721,7 +730,7 @@ and AddModuleOrNamespaceContentsToNameEnv (g:TcGlobals) amap (ad:AccessorDomain) // open M1 // // The list contains [M1b; M1a] -and AddModulesAndNamespacesContentsToNameEnv g amap ad m root nenv modrefs = +and AddModulesAndNamespacesContentsToNameEnv g amap ad m root nenv modrefs = (modrefs, nenv) ||> List.foldBack (fun modref acc -> AddModuleOrNamespaceContentsToNameEnv g amap ad m root acc modref) /// Add a single modules or namespace to the name resolution environment @@ -800,8 +809,11 @@ let AddResults res1 res2 = | Result x,Result l -> Result (x @ l) | Exception _,Result l -> Result l | Result x,Exception _ -> Result x + // This prefers error messages with more predictions + | Exception (UndefinedName(n1,_,_,predictions1) as e1),Exception (UndefinedName(n2,_,_,predictions2) as e2) when n1 = n2 -> + if Set.count predictions1 < Set.count predictions2 then Exception e2 else Exception e1 // This prefers error messages coming from deeper failing long identifier paths - | Exception (UndefinedName(n1,_,_,_) as e1),Exception (UndefinedName(n2,_,_,_) as e2) -> + | Exception (UndefinedName(n1,_,_,_) as e1),Exception (UndefinedName(n2,_,_,_) as e2) -> if n1 < n2 then Exception e2 else Exception e1 // Prefer more concrete errors about things being undefined | Exception (UndefinedName _ as e1),Exception (Error _) -> Exception e1 @@ -1073,8 +1085,7 @@ let GetNestedTypesOfType (ad, ncenv:NameResolver, optFilter, staticResInfo, chec | _ -> #endif - mty.TypesByAccessNames.Values - |> Seq.toList + mty.TypesByAccessNames.Values |> List.map (tcref.NestedTyconRef >> MakeNestedType ncenv tinst m) |> List.filter (IsTypeAccessible g ncenv.amap m ad) else []) @@ -1539,8 +1550,7 @@ let CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities let tcrefs = tcrefs // remove later duplicates (if we've opened the same module more than once) - |> Seq.distinctBy (fun (_,tcref) -> tcref.Stamp) - |> Seq.toList + |> List.distinctBy (fun (_,tcref) -> tcref.Stamp) // List.sortBy is a STABLE sort (the order matters!) |> List.sortBy (fun (_,tcref) -> tcref.Typars(m).Length) @@ -1609,15 +1619,15 @@ let rec ResolveLongIndentAsModuleOrNamespace amap m fullyQualified (nenv:NameRes | Some mspec when IsEntityAccessible amap m ad (modref.NestedTyconRef mspec) -> let subref = modref.NestedTyconRef mspec look (depth+1) subref mspec.ModuleOrNamespaceType rest - | _ -> raze (UndefinedName(depth,FSComp.SR.undefinedNameNamespace,id,[])) + | _ -> raze (UndefinedName(depth,FSComp.SR.undefinedNameNamespace,id,NoPredictions)) modrefs |> CollectResults (fun modref -> if IsEntityAccessible amap m ad modref then look 1 modref modref.ModuleOrNamespaceType rest else - raze (UndefinedName(0,FSComp.SR.undefinedNameNamespaceOrModule,id,[]))) + raze (UndefinedName(0,FSComp.SR.undefinedNameNamespaceOrModule,id,NoPredictions))) | None -> - raze (UndefinedName(0,FSComp.SR.undefinedNameNamespaceOrModule,id,[])) + raze (UndefinedName(0,FSComp.SR.undefinedNameNamespaceOrModule,id,NoPredictions)) let ResolveLongIndentAsModuleOrNamespaceThen amap m fullyQualified (nenv:NameResolutionEnv) ad lid f = @@ -1646,7 +1656,7 @@ let private ResolveObjectConstructorPrim (ncenv:NameResolver) edenv resInfo m ad success (resInfo, Item.FakeInterfaceCtor typ) else let defaultStructCtorInfo = - if (isStructTy g typ && not(ctorInfos |> List.exists (fun x -> x.IsNullary))) then + if (isStructTy g typ && not (isRecdTy g typ) && not (isUnionTy g typ) && not(ctorInfos |> List.exists (fun x -> x.IsNullary))) then [DefaultStructCtor(g,typ)] else [] if (isNil defaultStructCtorInfo && isNil ctorInfos) || not (isAppTy g typ) then @@ -1857,7 +1867,7 @@ let rec ResolveLongIdentInTypePrim (ncenv:NameResolver) nenv lookupKind (resInfo // since later on this logic is used when giving preference to intrinsic definitions match DecodeFSharpEvent (pinfos@extensionPropInfos) ad g ncenv m with | Some x -> success (resInfo, x, rest) - | None-> raze (UndefinedName (depth,FSComp.SR.undefinedNameFieldConstructorOrMember, id,[])) + | None -> raze (UndefinedName (depth,FSComp.SR.undefinedNameFieldConstructorOrMember, id,NoPredictions)) | Some(MethodItem msets) when (match lookupKind with LookupKind.Expr -> true | _ -> false) -> let minfos = msets |> ExcludeHiddenOfMethInfos g ncenv.amap m @@ -1882,7 +1892,7 @@ let rec ResolveLongIdentInTypePrim (ncenv:NameResolver) nenv lookupKind (resInfo success (resInfo,Item.MakeMethGroup (nm,minfos),rest) elif isTyparTy g typ then raze (IndeterminateType(unionRanges m id.idRange)) - else raze (UndefinedName (depth,FSComp.SR.undefinedNameFieldConstructorOrMember, id,[])) + else raze (UndefinedName (depth,FSComp.SR.undefinedNameFieldConstructorOrMember, id,NoPredictions)) let nestedSearchAccessible = let nestedTypes = GetNestedTypesOfType (ad, ncenv, Some nm, (if isNil rest then typeNameResInfo.StaticArgsInfo else TypeNameResolutionStaticArgsInfo.Indefinite), true, m) typ @@ -1994,7 +2004,7 @@ let rec ResolveExprLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv (typeN else NoResultsOrUsefulErrors - AtMostOneResult id.idRange ( tyconSearch +++ moduleSearch +++ raze (UndefinedName(depth,FSComp.SR.undefinedNameValueConstructorNamespaceOrType,id,[]))) + AtMostOneResult id.idRange ( tyconSearch +++ moduleSearch +++ raze (UndefinedName(depth,FSComp.SR.undefinedNameValueConstructorNamespaceOrType,id,NoPredictions))) /// An identifier has resolved to a type name in an expression (corresponding to one or more TyconRefs). @@ -2075,7 +2085,7 @@ let rec ResolveExprLongIdentPrim sink (ncenv:NameResolver) fullyQualified m ad n success [(resInfo,Item.ImplicitOp(id, ref None),[])] else NoResultsOrUsefulErrors - let failingCase = raze (UndefinedName(0,FSComp.SR.undefinedNameValueOfConstructor,id,[])) + let failingCase = raze (UndefinedName(0,FSComp.SR.undefinedNameValueOfConstructor,id,NoPredictions)) let search = ctorSearch +++ implicitOpSearch +++ failingCase let resInfo,item,rest = ForceRaise (AtMostOneResult m search) ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item)); @@ -2132,7 +2142,7 @@ let rec ResolveExprLongIdentPrim sink (ncenv:NameResolver) fullyQualified m ad n | Result _ as res -> ForceRaise res | _ -> - let failingCase = raze (UndefinedName(0,FSComp.SR.undefinedNameValueNamespaceTypeOrModule,id,[])) + let failingCase = raze (UndefinedName(0,FSComp.SR.undefinedNameValueNamespaceTypeOrModule,id,NoPredictions)) ForceRaise (AtMostOneResult m (search +++ moduleSearch AccessibleFromSomeFSharpCode +++ tyconSearch AccessibleFromSomeFSharpCode +++ failingCase)) ResolutionInfo.SendToSink(sink,ncenv,nenv,ItemOccurence.Use,ad,resInfo,ResultTyparChecker(fun () -> CheckAllTyparsInferrable ncenv.amap m item)); item,rest @@ -2199,7 +2209,7 @@ let rec ResolvePatternLongIdentInModuleOrNamespace (ncenv:NameResolver) nenv num | _ -> NoResultsOrUsefulErrors else NoResultsOrUsefulErrors - let res = AtMostOneResult id.idRange ( tyconSearch +++ ctorSearch +++ moduleSearch +++ raze (UndefinedName(depth,FSComp.SR.undefinedNameConstructorModuleOrNamespace,id,[]))) + let res = AtMostOneResult id.idRange ( tyconSearch +++ ctorSearch +++ moduleSearch +++ raze (UndefinedName(depth,FSComp.SR.undefinedNameConstructorModuleOrNamespace,id,NoPredictions))) res /// Used to report a warning condition for the use of upper-case identifiers in patterns @@ -2295,7 +2305,7 @@ let rec ResolveTypeLongIdentInTyconRefPrim (ncenv:NameResolver) (typeNameResInfo let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, typeNameResInfo, genOk, m) match tcrefs with | tcref :: _ -> success tcref - | [] -> raze (UndefinedName(depth,FSComp.SR.undefinedNameType,id,[])) + | [] -> raze (UndefinedName(depth,FSComp.SR.undefinedNameType,id,NoPredictions)) | id::rest -> #if EXTENSIONTYPING // No dotting through type generators to get to a nested type! @@ -2309,7 +2319,7 @@ let rec ResolveTypeLongIdentInTyconRefPrim (ncenv:NameResolver) (typeNameResInfo let tcrefs = CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities (tcrefs, typeNameResInfo.DropStaticArgsInfo, genOk, m) match tcrefs with | _ :: _ -> tcrefs |> CollectResults (fun (resInfo,tcref) -> ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad resInfo genOk (depth+1) m tcref rest) - | [] -> raze (UndefinedName(depth,FSComp.SR.undefinedNameType,id,[])) + | [] -> raze (UndefinedName(depth,FSComp.SR.undefinedNameType,id,NoPredictions)) AtMostOneResult m tyconSearch @@ -2321,6 +2331,15 @@ let ResolveTypeLongIdentInTyconRef sink (ncenv:NameResolver) nenv typeNameResInf CallNameResolutionSink sink (rangeOfLid lid,nenv,item,item,ItemOccurence.UseInType,nenv.eDisplayEnv,ad) tcref +/// Create an UndefinedName error with details +let SuggestTypeLongIdentInModuleOrNamespace depth (modref:ModuleOrNamespaceRef) (id:Ident) = + let predictedPossibleTypes = + modref.ModuleOrNamespaceType.AllEntities + |> Seq.map (fun e -> e.DisplayName) + |> Set.ofSeq + + let errorTextF s = FSComp.SR.undefinedNameTypeIn(s,fullDisplayTextOfModRef modref) + UndefinedName(depth,errorTextF,id,predictedPossibleTypes) /// Resolve a long identifier representing a type in a module or namespace let rec private ResolveTypeLongIdentInModuleOrNamespace (ncenv:NameResolver) (typeNameResInfo: TypeNameResolutionInfo) ad genOk (resInfo:ResolutionInfo) depth m modref _mty (lid: Ident list) = @@ -2331,7 +2350,7 @@ let rec private ResolveTypeLongIdentInModuleOrNamespace (ncenv:NameResolver) (ty let tcrefs = LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, id.idRange, id.idText, typeNameResInfo.StaticArgsInfo, modref) match tcrefs with | _ :: _ -> tcrefs |> CollectResults (fun tcref -> success(resInfo,tcref)) - | [] -> raze (UndefinedName(depth,FSComp.SR.undefinedNameType,id,[])) + | [] -> raze (SuggestTypeLongIdentInModuleOrNamespace depth modref id) | id::rest -> let m = unionRanges m id.idRange let modulSearch = @@ -2340,12 +2359,12 @@ let rec private ResolveTypeLongIdentInModuleOrNamespace (ncenv:NameResolver) (ty let resInfo = resInfo.AddEntity(id.idRange,submodref) ResolveTypeLongIdentInModuleOrNamespace ncenv typeNameResInfo ad genOk resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType rest | _ -> - raze (UndefinedName(depth,FSComp.SR.undefinedNameNamespaceOrModule,id,[])) + raze (UndefinedName(depth,FSComp.SR.undefinedNameNamespaceOrModule,id,NoPredictions)) let tyconSearch = let tcrefs = LookupTypeNameInEntityMaybeHaveArity (ncenv.amap, id.idRange, id.idText, TypeNameResolutionStaticArgsInfo.Indefinite, modref) match tcrefs with | _ :: _ -> tcrefs |> CollectResults (fun tcref -> ResolveTypeLongIdentInTyconRefPrim ncenv typeNameResInfo ad resInfo genOk (depth+1) m tcref rest) - | [] -> raze (UndefinedName(depth,FSComp.SR.undefinedNameType,id,[])) + | [] -> raze (UndefinedName(depth,FSComp.SR.undefinedNameType,id,NoPredictions)) tyconSearch +++ modulSearch /// Resolve a long identifier representing a type @@ -2375,7 +2394,7 @@ let rec ResolveTypeLongIdentPrim (ncenv:NameResolver) fullyQualified m nenv ad ( //CheckForTypeLegitimacyAndMultipleGenericTypeAmbiguities tcref rest typeNameResInfo m; success(ResolutionInfo.Empty,tcref) | [] -> - raze (UndefinedName(0,FSComp.SR.undefinedNameType,id,[])) + raze (UndefinedName(0,FSComp.SR.undefinedNameType,id,NoPredictions)) | id::rest -> let m = unionRanges m id.idRange @@ -2439,14 +2458,13 @@ let rec ResolveFieldInModuleOrNamespace (ncenv:NameResolver) nenv ad (resInfo:Re match lid with | id::rest -> let m = unionRanges m id.idRange - let error = raze (UndefinedName(depth,FSComp.SR.undefinedNameRecordLabelOrNamespace,id,[])) // search for module-qualified names, e.g. { Microsoft.FSharp.Core.contents = 1 } let modulScopedFieldNames = match TryFindTypeWithRecdField modref id with | Some tycon when IsEntityAccessible ncenv.amap m ad (modref.NestedTyconRef tycon) -> let showDeprecated = HasFSharpAttribute ncenv.g ncenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs success(resInfo, FieldResolution(modref.RecdFieldRefInNestedTycon tycon id,showDeprecated), rest) - | _ -> error + | _ -> raze (UndefinedName(depth,FSComp.SR.undefinedNameRecordLabelOrNamespace,id,NoPredictions)) // search for type-qualified names, e.g. { Microsoft.FSharp.Core.Ref.contents = 1 } let tyconSearch = match lid with @@ -2466,15 +2484,69 @@ let rec ResolveFieldInModuleOrNamespace (ncenv:NameResolver) nenv ad (resInfo:Re | Some(AccessibleEntityRef ncenv.amap m ad modref submodref) -> let resInfo = resInfo.AddEntity(id.idRange,submodref) ResolveFieldInModuleOrNamespace ncenv nenv ad resInfo (depth+1) m submodref submodref.ModuleOrNamespaceType rest - | _ -> - error - else error + | _ -> raze (UndefinedName(depth,FSComp.SR.undefinedNameRecordLabelOrNamespace,id,NoPredictions)) + else raze (UndefinedName(depth,FSComp.SR.undefinedNameRecordLabelOrNamespace,id,NoPredictions)) AtMostOneResult m (OneResult modulScopedFieldNames +++ tyconSearch +++ OneResult modulSearch) | [] -> error(InternalError("ResolveFieldInModuleOrNamespace",m)) +/// Suggest other labels of the same record +let SuggestOtherLabelsOfSameRecordType (nenv:NameResolutionEnv) typeName (id:Ident) (allFields:Ident list) = + let labelsOfPossibleRecord = + nenv.eFieldLabels + |> Seq.filter (fun kv -> + kv.Value + |> List.map (fun r -> r.TyconRef.DisplayName) + |> List.exists ((=) typeName)) + |> Seq.map (fun kv -> kv.Key) + |> Set.ofSeq + + let givenFields = + allFields + |> List.map (fun fld -> fld.idText) + |> List.filter ((<>) id.idText) + |> Set.ofList + + let predictedLabels = Set.difference labelsOfPossibleRecord givenFields + let predictions = ErrorResolutionHints.FilterPredictions id.idText predictedLabels + + let errorCode,text = FSComp.SR.nrRecordDoesNotContainSuchLabel(typeName, id.idText) + errorCode,text + ErrorResolutionHints.FormatPredictions predictions + + +let SuggestLabelsOfRelatedRecords (nenv:NameResolutionEnv) (id:Ident) (allFields:Ident list) = + let predictedLabels = + let givenFields = allFields |> List.map (fun fld -> fld.idText) |> List.filter ((<>) id.idText) |> Set.ofList + if Set.isEmpty givenFields then + // return labels from all records + NameMap.domainL nenv.eFieldLabels |> Set.ofList |> Set.remove "contents" + else + let possibleRecords = + [for fld in givenFields do + match Map.tryFind fld nenv.eFieldLabels with + | None -> () + | Some recordTypes -> yield! (recordTypes |> List.map (fun r -> r.TyconRef.DisplayName, fld)) ] + |> List.groupBy fst + |> List.map (fun (r,fields) -> r, fields |> List.map snd |> Set.ofList) + |> List.filter (fun (_,fields) -> Set.isSubset givenFields fields) + |> List.map fst + |> Set.ofList + + let labelsOfPossibleRecords = + nenv.eFieldLabels + |> Seq.filter (fun kv -> + kv.Value + |> List.map (fun r -> r.TyconRef.DisplayName) + |> List.exists possibleRecords.Contains) + |> Seq.map (fun kv -> kv.Key) + |> Set.ofSeq + + Set.difference labelsOfPossibleRecords givenFields + + UndefinedName(0,FSComp.SR.undefinedNameRecordLabel, id, predictedLabels) + /// Resolve a long identifier representing a record field -let ResolveFieldPrim (ncenv:NameResolver) nenv ad typ (mp,id:Ident) = +let ResolveFieldPrim (ncenv:NameResolver) nenv ad typ (mp,id:Ident) allFields = let typeNameResInfo = TypeNameResolutionInfo.Default let g = ncenv.g let m = id.idRange @@ -2483,11 +2555,20 @@ let ResolveFieldPrim (ncenv:NameResolver) nenv ad typ (mp,id:Ident) = if isAppTy g typ then match ncenv.InfoReader.TryFindRecdOrClassFieldInfoOfType(id.idText,m,typ) with | Some (RecdFieldInfo(_,rfref)) -> [ResolutionInfo.Empty, FieldResolution(rfref,false)] - | None -> error(Error(FSComp.SR.nrTypeDoesNotContainSuchField((NicePrint.minimalStringOfType nenv.eDisplayEnv typ), id.idText),m)) + | None -> + let typeName = NicePrint.minimalStringOfType nenv.eDisplayEnv typ + if isRecdTy g typ then + // record label doesn't belong to record type -> predict other labels of same record + error(Error(SuggestOtherLabelsOfSameRecordType nenv typeName id allFields,m)) + else + error(Error(FSComp.SR.nrTypeDoesNotContainSuchField(typeName, id.idText),m)) else let frefs = try Map.find id.idText nenv.eFieldLabels - with :? KeyNotFoundException -> error (UndefinedName(0,FSComp.SR.undefinedNameRecordLabel,id,NameMap.domainL nenv.eFieldLabels)) + with :? KeyNotFoundException -> + // record label is unknown -> predict related labels and give a hint to the user + error(SuggestLabelsOfRelatedRecords nenv id allFields) + // Eliminate duplicates arising from multiple 'open' frefs |> ListSet.setify (fun fref1 fref2 -> tyconRefEq g fref1.TyconRef fref2.TyconRef) @@ -2513,8 +2594,8 @@ let ResolveFieldPrim (ncenv:NameResolver) nenv ad typ (mp,id:Ident) = if nonNil rest then errorR(Error(FSComp.SR.nrInvalidFieldLabel(),(List.head rest).idRange)); [(resInfo,item)] -let ResolveField sink ncenv nenv ad typ (mp,id) = - let res = ResolveFieldPrim ncenv nenv ad typ (mp,id) +let ResolveField sink ncenv nenv ad typ (mp,id) allFields = + let res = ResolveFieldPrim ncenv nenv ad typ (mp,id) allFields // Register the results of any field paths "Module.Type" in "Module.Type.field" as a name resolution. (Note, the path resolution // info is only non-empty if there was a unique resolution of the field) for (resInfo,_rfref) in res do @@ -3084,9 +3165,8 @@ let rec ResolvePartialLongIdentInModuleOrNamespace (ncenv: NameResolver) nenv is let ilTyconNames = mty.TypesByAccessNames.Values - |> Seq.toList |> List.choose (fun (tycon:Tycon) -> if tycon.IsILTycon then Some tycon.DisplayName else None) - |> Set.ofSeq + |> Set.ofList match plid with | [] -> @@ -3167,9 +3247,8 @@ let rec ResolvePartialLongIdentPrim (ncenv: NameResolver) (nenv: NameResolutionE let ilTyconNames = nenv.TyconsByAccessNames(fullyQualified).Values - |> Seq.toList |> List.choose (fun tyconRef -> if tyconRef.IsILTycon then Some tyconRef.DisplayName else None) - |> Set.ofSeq + |> Set.ofList /// Include all the entries in the eUnqualifiedItems table. let unqualifiedItems = @@ -3177,7 +3256,6 @@ let rec ResolvePartialLongIdentPrim (ncenv: NameResolver) (nenv: NameResolutionE | FullyQualified -> [] | OpenQualified -> nenv.eUnqualifiedItems.Values - |> Seq.toList |> List.filter (function Item.UnqualifiedType _ -> false | _ -> true) |> List.filter (ItemIsUnseen ad g ncenv.amap m >> not) @@ -3200,7 +3278,6 @@ let rec ResolvePartialLongIdentPrim (ncenv: NameResolver) (nenv: NameResolutionE let tycons = nenv.TyconsByDemangledNameAndArity(fullyQualified).Values - |> Seq.toList |> List.filter (fun tcref -> not (tcref.LogicalName.Contains(","))) |> List.filter (fun tcref -> not tcref.IsExceptionDecl) |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not) @@ -3209,7 +3286,6 @@ let rec ResolvePartialLongIdentPrim (ncenv: NameResolver) (nenv: NameResolutionE // Get all the constructors accessible from here let constructors = nenv.TyconsByDemangledNameAndArity(fullyQualified).Values - |> Seq.toList |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not) |> List.collect (InfosForTyconConstructors ncenv m ad) @@ -3265,9 +3341,8 @@ let rec ResolvePartialLongIdentInModuleOrNamespaceForRecordFields (ncenv: NameRe let ilTyconNames = mty.TypesByAccessNames.Values - |> Seq.toList |> List.choose (fun (tycon:Tycon) -> if tycon.IsILTycon then Some tycon.DisplayName else None) - |> Set.ofSeq + |> Set.ofList match plid with | [] -> @@ -3332,9 +3407,8 @@ and ResolvePartialLongIdentToClassOrRecdFieldsImpl (ncenv: NameResolver) (nenv: // empty plid - return namespaces\modules\record types\accessible fields let iltyconNames = nenv.TyconsByAccessNames(fullyQualified).Values - |> Seq.toList |> List.choose (fun tyconRef -> if tyconRef.IsILTycon then Some tyconRef.DisplayName else None) - |> Set.ofSeq + |> Set.ofList let mods = nenv.ModulesAndNamespaces(fullyQualified) @@ -3347,7 +3421,6 @@ and ResolvePartialLongIdentToClassOrRecdFieldsImpl (ncenv: NameResolver) (nenv: let recdTyCons = nenv.TyconsByDemangledNameAndArity(fullyQualified).Values - |> Seq.toList |> List.filter (fun tcref -> not (tcref.LogicalName.Contains(","))) |> List.filter (fun tcref -> tcref.IsRecordTycon) |> List.filter (IsTyconUnseen ad g ncenv.amap m >> not) diff --git a/src/fsharp/NameResolution.fsi b/src/fsharp/NameResolution.fsi index d0dfe6e7b4..671009411f 100755 --- a/src/fsharp/NameResolution.fsi +++ b/src/fsharp/NameResolution.fsi @@ -3,18 +3,18 @@ module internal Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Import +open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.PrettyNaming - - /// A NameResolver is a context for name resolution. It primarily holds an InfoReader. type NameResolver = new : g:TcGlobals * amap:ImportMap * infoReader:InfoReader * instantiationGenerator:(range -> Typars -> TypeInst) -> NameResolver @@ -366,7 +366,7 @@ val internal ResolveTypeLongIdentInTyconRef : TcResultsSink -> NameResol val internal ResolveTypeLongIdent : TcResultsSink -> NameResolver -> ItemOccurence -> FullyQualifiedFlag -> NameResolutionEnv -> AccessorDomain -> Ident list -> TypeNameResolutionStaticArgsInfo -> PermitDirectReferenceToGeneratedType -> ResultOrException /// Resolve a long identifier to a field -val internal ResolveField : TcResultsSink -> NameResolver -> NameResolutionEnv -> AccessorDomain -> TType -> Ident list * Ident -> FieldResolution list +val internal ResolveField : TcResultsSink -> NameResolver -> NameResolutionEnv -> AccessorDomain -> TType -> Ident list * Ident -> Ident list -> FieldResolution list /// Resolve a long identifier occurring in an expression position val internal ResolveExprLongIdent : TcResultsSink -> NameResolver -> range -> AccessorDomain -> NameResolutionEnv -> TypeNameResolutionInfo -> Ident list -> Item * Ident list @@ -410,4 +410,4 @@ type ResolveCompletionTargets = | SettablePropertiesAndFields /// Resolve a (possibly incomplete) long identifier to a set of possible resolutions, qualified by type. -val ResolveCompletionsInType : NameResolver -> NameResolutionEnv -> ResolveCompletionTargets -> Range.range -> Infos.AccessorDomain -> bool -> TType -> Item list +val ResolveCompletionsInType : NameResolver -> NameResolutionEnv -> ResolveCompletionTargets -> Range.range -> AccessorDomain -> bool -> TType -> Item list diff --git a/src/fsharp/NicePrint.fs b/src/fsharp/NicePrint.fs index 0705d0eeae..e4dc8100c4 100755 --- a/src/fsharp/NicePrint.fs +++ b/src/fsharp/NicePrint.fs @@ -6,15 +6,13 @@ module internal Microsoft.FSharp.Compiler.NicePrint -#nowarn "44" // This construct is deprecated. please use List.item - open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Rational open Microsoft.FSharp.Compiler.Ast @@ -23,17 +21,20 @@ open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Tastops.DebugPrint open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.AbstractIL.IL (* Abstract IL *) open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.AttributeChecking +open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.PrettyNaming + open Microsoft.FSharp.Core.Printf + #if EXTENSIONTYPING open Microsoft.FSharp.Compiler.ExtensionTyping open Microsoft.FSharp.Core.CompilerServices #endif -open Microsoft.FSharp.Compiler.Layout -open Microsoft.FSharp.Compiler.PrettyNaming [] module internal PrintUtilities = @@ -57,7 +58,7 @@ module internal PrintUtilities = let applyMaxMembers maxMembers (alldecls : _ list) = match maxMembers with - | Some n when alldecls.Length > n -> (alldecls |> Seq.truncate n |> Seq.toList) @ [wordL "..."] + | Some n when alldecls.Length > n -> (alldecls |> List.truncate n) @ [wordL "..."] | _ -> alldecls /// fix up a name coming from IL metadata by quoting "funny" names (keywords, otherwise invalid identifiers) @@ -185,7 +186,7 @@ module private PrintIL = | ILType.Ptr t | ILType.Byref t -> layoutILType denv ilTyparSubst t | ILType.FunctionPointer t -> layoutILCallingSignature denv ilTyparSubst None t - | ILType.TypeVar n -> List.nth ilTyparSubst (int n) + | ILType.TypeVar n -> List.item (int n) ilTyparSubst | ILType.Modified (_, _, t) -> layoutILType denv ilTyparSubst t // Just recurse through them to the contained ILType /// Layout a function pointer signature using type-only-F#-style. No argument names are printed. @@ -515,8 +516,6 @@ module private PrintIL = | m :: _ -> layoutILCallingSignature denv ilTyparSubst None m.CallingSignature | _ -> comment "`Invoke` method could not be found" wordL "delegate" ^^ wordL "of" ^^ rhs - - | ILTypeDefKind.Other _ -> comment "cannot show type" and layoutILNestedClassDef (denv: DisplayEnv) (typeDef : ILTypeDef) = let name = adjustILName typeDef.Name @@ -1194,7 +1193,7 @@ module InfoMemberPrinting = /// Format the arguments of a method to a buffer. /// /// This uses somewhat "old fashioned" printf-style buffer printing. - let formatParamDataToBuffer denv os (ParamData(isParamArray, _isOutArg, optArgInfo, nmOpt, _reflArgInfo, pty)) = + let formatParamDataToBuffer denv os (ParamData(isParamArray, _isOutArg, optArgInfo, _callerInfoInfo, nmOpt, _reflArgInfo, pty)) = let isOptArg = optArgInfo.IsOptional match isParamArray, nmOpt, isOptArg, tryDestOptionTy denv.g pty with // Layout an optional argument @@ -1382,11 +1381,11 @@ module private TastDefinitionPrinting = /// When repn is class or datatype constructors (not single one). let breakTypeDefnEqn repr = match repr with - | TFsObjModelRepr _ -> true - | TFiniteUnionRepr r -> r.CasesTable.UnionCasesAsList.Length > 1 + | TFSharpObjectRepr _ -> true + | TUnionRepr r -> r.CasesTable.UnionCasesAsList.Length > 1 | TRecdRepr _ -> true | TAsmRepr _ - | TILObjModelRepr _ + | TILObjectRepr _ | TMeasureableRepr _ #if EXTENSIONTYPING | TProvidedTypeExtensionPoint _ @@ -1448,8 +1447,8 @@ module private TastDefinitionPrinting = match valRef with | None -> true | Some(vr) -> - (denv.showObsoleteMembers || not (Infos.AttributeChecking.CheckFSharpAttributesForObsolete denv.g vr.Attribs)) && - (denv.showHiddenMembers || not (Infos.AttributeChecking.CheckFSharpAttributesForHidden denv.g vr.Attribs)) + (denv.showObsoleteMembers || not (CheckFSharpAttributesForObsolete denv.g vr.Attribs)) && + (denv.showHiddenMembers || not (CheckFSharpAttributesForHidden denv.g vr.Attribs)) let ctors = GetIntrinsicConstructorInfosOfType infoReader m ty @@ -1582,8 +1581,8 @@ module private TastDefinitionPrinting = // Don't print individual methods forming interface implementations - these are currently never exported not (isInterfaceTy denv.g oty) | [] -> true) - |> List.filter (fun v -> denv.showObsoleteMembers || not (Infos.AttributeChecking.CheckFSharpAttributesForObsolete denv.g v.Attribs)) - |> List.filter (fun v -> denv.showHiddenMembers || not (Infos.AttributeChecking.CheckFSharpAttributesForHidden denv.g v.Attribs)) + |> List.filter (fun v -> denv.showObsoleteMembers || not (CheckFSharpAttributesForObsolete denv.g v.Attribs)) + |> List.filter (fun v -> denv.showHiddenMembers || not (CheckFSharpAttributesForHidden denv.g v.Attribs)) // sort let sortKey (v:ValRef) = (not v.IsConstructor, // constructors before others v.Id.idText, // sort by name @@ -1593,7 +1592,7 @@ module private TastDefinitionPrinting = let adhoc = adhoc |> List.sortBy sortKey let iimpls = match tycon.TypeReprInfo with - | TFsObjModelRepr r when (match r.fsobjmodel_kind with TTyconInterface -> true | _ -> false) -> [] + | TFSharpObjectRepr r when (match r.fsobjmodel_kind with TTyconInterface -> true | _ -> false) -> [] | _ -> tycon.ImmediateInterfacesOfFSharpTycon let iimpls = iimpls |> List.filter (fun (_,compgen,_) -> not compgen) // if TTyconInterface, the iimpls should be printed as inherited interfaces @@ -1612,11 +1611,11 @@ module private TastDefinitionPrinting = let repr = tycon.TypeReprInfo match repr with | TRecdRepr _ - | TFiniteUnionRepr _ - | TFsObjModelRepr _ + | TUnionRepr _ + | TFSharpObjectRepr _ | TAsmRepr _ | TMeasureableRepr _ - | TILObjModelRepr _ -> + | TILObjectRepr _ -> let brk = nonNil memberLs || breakTypeDefnEqn repr let rhsL = let addReprAccessL l = layoutAccessibility denv tycon.TypeReprAccessibility l @@ -1627,7 +1626,7 @@ module private TastDefinitionPrinting = let recdL = tycon.TrueFieldsAsList |> List.map recdFieldRefL |> applyMaxMembers denv.maxMembers |> aboveListL |> braceL Some (addMembersAsWithEnd (addReprAccessL recdL)) - | TFsObjModelRepr r -> + | TFSharpObjectRepr r -> match r.fsobjmodel_kind with | TTyconDelegate (TSlotSig(_,_, _,_,paraml, rty)) -> let rty = GetFSharpViewOfReturnType denv.g rty @@ -1674,18 +1673,18 @@ module private TastDefinitionPrinting = let declsL = aboveListL alldecls let declsL = match start with Some s -> (wordL s @@-- declsL) @@ wordL "end" | None -> declsL Some declsL - | TFiniteUnionRepr _ -> + | TUnionRepr _ -> let layoutUnionCases = tycon.UnionCasesAsList |> layoutUnionCases denv |> applyMaxMembers denv.maxMembers |> aboveListL Some (addMembersAsWithEnd (addReprAccessL layoutUnionCases)) | TAsmRepr _ -> Some (wordL "(# \"\" #)") | TMeasureableRepr ty -> Some (layoutType denv ty) - | TILObjModelRepr (_,_,td) -> + | TILObjectRepr (_,_,td) -> Some (PrintIL.layoutILTypeDef denv td) | _ -> None - let brk = match tycon.TypeReprInfo with | TILObjModelRepr _ -> true | _ -> brk + let brk = match tycon.TypeReprInfo with | TILObjectRepr _ -> true | _ -> brk match rhsL with | None -> lhsL | Some rhsL -> @@ -1742,8 +1741,8 @@ module private InferredSigPrinting = let rec isConcreteNamespace x = match x with - | TMDefRec(tycons,binds,mbinds,_) -> - nonNil tycons || not (FlatList.isEmpty binds) || (mbinds |> List.exists (fun (ModuleOrNamespaceBinding(x,_)) -> not x.IsNamespace)) + | TMDefRec(_,tycons,mbinds,_) -> + nonNil tycons || (mbinds |> List.exists (function ModuleOrNamespaceBinding.Binding _ -> true | ModuleOrNamespaceBinding.Module(x,_) -> not x.IsNamespace)) | TMDefLet _ -> true | TMDefDo _ -> true | TMDefs defs -> defs |> List.exists isConcreteNamespace @@ -1759,16 +1758,16 @@ module private InferredSigPrinting = let filterVal (v:Val) = not v.IsCompilerGenerated && isNone v.MemberInfo let filterExtMem (v:Val) = v.IsExtensionMember match x with - | TMDefRec(tycons,binds,mbinds,_) -> + | TMDefRec(_,tycons,mbinds,_) -> TastDefinitionPrinting.layoutTyconDefns denv infoReader ad m tycons @@ - (binds |> valsOfBinds |> List.filter filterExtMem |> TastDefinitionPrinting.layoutExtensionMembers denv) @@ - (binds |> valsOfBinds |> List.filter filterVal |> List.map (PrintTastMemberOrVals.layoutValOrMember denv) |> aboveListL) @@ - (mbinds |> List.map (imbindL denv) |> aboveListL) + (mbinds |> List.choose (function ModuleOrNamespaceBinding.Binding bind -> Some bind | _ -> None) |> valsOfBinds |> List.filter filterExtMem |> TastDefinitionPrinting.layoutExtensionMembers denv) @@ + (mbinds |> List.choose (function ModuleOrNamespaceBinding.Binding bind -> Some bind | _ -> None) |> valsOfBinds |> List.filter filterVal |> List.map (PrintTastMemberOrVals.layoutValOrMember denv) |> aboveListL) @@ + (mbinds |> List.choose (function ModuleOrNamespaceBinding.Module (mspec,def) -> Some (mspec,def) | _ -> None) |> List.map (imbindL denv) |> aboveListL) | TMDefLet(bind,_) -> ([bind.Var] |> List.filter filterVal |> List.map (PrintTastMemberOrVals.layoutValOrMember denv) |> aboveListL) | TMDefs defs -> imdefsL denv defs | TMDefDo _ -> emptyL | TMAbstract mexpr -> imexprLP denv mexpr - and imbindL denv (ModuleOrNamespaceBinding(mspec, def)) = + and imbindL denv (mspec, def) = let nm = mspec.DemangledModuleOrNamespaceName let innerPath = (fullCompPathOfModuleOrNamespace mspec).AccessPath let outerPath = mspec.CompilationPath.AccessPath diff --git a/src/fsharp/Optimizer.fs b/src/fsharp/Optimizer.fs index 1130f7d186..b75bbfbd3b 100755 --- a/src/fsharp/Optimizer.fs +++ b/src/fsharp/Optimizer.fs @@ -11,28 +11,27 @@ module internal Microsoft.FSharp.Compiler.Optimizer open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX -open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.AbstractIL.IL -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics - -open Microsoft.FSharp.Compiler.TastPickle +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.PrettyNaming open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.TastPickle open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Tastops.DebugPrint open Microsoft.FSharp.Compiler.TypeChecker open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Layout open Microsoft.FSharp.Compiler.TypeRelations -open Microsoft.FSharp.Compiler.Infos open System.Collections.Generic @@ -432,7 +431,7 @@ let BindExternalLocalVal cenv (v:Val) vval env = CheckInlineValueIsComplete v vval; #endif - if verboseOptimizationInfo then dprintn ("*** Binding "^v.LogicalName); + if verboseOptimizationInfo then dprintn ("*** Binding "+v.LogicalName); let vval = if v.IsMutable then {vval with ValExprInfo=UnknownValue } else vval let env = #if CHECKED @@ -535,7 +534,7 @@ let TryGetInfoForEntity sv n = | Some info -> Some (info.Force()) | None -> if verboseOptimizationInfo then - dprintn ("\n\n*** Optimization info for submodule "^n^" not found in parent module which contains submodules: "^String.concat "," (NameMap.domainL sv.ModuleOrNamespaceInfos)); + dprintn ("\n\n*** Optimization info for submodule "+n+" not found in parent module which contains submodules: "+String.concat "," (NameMap.domainL sv.ModuleOrNamespaceInfos)); None let rec TryGetInfoForPath sv (p:_[]) i = @@ -559,7 +558,7 @@ let GetInfoForNonLocalVal cenv env (vref:ValRef) = match structInfo.ValInfos.TryFind(vref) with | Some ninfo -> snd ninfo | None -> - //dprintn ("\n\n*** Optimization info for value "^n^" from module "^(full_name_of_nlpath smv)^" not found, module contains values: "^String.concat "," (NameMap.domainL structInfo.ValInfos)); + //dprintn ("\n\n*** Optimization info for value "+n+" from module "+(full_name_of_nlpath smv)+" not found, module contains values: "+String.concat "," (NameMap.domainL structInfo.ValInfos)); //System.Diagnostics.Debug.Assert(false,sprintf "Break for module %s, value %s" (full_name_of_nlpath smv) n) if cenv.g.compilingFslib then match structInfo.ValInfos.TryFindForFslib(vref) with @@ -1255,6 +1254,7 @@ let ValueIsUsedOrHasEffect cenv fvs (b:Binding,binfo) = not (cenv.settings.EliminateUnusedBindings()) || isSome v.MemberInfo || binfo.HasEffect || + v.IsFixed || Zset.contains v (fvs()) let rec SplitValuesByIsUsedOrHasEffect cenv fvs x = @@ -1321,7 +1321,8 @@ and OpHasEffect g op = | TOp.ExnFieldGet(ecref,n) -> isExnFieldMutable ecref n | TOp.RefAddrGet -> false | TOp.ValFieldGet rfref -> rfref.RecdField.IsMutable || (TryFindTyconRefBoolAttribute g Range.range0 g.attrib_AllowNullLiteralAttribute rfref.TyconRef = Some(true)) - | TOp.ValFieldGetAddr _rfref -> true (* check *) + | TOp.ValFieldGetAddr rfref -> rfref.RecdField.IsMutable (* data is immutable, so taking address is ok *) + | TOp.UnionCaseFieldGetAddr _ -> false (* data is immutable, so taking address is ok *) | TOp.LValueOp (LGetAddr,lv) -> lv.IsMutable | TOp.UnionCaseFieldSet _ | TOp.ExnFieldSet _ @@ -1345,6 +1346,7 @@ let TryEliminateBinding cenv _env (TBind(vspec1,e1,spBind)) e2 _m = if not (cenv.optimizing && cenv.settings.EliminateImmediatelyConsumedLocals()) && not vspec1.IsCompilerGenerated then None + elif vspec1.IsFixed then None else // Peephole on immediate consumption of single bindings, e.g. "let x = e in x" --> "e" // REVIEW: enhance this by general elimination of bindings to @@ -1454,7 +1456,7 @@ let ExpandStructuralBindingRaw cenv expr = else let argTys = destTupleTy cenv.g v.Type let argBind i (arg:Expr) argTy = - let name = v.LogicalName ^ "_" ^ string i + let name = v.LogicalName + "_" + string i let v,ve = mkCompGenLocal arg.Range name argTy ve,mkCompGenBind v arg @@ -1929,6 +1931,7 @@ and OptimizeExprOpFallback cenv env (op,tyargs,args',m) arginfos valu = | TOp.Array | TOp.For _ | TOp.While _ | TOp.TryCatch _ | TOp.TryFinally _ | TOp.ILCall _ | TOp.TraitCall _ | TOp.LValueOp _ | TOp.ValFieldSet _ | TOp.UnionCaseFieldSet _ | TOp.RefAddrGet | TOp.Coerce | TOp.Reraise + | TOp.UnionCaseFieldGetAddr _ | TOp.ExnFieldSet _ -> 1,valu | TOp.Recd (ctorInfo,tcref) -> let finfos = tcref.AllInstanceFieldsAsList @@ -2833,7 +2836,8 @@ and ComputeSplitToMethodCondition flag threshold cenv env (e,einfo) = // None of them should be local polymorphic constrained values not (IsGenericValWithGenericContraints cenv.g v) && // None of them should be mutable - not v.IsMutable)))) + not v.IsMutable)))) && + not (isByrefLikeTy cenv.g (tyOfExpr cenv.g e)) and ConsiderSplitToMethod flag threshold cenv env (e,einfo) = if ComputeSplitToMethodCondition flag threshold cenv env (e,einfo) then @@ -2842,7 +2846,7 @@ and ConsiderSplitToMethod flag threshold cenv env (e,einfo) = let ty = tyOfExpr cenv.g e let nm = match env.latestBoundId with - | Some id -> id.idText^suffixForVariablesThatMayNotBeEliminated + | Some id -> id.idText+suffixForVariablesThatMayNotBeEliminated | None -> suffixForVariablesThatMayNotBeEliminated let fv,fe = mkCompGenLocal m nm (cenv.g.unit_ty --> ty) mkInvisibleLet m fv (mkLambda m uv (e,ty)) @@ -3062,7 +3066,7 @@ and OptimizeBinding cenv isRec env (TBind(v,e,spBind)) = then {einfo with Info=UnknownValue} else einfo if v.MustInline && IsPartialExprVal einfo.Info then - errorR(InternalError("the mustinline value '"^v.LogicalName^"' was not inferred to have a known value",v.Range)); + errorR(InternalError("the mustinline value '"+v.LogicalName+"' was not inferred to have a known value",v.Range)); #if DEBUG if verboseOptimizations then dprintf "val %s gets opt info %s\n" (showL(valL v)) (showL(exprValueInfoL cenv.g einfo.Info)); #endif @@ -3128,19 +3132,23 @@ and OptimizeModuleExpr cenv env x = let rec elimModDef x = match x with - | TMDefRec(tycons,vbinds,mbinds,m) -> - let vbinds = vbinds |> FlatList.filter (fun b -> b.Var |> Zset.memberOf deadSet |> not) - let mbinds = mbinds |> List.map elim_mbind - TMDefRec(tycons,vbinds,mbinds,m) + | TMDefRec(isRec,tycons,mbinds,m) -> + let mbinds = mbinds |> List.choose elimModuleBinding + TMDefRec(isRec,tycons,mbinds,m) | TMDefLet(bind,m) -> - if Zset.contains bind.Var deadSet then TMDefRec([],FlatList.empty,[],m) else x + if Zset.contains bind.Var deadSet then TMDefRec(false,[],[],m) else x | TMDefDo _ -> x | TMDefs(defs) -> TMDefs(List.map elimModDef defs) | TMAbstract _ -> x - and elim_mbind (ModuleOrNamespaceBinding(mspec, d)) = - // Clean up the ModuleOrNamespaceType by mutation - elimModSpec mspec; - ModuleOrNamespaceBinding(mspec,elimModDef d) + and elimModuleBinding x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> + if bind.Var |> Zset.memberOf deadSet then None + else Some x + | ModuleOrNamespaceBinding.Module(mspec, d) -> + // Clean up the ModuleOrNamespaceType by mutation + elimModSpec mspec + Some (ModuleOrNamespaceBinding.Module(mspec,elimModDef d)) elimModDef def @@ -3153,18 +3161,20 @@ and mkValBind (bind:Binding) info = and OptimizeModuleDef cenv (env,bindInfosColl) x = match x with - | TMDefRec(tycons,binds,mbinds,m) -> - let env = BindInternalValsToUnknown cenv (valsOfBinds binds) env - let bindInfos,env = OptimizeBindings cenv true env binds - let binds', binfos = FlatList.unzip bindInfos + | TMDefRec(isRec,tycons,mbinds,m) -> + let env = if isRec then BindInternalValsToUnknown cenv (allValsOfModDef x) env else env let mbindInfos,(env,bindInfosColl) = OptimizeModuleBindings cenv (env,bindInfosColl) mbinds let mbinds,minfos = List.unzip mbindInfos + let binds = minfos |> List.choose (function Choice1Of2 (x,_) -> Some x | _ -> None) + let binfos = minfos |> List.choose (function Choice1Of2 (_,x) -> Some x | _ -> None) + let minfos = minfos |> List.choose (function Choice2Of2 x -> Some x | _ -> None) + (* REVIEW: Eliminate let bindings on the way back up *) - (TMDefRec(tycons,binds',mbinds,m), + (TMDefRec(isRec,tycons,mbinds,m), notlazy { ValInfos= ValInfos(FlatList.map2 (fun bind binfo -> mkValBind bind (mkValInfo binfo bind.Var)) binds binfos); ModuleOrNamespaceInfos = NameMap.ofList minfos}), - (env,(FlatList.toList bindInfos :: bindInfosColl)) + (env,bindInfosColl) | TMAbstract(mexpr) -> let mexpr,info = OptimizeModuleExpr cenv env mexpr let env = BindValsInModuleOrNamespace cenv info env @@ -3187,12 +3197,17 @@ and OptimizeModuleDef cenv (env,bindInfosColl) x = and OptimizeModuleBindings cenv (env,bindInfosColl) xs = List.mapFold (OptimizeModuleBinding cenv) (env,bindInfosColl) xs -and OptimizeModuleBinding cenv (env,bindInfosColl) (ModuleOrNamespaceBinding(mspec, def)) = - let id = mspec.Id - let (def,info),(_,bindInfosColl) = OptimizeModuleDef cenv (env,bindInfosColl) def - let env = BindValsInModuleOrNamespace cenv info env - (ModuleOrNamespaceBinding(mspec,def),(id.idText, info)), - (env,bindInfosColl) +and OptimizeModuleBinding cenv (env,bindInfosColl) x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> + let ((bind',binfo) as bindInfo),env = OptimizeBinding cenv true env bind + (ModuleOrNamespaceBinding.Binding bind', Choice1Of2 (bind',binfo)),(env, [ bindInfo ] :: bindInfosColl) + | ModuleOrNamespaceBinding.Module(mspec, def) -> + let id = mspec.Id + let (def,info),(_,bindInfosColl) = OptimizeModuleDef cenv (env,bindInfosColl) def + let env = BindValsInModuleOrNamespace cenv info env + (ModuleOrNamespaceBinding.Module(mspec,def),Choice2Of2 (id.idText, info)), + (env,bindInfosColl) and OptimizeModuleDefs cenv (env,bindInfosColl) defs = if verboseOptimizations then dprintf "OptimizeModuleDefs\n"; diff --git a/src/fsharp/PatternMatchCompilation.fs b/src/fsharp/PatternMatchCompilation.fs index 8e448cfbfc..4f1f62ab2e 100755 --- a/src/fsharp/PatternMatchCompilation.fs +++ b/src/fsharp/PatternMatchCompilation.fs @@ -375,7 +375,7 @@ let getDiscrimOfPattern g tpinst t = | TPat_array (args,ty,_m) -> Some(Test.ArrayLength (args.Length,ty)) | TPat_query ((pexp,resTys,apatVrefOpt,idx,apinfo),_,_m) -> - Some(Test.ActivePatternCase (pexp, instTypes tpinst resTys, apatVrefOpt,idx,apinfo)) + Some(Test.ActivePatternCase (pexp, instTypes tpinst resTys, apatVrefOpt, idx, apinfo)) | _ -> None let constOfDiscrim discrim = @@ -493,7 +493,7 @@ let (|ListEmptyDiscrim|_|) g = function /// - Compact integer switches become a single switch. Non-compact integer /// switches, string switches and floating point switches are treated in the /// same way as Test.IsInst. -let rec BuildSwitch resPreBindOpt g expr edges dflt m = +let rec BuildSwitch inpExprOpt g expr edges dflt m = if verbose then dprintf "--> BuildSwitch@%a, #edges = %A, dflt.IsSome = %A\n" outputRange m (List.length edges) (Option.isSome dflt); match edges,dflt with | [], None -> failwith "internal error: no edges and no default" @@ -505,12 +505,12 @@ let rec BuildSwitch resPreBindOpt g expr edges dflt m = // 'isinst' tests where we have stored the result of the 'isinst' in a variable // In this case the 'expr' already holds the result of the 'isinst' test. - | (TCase(Test.IsInst _,success)):: edges, dflt when isSome resPreBindOpt -> + | (TCase(Test.IsInst _,success)):: edges, dflt when isSome inpExprOpt -> TDSwitch(expr,[TCase(Test.IsNull,BuildSwitch None g expr edges dflt m)],Some success,m) // isnull and isinst tests | (TCase((Test.IsNull | Test.IsInst _),_) as edge):: edges, dflt -> - TDSwitch(expr,[edge],Some (BuildSwitch resPreBindOpt g expr edges dflt m),m) + TDSwitch(expr,[edge],Some (BuildSwitch inpExprOpt g expr edges dflt m),m) #if OPTIMIZE_LIST_MATCHING // 'cons/nil' tests where we have stored the result of the cons test in an 'isinst' in a variable @@ -519,7 +519,7 @@ let rec BuildSwitch resPreBindOpt g expr edges dflt m = | [TCase(ListEmptyDiscrim g tinst, emptyCase)], Some consCase | [TCase(ListEmptyDiscrim g _, emptyCase); TCase(ListConsDiscrim g tinst, consCase)], None | [TCase(ListConsDiscrim g tinst, consCase); TCase(ListEmptyDiscrim g _, emptyCase)], None - when isSome resPreBindOpt -> + when isSome inpExprOpt -> TDSwitch(expr, [TCase(Test.IsNull, emptyCase)], Some consCase, m) #endif @@ -792,10 +792,10 @@ let CompilePatternBasic if debug then dprintf "chooseSimultaneousEdgeSet\n"; let simulSetOfEdgeDiscrims,fallthroughPathFrontiers = ChooseSimultaneousEdges frontiers path - let resPreBindOpt, bindOpt = ChoosePreBinder simulSetOfEdgeDiscrims subexpr + let inpExprOpt, bindOpt = ChoosePreBinder simulSetOfEdgeDiscrims subexpr // For each case, recursively compile the residue decision trees that result if that case successfully matches - let simulSetOfCases, _ = CompileSimultaneousSet frontiers path refuted subexpr simulSetOfEdgeDiscrims resPreBindOpt + let simulSetOfCases, _ = CompileSimultaneousSet frontiers path refuted subexpr simulSetOfEdgeDiscrims inpExprOpt assert (nonNil(simulSetOfCases)); @@ -812,8 +812,8 @@ let CompilePatternBasic // OK, build the whole tree and whack on the binding if any let finalDecisionTree = - let inpExprToSwitch = (match resPreBindOpt with Some vexp -> vexp | None -> GetSubExprOfInput subexpr) - let tree = BuildSwitch resPreBindOpt g inpExprToSwitch simulSetOfCases defaultTreeOpt matchm + let inpExprToSwitch = (match inpExprOpt with Some vexp -> vexp | None -> GetSubExprOfInput subexpr) + let tree = BuildSwitch inpExprOpt g inpExprToSwitch simulSetOfCases defaultTreeOpt matchm match bindOpt with | None -> tree | Some bind -> TDBind (bind,tree) @@ -897,6 +897,21 @@ let CompilePatternBasic let appexp = mkIsInst tgty argexp matchm Some(vexp),Some(mkInvisibleBind v appexp) + // Any match on a struct union must take the address of its input + | EdgeDiscrim(_i',(Test.UnionCase (ucref, _)),_) :: _rest + when (isNil topgtvs && ucref.Tycon.IsStructRecordOrUnionTycon) -> + + let argexp = GetSubExprOfInput subexpr + let vOpt,addrexp = mkExprAddrOfExprAux g true false NeverMutates argexp None matchm + match vOpt with + | None -> Some addrexp, None + | Some (v,e) -> + if topv.IsMemberOrModuleBinding then + AdjustValToTopVal v topv.ActualParent ValReprInfo.emptyValData; + Some addrexp, Some (mkInvisibleBind v e) + + + #if OPTIMIZE_LIST_MATCHING | [EdgeDiscrim(_, ListConsDiscrim g tinst,m); EdgeDiscrim(_, ListEmptyDiscrim g _, _)] | [EdgeDiscrim(_, ListEmptyDiscrim g _, _); EdgeDiscrim(_, ListConsDiscrim g tinst, m)] @@ -915,7 +930,7 @@ let CompilePatternBasic #endif // Active pattern matches: create a variable to hold the results of executing the active pattern. - | (EdgeDiscrim(_,(Test.ActivePatternCase(pexp,resTys,_resPreBindOpt,_,apinfo)),m) :: _) -> + | (EdgeDiscrim(_,(Test.ActivePatternCase(pexp,resTys,_,_,apinfo)),m) :: _) -> if debug then dprintf "Building result var for active pattern...\n"; if nonNil topgtvs then error(InternalError("Unexpected generalized type variables when compiling an active pattern",m)); @@ -930,7 +945,7 @@ let CompilePatternBasic | _ -> None,None - and CompileSimultaneousSet frontiers path refuted subexpr simulSetOfEdgeDiscrims (resPreBindOpt: Expr option) = + and CompileSimultaneousSet frontiers path refuted subexpr simulSetOfEdgeDiscrims (inpExprOpt: Expr option) = ([],simulSetOfEdgeDiscrims) ||> List.collectFold (fun taken (EdgeDiscrim(i',discrim,m)) -> // Check to see if we've already collected the edge for this case, in which case skip it. @@ -953,17 +968,18 @@ let CompilePatternBasic match discrim with | Test.UnionCase (ucref, tinst) when #if OPTIMIZE_LIST_MATCHING - isNone resPreBindOpt && + isNone inpExprOpt && #endif (isNil topgtvs && not topv.IsMemberOrModuleBinding && + not ucref.Tycon.IsStructRecordOrUnionTycon && ucref.UnionCase.RecdFields.Length >= 1 && ucref.Tycon.UnionCasesArray.Length > 1) -> let v,vexp = mkCompGenLocal m "unionCase" (mkProvenUnionCaseTy ucref tinst) let argexp = GetSubExprOfInput subexpr - let appexp = mkUnionCaseProof(argexp, ucref,tinst,m) - Some(vexp),Some(mkInvisibleBind v appexp) + let appexp = mkUnionCaseProof (argexp, ucref,tinst,m) + Some vexp,Some(mkInvisibleBind v appexp) | _ -> None,None @@ -984,7 +1000,7 @@ let CompilePatternBasic // Project a successful edge through the frontiers. let investigation = Investigation(i',discrim,path) - let frontiers = frontiers |> List.collect (GenerateNewFrontiersAfterSucccessfulInvestigation resPreBindOpt resPostBindOpt investigation) + let frontiers = frontiers |> List.collect (GenerateNewFrontiersAfterSucccessfulInvestigation inpExprOpt resPostBindOpt investigation) let tree = InvestigateFrontiers refuted frontiers // Bind the resVar for the union case, if we have one let tree = @@ -1026,7 +1042,7 @@ let CompilePatternBasic // Build a new frontier that represents the result of a successful investigation // at rule point (i',discrim,path) - and GenerateNewFrontiersAfterSucccessfulInvestigation resPreBindOpt resPostBindOpt (Investigation(i',discrim,path)) (Frontier (i, active,valMap) as frontier) = + and GenerateNewFrontiersAfterSucccessfulInvestigation inpExprOpt resPostBindOpt (Investigation(i',discrim,path)) (Frontier (i, active,valMap) as frontier) = if debug then dprintf "projecting success of investigation encompassing rule %d through rule %d \n" i' i; if (isMemOfActives path active) then @@ -1052,11 +1068,14 @@ let CompilePatternBasic if (hasParam && i = i') || (discrimsEq g discrim (Option.get (getDiscrimOfPattern pat))) then let aparity = apinfo.Names.Length let accessf' j tpinst _e' = + assert inpExprOpt.IsSome if aparity <= 1 then - Option.get resPreBindOpt + Option.get inpExprOpt else let ucref = mkChoiceCaseRef g m aparity idx - mkUnionCaseFieldGetUnproven(Option.get resPreBindOpt,ucref,instTypes tpinst resTys,j,exprm) + // TODO: In the future we will want active patterns to be able to return struct-unions + // In that eventuality, we need to check we are taking the address correctly + mkUnionCaseFieldGetUnprovenViaExprAddr (Option.get inpExprOpt,ucref,instTypes tpinst resTys,j,exprm) mkSubFrontiers path accessf' active' [p] (fun path j -> PathQuery(path,int64 j)) elif hasParam then @@ -1068,7 +1087,9 @@ let CompilePatternBasic else if i = i' then let accessf' _j tpinst _ = - mkUnionCaseFieldGetUnproven(Option.get resPreBindOpt, mkSomeCase g, instTypes tpinst resTys, 0, exprm) + // TODO: In the future we will want active patterns to be able to return struct-unions + // In that eventuality, we need to check we are taking the address correctly + mkUnionCaseFieldGetUnprovenViaExprAddr (Option.get inpExprOpt, mkSomeCase g, instTypes tpinst resTys, 0, exprm) mkSubFrontiers path accessf' active' [p] (fun path j -> PathQuery(path,int64 j)) else // Successful active patterns don't refute other patterns @@ -1077,15 +1098,15 @@ let CompilePatternBasic | TPat_unioncase (ucref1, tyargs, argpats,_) -> match discrim with | Test.UnionCase (ucref2, tinst) when g.unionCaseRefEq ucref1 ucref2 -> - let accessf' j tpinst e' = -#if OPTIMIZE_LIST_MATCHING - match resPreBindOpt with - | Some e -> mkUnionCaseFieldGetProven(e,ucref1,tinst,j,exprm) - | None -> -#endif + let accessf' j tpinst exprIn = match resPostBindOpt with - | Some e -> mkUnionCaseFieldGetProven(e,ucref1,tinst,j,exprm) - | None -> mkUnionCaseFieldGetUnproven(accessf tpinst e',ucref1,instTypes tpinst tyargs,j,exprm) + | Some e -> mkUnionCaseFieldGetProvenViaExprAddr (e,ucref1,tinst,j,exprm) + | None -> + let exprIn = + match inpExprOpt with + | Some addrexp -> addrexp + | None -> accessf tpinst exprIn + mkUnionCaseFieldGetUnprovenViaExprAddr (exprIn,ucref1,instTypes tpinst tyargs,j,exprm) mkSubFrontiers path accessf' active' argpats (fun path j -> PathUnionConstr(path,ucref1,tyargs,j)) | Test.UnionCase _ -> @@ -1098,7 +1119,7 @@ let CompilePatternBasic | TPat_array (argpats,ty,_) -> match discrim with | Test.ArrayLength (n,_) when List.length argpats = n -> - let accessf' j tpinst e' = mkCallArrayGet g exprm ty (accessf tpinst e') (mkInt g exprm j) + let accessf' j tpinst exprIn = mkCallArrayGet g exprm ty (accessf tpinst exprIn) (mkInt g exprm j) mkSubFrontiers path accessf' active' argpats (fun path j -> PathArray(path,ty,List.length argpats,j)) // Successful length tests refute all other lengths | Test.ArrayLength _ -> @@ -1109,7 +1130,7 @@ let CompilePatternBasic | TPat_exnconstr (ecref, argpats,_) -> match discrim with | Test.IsInst (_srcTy,tgtTy) when typeEquiv g (mkAppTy ecref []) tgtTy -> - let accessf' j tpinst e' = mkExnCaseFieldGet(accessf tpinst e',ecref,j,exprm) + let accessf' j tpinst exprIn = mkExnCaseFieldGet(accessf tpinst exprIn,ecref,j,exprm) mkSubFrontiers path accessf' active' argpats (fun path j -> PathExnConstr(path,ecref,j)) | _ -> // Successful type tests against one sealed type refute all other sealed types @@ -1121,16 +1142,16 @@ let CompilePatternBasic | Test.IsInst (_srcTy,tgtTy2) when typeEquiv g tgtTy1 tgtTy2 -> match pbindOpt with | Some pbind -> - let accessf' tpinst e' = + let accessf' tpinst exprIn = // Fetch the result from the place where we saved it, if possible - match resPreBindOpt with + match inpExprOpt with | Some e -> e | _ -> // Otherwise call the helper - mkCallUnboxFast g exprm (instType tpinst tgtTy1) (accessf tpinst e') + mkCallUnboxFast g exprm (instType tpinst tgtTy1) (accessf tpinst exprIn) - let (v,e') = BindSubExprOfInput g amap topgtvs pbind exprm (SubExpr(accessf',ve)) - [Frontier (i, active', valMap.Add v e' )] + let (v,exprIn) = BindSubExprOfInput g amap topgtvs pbind exprm (SubExpr(accessf',ve)) + [Frontier (i, active', valMap.Add v exprIn )] | None -> [Frontier (i, active', valMap)] @@ -1169,17 +1190,17 @@ let CompilePatternBasic | TPat_wild _ -> BindProjectionPatterns [] s | TPat_as(p',pbind,m) -> - let (v,e') = BindSubExprOfInput g amap topgtvs pbind m subExpr - BindProjectionPattern (Active(path,subExpr,p')) (accActive,accValMap.Add v e' ) + let (v,subExpr') = BindSubExprOfInput g amap topgtvs pbind m subExpr + BindProjectionPattern (Active(path,subExpr,p')) (accActive,accValMap.Add v subExpr' ) | TPat_tuple(ps,tyargs,_m) -> - let accessf' j tpinst e' = mkTupleFieldGet(accessf tpinst e',instTypes tpinst tyargs,j,exprm) + let accessf' j tpinst exprIn = mkTupleFieldGet(accessf tpinst exprIn,instTypes tpinst tyargs,j,exprm) let pathBuilder path j = PathTuple(path,tyargs,j) let newActives = List.mapi (mkSubActive pathBuilder accessf') ps BindProjectionPatterns newActives s | TPat_recd(tcref,tinst,ps,_m) -> let newActives = (ps,tcref.TrueInstanceFieldsAsRefList) ||> List.mapi2 (fun j p fref -> - let accessf' fref _j tpinst e' = mkRecdFieldGet g (accessf tpinst e',fref,instTypes tpinst tinst,exprm) + let accessf' fref _j tpinst exprIn = mkRecdFieldGet g (accessf tpinst exprIn,fref,instTypes tpinst tinst,exprm) let pathBuilder path j = PathRecd(path,tcref,tinst,j) mkSubActive pathBuilder (accessf' fref) j p) BindProjectionPatterns newActives s @@ -1228,10 +1249,10 @@ let CompilePatternBasic // Report unused targets if warnOnUnused then - let used = accTargetsOfDecisionTree dtree [] |> Hashset.ofList + let used = HashSet<_>(accTargetsOfDecisionTree dtree [],HashIdentity.Structural) clausesL |> List.iteri (fun i c -> - if not (used.ContainsKey i) then warning (RuleNeverMatched c.Range)) + if not (used.Contains i) then warning (RuleNeverMatched c.Range)) dtree,targets diff --git a/src/fsharp/PostInferenceChecks.fs b/src/fsharp/PostInferenceChecks.fs index 8ab4f90b48..9d9804fcad 100755 --- a/src/fsharp/PostInferenceChecks.fs +++ b/src/fsharp/PostInferenceChecks.fs @@ -13,18 +13,20 @@ open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open Microsoft.FSharp.Compiler.Range + +open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Layout -open Microsoft.FSharp.Compiler.AbstractIL.IL -open Microsoft.FSharp.Compiler.TypeRelations open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.TypeRelations @@ -165,15 +167,17 @@ type cenv = denv: DisplayEnv; viewCcu : CcuThunk; reportErrors: bool; - isLastCompiland : bool; + isLastCompiland : bool*bool; // outputs mutable usesQuotations : bool mutable entryPointGiven:bool } let BindVal cenv (v:Val) = //printfn "binding %s..." v.DisplayName + let alreadyDone = cenv.boundVals.ContainsKey v.Stamp cenv.boundVals.[v.Stamp] <- 1 - if cenv.reportErrors && + if not alreadyDone && + cenv.reportErrors && not v.HasBeenReferenced && not v.IsCompiledAsTopLevel && not (v.DisplayName.StartsWith("_", System.StringComparison.Ordinal)) && @@ -480,10 +484,12 @@ and CheckExprInContext (cenv:cenv) (env:env) expr (context:ByrefCallContext) = match dir with | NormalSeq -> CheckExprInContext cenv env e2 context // carry context into _;RHS (normal sequencing only) | ThenDoSeq -> CheckExpr cenv {env with limited=false} e2 + | Expr.Let (bind,body,_,_) -> CheckBinding cenv env false bind ; BindVal cenv bind.Var - CheckExpr cenv env body + CheckExprInContext cenv env body context + | Expr.Const (_,m,ty) -> CheckTypePermitByrefs cenv env m ty @@ -637,19 +643,19 @@ and CheckExprInContext (cenv:cenv) (env:env) expr (context:ByrefCallContext) = CheckExpr cenv env e1 | Expr.Match(_,_,dtree,targets,m,ty) -> - CheckTypeNoByrefs cenv env m ty; - CheckDecisionTree cenv env dtree; - CheckDecisionTreeTargets cenv env targets; + CheckTypePermitByrefs cenv env m ty // computed byrefs allowed at each branch + CheckDecisionTree cenv env dtree + CheckDecisionTreeTargets cenv env targets context | Expr.LetRec (binds,e,_,_) -> BindVals cenv (valsOfBinds binds) - CheckBindings cenv env binds; + CheckBindings cenv env binds CheckExpr cenv env e | Expr.StaticOptimization (constraints,e2,e3,m) -> - CheckExpr cenv env e2; - CheckExpr cenv env e3; + CheckExpr cenv env e2 + CheckExpr cenv env e3 constraints |> List.iter (function | TTyconEqualsTycon(ty1,ty2) -> - CheckTypeNoByrefs cenv env m ty1; + CheckTypeNoByrefs cenv env m ty1 CheckTypeNoByrefs cenv env m ty2 | TTyconIsStruct(ty1) -> CheckTypeNoByrefs cenv env m ty1) @@ -662,8 +668,8 @@ and CheckMethods cenv env baseValOpt l = and CheckMethod cenv env baseValOpt (TObjExprMethod(_,attribs,tps,vs,e,m)) = let env = BindTypars cenv.g env tps let vs = List.concat vs - CheckAttribs cenv env attribs; - CheckNoReraise cenv None e; + CheckAttribs cenv env attribs + CheckNoReraise cenv None e CheckEscapes cenv true m (match baseValOpt with Some x -> x:: vs | None -> vs) e |> ignore CheckExpr cenv env e @@ -676,13 +682,13 @@ and CheckInterfaceImpl cenv env baseValOpt (_ty,overrides) = and CheckExprOp cenv env (op,tyargs,args,m) context = let limitedCheck() = - if env.limited then errorR(Error(FSComp.SR.chkObjCtorsCantUseExceptionHandling(), m)); - List.iter (CheckTypePermitByrefs cenv env m) tyargs; + if env.limited then errorR(Error(FSComp.SR.chkObjCtorsCantUseExceptionHandling(), m)) + List.iter (CheckTypePermitByrefs cenv env m) tyargs (* Special cases *) match op,tyargs,args,context with // Handle these as special cases since mutables are allowed inside their bodies | TOp.While _,_,[Expr.Lambda(_,_,_,[_],e1,_,_);Expr.Lambda(_,_,_,[_],e2,_,_)],_ -> - CheckTypeInstNoByrefs cenv env m tyargs; + CheckTypeInstNoByrefs cenv env m tyargs CheckExprs cenv env [e1;e2] | TOp.TryFinally _,[_],[Expr.Lambda(_,_,_,[_],e1,_,_); Expr.Lambda(_,_,_,[_],e2,_,_)],_ -> @@ -729,22 +735,41 @@ and CheckExprOp cenv env (op,tyargs,args,m) context = CheckTypeInstNoByrefs cenv env m tyargs; CheckExprDirectArgs cenv env [arg1]; (* See mkRecdFieldSetViaExprAddr -- byref arg1 when #args=2 *) CheckExprs cenv env [arg2] (* Property setters on mutable structs come through here (TBC). *) + | TOp.Coerce,[_ty1;_ty2],[x],_arity -> CheckTypeInstNoByrefs cenv env m tyargs; CheckExprInContext cenv env x context + | TOp.Reraise,[_ty1],[],_arity -> CheckTypeInstNoByrefs cenv env m tyargs + | TOp.ValFieldGetAddr rfref,tyargs,[],_ -> if context <> DirectArg && cenv.reportErrors then errorR(Error(FSComp.SR.chkNoAddressStaticFieldAtThisPoint(rfref.FieldName), m)); CheckTypeInstNoByrefs cenv env m tyargs (* NOTE: there are no arg exprs to check in this case *) + | TOp.ValFieldGetAddr rfref,tyargs,[rx],_ -> if context <> DirectArg && cenv.reportErrors then errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(rfref.FieldName), m)); (* This construct is used for &(rx.rfield) and &(rx->rfield). Relax to permit byref types for rx. [See Bug 1263]. *) CheckTypeInstNoByrefs cenv env m tyargs; CheckExprInContext cenv env rx DirectArg (* allow rx to be byref here *) + + | TOp.UnionCaseFieldGet _,_,[arg1],_arity -> + CheckTypeInstNoByrefs cenv env m tyargs + CheckExprInContext cenv env arg1 DirectArg + + | TOp.UnionCaseTagGet _,_,[arg1],_arity -> + CheckTypeInstNoByrefs cenv env m tyargs + CheckExprInContext cenv env arg1 DirectArg + + | TOp.UnionCaseFieldGetAddr (uref, _idx),tyargs,[rx],_ -> + if context <> DirectArg && cenv.reportErrors then + errorR(Error(FSComp.SR.chkNoAddressFieldAtThisPoint(uref.CaseName), m)) + CheckTypeInstNoByrefs cenv env m tyargs + CheckExprInContext cenv env rx DirectArg // allow rx to be byref here + | TOp.ILAsm (instrs,tys),_,_,_ -> CheckTypeInstPermitByrefs cenv env m tys; CheckTypeInstNoByrefs cenv env m tyargs; @@ -766,6 +791,8 @@ and CheckExprOp cenv env (op,tyargs,args,m) context = errorR(Error(FSComp.SR.chkNoAddressOfArrayElementAtThisPoint(), m)); CheckExprInContext cenv env lhsArray DirectArg (* permit byref for lhs lvalue *) CheckExprs cenv env indices + | [ AI_conv _ ],_ -> + CheckExprDirectArgs cenv env args (* permit byref for args to conv *) | _instrs -> CheckExprs cenv env args end @@ -870,13 +897,13 @@ and CheckFlatExprs cenv env exprs = and CheckExprDirectArgs cenv env exprs = exprs |> List.iter (fun x -> CheckExprInContext cenv env x DirectArg) -and CheckDecisionTreeTargets cenv env targets = - targets |> Array.iter (CheckDecisionTreeTarget cenv env) +and CheckDecisionTreeTargets cenv env targets context = + targets |> Array.iter (CheckDecisionTreeTarget cenv env context ) -and CheckDecisionTreeTarget cenv env (TTarget(vs,e,_)) = +and CheckDecisionTreeTarget cenv env context (TTarget(vs,e,_)) = BindVals cenv vs vs |> FlatList.iter (CheckValSpec cenv env) - CheckExpr cenv env e + CheckExprInContext cenv env e context and CheckDecisionTree cenv env x = match x with @@ -885,9 +912,9 @@ and CheckDecisionTree cenv env x = | TDSwitch (e,cases,dflt,m) -> CheckDecisionTreeSwitch cenv env (e,cases,dflt,m) and CheckDecisionTreeSwitch cenv env (e,cases,dflt,m) = - CheckExpr cenv env e; - List.iter (fun (TCase(discrim,e)) -> CheckDecisionTreeTest cenv env m discrim; CheckDecisionTree cenv env e) cases; - Option.iter (CheckDecisionTree cenv env) dflt + CheckExprInContext cenv env e DirectArg // can be byref for struct union switch + cases |> List.iter (fun (TCase(discrim,e)) -> CheckDecisionTreeTest cenv env m discrim; CheckDecisionTree cenv env e) + dflt |> Option.iter (CheckDecisionTree cenv env) and CheckDecisionTreeTest cenv env m discrim = match discrim with @@ -956,7 +983,7 @@ and CheckAttribs cenv env (attribs: Attribs) = // Check for violations of allowMultiple = false let duplicates = - tcrefs + tcrefs |> Seq.groupBy (fun (tcref,_) -> tcref.Stamp) |> Seq.map (fun (_,elems) -> List.last (List.ofSeq elems), Seq.length elems) |> Seq.filter (fun (_,count) -> count > 1) @@ -1091,11 +1118,12 @@ and CheckBinding cenv env alwaysCheckNoReraise (TBind(v,e,_) as bind) = and CheckBindings cenv env xs = FlatList.iter (CheckBinding cenv env false) xs // Top binds introduce expression, check they are reraise free. -let CheckTopBinding cenv env (TBind(v,e,_) as bind) = +let CheckModuleBinding cenv env (TBind(v,e,_) as bind) = let isExplicitEntryPoint = HasFSharpAttribute cenv.g cenv.g.attrib_EntryPointAttribute v.Attribs if isExplicitEntryPoint then cenv.entryPointGiven <- true; - if not cenv.isLastCompiland && cenv.reportErrors then + let isLastCompiland = fst cenv.isLastCompiland + if not isLastCompiland && cenv.reportErrors then errorR(Error(FSComp.SR.chkEntryPointUsage(), v.Range)) // Analyze the r.h.s. for the "IsCompiledAsStaticPropertyWithoutField" condition @@ -1215,7 +1243,7 @@ let CheckTopBinding cenv env (TBind(v,e,_) as bind) = CheckBinding cenv env true bind -let CheckTopBindings cenv env binds = FlatList.iter (CheckTopBinding cenv env) binds +let CheckModuleBindings cenv env binds = FlatList.iter (CheckModuleBinding cenv env) binds //-------------------------------------------------------------------------- // check tycons @@ -1254,7 +1282,7 @@ let CheckEntityDefn cenv env (tycon:Entity) = | None -> [] let namesOfMethodsThatMayDifferOnlyInReturnType = ["op_Explicit";"op_Implicit"] (* hardwired *) - let methodUniquenessIncludesReturnType (minfo:MethInfo) = List.mem minfo.LogicalName namesOfMethodsThatMayDifferOnlyInReturnType + let methodUniquenessIncludesReturnType (minfo:MethInfo) = List.contains minfo.LogicalName namesOfMethodsThatMayDifferOnlyInReturnType let MethInfosEquivWrtUniqueness eraseFlag m minfo minfo2 = if methodUniquenessIncludesReturnType minfo then MethInfosEquivByNameAndSig eraseFlag true cenv.g cenv.amap m minfo minfo2 @@ -1310,15 +1338,42 @@ let CheckEntityDefn cenv env (tycon:Entity) = else errorR(Error(FSComp.SR.chkDuplicateMethodWithSuffix(nm),m)) - if minfo.NumArgs.Length > 1 && others |> List.exists (fun minfo2 -> not (IsAbstractDefaultPair2 minfo minfo2)) then + let numCurriedArgSets = minfo.NumArgs.Length + + if numCurriedArgSets > 1 && others |> List.exists (fun minfo2 -> not (IsAbstractDefaultPair2 minfo minfo2)) then errorR(Error(FSComp.SR.chkDuplicateMethodCurried nm,m)) - if minfo.NumArgs.Length > 1 && + if numCurriedArgSets > 1 && (minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) - |> List.existsSquared (fun (ParamData(isParamArrayArg, isOutArg, optArgInfo, _, reflArgInfo, ty)) -> - isParamArrayArg || isOutArg || reflArgInfo.AutoQuote || optArgInfo.IsOptional || isByrefTy cenv.g ty)) then + |> List.existsSquared (fun (ParamData(isParamArrayArg, isOutArg, optArgInfo, callerInfoInfo, _, reflArgInfo, ty)) -> + isParamArrayArg || isOutArg || reflArgInfo.AutoQuote || optArgInfo.IsOptional || callerInfoInfo <> NoCallerInfo || isByrefTy cenv.g ty)) then errorR(Error(FSComp.SR.chkCurriedMethodsCantHaveOutParams(), m)) + if numCurriedArgSets = 1 then + minfo.GetParamDatas(cenv.amap, m, minfo.FormalMethodInst) + |> List.iterSquared (fun (ParamData(_, _, optArgInfo, callerInfoInfo, _, _, ty)) -> + match (optArgInfo, callerInfoInfo) with + | _, NoCallerInfo -> () + | NotOptional, _ -> errorR(Error(FSComp.SR.tcCallerInfoNotOptional(callerInfoInfo.ToString()),m)) + | CallerSide(_), CallerLineNumber -> + if not (typeEquiv cenv.g cenv.g.int32_ty ty) then + errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfoInfo.ToString(), "int", NicePrint.minimalStringOfType cenv.denv ty),m)) + | CalleeSide, CallerLineNumber -> + if not ((isOptionTy cenv.g ty) && (typeEquiv cenv.g cenv.g.int32_ty (destOptionTy cenv.g ty))) then + errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfoInfo.ToString(), "int", NicePrint.minimalStringOfType cenv.denv (destOptionTy cenv.g ty)),m)) + | CallerSide(_), CallerFilePath -> + if not (typeEquiv cenv.g cenv.g.string_ty ty) then + errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfoInfo.ToString(), "string", NicePrint.minimalStringOfType cenv.denv ty),m)) + | CalleeSide, CallerFilePath -> + if not ((isOptionTy cenv.g ty) && (typeEquiv cenv.g cenv.g.string_ty (destOptionTy cenv.g ty))) then + errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfoInfo.ToString(), "string", NicePrint.minimalStringOfType cenv.denv (destOptionTy cenv.g ty)),m)) + | CallerSide(_), CallerMemberName -> + if not (typeEquiv cenv.g cenv.g.string_ty ty) then + errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfoInfo.ToString(), "string", NicePrint.minimalStringOfType cenv.denv ty),m)) + | CalleeSide, CallerMemberName -> + if not ((isOptionTy cenv.g ty) && (typeEquiv cenv.g cenv.g.string_ty (destOptionTy cenv.g ty))) then + errorR(Error(FSComp.SR.tcCallerInfoWrongType(callerInfoInfo.ToString(), "string", NicePrint.minimalStringOfType cenv.denv (destOptionTy cenv.g ty)),m))) + for pinfo in immediateProps do let nm = pinfo.PropertyName let m = (match pinfo.ArbitraryValRef with None -> m | Some vref -> vref.DefinitionRange) @@ -1404,8 +1459,8 @@ let CheckEntityDefn cenv env (tycon:Entity) = end; - // Considers TFsObjModelRepr, TRecdRepr and TFiniteUnionRepr. - // [Review] are all cases covered: TILObjModelRepr,TAsmRepr. [Yes - these are FSharp.Core.dll only] + // Considers TFSharpObjectRepr, TRecdRepr and TUnionRepr. + // [Review] are all cases covered: TILObjectRepr,TAsmRepr. [Yes - these are FSharp.Core.dll only] tycon.AllFieldsArray |> Array.iter (CheckRecdField false cenv env tycon); abstractSlotValsOfTycons [tycon] |> List.iter (typeOfVal >> CheckTypePermitByrefs cenv env m); (* check vslots = abstract slots *) tycon.ImmediateInterfaceTypesOfFSharpTycon |> List.iter (CheckTypePermitByrefs cenv env m); (* check implemented interface types *) @@ -1424,7 +1479,7 @@ let CheckEntityDefn cenv env (tycon:Entity) = //implements_of_tycon cenv.g tycon |> List.iter visitType if tycon.IsFSharpDelegateTycon then match tycon.TypeReprInfo with - | TFsObjModelRepr r -> + | TFSharpObjectRepr r -> match r.fsobjmodel_kind with | TTyconDelegate ss -> //ss.ClassTypars @@ -1489,15 +1544,14 @@ and CheckNothingAfterEntryPoint cenv m = and CheckDefnInModule cenv env x = match x with - | TMDefRec(tycons,binds,mspecs,m) -> + | TMDefRec(isRec,tycons,mspecs,m) -> CheckNothingAfterEntryPoint cenv m - BindVals cenv (valsOfBinds binds) - CheckEntityDefns cenv env tycons; - CheckTopBindings cenv env binds; + if isRec then BindVals cenv (allValsOfModDef x |> Seq.toList) + CheckEntityDefns cenv env tycons List.iter (CheckModuleSpec cenv env) mspecs | TMDefLet(bind,m) -> CheckNothingAfterEntryPoint cenv m - CheckTopBinding cenv env bind + CheckModuleBinding cenv env bind BindVal cenv bind.Var | TMDefDo(e,m) -> CheckNothingAfterEntryPoint cenv m @@ -1506,12 +1560,17 @@ and CheckDefnInModule cenv env x = | TMAbstract(def) -> CheckModuleExpr cenv env def | TMDefs(defs) -> CheckDefnsInModule cenv env defs -and CheckModuleSpec cenv env (ModuleOrNamespaceBinding(mspec, rhs)) = - CheckEntityDefn cenv env mspec; - let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } - CheckDefnInModule cenv env rhs - -let CheckTopImpl (g,amap,reportErrors,infoReader,internalsVisibleToPaths,viewCcu,denv ,mexpr,extraAttribs,isLastCompiland) = +and CheckModuleSpec cenv env x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> + BindVals cenv (valsOfBinds [bind]) + CheckModuleBinding cenv env bind + | ModuleOrNamespaceBinding.Module (mspec, rhs) -> + CheckEntityDefn cenv env mspec; + let env = { env with reflect = env.reflect || HasFSharpAttribute cenv.g cenv.g.attrib_ReflectedDefinitionAttribute mspec.Attribs } + CheckDefnInModule cenv env rhs + +let CheckTopImpl (g,amap,reportErrors,infoReader,internalsVisibleToPaths,viewCcu,denv ,mexpr,extraAttribs,(isLastCompiland:bool*bool)) = let cenv = { g =g ; reportErrors=reportErrors; diff --git a/src/fsharp/PostInferenceChecks.fsi b/src/fsharp/PostInferenceChecks.fsi index 834cd92b6a..b647dd2cc0 100644 --- a/src/fsharp/PostInferenceChecks.fsi +++ b/src/fsharp/PostInferenceChecks.fsi @@ -6,6 +6,7 @@ module internal Microsoft.FSharp.Compiler.PostTypeCheckSemanticChecks open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.InfoReader val testFlagMemberBody : bool ref -val CheckTopImpl : TcGlobals * Import.ImportMap * bool * Infos.InfoReader * Tast.CompilationPath list * Tast.CcuThunk * Tastops.DisplayEnv * Tast.ModuleOrNamespaceExprWithSig * Tast.Attribs * bool -> bool +val CheckTopImpl : TcGlobals * Import.ImportMap * bool * InfoReader * Tast.CompilationPath list * Tast.CcuThunk * Tastops.DisplayEnv * Tast.ModuleOrNamespaceExprWithSig * Tast.Attribs * (bool * bool) -> bool diff --git a/src/fsharp/QueueList.fs b/src/fsharp/QueueList.fs index f7720ce48b..343589d373 100755 --- a/src/fsharp/QueueList.fs +++ b/src/fsharp/QueueList.fs @@ -12,7 +12,7 @@ open System.Collections.Generic /// The type doesn't support structural hashing or comparison. type internal QueueList<'T>(firstElementsIn: FlatList<'T>, lastElementsRevIn: 'T list, numLastElementsIn: int) = let numFirstElements = firstElementsIn.Length - // Push the lastElementsRev onto the firstElements every so often + // Push the lastElementsRev onto the firstElements every so often. let push = numLastElementsIn > numFirstElements / 5 // Compute the contents after pushing. @@ -20,7 +20,7 @@ type internal QueueList<'T>(firstElementsIn: FlatList<'T>, lastElementsRevIn: ' let lastElementsRev = if push then [] else lastElementsRevIn let numLastElements = if push then 0 else numLastElementsIn - // Compute the last elements on demand + // Compute the last elements on demand. let lastElements() = if push then [] else List.rev lastElementsRev static let empty = QueueList<'T>(FlatList.empty, [], 0) @@ -32,11 +32,11 @@ type internal QueueList<'T>(firstElementsIn: FlatList<'T>, lastElementsRevIn: ' member internal x.FirstElements = firstElements member internal x.LastElements = lastElements() - /// Note this operation is O(1), unless a push happens, which is rare + /// This operation is O(1), unless a push happens, which is rare. member x.AppendOne(y) = QueueList(firstElements, y :: lastElementsRev, numLastElements+1) member x.Append(ys:seq<_>) = QueueList(firstElements, (List.rev (Seq.toList ys) @ lastElementsRev), numLastElements+1) - /// Note this operation is O(n) anyway, so executing ToFlatList() here is OK + /// This operation is O(n) anyway, so executing ToFlatList() here is OK interface IEnumerable<'T> with member x.GetEnumerator() : IEnumerator<'T> = (x.ToFlatList() :> IEnumerable<_>).GetEnumerator() interface IEnumerable with diff --git a/src/fsharp/QuotationTranslator.fs b/src/fsharp/QuotationTranslator.fs index 22090236d4..3361b5ec54 100755 --- a/src/fsharp/QuotationTranslator.fs +++ b/src/fsharp/QuotationTranslator.fs @@ -433,6 +433,9 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP. | TOp.ValFieldGetAddr(_rfref),_tyargs,_ -> wfail(Error(FSComp.SR.crefQuotationsCantContainAddressOf(), m)) + | TOp.UnionCaseFieldGetAddr _,_tyargs,_ -> + wfail(Error(FSComp.SR.crefQuotationsCantContainAddressOf(), m)) + | TOp.ValFieldGet(_rfref),_tyargs,[] -> wfail(Error(FSComp.SR.crefQuotationsCantContainStaticFieldRef(),m)) diff --git a/src/fsharp/ReferenceResolution.fs b/src/fsharp/ReferenceResolution.fs index 353badb8ac..a18003a126 100644 --- a/src/fsharp/ReferenceResolution.fs +++ b/src/fsharp/ReferenceResolution.fs @@ -44,17 +44,17 @@ module internal MSBuildResolver = open System.Reflection type ResolvedFile = - { /// Item specification + { /// Item specification. itemSpec:string - /// Location that the assembly was resolved from + /// Location that the assembly was resolved from. resolvedFrom:ResolvedFrom - /// The long fusion name of the assembly + /// The long fusion name of the assembly. fusionName:string - /// The version of the assembly (like 4.0.0.0) + /// The version of the assembly (like 4.0.0.0). version:string - /// The name of the redist the assembly was found in + /// The name of the redist the assembly was found in. redist:string - /// Round-tripped baggage string + /// Round-tripped baggage string. baggage:string } @@ -62,17 +62,17 @@ module internal MSBuildResolver = /// Reference resolution results. All paths are fully qualified. type ResolutionResults = - { /// Paths to primary references + { /// Paths to primary references. resolvedFiles:ResolvedFile[] - /// Paths to dependencies + /// Paths to dependencies. referenceDependencyPaths:string[] - /// Paths to related files (like .xml and .pdb) + /// Paths to related files (like .xml and .pdb). relatedPaths:string[] /// Paths to satellite assemblies used for localization. referenceSatellitePaths:string[] /// Additional files required to support multi-file assemblies. referenceScatterPaths:string[] - /// Paths to files that reference resolution recommend be copied to the local directory + /// Paths to files that reference resolution recommend be copied to the local directory. referenceCopyLocalPaths:string[] /// Binding redirects that reference resolution recommends for the app.config file. suggestedBindingRedirects:string[] @@ -89,9 +89,10 @@ module internal MSBuildResolver = } - /// Get the Reference Assemblies directory for the .NET Framework on Window + /// Get the Reference Assemblies directory for the .NET Framework on Window. let DotNetFrameworkReferenceAssembliesRootDirectoryOnWindows = - // Note that ProgramFilesX86 is correct for both x86 and x64 architectures (the reference assemblies are always in the 32-bit location, which is PF(x86) on an x64 machine) + // ProgramFilesX86 is correct for both x86 and x64 architectures + // (the reference assemblies are always in the 32-bit location, which is PF(x86) on an x64 machine) let PF = match Environment.GetEnvironmentVariable("ProgramFiles(x86)") with | null -> Environment.GetEnvironmentVariable("ProgramFiles") // if PFx86 is null, then we are 32-bit and just get PF @@ -416,7 +417,7 @@ module internal MSBuildResolver = outputDirectory, fsharpCoreExplicitDirOrFSharpBinariesDir, explicitIncludeDirs, implicitIncludeDir, frameworkRegistryBase, assemblyFoldersSuffix, assemblyFoldersConditions, logMessage, logWarning, logError) = - // The {RawFileName} target is 'dangerous', in the sense that is uses Directory.GetCurrentDirectory() to resolve unrooted file paths. + // The {RawFileName} target is 'dangerous', in the sense that is uses Directory.GetCurrentDirectory() to resolve unrooted file paths. // It is unreliable to use this mutable global state inside Visual Studio. As a result, we partition all references into a "rooted" set // (which contains e.g. C:\MyDir\MyAssem.dll) and "unrooted" (everything else). We only allow "rooted" to use {RawFileName}. Note that // unrooted may still find 'local' assemblies by virtue of the fact that "implicitIncludeDir" is one of the places searched during diff --git a/src/fsharp/ReferenceResolution.fsi b/src/fsharp/ReferenceResolution.fsi index 03b6980239..555dc07ad4 100644 --- a/src/fsharp/ReferenceResolution.fsi +++ b/src/fsharp/ReferenceResolution.fsi @@ -32,39 +32,39 @@ module internal MSBuildResolver = /// Information about a resolved file. type ResolvedFile = - { /// Item specification + { /// Item specification. itemSpec:string - /// Location that the assembly was resolved from + /// Location that the assembly was resolved from. resolvedFrom:ResolvedFrom - /// The long fusion name of the assembly + /// The long fusion name of the assembly. fusionName:string - /// The version of the assembly (like 4.0.0.0) + /// The version of the assembly (like 4.0.0.0). version:string - /// The name of the redist the assembly was found in + /// The name of the redist the assembly was found in. redist:string - /// Round-tripped baggage string + /// Round-tripped baggage string. baggage:string } /// Reference resolution results. All paths are fully qualified. type ResolutionResults = - { /// Paths to primary references + { /// Paths to primary references. resolvedFiles:ResolvedFile[] - /// Paths to dependencies + /// Paths to dependencies. referenceDependencyPaths:string[] - /// Paths to related files (like .xml and .pdb) + /// Paths to related files (like .xml and .pdb). relatedPaths:string[] /// Paths to satellite assemblies used for localization. referenceSatellitePaths:string[] /// Additional files required to support multi-file assemblies. referenceScatterPaths:string[] - /// Paths to files that reference resolution recommend be copied to the local directory + /// Paths to files that reference resolution recommend be copied to the local directory. referenceCopyLocalPaths:string[] /// Binding redirects that reference resolution recommends for the app.config file. suggestedBindingRedirects:string[] } - /// Perform assembly resolution on the given references + /// Perform assembly resolution on the given references. val Resolve: resolutionEnvironment: ResolutionEnvironment * references:seq * diff --git a/src/fsharp/SignatureConformance.fs b/src/fsharp/SignatureConformance.fs new file mode 100644 index 0000000000..3d8a863faa --- /dev/null +++ b/src/fsharp/SignatureConformance.fs @@ -0,0 +1,638 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +/// Primary relations on types and signatures, with the exception of +/// constraint solving and method overload resolution. +module internal Microsoft.FSharp.Compiler.SignatureConformance + +open Internal.Utilities +open System.Text + +open Microsoft.FSharp.Compiler +open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.Tastops +open Microsoft.FSharp.Compiler.Tastops.DebugPrint +open Microsoft.FSharp.Compiler.TcGlobals +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.TypeRelations + +#if EXTENSIONTYPING +open Microsoft.FSharp.Compiler.ExtensionTyping +#endif + + +exception RequiredButNotSpecified of DisplayEnv * Tast.ModuleOrNamespaceRef * string * (StringBuilder -> unit) * range +exception ValueNotContained of DisplayEnv * Tast.ModuleOrNamespaceRef * Val * Val * (string * string * string -> string) +exception ConstrNotContained of DisplayEnv * UnionCase * UnionCase * (string * string -> string) +exception ExnconstrNotContained of DisplayEnv * Tycon * Tycon * (string * string -> string) +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) = + + // Build a remap that maps tcrefs in the signature to tcrefs in the implementation + // Used when checking attributes. + let sigToImplRemap = + let remap = Remap.Empty + let remap = (remapInfo.mrpiEntities,remap) ||> List.foldBack (fun (implTcref ,signTcref) acc -> addTyconRefRemap signTcref implTcref acc) + let remap = (remapInfo.mrpiVals ,remap) ||> List.foldBack (fun (implValRef,signValRef) acc -> addValRemap signValRef.Deref implValRef.Deref acc) + remap + + // For all attributable elements (types, modules, exceptions, record fields, unions, parameters, generic type parameters) + // + // (a) Start with lists AImpl and ASig containing the attributes in the implementation and signature, in declaration order + // (b) Each attribute in AImpl is checked against the available attributes in ASig. + // a. If an attribute is found in ASig which is an exact match (after evaluating attribute arguments), then the attribute in the implementation is ignored, the attribute is removed from ASig, and checking continues + // b. If an attribute is found in ASig that has the same attribute type, then a warning is given and the attribute in the implementation is ignored + // c. Otherwise, the attribute in the implementation is kept + // (c) The attributes appearing in the compiled element are the compiled forms of the attributes from the signature and the kept attributes from the implementation + let checkAttribs _aenv (implAttribs:Attribs) (sigAttribs:Attribs) fixup = + + // Remap the signature attributes to make them look as if they were declared in + // the implementation. This allows us to compare them and propagate them to the implementation + // if needed. + let sigAttribs = sigAttribs |> List.map (remapAttrib g sigToImplRemap) + + // Helper to check for equality of evaluated attribute expressions + let attribExprEq (AttribExpr(_,e1)) (AttribExpr(_,e2)) = EvaledAttribExprEquality g e1 e2 + + // Helper to check for equality of evaluated named attribute arguments + let attribNamedArgEq (AttribNamedArg(nm1,ty1,isProp1,e1)) (AttribNamedArg(nm2,ty2,isProp2,e2)) = + (nm1 = nm2) && + typeEquiv g ty1 ty2 && + (isProp1 = isProp2) && + attribExprEq e1 e2 + + let attribsEq attrib1 attrib2 = + let (Attrib(implTcref,_,implArgs,implNamedArgs,_,_,_implRange)) = attrib1 + let (Attrib(signTcref,_,signArgs,signNamedArgs,_,_,_signRange)) = attrib2 + tyconRefEq g signTcref implTcref && + (implArgs,signArgs) ||> List.lengthsEqAndForall2 attribExprEq && + (implNamedArgs, signNamedArgs) ||> List.lengthsEqAndForall2 attribNamedArgEq + + let attribsHaveSameTycon attrib1 attrib2 = + let (Attrib(implTcref,_,_,_,_,_,_)) = attrib1 + let (Attrib(signTcref,_,_,_,_,_,_)) = attrib2 + tyconRefEq g signTcref implTcref + + // For each implementation attribute, only keep if it is not mentioned in the signature. + // Emit a warning if it is mentioned in the signature and the arguments to the attributes are + // not identical. + let rec check keptImplAttribsRev implAttribs sigAttribs = + match implAttribs with + | [] -> keptImplAttribsRev |> List.rev + | implAttrib :: remainingImplAttribs -> + + // Look for an attribute in the signature that matches precisely. If so, remove it + let lookForMatchingAttrib = sigAttribs |> List.tryRemove (attribsEq implAttrib) + match lookForMatchingAttrib with + | Some (_, remainingSigAttribs) -> check keptImplAttribsRev remainingImplAttribs remainingSigAttribs + | None -> + + // Look for an attribute in the signature that has the same type. If so, give a warning + let existsSimilarAttrib = sigAttribs |> List.exists (attribsHaveSameTycon implAttrib) + + if existsSimilarAttrib then + let (Attrib(implTcref,_,_,_,_,_,implRange)) = implAttrib + warning(Error(FSComp.SR.tcAttribArgsDiffer(implTcref.DisplayName), implRange)) + check keptImplAttribsRev remainingImplAttribs sigAttribs + else + check (implAttrib :: keptImplAttribsRev) remainingImplAttribs sigAttribs + + let keptImplAttribs = check [] implAttribs sigAttribs + + fixup (sigAttribs @ keptImplAttribs) + true + + let rec checkTypars m (aenv: TypeEquivEnv) (implTypars:Typars) (sigTypars:Typars) = + if implTypars.Length <> sigTypars.Length then + errorR (Error(FSComp.SR.typrelSigImplNotCompatibleParamCountsDiffer(),m)) + false + else + let aenv = aenv.BindEquivTypars implTypars sigTypars + (implTypars,sigTypars) ||> List.forall2 (fun implTypar sigTypar -> + let m = sigTypar.Range + if implTypar.StaticReq <> sigTypar.StaticReq then + errorR (Error(FSComp.SR.typrelSigImplNotCompatibleCompileTimeRequirementsDiffer(), m)) + + // Adjust the actual type parameter name to look like the signature + implTypar.SetIdent (mkSynId implTypar.Range sigTypar.Id.idText) + + // Mark it as "not compiler generated", now that we've got a good name for it + implTypar.SetCompilerGenerated false + + // Check the constraints in the implementation are present in the signature + implTypar.Constraints |> List.forall (fun implTyparCx -> + match implTyparCx with + // defaults can be dropped in the signature + | TyparConstraint.DefaultsTo(_,_acty,_) -> true + | _ -> + if not (List.exists (typarConstraintsAEquiv g aenv implTyparCx) sigTypar.Constraints) + then (errorR(Error(FSComp.SR.typrelSigImplNotCompatibleConstraintsDiffer(sigTypar.Name, Layout.showL(NicePrint.layoutTyparConstraint denv (implTypar,implTyparCx))),m)); false) + else true) && + + // Check the constraints in the signature are present in the implementation + sigTypar.Constraints |> List.forall (fun sigTyparCx -> + match sigTyparCx with + // defaults can be present in the signature and not in the implementation because they are erased + | TyparConstraint.DefaultsTo(_,_acty,_) -> true + // 'comparison' and 'equality' constraints can be present in the signature and not in the implementation because they are erased + | TyparConstraint.SupportsComparison _ -> true + | TyparConstraint.SupportsEquality _ -> true + | _ -> + if not (List.exists (fun implTyparCx -> typarConstraintsAEquiv g aenv implTyparCx sigTyparCx) implTypar.Constraints) then + (errorR(Error(FSComp.SR.typrelSigImplNotCompatibleConstraintsDifferRemove(sigTypar.Name, Layout.showL(NicePrint.layoutTyparConstraint denv (sigTypar,sigTyparCx))),m)); false) + else + true) && + (not checkingSig || checkAttribs aenv implTypar.Attribs sigTypar.Attribs (fun attribs -> implTypar.Data.typar_attribs <- attribs))) + + and checkTypeDef (aenv: TypeEquivEnv) (implTycon:Tycon) (sigTycon:Tycon) = + let m = implTycon.Range + // Propagate defn location information from implementation to signature . + sigTycon.SetOtherRange (implTycon.Range, true) + implTycon.SetOtherRange (sigTycon.Range, false) + let err f = Error(f(implTycon.TypeOrMeasureKind.ToString()), m) + if implTycon.LogicalName <> sigTycon.LogicalName then (errorR (err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNamesDiffer)); false) else + if implTycon.CompiledName <> sigTycon.CompiledName then (errorR (err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNamesDiffer)); false) else + checkExnInfo (fun f -> ExnconstrNotContained(denv,implTycon,sigTycon,f)) aenv implTycon.ExceptionInfo sigTycon.ExceptionInfo && + let implTypars = implTycon.Typars m + let sigTypars = sigTycon.Typars m + if implTypars.Length <> sigTypars.Length then + errorR (err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleParameterCountsDiffer)) + false + elif isLessAccessible implTycon.Accessibility sigTycon.Accessibility then + errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleAccessibilityDiffer)) + false + else + let aenv = aenv.BindEquivTypars implTypars sigTypars + + let aintfs = implTycon.ImmediateInterfaceTypesOfFSharpTycon + let fintfs = sigTycon.ImmediateInterfaceTypesOfFSharpTycon + let aintfsUser = implTycon.TypeContents.tcaug_interfaces |> List.filter (fun (_,compgen,_) -> not compgen) |> List.map p13 + let flatten tys = + tys + |> List.collect (AllSuperTypesOfType g amap m AllowMultiIntfInstantiations.Yes) + |> ListSet.setify (typeEquiv g) + |> List.filter (isInterfaceTy g) + let aintfs = flatten aintfs + let aintfsUser = flatten aintfsUser + let fintfs = flatten fintfs + + let unimpl = ListSet.subtract (fun fity aity -> typeAEquiv g aenv aity fity) fintfs aintfs + (unimpl |> List.forall (fun ity -> errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleMissingInterface(x, NicePrint.minimalStringOfType denv ity))); false)) && + let hidden = ListSet.subtract (typeAEquiv g aenv) aintfsUser fintfs + hidden |> List.iter (fun ity -> (if implTycon.IsFSharpInterfaceTycon then error else warning) (InterfaceNotRevealed(denv,ity,implTycon.Range))) + + let aNull = IsUnionTypeWithNullAsTrueValue g implTycon + let fNull = IsUnionTypeWithNullAsTrueValue g sigTycon + if aNull && not fNull then + errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull)) + elif fNull && not aNull then + errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull)) + + let aNull2 = TypeNullIsExtraValue g m (generalizedTyconRef (mkLocalTyconRef implTycon)) + let fNull2 = TypeNullIsExtraValue g m (generalizedTyconRef (mkLocalTyconRef implTycon)) + if aNull2 && not fNull2 then + errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull2)) + elif fNull2 && not aNull2 then + errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull2)) + + let aSealed = isSealedTy g (generalizedTyconRef (mkLocalTyconRef implTycon)) + let fSealed = isSealedTy g (generalizedTyconRef (mkLocalTyconRef sigTycon)) + if aSealed && not fSealed then + errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSealed)) + if not aSealed && fSealed then + errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsNotSealed)) + + let aPartial = isAbstractTycon implTycon + let fPartial = isAbstractTycon sigTycon + if aPartial && not fPartial then + errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsAbstract)) + + if not aPartial && fPartial then + errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureIsAbstract)) + + if not (typeAEquiv g aenv (superOfTycon g implTycon) (superOfTycon g sigTycon)) then + errorR (err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypesHaveDifferentBaseTypes)) + + checkTypars m aenv implTypars sigTypars && + checkTypeRepr err aenv implTycon.TypeReprInfo sigTycon.TypeReprInfo && + checkTypeAbbrev err aenv implTycon.TypeOrMeasureKind sigTycon.TypeOrMeasureKind implTycon.TypeAbbrev sigTycon.TypeAbbrev && + checkAttribs aenv implTycon.Attribs sigTycon.Attribs (fun attribs -> implTycon.Data.entity_attribs <- attribs) && + checkModuleOrNamespaceContents implTycon.Range aenv (mkLocalEntityRef implTycon) sigTycon.ModuleOrNamespaceType + + and checkValInfo aenv err (implVal : Val) (sigVal : Val) = + let id = implVal.Id + match implVal.ValReprInfo, sigVal.ValReprInfo with + | _,None -> true + | None, Some _ -> err(FSComp.SR.ValueNotContainedMutabilityArityNotInferred) + | Some (ValReprInfo (implTyparNames,implArgInfos,implRetInfo) as implValInfo), Some (ValReprInfo (sigTyparNames,sigArgInfos,sigRetInfo) as sigValInfo) -> + let ntps = implTyparNames.Length + let mtps = sigTyparNames.Length + if ntps <> mtps then + err(fun(x, y, z) -> FSComp.SR.ValueNotContainedMutabilityGenericParametersDiffer(x, y, z, string mtps, string ntps)) + elif implValInfo.KindsOfTypars <> sigValInfo.KindsOfTypars then + err(FSComp.SR.ValueNotContainedMutabilityGenericParametersAreDifferentKinds) + elif not (sigArgInfos.Length <= implArgInfos.Length && List.forall2 (fun x y -> List.length x <= List.length y) sigArgInfos (fst (List.chop sigArgInfos.Length implArgInfos))) then + err(fun(x, y, z) -> FSComp.SR.ValueNotContainedMutabilityAritiesDiffer(x, y, z, id.idText, string sigArgInfos.Length, id.idText, id.idText)) + else + let implArgInfos = implArgInfos |> List.take sigArgInfos.Length + let implArgInfos = (implArgInfos, sigArgInfos) ||> List.map2 (fun l1 l2 -> l1 |> List.take l2.Length) + // Propagate some information signature to implementation. + + // Check the attributes on each argument, and update the ValReprInfo for + // the value to reflect the information in the signature. + // This ensures that the compiled form of the value matches the signature rather than + // the implementation. This also propagates argument names from signature to implementation + let res = + (implArgInfos,sigArgInfos) ||> List.forall2 (List.forall2 (fun implArgInfo sigArgInfo -> + checkAttribs aenv implArgInfo.Attribs sigArgInfo.Attribs (fun attribs -> + implArgInfo.Name <- sigArgInfo.Name + implArgInfo.Attribs <- attribs))) && + + checkAttribs aenv implRetInfo.Attribs sigRetInfo.Attribs (fun attribs -> + implRetInfo.Name <- sigRetInfo.Name + implRetInfo.Attribs <- attribs) + + implVal.SetValReprInfo (Some (ValReprInfo (sigTyparNames,implArgInfos,implRetInfo))) + res + + and checkVal implModRef (aenv:TypeEquivEnv) (implVal:Val) (sigVal:Val) = + + // Propagate defn location information from implementation to signature . + sigVal.SetOtherRange (implVal.Range, true) + implVal.SetOtherRange (sigVal.Range, false) + + let mk_err denv f = ValueNotContained(denv,implModRef,implVal,sigVal,f) + let err denv f = errorR(mk_err denv f); false + let m = implVal.Range + if implVal.IsMutable <> sigVal.IsMutable then (err denv FSComp.SR.ValueNotContainedMutabilityAttributesDiffer) + elif implVal.LogicalName <> sigVal.LogicalName then (err denv FSComp.SR.ValueNotContainedMutabilityNamesDiffer) + elif implVal.CompiledName <> sigVal.CompiledName then (err denv FSComp.SR.ValueNotContainedMutabilityCompiledNamesDiffer) + elif implVal.DisplayName <> sigVal.DisplayName then (err denv FSComp.SR.ValueNotContainedMutabilityDisplayNamesDiffer) + elif isLessAccessible implVal.Accessibility sigVal.Accessibility then (err denv FSComp.SR.ValueNotContainedMutabilityAccessibilityMore) + elif implVal.MustInline <> sigVal.MustInline then (err denv FSComp.SR.ValueNotContainedMutabilityInlineFlagsDiffer) + elif implVal.LiteralValue <> sigVal.LiteralValue then (err denv FSComp.SR.ValueNotContainedMutabilityLiteralConstantValuesDiffer) + elif implVal.IsTypeFunction <> sigVal.IsTypeFunction then (err denv FSComp.SR.ValueNotContainedMutabilityOneIsTypeFunction) + else + let implTypars,atau = implVal.TypeScheme + let sigTypars,ftau = sigVal.TypeScheme + if implTypars.Length <> sigTypars.Length then (err {denv with showTyparBinding=true} FSComp.SR.ValueNotContainedMutabilityParameterCountsDiffer) else + let aenv = aenv.BindEquivTypars implTypars sigTypars + checkTypars m aenv implTypars sigTypars && + if not (typeAEquiv g aenv atau ftau) then err denv (FSComp.SR.ValueNotContainedMutabilityTypesDiffer) + elif not (checkValInfo aenv (err denv) implVal sigVal) then false + elif not (implVal.IsExtensionMember = sigVal.IsExtensionMember) then err denv (FSComp.SR.ValueNotContainedMutabilityExtensionsDiffer) + elif not (checkMemberDatasConform (err denv) (implVal.Attribs, implVal,implVal.MemberInfo) (sigVal.Attribs,sigVal,sigVal.MemberInfo)) then false + else checkAttribs aenv implVal.Attribs sigVal.Attribs (fun attribs -> implVal.Data.val_attribs <- attribs) + + + and checkExnInfo err aenv implTypeRepr sigTypeRepr = + match implTypeRepr,sigTypeRepr with + | TExnAsmRepr _, TExnFresh _ -> + (errorR (err FSComp.SR.ExceptionDefsNotCompatibleHiddenBySignature); false) + | TExnAsmRepr tcr1, TExnAsmRepr tcr2 -> + if tcr1 <> tcr2 then (errorR (err FSComp.SR.ExceptionDefsNotCompatibleDotNetRepresentationsDiffer); false) else true + | TExnAbbrevRepr _, TExnFresh _ -> + (errorR (err FSComp.SR.ExceptionDefsNotCompatibleAbbreviationHiddenBySignature); false) + | TExnAbbrevRepr ecr1, TExnAbbrevRepr ecr2 -> + if not (tcrefAEquiv g aenv ecr1 ecr2) then + (errorR (err FSComp.SR.ExceptionDefsNotCompatibleSignaturesDiffer); false) + else true + | TExnFresh r1, TExnFresh r2-> checkRecordFieldsForExn g denv err aenv r1 r2 + | TExnNone,TExnNone -> true + | _ -> + (errorR (err FSComp.SR.ExceptionDefsNotCompatibleExceptionDeclarationsDiffer); false) + + and checkUnionCase aenv implUnionCase sigUnionCase = + let err f = errorR(ConstrNotContained(denv,implUnionCase,sigUnionCase,f));false + sigUnionCase.OtherRangeOpt <- Some (implUnionCase.Range, true) + implUnionCase.OtherRangeOpt <- Some (sigUnionCase.Range, false) + if implUnionCase.Id.idText <> sigUnionCase.Id.idText then err FSComp.SR.ModuleContainsConstructorButNamesDiffer + elif implUnionCase.RecdFields.Length <> sigUnionCase.RecdFields.Length then err FSComp.SR.ModuleContainsConstructorButDataFieldsDiffer + elif not (List.forall2 (checkField aenv) implUnionCase.RecdFields sigUnionCase.RecdFields) then err FSComp.SR.ModuleContainsConstructorButTypesOfFieldsDiffer + elif isLessAccessible implUnionCase.Accessibility sigUnionCase.Accessibility then err FSComp.SR.ModuleContainsConstructorButAccessibilityDiffers + else checkAttribs aenv implUnionCase.Attribs sigUnionCase.Attribs (fun attribs -> implUnionCase.Attribs <- attribs) + + and checkField aenv implField sigField = + let err f = errorR(FieldNotContained(denv,implField,sigField,f)); false + sigField.rfield_other_range <- Some (implField.Range, true) + implField.rfield_other_range <- Some (sigField.Range, false) + if implField.rfield_id.idText <> sigField.rfield_id.idText then err FSComp.SR.FieldNotContainedNamesDiffer + elif isLessAccessible implField.Accessibility sigField.Accessibility then err FSComp.SR.FieldNotContainedAccessibilitiesDiffer + elif implField.IsStatic <> sigField.IsStatic then err FSComp.SR.FieldNotContainedStaticsDiffer + elif implField.IsMutable <> sigField.IsMutable then err FSComp.SR.FieldNotContainedMutablesDiffer + elif implField.LiteralValue <> sigField.LiteralValue then err FSComp.SR.FieldNotContainedLiteralsDiffer + elif not (typeAEquiv g aenv implField.FormalType sigField.FormalType) then err FSComp.SR.FieldNotContainedTypesDiffer + else + checkAttribs aenv implField.FieldAttribs sigField.FieldAttribs (fun attribs -> implField.rfield_fattribs <- attribs) && + checkAttribs aenv implField.PropertyAttribs sigField.PropertyAttribs (fun attribs -> implField.rfield_pattribs <- attribs) + + and checkMemberDatasConform err (_implAttrs,implVal,implMemberInfo) (_sigAttrs, sigVal,sigMemberInfo) = + match implMemberInfo,sigMemberInfo with + | None,None -> true + | Some implMembInfo, Some sigMembInfo -> + if not (implVal.CompiledName = sigVal.CompiledName) then + err(FSComp.SR.ValueNotContainedMutabilityDotNetNamesDiffer) + elif not (implMembInfo.MemberFlags.IsInstance = sigMembInfo.MemberFlags.IsInstance) then + err(FSComp.SR.ValueNotContainedMutabilityStaticsDiffer) + elif false then + err(FSComp.SR.ValueNotContainedMutabilityVirtualsDiffer) + elif not (implMembInfo.MemberFlags.IsDispatchSlot = sigMembInfo.MemberFlags.IsDispatchSlot) then + err(FSComp.SR.ValueNotContainedMutabilityAbstractsDiffer) + // The final check is an implication: + // classes have non-final CompareTo/Hash methods + // abstract have non-final CompareTo/Hash methods + // records have final CompareTo/Hash methods + // unions have final CompareTo/Hash methods + // This is an example where it is OK for the signature to say 'non-final' when the implementation says 'final' + elif not implMembInfo.MemberFlags.IsFinal && sigMembInfo.MemberFlags.IsFinal then + err(FSComp.SR.ValueNotContainedMutabilityFinalsDiffer) + elif not (implMembInfo.MemberFlags.IsOverrideOrExplicitImpl = sigMembInfo.MemberFlags.IsOverrideOrExplicitImpl) then + err(FSComp.SR.ValueNotContainedMutabilityOverridesDiffer) + elif not (implMembInfo.MemberFlags.MemberKind = sigMembInfo.MemberFlags.MemberKind) then + err(FSComp.SR.ValueNotContainedMutabilityOneIsConstructor) + else + let finstance = ValSpecIsCompiledAsInstance g sigVal + let ainstance = ValSpecIsCompiledAsInstance g implVal + if finstance && not ainstance then + err(FSComp.SR.ValueNotContainedMutabilityStaticButInstance) + elif not finstance && ainstance then + err(FSComp.SR.ValueNotContainedMutabilityInstanceButStatic) + else true + + | _ -> false + + // ------------------------------------------------------------------------------- + // WARNING!!!! + // checkRecordFields and checkRecordFieldsForExn are the EXACT SAME FUNCTION. + // The only difference is the signature for err - this is because err is a function + // that reports errors, and checkRecordFields is called with a different + // sig for err then checkRecordFieldsForExn. + // ------------------------------------------------------------------------------- + + and checkRecordFields _g _amap _denv err aenv (implFields:TyconRecdFields) (sigFields:TyconRecdFields) = + let implFields = implFields.TrueFieldsAsList + let sigFields = sigFields.TrueFieldsAsList + let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) + let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) + NameMap.suball2 (fun s _ -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldRequiredButNotSpecified(x, s))); false) (checkField aenv) m1 m2 && + NameMap.suball2 (fun s _ -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldWasPresent(x, s))); false) (fun x y -> checkField aenv y x) m2 m1 && + // This check is required because constructors etc. are externally visible + // and thus compiled representations do pick up dependencies on the field order + (if List.forall2 (checkField aenv) implFields sigFields + then true + else (errorR(err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldOrderDiffer)); false)) + + and checkRecordFieldsForExn _g _denv err aenv (implFields:TyconRecdFields) (sigFields:TyconRecdFields) = + let implFields = implFields.TrueFieldsAsList + let sigFields = sigFields.TrueFieldsAsList + let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) + let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) + NameMap.suball2 (fun s _ -> errorR(err (fun (x, y) -> FSComp.SR.ExceptionDefsNotCompatibleFieldInSigButNotImpl(s, x, y))); false) (checkField aenv) m1 m2 && + NameMap.suball2 (fun s _ -> errorR(err (fun (x, y) -> FSComp.SR.ExceptionDefsNotCompatibleFieldInImplButNotSig(s, x, y))); false) (fun x y -> checkField aenv y x) m2 m1 && + // This check is required because constructors etc. are externally visible + // and thus compiled representations do pick up dependencies on the field order + (if List.forall2 (checkField aenv) implFields sigFields + then true + else (errorR(err (FSComp.SR.ExceptionDefsNotCompatibleFieldOrderDiffers)); false)) + + and checkVirtualSlots _g denv err _aenv implAbstractSlots sigAbstractSlots = + let m1 = NameMap.ofKeyedList (fun (v:ValRef) -> v.DisplayName) implAbstractSlots + let m2 = NameMap.ofKeyedList (fun (v:ValRef) -> v.DisplayName) sigAbstractSlots + (m1,m2) ||> NameMap.suball2 (fun _s vref -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbstractMemberMissingInImpl(x, NicePrint.stringValOrMember denv vref.Deref))); false) (fun _x _y -> true) && + (m2,m1) ||> NameMap.suball2 (fun _s vref -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbstractMemberMissingInSig(x, NicePrint.stringValOrMember denv vref.Deref))); false) (fun _x _y -> true) + + and checkClassFields isStruct _g _amap _denv err aenv (implFields:TyconRecdFields) (sigFields:TyconRecdFields) = + let implFields = implFields.TrueFieldsAsList + let sigFields = sigFields.TrueFieldsAsList + let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) + let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) + NameMap.suball2 (fun s _ -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldRequiredButNotSpecified(x, s))); false) (checkField aenv) m1 m2 && + (if isStruct then + NameMap.suball2 (fun s _ -> warning(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldIsInImplButNotSig(x, s))); true) (fun x y -> checkField aenv y x) m2 m1 + else + true) + + + and checkTypeRepr err aenv implTypeRepr sigTypeRepr = + let reportNiceError k s1 s2 = + let aset = NameSet.ofList s1 + let fset = NameSet.ofList s2 + match Zset.elements (Zset.diff aset fset) with + | [] -> + match Zset.elements (Zset.diff fset aset) with + | [] -> (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleNumbersDiffer(x, k))); false) + | l -> (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDefinesButImplDoesNot(x, k, String.concat ";" l))); false) + | l -> (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesButSignatureDoesNot(x, k, String.concat ";" l))); false) + + match implTypeRepr,sigTypeRepr with + | (TRecdRepr _ + | TUnionRepr _ + | TILObjectRepr _ +#if EXTENSIONTYPING + | TProvidedTypeExtensionPoint _ + | TProvidedNamespaceExtensionPoint _ +#endif + ), TNoRepr -> true + | (TFSharpObjectRepr r), TNoRepr -> + match r.fsobjmodel_kind with + | TTyconStruct | TTyconEnum -> + (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesStruct); false) + | _ -> + true + | (TAsmRepr _), TNoRepr -> + (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleDotNetTypeRepresentationIsHidden); false) + | (TMeasureableRepr _), TNoRepr -> + (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsHidden); false) + | (TUnionRepr r1), (TUnionRepr r2) -> + let ucases1 = r1.UnionCasesAsList + let ucases2 = r2.UnionCasesAsList + if ucases1.Length <> ucases2.Length then + let names (l: UnionCase list) = l |> List.map (fun c -> c.Id.idText) + reportNiceError "union case" (names ucases1) (names ucases2) + else List.forall2 (checkUnionCase aenv) ucases1 ucases2 + | (TRecdRepr implFields), (TRecdRepr sigFields) -> + checkRecordFields g amap denv err aenv implFields sigFields + | (TFSharpObjectRepr r1), (TFSharpObjectRepr r2) -> + if not (match r1.fsobjmodel_kind,r2.fsobjmodel_kind with + | TTyconClass,TTyconClass -> true + | TTyconInterface,TTyconInterface -> true + | TTyconStruct,TTyconStruct -> true + | TTyconEnum, TTyconEnum -> true + | TTyconDelegate (TSlotSig(_,typ1,ctps1,mtps1,ps1, rty1)), + TTyconDelegate (TSlotSig(_,typ2,ctps2,mtps2,ps2, rty2)) -> + (typeAEquiv g aenv typ1 typ2) && + (ctps1.Length = ctps2.Length) && + (let aenv = aenv.BindEquivTypars ctps1 ctps2 + (typarsAEquiv g aenv ctps1 ctps2) && + (mtps1.Length = mtps2.Length) && + (let aenv = aenv.BindEquivTypars mtps1 mtps2 + (typarsAEquiv g aenv mtps1 mtps2) && + ((ps1,ps2) ||> List.lengthsEqAndForall2 (List.lengthsEqAndForall2 (fun p1 p2 -> typeAEquiv g aenv p1.Type p2.Type))) && + (returnTypesAEquiv g aenv rty1 rty2))) + | _,_ -> false) then + (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsDifferentKind); false) + else + let isStruct = (match r1.fsobjmodel_kind with TTyconStruct -> true | _ -> false) + checkClassFields isStruct g amap denv err aenv r1.fsobjmodel_rfields r2.fsobjmodel_rfields && + checkVirtualSlots g denv err aenv r1.fsobjmodel_vslots r2.fsobjmodel_vslots + | (TAsmRepr tcr1), (TAsmRepr tcr2) -> + if tcr1 <> tcr2 then (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleILDiffer); false) else true + | (TMeasureableRepr ty1), (TMeasureableRepr ty2) -> + if typeAEquiv g aenv ty1 ty2 then true else (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer); false) + | TNoRepr, TNoRepr -> true +#if EXTENSIONTYPING + | TProvidedTypeExtensionPoint info1 , TProvidedTypeExtensionPoint info2 -> + Tainted.EqTainted info1.ProvidedType.TypeProvider info2.ProvidedType.TypeProvider && ProvidedType.TaintedEquals(info1.ProvidedType,info2.ProvidedType) + | TProvidedNamespaceExtensionPoint _, TProvidedNamespaceExtensionPoint _ -> + System.Diagnostics.Debug.Assert(false, "unreachable: TProvidedNamespaceExtensionPoint only on namespaces, not types" ) + true +#endif + | TNoRepr, _ -> (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer); false) + | _, _ -> (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer); false) + + and checkTypeAbbrev err aenv kind1 kind2 implTypeAbbrev sigTypeAbbrev = + if kind1 <> kind2 then (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDeclaresDiffer(x, kind2.ToString(), kind1.ToString()))); false) + else + match implTypeAbbrev,sigTypeAbbrev with + | Some ty1, Some ty2 -> + if not (typeAEquiv g aenv ty1 ty2) then + let s1, s2, _ = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 + errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbbreviationsDiffer(x, s1, s2))) + false + else + true + | None,None -> true + | Some _, None -> (errorR (err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbbreviationHiddenBySig)); false) + | None, Some _ -> (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleSigHasAbbreviation); false) + + and checkModuleOrNamespaceContents m aenv (implModRef:ModuleOrNamespaceRef) (signModType:ModuleOrNamespaceType) = + let implModType = implModRef.ModuleOrNamespaceType + (if implModType.ModuleOrNamespaceKind <> signModType.ModuleOrNamespaceKind then errorR(Error(FSComp.SR.typrelModuleNamespaceAttributesDifferInSigAndImpl(),m))) + + + (implModType.TypesByMangledName , signModType.TypesByMangledName) + ||> NameMap.suball2 + (fun s _fx -> errorR(RequiredButNotSpecified(denv,implModRef,"type",(fun os -> Printf.bprintf os "%s" s),m)); false) + (checkTypeDef aenv) && + + + (implModType.ModulesAndNamespacesByDemangledName, signModType.ModulesAndNamespacesByDemangledName ) + ||> NameMap.suball2 + (fun s fx -> errorR(RequiredButNotSpecified(denv,implModRef,(if fx.IsModule then "module" else "namespace"),(fun os -> Printf.bprintf os "%s" s),m)); false) + (fun x1 x2 -> checkModuleOrNamespace aenv (mkLocalModRef x1) x2) && + + let sigValHadNoMatchingImplementation (fx:Val) (_closeActualVal: Val option) = + errorR(RequiredButNotSpecified(denv,implModRef,"value",(fun os -> + (* In the case of missing members show the full required enclosing type and signature *) + if fx.IsMember then + NicePrint.outputQualifiedValOrMember denv os fx + else + Printf.bprintf os "%s" fx.DisplayName),m)) + + let valuesPartiallyMatch (av:Val) (fv:Val) = + (av.LinkagePartialKey.MemberParentMangledName = fv.LinkagePartialKey.MemberParentMangledName) && + (av.LinkagePartialKey.LogicalName = fv.LinkagePartialKey.LogicalName) && + (av.LinkagePartialKey.TotalArgCount = fv.LinkagePartialKey.TotalArgCount) + + (implModType.AllValsAndMembersByLogicalNameUncached, signModType.AllValsAndMembersByLogicalNameUncached) + ||> NameMap.suball2 + (fun _s (fxs:Val list) -> sigValHadNoMatchingImplementation fxs.Head None; false) + (fun avs fvs -> + match avs,fvs with + | [],_ | _,[] -> failwith "unreachable" + | [av],[fv] -> + if valuesPartiallyMatch av fv then + checkVal implModRef aenv av fv + else + sigValHadNoMatchingImplementation fv None + false + | _ -> + // for each formal requirement, try to find a precisely matching actual requirement + let matchingPairs = + fvs |> List.choose (fun fv -> + match avs |> List.tryFind (fun av -> + let res = valLinkageAEquiv g aenv av fv + //if res then printfn "%s" (bufs (fun buf -> Printf.bprintf buf "YES MATCH: fv '%a', av '%a'" (NicePrint.outputQualifiedValOrMember denv) fv (NicePrint.outputQualifiedValOrMember denv) av)) + //else printfn "%s" (bufs (fun buf -> Printf.bprintf buf "NO MATCH: fv '%a', av '%a'" (NicePrint.outputQualifiedValOrMember denv) fv (NicePrint.outputQualifiedValOrMember denv) av)) + res) with + | None -> None + | Some av -> Some(fv,av)) + + // Check the ones with matching linkage + let allPairsOk = matchingPairs |> List.map (fun (fv,av) -> checkVal implModRef aenv av fv) |> List.forall id + let someNotOk = matchingPairs.Length < fvs.Length + // Report an error for those that don't. Try pairing up by enclosing-type/name + if someNotOk then + let noMatches,partialMatchingPairs = + fvs |> List.splitChoose (fun fv -> + match avs |> List.tryFind (fun av -> valuesPartiallyMatch av fv) with + | None -> Choice1Of2 fv + | Some av -> Choice2Of2(fv,av)) + for (fv,av) in partialMatchingPairs do + checkVal implModRef aenv av fv |> ignore + for fv in noMatches do + sigValHadNoMatchingImplementation fv None + allPairsOk && not someNotOk) + + + and checkModuleOrNamespace aenv implModRef sigModRef = + // Propagate defn location information from implementation to signature . + sigModRef.SetOtherRange (implModRef.Range, true) + implModRef.Deref.SetOtherRange (sigModRef.Range, false) + checkModuleOrNamespaceContents implModRef.Range aenv implModRef sigModRef.ModuleOrNamespaceType && + checkAttribs aenv implModRef.Attribs sigModRef.Attribs implModRef.Deref.SetAttribs + + member __.CheckSignature aenv (implModRef:ModuleOrNamespaceRef) (signModType:ModuleOrNamespaceType) = + checkModuleOrNamespaceContents implModRef.Range aenv implModRef signModType + + member __.CheckTypars m aenv (implTypars: Typars) (signTypars: Typars) = + checkTypars m aenv implTypars signTypars + + +/// Check the names add up between a signature and its implementation. We check this first. +let rec CheckNamesOfModuleOrNamespaceContents denv (implModRef:ModuleOrNamespaceRef) (signModType:ModuleOrNamespaceType) = + let m = implModRef.Range + let implModType = implModRef.ModuleOrNamespaceType + NameMap.suball2 + (fun s _fx -> errorR(RequiredButNotSpecified(denv,implModRef,"type",(fun os -> Printf.bprintf os "%s" s),m)); false) + (fun _ _ -> true) + implModType.TypesByMangledName + signModType.TypesByMangledName && + + (implModType.ModulesAndNamespacesByDemangledName, signModType.ModulesAndNamespacesByDemangledName ) + ||> NameMap.suball2 + (fun s fx -> errorR(RequiredButNotSpecified(denv,implModRef,(if fx.IsModule then "module" else "namespace"),(fun os -> Printf.bprintf os "%s" s),m)); false) + (fun x1 (x2:ModuleOrNamespace) -> CheckNamesOfModuleOrNamespace denv (mkLocalModRef x1) x2.ModuleOrNamespaceType) && + + (implModType.AllValsAndMembersByLogicalNameUncached , signModType.AllValsAndMembersByLogicalNameUncached) + ||> NameMap.suball2 + (fun _s (fxs:Val list) -> + let fx = fxs.Head + errorR(RequiredButNotSpecified(denv,implModRef,"value",(fun os -> + // In the case of missing members show the full required enclosing type and signature + if isSome fx.MemberInfo then + NicePrint.outputQualifiedValOrMember denv os fx + else + Printf.bprintf os "%s" fx.DisplayName),m)); false) + (fun _ _ -> true) + + +and CheckNamesOfModuleOrNamespace denv (implModRef:ModuleOrNamespaceRef) signModType = + CheckNamesOfModuleOrNamespaceContents denv implModRef signModType + diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 932e1929d5..2be517b27d 100755 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -1,9 +1,7 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. /// Defines derived expression manipulation and construction functions. -module internal Microsoft.FSharp.Compiler.Tastops - -#nowarn "44" // This construct is deprecated. please use List.item +module internal Microsoft.FSharp.Compiler.Tastops open System.Collections.Generic open Internal.Utilities @@ -538,7 +536,7 @@ let rec sizeMeasure g ms = // Some basic type builders //--------------------------------------------------------------------------- -let mkNativePtrType g ty = TType_app (g.nativeptr_tcr, [ty]) +let mkNativePtrTy g ty = TType_app (g.nativeptr_tcr, [ty]) let mkByrefTy g ty = TType_app (g.byref_tcr, [ty]) let mkArrayTy g rank ty m = @@ -1183,24 +1181,34 @@ let mkStaticRecdFieldGetAddr(fref,tinst,m) = Expr.Op (TOp.ValFieldGetAd let mkStaticRecdFieldGet(fref,tinst,m) = Expr.Op (TOp.ValFieldGet(fref), tinst, [],m) let mkStaticRecdFieldSet(fref,tinst,e,m) = Expr.Op (TOp.ValFieldSet(fref), tinst, [e],m) -let mkRecdFieldSetViaExprAddr(e1,fref,tinst,e2,m) = Expr.Op (TOp.ValFieldSet(fref), tinst, [e1;e2],m) +let mkArrayElemAddress g (readonly,isNativePtr,shape,elemTy,aexpr,nexpr,m) = Expr.Op (TOp.ILAsm ([IL.I_ldelema(readonly,isNativePtr,shape,mkILTyvarTy 0us)],[mkByrefTy g elemTy]), [elemTy],[aexpr;nexpr],m) + +let mkRecdFieldSetViaExprAddr (e1,fref,tinst,e2,m) = Expr.Op (TOp.ValFieldSet(fref), tinst, [e1;e2],m) + +let mkUnionCaseTagGetViaExprAddr (e1,cref,tinst,m) = Expr.Op (TOp.UnionCaseTagGet(cref), tinst, [e1],m) + +/// Make a 'TOp.UnionCaseProof' expression, which proves a union value is over a particular case (used only for ref-unions, not struct-unions) +let mkUnionCaseProof (e1,cref:UnionCaseRef,tinst,m) = if cref.Tycon.IsStructOrEnumTycon then e1 else Expr.Op (TOp.UnionCaseProof(cref), tinst, [e1],m) -let mkUnionCaseTagGet(e1,cref,tinst,m) = Expr.Op (TOp.UnionCaseTagGet(cref), tinst, [e1],m) -let mkUnionCaseProof(e1,cref,tinst,m) = Expr.Op (TOp.UnionCaseProof(cref), tinst, [e1],m) +/// Build a 'TOp.UnionCaseFieldGet' expression for something we've already determined to be a particular union case. For ref-unions, +/// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. +let mkUnionCaseFieldGetProvenViaExprAddr (e1,cref,tinst,j,m) = Expr.Op (TOp.UnionCaseFieldGet(cref,j), tinst, [e1],m) -/// Build a 'get' expression for something we've already determined to be a particular union case, and where the -/// input expression has 'TType_ucase', which is an F# compiler internal "type" -let mkUnionCaseFieldGetProven(e1,cref,tinst,j,m) = Expr.Op (TOp.UnionCaseFieldGet(cref,j), tinst, [e1],m) +/// Build a 'TOp.UnionCaseFieldGetAddr' expression for a field of a union when we've already determined the value to be a particular union case. For ref-unions, +/// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. +let mkUnionCaseFieldGetAddrProvenViaExprAddr (e1,cref,tinst,j,m) = Expr.Op (TOp.UnionCaseFieldGetAddr(cref,j), tinst, [e1],m) /// Build a 'get' expression for something we've already determined to be a particular union case, but where /// the static type of the input is not yet proven to be that particular union case. This requires a type /// cast to 'prove' the condition. -let mkUnionCaseFieldGetUnproven(e1,cref,tinst,j,m) = mkUnionCaseFieldGetProven(mkUnionCaseProof(e1,cref,tinst,m),cref,tinst,j,m) +let mkUnionCaseFieldGetUnprovenViaExprAddr (e1,cref,tinst,j,m) = mkUnionCaseFieldGetProvenViaExprAddr(mkUnionCaseProof(e1,cref,tinst,m),cref,tinst,j,m) -let mkUnionCaseFieldSet(e1,cref,tinst,j,e2,m) = Expr.Op (TOp.UnionCaseFieldSet(cref,j), tinst, [e1;e2],m) +let mkUnionCaseFieldSet (e1,cref,tinst,j,e2,m) = Expr.Op (TOp.UnionCaseFieldSet(cref,j), tinst, [e1;e2],m) -let mkExnCaseFieldGet(e1,ecref,j,m) = Expr.Op (TOp.ExnFieldGet(ecref,j), [],[e1],m) -let mkExnCaseFieldSet(e1,ecref,j,e2,m) = Expr.Op (TOp.ExnFieldSet(ecref,j), [],[e1;e2],m) +let mkExnCaseFieldGet (e1,ecref,j,m) = Expr.Op (TOp.ExnFieldGet(ecref,j), [],[e1],m) +let mkExnCaseFieldSet (e1,ecref,j,e2,m) = Expr.Op (TOp.ExnFieldSet(ecref,j), [],[e1;e2],m) let mkDummyLambda g (e:Expr,ety) = let m = e.Range @@ -1312,6 +1320,9 @@ let actualTyOfRecdFieldForTycon tycon tinst (fspec:RecdField) = let actualTyOfRecdFieldRef (fref:RecdFieldRef) tinst = actualTyOfRecdFieldForTycon fref.Tycon tinst fref.RecdField +let actualTyOfUnionFieldRef (fref:UnionCaseRef) n tinst = + actualTyOfRecdFieldForTycon fref.Tycon tinst (fref.FieldByIndex(n)) + //--------------------------------------------------------------------------- // Apply type functions to types @@ -1458,6 +1469,7 @@ let isUnitTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> t let isObjTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tyconRefEq g g.system_Object_tcref tcref | _ -> false) let isVoidTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tyconRefEq g g.system_Void_tcref tcref | _ -> false) let isILAppTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tcref.IsILTycon | _ -> false) +let isNativePtrTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tyconRefEq g g.nativeptr_tcr tcref | _ -> false) let isByrefTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> tyconRefEq g g.byref_tcr tcref | _ -> false) let isByrefLikeTy g ty = ty |> stripTyEqns g |> (function TType_app(tcref,_) -> isByrefLikeTyconRef g tcref | _ -> false) #if EXTENSIONTYPING @@ -1552,18 +1564,22 @@ let isClassTy g ty = | ILTypeMetadata (_,td) -> (td.tdKind = ILTypeDefKind.Class) | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> isFSharpClassTy g ty +let isStructOrEnumTyconTy g ty = isAppTy g ty && (tyconOfAppTy g ty).IsStructOrEnumTycon + +let isStructTy g ty = isStructOrEnumTyconTy g ty + let isRefTy g ty = - isUnionTy g ty || - (isTupleTy g ty && not (isTupleStructTy g ty)) || - isRecdTy g ty || - isILReferenceTy g ty || - isFunTy g ty || - isReprHiddenTy g ty || - isFSharpObjModelRefTy g ty || - isUnitTy g ty - -let isStructTy g ty = - (isAppTy g ty && (tyconOfAppTy g ty).IsStructOrEnumTycon) || isTupleStructTy g ty + not (isStructOrEnumTyconTy g ty) && + ( + isUnionTy g ty || + isTupleTy g ty || + isRecdTy g ty || + isILReferenceTy g ty || + isFunTy g ty || + isReprHiddenTy g ty || + isFSharpObjModelRefTy g ty || + isUnitTy g ty + ) // ECMA C# LANGUAGE SPECIFICATION, 27.2 // An unmanaged-type is any type that isn't a reference-type, a type-parameter, or a generic struct-type and @@ -2212,7 +2228,7 @@ module PrettyTypes = begin choose (tp::tps) (typeIndex, measureIndex) acc let tryName (nm, typeIndex, measureIndex) f = - if List.mem nm alreadyInUse then + if List.contains nm alreadyInUse then f() else useThisName (nm, typeIndex, measureIndex) @@ -2649,6 +2665,7 @@ let TyconRefHasAttribute g m attribSpec tcref = //------------------------------------------------------------------------- let destByrefTy g ty = if isByrefTy g ty then List.head (argsOfAppTy g ty) else failwith "destByrefTy: not a byref type" +let destNativePtrTy g ty = if isNativePtrTy g ty then List.head (argsOfAppTy g ty) else failwith "destNativePtrTy: not a native ptr type" let isRefCellTy g ty = match tryDestAppTy g ty with @@ -3124,7 +3141,7 @@ module DebugPrint = begin |> List.filter (fun v -> isNil (Option.get v.MemberInfo).ImplementedSlotSigs) let iimpls = match tycon.TypeReprInfo with - | TFsObjModelRepr r when (match r.fsobjmodel_kind with TTyconInterface -> true | _ -> false) -> [] + | TFSharpObjectRepr r when (match r.fsobjmodel_kind with TTyconInterface -> true | _ -> false) -> [] | _ -> tycon.ImmediateInterfacesOfFSharpTycon let iimpls = iimpls |> List.filter (fun (_,compgen,_) -> not compgen) // if TTyconInterface, the iimpls should be printed as inheritted interfaces @@ -3156,7 +3173,7 @@ module DebugPrint = begin match repr with | TRecdRepr _ -> tycon.TrueFieldsAsList |> List.map (fun fld -> layoutRecdField fld ^^ rightL ";") |> aboveListL - | TFsObjModelRepr r -> + | TFSharpObjectRepr r -> match r.fsobjmodel_kind with | TTyconDelegate _ -> wordL "delegate ..." @@ -3184,10 +3201,10 @@ module DebugPrint = begin let alldecls = inherits @ vsprs @ vals let emptyMeasure = match tycon.TypeOrMeasureKind with TyparKind.Measure -> isNil alldecls | _ -> false if emptyMeasure then emptyL else (wordL start @@-- aboveListL alldecls) @@ wordL "end" - | TFiniteUnionRepr _ -> tycon.UnionCasesAsList |> layoutUnionCases |> aboveListL + | TUnionRepr _ -> tycon.UnionCasesAsList |> layoutUnionCases |> aboveListL | TAsmRepr _ -> wordL "(# ... #)" | TMeasureableRepr ty -> typeL ty - | TILObjModelRepr (_,_,td) -> wordL td.Name + | TILObjectRepr (_,_,td) -> wordL td.Name | _ -> failwith "unreachable" let reprL = match tycon.TypeReprInfo with @@ -3379,12 +3396,15 @@ module DebugPrint = begin and mdefsL defs = wordL "Module Defs" @@-- aboveListL(List.map mdefL defs) and mdefL x = match x with - | TMDefRec(tycons ,binds,mbinds,_) -> aboveListL ((tycons |> List.map tyconL) @ [letRecL binds emptyL] @ List.map mbindL mbinds) + | TMDefRec(_,tycons ,mbinds,_) -> aboveListL ((tycons |> List.map tyconL) @ List.map mbindL mbinds) | TMDefLet(bind,_) -> letL bind emptyL | TMDefDo(e,_) -> exprL e | TMDefs defs -> mdefsL defs; | TMAbstract mexpr -> mexprL mexpr - and mbindL (ModuleOrNamespaceBinding(mspec, rhs)) = + and mbindL x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> letL bind emptyL + | ModuleOrNamespaceBinding.Module(mspec, rhs) -> (wordL (if mspec.IsNamespace then "namespace" else "module") ^^ (wordL mspec.DemangledModuleOrNamespaceName |> stampL mspec.Stamp)) @@-- mdefL rhs and entityTypeL (mtyp:ModuleOrNamespaceType) = @@ -3446,13 +3466,13 @@ end let wrapModuleOrNamespaceType id cpath mtyp = NewModuleOrNamespace (Some cpath) taccessPublic id XmlDoc.Empty [] (notlazy mtyp) -let wrapModuleOrNamespaceTypeInNamespace id cpath (mtyp:ModuleOrNamespaceType) = - let mspec = NewModuleOrNamespace (Some cpath) taccessPublic id XmlDoc.Empty [] (notlazy mtyp) - NewModuleOrNamespaceType Namespace [ mspec ] [] +let wrapModuleOrNamespaceTypeInNamespace id cpath mtyp = + let mspec = wrapModuleOrNamespaceType id cpath mtyp + NewModuleOrNamespaceType Namespace [ mspec ] [], mspec let wrapModuleOrNamespaceExprInNamespace (id :Ident) cpath mexpr = - let mspec = NewModuleOrNamespace (Some cpath) taccessPublic id XmlDoc.Empty [] (notlazy (NewEmptyModuleOrNamespaceType Namespace)) - TMDefRec ([],FlatList.empty,[ModuleOrNamespaceBinding(mspec, mexpr)],id.idRange) + let mspec = wrapModuleOrNamespaceType id cpath (NewEmptyModuleOrNamespaceType Namespace) + TMDefRec (false, [], [ModuleOrNamespaceBinding.Module(mspec, mexpr)], id.idRange) // cleanup: make this a property let SigTypeOfImplFile (TImplFile(_,_,mexpr,_,_)) = mexpr.Type @@ -3610,7 +3630,7 @@ let abstractSlotValsOfTycons (tycons:Tycon list) = let rec accEntityRemapFromModuleOrNamespace msigty x acc = match x with - | TMDefRec(tycons,_,mbinds,_) -> + | TMDefRec(_,tycons,mbinds,_) -> let acc = (mbinds, acc) ||> List.foldBack (accEntityRemapFromModuleOrNamespaceBind msigty) let acc = (tycons, acc) ||> List.foldBack (accEntityRemap msigty) let acc = (tycons, acc) ||> List.foldBack (fun e acc -> accEntityRemapFromModuleOrNamespaceType e.ModuleOrNamespaceType (getCorrespondingSigTy e.LogicalName msigty) acc) @@ -3623,15 +3643,17 @@ let rec accEntityRemapFromModuleOrNamespace msigty x acc = and accEntityRemapFromModuleOrNamespaceDefs msigty mdefs acc = List.foldBack (accEntityRemapFromModuleOrNamespace msigty) mdefs acc -and accEntityRemapFromModuleOrNamespaceBind msigty (ModuleOrNamespaceBinding(mspec, def)) acc = +and accEntityRemapFromModuleOrNamespaceBind msigty x acc = + match x with + | ModuleOrNamespaceBinding.Binding _ -> acc + | ModuleOrNamespaceBinding.Module(mspec, def) -> accSubEntityRemap msigty mspec (accEntityRemapFromModuleOrNamespace (getCorrespondingSigTy mspec.LogicalName msigty) def acc) let rec accValRemapFromModuleOrNamespace g aenv msigty x acc = match x with - | TMDefRec(tycons,binds,mbinds,_) -> + | TMDefRec(_,tycons,mbinds,_) -> let acc = (mbinds, acc) ||> List.foldBack (accValRemapFromModuleOrNamespaceBind g aenv msigty) - let acc = (binds, acc) ||> FlatList.foldBack (valOfBind >> accValRemap g aenv msigty) // Abstract (virtual) vslots in the tycons at TMDefRec nodes are binders. They also need to be added to the remapping. let vslotvs = abstractSlotValsOfTycons tycons let acc = (vslotvs, acc) ||> List.foldBack (accValRemap g aenv msigty) @@ -3640,7 +3662,10 @@ let rec accValRemapFromModuleOrNamespace g aenv msigty x acc = | TMDefDo _ -> acc | TMDefs defs -> accValRemapFromModuleOrNamespaceDefs g aenv msigty defs acc | TMAbstract mexpr -> accValRemapFromModuleOrNamespaceType g aenv mexpr.Type msigty acc -and accValRemapFromModuleOrNamespaceBind g aenv msigty (ModuleOrNamespaceBinding(mspec, def)) acc = +and accValRemapFromModuleOrNamespaceBind g aenv msigty x acc = + match x with + | ModuleOrNamespaceBinding.Binding bind -> accValRemap g aenv msigty bind.Var acc + | ModuleOrNamespaceBinding.Module(mspec, def) -> accSubEntityRemap msigty mspec (accValRemapFromModuleOrNamespace g aenv (getCorrespondingSigTy mspec.LogicalName msigty) def acc) and accValRemapFromModuleOrNamespaceDefs g aenv msigty mdefs acc = List.foldBack (accValRemapFromModuleOrNamespace g aenv msigty) mdefs acc @@ -3978,7 +4003,7 @@ and accLocalTyconRepr opts b fvs = else { fvs with FreeLocalTyconReprs = Zset.add b fvs.FreeLocalTyconReprs } and accUsedRecdOrUnionTyconRepr opts (tc:Tycon) fvs = - if match tc.TypeReprInfo with TFsObjModelRepr _ | TRecdRepr _ | TFiniteUnionRepr _ -> true | _ -> false + if match tc.TypeReprInfo with TFSharpObjectRepr _ | TRecdRepr _ | TUnionRepr _ -> true | _ -> false then accLocalTyconRepr opts tc fvs else fvs @@ -4128,6 +4153,7 @@ and accFreeInOp opts op acc = // Things containing just a union case reference | TOp.UnionCaseProof cr | TOp.UnionCase cr + | TOp.UnionCaseFieldGetAddr (cr,_) | TOp.UnionCaseFieldGet (cr,_) | TOp.UnionCaseFieldSet (cr,_) -> accFreeUnionCaseRef opts cr acc @@ -4187,12 +4213,15 @@ and freeInExpr opts e = accFreeInExpr opts e emptyFreeVars // Note: these are only an approximation - they are currently used only by the optimizer let rec accFreeInModuleOrNamespace opts x acc = match x with - | TMDefRec(_,binds,mbinds,_) -> FlatList.foldBack (accBindRhs opts) binds (List.foldBack (accFreeInModuleOrNamespaceBind opts) mbinds acc) + | TMDefRec(_,_,mbinds,_) -> List.foldBack (accFreeInModuleOrNamespaceBind opts) mbinds acc | TMDefLet(bind,_) -> accBindRhs opts bind acc | TMDefDo(e,_) -> accFreeInExpr opts e acc | TMDefs defs -> accFreeInModuleOrNamespaces opts defs acc | TMAbstract(ModuleOrNamespaceExprWithSig(_,mdef,_)) -> accFreeInModuleOrNamespace opts mdef acc // not really right, but sufficient for how this is used in optimization -and accFreeInModuleOrNamespaceBind opts (ModuleOrNamespaceBinding(_, def)) acc = accFreeInModuleOrNamespace opts def acc +and accFreeInModuleOrNamespaceBind opts x acc = + match x with + | ModuleOrNamespaceBinding.Binding bind -> accBindRhs opts bind acc + | ModuleOrNamespaceBinding.Module (_, def) -> accFreeInModuleOrNamespace opts def acc and accFreeInModuleOrNamespaces opts x acc = List.foldBack (accFreeInModuleOrNamespace opts) x acc @@ -4536,7 +4565,7 @@ and remapExpr g (compgen:ValCopyFlag) (tmenv:Remap) x = List.map (remapMethod g compgen tmenvinner) overrides, List.map (remapInterfaceImpl g compgen tmenvinner) iimpls,m) - // Addresses of immutable field may "leak" across assembly boundaries - see CanTakeAddressOfRecdField below. + // Addresses of immutable field may "leak" across assembly boundaries - see CanTakeAddressOfRecdFieldRef below. // This is "ok", in the sense that it is always valid to fix these up to be uses // of a temporary local, e.g. // &(E.RF) --> let mutable v = E.RF in &v @@ -4550,6 +4579,15 @@ and remapExpr g (compgen:ValCopyFlag) (tmenv:Remap) x = let tmp,_ = mkMutableCompGenLocal m "copyOfStruct" (actualTyOfRecdFieldRef rfref tinst) mkCompGenLet m tmp (mkRecdFieldGetViaExprAddr(arg,rfref,tinst,m)) (mkValAddr m (mkLocalValRef tmp)) + | Expr.Op (TOp.UnionCaseFieldGetAddr (uref,cidx),tinst,[arg],m) when + not (uref.FieldByIndex(cidx).IsMutable) && + not (entityRefInThisAssembly g.compilingFslib uref.TyconRef) -> + + let tinst = remapTypes tmenv tinst + let arg = remapExpr g compgen tmenv arg + let tmp,_ = mkMutableCompGenLocal m "copyOfStruct" (actualTyOfUnionFieldRef uref cidx tinst) + mkCompGenLet m tmp (mkUnionCaseFieldGetProvenViaExprAddr(arg,uref,tinst,cidx,m)) (mkValAddr m (mkLocalValRef tmp)) + | Expr.Op (op,tinst,args,m) -> let op' = remapOp tmenv op let tinst' = remapTypes tmenv tinst @@ -4710,10 +4748,10 @@ and remapFsObjData g tmenv x = and remapTyconRepr g tmenv repr = match repr with - | TFsObjModelRepr x -> TFsObjModelRepr (remapFsObjData g tmenv x) + | TFSharpObjectRepr x -> TFSharpObjectRepr (remapFsObjData g tmenv x) | TRecdRepr x -> TRecdRepr (remapRecdFields g tmenv x) - | TFiniteUnionRepr x -> TFiniteUnionRepr (remapUnionCases g tmenv x) - | TILObjModelRepr _ -> failwith "cannot remap IL type definitions" + | TUnionRepr x -> TUnionRepr (remapUnionCases g tmenv x) + | TILObjectRepr _ -> failwith "cannot remap IL type definitions" #if EXTENSIONTYPING | TProvidedNamespaceExtensionPoint _ -> repr | TProvidedTypeExtensionPoint info -> @@ -4843,29 +4881,33 @@ and allTyconsOfTycon (tycon:Tycon) = for nestedTycon in tycon.ModuleOrNamespaceType.AllEntities do yield! allTyconsOfTycon nestedTycon } -and allTyconsOfModDef mdef = +and allEntitiesOfModDef mdef = seq { match mdef with - | TMDefRec(tycons,_,mbinds,_) -> + | TMDefRec(_,tycons,mbinds,_) -> for tycon in tycons do yield! allTyconsOfTycon tycon - for (ModuleOrNamespaceBinding(mspec, def)) in mbinds do - yield mspec; - yield! allTyconsOfModDef def + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Binding _ -> () + | ModuleOrNamespaceBinding.Module(mspec, def) -> + yield mspec + yield! allEntitiesOfModDef def | TMDefLet _ -> () | TMDefDo _ -> () | TMDefs defs -> for def in defs do - yield! allTyconsOfModDef def + yield! allEntitiesOfModDef def | TMAbstract(ModuleOrNamespaceExprWithSig(mty,_,_)) -> yield! allEntitiesOfModuleOrNamespaceTy mty } and allValsOfModDef mdef = seq { match mdef with - | TMDefRec(tycons,binds,mbinds,_) -> + | TMDefRec(_,tycons,mbinds,_) -> yield! abstractSlotValsOfTycons tycons - yield! (binds |> valsOfBinds |> FlatList.toList) - for (ModuleOrNamespaceBinding(_, def)) in mbinds do - yield! allValsOfModDef def + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Binding bind -> yield bind.Var + | ModuleOrNamespaceBinding.Module(_, def) -> yield! allValsOfModDef def | TMDefLet(bind,_) -> yield bind.Var | TMDefDo _ -> () @@ -4886,7 +4928,7 @@ and remapModExpr g compgen tmenv (ModuleOrNamespaceExprWithSig(mty,mdef,m)) = ModuleOrNamespaceExprWithSig(mty,mdef,m) and copyAndRemapModDef g compgen tmenv mdef = - let tycons = allTyconsOfModDef mdef |> List.ofSeq + let tycons = allEntitiesOfModDef mdef |> List.ofSeq let vs = allValsOfModDef mdef |> List.ofSeq let _,_,tmenvinner = copyAndRemapAndBindTyconsAndVals g compgen tmenv tycons vs remapAndRenameModDef g compgen tmenvinner mdef @@ -4896,12 +4938,11 @@ and remapAndRenameModDefs g compgen tmenv x = and remapAndRenameModDef g compgen tmenv mdef = match mdef with - | TMDefRec(tycons,binds,mbinds,m) -> + | TMDefRec(isRec,tycons,mbinds,m) -> // Abstract (virtual) vslots in the tycons at TMDefRec nodes are binders. They also need to be copied and renamed. let tycons = tycons |> List.map (renameTycon tmenv) - let binds = remapAndRenameBinds g compgen tmenv binds (binds |> FlatList.map (valOfBind >> renameVal tmenv)) let mbinds = mbinds |> List.map (remapAndRenameModBind g compgen tmenv) - TMDefRec(tycons,binds,mbinds,m) + TMDefRec(isRec,tycons,mbinds,m) | TMDefLet(bind,m) -> let v = bind.Var let bind = remapAndRenameBind g compgen tmenv bind (renameVal tmenv v) @@ -4916,10 +4957,16 @@ and remapAndRenameModDef g compgen tmenv mdef = let mexpr = remapModExpr g compgen tmenv mexpr TMAbstract mexpr -and remapAndRenameModBind g compgen tmenv (ModuleOrNamespaceBinding(mspec, def)) = - let mspec = renameTycon tmenv mspec - let def = remapAndRenameModDef g compgen tmenv def - ModuleOrNamespaceBinding(mspec, def) +and remapAndRenameModBind g compgen tmenv x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> + let v2 = bind |> valOfBind |> renameVal tmenv + let bind2 = remapAndRenameBind g compgen tmenv bind v2 + ModuleOrNamespaceBinding.Binding bind2 + | ModuleOrNamespaceBinding.Module(mspec, def) -> + let mspec = renameTycon tmenv mspec + let def = remapAndRenameModDef g compgen tmenv def + ModuleOrNamespaceBinding.Module(mspec, def) and remapImplFile g compgen tmenv mv = mapAccImplFile (remapAndBindModExpr g compgen) tmenv mv @@ -4998,14 +5045,14 @@ and remarkBind m (TBind(v,repr,_)) = //-------------------------------------------------------------------------- let isRecdOrStructFieldAllocObservable (f:RecdField) = not f.IsStatic && f.IsMutable -let ucaseAllocObservable (uc:UnionCase) = uc.FieldTable.FieldsByIndex |> Array.exists isRecdOrStructFieldAllocObservable -let isUnionCaseAllocObservable (uc:UnionCaseRef) = uc.UnionCase |> ucaseAllocObservable +let isUnionCaseAllocObservable (uc:UnionCase) = uc.FieldTable.FieldsByIndex |> Array.exists isRecdOrStructFieldAllocObservable +let isUnionCaseRefAllocObservable (uc:UnionCaseRef) = uc.UnionCase |> isUnionCaseAllocObservable let isRecdOrUnionOrStructTyconAllocObservable (_g:TcGlobals) (tycon:Tycon) = - if tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then + if tycon.IsUnionTycon then + tycon.UnionCasesArray |> Array.exists isUnionCaseAllocObservable + elif tycon.IsRecordTycon || tycon.IsStructOrEnumTycon then tycon.AllFieldsArray |> Array.exists isRecdOrStructFieldAllocObservable - elif tycon.IsUnionTycon then - tycon.UnionCasesArray |> Array.exists ucaseAllocObservable else false @@ -5091,7 +5138,7 @@ let rec tyOfExpr g e = | TOp.ExnConstr _ -> g.exn_ty | TOp.Bytes _ -> mkByteArrayTy g | TOp.UInt16s _ -> mkArrayType g g.uint16_ty - | TOp.TupleFieldGet(i) -> List.nth tinst i + | TOp.TupleFieldGet(i) -> List.item i tinst | TOp.Tuple -> mkTupleTy tinst | (TOp.For _ | TOp.While _) -> g.unit_ty | TOp.Array -> (match tinst with [ty] -> mkArrayType g ty | _ -> failwith "bad TOp.Array node") @@ -5100,6 +5147,7 @@ let rec tyOfExpr g e = | TOp.ValFieldGet(fref) -> actualTyOfRecdFieldRef fref tinst | (TOp.ValFieldSet _ | TOp.UnionCaseFieldSet _ | TOp.ExnFieldSet _ | TOp.LValueOp ((LSet | LByrefSet),_)) ->g.unit_ty | TOp.UnionCaseTagGet _ -> g.int_ty + | TOp.UnionCaseFieldGetAddr(cref,j) -> mkByrefTy g (actualTyOfRecdField (mkTyconRefInst cref.TyconRef tinst) (cref.FieldByIndex j)) | TOp.UnionCaseFieldGet(cref,j) -> actualTyOfRecdField (mkTyconRefInst cref.TyconRef tinst) (cref.FieldByIndex j) | TOp.ExnFieldGet(ecref,j) -> recdFieldTyOfExnDefRefByIdx ecref j | TOp.LValueOp (LByrefGet, v) -> destByrefTy g v.Type @@ -5324,13 +5372,13 @@ let mkAndSimplifyMatch spBind exprm matchm ty tree targets = //------------------------------------------------------------------------- -// mkExprAddrOfExpr +// mkExprAddrOfExprAux //------------------------------------------------------------------------- type Mutates = DefinitelyMutates | PossiblyMutates | NeverMutates exception DefensiveCopyWarning of string * range -let isRecdOrStuctTyImmutable g ty = +let isRecdOrStructTyImmutable g ty = match tryDestAppTy g ty with | None -> false | Some tcref -> @@ -5349,7 +5397,7 @@ let isRecdOrStuctTyImmutable g ty = // let g1 = A.G(1) // (fun () -> g1.x1) // -// Note: isRecdOrStuctTyImmutable implies PossiblyMutates or NeverMutates +// Note: isRecdOrStructTyImmutable implies PossiblyMutates or NeverMutates // // We only do this for true local or closure fields because we can't take adddresses of immutable static // fields across assemblies. @@ -5360,7 +5408,7 @@ let CanTakeAddressOfImmutableVal g (v:ValRef) mut = not v.IsMemberOrModuleBinding && (match mut with | NeverMutates -> true - | PossiblyMutates -> isRecdOrStuctTyImmutable g v.Type + | PossiblyMutates -> isRecdOrStructTyImmutable g v.Type | DefinitelyMutates -> false) let MustTakeAddressOfVal g (v:ValRef) = @@ -5368,48 +5416,61 @@ let MustTakeAddressOfVal g (v:ValRef) = // We can only take the address of mutable values in the same assembly valRefInThisAssembly g.compilingFslib v -let MustTakeAddressOfRecdField (rfref: RecdFieldRef) = +let MustTakeAddressOfRecdField (rf: RecdField) = // Static mutable fields must be private, hence we don't have to take their address - not rfref.RecdField.IsStatic && - rfref.RecdField.IsMutable + not rf.IsStatic && + rf.IsMutable -let CanTakeAddressOfRecdField g (rfref: RecdFieldRef) mut tinst = +let MustTakeAddressOfRecdFieldRef (rfref: RecdFieldRef) = MustTakeAddressOfRecdField rfref.RecdField + +let CanTakeAddressOfRecdFieldRef g (rfref: RecdFieldRef) mut tinst = mut <> DefinitelyMutates && // We only do this if the field is defined in this assembly because we can't take adddresses across assemblies for immutable fields entityRefInThisAssembly g.compilingFslib rfref.TyconRef && - isRecdOrStuctTyImmutable g (actualTyOfRecdFieldRef rfref tinst) + isRecdOrStructTyImmutable g (actualTyOfRecdFieldRef rfref tinst) + +let CanTakeAddressOfUnionFieldRef g (uref: UnionCaseRef) mut tinst cidx = + mut <> DefinitelyMutates && + // We only do this if the field is defined in this assembly because we can't take adddresses across assemblies for immutable fields + entityRefInThisAssembly g.compilingFslib uref.TyconRef && + isRecdOrStructTyImmutable g (actualTyOfUnionFieldRef uref cidx tinst) -let rec mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m = - if not mustTakeAddress then (fun x -> x),e else +let rec mkExprAddrOfExprAux g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m = + if not mustTakeAddress then None,e else match e with // LVALUE: "x" where "x" is byref | Expr.Op (TOp.LValueOp (LByrefGet, v), _,[], m) -> - (fun x -> x), exprForValRef m v + None, exprForValRef m v // LVALUE: "x" where "x" is mutable local, mutable intra-assembly module/static binding, or operation doesn't mutate // Note: we can always take the address of mutable values | Expr.Val(v, _,m) when MustTakeAddressOfVal g v || CanTakeAddressOfImmutableVal g v mut -> - (fun x -> x), mkValAddr m v - // LVALUE: "x" where "e.x" is mutable record field. "e" may be an lvalue - | Expr.Op (TOp.ValFieldGet rfref, tinst,[e],m) when MustTakeAddressOfRecdField rfref || CanTakeAddressOfRecdField g rfref mut tinst -> + None, mkValAddr m v + // LVALUE: "x" where "e.x" is record field. + | Expr.Op (TOp.ValFieldGet rfref, tinst,[e],m) when MustTakeAddressOfRecdFieldRef rfref || CanTakeAddressOfRecdFieldRef g rfref mut tinst -> let exprty = tyOfExpr g e - let wrap,expra = mkExprAddrOfExpr g (isStructTy g exprty) false mut e None m + let wrap,expra = mkExprAddrOfExprAux g (isStructTy g exprty) false mut e None m wrap, mkRecdFieldGetAddrViaExprAddr(expra,rfref,tinst,m) + // LVALUE: "x" where "e.x" is union field + | Expr.Op (TOp.UnionCaseFieldGet (uref,cidx), tinst,[e],m) when MustTakeAddressOfRecdField (uref.FieldByIndex(cidx)) || CanTakeAddressOfUnionFieldRef g uref mut tinst cidx -> + let exprty = tyOfExpr g e + let wrap,expra = mkExprAddrOfExprAux g (isStructTy g exprty) false mut e None m + wrap, mkUnionCaseFieldGetAddrProvenViaExprAddr(expra,uref,tinst,cidx,m) // LVALUE: "x" where "e.x" is a .NET static field. | Expr.Op (TOp.ILAsm ([IL.I_ldsfld(_vol,fspec)],[ty2]), tinst,[],m) -> - (fun x -> x),Expr.Op (TOp.ILAsm ([IL.I_ldsflda(fspec)],[mkByrefTy g ty2]), tinst,[],m) + None,Expr.Op (TOp.ILAsm ([IL.I_ldsflda(fspec)],[mkByrefTy g ty2]), tinst,[],m) // LVALUE: "x" where "e.x" is a .NET instance field. "e" may be an lvalue | Expr.Op (TOp.ILAsm ([IL.I_ldfld(_align,_vol,fspec)],[ty2]), tinst,[e],m) -> let exprty = tyOfExpr g e - let wrap,expra = mkExprAddrOfExpr g (isStructTy g exprty) false mut e None m + let wrap,expra = mkExprAddrOfExprAux g (isStructTy g exprty) false mut e None m wrap,Expr.Op (TOp.ILAsm ([IL.I_ldflda(fspec)],[mkByrefTy g ty2]), tinst,[expra],m) // LVALUE: "x" where "x" is mutable static field. - | Expr.Op (TOp.ValFieldGet rfref, tinst,[],m) when MustTakeAddressOfRecdField rfref || CanTakeAddressOfRecdField g rfref mut tinst -> - (fun x -> x), mkStaticRecdFieldGetAddr(rfref,tinst,m) + | Expr.Op (TOp.ValFieldGet rfref, tinst,[],m) when MustTakeAddressOfRecdFieldRef rfref || CanTakeAddressOfRecdFieldRef g rfref mut tinst -> + None, mkStaticRecdFieldGetAddr(rfref,tinst,m) // LVALUE: "e.[n]" where e is an array of structs | Expr.App(Expr.Val(vf,_,_),_,[elemTy],[aexpr;nexpr],_) @@ -5421,7 +5482,7 @@ let rec mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut match addrExprVal with | Some(vf) -> valRefEq g vf g.addrof2_vref | _ -> false - (fun x -> x), Expr.Op (TOp.ILAsm ([IL.I_ldelema(readonly,isNativePtr,shape,mkILTyvarTy 0us)],[mkByrefTy g elemTy]), [elemTy],[aexpr;nexpr],m) + None, mkArrayElemAddress g (readonly,isNativePtr,shape,elemTy,aexpr,nexpr,m) // LVALUE: "e.[n1,n2]", "e.[n1,n2,n3]", "e.[n1,n2,n3,n4]" where e is an array of structs | Expr.App(Expr.Val(vf,_,_),_,[elemTy],(aexpr::args),_) @@ -5434,7 +5495,7 @@ let rec mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut | Some(vf) -> valRefEq g vf g.addrof2_vref | _ -> false - (fun x -> x), Expr.Op (TOp.ILAsm ([IL.I_ldelema(readonly,isNativePtr,shape,mkILTyvarTy 0us)],[mkByrefTy g elemTy]), [elemTy],(aexpr::args),m) + None, Expr.Op (TOp.ILAsm ([IL.I_ldelema(readonly,isNativePtr,shape,mkILTyvarTy 0us)],[mkByrefTy g elemTy]), [elemTy],(aexpr::args),m) // Give a nice error message for DefinitelyMutates on immutable values, or mutable values in other assemblies | Expr.Val(v, _,m) when mut = DefinitelyMutates @@ -5454,16 +5515,28 @@ let rec mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut errorR(Error(FSComp.SR.tastInvalidMutationOfConstant(),m)); | PossiblyMutates -> warning(DefensiveCopyWarning(FSComp.SR.tastValueHasBeenCopied(),m)); - let tmp,_ = mkMutableCompGenLocal m "copyOfStruct" ty - (fun rest -> mkCompGenLet m tmp e rest), (mkValAddr m (mkLocalValRef tmp)) + let tmp,_ = + match mut with + | NeverMutates -> mkCompGenLocal m "copyOfStruct" ty + | _ -> mkMutableCompGenLocal m "copyOfStruct" ty + Some (tmp,e), (mkValAddr m (mkLocalValRef tmp)) + +let mkExprAddrOfExpr g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m = + let optBind, addre = mkExprAddrOfExprAux g mustTakeAddress useReadonlyForGenericArrayAddress mut e addrExprVal m + match optBind with + | None -> (fun x -> x), addre + | Some (tmp,rval) -> (fun x -> mkCompGenLet m tmp rval x), addre let mkRecdFieldGet g (e,fref:RecdFieldRef,tinst,m) = + assert (not (isByrefTy g (tyOfExpr g e))) let wrap,e' = mkExprAddrOfExpr g fref.Tycon.IsStructOrEnumTycon false NeverMutates e None m wrap (mkRecdFieldGetViaExprAddr(e',fref,tinst,m)) -let mkRecdFieldSet g (e,fref:RecdFieldRef,tinst,e2,m) = - let wrap,e' = mkExprAddrOfExpr g fref.Tycon.IsStructOrEnumTycon false DefinitelyMutates e None m - wrap (mkRecdFieldSetViaExprAddr(e',fref,tinst,e2,m)) +let mkUnionCaseFieldGetUnproven g (e,cref:UnionCaseRef,tinst,j,m) = + assert (not (isByrefTy g (tyOfExpr g e))) + let wrap,e' = mkExprAddrOfExpr g cref.Tycon.IsStructOrEnumTycon false NeverMutates e None m + wrap (mkUnionCaseFieldGetUnprovenViaExprAddr (e',cref,tinst,j,m)) + let mkArray (argty, args, m) = Expr.Op(TOp.Array, [argty],args,m) @@ -5503,12 +5576,13 @@ let rec IterateRecursiveFixups g (selfv : Val option) rvs ((access : Expr),set) | Expr.Op (TOp.UnionCase (c),tinst,args,m) -> args |> List.iteri (fun n -> IterateRecursiveFixups g None rvs - (mkUnionCaseFieldGetUnproven(access,c,tinst,n,m), + (mkUnionCaseFieldGetUnprovenViaExprAddr (access,c,tinst,n,m), (fun e -> // NICE: it would be better to do this check in the type checker let tcref = c.TyconRef - errorR(Error(FSComp.SR.tastRecursiveValuesMayNotAppearInConstructionOfType(tcref.LogicalName),m)); - mkUnionCaseFieldSet(access,c,tinst,n,e,m)))) + if not (c.FieldByIndex(n)).IsMutable && not (entityRefInThisAssembly g.compilingFslib tcref) then + errorR(Error(FSComp.SR.tastRecursiveValuesMayNotAppearInConstructionOfType(tcref.LogicalName),m)); + mkUnionCaseFieldSet (access,c,tinst,n,e,m)))) | Expr.Op (TOp.Recd (_,tcref),tinst,args,m) -> (tcref.TrueInstanceFieldsAsRefList, args) ||> List.iter2 (fun fref arg -> @@ -5519,7 +5593,7 @@ let rec IterateRecursiveFixups g (selfv : Val option) rvs ((access : Expr),set) // NICE: it would be better to do this check in the type checker if not fspec.IsMutable && not (entityRefInThisAssembly g.compilingFslib tcref) then errorR(Error(FSComp.SR.tastRecursiveValuesMayNotBeAssignedToNonMutableField(fspec.rfield_id.idText, tcref.LogicalName),m)); - mkRecdFieldSet g (access,fref,tinst,e,m))) arg ) + mkRecdFieldSetViaExprAddr (access,fref,tinst,e,m))) arg ) | Expr.Val _ | Expr.Lambda _ | Expr.Obj _ @@ -5671,9 +5745,8 @@ let mkFolders (folders : _ ExprFolder) = and mdefF z x = match x with - | TMDefRec(_,binds,mbinds,_) -> + | TMDefRec(_,_,mbinds,_) -> (* REVIEW: also iterate the abstract slot vspecs hidden in the _vslots field in the tycons *) - let z = valBindsF false z binds let z = List.fold mbindF z mbinds z | TMDefLet(bind,_) -> valBindF false z bind @@ -5681,7 +5754,10 @@ let mkFolders (folders : _ ExprFolder) = | TMDefs defs -> List.fold mdefF z defs | TMAbstract x -> mexprF z x - and mbindF z (ModuleOrNamespaceBinding(_, def)) = mdefF z def + and mbindF z x = + match x with + | ModuleOrNamespaceBinding.Binding b -> valBindF false z b + | ModuleOrNamespaceBinding.Module(_, def) -> mdefF z def and implF z x = foldTImplFile mexprF z x @@ -5848,8 +5924,8 @@ let mkRecordExpr g (lnk,tcref,tinst,rfrefs:RecdFieldRef list,args,m) = //------------------------------------------------------------------------- let mkRefCell g m ty e = mkRecordExpr g (RecdExpr,g.refcell_tcr_canon,[ty],[mkRefCellContentsRef g],[e],m) -let mkRefCellGet g m ty e = mkRecdFieldGet g (e,mkRefCellContentsRef g,[ty],m) -let mkRefCellSet g m ty e1 e2 = mkRecdFieldSet g (e1,mkRefCellContentsRef g,[ty],e2,m) +let mkRefCellGet g m ty e = mkRecdFieldGetViaExprAddr (e,mkRefCellContentsRef g,[ty],m) +let mkRefCellSet g m ty e1 e2 = mkRecdFieldSetViaExprAddr (e1,mkRefCellContentsRef g,[ty],e2,m) let mkNil g m ty = mkUnionCaseExpr (g.nil_ucref,[ty],[],m) let mkCons g ty h t = mkUnionCaseExpr (g.cons_ucref,[ty],[h;t],unionRanges h.Range t.Range) @@ -6761,8 +6837,9 @@ let typarEnc _g (gtpsType,gtpsMethod) typar = "``0" // REVIEW: this should be ERROR not WARNING? let rec typeEnc g (gtpsType,gtpsMethod) ty = - if verbose then dprintf "--> typeEnc"; - match (stripTyEqns g ty) with + if verbose then dprintf "--> typeEnc" + let stripped = stripTyEqnsAndMeasureEqns g ty + match stripped with | TType_forall _ -> "Microsoft.FSharp.Core.FSharpTypeFunc" | _ when isArrayTy g ty -> @@ -7152,8 +7229,8 @@ type ActivePatternElemRef with | None -> error(InternalError("not an active pattern name", vref.Range)) | Some apinfo -> let nms = apinfo.ActiveTags - if n < 0 || n >= List.length nms then error(InternalError("name_of_apref: index out of range for active pattern refernce", vref.Range)); - List.nth nms n + if n < 0 || n >= List.length nms then error(InternalError("name_of_apref: index out of range for active pattern reference", vref.Range)); + List.item n nms let mkChoiceTyconRef g m n = match n with @@ -7370,13 +7447,16 @@ and rewriteModuleOrNamespaceDefs env x = List.map (rewriteModuleOrNamespaceDef e and rewriteModuleOrNamespaceDef env x = match x with - | TMDefRec(tycons,binds,mbinds,m) -> TMDefRec(tycons,rewriteBinds env binds,rewriteModuleOrNamespaceBindings env mbinds,m) + | TMDefRec(isRec,tycons,mbinds,m) -> TMDefRec(isRec,tycons,rewriteModuleOrNamespaceBindings env mbinds,m) | TMDefLet(bind,m) -> TMDefLet(rewriteBind env bind,m) | TMDefDo(e,m) -> TMDefDo(RewriteExpr env e,m) | TMDefs defs -> TMDefs(rewriteModuleOrNamespaceDefs env defs) | TMAbstract mexpr -> TMAbstract(rewriteModuleOrNamespaceExpr env mexpr) -and rewriteModuleOrNamespaceBinding env (ModuleOrNamespaceBinding(nm, rhs)) = ModuleOrNamespaceBinding(nm,rewriteModuleOrNamespaceDef env rhs) +and rewriteModuleOrNamespaceBinding env x = + match x with + | ModuleOrNamespaceBinding.Binding bind -> ModuleOrNamespaceBinding.Binding (rewriteBind env bind) + | ModuleOrNamespaceBinding.Module(nm, rhs) -> ModuleOrNamespaceBinding.Module(nm,rewriteModuleOrNamespaceDef env rhs) and rewriteModuleOrNamespaceBindings env mbinds = List.map (rewriteModuleOrNamespaceBinding env) mbinds @@ -7840,8 +7920,8 @@ let DetectAndOptimizeForExpression g option expr = let elemTy = destListTy g enumerableTy let guardExpr = mkNonNullTest g m nextExpr - let headOrDefaultExpr = mkUnionCaseFieldGetUnproven(currentExpr,g.cons_ucref,[elemTy],IndexHead,m) - let tailOrNullExpr = mkUnionCaseFieldGetUnproven(currentExpr,g.cons_ucref,[elemTy],IndexTail,mBody) + let headOrDefaultExpr = mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr,g.cons_ucref,[elemTy],IndexHead,m) + let tailOrNullExpr = mkUnionCaseFieldGetUnprovenViaExprAddr (currentExpr,g.cons_ucref,[elemTy],IndexTail,mBody) let bodyExpr = mkCompGenLet m elemVar headOrDefaultExpr (mkCompGenSequential mBody diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index b63625a222..ad0ce3d440 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -188,14 +188,39 @@ val mkStaticRecdFieldGet : RecdFieldRef * TypeInst val mkStaticRecdFieldSet : RecdFieldRef * TypeInst * Expr * range -> Expr val mkStaticRecdFieldGetAddr : RecdFieldRef * TypeInst * range -> Expr val mkRecdFieldSetViaExprAddr : Expr * RecdFieldRef * TypeInst * Expr * range -> Expr -val mkUnionCaseTagGet : Expr * TyconRef * TypeInst * range -> Expr +val mkUnionCaseTagGetViaExprAddr : Expr * TyconRef * TypeInst * range -> Expr + +/// Make a 'TOp.UnionCaseProof' expression, which proves a union value is over a particular case (used only for ref-unions, not struct-unions) val mkUnionCaseProof : Expr * UnionCaseRef * TypeInst * range -> Expr -val mkUnionCaseFieldGetProven : Expr * UnionCaseRef * TypeInst * int * range -> Expr -val mkUnionCaseFieldGetUnproven : Expr * UnionCaseRef * TypeInst * int * range -> Expr -val mkExnCaseFieldGet : Expr * TyconRef * int * range -> Expr + +/// Build a 'TOp.UnionCaseFieldGet' expression for something we've already determined to be a particular union case. For ref-unions, +/// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. +val mkUnionCaseFieldGetProvenViaExprAddr : Expr * UnionCaseRef * TypeInst * int * range -> Expr + +/// Build a 'TOp.UnionCaseFieldGetAddr' expression for a field of a union when we've already determined the value to be a particular union case. For ref-unions, +/// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. +val mkUnionCaseFieldGetAddrProvenViaExprAddr : Expr * UnionCaseRef * TypeInst * int * range -> Expr + +/// Build a 'TOp.UnionCaseFieldGetAddr' expression for a field of a union when we've already determined the value to be a particular union case. For ref-unions, +/// the input expression has 'TType_ucase', which is an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. +val mkUnionCaseFieldGetUnprovenViaExprAddr : Expr * UnionCaseRef * TypeInst * int * range -> Expr + +/// Build a 'TOp.UnionCaseFieldSet' expression. For ref-unions, the input expression has 'TType_ucase', which is +/// an F# compiler internal "type" corresponding to the union case. For struct-unions, +/// the input should be the address of the expression. val mkUnionCaseFieldSet : Expr * UnionCaseRef * TypeInst * int * Expr * range -> Expr + +/// Like mkUnionCaseFieldGetUnprovenViaExprAddr, but for struct-unions, the input should be a copy of the expression. +val mkUnionCaseFieldGetUnproven : TcGlobals -> Expr * UnionCaseRef * TypeInst * int * range -> Expr + +val mkExnCaseFieldGet : Expr * TyconRef * int * range -> Expr val mkExnCaseFieldSet : Expr * TyconRef * int * Expr * range -> Expr +val mkArrayElemAddress : TcGlobals -> ILReadonly * bool * ILArrayShape * TType * Expr * Expr * range -> Expr + //------------------------------------------------------------------------- // Compiled view of tuples //------------------------------------------------------------------------- @@ -217,6 +242,7 @@ val mkGetTupleItemN : TcGlobals -> range -> int -> ILType -> Expr -> TType -> Ex exception DefensiveCopyWarning of string * range type Mutates = DefinitelyMutates | PossiblyMutates | NeverMutates +val mkExprAddrOfExprAux : TcGlobals -> bool -> bool -> Mutates -> Expr -> ValRef option -> range -> (Val * Expr) option * Expr val mkExprAddrOfExpr : TcGlobals -> bool -> bool -> Mutates -> Expr -> ValRef option -> range -> (Expr -> Expr) * Expr //------------------------------------------------------------------------- @@ -609,7 +635,7 @@ type DisplayEnv = showConstraintTyparAnnotations:bool; abbreviateAdditionalConstraints: bool; showTyparDefaultConstraints: bool - g: TcGlobals + g: TcGlobals contextAccessibility: Accessibility generatedValueLayout:(Val -> layout option) } member SetOpenPaths: string list list -> DisplayEnv @@ -757,7 +783,7 @@ val ComputeHidingInfoAtAssemblyBoundary : ModuleOrNamespaceType -> SignatureHidi val mkRepackageRemapping : SignatureRepackageInfo -> Remap val wrapModuleOrNamespaceExprInNamespace : Ident -> CompilationPath -> ModuleOrNamespaceExpr -> ModuleOrNamespaceExpr -val wrapModuleOrNamespaceTypeInNamespace : Ident -> CompilationPath -> ModuleOrNamespaceType -> ModuleOrNamespaceType +val wrapModuleOrNamespaceTypeInNamespace : Ident -> CompilationPath -> ModuleOrNamespaceType -> ModuleOrNamespaceType * ModuleOrNamespace val wrapModuleOrNamespaceType : Ident -> CompilationPath -> ModuleOrNamespaceType -> ModuleOrNamespace val SigTypeOfImplFile : TypedImplFile -> ModuleOrNamespaceType @@ -811,7 +837,6 @@ val mkValAddr : range -> ValRef -> Expr //------------------------------------------------------------------------- val mkRecdFieldGet : TcGlobals -> Expr * RecdFieldRef * TypeInst * range -> Expr -val mkRecdFieldSet : TcGlobals -> Expr * RecdFieldRef * TypeInst * Expr * range -> Expr //------------------------------------------------------------------------- // Get the targets used in a decision graph (for reporting warnings) @@ -907,7 +932,7 @@ val ExprStats : Expr -> string // Make some common types //------------------------------------------------------------------------- -val mkNativePtrType : TcGlobals -> TType -> TType +val mkNativePtrTy : TcGlobals -> TType -> TType val mkArrayType : TcGlobals -> TType -> TType val isOptionTy : TcGlobals -> TType -> bool val destOptionTy : TcGlobals -> TType -> TType @@ -1023,7 +1048,7 @@ val TypeHasDefaultValue : TcGlobals -> range -> TType -> bool val isAbstractTycon : Tycon -> bool -val isUnionCaseAllocObservable : UnionCaseRef -> bool +val isUnionCaseRefAllocObservable : UnionCaseRef -> bool val isRecdOrUnionOrStructTyconRefAllocObservable : TcGlobals -> TyconRef -> bool val isExnAllocObservable : TyconRef -> bool val isUnionCaseFieldMutable : TcGlobals -> UnionCaseRef -> int -> bool @@ -1256,7 +1281,9 @@ val mkCompilerGeneratedAttr : TcGlobals -> int -> ILAtt //------------------------------------------------------------------------- val isByrefTy : TcGlobals -> TType -> bool +val isNativePtrTy : TcGlobals -> TType -> bool val destByrefTy : TcGlobals -> TType -> TType +val destNativePtrTy : TcGlobals -> TType -> TType val isByrefLikeTyconRef : TcGlobals -> TyconRef -> bool val isByrefLikeTy : TcGlobals -> TType -> bool @@ -1394,3 +1421,5 @@ val rebuildLinearMatchExpr : (SequencePointInfoForBinding * range * DecisionTree val mkCoerceIfNeeded : TcGlobals -> tgtTy: TType -> srcTy: TType -> Expr -> Expr val (|InnerExprPat|) : Expr -> Expr + +val allValsOfModDef : ModuleOrNamespaceExpr -> seq diff --git a/src/fsharp/TastPickle.fs b/src/fsharp/TastPickle.fs index 57d5badbdf..cf37fbfc19 100755 --- a/src/fsharp/TastPickle.fs +++ b/src/fsharp/TastPickle.fs @@ -1671,9 +1671,9 @@ and p_tycon_repr x st = // The leading "p_byte 1" and "p_byte 0" come from the F# 2.0 format, which used an option value at this point. match x with | TRecdRepr fs -> p_byte 1 st; p_byte 0 st; p_rfield_table fs st; false - | TFiniteUnionRepr x -> p_byte 1 st; p_byte 1 st; p_list p_unioncase_spec (Array.toList x.CasesTable.CasesByIndex) st; false + | TUnionRepr x -> p_byte 1 st; p_byte 1 st; p_list p_unioncase_spec (Array.toList x.CasesTable.CasesByIndex) st; false | TAsmRepr ilty -> p_byte 1 st; p_byte 2 st; p_ILType ilty st; false - | TFsObjModelRepr r -> p_byte 1 st; p_byte 3 st; p_tycon_objmodel_data r st; false + | TFSharpObjectRepr r -> p_byte 1 st; p_byte 3 st; p_tycon_objmodel_data r st; false | TMeasureableRepr ty -> p_byte 1 st; p_byte 4 st; p_typ ty st; false | TNoRepr -> p_byte 0 st; false #if EXTENSIONTYPING @@ -1686,7 +1686,7 @@ and p_tycon_repr x st = p_byte 1 st; p_byte 2 st; p_ILType (mkILBoxedType(ILTypeSpec.Create(ExtensionTyping.GetILTypeRefOfProvidedType(info.ProvidedType ,range0),emptyILGenericArgs))) st; true | TProvidedNamespaceExtensionPoint _ -> p_byte 0 st; false #endif - | TILObjModelRepr (_,_,td) -> error (Failure("Unexpected IL type definition"+td.Name)) + | TILObjectRepr (_,_,td) -> error (Failure("Unexpected IL type definition"+td.Name)) and p_tycon_objmodel_data x st = p_tup3 p_tycon_objmodel_kind (p_vrefs "vslots") p_rfield_table @@ -1897,7 +1897,7 @@ and u_tycon_repr st = | h::t -> let nestedTypeDef = tdefs.FindByName h find (tdefs.FindByName h :: acc) t nestedTypeDef.NestedTypes let nestedILTypeDefs,ilTypeDef = find [] iltref.Enclosing iILModule.TypeDefs - TILObjModelRepr(st.iilscope,nestedILTypeDefs,ilTypeDef) + TILObjectRepr(st.iilscope,nestedILTypeDefs,ilTypeDef) with _ -> System.Diagnostics.Debug.Assert(false, sprintf "failed to find IL backing metadata for cross-assembly generated type %s" iltref.FullName) TNoRepr @@ -1905,7 +1905,7 @@ and u_tycon_repr st = TAsmRepr v) | 3 -> let v = u_tycon_objmodel_data st - (fun _flagBit -> TFsObjModelRepr v) + (fun _flagBit -> TFSharpObjectRepr v) | 4 -> let v = u_typ st (fun _flagBit -> TMeasureableRepr v) @@ -2315,6 +2315,7 @@ and p_op x st = | TOp.ValFieldGetAddr (a) -> p_byte 25 st; p_rfref a st | TOp.UInt16s arr -> p_byte 26 st; p_array p_uint16 arr st | TOp.Reraise -> p_byte 27 st + | TOp.UnionCaseFieldGetAddr (a,b) -> p_byte 28 st; p_tup2 p_ucref p_int (a,b) st | TOp.Goto _ | TOp.Label _ | TOp.Return -> failwith "unexpected backend construct in pickled TAST" #endif @@ -2376,6 +2377,9 @@ and u_op st = TOp.ValFieldGetAddr a | 26 -> TOp.UInt16s (u_array u_uint16 st) | 27 -> TOp.Reraise + | 28 -> let a = u_ucref st + let b = u_int st + TOp.UnionCaseFieldGetAddr (a,b) | _ -> ufailwith st "u_op" #if INCLUDE_METADATA_WRITER diff --git a/src/fsharp/TastPickle.fsi b/src/fsharp/TastPickle.fsi index a5bf150061..e8dc0ddbd9 100644 --- a/src/fsharp/TastPickle.fsi +++ b/src/fsharp/TastPickle.fsi @@ -84,7 +84,6 @@ val internal pickleCcuInfo : pickler /// Serialize an arbitrary object using the given pickler val pickleObjWithDanglingCcus : string -> TcGlobals -> scope:CcuThunk -> pickler<'T> -> 'T -> byte[] -#else #endif /// The type of state unpicklers read from diff --git a/src/fsharp/TcGlobals.fs b/src/fsharp/TcGlobals.fs index b9174acb89..6d23531256 100755 --- a/src/fsharp/TcGlobals.fs +++ b/src/fsharp/TcGlobals.fs @@ -6,9 +6,7 @@ /// into the compiler. This lets the compiler perform particular optimizations /// for these types and values, for example emitting optimized calls for /// comparison and hashing functions. -module internal Microsoft.FSharp.Compiler.TcGlobals - -#nowarn "44" // This construct is deprecated. please use List.item +module internal Microsoft.FSharp.Compiler.TcGlobals open Internal.Utilities open Microsoft.FSharp.Compiler @@ -220,6 +218,7 @@ type public TcGlobals = system_Array_typ : TType system_Object_typ : TType system_IDisposable_typ : TType + system_RuntimeHelpers_typ : TType system_Value_typ : TType system_Delegate_typ : TType system_MulticastDelegate_typ : TType @@ -300,6 +299,10 @@ type public TcGlobals = attrib_PreserveSigAttribute : BuiltinAttribInfo option attrib_MethodImplAttribute : BuiltinAttribInfo attrib_ExtensionAttribute : BuiltinAttribInfo + attrib_CallerLineNumberAttribute : BuiltinAttribInfo + attrib_CallerFilePathAttribute : BuiltinAttribInfo + attrib_CallerMemberNameAttribute : BuiltinAttribInfo + tcref_System_Collections_Generic_IList : TyconRef tcref_System_Collections_Generic_IReadOnlyList : TyconRef tcref_System_Collections_Generic_ICollection : TyconRef @@ -618,6 +621,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa let sysLinq = ["System";"Linq"] let sysCollections = ["System";"Collections"] let sysGenerics = ["System";"Collections";"Generic"] + let sysCompilerServices = ["System";"Runtime";"CompilerServices"] let lazy_tcr = mkSysTyconRef sys "Lazy`1" let fslib_IEvent2_tcr = mk_MFControl_tcref fslibCcu "IEvent`2" @@ -668,7 +672,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa (* local helpers to build value infos *) let mkNullableTy ty = TType_app(nullable_tcr, [ty]) let mkByrefTy ty = TType_app(byref_tcr, [ty]) - let mkNativePtrType ty = TType_app(nativeptr_tcr, [ty]) + let mkNativePtrTy ty = TType_app(nativeptr_tcr, [ty]) let mkFunTy d r = TType_fun (d,r) let (-->) d r = mkFunTy d r let mkIteratedFunTy dl r = List.foldBack (-->) dl r @@ -847,7 +851,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa let and_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "&" ,None ,None ,[], mk_rel_sig bool_ty) let addrof_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "~&" ,None ,None ,[vara], ([[varaTy]], mkByrefTy varaTy)) - let addrof2_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "~&&" ,None ,None ,[vara], ([[varaTy]], mkNativePtrType varaTy)) + let addrof2_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "~&&" ,None ,None ,[vara], ([[varaTy]], mkNativePtrTy varaTy)) let and2_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "&&" ,None ,None ,[], mk_rel_sig bool_ty) let or_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, "or" ,None ,Some "Or" ,[], mk_rel_sig bool_ty) let or2_info = makeIntrinsicValRef(fslib_MFIntrinsicOperators_nleref, CompileOpName "||" ,None ,None ,[], mk_rel_sig bool_ty) @@ -995,7 +999,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa { ilg=ilg #if NO_COMPILER_BACKEND #else - ilxPubCloEnv=EraseClosures.new_cenv(ilg) + ilxPubCloEnv=EraseClosures.newIlxPubCloEnv(ilg) #endif knownIntrinsics = knownIntrinsics knownFSharpCoreModules = knownFSharpCoreModules @@ -1101,6 +1105,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa system_Array_typ = mkSysNonGenericTy sys "Array" system_Object_typ = mkSysNonGenericTy sys "Object" system_IDisposable_typ = mkSysNonGenericTy sys "IDisposable" + system_RuntimeHelpers_typ = mkSysNonGenericTy sysCompilerServices "RuntimeHelpers" system_Value_typ = mkSysNonGenericTy sys "ValueType" system_Delegate_typ = mkSysNonGenericTy sys "Delegate" system_MulticastDelegate_typ = mkSysNonGenericTy sys "MulticastDelegate" @@ -1202,7 +1207,10 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa attrib_PreserveSigAttribute = mkSystemRuntimeInteropServicesAttribute "System.Runtime.InteropServices.PreserveSigAttribute" attrib_MethodImplAttribute = mkSystemRuntimeAttrib "System.Runtime.CompilerServices.MethodImplAttribute" attrib_ExtensionAttribute = mkSystemRuntimeAttrib "System.Runtime.CompilerServices.ExtensionAttribute" - + attrib_CallerLineNumberAttribute = mkSystemRuntimeAttrib "System.Runtime.CompilerServices.CallerLineNumberAttribute" + attrib_CallerFilePathAttribute = mkSystemRuntimeAttrib "System.Runtime.CompilerServices.CallerFilePathAttribute" + attrib_CallerMemberNameAttribute = mkSystemRuntimeAttrib "System.Runtime.CompilerServices.CallerMemberNameAttribute" + attrib_ProjectionParameterAttribute = mk_MFCore_attrib "ProjectionParameterAttribute" attrib_CustomOperationAttribute = mk_MFCore_attrib "CustomOperationAttribute" attrib_NonSerializedAttribute = if ilg.traits.NonSerializedAttributeScopeRef.IsSome then Some(mkSystemRuntimeAttrib "System.NonSerializedAttribute") else None @@ -1279,7 +1287,7 @@ let mkTcGlobals (compilingFslib,sysCcu,ilg,fslibCcu,directoryToResolveRelativePa let ty = mkNonGenericTy tcr nm, mkSysTyconRef sys nm, (fun _ -> ty)) let entries2 = - [ "FSharpFunc`2", fastFunc_tcr, (fun tinst -> mkFunTy (List.nth tinst 0) (List.nth tinst 1)) + [ "FSharpFunc`2", fastFunc_tcr, (fun tinst -> mkFunTy (List.item 0 tinst) (List.item 1 tinst)) "Tuple`2", tuple2_tcr, decodeTupleTy "Tuple`3", tuple3_tcr, decodeTupleTy "Tuple`4", tuple4_tcr, decodeTupleTy diff --git a/src/fsharp/TraceCall.fs b/src/fsharp/TraceCall.fs index d2d7b7e4eb..db24974fec 100755 --- a/src/fsharp/TraceCall.fs +++ b/src/fsharp/TraceCall.fs @@ -57,7 +57,7 @@ type internal Trace private() = if String.IsNullOrEmpty(Trace.threadName) then sprintf "(id=%d)" Thread.CurrentThread.ManagedThreadId else sprintf "(id=%d,name=%s)" Thread.CurrentThread.ManagedThreadId Trace.threadName - /// Report the elapsed time since start + /// Report the elapsed time since start. static member private ElapsedTime(start) = let elapsed : TimeSpan = (DateTime.Now-start) sprintf "%A ms" elapsed.TotalMilliseconds @@ -82,7 +82,7 @@ type internal Trace private() = else if not(current.Contains(threadName)) then Trace.threadName <- current^","^threadName | None -> () - /// Base implementation of the call function + /// Base implementation of the call function. static member private CallImpl(loggingClass,functionName,descriptionFunc,threadName:string option) : IDisposable = #if DEBUG if Trace.ShouldLog(loggingClass) then @@ -127,9 +127,9 @@ type internal Trace private() = noopDisposable : IDisposable #endif - /// Log a method as its called. + /// Log a method as it's called. static member Call(loggingClass:string,functionName:string,descriptionFunc:unit->string) = Trace.CallImpl(loggingClass,functionName,descriptionFunc,None) - /// Log a method as its called. Expected always to be called on the same thread which will be named 'threadName' + /// Log a method as it's called. Expected always to be called on the same thread which will be named 'threadName'. static member CallByThreadNamed(loggingClass:string,functionName:string,threadName:string,descriptionFunc:unit->string) = Trace.CallImpl(loggingClass,functionName,descriptionFunc,Some(threadName)) /// Log a message by logging class. static member PrintLine(loggingClass:string, messageFunc:unit->string) = diff --git a/src/fsharp/TypeChecker.fs b/src/fsharp/TypeChecker.fs index ecdfc13d96..f18e62b8e8 100755 --- a/src/fsharp/TypeChecker.fs +++ b/src/fsharp/TypeChecker.fs @@ -4,10 +4,12 @@ /// with generalization at appropriate points. module internal Microsoft.FSharp.Compiler.TypeChecker -#nowarn "44" // This construct is deprecated. please use List.item +open System +open System.Collections.Generic open Internal.Utilities open Internal.Utilities.Collections + open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal @@ -25,18 +27,18 @@ open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Tastops.DebugPrint open Microsoft.FSharp.Compiler.PatternMatchCompilation open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Layout open Microsoft.FSharp.Compiler.Infos -open Microsoft.FSharp.Compiler.Infos.AccessibilityLogic -open Microsoft.FSharp.Compiler.Infos.AttributeChecking +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.AttributeChecking open Microsoft.FSharp.Compiler.TypeRelations +open Microsoft.FSharp.Compiler.MethodCalls +open Microsoft.FSharp.Compiler.MethodOverrides open Microsoft.FSharp.Compiler.ConstraintSolver open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.PrettyNaming -open System -open System.Collections.Generic +open Microsoft.FSharp.Compiler.InfoReader #if EXTENSIONTYPING open Microsoft.FSharp.Compiler.ExtensionTyping @@ -230,7 +232,7 @@ type UngeneralizableItem(computeFreeTyvars : (unit -> FreeTyvars)) = member item.WillNeverHaveFreeTypars = willNeverHaveFreeTypars member item.CachedFreeLocalTycons = cachedFreeLocalTycons member item.CachedFreeTraitSolutions = cachedFreeTraitSolutions - + [] type TcEnv = { /// Name resolution information @@ -257,11 +259,17 @@ type TcEnv = ePath: Ident list eCompPath: CompilationPath eAccessPath: CompilationPath - eAccessRights: AccessorDomain // this field is computed from other fields, but we amortize the cost of computing it. - eInternalsVisibleCompPaths: CompilationPath list // internals under these should be accessible + /// This field is computed from other fields, but we amortize the cost of computing it. + eAccessRights: AccessorDomain + + /// Internals under these should be accessible + eInternalsVisibleCompPaths: CompilationPath list /// Mutable accumulator for the current module type - eModuleOrNamespaceTypeAccumulator: ModuleOrNamespaceType ref + eModuleOrNamespaceTypeAccumulator: ModuleOrNamespaceType ref + + /// Context information for type checker + eContextInfo : ContextInfo /// Here Some tcref indicates we can access protected members in all super types eFamilyType: TyconRef option @@ -269,6 +277,8 @@ type TcEnv = // Information to enforce special restrictions on valid expressions // for .NET constructors. eCtorInfo : CtorInfo option + + eCallerMemberName : string option } member tenv.DisplayEnv = tenv.eNameResEnv.DisplayEnv member tenv.NameEnv = tenv.eNameResEnv @@ -287,9 +297,11 @@ let emptyTcEnv g = eAccessPath=cpath // dummy eAccessRights=computeAccessRights cpath [] None // compute this field eInternalsVisibleCompPaths=[] + eContextInfo=ContextInfo.NoContext eModuleOrNamespaceTypeAccumulator= ref (NewEmptyModuleOrNamespaceType Namespace) eFamilyType=None - eCtorInfo=None } + eCtorInfo=None + eCallerMemberName=None} //------------------------------------------------------------------------- // Helpers related to determining if we're in a constructor and/or a class @@ -393,7 +405,7 @@ let AddLocalVal tcSink scopem v env = CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights) env -let AddLocalExnDefn tcSink scopem (exnc:Tycon) env = +let AddLocalExnDefnAndReport tcSink scopem env (exnc:Tycon) = let env = ModifyNameResEnv (fun nenv -> AddExceptionDeclsToNameEnv BulkAdd.No nenv (mkLocalEntityRef exnc)) env (* Also make VisualStudio think there is an identifier in scope at the range of the identifier text of its binding location *) CallEnvSink tcSink (exnc.Range,env.NameEnv,env.eAccessRights) @@ -401,13 +413,13 @@ let AddLocalExnDefn tcSink scopem (exnc:Tycon) env = env let AddLocalTyconRefs ownDefinition g amap m tcrefs env = - ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.No ownDefinition g amap m false nenv tcrefs) env + env |> ModifyNameResEnv (fun nenv -> AddTyconRefsToNameEnv BulkAdd.No ownDefinition g amap m false nenv tcrefs) let AddLocalTycons g amap m (tycons: Tycon list) env = - AddLocalTyconRefs false g amap m (List.map mkLocalTyconRef tycons) env + env |> AddLocalTyconRefs false g amap m (List.map mkLocalTyconRef tycons) -let AddLocalTyconsAndReport tcSink g amap scopem tycons env = - let env = AddLocalTycons g amap scopem tycons env +let AddLocalTyconsAndReport tcSink scopem g amap m tycons env = + let env = AddLocalTycons g amap m tycons env CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights) env @@ -454,16 +466,20 @@ let AddLocalRootModuleOrNamespace tcSink g amap scopem env (mtyp:ModuleOrNamespa CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights) env -let AddModuleAbbreviation tcSink scopem id modrefs env = +let AddModuleAbbreviationAndReport tcSink scopem id modrefs env = let env = ModifyNameResEnv (fun nenv -> AddModuleAbbrevToNameEnv id nenv modrefs) env CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights) let item = Item.ModuleOrNamespaces(modrefs) CallNameResolutionSink tcSink (id.idRange,env.NameEnv,item,item,ItemOccurence.Use,env.DisplayEnv,env.eAccessRights) env -let AddLocalSubModule tcSink g amap m scopem env (modul:ModuleOrNamespace) = +let AddLocalSubModule g amap m env (modul:ModuleOrNamespace) = let env = ModifyNameResEnv (fun nenv -> AddModuleOrNamespaceRefToNameEnv g amap m false env.eAccessRights nenv (mkLocalModRef modul)) env let env = {env with eUngeneralizableItems = addFreeItemOfModuleTy modul.ModuleOrNamespaceType env.eUngeneralizableItems} + env + +let AddLocalSubModuleAndReport tcSink scopem g amap m env (modul:ModuleOrNamespace) = + let env = AddLocalSubModule g amap m env modul CallEnvSink tcSink (scopem,env.NameEnv,env.eAccessRights) env @@ -548,9 +564,7 @@ let CopyAndFixupTypars m rigid tpsorig = ConstraintSolver.FreshenAndFixupTypars m rigid [] [] tpsorig let UnifyTypes cenv (env: TcEnv) m expectedTy actualTy = - ConstraintSolver.AddCxTypeEqualsType env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g expectedTy) (tryNormalizeMeasureInType cenv.g actualTy) - - + ConstraintSolver.AddCxTypeEqualsType env.eContextInfo env.DisplayEnv cenv.css m (tryNormalizeMeasureInType cenv.g expectedTy) (tryNormalizeMeasureInType cenv.g actualTy) //------------------------------------------------------------------------- // Generate references to the module being generated - used for @@ -558,21 +572,24 @@ let UnifyTypes cenv (env: TcEnv) m expectedTy actualTy = //------------------------------------------------------------------------- let MakeInitialEnv env = - (* Note: here we allocate a new module type accumulator *) + // Note: here we allocate a new module type accumulator let mtypeAcc = ref (NewEmptyModuleOrNamespaceType Namespace) { env with eModuleOrNamespaceTypeAccumulator = mtypeAcc },mtypeAcc -let MakeInnerEnv env nm modKind = +let MakeInnerEnvWithAcc env nm mtypeAcc modKind = let path = env.ePath @ [nm] - (* Note: here we allocate a new module type accumulator *) - let mtypeAcc = ref (NewEmptyModuleOrNamespaceType modKind) let cpath = env.eCompPath.NestedCompPath nm.idText modKind { env with ePath = path eCompPath = cpath eAccessPath = cpath eAccessRights = computeAccessRights cpath env.eInternalsVisibleCompPaths env.eFamilyType // update this computed field eNameResEnv = { env.eNameResEnv with eDisplayEnv = env.DisplayEnv.AddOpenPath (pathOfLid path) } - eModuleOrNamespaceTypeAccumulator = mtypeAcc },mtypeAcc + eModuleOrNamespaceTypeAccumulator = mtypeAcc } + +let MakeInnerEnv env nm modKind = + // Note: here we allocate a new module type accumulator + let mtypeAcc = ref (NewEmptyModuleOrNamespaceType modKind) + MakeInnerEnvWithAcc env nm mtypeAcc modKind,mtypeAcc let MakeInnerEnvForTyconRef _cenv env tcref isExtrinsicExtension = @@ -609,8 +626,10 @@ let LocateEnv ccu env enclosingNamespacePath = env let BuildRootModuleType enclosingNamespacePath (cpath:CompilationPath) mtyp = - (enclosingNamespacePath,(cpath, mtyp)) - ||> List.foldBack (fun id (cpath, mtyp) -> (cpath.ParentCompPath, wrapModuleOrNamespaceTypeInNamespace id cpath.ParentCompPath mtyp)) + (enclosingNamespacePath,(cpath, (mtyp, None))) + ||> List.foldBack (fun id (cpath, (mtyp, mspec)) -> + let a,b = wrapModuleOrNamespaceTypeInNamespace id cpath.ParentCompPath mtyp + cpath.ParentCompPath, (a, match mspec with Some _ -> mspec | None -> Some b)) |> snd let BuildRootModuleExpr enclosingNamespacePath (cpath:CompilationPath) mexpr = @@ -649,14 +668,20 @@ let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath env = /// Optimized unification routine that avoids creating new inference /// variables unnecessarily -let UnifyTupleType cenv denv m ty ps = +let UnifyTupleType contextInfo cenv denv m ty ps = let ptys = if isTupleTy cenv.g ty then let ptys = destTupleTy cenv.g ty if (List.length ps) = (List.length ptys) then ptys else NewInferenceTypes ps else NewInferenceTypes ps - AddCxTypeEqualsType denv cenv.css m ty (TType_tuple ptys) + + let contextInfo = + match contextInfo with + | ContextInfo.RecordFields -> ContextInfo.TupleInRecordFields + | _ -> contextInfo + + AddCxTypeEqualsType contextInfo denv cenv.css m ty (TType_tuple ptys) ptys /// Optimized unification routine that avoids creating new inference @@ -889,7 +914,7 @@ let AdjustValSynInfoInSignature g ty (SynValInfo(argsData,retData) as sigMD) = /// The ValReprInfo for a value, except the number of typars is not yet inferred type PartialValReprInfo = PartialValReprInfo of ArgReprInfo list list * ArgReprInfo -let TranslateTopArgSynInfo isArg m tcAttribute (SynArgInfo(attrs,isOpt,nm)) = +let TranslateTopArgSynInfo isArg m tcAttributes (SynArgInfo(attrs,isOpt,nm)) = // Synthesize an artificial "OptionalArgument" attribute for the parameter let optAttrs = if isOpt then @@ -908,7 +933,7 @@ let TranslateTopArgSynInfo isArg m tcAttribute (SynArgInfo(attrs,isOpt,nm)) = errorR(Error(FSComp.SR.tcReturnValuesCannotHaveNames(),m)) // Call the attribute checking function - let attribs = tcAttribute (optAttrs@attrs) + let attribs = tcAttributes (optAttrs@attrs) ({ Attribs = attribs; Name = nm } : ArgReprInfo) /// Members have an arity inferred from their syntax. This "valSynData" is not quite the same as the arities @@ -917,9 +942,9 @@ let TranslateTopArgSynInfo isArg m tcAttribute (SynArgInfo(attrs,isOpt,nm)) = /// Hence remove all "zeros" from arity and replace them with 1 here. /// Note we currently use the compiled form for choosing unique names, to distinguish overloads because this must match up /// between signature and implementation, and the signature just has "unit". -let TranslateTopValSynInfo m tcAttribute (SynValInfo(argsData,retData)) = - PartialValReprInfo (argsData |> List.mapSquared (TranslateTopArgSynInfo true m (tcAttribute AttributeTargets.Parameter)), - retData |> TranslateTopArgSynInfo false m (tcAttribute AttributeTargets.ReturnValue)) +let TranslateTopValSynInfo m tcAttributes (SynValInfo(argsData,retData)) = + PartialValReprInfo (argsData |> List.mapSquared (TranslateTopArgSynInfo true m (tcAttributes AttributeTargets.Parameter)), + retData |> TranslateTopArgSynInfo false m (tcAttributes AttributeTargets.ReturnValue)) let TranslatePartialArity tps (PartialValReprInfo (argsData,retData)) = ValReprInfo(ValReprInfo.InferTyparInfo tps,argsData,retData) @@ -1026,7 +1051,7 @@ type DeclKind = | IntrinsicExtensionBinding /// Extensions to a type in a different assembly | ExtrinsicExtensionBinding - | ClassLetBinding + | ClassLetBinding of (* isStatic *) bool | ObjectExpressionOverrideBinding | ExpressionBinding @@ -1035,7 +1060,7 @@ type DeclKind = | ModuleOrMemberBinding -> true | IntrinsicExtensionBinding -> true | ExtrinsicExtensionBinding -> true - | ClassLetBinding -> false + | ClassLetBinding _ -> false | ObjectExpressionOverrideBinding -> false | ExpressionBinding -> false @@ -1046,7 +1071,7 @@ type DeclKind = | ModuleOrMemberBinding -> true | IntrinsicExtensionBinding -> true | ExtrinsicExtensionBinding -> true - | ClassLetBinding -> true + | ClassLetBinding _ -> true | ObjectExpressionOverrideBinding -> false | ExpressionBinding -> false @@ -1066,7 +1091,7 @@ type DeclKind = | None -> AttributeTargets.Field ||| AttributeTargets.Method ||| AttributeTargets.Property | IntrinsicExtensionBinding -> AttributeTargets.Method ||| AttributeTargets.Property | ExtrinsicExtensionBinding -> AttributeTargets.Method ||| AttributeTargets.Property - | ClassLetBinding -> AttributeTargets.Field ||| AttributeTargets.Method + | ClassLetBinding _ -> AttributeTargets.Field ||| AttributeTargets.Method | ExpressionBinding -> enum 0 // indicates attributes not allowed on expression 'let' bindings // Note: now always true @@ -1075,7 +1100,7 @@ type DeclKind = | ModuleOrMemberBinding -> true | IntrinsicExtensionBinding -> true | ExtrinsicExtensionBinding -> true - | ClassLetBinding -> true + | ClassLetBinding _ -> true | ObjectExpressionOverrideBinding -> true | ExpressionBinding -> true @@ -1084,7 +1109,7 @@ type DeclKind = | ModuleOrMemberBinding -> true | IntrinsicExtensionBinding -> true | ExtrinsicExtensionBinding -> true - | ClassLetBinding -> true + | ClassLetBinding _ -> true | ObjectExpressionOverrideBinding -> true | ExpressionBinding -> false @@ -1093,7 +1118,7 @@ type DeclKind = | ModuleOrMemberBinding -> OverridesOK | IntrinsicExtensionBinding -> WarnOnOverrides | ExtrinsicExtensionBinding -> ErrorOnOverrides - | ClassLetBinding -> ErrorOnOverrides + | ClassLetBinding _ -> ErrorOnOverrides | ObjectExpressionOverrideBinding -> OverridesOK | ExpressionBinding -> ErrorOnOverrides @@ -1174,7 +1199,6 @@ type TcPatPhase2Input = type CheckedBindingInfo = | CheckedBindingInfo of ValInline * - bool * (* immutable? *) Tast.Attribs * XmlDoc * (TcPatPhase2Input -> PatternMatchCompilation.Pattern) * @@ -1185,10 +1209,11 @@ type CheckedBindingInfo = TType * range * SequencePointInfoForBinding * - bool * (* compiler generated? *) - Const option (* literal value? *) - member x.Expr = let (CheckedBindingInfo(_,_,_,_,_,_,_,expr,_,_,_,_,_,_)) = x in expr - member x.SeqPoint = let (CheckedBindingInfo(_,_,_,_,_,_,_,_,_,_,_,spBind,_,_)) = x in spBind + bool * // compiler generated? + Const option * // literal value? + bool // fixed? + member x.Expr = let (CheckedBindingInfo(_,_,_,_,_,_,expr,_,_,_,_,_,_,_)) = x in expr + member x.SeqPoint = let (CheckedBindingInfo(_,_,_,_,_,_,_,_,_,_,spBind,_,_,_)) = x in spBind //------------------------------------------------------------------------- // Helpers related to type schemes @@ -1845,8 +1870,9 @@ let BuildFieldMap cenv env isPartial ty flds m = if isNil flds then invalidArg "flds" "BuildFieldMap" let frefSets = + let allFields = flds |> List.map (fun ((_,ident),_) -> ident) flds |> List.map (fun (fld,fldExpr) -> - let frefSet = ResolveField cenv.tcSink cenv.nameResolver env.eNameResEnv ad ty fld + let frefSet = ResolveField cenv.tcSink cenv.nameResolver env.eNameResEnv ad ty fld allFields fld,frefSet, fldExpr) let relevantTypeSets = frefSets |> List.map (fun (_,frefSet,_) -> frefSet |> List.choose (fun (FieldResolution(rfref,_)) -> Some rfref.TyconRef)) @@ -1934,7 +1960,7 @@ let TcUnionCaseOrExnField cenv (env: TcEnv) ty1 m c n funcs = | _ -> error(Error(FSComp.SR.tcUnknownUnion(),m)) if n >= List.length argtys then error (UnionCaseWrongNumberOfArgs(env.DisplayEnv,List.length argtys,n,m)) - let ty2 = List.nth argtys n + let ty2 = List.item n argtys mkf,ty2 //------------------------------------------------------------------------- @@ -2014,7 +2040,7 @@ module GeneralizationHelpers = | Expr.Op(op,_,args,_) -> match op with | TOp.Tuple -> true - | TOp.UnionCase uc -> not (isUnionCaseAllocObservable uc) + | TOp.UnionCase uc -> not (isUnionCaseRefAllocObservable uc) | TOp.Recd(ctorInfo,tcref) -> match ctorInfo with | RecdExpr -> not (isRecdOrUnionOrStructTyconRefAllocObservable g tcref) @@ -2102,9 +2128,9 @@ module GeneralizationHelpers = match tp.Constraints |> List.partition (function (TyparConstraint.CoercesTo _) -> true | _ -> false) with | [TyparConstraint.CoercesTo(cxty,_)], others -> // Throw away null constraints if they are implied - match others |> List.filter (function (TyparConstraint.SupportsNull(_)) -> not (TypeSatisfiesNullConstraint cenv.g m cxty) | _ -> true) with - | [] -> Some cxty - | _ -> None + if others |> List.exists (function (TyparConstraint.SupportsNull(_)) -> not (TypeSatisfiesNullConstraint cenv.g m cxty) | _ -> true) + then None + else Some cxty | _ -> None @@ -2143,7 +2169,7 @@ module GeneralizationHelpers = let CanonicalizePartialInferenceProblem (cenv,denv,m) tps = // Canonicalize constraints prior to generalization - let csenv = (MakeConstraintSolverEnv cenv.css m denv) + let csenv = (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) TryD (fun () -> ConstraintSolver.CanonicalizeRelevantMemberConstraints csenv 0 NoTrace tps) (fun res -> ErrorD (ErrorFromAddingConstraint(denv,res,m))) |> RaiseOperationResult @@ -2151,7 +2177,7 @@ module GeneralizationHelpers = let ComputeAndGeneralizeGenericTypars (cenv, denv:DisplayEnv, m, - immut, + canGeneralize, freeInEnv:FreeTypars, canInferTypars, genConstrainedTyparFlag, @@ -2164,7 +2190,7 @@ module GeneralizationHelpers = let allDeclaredTypars = NormalizeDeclaredTyparsForEquiRecursiveInference cenv.g allDeclaredTypars let typarsToAttemptToGeneralize = - if immut && (match exprOpt with None -> true | Some e -> IsGeneralizableValue cenv.g e) + if canGeneralize && (match exprOpt with None -> true | Some e -> IsGeneralizableValue cenv.g e) then (ListSet.unionFavourLeft typarEq allDeclaredTypars maxInferredTypars) else allDeclaredTypars @@ -2190,7 +2216,7 @@ module GeneralizationHelpers = generalizedTypars |> List.iter (SetTyparRigid cenv.g denv m) // Generalization removes constraints related to generalized type variables - let csenv = MakeConstraintSolverEnv cenv.css m denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv EliminateConstraintsForGeneralizedTypars csenv NoTrace generalizedTypars generalizedTypars @@ -2810,7 +2836,7 @@ let MakeApplicableExprWithFlex cenv (env: TcEnv) expr = then actualType else let flexibleType = NewInferenceType () - AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace actualType flexibleType; + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace actualType flexibleType; flexibleType) // Create a coercion to represent the expansion of the application @@ -2819,7 +2845,7 @@ let MakeApplicableExprWithFlex cenv (env: TcEnv) expr = /// Checks, warnings and constraint assertions for downcasts -let TcRuntimeTypeTest isCast cenv denv m tgty srcTy = +let TcRuntimeTypeTest isCast isOperator cenv denv m tgty srcTy = if TypeDefinitelySubsumesTypeNoCoercion 0 cenv.g cenv.amap m tgty srcTy then warning(TypeTestUnnecessary(m)) @@ -2827,12 +2853,13 @@ let TcRuntimeTypeTest isCast cenv denv m tgty srcTy = error(IndeterminateRuntimeCoercion(denv,srcTy,tgty,m)) if isSealedTy cenv.g srcTy then - error(RuntimeCoercionSourceSealed(denv,srcTy,m)) + error(RuntimeCoercionSourceSealed(denv,srcTy,m)) - if isSealedTy cenv.g tgty || - isTyparTy cenv.g tgty || - not (isInterfaceTy cenv.g srcTy) then - AddCxTypeMustSubsumeType denv cenv.css m NoTrace srcTy tgty + if isSealedTy cenv.g tgty || isTyparTy cenv.g tgty || not (isInterfaceTy cenv.g srcTy) then + if isCast then + AddCxTypeMustSubsumeType (ContextInfo.RuntimeTypeTest isOperator) denv cenv.css m NoTrace srcTy tgty + else + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace srcTy tgty if isErasedType cenv.g tgty then if isCast then @@ -2856,7 +2883,7 @@ let TcStaticUpcast cenv denv m tgty srcTy = if typeEquiv cenv.g srcTy tgty then warning(UpcastUnnecessary(m)) - AddCxTypeMustSubsumeType denv cenv.css m NoTrace tgty srcTy + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css m NoTrace tgty srcTy @@ -2867,7 +2894,7 @@ let BuildPossiblyConditionalMethodCall cenv env isMutable m isProp minfo valUseF let conditionalCallDefineOpt = TryFindMethInfoStringAttribute cenv.g m cenv.g.attrib_ConditionalAttribute minfo match conditionalCallDefineOpt with - | Some(d) when not (List.mem d cenv.conditionalDefines) -> + | Some(d) when not (List.contains d cenv.conditionalDefines) -> // Methods marked with 'Conditional' must return 'unit' UnifyTypes cenv env m cenv.g.unit_ty (minfo.GetFSharpReturnTy(cenv.amap, m, minst)) @@ -2921,6 +2948,17 @@ let BuildDisposableCleanup cenv env m (v:Val) = let inpe = mkCoerceExpr(exprForVal v.Range v,cenv.g.obj_ty,m,v.Type) mkIsInstConditional cenv.g m cenv.g.system_IDisposable_typ inpe disposeObjVar disposeExpr (mkUnit cenv.g m) +/// Build call to get_OffsetToStringData as part of 'fixed' +let BuildOffsetToStringData cenv env m = + let ad = env.eAccessRights + let offsetToStringDataMethod = + match TryFindIntrinsicOrExtensionMethInfo cenv env m ad "get_OffsetToStringData" cenv.g.system_RuntimeHelpers_typ with + | [x] -> x + | _ -> error(Error(FSComp.SR.tcCouldNotFindOffsetToStringData(),m)) + + let offsetExpr,_ = BuildPossiblyConditionalMethodCall cenv env NeverMutates m false offsetToStringDataMethod NormalValUse [] [] [] + offsetExpr + let BuildILFieldGet g amap m objExpr (finfo:ILFieldInfo) = let fref = finfo.ILFieldRef let isValueType = finfo.IsValueType @@ -2976,7 +3014,8 @@ let BuildRecdFieldSet g m objExpr (rfinfo:RecdFieldInfo) argExpr = let tgty = rfinfo.EnclosingType let valu = isStructTy g tgty let objExpr = if valu then objExpr else mkCoerceExpr(objExpr,tgty,m,tyOfExpr g objExpr) - mkRecdFieldSet g (objExpr,rfinfo.RecdFieldRef,rfinfo.TypeInst,argExpr,m) + let wrap,objExpr = mkExprAddrOfExpr g valu false DefinitelyMutates objExpr None m + wrap (mkRecdFieldSetViaExprAddr (objExpr,rfinfo.RecdFieldRef,rfinfo.TypeInst,argExpr,m) ) //------------------------------------------------------------------------- @@ -3261,7 +3300,7 @@ let mkSeqCollect cenv env m enumElemTy genTy lam enumExpr = mkCallSeqCollect cenv.g m enumElemTy genResultTy lam enumExpr let mkSeqUsing cenv (env: TcEnv) m resourceTy genTy resourceExpr lam = - AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace cenv.g.system_IDisposable_typ resourceTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace cenv.g.system_IDisposable_typ resourceTy let genResultTy = NewInferenceType () UnifyTypes cenv env m genTy (mkSeqTy cenv.g genResultTy) mkCallSeqUsing cenv.g m resourceTy genResultTy resourceExpr lam @@ -3377,6 +3416,131 @@ let (|SimpleSemicolonSequence|_|) acceptDeprecated c = else None +//------------------------------------------------------------------------- +// Mutually recursive shapes +//------------------------------------------------------------------------- + +/// Represents the shape of a mutually recursive group of declarations including nested modules +[] +type MutRecShape<'TypeData, 'LetsData, 'ModuleData, 'ModuleAbbrevData, 'OpenData> = + | Tycon of 'TypeData + | Lets of 'LetsData + | Module of 'ModuleData * MutRecShapes<'TypeData, 'LetsData, 'ModuleData, 'ModuleAbbrevData, 'OpenData> + | ModuleAbbrev of 'ModuleAbbrevData + | Open of 'OpenData + +and MutRecShapes<'TypeData, 'LetsData, 'ModuleData, 'ModuleAbbrevData, 'OpenData> = MutRecShape<'TypeData, 'LetsData, 'ModuleData, 'ModuleAbbrevData, 'OpenData> list + +module MutRecShapes = + let rec map f1 f2 f3 x = + x |> List.map (function + | MutRecShape.Open a -> MutRecShape.Open a + | MutRecShape.ModuleAbbrev b -> MutRecShape.ModuleAbbrev b + | MutRecShape.Tycon a -> MutRecShape.Tycon (f1 a) + | MutRecShape.Lets b -> MutRecShape.Lets (f2 b) + | MutRecShape.Module (c,d) -> MutRecShape.Module (f3 c, map f1 f2 f3 d)) + + + let mapTycons f1 xs = map f1 id id xs + let mapTyconsAndLets f1 f2 xs = map f1 f2 id xs + let mapLets f2 xs = map id f2 id xs + let mapModules f1 xs = map id id f1 xs + + let rec mapWithEnv fTycon fLets (env: 'Env) x = + x |> List.map (function + | MutRecShape.Open a -> MutRecShape.Open a + | MutRecShape.ModuleAbbrev a -> MutRecShape.ModuleAbbrev a + | MutRecShape.Tycon a -> MutRecShape.Tycon (fTycon env a) + | MutRecShape.Lets b -> MutRecShape.Lets (fLets env b) + | MutRecShape.Module ((c, env2),d) -> MutRecShape.Module ((c,env2), mapWithEnv fTycon fLets env2 d)) + + let mapTyconsWithEnv f1 env xs = mapWithEnv f1 (fun _env x -> x) env xs + + let rec mapWithParent parent f1 f2 f3 xs = + xs |> List.map (function + | MutRecShape.Open a -> MutRecShape.Open a + | MutRecShape.ModuleAbbrev a -> MutRecShape.ModuleAbbrev a + | MutRecShape.Tycon a -> MutRecShape.Tycon (f2 parent a) + | MutRecShape.Lets b -> MutRecShape.Lets (f3 parent b) + | MutRecShape.Module (c,d) -> + let c2, parent2 = f1 parent c + MutRecShape.Module (c2, mapWithParent parent2 f1 f2 f3 d)) + + let rec computeEnvs f1 f2 (env: 'Env) xs = + let env = f2 env xs + env, + xs |> List.map (function + | MutRecShape.Open a -> MutRecShape.Open a + | MutRecShape.ModuleAbbrev a -> MutRecShape.ModuleAbbrev a + | MutRecShape.Tycon a -> MutRecShape.Tycon a + | MutRecShape.Lets b -> MutRecShape.Lets b + | MutRecShape.Module (c,ds) -> + let env2 = f1 env c + let env3, ds2 = computeEnvs f1 f2 env2 ds + MutRecShape.Module ((c,env3), ds2)) + + let rec extendEnvs f1 (env: 'Env) xs = + let env = f1 env xs + env, + xs |> List.map (function + | MutRecShape.Module ((c,env),ds) -> + let env2, ds2 = extendEnvs f1 env ds + MutRecShape.Module ((c,env2), ds2) + | x -> x) + + let dropEnvs xs = xs |> mapModules fst + + let rec expandTyconsWithEnv f1 env xs = + let preBinds, postBinds = + xs |> List.map (fun elem -> + match elem with + | MutRecShape.Tycon a -> f1 env a + | _ -> [], []) + |> List.unzip + [MutRecShape.Lets (List.concat preBinds)] @ + (xs |> List.map (fun elem -> + match elem with + | MutRecShape.Module ((c,env2),d) -> MutRecShape.Module ((c,env2), expandTyconsWithEnv f1 env2 d) + | _ -> elem)) @ + [MutRecShape.Lets (List.concat postBinds)] + + let rec mapFoldWithEnv f1 z env xs = + (z,xs) ||> List.mapFold (fun z x -> + match x with + | MutRecShape.Module ((c,env2),ds) -> let ds2,z = mapFoldWithEnv f1 z env2 ds in MutRecShape.Module ((c, env2), ds2),z + | _ -> let x2,z = f1 z env x in x2, z) + + + let rec collectTycons x = + x |> List.collect (function + | MutRecShape.Tycon a -> [a] + | MutRecShape.Module (_,d) -> collectTycons d + | _ -> []) + + let topTycons x = + x |> List.choose (function MutRecShape.Tycon a -> Some a | _ -> None) + + let rec iter f1 f2 f3 f4 f5 x = + x |> List.iter (function + | MutRecShape.Tycon a -> f1 a + | MutRecShape.Lets b -> f2 b + | MutRecShape.Module (c,d) -> f3 c; iter f1 f2 f3 f4 f5 d + | MutRecShape.Open a -> f4 a + | MutRecShape.ModuleAbbrev a -> f5 a) + + let iterTycons f1 x = iter f1 ignore ignore ignore ignore x + let iterTyconsAndLets f1 f2 x = iter f1 f2 ignore ignore ignore x + let iterModules f1 x = iter ignore ignore f1 ignore ignore x + + let rec iterWithEnv f1 f2 f3 f4 env x = + x |> List.iter (function + | MutRecShape.Tycon a -> f1 env a + | MutRecShape.Lets b -> f2 env b + | MutRecShape.Module ((_,env),d) -> iterWithEnv f1 f2 f3 f4 env d + | MutRecShape.Open a -> f3 env a + | MutRecShape.ModuleAbbrev a -> f4 env a) + + let iterTyconsWithEnv f1 env xs = iterWithEnv f1 (fun _env _x -> ()) (fun _env _x -> ()) (fun _env _x -> ()) env xs //------------------------------------------------------------------------- // Post-transform initialization graphs using the 'lazy' interpretation. @@ -3395,12 +3559,20 @@ type PreInitializationGraphEliminationBinding = Binding: Tast.Binding } -let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithoutLaziness : PreInitializationGraphEliminationBinding list) bindsm = - // BEGIN INITIALIZATION GRAPHS - // Check for safety and determine if we need to insert lazy thunks - let fixupsl = fixupsAndBindingsWithoutLaziness |> List.map (fun b -> b.FixupPoints) - let bindsWithoutLaziness = fixupsAndBindingsWithoutLaziness |> List.map (fun b -> b.Binding) - let rvs = bindsWithoutLaziness |> List.map (fun (TBind(v,_,_)) -> mkLocalValRef v) +/// Check for safety and determine if we need to insert lazy thunks +let EliminateInitializationGraphs + (getTyconBinds: 'TyconDataIn -> PreInitializationGraphEliminationBinding list) + (morphTyconBinds: (PreInitializationGraphEliminationBinding list -> Binding list) -> 'TyconDataIn -> 'TyconDataOut) + (getLetBinds: 'LetDataIn list -> PreInitializationGraphEliminationBinding list) + (morphLetBinds: (PreInitializationGraphEliminationBinding list -> Binding list) -> 'LetDataIn list -> Binding list) + g mustHaveArity denv + (fixupsAndBindingsWithoutLaziness : MutRecShape<_,_,_,_,_> list) bindsm = + + let recursiveVals = + let hash = ValHash.Create() + let add (pgrbind: PreInitializationGraphEliminationBinding) = let c = pgrbind.Binding.Var in hash.Add(c,c) + fixupsAndBindingsWithoutLaziness |> MutRecShapes.iterTyconsAndLets (getTyconBinds >> List.iter add) (getLetBinds >> List.iter add) + hash // The output of the analysis let outOfOrder = ref false @@ -3414,7 +3586,8 @@ let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithout | Expr.TyChoose(_,b,_) -> stripChooseAndExpr b | e -> e - let check availIfInOrder boundv expr = + let availIfInOrder = ValHash<_>.Create() + let check boundv expr = let strict = function | MaybeLazy -> MaybeLazy | DefinitelyLazy -> DefinitelyLazy @@ -3454,7 +3627,7 @@ let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithout List.iter (snd >> List.iter (fun (TObjExprMethod(_,_,_,_,e,_)) -> CheckExpr (lzy (strict st)) e)) extraImpls // Expressions where fixups may be needed - | Expr.Val (v,_,m) -> CheckValSpec st v m + | Expr.Val (v,_,m) -> CheckValRef st v m // Expressions where subparts may be fixable | Expr.Op((TOp.Tuple | TOp.UnionCase _ | TOp.Recd _),_,args,_) -> @@ -3494,28 +3667,28 @@ let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithout and CheckExprOp st op m = match op with - | TOp.LValueOp (_,lvr) -> CheckValSpec (strict st) lvr m + | TOp.LValueOp (_,lvr) -> CheckValRef (strict st) lvr m | _ -> () - and CheckValSpec st v m = + and CheckValRef st (v: ValRef) m = match st with | MaybeLazy -> - if ListSet.contains g.valRefEq v rvs then + if recursiveVals.TryFind v.Deref |> Option.isSome then warning (RecursiveUseCheckedAtRuntime (denv,v,m)) if not !reportedEager then (warning (LetRecCheckedAtRuntime m); reportedEager := true) runtimeChecks := true | Top | DefinitelyStrict -> - if ListSet.contains g.valRefEq v rvs then - if not (ListSet.contains g.valRefEq v availIfInOrder) then + if recursiveVals.TryFind v.Deref |> Option.isSome then + if availIfInOrder.TryFind v.Deref |> Option.isNone then warning (LetRecEvaluatedOutOfOrder (denv,boundv,v,m)) outOfOrder := true if not !reportedEager then (warning (LetRecCheckedAtRuntime m); reportedEager := true) definiteDependencies := (boundv,v) :: !definiteDependencies | InnerTop -> - if ListSet.contains g.valRefEq v rvs then + if recursiveVals.TryFind v.Deref |> Option.isSome then directRecursiveData := true | DefinitelyLazy -> () and checkDelayed st b = @@ -3528,13 +3701,16 @@ let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithout // Check the bindings one by one, each w.r.t. the previously available set of binding - ([], bindsWithoutLaziness) ||> List.fold (fun availIfInOrder (TBind(v,e,_)) -> - check availIfInOrder (mkLocalValRef v) e - (mkLocalValRef v::availIfInOrder)) - |> ignore + begin + let checkBind (pgrbind: PreInitializationGraphEliminationBinding) = + let (TBind(v,e,_)) = pgrbind.Binding + check (mkLocalValRef v) e + availIfInOrder.Add(v, 1) + fixupsAndBindingsWithoutLaziness |> MutRecShapes.iterTyconsAndLets (getTyconBinds >> List.iter checkBind) (getLetBinds >> List.iter checkBind) + end // ddg = definiteDependencyGraph - let ddgNodes = bindsWithoutLaziness |> List.map (fun (TBind(v,_,_)) -> mkLocalValRef v) + let ddgNodes = recursiveVals.Values |> Seq.toList |> List.map mkLocalValRef let ddg = Graph((fun v -> v.Stamp), ddgNodes, !definiteDependencies ) ddg.IterateCycles (fun path -> error (LetRecUnsound (denv,path,path.Head.Range))) @@ -3542,38 +3718,41 @@ let EliminateInitializationGraphs g mustHaveArity denv (fixupsAndBindingsWithout if !directRecursiveData && requiresLazyBindings then error(Error(FSComp.SR.tcInvalidMixtureOfRecursiveForms(),bindsm)) - let bindsBefore, bindsAfter = - if requiresLazyBindings then - let bindsBeforeL, bindsAfterL = - - (fixupsl, bindsWithoutLaziness) - ||> List.map2 (fun (RecursiveUseFixupPoints(fixupPoints)) (TBind(v,e,seqPtOpt)) -> - match stripChooseAndExpr e with - | Expr.Lambda _ | Expr.TyLambda _ -> - [mkInvisibleBind v e],[] - | _ -> - let ty = v.Type - let m = v.Range - let vty = (mkLazyTy g ty) + if requiresLazyBindings then + let morphBinding (pgrbind: PreInitializationGraphEliminationBinding) = + let (RecursiveUseFixupPoints(fixupPoints)) = pgrbind.FixupPoints + let (TBind(v,e,seqPtOpt)) = pgrbind.Binding + match stripChooseAndExpr e with + | Expr.Lambda _ | Expr.TyLambda _ -> + [],[mkInvisibleBind v e] + | _ -> + let ty = v.Type + let m = v.Range + let vty = (mkLazyTy g ty) - let fty = (g.unit_ty --> ty) - let flazy,felazy = Tastops.mkCompGenLocal m v.LogicalName fty - let frhs = mkUnitDelayLambda g m e - if mustHaveArity then flazy.SetValReprInfo (Some(InferArityOfExpr g fty [] [] frhs)) + let fty = (g.unit_ty --> ty) + let flazy,felazy = Tastops.mkCompGenLocal m v.LogicalName fty + let frhs = mkUnitDelayLambda g m e + if mustHaveArity then flazy.SetValReprInfo (Some(InferArityOfExpr g fty [] [] frhs)) - let vlazy,velazy = Tastops.mkCompGenLocal m v.LogicalName vty - let vrhs = (mkLazyDelayed g m ty felazy) + let vlazy,velazy = Tastops.mkCompGenLocal m v.LogicalName vty + let vrhs = (mkLazyDelayed g m ty felazy) - if mustHaveArity then vlazy.SetValReprInfo (Some(InferArityOfExpr g vty [] [] vrhs)) - fixupPoints |> List.iter (fun (fp,_) -> fp := mkLazyForce g (!fp).Range ty velazy) + if mustHaveArity then vlazy.SetValReprInfo (Some(InferArityOfExpr g vty [] [] vrhs)) + fixupPoints |> List.iter (fun (fp,_) -> fp := mkLazyForce g (!fp).Range ty velazy) - [mkInvisibleBind flazy frhs; mkInvisibleBind vlazy vrhs], - [mkBind seqPtOpt v (mkLazyForce g m ty velazy)]) - |> List.unzip - List.concat bindsBeforeL, List.concat bindsAfterL - else - bindsWithoutLaziness,[] - bindsBefore @ bindsAfter + [mkInvisibleBind flazy frhs; mkInvisibleBind vlazy vrhs], + [mkBind seqPtOpt v (mkLazyForce g m ty velazy)] + + let newTopBinds = ResizeArray<_>() + let morphBindings pgrbinds = pgrbinds |> List.map morphBinding |> List.unzip |> (fun (a,b) -> newTopBinds.Add (List.concat a); List.concat b) + + let res = fixupsAndBindingsWithoutLaziness |> MutRecShapes.map (morphTyconBinds morphBindings) (morphLetBinds morphBindings) id + if newTopBinds.Count = 0 then res + else MutRecShape.Lets (List.concat newTopBinds) :: res + else + let noMorph (pgrbinds : PreInitializationGraphEliminationBinding list) = pgrbinds |> List.map (fun pgrbind -> pgrbind.Binding) + fixupsAndBindingsWithoutLaziness |> MutRecShapes.map (morphTyconBinds noMorph) (morphLetBinds noMorph) id //------------------------------------------------------------------------- // Check the shape of an object constructor and rewrite calls @@ -3610,7 +3789,7 @@ let CheckAndRewriteObjectCtor g env (ctorLambaExpr:Expr) = let thisTy = tyOfExpr g recdExpr let thisExpr = mkGetArg0 m thisTy let thisTyInst = argsOfAppTy g thisTy - let setExpr = mkRecdFieldSet g (thisExpr, rfref, thisTyInst, mkOne g m, m) + let setExpr = mkRecdFieldSetViaExprAddr (thisExpr, rfref, thisTyInst, mkOne g m, m) Expr.Sequential(recdExpr,setExpr,ThenDoSeq,SuppressSequencePointOnExprOfSequential,m) recdExpr @@ -3780,17 +3959,31 @@ type NormalizedRecBindingDefn = NormalizedRecBindingDefn of ContainerInfo * NewS type TyconBindingDefn = TyconBindingDefn of ContainerInfo * NewSlotsOK * DeclKind * SynMemberDefn * range -type TyconBindingDefns = TyconBindingDefns of TyconRef * Typars * DeclKind * TyconBindingDefn list - -type TyconMemberData = TyconMemberData of DeclKind * TyconRef * Val option * SafeInitData * Typars * SynMemberDefn list * range * NewSlotsOK - type ValSpecResult = ValSpecResult of ParentRef * ValMemberInfoTransient option * Ident * Typars * Typars * TType * PartialValReprInfo * DeclKind //------------------------------------------------------------------------- // Additional data structures used by checking recursive bindings //------------------------------------------------------------------------- -type RecursiveBindingDefnInfo = RecBindingDefn of ContainerInfo * NewSlotsOK * DeclKind * SynBinding + +type RecDefnBindingInfo = RecDefnBindingInfo of ContainerInfo * NewSlotsOK * DeclKind * SynBinding + +type MutRecDataForOpen = MutRecDataForOpen of LongIdent * range +type MutRecDataForModuleAbbrev = MutRecDataForModuleAbbrev of Ident * LongIdent * range + +type MutRecSigsInitialData = MutRecShape list +type MutRecDefnsInitialData = MutRecShape list + +type MutRecDefnsPhase1DataForTycon = MutRecDefnsPhase1DataForTycon of SynComponentInfo * SynTypeDefnSimpleRepr * (SynType * range) list * preEstablishedHasDefaultCtor: bool * hasSelfReferentialCtor: bool * isAtOriginalTyconDefn: bool +type MutRecDefnsPhase1Data = MutRecShape list + +type MutRecDefnsPhase2DataForTycon = MutRecDefnsPhase2DataForTycon of Tycon option * ParentRef * DeclKind * TyconRef * Val option * SafeInitData * Typars * SynMemberDefn list * range * NewSlotsOK * fixupFinalAttribs: (unit -> unit) +type MutRecDefnsPhase2DataForModule = MutRecDefnsPhase2DataForModule of ModuleOrNamespaceType ref * ModuleOrNamespace +type MutRecDefnsPhase2Data = MutRecShape list + +type MutRecDefnsPhase2InfoForTycon = MutRecDefnsPhase2InfoForTycon of Tycon option * TyconRef * Typars * DeclKind * TyconBindingDefn list * fixupFinalAttrs: (unit -> unit) +type MutRecDefnsPhase2Info = MutRecShape list + /// RecursiveBindingInfo - flows through initial steps of TcLetrec type RecursiveBindingInfo = @@ -3876,7 +4069,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = | WhereTyparDefaultsToType(tp,ty,m) -> let ty',tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty let tp',tpenv = TcTypar cenv env newOk tpenv tp - let csenv = (MakeConstraintSolverEnv cenv.css m env.DisplayEnv) + let csenv = (MakeConstraintSolverEnv env.eContextInfo cenv.css m env.DisplayEnv) AddConstraint csenv 0 m NoTrace tp' (TyparConstraint.DefaultsTo(ridx,ty',m)) |> CommitOperationResult tpenv @@ -3885,7 +4078,7 @@ let rec TcTyparConstraint ridx cenv newOk checkCxs occ (env: TcEnv) tpenv c = let tp',tpenv = TcTypar cenv env newOk tpenv tp if (newOk = NoNewTypars) && isSealedTy cenv.g ty' then errorR(Error(FSComp.SR.tcInvalidConstraintTypeSealed(),m)) - AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp') + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp') tpenv | WhereTyparSupportsNull(tp,m) -> checkSimpleConstraint tp m AddCxTypeMustSupportNull @@ -4135,7 +4328,7 @@ and TcTyparOrMeasurePar optKind cenv (env:TcEnv) newOk tpenv (Typar(id,_,_) as t match TryFindUnscopedTypar key tpenv with | Some res -> checkRes res | None -> - if newOk = NoNewTypars then error (UndefinedName(0,FSComp.SR.undefinedNameTypeParameter,id,[""])) + if newOk = NoNewTypars then error (UndefinedName(0,FSComp.SR.undefinedNameTypeParameter,id,NoPredictions)) // OK, this is an implicit declaration of a type parameter // The kind defaults to Type let tp' = NewTypar ((match optKind with None -> TyparKind.Type | Some kind -> kind), TyparRigidity.WarnIfNotRigid,tp,false,TyparDynamicReq.Yes,[],false,false) @@ -4263,7 +4456,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv:SyntacticUnscoped | SynType.HashConstraint(ty,m) -> let tp = TcAnonTypeOrMeasure (Some TyparKind.Type) cenv TyparRigidity.WarnIfNotRigid TyparDynamicReq.Yes newOk m let ty',tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv ty - AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp) + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace ty' (mkTyparTy tp) tp.AsType, tpenv | SynType.StaticConstant (c, m) -> @@ -4449,9 +4642,9 @@ and CrackStaticConstantArgs cenv env tpenv (staticParameters: Tainted (Some id, v) | v -> (None, v)) let unnamedArgs = args |> Seq.takeWhile (fst >> isNone) |> Seq.toArray |> Array.map snd - let otherArgs = args |> Seq.skipWhile (fst >> isNone) |> Seq.toList - let namedArgs = otherArgs |> Seq.takeWhile (fst >> isSome) |> Seq.toList |> List.map (map1Of2 Option.get) - let otherArgs = otherArgs |> Seq.skipWhile (fst >> isSome) |> Seq.toList + let otherArgs = args |> List.skipWhile (fst >> isNone) + let namedArgs = otherArgs |> List.takeWhile (fst >> isSome) |> List.map (map1Of2 Option.get) + let otherArgs = otherArgs |> List.skipWhile (fst >> isSome) if not otherArgs.IsEmpty then error (Error(FSComp.SR.etBadUnnamedStaticArgs(),m)) for (n,_) in namedArgs do @@ -4696,7 +4889,7 @@ and TcSimplePats cenv optArgsOK checkCxs ty env (tpenv,names,takenNames:Set<_>) [v],(tpenv,names,takenNames) | SynSimplePats.SimplePats (ps,m) -> - let ptys = UnifyTupleType cenv env.DisplayEnv m ty ps + let ptys = UnifyTupleType env.eContextInfo cenv env.DisplayEnv m ty ps let ps',(tpenv,names,takenNames) = List.mapFold (fun tpenv (ty,e) -> TcSimplePat optArgsOK checkCxs cenv ty env tpenv e) (tpenv,names,takenNames) (List.zip ptys ps) ps',(tpenv,names,takenNames) @@ -4783,7 +4976,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat | SynPat.Named (SynPat.IsInst(cty,m),_,_,_,_) -> let srcTy = ty let tgty,tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurence.UseInType env tpenv cty - TcRuntimeTypeTest (*isCast*)false cenv env.DisplayEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv m tgty srcTy match pat with | SynPat.IsInst(_,m) -> (fun _ -> TPat_isinst (srcTy,tgty,None,m)),(tpenv,names,takenNames) @@ -4847,7 +5040,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat match args with | SynConstructorArgs.Pats [] | SynConstructorArgs.NamePatPairs ([], _)-> TcPat warnOnUpperForId cenv env topValInfo vFlags (tpenv,names,takenNames) ty (mkSynPatVar vis id) - | _ -> error (UndefinedName(0,FSComp.SR.undefinedNamePatternDiscriminator,id,[])) + | _ -> error (UndefinedName(0,FSComp.SR.undefinedNamePatternDiscriminator,id,NoPredictions)) | Item.ActivePatternCase(APElemRef(apinfo,vref,idx)) as item -> let args = match args with SynConstructorArgs.Pats args -> args | _ -> failwith "impossible" @@ -4904,7 +5097,7 @@ and TcPat warnOnUpper cenv env topValInfo vFlags (tpenv,names,takenNames) ty pat let activePatExpr, tpenv = PropagateThenTcDelayed cenv activePatType env tpenv m vexp vexpty ExprAtomicFlag.NonAtomic delayed if idx >= activePatResTys.Length then error(Error(FSComp.SR.tcInvalidIndexIntoActivePatternArray(),m)) - let argty = List.nth activePatResTys idx + let argty = List.item idx activePatResTys let arg',(tpenv,names,takenNames) = TcPat warnOnUpper cenv env None vFlags (tpenv,names,takenNames) argty patarg @@ -5081,7 +5274,7 @@ and TcPatterns warnOnUpper cenv env vFlags s argtys args = and solveTypAsError cenv denv m ty = let ty2 = NewErrorType () assert((destTyparTy cenv.g ty2).IsFromError) - SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv cenv.css m denv) 0 m NoTrace ty ty2 |> ignore + SolveTypEqualsTypKeepAbbrevs (MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denv) 0 m NoTrace ty ty2 |> ignore and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv expr = // This function is motivated by cases like @@ -5095,7 +5288,7 @@ and RecordNameAndTypeResolutions_IdeallyWithoutHavingOtherEffects cenv env tpenv // The tricky bit is to not also have any other effects from typechecking, namely producing error diagnostics (which may be spurious) or having // side-effects on the typecheck environment. // - // TODO: Deal with the tricky bit. As it stands, we turn off error logging, but still have typechecking environment effects. As a result, + // REVIEW: We are yet to deal with the tricky bit. As it stands, we turn off error logging, but still have typechecking environment effects. As a result, // at the very least, you cannot call this function unless you're already reported a typechecking error (the 'worst' possible outcome would be // to incorrectly solve typecheck constraints as a result of effects in this function, and then have the code compile successfully and behave // in some weird way; so ensure the code can't possibly compile before calling this function as an expedient way to get better IntelliSense). @@ -5121,7 +5314,7 @@ and TcExprOfUnknownType cenv env tpenv expr = and TcExprFlex cenv flex ty (env: TcEnv) tpenv (e: SynExpr) = if flex then let argty = NewInferenceType () - AddCxTypeMustSubsumeType env.DisplayEnv cenv.css e.Range NoTrace ty argty + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css e.Range NoTrace ty argty let e',tpenv = TcExpr cenv argty env tpenv e let e' = mkCoerceIfNeeded cenv.g ty argty e' e',tpenv @@ -5130,16 +5323,13 @@ and TcExprFlex cenv flex ty (env: TcEnv) tpenv (e: SynExpr) = and TcExpr cenv ty (env: TcEnv) tpenv (expr: SynExpr) = - - let m = expr.Range - // Start an error recovery handler // Note the try/catch can lead to tail-recursion problems for iterated constructs, e.g. let... in... // So be careful! try TcExprNoRecover cenv ty env tpenv expr with e -> - + let m = expr.Range // Error recovery - return some rubbish expression, but replace/annotate // the type of the current expression with a type variable that indicates an error errorRecovery e m @@ -5324,6 +5514,9 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.Assert (x,m) -> TcAssertExpr cenv overallTy env m tpenv x + | SynExpr.Fixed (_,m) -> + error(Error(FSComp.SR.tcFixedNotAllowed(),m)) + // e : ty | SynExpr.Typed (e,cty,m) -> let tgty,tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv cty @@ -5336,7 +5529,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = let e',srcTy,tpenv = TcExprOfUnknownType cenv env tpenv e UnifyTypes cenv env m overallTy cenv.g.bool_ty let tgty,tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgty - TcRuntimeTypeTest (*isCast*)false cenv env.DisplayEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)false (*isOperator*)true cenv env.DisplayEnv m tgty srcTy let e' = mkCallTypeTest cenv.g m tgty e' e', tpenv @@ -5362,15 +5555,15 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.Downcast(e,_,m) | SynExpr.InferredDowncast (e,m) -> let e',srcTy,tpenv = TcExprOfUnknownType cenv env tpenv e - let tgty,tpenv = + let tgty,tpenv,isOperator = match expr with | SynExpr.Downcast (_,tgty,m) -> let tgty,tpenv = TcType cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv tgty UnifyTypes cenv env m tgty overallTy - tgty,tpenv - | SynExpr.InferredDowncast _ -> overallTy,tpenv + tgty,tpenv,true + | SynExpr.InferredDowncast _ -> overallTy,tpenv,false | _ -> failwith "downcast" - TcRuntimeTypeTest (*isCast*)true cenv env.DisplayEnv m tgty srcTy + TcRuntimeTypeTest (*isCast*)true isOperator cenv env.DisplayEnv m tgty srcTy // TcRuntimeTypeTest ensures tgty is a nominal type. Hence we can insert a check here // based on the nullness semantics of the nominal type. @@ -5388,7 +5581,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = mkLazyDelayed cenv.g m ety (mkUnitDelayLambda cenv.g m e'), tpenv | SynExpr.Tuple (args,_,m) -> - let argtys = UnifyTupleType cenv env.DisplayEnv m overallTy args + let argtys = UnifyTupleType env.eContextInfo cenv env.DisplayEnv m overallTy args // No subsumption at tuple construction let flexes = argtys |> List.map (fun _ -> false) let args',tpenv = TcExprs cenv env m tpenv flexes argtys args @@ -5495,7 +5688,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = UnifyTypes cenv env m overallTy genCollTy let exprty = NewInferenceType () let genEnumTy = mkSeqTy cenv.g genCollElemTy - AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace genEnumTy exprty + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace genEnumTy exprty let expr,tpenv = TcExpr cenv exprty env tpenv comp let expr = mkCoerceIfNeeded cenv.g genEnumTy (tyOfExpr cenv.g expr) expr (if isArray then mkCallSeqToArray else mkCallSeqToList) cenv.g m genCollElemTy @@ -5568,14 +5761,20 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = TcStmtThatCantBeCtorBody cenv env tpenv e1 | SynExpr.IfThenElse (e1,e2,e3opt,spIfToThen,isRecovery,mIfToThen,m) -> - let e1',tpenv = TcExprThatCantBeCtorBody cenv cenv.g.bool_ty env tpenv e1 - (if isNone e3opt && not isRecovery then UnifyTypes cenv env m overallTy cenv.g.unit_ty) - let e2',tpenv = TcExprThatCanBeCtorBody cenv overallTy env tpenv e2 + let e1',tpenv = TcExprThatCantBeCtorBody cenv cenv.g.bool_ty env tpenv e1 + let e2',tpenv = + if not isRecovery && isNone e3opt then + let env = { env with eContextInfo = ContextInfo.OmittedElseBranch } + UnifyTypes cenv env m cenv.g.unit_ty overallTy + TcExprThatCanBeCtorBody cenv overallTy env tpenv e2 + else + TcExprThatCanBeCtorBody cenv overallTy env tpenv e2 let e3',sp2,tpenv = match e3opt with - | None -> + | None -> mkUnit cenv.g mIfToThen,SuppressSequencePointAtTarget, tpenv // the fake 'unit' value gets exactly the same range as spIfToThen | Some e3 -> + let env = { env with eContextInfo = ContextInfo.ElseBranch } let e3',tpenv = TcExprThatCanBeCtorBody cenv overallTy env tpenv e3 e3',SequencePointAtTarget,tpenv primMkCond spIfToThen SequencePointAtTarget sp2 m overallTy e1' e2' e3', tpenv @@ -5626,7 +5825,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.TraitCall(tps,memSpfn,arg,m) -> let (TTrait(_,logicalCompiledName,_,argtys,returnTy,_) as traitInfo),tpenv = TcPseudoMemberSpec cenv NewTyparsOK env tps tpenv memSpfn m - if List.mem logicalCompiledName BakedInTraitConstraintNames then + if List.contains logicalCompiledName BakedInTraitConstraintNames then warning(BakedInMemberConstraintName(logicalCompiledName,m)) let returnTy = GetFSharpViewOfReturnType cenv.g returnTy @@ -5642,7 +5841,7 @@ and TcExprUndelayed cenv overallTy env tpenv (expr: SynExpr) = | SynExpr.LibraryOnlyUnionCaseFieldGet (e1,c,n,m) -> let e1',ty1,tpenv = TcExprOfUnknownType cenv env tpenv e1 let mkf,ty2 = TcUnionCaseOrExnField cenv env ty1 m c n - ((fun (a,b) n -> mkUnionCaseFieldGetUnproven(e1',a,b,n,m)), + ((fun (a,b) n -> mkUnionCaseFieldGetUnproven cenv.g (e1',a,b,n,m)), (fun a n -> mkExnCaseFieldGet(e1',a,n,m))) UnifyTypes cenv env m overallTy ty2 mkf n,tpenv @@ -5896,7 +6095,7 @@ and TcCtorCall isNaked cenv env tpenv overallTy objTy mObjTyOpt item superInit a // TcRecordConstruction //------------------------------------------------------------------------- -// Check a record consutrction expression +// Check a record construction expression and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m = let tcref = tcrefOfAppTy cenv.g objTy let tycon = tcref.Deref @@ -5922,22 +6121,25 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m = // Type check and generalize the supplied bindings let fldsList,tpenv = - (tpenv,fldsList) ||> List.mapFold (fun tpenv (fname,fexpr,fty,flex) -> + let env = { env with eContextInfo = ContextInfo.RecordFields } + (tpenv,fldsList) ||> List.mapFold (fun tpenv (fname,fexpr,fty,flex) -> let fieldExpr,tpenv = TcExprFlex cenv flex fty env tpenv fexpr (fname,fieldExpr),tpenv) // Add rebindings for unbound field when an "old value" is available - let oldFldsList = + // Effect order: mutable fields may get modified by other bindings... + let oldFldsList, wrap = match optOrigExpr with - | None -> [] - | Some (_,_,oldve') -> - // When we have an "old" value, append bindings for the unbound fields. - // Effect order - mutable fields may get modified by other bindings... - let fieldNameUnbound nom = List.forall (fun (name,_) -> name <> nom) fldsList - fspecs - |> List.filter (fun rfld -> rfld.Name |> fieldNameUnbound) - |> List.filter (fun f -> not f.IsZeroInit) - |> List.map (fun fspec ->fspec.Name, mkRecdFieldGet cenv.g (oldve',tcref.MakeNestedRecdFieldRef fspec,tinst,m)) + | None -> [], id + | Some (_,_,oldve) -> + let wrap,oldveaddr = mkExprAddrOfExpr cenv.g tycon.IsStructOrEnumTycon false NeverMutates oldve None m + let fieldNameUnbound nom = List.forall (fun (name,_) -> name <> nom) fldsList + let flds = + fspecs |> List.choose (fun rfld -> + if fieldNameUnbound rfld.Name && not rfld.IsZeroInit + then Some(rfld.Name, mkRecdFieldGetViaExprAddr (oldveaddr,tcref.MakeNestedRecdFieldRef rfld,tinst,m)) + else None) + flds, wrap let fldsList = fldsList @ oldFldsList @@ -5970,7 +6172,7 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m = let args = List.map snd fldsList - let expr = mkRecordExpr cenv.g (GetRecdInfo env, tcref, tinst, rfrefs, args, m) + let expr = wrap (mkRecordExpr cenv.g (GetRecdInfo env, tcref, tinst, rfrefs, args, m)) let expr = match optOrigExpr with @@ -5978,10 +6180,10 @@ and TcRecordConstruction cenv overallTy env tpenv optOrigExpr objTy fldsList m = // '{ recd fields }'. // expr - | Some (old',oldv',_) -> + | Some (old,oldv,_) -> // '{ recd with fields }'. // Assign the first object to a tmp and then construct - mkCompGenLet m oldv' old' expr + mkCompGenLet m oldv old expr expr, tpenv @@ -6050,7 +6252,7 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo,bind) = // 4a1. normalize the binding (note: needlessly repeating what we've done above) let (NormalizedBinding(vis,bkind,isInline,isMutable,attrs,doc,synTyparDecls,valSynData,p,bindingRhs,mBinding,spBind)) = bind let (SynValData(memberFlagsOpt,_,_)) = valSynData - // 4a2. adjust the binding, especially in the "member" case, a subset of the logic of AnalyzeAndMakeRecursiveValue + // 4a2. adjust the binding, especially in the "member" case, a subset of the logic of AnalyzeAndMakeAndPublishRecursiveValue let bindingRhs,logicalMethId,memberFlags = let rec lookPat p = match p,memberFlagsOpt with @@ -6079,9 +6281,9 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo,bind) = | _ -> implty --> NewInferenceType () - let (CheckedBindingInfo(inlineFlag,immut,bindingAttribs,_,_,ExplicitTyparInfo(_,declaredTypars,_),nameToPrelimValSchemeMap,rhsExpr,_,_,m,_,_,_),tpenv) = + let (CheckedBindingInfo(inlineFlag,bindingAttribs,_,_,ExplicitTyparInfo(_,declaredTypars,_),nameToPrelimValSchemeMap,rhsExpr,_,_,m,_,_,_,_),tpenv) = let flex, tpenv = TcNonrecBindingTyparDecls cenv env tpenv bind - TcNormalizedBinding ObjectExpressionOverrideBinding cenv env tpenv bindingTy None NoSafeInitInfo ([],flex) bind + TcNormalizedBinding ObjectExpressionOverrideBinding cenv env tpenv false bindingTy None NoSafeInitInfo ([],flex) bind // 4c. generalize the binding - only relevant when implementing a generic virtual method @@ -6100,7 +6302,7 @@ and TcObjectExprBinding cenv (env: TcEnv) implty tpenv (absSlotInfo,bind) = let freeInEnv = GeneralizationHelpers.ComputeUngeneralizableTypars env - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv,denv,m,immut,freeInEnv,false,CanGeneralizeConstrainedTypars,inlineFlag,Some(rhsExpr),declaredTypars,[],bindingTy,false) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv,denv,m,true,freeInEnv,false,CanGeneralizeConstrainedTypars,inlineFlag,Some(rhsExpr),declaredTypars,[],bindingTy,false) let declaredTypars = ChooseCanonicalDeclaredTyparsAfterInference cenv.g env.DisplayEnv declaredTypars m let generalizedTypars = PlaceTyparsInDeclarationOrder declaredTypars generalizedTypars @@ -6420,13 +6622,13 @@ and TcRecdExpr cenv overallTy env tpenv (inherits, optOrigExpr, flds, mWholeExpr let optOrigExpr,tpenv = match optOrigExpr with | None -> None, tpenv - | Some (e, _) -> + | Some (origExpr, _) -> match inherits with | Some (_,_,mInherits, _, _) -> error(Error(FSComp.SR.tcInvalidRecordConstruction(),mInherits)) | None -> - let e',tpenv = TcExpr cenv overallTy env tpenv e - let v',ve' = mkCompGenLocal mWholeExpr "inputRecord" overallTy - Some (e',v',ve'), tpenv + let olde,tpenv = TcExpr cenv overallTy env tpenv origExpr + let oldv,oldve = mkCompGenLocal mWholeExpr "inputRecord" overallTy + Some (olde,oldv,oldve), tpenv let fldsList = let flds = @@ -6665,8 +6867,8 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv let customOperationMethods = AllMethInfosOfTypeInScope cenv.infoReader env.NameEnv (None,ad) IgnoreOverrides mBuilderVal builderTy - |> List.filter (IsMethInfoAccessible cenv.amap mBuilderVal ad) |> List.choose (fun methInfo -> + if not (IsMethInfoAccessible cenv.amap mBuilderVal ad methInfo) then None else let nameSearch = TryBindMethInfoAttribute cenv.g mBuilderVal cenv.g.attrib_CustomOperationAttribute methInfo (fun _ -> None) // We do not respect this attribute for IL methods @@ -6805,7 +7007,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv | None -> false | Some argInfos -> i < argInfos.Length && - let (_,argInfo) = List.nth argInfos i + let (_,argInfo) = List.item i argInfos HasFSharpAttribute cenv.g cenv.g.attrib_ProjectionParameterAttribute argInfo.Attribs @@ -7618,6 +7820,12 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv let mBuilderVal = mBuilderVal.MakeSynthetic() SynExpr.Lambda (false,false,SynSimplePats.SimplePats ([mkSynSimplePatVar false (mkSynId mBuilderVal builderValName)],mBuilderVal), runExpr, mBuilderVal) + let env = + match comp with + | SynExpr.YieldOrReturn ((true,_),_,_) -> { env with eContextInfo = ContextInfo.YieldInComputationExpression } + | SynExpr.YieldOrReturn ((_,true),_,_) -> { env with eContextInfo = ContextInfo.ReturnInComputationExpression } + | _ -> env + let lambdaExpr ,tpenv= TcExpr cenv (builderTy --> overallTy) env tpenv lambdaExpr // beta-var-reduce to bind the builder using a 'let' binding let coreExpr = mkApps cenv.g ((lambdaExpr,tyOfExpr cenv.g lambdaExpr),[],[interpExpr],mBuilderVal) @@ -7630,7 +7838,7 @@ and TcComputationExpression cenv env overallTy mWhole interpExpr builderTy tpenv /// and helpers rather than to the builder methods (there is actually no builder for 'seq' in the library). /// These are later detected by state machine compilation. /// -/// Also "ienumerable extraction" is performaed on arguments to "for". +/// Also "ienumerable extraction" is performed on arguments to "for". and TcSequenceExpression cenv env tpenv comp overallTy m = let mkDelayedExpr (coreExpr:Expr) = @@ -7773,7 +7981,7 @@ and TcSequenceExpression cenv env tpenv comp overallTy m = if not isYield then errorR(Error(FSComp.SR.tcUseYieldBangForMultipleResults(),m)) - AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace genOuterTy genExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace genOuterTy genExprTy Some(mkCoerceExpr(resultExpr,genOuterTy,m,genExprTy), tpenv) | SynExpr.YieldOrReturn((isYield,_),yieldExpr,m) -> @@ -8050,14 +8258,14 @@ and TcItemThen cenv overallTy env tpenv (item,mItem,rest,afterOverloadResolution let isSpecialCaseForBackwardCompatibility = if currentIndex = SEEN_NAMED_ARGUMENT then false else - match stripTyEqns cenv.g (List.nth argtys currentIndex) with + match stripTyEqns cenv.g (List.item currentIndex argtys) with | TType_app(tcref, _) -> tyconRefEq cenv.g cenv.g.bool_tcr tcref || tyconRefEq cenv.g cenv.g.system_Bool_tcref tcref | TType_var(_) -> true | _ -> false if isSpecialCaseForBackwardCompatibility then assert (box fittedArgs.[currentIndex] = null) - fittedArgs.[currentIndex] <- List.nth args currentIndex // grab original argument, not item from the list of named parametere + fittedArgs.[currentIndex] <- List.item currentIndex args // grab original argument, not item from the list of named parametere currentIndex <- currentIndex + 1 else let caseName = @@ -8539,7 +8747,7 @@ and TcLookupThen cenv overallTy env tpenv mObjExpr objExpr objExprTy longId dela RecdFieldInstanceChecks cenv.g cenv.amap ad mItem rfinfo let tgty = rfinfo.EnclosingType let valu = isStructTy cenv.g tgty - AddCxTypeMustSubsumeType env.DisplayEnv cenv.css mItem NoTrace tgty objExprTy + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css mItem NoTrace tgty objExprTy let objExpr = if valu then objExpr else mkCoerceExpr(objExpr,tgty,mExprAndItem,objExprTy) let fieldTy = rfinfo.FieldType match delayed with @@ -8713,8 +8921,8 @@ and TcMethodApplication let denv = env.DisplayEnv - let isSimpleFormalArg (isParamArrayArg, isOutArg, optArgInfo: OptionalArgInfo, _reflArgInfo: ReflectedArgInfo) = - not isParamArrayArg && not isOutArg && not optArgInfo.IsOptional + let isSimpleFormalArg (isParamArrayArg, isOutArg, optArgInfo: OptionalArgInfo, callerInfoInfo: CallerInfoInfo, _reflArgInfo: ReflectedArgInfo) = + not isParamArrayArg && not isOutArg && not optArgInfo.IsOptional && callerInfoInfo = NoCallerInfo let callerObjArgTys = objArgs |> List.map (tyOfExpr cenv.g) @@ -8823,9 +9031,8 @@ and TcMethodApplication let GenerateMatchingSimpleArgumentTypes (calledMeth:MethInfo) = let curriedMethodArgAttribs = calledMeth.GetParamAttribs(cenv.amap, mItem) - curriedMethodArgAttribs - |> List.map (List.filter isSimpleFormalArg) - |> List.map (NewInferenceTypes) + curriedMethodArgAttribs + |> List.map (List.filter isSimpleFormalArg >> NewInferenceTypes) let UnifyMatchingSimpleArgumentTypes exprTy (calledMeth:MethInfo) = let curriedArgTys = GenerateMatchingSimpleArgumentTypes calledMeth @@ -8906,7 +9113,7 @@ and TcMethodApplication yield makeOneCalledMeth (minfo,pinfoOpt,false) ] let uniquelyResolved = - let csenv = MakeConstraintSolverEnv cenv.css mMethExpr denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv let res = UnifyUniqueOverloading csenv callerArgCounts methodName ad preArgumentTypeCheckingCalledMethGroup returnTy match res with | ErrorResult _ -> afterTcOverloadResolution.OnOverloadResolutionFailure() @@ -8992,7 +9199,7 @@ and TcMethodApplication CalledMeth(cenv.infoReader,Some(env.NameEnv),checkingAttributeCall,FreshenMethInfo, mMethExpr,ad,minfo,minst,callerTyArgs,pinfoOpt,callerObjArgTys,callerArgs,usesParamArrayConversion,true,objTyOpt)) let callerArgCounts = (unnamedCurriedCallerArgs.Length, namedCurriedCallerArgs.Length) - let csenv = MakeConstraintSolverEnv cenv.css mMethExpr denv + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css mMethExpr denv // Commit unassociated constraints prior to member overload resolution where there is ambiguity // about the possible target of the call. @@ -9019,8 +9226,7 @@ and TcMethodApplication let resultMinfo = result.Method let overridingInfo = overriding - |> List.filter (fun (minfo,_) -> minfo.IsVirtual) - |> List.tryFind (fun (minfo,_) -> MethInfosEquivByNameAndSig EraseNone true cenv.g cenv.amap range0 resultMinfo minfo) + |> List.tryFind (fun (minfo,_) -> minfo.IsVirtual && MethInfosEquivByNameAndSig EraseNone true cenv.g cenv.amap range0 resultMinfo minfo) match overridingInfo with | Some r -> r |> callSink | None -> (result.Method,result.AssociatedPropertyInfo) |> callSink @@ -9073,7 +9279,7 @@ and TcMethodApplication if HasHeadType cenv.g cenv.g.tcref_System_Collections_Generic_Dictionary finalCalledMethInfo.EnclosingType && finalCalledMethInfo.IsConstructor && not (finalCalledMethInfo.GetParamDatas(cenv.amap, mItem, finalCalledMeth.CallerTyArgs) - |> List.existsSquared (fun (ParamData(_,_,_,_,_,ty)) -> + |> List.existsSquared (fun (ParamData(_,_,_,_,_,_,ty)) -> HasHeadType cenv.g cenv.g.tcref_System_Collections_Generic_IEqualityComparer ty)) then match argsOfAppTy cenv.g finalCalledMethInfo.EnclosingType with @@ -9202,7 +9408,16 @@ and TcMethodApplication | ByrefTy cenv.g inst -> build inst (PassByRef(inst, currDfltVal)) | _ -> - emptyPreBinder,Expr.Const(TcFieldInit mMethExpr fieldInit,mMethExpr,currCalledArgTy) + match calledArg.CallerInfoInfo, env.eCallerMemberName with + | CallerLineNumber, _ when typeEquiv cenv.g currCalledArgTy cenv.g.int_ty -> + emptyPreBinder,Expr.Const(Const.Int32(mMethExpr.StartLine), mMethExpr, currCalledArgTy) + | CallerFilePath, _ when typeEquiv cenv.g currCalledArgTy cenv.g.string_ty -> + emptyPreBinder,Expr.Const(Const.String(System.IO.Path.GetFullPath(mMethExpr.FileName)), mMethExpr, currCalledArgTy) + | CallerMemberName, Some(callerName) when (typeEquiv cenv.g currCalledArgTy cenv.g.string_ty) -> + emptyPreBinder,Expr.Const(Const.String(callerName), mMethExpr, currCalledArgTy) + | _ -> + emptyPreBinder,Expr.Const(TcFieldInit mMethExpr fieldInit,mMethExpr,currCalledArgTy) + | WrapperForIDispatch -> match cenv.g.ilg.traits.SystemRuntimeInteropServicesScopeRef.Value with | None -> error(Error(FSComp.SR.fscSystemRuntimeInteropServicesIsRequired(), mMethExpr)) @@ -9224,13 +9439,25 @@ and TcMethodApplication let wrapper2,rhs = build currCalledArgTy dfltVal2 (wrapper2 >> mkCompGenLet mMethExpr v rhs), mkValAddr mMethExpr (mkLocalValRef v) build calledArgTy dfltVal - | CalleeSide -> + | CalleeSide -> let calledNonOptTy = if isOptionTy cenv.g calledArgTy then destOptionTy cenv.g calledArgTy else calledArgTy // should be unreachable - emptyPreBinder,mkUnionCaseExpr(mkNoneCase cenv.g,[calledNonOptTy],[],mMethExpr) + + match calledArg.CallerInfoInfo, env.eCallerMemberName with + | CallerLineNumber, _ when typeEquiv cenv.g calledNonOptTy cenv.g.int_ty -> + let lineExpr = Expr.Const(Const.Int32(mMethExpr.StartLine), mMethExpr, calledNonOptTy) + emptyPreBinder,mkUnionCaseExpr(mkSomeCase cenv.g,[calledNonOptTy],[lineExpr],mMethExpr) + | CallerFilePath, _ when typeEquiv cenv.g calledNonOptTy cenv.g.string_ty -> + let filePathExpr = Expr.Const(Const.String(System.IO.Path.GetFullPath(mMethExpr.FileName)), mMethExpr, calledNonOptTy) + emptyPreBinder,mkUnionCaseExpr(mkSomeCase cenv.g,[calledNonOptTy],[filePathExpr],mMethExpr) + | CallerMemberName, Some(callerName) when typeEquiv cenv.g calledNonOptTy cenv.g.string_ty -> + let memberNameExpr = Expr.Const(Const.String(callerName), mMethExpr, calledNonOptTy) + emptyPreBinder,mkUnionCaseExpr(mkSomeCase cenv.g,[calledNonOptTy],[memberNameExpr],mMethExpr) + | _ -> + emptyPreBinder,mkUnionCaseExpr(mkNoneCase cenv.g,[calledNonOptTy],[],mMethExpr) // Combine the variable allocators (if any) let wrapper = (wrapper >> wrapper2) @@ -9240,18 +9467,19 @@ and TcMethodApplication // Handle optional arguments let wrapOptionalArg (assignedArg: AssignedCalledArg<_>) = - let (CallerArg(callerArgTy,m,isOptCallerArg,expr)) = assignedArg.CallerArg + let (CallerArg(callerArgTy,m,isOptCallerArg,expr)) = assignedArg.CallerArg match assignedArg.CalledArg.OptArgInfo with | NotOptional -> if isOptCallerArg then errorR(Error(FSComp.SR.tcFormalArgumentIsNotOptional(),m)) assignedArg - | _ -> let expr = match assignedArg.CalledArg.OptArgInfo with | CallerSide _ -> if isOptCallerArg then - mkUnionCaseFieldGetUnproven(expr,mkSomeCase cenv.g,[destOptionTy cenv.g callerArgTy],0,m) + // STRUCT OPTIONS: if we allow struct options as optional arguments then we should take + // the address correctly. + mkUnionCaseFieldGetUnprovenViaExprAddr (expr,mkSomeCase cenv.g,[destOptionTy cenv.g callerArgTy],0,m) else expr | CalleeSide -> @@ -9433,16 +9661,16 @@ and TcMethodArg cenv env (lambdaPropagationInfo,tpenv) (lambdaPropagationInfoF // Apply the F# 3.1 rule for extracting information for lambdas // - // Before we check the argume, check to see if we can propagate info from a called lambda expression into the arguments of a received lambda + // Before we check the argument, check to see if we can propagate info from a called lambda expression into the arguments of a received lambda begin if lambdaPropagationInfoForArg.Length > 0 then let allOverloadsAreFuncOrMismatchForThisArg = lambdaPropagationInfoForArg |> Array.forall (function ArgDoesNotMatch | CallerLambdaHasArgTypes _ -> true | NoInfo | CalledArgMatchesType _ -> false) if allOverloadsAreFuncOrMismatchForThisArg then - let overloadsWhichAreFuncAtThisPosition = lambdaPropagationInfoForArg |> Array.choose (function CallerLambdaHasArgTypes r -> Some r | _ -> None) + let overloadsWhichAreFuncAtThisPosition = lambdaPropagationInfoForArg |> Array.choose (function CallerLambdaHasArgTypes r -> Some (List.toArray r) | _ -> None) if overloadsWhichAreFuncAtThisPosition.Length > 0 then - let minFuncArity = overloadsWhichAreFuncAtThisPosition |> Array.minBy List.length |> List.length + let minFuncArity = overloadsWhichAreFuncAtThisPosition |> Array.minBy Array.length |> Array.length let prefixOfLambdaArgsForEachOverload = overloadsWhichAreFuncAtThisPosition |> Array.map (Array.take minFuncArity) if prefixOfLambdaArgsForEachOverload.Length > 0 then @@ -9530,7 +9758,7 @@ and TcLinearLetExprs bodyChecker cenv env overallTy builder tpenv (processUseBin if isRec then // TcLinearLetExprs processes at most one recursive binding CheckRecursiveBindingIds binds - let binds = List.map (fun x -> RecBindingDefn(ExprContainerInfo,NoNewSlots,ExpressionBinding,x)) binds + let binds = List.map (fun x -> RecDefnBindingInfo(ExprContainerInfo,NoNewSlots,ExpressionBinding,x)) binds if isUse then errorR(Error(FSComp.SR.tcBindingCannotBeUseAndRec(),m)) let binds,envinner,tpenv = TcLetrec ErrorOnOverrides cenv env tpenv (binds,m,m) let bodyExpr,tpenv = bodyChecker overallTy envinner tpenv body @@ -9540,8 +9768,7 @@ and TcLinearLetExprs bodyChecker cenv env overallTy builder tpenv (processUseBin // TcLinearLetExprs processes multiple 'let' bindings in a tail recursive way // We process one binding, then look for additional linear bindings and accumulate the builder continuation. // Don't processes 'use' bindings (e.g. in sequence expressions) unless directed to. - let mkf,envinner,tpenv = - TcLetBinding cenv isUse env ExprContainerInfo ExpressionBinding tpenv (binds,m,body.Range) + let mkf,envinner,tpenv = TcLetBinding cenv isUse env ExprContainerInfo ExpressionBinding tpenv (binds,m,body.Range) let builder' x = builder (mkf x) match body with | SynExpr.LetOrUse (isRec',isUse',binds',bodyExpr,m') when (not isUse' || processUseBindings) -> @@ -9585,18 +9812,118 @@ and TcStaticOptimizationConstraint cenv env tpenv c = let tp',tpenv = TcTypar cenv env NewTyparsOK tpenv tp TTyconIsStruct(mkTyparTy tp'),tpenv +/// Emit a conv.i instruction +and mkConvToNativeInt g e m = Expr.Op (TOp.ILAsm ([ AI_conv ILBasicType.DT_I], [ g.nativeint_ty ]),[],[e],m) + +/// Fix up the r.h.s. of a 'use x = fixed expr' +and TcAndBuildFixedExpr cenv env (overallPatTy, fixedExpr, overallExprTy, mBinding) = + warning(PossibleUnverifiableCode(mBinding)) + match overallExprTy with + | ty when isByrefTy cenv.g ty -> + let okByRef = + match stripExpr fixedExpr with + | Expr.Op (op,tyargs,args,_) -> + match op,tyargs,args with + | TOp.ValFieldGetAddr rfref,_,[_] -> not rfref.Tycon.IsStructOrEnumTycon + | TOp.ILAsm ([ I_ldflda (fspec)],_),_,_ -> fspec.EnclosingType.Boxity = ILBoxity.AsObject + | TOp.ILAsm ([ I_ldelema _],_),_,_ -> true + | TOp.RefAddrGet _,_,_ -> true + | _ -> false + | _ -> false + if not okByRef then + error(Error(FSComp.SR.tcFixedNotAllowed(),mBinding)) + + let elemTy = destByrefTy cenv.g overallExprTy + UnifyTypes cenv env mBinding (mkNativePtrTy cenv.g elemTy) overallPatTy + mkCompGenLetIn mBinding "pinnedByref" ty fixedExpr (fun (v,ve) -> + v.SetIsFixed() + mkConvToNativeInt cenv.g ve mBinding) + + | ty when isStringTy cenv.g ty -> + let charPtrTy = mkNativePtrTy cenv.g cenv.g.char_ty + UnifyTypes cenv env mBinding charPtrTy overallPatTy + // + // let ptr : nativeptr = + // let pinned s = str + // (nativeptr)s + get_OffsettoStringData() + + mkCompGenLetIn mBinding "pinnedString" cenv.g.string_ty fixedExpr (fun (v,ve) -> + v.SetIsFixed() + let addrOffset = BuildOffsetToStringData cenv env mBinding + let stringAsNativeInt = mkConvToNativeInt cenv.g ve mBinding + let plusOffset = Expr.Op (TOp.ILAsm ([ AI_add ], [ cenv.g.nativeint_ty ]),[],[stringAsNativeInt; addrOffset],mBinding) + // check for non-null + mkNullTest cenv.g mBinding ve plusOffset ve) + + | ty when isArray1DTy cenv.g ty -> + let elemTy = destArrayTy cenv.g overallExprTy + let elemPtrTy = mkNativePtrTy cenv.g elemTy + UnifyTypes cenv env mBinding elemPtrTy overallPatTy + + // let ptr : nativeptr = + // let tmpArray : elem[] = arr + // if nonNull tmpArray then + // if tmpArray.Length <> 0 then + // let pinned tmpArrayByref : byref = &arr.[0] + // (nativeint) tmpArrayByref + // else + // (nativeint) 0 + // else + // (nativeint) 0 + // + mkCompGenLetIn mBinding "tmpArray" overallExprTy fixedExpr (fun (_,ve) -> + // This is &arr.[0] + let elemZeroAddress = mkArrayElemAddress cenv.g (ILReadonly.NormalAddress,false,ILArrayShape.SingleDimensional,elemTy,ve,mkInt32 cenv.g mBinding 0,mBinding) + // check for non-null and non-empty + let zero = mkConvToNativeInt cenv.g (mkInt32 cenv.g mBinding 0) mBinding + // This is arr.Length + let arrayLengthExpr = mkCallArrayLength cenv.g mBinding elemTy ve + mkNullTest cenv.g mBinding ve + (mkNullTest cenv.g mBinding arrayLengthExpr + (mkCompGenLetIn mBinding "pinnedByref" (mkByrefTy cenv.g elemTy) elemZeroAddress (fun (v,ve) -> + v.SetIsFixed() + (mkConvToNativeInt cenv.g ve mBinding))) + zero) + zero) + + | _ -> error(Error(FSComp.SR.tcFixedNotAllowed(),mBinding)) + + /// Binding checking code, for all bindings including let bindings, let-rec bindings, member bindings and object-expression bindings and -and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt safeInitInfo (enclosingDeclaredTypars,(ExplicitTyparInfo(_,declaredTypars,_) as flex)) bind = +and TcNormalizedBinding declKind (cenv:cenv) env tpenv isUse overallTy safeThisValOpt safeInitInfo (enclosingDeclaredTypars,(ExplicitTyparInfo(_,declaredTypars,_) as flex)) bind = let envinner = AddDeclaredTypars NoCheckForDuplicateTypars (enclosingDeclaredTypars@declaredTypars) env match bind with | NormalizedBinding(vis,bkind,isInline,isMutable,attrs,doc,_,valSynData,pat,NormalizedBindingRhs(spatsL,rtyOpt,rhsExpr),mBinding,spBind) -> - let (SynValData(memberFlagsOpt,valSynInfo,_)) = valSynData + let callerName = + match declKind, bkind, pat with + | ExpressionBinding, _, _ -> envinner.eCallerMemberName + | _, _, SynPat.Named(_,name,_,_,_) -> + match memberFlagsOpt with + | Some(memberFlags) -> + match memberFlags.MemberKind with + | MemberKind.PropertyGet | MemberKind.PropertySet | MemberKind.PropertyGetSet -> Some(name.idText.Substring(4)) + | MemberKind.ClassConstructor -> Some(".ctor") + | MemberKind.Constructor -> Some(".ctor") + | _ -> Some(name.idText) + | _ -> Some(name.idText) + | ClassLetBinding(false), DoBinding, _ -> Some(".ctor") + | ClassLetBinding(true), DoBinding, _ -> Some(".cctor") + | ModuleOrMemberBinding, StandaloneExpression, _ -> Some(".cctor") + | _, _, _ -> envinner.eCallerMemberName + + let envinner = {envinner with eCallerMemberName = callerName } + let attrTgt = DeclKind.AllowedAttribTargets memberFlagsOpt declKind + let isFixed,rhsExpr,overallPatTy,overallExprTy = + match rhsExpr with + | SynExpr.Fixed (e,_) -> true, e, NewInferenceType(), overallTy + | e -> false, e, overallTy, overallTy + // Check the attributes of the binding, parameters or return value let TcAttrs tgt attrs = let attrs = TcAttributes cenv envinner tgt attrs @@ -9611,6 +9938,7 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt let argAttribs = spatsL |> List.map (SynInfo.InferSynArgInfoFromSimplePats >> List.map (SynInfo.AttribsOfArgData >> TcAttrs AttributeTargets.Parameter)) + let retAttribs = match rtyOpt with | Some (SynBindingReturnInfo(_,_,retAttrs)) -> TcAttrs AttributeTargets.ReturnValue retAttrs @@ -9625,11 +9953,20 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt if isThreadStatic then errorR(DeprecatedThreadStaticBindingWarning(mBinding)) if isVolatile then - if declKind <> ClassLetBinding then - errorR(Error(FSComp.SR.tcVolatileOnlyOnClassLetBindings(),mBinding)) + match declKind with + | ClassLetBinding(_) -> () + | _ -> errorR(Error(FSComp.SR.tcVolatileOnlyOnClassLetBindings(),mBinding)) + if (not isMutable || isThreadStatic) then errorR(Error(FSComp.SR.tcVolatileFieldsMustBeMutable(),mBinding)) + if isFixed then + if declKind <> ExpressionBinding || isInline || isMutable then + errorR(Error(FSComp.SR.tcFixedNotAllowed(),mBinding)) + + if isUse && isMutable then + warning(Error(FSComp.SR.tcUseMayNotBeMutable(),mBinding)) + if HasFSharpAttributeOpt cenv.g cenv.g.attrib_DllImportAttribute valAttribs then if not declKind.CanBeDllImport || (match memberFlagsOpt with Some memberFlags -> memberFlags.IsInstance | _ -> false) then errorR(Error(FSComp.SR.tcDllImportNotAllowed(),mBinding)) @@ -9641,12 +9978,16 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt if isSome(memberFlagsOpt) then errorR(Error(FSComp.SR.tcEntryPointAttributeRequiresFunctionInModule(),mBinding)) else - UnifyTypes cenv env mBinding overallTy (mkArrayType cenv.g cenv.g.string_ty --> cenv.g.int_ty) + UnifyTypes cenv env mBinding overallPatTy (mkArrayType cenv.g cenv.g.string_ty --> cenv.g.int_ty) if isMutable && isInline then errorR(Error(FSComp.SR.tcMutableValuesCannotBeInline(),mBinding)) + if isMutable && nonNil declaredTypars then errorR(Error(FSComp.SR.tcMutableValuesMayNotHaveGenericParameters(),mBinding)) + let flex = if isMutable then dontInferTypars else flex + if isMutable && nonNil spatsL then errorR(Error(FSComp.SR.tcMutableValuesSyntax(),mBinding)) + let isInline = if isInline && isNil spatsL && isNil declaredTypars then errorR(Error(FSComp.SR.tcOnlyFunctionsCanBeInline(),mBinding)) @@ -9661,7 +10002,7 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt // Check the pattern of the l.h.s. of the binding let tcPatPhase2,(tpenv,nameToPrelimValSchemeMap,_) = - TcPat AllIdsOK cenv envinner (Some(partialValReprInfo)) (inlineFlag,flex,argAndRetAttribs,isMutable,vis,compgen) (tpenv,NameMap.empty,Set.empty) overallTy pat + TcPat AllIdsOK cenv envinner (Some(partialValReprInfo)) (inlineFlag,flex,argAndRetAttribs,isMutable,vis,compgen) (tpenv,NameMap.empty,Set.empty) overallPatTy pat // Add active pattern result names to the environment @@ -9692,22 +10033,26 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt // If binding a ctor then set the ugly counter that permits us to write ctor expressions on the r.h.s. let isCtor = (match memberFlagsOpt with Some memberFlags -> memberFlags.MemberKind = MemberKind.Constructor | _ -> false) - let tc = - if isCtor then TcExprThatIsCtorBody (safeThisValOpt, safeInitInfo) - else TcExprThatCantBeCtorBody - // At each module binding, dive into the expression to check for syntax errors and suppress them if they show. // Don't do this for lambdas, because we always check for suppression for all lambda bodies in TcIteratedLambdas - let rhsExpr',tpenv = + let rhsExprChecked,tpenv = let atTopNonLambdaDefn = DeclKind.IsModuleOrMemberOrExtensionBinding declKind && (match rhsExpr with SynExpr.Lambda _ -> false | _ -> true) && synExprContainsError rhsExpr + conditionallySuppressErrorReporting atTopNonLambdaDefn (fun () -> - tc cenv overallTy envinner tpenv rhsExpr) + + if isCtor then TcExprThatIsCtorBody (safeThisValOpt, safeInitInfo) cenv overallExprTy envinner tpenv rhsExpr + else TcExprThatCantBeCtorBody cenv overallExprTy envinner tpenv rhsExpr) if bkind = StandaloneExpression && not cenv.isScript then - UnifyUnitType cenv env.DisplayEnv mBinding overallTy (Some rhsExpr') |> ignore + UnifyUnitType cenv env.DisplayEnv mBinding overallPatTy (Some rhsExprChecked) |> ignore + + // Fix up the r.h.s. expression for 'fixed' + let rhsExprChecked = + if isFixed then TcAndBuildFixedExpr cenv env (overallPatTy, rhsExprChecked, overallExprTy, mBinding) + else rhsExprChecked // Assert the return type of an active pattern match apinfoOpt with @@ -9719,7 +10064,7 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt () // Check other attributes - let hasLiteralAttr,konst = TcLiteral cenv overallTy env tpenv (valAttribs,rhsExpr) + let hasLiteralAttr,konst = TcLiteral cenv overallExprTy env tpenv (valAttribs,rhsExpr) if hasLiteralAttr && isThreadStatic then errorR(Error(FSComp.SR.tcIllegalAttributesForLiteral(),mBinding)) if hasLiteralAttr && isMutable then @@ -9729,7 +10074,7 @@ and TcNormalizedBinding declKind (cenv:cenv) env tpenv overallTy safeThisValOpt if hasLiteralAttr && nonNil declaredTypars then errorR(Error(FSComp.SR.tcLiteralCannotHaveGenericParameters(),mBinding)) - CheckedBindingInfo(inlineFlag,true,valAttribs,doc,tcPatPhase2,flex,nameToPrelimValSchemeMap,rhsExpr',argAndRetAttribs,overallTy,mBinding,spBind,compgen,konst),tpenv + CheckedBindingInfo(inlineFlag,valAttribs,doc,tcPatPhase2,flex,nameToPrelimValSchemeMap,rhsExprChecked,argAndRetAttribs,overallPatTy,mBinding,spBind,compgen,konst,isFixed),tpenv and TcLiteral cenv overallTy env tpenv (attrs,synLiteralValExpr) = let hasLiteralAttr = HasFSharpAttribute cenv.g cenv.g.attrib_LiteralAttribute attrs @@ -9771,16 +10116,16 @@ and TcNonrecBindingTyparDecls cenv env tpenv bind = let (NormalizedBinding(_,_,_,_,_,_,synTyparDecls,_,_,_,_,_)) = bind TcBindingTyparDecls true cenv env tpenv synTyparDecls -and TcNonRecursiveBinding declKind cenv env tpenv ty b = +and TcNonRecursiveBinding declKind cenv env tpenv isUse ty b = let b = BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env b let flex, tpenv = TcNonrecBindingTyparDecls cenv env tpenv b - TcNormalizedBinding declKind cenv env tpenv ty None NoSafeInitInfo ([],flex) b + TcNormalizedBinding declKind cenv env tpenv isUse ty None NoSafeInitInfo ([],flex) b //------------------------------------------------------------------------- // TcAttribute* //------------------------------------------------------------------------ -and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = +and TcAttribute canFail cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = let (LongIdentWithDots(tycon,_))= synAttr.TypeName let arg = synAttr.ArgExpr let targetIndicator = synAttr.Target @@ -9811,8 +10156,8 @@ and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = let conditionalCallDefineOpt = TryFindTyconRefStringAttribute cenv.g mAttr cenv.g.attrib_ConditionalAttribute tcref match conditionalCallDefineOpt with - | Some d when not (List.mem d cenv.conditionalDefines) -> - [] + | Some d when not (List.contains d cenv.conditionalDefines) -> + [], false | _ -> // REVIEW: take notice of inherited? @@ -9871,7 +10216,10 @@ and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = else error(Error(FSComp.SR.tcAttributeIsNotValidForLanguageElement(),mAttr)) - let item = ForceRaise (ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mAttr ad ty) + match ResolveObjectConstructor cenv.nameResolver env.DisplayEnv mAttr ad ty with + | ResultOrException.Exception _ when canFail -> [ ], true + | res -> + let item = ForceRaise res let attrib = match item with | Item.CtorGroup(methodName,minfos) -> @@ -9912,7 +10260,7 @@ and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = let propNameItem = Item.SetterArg(id, setterItem) CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,propNameItem,propNameItem,ItemOccurence.Use,env.DisplayEnv,ad) - AddCxTypeMustSubsumeType env.DisplayEnv cenv.css m NoTrace argty argtyv + AddCxTypeMustSubsumeType ContextInfo.NoContext env.DisplayEnv cenv.css m NoTrace argty argtyv AttribNamedArg(nm,argty,isProp,mkAttribExpr expr)) @@ -9923,9 +10271,9 @@ and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = let args = args |> List.map mkAttribExpr Attrib(tcref,ILAttrib(ilMethRef),args,namedAttribArgMap,isAppliedToGetterOrSetter,Some constrainedTgts,m) - | Expr.App(Expr.Val(vref,_,_),_,_,args,_) -> - let try_dest_unit_or_tuple = function Expr.Const(Const.Unit,_,_) -> [] | expr -> tryDestTuple expr - let args = args |> List.collect (try_dest_unit_or_tuple) |> List.map mkAttribExpr + | Expr.App((InnerExprPat(ExprValWithPossibleTypeInst(vref,_,_,_))),_,_,args,_) -> + let tryDestUnitOrTuple = function Expr.Const(Const.Unit,_,_) -> [] | expr -> tryDestTuple expr + let args = args |> List.collect tryDestUnitOrTuple |> List.map mkAttribExpr Attrib(tcref,FSAttrib(vref),args,namedAttribArgMap,isAppliedToGetterOrSetter,Some constrainedTgts,mAttr) | _ -> @@ -9934,13 +10282,13 @@ and TcAttribute cenv (env: TcEnv) attrTgt (synAttr: SynAttribute) = | _ -> error(Error(FSComp.SR.tcAttributeExpressionsMustBeConstructorCalls(),mAttr)) - [ (constrainedTgts, attrib) ] + [ (constrainedTgts, attrib) ], false -and TcAttributesWithPossibleTargets cenv env attrTgt synAttribs = +and TcAttributesWithPossibleTargets canFail cenv env attrTgt synAttribs = - synAttribs |> List.collect (fun synAttrib -> + (false,synAttribs) ||> List.collectFold (fun didFail synAttrib -> try - let attribsAndTargets = TcAttribute cenv env attrTgt synAttrib + let attribsAndTargets, didFail2 = TcAttribute canFail cenv env attrTgt synAttrib // This is where we place any checks that completely exclude the use of some particular // attributes from F#. @@ -9950,14 +10298,22 @@ and TcAttributesWithPossibleTargets cenv env attrTgt synAttribs = HasFSharpAttribute cenv.g cenv.g.attrib_CompilationMappingAttribute attribs then errorR(Error(FSComp.SR.tcUnsupportedAttribute(),synAttrib.Range)) - attribsAndTargets + attribsAndTargets, didFail || didFail2 with e -> errorRecovery e synAttrib.Range - []) + [], false) + +and TcAttributesMaybeFail canFail cenv env attrTgt synAttribs = + let attribsAndTargets, didFail = TcAttributesWithPossibleTargets canFail cenv env attrTgt synAttribs + attribsAndTargets |> List.map snd, didFail + +and TcAttributesCanFail cenv env attrTgt synAttribs = + let attrs, didFail = TcAttributesMaybeFail true cenv env attrTgt synAttribs + attrs, (fun () -> if didFail then TcAttributes cenv env attrTgt synAttribs else attrs) and TcAttributes cenv env attrTgt synAttribs = - TcAttributesWithPossibleTargets cenv env attrTgt synAttribs |> List.map snd + TcAttributesMaybeFail false cenv env attrTgt synAttribs |> fst //------------------------------------------------------------------------- // TcLetBinding @@ -9966,14 +10322,14 @@ and TcAttributes cenv env attrTgt synAttribs = and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scopem) = // Typecheck all the bindings... - let binds',tpenv = List.mapFold (fun tpenv b -> TcNonRecursiveBinding declKind cenv env tpenv (NewInferenceType ()) b) tpenv binds + let binds',tpenv = List.mapFold (fun tpenv b -> TcNonRecursiveBinding declKind cenv env tpenv isUse (NewInferenceType ()) b) tpenv binds let (ContainerInfo(altActualParent,_)) = containerInfo // Canonicalize constraints prior to generalization let denv = env.DisplayEnv GeneralizationHelpers.CanonicalizePartialInferenceProblem (cenv,denv,bindsm) (binds' |> List.collect (fun tbinfo -> - let (CheckedBindingInfo(_,_,_,_,_,flex,_,_,_,tauTy,_,_,_,_)) = tbinfo + let (CheckedBindingInfo(_,_,_,_,flex,_,_,_,tauTy,_,_,_,_,_)) = tbinfo let (ExplicitTyparInfo(_,declaredTypars,_)) = flex let maxInferredTypars = (freeInTypeLeftToRight cenv.g false tauTy) declaredTypars @ maxInferredTypars)) @@ -9982,7 +10338,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope // Generalize the bindings... (((fun x -> x), env, tpenv), binds') ||> List.fold (fun (mkf_sofar,env,tpenv) tbinfo -> - let (CheckedBindingInfo(inlineFlag,immut,attrs,doc,tcPatPhase2,flex,nameToPrelimValSchemeMap,rhsExpr,_,tauTy,m,spBind,_,konst)) = tbinfo + let (CheckedBindingInfo(inlineFlag,attrs,doc,tcPatPhase2,flex,nameToPrelimValSchemeMap,rhsExpr,_,tauTy,m,spBind,_,konst,isFixed)) = tbinfo let enclosingDeclaredTypars = [] let (ExplicitTyparInfo(_,declaredTypars,canInferTypars)) = flex let allDeclaredTypars = enclosingDeclaredTypars @ declaredTypars @@ -9996,7 +10352,7 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope [] else let freeInEnv = lazyFreeInEnv.Force() - GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv,denv, m, immut, freeInEnv, canInferTypars, GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl(declKind), inlineFlag, Some rhsExpr, allDeclaredTypars, maxInferredTypars,tauTy,false) + GeneralizationHelpers.ComputeAndGeneralizeGenericTypars(cenv,denv, m, true, freeInEnv, canInferTypars, GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl(declKind), inlineFlag, Some rhsExpr, allDeclaredTypars, maxInferredTypars,tauTy,false) let prelimValSchemes2 = GeneralizeVals cenv denv enclosingDeclaredTypars generalizedTypars nameToPrelimValSchemeMap @@ -10011,13 +10367,13 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope let prelimRecValues = NameMap.map fst values // Now bind the r.h.s. to the l.h.s. - let rhse = mkTypeLambda m generalizedTypars (rhsExpr,tauTy) + let rhsExpr = mkTypeLambda m generalizedTypars (rhsExpr,tauTy) match pat' with // Don't introduce temporary or 'let' for 'match against wild' or 'match against unit' - | (TPat_wild _ | TPat_const (Const.Unit,_)) when not isUse && isNil generalizedTypars -> - let mk_seq_bind (tm,tmty) = (mkSequential SequencePointsAtSeq m rhse tm, tmty) + | (TPat_wild _ | TPat_const (Const.Unit,_)) when not isUse && not isFixed && isNil generalizedTypars -> + let mk_seq_bind (tm,tmty) = (mkSequential SequencePointsAtSeq m rhsExpr tm, tmty) (mk_seq_bind << mkf_sofar,env,tpenv) | _ -> @@ -10028,38 +10384,42 @@ and TcLetBinding cenv isUse env containerInfo declKind tpenv (binds,bindsm,scope // nice: don't introduce awful temporary for r.h.s. in the 99% case where we know what we're binding it to | TPat_as (pat1,PBind(v,TypeScheme(generalizedTypars',_)),_) when List.lengthsEqAndForall2 typarRefEq generalizedTypars generalizedTypars' -> + v, pat1 | _ when mustinline(inlineFlag) -> error(Error(FSComp.SR.tcInvalidInlineSpecification(),m)) | _ -> let tmp,_ = mkCompGenLocal m "patternInput" (generalizedTypars +-> tauTy) - if isUse then + if isUse || isFixed then errorR(Error(FSComp.SR.tcInvalidUseBinding(),m)) // This assignment forces representation as module value, to maintain the invariant from the // type checker that anything related to binding module-level values is marked with an // val_repr_info, val_actual_parent and is_topbind if (DeclKind.MustHaveArity declKind) then - AdjustValToTopVal tmp altActualParent (InferArityOfExprBinding cenv.g tmp rhse) + AdjustValToTopVal tmp altActualParent (InferArityOfExprBinding cenv.g tmp rhsExpr) tmp,pat' - let mkRhsBind (tm,tmty) = (mkLet spBind m tmp rhse tm),tmty + let mkRhsBind (bodyExpr,bodyExprTy) = + let letExpr = mkLet spBind m tmp rhsExpr bodyExpr + letExpr,bodyExprTy + let allValsDefinedByPattern = (NameMap.range prelimRecValues |> FlatList.ofList) - let mkPatBind (tm,tmty) = + let mkPatBind (bodyExpr,bodyExprTy) = let valsDefinedByMatching = FlatListSet.remove valEq tmp allValsDefinedByPattern - let matchx = CompilePatternForMatch cenv env m m true ThrowIncompleteMatchException (tmp,generalizedTypars) [TClause(pat'',None,TTarget(valsDefinedByMatching,tm,SuppressSequencePointAtTarget),m)] tauTy tmty + let matchx = CompilePatternForMatch cenv env m m true ThrowIncompleteMatchException (tmp,generalizedTypars) [TClause(pat'',None,TTarget(valsDefinedByMatching,bodyExpr,SuppressSequencePointAtTarget),m)] tauTy bodyExprTy let matchx = if (DeclKind.ConvertToLinearBindings declKind) then LinearizeTopMatch cenv.g altActualParent matchx else matchx - matchx,tmty + matchx,bodyExprTy - let mkCleanup (tm,tmty) = - if isUse then - (allValsDefinedByPattern,(tm,tmty)) ||> FlatList.foldBack (fun v (tm,tmty) -> - AddCxTypeMustSubsumeType denv cenv.css v.Range NoTrace cenv.g.system_IDisposable_typ v.Type + let mkCleanup (bodyExpr,bodyExprTy) = + if isUse && not isFixed then + (allValsDefinedByPattern,(bodyExpr,bodyExprTy)) ||> FlatList.foldBack (fun v (bodyExpr,bodyExprTy) -> + AddCxTypeMustSubsumeType ContextInfo.NoContext denv cenv.css v.Range NoTrace cenv.g.system_IDisposable_typ v.Type let cleanupE = BuildDisposableCleanup cenv env m v - mkTryFinally cenv.g (tm,cleanupE,m,tmty,SequencePointInBodyOfTry,NoSequencePointAtFinally),tmty) + mkTryFinally cenv.g (bodyExpr,cleanupE,m,bodyExprTy,SequencePointInBodyOfTry,NoSequencePointAtFinally),bodyExprTy) else - (tm,tmty) + (bodyExpr,bodyExprTy) ((mkRhsBind << mkPatBind << mkCleanup << mkf_sofar), AddLocalValMap cenv.tcSink scopem prelimRecValues env, @@ -10286,7 +10646,7 @@ and CheckForNonAbstractInterface declKind tcref memberFlags m = error(Error(FSComp.SR.tcConcreteMembersIllegalInInterface(),m)) //------------------------------------------------------------------------- -// TcLetrec - AnalyzeAndMakeRecursiveValue(s) +// TcLetrec - AnalyzeAndMakeAndPublishRecursiveValue(s) //------------------------------------------------------------------------ and AnalyzeRecursiveStaticMemberOrValDecl (cenv, envinner: TcEnv, tpenv, declKind, newslotsOK, overridesOK, tcrefContainerInfo, vis1, id:Ident, vis2, declaredTypars, memberFlagsOpt, thisIdOpt, bindingAttribs, valSynInfo, ty, bindingRhs, mBinding, flex) = @@ -10430,12 +10790,15 @@ and AnalyzeRecursiveDecl (cenv,envinner,tpenv,declKind,synTyparDecls,declaredTyp error(Error(FSComp.SR.tcAttributesInvalidInPatterns(),m)) //analyzeRecursiveDeclPat pat' - // This is for the construct - // 'let rec x = ... and do ... and y = ...' - // DEPRECATED IN pars.mly - | SynPat.Const (SynConst.Unit, m) -> - let id = ident ("doval",m) - analyzeRecursiveDeclPat tpenv (SynPat.Named (SynPat.Wild m, id,false,None,m)) + // This is for the construct 'let rec x = ... and do ... and y = ...' (DEPRECATED IN pars.mly ) + // + // Also for + // module rec M = + // printfn "hello" // side effects in recursive modules + // let x = 1 + | SynPat.Const (SynConst.Unit, m) | SynPat.Wild m -> + let id = ident (cenv.niceNameGen.FreshCompilerGeneratedName("doval",m),m) + analyzeRecursiveDeclPat tpenv (SynPat.Named (SynPat.Wild m, id, false, None, m)) | SynPat.Named (SynPat.Wild _, id,_,vis2,_) -> AnalyzeRecursiveStaticMemberOrValDecl (cenv,envinner,tpenv,declKind,newslotsOK,overridesOK,tcrefContainerInfo,vis1,id,vis2,declaredTypars,memberFlagsOpt,thisIdOpt,bindingAttribs,valSynInfo,ty,bindingRhs,mBinding,flex) @@ -10454,7 +10817,7 @@ and AnalyzeRecursiveDecl (cenv,envinner,tpenv,declKind,synTyparDecls,declaredTyp /// and overrides). At this point we perform override inference, to infer /// which method we are overriding, in order to add constraints to the /// implementation of the method. -and AnalyzeAndMakeRecursiveValue overridesOK isGeneratedEventVal cenv (env:TcEnv) (tpenv,recBindIdx) (NormalizedRecBindingDefn(containerInfo,newslotsOK,declKind,binding)) = +and AnalyzeAndMakeAndPublishRecursiveValue overridesOK isGeneratedEventVal cenv (env:TcEnv) (tpenv,recBindIdx) (NormalizedRecBindingDefn(containerInfo,newslotsOK,declKind,binding)) = // Pull apart the inputs let (NormalizedBinding(vis1,bindingKind,isInline,isMutable,bindingSynAttribs,bindingXmlDoc,synTyparDecls,valSynData,declPattern,bindingRhs,mBinding,spBind)) = binding @@ -10512,7 +10875,7 @@ and AnalyzeAndMakeRecursiveValue overridesOK isGeneratedEventVal cenv (env:TcEnv let extraBindings = [ for extraBinding in EventDeclarationNormalization.GenerateExtraBindings cenv (bindingAttribs,binding) do yield (NormalizedRecBindingDefn(containerInfo,newslotsOK,declKind,extraBinding)) ] - let res,(tpenv,recBindIdx) = List.mapFold (AnalyzeAndMakeRecursiveValue overridesOK true cenv env) (tpenv,recBindIdx) extraBindings + let res,(tpenv,recBindIdx) = List.mapFold (AnalyzeAndMakeAndPublishRecursiveValue overridesOK true cenv env) (tpenv,recBindIdx) extraBindings let extraBindings, extraValues = List.unzip res List.concat extraBindings, List.concat extraValues, tpenv,recBindIdx @@ -10550,9 +10913,9 @@ and AnalyzeAndMakeRecursiveValue overridesOK isGeneratedEventVal cenv (env:TcEnv ((primaryBinding::extraBindings),(vspec::extraValues)),(tpenv,recBindIdx) -and AnalyzeAndMakeRecursiveValues overridesOK cenv env tpenv binds = +and AnalyzeAndMakeAndPublishRecursiveValues overridesOK cenv env tpenv binds = let recBindIdx = 0 - let res,tpenv = List.mapFold (AnalyzeAndMakeRecursiveValue overridesOK false cenv env) (tpenv,recBindIdx) binds + let res,tpenv = List.mapFold (AnalyzeAndMakeAndPublishRecursiveValue overridesOK false cenv env) (tpenv,recBindIdx) binds let bindings, values = List.unzip res List.concat bindings, List.concat values, tpenv @@ -10608,7 +10971,7 @@ and TcLetrecBinding let envRec = MakeInnerEnvForMember cenv envRec vspec let checkedBind,tpenv = - TcNormalizedBinding declKind cenv envRec tpenv tau safeThisValOpt safeInitInfo (enclosingDeclaredTypars,flex) rbind.SyntacticBinding + TcNormalizedBinding declKind cenv envRec tpenv false tau safeThisValOpt safeInitInfo (enclosingDeclaredTypars,flex) rbind.SyntacticBinding (try UnifyTypes cenv envRec vspec.Range (allDeclaredTypars +-> tau) vspec.Type with e -> error (Recursion(envRec.DisplayEnv,vspec.Id,tau,vspec.Type,vspec.Range))) @@ -10825,7 +11188,7 @@ and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgr let rbinfo = pgrbind.RecBindingInfo let vspec = rbinfo.Val - let (CheckedBindingInfo(inlineFlag,immut,_,_,_,_,_,expr,_,_,m,_,_,_)) = pgrbind.CheckedBinding + let (CheckedBindingInfo(inlineFlag,_,_,_,_,_,expr,_,_,m,_,_,_,_)) = pgrbind.CheckedBinding let (ExplicitTyparInfo(rigidCopyOfDeclaredTypars,declaredTypars,_)) = rbinfo.ExplicitTyparInfo let allDeclaredTypars = rbinfo.EnclosingDeclaredTypars @ declaredTypars @@ -10846,7 +11209,7 @@ and TcLetrecComputeAndGeneralizeGenericTyparsForBinding cenv denv freeInEnv (pgr let maxInferredTypars = freeInTypeLeftToRight cenv.g false tau let canGeneralizeConstrained = GeneralizationHelpers.CanGeneralizeConstrainedTyparsForDecl rbinfo.DeclKind - let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars (cenv,denv,m,immut,freeInEnv,canInferTypars,canGeneralizeConstrained,inlineFlag, Some(expr), allDeclaredTypars, maxInferredTypars,tau,isCtor) + let generalizedTypars = GeneralizationHelpers.ComputeAndGeneralizeGenericTypars (cenv,denv,m,true,freeInEnv,canInferTypars,canGeneralizeConstrained,inlineFlag, Some(expr), allDeclaredTypars, maxInferredTypars,tau,isCtor) generalizedTypars /// Compute the type variables which may have member constraints that need to be canonicalized prior to generalization @@ -10864,8 +11227,11 @@ and TcLetrecComputeSupportForBinding cenv (pgrbind : PreGeneralizationRecursiveB and TcLetrecGeneralizeBinding cenv denv generalizedTypars (pgrbind : PreGeneralizationRecursiveBinding) : PostGeneralizationRecursiveBinding = let (RBInfo(_,_,enclosingDeclaredTypars,_,vspec,flex,partialValReprInfo,memberInfoOpt,_,_,_,vis,_,declKind)) = pgrbind.RecBindingInfo - let (CheckedBindingInfo(inlineFlag,_,_,_,_,_,_,expr,argAttribs,_,_,_,compgen,_)) = pgrbind.CheckedBinding + let (CheckedBindingInfo(inlineFlag,_,_,_,_,_,expr,argAttribs,_,_,_,compgen,_,isFixed)) = pgrbind.CheckedBinding + if isFixed then + errorR(Error(FSComp.SR.tcFixedNotAllowed(),expr.Range)) + let _,tau = vspec.TypeScheme let pvalscheme1 = PrelimValScheme1(vspec.Id,flex,tau,Some(partialValReprInfo),memberInfoOpt,false,inlineFlag,NormalVal,argAttribs,vis,compgen) @@ -10894,7 +11260,7 @@ and MakeCheckSafeInitField g tinst thisValOpt rfref reqExpr (expr:Expr) = | None -> mkStaticRecdFieldGet (rfref, tinst, m) | Some thisVar -> // This is an instance method, it must have a 'this' var - mkRecdFieldGet g (exprForVal m thisVar, rfref, tinst, m) + mkRecdFieldGetViaExprAddr (exprForVal m thisVar, rfref, tinst, m) let failureExpr = match thisValOpt with None -> mkCallFailStaticInit g m | Some _ -> mkCallFailInit g m mkCompGenSequential m (mkIfThen g m (mkILAsmClt g m availExpr reqExpr) failureExpr) expr @@ -11000,8 +11366,8 @@ and unionGeneralizedTypars typarSets = List.foldBack (ListSet.unionFavourRight t and TcLetrec overridesOK cenv env tpenv (binds,bindsm,scopem) = // Create prelimRecValues for the recursive items (includes type info from LHS of bindings) *) - let binds = binds |> List.map (fun (RecBindingDefn(a,b,c,bind)) -> NormalizedRecBindingDefn(a,b,c,BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env bind)) - let uncheckedRecBinds,prelimRecValues,(tpenv,_) = AnalyzeAndMakeRecursiveValues overridesOK cenv env tpenv binds + let binds = binds |> List.map (fun (RecDefnBindingInfo(a,b,c,bind)) -> NormalizedRecBindingDefn(a,b,c,BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env bind)) + let uncheckedRecBinds,prelimRecValues,(tpenv,_) = AnalyzeAndMakeAndPublishRecursiveValues overridesOK cenv env tpenv binds let envRec = AddLocalVals cenv.tcSink scopem prelimRecValues env @@ -11036,7 +11402,17 @@ and TcLetrec overridesOK cenv env tpenv (binds,bindsm,scopem) = | [] -> false | (rbind :: _) -> DeclKind.MustHaveArity rbind.RecBindingInfo.DeclKind - EliminateInitializationGraphs cenv.g mustHaveArity env.DisplayEnv bindsWithoutLaziness bindsm + let results = + EliminateInitializationGraphs + (fun _ -> failwith "unreachable 2 - no type definitions in recursivve group") + (fun _ _ -> failwith "unreachable 3 - no type definitions in recursivve group") + id + (fun morpher oldBinds -> morpher oldBinds) + cenv.g mustHaveArity env.DisplayEnv [MutRecShape.Lets bindsWithoutLaziness] bindsm + match results with + | [MutRecShape.Lets newBinds; MutRecShape.Lets newBinds2] -> newBinds @ newBinds2 + | [MutRecShape.Lets newBinds] -> newBinds + | _ -> failwith "unreachable 4 - gave a Lets shape, expected at most one pre-lets shape back" // Post letrec env let envbody = AddLocalVals cenv.tcSink scopem prelimRecValues env @@ -11139,7 +11515,7 @@ module TcRecdUnionAndEnumDeclarations = begin NewRecdField isStatic konst id ty' isMutable vol attrsForProperty attrsForField xmldoc vis false let TcFieldDecl cenv env parent isIncrClass tpenv (isStatic,synAttrs,id,ty,isMutable,xmldoc,vis,m) = - let attrs = TcAttributesWithPossibleTargets cenv env AttributeTargets.FieldDecl synAttrs + let attrs, _ = TcAttributesWithPossibleTargets false cenv env AttributeTargets.FieldDecl synAttrs let attrsForProperty,attrsForField = attrs |> List.partition (fun (attrTargets,_) -> (attrTargets &&& AttributeTargets.Property) <> enum 0) let attrsForProperty = (List.map snd attrsForProperty) let attrsForField = (List.map snd attrsForField) @@ -11161,7 +11537,7 @@ module TcRecdUnionAndEnumDeclarations = begin match parent with | Parent tcref when useGenuineField tcref.Deref rfspec -> // Recheck the attributes for errors if the definition only generates a field - TcAttributesWithPossibleTargets cenv env AttributeTargets.FieldDeclRestricted synAttrs |> ignore + TcAttributesWithPossibleTargets false cenv env AttributeTargets.FieldDeclRestricted synAttrs |> ignore | _ -> () rfspec @@ -11293,7 +11669,7 @@ let TcAndPublishMemberSpec cenv env containerInfo declKind tpenv memb = | SynMemberSig.Member(valSpfn,memberFlags,_) -> TcAndPublishValSpec (cenv,env,containerInfo,declKind,Some memberFlags,tpenv,valSpfn) | SynMemberSig.Interface _ -> - // These are done in TcTyconDefnCores + // These are done in TcMutRecDefns_Phase1 [],tpenv @@ -11317,7 +11693,9 @@ let TcOpenDecl tcSink g amap m scopem env (longId : Ident list) = let modrefs = ForceRaise (TcModuleOrNamespaceLidAndPermitAutoResolve env amap longId) // validate opened namespace names - longId |> List.filter (fun id -> id.idText <> MangledGlobalName) |> List.iter (CheckNamespaceModuleOrTypeName g) + for id in longId do + if id.idText <> MangledGlobalName then + CheckNamespaceModuleOrTypeName g id let IsPartiallyQualifiedNamespace (modref: ModuleOrNamespaceRef) = let (CompPath(_,p)) = modref.CompilationPath @@ -11367,7 +11745,7 @@ let TcOpenDecl tcSink g amap m scopem env (longId : Ident list) = exception ParameterlessStructCtor of range /// Incremental class definitions -module IncrClassChecking = begin +module IncrClassChecking = /// Represents a single group of bindings in a class with an implicit constructor type IncrClassBindingGroup = @@ -11411,7 +11789,7 @@ module IncrClassChecking = begin /// Check and elaborate the "left hand side" of the implicit class construction /// syntax. - let TcImplictCtorLhsPassA(cenv, env, tpenv, tcref:TyconRef, vis, attrs, spats, thisIdOpt, baseValOpt: Val option, safeInitInfo, m, copyOfTyconTypars, objTy, thisTy) = + let TcImplictCtorLhs_Phase2A(cenv, env, tpenv, tcref:TyconRef, vis, attrs, spats, thisIdOpt, baseValOpt: Val option, safeInitInfo, m, copyOfTyconTypars, objTy, thisTy) = let baseValOpt = match GetSuperTypeOfType cenv.g cenv.amap m objTy with @@ -11483,7 +11861,7 @@ module IncrClassChecking = begin // --- Create this for use inside constructor let thisId = ident ("this",m) let thisValScheme = ValScheme(thisId,NonGenericTypeScheme(thisTy),None,None,false,ValInline.Never,CtorThisVal,None,true,false,false,false) - let thisVal = MakeAndPublishVal cenv env (ParentNone,false,ClassLetBinding,ValNotInRecScope,thisValScheme,[],XmlDoc.Empty,None,false) + let thisVal = MakeAndPublishVal cenv env (ParentNone,false,ClassLetBinding(false),ValNotInRecScope,thisValScheme,[],XmlDoc.Empty,None,false) thisVal {TyconRef = tcref @@ -11756,7 +12134,7 @@ module IncrClassChecking = begin let recdFields = MakeRecdFieldsTable (rfspecs @ tcref.AllFieldsAsList) // Mutate the entity_tycon_repr to publish the fields - tcref.Deref.Data.entity_tycon_repr <- TFsObjModelRepr { tcref.FSharpObjectModelTypeInfo with fsobjmodel_rfields = recdFields} + tcref.Deref.Data.entity_tycon_repr <- TFSharpObjectRepr { tcref.FSharpObjectModelTypeInfo with fsobjmodel_rfields = recdFields} /// Given localRep saying how locals have been represented, e.g. as fields. @@ -11765,7 +12143,7 @@ module IncrClassChecking = begin /// Fix up the references to the locals, e.g. /// v -> this.fieldv /// f x -> this.method x - member localRep.FixupIncrClassExprPassC thisValOpt safeStaticInitInfo (thisTyInst:TypeInst) expr = + member localRep.FixupIncrClassExprPhase2C thisValOpt safeStaticInitInfo (thisTyInst:TypeInst) expr = // fixup: intercept and expr rewrite let FixupExprNode rw e = //dprintfn "Fixup %s" (showL (exprL e)) @@ -11809,17 +12187,16 @@ module IncrClassChecking = begin IsUnderQuotations=true } expr - type IncrClassConstructionBindingsPassC = - | PassCBindings of IncrClassBindingGroup list - | PassCCtorJustAfterSuperInit - | PassCCtorJustAfterLastLet + type IncrClassConstructionBindingsPhase2C = + | Phase2CBindings of IncrClassBindingGroup list + | Phase2CCtorJustAfterSuperInit + | Phase2CCtorJustAfterLastLet /// Given a set of 'let' bindings (static or not, recursive or not) that make up a class, /// generate their initialization expression(s). - let MakeCtorForIncrClassConstructionPassC + let MakeCtorForIncrClassConstructionPhase2C (cenv, env: TcEnv, - _tpenv , /// The lhs information about the implicit constructor ctorInfo:IncrClassCtorLhs, /// The call to the super class constructor @@ -11827,7 +12204,7 @@ module IncrClassChecking = begin /// Should we place a sequence point at the 'inheritedTys call? inheritsIsVisible, /// The declarations - decs : IncrClassConstructionBindingsPassC list, + decs : IncrClassConstructionBindingsPhase2C list, memberBinds : Binding list, /// Record any unconstrained type parameters generalized for the outer members as "free choices" in the let bindings generalizedTyparsForRecursiveBlock, @@ -11866,10 +12243,10 @@ module IncrClassChecking = begin let (staticForcedFieldVars,instanceForcedFieldVars) = ((emptyFreeVars,emptyFreeVars),decs) ||> List.fold (fun (staticForcedFieldVars,instanceForcedFieldVars) dec -> match dec with - | PassCCtorJustAfterLastLet - | PassCCtorJustAfterSuperInit -> + | Phase2CCtorJustAfterLastLet + | Phase2CCtorJustAfterSuperInit -> (staticForcedFieldVars,instanceForcedFieldVars) - | PassCBindings decs -> + | Phase2CBindings decs -> ((staticForcedFieldVars,instanceForcedFieldVars),decs) ||> List.fold (fun (staticForcedFieldVars,instanceForcedFieldVars) dec -> match dec with | IncrClassBindingGroup(binds,isStatic,_) -> @@ -11908,7 +12285,7 @@ module IncrClassChecking = begin let TransBind (reps:IncrClassReprInfo) (TBind(v,rhsExpr,spBind)) = if v.MustInline then error(Error(FSComp.SR.tcLocalClassBindingsCannotBeInline(),v.Range)) - let rhsExpr = reps.FixupIncrClassExprPassC (Some thisVal) safeStaticInitInfo thisTyInst rhsExpr + let rhsExpr = reps.FixupIncrClassExprPhase2C (Some thisVal) safeStaticInitInfo thisTyInst rhsExpr // The initialization of the 'ref cell' variable for 'this' is the only binding which comes prior to the super init let isPriorToSuperInit = @@ -11958,7 +12335,7 @@ module IncrClassChecking = begin match safeStaticInitInfo with | SafeInitField (rfref, _) -> let setExpr = mkStaticRecdFieldSet (rfref, thisTyInst, mkInt cenv.g m idx, m) - let setExpr = reps.FixupIncrClassExprPassC (Some(thisVal)) NoSafeInitInfo thisTyInst setExpr + let setExpr = reps.FixupIncrClassExprPhase2C (Some(thisVal)) NoSafeInitInfo thisTyInst setExpr Some setExpr | NoSafeInitInfo -> None @@ -11994,7 +12371,7 @@ module IncrClassChecking = begin ([],actions,methodBinds),reps | IncrClassDo (doExpr,isStatic) -> - let doExpr = reps.FixupIncrClassExprPassC (Some(thisVal)) safeStaticInitInfo thisTyInst doExpr + let doExpr = reps.FixupIncrClassExprPhase2C (Some(thisVal)) safeStaticInitInfo thisTyInst doExpr let binder = (fun e -> mkSequential SequencePointsAtSeq doExpr.Range doExpr e) let isPriorToSuperInit = false if isStatic then @@ -12008,13 +12385,13 @@ module IncrClassChecking = begin let TransDec (reps:IncrClassReprInfo) dec = match dec with // The call to the base class constructor is done so we can set the ref cell - | PassCCtorJustAfterSuperInit -> + | Phase2CCtorJustAfterSuperInit -> let binders = [ match ctorInfo.InstanceCtorSafeThisValOpt with | None -> () | Some v -> let setExpr = mkRefCellSet cenv.g m ctorInfo.InstanceCtorThisVal.Type (exprForVal m v) (exprForVal m ctorInfo.InstanceCtorThisVal) - let setExpr = reps.FixupIncrClassExprPassC (Some(thisVal)) safeStaticInitInfo thisTyInst setExpr + let setExpr = reps.FixupIncrClassExprPhase2C (Some(thisVal)) safeStaticInitInfo thisTyInst setExpr let binder = (fun e -> mkSequential SequencePointsAtSeq setExpr.Range setExpr e) let isPriorToSuperInit = false yield (isPriorToSuperInit,binder) ] @@ -12023,12 +12400,12 @@ module IncrClassChecking = begin // The last 'let' binding is done so we can set the initialization condition for the collection of object fields // which now allows members to be called. - | PassCCtorJustAfterLastLet -> + | Phase2CCtorJustAfterLastLet -> let binders = [ match ctorInfo.InstanceCtorSafeInitInfo with | SafeInitField (rfref, _) -> - let setExpr = mkRecdFieldSet cenv.g (exprForVal m thisVal, rfref, thisTyInst, mkOne cenv.g m, m) - let setExpr = reps.FixupIncrClassExprPassC (Some(thisVal)) safeStaticInitInfo thisTyInst setExpr + let setExpr = mkRecdFieldSetViaExprAddr (exprForVal m thisVal, rfref, thisTyInst, mkOne cenv.g m, m) + let setExpr = reps.FixupIncrClassExprPhase2C (Some(thisVal)) safeStaticInitInfo thisTyInst setExpr let binder = (fun e -> mkSequential SequencePointsAtSeq setExpr.Range setExpr e) let isPriorToSuperInit = false yield (isPriorToSuperInit,binder) @@ -12037,7 +12414,7 @@ module IncrClassChecking = begin ([],binders,[]),reps - | PassCBindings decs -> + | Phase2CBindings decs -> let initActions, reps = List.mapFold (TransTrueDec false) reps decs let cctorInitActions, ctorInitActions, methodBinds = List.unzip3 initActions (List.concat cctorInitActions, List.concat ctorInitActions, List.concat methodBinds), reps @@ -12097,7 +12474,7 @@ module IncrClassChecking = begin // // As a result, the most natural way to implement this would be to simply capture arg0 if needed // and access all variables via that. This would be done by rewriting the inheritsExpr as follows: - // let inheritsExpr = reps.FixupIncrClassExprPassC (Some(thisVal)) thisTyInst inheritsExpr + // let inheritsExpr = reps.FixupIncrClassExprPhase2C (Some(thisVal)) thisTyInst inheritsExpr // However, the rules of IL mean we are not actually allowed to capture arg0 // and store it as a closure field before the base class constructor is called. // @@ -12113,7 +12490,7 @@ module IncrClassChecking = begin // Rewrite the expression to convert it to a load of a field if needed. // We are allowed to load fields from our own object even though we haven't called // the super class cosntructor yet. - let ldexpr = reps.FixupIncrClassExprPassC (Some(thisVal)) safeStaticInitInfo thisTyInst (exprForVal m v) + let ldexpr = reps.FixupIncrClassExprPhase2C (Some(thisVal)) safeStaticInitInfo thisTyInst (exprForVal m v) mkInvisibleLet m v ldexpr inheritsExpr let spAtSuperInit = (if inheritsIsVisible then SequencePointsAtSeq else SuppressSequencePointOnExprOfSequential) @@ -12142,88 +12519,88 @@ module IncrClassChecking = begin ctorBody,cctorBodyOpt,methodBinds,reps -end -// Checking of members and 'let' bindings in classes + +// Checking of mutually recursive types, members and 'let' bindings in classes // // Technique: multiple passes. -// - create val_specs for recursive items given names and args -// - type check AST to TAST collecting (sufficient) type constraints -// - determine typars to generalize over -// - generalize definitions (fixing up recursive instances) -// - build ctor binding -// - Yields set of recursive bindings for the ctors and members of the types. -module TyconBindingChecking = begin +// Phase1: create and establish type definitions and core representation information +// Phase2A: create Vals for recursive items given names and args +// Phase2B-D: type check AST to TAST collecting (sufficient) type constraints, +// generalize definitions, fix up recursive instances, build ctor binding +module MutRecBindingChecking = open IncrClassChecking /// Represents one element in a type definition, after the first phase - type TyconBindingsPassA = + type TyconBindingPhase2A = /// An entry corresponding to the definition of the implicit constructor for a class - | PassAIncrClassCtor of IncrClassCtorLhs + | Phase2AIncrClassCtor of IncrClassCtorLhs /// An 'inherit' declaration in an incremental class /// - /// PassAInherit (typ,arg,baseValOpt,m) - | PassAInherit of SynType * SynExpr * Val option * range + /// Phase2AInherit (typ,arg,baseValOpt,m) + | Phase2AInherit of SynType * SynExpr * Val option * range /// A set of value or function definitions in an incremental class /// - /// PassAIncrClassBindings (tcref,letBinds,isStatic,isRec,m) - | PassAIncrClassBindings of TyconRef * Ast.SynBinding list * bool * bool * range + /// Phase2AIncrClassBindings (tcref,letBinds,isStatic,isRec,m) + | Phase2AIncrClassBindings of TyconRef * Ast.SynBinding list * bool * bool * range /// A 'member' definition in a class - | PassAMember of PreCheckingRecursiveBinding + | Phase2AMember of PreCheckingRecursiveBinding #if OPEN_IN_TYPE_DECLARATIONS /// A dummy declaration, should we ever support 'open' in type definitions - | PassAOpen of LongIdent * range + | Phase2AOpen of LongIdent * range #endif /// Indicates the super init has just been called, 'this' may now be published - | PassAIncrClassCtorJustAfterSuperInit + | Phase2AIncrClassCtorJustAfterSuperInit /// Indicates the last 'field' has been initialized, only 'do' comes after - | PassAIncrClassCtorJustAfterLastLet + | Phase2AIncrClassCtorJustAfterLastLet /// The collected syntactic input definitions for a single type or type-extension definition - type TyconBindingsPassAGroup = TyconBindingsPassAGroup of TcEnv * TyconRef * Typar list * TType * TyconBindingsPassA list + type TyconBindingsPhase2A = + | TyconBindingsPhase2A of Tycon option * DeclKind * Val list * TyconRef * Typar list * TType * TyconBindingPhase2A list /// The collected syntactic input definitions for a recursive group of type or type-extension definitions - type TyconBindingsPassAGroups = TyconBindingsPassAGroup list + type MutRecDefnsPhase2AData = MutRecShape list /// Represents one element in a type definition, after the second phase - type TyconBindingsPassB = - | PassBIncrClassCtor of IncrClassCtorLhs * Tast.Binding option - | PassBInherit of Expr * Val option + type TyconBindingPhase2B = + | Phase2BIncrClassCtor of IncrClassCtorLhs * Tast.Binding option + | Phase2BInherit of Expr * Val option /// A set of value of function definitions in a class definition with an implicit consructor. - | PassBIncrClassBindings of IncrClassBindingGroup list - | PassBMember of int + | Phase2BIncrClassBindings of IncrClassBindingGroup list + | Phase2BMember of int /// An intermediate definition that represent the point in an implicit class definition where /// the super type has been initialized. - | PassBIncrClassCtorJustAfterSuperInit + | Phase2BIncrClassCtorJustAfterSuperInit /// An intermediate definition that represent the point in an implicit class definition where /// the last 'field' has been initialized, i.e. only 'do' and 'member' definitions come after /// this point. - | PassBIncrClassCtorJustAfterLastLet + | Phase2BIncrClassCtorJustAfterLastLet - type TyconBindingsPassBGroup = TyconBindingsPassBGroup of TyconRef * TyconBindingsPassB list + type TyconBindingsPhase2B = TyconBindingsPhase2B of Tycon option * TyconRef * TyconBindingPhase2B list - type TyconBindingsPassBGroups = TyconBindingsPassBGroup list + type MutRecDefnsPhase2BData = MutRecShape list /// Represents one element in a type definition, after the third phase - type TyconBindingsPassC = - | PassCIncrClassCtor of IncrClassCtorLhs * Tast.Binding option - | PassCInherit of Expr * Val option - | PassCIncrClassBindings of IncrClassBindingGroup list - | PassCMember of PreInitializationGraphEliminationBinding + type TyconBindingPhase2C = + | Phase2CIncrClassCtor of IncrClassCtorLhs * Tast.Binding option + | Phase2CInherit of Expr * Val option + | Phase2CIncrClassBindings of IncrClassBindingGroup list + | Phase2CMember of PreInitializationGraphEliminationBinding // Indicates the last 'field' has been initialized, only 'do' comes after - | PassCIncrClassCtorJustAfterSuperInit - | PassCIncrClassCtorJustAfterLastLet + | Phase2CIncrClassCtorJustAfterSuperInit + | Phase2CIncrClassCtorJustAfterLastLet + + type TyconBindingsPhase2C = TyconBindingsPhase2C of Tycon option * TyconRef * TyconBindingPhase2C list - type TyconBindingsPassCGroup = TyconBindingsPassCGroup of TyconRef * TyconBindingsPassC list + type MutRecDefnsPhase2CData = MutRecShape list - type TyconBindingsPassCGroups = TyconBindingsPassCGroup list - // PassA: create member prelimRecValues for "recursive" items, i.e. ctor val and member vals - // PassA: also processes their arg patterns - collecting type assertions - let TcTyconBindings_PassA_CreateRecursiveValuesAndCheckArgumentPatterns cenv envInitial tpenv (bindsl : TyconBindingDefns list) = + // Phase2A: create member prelimRecValues for "recursive" items, i.e. ctor val and member vals + // Phase2A: also processes their arg patterns - collecting type assertions + let TcMutRecBindings_Phase2A_CreateRecursiveValuesAndCheckArgumentPatterns cenv tpenv (envMutRec, mutRecDefns : MutRecDefnsPhase2Info) = // The basic iteration over the declarations in a single type definition // State: @@ -12231,37 +12608,48 @@ module TyconBindingChecking = begin // recBindIdx: index of the recursive binding // prelimRecValuesRev: accumulation of prelim value entries // uncheckedBindsRev: accumulation of unchecked bindings - let defnsAs, (tpenv,_,prelimRecValuesRev,uncheckedBindsRev) = - let initialOuterState = (tpenv, 0, ([]:Val list), ([]: PreCheckingRecursiveBinding list)) - (initialOuterState, bindsl) ||> List.mapFold (fun outerState defns -> - - let (TyconBindingDefns(tcref, declaredTyconTypars, declKind, binds)) = defns - let (tpenv,recBindIdx,prelimRecValuesRev,uncheckedBindsRev) = outerState + let (defnsAs: MutRecDefnsPhase2AData), (tpenv,_,uncheckedBindsRev) = + let initialOuterState = (tpenv, 0, ([]: PreCheckingRecursiveBinding list)) + (initialOuterState, envMutRec, mutRecDefns) |||> MutRecShapes.mapFoldWithEnv (fun outerState envForDecls defn -> + let (tpenv,recBindIdx,uncheckedBindsRev) = outerState + match defn with + | MutRecShape.Module _ -> failwith "unreachable" + | MutRecShape.Open x -> MutRecShape.Open x, outerState + | MutRecShape.ModuleAbbrev x -> MutRecShape.ModuleAbbrev x, outerState + | MutRecShape.Lets recBinds -> + let normRecDefns = + [ for (RecDefnBindingInfo(a,b,c,bind)) in recBinds do + yield NormalizedRecBindingDefn(a,b,c,BindingNormalization.NormalizeBinding ValOrMemberBinding cenv envForDecls bind) ] + let bindsAndValues,(tpenv,recBindIdx) = ((tpenv,recBindIdx), normRecDefns) ||> List.mapFold (AnalyzeAndMakeAndPublishRecursiveValue ErrorOnOverrides false cenv envForDecls) + let binds = bindsAndValues |> List.map fst |> List.concat + + let defnAs = MutRecShape.Lets binds + defnAs,(tpenv,recBindIdx,List.rev binds @ uncheckedBindsRev) + + | MutRecShape.Tycon (MutRecDefnsPhase2InfoForTycon(tyconOpt, tcref, declaredTyconTypars, declKind, binds, _)) -> // Class members can access protected members of the implemented type // Class members can access private members in the typ let isExtrinsic = (declKind = ExtrinsicExtensionBinding) - let envForTycon = MakeInnerEnvForTyconRef cenv envInitial tcref isExtrinsic + let envForTycon = MakeInnerEnvForTyconRef cenv envForDecls tcref isExtrinsic // Re-add the type constructor to make it take precedence for record label field resolutions // This does not apply to extension members: in those cases the relationship between the record labels // and the type is too extruded - let envForTycon = - if isExtrinsic then envForTycon - else AddLocalTyconRefs true cenv.g cenv.amap tcref.Range [tcref] envForTycon + let envForTycon = if isExtrinsic then envForTycon else AddLocalTyconRefs true cenv.g cenv.amap tcref.Range [tcref] envForTycon // Make fresh version of the class type for type checking the members and lets * let _,copyOfTyconTypars,_,objTy,thisTy = FreshenObjectArgType cenv tcref.Range TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars // The basic iteration over the declarations in a single type definition - let initialInnerState = (None,envForTycon,tpenv,recBindIdx,prelimRecValuesRev,uncheckedBindsRev) - let defnAs,(_,envForTycon,tpenv,recBindIdx,prelimRecValuesRev,uncheckedBindsRev) = + let initialInnerState = (None,envForTycon,tpenv,recBindIdx,uncheckedBindsRev) + let defnAs,(_,_envForTycon,tpenv,recBindIdx,uncheckedBindsRev) = (initialInnerState,binds) ||> List.collectFold (fun innerState defn -> let (TyconBindingDefn(containerInfo,newslotsOK,declKind,classMemberDef,m)) = defn - let (incrClassCtorLhsOpt,env,tpenv,recBindIdx,prelimRecValuesRev,uncheckedBindsRev) = innerState + let (incrClassCtorLhsOpt,envForTycon,tpenv,recBindIdx,uncheckedBindsRev) = innerState if tcref.IsTypeAbbrev then error(Error(FSComp.SR.tcTypeAbbreviationsMayNotHaveMembers(),(trimRangeToLine m))) // ideally we'd have the 'm' of the type declaration stored here, to avoid needing to trim to line to approx if tcref.IsEnumTycon && (declKind <> ExtrinsicExtensionBinding) then error(Error(FSComp.SR.tcEnumerationsMayNotHaveMembers(),(trimRangeToLine m))) // ideally we'd have the 'm' of the type declaration stored here, to avoid needing to trim to line to approx @@ -12271,21 +12659,21 @@ module TyconBindingChecking = begin | SynMemberDefn.ImplicitCtor (vis,attrs,spats,thisIdOpt, m), ContainerInfo(_,Some(MemberOrValContainerInfo(tcref, _, baseValOpt, safeInitInfo, _))) -> match tcref.TypeOrMeasureKind with TyparKind.Measure -> error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m)) | _ -> () - // PassA: make incrClassCtorLhs - ctorv, thisVal etc, type depends on argty(s) - let incrClassCtorLhs = TcImplictCtorLhsPassA(cenv,env,tpenv,tcref,vis,attrs,spats,thisIdOpt,baseValOpt,safeInitInfo,m,copyOfTyconTypars,objTy,thisTy) - // PassA: Add copyOfTyconTypars from incrClassCtorLhs - or from tcref - let env = AddDeclaredTypars CheckForDuplicateTypars incrClassCtorLhs.InstanceCtorDeclaredTypars env - let innerState = (Some incrClassCtorLhs, env, tpenv, recBindIdx, prelimRecValuesRev, uncheckedBindsRev) + // Phase2A: make incrClassCtorLhs - ctorv, thisVal etc, type depends on argty(s) + let incrClassCtorLhs = TcImplictCtorLhs_Phase2A(cenv,envForTycon,tpenv,tcref,vis,attrs,spats,thisIdOpt,baseValOpt,safeInitInfo,m,copyOfTyconTypars,objTy,thisTy) + // Phase2A: Add copyOfTyconTypars from incrClassCtorLhs - or from tcref + let envForTycon = AddDeclaredTypars CheckForDuplicateTypars incrClassCtorLhs.InstanceCtorDeclaredTypars envForTycon + let innerState = (Some incrClassCtorLhs, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) - [PassAIncrClassCtor incrClassCtorLhs],innerState + [Phase2AIncrClassCtor incrClassCtorLhs],innerState | SynMemberDefn.ImplicitInherit (typ,arg,_baseIdOpt,m),_ -> match tcref.TypeOrMeasureKind with TyparKind.Measure -> error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m)) | _ -> () - // PassA: inherit typ(arg) as base - pass through - // PassA: pick up baseValOpt! + // Phase2A: inherit typ(arg) as base - pass through + // Phase2A: pick up baseValOpt! let baseValOpt = incrClassCtorLhsOpt |> Option.bind (fun x -> x.InstanceCtorBaseValOpt) - let innerState = (incrClassCtorLhsOpt,env,tpenv,recBindIdx,prelimRecValuesRev,uncheckedBindsRev) - [PassAInherit (typ,arg,baseValOpt,m); PassAIncrClassCtorJustAfterSuperInit], innerState + let innerState = (incrClassCtorLhsOpt,envForTycon,tpenv,recBindIdx,uncheckedBindsRev) + [Phase2AInherit (typ,arg,baseValOpt,m); Phase2AIncrClassCtorJustAfterSuperInit], innerState @@ -12308,13 +12696,13 @@ module TyconBindingChecking = begin if isStatic && isNone incrClassCtorLhsOpt then errorR(Error(FSComp.SR.tcStaticLetBindingsRequireClassesWithImplicitConstructors(),m)) - // PassA: let-bindings - pass through - let innerState = (incrClassCtorLhsOpt,env,tpenv,recBindIdx,prelimRecValuesRev,uncheckedBindsRev) - [PassAIncrClassBindings (tcref,letBinds,isStatic,isRec,m)], innerState + // Phase2A: let-bindings - pass through + let innerState = (incrClassCtorLhsOpt,envForTycon,tpenv,recBindIdx,uncheckedBindsRev) + [Phase2AIncrClassBindings (tcref,letBinds,isStatic,isRec,m)], innerState | SynMemberDefn.Member (bind,m),_ -> - // PassA: member binding - create prelim valspec (for recursive reference) and RecursiveBindingInfo - let (NormalizedBinding(_,_,_,_,_,_,_,valSynData,_,_,_,_)) as bind = BindingNormalization.NormalizeBinding ValOrMemberBinding cenv env bind + // Phase2A: member binding - create prelim valspec (for recursive reference) and RecursiveBindingInfo + let (NormalizedBinding(_,_,_,_,_,_,_,valSynData,_,_,_,_)) as bind = BindingNormalization.NormalizeBinding ValOrMemberBinding cenv envForTycon bind let (SynValData(memberFlagsOpt,_,_)) = valSynData match tcref.TypeOrMeasureKind with | TyparKind.Type -> () @@ -12328,65 +12716,66 @@ module TyconBindingChecking = begin | _ -> () let rbind = NormalizedRecBindingDefn(containerInfo,newslotsOK,declKind,bind) let overridesOK = DeclKind.CanOverrideOrImplement(declKind) - let (binds,values),(tpenv,recBindIdx) = AnalyzeAndMakeRecursiveValue overridesOK false cenv env (tpenv,recBindIdx) rbind - let cbinds = [ for rbind in binds -> PassAMember rbind ] + let (binds,_values),(tpenv,recBindIdx) = AnalyzeAndMakeAndPublishRecursiveValue overridesOK false cenv envForTycon (tpenv,recBindIdx) rbind + let cbinds = [ for rbind in binds -> Phase2AMember rbind ] - let innerState = (incrClassCtorLhsOpt, env, tpenv, recBindIdx, List.rev values @ prelimRecValuesRev,List.rev binds @ uncheckedBindsRev) + let innerState = (incrClassCtorLhsOpt, envForTycon, tpenv, recBindIdx, List.rev binds @ uncheckedBindsRev) cbinds,innerState #if OPEN_IN_TYPE_DECLARATIONS | SynMemberDefn.Open (mp,m),_ -> let innerState = (incrClassCtorLhsOpt,env,tpenv,recBindIdx,prelimRecValuesRev,uncheckedBindsRev) - [ PassAOpen (mp,m) ], innerState + [ Phase2AOpen (mp,m) ], innerState #endif | _ -> error(InternalError("Unexpected definition",m))) - // If no constructor call, insert PassAIncrClassCtorJustAfterSuperInit at start + // If no constructor call, insert Phase2AIncrClassCtorJustAfterSuperInit at start let defnAs = match defnAs with - | (PassAIncrClassCtor _ as b1) :: rest -> + | (Phase2AIncrClassCtor _ as b1) :: rest -> let rest = - if rest |> List.exists (function PassAIncrClassCtorJustAfterSuperInit -> true | _ -> false) then + if rest |> List.exists (function Phase2AIncrClassCtorJustAfterSuperInit -> true | _ -> false) then rest else - PassAIncrClassCtorJustAfterSuperInit :: rest - // Insert PassAIncrClassCtorJustAfterLastLet at the point where local construction is known to have been finished + Phase2AIncrClassCtorJustAfterSuperInit :: rest + // Insert Phase2AIncrClassCtorJustAfterLastLet at the point where local construction is known to have been finished let rest = let isAfter b = match b with #if OPEN_IN_TYPE_DECLARATIONS - | PassAOpen _ + | Phase2AOpen _ #endif - | PassAIncrClassCtor _ | PassAInherit _ | PassAIncrClassCtorJustAfterSuperInit -> false - | PassAIncrClassBindings (_,binds,_,_,_) -> binds |> List.exists (function (Binding (_,DoBinding,_,_,_,_,_,_,_,_,_,_)) -> true | _ -> false) - | PassAIncrClassCtorJustAfterLastLet - | PassAMember _ -> true + | Phase2AIncrClassCtor _ | Phase2AInherit _ | Phase2AIncrClassCtorJustAfterSuperInit -> false + | Phase2AIncrClassBindings (_,binds,_,_,_) -> binds |> List.exists (function (Binding (_,DoBinding,_,_,_,_,_,_,_,_,_,_)) -> true | _ -> false) + | Phase2AIncrClassCtorJustAfterLastLet + | Phase2AMember _ -> true let restRev = List.rev rest - let afterRev = restRev |> Seq.takeWhile isAfter |> Seq.toList - let beforeRev = restRev |> Seq.skipWhile isAfter |> Seq.toList + let afterRev = restRev |> List.takeWhile isAfter + let beforeRev = restRev |> List.skipWhile isAfter [ yield! List.rev beforeRev - yield PassAIncrClassCtorJustAfterLastLet + yield Phase2AIncrClassCtorJustAfterLastLet yield! List.rev afterRev ] b1 :: rest // Cover the case where this is not a type with an implicit constructor. | rest -> rest - let bindingGroup = TyconBindingsPassAGroup(envForTycon,tcref,copyOfTyconTypars,thisTy,defnAs) - bindingGroup,(tpenv,recBindIdx,prelimRecValuesRev,uncheckedBindsRev)) + let prelimRecValues = [ for x in defnAs do match x with Phase2AMember bind -> yield bind.RecBindingInfo.Val | _ -> () ] + let defnAs = MutRecShape.Tycon(TyconBindingsPhase2A(tyconOpt,declKind,prelimRecValues,tcref,copyOfTyconTypars,thisTy,defnAs)) + defnAs,(tpenv,recBindIdx,uncheckedBindsRev)) - let prelimRecValues = List.rev prelimRecValuesRev let uncheckedRecBinds = List.rev uncheckedBindsRev - (defnsAs, prelimRecValues, uncheckedRecBinds, tpenv) - /// PassB: type check each of the bindings, convert from ast to tast and collects type assertions + (defnsAs, uncheckedRecBinds, tpenv) + + /// Phase2B: check each of the bindings, convert from ast to tast and collects type assertions. /// Also generalize incrementally. - let TcTyconBindings_PassB_TypeCheckAndIncrementalGeneralization cenv envInitial tpenv (ad, defnsAs:TyconBindingsPassAGroups, prelimRecValues:Val list, uncheckedRecBinds: PreCheckingRecursiveBinding list, scopem) = + let TcMutRecBindings_Phase2B_TypeCheckAndIncrementalGeneralization cenv tpenv envInitial (envMutRec, defnsAs:MutRecDefnsPhase2AData, uncheckedRecBinds: PreCheckingRecursiveBinding list, scopem) : MutRecDefnsPhase2BData * _ * _ = - let defnsBs, (tpenv, generalizedRecBinds, preGeneralizationRecBinds, _, _) = + let (defnsBs: MutRecDefnsPhase2BData), (tpenv, generalizedRecBinds, preGeneralizationRecBinds, _, _) = let uncheckedRecBindsTable = uncheckedRecBinds |> List.map (fun rbind -> rbind.RecBindingInfo.Val.Stamp, rbind) |> Map.ofList @@ -12409,18 +12798,41 @@ module TyconBindingChecking = begin let initialOuterState = (tpenv,([]: PostGeneralizationRecursiveBinding list),([]: PreGeneralizationRecursiveBinding list),uncheckedRecBindsTable,envInitial) - (initialOuterState,defnsAs) ||> List.mapFold (fun outerState defnsA -> + (initialOuterState,envMutRec,defnsAs) |||> MutRecShapes.mapFoldWithEnv (fun outerState envForDecls defnsA -> - let (TyconBindingsPassAGroup(envForTycon, tcref, copyOfTyconTypars, thisTy, defnAs)) = defnsA + let (tpenv,generalizedRecBinds,preGeneralizationRecBinds,uncheckedRecBindsTable,envNonRec) = outerState - let (tpenv,generalizedRecBinds,preGeneralizationRecBinds,uncheckedRecBindsTable,envNonRec) = outerState + match defnsA with + | MutRecShape.Module _ -> failwith "unreachable" + | MutRecShape.Open x -> MutRecShape.Open x, outerState + | MutRecShape.ModuleAbbrev x -> MutRecShape.ModuleAbbrev x, outerState + | MutRecShape.Lets binds -> - // Add prelimRecValues to env (breaks recursion) and vrec=true - let envForTycon = AddLocalVals cenv.tcSink scopem prelimRecValues envForTycon + let defnBs,(tpenv,_,envNonRec,generalizedRecBinds,preGeneralizationRecBinds,uncheckedRecBindsTable) = + + let initialInnerState = (tpenv,envForDecls,envNonRec,generalizedRecBinds,preGeneralizationRecBinds,uncheckedRecBindsTable) + (initialInnerState,binds) ||> List.mapFold (fun innerState rbind -> + + let (tpenv,envStatic,envNonRec,generalizedRecBinds,preGeneralizationRecBinds,uncheckedRecBindsTable) = innerState + + let (envNonRec, generalizedRecBinds, preGeneralizationRecBinds, _, uncheckedRecBindsTable) = TcLetrecBinding (cenv,envStatic,scopem,[],None) (envNonRec, generalizedRecBinds, preGeneralizationRecBinds, tpenv, uncheckedRecBindsTable) rbind + + let innerState = (tpenv, envStatic, envNonRec, generalizedRecBinds, preGeneralizationRecBinds, uncheckedRecBindsTable) + rbind.RecBindingInfo.Index, innerState) + + let outerState = (tpenv, generalizedRecBinds, preGeneralizationRecBinds, uncheckedRecBindsTable, envNonRec) + MutRecShape.Lets defnBs, outerState + + | MutRecShape.Tycon (TyconBindingsPhase2A(tyconOpt, declKind, _, tcref, copyOfTyconTypars, thisTy, defnAs)) -> + let isExtrinsic = (declKind = ExtrinsicExtensionBinding) + let envForTycon = MakeInnerEnvForTyconRef cenv envForDecls tcref isExtrinsic + let envForTycon = if isExtrinsic then envForTycon else AddLocalTyconRefs true cenv.g cenv.amap tcref.Range [tcref] envForTycon // Set up the environment so use-before-definition warnings are given, at least - // until we reach a PassAIncrClassCtorJustAfterSuperInit. + // until we reach a Phase2AIncrClassCtorJustAfterSuperInit. let envForTycon = { envForTycon with eCtorInfo = Some (InitialImplicitCtorInfo()) } + + let reqdThisValTyOpt = Some thisTy // Loop through the definition elements in a type... // State: @@ -12438,10 +12850,12 @@ module TyconBindingChecking = begin let (tpenv,envInstance,envStatic,envNonRec,generalizedRecBinds,preGeneralizationRecBinds,uncheckedRecBindsTable) = innerState match defnA with - // PassB for the definition of an implicit constructor. Enrich the instance environments + // Phase2B for the definition of an implicit constructor. Enrich the instance environments // with the implicit ctor args. - | PassAIncrClassCtor incrClassCtorLhs -> + | Phase2AIncrClassCtor incrClassCtorLhs -> + let envInstance = AddDeclaredTypars CheckForDuplicateTypars incrClassCtorLhs.InstanceCtorDeclaredTypars envInstance + let envStatic = AddDeclaredTypars CheckForDuplicateTypars incrClassCtorLhs.InstanceCtorDeclaredTypars envStatic let envInstance = match incrClassCtorLhs.InstanceCtorSafeThisValOpt with Some v -> AddLocalVal cenv.tcSink scopem v envInstance | None -> envInstance let envInstance = List.foldBack AddLocalValPrimitive incrClassCtorLhs.InstanceCtorArgs envInstance let envNonRec = match incrClassCtorLhs.InstanceCtorSafeThisValOpt with Some v -> AddLocalVal cenv.tcSink scopem v envNonRec | None -> envNonRec @@ -12449,32 +12863,32 @@ module TyconBindingChecking = begin let safeThisValBindOpt = TcLetrecComputeCtorSafeThisValBind cenv incrClassCtorLhs.InstanceCtorSafeThisValOpt let innerState = (tpenv,envInstance,envStatic,envNonRec,generalizedRecBinds,preGeneralizationRecBinds,uncheckedRecBindsTable) - PassBIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt), innerState + Phase2BIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt), innerState - // PassB: typecheck the argument to an 'inherits' call and build the new object expr for the inherit-call - | PassAInherit (synBaseTy,arg,baseValOpt,m) -> + // Phase2B: typecheck the argument to an 'inherits' call and build the new object expr for the inherit-call + | Phase2AInherit (synBaseTy,arg,baseValOpt,m) -> let baseTy,tpenv = TcType cenv NoNewTypars CheckCxs ItemOccurence.Use envInstance tpenv synBaseTy let inheritsExpr,tpenv = TcNewExpr cenv envInstance tpenv baseTy (Some synBaseTy.Range) true arg m let envInstance = match baseValOpt with Some baseVal -> AddLocalVal cenv.tcSink scopem baseVal envInstance | None -> envInstance let envNonRec = match baseValOpt with Some baseVal -> AddLocalVal cenv.tcSink scopem baseVal envNonRec | None -> envNonRec let innerState = (tpenv,envInstance,envStatic,envNonRec,generalizedRecBinds,preGeneralizationRecBinds,uncheckedRecBindsTable) - PassBInherit (inheritsExpr,baseValOpt), innerState + Phase2BInherit (inheritsExpr,baseValOpt), innerState - // PassB: let and let rec value and function definitions - | PassAIncrClassBindings (tcref,binds,isStatic,isRec,bindsm) -> + // Phase2B: let and let rec value and function definitions + | Phase2AIncrClassBindings (tcref,binds,isStatic,isRec,bindsm) -> let envForBinding = if isStatic then envStatic else envInstance let binds,bindRs,env,tpenv = if isRec then // Type check local recursive binding - let binds = binds |> List.map (fun bind -> RecBindingDefn(ExprContainerInfo,NoNewSlots,ClassLetBinding,bind)) + let binds = binds |> List.map (fun bind -> RecDefnBindingInfo(ExprContainerInfo,NoNewSlots,ClassLetBinding(isStatic),bind)) let binds,env,tpenv = TcLetrec ErrorOnOverrides cenv envForBinding tpenv (binds,scopem(*bindsm*),scopem) let bindRs = [IncrClassBindingGroup(binds,isStatic,true)] binds,bindRs,env,tpenv else // Type check local binding - let binds,env,tpenv = TcLetBindings cenv envForBinding ExprContainerInfo ClassLetBinding tpenv (binds,bindsm,scopem) + let binds,env,tpenv = TcLetBindings cenv envForBinding ExprContainerInfo (ClassLetBinding(isStatic)) tpenv (binds,bindsm,scopem) let binds,bindRs = binds |> List.map (function @@ -12494,6 +12908,7 @@ module TyconBindingChecking = begin let nm = bind.Var.DisplayName let ty = generalizedTyconRef tcref + let ad = envNonRec.eAccessRights match TryFindIntrinsicMethInfo cenv.infoReader bind.Var.Range ad nm ty, TryFindPropInfo cenv.infoReader bind.Var.Range ad nm ty with | [],[] -> () @@ -12503,31 +12918,31 @@ module TyconBindingChecking = begin let envInstance = (if isStatic then (binds,envInstance) ||> List.foldBack (fun b e -> AddLocalVal cenv.tcSink scopem b.Var e) else env) let envStatic = (if isStatic then env else envStatic) let innerState = (tpenv, envInstance, envStatic, envNonRec, generalizedRecBinds, preGeneralizationRecBinds, uncheckedRecBindsTable) - PassBIncrClassBindings bindRs,innerState + Phase2BIncrClassBindings bindRs,innerState - | PassAIncrClassCtorJustAfterSuperInit -> + | Phase2AIncrClassCtorJustAfterSuperInit -> let innerState = (tpenv, envInstance, envStatic, envNonRec, generalizedRecBinds, preGeneralizationRecBinds, uncheckedRecBindsTable) - PassBIncrClassCtorJustAfterSuperInit, innerState + Phase2BIncrClassCtorJustAfterSuperInit, innerState - | PassAIncrClassCtorJustAfterLastLet -> + | Phase2AIncrClassCtorJustAfterLastLet -> let innerState = (tpenv, envInstance, envStatic, envNonRec, generalizedRecBinds, preGeneralizationRecBinds, uncheckedRecBindsTable) - PassBIncrClassCtorJustAfterLastLet , innerState + Phase2BIncrClassCtorJustAfterLastLet , innerState #if OPEN_IN_TYPE_DECLARATIONS - | PassAOpen(mp,m) -> + | Phase2AOpen(mp,m) -> let envInstance = TcOpenDecl cenv.tcSink cenv.g cenv.amap m scopem envInstance mp let envStatic = TcOpenDecl cenv.tcSink cenv.g cenv.amap m scopem envStatic mp let innerState = (tpenv, envInstance, envStatic, envNonRec, generalizedRecBinds, preGeneralizationRecBinds, uncheckedRecBindsTable) - PassBOpen,innerState + Phase2BOpen,innerState #endif // Note: this path doesn't add anything the environment, because the member is already available off via its type - | PassAMember rbind -> + | Phase2AMember rbind -> - // PassB: Typecheck member binding, generalize them later, when all type constraints are known + // Phase2B: Typecheck member binding, generalize them later, when all type constraints are known // static members are checked under envStatic. // envStatic contains class typars and the (ungeneralized) members on the class(es). // envStatic has no instance-variables (local let-bindings or ctor args). @@ -12544,7 +12959,6 @@ module TyconBindingChecking = begin // for the class to be identical to those used for the implicit class constructor and the static class constructor. // // See TcLetrecBinding where this information is consumed. - let reqdThisValTyOpt = Some thisTy // Type check the member and apply early generalization. // We ignore the tpenv returned by checking each member. Each member gets checked in a fresh, clean tpenv @@ -12552,11 +12966,11 @@ module TyconBindingChecking = begin TcLetrecBinding (cenv,envForBinding,scopem,extraGeneralizableTypars,reqdThisValTyOpt) (envNonRec, generalizedRecBinds, preGeneralizationRecBinds, tpenv, uncheckedRecBindsTable) rbind let innerState = (tpenv, envInstance, envStatic, envNonRec, generalizedRecBinds, preGeneralizationRecBinds, uncheckedRecBindsTable) - PassBMember rbind.RecBindingInfo.Index, innerState) + Phase2BMember rbind.RecBindingInfo.Index, innerState) - let resultGroup = TyconBindingsPassBGroup(tcref, defnBs) + let defnBs = MutRecShape.Tycon (TyconBindingsPhase2B(tyconOpt, tcref, defnBs)) let outerState = (tpenv, generalizedRecBinds, preGeneralizationRecBinds, uncheckedRecBindsTable, envNonRec) - resultGroup, outerState) + defnBs, outerState) // There should be no bindings that have not been generalized since checking the vary last binding always // results in the generalization of all remaining ungeneralized bindings, since there are no remaining unchecked bindings @@ -12568,60 +12982,63 @@ module TyconBindingChecking = begin // Choose type scheme implicit constructors and adjust their recursive types. // Fixup recursive references to members. - let TcTyconBindings_PassC_FixupRecursiveReferences cenv (envInitial:TcEnv) tpenv (denv, defnsBs: TyconBindingsPassBGroups, generalizedTyparsForRecursiveBlock: Typar list, generalizedRecBinds: PostGeneralizationRecursiveBinding list, scopem) = + let TcMutRecBindings_Phase2C_FixupRecursiveReferences cenv (denv, defnsBs: MutRecDefnsPhase2BData, generalizedTyparsForRecursiveBlock: Typar list, generalizedRecBinds: PostGeneralizationRecursiveBinding list, scopem) = // Build an index ---> binding map let generalizedBindingsMap = generalizedRecBinds |> List.map (fun pgrbind -> (pgrbind.RecBindingInfo.Index, pgrbind)) |> Map.ofList - let defnsCs,tpenv = - (tpenv, defnsBs) ||> List.mapFold (fun tpenv defnsB -> - let (TyconBindingsPassBGroup(tcref, defnBs)) = defnsB + defnsBs |> MutRecShapes.mapTyconsAndLets + + // Phase2C: Fixup member bindings + (fun (TyconBindingsPhase2B(tyconOpt, tcref, defnBs)) -> - let defnCs, tpenv = - (tpenv,defnBs) ||> List.mapFold (fun tpenv defnB -> + let defnCs = + defnBs |> List.map (fun defnB -> - // PassC: Generalise implicit ctor val + // Phase2C: Generalise implicit ctor val match defnB with - | PassBIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt) -> + | Phase2BIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt) -> let valscheme = incrClassCtorLhs.InstanceCtorValScheme let valscheme = ChooseCanonicalValSchemeAfterInference cenv.g denv valscheme scopem AdjustRecType cenv incrClassCtorLhs.InstanceCtorVal valscheme - PassCIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt),tpenv + Phase2CIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt) - | PassBInherit (inheritsExpr,basevOpt) -> - PassCInherit (inheritsExpr,basevOpt),tpenv + | Phase2BInherit (inheritsExpr,basevOpt) -> + Phase2CInherit (inheritsExpr,basevOpt) - | PassBIncrClassBindings bindRs -> - PassCIncrClassBindings bindRs,tpenv + | Phase2BIncrClassBindings bindRs -> + Phase2CIncrClassBindings bindRs - | PassBIncrClassCtorJustAfterSuperInit -> - PassCIncrClassCtorJustAfterSuperInit, tpenv + | Phase2BIncrClassCtorJustAfterSuperInit -> + Phase2CIncrClassCtorJustAfterSuperInit - | PassBIncrClassCtorJustAfterLastLet -> - PassCIncrClassCtorJustAfterLastLet, tpenv + | Phase2BIncrClassCtorJustAfterLastLet -> + Phase2CIncrClassCtorJustAfterLastLet - | PassBMember idx -> - // PassC: Fixup member bindings + | Phase2BMember idx -> + // Phase2C: Fixup member bindings let generalizedBinding = generalizedBindingsMap.[idx] let vxbind = TcLetrecAdjustMemberForSpecialVals cenv generalizedBinding - let pgbrind = FixupLetrecBind cenv envInitial.DisplayEnv generalizedTyparsForRecursiveBlock vxbind - PassCMember pgbrind, tpenv) - let group = TyconBindingsPassCGroup(tcref,defnCs) - group, tpenv) - (defnsCs,tpenv) + let pgbrind = FixupLetrecBind cenv denv generalizedTyparsForRecursiveBlock vxbind + Phase2CMember pgbrind) + TyconBindingsPhase2C(tyconOpt, tcref, defnCs)) + + // Phase2C: Fixup let bindings + (fun bindIdxs -> + [ for idx in bindIdxs do + let generalizedBinding = generalizedBindingsMap.[idx] + let vxbind = TcLetrecAdjustMemberForSpecialVals cenv generalizedBinding + yield FixupLetrecBind cenv denv generalizedTyparsForRecursiveBlock vxbind ]) // --- Extract field bindings from let-bindings // --- Extract method bindings from let-bindings // --- Extract bindings for implicit constructors - let TcTyconBindings_ExtractImplicitFieldAndMethodBindings cenv envInitial tpenv (denv, generalizedTyparsForRecursiveBlock, defnsCs) = + let TcMutRecBindings_Phase2D_ExtractImplicitFieldAndMethodBindings cenv envMutRec tpenv (denv, generalizedTyparsForRecursiveBlock, defnsCs: MutRecDefnsPhase2CData) = - let (fixupValueExprBinds, methodBinds) = - defnsCs |> List.map (fun (TyconBindingsPassCGroup(tcref,defnCs)) -> + // let (fixupValueExprBinds, methodBinds) = + (envMutRec, defnsCs) ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls (TyconBindingsPhase2C(tyconOpt, tcref,defnCs)) -> match defnCs with - - - | PassCIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt) :: defnCs -> - + | Phase2CIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt) :: defnCs -> // Determine is static fields in this type need to be "protected" against invalid recursive initialization let safeStaticInitInfo = @@ -12648,16 +13065,15 @@ module TyconBindingChecking = begin // We only need safe static init checks if there are some static field bindings (actually, we look for non-method bindings) let hasStaticBindings = defnCs |> List.exists (function - | PassCIncrClassBindings groups -> + | Phase2CIncrClassBindings groups -> groups |> List.exists (function - | IncrClassBindingGroup(binds,isStatic,_) -> - let nonMethodBinds = binds |> List.filter (IncrClassReprInfo.IsMethodRepr cenv >> not) - isStatic && not nonMethodBinds.IsEmpty + | IncrClassBindingGroup(binds,isStatic,_) -> + isStatic && (binds |> List.exists (IncrClassReprInfo.IsMethodRepr cenv >> not)) | _ -> false) | _ -> false) - if needsSafeStaticInit && hasStaticBindings then - let rfield = MakeSafeInitField cenv.g envInitial tcref.Range true + if needsSafeStaticInit && hasStaticBindings then + let rfield = MakeSafeInitField cenv.g envForDecls tcref.Range true SafeInitField(mkRecdFieldRef tcref rfield.Name, rfield) else NoSafeInitInfo @@ -12668,35 +13084,35 @@ module TyconBindingChecking = begin // Assumes inherit call immediately follows implicit ctor. Checked by CheckMembersForm let inheritsExpr,inheritsIsVisible,_,defnCs = - match defnCs |> List.partition (function PassCInherit _ -> true | _ -> false) with - | [PassCInherit (inheritsExpr,baseValOpt)], defnCs -> + match defnCs |> List.partition (function Phase2CInherit _ -> true | _ -> false) with + | [Phase2CInherit (inheritsExpr,baseValOpt)], defnCs -> inheritsExpr,true,baseValOpt,defnCs | _ -> if tcref.IsStructOrEnumTycon then mkUnit cenv.g tcref.Range, false,None, defnCs else - let inheritsExpr,_ = TcNewExpr cenv envInitial tpenv cenv.g.obj_ty None true (SynExpr.Const(SynConst.Unit,tcref.Range)) tcref.Range + let inheritsExpr,_ = TcNewExpr cenv envForDecls tpenv cenv.g.obj_ty None true (SynExpr.Const(SynConst.Unit,tcref.Range)) tcref.Range inheritsExpr,false,None,defnCs - let envForTycon = MakeInnerEnvForTyconRef cenv envInitial tcref false + let envForTycon = MakeInnerEnvForTyconRef cenv envForDecls tcref false // Compute the cpath used when creating the hidden fields let cpath = envForTycon.eAccessPath let localDecs = defnCs |> List.filter (function - | PassCIncrClassBindings _ - | PassCIncrClassCtorJustAfterSuperInit - | PassCIncrClassCtorJustAfterLastLet -> true + | Phase2CIncrClassBindings _ + | Phase2CIncrClassCtorJustAfterSuperInit + | Phase2CIncrClassCtorJustAfterLastLet -> true | _ -> false) - let memberBindsWithFixups = defnCs |> List.choose (function PassCMember pgrbind -> Some pgrbind | _ -> None) + let memberBindsWithFixups = defnCs |> List.choose (function Phase2CMember pgrbind -> Some pgrbind | _ -> None) // Extend localDecs with "let safeThisVal = ref null" if there is a safeThisVal let localDecs = match safeThisValBindOpt with | None -> localDecs - | Some bind -> PassCIncrClassBindings [IncrClassBindingGroup([bind],false,false)] :: localDecs + | Some bind -> Phase2CIncrClassBindings [IncrClassBindingGroup([bind],false,false)] :: localDecs // Carve out the initialization sequence and decide on the localRep let ctorBodyLambdaExpr,cctorBodyLambdaExprOpt,methodBinds,localReps = @@ -12704,19 +13120,19 @@ module TyconBindingChecking = begin let localDecs = [ for localDec in localDecs do match localDec with - | PassCIncrClassBindings(binds) -> yield PassCBindings binds - | PassCIncrClassCtorJustAfterSuperInit -> yield PassCCtorJustAfterSuperInit - | PassCIncrClassCtorJustAfterLastLet -> yield PassCCtorJustAfterLastLet + | Phase2CIncrClassBindings(binds) -> yield Phase2CBindings binds + | Phase2CIncrClassCtorJustAfterSuperInit -> yield Phase2CCtorJustAfterSuperInit + | Phase2CIncrClassCtorJustAfterLastLet -> yield Phase2CCtorJustAfterLastLet | _ -> () ] let memberBinds = memberBindsWithFixups |> List.map (fun x -> x.Binding) - MakeCtorForIncrClassConstructionPassC(cenv,envForTycon,tpenv,incrClassCtorLhs,inheritsExpr,inheritsIsVisible,localDecs,memberBinds,generalizedTyparsForRecursiveBlock,safeStaticInitInfo) + MakeCtorForIncrClassConstructionPhase2C(cenv,envForTycon,incrClassCtorLhs,inheritsExpr,inheritsIsVisible,localDecs,memberBinds,generalizedTyparsForRecursiveBlock,safeStaticInitInfo) // Generate the (value,expr) pairs for the implicit // object constructor and implicit static initializer let ctorValueExprBindings = [ (let ctorValueExprBinding = TBind(incrClassCtorLhs.InstanceCtorVal,ctorBodyLambdaExpr,NoSequencePointAtStickyBinding) let rbind = { ValScheme = incrClassCtorLhs.InstanceCtorValScheme ; Binding = ctorValueExprBinding } - FixupLetrecBind cenv envInitial.DisplayEnv generalizedTyparsForRecursiveBlock rbind) ] + FixupLetrecBind cenv envForDecls.DisplayEnv generalizedTyparsForRecursiveBlock rbind) ] @ ( match cctorBodyLambdaExprOpt with | None -> [] @@ -12724,7 +13140,7 @@ module TyconBindingChecking = begin [ (let _,cctorVal, cctorValScheme = incrClassCtorLhs.StaticCtorValInfo.Force() let cctorValueExprBinding = TBind(cctorVal,cctorBodyLambdaExpr,NoSequencePointAtStickyBinding) let rbind = { ValScheme = cctorValScheme; Binding = cctorValueExprBinding } - FixupLetrecBind cenv envInitial.DisplayEnv generalizedTyparsForRecursiveBlock rbind) ] ) + FixupLetrecBind cenv envForDecls.DisplayEnv generalizedTyparsForRecursiveBlock rbind) ] ) // Publish the fields of the representation to the type localReps.PublishIncrClassFields (cenv, denv, cpath, incrClassCtorLhs, safeStaticInitInfo) (* mutation *) @@ -12742,47 +13158,141 @@ module TyconBindingChecking = begin // Members have at least as many type parameters as the enclosing class. Just grab the type variables for the type. let thisTyInst = List.map mkTyparTy (List.take (tcref.Typars(v.Range).Length) v.Typars) - let x = localReps.FixupIncrClassExprPassC thisValOpt safeStaticInitInfo thisTyInst x + let x = localReps.FixupIncrClassExprPhase2C thisValOpt safeStaticInitInfo thisTyInst x { pgrbind with Binding = TBind(v,x,spBind) } ) - ctorValueExprBindings @ memberBindsWithFixups, methodBinds + tyconOpt, ctorValueExprBindings @ memberBindsWithFixups, methodBinds // Cover the case where this is not a class with an implicit constructor | defnCs -> - let memberBindsWithFixups = defnCs |> List.choose (function PassCMember pgrbind -> Some pgrbind | _ -> None) - memberBindsWithFixups,[]) - |> List.unzip - let fixupValueExprBinds = List.concat fixupValueExprBinds - let methodBinds = List.concat methodBinds - (fixupValueExprBinds, methodBinds) + let memberBindsWithFixups = defnCs |> List.choose (function Phase2CMember pgrbind -> Some pgrbind | _ -> None) + tyconOpt, memberBindsWithFixups,[]) + + /// Check a "module X = A.B.C" module abbreviation declaration + let TcModuleAbbrevDecl (cenv:cenv) scopem env (id,p,m) = + let ad = env.eAccessRights + let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace cenv.amap m OpenQualified env.eNameResEnv ad p) + let modrefs = mvvs |> List.map p23 + if modrefs.Length > 0 && modrefs |> List.forall (fun modref -> modref.IsNamespace) then + errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head modrefs)),m)) + let modrefs = modrefs |> List.filter (fun mvv -> not mvv.IsNamespace) + modrefs |> List.iter (fun modref -> CheckEntityAttributes cenv.g modref m |> CommitOperationResult) + let env = (if modrefs.Length > 0 then AddModuleAbbreviationAndReport cenv.tcSink scopem id modrefs env else env) + env + + + /// Update the contents accessible via the recursive namespace declaration, if any + let TcMutRecDefns_UpdateNSContents mutRecNSInfo = + match mutRecNSInfo with + | Some (Some (mspecNS: ModuleOrNamespace), mtypeAcc) -> + mspecNS.Data.entity_modul_contents <- notlazy !mtypeAcc + | _ -> () + /// Updates the types of the modules to contain the contents so far + let TcMutRecDefns_UpdateModuleContents mutRecNSInfo defns = + defns |> MutRecShapes.iterModules (fun (MutRecDefnsPhase2DataForModule (mtypeAcc, mspec), _) -> + mspec.Data.entity_modul_contents <- notlazy !mtypeAcc) - /// Main routine - let TcTyconBindings cenv (env: TcEnv) tpenv bindsm scopem (bindsl : TyconBindingDefns list) = + TcMutRecDefns_UpdateNSContents mutRecNSInfo + + /// Compute the active environments within each nested module. + let TcMutRecDefns_ComputeEnvs getTyconOpt getVals (cenv: cenv) report scopem m envInitial mutRecShape = + (envInitial, mutRecShape) ||> MutRecShapes.computeEnvs + (fun envAbove (MutRecDefnsPhase2DataForModule (mtypeAcc, mspec)) -> MakeInnerEnvWithAcc envAbove mspec.Id mtypeAcc mspec.ModuleOrNamespaceType.ModuleOrNamespaceKind) + (fun envAbove decls -> + + // Collect the type definitions, exception definitions, modules and "open" declarations + let tycons = decls |> List.choose (function MutRecShape.Tycon d -> getTyconOpt d | _ -> None) + let mspecs = decls |> List.choose (function MutRecShape.Module (MutRecDefnsPhase2DataForModule (_, mspec),_) -> Some mspec | _ -> None) + let moduleAbbrevs = decls |> List.choose (function MutRecShape.ModuleAbbrev (MutRecDataForModuleAbbrev (id,mp,m)) -> Some (id,mp,m) | _ -> None) + let opens = decls |> List.choose (function MutRecShape.Open (MutRecDataForOpen (mp,m)) -> Some (mp,m) | _ -> None) + let lets = decls |> List.collect (function MutRecShape.Lets binds -> getVals binds | _ -> []) + let exns = tycons |> List.filter (fun (tycon:Tycon) -> tycon.IsExceptionDecl) + + // Add the type definitions, exceptions, modules and "open" declarations. + // The order here is sensitive. The things added first will be resolved in an environment + // where not everything has been added. The things added last will be preferred in name + // resolution. + // + // 'open' declarations ('open M') may refer to modules being defined ('M') and so must be + // processed in an environment where 'M' is present. However, in later processing the names of + // modules being defined ('M') take precedence over those coming from 'open' declarations. + // So add the names of the modules being defined to the environment twice - once to allow + // the processing of 'open M', and once to allow the correct name resolution of 'M'. + // + // Module abbreviations being defined ('module M = A.B.C') are not available for use in 'open' + // declarations. So + // namespace rec N = + // open M + // module M = FSharp.Core.Operators + // is not allowed. + + let envForDecls = envAbove + // Add the modules being defined + let envForDecls = (envForDecls, mspecs) ||> List.fold ((if report then AddLocalSubModuleAndReport cenv.tcSink scopem else AddLocalSubModule) cenv.g cenv.amap m) + // Process the 'open' declarations + let envForDecls = (envForDecls, opens) ||> List.fold (fun env (mp,m) -> TcOpenDecl cenv.tcSink cenv.g cenv.amap m scopem env mp) + // Add the type definitions being defined + let envForDecls = (if report then AddLocalTyconsAndReport cenv.tcSink scopem else AddLocalTycons) cenv.g cenv.amap m tycons envForDecls + // Add the exception definitions being defined + let envForDecls = (envForDecls, exns) ||> List.fold (AddLocalExnDefnAndReport cenv.tcSink scopem) + // Add the modules again (but don't report them a second time) + let envForDecls = (envForDecls, mspecs) ||> List.fold (AddLocalSubModule cenv.g cenv.amap m) + // Add the module abbreviations + let envForDecls = (envForDecls, moduleAbbrevs) ||> List.fold (TcModuleAbbrevDecl cenv scopem) + // Add the values and members + let envForDecls = AddLocalVals cenv.tcSink scopem lets envForDecls + envForDecls) + + /// Phase 2: Check the members and 'let' definitions in a mutually recursive group of definitions. + let TcMutRecDefns_Phase2_Bindings cenv envInitial tpenv bindsm scopem mutRecNSInfo (envMutRecPrelimWithReprs: TcEnv) (mutRecDefns: MutRecDefnsPhase2Info) = let g = cenv.g - let ad = env.eAccessRights - let denv = env.DisplayEnv - let envInitial = env - let env = () // hide this to make sure it is not used inadvertently - env |> ignore // mark it as used + let denv = envMutRecPrelimWithReprs.DisplayEnv - let tcrefsWithCSharpExtensionMembers = - bindsl |> List.choose (fun (TyconBindingDefns(tcref, _, declKind, _)) -> - if TyconRefHasAttribute g scopem g.attrib_ExtensionAttribute tcref && (declKind <> DeclKind.ExtrinsicExtensionBinding) then - Some tcref - else - None) + // Phase2A: create member prelimRecValues for "recursive" items, i.e. ctor val and member vals + // Phase2A: also processes their arg patterns - collecting type assertions + let (defnsAs, uncheckedRecBinds, tpenv) = TcMutRecBindings_Phase2A_CreateRecursiveValuesAndCheckArgumentPatterns cenv tpenv (envMutRecPrelimWithReprs, mutRecDefns) + + // Now basic member values are created we can compute the final attributes (i.e. in the case where attributes refer to constructors being defined) + mutRecDefns |> MutRecShapes.iterTycons (fun (MutRecDefnsPhase2InfoForTycon(_, _, _, _, _, fixupFinalAttrs)) -> + fixupFinalAttrs()) + + // Updates the types of the modules to contain the contents so far, which now includes values and members + TcMutRecDefns_UpdateModuleContents mutRecNSInfo defnsAs + + // Updates the environments to include the values + // We must open all modules from scratch again because there may be extension methods and/or AutoOpen + let envMutRec, defnsAs = + (envInitial, MutRecShapes.dropEnvs defnsAs) + ||> TcMutRecDefns_ComputeEnvs + (fun (TyconBindingsPhase2A(tyconOpt,_,_,_,_,_,_)) -> tyconOpt) + (fun binds -> [ for bind in binds -> bind.RecBindingInfo.Val ]) + cenv false scopem scopem + ||> MutRecShapes.extendEnvs (fun envForDecls decls -> + + let prelimRecValues = + decls |> List.collect (function + | MutRecShape.Tycon (TyconBindingsPhase2A(_,_,prelimRecValues,_,_,_,_)) -> prelimRecValues + | MutRecShape.Lets binds -> [ for bind in binds -> bind.RecBindingInfo.Val ] + | _ -> []) + + let ctorVals = + decls |> MutRecShapes.topTycons |> List.collect (fun (TyconBindingsPhase2A(_, _, _, _, _, _, defnAs)) -> + [ for defnB in defnAs do + match defnB with + | Phase2AIncrClassCtor (incrClassCtorLhs) -> yield incrClassCtorLhs.InstanceCtorVal + | _ -> () ]) - // Re-add the any tycons to get any C#-style extension members - let envInternal = AddLocalTyconRefs true g cenv.amap scopem tcrefsWithCSharpExtensionMembers envInitial + let envForDeclsUpdated = + envForDecls + |> AddLocalVals cenv.tcSink scopem prelimRecValues + |> AddLocalVals cenv.tcSink scopem ctorVals - // PassA: create member prelimRecValues for "recursive" items, i.e. ctor val and member vals - // PassA: also processes their arg patterns - collecting type assertions - let (defnsAs, prelimRecValues, uncheckedRecBinds, tpenv) = TcTyconBindings_PassA_CreateRecursiveValuesAndCheckArgumentPatterns cenv envInternal tpenv bindsl + envForDeclsUpdated) - // PassB: type check pass, convert from ast to tast and collects type assertions, and generalize - let defnsBs, generalizedRecBinds, tpenv = TcTyconBindings_PassB_TypeCheckAndIncrementalGeneralization cenv envInternal tpenv (ad, defnsAs, prelimRecValues, uncheckedRecBinds, scopem) + // Phase2B: type check pass, convert from ast to tast and collects type assertions, and generalize + let defnsBs, generalizedRecBinds, tpenv = TcMutRecBindings_Phase2B_TypeCheckAndIncrementalGeneralization cenv tpenv envInitial (envMutRec, defnsAs, uncheckedRecBinds, scopem) let generalizedTyparsForRecursiveBlock = @@ -12793,14 +13303,12 @@ module TyconBindingChecking = begin // Check the escape condition for all extraGeneralizableTypars. // First collect up all the extraGeneralizableTypars. let allExtraGeneralizableTypars = - [ for (TyconBindingsPassAGroup(_, _, copyOfTyconTypars, _, defnAs)) in defnsAs do - yield! copyOfTyconTypars + defnsAs |> MutRecShapes.collectTycons |> List.collect (fun (TyconBindingsPhase2A(_, _, _, _, copyOfTyconTypars, _, defnAs)) -> + [ yield! copyOfTyconTypars for defnA in defnAs do match defnA with - | PassAMember rbind -> - yield! rbind.RecBindingInfo.EnclosingDeclaredTypars - | _ -> - () ] + | Phase2AMember rbind -> yield! rbind.RecBindingInfo.EnclosingDeclaredTypars + | _ -> () ]) // Now check they don't escape the overall scope of the recursive set of types if nonNil allExtraGeneralizableTypars then @@ -12821,16 +13329,16 @@ module TyconBindingChecking = begin let allTypes = [ for pgrbind in generalizedRecBinds do yield pgrbind.RecBindingInfo.Val.Type - for (TyconBindingsPassBGroup(_tcref, defnBs)) in defnsBs do + for (TyconBindingsPhase2B(_tyconOpt, _tcref, defnBs)) in MutRecShapes.collectTycons defnsBs do for defnB in defnBs do match defnB with - | PassBIncrClassCtor (incrClassCtorLhs, _) -> + | Phase2BIncrClassCtor (incrClassCtorLhs, _) -> yield incrClassCtorLhs.InstanceCtorVal.Type | _ -> () ] //printfn "allTypes.Length = %d" allTypes.Length - let unsolvedTypars = freeInTypesLeftToRight cenv.g true allTypes + let unsolvedTypars = freeInTypesLeftToRight g true allTypes //printfn "unsolvedTypars.Length = %d" unsolvedTypars.Length //for x in unsolvedTypars do // printfn "unsolvedTypar : %s #%d" x.DisplayName x.Stamp @@ -12852,40 +13360,28 @@ module TyconBindingChecking = begin ConstraintSolver.ChooseTyparSolutionAndSolve cenv.css denv tp // Now that we know what we've generalized we can adjust the recursive references - let defnsCs,tpenv = TcTyconBindings_PassC_FixupRecursiveReferences cenv envInitial tpenv (denv, defnsBs, generalizedTyparsForRecursiveBlock, generalizedRecBinds, scopem) + let defnsCs = TcMutRecBindings_Phase2C_FixupRecursiveReferences cenv (denv, defnsBs, generalizedTyparsForRecursiveBlock, generalizedRecBinds, scopem) // --- Extract field bindings from let-bindings // --- Extract method bindings from let-bindings // --- Extract bindings for implicit constructors - let fixupValueExprBinds, methodBinds = TcTyconBindings_ExtractImplicitFieldAndMethodBindings cenv envInitial tpenv (denv, generalizedTyparsForRecursiveBlock, defnsCs) + let defnsDs = TcMutRecBindings_Phase2D_ExtractImplicitFieldAndMethodBindings cenv envMutRec tpenv (denv, generalizedTyparsForRecursiveBlock, defnsCs) - // INITIALIZATION GRAPHS - let binds = EliminateInitializationGraphs cenv.g true envInitial.DisplayEnv fixupValueExprBinds bindsm - - let binds = binds @ methodBinds + // Phase2E - rewrite values to initialization graphs + let defnsEs = + EliminateInitializationGraphs + p23 + (fun morpher (tyconOpt,fixupValueExprBinds,methodBinds) -> (tyconOpt, morpher fixupValueExprBinds @ methodBinds)) + id + (fun morpher oldBinds -> morpher oldBinds) + g true denv defnsDs bindsm - // Post letrec env - let envFinal = AddLocalTyconRefs false g cenv.amap scopem tcrefsWithCSharpExtensionMembers envInitial - let envFinal = AddLocalVals cenv.tcSink scopem prelimRecValues envFinal - let envFinal = - let ctorVals = - [ for (TyconBindingsPassBGroup(_tcref, defnBs)) in defnsBs do - for defnB in defnBs do - match defnB with - | PassBIncrClassCtor (incrClassCtorLhs, _) -> yield incrClassCtorLhs.InstanceCtorVal - | _ -> () ] - AddLocalVals cenv.tcSink scopem ctorVals envFinal + defnsEs,envMutRec - binds,envFinal,tpenv - -end - -//------------------------------------------------------------------------- -// The member portions of class defns -//------------------------------------------------------------------------- - -let TcTyconMemberDefns cenv env parent bindsm scopem tyconDefnMembers = - let interfacesFromTypeDefn (TyconMemberData(declKind, tcref, _, _, declaredTyconTypars, members, _, _)) = +/// Check and generalize the interface implementations, members, 'let' definitions in a mutually recursive group of definitions. +let TcMutRecDefns_Phase2 cenv envInitial bindsm scopem mutRecNSInfo (envMutRec: TcEnv) (mutRecDefns: MutRecDefnsPhase2Data) = + let interfacesFromTypeDefn envForTycon tyconMembersData = + let (MutRecDefnsPhase2DataForTycon(_, _, declKind, tcref, _, _, declaredTyconTypars, members, _, _, _)) = tyconMembersData let overridesOK = DeclKind.CanOverrideOrImplement(declKind) members |> List.collect (function | SynMemberDefn.Interface(ity,defnOpt,_) -> @@ -12895,7 +13391,7 @@ let TcTyconMemberDefns cenv env parent bindsm scopem tyconDefnMembers = if tcref.IsEnumTycon then error(Error(FSComp.SR.tcEnumerationsCannotHaveInterfaceDeclaration(),m)) let ity' = - let envinner = AddDeclaredTypars CheckForDuplicateTypars declaredTyconTypars env + let envinner = AddDeclaredTypars CheckForDuplicateTypars declaredTyconTypars envForTycon TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType envinner emptyUnscopedTyparEnv ity |> fst if not (isInterfaceTy cenv.g ity') then errorR(Error(FSComp.SR.tcTypeIsNotInterfaceType0(),ity.Range)) @@ -12917,19 +13413,43 @@ let TcTyconMemberDefns cenv env parent bindsm scopem tyconDefnMembers = | _ -> []) - let interfaceMembersFromTypeDefn (TyconMemberData(declKind, tcref, baseValOpt, safeInitInfo, declaredTyconTypars, _, _, newslotsOK)) (ity',defn,_) implTySet = + let interfaceMembersFromTypeDefn tyconMembersData (ity',defn,_) implTySet = + let (MutRecDefnsPhase2DataForTycon(_, parent, declKind, tcref, baseValOpt, safeInitInfo, declaredTyconTypars, _, _, newslotsOK, _)) = tyconMembersData let containerInfo = ContainerInfo(parent, Some(MemberOrValContainerInfo(tcref, Some(ity',implTySet), baseValOpt, safeInitInfo, declaredTyconTypars))) defn |> List.choose (fun mem -> - match mem with - | SynMemberDefn.Member(_,m) -> Some(TyconBindingDefn(containerInfo,newslotsOK,declKind,mem,m)) - | SynMemberDefn.AutoProperty(_,_,_,_,_,_,_,_,_,_,m) -> Some(TyconBindingDefn(containerInfo,newslotsOK,declKind,mem,m)) - | _ -> errorR(Error(FSComp.SR.tcMemberNotPermittedInInterfaceImplementation(),mem.Range)); None) - + match mem with + | SynMemberDefn.Member(_,m) -> Some(TyconBindingDefn(containerInfo,newslotsOK,declKind,mem,m)) + | SynMemberDefn.AutoProperty(_,_,_,_,_,_,_,_,_,_,m) -> Some(TyconBindingDefn(containerInfo,newslotsOK,declKind,mem,m)) + | _ -> errorR(Error(FSComp.SR.tcMemberNotPermittedInInterfaceImplementation(),mem.Range)); None) + + let tyconBindingsOfTypeDefn (MutRecDefnsPhase2DataForTycon(_, parent, declKind, tcref, baseValOpt, safeInitInfo, declaredTyconTypars, members, _, newslotsOK, _)) = + let containerInfo = ContainerInfo(parent,Some(MemberOrValContainerInfo(tcref, None, baseValOpt, safeInitInfo, declaredTyconTypars))) + members + |> List.choose (fun memb -> + match memb with + | SynMemberDefn.ImplicitCtor _ + | SynMemberDefn.ImplicitInherit _ + | SynMemberDefn.LetBindings _ + | SynMemberDefn.AutoProperty _ + | SynMemberDefn.Member _ + | SynMemberDefn.Open _ + -> Some(TyconBindingDefn(containerInfo,newslotsOK,declKind,memb,memb.Range)) + + // Interfaces exist in the member list - handled above in interfaceMembersFromTypeDefn + | SynMemberDefn.Interface _ -> None + + // The following should have been List.unzip out already in SplitTyconDefn + | SynMemberDefn.AbstractSlot _ + | SynMemberDefn.ValField _ + | SynMemberDefn.Inherit _ -> error(InternalError("Unexpected declaration element",memb.Range)) + | SynMemberDefn.NestedType _ -> error(Error(FSComp.SR.tcTypesCannotContainNestedTypes(),memb.Range))) + let tpenv = emptyUnscopedTyparEnv try // Some preliminary checks - tyconDefnMembers |> List.iter (fun (TyconMemberData(declKind, tcref, _, _, _, members, m, newslotsOK)) -> + mutRecDefns |> MutRecShapes.iterTycons (fun tyconData -> + let (MutRecDefnsPhase2DataForTycon(_, _, declKind, tcref, _, _, _, members, m, newslotsOK, _)) = tyconData let tcaug = tcref.TypeContents if tcaug.tcaug_closed && declKind <> ExtrinsicExtensionBinding then error(InternalError("Intrinsic augmentations of types are only permitted in the same file as the definition of the type",m)) @@ -12945,49 +13465,27 @@ let TcTyconMemberDefns cenv env parent bindsm scopem tyconDefnMembers = // The rest should have been removed by splitting, they belong to "core" (they are "shape" of type, not implementation) | _ -> error(Error(FSComp.SR.tcDeclarationElementNotPermittedInAugmentation(),mem.Range)))) - let tyconBindingsOfTypeDefn (TyconMemberData(declKind, tcref, baseValOpt, safeInitInfo, declaredTyconTypars, members, _, newslotsOK)) = - let containerInfo = ContainerInfo(parent,Some(MemberOrValContainerInfo(tcref, None, baseValOpt, safeInitInfo, declaredTyconTypars))) - members - |> List.choose (fun memb -> - match memb with - | SynMemberDefn.ImplicitCtor _ - | SynMemberDefn.ImplicitInherit _ - | SynMemberDefn.LetBindings _ - | SynMemberDefn.AutoProperty _ - | SynMemberDefn.Member _ - | SynMemberDefn.Open _ - -> Some(TyconBindingDefn(containerInfo,newslotsOK,declKind,memb,memb.Range)) - - // Interfaces exist in the member list - handled above in interfaceMembersFromTypeDefn - | SynMemberDefn.Interface _ -> None - - // The following should have been List.unzip out already in SplitTyconDefn - | SynMemberDefn.AbstractSlot _ - | SynMemberDefn.ValField _ - | SynMemberDefn.Inherit _ -> error(InternalError("Unexpected declaration element",memb.Range)) - | SynMemberDefn.NestedType _ -> error(Error(FSComp.SR.tcTypesCannotContainNestedTypes(),memb.Range))) - - let binds = - tyconDefnMembers |> List.map (fun (TyconMemberData(declKind, tcref, _, _, declaredTyconTypars, _, _, _) as tyconMemberData) -> - let obinds = tyconBindingsOfTypeDefn tyconMemberData + + let binds : MutRecDefnsPhase2Info = + (envMutRec, mutRecDefns) ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls tyconData -> + let (MutRecDefnsPhase2DataForTycon(tyconOpt, _, declKind, tcref, _, _, declaredTyconTypars, _, _, _, fixupFinalAttrs)) = tyconData + let obinds = tyconBindingsOfTypeDefn tyconData let ibinds = - let intfTypes = interfacesFromTypeDefn tyconMemberData - let slotImplSets = DispatchSlotChecking.GetSlotImplSets cenv.infoReader env.DisplayEnv false (List.map (fun (ity,_,m) -> (ity,m)) intfTypes) - List.concat (List.map2 (interfaceMembersFromTypeDefn tyconMemberData) intfTypes slotImplSets) - TyconBindingDefns(tcref, declaredTyconTypars, declKind, obinds @ ibinds)) + let intfTypes = interfacesFromTypeDefn envForDecls tyconData + let slotImplSets = DispatchSlotChecking.GetSlotImplSets cenv.infoReader envForDecls.DisplayEnv false (List.map (fun (ity,_,m) -> (ity,m)) intfTypes) + (intfTypes, slotImplSets) ||> List.map2 (interfaceMembersFromTypeDefn tyconData) |> List.concat + MutRecDefnsPhase2InfoForTycon(tyconOpt, tcref, declaredTyconTypars, declKind, obinds @ ibinds, fixupFinalAttrs)) - let results = TyconBindingChecking.TcTyconBindings cenv env tpenv bindsm scopem binds - let binds,envbody,_ = results - binds,envbody + MutRecBindingChecking.TcMutRecDefns_Phase2_Bindings cenv envInitial tpenv bindsm scopem mutRecNSInfo envMutRec binds - with e -> errorRecovery e scopem; [], env + with e -> errorRecovery e scopem; [], envMutRec //------------------------------------------------------------------------- // Build augmentation declarations //------------------------------------------------------------------------- -module AddAugmentationDeclarations = begin - let tcaug_has_nominal_interface g (tcaug: TyconAugmentation) tcref = +module AddAugmentationDeclarations = + let tcaugHasNominalInterface g (tcaug: TyconAugmentation) tcref = tcaug.tcaug_interfaces |> List.exists (fun (x,_,_) -> isAppTy g x && tyconRefEq g (tcrefOfAppTy g x) tcref) @@ -13002,7 +13500,7 @@ module AddAugmentationDeclarations = begin let hasExplicitIComparable = tycon.HasInterface cenv.g cenv.g.mk_IComparable_ty - let hasExplicitGenericIComparable = tcaug_has_nominal_interface cenv.g tcaug cenv.g.system_GenericIComparable_tcref + let hasExplicitGenericIComparable = tcaugHasNominalInterface cenv.g tcaug cenv.g.system_GenericIComparable_tcref let hasExplicitIStructuralComparable = tycon.HasInterface cenv.g cenv.g.mk_IStructuralComparable_ty if hasExplicitIComparable then @@ -13086,7 +13584,7 @@ module AddAugmentationDeclarations = begin // Note: tycon.HasOverride only gives correct results after we've done the type augmentation let hasExplicitObjectEqualsOverride = tycon.HasOverride cenv.g "Equals" [cenv.g.obj_ty] - let hasExplicitGenericIEquatable = tcaug_has_nominal_interface cenv.g tcaug cenv.g.system_GenericIEquatable_tcref + let hasExplicitGenericIEquatable = tcaugHasNominalInterface cenv.g tcaug cenv.g.system_GenericIEquatable_tcref if hasExplicitGenericIEquatable then errorR(Error(FSComp.SR.tcImplementsIEquatableExplicitly(tycon.DisplayName),m)) @@ -13106,18 +13604,20 @@ module AddAugmentationDeclarations = begin else [] else [] -end -module TyconConstraintInference = begin - let InferSetOfTyconsSupportingComparable cenv (env: TcEnv) structuralTypes (tycons:Tycon list) = +/// Infer 'comparison' and 'equality' constraints from type definitions +module TyconConstraintInference = + + /// Infer 'comparison' constraints from type definitions + let InferSetOfTyconsSupportingComparable cenv (denv: DisplayEnv) tyconsWithStructuralTypes = let g = cenv.g - let tab = (tycons,structuralTypes) ||> List.map2 (fun tycon c -> tycon.Stamp, (tycon,c)) |> Map.ofList + let tab = tyconsWithStructuralTypes |> List.map (fun (tycon:Tycon, structuralTypes) -> tycon.Stamp, (tycon,structuralTypes)) |> Map.ofList // Initially, assume the equality relation is available for all structural type definitions let initialAssumedTycons = - set [ for tycon in tycons do + set [ for (tycon,_) in tyconsWithStructuralTypes do if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare cenv.g tycon then yield tycon.Stamp ] @@ -13198,9 +13698,9 @@ module TyconConstraintInference = begin failwith "unreachble" | Some (ty,_) -> if isTyparTy g ty then - errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied1(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range)) + errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied1(tycon.DisplayName,NicePrint.prettyStringOfTy denv ty),tycon.Range)) else - errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied2(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range)) + errorR(Error(FSComp.SR.tcStructuralComparisonNotSatisfied2(tycon.DisplayName,NicePrint.prettyStringOfTy denv ty),tycon.Range)) | Some(false) -> () @@ -13214,9 +13714,9 @@ module TyconConstraintInference = begin // PERF: this call to prettyStringOfTy is always being executed, even when the warning // is not being reported (the normal case). if isTyparTy g ty then - warning(Error(FSComp.SR.tcNoComparisonNeeded1(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range)) + warning(Error(FSComp.SR.tcNoComparisonNeeded1(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty, tycon.DisplayName),tycon.Range)) else - warning(Error(FSComp.SR.tcNoComparisonNeeded2(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range)) + warning(Error(FSComp.SR.tcNoComparisonNeeded2(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty, tycon.DisplayName),tycon.Range)) res) @@ -13238,14 +13738,15 @@ module TyconConstraintInference = begin // Return the set of structural type definitions which support the relation uneliminatedTycons - let InferSetOfTyconsSupportingEquatable cenv (env: TcEnv) structuralTypes (tycons:Tycon list) = + /// Infer 'equality' constraints from type definitions + let InferSetOfTyconsSupportingEquatable cenv (denv: DisplayEnv) (tyconsWithStructuralTypes:(Tycon * _) list) = let g = cenv.g - let tab = (tycons,structuralTypes) ||> List.map2 (fun tycon c -> tycon.Stamp, (tycon,c)) |> Map.ofList + let tab = tyconsWithStructuralTypes |> List.map (fun (tycon,c) -> tycon.Stamp, (tycon,c)) |> Map.ofList // Initially, assume the equality relation is available for all structural type definitions let initialAssumedTycons = - set [ for tycon in tycons do + set [ for (tycon,_) in tyconsWithStructuralTypes do if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals cenv.g tycon then yield tycon.Stamp ] @@ -13324,9 +13825,9 @@ module TyconConstraintInference = begin failwith "unreachble" | Some (ty,_) -> if isTyparTy g ty then - errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied1(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range)) + errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied1(tycon.DisplayName,NicePrint.prettyStringOfTy denv ty),tycon.Range)) else - errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied2(tycon.DisplayName,NicePrint.prettyStringOfTy env.DisplayEnv ty),tycon.Range)) + errorR(Error(FSComp.SR.tcStructuralEqualityNotSatisfied2(tycon.DisplayName,NicePrint.prettyStringOfTy denv ty),tycon.Range)) else () | Some(false) -> @@ -13339,9 +13840,9 @@ module TyconConstraintInference = begin failwith "unreachble" | Some (ty,_) -> if isTyparTy g ty then - warning(Error(FSComp.SR.tcNoEqualityNeeded1(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range)) + warning(Error(FSComp.SR.tcNoEqualityNeeded1(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty, tycon.DisplayName),tycon.Range)) else - warning(Error(FSComp.SR.tcNoEqualityNeeded2(tycon.DisplayName, NicePrint.prettyStringOfTy env.DisplayEnv ty, tycon.DisplayName),tycon.Range)) + warning(Error(FSComp.SR.tcNoEqualityNeeded2(tycon.DisplayName, NicePrint.prettyStringOfTy denv ty, tycon.DisplayName),tycon.Range)) res) @@ -13363,8 +13864,6 @@ module TyconConstraintInference = begin // Return the set of structural type definitions which support the relation uneliminatedTycons -end - //------------------------------------------------------------------------- // Helpers for modules, types and exception declarations @@ -13374,13 +13873,13 @@ let ComputeModuleName (longPath: Ident list) = if longPath.Length <> 1 then error(Error(FSComp.SR.tcInvalidModuleName(),(List.head longPath).idRange)) longPath.Head -let CheckForDuplicateConcreteType _cenv env nm m = +let CheckForDuplicateConcreteType env nm m = let curr = GetCurrAccumulatedModuleOrNamespaceType env if Map.containsKey nm curr.AllEntitiesByCompiledAndLogicalMangledNames then // Use 'error' instead of 'errorR' here to avoid cascading errors - see bug 1177 in FSharp 1.0 error (Duplicate(FSComp.SR.tcTypeExceptionOrModule(),nm,m)) -let CheckForDuplicateModule _cenv env nm m = +let CheckForDuplicateModule env nm m = let curr = GetCurrAccumulatedModuleOrNamespaceType env if curr.ModulesAndNamespacesByDemangledName.ContainsKey(nm) then errorR (Duplicate(FSComp.SR.tcTypeOrModule(),nm,m)) @@ -13390,27 +13889,34 @@ let CheckForDuplicateModule _cenv env nm m = // Bind exception definitions //------------------------------------------------------------------------- -module TcExceptionDeclarations = begin +/// Check 'exception' declarations in implementations and signatures +module TcExceptionDeclarations = - let private TcExnDefnCore cenv env parent tpenv (ExceptionDefnRepr(synAttrs,UnionCase(_,id,args,_,_,_),repr,doc,vis,m), scopem) = + let TcExnDefnCore_Phase1A cenv env parent (SynExceptionDefnRepr(synAttrs,UnionCase(_,id,_,_,_,_),_,doc,vis,m)) = let attrs = TcAttributes cenv env AttributeTargets.ExnDecl synAttrs + if not (String.isUpper id.idText) then errorR(NotUpperCaseConstructor(m)) + let vis,cpath = ComputeAccessAndCompPath env None m vis parent + let vis = TcRecdUnionAndEnumDeclarations.CombineReprAccess parent vis + CheckForDuplicateConcreteType env (id.idText + "Exception") id.idRange + CheckForDuplicateConcreteType env id.idText id.idRange + NewExn cpath id vis (TExnFresh (MakeRecdFieldsTable [])) attrs (doc.ToXmlDoc()) + + let TcExnDefnCore_Phase1G_EstablishRepresentation cenv env parent (exnc: Entity) (SynExceptionDefnRepr(_,UnionCase(_,_,args,_,_,_),reprIdOpt,_,_,m)) = let args = match args with (UnionCaseFields args) -> args | _ -> error(Error(FSComp.SR.tcExplicitTypeSpecificationCannotBeUsedForExceptionConstructors(),m)) let ad = env.eAccessRights + let id = exnc.Id - let args' = List.mapi (fun i fdef -> TcRecdUnionAndEnumDeclarations.TcAnonFieldDecl cenv env parent tpenv ("Data" + string i) fdef) args + let args' = List.mapi (fun i fdef -> TcRecdUnionAndEnumDeclarations.TcAnonFieldDecl cenv env parent emptyUnscopedTyparEnv ("Data" + string i) fdef) args TcRecdUnionAndEnumDeclarations.ValidateFieldNames(args, args') - if not (String.isUpper id.idText) then errorR(NotUpperCaseConstructor(m)) - let vis,cpath = ComputeAccessAndCompPath env None m vis parent - let vis = TcRecdUnionAndEnumDeclarations.CombineReprAccess parent vis - let exnc = - match repr with + let repr = + match reprIdOpt with | Some longId -> match ResolveExprLongIdent cenv.tcSink cenv.nameResolver m ad env.eNameResEnv TypeNameResolutionInfo.Default longId with | Item.ExnCase exnc, [] -> CheckTyconAccessible cenv.amap m env.eAccessRights exnc |> ignore if List.length args' <> 0 then errorR (Error(FSComp.SR.tcExceptionAbbreviationsShouldNotHaveArgumentList(),m)) - NewExn cpath id vis (TExnAbbrevRepr exnc) attrs (doc.ToXmlDoc()) + TExnAbbrevRepr exnc | Item.CtorGroup(_,meths) , [] -> // REVIEW: check this really is an exception type match args' with @@ -13425,7 +13931,7 @@ module TcExceptionDeclarations = begin match minfo.EnclosingType with | AppTy cenv.g (tcref,_) as ety when (TypeDefinitelySubsumesTypeNoCoercion 0 cenv.g cenv.amap m cenv.g.exn_ty ety) -> let tref = tcref.CompiledRepresentationForNamedType - NewExn cpath id vis (TExnAsmRepr tref) attrs (doc.ToXmlDoc()) + TExnAsmRepr tref | _ -> error(Error(FSComp.SR.tcExceptionAbbreviationsMustReferToValidExceptions(),m)) | _ -> @@ -13433,18 +13939,24 @@ module TcExceptionDeclarations = begin | _ -> error (Error(FSComp.SR.tcNotAnException(),m)) | None -> - NewExn cpath id vis (TExnFresh (MakeRecdFieldsTable args')) attrs (doc.ToXmlDoc()) + TExnFresh (MakeRecdFieldsTable args') - let tcaug = exnc.TypeContents - tcaug.tcaug_super <- Some cenv.g.exn_ty + exnc.Data.entity_exn_info <- repr + + let item = Item.ExnCase(mkLocalTyconRef exnc) + CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,item,item,ItemOccurence.Binding,env.DisplayEnv,env.eAccessRights) + args' + + let private TcExnDefnCore cenv env parent synExnDefnRepr = + let exnc = TcExnDefnCore_Phase1A cenv env parent synExnDefnRepr + let args' = TcExnDefnCore_Phase1G_EstablishRepresentation cenv env parent exnc synExnDefnRepr + exnc.TypeContents.tcaug_super <- Some cenv.g.exn_ty - CheckForDuplicateConcreteType cenv env (id.idText ^ "Exception") id.idRange - CheckForDuplicateConcreteType cenv env id.idText id.idRange PublishTypeDefn cenv env exnc let structuralTypes = args' |> List.map (fun rf -> (rf.FormalType, rf.Range)) - let scSet = TyconConstraintInference.InferSetOfTyconsSupportingComparable cenv env [structuralTypes] [exnc] - let seSet = TyconConstraintInference.InferSetOfTyconsSupportingEquatable cenv env [structuralTypes] [exnc] + let scSet = TyconConstraintInference.InferSetOfTyconsSupportingComparable cenv env.DisplayEnv [(exnc,structuralTypes)] + let seSet = TyconConstraintInference.InferSetOfTyconsSupportingEquatable cenv env.DisplayEnv [(exnc,structuralTypes)] // Augment the exception constructor with comparison and hash methods if needed let binds = @@ -13454,40 +13966,28 @@ module TcExceptionDeclarations = begin AddAugmentationDeclarations.AddGenericHashAndComparisonDeclarations cenv env scSet seSet exnc AddAugmentationDeclarations.AddGenericHashAndComparisonBindings cenv exnc - let item = Item.ExnCase(mkLocalTyconRef exnc) - CallNameResolutionSink cenv.tcSink (id.idRange,env.NameEnv,item,item,ItemOccurence.Binding,env.DisplayEnv,env.eAccessRights) + binds,exnc + - binds, - exnc, - AddLocalExnDefn cenv.tcSink scopem exnc (AddLocalTycons cenv.g cenv.amap scopem [exnc] env) + let TcExnDefn cenv envInitial parent (SynExceptionDefn(core,aug,m),scopem) = + let binds1,exnc = TcExnDefnCore cenv envInitial parent core + let envMutRec = AddLocalExnDefnAndReport cenv.tcSink scopem (AddLocalTycons cenv.g cenv.amap scopem [exnc] envInitial) exnc - let TcExnDefn cenv env parent tpenv (ExceptionDefn(core,aug,m),scopem) = - let binds1,exnc,env = TcExnDefnCore cenv env parent tpenv (core,scopem) - let binds2,env = TcTyconMemberDefns cenv env parent m scopem [TyconMemberData(ModuleOrMemberBinding, (mkLocalEntityRef exnc), None, NoSafeInitInfo, [], aug, m, NoNewSlots)] + let defns = [MutRecShape.Tycon(MutRecDefnsPhase2DataForTycon(Some exnc, parent, ModuleOrMemberBinding, mkLocalEntityRef exnc, None, NoSafeInitInfo, [], aug, m, NoNewSlots, (fun () -> ())))] + let binds2,envFinal = TcMutRecDefns_Phase2 cenv envInitial m scopem None envMutRec defns + let binds2flat = binds2 |> MutRecShapes.collectTycons |> List.map snd |> List.concat // Augment types with references to values that implement the pre-baked semantics of the type - let binds3 = AddAugmentationDeclarations.AddGenericEqualityBindings cenv env exnc - binds1 @ binds2 @ binds3,exnc,env + let binds3 = AddAugmentationDeclarations.AddGenericEqualityBindings cenv envFinal exnc + binds1 @ binds2flat @ binds3,exnc,envFinal - let TcExnSignature cenv env parent tpenv (ExceptionSig(core,aug,_),scopem) = - let binds,exnc,env = TcExnDefnCore cenv env parent tpenv (core,scopem) + let TcExnSignature cenv envInitial parent tpenv (SynExceptionSig(core,aug,_),scopem) = + let binds,exnc = TcExnDefnCore cenv envInitial parent core + let envMutRec = AddLocalExnDefnAndReport cenv.tcSink scopem (AddLocalTycons cenv.g cenv.amap scopem [exnc] envInitial) exnc let ecref = mkLocalEntityRef exnc - let vals,_ = TcTyconMemberSpecs cenv env (ContainerInfo(parent,Some(MemberOrValContainerInfo(ecref,None,None,NoSafeInitInfo,[])))) ModuleOrMemberBinding tpenv aug - binds,vals,ecref,env + let vals,_ = TcTyconMemberSpecs cenv envMutRec (ContainerInfo(parent,Some(MemberOrValContainerInfo(ecref,None,None,NoSafeInitInfo,[])))) ModuleOrMemberBinding tpenv aug + binds,vals,ecref,envMutRec -end -/// The core syntactic input to the type checking of type definitions. -/// -/// TyconDefnCore(info,repr,m,preEstablishedHasDefaultCtor,hasSelfReferentialCtor) -type TyconDefnCore = - TyconDefnCore of SynComponentInfo * SynTypeDefnSimpleRepr * (SynType * range) list * bool * bool - -/// Same as TyconDefnCore but with an integer index. -/// -/// TyconDefnCoreIndexed(info,repr,m,preEstablishedHasDefaultCtor,hasSelfReferentialCtor,i) -type TyconDefnCoreIndexed = - TyconDefnCoreIndexed of - SynComponentInfo * SynTypeDefnSimpleRepr * (SynType * range) list * bool *bool * int /// Bind type definitions /// @@ -13503,7 +14003,7 @@ type TyconDefnCoreIndexed = /// refer to the types being defined. However a functional version of this /// would need to re-implement certain type relations to work over a /// partial representation of types. -module EstablishTypeDefinitionCores = begin +module EstablishTypeDefinitionCores = /// Compute the mangled name of a type definition. 'doErase' is true for all type definitions except type abbreviations. let private ComputeTyconName (longPath: Ident list, doErase:bool, typars: Typars) = @@ -13545,7 +14045,7 @@ module EstablishTypeDefinitionCores = begin if hasClassAttr && not (match k with TyconClass -> true | _ -> false) || hasMeasureAttr && not (match k with TyconClass | TyconAbbrev | TyconHiddenRepr -> true | _ -> false) || hasInterfaceAttr && not (match k with TyconInterface -> true | _ -> false) || - hasStructAttr && not (match k with TyconStruct -> true | _ -> false) then + hasStructAttr && not (match k with TyconStruct | TyconRecord | TyconUnion -> true | _ -> false) then error(Error(FSComp.SR.tcKindOfTypeSpecifiedDoesNotMatchDefinition(),m)) k @@ -13564,7 +14064,7 @@ module EstablishTypeDefinitionCores = begin /// Get the component types that make a record, union or struct type. /// /// Used when determining if a structural type supports structural comparison. - let private GetStructuralElementsOfTyconDefn cenv env tpenv (TyconDefnCoreIndexed(_,synTyconRepr,_,_,_,_)) tycon = + let private GetStructuralElementsOfTyconDefn cenv env tpenv (MutRecDefnsPhase1DataForTycon(_,synTyconRepr,_,_,_,_)) tycon = let thisTyconRef = mkLocalTyconRef tycon let m = tycon.Range let env = AddDeclaredTypars CheckForDuplicateTypars (tycon.Typars(m)) env @@ -13572,13 +14072,14 @@ module EstablishTypeDefinitionCores = begin [ match synTyconRepr with | SynTypeDefnSimpleRepr.None _ -> () | SynTypeDefnSimpleRepr.Union (_,unionCases,_) -> + for (UnionCase (_,_,args,_,_,m)) in unionCases do - match args with - | UnionCaseFields flds -> + match args with + | UnionCaseFields flds -> for (Field(_,_,_,ty,_,_,_,m)) in flds do let ty',_ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty yield (ty',m) - | UnionCaseFullType (ty,arity) -> + | UnionCaseFullType (ty,arity) -> let ty',_ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty let argtysl,_ = GetTopTauTypeInFSharpForm cenv.g (arity |> TranslateTopValSynInfo m (TcAttributes cenv env) |> TranslatePartialArity []).ArgInfos ty' m if argtysl.Length > 1 then @@ -13608,29 +14109,61 @@ module EstablishTypeDefinitionCores = begin for (Field(_,_,_,ty,_,_,_,m)) in fields do let ty',_ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty yield (ty',m) + | _ -> () ] + let ComputeModuleOrNamespaceKind g isModule attribs = + if not isModule then Namespace + elif ModuleNameIsMangled g attribs then FSharpModuleWithSuffix + else ModuleOrType + + let AdjustModuleName modKind nm = (match modKind with FSharpModuleWithSuffix -> nm+FSharpModuleSuffix | _ -> nm) + + + let TcTyconDefnCore_Phase1A_BuildInitialModule cenv envInitial parent compInfo = + let (ComponentInfo(attribs,_parms, _constraints,longPath,xml,_,vis,im)) = compInfo + let id = ComputeModuleName longPath + let modAttrs = TcAttributes cenv envInitial AttributeTargets.ModuleDecl attribs + let modKind = ComputeModuleOrNamespaceKind cenv.g true modAttrs + let modName = AdjustModuleName modKind id.idText + + let vis,_ = ComputeAccessAndCompPath envInitial None id.idRange vis parent + + CheckForDuplicateModule envInitial id.idText id.idRange + let id = ident (modName, id.idRange) + CheckForDuplicateConcreteType envInitial id.idText im + CheckNamespaceModuleOrTypeName cenv.g id + + let envForDecls, mtypeAcc = MakeInnerEnv envInitial id modKind + let mspec = NewModuleOrNamespace (Some envInitial.eCompPath) vis id (xml.ToXmlDoc()) modAttrs (notlazy (NewEmptyModuleOrNamespaceType modKind)) + let innerParent = Parent (mkLocalModRef mspec) + MutRecDefnsPhase2DataForModule (mtypeAcc, mspec), (innerParent, envForDecls) + /// Establish 'type C < T1... TN > = ...' including /// - computing the mangled name for C /// but /// - we don't yet 'properly' establish constraints on type parameters - let private TcTyconDefnCore_Phase0_BuildInitialTycon cenv env parent (TyconDefnCoreIndexed(synTyconInfo,synTyconRepr,_,preEstablishedHasDefaultCtor,hasSelfReferentialCtor,_)) = - let (ComponentInfo(_,synTypars, _,id,doc,preferPostfix, vis,_)) = synTyconInfo + let private TcTyconDefnCore_Phase1A_BuildInitialTycon cenv env parent (MutRecDefnsPhase1DataForTycon(synTyconInfo,synTyconRepr,_,preEstablishedHasDefaultCtor,hasSelfReferentialCtor, _)) = + let (ComponentInfo (_, synTypars, _,id, doc, preferPostfix, synVis,_)) = synTyconInfo let checkedTypars = TcTyparDecls cenv env synTypars id |> List.iter (CheckNamespaceModuleOrTypeName cenv.g) + match synTyconRepr with + | SynTypeDefnSimpleRepr.Exception synExnDefnRepr -> + TcExceptionDeclarations.TcExnDefnCore_Phase1A cenv env parent synExnDefnRepr + | _ -> let id = ComputeTyconName (id, (match synTyconRepr with SynTypeDefnSimpleRepr.TypeAbbrev _ -> false | _ -> true), checkedTypars) // Augmentations of type definitions are allowed within the same file as long as no new type representation or abbreviation is given - CheckForDuplicateConcreteType cenv env id.idText id.idRange - CheckForDuplicateModule cenv env id.idText id.idRange - let vis,cpath = ComputeAccessAndCompPath env None id.idRange vis parent + CheckForDuplicateConcreteType env id.idText id.idRange + CheckForDuplicateModule env id.idText id.idRange + let vis,cpath = ComputeAccessAndCompPath env None id.idRange synVis parent // Establish the visibility of the representation, e.g. // type R = // private { f:int } // member x.P = x.f + x.f - let visOfRepr = + let synVisOfRepr = match synTyconRepr with | SynTypeDefnSimpleRepr.None _ -> None | SynTypeDefnSimpleRepr.TypeAbbrev _ -> None @@ -13639,11 +14172,13 @@ module EstablishTypeDefinitionCores = begin | SynTypeDefnSimpleRepr.Record (vis,_,_) -> vis | SynTypeDefnSimpleRepr.General _ -> None | SynTypeDefnSimpleRepr.Enum _ -> None + | SynTypeDefnSimpleRepr.Exception _ -> None - let visOfRepr,_ = ComputeAccessAndCompPath env None id.idRange visOfRepr parent + let visOfRepr,_ = ComputeAccessAndCompPath env None id.idRange synVisOfRepr parent let visOfRepr = combineAccess vis visOfRepr // If we supported nested types and modules then additions would be needed here let lmtyp = notlazy (NewEmptyModuleOrNamespaceType ModuleOrType) + NewTycon(cpath, id.idText, id.idRange, vis, visOfRepr, TyparKind.Type, LazyWithContext.NotLazy checkedTypars, doc.ToXmlDoc(), preferPostfix, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, lmtyp) //------------------------------------------------------------------------- @@ -13657,15 +14192,26 @@ module EstablishTypeDefinitionCores = begin /// /// synTyconInfo: Syntactic AST for the name, attributes etc. of the type constructor /// synTyconRepr: Syntactic AST for the RHS of the type definition - let private TcTyconDefnCore_Phase1_EstablishBasicKind cenv inSig envinner (TyconDefnCoreIndexed(synTyconInfo,synTyconRepr,_,_,_,_)) (tycon:Tycon) = + let private TcTyconDefnCore_Phase1B_EstablishBasicKind cenv inSig envinner (MutRecDefnsPhase1DataForTycon(synTyconInfo,synTyconRepr,_,_,_,_)) (tycon:Tycon) = let (ComponentInfo(synAttrs,typars, _,_, _, _,_,_)) = synTyconInfo let m = tycon.Range let id = tycon.Id - // 'Check' the attributes. We return the results to avoid having to re-check them in all other phases. - let attrs = TcAttributes cenv envinner AttributeTargets.TyconDecl synAttrs + // 'Check' the attributes. We return the results to avoid having to re-check them in all other phases. + // Allow failure of constructor resolution because Vals for members in the same recursive group are not yet available + let attrs, getFinalAttrs = TcAttributesCanFail cenv envinner AttributeTargets.TyconDecl synAttrs let hasMeasureAttr = HasFSharpAttribute cenv.g cenv.g.attrib_MeasureAttribute attrs + let isStructRecordOrUnionType = + match synTyconRepr with + | SynTypeDefnSimpleRepr.Record _ + | SynTypeDefnSimpleRepr.Union _ -> + HasFSharpAttribute cenv.g cenv.g.attrib_StructAttribute attrs + | _ -> + false + + tycon.SetIsStructRecordOrUnion isStructRecordOrUnionType + // Set the compiled name, if any tycon.Data.entity_compiled_name <- TryFindFSharpStringAttribute cenv.g cenv.g.attrib_CompiledNameAttribute attrs @@ -13675,15 +14221,16 @@ module EstablishTypeDefinitionCores = begin let repr = match synTyconRepr with + | SynTypeDefnSimpleRepr.Exception _ -> TNoRepr | SynTypeDefnSimpleRepr.None m -> // Run InferTyconKind to raise errors on inconsistent attribute sets InferTyconKind cenv.g (TyconHiddenRepr,attrs,[],[],inSig,true,m) |> ignore if not inSig && not hasMeasureAttr then errorR(Error(FSComp.SR.tcTypeRequiresDefinition(),m)) if hasMeasureAttr then - TFsObjModelRepr { fsobjmodel_kind=TTyconClass - fsobjmodel_vslots=[] - fsobjmodel_rfields=MakeRecdFieldsTable [] } + TFSharpObjectRepr { fsobjmodel_kind=TTyconClass + fsobjmodel_vslots=[] + fsobjmodel_rfields=MakeRecdFieldsTable [] } else TNoRepr @@ -13727,18 +14274,18 @@ module EstablishTypeDefinitionCores = begin let repr = { fsobjmodel_kind=kind fsobjmodel_vslots=[] fsobjmodel_rfields=MakeRecdFieldsTable [] } - TFsObjModelRepr repr + TFSharpObjectRepr repr | SynTypeDefnSimpleRepr.Enum _ -> let kind = TTyconEnum let repr = { fsobjmodel_kind=kind fsobjmodel_vslots=[] fsobjmodel_rfields=MakeRecdFieldsTable [] } - TFsObjModelRepr repr + TFSharpObjectRepr repr // OK, now fill in the (partially computed) type representation tycon.Data.entity_tycon_repr <- repr - attrs + attrs, getFinalAttrs #if EXTENSIONTYPING /// Get the items on the r.h.s. of a 'type X = ABC<...>' definition @@ -13783,7 +14330,7 @@ module EstablishTypeDefinitionCores = begin /// Check and establish a 'type X = ABC<...>' provided type definition - let private TcTyconDefnCore_Phase2_EstablishDeclarationForGeneratedSetOfTypes cenv inSig (tycon:Tycon, rhsType:SynType, tcrefForContainer:TyconRef, theRootType:Tainted, checkTypeName, args, m) = + let private TcTyconDefnCore_Phase1C_EstablishDeclarationForGeneratedSetOfTypes cenv inSig (tycon:Tycon, rhsType:SynType, tcrefForContainer:TyconRef, theRootType:Tainted, checkTypeName, args, m) = let tcref = mkLocalTyconRef tycon try @@ -13936,14 +14483,13 @@ module EstablishTypeDefinitionCores = begin // such as 'isTupleTy' will return reliable results, e.g. isTupleTy on the /// TAST type for 'PairOfInts' will report 'true' // - let private TcTyconDefnCore_Phase2_Phase4_EstablishAbbreviations cenv envinner inSig tpenv pass (TyconDefnCoreIndexed(_,synTyconRepr,_,_,_,_)) (tycon:Tycon) (checkedAttrs:Attribs) = + let private TcTyconDefnCore_Phase1C_Phase1E_EstablishAbbreviations cenv envinner inSig tpenv pass (MutRecDefnsPhase1DataForTycon(_,synTyconRepr,_,_,_,_)) (tycon:Tycon) (attrs:Attribs) = let m = tycon.Range let checkCxs = if (pass = SecondPass) then CheckCxs else NoCheckCxs let firstPass = (pass = FirstPass) try let id = tycon.Id let thisTyconRef = mkLocalTyconRef tycon - let attrs = checkedAttrs let hasMeasureAttr = HasFSharpAttribute cenv.g cenv.g.attrib_MeasureAttribute attrs let hasMeasureableAttr = HasFSharpAttribute cenv.g cenv.g.attrib_MeasureableAttribute attrs @@ -13970,7 +14516,7 @@ module EstablishTypeDefinitionCores = begin | Some (tcrefForContainer, providedTypeAfterStaticArguments, checkTypeName, args, m) -> // If this is a generative provided type definition then establish the provided type and all its nested types. Only do this on the first pass. if firstPass then - TcTyconDefnCore_Phase2_EstablishDeclarationForGeneratedSetOfTypes cenv inSig (tycon, rhsType, tcrefForContainer, providedTypeAfterStaticArguments, checkTypeName, args, m) + TcTyconDefnCore_Phase1C_EstablishDeclarationForGeneratedSetOfTypes cenv inSig (tycon, rhsType, tcrefForContainer, providedTypeAfterStaticArguments, checkTypeName, args, m) | None -> #else ignore inSig @@ -13999,13 +14545,16 @@ module EstablishTypeDefinitionCores = begin // Third phase: check and publish the supr types. Run twice, once before constraints are established // and once after - let private TcTyconDefnCore_Phase3_Phase5_EstablishSuperTypesAndInterfaceTypes cenv envinner tpenv inSig typeDefCores (tycons:Tycon list) pass (checkedAttrsList:Attribs list) = + let private TcTyconDefnCore_Phase1D_Phase1F_EstablishSuperTypesAndInterfaceTypes cenv tpenv inSig pass (envMutRec, mutRecDefns:MutRecShape<(_ * (Tycon * (Attribs * _)) option),_,_,_,_> list) = let checkCxs = if (pass = SecondPass) then CheckCxs else NoCheckCxs let firstPass = (pass = FirstPass) // Publish the immediately declared interfaces. - let implementsL = - (typeDefCores,tycons,checkedAttrsList) |||> List.map3 (fun (TyconDefnCoreIndexed(_,synTyconRepr,explicitImplements,_,_,_)) tycon checkedAttrs -> + let tyconWithImplementsL = + (envMutRec, mutRecDefns) ||> MutRecShapes.mapTyconsWithEnv (fun envinner (origInfo,tyconAndAttrsOpt) -> + match origInfo, tyconAndAttrsOpt with + | (typeDefCore,_,_), Some (tycon, (attrs,_)) -> + let (MutRecDefnsPhase1DataForTycon(_,synTyconRepr,explicitImplements,_,_,_)) = typeDefCore let m = tycon.Range let tcref = mkLocalTyconRef tycon let envinner = AddDeclaredTypars CheckForDuplicateTypars (tycon.Typars(m)) envinner @@ -14013,13 +14562,12 @@ module EstablishTypeDefinitionCores = begin let implementedTys,_ = List.mapFold (mapFoldFst (TcTypeAndRecover cenv NoNewTypars checkCxs ItemOccurence.UseInType envinner)) tpenv explicitImplements - let attrs = checkedAttrs - if firstPass then tycon.Data.entity_attribs <- attrs let implementedTys,inheritedTys = match synTyconRepr with + | SynTypeDefnSimpleRepr.Exception _ -> [], [] | SynTypeDefnSimpleRepr.General (kind,inherits,slotsigs,fields,isConcrete,_,_,m) -> let kind = InferTyconKind cenv.g (kind,attrs,slotsigs,fields,inSig,isConcrete,m) @@ -14047,19 +14595,23 @@ module EstablishTypeDefinitionCores = begin if firstPass then implementedTys |> List.iter (fun (ty,m) -> PublishInterface cenv envinner.DisplayEnv tcref m false ty) - attrs,inheritedTys) + Some (attrs,inheritedTys,synTyconRepr,tycon) + | _ -> None) // Publish the attributes and supertype - (implementsL,typeDefCores,tycons) |||> List.iter3 (fun (attrs,inheritedTys) (TyconDefnCoreIndexed(_,synTyconRepr,_,_,_,_)) tycon -> + tyconWithImplementsL |> MutRecShapes.iterTycons (Option.iter (fun (attrs,inheritedTys, synTyconRepr, tycon) -> let m = tycon.Range try let super = match synTyconRepr with + | SynTypeDefnSimpleRepr.Exception _ -> Some cenv.g.exn_ty | SynTypeDefnSimpleRepr.None _ -> None | SynTypeDefnSimpleRepr.TypeAbbrev _ -> None - | SynTypeDefnSimpleRepr.Union _ -> None | SynTypeDefnSimpleRepr.LibraryOnlyILAssembly _ -> None - | SynTypeDefnSimpleRepr.Record _ -> None + | SynTypeDefnSimpleRepr.Union _ + | SynTypeDefnSimpleRepr.Record _ -> + if tycon.IsStructRecordOrUnionTycon then Some(cenv.g.system_Value_typ) + else None | SynTypeDefnSimpleRepr.General (kind,_,slotsigs,fields,isConcrete,_,_,_) -> let kind = InferTyconKind cenv.g (kind,attrs,slotsigs,fields,inSig,isConcrete,m) @@ -14090,18 +14642,16 @@ module EstablishTypeDefinitionCores = begin // Publish the super type tycon.TypeContents.tcaug_super <- super - with e -> errorRecovery e m) + with e -> errorRecovery e m)) /// Establish the fields, dispatch slots and union cases of a type - let private TcTyconDefnCore_Phase6_EstablishRepresentation cenv envinner tpenv inSig (TyconDefnCoreIndexed(_,synTyconRepr,_,_,_,tyconIdx)) (tycon:Tycon) (checkedAttrs:Attribs) = + let private TcTyconDefnCore_Phase1G_EstablishRepresentation cenv envinner tpenv inSig (MutRecDefnsPhase1DataForTycon(_,synTyconRepr,_,_,_,_)) (tycon:Tycon) (attrs:Attribs) = let m = tycon.Range try let id = tycon.Id let thisTyconRef = mkLocalTyconRef tycon - let innerParent = Parent(thisTyconRef) + let innerParent = Parent thisTyconRef let thisTyInst,thisTy = generalizeTyconRef thisTyconRef - let attrs = checkedAttrs - let hasAbstractAttr = HasFSharpAttribute cenv.g cenv.g.attrib_AbstractClassAttribute attrs let hasSealedAttr = @@ -14112,7 +14662,7 @@ module EstablishTypeDefinitionCores = begin TryFindFSharpBoolAttribute cenv.g cenv.g.attrib_SealedAttribute attrs let hasMeasureAttr = HasFSharpAttribute cenv.g cenv.g.attrib_MeasureAttribute attrs - // TODO: for hasMeasureableAttr we need to be stricter about checking these + // REVIEW: for hasMeasureableAttr we need to be stricter about checking these // are only used on exactly the right kinds of type definitions and not inconjunction with other attributes. let hasMeasureableAttr = HasFSharpAttribute cenv.g cenv.g.attrib_MeasureableAttribute attrs let hasCLIMutable = HasFSharpAttribute cenv.g cenv.g.attrib_CLIMutableAttribute attrs @@ -14177,14 +14727,15 @@ module EstablishTypeDefinitionCores = begin let writeFakeRecordFieldsToSink (fields:RecdField list) = let nenv = envinner.NameEnv // Record fields should be visible from IntelliSense, so add fake names for them (similarly to "let a = ..") - for fspec in (fields |> List.filter (fun fspec -> not fspec.IsCompilerGenerated)) do - let info = RecdFieldInfo(thisTyInst, thisTyconRef.MakeNestedRecdFieldRef fspec) - let nenv' = AddFakeNameToNameEnv fspec.Name nenv (Item.RecdField info) - // Name resolution gives better info for tooltips - let item = FreshenRecdFieldRef cenv.nameResolver m (thisTyconRef.MakeNestedRecdFieldRef fspec) - CallNameResolutionSink cenv.tcSink (fspec.Range,nenv,item,item,ItemOccurence.Binding,envinner.DisplayEnv,ad) - // Environment is needed for completions - CallEnvSink cenv.tcSink (fspec.Range, nenv', ad) + for fspec in fields do + if not fspec.IsCompilerGenerated then + let info = RecdFieldInfo(thisTyInst, thisTyconRef.MakeNestedRecdFieldRef fspec) + let nenv' = AddFakeNameToNameEnv fspec.Name nenv (Item.RecdField info) + // Name resolution gives better info for tooltips + let item = FreshenRecdFieldRef cenv.nameResolver m (thisTyconRef.MakeNestedRecdFieldRef fspec) + CallNameResolutionSink cenv.tcSink (fspec.Range,nenv,item,item,ItemOccurence.Binding,envinner.DisplayEnv,ad) + // Environment is needed for completions + CallEnvSink cenv.tcSink (fspec.Range, nenv', ad) // Notify the Language Service about constructors in discriminated union declaration let writeFakeUnionCtorsToSink (unionCases: UnionCase list) = @@ -14198,16 +14749,21 @@ module EstablishTypeDefinitionCores = begin CallNameResolutionSink cenv.tcSink (unionCase.Range,nenv,item,item,ItemOccurence.Binding,envinner.DisplayEnv,ad) CallEnvSink cenv.tcSink (unionCase.Id.idRange, nenv', ad) - let theTypeRepresentation, baseValOpt, safeInitInfo = + let typeRepr, baseValOpt, safeInitInfo = match synTyconRepr with + | SynTypeDefnSimpleRepr.Exception synExnDefnRepr -> + let parent = Parent (mkLocalTyconRef tycon) + TcExceptionDeclarations.TcExnDefnCore_Phase1G_EstablishRepresentation cenv envinner parent tycon synExnDefnRepr |> ignore + TNoRepr, None, NoSafeInitInfo + | SynTypeDefnSimpleRepr.None _ -> hiddenReprChecks(false) noAllowNullLiteralAttributeCheck() if hasMeasureAttr then - let repr = TFsObjModelRepr { fsobjmodel_kind=TTyconClass - fsobjmodel_vslots=[] - fsobjmodel_rfields= MakeRecdFieldsTable [] } + let repr = TFSharpObjectRepr { fsobjmodel_kind=TTyconClass + fsobjmodel_vslots=[] + fsobjmodel_rfields= MakeRecdFieldsTable [] } repr, None, NoSafeInitInfo else TNoRepr, None, NoSafeInitInfo @@ -14252,6 +14808,10 @@ module EstablishTypeDefinitionCores = begin noAllowNullLiteralAttributeCheck() structLayoutAttributeCheck(false) let unionCases = TcRecdUnionAndEnumDeclarations.TcUnionCaseDecls cenv envinner innerParent thisTy tpenv unionCases + + if tycon.IsStructRecordOrUnionTycon && unionCases.Length > 1 then + errorR(Error(FSComp.SR.tcStructUnionMultiCase(),m)) + writeFakeUnionCtorsToSink unionCases MakeUnionRepr unionCases, None, NoSafeInitInfo @@ -14358,6 +14918,7 @@ module EstablishTypeDefinitionCores = begin let baseIdOpt = match synTyconRepr with | SynTypeDefnSimpleRepr.None _ -> None + | SynTypeDefnSimpleRepr.Exception _ -> None | SynTypeDefnSimpleRepr.TypeAbbrev _ -> None | SynTypeDefnSimpleRepr.Union _ -> None | SynTypeDefnSimpleRepr.LibraryOnlyILAssembly _ -> None @@ -14390,7 +14951,7 @@ module EstablishTypeDefinitionCores = begin let safeInitFields = match safeInitInfo with SafeInitField (_, fld) -> [fld] | NoSafeInitInfo -> [] let repr = - TFsObjModelRepr + TFSharpObjectRepr { fsobjmodel_kind=kind fsobjmodel_vslots= abstractSlots fsobjmodel_rfields=MakeRecdFieldsTable (userFields @ implicitStructFields @ safeInitFields) } @@ -14410,13 +14971,13 @@ module EstablishTypeDefinitionCores = begin writeFakeRecordFieldsToSink fields' let repr = - TFsObjModelRepr + TFSharpObjectRepr { fsobjmodel_kind=kind fsobjmodel_vslots=[] fsobjmodel_rfields= MakeRecdFieldsTable (vfld :: fields') } repr, None, NoSafeInitInfo - tycon.Data.entity_tycon_repr <- theTypeRepresentation + tycon.Data.entity_tycon_repr <- typeRepr // We check this just after establishing the representation if TyconHasUseNullAsTrueValueAttribute cenv.g tycon && not (CanHaveUseNullAsTrueValueAttribute cenv.g tycon) then errorR(Error(FSComp.SR.tcInvalidUseNullAsTrueValue(),m)) @@ -14428,13 +14989,13 @@ module EstablishTypeDefinitionCores = begin errorR(Error(FSComp.SR.tcConditionalAttributeUsage(),m)) | _ -> () - (baseValOpt, safeInitInfo, tyconIdx) + (baseValOpt, safeInitInfo) with e -> errorRecovery e m - None, NoSafeInitInfo, tyconIdx + None, NoSafeInitInfo /// Check that a set of type definitions is free of cycles in abbreviations - let private CheckForCyclicAbbreviations _cenv tycons = + let private TcTyconDefnCore_CheckForCyclicAbbreviations tycons = let edgesFrom (tycon:Tycon) = @@ -14499,7 +15060,7 @@ module EstablishTypeDefinitionCores = begin /// Check that a set of type definitions is free of inheritance cycles - let CheckForCyclicStructsAndInheritance cenv tycons = + let TcTyconDefnCore_CheckForCyclicStructsAndInheritance cenv tycons = // Overview: // Given several tycons now being defined (the "intial" tycons). // Look for cycles in inheritance and struct-field-containment. @@ -14588,11 +15149,18 @@ module EstablishTypeDefinitionCores = begin else // Only collect once from each type instance. let doneTypes = ty :: doneTypes - let fspecs = structTycon.AllFieldsAsList |> List.filter (fun fspec -> includeStaticFields || not fspec.IsStatic) + let fspecs = + if structTycon.IsUnionTycon then + [ for uc in structTycon.UnionCasesArray do + for c in uc.FieldTable.AllFieldsAsList do + yield c] + else + structTycon.AllFieldsAsList + let fspecs = fspecs |> List.filter (fun fspec -> includeStaticFields || not fspec.IsStatic) let doneTypes,acc = List.foldBack (accStructField structTycon tinst) fspecs (doneTypes,acc) doneTypes,acc and accStructInstanceFields ty structTycon tinst (doneTypes,acc) = accStructFields false ty structTycon tinst (doneTypes,acc) - and accStructAllFields ty structTycon tinst (doneTypes,acc) = accStructFields true ty structTycon tinst (doneTypes,acc) + and accStructAllFields ty (structTycon: Tycon) tinst (doneTypes,acc) = accStructFields true ty structTycon tinst (doneTypes,acc) let acc = [] let acc = @@ -14620,117 +15188,198 @@ module EstablishTypeDefinitionCores = begin tycon.Data.entity_tycon_repr <- TNoRepr errorR(Error(FSComp.SR.tcTypeDefinitionIsCyclicThroughInheritance(),tycon.Range))) - let isAugmentationTyconDefnRepr x = match x with (SynTypeDefnSimpleRepr.General(TyconAugmentation,_,_,_,_,_,_,_)) -> true | _ -> false - - let TcTyconDefnCores cenv env inSig parent tpenv (typeDefCores:TyconDefnCore list, m, scopem) = - - // Add indexes - let typeDefCores = typeDefCores |> List.mapi (fun i (TyconDefnCore(info,repr,m,preEstablishedHasDefaultCtor,hasSelfReferentialCtor)) -> TyconDefnCoreIndexed(info,repr,m,preEstablishedHasDefaultCtor,hasSelfReferentialCtor,i)) - // Skip augmentations - let tdefsForAugmentations, typeDefCores = typeDefCores |> List.partition (fun (TyconDefnCoreIndexed(_,repr,_,_,_,_)) -> isAugmentationTyconDefnRepr repr) - - // First define the type constructors and the abbreviations, if any. - let tycons = typeDefCores |> List.map (TcTyconDefnCore_Phase0_BuildInitialTycon cenv env parent) - - // Publish the preliminary tycons - tycons |> List.iter (fun tycon -> - // recheck these in case type is a duplicate in a mutually recursive set - CheckForDuplicateConcreteType cenv env tycon.LogicalName tycon.Range - CheckForDuplicateModule cenv env tycon.LogicalName tycon.Range - PublishTypeDefn cenv env tycon) - - // Add them to the environment, though this does not add the fields and - // constructors (because we haven't established them yet). - // We re-add them to the original environment later on. - // We don't report them to the Language Service yet as we don't know if - // they are well-formed (e.g. free of abbreviation cycles - see bug 952) - let envinner = AddLocalTycons cenv.g cenv.amap scopem tycons env + // Interlude between Phase1D and Phase1E - Check and publish the explicit constraints. + let TcMutRecDefns_CheckExplicitConstraints cenv tpenv m checkCxs envMutRecPrelim withEnvs = + (envMutRecPrelim,withEnvs) ||> MutRecShapes.iterTyconsWithEnv (fun envForDecls (origInfo, tyconOpt) -> + match origInfo, tyconOpt with + | (typeDefCore,_,_), Some (tycon:Tycon) -> + let (MutRecDefnsPhase1DataForTycon(synTyconInfo,_,_,_,_,_)) = typeDefCore + let (ComponentInfo(_,_, synTyconConstraints,_,_,_, _,_)) = synTyconInfo + let envForTycon = AddDeclaredTypars CheckForDuplicateTypars (tycon.Typars(m)) envForDecls + let thisTyconRef = mkLocalTyconRef tycon + let envForTycon = MakeInnerEnvForTyconRef cenv envForTycon thisTyconRef false + try TcTyparConstraints cenv NoNewTypars checkCxs ItemOccurence.UseInType envForTycon tpenv synTyconConstraints |> ignore + with e -> errorRecovery e m + | _ -> ()) + + + let TcMutRecDefns_Phase1 mkLetInfo cenv envInitial parent inSig tpenv m scopem mutRecNSInfo (typeDefCores:MutRecShapes) = + + // Phase1A - build Entity for type definitions, exception definitions and module definitions. + // Also for abbreviations of any of these. Augmentations are skipped in this phase. + let withEntities = + typeDefCores + |> MutRecShapes.mapWithParent + (parent, envInitial) + // Build the initial entity for each module definition + (fun (innerParent, envForDecls) compInfo -> + TcTyconDefnCore_Phase1A_BuildInitialModule cenv envForDecls innerParent compInfo) + + // Build the initial Tycon for each type definition + (fun (innerParent, envForDecls) (typeDefCore,tyconMemberInfo) -> + let (MutRecDefnsPhase1DataForTycon(_,_,_,_,_,isAtOriginalTyconDefn)) = typeDefCore + let tyconOpt = + if isAtOriginalTyconDefn then + Some (TcTyconDefnCore_Phase1A_BuildInitialTycon cenv envForDecls innerParent typeDefCore) + else + None + (typeDefCore, tyconMemberInfo, innerParent), tyconOpt) + + // Bundle up the data for each 'val', 'member' or 'let' definition (just package up the data, no processing yet) + (fun (innerParent,_) synBinds -> + let containerInfo = ModuleOrNamespaceContainerInfo(match innerParent with Parent p -> p | _ -> failwith "unreachable") + mkLetInfo containerInfo synBinds) + + // Phase1AB - Publish modules + let envTmp, withEnvs = + (envInitial, withEntities) ||> MutRecShapes.computeEnvs + (fun envAbove (MutRecDefnsPhase2DataForModule (mtypeAcc, mspec)) -> + PublishModuleDefn cenv envAbove mspec + MakeInnerEnvWithAcc envAbove mspec.Id mtypeAcc mspec.ModuleOrNamespaceType.ModuleOrNamespaceKind) + (fun envAbove _ -> envAbove) + + // Updates the types of the modules to contain the contents so far, which now includes the nested modules and types + MutRecBindingChecking.TcMutRecDefns_UpdateModuleContents mutRecNSInfo withEnvs + + // Publish tycons + (envTmp, withEnvs) ||> MutRecShapes.iterTyconsWithEnv + (fun envAbove (_, tyconOpt) -> + tyconOpt |> Option.iter (fun tycon -> + // recheck these in case type is a duplicate in a mutually recursive set + CheckForDuplicateConcreteType envAbove tycon.LogicalName tycon.Range + CheckForDuplicateModule envAbove tycon.LogicalName tycon.Range + PublishTypeDefn cenv envAbove tycon)) + + // Updates the types of the modules to contain the contents so far + MutRecBindingChecking.TcMutRecDefns_UpdateModuleContents mutRecNSInfo withEnvs + + // Phase1AB - Compute the active environments within each nested module. + // + // Add the types to the environment. This does not add the fields and union cases (because we haven't established them yet). + // We re-add them to the original environment later on. We don't report them to the Language Service yet as we don't know if + // they are well-formed (e.g. free of abbreviation cycles) + let envMutRecPrelim, withEnvs = (envInitial, withEntities) ||> MutRecBindingChecking.TcMutRecDefns_ComputeEnvs snd (fun _ -> []) cenv false scopem m - // Establish the kind of each type constructor + // Phase 1B. Establish the kind of each type constructor // Here we run InferTyconKind and record partial information about the kind of the type constructor. // This means TyconObjModelKind is set, which means isSealedTy, isInterfaceTy etc. give accurate results. - let checkedAttrsList = (typeDefCores,tycons) ||> List.map2 (TcTyconDefnCore_Phase1_EstablishBasicKind cenv inSig envinner) + let withAttrs = + (envMutRecPrelim, withEnvs) ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls (origInfo,tyconOpt) -> + let res = + match origInfo, tyconOpt with + | (typeDefCore,_,_), Some tycon -> Some (tycon,TcTyconDefnCore_Phase1B_EstablishBasicKind cenv inSig envForDecls typeDefCore tycon) + | _ -> None + origInfo, res) - // Establish the abbreviations (no constraint checking, because constraints not yet established) - (typeDefCores,tycons,checkedAttrsList) |||> List.iter3 (TcTyconDefnCore_Phase2_Phase4_EstablishAbbreviations cenv envinner inSig tpenv FirstPass) + // Phase 1C. Establish the abbreviations (no constraint checking, because constraints not yet established) + (envMutRecPrelim, withAttrs) ||> MutRecShapes.iterTyconsWithEnv (fun envForDecls (origInfo,tyconAndAttrsOpt) -> + match origInfo, tyconAndAttrsOpt with + | (typeDefCore, _,_), Some (tycon,(attrs,_)) -> TcTyconDefnCore_Phase1C_Phase1E_EstablishAbbreviations cenv envForDecls inSig tpenv FirstPass typeDefCore tycon attrs + | _ -> ()) // Check for cyclic abbreviations. If this succeeds we can start reducing abbreviations safely. - CheckForCyclicAbbreviations cenv tycons + let tycons = withEntities |> MutRecShapes.collectTycons |> List.choose snd - // Establish the super type and interfaces (no constraint checking, because constraints not yet established) - TcTyconDefnCore_Phase3_Phase5_EstablishSuperTypesAndInterfaceTypes cenv envinner tpenv inSig typeDefCores tycons FirstPass checkedAttrsList + TcTyconDefnCore_CheckForCyclicAbbreviations tycons - // REVIEW: we should separate the checking for cyclic hierarchies and cyclic structs - // REVIEW: this is because in some extreme cases the TcTyparConstraints call below could - // exercise a cyclic hierarchy (and thus not terminate) before the cycle checking has been - // performed. Likewise operations in phases 3-6 could also exercise a cyclic hierarchy - - // Add the interface and member declarations for hash/compare. Because this adds interfaces, this may let constraints - // be satisfied, so we have to do this prior to checking any constraints. + // Phase 1D. Establish the super type and interfaces (no constraint checking, because constraints not yet established) + (envMutRecPrelim, withAttrs) |> TcTyconDefnCore_Phase1D_Phase1F_EstablishSuperTypesAndInterfaceTypes cenv tpenv inSig FirstPass + // Interlude between Phase1D and Phase1E - Add the interface and member declarations for + // hash/compare. Because this adds interfaces, this may let constraints + // be satisfied, so we have to do this prior to checking any constraints. + // + // First find all the field types in all the structrual types + let tyconsWithStructuralTypes = + (envMutRecPrelim,withEnvs) + ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls (origInfo, tyconOpt) -> + match origInfo, tyconOpt with + | (typeDefCore,_,_), Some tycon -> Some (tycon,GetStructuralElementsOfTyconDefn cenv envForDecls tpenv typeDefCore tycon) + | _ -> None) + |> MutRecShapes.collectTycons + |> List.choose id - - // Find all the field types in all the structrual types - let structuralTypes = (typeDefCores,tycons) ||> List.map2 (GetStructuralElementsOfTyconDefn cenv envinner tpenv) - - let scSet = TyconConstraintInference.InferSetOfTyconsSupportingComparable cenv envinner structuralTypes tycons - let seSet = TyconConstraintInference.InferSetOfTyconsSupportingEquatable cenv envinner structuralTypes tycons - - tycons |> List.iter (AddAugmentationDeclarations.AddGenericHashAndComparisonDeclarations cenv env scSet seSet) + let scSet = TyconConstraintInference.InferSetOfTyconsSupportingComparable cenv envMutRecPrelim.DisplayEnv tyconsWithStructuralTypes + let seSet = TyconConstraintInference.InferSetOfTyconsSupportingEquatable cenv envMutRecPrelim.DisplayEnv tyconsWithStructuralTypes - // Check and publish the explicit constraints. - let checkExplicitConstraints checkCxs = - (typeDefCores,tycons) ||> List.iter2 (fun (TyconDefnCoreIndexed(synTyconInfo,_,_,_,_,_)) tycon -> - let (ComponentInfo(_,_, wcs,_,_,_, _,_)) = synTyconInfo - let envinner = AddDeclaredTypars CheckForDuplicateTypars (tycon.Typars(m)) envinner - let thisTyconRef = mkLocalTyconRef tycon - let envinner = MakeInnerEnvForTyconRef cenv envinner thisTyconRef false - try TcTyparConstraints cenv NoNewTypars checkCxs ItemOccurence.UseInType envinner tpenv wcs |> ignore - with e -> errorRecovery e m) + (envMutRecPrelim,withEnvs) + ||> MutRecShapes.iterTyconsWithEnv (fun envForDecls (_, tyconOpt) -> + tyconOpt |> Option.iter (AddAugmentationDeclarations.AddGenericHashAndComparisonDeclarations cenv envForDecls scSet seSet)) - checkExplicitConstraints NoCheckCxs + TcMutRecDefns_CheckExplicitConstraints cenv tpenv m NoCheckCxs envMutRecPrelim withEnvs // No inferred constraints allowed on declared typars - tycons |> List.iter (fun tc -> tc.Typars(m) |> List.iter (SetTyparRigid cenv.g env.DisplayEnv m)) + (envMutRecPrelim,withEnvs) ||> MutRecShapes.iterTyconsWithEnv (fun envForDecls (_, tyconOpt) -> + tyconOpt |> Option.iter (fun tycon -> tycon.Typars(m) |> List.iter (SetTyparRigid cenv.g envForDecls.DisplayEnv m))) - // OK, now recheck the abbreviations, super/interface and explicit constraints types (this time checking constraints) - (typeDefCores,tycons,checkedAttrsList) |||> List.iter3 (TcTyconDefnCore_Phase2_Phase4_EstablishAbbreviations cenv envinner inSig tpenv SecondPass) - TcTyconDefnCore_Phase3_Phase5_EstablishSuperTypesAndInterfaceTypes cenv envinner tpenv inSig typeDefCores tycons SecondPass checkedAttrsList - checkExplicitConstraints CheckCxs - + // Phase1E. OK, now recheck the abbreviations, super/interface and explicit constraints types (this time checking constraints) + (envMutRecPrelim, withAttrs) ||> MutRecShapes.iterTyconsWithEnv (fun envForDecls (origInfo,tyconAndAttrsOpt) -> + match origInfo, tyconAndAttrsOpt with + | (typeDefCore, _, _), Some (tycon,(attrs,_)) -> TcTyconDefnCore_Phase1C_Phase1E_EstablishAbbreviations cenv envForDecls inSig tpenv SecondPass typeDefCore tycon attrs + | _ -> ()) + + // Phase1F. Establish inheritance hierarchy + (envMutRecPrelim, withAttrs) |> TcTyconDefnCore_Phase1D_Phase1F_EstablishSuperTypesAndInterfaceTypes cenv tpenv inSig SecondPass + + TcMutRecDefns_CheckExplicitConstraints cenv tpenv m CheckCxs envMutRecPrelim withEnvs + + // Add exception definitions to the environments, which are used for checking exception abbreviations in representations + let envMutRecPrelim, withAttrs = + (envMutRecPrelim, withAttrs) + ||> MutRecShapes.extendEnvs (fun envForDecls decls -> + let tycons = decls |> List.choose (function MutRecShape.Tycon (_, Some (tycon,_)) -> Some tycon | _ -> None) + let exns = tycons |> List.filter (fun tycon -> tycon.IsExceptionDecl) + let envForDecls = (envForDecls, exns) ||> List.fold (AddLocalExnDefnAndReport cenv.tcSink scopem) + envForDecls) + + // Phase1G. Establish inheritance hierarchy // Now all the type parameters, abbreviations, constraints and kind information is established. // Now do the representations. Each baseValOpt is a residue from the representation which is potentially available when // checking the members. - let baseValOpts, safeInitValOpts = - let baseValOptsForTycons = (typeDefCores,tycons,checkedAttrsList) |||> List.map3 (TcTyconDefnCore_Phase6_EstablishRepresentation cenv envinner tpenv inSig) - // Make sure we return a 'None' for each augmentation as well. These can't use 'base' - let baseValOptsForAugmentations = tdefsForAugmentations |> List.map (fun (TyconDefnCoreIndexed(_,_,_,_,_,idx)) -> (None, NoSafeInitInfo, idx)) - // Collect them up, sort them by index - (baseValOptsForAugmentations @ baseValOptsForTycons) |> List.sortBy p33 |> List.map (fun (a,b,_) -> (a,b)) |> List.unzip + let withBaseValsAndSafeInitInfos = + (envMutRecPrelim,withAttrs) ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls (origInfo,tyconAndAttrsOpt) -> + let info = + match origInfo, tyconAndAttrsOpt with + | (typeDefCore,_,_), Some (tycon,(attrs,_)) -> TcTyconDefnCore_Phase1G_EstablishRepresentation cenv envForDecls tpenv inSig typeDefCore tycon attrs + | _ -> None, NoSafeInitInfo + let tyconOpt, fixupFinalAttrs = + match tyconAndAttrsOpt with + | None -> None, (fun () -> ()) + | Some (tycon, (_prelimAttrs, getFinalAttrs)) -> Some tycon, (fun () -> tycon.Data.entity_attribs <- getFinalAttrs()) + + (origInfo, tyconOpt, fixupFinalAttrs, info)) // Now check for cyclic structs and inheritance. It's possible these should be checked as separate conditions. // REVIEW: checking for cyclic inheritance is happening too late. See note above. - CheckForCyclicStructsAndInheritance cenv tycons - - // Add the tycons again to the environment (again) - this will add the constructors and fields. - let env = AddLocalTyconsAndReport cenv.tcSink cenv.g cenv.amap scopem tycons env + TcTyconDefnCore_CheckForCyclicStructsAndInheritance cenv tycons - (tycons, env, baseValOpts, safeInitValOpts) -end // module EstablishTypeDefinitionCores + (tycons, envMutRecPrelim, withBaseValsAndSafeInitInfos) -module TcTypeDeclarations = begin +/// Bind declarations in implementation and signature files +module TcDeclarations = /// Given a type definition, compute whether its members form an extension of an existing type, and if so if it is an /// intrinsic or extrinsic extension - let private ComputeTyconDeclKind isAtOriginalTyconDefn cenv env inSig m (typars:SynTyparDecl list) cs longPath = - let ad = env.eAccessRights + let private ComputeTyconDeclKind tyconOpt isAtOriginalTyconDefn cenv envForDecls inSig m (typars:SynTyparDecl list) cs longPath = + let ad = envForDecls.eAccessRights let tcref = + match tyconOpt with + | Some tycon when isAtOriginalTyconDefn -> + + // This records a name resolution of the type at the location let resInfo = TypeNameResolutionStaticArgsInfo.FromTyArgs typars.Length - match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Binding OpenQualified env.eNameResEnv ad longPath resInfo PermitDirectReferenceToGeneratedType.No with + ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Binding OpenQualified envForDecls.eNameResEnv ad longPath resInfo PermitDirectReferenceToGeneratedType.No + |> ignore + + mkLocalTyconRef tycon + + | _ -> + let resInfo = TypeNameResolutionStaticArgsInfo.FromTyArgs typars.Length + match ResolveTypeLongIdent cenv.tcSink cenv.nameResolver ItemOccurence.Binding OpenQualified envForDecls.eNameResEnv ad longPath resInfo PermitDirectReferenceToGeneratedType.No with | Result res -> res | res when inSig && longPath.Length = 1 -> errorR(Deprecated(FSComp.SR.tcReservedSyntaxForAugmentation(),m)) @@ -14742,14 +15391,6 @@ module TcTypeDeclarations = begin tcref.Deref.IsFSharpDelegateTycon || tcref.Deref.IsFSharpEnumTycon - let isInSameModuleOrNamespace = - match env.eModuleOrNamespaceTypeAccumulator.Value.TypesByMangledName.TryFind(tcref.LogicalName) with - | Some tycon -> (tyconOrder.Compare(tcref.Deref,tycon) = 0) - | None -> - //false - // There is a special case we allow when compiling FSharp.Core.dll which permits interface implementations across namespace fragments - (cenv.g.compilingFslib && tcref.LogicalName.StartsWith("Tuple`")) - let reqTypars = tcref.Typars(m) // Member definitions are intrinsic (added directly to the type) if: @@ -14757,10 +15398,19 @@ module TcTypeDeclarations = begin // Augmentations to interfaces via partial type defns will always be extensions, e.g. extension members on interfaces. // b) For other types, if the type is isInSameModuleOrNamespace let declKind,typars = - if isAtOriginalTyconDefn then - ModuleOrMemberBinding, reqTypars + if isAtOriginalTyconDefn then + ModuleOrMemberBinding, reqTypars - elif isInSameModuleOrNamespace && not isInterfaceOrDelegateOrEnum then + else + let isInSameModuleOrNamespace = + match envForDecls.eModuleOrNamespaceTypeAccumulator.Value.TypesByMangledName.TryFind(tcref.LogicalName) with + | Some tycon -> (tyconOrder.Compare(tcref.Deref,tycon) = 0) + | None -> + //false + // There is a special case we allow when compiling FSharp.Core.dll which permits interface implementations across namespace fragments + (cenv.g.compilingFslib && tcref.LogicalName.StartsWith("Tuple`")) + + if isInSameModuleOrNamespace && not isInterfaceOrDelegateOrEnum then IntrinsicExtensionBinding, reqTypars else if isInSameModuleOrNamespace && isInterfaceOrDelegateOrEnum then @@ -14770,10 +15420,10 @@ module TcTypeDeclarations = begin // not recoverable error(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) - let declaredTypars = TcTyparDecls cenv env typars - let envinner = AddDeclaredTypars CheckForDuplicateTypars declaredTypars env - let _tpenv = TcTyparConstraints cenv NoNewTypars CheckCxs ItemOccurence.UseInType envinner emptyUnscopedTyparEnv cs - declaredTypars |> List.iter (SetTyparRigid cenv.g env.DisplayEnv m) + let declaredTypars = TcTyparDecls cenv envForDecls typars + let envForTycon = AddDeclaredTypars CheckForDuplicateTypars declaredTypars envForDecls + let _tpenv = TcTyparConstraints cenv NoNewTypars CheckCxs ItemOccurence.UseInType envForTycon emptyUnscopedTyparEnv cs + declaredTypars |> List.iter (SetTyparRigid cenv.g envForDecls.DisplayEnv m) if not (typarsAEquiv cenv.g TypeEquivEnv.Empty reqTypars declaredTypars) then errorR(Error(FSComp.SR.tcDeclaredTypeParametersForExtensionDoNotMatchOriginal(tcref.DisplayNameWithStaticParametersAndUnderscoreTypars), m)) ExtrinsicExtensionBinding, declaredTypars @@ -14782,6 +15432,7 @@ module TcTypeDeclarations = begin declKind, tcref, typars + let private isAugmentationTyconDefnRepr = function (SynTypeDefnSimpleRepr.General(TyconAugmentation,_,_,_,_,_,_,_)) -> true | _ -> false let private isAutoProperty = function SynMemberDefn.AutoProperty _ -> true | _ -> false let private isMember = function SynMemberDefn.Member _ -> true | _ -> false let private isImplicitCtor = function SynMemberDefn.ImplicitCtor _ -> true | _ -> false @@ -14850,16 +15501,13 @@ module TcTypeDeclarations = begin | _ -> () - /// Parallels SplitTyconSignature/SplitTyconDefn] /// Separates the definition into core (shape) and body. + /// /// core = synTyconInfo,simpleRepr,interfaceTypes /// where simpleRepr can contain inherit type, declared fields and virtual slots. /// body = members /// where members contain methods/overrides, also implicit ctor, inheritCall and local definitions. - ///------ - /// The tinfos arg are the enclosing types when processing nested types... - /// The tinfos arg is not currently used... just stacked up. - let rec private SplitTyconDefn (cenv:cenv) tinfos (TypeDefn(synTyconInfo,trepr,extraMembers,_)) = + let rec private SplitTyconDefn (TypeDefn(synTyconInfo,trepr,extraMembers,_)) = let implements1 = List.choose (function SynMemberDefn.Interface (ty,_,_) -> Some(ty,ty.Range) | _ -> None) extraMembers match trepr with | SynTypeDefnRepr.ObjectModel(kind,cspec,m) -> @@ -14870,7 +15518,7 @@ module TcTypeDeclarations = begin | SynMemberDefn.Inherit (ty,idOpt,m) -> Some(ty,m,idOpt) | SynMemberDefn.ImplicitInherit (ty,_,idOpt,m) -> Some(ty,m,idOpt) | _ -> None) - let tycons = cspec |> List.choose (function SynMemberDefn.NestedType (x,_,_) -> Some(x) | _ -> None) + //let nestedTycons = cspec |> List.choose (function SynMemberDefn.NestedType (x,_,_) -> Some(x) | _ -> None) let slotsigs = cspec |> List.choose (function SynMemberDefn.AbstractSlot (x,y,_) -> Some(x,y) | _ -> None) let members = @@ -14970,8 +15618,6 @@ module TcTypeDeclarations = begin preMembers @ postMembers - let a,b = SplitTyconDefns cenv (tinfos @ [synTyconInfo]) tycons - let isConcrete = members |> List.exists (function | SynMemberDefn.Member(Binding(_,_,_,_,_,_,SynValData(Some memberFlags,_,_),_,_,_,_,_),_) -> not memberFlags.IsDispatchSlot @@ -15005,62 +15651,95 @@ module TcTypeDeclarations = begin memberFlags.MemberKind=MemberKind.Constructor | SynMemberDefn.ImplicitCtor (_,_,spats,_, _) -> isNil spats | _ -> false) - - let core = TyconDefnCore(synTyconInfo, SynTypeDefnSimpleRepr.General(kind,inherits,slotsigs,fields,isConcrete,isIncrClass,implicitCtorSynPats,m), implements2@implements1, preEstablishedHasDefaultCtor, hasSelfReferentialCtor) + let repr = SynTypeDefnSimpleRepr.General(kind,inherits,slotsigs,fields,isConcrete,isIncrClass,implicitCtorSynPats,m) + let isAtOriginalTyconDefn = not (isAugmentationTyconDefnRepr repr) + let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, repr, implements2@implements1, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, isAtOriginalTyconDefn) - core :: a, members :: b + core, members @ extraMembers - | SynTypeDefnRepr.Simple(r,_) -> + | SynTypeDefnRepr.Simple(repr,_) -> let members = [] - let core = TyconDefnCore(synTyconInfo,r,implements1,false,false) - [ core ],[ members ] - - and private SplitTyconDefns cenv tinfos tycons = - let a,b = List.unzip (List.map (SplitTyconDefn cenv tinfos) tycons) - List.concat a, List.concat b + let isAtOriginalTyconDefn = not (isAugmentationTyconDefnRepr repr) + let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, repr, implements1, false, false, isAtOriginalTyconDefn) + core, members @ extraMembers - let private PrepareTyconMemberDefns isAtOriginalTyconDefn cenv env (synTyconInfo, baseValOpt, safeInitInfo, members, tyDeclm, m) = - let (ComponentInfo(_,typars, cs,longPath, _, _, _,_)) = synTyconInfo - - let declKind,tcref, declaredTyconTypars = ComputeTyconDeclKind isAtOriginalTyconDefn cenv env false tyDeclm typars cs longPath - - let newslotsOK = (if isAtOriginalTyconDefn && tcref.IsFSharpObjectModelTycon then NewSlotsOK else NoNewSlots) // NewSlotsOK only on fsobjs - - if nonNil members && tcref.IsTypeAbbrev then errorR(Error(FSComp.SR.tcTypeAbbreviationsCannotHaveAugmentations(), tyDeclm)) - - TyconMemberData(declKind, tcref, baseValOpt, safeInitInfo, declaredTyconTypars, members, m, newslotsOK) + | SynTypeDefnRepr.Exception(r) -> + let isAtOriginalTyconDefn = true + let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, SynTypeDefnSimpleRepr.Exception r, implements1, false, false, isAtOriginalTyconDefn) + core, extraMembers //------------------------------------------------------------------------- - // Bind type definitions - main - //------------------------------------------------------------------------- - - let TcTyconDefns cenv env parent tpenv (typeDefs: SynTypeDefn list,m,scopem) = - let typeDefCores,tyconDefnMembers = SplitTyconDefns cenv [] typeDefs - let tycons, env, baseValOpts, safeInitValOpts = EstablishTypeDefinitionCores.TcTyconDefnCores cenv env false parent tpenv (typeDefCores,m,scopem) - let augments = - (List.zip typeDefs typeDefCores, List.zip baseValOpts safeInitValOpts, tyconDefnMembers) |||> List.map3 (fun (TypeDefn(synTyconInfo,_,extraMembers,m), TyconDefnCore(_,repr,_,_,_)) (baseValOpt, safeInitInfo) members -> - let isAtOriginalTyconDefn = not (EstablishTypeDefinitionCores.isAugmentationTyconDefnRepr repr) - PrepareTyconMemberDefns isAtOriginalTyconDefn cenv env (synTyconInfo, baseValOpt, safeInitInfo, members@extraMembers, synTyconInfo.Range, m)) // TODO gotoDef on 'm' here goes to wrong m, but only inside production.proj - - let valExprBuilders,env = TcTyconMemberDefns cenv env parent m scopem augments + /// Bind a collection of mutually recursive definitions in an implementation file + let TcMutRecDefinitions cenv envInitial parent tpenv m scopem mutRecNSInfo (mutRecDefns: MutRecDefnsInitialData) = + + // Split the definitions into "core representations" and "members". The code to process core representations + // is shared between processing of signature files and implementation files. + let mutRecDefnsAfterSplit = mutRecDefns |> MutRecShapes.mapTycons SplitTyconDefn + + // Create the entities for each module and type definition, and process the core representation of each type definition. + let tycons, envMutRecPrelim, mutRecDefnsAfterCore = + EstablishTypeDefinitionCores.TcMutRecDefns_Phase1 + (fun containerInfo synBinds -> [ for synBind in synBinds -> RecDefnBindingInfo(containerInfo,NoNewSlots,ModuleOrMemberBinding,synBind) ]) + cenv envInitial parent false tpenv m scopem mutRecNSInfo mutRecDefnsAfterSplit + + // Package up the phase two information for processing members. + let mutRecDefnsAfterPrep = + (envMutRecPrelim,mutRecDefnsAfterCore) + ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls ((typeDefnCore, members, innerParent), tyconOpt, fixupFinalAttrs, (baseValOpt, safeInitInfo)) -> + let (MutRecDefnsPhase1DataForTycon(synTyconInfo,_,_,_,_,isAtOriginalTyconDefn)) = typeDefnCore + let tyDeclRange = synTyconInfo.Range + let (ComponentInfo(_,typars, cs,longPath, _, _, _,_)) = synTyconInfo + let declKind, tcref, declaredTyconTypars = ComputeTyconDeclKind tyconOpt isAtOriginalTyconDefn cenv envForDecls false tyDeclRange typars cs longPath + let newslotsOK = (if isAtOriginalTyconDefn && tcref.IsFSharpObjectModelTycon then NewSlotsOK else NoNewSlots) + if nonNil members && tcref.IsTypeAbbrev then + errorR(Error(FSComp.SR.tcTypeAbbreviationsCannotHaveAugmentations(), tyDeclRange)) + MutRecDefnsPhase2DataForTycon(tyconOpt, innerParent, declKind, tcref, baseValOpt, safeInitInfo, declaredTyconTypars, members, tyDeclRange, newslotsOK, fixupFinalAttrs)) + + // By now we've established the full contents of type definitions apart from their + // members and any fields determined by implicit construction. We know the kinds and + // representations of types and have established them as valid. + // + // We now reconstruct the active environments all over again - this will add the union cases and fields. + // + // Note: This environment reconstruction doesn't seem necessary. We're about to create Val's for all members, + // which does require type checking, but no more information than is already available. + let envMutRecPrelimWithReprs, withEnvs = + (envInitial, MutRecShapes.dropEnvs mutRecDefnsAfterPrep) + ||> MutRecBindingChecking.TcMutRecDefns_ComputeEnvs + (fun (MutRecDefnsPhase2DataForTycon(tyconOpt, _, _, _, _, _, _, _, _, _, _)) -> tyconOpt) + (fun _binds -> [ (* no values are available yet *) ]) + cenv true scopem m + + // Check the members and decide on representations for types with implicit constructors. + let withBindings,envFinal = TcMutRecDefns_Phase2 cenv envInitial m scopem mutRecNSInfo envMutRecPrelimWithReprs withEnvs + + // Generate the hash/compare/equality bindings for all tycons. + // // Note: generating these bindings must come after generating the members, since some in the case of structs some fields // may be added by generating the implicit construction syntax - let binds = tycons |> List.collect (AddAugmentationDeclarations.AddGenericHashAndComparisonBindings cenv) - let binds3 = tycons |> List.collect (AddAugmentationDeclarations.AddGenericEqualityBindings cenv env) + let withExtraBindings = + (envFinal,withBindings) ||> MutRecShapes.expandTyconsWithEnv (fun envForDecls (tyconOpt, _) -> + match tyconOpt with + | None -> [],[] + | Some tycon -> + // We put the hash/compare bindings before the type definitions and the + // equality bindings after because tha is the order they've always been generated + // in, and there are code generation tests to check that. + let binds = AddAugmentationDeclarations.AddGenericHashAndComparisonBindings cenv tycon + let binds3 = AddAugmentationDeclarations.AddGenericEqualityBindings cenv envForDecls tycon + binds, binds3) // Check for cyclic structs and inheritance all over again, since we may have added some fields to the struct when generating the implicit construction syntax - EstablishTypeDefinitionCores.CheckForCyclicStructsAndInheritance cenv tycons + EstablishTypeDefinitionCores.TcTyconDefnCore_CheckForCyclicStructsAndInheritance cenv tycons - (binds @ valExprBuilders @ binds3),tycons,env + withExtraBindings,envFinal //------------------------------------------------------------------------- - // Bind type specifications - //------------------------------------------------------------------------- - /// Parallels split_tycon[Spfn/Defn] - let rec private SplitTyconSignature tinfos (TypeDefnSig(synTyconInfo,trepr,extraMembers,_)) = + /// Separates the signature declaration into core (shape) and body. + let rec private SplitTyconSignature (TypeDefnSig(synTyconInfo,trepr,extraMembers,_)) = let implements1 = extraMembers |> List.choose (function SynMemberSig.Interface (f,m) -> Some(f,m) | _ -> None) match trepr with @@ -15068,7 +15747,7 @@ module TcTypeDeclarations = begin let fields = cspec |> List.choose (function SynMemberSig.ValField (f,_) -> Some(f) | _ -> None) let implements2 = cspec |> List.choose (function SynMemberSig.Interface (ty,m) -> Some(ty,m) | _ -> None) let inherits = cspec |> List.choose (function SynMemberSig.Inherit (ty,_) -> Some(ty,m,None) | _ -> None) - let nestedTycons = cspec |> List.choose (function SynMemberSig.NestedType (x,_) -> Some(x) | _ -> None) + //let nestedTycons = cspec |> List.choose (function SynMemberSig.NestedType (x,_) -> Some(x) | _ -> None) let slotsigs = cspec |> List.choose (function SynMemberSig.Member (v,fl,_) when fl.IsDispatchSlot -> Some(v,fl) | _ -> None) let members = cspec |> List.filter (function | SynMemberSig.Interface _ -> true @@ -15094,63 +15773,95 @@ module TcTypeDeclarations = begin let hasSelfReferentialCtor = false - let a,b = nestedTycons |> SplitTyconSignatures (tinfos @ [synTyconInfo]) - - let tyconCore = TyconDefnCore (synTyconInfo, SynTypeDefnSimpleRepr.General(kind,inherits,slotsigs,fields,isConcrete,false,None,m),implements2@implements1,preEstablishedHasDefaultCtor,hasSelfReferentialCtor) + let repr = SynTypeDefnSimpleRepr.General(kind,inherits,slotsigs,fields,isConcrete,false,None,m) + let isAtOriginalTyconDefn = true + let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, repr, implements2@implements1, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, isAtOriginalTyconDefn) - [ tyconCore ] @ a, - [ (synTyconInfo,true,members@extraMembers) ] @ b + tyconCore, (synTyconInfo,members@extraMembers) // 'type X with ...' in a signature is always interpreted as an extrinsic extension. // Representation-hidden types with members and interfaces are written 'type X = ...' - | SynTypeDefnSigRepr.Simple(SynTypeDefnSimpleRepr.None _,_) when nonNil extraMembers -> + | SynTypeDefnSigRepr.Simple((SynTypeDefnSimpleRepr.None _ as r),_) when nonNil extraMembers -> let isAtOriginalTyconDefn = false - [],[ (synTyconInfo,isAtOriginalTyconDefn,extraMembers) ] + let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, r, implements1, false, false, isAtOriginalTyconDefn) + tyconCore, (synTyconInfo,extraMembers) + + | SynTypeDefnSigRepr.Exception(r) -> + let isAtOriginalTyconDefn = true + let core = MutRecDefnsPhase1DataForTycon(synTyconInfo,SynTypeDefnSimpleRepr.Exception r,implements1,false,false,isAtOriginalTyconDefn) + core, (synTyconInfo,extraMembers) | SynTypeDefnSigRepr.Simple(r,_) -> - let tyconCore = TyconDefnCore (synTyconInfo, r, implements1, false, false) - [ tyconCore ],[ (synTyconInfo,true,extraMembers) ] + let isAtOriginalTyconDefn = true + let tyconCore = MutRecDefnsPhase1DataForTycon (synTyconInfo, r, implements1, false, false, isAtOriginalTyconDefn) + tyconCore, (synTyconInfo,extraMembers) - and private SplitTyconSignatures tinfos tycons = - let a,b = tycons |> List.map (SplitTyconSignature tinfos) |> List.unzip - List.concat a, List.concat b - let private TcTyconSignatureMemberSpecs cenv env parent tpenv tyconDefnMembers = - (tpenv, tyconDefnMembers) ||> List.mapFold (fun tpenv (synTyconInfo,isAtOriginalTyconDefn,members) -> - let (ComponentInfo(_,typars,cs,longPath, _, _, _,m)) = synTyconInfo - let declKind,tcref,declaredTyconTypars = ComputeTyconDeclKind isAtOriginalTyconDefn cenv env true m typars cs longPath + let private TcMutRecSignatureDecls_Phase2 cenv scopem envMutRec mutRecDefns = + (envMutRec,mutRecDefns) ||> MutRecShapes.mapWithEnv + // Do this for the members in each 'type' declaration + (fun envForDecls ((tyconCore, (synTyconInfo,members), innerParent), tyconOpt, _fixupFinalAttrs, _) -> + let tpenv = emptyUnscopedTyparEnv + let (MutRecDefnsPhase1DataForTycon (_, _, _, _, _, isAtOriginalTyconDefn)) = tyconCore + let (ComponentInfo(_,typars,cs,longPath, _, _, _,m)) = synTyconInfo + let declKind,tcref,declaredTyconTypars = ComputeTyconDeclKind tyconOpt isAtOriginalTyconDefn cenv envForDecls true m typars cs longPath - let envinner = AddDeclaredTypars CheckForDuplicateTypars declaredTyconTypars env - let envinner = MakeInnerEnvForTyconRef cenv envinner tcref (declKind = ExtrinsicExtensionBinding) + let envForTycon = AddDeclaredTypars CheckForDuplicateTypars declaredTyconTypars envForDecls + let envForTycon = MakeInnerEnvForTyconRef cenv envForTycon tcref (declKind = ExtrinsicExtensionBinding) - TcTyconMemberSpecs cenv envinner (TyconContainerInfo(parent, tcref, declaredTyconTypars, NoSafeInitInfo)) declKind tpenv members) + TcTyconMemberSpecs cenv envForTycon (TyconContainerInfo(innerParent, tcref, declaredTyconTypars, NoSafeInitInfo)) declKind tpenv members) + + // Do this for each 'val' declaration in a module + (fun envForDecls (containerInfo, valSpec) -> + let tpenv = emptyUnscopedTyparEnv + let idvs,_ = TcAndPublishValSpec (cenv,envForDecls,containerInfo,ModuleOrMemberBinding,None,tpenv,valSpec) + let env = List.foldBack (AddLocalVal cenv.tcSink scopem) idvs envForDecls + env) - let TcTyconSignatures cenv env parent tpenv (tspecs:SynTypeDefnSig list,m,scopem) = - let typeDefCores,tyconDefnMembers = SplitTyconSignatures [] tspecs - let _, env, _, _ = EstablishTypeDefinitionCores.TcTyconDefnCores cenv env true parent tpenv (typeDefCores,m,scopem) - let _ = TcTyconSignatureMemberSpecs cenv env parent tpenv tyconDefnMembers - env -end + + /// Bind a collection of mutually recursive declarations in a signature file + let TcMutRecSignatureDecls cenv envInitial parent tpenv m scopem mutRecNSInfo (mutRecSigs:MutRecSigsInitialData) = + let mutRecSigsAfterSplit = mutRecSigs |> MutRecShapes.mapTycons SplitTyconSignature + let _tycons, envMutRec, mutRecDefnsAfterCore = EstablishTypeDefinitionCores.TcMutRecDefns_Phase1 (fun containerInfo valDecl -> (containerInfo, valDecl)) cenv envInitial parent true tpenv m scopem mutRecNSInfo mutRecSigsAfterSplit + + // Updates the types of the modules to contain the contents so far, which now includes values and members + MutRecBindingChecking.TcMutRecDefns_UpdateModuleContents mutRecNSInfo mutRecDefnsAfterCore + + // By now we've established the full contents of type definitions apart from their + // members and any fields determined by implicit construction. We know the kinds and + // representations of types and have established them as valid. + // + // We now reconstruct the active environments all over again - this will add the union cases and fields. + // + // Note: This environment reconstruction doesn't seem necessary. We're about to create Val's for all members, + // which does require type checking, but no more information than is already available. + let envMutRecPrelimWithReprs, withEnvs = + (envInitial, MutRecShapes.dropEnvs mutRecDefnsAfterCore) + ||> MutRecBindingChecking.TcMutRecDefns_ComputeEnvs + (fun (_, tyconOpt, _, _) -> tyconOpt) + (fun _binds -> [ (* no values are available yet *) ]) + cenv true scopem m + + let _ = TcMutRecSignatureDecls_Phase2 cenv scopem envMutRecPrelimWithReprs withEnvs + envMutRec //------------------------------------------------------------------------- // Bind module types //------------------------------------------------------------------------- -let AdjustModuleName modKind nm = (match modKind with FSharpModuleWithSuffix -> nm^FSharpModuleSuffix | _ -> nm) - - -let rec TcSignatureElement cenv parent endm (env: TcEnv) e : Eventually = +let rec TcSignatureElementNonMutRec cenv parent endm (env: TcEnv) synSigDecl : Eventually = eventually { try - match e with + match synSigDecl with | SynModuleSigDecl.Exception (edef,m) -> let scopem = unionRanges m.EndRange endm let _,_,_,env = TcExceptionDeclarations.TcExnSignature cenv env parent emptyUnscopedTyparEnv (edef,scopem) return env - | SynModuleSigDecl.Types (tspecs,m) -> + | SynModuleSigDecl.Types (typeSpecs,m) -> let scopem = unionRanges m endm - let env = TcTypeDeclarations.TcTyconSignatures cenv env parent emptyUnscopedTyparEnv (tspecs,m,scopem) + let mutRecDefns = typeSpecs |> List.map MutRecShape.Tycon + let env = TcDeclarations.TcMutRecSignatureDecls cenv env parent emptyUnscopedTyparEnv m scopem None mutRecDefns return env | SynModuleSigDecl.Open (mp,m) -> @@ -15169,14 +15880,33 @@ let rec TcSignatureElement cenv parent endm (env: TcEnv) e : Eventually = let env = List.foldBack (AddLocalVal cenv.tcSink scopem) idvs env return env - | SynModuleSigDecl.NestedModule(ComponentInfo(attribs,_parms, _constraints,longPath,xml,_,vis,im),mdefs,m) -> - let id = ComputeModuleName longPath - let vis,_ = ComputeAccessAndCompPath env None im vis parent - let! (mspec,_) = TcModuleOrNamespaceSignature cenv env (id,true,mdefs,xml,attribs,vis,m) - let scopem = unionRanges m endm - PublishModuleDefn cenv env mspec; - let env = AddLocalSubModule cenv.tcSink cenv.g cenv.amap m scopem env mspec - return env + | SynModuleSigDecl.NestedModule(ComponentInfo(attribs,_parms, _constraints,longPath,xml,_,vis,im) as compInfo,isRec,mdefs,m) -> + if isRec then + // Treat 'module rec M = ...' as a single mutully recursive definition group 'module M = ...' + let modDecl = SynModuleSigDecl.NestedModule(compInfo,false,mdefs,m) + return! TcSignatureElementsMutRec cenv parent endm None env [modDecl] + else + let id = ComputeModuleName longPath + let vis,_ = ComputeAccessAndCompPath env None im vis parent + let attribs = TcAttributes cenv env AttributeTargets.ModuleDecl attribs + CheckNamespaceModuleOrTypeName cenv.g id + let modKind = EstablishTypeDefinitionCores.ComputeModuleOrNamespaceKind cenv.g true attribs + let modName = EstablishTypeDefinitionCores.AdjustModuleName modKind id.idText + CheckForDuplicateConcreteType env modName id.idRange + CheckForDuplicateModule env id.idText id.idRange + + // Now typecheck the signature, accumulating and then recording the submodule description. + let id = ident (modName, id.idRange) + + let mspec = NewModuleOrNamespace (Some env.eCompPath) vis id (xml.ToXmlDoc()) attribs (notlazy (NewEmptyModuleOrNamespaceType modKind)) + + let! (mtyp,_) = TcModuleOrNamespaceSignatureElementsNonMutRec cenv (Parent (mkLocalModRef mspec)) env (id,modKind,mdefs,m,xml) + + mspec.Data.entity_modul_contents <- notlazy mtyp + let scopem = unionRanges m endm + PublishModuleDefn cenv env mspec + let env = AddLocalSubModuleAndReport cenv.tcSink scopem cenv.g cenv.amap m env mspec + return env | SynModuleSigDecl.ModuleAbbrev (id,p,m) -> let ad = env.eAccessRights @@ -15189,7 +15919,7 @@ let rec TcSignatureElement cenv parent endm (env: TcEnv) e : Eventually = modrefs |> List.iter (fun modref -> CheckEntityAttributes cenv.g modref m |> CommitOperationResult) let env = - if modrefs.Length > 0 then AddModuleAbbreviation cenv.tcSink scopem id modrefs env + if modrefs.Length > 0 then AddModuleAbbreviationAndReport cenv.tcSink scopem id modrefs env else env return env @@ -15197,30 +15927,46 @@ let rec TcSignatureElement cenv parent endm (env: TcEnv) e : Eventually = return env - | SynModuleSigDecl.NamespaceFragment (SynModuleOrNamespaceSig(longId,isModule,defs,xml,attribs,vis,m)) -> + | SynModuleSigDecl.NamespaceFragment (SynModuleOrNamespaceSig(longId,isRec,isModule,defs,xml,attribs,vis,m)) -> do for id in longId do CheckNamespaceModuleOrTypeName cenv.g id - let enclosingNamespacePath = if isModule then fst (List.frontAndBack longId) else longId - - let defs = + // Logically speaking, this changes + // module [rec] A.B.M + // ... + // to + // namespace [rec] A.B + // module M = ... + let enclosingNamespacePath, defs = if isModule then - [SynModuleSigDecl.NestedModule(ComponentInfo(attribs,[], [],[snd(List.frontAndBack longId)],xml,false,vis,m),defs,m)] + let nsp, modName = List.frontAndBack longId + let modDecl = [SynModuleSigDecl.NestedModule(ComponentInfo(attribs,[], [],[modName],xml,false,vis,m),false,defs,m)] + nsp, modDecl else - defs - let envinner = LocateEnv cenv.topCcu env enclosingNamespacePath + longId, defs + + let envNS = LocateEnv cenv.topCcu env enclosingNamespacePath + let envNS = ImplicitlyOpenOwnNamespace cenv.tcSink cenv.g cenv.amap m enclosingNamespacePath envNS + + // For 'namespace rec' and 'module rec' we add the thing being defined + let mtypNS = !(envNS.eModuleOrNamespaceTypeAccumulator) + let mtypRoot, mspecNSOpt = BuildRootModuleType enclosingNamespacePath envNS.eCompPath mtypNS + + // For 'namespace rec' and 'module rec' we add the thing being defined + let envNS = if isRec then AddLocalRootModuleOrNamespace cenv.tcSink cenv.g cenv.amap m envNS mtypRoot else envNS + let nsInfo = Some (mspecNSOpt, envNS.eModuleOrNamespaceTypeAccumulator) + let mutRecNSInfo = if isRec then nsInfo else None + + let! envAtEnd = TcSignatureElements cenv ParentNone m.EndRange envNS xml mutRecNSInfo defs + + MutRecBindingChecking.TcMutRecDefns_UpdateNSContents nsInfo - let envinner = ImplicitlyOpenOwnNamespace cenv.tcSink cenv.g cenv.amap m enclosingNamespacePath envinner - - let! envAtEnd = TcSignatureElements cenv ParentNone m.EndRange envinner xml defs let env = if isNil enclosingNamespacePath then envAtEnd else - let modulTypeRoot = BuildRootModuleType enclosingNamespacePath envinner.eCompPath !(envinner.eModuleOrNamespaceTypeAccumulator) - - let env = AddLocalRootModuleOrNamespace cenv.tcSink cenv.g cenv.amap m env modulTypeRoot + let env = AddLocalRootModuleOrNamespace cenv.tcSink cenv.g cenv.amap m env mtypRoot // If the namespace is an interactive fragment e.g. FSI_0002, then open FSI_0002 in the subsequent environment. let env = @@ -15229,7 +15975,7 @@ let rec TcSignatureElement cenv parent endm (env: TcEnv) e : Eventually = | None -> env // Publish the combined module type - env.eModuleOrNamespaceTypeAccumulator := CombineCcuContentFragments m [!(env.eModuleOrNamespaceTypeAccumulator); modulTypeRoot] + env.eModuleOrNamespaceTypeAccumulator := CombineCcuContentFragments m [!(env.eModuleOrNamespaceTypeAccumulator); mtypRoot] env return env @@ -15239,52 +15985,88 @@ let rec TcSignatureElement cenv parent endm (env: TcEnv) e : Eventually = return env } -and TcSignatureElements cenv parent endm env xml defs = + +and TcSignatureElements cenv parent endm env xml mutRecNSInfo defs = eventually { - // Ensure the deref_nlpath call in UpdateAccModuleOrNamespaceType succeeds + // Ensure the .Deref call in UpdateAccModuleOrNamespaceType succeeds if cenv.compilingCanonicalFslibModuleType then ensureCcuHasModuleOrNamespaceAtPath cenv.topCcu env.ePath env.eCompPath (xml.ToXmlDoc()) - return! Eventually.fold (TcSignatureElement cenv parent endm) env defs + match mutRecNSInfo with + | Some _ -> + return! TcSignatureElementsMutRec cenv parent endm mutRecNSInfo env defs + | None -> + return! TcSignatureElementsNonMutRec cenv parent endm env defs } -and ComputeModuleOrNamespaceKind g isModule attribs = - if not isModule then Namespace - elif ModuleNameIsMangled g attribs then FSharpModuleWithSuffix - else ModuleOrType - -and TcModuleOrNamespaceSignature cenv env (id:Ident,isModule,defs,xml,attribs,vis,m) = - eventually { - let attribs = TcAttributes cenv env AttributeTargets.ModuleDecl attribs - CheckNamespaceModuleOrTypeName cenv.g id - let modKind = ComputeModuleOrNamespaceKind cenv.g isModule attribs - if isModule then CheckForDuplicateConcreteType cenv env (AdjustModuleName modKind id.idText) id.idRange - if isModule then CheckForDuplicateModule cenv env id.idText id.idRange - - // Now typecheck the signature, accumulating and then recording the submodule description. - let id = ident (AdjustModuleName modKind id.idText, id.idRange) +and TcSignatureElementsNonMutRec cenv parent endm env defs = + eventually { + return! Eventually.fold (TcSignatureElementNonMutRec cenv parent endm ) env defs + } - let mspec = NewModuleOrNamespace (Some env.eCompPath) vis id (xml.ToXmlDoc()) attribs (notlazy (NewEmptyModuleOrNamespaceType modKind)) +and TcSignatureElementsMutRec cenv parent endm mutRecNSInfo envInitial (defs: SynModuleSigDecl list) = + eventually { + let m = match defs with [] -> endm | _ -> defs |> List.map (fun d -> d.Range) |> List.reduce unionRanges + let scopem = (defs, endm) ||> List.foldBack (fun h m -> unionRanges h.Range m) + + let mutRecDefns = + let rec loop isNamespace defs : MutRecSigsInitialData = + ((true, true), defs) ||> List.collectFold (fun (openOk, moduleAbbrevOk) def -> + match def with + | SynModuleSigDecl.Types (typeSpecs,_) -> + let decls = typeSpecs |> List.map MutRecShape.Tycon + decls, (false, false) + + | SynModuleSigDecl.Open (lid,m) -> + if not openOk then errorR(Error(FSComp.SR.tcOpenFirstInMutRec(),m)) + let decls = [ MutRecShape.Open (MutRecDataForOpen(lid, m)) ] + decls, (openOk, moduleAbbrevOk) + + | SynModuleSigDecl.Exception (SynExceptionSig(exnRepr,members,_),_) -> + let ( SynExceptionDefnRepr(synAttrs,UnionCase(_,id,_args,_,_,_),_,doc,vis,m)) = exnRepr + let compInfo = ComponentInfo(synAttrs,[],[],[id],doc,false,vis,id.idRange) + let decls = [ MutRecShape.Tycon(SynTypeDefnSig.TypeDefnSig(compInfo, SynTypeDefnSigRepr.Exception exnRepr, members, m)) ] + decls, (false, false) + + | SynModuleSigDecl.Val (vspec,_) -> + if isNamespace then error(NumberedError(FSComp.SR.tcNamespaceCannotContainValues(),vspec.RangeOfId)) + let decls = [ MutRecShape.Lets(vspec) ] + decls, (false, false) + + | SynModuleSigDecl.NestedModule(compInfo,isRec,synDefs,_) -> + if isRec then warning(Error(FSComp.SR.tcRecImplied(),compInfo.Range)) + let mutRecDefs = loop false synDefs + let decls = [MutRecShape.Module (compInfo, mutRecDefs)] + decls, (false, false) + + | SynModuleSigDecl.HashDirective _ -> + [], (openOk, moduleAbbrevOk) + + | SynModuleSigDecl.ModuleAbbrev (id, p, m) -> + if not moduleAbbrevOk then errorR(Error(FSComp.SR.tcModuleAbbrevFirstInMutRec(),m)) + let decls = [ MutRecShape.ModuleAbbrev (MutRecDataForModuleAbbrev(id, p, m)) ] + decls, (false, moduleAbbrevOk) + + | SynModuleSigDecl.NamespaceFragment _ -> + error(Error(FSComp.SR.tcUnsupportedMutRecDecl(),def.Range))) + + |> fst + loop (match parent with ParentNone -> true | Parent _ -> false) defs + return TcDeclarations.TcMutRecSignatureDecls cenv envInitial parent emptyUnscopedTyparEnv m scopem mutRecNSInfo mutRecDefns + } - let innerParent = mkLocalModRef mspec - - let! (mtyp,envAtEnd) = TcModuleOrNamespaceSignatureElements cenv (Parent innerParent) env (id,modKind,defs,m,xml) - mspec.Data.entity_modul_contents <- notlazy mtyp - - return (mspec, envAtEnd) - } -and TcModuleOrNamespaceSignatureElements cenv parent env (id,modKind,defs,m:range,xml) = +and TcModuleOrNamespaceSignatureElementsNonMutRec cenv parent env (id,modKind,defs,m:range,xml) = eventually { let endm = m.EndRange // use end of range for errors // Create the module type that will hold the results of type checking.... - let envinner,mtypeAcc = MakeInnerEnv env id modKind + let envForModule,mtypeAcc = MakeInnerEnv env id modKind // Now typecheck the signature, using mutation to fill in the submodule description. - let! envAtEnd = TcSignatureElements cenv parent endm envinner xml defs + let! envAtEnd = TcSignatureElements cenv parent endm envForModule xml None defs // mtypeAcc has now accumulated the module type return !mtypeAcc, envAtEnd @@ -15294,49 +16076,75 @@ and TcModuleOrNamespaceSignatureElements cenv parent env (id,modKind,defs,m:rang // Bind definitions within modules //------------------------------------------------------------------------- -let rec TcModuleOrNamespaceElement (cenv:cenv) parent scopem env e = // : ((ModuleOrNamespaceExpr list -> ModuleOrNamespaceExpr list) * _) * tcEnv = + +let ElimModuleDoBinding bind = + match bind with + | SynModuleDecl.DoExpr (spExpr,expr, m) -> + let bind2 = Binding (None,StandaloneExpression,false,false,[],PreXmlDoc.Empty,SynInfo.emptySynValData,SynPat.Wild m,None,expr,m,spExpr) + SynModuleDecl.Let(false,[bind2],m) + | _ -> bind + +let TcMutRecDefnsEscapeCheck (binds: MutRecShapes<_,_,_,_,_>) env = + let freeInEnv = GeneralizationHelpers.ComputeUnabstractableTycons env + let checkTycon (tycon: Tycon) = + if not tycon.IsTypeAbbrev && Zset.contains tycon freeInEnv then + let nm = tycon.DisplayName + errorR(Error(FSComp.SR.tcTypeUsedInInvalidWay(nm, nm, nm), tycon.Range)) + + binds |> MutRecShapes.iterTycons (fst >> Option.iter checkTycon) + + let freeInEnv = GeneralizationHelpers.ComputeUnabstractableTraitSolutions env + let checkBinds (binds: Binding list) = + for bind in binds do + if Zset.contains bind.Var freeInEnv then + let nm = bind.Var.DisplayName + errorR(Error(FSComp.SR.tcMemberUsedInInvalidWay(nm, nm, nm), bind.Var.Range)) + + binds |> MutRecShapes.iterTyconsAndLets (snd >> checkBinds) checkBinds + +// ignore solitary '()' expressions and 'do ()' bindings, since these are allowed in namespaces +// for the purposes of attaching attributes to an assembly, e.g. +// namespace A.B.C +// [] +// do() + +let CheckLetOrDoInNamespace binds m = + match binds with + | [ Binding (None,(StandaloneExpression | DoBinding),false,false,[],_,_,_,None,(SynExpr.Do (SynExpr.Const (SynConst.Unit,_),_) | SynExpr.Const (SynConst.Unit,_)),_,_) ] -> + () + | [] -> + error(NumberedError(FSComp.SR.tcNamespaceCannotContainValues(),m)) + | _ -> + error(NumberedError(FSComp.SR.tcNamespaceCannotContainValues(),binds.Head.RangeOfHeadPat)) + +/// The non-mutually recursive case for a declaration +let rec TcModuleOrNamespaceElementNonMutRec (cenv:cenv) parent scopem env synDecl = eventually { cenv.synArgNameGenerator.Reset() let tpenv = emptyUnscopedTyparEnv //printfn "----------\nCHECKING, e = %+A\n------------------\n" e try - match e with + match ElimModuleDoBinding synDecl with | SynModuleDecl.ModuleAbbrev (id,p,m) -> - let ad = env.eAccessRights - let mvvs = ForceRaise (ResolveLongIndentAsModuleOrNamespace cenv.amap m OpenQualified env.eNameResEnv ad p) - let modrefs = mvvs |> List.map p23 - if modrefs.Length > 0 && modrefs |> List.forall (fun modref -> modref.IsNamespace) then - errorR(Error(FSComp.SR.tcModuleAbbreviationForNamespace(fullDisplayTextOfModRef (List.head modrefs)),m)) - let modrefs = modrefs |> List.filter (fun mvv -> not mvv.IsNamespace) - modrefs |> List.iter (fun modref -> CheckEntityAttributes cenv.g modref m |> CommitOperationResult) - let env = (if modrefs.Length > 0 then AddModuleAbbreviation cenv.tcSink scopem id modrefs env else env) + let env = MutRecBindingChecking.TcModuleAbbrevDecl cenv scopem env (id,p,m) return ((fun e -> e), []), env, env | SynModuleDecl.Exception (edef,m) -> - let binds,decl,env = TcExceptionDeclarations.TcExnDefn cenv env parent tpenv (edef,scopem) - return ((fun e -> TMDefRec([decl], FlatList.ofList binds, [],m) :: e),[]), env, env + let binds,decl,env = TcExceptionDeclarations.TcExnDefn cenv env parent (edef,scopem) + return ((fun e -> TMDefRec(true,[decl], binds |> List.map ModuleOrNamespaceBinding.Binding,m) :: e),[]), env, env | SynModuleDecl.Types (typeDefs,m) -> let scopem = unionRanges m scopem - let binds,tycons,env' = TcTypeDeclarations.TcTyconDefns cenv env parent tpenv (typeDefs,m,scopem) + let mutRecDefns = typeDefs |> List.map MutRecShape.Tycon + let mutRecDefnsChecked,envAfter = TcDeclarations.TcMutRecDefinitions cenv env parent tpenv m scopem None mutRecDefns // Check the non-escaping condition as we build the expression on the way back up let exprfWithEscapeCheck e = - let freeInEnv = GeneralizationHelpers.ComputeUnabstractableTycons env - tycons |> List.iter(fun tycon -> - if not tycon.IsTypeAbbrev && Zset.contains tycon freeInEnv then - let nm = tycon.DisplayName - errorR(Error(FSComp.SR.tcTypeUsedInInvalidWay(nm, nm, nm), tycon.Range))) - - let freeInEnv = GeneralizationHelpers.ComputeUnabstractableTraitSolutions env - binds |> List.iter(fun bind -> - let nm = bind.Var.DisplayName - if Zset.contains bind.Var freeInEnv then errorR(Error(FSComp.SR.tcMemberUsedInInvalidWay(nm, nm, nm), bind.Var.Range))) + TcMutRecDefnsEscapeCheck mutRecDefnsChecked env + TcMutRecDefsFinish cenv mutRecDefnsChecked m :: e - TMDefRec(tycons,FlatList.ofList binds,[],m) :: e - - return (exprfWithEscapeCheck,[]),env', env' + return (exprfWithEscapeCheck, []), envAfter, envAfter | SynModuleDecl.Open (LongIdentWithDots(mp,_),m) -> let scopem = unionRanges m.EndRange scopem @@ -15347,89 +16155,80 @@ let rec TcModuleOrNamespaceElement (cenv:cenv) parent scopem env e = // : ((Modu match parent with | ParentNone -> - - match binds with - // ignore solitary '()' expressions and 'do ()' bindings, since these are allowed in namespaces - // for the purposes of attaching attributes to an assembly, e.g. - // namespace A.B.C - // [] - // do() - - | [ Binding (None,(StandaloneExpression | DoBinding),false,false,[],_,_,_, - None,(SynExpr.Do (SynExpr.Const (SynConst.Unit,_),_) | SynExpr.Const (SynConst.Unit,_)), - _,_) ] -> - return (id,[]), env, env - | [] -> - return error(NumberedError(FSComp.SR.tcNamespaceCannotContainValues(),m)) - | _ -> - return error(NumberedError(FSComp.SR.tcNamespaceCannotContainValues(),binds.Head.RangeOfHeadPat)) + CheckLetOrDoInNamespace binds m + return (id,[]), env, env | Parent parentModule -> - //do - // for b in binds do - // printfn "----------\nb = %+A\n------------------\n" b - // match b with - // | Binding (None,DoBinding,_,_,_,_,_,_,BindingRhs(_,_,e),_,_) -> - // printfn "----------\ne = %+A, #binds = %d\n------------------\n" e binds.Length - // | _ -> - // () let containerInfo = ModuleOrNamespaceContainerInfo(parentModule) if letrec then let scopem = unionRanges m scopem - let binds = binds |> List.map (fun bind -> RecBindingDefn(containerInfo,NoNewSlots,ModuleOrMemberBinding,bind)) + let binds = binds |> List.map (fun bind -> RecDefnBindingInfo(containerInfo,NoNewSlots,ModuleOrMemberBinding,bind)) let binds,env,_ = TcLetrec WarnOnOverrides cenv env tpenv (binds,m, scopem) - return ((fun e -> TMDefRec([],FlatList.ofList binds,[],m) :: e),[]), env, env + return ((fun e -> TMDefRec(true,[],binds |> List.map ModuleOrNamespaceBinding.Binding,m) :: e),[]), env, env else let binds,env,_ = TcLetBindings cenv env containerInfo ModuleOrMemberBinding tpenv (binds,m,scopem) return ((fun e -> binds@e),[]), env, env - | SynModuleDecl.DoExpr (spExpr,expr, m) -> - - let bind = - Binding (None, - StandaloneExpression, - false,false,[],PreXmlDoc.Empty,SynInfo.emptySynValData, - SynPat.Wild m, - None,expr,m,spExpr) - - return! TcModuleOrNamespaceElement cenv parent scopem env (SynModuleDecl.Let(false,[bind],m)) + | SynModuleDecl.DoExpr _ -> return! failwith "unreachable" | SynModuleDecl.Attributes (synAttrs,_) -> - let attrs = TcAttributesWithPossibleTargets cenv env AttributeTargets.Top synAttrs + let attrs, _ = TcAttributesWithPossibleTargets false cenv env AttributeTargets.Top synAttrs return ((fun e -> e), attrs), env, env | SynModuleDecl.HashDirective _ -> return ((fun e -> e), []), env, env - | SynModuleDecl.NestedModule(ComponentInfo(attribs,_parms, _constraints,longPath,xml,_,vis,im),mdefs,isContinuingModule,m) -> - let id = ComputeModuleName longPath - - let modAttrs = TcAttributes cenv env AttributeTargets.ModuleDecl attribs - let modKind = ComputeModuleOrNamespaceKind cenv.g true modAttrs + | SynModuleDecl.NestedModule(compInfo, isRec, mdefs, isContinuingModule, m) -> - CheckForDuplicateConcreteType cenv env (AdjustModuleName modKind id.idText) im - CheckForDuplicateModule cenv env id.idText id.idRange - let vis,_ = ComputeAccessAndCompPath env None id.idRange vis parent + // Treat 'module rec M = ...' as a single mutully recursive definition group 'module M = ...' + if isRec then + assert (not isContinuingModule) + let modDecl = SynModuleDecl.NestedModule(compInfo, false, mdefs, isContinuingModule, m) + return! TcModuleOrNamespaceElementsMutRec cenv parent m env None [modDecl] + else + let (ComponentInfo(attribs,_parms, _constraints,longPath,xml,_,vis,im)) = compInfo + let id = ComputeModuleName longPath + + let modAttrs = TcAttributes cenv env AttributeTargets.ModuleDecl attribs + let modKind = EstablishTypeDefinitionCores.ComputeModuleOrNamespaceKind cenv.g true modAttrs + let modName = EstablishTypeDefinitionCores.AdjustModuleName modKind id.idText + CheckForDuplicateConcreteType env modName im + CheckForDuplicateModule env id.idText id.idRange + let vis,_ = ComputeAccessAndCompPath env None id.idRange vis parent - let! (topAttrsNew, _,ModuleOrNamespaceBinding(mspecPriorToOuterOrExplicitSig,mexpr)),_,envAtEnd = - TcModuleOrNamespace cenv env (id,true,mdefs,xml,modAttrs,vis,m) + let endm = m.EndRange + let id = ident (modName, id.idRange) + + CheckNamespaceModuleOrTypeName cenv.g id - let mspec = mspecPriorToOuterOrExplicitSig - let mdef = TMDefRec([],FlatList.empty,[ModuleOrNamespaceBinding(mspecPriorToOuterOrExplicitSig,mexpr)],m) - PublishModuleDefn cenv env mspec - let env = AddLocalSubModule cenv.tcSink cenv.g cenv.amap m scopem env mspec + let envForModule, mtypeAcc = MakeInnerEnv env id modKind + + // Create the new module specification to hold the accumulated results of the type of the module + // Also record this in the environment as the accumulator + let mspec = NewModuleOrNamespace (Some env.eCompPath) vis id (xml.ToXmlDoc()) modAttrs (notlazy (NewEmptyModuleOrNamespaceType modKind)) + + // Now typecheck. + let! mexpr, topAttrsNew, envAtEnd = TcModuleOrNamespaceElements cenv (Parent (mkLocalModRef mspec)) endm envForModule xml None mdefs + + // Get the inferred type of the decls and record it in the mspec. + mspec.Data.entity_modul_contents <- notlazy !mtypeAcc + let modDefn = TMDefRec(false,[],[ModuleOrNamespaceBinding.Module(mspec,mexpr)],m) + PublishModuleDefn cenv env mspec + let env = AddLocalSubModuleAndReport cenv.tcSink scopem cenv.g cenv.amap m env mspec - // isContinuingModule is true for all of the following - // - the implicit module of a script - // - the major 'module' declaration for a file stating with 'module X.Y' - // - an interactive entry for F# Interactive - // In this case the envAtEnd is the environment at the end of this module - let envAtEnd = (if isContinuingModule then envAtEnd else env) + // isContinuingModule is true for all of the following + // - the implicit module of a script + // - the major 'module' declaration for a file stating with 'module X.Y' + // - an interactive entry for F# Interactive + // + // In this case the envAtEnd is the environment at the end of this module, which doesn't contain the module definition itself + // but does contain the results of all the 'open' declarations and so on. + let envAtEnd = (if isContinuingModule then envAtEnd else env) - return ((fun e -> mdef :: e),topAttrsNew), env, envAtEnd + return ((fun modDefs -> modDefn :: modDefs),topAttrsNew), env, envAtEnd - | SynModuleDecl.NamespaceFragment(SynModuleOrNamespace(longId,isModule,defs,xml,attribs,vis,m)) -> + | SynModuleDecl.NamespaceFragment(SynModuleOrNamespace(longId,isRec,isModule,defs,xml,attribs,vis,m)) -> if !progress then dprintn ("Typecheck implementation " + textOfLid longId) let endm = m.EndRange @@ -15437,24 +16236,43 @@ let rec TcModuleOrNamespaceElement (cenv:cenv) parent scopem env e = // : ((Modu do for id in longId do CheckNamespaceModuleOrTypeName cenv.g id - let enclosingNamespacePath = if isModule then fst (List.frontAndBack longId) else longId - let defs = + // Logically speaking, this changes + // module [rec] A.B.M + // ... + // to + // namespace [rec] A.B + // module M = ... + let enclosingNamespacePath, defs = if isModule then - [SynModuleDecl.NestedModule(ComponentInfo(attribs,[], [],[snd(List.frontAndBack longId)],xml,false,vis,m),defs,true,m)] + let nsp, modName = List.frontAndBack longId + let modDecl = [SynModuleDecl.NestedModule(ComponentInfo(attribs,[], [],[modName],xml,false,vis,m),false,defs,true,m)] + nsp, modDecl else - defs - let envinner = LocateEnv cenv.topCcu env enclosingNamespacePath - let envinner = ImplicitlyOpenOwnNamespace cenv.tcSink cenv.g cenv.amap m enclosingNamespacePath envinner + longId, defs + + let envNS = LocateEnv cenv.topCcu env enclosingNamespacePath + let envNS = ImplicitlyOpenOwnNamespace cenv.tcSink cenv.g cenv.amap m enclosingNamespacePath envNS + + let mtypNS = !(envNS.eModuleOrNamespaceTypeAccumulator) + let mtypRoot, mspecNSOpt = BuildRootModuleType enclosingNamespacePath envNS.eCompPath mtypNS - let! mexpr, topAttrs, _, envAtEnd = TcModuleOrNamespaceElements cenv parent endm envinner xml defs + // TODO: test 'namespace rec global' + + // For 'namespace rec' and 'module rec' we add the thing being defined + let envNS = if isRec then AddLocalRootModuleOrNamespace cenv.tcSink cenv.g cenv.amap m envNS mtypRoot else envNS + let nsInfo = Some (mspecNSOpt, envNS.eModuleOrNamespaceTypeAccumulator) + let mutRecNSInfo = if isRec then nsInfo else None + + let! modExpr, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv parent endm envNS xml mutRecNSInfo defs + + MutRecBindingChecking.TcMutRecDefns_UpdateNSContents nsInfo let env = if isNil enclosingNamespacePath then envAtEnd else - let modulTypeRoot = BuildRootModuleType enclosingNamespacePath envinner.eCompPath !(envinner.eModuleOrNamespaceTypeAccumulator) - let env = AddLocalRootModuleOrNamespace cenv.tcSink cenv.g cenv.amap m env modulTypeRoot + let env = AddLocalRootModuleOrNamespace cenv.tcSink cenv.g cenv.amap m env mtypRoot // If the namespace is an interactive fragment e.g. FSI_0002, then open FSI_0002 in the subsequent environment let env = @@ -15463,78 +16281,153 @@ let rec TcModuleOrNamespaceElement (cenv:cenv) parent scopem env e = // : ((Modu | None -> env // Publish the combined module type - env.eModuleOrNamespaceTypeAccumulator := CombineCcuContentFragments m [!(env.eModuleOrNamespaceTypeAccumulator); modulTypeRoot] + env.eModuleOrNamespaceTypeAccumulator := CombineCcuContentFragments m [!(env.eModuleOrNamespaceTypeAccumulator); mtypRoot] env - let mexprRoot = BuildRootModuleExpr enclosingNamespacePath envinner.eCompPath mexpr + let modExprRoot = BuildRootModuleExpr enclosingNamespacePath envNS.eCompPath modExpr - return ((fun e -> mexprRoot :: e),topAttrs), env, envAtEnd + return ((fun modExprs -> modExprRoot :: modExprs),topAttrs), env, envAtEnd with exn -> - errorRecovery exn e.Range + errorRecovery exn synDecl.Range return ((fun e -> e), []), env, env } -and TcModuleOrNamespaceElementsAux cenv parent endm (defsSoFar, env, envAtEnd) (moreDefs: SynModuleDecl list) = +/// The non-mutually recursive case for a sequence of declarations +and TcModuleOrNamespaceElementsNonMutRec cenv parent endm (defsSoFar, env, envAtEnd) (moreDefs: SynModuleDecl list) = eventually { match moreDefs with - | (h1 :: t) -> + | (firstDef :: otherDefs) -> // Lookahead one to find out the scope of the next declaration. let scopem = - if isNil t then unionRanges h1.Range endm - else unionRanges (List.head t).Range endm + if isNil otherDefs then unionRanges firstDef.Range endm + else unionRanges (List.head otherDefs).Range endm // Possibly better: //let scopem = unionRanges h1.Range.EndRange endm - let! h1',env', envAtEnd' = TcModuleOrNamespaceElement cenv parent scopem env h1 + let! firstDef',env', envAtEnd' = TcModuleOrNamespaceElementNonMutRec cenv parent scopem env firstDef // tail recursive - return! TcModuleOrNamespaceElementsAux cenv parent endm ( (h1' :: defsSoFar), env', envAtEnd') t + return! TcModuleOrNamespaceElementsNonMutRec cenv parent endm ( (firstDef' :: defsSoFar), env', envAtEnd') otherDefs | [] -> - return List.rev defsSoFar,env, envAtEnd + return List.rev defsSoFar, envAtEnd } -and TcModuleOrNamespaceElements cenv parent endm env xml defs = - eventually { - // Ensure the deref_nlpath call in UpdateAccModuleOrNamespaceType succeeds - if cenv.compilingCanonicalFslibModuleType then - ensureCcuHasModuleOrNamespaceAtPath cenv.topCcu env.ePath env.eCompPath (xml.ToXmlDoc()) +/// The mutually recursive case for a sequence of declarations (and nested modules) +and TcModuleOrNamespaceElementsMutRec cenv parent endm envInitial mutRecNSInfo (defs: SynModuleDecl list) = + eventually { - let! compiledDefs, env, envAtEnd = TcModuleOrNamespaceElementsAux cenv parent endm ([], env, env) defs - // Apply the functions for each declaration to build the overall expression-builder - let mexpr = TMDefs(List.foldBack (fun (f,_) x -> f x) compiledDefs []) + let m = match defs with [] -> endm | _ -> defs |> List.map (fun d -> d.Range) |> List.reduce unionRanges + let scopem = (defs, endm) ||> List.foldBack (fun h m -> unionRanges h.Range m) - // Collect up the attributes that are global to the file - let topAttrsNew = List.foldBack (fun (_,y) x -> y@x) compiledDefs [] - return (mexpr, topAttrsNew, env, envAtEnd) - } - -and TcModuleOrNamespace cenv env (id,isModule,defs,xml,modAttrs,vis,m:range) = - eventually { - let endm = m.EndRange - let modKind = ComputeModuleOrNamespaceKind cenv.g isModule modAttrs - let id = ident (AdjustModuleName modKind id.idText, id.idRange) + let (mutRecDefns, (_, _, synAttrs)) = + let rec loop isNamespace attrs defs : (MutRecDefnsInitialData * _) = + ((true, true, attrs),defs) ||> List.collectFold (fun (openOk,moduleAbbrevOk,attrs) def -> + match ElimModuleDoBinding def with - CheckNamespaceModuleOrTypeName cenv.g id + | SynModuleDecl.Types (typeDefs,_) -> + let decls = typeDefs |> List.map MutRecShape.Tycon + decls, (false, false, attrs) - let envinner, mtypeAcc = MakeInnerEnv env id modKind - - // Create the new module specification to hold the accumulated results of the type of the module - // Also record this in the environment as the accumulator - let mspec = NewModuleOrNamespace (Some env.eCompPath) vis id (xml.ToXmlDoc()) modAttrs (notlazy (NewEmptyModuleOrNamespaceType modKind)) + | SynModuleDecl.Let (letrec, binds, m) -> + let binds = + if isNamespace then + CheckLetOrDoInNamespace binds m; [] + else + if letrec then [MutRecShape.Lets binds] + else List.map (List.singleton >> MutRecShape.Lets) binds + binds, (false, false, attrs) + + | SynModuleDecl.NestedModule(compInfo, isRec, synDefs,_isContinuingModule,_) -> + if isRec then warning(Error(FSComp.SR.tcRecImplied(),compInfo.Range)) + let mutRecDefs, (_, _, attrs) = loop false attrs synDefs + let decls = [MutRecShape.Module (compInfo, mutRecDefs)] + decls, (false, false, attrs) + + | SynModuleDecl.Open (LongIdentWithDots(lid,_), m) -> + if not openOk then errorR(Error(FSComp.SR.tcOpenFirstInMutRec(),m)) + let decls = [ MutRecShape.Open (MutRecDataForOpen(lid, m)) ] + decls, (openOk, moduleAbbrevOk, attrs) + + | SynModuleDecl.Exception (SynExceptionDefn(repr,members,_),_m) -> + let (SynExceptionDefnRepr(synAttrs,UnionCase(_,id,_args,_,_,_),_repr,doc,vis,m)) = repr + let compInfo = ComponentInfo(synAttrs,[],[],[id],doc,false,vis,id.idRange) + let decls = [ MutRecShape.Tycon(SynTypeDefn.TypeDefn(compInfo, SynTypeDefnRepr.Exception repr, members, m)) ] + decls, (false, false, attrs) - let innerParent = mkLocalModRef mspec + | SynModuleDecl.HashDirective _ -> + [ ], (openOk, moduleAbbrevOk, attrs) - // Now typecheck. - let! mexpr, topAttrs, env, envAtEnd = TcModuleOrNamespaceElements cenv (Parent innerParent) endm envinner xml defs + | SynModuleDecl.Attributes (synAttrs,_) -> + [ ], (false, false, synAttrs) - // Get the inferred type of the decls. It's precisely the one we created before checking - // and mutated as we went. Record it in the mspec. - mspec.Data.entity_modul_contents <- notlazy !mtypeAcc + | SynModuleDecl.ModuleAbbrev (id, p, m) -> + if not moduleAbbrevOk then errorR(Error(FSComp.SR.tcModuleAbbrevFirstInMutRec(),m)) + let decls = [ MutRecShape.ModuleAbbrev (MutRecDataForModuleAbbrev(id, p, m)) ] + decls, (false, moduleAbbrevOk, attrs) + + | SynModuleDecl.DoExpr _ -> failwith "unreachable: SynModuleDecl.DoExpr - ElimModuleDoBinding" + + | (SynModuleDecl.NamespaceFragment _ as d) -> error(Error(FSComp.SR.tcUnsupportedMutRecDecl(),d.Range))) + + loop (match parent with ParentNone -> true | Parent _ -> false) [] defs + + let tpenv = emptyUnscopedTyparEnv + let mutRecDefnsChecked,envAfter = TcDeclarations.TcMutRecDefinitions cenv envInitial parent tpenv m scopem mutRecNSInfo mutRecDefns + + // Check the assembly attributes + let attrs, _ = TcAttributesWithPossibleTargets false cenv envAfter AttributeTargets.Top synAttrs + + // Check the non-escaping condition as we build the list of module expressions on the way back up + let exprfWithEscapeCheck modExprs = + TcMutRecDefnsEscapeCheck mutRecDefnsChecked envInitial + let modExpr = TcMutRecDefsFinish cenv mutRecDefnsChecked m + modExpr :: modExprs + + return (exprfWithEscapeCheck,attrs),envAfter, envAfter - return (topAttrs,mspec,ModuleOrNamespaceBinding(mspec,mexpr)), env, envAtEnd } +and TcMutRecDefsFinish cenv defs m = + let tycons = defs |> List.choose (function MutRecShape.Tycon (Some tycon,_) -> Some tycon | _ -> None) + let binds = + defs |> List.collect (function + | MutRecShape.Open _ -> [] + | MutRecShape.ModuleAbbrev _ -> [] + | MutRecShape.Tycon (_,binds) + | MutRecShape.Lets binds -> + binds |> List.map ModuleOrNamespaceBinding.Binding + | MutRecShape.Module ((MutRecDefnsPhase2DataForModule(mtypeAcc, mspec), _),mdefs) -> + let mexpr = TcMutRecDefsFinish cenv mdefs m + mspec.Data.entity_modul_contents <- notlazy !mtypeAcc + [ ModuleOrNamespaceBinding.Module(mspec,mexpr) ]) + + TMDefRec(true,tycons,binds,m) + +and TcModuleOrNamespaceElements cenv parent endm env xml mutRecNSInfo defs = + eventually { + // Ensure the deref_nlpath call in UpdateAccModuleOrNamespaceType succeeds + if cenv.compilingCanonicalFslibModuleType then + ensureCcuHasModuleOrNamespaceAtPath cenv.topCcu env.ePath env.eCompPath (xml.ToXmlDoc()) + + match mutRecNSInfo with + | Some _ -> + let! (exprf, topAttrsNew), _, envAtEnd = TcModuleOrNamespaceElementsMutRec cenv parent endm env mutRecNSInfo defs + // Apply the functions for each declaration to build the overall expression-builder + let mexpr = TMDefs(exprf []) + return (mexpr, topAttrsNew, envAtEnd) + + | None -> + let! compiledDefs, envAtEnd = TcModuleOrNamespaceElementsNonMutRec cenv parent endm ([], env, env) defs + + // Apply the functions for each declaration to build the overall expression-builder + let mexpr = TMDefs(List.foldBack (fun (f,_) x -> f x) compiledDefs []) + + // Collect up the attributes that are global to the file + let topAttrsNew = List.foldBack (fun (_,y) x -> y@x) compiledDefs [] + return (mexpr, topAttrsNew, envAtEnd) + } + //-------------------------------------------------------------------------- // TypeCheckOneImplFile - Typecheck all the namespace fragments in a file. @@ -15619,7 +16512,7 @@ let ApplyDefaults cenv g denvAtEnd m mexpr extraAttribs = | TyparConstraint.DefaultsTo(priority2,ty2,m) when priority2 = priority -> let ty1 = mkTyparTy tp if not tp.IsSolved && not (typeEquiv cenv.g ty1 ty2) then - let csenv = MakeConstraintSolverEnv cenv.css m denvAtEnd + let csenv = MakeConstraintSolverEnv ContextInfo.NoContext cenv.css m denvAtEnd TryD (fun () -> ConstraintSolver.SolveTyparEqualsTyp csenv 0 m NoTrace ty1 ty2) (fun e -> solveTypAsError cenv denvAtEnd m ty1 ErrorD(ErrorFromApplyingDefault(g,denvAtEnd,tp,ty2,e,m))) @@ -15716,7 +16609,7 @@ let TypeCheckOneImplFile let envinner, mtypeAcc = MakeInitialEnv env let defs = [ for x in implFileFrags -> SynModuleDecl.NamespaceFragment(x) ] - let! mexpr, topAttrs, env, envAtEnd = TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDocEmpty defs + let! mexpr, topAttrs, envAtEnd = TcModuleOrNamespaceElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDocEmpty None defs let implFileTypePriorToSig = !mtypeAcc @@ -15788,16 +16681,13 @@ let TypeCheckOneImplFile /// Check an entire signature file -let TypeCheckOneSigFile - (g,niceNameGen,amap,topCcu,checkForErrors,conditionalDefines,tcSink) - tcEnv - (ParsedSigFileInput(_,qualNameOfFile,_, _,sigFileFrags)) = +let TypeCheckOneSigFile (g,niceNameGen,amap,topCcu,checkForErrors,conditionalDefines,tcSink) tcEnv (ParsedSigFileInput(_,qualNameOfFile,_, _,sigFileFrags)) = eventually { let cenv = cenv.Create (g,false,niceNameGen,amap,topCcu,true,false,conditionalDefines,tcSink, (LightweightTcValForUsingInBuildMethodCall g)) let envinner,mtypeAcc = MakeInitialEnv tcEnv let specs = [ for x in sigFileFrags -> SynModuleSigDecl.NamespaceFragment(x) ] - let! tcEnv = TcSignatureElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDocEmpty specs + let! tcEnv = TcSignatureElements cenv ParentNone qualNameOfFile.Range envinner PreXmlDocEmpty None specs let sigFileType = !mtypeAcc diff --git a/src/fsharp/TypeChecker.fsi b/src/fsharp/TypeChecker.fsi index db581d85df..51a346c35e 100644 --- a/src/fsharp/TypeChecker.fsi +++ b/src/fsharp/TypeChecker.fsi @@ -8,8 +8,9 @@ open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library -open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops diff --git a/src/fsharp/TypeRelations.fs b/src/fsharp/TypeRelations.fs index f6b3a88620..b0bb80e982 100755 --- a/src/fsharp/TypeRelations.fs +++ b/src/fsharp/TypeRelations.fs @@ -24,13 +24,9 @@ open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.PrettyNaming -open Microsoft.FSharp.Compiler.Infos.AccessibilityLogic +open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.NameResolution -#if EXTENSIONTYPING -open Microsoft.FSharp.Compiler.ExtensionTyping -#endif - //------------------------------------------------------------------------- // a :> b without coercion based on finalized (no type variable) types //------------------------------------------------------------------------- @@ -291,1723 +287,6 @@ let IteratedAdjustArityOfLambda g amap topValInfo e = tps,ctorThisValOpt,baseValOpt,vsl,body,bodyty -exception RequiredButNotSpecified of DisplayEnv * Tast.ModuleOrNamespaceRef * string * (StringBuilder -> unit) * range -exception ValueNotContained of DisplayEnv * Tast.ModuleOrNamespaceRef * Val * Val * (string * string * string -> string) -exception ConstrNotContained of DisplayEnv * UnionCase * UnionCase * (string * string -> string) -exception ExnconstrNotContained of DisplayEnv * Tycon * Tycon * (string * string -> string) -exception FieldNotContained of DisplayEnv * RecdField * RecdField * (string * string -> string) -exception InterfaceNotRevealed of DisplayEnv * TType * range - - -/// Containment relation for module types -module SignatureConformance = begin - - // Use a type to capture the constant, common parameters - type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = - - // Build a remap that maps tcrefs in the signature to tcrefs in the implementation - // Used when checking attributes. - let sigToImplRemap = - let remap = Remap.Empty - let remap = (remapInfo.mrpiEntities,remap) ||> List.foldBack (fun (implTcref ,signTcref) acc -> addTyconRefRemap signTcref implTcref acc) - let remap = (remapInfo.mrpiVals ,remap) ||> List.foldBack (fun (implValRef,signValRef) acc -> addValRemap signValRef.Deref implValRef.Deref acc) - remap - - // For all attributable elements (types, modules, exceptions, record fields, unions, parameters, generic type parameters) - // - // (a) Start with lists AImpl and ASig containing the attributes in the implementation and signature, in declaration order - // (b) Each attribute in AImpl is checked against the available attributes in ASig. - // a. If an attribute is found in ASig which is an exact match (after evaluating attribute arguments), then the attribute in the implementation is ignored, the attribute is removed from ASig, and checking continues - // b. If an attribute is found in ASig that has the same attribute type, then a warning is given and the attribute in the implementation is ignored - // c. Otherwise, the attribute in the implementation is kept - // (c) The attributes appearing in the compiled element are the compiled forms of the attributes from the signature and the kept attributes from the implementation - let checkAttribs _aenv (implAttribs:Attribs) (sigAttribs:Attribs) fixup = - - // Remap the signature attributes to make them look as if they were declared in - // the implementation. This allows us to compare them and propagate them to the implementation - // if needed. - let sigAttribs = sigAttribs |> List.map (remapAttrib g sigToImplRemap) - - // Helper to check for equality of evaluated attribute expressions - let attribExprEq (AttribExpr(_,e1)) (AttribExpr(_,e2)) = EvaledAttribExprEquality g e1 e2 - - // Helper to check for equality of evaluated named attribute arguments - let attribNamedArgEq (AttribNamedArg(nm1,ty1,isProp1,e1)) (AttribNamedArg(nm2,ty2,isProp2,e2)) = - (nm1 = nm2) && - typeEquiv g ty1 ty2 && - (isProp1 = isProp2) && - attribExprEq e1 e2 - - let attribsEq attrib1 attrib2 = - let (Attrib(implTcref,_,implArgs,implNamedArgs,_,_,_implRange)) = attrib1 - let (Attrib(signTcref,_,signArgs,signNamedArgs,_,_,_signRange)) = attrib2 - tyconRefEq g signTcref implTcref && - (implArgs,signArgs) ||> List.lengthsEqAndForall2 attribExprEq && - (implNamedArgs, signNamedArgs) ||> List.lengthsEqAndForall2 attribNamedArgEq - - let attribsHaveSameTycon attrib1 attrib2 = - let (Attrib(implTcref,_,_,_,_,_,_)) = attrib1 - let (Attrib(signTcref,_,_,_,_,_,_)) = attrib2 - tyconRefEq g signTcref implTcref - - // For each implementation attribute, only keep if it is not mentioned in the signature. - // Emit a warning if it is mentioned in the signature and the arguments to the attributes are - // not identical. - let rec check keptImplAttribsRev implAttribs sigAttribs = - match implAttribs with - | [] -> keptImplAttribsRev |> List.rev - | implAttrib :: remainingImplAttribs -> - - // Look for an attribute in the signature that matches precisely. If so, remove it - let lookForMatchingAttrib = sigAttribs |> List.tryRemove (attribsEq implAttrib) - match lookForMatchingAttrib with - | Some (_, remainingSigAttribs) -> check keptImplAttribsRev remainingImplAttribs remainingSigAttribs - | None -> - - // Look for an attribute in the signature that has the same type. If so, give a warning - let existsSimilarAttrib = sigAttribs |> List.exists (attribsHaveSameTycon implAttrib) - - if existsSimilarAttrib then - let (Attrib(implTcref,_,_,_,_,_,implRange)) = implAttrib - warning(Error(FSComp.SR.tcAttribArgsDiffer(implTcref.DisplayName), implRange)) - check keptImplAttribsRev remainingImplAttribs sigAttribs - else - check (implAttrib :: keptImplAttribsRev) remainingImplAttribs sigAttribs - - let keptImplAttribs = check [] implAttribs sigAttribs - - fixup (sigAttribs @ keptImplAttribs) - true - - let rec checkTypars m (aenv: TypeEquivEnv) (implTypars:Typars) (sigTypars:Typars) = - if implTypars.Length <> sigTypars.Length then - errorR (Error(FSComp.SR.typrelSigImplNotCompatibleParamCountsDiffer(),m)) - false - else - let aenv = aenv.BindEquivTypars implTypars sigTypars - (implTypars,sigTypars) ||> List.forall2 (fun implTypar sigTypar -> - let m = sigTypar.Range - if implTypar.StaticReq <> sigTypar.StaticReq then - errorR (Error(FSComp.SR.typrelSigImplNotCompatibleCompileTimeRequirementsDiffer(), m)) - - // Adjust the actual type parameter name to look like the signature - implTypar.SetIdent (mkSynId implTypar.Range sigTypar.Id.idText) - - // Mark it as "not compiler generated", now that we've got a good name for it - implTypar.SetCompilerGenerated false - - // Check the constraints in the implementation are present in the signature - implTypar.Constraints |> List.forall (fun implTyparCx -> - match implTyparCx with - // defaults can be dropped in the signature - | TyparConstraint.DefaultsTo(_,_acty,_) -> true - | _ -> - if not (List.exists (typarConstraintsAEquiv g aenv implTyparCx) sigTypar.Constraints) - then (errorR(Error(FSComp.SR.typrelSigImplNotCompatibleConstraintsDiffer(sigTypar.Name, Layout.showL(NicePrint.layoutTyparConstraint denv (implTypar,implTyparCx))),m)); false) - else true) && - - // Check the constraints in the signature are present in the implementation - sigTypar.Constraints |> List.forall (fun sigTyparCx -> - match sigTyparCx with - // defaults can be present in the signature and not in the implementation because they are erased - | TyparConstraint.DefaultsTo(_,_acty,_) -> true - // 'comparison' and 'equality' constraints can be present in the signature and not in the implementation because they are erased - | TyparConstraint.SupportsComparison _ -> true - | TyparConstraint.SupportsEquality _ -> true - | _ -> - if not (List.exists (fun implTyparCx -> typarConstraintsAEquiv g aenv implTyparCx sigTyparCx) implTypar.Constraints) then - (errorR(Error(FSComp.SR.typrelSigImplNotCompatibleConstraintsDifferRemove(sigTypar.Name, Layout.showL(NicePrint.layoutTyparConstraint denv (sigTypar,sigTyparCx))),m)); false) - else - true) && - (not checkingSig || checkAttribs aenv implTypar.Attribs sigTypar.Attribs (fun attribs -> implTypar.Data.typar_attribs <- attribs))) - - and checkTypeDef (aenv: TypeEquivEnv) (implTycon:Tycon) (sigTycon:Tycon) = - let m = implTycon.Range - // Propagate defn location information from implementation to signature . - sigTycon.SetOtherRange (implTycon.Range, true) - implTycon.SetOtherRange (sigTycon.Range, false) - let err f = Error(f(implTycon.TypeOrMeasureKind.ToString()), m) - if implTycon.LogicalName <> sigTycon.LogicalName then (errorR (err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNamesDiffer)); false) else - if implTycon.CompiledName <> sigTycon.CompiledName then (errorR (err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleNamesDiffer)); false) else - checkExnInfo (fun f -> ExnconstrNotContained(denv,implTycon,sigTycon,f)) aenv implTycon.ExceptionInfo sigTycon.ExceptionInfo && - let implTypars = implTycon.Typars m - let sigTypars = sigTycon.Typars m - if implTypars.Length <> sigTypars.Length then - errorR (err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleParameterCountsDiffer)) - false - elif isLessAccessible implTycon.Accessibility sigTycon.Accessibility then - errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleAccessibilityDiffer)) - false - else - let aenv = aenv.BindEquivTypars implTypars sigTypars - - let aintfs = implTycon.ImmediateInterfaceTypesOfFSharpTycon - let fintfs = sigTycon.ImmediateInterfaceTypesOfFSharpTycon - let aintfsUser = implTycon.TypeContents.tcaug_interfaces |> List.filter (fun (_,compgen,_) -> not compgen) |> List.map p13 - let flatten tys = - tys - |> List.collect (AllSuperTypesOfType g amap m AllowMultiIntfInstantiations.Yes) - |> ListSet.setify (typeEquiv g) - |> List.filter (isInterfaceTy g) - let aintfs = flatten aintfs - let aintfsUser = flatten aintfsUser - let fintfs = flatten fintfs - - let unimpl = ListSet.subtract (fun fity aity -> typeAEquiv g aenv aity fity) fintfs aintfs - (unimpl |> List.forall (fun ity -> errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleMissingInterface(x, NicePrint.minimalStringOfType denv ity))); false)) && - let hidden = ListSet.subtract (typeAEquiv g aenv) aintfsUser fintfs - hidden |> List.iter (fun ity -> (if implTycon.IsFSharpInterfaceTycon then error else warning) (InterfaceNotRevealed(denv,ity,implTycon.Range))) - - let aNull = IsUnionTypeWithNullAsTrueValue g implTycon - let fNull = IsUnionTypeWithNullAsTrueValue g sigTycon - if aNull && not fNull then - errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull)) - elif fNull && not aNull then - errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull)) - - let aNull2 = TypeNullIsExtraValue g m (generalizedTyconRef (mkLocalTyconRef implTycon)) - let fNull2 = TypeNullIsExtraValue g m (generalizedTyconRef (mkLocalTyconRef implTycon)) - if aNull2 && not fNull2 then - errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSaysNull2)) - elif fNull2 && not aNull2 then - errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureSaysNull2)) - - let aSealed = isSealedTy g (generalizedTyconRef (mkLocalTyconRef implTycon)) - let fSealed = isSealedTy g (generalizedTyconRef (mkLocalTyconRef sigTycon)) - if aSealed && not fSealed then - errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationSealed)) - if not aSealed && fSealed then - errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsNotSealed)) - - let aPartial = isAbstractTycon implTycon - let fPartial = isAbstractTycon sigTycon - if aPartial && not fPartial then - errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplementationIsAbstract)) - - if not aPartial && fPartial then - errorR(err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureIsAbstract)) - - if not (typeAEquiv g aenv (superOfTycon g implTycon) (superOfTycon g sigTycon)) then - errorR (err(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypesHaveDifferentBaseTypes)) - - checkTypars m aenv implTypars sigTypars && - checkTypeRepr err aenv implTycon.TypeReprInfo sigTycon.TypeReprInfo && - checkTypeAbbrev err aenv implTycon.TypeOrMeasureKind sigTycon.TypeOrMeasureKind implTycon.TypeAbbrev sigTycon.TypeAbbrev && - checkAttribs aenv implTycon.Attribs sigTycon.Attribs (fun attribs -> implTycon.Data.entity_attribs <- attribs) && - checkModuleOrNamespaceContents implTycon.Range aenv (mkLocalEntityRef implTycon) sigTycon.ModuleOrNamespaceType - - and checkValInfo aenv err (implVal : Val) (sigVal : Val) = - let id = implVal.Id - match implVal.ValReprInfo, sigVal.ValReprInfo with - | _,None -> true - | None, Some _ -> err(FSComp.SR.ValueNotContainedMutabilityArityNotInferred) - | Some (ValReprInfo (implTyparNames,implArgInfos,implRetInfo) as implValInfo), Some (ValReprInfo (sigTyparNames,sigArgInfos,sigRetInfo) as sigValInfo) -> - let ntps = implTyparNames.Length - let mtps = sigTyparNames.Length - if ntps <> mtps then - err(fun(x, y, z) -> FSComp.SR.ValueNotContainedMutabilityGenericParametersDiffer(x, y, z, string mtps, string ntps)) - elif implValInfo.KindsOfTypars <> sigValInfo.KindsOfTypars then - err(FSComp.SR.ValueNotContainedMutabilityGenericParametersAreDifferentKinds) - elif not (sigArgInfos.Length <= implArgInfos.Length && List.forall2 (fun x y -> List.length x <= List.length y) sigArgInfos (fst (List.chop sigArgInfos.Length implArgInfos))) then - err(fun(x, y, z) -> FSComp.SR.ValueNotContainedMutabilityAritiesDiffer(x, y, z, id.idText, string sigArgInfos.Length, id.idText, id.idText)) - else - let implArgInfos = implArgInfos |> List.take sigArgInfos.Length - let implArgInfos = (implArgInfos, sigArgInfos) ||> List.map2 (fun l1 l2 -> l1 |> List.take l2.Length) - // Propagate some information signature to implementation. - - // Check the attributes on each argument, and update the ValReprInfo for - // the value to reflect the information in the signature. - // This ensures that the compiled form of the value matches the signature rather than - // the implementation. This also propagates argument names from signature to implementation - let res = - (implArgInfos,sigArgInfos) ||> List.forall2 (List.forall2 (fun implArgInfo sigArgInfo -> - checkAttribs aenv implArgInfo.Attribs sigArgInfo.Attribs (fun attribs -> - implArgInfo.Name <- sigArgInfo.Name - implArgInfo.Attribs <- attribs))) && - - checkAttribs aenv implRetInfo.Attribs sigRetInfo.Attribs (fun attribs -> - implRetInfo.Name <- sigRetInfo.Name - implRetInfo.Attribs <- attribs) - - implVal.SetValReprInfo (Some (ValReprInfo (sigTyparNames,implArgInfos,implRetInfo))) - res - - and checkVal implModRef (aenv:TypeEquivEnv) (implVal:Val) (sigVal:Val) = - - // Propagate defn location information from implementation to signature . - sigVal.SetOtherRange (implVal.Range, true) - implVal.SetOtherRange (sigVal.Range, false) - - let mk_err denv f = ValueNotContained(denv,implModRef,implVal,sigVal,f) - let err denv f = errorR(mk_err denv f); false - let m = implVal.Range - if implVal.IsMutable <> sigVal.IsMutable then (err denv FSComp.SR.ValueNotContainedMutabilityAttributesDiffer) - elif implVal.LogicalName <> sigVal.LogicalName then (err denv FSComp.SR.ValueNotContainedMutabilityNamesDiffer) - elif implVal.CompiledName <> sigVal.CompiledName then (err denv FSComp.SR.ValueNotContainedMutabilityCompiledNamesDiffer) - elif implVal.DisplayName <> sigVal.DisplayName then (err denv FSComp.SR.ValueNotContainedMutabilityDisplayNamesDiffer) - elif isLessAccessible implVal.Accessibility sigVal.Accessibility then (err denv FSComp.SR.ValueNotContainedMutabilityAccessibilityMore) - elif implVal.MustInline <> sigVal.MustInline then (err denv FSComp.SR.ValueNotContainedMutabilityInlineFlagsDiffer) - elif implVal.LiteralValue <> sigVal.LiteralValue then (err denv FSComp.SR.ValueNotContainedMutabilityLiteralConstantValuesDiffer) - elif implVal.IsTypeFunction <> sigVal.IsTypeFunction then (err denv FSComp.SR.ValueNotContainedMutabilityOneIsTypeFunction) - else - let implTypars,atau = implVal.TypeScheme - let sigTypars,ftau = sigVal.TypeScheme - if implTypars.Length <> sigTypars.Length then (err {denv with showTyparBinding=true} FSComp.SR.ValueNotContainedMutabilityParameterCountsDiffer) else - let aenv = aenv.BindEquivTypars implTypars sigTypars - checkTypars m aenv implTypars sigTypars && - if not (typeAEquiv g aenv atau ftau) then err denv (FSComp.SR.ValueNotContainedMutabilityTypesDiffer) - elif not (checkValInfo aenv (err denv) implVal sigVal) then false - elif not (implVal.IsExtensionMember = sigVal.IsExtensionMember) then err denv (FSComp.SR.ValueNotContainedMutabilityExtensionsDiffer) - elif not (checkMemberDatasConform (err denv) (implVal.Attribs, implVal,implVal.MemberInfo) (sigVal.Attribs,sigVal,sigVal.MemberInfo)) then false - else checkAttribs aenv implVal.Attribs sigVal.Attribs (fun attribs -> implVal.Data.val_attribs <- attribs) - - - and checkExnInfo err aenv implTypeRepr sigTypeRepr = - match implTypeRepr,sigTypeRepr with - | TExnAsmRepr _, TExnFresh _ -> - (errorR (err FSComp.SR.ExceptionDefsNotCompatibleHiddenBySignature); false) - | TExnAsmRepr tcr1, TExnAsmRepr tcr2 -> - if tcr1 <> tcr2 then (errorR (err FSComp.SR.ExceptionDefsNotCompatibleDotNetRepresentationsDiffer); false) else true - | TExnAbbrevRepr _, TExnFresh _ -> - (errorR (err FSComp.SR.ExceptionDefsNotCompatibleAbbreviationHiddenBySignature); false) - | TExnAbbrevRepr ecr1, TExnAbbrevRepr ecr2 -> - if not (tcrefAEquiv g aenv ecr1 ecr2) then - (errorR (err FSComp.SR.ExceptionDefsNotCompatibleSignaturesDiffer); false) - else true - | TExnFresh r1, TExnFresh r2-> checkRecordFieldsForExn g denv err aenv r1 r2 - | TExnNone,TExnNone -> true - | _ -> - (errorR (err FSComp.SR.ExceptionDefsNotCompatibleExceptionDeclarationsDiffer); false) - - and checkUnionCase aenv implUnionCase sigUnionCase = - let err f = errorR(ConstrNotContained(denv,implUnionCase,sigUnionCase,f));false - sigUnionCase.OtherRangeOpt <- Some (implUnionCase.Range, true) - implUnionCase.OtherRangeOpt <- Some (sigUnionCase.Range, false) - if implUnionCase.Id.idText <> sigUnionCase.Id.idText then err FSComp.SR.ModuleContainsConstructorButNamesDiffer - elif implUnionCase.RecdFields.Length <> sigUnionCase.RecdFields.Length then err FSComp.SR.ModuleContainsConstructorButDataFieldsDiffer - elif not (List.forall2 (checkField aenv) implUnionCase.RecdFields sigUnionCase.RecdFields) then err FSComp.SR.ModuleContainsConstructorButTypesOfFieldsDiffer - elif isLessAccessible implUnionCase.Accessibility sigUnionCase.Accessibility then err FSComp.SR.ModuleContainsConstructorButAccessibilityDiffers - else checkAttribs aenv implUnionCase.Attribs sigUnionCase.Attribs (fun attribs -> implUnionCase.Attribs <- attribs) - - and checkField aenv implField sigField = - let err f = errorR(FieldNotContained(denv,implField,sigField,f)); false - sigField.rfield_other_range <- Some (implField.Range, true) - implField.rfield_other_range <- Some (sigField.Range, false) - if implField.rfield_id.idText <> sigField.rfield_id.idText then err FSComp.SR.FieldNotContainedNamesDiffer - elif isLessAccessible implField.Accessibility sigField.Accessibility then err FSComp.SR.FieldNotContainedAccessibilitiesDiffer - elif implField.IsStatic <> sigField.IsStatic then err FSComp.SR.FieldNotContainedStaticsDiffer - elif implField.IsMutable <> sigField.IsMutable then err FSComp.SR.FieldNotContainedMutablesDiffer - elif implField.LiteralValue <> sigField.LiteralValue then err FSComp.SR.FieldNotContainedLiteralsDiffer - elif not (typeAEquiv g aenv implField.FormalType sigField.FormalType) then err FSComp.SR.FieldNotContainedTypesDiffer - else - checkAttribs aenv implField.FieldAttribs sigField.FieldAttribs (fun attribs -> implField.rfield_fattribs <- attribs) && - checkAttribs aenv implField.PropertyAttribs sigField.PropertyAttribs (fun attribs -> implField.rfield_pattribs <- attribs) - - and checkMemberDatasConform err (_implAttrs,implVal,implMemberInfo) (_sigAttrs, sigVal,sigMemberInfo) = - match implMemberInfo,sigMemberInfo with - | None,None -> true - | Some implMembInfo, Some sigMembInfo -> - if not (implVal.CompiledName = sigVal.CompiledName) then - err(FSComp.SR.ValueNotContainedMutabilityDotNetNamesDiffer) - elif not (implMembInfo.MemberFlags.IsInstance = sigMembInfo.MemberFlags.IsInstance) then - err(FSComp.SR.ValueNotContainedMutabilityStaticsDiffer) - elif false then - err(FSComp.SR.ValueNotContainedMutabilityVirtualsDiffer) - elif not (implMembInfo.MemberFlags.IsDispatchSlot = sigMembInfo.MemberFlags.IsDispatchSlot) then - err(FSComp.SR.ValueNotContainedMutabilityAbstractsDiffer) - // The final check is an implication: - // classes have non-final CompareTo/Hash methods - // abstract have non-final CompareTo/Hash methods - // records have final CompareTo/Hash methods - // unions have final CompareTo/Hash methods - // This is an example where it is OK for the signature to say 'non-final' when the implementation says 'final' - elif not implMembInfo.MemberFlags.IsFinal && sigMembInfo.MemberFlags.IsFinal then - err(FSComp.SR.ValueNotContainedMutabilityFinalsDiffer) - elif not (implMembInfo.MemberFlags.IsOverrideOrExplicitImpl = sigMembInfo.MemberFlags.IsOverrideOrExplicitImpl) then - err(FSComp.SR.ValueNotContainedMutabilityOverridesDiffer) - elif not (implMembInfo.MemberFlags.MemberKind = sigMembInfo.MemberFlags.MemberKind) then - err(FSComp.SR.ValueNotContainedMutabilityOneIsConstructor) - else - let finstance = ValSpecIsCompiledAsInstance g sigVal - let ainstance = ValSpecIsCompiledAsInstance g implVal - if finstance && not ainstance then - err(FSComp.SR.ValueNotContainedMutabilityStaticButInstance) - elif not finstance && ainstance then - err(FSComp.SR.ValueNotContainedMutabilityInstanceButStatic) - else true - - | _ -> false - - // ------------------------------------------------------------------------------- - // WARNING!!!! - // checkRecordFields and checkRecordFieldsForExn are the EXACT SAME FUNCTION. - // The only difference is the signature for err - this is because err is a function - // that reports errors, and checkRecordFields is called with a different - // sig for err then checkRecordFieldsForExn. - // ------------------------------------------------------------------------------- - - and checkRecordFields _g _amap _denv err aenv (implFields:TyconRecdFields) (sigFields:TyconRecdFields) = - let implFields = implFields.TrueFieldsAsList - let sigFields = sigFields.TrueFieldsAsList - let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) - let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) - NameMap.suball2 (fun s _ -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldRequiredButNotSpecified(x, s))); false) (checkField aenv) m1 m2 && - NameMap.suball2 (fun s _ -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldWasPresent(x, s))); false) (fun x y -> checkField aenv y x) m2 m1 && - // This check is required because constructors etc. are externally visible - // and thus compiled representations do pick up dependencies on the field order - (if List.forall2 (checkField aenv) implFields sigFields - then true - else (errorR(err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldOrderDiffer)); false)) - - and checkRecordFieldsForExn _g _denv err aenv (implFields:TyconRecdFields) (sigFields:TyconRecdFields) = - let implFields = implFields.TrueFieldsAsList - let sigFields = sigFields.TrueFieldsAsList - let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) - let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) - NameMap.suball2 (fun s _ -> errorR(err (fun (x, y) -> FSComp.SR.ExceptionDefsNotCompatibleFieldInSigButNotImpl(s, x, y))); false) (checkField aenv) m1 m2 && - NameMap.suball2 (fun s _ -> errorR(err (fun (x, y) -> FSComp.SR.ExceptionDefsNotCompatibleFieldInImplButNotSig(s, x, y))); false) (fun x y -> checkField aenv y x) m2 m1 && - // This check is required because constructors etc. are externally visible - // and thus compiled representations do pick up dependencies on the field order - (if List.forall2 (checkField aenv) implFields sigFields - then true - else (errorR(err (FSComp.SR.ExceptionDefsNotCompatibleFieldOrderDiffers)); false)) - - and checkVirtualSlots _g denv err _aenv implAbstractSlots sigAbstractSlots = - let m1 = NameMap.ofKeyedList (fun (v:ValRef) -> v.DisplayName) implAbstractSlots - let m2 = NameMap.ofKeyedList (fun (v:ValRef) -> v.DisplayName) sigAbstractSlots - (m1,m2) ||> NameMap.suball2 (fun _s vref -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbstractMemberMissingInImpl(x, NicePrint.stringValOrMember denv vref.Deref))); false) (fun _x _y -> true) && - (m2,m1) ||> NameMap.suball2 (fun _s vref -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbstractMemberMissingInSig(x, NicePrint.stringValOrMember denv vref.Deref))); false) (fun _x _y -> true) - - and checkClassFields isStruct _g _amap _denv err aenv (implFields:TyconRecdFields) (sigFields:TyconRecdFields) = - let implFields = implFields.TrueFieldsAsList - let sigFields = sigFields.TrueFieldsAsList - let m1 = implFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) - let m2 = sigFields |> NameMap.ofKeyedList (fun rfld -> rfld.Name) - NameMap.suball2 (fun s _ -> errorR(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldRequiredButNotSpecified(x, s))); false) (checkField aenv) m1 m2 && - (if isStruct then - NameMap.suball2 (fun s _ -> warning(err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleFieldIsInImplButNotSig(x, s))); true) (fun x y -> checkField aenv y x) m2 m1 - else - true) - - - and checkTypeRepr err aenv implTypeRepr sigTypeRepr = - let reportNiceError k s1 s2 = - let aset = NameSet.ofList s1 - let fset = NameSet.ofList s2 - match Zset.elements (Zset.diff aset fset) with - | [] -> - match Zset.elements (Zset.diff fset aset) with - | [] -> (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleNumbersDiffer(x, k))); false) - | l -> (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDefinesButImplDoesNot(x, k, String.concat ";" l))); false) - | l -> (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesButSignatureDoesNot(x, k, String.concat ";" l))); false) - - match implTypeRepr,sigTypeRepr with - | (TRecdRepr _ - | TFiniteUnionRepr _ - | TILObjModelRepr _ -#if EXTENSIONTYPING - | TProvidedTypeExtensionPoint _ - | TProvidedNamespaceExtensionPoint _ -#endif - ), TNoRepr -> true - | (TFsObjModelRepr r), TNoRepr -> - match r.fsobjmodel_kind with - | TTyconStruct | TTyconEnum -> - (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesStruct); false) - | _ -> - true - | (TAsmRepr _), TNoRepr -> - (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleDotNetTypeRepresentationIsHidden); false) - | (TMeasureableRepr _), TNoRepr -> - (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsHidden); false) - | (TFiniteUnionRepr r1), (TFiniteUnionRepr r2) -> - let ucases1 = r1.UnionCasesAsList - let ucases2 = r2.UnionCasesAsList - if ucases1.Length <> ucases2.Length then - let names (l: UnionCase list) = l |> List.map (fun c -> c.Id.idText) - reportNiceError "union case" (names ucases1) (names ucases2) - else List.forall2 (checkUnionCase aenv) ucases1 ucases2 - | (TRecdRepr implFields), (TRecdRepr sigFields) -> - checkRecordFields g amap denv err aenv implFields sigFields - | (TFsObjModelRepr r1), (TFsObjModelRepr r2) -> - if not (match r1.fsobjmodel_kind,r2.fsobjmodel_kind with - | TTyconClass,TTyconClass -> true - | TTyconInterface,TTyconInterface -> true - | TTyconStruct,TTyconStruct -> true - | TTyconEnum, TTyconEnum -> true - | TTyconDelegate (TSlotSig(_,typ1,ctps1,mtps1,ps1, rty1)), - TTyconDelegate (TSlotSig(_,typ2,ctps2,mtps2,ps2, rty2)) -> - (typeAEquiv g aenv typ1 typ2) && - (ctps1.Length = ctps2.Length) && - (let aenv = aenv.BindEquivTypars ctps1 ctps2 - (typarsAEquiv g aenv ctps1 ctps2) && - (mtps1.Length = mtps2.Length) && - (let aenv = aenv.BindEquivTypars mtps1 mtps2 - (typarsAEquiv g aenv mtps1 mtps2) && - ((ps1,ps2) ||> List.lengthsEqAndForall2 (List.lengthsEqAndForall2 (fun p1 p2 -> typeAEquiv g aenv p1.Type p2.Type))) && - (returnTypesAEquiv g aenv rty1 rty2))) - | _,_ -> false) then - (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsDifferentKind); false) - else - let isStruct = (match r1.fsobjmodel_kind with TTyconStruct -> true | _ -> false) - checkClassFields isStruct g amap denv err aenv r1.fsobjmodel_rfields r2.fsobjmodel_rfields && - checkVirtualSlots g denv err aenv r1.fsobjmodel_vslots r2.fsobjmodel_vslots - | (TAsmRepr tcr1), (TAsmRepr tcr2) -> - if tcr1 <> tcr2 then (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleILDiffer); false) else true - | (TMeasureableRepr ty1), (TMeasureableRepr ty2) -> - if typeAEquiv g aenv ty1 ty2 then true else (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer); false) - | TNoRepr, TNoRepr -> true -#if EXTENSIONTYPING - | TProvidedTypeExtensionPoint info1 , TProvidedTypeExtensionPoint info2 -> - Tainted.EqTainted info1.ProvidedType.TypeProvider info2.ProvidedType.TypeProvider && ProvidedType.TaintedEquals(info1.ProvidedType,info2.ProvidedType) - | TProvidedNamespaceExtensionPoint _, TProvidedNamespaceExtensionPoint _ -> - System.Diagnostics.Debug.Assert(false, "unreachable: TProvidedNamespaceExtensionPoint only on namespaces, not types" ) - true -#endif - | TNoRepr, _ -> (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer); false) - | _, _ -> (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleRepresentationsDiffer); false) - - and checkTypeAbbrev err aenv kind1 kind2 implTypeAbbrev sigTypeAbbrev = - if kind1 <> kind2 then (errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleSignatureDeclaresDiffer(x, kind2.ToString(), kind1.ToString()))); false) - else - match implTypeAbbrev,sigTypeAbbrev with - | Some ty1, Some ty2 -> - if not (typeAEquiv g aenv ty1 ty2) then - let s1, s2, _ = NicePrint.minimalStringsOfTwoTypes denv ty1 ty2 - errorR (err (fun x -> FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbbreviationsDiffer(x, s1, s2))) - false - else - true - | None,None -> true - | Some _, None -> (errorR (err (FSComp.SR.DefinitionsInSigAndImplNotCompatibleAbbreviationHiddenBySig)); false) - | None, Some _ -> (errorR (err FSComp.SR.DefinitionsInSigAndImplNotCompatibleSigHasAbbreviation); false) - - and checkModuleOrNamespaceContents m aenv (implModRef:ModuleOrNamespaceRef) (signModType:ModuleOrNamespaceType) = - let implModType = implModRef.ModuleOrNamespaceType - (if implModType.ModuleOrNamespaceKind <> signModType.ModuleOrNamespaceKind then errorR(Error(FSComp.SR.typrelModuleNamespaceAttributesDifferInSigAndImpl(),m))) - - - (implModType.TypesByMangledName , signModType.TypesByMangledName) - ||> NameMap.suball2 - (fun s _fx -> errorR(RequiredButNotSpecified(denv,implModRef,"type",(fun os -> Printf.bprintf os "%s" s),m)); false) - (checkTypeDef aenv) && - - - (implModType.ModulesAndNamespacesByDemangledName, signModType.ModulesAndNamespacesByDemangledName ) - ||> NameMap.suball2 - (fun s fx -> errorR(RequiredButNotSpecified(denv,implModRef,(if fx.IsModule then "module" else "namespace"),(fun os -> Printf.bprintf os "%s" s),m)); false) - (fun x1 x2 -> checkModuleOrNamespace aenv (mkLocalModRef x1) x2) && - - let sigValHadNoMatchingImplementation (fx:Val) (_closeActualVal: Val option) = - errorR(RequiredButNotSpecified(denv,implModRef,"value",(fun os -> - (* In the case of missing members show the full required enclosing type and signature *) - if fx.IsMember then - NicePrint.outputQualifiedValOrMember denv os fx - else - Printf.bprintf os "%s" fx.DisplayName),m)) - - let valuesPartiallyMatch (av:Val) (fv:Val) = - (av.LinkagePartialKey.MemberParentMangledName = fv.LinkagePartialKey.MemberParentMangledName) && - (av.LinkagePartialKey.LogicalName = fv.LinkagePartialKey.LogicalName) && - (av.LinkagePartialKey.TotalArgCount = fv.LinkagePartialKey.TotalArgCount) - - (implModType.AllValsAndMembersByLogicalNameUncached, signModType.AllValsAndMembersByLogicalNameUncached) - ||> NameMap.suball2 - (fun _s (fxs:Val list) -> sigValHadNoMatchingImplementation fxs.Head None; false) - (fun avs fvs -> - match avs,fvs with - | [],_ | _,[] -> failwith "unreachable" - | [av],[fv] -> - if valuesPartiallyMatch av fv then - checkVal implModRef aenv av fv - else - sigValHadNoMatchingImplementation fv None - false - | _ -> - // for each formal requirement, try to find a precisely matching actual requirement - let matchingPairs = - fvs |> List.choose (fun fv -> - match avs |> List.tryFind (fun av -> - let res = valLinkageAEquiv g aenv av fv - //if res then printfn "%s" (bufs (fun buf -> Printf.bprintf buf "YES MATCH: fv '%a', av '%a'" (NicePrint.outputQualifiedValOrMember denv) fv (NicePrint.outputQualifiedValOrMember denv) av)) - //else printfn "%s" (bufs (fun buf -> Printf.bprintf buf "NO MATCH: fv '%a', av '%a'" (NicePrint.outputQualifiedValOrMember denv) fv (NicePrint.outputQualifiedValOrMember denv) av)) - res) with - | None -> None - | Some av -> Some(fv,av)) - - // Check the ones with matching linkage - let allPairsOk = matchingPairs |> List.map (fun (fv,av) -> checkVal implModRef aenv av fv) |> List.forall id - let someNotOk = matchingPairs.Length < fvs.Length - // Report an error for those that don't. Try pairing up by enclosing-type/name - if someNotOk then - let noMatches,partialMatchingPairs = - fvs |> List.splitChoose (fun fv -> - match avs |> List.tryFind (fun av -> valuesPartiallyMatch av fv) with - | None -> Choice1Of2 fv - | Some av -> Choice2Of2(fv,av)) - for (fv,av) in partialMatchingPairs do - checkVal implModRef aenv av fv |> ignore - for fv in noMatches do - sigValHadNoMatchingImplementation fv None - allPairsOk && not someNotOk) - - - and checkModuleOrNamespace aenv implModRef sigModRef = - // Propagate defn location information from implementation to signature . - sigModRef.SetOtherRange (implModRef.Range, true) - implModRef.Deref.SetOtherRange (sigModRef.Range, false) - checkModuleOrNamespaceContents implModRef.Range aenv implModRef sigModRef.ModuleOrNamespaceType && - checkAttribs aenv implModRef.Attribs sigModRef.Attribs implModRef.Deref.SetAttribs - - member __.CheckSignature aenv (implModRef:ModuleOrNamespaceRef) (signModType:ModuleOrNamespaceType) = - checkModuleOrNamespaceContents implModRef.Range aenv implModRef signModType - - member __.CheckTypars m aenv (implTypars: Typars) (signTypars: Typars) = - checkTypars m aenv implTypars signTypars - - - /// Check the names add up between a signature and its implementation. We check this first. - let rec CheckNamesOfModuleOrNamespaceContents denv (implModRef:ModuleOrNamespaceRef) (signModType:ModuleOrNamespaceType) = - let m = implModRef.Range - let implModType = implModRef.ModuleOrNamespaceType - NameMap.suball2 - (fun s _fx -> errorR(RequiredButNotSpecified(denv,implModRef,"type",(fun os -> Printf.bprintf os "%s" s),m)); false) - (fun _ _ -> true) - implModType.TypesByMangledName - signModType.TypesByMangledName && - - (implModType.ModulesAndNamespacesByDemangledName, signModType.ModulesAndNamespacesByDemangledName ) - ||> NameMap.suball2 - (fun s fx -> errorR(RequiredButNotSpecified(denv,implModRef,(if fx.IsModule then "module" else "namespace"),(fun os -> Printf.bprintf os "%s" s),m)); false) - (fun x1 (x2:ModuleOrNamespace) -> CheckNamesOfModuleOrNamespace denv (mkLocalModRef x1) x2.ModuleOrNamespaceType) && - - (implModType.AllValsAndMembersByLogicalNameUncached , signModType.AllValsAndMembersByLogicalNameUncached) - ||> NameMap.suball2 - (fun _s (fxs:Val list) -> - let fx = fxs.Head - errorR(RequiredButNotSpecified(denv,implModRef,"value",(fun os -> - // In the case of missing members show the full required enclosing type and signature - if isSome fx.MemberInfo then - NicePrint.outputQualifiedValOrMember denv os fx - else - Printf.bprintf os "%s" fx.DisplayName),m)); false) - (fun _ _ -> true) - - - and CheckNamesOfModuleOrNamespace denv (implModRef:ModuleOrNamespaceRef) signModType = - CheckNamesOfModuleOrNamespaceContents denv implModRef signModType - -end - -//------------------------------------------------------------------------- -// Completeness of classes -//------------------------------------------------------------------------- - -type OverrideCanImplement = - | CanImplementAnyInterfaceSlot - | CanImplementAnyClassHierarchySlot - | CanImplementAnySlot - | CanImplementNoSlots - -/// The overall information about a method implementation in a class or object expression -type OverrideInfo = - | Override of OverrideCanImplement * TyconRef * Ident * (Typars * TyparInst) * TType list list * TType option * bool * bool - member x.CanImplement = let (Override(a,_,_,_,_,_,_,_)) = x in a - member x.BoundingTyconRef = let (Override(_,ty,_,_,_,_,_,_)) = x in ty - member x.LogicalName = let (Override(_,_,id,_,_,_,_,_)) = x in id.idText - member x.Range = let (Override(_,_,id,_,_,_,_,_)) = x in id.idRange - member x.IsFakeEventProperty = let (Override(_,_,_,_,_,_,b,_)) = x in b - member x.ArgTypes = let (Override(_,_,_,_,b,_,_,_)) = x in b - member x.ReturnType = let (Override(_,_,_,_,_,b,_,_)) = x in b - member x.IsCompilerGenerated = let (Override(_,_,_,_,_,_,_,b)) = x in b - -// If the bool is true then the slot is optional, i.e. is an interface slot -// which does not _have_ to be implemented, because an inherited implementation -// is available. -type RequiredSlot = RequiredSlot of MethInfo * (* isOptional: *) bool - -type SlotImplSet = SlotImplSet of RequiredSlot list * NameMultiMap * OverrideInfo list * PropInfo list - -exception TypeIsImplicitlyAbstract of range -exception OverrideDoesntOverride of DisplayEnv * OverrideInfo * MethInfo option * TcGlobals * Import.ImportMap * range - -module DispatchSlotChecking = - - /// Print the signature of an override to a buffer as part of an error message - let PrintOverrideToBuffer denv os (Override(_,_,id,(mtps,memberToParentInst),argTys,retTy,_,_)) = - let denv = { denv with showTyparBinding = true } - let retTy = (retTy |> GetFSharpViewOfReturnType denv.g) - let argInfos = - match argTys with - | [] -> [[(denv.g.unit_ty,ValReprInfo.unnamedTopArg1)]] - | _ -> argTys |> List.mapSquared (fun ty -> (ty, ValReprInfo.unnamedTopArg1)) - Layout.bufferL os (NicePrint.layoutMemberSig denv (memberToParentInst,id.idText,mtps, argInfos, retTy)) - - /// Print the signature of a MethInfo to a buffer as part of an error message - let PrintMethInfoSigToBuffer g amap m denv os minfo = - let denv = { denv with showTyparBinding = true } - let (CompiledSig(argTys,retTy,fmtps,ttpinst)) = CompiledSigOfMeth g amap m minfo - let retTy = (retTy |> GetFSharpViewOfReturnType g) - let argInfos = argTys |> List.mapSquared (fun ty -> (ty, ValReprInfo.unnamedTopArg1)) - let nm = minfo.LogicalName - Layout.bufferL os (NicePrint.layoutMemberSig denv (ttpinst,nm,fmtps, argInfos, retTy)) - - /// Format the signature of an override as a string as part of an error message - let FormatOverride denv d = bufs (fun buf -> PrintOverrideToBuffer denv buf d) - - /// Format the signature of a MethInfo as a string as part of an error message - let FormatMethInfoSig g amap m denv d = bufs (fun buf -> PrintMethInfoSigToBuffer g amap m denv buf d) - - /// Get the override info for an existing (inherited) method being used to implement a dispatch slot. - let GetInheritedMemberOverrideInfo g amap m parentType (minfo:MethInfo) = - let nm = minfo.LogicalName - let (CompiledSig (argTys,retTy,fmtps,ttpinst)) = CompiledSigOfMeth g amap m minfo - - let isFakeEventProperty = minfo.IsFSharpEventPropertyMethod - Override(parentType,tcrefOfAppTy g minfo.EnclosingType,mkSynId m nm, (fmtps,ttpinst),argTys,retTy,isFakeEventProperty,false) - - /// Get the override info for a value being used to implement a dispatch slot. - let GetTypeMemberOverrideInfo g reqdTy (overrideBy:ValRef) = - let _,argInfos,retTy,_ = GetTypeOfMemberInMemberForm g overrideBy - let nm = overrideBy.LogicalName - - let argTys = argInfos |> List.mapSquared fst - - let memberMethodTypars,memberToParentInst,argTys,retTy = - match PartitionValRefTypars g overrideBy with - | Some(_,_,memberMethodTypars,memberToParentInst,_tinst) -> - let argTys = argTys |> List.mapSquared (instType memberToParentInst) - let retTy = retTy |> Option.map (instType memberToParentInst) - memberMethodTypars, memberToParentInst,argTys, retTy - | None -> - error(Error(FSComp.SR.typrelMethodIsOverconstrained(),overrideBy.Range)) - let implKind = - if ValRefIsExplicitImpl g overrideBy then - - let belongsToReqdTy = - match overrideBy.MemberInfo.Value.ImplementedSlotSigs with - | [] -> false - | ss :: _ -> isInterfaceTy g ss.ImplementedType && typeEquiv g reqdTy ss.ImplementedType - if belongsToReqdTy then - CanImplementAnyInterfaceSlot - else - CanImplementNoSlots - else if overrideBy.IsDispatchSlotMember then - CanImplementNoSlots - // abstract slots can only implement interface slots - //CanImplementAnyInterfaceSlot <<----- Change to this to enable implicit interface implementation - - else - CanImplementAnyClassHierarchySlot - //CanImplementAnySlot <<----- Change to this to enable implicit interface implementation - - let isFakeEventProperty = overrideBy.IsFSharpEventProperty(g) - Override(implKind,overrideBy.MemberApparentParent, mkSynId overrideBy.Range nm, (memberMethodTypars,memberToParentInst),argTys,retTy,isFakeEventProperty, overrideBy.IsCompilerGenerated) - - /// Get the override information for an object expression method being used to implement dispatch slots - let GetObjectExprOverrideInfo g amap (implty, id:Ident, memberFlags, ty, arityInfo, bindingAttribs, rhsExpr) = - // Dissect the type - let tps, argInfos, retTy, _ = GetMemberTypeInMemberForm g memberFlags arityInfo ty id.idRange - let argTys = argInfos |> List.mapSquared fst - // Dissect the implementation - let _, ctorThisValOpt, baseValOpt, vsl, rhsExpr,_ = destTopLambda g amap arityInfo (rhsExpr,ty) - assert ctorThisValOpt.IsNone - - // Drop 'this' - match vsl with - | [thisv]::vs -> - // Check for empty variable list from a () arg - let vs = if vs.Length = 1 && argInfos.IsEmpty then [] else vs - let implKind = - if isInterfaceTy g implty then - CanImplementAnyInterfaceSlot - else - CanImplementAnyClassHierarchySlot - //CanImplementAnySlot <<----- Change to this to enable implicit interface implementation - let isFakeEventProperty = CompileAsEvent g bindingAttribs - let overrideByInfo = Override(implKind, tcrefOfAppTy g implty, id, (tps,[]), argTys, retTy, isFakeEventProperty, false) - overrideByInfo, (baseValOpt, thisv, vs, bindingAttribs, rhsExpr) - | _ -> - error(InternalError("Unexpected shape for object expression override",id.idRange)) - - /// Check if an override matches a dispatch slot by name - let IsNameMatch (dispatchSlot:MethInfo) (overrideBy: OverrideInfo) = - (overrideBy.LogicalName = dispatchSlot.LogicalName) - - /// Check if an override matches a dispatch slot by name - let IsImplMatch g (dispatchSlot:MethInfo) (overrideBy: OverrideInfo) = - // If the override is listed as only relevant to one type, and we're matching it against an abstract slot of an interface type, - // then check that interface type is the right type. - (match overrideBy.CanImplement with - | CanImplementNoSlots -> false - | CanImplementAnySlot -> true - | CanImplementAnyClassHierarchySlot -> not (isInterfaceTy g dispatchSlot.EnclosingType) - //| CanImplementSpecificInterfaceSlot parentTy -> isInterfaceTy g dispatchSlot.EnclosingType && typeEquiv g parentTy dispatchSlot.EnclosingType - | CanImplementAnyInterfaceSlot -> isInterfaceTy g dispatchSlot.EnclosingType) - - /// Check if the kinds of type parameters match between a dispatch slot and an override. - let IsTyparKindMatch g amap m (dispatchSlot:MethInfo) (Override(_,_,_,(mtps,_),_,_,_,_)) = - let (CompiledSig(_,_,fvmtps,_)) = CompiledSigOfMeth g amap m dispatchSlot - List.lengthsEqAndForall2 (fun (tp1:Typar) (tp2:Typar) -> tp1.Kind = tp2.Kind) mtps fvmtps - - /// Check if an override is a partial match for the requirements for a dispatch slot - let IsPartialMatch g amap m (dispatchSlot:MethInfo) (Override(_,_,_,(mtps,_),argTys,_retTy,_,_) as overrideBy) = - IsNameMatch dispatchSlot overrideBy && - let (CompiledSig (vargtys,_,fvmtps,_)) = CompiledSigOfMeth g amap m dispatchSlot - mtps.Length = fvmtps.Length && - IsTyparKindMatch g amap m dispatchSlot overrideBy && - argTys.Length = vargtys.Length && - IsImplMatch g dispatchSlot overrideBy - - /// Compute the reverse of a type parameter renaming. - let ReverseTyparRenaming g tinst = - tinst |> List.map (fun (tp,ty) -> (destTyparTy g ty, mkTyparTy tp)) - - /// Compose two instantiations of type parameters. - let ComposeTyparInsts inst1 inst2 = - inst1 |> List.map (map2Of2 (instType inst2)) - - /// Check if an override exactly matches the requirements for a dispatch slot - let IsExactMatch g amap m dispatchSlot (Override(_,_,_,(mtps,mtpinst),argTys,retTy,_,_) as overrideBy) = - IsPartialMatch g amap m dispatchSlot overrideBy && - let (CompiledSig (vargtys,vrty,fvmtps,ttpinst)) = CompiledSigOfMeth g amap m dispatchSlot - - // Compare the types. CompiledSigOfMeth, GetObjectExprOverrideInfo and GetTypeMemberOverrideInfo have already - // applied all relevant substitutions except the renamings from fvtmps <-> mtps - - let aenv = TypeEquivEnv.FromEquivTypars fvmtps mtps - - List.forall2 (List.lengthsEqAndForall2 (typeAEquiv g aenv)) vargtys argTys && - returnTypesAEquiv g aenv vrty retTy && - - // Comparing the method typars and their constraints is much trickier since the substitutions have not been applied - // to the constraints of these babies. This is partly because constraints are directly attached to typars so it's - // difficult to apply substitutions to them unless we separate them off at some point, which we don't as yet. - // - // Given C - // D - // dispatchSlot : C.M(...) - // overrideBy: parent: D value: ! (...) - // - // where X[dtps] indicates that X may involve free type variables dtps - // - // we have - // ttpinst maps ctps --> ctys[dtps] - // mtpinst maps ttps --> dtps - // - // compare fvtmps[ctps] and mtps[ttps] by - // fvtmps[ctps] @ ttpinst -- gives fvtmps[dtps] - // fvtmps[dtps] @ rev(mtpinst) -- gives fvtmps[ttps] - // - // Now fvtmps[ttps] and mtpinst[ttps] are comparable, i.e. have constraints w.r.t. the same set of type variables - // - // i.e. Compose the substitutions ttpinst and rev(mtpinst) - - let ttpinst = - // check we can reverse - in some error recovery situations we can't - if mtpinst |> List.exists (snd >> isTyparTy g >> not) then ttpinst - else ComposeTyparInsts ttpinst (ReverseTyparRenaming g mtpinst) - - // Compare under the composed substitutions - let aenv = TypeEquivEnv.FromTyparInst ttpinst - - typarsAEquiv g aenv fvmtps mtps - - /// Check if an override implements a dispatch slot - let OverrideImplementsDispatchSlot g amap m dispatchSlot availPriorOverride = - IsExactMatch g amap m dispatchSlot availPriorOverride && - // The override has to actually be in some subtype of the dispatch slot - ExistsHeadTypeInEntireHierarchy g amap m (generalizedTyconRef availPriorOverride.BoundingTyconRef) (tcrefOfAppTy g dispatchSlot.EnclosingType) - - /// Check if a dispatch slot is already implemented - let DispatchSlotIsAlreadyImplemented g amap m availPriorOverridesKeyed (dispatchSlot: MethInfo) = - availPriorOverridesKeyed - |> NameMultiMap.find dispatchSlot.LogicalName - |> List.exists (OverrideImplementsDispatchSlot g amap m dispatchSlot) - - - /// Check all dispatch slots are implemented by some override. - let CheckDispatchSlotsAreImplemented (denv,g,amap,m, - nenv,sink:TcResultsSink, - isOverallTyAbstract, - reqdTy, - dispatchSlots:RequiredSlot list, - availPriorOverrides:OverrideInfo list, - overrides:OverrideInfo list) = - - let isReqdTyInterface = isInterfaceTy g reqdTy - let showMissingMethodsAndRaiseErrors = (isReqdTyInterface || not isOverallTyAbstract) - let res = ref true - let fail exn = (res := false ; if showMissingMethodsAndRaiseErrors then errorR exn) - - // Index the availPriorOverrides and overrides by name - let availPriorOverridesKeyed = availPriorOverrides |> NameMultiMap.initBy (fun ov -> ov.LogicalName) - let overridesKeyed = overrides |> NameMultiMap.initBy (fun ov -> ov.LogicalName) - - dispatchSlots |> List.iter (fun (RequiredSlot(dispatchSlot,isOptional)) -> - - match NameMultiMap.find dispatchSlot.LogicalName overridesKeyed - |> List.filter (OverrideImplementsDispatchSlot g amap m dispatchSlot) with - | [ovd] -> - if not ovd.IsCompilerGenerated then - let item = Item.MethodGroup(ovd.LogicalName,[dispatchSlot],None) - CallNameResolutionSink sink (ovd.Range,nenv,item,item,ItemOccurence.Implemented,denv,AccessorDomain.AccessibleFromSomewhere) - sink |> ignore - () - | [] -> - if not isOptional && - // Check that no available prior override implements this dispatch slot - not (DispatchSlotIsAlreadyImplemented g amap m availPriorOverridesKeyed dispatchSlot) then - // error reporting path - let (CompiledSig (vargtys,_vrty,fvmtps,_)) = CompiledSigOfMeth g amap m dispatchSlot - let noimpl() = if isReqdTyInterface then fail(Error(FSComp.SR.typrelNoImplementationGivenWithSuggestion(NicePrint.stringOfMethInfo amap m denv dispatchSlot), m)) - else fail(Error(FSComp.SR.typrelNoImplementationGiven(NicePrint.stringOfMethInfo amap m denv dispatchSlot), m)) - match overrides |> List.filter (IsPartialMatch g amap m dispatchSlot) with - | [] -> - match overrides |> List.filter (fun overrideBy -> IsNameMatch dispatchSlot overrideBy && - IsImplMatch g dispatchSlot overrideBy) with - | [] -> - noimpl() - | [ Override(_,_,_,(mtps,_),argTys,_,_,_) as overrideBy ] -> - let error_msg = - if argTys.Length <> vargtys.Length then FSComp.SR.typrelMemberDoesNotHaveCorrectNumberOfArguments(FormatOverride denv overrideBy, FormatMethInfoSig g amap m denv dispatchSlot) - elif mtps.Length <> fvmtps.Length then FSComp.SR.typrelMemberDoesNotHaveCorrectNumberOfTypeParameters(FormatOverride denv overrideBy, FormatMethInfoSig g amap m denv dispatchSlot) - elif not (IsTyparKindMatch g amap m dispatchSlot overrideBy) then FSComp.SR.typrelMemberDoesNotHaveCorrectKindsOfGenericParameters(FormatOverride denv overrideBy, FormatMethInfoSig g amap m denv dispatchSlot) - else FSComp.SR.typrelMemberCannotImplement(FormatOverride denv overrideBy, NicePrint.stringOfMethInfo amap m denv dispatchSlot, FormatMethInfoSig g amap m denv dispatchSlot) - fail(Error(error_msg, overrideBy.Range)) - | overrideBy :: _ -> - errorR(Error(FSComp.SR.typrelOverloadNotFound(FormatMethInfoSig g amap m denv dispatchSlot, FormatMethInfoSig g amap m denv dispatchSlot),overrideBy.Range)) - - | [ overrideBy ] -> - - match dispatchSlots |> List.filter (fun (RequiredSlot(dispatchSlot,_)) -> OverrideImplementsDispatchSlot g amap m dispatchSlot overrideBy) with - | [] -> - // Error will be reported below in CheckOverridesAreAllUsedOnce - () - | _ -> - noimpl() - - | _ -> - fail(Error(FSComp.SR.typrelOverrideWasAmbiguous(FormatMethInfoSig g amap m denv dispatchSlot),m)) - | _ -> fail(Error(FSComp.SR.typrelMoreThenOneOverride(FormatMethInfoSig g amap m denv dispatchSlot),m))) - !res - - /// Check all implementations implement some dispatch slot. - let CheckOverridesAreAllUsedOnce(denv, g, amap, isObjExpr, reqdTy, - dispatchSlotsKeyed: NameMultiMap, - availPriorOverrides: OverrideInfo list, - overrides: OverrideInfo list) = - let availPriorOverridesKeyed = availPriorOverrides |> NameMultiMap.initBy (fun ov -> ov.LogicalName) - for overrideBy in overrides do - if not overrideBy.IsFakeEventProperty then - let m = overrideBy.Range - let relevantVirts = NameMultiMap.find overrideBy.LogicalName dispatchSlotsKeyed - let relevantVirts = relevantVirts |> List.map (fun (RequiredSlot(dispatchSlot,_)) -> dispatchSlot) - - match relevantVirts |> List.filter (fun dispatchSlot -> OverrideImplementsDispatchSlot g amap m dispatchSlot overrideBy) with - | [] -> - // This is all error reporting - match relevantVirts |> List.filter (fun dispatchSlot -> IsPartialMatch g amap m dispatchSlot overrideBy) with - | [dispatchSlot] -> - errorR(OverrideDoesntOverride(denv,overrideBy,Some dispatchSlot,g,amap,m)) - | _ -> - match relevantVirts |> List.filter (fun dispatchSlot -> IsNameMatch dispatchSlot overrideBy) with - | [dispatchSlot] -> - errorR(OverrideDoesntOverride(denv, overrideBy, Some dispatchSlot, g, amap, m)) - | _ -> - errorR(OverrideDoesntOverride(denv,overrideBy,None,g,amap,m)) - - - | [dispatchSlot] -> - if dispatchSlot.IsFinal && (isObjExpr || not (typeEquiv g reqdTy dispatchSlot.EnclosingType)) then - errorR(Error(FSComp.SR.typrelMethodIsSealed(NicePrint.stringOfMethInfo amap m denv dispatchSlot),m)) - | dispatchSlots -> - match dispatchSlots |> List.filter (fun dispatchSlot -> - isInterfaceTy g dispatchSlot.EnclosingType || - not (DispatchSlotIsAlreadyImplemented g amap m availPriorOverridesKeyed dispatchSlot)) with - | h1 :: h2 :: _ -> - errorR(Error(FSComp.SR.typrelOverrideImplementsMoreThenOneSlot((FormatOverride denv overrideBy), (NicePrint.stringOfMethInfo amap m denv h1), (NicePrint.stringOfMethInfo amap m denv h2)),m)) - | _ -> - // dispatch slots are ordered from the derived classes to base - // so we can check the topmost dispatch slot if it is final - match dispatchSlots with - | meth::_ when meth.IsFinal -> errorR(Error(FSComp.SR.tcCannotOverrideSealedMethod((sprintf "%s::%s" (meth.EnclosingType.ToString()) (meth.LogicalName))), m)) - | _ -> () - - - - /// Get the slots of a type that can or must be implemented. This depends - /// partly on the full set of interface types that are being implemented - /// simultaneously, e.g. - /// { new C with interface I2 = ... interface I3 = ... } - /// allReqdTys = {C;I2;I3} - /// - /// allReqdTys can include one class/record/union type. - let GetSlotImplSets (infoReader:InfoReader) denv isObjExpr allReqdTys = - - let g = infoReader.g - let amap = infoReader.amap - - let availImpliedInterfaces : TType list = - [ for (reqdTy,m) in allReqdTys do - if not (isInterfaceTy g reqdTy) then - let baseTyOpt = if isObjExpr then Some reqdTy else GetSuperTypeOfType g amap m reqdTy - match baseTyOpt with - | None -> () - | Some baseTy -> yield! AllInterfacesOfType g amap m AllowMultiIntfInstantiations.Yes baseTy ] - - // For each implemented type, get a list containing the transitive closure of - // interface types implied by the type. This includes the implemented type itself if the implemented type - // is an interface type. - let intfSets = - allReqdTys |> List.mapi (fun i (reqdTy,m) -> - let interfaces = AllInterfacesOfType g amap m AllowMultiIntfInstantiations.Yes reqdTy - let impliedTys = (if isInterfaceTy g reqdTy then interfaces else reqdTy :: interfaces) - (i, reqdTy, impliedTys,m)) - - // For each implemented type, reduce its list of implied interfaces by subtracting out those implied - // by another implemented interface type. - // - // REVIEW: Note complexity O(ity*jty) - let reqdTyInfos = - intfSets |> List.map (fun (i,reqdTy,impliedTys,m) -> - let reduced = - (impliedTys,intfSets) ||> List.fold (fun acc (j,jty,impliedTys2,m) -> - if i <> j && TypeFeasiblySubsumesType 0 g amap m jty CanCoerce reqdTy - then ListSet.subtract (TypesFeasiblyEquiv 0 g amap m) acc impliedTys2 - else acc ) - (i, reqdTy, m, reduced)) - - // Check that, for each implemented type, at least one implemented type is implied. This is enough to capture - // duplicates. - for (_i, reqdTy, m, impliedTys) in reqdTyInfos do - if isInterfaceTy g reqdTy && isNil impliedTys then - errorR(Error(FSComp.SR.typrelDuplicateInterface(),m)) - - // Check that no interface type is implied twice - // - // Note complexity O(reqdTy*reqdTy) - for (i, _reqdTy, reqdTyRange, impliedTys) in reqdTyInfos do - for (j,_,_,impliedTys2) in reqdTyInfos do - if i > j then - let overlap = ListSet.intersect (TypesFeasiblyEquiv 0 g amap reqdTyRange) impliedTys impliedTys2 - overlap |> List.iter (fun overlappingTy -> - if nonNil(GetImmediateIntrinsicMethInfosOfType (None,AccessibleFromSomewhere) g amap reqdTyRange overlappingTy |> List.filter (fun minfo -> minfo.IsVirtual)) then - errorR(Error(FSComp.SR.typrelNeedExplicitImplementation(NicePrint.minimalStringOfType denv (List.head overlap)),reqdTyRange))) - - // Get the SlotImplSet for each implemented type - // This contains the list of required members and the list of available members - [ for (_,reqdTy,reqdTyRange,impliedTys) in reqdTyInfos do - - // Build a set of the implied interface types, for quicker lookup, by nominal type - let isImpliedInterfaceTable = - impliedTys - |> List.filter (isInterfaceTy g) - |> List.map (fun ty -> tcrefOfAppTy g ty, ()) - |> TyconRefMap.OfList - - // Is a member an abstract slot of one of the implied interface types? - let isImpliedInterfaceType ty = - isImpliedInterfaceTable.ContainsKey (tcrefOfAppTy g ty) && - impliedTys |> List.exists (TypesFeasiblyEquiv 0 g amap reqdTyRange ty) - - //let isSlotImpl (minfo:MethInfo) = - // not minfo.IsAbstract && minfo.IsVirtual - - // Compute the abstract slots that require implementations - let dispatchSlots = - [ if isInterfaceTy g reqdTy then - for impliedTy in impliedTys do - // Check if the interface has an inherited implementation - // If so, you do not have to implement all the methods - each - // specific method is "optionally" implemented. - let isOptional = - ListSet.contains (typeEquiv g) impliedTy availImpliedInterfaces - for reqdSlot in GetImmediateIntrinsicMethInfosOfType (None,AccessibleFromSomewhere) g amap reqdTyRange impliedTy do - yield RequiredSlot(reqdSlot, isOptional) - else - - // In the normal case, the requirements for a class are precisely all the abstract slots up the whole hierarchy. - // So here we get and yield all of those. - for minfo in reqdTy |> GetIntrinsicMethInfosOfType infoReader (None,AccessibleFromSomewhere,AllowMultiIntfInstantiations.Yes) IgnoreOverrides reqdTyRange do - if minfo.IsDispatchSlot then - yield RequiredSlot(minfo,(*isOptional=*)false) ] - - - // Compute the methods that are available to implement abstract slots from the base class - // - // This is used in CheckDispatchSlotsAreImplemented when we think a dispatch slot may not - // have been implemented. - let availPriorOverrides : OverrideInfo list = - if isInterfaceTy g reqdTy then - [] - else - let reqdTy = - let baseTyOpt = if isObjExpr then Some reqdTy else GetSuperTypeOfType g amap reqdTyRange reqdTy - match baseTyOpt with - | None -> reqdTy - | Some baseTy -> baseTy - [ // Get any class hierarchy methods on this type - // - // NOTE: What we have below is an over-approximation that will get too many methods - // and not always correctly relate them to the slots they implement. For example, - // we may get an override from a base class and believe it implements a fresh, new abstract - // slot in a subclass. - for minfos in infoReader.GetRawIntrinsicMethodSetsOfType(None,AccessibleFromSomewhere,AllowMultiIntfInstantiations.Yes,reqdTyRange,reqdTy) do - for minfo in minfos do - if not minfo.IsAbstract then - yield GetInheritedMemberOverrideInfo g amap reqdTyRange CanImplementAnyClassHierarchySlot minfo ] - - // We also collect up the properties. This is used for abstract slot inference when overriding properties - let isRelevantRequiredProperty (x:PropInfo) = - (x.IsVirtualProperty && not (isInterfaceTy g reqdTy)) || - isImpliedInterfaceType x.EnclosingType - - let reqdProperties = - GetIntrinsicPropInfosOfType infoReader (None,AccessibleFromSomewhere,AllowMultiIntfInstantiations.Yes) IgnoreOverrides reqdTyRange reqdTy - |> List.filter isRelevantRequiredProperty - - let dispatchSlotsKeyed = dispatchSlots |> NameMultiMap.initBy (fun (RequiredSlot(v,_)) -> v.LogicalName) - yield SlotImplSet(dispatchSlots, dispatchSlotsKeyed, availPriorOverrides, reqdProperties) ] - - - /// Check that a type definition implements all its required interfaces after processing all declarations - /// within a file. - let CheckImplementationRelationAtEndOfInferenceScope (infoReader :InfoReader,denv,nenv,sink,tycon:Tycon,isImplementation) = - - let g = infoReader.g - let amap = infoReader.amap - - let tcaug = tycon.TypeContents - let interfaces = tycon.ImmediateInterfacesOfFSharpTycon |> List.map (fun (ity,_compgen,m) -> (ity,m)) - - let overallTy = generalizedTyconRef (mkLocalTyconRef tycon) - - let allReqdTys = (overallTy,tycon.Range) :: interfaces - - // Get all the members that are immediately part of this type - // Include the auto-generated members - let allImmediateMembers = tycon.MembersOfFSharpTyconSorted @ tycon.AllGeneratedValues - - // Get all the members we have to implement, organized by each type we explicitly implement - let slotImplSets = GetSlotImplSets infoReader denv false allReqdTys - - let allImpls = List.zip allReqdTys slotImplSets - - // Find the methods relevant to implementing the abstract slots listed under the reqdType being checked. - let allImmediateMembersThatMightImplementDispatchSlots = - allImmediateMembers |> List.filter (fun overrideBy -> - overrideBy.IsInstanceMember && // exclude static - overrideBy.IsVirtualMember && // exclude non virtual (e.g. keep override/default). [4469] - not overrideBy.IsDispatchSlotMember) - - let mustOverrideSomething reqdTy (overrideBy:ValRef) = - let memberInfo = overrideBy.MemberInfo.Value - not (overrideBy.IsFSharpEventProperty(g)) && - memberInfo.MemberFlags.IsOverrideOrExplicitImpl && - - match memberInfo.ImplementedSlotSigs with - | [] -> - // Are we looking at the implementation of the class hierarchy? If so include all the override members - not (isInterfaceTy g reqdTy) - | ss -> - ss |> List.forall (fun ss -> - let ty = ss.ImplementedType - if isInterfaceTy g ty then - // Is this a method impl listed under the reqdTy? - typeEquiv g ty reqdTy - else - not (isInterfaceTy g reqdTy) ) - - - // We check all the abstracts related to the class hierarchy and then check each interface implementation - for ((reqdTy,m),slotImplSet) in allImpls do - let (SlotImplSet(dispatchSlots, dispatchSlotsKeyed, availPriorOverrides,_)) = slotImplSet - try - - // Now extract the information about each overriding method relevant to this SlotImplSet - let allImmediateMembersThatMightImplementDispatchSlots = - allImmediateMembersThatMightImplementDispatchSlots - |> List.map (fun overrideBy -> overrideBy,GetTypeMemberOverrideInfo g reqdTy overrideBy) - - // Now check the implementation - // We don't give missing method errors for abstract classes - - if isImplementation && not (isInterfaceTy g overallTy) then - let overrides = allImmediateMembersThatMightImplementDispatchSlots |> List.map snd - let allCorrect = CheckDispatchSlotsAreImplemented (denv,g,amap,m,nenv,sink,tcaug.tcaug_abstract,reqdTy,dispatchSlots,availPriorOverrides,overrides) - - // Tell the user to mark the thing abstract if it was missing implementations - if not allCorrect && not tcaug.tcaug_abstract && not (isInterfaceTy g reqdTy) then - errorR(TypeIsImplicitlyAbstract(m)) - - let overridesToCheck = - allImmediateMembersThatMightImplementDispatchSlots - |> List.filter (fst >> mustOverrideSomething reqdTy) - |> List.map snd - - CheckOverridesAreAllUsedOnce (denv, g, amap, false, reqdTy, dispatchSlotsKeyed, availPriorOverrides, overridesToCheck) - - with e -> errorRecovery e m - - // Now record the full slotsigs of the abstract members implemented by each override. - // This is used to generate IL MethodImpls in the code generator. - allImmediateMembersThatMightImplementDispatchSlots |> List.iter (fun overrideBy -> - - let isFakeEventProperty = overrideBy.IsFSharpEventProperty(g) - let overriden = - if isFakeEventProperty then - let slotsigs = overrideBy.MemberInfo.Value.ImplementedSlotSigs - slotsigs |> List.map (ReparentSlotSigToUseMethodTypars g overrideBy.Range overrideBy) - else - [ for ((reqdTy,m),(SlotImplSet(_dispatchSlots,dispatchSlotsKeyed,_,_))) in allImpls do - let overrideByInfo = GetTypeMemberOverrideInfo g reqdTy overrideBy - let overridenForThisSlotImplSet = - [ for (RequiredSlot(dispatchSlot,_)) in NameMultiMap.find overrideByInfo.LogicalName dispatchSlotsKeyed do - if OverrideImplementsDispatchSlot g amap m dispatchSlot overrideByInfo then - if tyconRefEq g overrideByInfo.BoundingTyconRef (tcrefOfAppTy g dispatchSlot.EnclosingType) then - match dispatchSlot.ArbitraryValRef with - | Some virtMember -> - if virtMember.MemberInfo.Value.IsImplemented then errorR(Error(FSComp.SR.tcDefaultImplementationAlreadyExists(),overrideByInfo.Range)) - virtMember.MemberInfo.Value.IsImplemented <- true - | None -> () // not an F# slot - - // Get the slotsig of the overridden method - let slotsig = dispatchSlot.GetSlotSig(amap, m) - - // The slotsig from the overridden method is in terms of the type parameters on the parent type of the overriding method, - // Modify map the slotsig so it is in terms of the type parameters for the overriding method - let slotsig = ReparentSlotSigToUseMethodTypars g m overrideBy slotsig - - // Record the slotsig via mutation - yield slotsig ] - //if mustOverrideSomething reqdTy overrideBy then - // assert nonNil overridenForThisSlotImplSet - yield! overridenForThisSlotImplSet ] - - overrideBy.MemberInfo.Value.ImplementedSlotSigs <- overriden) - - -//------------------------------------------------------------------------- -// Sets of methods involved in overload resolution and trait constraint -// satisfaction. -//------------------------------------------------------------------------- - -/// In the following, 'T gets instantiated to: -/// 1. the expression being supplied for an argument -/// 2. "unit", when simply checking for the existence of an overload that satisfies -/// a signature, or when finding the corresponding witness. -/// Note the parametricity helps ensure that overload resolution doesn't depend on the -/// expression on the callside (though it is in some circumstances allowed -/// to depend on some type information inferred syntactically from that -/// expression, e.g. a lambda expression may be converted to a delegate as -/// an adhoc conversion. -/// -/// The bool indicates if named using a '?' -type CallerArg<'T> = - /// CallerArg(ty, range, isOpt, exprInfo) - | CallerArg of TType * range * bool * 'T - member x.Type = (let (CallerArg(ty,_,_,_)) = x in ty) - member x.Range = (let (CallerArg(_,m,_,_)) = x in m) - member x.IsOptional = (let (CallerArg(_,_,isOpt,_)) = x in isOpt) - member x.Expr = (let (CallerArg(_,_,_,expr)) = x in expr) - -/// Represents the information about an argument in the method being called -type CalledArg = - { Position: (int * int) - IsParamArray : bool - OptArgInfo : OptionalArgInfo - IsOutArg: bool - ReflArgInfo: ReflectedArgInfo - NameOpt: Ident option - CalledArgumentType : TType } - -let CalledArg(pos,isParamArray,optArgInfo,isOutArg,nameOpt,reflArgInfo,calledArgTy) = - { Position=pos - IsParamArray=isParamArray - OptArgInfo =optArgInfo - IsOutArg=isOutArg - ReflArgInfo=reflArgInfo - NameOpt=nameOpt - CalledArgumentType = calledArgTy } - -/// Represents a match between a caller argument and a called argument, arising from either -/// a named argument or an unnamed argument. -type AssignedCalledArg<'T> = - { /// The identifier for a named argument, if any - NamedArgIdOpt : Ident option - /// The called argument in the method - CalledArg: CalledArg - /// The argument on the caller side - CallerArg: CallerArg<'T> } - member x.Position = x.CalledArg.Position - -/// Represents the possibilities for a named-setter argument (a property, field , or a record field setter) -type AssignedItemSetterTarget = - | AssignedPropSetter of PropInfo * MethInfo * TypeInst (* the MethInfo is a non-indexer setter property *) - | AssignedILFieldSetter of ILFieldInfo - | AssignedRecdFieldSetter of RecdFieldInfo - -/// Represents the resolution of a caller argument as a named-setter argument -type AssignedItemSetter<'T> = AssignedItemSetter of Ident * AssignedItemSetterTarget * CallerArg<'T> - -type CallerNamedArg<'T> = - | CallerNamedArg of Ident * CallerArg<'T> - member x.Ident = (let (CallerNamedArg(id,_)) = x in id) - member x.Name = x.Ident.idText - member x.CallerArg = (let (CallerNamedArg(_,a)) = x in a) - -//------------------------------------------------------------------------- -// Callsite conversions -//------------------------------------------------------------------------- - -// F# supports three adhoc conversions at method callsites (note C# supports more, though ones -// such as implicit conversions interact badly with type inference). -// -// 1. The use of "(fun x y -> ...)" when a delegate it expected. This is not part of -// the ":>" coercion relationship or inference constraint problem as -// such, but is a special rule applied only to method arguments. -// -// The function AdjustCalledArgType detects this case based on types and needs to know that the type being applied -// is a function type. -// -// 2. The use of "(fun x y -> ...)" when Expression it expected. This is similar to above. -// -// 3. Two ways to pass a value where a byref is expected. The first (default) -// is to use a reference cell, and the interior address is taken automatically -// The second is an explicit use of the "address-of" operator "&e". Here we detect the second case, -// and record the presence of the sytnax "&e" in the pre-inferred actual type for the method argument. -// The function AdjustCalledArgType detects this and refuses to apply the default byref-to-ref transformation. -// -// The function AdjustCalledArgType also adjusts for optional arguments. -let AdjustCalledArgType (infoReader:InfoReader) isConstraint (calledArg: CalledArg) (callerArg: CallerArg<_>) = - let g = infoReader.g - // #424218 - when overload resolution is part of constraint solving - do not perform type-directed conversions - let calledArgTy = calledArg.CalledArgumentType - let callerArgTy = callerArg.Type - let m = callerArg.Range - if isConstraint then calledArgTy else - // If the called method argument is a byref type, then the caller may provide a byref or ref - if isByrefTy g calledArgTy then - if isByrefTy g callerArgTy then - calledArgTy - else - mkRefCellTy g (destByrefTy g calledArgTy) - else - // If the called method argument is a delegate type, then the caller may provide a function - let calledArgTy = - let adjustDelegateTy calledTy = - let (SigOfFunctionForDelegate(_,delArgTys,_,fty)) = GetSigOfFunctionForDelegate infoReader calledTy m AccessibleFromSomeFSharpCode - let delArgTys = (if isNil delArgTys then [g.unit_ty] else delArgTys) - if (fst (stripFunTy g callerArgTy)).Length = delArgTys.Length - then fty - else calledArgTy - - if isDelegateTy g calledArgTy && isFunTy g callerArgTy then - adjustDelegateTy calledArgTy - - elif isLinqExpressionTy g calledArgTy && isFunTy g callerArgTy then - let origArgTy = calledArgTy - let calledArgTy = destLinqExpressionTy g calledArgTy - if isDelegateTy g calledArgTy then - adjustDelegateTy calledArgTy - else - // BUG 435170: called arg is Expr<'t> where 't is not delegate - such conversion is not legal -> return original type - origArgTy - - elif calledArg.ReflArgInfo.AutoQuote && isQuotedExprTy g calledArgTy && not (isQuotedExprTy g callerArgTy) then - destQuotedExprTy g calledArgTy - - else calledArgTy - - // Adjust the called argument type to take into account whether the caller's argument is M(?arg=Some(3)) or M(arg=1) - // If the called method argument is optional with type Option, then the caller may provide a T, unless their argument is propogating-optional (i.e. isOptCallerArg) - let calledArgTy = - match calledArg.OptArgInfo with - | NotOptional -> calledArgTy - | CalleeSide when not callerArg.IsOptional && isOptionTy g calledArgTy -> destOptionTy g calledArgTy - | CalleeSide | CallerSide _ -> calledArgTy - calledArgTy - - -//------------------------------------------------------------------------- -// CalledMeth -//------------------------------------------------------------------------- - -type CalledMethArgSet<'T> = - { /// The called arguments corresponding to "unnamed" arguments - UnnamedCalledArgs : CalledArg list - /// Any unnamed caller arguments not otherwise assigned - UnnamedCallerArgs : CallerArg<'T> list - /// The called "ParamArray" argument, if any - ParamArrayCalledArgOpt : CalledArg option - /// Any unnamed caller arguments assigned to a "param array" argument - ParamArrayCallerArgs : CallerArg<'T> list - /// Named args - AssignedNamedArgs: AssignedCalledArg<'T> list } - member x.NumUnnamedCallerArgs = x.UnnamedCallerArgs.Length - member x.NumAssignedNamedArgs = x.AssignedNamedArgs.Length - member x.NumUnnamedCalledArgs = x.UnnamedCalledArgs.Length - - -let MakeCalledArgs amap m (minfo:MethInfo) minst = - // Mark up the arguments with their position, so we can sort them back into order later - let paramDatas = minfo.GetParamDatas(amap, m, minst) - paramDatas |> List.mapiSquared (fun i j (ParamData(isParamArrayArg,isOutArg,optArgInfo,nmOpt,reflArgInfo,typeOfCalledArg)) -> - { Position=(i,j) - IsParamArray=isParamArrayArg - OptArgInfo=optArgInfo - IsOutArg=isOutArg - ReflArgInfo=reflArgInfo - NameOpt=nmOpt - CalledArgumentType=typeOfCalledArg }) - -/// Represents the syntactic matching between a caller of a method and the called method. -/// -/// The constructor takes all the information about the caller and called side of a method, match up named arguments, property setters etc., -/// and returns a CalledMeth object for further analysis. -type CalledMeth<'T> - (infoReader:InfoReader, - nameEnv: NameResolutionEnv option, - isCheckingAttributeCall, - freshenMethInfo,// a function to help generate fresh type variables the property setters methods in generic classes - m, - ad, // the access domain of the place where the call is taking place - minfo:MethInfo, // the method we're attempting to call - calledTyArgs, // the 'called type arguments', i.e. the fresh generic instantiation of the method we're attempting to call - callerTyArgs: TType list, // the 'caller type arguments', i.e. user-given generic instantiation of the method we're attempting to call - pinfoOpt: PropInfo option, // the property related to the method we're attempting to call, if any - callerObjArgTys: TType list, // the types of the actual object argument, if any - curriedCallerArgs: (CallerArg<'T> list * CallerNamedArg<'T> list) list, // the data about any arguments supplied by the caller - allowParamArgs:bool, // do we allow the use of a param args method in its "expanded" form? - allowOutAndOptArgs: bool, // do we allow the use of the transformation that converts out arguments as tuple returns? - tyargsOpt : TType option) // method parameters - = - let g = infoReader.g - let methodRetTy = minfo.GetFSharpReturnTy(infoReader.amap, m, calledTyArgs) - - let fullCurriedCalledArgs = MakeCalledArgs infoReader.amap m minfo calledTyArgs - do assert (fullCurriedCalledArgs.Length = fullCurriedCalledArgs.Length) - - let argSetInfos = - (curriedCallerArgs, fullCurriedCalledArgs) ||> List.map2 (fun (unnamedCallerArgs,namedCallerArgs) fullCalledArgs -> - // Find the arguments not given by name - let unnamedCalledArgs = - fullCalledArgs |> List.filter (fun calledArg -> - match calledArg.NameOpt with - | Some nm -> namedCallerArgs |> List.forall (fun (CallerNamedArg(nm2,_e)) -> nm.idText <> nm2.idText) - | None -> true) - - // See if any of them are 'out' arguments being returned as part of a return tuple - let unnamedCalledArgs, unnamedCalledOptArgs, unnamedCalledOutArgs = - let nUnnamedCallerArgs = unnamedCallerArgs.Length - if allowOutAndOptArgs && nUnnamedCallerArgs < unnamedCalledArgs.Length then - let unnamedCalledArgsTrimmed,unnamedCalledOptOrOutArgs = List.chop nUnnamedCallerArgs unnamedCalledArgs - - // Check if all optional/out arguments are byref-out args - if unnamedCalledOptOrOutArgs |> List.forall (fun x -> x.IsOutArg && isByrefTy g x.CalledArgumentType) then - unnamedCalledArgsTrimmed,[],unnamedCalledOptOrOutArgs - // Check if all optional/out arguments are optional args - elif unnamedCalledOptOrOutArgs |> List.forall (fun x -> x.OptArgInfo.IsOptional) then - unnamedCalledArgsTrimmed,unnamedCalledOptOrOutArgs,[] - // Otherwise drop them on the floor - else - unnamedCalledArgs,[],[] - else - unnamedCalledArgs,[],[] - - let (unnamedCallerArgs,paramArrayCallerArgs),unnamedCalledArgs,paramArrayCalledArgOpt = - let minArgs = unnamedCalledArgs.Length - 1 - let supportsParamArgs = - allowParamArgs && - minArgs >= 0 && - unnamedCalledArgs |> List.last |> (fun calledArg -> calledArg.IsParamArray && isArray1DTy g calledArg.CalledArgumentType) - - if supportsParamArgs && unnamedCallerArgs.Length >= minArgs then - let a,b = List.frontAndBack unnamedCalledArgs - List.chop minArgs unnamedCallerArgs, a, Some(b) - else - (unnamedCallerArgs, []),unnamedCalledArgs, None - - let assignedNamedArgs = - fullCalledArgs |> List.choose (fun calledArg -> - match calledArg.NameOpt with - | Some nm -> - namedCallerArgs |> List.tryPick (fun (CallerNamedArg(nm2,callerArg)) -> - if nm.idText = nm2.idText then Some { NamedArgIdOpt = Some nm2; CallerArg=callerArg; CalledArg=calledArg } - else None) - | _ -> None) - - let unassignedNamedItem = - namedCallerArgs |> List.filter (fun (CallerNamedArg(nm,_e)) -> - fullCalledArgs |> List.forall (fun calledArg -> - match calledArg.NameOpt with - | Some nm2 -> nm.idText <> nm2.idText - | None -> true)) - - let attributeAssignedNamedItems,unassignedNamedItem = - if isCheckingAttributeCall then - // the assignment of names to properties is substantially for attribute specifications - // permits bindings of names to non-mutable fields and properties, so we do that using the old - // reliable code for this later on. - unassignedNamedItem,[] - else - [],unassignedNamedItem - - let assignedNamedProps,unassignedNamedItem = - let returnedObjTy = if minfo.IsConstructor then minfo.EnclosingType else methodRetTy - unassignedNamedItem |> List.splitChoose (fun (CallerNamedArg(id,e) as arg) -> - let nm = id.idText - let pinfos = GetIntrinsicPropInfoSetsOfType infoReader (Some(nm),ad,AllowMultiIntfInstantiations.Yes) IgnoreOverrides id.idRange returnedObjTy - let pinfos = pinfos |> ExcludeHiddenOfPropInfos g infoReader.amap m - match pinfos with - | [pinfo] when pinfo.HasSetter && not pinfo.IsIndexer -> - let pminfo = pinfo.SetterMethod - let pminst = freshenMethInfo m pminfo - Choice1Of2(AssignedItemSetter(id,AssignedPropSetter(pinfo,pminfo, pminst), e)) - | _ -> - let epinfos = - match nameEnv with - | Some(ne) -> ExtensionPropInfosOfTypeInScope infoReader ne (Some(nm), ad) m returnedObjTy - | _ -> [] - match epinfos with - | [pinfo] when pinfo.HasSetter && not pinfo.IsIndexer -> - let pminfo = pinfo.SetterMethod - let pminst = match minfo with - | MethInfo.FSMeth(_,TType.TType_app(_,types),_,_) -> types - | _ -> freshenMethInfo m pminfo - - let pminst = match tyargsOpt with - | Some(TType.TType_app(_, types)) -> types - | _ -> pminst - Choice1Of2(AssignedItemSetter(id,AssignedPropSetter(pinfo,pminfo, pminst), e)) - | _ -> - match infoReader.GetILFieldInfosOfType(Some(nm),ad,m,returnedObjTy) with - | finfo :: _ -> - Choice1Of2(AssignedItemSetter(id,AssignedILFieldSetter(finfo), e)) - | _ -> - match infoReader.TryFindRecdOrClassFieldInfoOfType(nm,m,returnedObjTy) with - | Some rfinfo -> - Choice1Of2(AssignedItemSetter(id,AssignedRecdFieldSetter(rfinfo), e)) - | None -> - Choice2Of2(arg)) - - let names = namedCallerArgs |> List.map (fun (CallerNamedArg(nm,_)) -> nm.idText) - - if (List.noRepeats String.order names).Length <> namedCallerArgs.Length then - errorR(Error(FSComp.SR.typrelNamedArgumentHasBeenAssignedMoreThenOnce(),m)) - - let argSet = { UnnamedCalledArgs=unnamedCalledArgs; UnnamedCallerArgs=unnamedCallerArgs; ParamArrayCalledArgOpt=paramArrayCalledArgOpt; ParamArrayCallerArgs=paramArrayCallerArgs; AssignedNamedArgs=assignedNamedArgs } - - (argSet,assignedNamedProps,unassignedNamedItem,attributeAssignedNamedItems,unnamedCalledOptArgs,unnamedCalledOutArgs)) - - let argSets = argSetInfos |> List.map (fun (x,_,_,_,_,_) -> x) - let assignedNamedProps = argSetInfos |> List.collect (fun (_,x,_,_,_,_) -> x) - let unassignedNamedItems = argSetInfos |> List.collect (fun (_,_,x,_,_,_) -> x) - let attributeAssignedNamedItems = argSetInfos |> List.collect (fun (_,_,_,x,_,_) -> x) - let unnamedCalledOptArgs = argSetInfos |> List.collect (fun (_,_,_,_,x,_) -> x) - let unnamedCalledOutArgs = argSetInfos |> List.collect (fun (_,_,_,_,_,x) -> x) - - member x.infoReader = infoReader - member x.amap = infoReader.amap - - /// the method we're attempting to call - member x.Method=minfo - /// the instantiation of the method we're attempting to call - member x.CalledTyArgs=calledTyArgs - /// the formal instantiation of the method we're attempting to call - member x.CallerTyArgs=callerTyArgs - /// The types of the actual object arguments, if any - member x.CallerObjArgTys=callerObjArgTys - /// The argument analysis for each set of curried arguments - member x.ArgSets=argSets - /// return type - member x.ReturnType=methodRetTy - /// named setters - member x.AssignedItemSetters=assignedNamedProps - /// the property related to the method we're attempting to call, if any - member x.AssociatedPropertyInfo=pinfoOpt - /// unassigned args - member x.UnassignedNamedArgs=unassignedNamedItems - /// args assigned to specify values for attribute fields and properties (these are not necessarily "property sets") - member x.AttributeAssignedNamedArgs=attributeAssignedNamedItems - /// unnamed called optional args: pass defaults for these - member x.UnnamedCalledOptArgs=unnamedCalledOptArgs - /// unnamed called out args: return these as part of the return tuple - member x.UnnamedCalledOutArgs=unnamedCalledOutArgs - - static member GetMethod (x:CalledMeth<'T>) = x.Method - - member x.NumArgSets = x.ArgSets.Length - - member x.HasOptArgs = nonNil x.UnnamedCalledOptArgs - member x.HasOutArgs = nonNil x.UnnamedCalledOutArgs - member x.UsesParamArrayConversion = x.ArgSets |> List.exists (fun argSet -> argSet.ParamArrayCalledArgOpt.IsSome) - member x.ParamArrayCalledArgOpt = x.ArgSets |> List.tryPick (fun argSet -> argSet.ParamArrayCalledArgOpt) - member x.ParamArrayCallerArgs = x.ArgSets |> List.tryPick (fun argSet -> if isSome argSet.ParamArrayCalledArgOpt then Some argSet.ParamArrayCallerArgs else None ) - member x.ParamArrayElementType = - assert (x.UsesParamArrayConversion) - x.ParamArrayCalledArgOpt.Value.CalledArgumentType |> destArrayTy x.amap.g - member x.NumAssignedProps = x.AssignedItemSetters.Length - member x.CalledObjArgTys(m) = x.Method.GetObjArgTypes(x.amap, m, x.CalledTyArgs) - member x.NumCalledTyArgs = x.CalledTyArgs.Length - member x.NumCallerTyArgs = x.CallerTyArgs.Length - - member x.AssignsAllNamedArgs = isNil x.UnassignedNamedArgs - - member x.HasCorrectArity = - (x.NumCalledTyArgs = x.NumCallerTyArgs) && - x.ArgSets |> List.forall (fun argSet -> argSet.NumUnnamedCalledArgs = argSet.NumUnnamedCallerArgs) - - member x.HasCorrectGenericArity = - (x.NumCalledTyArgs = x.NumCallerTyArgs) - - member x.IsAccessible(m,ad) = - IsMethInfoAccessible x.amap m ad x.Method - - member x.HasCorrectObjArgs(m) = - x.CalledObjArgTys(m).Length = x.CallerObjArgTys.Length - - member x.IsCandidate(m,ad) = - x.IsAccessible(m,ad) && - x.HasCorrectArity && - x.HasCorrectObjArgs(m) && - x.AssignsAllNamedArgs - - member x.AssignedUnnamedArgs = - // We use Seq.map2 to tolerate there being mismatched caller/called args - x.ArgSets |> List.map (fun argSet -> - (argSet.UnnamedCalledArgs, argSet.UnnamedCallerArgs) ||> Seq.map2 (fun calledArg callerArg -> - { NamedArgIdOpt=None; CalledArg=calledArg; CallerArg=callerArg }) |> Seq.toList) - - member x.AssignedNamedArgs = - x.ArgSets |> List.map (fun argSet -> argSet.AssignedNamedArgs) - - member x.AllUnnamedCalledArgs = x.ArgSets |> List.collect (fun x -> x.UnnamedCalledArgs) - member x.TotalNumUnnamedCalledArgs = x.ArgSets |> List.sumBy (fun x -> x.NumUnnamedCalledArgs) - member x.TotalNumUnnamedCallerArgs = x.ArgSets |> List.sumBy (fun x -> x.NumUnnamedCallerArgs) - member x.TotalNumAssignedNamedArgs = x.ArgSets |> List.sumBy (fun x -> x.NumAssignedNamedArgs) - -let NamesOfCalledArgs (calledArgs: CalledArg list) = - calledArgs |> List.choose (fun x -> x.NameOpt) - -//------------------------------------------------------------------------- -// Helpers dealing with propagating type information in method overload resolution -//------------------------------------------------------------------------- - -type ArgumentAnalysis = - | NoInfo - | ArgDoesNotMatch - | CallerLambdaHasArgTypes of TType list - | CalledArgMatchesType of TType - -let InferLambdaArgsForLambdaPropagation origRhsExpr = - let rec loop e = - match e with - | SynExpr.Lambda(_,_,_,rest,_) -> 1 + loop rest - | SynExpr.MatchLambda _ -> 1 - | _ -> 0 - loop origRhsExpr - -let ExamineArgumentForLambdaPropagation (infoReader:InfoReader) (arg: AssignedCalledArg) = - let g = infoReader.g - // Find the explicit lambda arguments of the caller. Ignore parentheses. - let argExpr = match arg.CallerArg.Expr with SynExpr.Paren(x,_,_,_) -> x | x -> x - let countOfCallerLambdaArg = InferLambdaArgsForLambdaPropagation argExpr - // Adjust for Expression<_>, Func<_,_>, ... - let adjustedCalledArgTy = AdjustCalledArgType infoReader false arg.CalledArg arg.CallerArg - if countOfCallerLambdaArg > 0 then - // Decompose the explicit function type of the target - let calledLambdaArgTys,_calledLambdaRetTy = Tastops.stripFunTy g adjustedCalledArgTy - if calledLambdaArgTys.Length >= countOfCallerLambdaArg then - // success - CallerLambdaHasArgTypes calledLambdaArgTys - elif isDelegateTy g (if isLinqExpressionTy g adjustedCalledArgTy then destLinqExpressionTy g adjustedCalledArgTy else adjustedCalledArgTy) then - ArgDoesNotMatch // delegate arity mismatch - else - NoInfo // not a function type on the called side - no information - else CalledArgMatchesType(adjustedCalledArgTy) // not a lambda on the caller side - push information from caller to called - -let ExamineMethodForLambdaPropagation(x:CalledMeth) = - let unnamedInfo = x.AssignedUnnamedArgs |> List.mapSquared (ExamineArgumentForLambdaPropagation x.infoReader) - let namedInfo = x.AssignedNamedArgs |> List.mapSquared (fun arg -> (arg.NamedArgIdOpt.Value, ExamineArgumentForLambdaPropagation x.infoReader arg)) - if unnamedInfo |> List.existsSquared (function CallerLambdaHasArgTypes _ -> true | _ -> false) || - namedInfo |> List.existsSquared (function (_,CallerLambdaHasArgTypes _) -> true | _ -> false) then - Some (unnamedInfo, namedInfo) - else - None - - - -//------------------------------------------------------------------------- -// "Type Completion" inference and a few other checks at the end of the inference scope -//------------------------------------------------------------------------- - - -/// "Type Completion" inference and a few other checks at the end of the inference scope -let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader:InfoReader, nenv, sink, isImplementation, denv) (tycon:Tycon) = - - let g = infoReader.g - let amap = infoReader.amap - - let tcaug = tycon.TypeContents - tcaug.tcaug_closed <- true - - // Note you only have to explicitly implement 'System.IComparable' to customize structural comparison AND equality on F# types - if isImplementation && -#if EXTENSIONTYPING - not tycon.IsProvidedGeneratedTycon && -#endif - isNone tycon.GeneratedCompareToValues && - tycon.HasInterface g g.mk_IComparable_ty && - not (tycon.HasOverride g "Equals" [g.obj_ty]) && - not tycon.IsFSharpInterfaceTycon - then - (* Warn when we're doing this for class types *) - if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then - warning(Error(FSComp.SR.typrelTypeImplementsIComparableShouldOverrideObjectEquals(tycon.DisplayName),tycon.Range)) - else - warning(Error(FSComp.SR.typrelTypeImplementsIComparableDefaultObjectEqualsProvided(tycon.DisplayName),tycon.Range)) - - AugmentWithHashCompare.CheckAugmentationAttribs isImplementation g amap tycon - // Check some conditions about generic comparison and hashing. We can only check this condition after we've done the augmentation - if isImplementation -#if EXTENSIONTYPING - && not tycon.IsProvidedGeneratedTycon -#endif - then - let tcaug = tycon.TypeContents - let m = tycon.Range - let hasExplicitObjectGetHashCode = tycon.HasOverride g "GetHashCode" [] - let hasExplicitObjectEqualsOverride = tycon.HasOverride g "Equals" [g.obj_ty] - - if (isSome tycon.GeneratedHashAndEqualsWithComparerValues) && - (hasExplicitObjectGetHashCode || hasExplicitObjectEqualsOverride) then - errorR(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCodeOrEquals(tycon.DisplayName),m)) - - if not hasExplicitObjectEqualsOverride && hasExplicitObjectGetHashCode then - warning(Error(FSComp.SR.typrelExplicitImplementationOfGetHashCode(tycon.DisplayName),m)) - - if hasExplicitObjectEqualsOverride && not hasExplicitObjectGetHashCode then - warning(Error(FSComp.SR.typrelExplicitImplementationOfEquals(tycon.DisplayName),m)) - - - // remember these values to ensure we don't generate these methods during codegen - tcaug.SetHasObjectGetHashCode hasExplicitObjectGetHashCode - - if not tycon.IsHiddenReprTycon - && not tycon.IsTypeAbbrev - && not tycon.IsMeasureableReprTycon - && not tycon.IsAsmReprTycon - && not tycon.IsFSharpInterfaceTycon - && not tycon.IsFSharpDelegateTycon then - - DispatchSlotChecking.CheckImplementationRelationAtEndOfInferenceScope (infoReader,denv,nenv,sink,tycon,isImplementation) - -//------------------------------------------------------------------------- -// Additional helpers for type checking and constraint solving -//------------------------------------------------------------------------- - /// "Single Feasible Type" inference /// Look for the unique supertype of ty2 for which ty2 :> ty1 might feasibly hold let FindUniqueFeasibleSupertype g amap m ty1 ty2 = @@ -2016,661 +295,3 @@ let FindUniqueFeasibleSupertype g amap m ty1 ty2 = supertypes |> List.tryFind (TypeFeasiblySubsumesType 0 g amap m ty1 NoCoerce) - -/// Get the methods relevant to determining if a uniquely-identified-override exists based on the syntactic information -/// at the member signature prior to type inference. This is used to pre-assign type information if it does -let GetAbstractMethInfosForSynMethodDecl(infoReader:InfoReader,ad,memberName:Ident,bindm,typToSearchForAbstractMembers,valSynData) = - let minfos = - match typToSearchForAbstractMembers with - | _,Some(SlotImplSet(_, dispatchSlotsKeyed,_,_)) -> - NameMultiMap.find memberName.idText dispatchSlotsKeyed |> List.map (fun (RequiredSlot(dispatchSlot,_)) -> dispatchSlot) - | ty, None -> - GetIntrinsicMethInfosOfType infoReader (Some(memberName.idText), ad, AllowMultiIntfInstantiations.Yes) IgnoreOverrides bindm ty - let dispatchSlots = minfos |> List.filter (fun minfo -> minfo.IsDispatchSlot) - let topValSynArities = SynInfo.AritiesOfArgs valSynData - let topValSynArities = if topValSynArities.Length > 0 then topValSynArities.Tail else topValSynArities - let dispatchSlotsArityMatch = dispatchSlots |> List.filter (fun minfo -> minfo.NumArgs = topValSynArities) - dispatchSlots,dispatchSlotsArityMatch - -/// Get the properties relevant to determining if a uniquely-identified-override exists based on the syntactic information -/// at the member signature prior to type inference. This is used to pre-assign type information if it does -let GetAbstractPropInfosForSynPropertyDecl(infoReader:InfoReader,ad,memberName:Ident,bindm,typToSearchForAbstractMembers,_k,_valSynData) = - let pinfos = - match typToSearchForAbstractMembers with - | _,Some(SlotImplSet(_,_,_,reqdProps)) -> - reqdProps |> List.filter (fun pinfo -> pinfo.PropertyName = memberName.idText) - | ty, None -> - GetIntrinsicPropInfosOfType infoReader (Some(memberName.idText), ad, AllowMultiIntfInstantiations.Yes) IgnoreOverrides bindm ty - - let dispatchSlots = pinfos |> List.filter (fun pinfo -> pinfo.IsVirtualProperty) - dispatchSlots - -//------------------------------------------------------------------------- -// Additional helpers for building method calls and doing TAST generation -//------------------------------------------------------------------------- - -/// Is this a 'base' call (in the sense of C#) -let IsBaseCall objArgs = - match objArgs with - | [Expr.Val(v,_,_)] when v.BaseOrThisInfo = BaseVal -> true - | _ -> false - -/// Compute whether we insert a 'coerce' on the 'this' pointer for an object model call -/// For example, when calling an interface method on a struct, or a method on a constrained -/// variable type. -let ComputeConstrainedCallInfo g amap m (objArgs,minfo:MethInfo) = - match objArgs with - | [objArgExpr] when not minfo.IsExtensionMember -> - let methObjTy = minfo.EnclosingType - let objArgTy = tyOfExpr g objArgExpr - if TypeDefinitelySubsumesTypeNoCoercion 0 g amap m methObjTy objArgTy - // Constrained calls to class types can only ever be needed for the three class types that - // are base types of value types - || (isClassTy g methObjTy && - (not (typeEquiv g methObjTy g.system_Object_typ || - typeEquiv g methObjTy g.system_Value_typ || - typeEquiv g methObjTy g.system_Enum_typ))) then - None - else - // The object argument is a value type or variable type and the target method is an interface or System.Object - // type. A .NET 2.0 generic constrained call is required - Some objArgTy - | _ -> - None - - -/// Adjust the 'this' pointer before making a call -/// Take the address of a struct, and coerce to an interface/base/constraint type if necessary -let TakeObjAddrForMethodCall g amap (minfo:MethInfo) isMutable m objArgs f = - let ccallInfo = ComputeConstrainedCallInfo g amap m (objArgs,minfo) - let mustTakeAddress = - (minfo.IsStruct && not minfo.IsExtensionMember) // don't take the address of a struct when passing to an extension member - || - (match ccallInfo with - | Some _ -> true - | None -> false) - let wrap,objArgs = - match objArgs with - | [objArgExpr] -> - let objArgTy = tyOfExpr g objArgExpr - let wrap,objArgExpr' = mkExprAddrOfExpr g mustTakeAddress (isSome ccallInfo) isMutable objArgExpr None m - - // Extension members and calls to class constraints may need a coercion for their object argument - let objArgExpr' = - if isNone ccallInfo && // minfo.IsExtensionMember && minfo.IsStruct && - not (TypeDefinitelySubsumesTypeNoCoercion 0 g amap m minfo.EnclosingType objArgTy) then - mkCoerceExpr(objArgExpr',minfo.EnclosingType,m,objArgTy) - else - objArgExpr' - - wrap,[objArgExpr'] - - | _ -> - (fun x -> x), objArgs - let e,ety = f ccallInfo objArgs - wrap e,ety - -//------------------------------------------------------------------------- -// Build method calls. -//------------------------------------------------------------------------- - -#if EXTENSIONTYPING -// This imports a provided method, and checks if it is a known compiler intrinsic like "1 + 2" -let TryImportProvidedMethodBaseAsLibraryIntrinsic (amap:Import.ImportMap, m:range, mbase: Tainted) = - let methodName = mbase.PUntaint((fun x -> x.Name),m) - let declaringType = Import.ImportProvidedType amap m (mbase.PApply((fun x -> x.DeclaringType),m)) - if isAppTy amap.g declaringType then - let declaringEntity = tcrefOfAppTy amap.g declaringType - if not declaringEntity.IsLocalRef && ccuEq declaringEntity.nlr.Ccu amap.g.fslibCcu then - match amap.g.knownIntrinsics.TryGetValue ((declaringEntity.LogicalName, methodName)) with - | true,vref -> Some vref - | _ -> - match amap.g.knownFSharpCoreModules.TryGetValue(declaringEntity.LogicalName) with - | true,modRef -> - match modRef.ModuleOrNamespaceType.AllValsByLogicalName |> Seq.tryPick (fun (KeyValue(_,v)) -> if v.CompiledName = methodName then Some v else None) with - | Some v -> Some (mkNestedValRef modRef v) - | None -> None - | _ -> None - else - None - else - None -#endif - - -/// Build an expression that calls a given method info. -/// This is called after overload resolution, and also to call other -/// methods such as 'setters' for properties. -// tcVal: used to convert an F# value into an expression. See tc.fs. -// isProp: is it a property get? -// minst: the instantiation to apply for a generic method -// objArgs: the 'this' argument, if any -// args: the arguments, if any -let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objArgs args = - - let direct = IsBaseCall objArgs - - TakeObjAddrForMethodCall g amap minfo isMutable m objArgs (fun ccallInfo objArgs -> - let allArgs = (objArgs @ args) - let valUseFlags = - if (direct && (match valUseFlags with NormalValUse -> true | _ -> false)) then - VSlotDirectCall - else - match ccallInfo with - | Some ty -> - // printfn "possible constrained call to '%s' at %A" minfo.LogicalName m - PossibleConstrainedCall ty - | None -> - valUseFlags - - match minfo with -#if EXTENSIONTYPING - // By this time this is an erased method info, e.g. one returned from an expression - // REVIEW: copied from tastops, which doesn't allow protected methods - | ProvidedMeth (amap,providedMeth,_,_) -> - // TODO: there is a fair bit of duplication here with mk_il_minfo_call. We should be able to merge these - - /// Build an expression node that is a call to a extension method in a generated assembly - let enclTy = minfo.EnclosingType - // prohibit calls to methods that are declared in specific array types (Get,Set,Address) - // these calls are provided by the runtime and should not be called from the user code - if isArrayTy g enclTy then - let tpe = TypeProviderError(FSComp.SR.tcRuntimeSuppliedMethodCannotBeUsedInUserCode(minfo.DisplayName), providedMeth.TypeProviderDesignation, m) - error (tpe) - let valu = isStructTy g enclTy - let isCtor = minfo.IsConstructor - if minfo.IsClassConstructor then - error (InternalError (minfo.LogicalName ^": cannot call a class constructor",m)) - let useCallvirt = not valu && not direct && minfo.IsVirtual - let isProtected = minfo.IsProtectedAccessiblity - let exprTy = if isCtor then enclTy else minfo.GetFSharpReturnTy(amap, m, minst) - match TryImportProvidedMethodBaseAsLibraryIntrinsic (amap, m, providedMeth) with - | Some fsValRef -> - //reraise() calls are converted to TOp.Reraise in the type checker. So if a provided expression includes a reraise call - // we must put it in that form here. - if valRefEq amap.g fsValRef amap.g.reraise_vref then - mkReraise m exprTy, exprTy - else - let vexp, vexpty = tcVal fsValRef valUseFlags (minfo.DeclaringTypeInst @ minst) m - BuildFSharpMethodApp g m fsValRef vexp vexpty allArgs - | None -> - let ilMethRef = Import.ImportProvidedMethodBaseAsILMethodRef amap m providedMeth - let isNewObj = isCtor && (match valUseFlags with NormalValUse -> true | _ -> false) - let actualTypeInst = - if isTupleTy g enclTy then argsOfAppTy g (mkCompiledTupleTy g (destTupleTy g enclTy)) // provided expressions can include method calls that get properties of tuple types - elif isFunTy g enclTy then [ domainOfFunTy g enclTy; rangeOfFunTy g enclTy ] // provided expressions can call Invoke - else minfo.DeclaringTypeInst - let actualMethInst = minst - let retTy = (if not isCtor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprTy]) - let noTailCall = false - let expr = Expr.Op(TOp.ILCall(useCallvirt,isProtected,valu,isNewObj,valUseFlags,isProp,noTailCall,ilMethRef,actualTypeInst,actualMethInst, retTy),[],allArgs,m) - expr,exprTy - -#endif - - // Build a call to a .NET method - | ILMeth(_,ilMethInfo,_) -> - BuildILMethInfoCall g amap m isProp ilMethInfo valUseFlags minst direct allArgs - - // Build a call to an F# method - | FSMeth(_, _, vref, _) -> - - // Go see if this is a use of a recursive definition... Note we know the value instantiation - // we want to use so we pass that in order not to create a new one. - let vexp, vexpty = tcVal vref valUseFlags (minfo.DeclaringTypeInst @ minst) m - BuildFSharpMethodApp g m vref vexp vexpty allArgs - - // Build a 'call' to a struct default constructor - | DefaultStructCtor (g,typ) -> - if not (TypeHasDefaultValue g m typ) then - errorR(Error(FSComp.SR.tcDefaultStructConstructorCall(),m)) - mkDefault (m,typ), typ) - -//------------------------------------------------------------------------- -// Build delegate constructions (lambdas/functions to delegates) -//------------------------------------------------------------------------- - -/// Implements the elaborated form of adhoc conversions from functions to delegates at member callsites -let BuildNewDelegateExpr (eventInfoOpt:EventInfo option, g, amap, delegateTy, invokeMethInfo:MethInfo, delArgTys, f, fty, m) = - let slotsig = invokeMethInfo.GetSlotSig(amap, m) - let delArgVals,expr = - let topValInfo = ValReprInfo([],List.replicate (List.length delArgTys) ValReprInfo.unnamedTopArg, ValReprInfo.unnamedRetVal) - - // Try to pull apart an explicit lambda and use it directly - // Don't do this in the case where we're adjusting the arguments of a function used to build a .NET-compatible event handler - let lambdaContents = - if isSome eventInfoOpt then - None - else - tryDestTopLambda g amap topValInfo (f, fty) - match lambdaContents with - | None -> - - if List.exists (isByrefTy g) delArgTys then - error(Error(FSComp.SR.tcFunctionRequiresExplicitLambda(List.length delArgTys),m)) - - let delArgVals = delArgTys |> List.mapi (fun i argty -> fst (mkCompGenLocal m ("delegateArg"^string i) argty)) - let expr = - let args = - match eventInfoOpt with - | Some einfo -> - match delArgVals with - | [] -> error(nonStandardEventError einfo.EventName m) - | h :: _ when not (isObjTy g h.Type) -> error(nonStandardEventError einfo.EventName m) - | h :: t -> [exprForVal m h; mkTupledVars g m t] - | None -> - if isNil delArgTys then [mkUnit g m] else List.map (exprForVal m) delArgVals - mkApps g ((f,fty),[],args,m) - delArgVals,expr - - | Some _ -> - if isNil delArgTys then [], mkApps g ((f,fty),[],[mkUnit g m],m) - else - let _,_,_,vsl,body,_ = IteratedAdjustArityOfLambda g amap topValInfo f - List.concat vsl, body - - let meth = TObjExprMethod(slotsig, [], [], [delArgVals], expr, m) - mkObjExpr(delegateTy,None,BuildObjCtorCall g m,[meth],[],m) - -let CoerceFromFSharpFuncToDelegate g amap infoReader ad callerArgTy m callerArgExpr delegateTy = - let (SigOfFunctionForDelegate(invokeMethInfo,delArgTys,_,_)) = GetSigOfFunctionForDelegate infoReader delegateTy m ad - BuildNewDelegateExpr (None, g, amap, delegateTy, invokeMethInfo, delArgTys, callerArgExpr, callerArgTy, m) - - -//------------------------------------------------------------------------- -// Import provided expressions -//------------------------------------------------------------------------- - - -#if EXTENSIONTYPING -// This file is not a great place for this functionality to sit, it's here because of BuildMethodCall -module ProvidedMethodCalls = - - let private convertConstExpr g amap m (constant : Tainted) = - let (obj,objTy) = constant.PApply2(id,m) - let ty = Import.ImportProvidedType amap m objTy - let normTy = normalizeEnumTy g ty - obj.PUntaint((fun v -> - let fail() = raise <| TypeProviderError(FSComp.SR.etUnsupportedConstantType(v.GetType().ToString()), constant.TypeProviderDesignation, m) - try - match v with - | null -> mkNull m ty - | _ when typeEquiv g normTy g.bool_ty -> Expr.Const(Const.Bool(v :?> bool), m, ty) - | _ when typeEquiv g normTy g.sbyte_ty -> Expr.Const(Const.SByte(v :?> sbyte), m, ty) - | _ when typeEquiv g normTy g.byte_ty -> Expr.Const(Const.Byte(v :?> byte), m, ty) - | _ when typeEquiv g normTy g.int16_ty -> Expr.Const(Const.Int16(v :?> int16), m, ty) - | _ when typeEquiv g normTy g.uint16_ty -> Expr.Const(Const.UInt16(v :?> uint16), m, ty) - | _ when typeEquiv g normTy g.int32_ty -> Expr.Const(Const.Int32(v :?> int32), m, ty) - | _ when typeEquiv g normTy g.uint32_ty -> Expr.Const(Const.UInt32(v :?> uint32), m, ty) - | _ when typeEquiv g normTy g.int64_ty -> Expr.Const(Const.Int64(v :?> int64), m, ty) - | _ when typeEquiv g normTy g.uint64_ty -> Expr.Const(Const.UInt64(v :?> uint64), m, ty) - | _ when typeEquiv g normTy g.nativeint_ty -> Expr.Const(Const.IntPtr(v :?> int64), m, ty) - | _ when typeEquiv g normTy g.unativeint_ty -> Expr.Const(Const.UIntPtr(v :?> uint64), m, ty) - | _ when typeEquiv g normTy g.float32_ty -> Expr.Const(Const.Single(v :?> float32), m, ty) - | _ when typeEquiv g normTy g.float_ty -> Expr.Const(Const.Double(v :?> float), m, ty) - | _ when typeEquiv g normTy g.char_ty -> Expr.Const(Const.Char(v :?> char), m, ty) - | _ when typeEquiv g normTy g.string_ty -> Expr.Const(Const.String(v :?> string), m, ty) - | _ when typeEquiv g normTy g.decimal_ty -> Expr.Const(Const.Decimal(v :?> decimal), m, ty) - | _ when typeEquiv g normTy g.unit_ty -> Expr.Const(Const.Unit, m, ty) - | _ -> fail() - with _ -> - fail() - ), range=m) - - /// Erasure over System.Type. - /// - /// This is a reimplementation of the logic of provided-type erasure, working entirely over (tainted, provided) System.Type - /// values. This is used when preparing ParameterInfo objects to give to the provider in GetInvokerExpression. - /// These ParameterInfo have erased ParameterType - giving the provider an erased type makes it considerably easier - /// to implement a correct GetInvokerExpression. - /// - /// Ideally we would implement this operation by converting to an F# TType using ImportSystemType, and then erasing, and then converting - /// back to System.Type. However, there is currently no way to get from an arbitrary F# TType (even the TType for - /// System.Object) to a System.Type to give to the type provider. - let eraseSystemType (amap,m,inputType) = - let rec loop (st:Tainted) = - if st.PUntaint((fun st -> st.IsGenericParameter),m) then st - elif st.PUntaint((fun st -> st.IsArray),m) then - let et = st.PApply((fun st -> st.GetElementType()),m) - let rank = st.PUntaint((fun st -> st.GetArrayRank()),m) - (loop et).PApply((fun st -> ProvidedType.CreateNoContext(if rank = 1 then st.RawSystemType.MakeArrayType() else st.RawSystemType.MakeArrayType(rank))),m) - elif st.PUntaint((fun st -> st.IsByRef),m) then - let et = st.PApply((fun st -> st.GetElementType()),m) - (loop et).PApply((fun st -> ProvidedType.CreateNoContext(st.RawSystemType.MakeByRefType())),m) - elif st.PUntaint((fun st -> st.IsPointer),m) then - let et = st.PApply((fun st -> st.GetElementType()),m) - (loop et).PApply((fun st -> ProvidedType.CreateNoContext(st.RawSystemType.MakePointerType())),m) - else - let isGeneric = st.PUntaint((fun st -> st.IsGenericType),m) - let headType = if isGeneric then st.PApply((fun st -> st.GetGenericTypeDefinition()),m) else st - // We import in order to use IsProvidedErasedTycon, to make sure we at least don't reinvent that - let headTypeAsFSharpType = Import.ImportProvidedNamedType amap m headType - if headTypeAsFSharpType.IsProvidedErasedTycon then - let baseType = - st.PApply((fun st -> - match st.BaseType with - | null -> ProvidedType.CreateNoContext(typeof) // it might be an interface - | st -> st),m) - loop baseType - else - if isGeneric then - let genericArgs = st.PApplyArray((fun st -> st.GetGenericArguments()),"GetGenericArguments",m) - let typars = headTypeAsFSharpType.Typars(m) - // Drop the generic arguments that don't correspond to type arguments, i.e. are units-of-measure - let genericArgs = - [| for (genericArg,tp) in Seq.zip genericArgs typars do - if tp.Kind = TyparKind.Type then - yield genericArg |] - - if genericArgs.Length = 0 then - headType - else - let erasedArgTys = genericArgs |> Array.map loop - headType.PApply((fun st -> - let erasedArgTys = erasedArgTys |> Array.map (fun a -> a.PUntaintNoFailure (fun x -> x.RawSystemType)) - ProvidedType.CreateNoContext(st.RawSystemType.MakeGenericType erasedArgTys)),m) - else - st - loop inputType - - let convertProvidedExpressionToExprAndWitness tcVal (thisArg:Expr option, - allArgs:Exprs, - paramVars:Tainted[], - g,amap,mut,isProp,isSuperInit,m, - expr:Tainted) = - let varConv = - [ for (v,e) in Seq.zip (paramVars |> Seq.map (fun x -> x.PUntaint(id,m))) (Option.toList thisArg @ allArgs) do - yield (v,(None,e)) ] - |> Dictionary.ofList - - let rec exprToExprAndWitness top (ea:Tainted) = - let fail() = error(Error(FSComp.SR.etUnsupportedProvidedExpression(ea.PUntaint((fun etree -> etree.UnderlyingExpressionString), m)),m)) - match ea with - | Tainted.Null -> error(Error(FSComp.SR.etNullProvidedExpression(ea.TypeProviderDesignation),m)) - | _ -> - match ea.PApplyOption((function ProvidedTypeAsExpr x -> Some x | _ -> None), m) with - | Some info -> - let (expr,targetTy) = info.PApply2(id,m) - let srcExpr = exprToExpr expr - let targetTy = Import.ImportProvidedType amap m (targetTy.PApply(id,m)) - let sourceTy = Import.ImportProvidedType amap m (expr.PApply((fun e -> e.Type),m)) - let te = mkCoerceIfNeeded g targetTy sourceTy srcExpr - None, (te, tyOfExpr g te) - | None -> - match ea.PApplyOption((function ProvidedTypeTestExpr x -> Some x | _ -> None), m) with - | Some info -> - let (expr,targetTy) = info.PApply2(id,m) - let srcExpr = exprToExpr expr - let targetTy = Import.ImportProvidedType amap m (targetTy.PApply(id,m)) - let te = mkCallTypeTest g m targetTy srcExpr - None, (te, tyOfExpr g te) - | None -> - match ea.PApplyOption((function ProvidedIfThenElseExpr x -> Some x | _ -> None), m) with - | Some info -> - let test,thenBranch,elseBranch = info.PApply3(id,m) - let testExpr = exprToExpr test - let ifTrueExpr = exprToExpr thenBranch - let ifFalseExpr = exprToExpr elseBranch - let te = mkCond NoSequencePointAtStickyBinding SuppressSequencePointAtTarget m (tyOfExpr g ifTrueExpr) testExpr ifTrueExpr ifFalseExpr - None, (te, tyOfExpr g te) - | None -> - match ea.PApplyOption((function ProvidedVarExpr x -> Some x | _ -> None), m) with - | Some info -> - let _,vTe = varToExpr info - None, (vTe, tyOfExpr g vTe) - | None -> - match ea.PApplyOption((function ProvidedConstantExpr x -> Some x | _ -> None), m) with - | Some info -> - let ce = convertConstExpr g amap m info - None, (ce, tyOfExpr g ce) - | None -> - match ea.PApplyOption((function ProvidedNewTupleExpr x -> Some x | _ -> None), m) with - | Some info -> - let elems = info.PApplyArray(id, "GetInvokerExpresson",m) - let elemsT = elems |> Array.map exprToExpr |> Array.toList - let exprT = mkTupledNoTypes g m elemsT - None, (exprT, tyOfExpr g exprT) - | None -> - match ea.PApplyOption((function ProvidedNewArrayExpr x -> Some x | _ -> None), m) with - | Some info -> - let ty,elems = info.PApply2(id,m) - let tyT = Import.ImportProvidedType amap m ty - let elems = elems.PApplyArray(id, "GetInvokerExpresson",m) - let elemsT = elems |> Array.map exprToExpr |> Array.toList - let exprT = Expr.Op(TOp.Array, [tyT],elemsT,m) - None, (exprT, tyOfExpr g exprT) - | None -> - match ea.PApplyOption((function ProvidedTupleGetExpr x -> Some x | _ -> None), m) with - | Some info -> - let inp,n = info.PApply2(id, m) - let inpT = inp |> exprToExpr - // if type of expression is erased type then we need convert it to the underlying base type - let typeOfExpr = - let t = tyOfExpr g inpT - stripTyEqnsWrtErasure EraseMeasures g t - let tysT = tryDestTupleTy g typeOfExpr - let exprT = mkTupleFieldGet (inpT, tysT, n.PUntaint(id,m), m) - None, (exprT, tyOfExpr g exprT) - | None -> - match ea.PApplyOption((function ProvidedLambdaExpr x -> Some x | _ -> None), m) with - | Some info -> - let v,b = info.PApply2(id, m) - let vT = addVar v - let bT = exprToExpr b - removeVar v - let exprT = mkLambda m vT (bT, tyOfExpr g bT) - None, (exprT, tyOfExpr g exprT) - | None -> - match ea.PApplyOption((function ProvidedLetExpr x -> Some x | _ -> None), m) with - | Some info -> - let v,e,b = info.PApply3(id, m) - let eT = exprToExpr e - let vT = addVar v - let bT = exprToExpr b - removeVar v - let exprT = mkCompGenLet m vT eT bT - None, (exprT, tyOfExpr g exprT) - | None -> - match ea.PApplyOption((function ProvidedVarSetExpr x -> Some x | _ -> None), m) with - | Some info -> - let v,e = info.PApply2(id, m) - let eT = exprToExpr e - let vTopt,_ = varToExpr v - match vTopt with - | None -> - fail() - | Some vT -> - let exprT = mkValSet m (mkLocalValRef vT) eT - None, (exprT, tyOfExpr g exprT) - | None -> - match ea.PApplyOption((function ProvidedWhileLoopExpr x -> Some x | _ -> None), m) with - | Some info -> - let guardExpr,bodyExpr = info.PApply2(id, m) - let guardExprT = exprToExpr guardExpr - let bodyExprT = exprToExpr bodyExpr - let exprT = mkWhile g (SequencePointInfoForWhileLoop.NoSequencePointAtWhileLoop,SpecialWhileLoopMarker.NoSpecialWhileLoopMarker, guardExprT, bodyExprT, m) - None, (exprT, tyOfExpr g exprT) - | None -> - match ea.PApplyOption((function ProvidedForIntegerRangeLoopExpr x -> Some x | _ -> None), m) with - | Some info -> - let v,e1,e2,e3 = info.PApply4(id, m) - let e1T = exprToExpr e1 - let e2T = exprToExpr e2 - let vT = addVar v - let e3T = exprToExpr e3 - removeVar v - let exprT = mkFastForLoop g (SequencePointInfoForForLoop.NoSequencePointAtForLoop,m,vT,e1T,true,e2T,e3T) - None, (exprT, tyOfExpr g exprT) - | None -> - match ea.PApplyOption((function ProvidedNewDelegateExpr x -> Some x | _ -> None), m) with - | Some info -> - let delegateTy,boundVars,delegateBodyExpr = info.PApply3(id, m) - let delegateTyT = Import.ImportProvidedType amap m delegateTy - let vs = boundVars.PApplyArray(id, "GetInvokerExpresson",m) |> Array.toList - let vsT = List.map addVar vs - let delegateBodyExprT = exprToExpr delegateBodyExpr - List.iter removeVar vs - let lambdaExpr = mkLambdas m [] vsT (delegateBodyExprT, tyOfExpr g delegateBodyExprT) - let lambdaExprTy = tyOfExpr g lambdaExpr - let infoReader = InfoReader(g, amap) - let exprT = CoerceFromFSharpFuncToDelegate g amap infoReader AccessorDomain.AccessibleFromSomewhere lambdaExprTy m lambdaExpr delegateTyT - None, (exprT, tyOfExpr g exprT) - | None -> -#if PROVIDED_ADDRESS_OF - match ea.PApplyOption((function ProvidedAddressOfExpr x -> Some x | _ -> None), m) with - | Some e -> - let eT = exprToExpr e - let wrap,ce = mkExprAddrOfExpr g true false DefinitelyMutates eT None m - let ce = wrap ce - None, (ce, tyOfExpr g ce) - | None -> -#endif - match ea.PApplyOption((function ProvidedDefaultExpr x -> Some x | _ -> None), m) with - | Some pty -> - let ty = Import.ImportProvidedType amap m pty - let ce = mkDefault (m, ty) - None, (ce, tyOfExpr g ce) - | None -> - match ea.PApplyOption((function ProvidedCallExpr c -> Some c | _ -> None), m) with - | Some info -> - methodCallToExpr top ea info - | None -> - match ea.PApplyOption((function ProvidedSequentialExpr c -> Some c | _ -> None), m) with - | Some info -> - let e1,e2 = info.PApply2(id, m) - let e1T = exprToExpr e1 - let e2T = exprToExpr e2 - let ce = mkCompGenSequential m e1T e2T - None, (ce, tyOfExpr g ce) - | None -> - match ea.PApplyOption((function ProvidedTryFinallyExpr c -> Some c | _ -> None), m) with - | Some info -> - let e1,e2 = info.PApply2(id, m) - let e1T = exprToExpr e1 - let e2T = exprToExpr e2 - let ce = mkTryFinally g (e1T,e2T,m,tyOfExpr g e1T,SequencePointInfoForTry.NoSequencePointAtTry,SequencePointInfoForFinally.NoSequencePointAtFinally) - None, (ce, tyOfExpr g ce) - | None -> - match ea.PApplyOption((function ProvidedTryWithExpr c -> Some c | _ -> None), m) with - | Some info -> - let bT = exprToExpr (info.PApply((fun (x,_,_,_,_) -> x), m)) - let v1 = info.PApply((fun (_,x,_,_,_) -> x), m) - let v1T = addVar v1 - let e1T = exprToExpr (info.PApply((fun (_,_,x,_,_) -> x), m)) - removeVar v1 - let v2 = info.PApply((fun (_,_,_,x,_) -> x), m) - let v2T = addVar v2 - let e2T = exprToExpr (info.PApply((fun (_,_,_,_,x) -> x), m)) - removeVar v2 - let ce = mkTryWith g (bT,v1T,e1T,v2T,e2T,m,tyOfExpr g bT,SequencePointInfoForTry.NoSequencePointAtTry,SequencePointInfoForWith.NoSequencePointAtWith) - None, (ce, tyOfExpr g ce) - | None -> - match ea.PApplyOption((function ProvidedNewObjectExpr c -> Some c | _ -> None), m) with - | Some info -> - None, ctorCallToExpr info - | None -> - fail() - - - and ctorCallToExpr (ne:Tainted<_>) = - let (ctor,args) = ne.PApply2(id,m) - let targetMethInfo = ProvidedMeth(amap,ctor.PApply((fun ne -> upcast ne),m),None,m) - let objArgs = [] - let arguments = [ for ea in args.PApplyArray(id, "GetInvokerExpresson", m) -> exprToExpr ea ] - let callExpr = BuildMethodCall tcVal g amap Mutates.PossiblyMutates m false targetMethInfo isSuperInit [] objArgs arguments - callExpr - - and addVar (v:Tainted) = - let nm = v.PUntaint ((fun v -> v.Name),m) - let mut = v.PUntaint ((fun v -> v.IsMutable),m) - let vRaw = v.PUntaint (id,m) - let tyT = Import.ImportProvidedType amap m (v.PApply ((fun v -> v.Type),m)) - let vT,vTe = if mut then mkMutableCompGenLocal m nm tyT else mkCompGenLocal m nm tyT - varConv.[vRaw] <- (Some vT,vTe) - vT - - and removeVar (v:Tainted) = - let vRaw = v.PUntaint (id,m) - varConv.Remove vRaw |> ignore - - and methodCallToExpr top _origExpr (mce:Tainted<_>) = - let (objOpt,meth,args) = mce.PApply3(id,m) - let targetMethInfo = ProvidedMeth(amap,meth.PApply((fun mce -> upcast mce), m),None,m) - let objArgs = - match objOpt.PApplyOption(id, m) with - | None -> [] - | Some objExpr -> [exprToExpr objExpr] - - let arguments = [ for ea in args.PApplyArray(id, "GetInvokerExpresson", m) -> exprToExpr ea ] - let genericArguments = - if meth.PUntaint((fun m -> m.IsGenericMethod), m) then - meth.PApplyArray((fun m -> m.GetGenericArguments()), "GetGenericArguments", m) - else - [| |] - let replacementGenericArguments = genericArguments |> Array.map (fun t->Import.ImportProvidedType amap m t) |> List.ofArray - - let mut = if top then mut else PossiblyMutates - let isSuperInit = if top then isSuperInit else ValUseFlag.NormalValUse - let isProp = if top then isProp else false - let callExpr = BuildMethodCall tcVal g amap mut m isProp targetMethInfo isSuperInit replacementGenericArguments objArgs arguments - Some meth, callExpr - - and varToExpr (pe:Tainted) = - // sub in the appropriate argument - // REVIEW: "thisArg" pointer should be first, if present - let vRaw = pe.PUntaint(id,m) - if not (varConv.ContainsKey vRaw) then - let typeProviderDesignation = ExtensionTyping.DisplayNameOfTypeProvider (pe.TypeProvider, m) - error(NumberedError(FSComp.SR.etIncorrectParameterExpression(typeProviderDesignation,vRaw.Name), m)) - varConv.[vRaw] - - and exprToExpr expr = - let _, (resExpr, _) = exprToExprAndWitness false expr - resExpr - - exprToExprAndWitness true expr - - - // fill in parameter holes in the expression - let TranslateInvokerExpressionForProvidedMethodCall tcVal (g, amap, mut, isProp, isSuperInit, mi:Tainted, objArgs, allArgs, m) = - let parameters = - mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters", m) - let paramTys = - parameters - |> Array.map (fun p -> p.PApply((fun st -> st.ParameterType),m)) - let erasedParamTys = - paramTys - |> Array.map (fun pty -> eraseSystemType (amap,m,pty)) - let paramVars = - erasedParamTys - |> Array.mapi (fun i erasedParamTy -> erasedParamTy.PApply((fun ty -> ProvidedVar.Fresh("arg" + i.ToString(),ty)),m)) - - - // encode "this" as the first ParameterExpression, if applicable - let thisArg, paramVars = - match objArgs with - | [objArg] -> - let erasedThisTy = eraseSystemType (amap,m,mi.PApply((fun mi -> mi.DeclaringType),m)) - let thisVar = erasedThisTy.PApply((fun ty -> ProvidedVar.Fresh("this", ty)), m) - Some objArg , Array.append [| thisVar |] paramVars - | [] -> None , paramVars - | _ -> failwith "multiple objArgs?" - - let ea = mi.PApplyWithProvider((fun (methodInfo,provider) -> ExtensionTyping.GetInvokerExpression(provider, methodInfo, [| for p in paramVars -> p.PUntaintNoFailure id |])), m) - - convertProvidedExpressionToExprAndWitness tcVal (thisArg,allArgs,paramVars,g,amap,mut,isProp,isSuperInit,m,ea) - - - let BuildInvokerExpressionForProvidedMethodCall tcVal (g, amap, mi:Tainted, objArgs, mut, isProp, isSuperInit, allArgs, m) = - try - let methInfoOpt, (expr, retTy) = TranslateInvokerExpressionForProvidedMethodCall tcVal (g, amap, mut, isProp, isSuperInit, mi, objArgs, allArgs, m) - - let exprty = GetCompiledReturnTyOfProvidedMethodInfo amap m mi |> GetFSharpViewOfReturnType g - let expr = mkCoerceIfNeeded g exprty retTy expr - methInfoOpt, expr, exprty - with - | :? TypeProviderError as tpe -> - let typeName = mi.PUntaint((fun mb -> mb.DeclaringType.FullName), m) - let methName = mi.PUntaint((fun mb -> mb.Name), m) - raise( tpe.WithContext(typeName, methName) ) // loses original stack trace -#endif diff --git a/src/fsharp/ast.fs b/src/fsharp/ast.fs index d44e0c0da3..9c2ac0068b 100644 --- a/src/fsharp/ast.fs +++ b/src/fsharp/ast.fs @@ -695,66 +695,72 @@ and /// Inserted for error recovery when there is "expr." and missing tokens or error recovery after the dot | DiscardAfterMissingQualificationAfterDot of expr:SynExpr * range:range + + /// 'use x = fixed expr' + | Fixed of SynExpr * range + /// Get the syntactic range of source code covered by this construct. member e.Range = match e with - | SynExpr.Paren (range=m) - | SynExpr.Quote (range=m) - | SynExpr.Const (range=m) - | SynExpr.Typed (range=m) - | SynExpr.Tuple (range=m) - | SynExpr.ArrayOrList (range=m) - | SynExpr.Record (range=m) - | SynExpr.New (range=m) - | SynExpr.ObjExpr (range=m) - | SynExpr.While (range=m) - | SynExpr.For (range=m) - | SynExpr.ForEach (range=m) - | SynExpr.CompExpr (range=m) - | SynExpr.ArrayOrListOfSeqExpr (range=m) - | SynExpr.Lambda (range=m) - | SynExpr.Match (range=m) - | SynExpr.MatchLambda (range=m) - | SynExpr.Do (range=m) - | SynExpr.Assert (range=m) - | SynExpr.App (range=m) - | SynExpr.TypeApp (range=m) - | SynExpr.LetOrUse (range=m) - | SynExpr.TryWith (range=m) - | SynExpr.TryFinally (range=m) - | SynExpr.Sequential (range=m) - | SynExpr.ArbitraryAfterError (range=m) - | SynExpr.FromParseError (range=m) - | SynExpr.DiscardAfterMissingQualificationAfterDot (range=m) - | SynExpr.IfThenElse (range=m) - | SynExpr.LongIdent (range=m) - | SynExpr.LongIdentSet (range=m) - | SynExpr.NamedIndexedPropertySet (range=m) - | SynExpr.DotIndexedGet (range=m) - | SynExpr.DotIndexedSet (range=m) - | SynExpr.DotGet (range=m) - | SynExpr.DotSet (range=m) - | SynExpr.DotNamedIndexedPropertySet (range=m) - | SynExpr.LibraryOnlyUnionCaseFieldGet (range=m) - | SynExpr.LibraryOnlyUnionCaseFieldSet (range=m) - | SynExpr.LibraryOnlyILAssembly (range=m) - | SynExpr.LibraryOnlyStaticOptimization (range=m) - | SynExpr.TypeTest (range=m) - | SynExpr.Upcast (range=m) - | SynExpr.AddressOf (range=m) - | SynExpr.Downcast (range=m) - | SynExpr.JoinIn (range=m) - | SynExpr.InferredUpcast (range=m) - | SynExpr.InferredDowncast (range=m) - | SynExpr.Null (range=m) - | SynExpr.Lazy (range=m) - | SynExpr.TraitCall (range=m) - | SynExpr.ImplicitZero (range=m) - | SynExpr.YieldOrReturn (range=m) - | SynExpr.YieldOrReturnFrom (range=m) - | SynExpr.LetOrUseBang (range=m) - | SynExpr.DoBang (range=m) -> m + | SynExpr.Paren(_,_,_,m) + | SynExpr.Quote(_,_,_,_,m) + | SynExpr.Const(_,m) + | SynExpr.Typed (_,_,m) + | SynExpr.Tuple (_,_,m) + | SynExpr.ArrayOrList (_,_,m) + | SynExpr.Record (_,_,_,m) + | SynExpr.New (_,_,_,m) + | SynExpr.ObjExpr (_,_,_,_,_,m) + | SynExpr.While (_,_,_,m) + | SynExpr.For (_,_,_,_,_,_,m) + | SynExpr.ForEach (_,_,_,_,_,_,m) + | SynExpr.CompExpr (_,_,_,m) + | SynExpr.ArrayOrListOfSeqExpr (_,_,m) + | SynExpr.Lambda (_,_,_,_,m) + | SynExpr.Match (_,_,_,_,m) + | SynExpr.MatchLambda (_,_,_,_,m) + | SynExpr.Do (_,m) + | SynExpr.Assert (_,m) + | SynExpr.App (_,_,_,_,m) + | SynExpr.TypeApp (_,_,_,_,_,_,m) + | SynExpr.LetOrUse (_,_,_,_,m) + | SynExpr.TryWith (_,_,_,_,m,_,_) + | SynExpr.TryFinally (_,_,m,_,_) + | SynExpr.Sequential (_,_,_,_,m) + | SynExpr.ArbitraryAfterError(_,m) + | SynExpr.FromParseError (_,m) + | SynExpr.DiscardAfterMissingQualificationAfterDot (_,m) + | SynExpr.IfThenElse (_,_,_,_,_,_,m) + | SynExpr.LongIdent (_,_,_,m) + | SynExpr.LongIdentSet (_,_,m) + | SynExpr.NamedIndexedPropertySet (_,_,_,m) + | SynExpr.DotIndexedGet (_,_,_,m) + | SynExpr.DotIndexedSet (_,_,_,_,_,m) + | SynExpr.DotGet (_,_,_,m) + | SynExpr.DotSet (_,_,_,m) + | SynExpr.DotNamedIndexedPropertySet (_,_,_,_,m) + | SynExpr.LibraryOnlyUnionCaseFieldGet (_,_,_,m) + | SynExpr.LibraryOnlyUnionCaseFieldSet (_,_,_,_,m) + | SynExpr.LibraryOnlyILAssembly (_,_,_,_,m) + | SynExpr.LibraryOnlyStaticOptimization (_,_,_,m) + | SynExpr.TypeTest (_,_,m) + | SynExpr.Upcast (_,_,m) + | SynExpr.AddressOf (_,_,_,m) + | SynExpr.Downcast (_,_,m) + | SynExpr.JoinIn (_,_,_,m) + | SynExpr.InferredUpcast (_,m) + | SynExpr.InferredDowncast (_,m) + | SynExpr.Null m + | SynExpr.Lazy (_, m) + | SynExpr.TraitCall(_,_,_,m) + | SynExpr.ImplicitZero (m) + | SynExpr.YieldOrReturn (_,_,m) + | SynExpr.YieldOrReturnFrom (_,_,m) + | SynExpr.LetOrUseBang (_,_,_,_,_,_,m) + | SynExpr.DoBang (_,m) -> m + | SynExpr.Fixed (_,m) -> m | SynExpr.Ident id -> id.idRange + /// range ignoring any (parse error) extra trailing dots member e.RangeSansAnyExtraDot = match e with @@ -814,6 +820,7 @@ and | SynExpr.DotGet (expr,_,lidwd,m) -> if lidwd.ThereIsAnExtraDotAtTheEnd then unionRanges expr.Range lidwd.RangeSansAnyExtraDot else m | SynExpr.LongIdent (_,lidwd,_,_) -> lidwd.RangeSansAnyExtraDot | SynExpr.DiscardAfterMissingQualificationAfterDot (expr,_) -> expr.Range + | SynExpr.Fixed (_,m) -> m | SynExpr.Ident id -> id.idRange /// Attempt to get the range of the first token or initial portion only - this is extremely ad-hoc, just a cheap way to improve a certain 'query custom operation' error range member e.RangeOfFirstPortion = @@ -881,6 +888,7 @@ and let e = (pat.Range : range).Start mkRange r.FileName start e | SynExpr.Ident id -> id.idRange + | SynExpr.Fixed (_,m) -> m and @@ -1116,32 +1124,44 @@ and /// The untyped, unchecked syntax tree for the core of a simple type definition, in either signature /// or implementation. SynTypeDefnSimpleRepr = + /// A union type definition, type X = A | B | Union of accessiblity:SynAccess option * cases:SynUnionCases * range:range + /// An enum type definition, type X = A = 1 | B = 2 | Enum of cases:SynEnumCases * range:range + /// A record type definition, type X = { A : int; B : int } | Record of accessiblity:SynAccess option * fields:SynFields * range:range + /// An object oriented type definition. This is not a parse-tree form, but represents the core /// type representation which the type checker splits out from the 'ObjectModel' cases of type definitions. | General of SynTypeDefnKind * (SynType * range * Ident option) list * (SynValSig * MemberFlags) list * SynField list * bool * bool * SynSimplePat list option * range:range + /// A type defined by using an IL assembly representation. Only used in FSharp.Core. /// /// F# syntax: type X = (# '...' #) | LibraryOnlyILAssembly of ILType * range:range - /// A type abbreviation, 'type X = A.B.C' + + /// A type abbreviation, "type X = A.B.C" | TypeAbbrev of ParserDetail * SynType * range:range - /// An abstract definition , 'type X' + + /// An abstract definition , "type X" | None of range:range + + /// An exception definition , "exception E = ..." + | Exception of SynExceptionDefnRepr + member this.Range = match this with - | Union (range=m) - | Enum (range=m) - | Record (range=m) - | General (range=m) - | LibraryOnlyILAssembly (range=m) - | TypeAbbrev (range=m) - | None (range=m) -> m + | Union(_,_,m) + | Enum(_,m) + | Record(_,_,m) + | General(_,_,_,_,_,_,_,m) + | LibraryOnlyILAssembly(_,m) + | TypeAbbrev(_,_,m) + | None(m) -> m + | Exception t -> t.Range and SynEnumCases = SynEnumCase list @@ -1185,9 +1205,12 @@ and | ObjectModel of SynTypeDefnKind * memberSigs:SynMemberSigs * range:range /// Indicates the right right-hand-side is a record, union or other simple type. | Simple of SynTypeDefnSimpleRepr * range:range + | Exception of SynExceptionDefnRepr member this.Range = match this with - | ObjectModel (range=m) | Simple (range=m) -> m + | ObjectModel(_,_,m) -> m + | Simple(_,m) -> m + | Exception e -> e.Range and [] @@ -1261,25 +1284,30 @@ and /// 'exception E = ... ' and [] - SynExceptionRepr = - | ExceptionDefnRepr of SynAttributes * case:SynUnionCase * longId:LongIdent option * xmlDoc:PreXmlDoc * accesibility:SynAccess option * range:range - member this.Range = match this with ExceptionDefnRepr (range=m) -> m + SynExceptionDefnRepr = + | SynExceptionDefnRepr of SynAttributes * case:SynUnionCase * longId:LongIdent option * xmlDoc:PreXmlDoc * accesibility:SynAccess option * range:range + member this.Range = match this with SynExceptionDefnRepr(_,_,_,_,_,m) -> m /// 'exception E = ... with ...' and [] SynExceptionDefn = - | ExceptionDefn of exnRepr:SynExceptionRepr * members:SynMemberDefns * range:range + | SynExceptionDefn of exnRepr:SynExceptionDefnRepr * members:SynMemberDefns * range:range + member this.Range = + match this with + | SynExceptionDefn(_,_,m) -> m and - [] + [] SynTypeDefnRepr = | ObjectModel of SynTypeDefnKind * members:SynMemberDefns * range:range | Simple of SynTypeDefnSimpleRepr * range:range + | Exception of SynExceptionDefnRepr member this.Range = match this with | ObjectModel(_,_,m) -> m | Simple(_,m) -> m + | Exception t -> t.Range and [] @@ -1331,41 +1359,41 @@ and SynMemberDefns = SynMemberDefn list and [] SynModuleDecl = - | ModuleAbbrev of id:Ident * longId:LongIdent * range:range - | NestedModule of SynComponentInfo * moduleDecls:SynModuleDecls * bool * range:range - | Let of bool * bindings:SynBinding list * range:range - | DoExpr of spBind:SequencePointInfoForBinding * SynExpr * range:range - | Types of typeDefns:SynTypeDefn list * range:range - | Exception of exnDefn:SynExceptionDefn * range:range - | Open of dotId:LongIdentWithDots * range:range - | Attributes of attributes:SynAttributes * range:range - | HashDirective of hashDirectives:ParsedHashDirective * range:range + | ModuleAbbrev of Ident * LongIdent * range + | NestedModule of SynComponentInfo * isRec: bool * SynModuleDecls * bool * range + | Let of bool * SynBinding list * range + | DoExpr of SequencePointInfoForBinding * SynExpr * range + | Types of SynTypeDefn list * range + | Exception of SynExceptionDefn * range + | Open of LongIdentWithDots * range + | Attributes of SynAttributes * range + | HashDirective of ParsedHashDirective * range | NamespaceFragment of SynModuleOrNamespace member d.Range = match d with - | SynModuleDecl.ModuleAbbrev (range=m) - | SynModuleDecl.NestedModule (range=m) - | SynModuleDecl.Let (range=m) - | SynModuleDecl.DoExpr (range=m) - | SynModuleDecl.Types (range=m) - | SynModuleDecl.Exception (range=m) - | SynModuleDecl.Open (range=m) - | SynModuleDecl.HashDirective (range=m) - | SynModuleDecl.NamespaceFragment (SynModuleOrNamespace (range=m)) - | SynModuleDecl.Attributes (range=m) -> m + | SynModuleDecl.ModuleAbbrev(_,_,m) + | SynModuleDecl.NestedModule(_,_,_,_,m) + | SynModuleDecl.Let(_,_,m) + | SynModuleDecl.DoExpr(_,_,m) + | SynModuleDecl.Types(_,m) + | SynModuleDecl.Exception(_,m) + | SynModuleDecl.Open (_,m) + | SynModuleDecl.HashDirective (_,m) + | SynModuleDecl.NamespaceFragment(SynModuleOrNamespace(_,_,_,_,_,_,_,m)) + | SynModuleDecl.Attributes(_,m) -> m and SynModuleDecls = SynModuleDecl list and [] SynExceptionSig = - | ExceptionSig of exnRepr:SynExceptionRepr * memberSigs:SynMemberSigs * range:range + | SynExceptionSig of exnRepr:SynExceptionDefnRepr * memberSigs:SynMemberSigs * range:range and [] SynModuleSigDecl = | ModuleAbbrev of id:Ident * longId:LongIdent * range:range - | NestedModule of SynComponentInfo * moduleSigDecls:SynModuleSigDecls * range:range + | NestedModule of SynComponentInfo * isRec: bool * moduleSigDecls:SynModuleSigDecls * range:range | Val of valSig:SynValSig * range:range | Types of typeDefSigs:SynTypeDefnSig list * range:range | Exception of exnSig:SynExceptionSig * range:range @@ -1375,30 +1403,30 @@ and member d.Range = match d with - | SynModuleSigDecl.ModuleAbbrev (range=m) - | SynModuleSigDecl.NestedModule (range=m) - | SynModuleSigDecl.Val (range=m) - | SynModuleSigDecl.Types (range=m) - | SynModuleSigDecl.Exception (range=m) - | SynModuleSigDecl.Open (range=m) - | SynModuleSigDecl.NamespaceFragment (SynModuleOrNamespaceSig (range=m)) - | SynModuleSigDecl.HashDirective (range=m) -> m + | SynModuleSigDecl.ModuleAbbrev (_,_,m) + | SynModuleSigDecl.NestedModule (_,_,_,m) + | SynModuleSigDecl.Val (_,m) + | SynModuleSigDecl.Types (_,m) + | SynModuleSigDecl.Exception (_,m) + | SynModuleSigDecl.Open (_,m) + | SynModuleSigDecl.NamespaceFragment (SynModuleOrNamespaceSig(_,_,_,_,_,_,_,m)) + | SynModuleSigDecl.HashDirective (_,m) -> m and SynModuleSigDecls = SynModuleSigDecl list -/// SynModuleOrNamespace(lid,isModule,decls,xmlDoc,attribs,SynAccess,m) +/// SynModuleOrNamespace(lid,isRec,isModule,decls,xmlDoc,attribs,SynAccess,m) and [] SynModuleOrNamespace = - | SynModuleOrNamespace of id:LongIdent * isModule:bool * decls:SynModuleDecls * xmlDoc:PreXmlDoc * attributes:SynAttributes * access:SynAccess option * range:range + | SynModuleOrNamespace of id:LongIdent * isRec: bool * isModule:bool * decls:SynModuleDecls * xmlDoc:PreXmlDoc * attributes:SynAttributes * access:SynAccess option * range:range member this.Range = match this with - | SynModuleOrNamespace (range=m) -> m + | SynModuleOrNamespace(_,_,_,_,_,_,_,m) -> m and [] SynModuleOrNamespaceSig = - | SynModuleOrNamespaceSig of id:LongIdent * isModule:bool * SynModuleSigDecls * xmlDoc:PreXmlDoc * attributes:SynAttributes * SynAccess option * range:range + | SynModuleOrNamespaceSig of id:LongIdent * isRec: bool * isModule:bool * SynModuleSigDecls * xmlDoc:PreXmlDoc * attributes:SynAttributes * SynAccess option * range:range and [] ParsedHashDirective = @@ -1408,13 +1436,13 @@ and [] type ParsedImplFileFragment = | AnonModule of moduleDecls:SynModuleDecls * range:range | NamedModule of SynModuleOrNamespace - | NamespaceFragment of longId:LongIdent * bool * moduleDecls:SynModuleDecls * xmlDoc:PreXmlDoc * attributes:SynAttributes * range:range + | NamespaceFragment of longId:LongIdent * bool * bool * moduleDecls:SynModuleDecls * xmlDoc:PreXmlDoc * attributes:SynAttributes * range:range [] type ParsedSigFileFragment = | AnonModule of moduleSigDecl:SynModuleSigDecls * range:range | NamedModule of SynModuleOrNamespaceSig - | NamespaceFragment of longId:LongIdent * bool * moduleSigDecls:SynModuleSigDecls * xmlDoc:PreXmlDoc * attributes:SynAttributes * range:range + | NamespaceFragment of longId:LongIdent * bool * bool * moduleSigDecls:SynModuleSigDecls * xmlDoc:PreXmlDoc * attributes:SynAttributes * range:range [] type ParsedFsiInteraction = @@ -1469,7 +1497,7 @@ type QualifiedNameOfFile = [] type ParsedImplFileInput = - | ParsedImplFileInput of filename:string * isScript:bool * QualifiedNameOfFile * ScopedPragma list * ParsedHashDirective list * SynModuleOrNamespace list * bool + | ParsedImplFileInput of filename:string * isScript:bool * QualifiedNameOfFile * ScopedPragma list * ParsedHashDirective list * SynModuleOrNamespace list * (bool * bool) [] type ParsedSigFileInput = @@ -1482,8 +1510,8 @@ type ParsedInput = member inp.Range = match inp with - | ParsedInput.ImplFile (ParsedImplFileInput(_,_,_,_,_,(SynModuleOrNamespace(range=m) :: _),_)) - | ParsedInput.SigFile (ParsedSigFileInput(_,_,_,_,(SynModuleOrNamespaceSig(range=m) :: _))) -> m + | ParsedInput.ImplFile (ParsedImplFileInput(_,_,_,_,_,(SynModuleOrNamespace(_,_,_,_,_,_,_,m) :: _),_)) + | ParsedInput.SigFile (ParsedSigFileInput(_,_,_,_,(SynModuleOrNamespaceSig(_,_,_,_,_,_,_,m) :: _))) -> m | ParsedInput.ImplFile (ParsedImplFileInput(filename,_,_,_,_,[],_)) | ParsedInput.SigFile (ParsedSigFileInput(filename,_,_,_,[])) -> #if DEBUG @@ -2248,8 +2276,9 @@ let rec synExprContainsError inpExpr = | SynExpr.TraitCall(_,_,e,_) | SynExpr.YieldOrReturn (_,e,_) | SynExpr.YieldOrReturnFrom (_,e,_) - | SynExpr.DoBang (e,_) - | SynExpr.Paren(e,_,_,_) -> + | SynExpr.DoBang (e,_) + | SynExpr.Fixed (e,_) + | SynExpr.Paren (e,_,_,_) -> walkExpr e | SynExpr.NamedIndexedPropertySet (_,e1,e2,_) diff --git a/src/fsharp/fsc.fs b/src/fsharp/fsc.fs index f3ab3879d0..c6507ed170 100755 --- a/src/fsharp/fsc.fs +++ b/src/fsharp/fsc.fs @@ -13,16 +13,18 @@ module internal Microsoft.FSharp.Compiler.Driver open System +open System.Collections.Generic open System.Diagnostics open System.Globalization open System.IO -open System.Threading open System.Reflection -open System.Collections.Generic open System.Runtime.CompilerServices open System.Text +open System.Threading + open Internal.Utilities open Internal.Utilities.Collections + open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL open Microsoft.FSharp.Compiler.AbstractIL.IL @@ -35,22 +37,23 @@ open Microsoft.FSharp.Compiler.AbstractIL.IL #else open Microsoft.FSharp.Compiler.IlxGen #endif + +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.AttributeChecking open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.CompileOptions open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.DiagnosticMessage +open Microsoft.FSharp.Compiler.Optimizer open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.TypeChecker -open Microsoft.FSharp.Compiler.Infos -open Microsoft.FSharp.Compiler.Infos.AccessibilityLogic -open Microsoft.FSharp.Compiler.Infos.AttributeChecking open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops -open Microsoft.FSharp.Compiler.Optimizer open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.CompileOps -open Microsoft.FSharp.Compiler.Lib -open Microsoft.FSharp.Compiler.CompileOptions -open Microsoft.FSharp.Compiler.DiagnosticMessage -open Microsoft.FSharp.Core #if EXTENSIONTYPING open Microsoft.FSharp.Compiler.ExtensionTyping @@ -225,7 +228,7 @@ let AdjustForScriptCompile(tcConfigB:TcConfigBuilder,commandLineSourceFiles,lexR let tcConfig = TcConfig.Create(tcConfigB,validate=false) let AddIfNotPresent(filename:string) = - if not(!allSources |> List.mem filename) then + if not(!allSources |> List.contains filename) then allSources := filename::!allSources let AppendClosureInformation(filename) = @@ -399,14 +402,14 @@ let GetTcImportsFromCommandLine ReportTime tcConfig "Parse inputs" use unwindParsePhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.Parse) let inputs = - try - sourceFiles - |> tcConfig.ComputeCanContainEntryPoint + try + let isLastCompiland, isExe = sourceFiles |> tcConfig.ComputeCanContainEntryPoint + isLastCompiland |> List.zip sourceFiles // PERF: consider making this parallel, once uses of global state relevant to parsing are cleaned up - |> List.choose (fun (filename:string,isLastCompiland:bool) -> + |> List.choose (fun (filename:string, isLastCompiland) -> let pathOfMetaCommandSource = Path.GetDirectoryName(filename) - match ParseOneInputFile(tcConfig,lexResourceManager,["COMPILED"],filename,isLastCompiland,errorLogger,(*retryLocked*)false) with + match ParseOneInputFile(tcConfig,lexResourceManager,["COMPILED"],filename,(isLastCompiland, isExe),errorLogger,(*retryLocked*)false) with | Some(input)->Some(input,pathOfMetaCommandSource) | None -> None ) @@ -1572,7 +1575,7 @@ module StaticLinker = ReportTime tcConfig "Static link"; #if EXTENSIONTYPING - Morphs.enablemorphCustomAttributeData() + Morphs.enableMorphCustomAttributeData() let providerGeneratedILModules = FindProviderGeneratedILModules (tcImports, providerGeneratedAssemblies) // Transform the ILTypeRefs references in the IL of all provider-generated assemblies so that the references @@ -1694,7 +1697,7 @@ module StaticLinker = providerGeneratedILModules, ilxMainModule - Morphs.disablemorphCustomAttributeData() + Morphs.disableMorphCustomAttributeData() #else let providerGeneratedILModules = [] #endif @@ -2117,20 +2120,7 @@ let main2b (tcImportsCapture,dynamicAssemblyCreator) (Args(tcConfig:TcConfig, tc Args (tcConfig,errorLogger,staticLinker,ilGlobals,outfile,pdbfile,ilxMainModule,signingInfo,exiter) -let main2c(Args(tcConfig, errorLogger, staticLinker, ilGlobals, outfile, pdbfile, ilxMainModule, signingInfo, exiter: Exiter)) = - - use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind (BuildPhase.IlGen) - - ReportTime tcConfig "ILX -> IL (Unions)"; - let ilxMainModule = EraseUnions.ConvModule ilGlobals ilxMainModule - ReportTime tcConfig "ILX -> IL (Funcs)"; - let ilxMainModule = EraseClosures.ConvModule ilGlobals ilxMainModule - - AbortOnError(errorLogger,tcConfig,exiter) - Args(tcConfig,errorLogger,staticLinker,ilGlobals,ilxMainModule,outfile,pdbfile,signingInfo,exiter) - - -let main3(Args(tcConfig, errorLogger: ErrorLogger, staticLinker, ilGlobals, ilxMainModule, outfile, pdbfile, signingInfo, exiter:Exiter)) = +let main3(Args(tcConfig, errorLogger: ErrorLogger, staticLinker, ilGlobals, outfile, pdbfile, ilxMainModule, signingInfo, exiter:Exiter)) = let ilxMainModule = try staticLinker ilxMainModule @@ -2171,7 +2161,6 @@ let typecheckAndCompile(argv,bannerAlreadyPrinted,openBinariesInMemory,exiter:Ex |> main1 |> main2 |> main2b (tcImportsCapture,dynamicAssemblyCreator) - |> main2c |> main3 |> main4 dynamicAssemblyCreator @@ -2180,7 +2169,6 @@ let compileOfAst (openBinariesInMemory, assemblyName, target, outFile, pdbFile, main1OfAst (openBinariesInMemory, assemblyName, target, outFile, pdbFile, dllReferences, noframework, exiter, errorLoggerProvider, inputs) |> main2 |> main2b (tcImportsCapture, dynamicAssemblyCreator) - |> main2c |> main3 |> main4 dynamicAssemblyCreator diff --git a/src/fsharp/fsi/fsi.fs b/src/fsharp/fsi/fsi.fs index a91163f2a8..a05bb2e7b9 100644 --- a/src/fsharp/fsi/fsi.fs +++ b/src/fsharp/fsi/fsi.fs @@ -22,28 +22,32 @@ open System.Threading open System.Reflection open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX open Microsoft.FSharp.Compiler.AbstractIL.ILRuntimeWriter open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.CompileOptions -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.InfoReader +open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.IlxGen +open Microsoft.FSharp.Compiler.Lexhelp +open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.Optimizer +open Microsoft.FSharp.Compiler.PostTypeCheckSemanticChecks open Microsoft.FSharp.Compiler.Range -open Microsoft.FSharp.Compiler.Ast -open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.TypeChecker open Microsoft.FSharp.Compiler.Tast -open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.CompileOps -open Microsoft.FSharp.Compiler.Lexhelp -open Microsoft.FSharp.Compiler.Layout -open Microsoft.FSharp.Compiler.NameResolution open Microsoft.FSharp.Compiler.SourceCodeServices open Internal.Utilities @@ -869,7 +873,7 @@ let internal WithImplicitHome (tcConfigB, dir) f = type internal FsiDynamicCompiler (fsi: FsiEvaluationSessionHostConfig, timeReporter : FsiTimeReporter, - tcConfigB, + tcConfigB: TcConfigBuilder, tcLockObject : obj, outWriter: TextWriter, tcImports: TcImports, @@ -900,7 +904,7 @@ type internal FsiDynamicCompiler let infoReader = InfoReader(tcGlobals,tcImports.GetImportMap()) /// Add attributes - let CreateModuleFragment (tcConfigB, assemblyName, codegenResults) = + let CreateModuleFragment (tcConfigB: TcConfigBuilder, assemblyName, codegenResults) = if !progress then fprintfn fsiConsoleOutput.Out "Creating main module..."; let mainModule = mkILSimpleModule assemblyName (GetGeneratedILModuleName tcConfigB.target assemblyName) (tcConfigB.target = Dll) tcConfigB.subsystemVersion tcConfigB.useHighEntropyVA (mkILTypeDefs codegenResults.ilTypeDefs) None None 0x0 (mkILExportedTypes []) "" { mainModule @@ -955,13 +959,6 @@ type internal FsiDynamicCompiler errorLogger.AbortOnError(fsiConsoleOutput); - ReportTime tcConfig "ILX -> IL (Unions)"; - let ilxMainModule = EraseUnions.ConvModule ilGlobals ilxMainModule - ReportTime tcConfig "ILX -> IL (Funcs)"; - let ilxMainModule = EraseClosures.ConvModule ilGlobals ilxMainModule - - errorLogger.AbortOnError(fsiConsoleOutput); - ReportTime tcConfig "Assembly refs Normalised"; let mainmod3 = Morphs.morphILScopeRefsInILModuleMemoized ilGlobals (NormalizeAssemblyRefs tcImports) ilxMainModule errorLogger.AbortOnError(fsiConsoleOutput); @@ -1071,8 +1068,8 @@ type internal FsiDynamicCompiler let i = nextFragmentId() let prefix = mkFragmentPath i let prefixPath = pathOfLid prefix - let impl = SynModuleOrNamespace(prefix,(* isModule: *) true,defs,PreXmlDoc.Empty,[],None,rangeStdin) - let input = ParsedInput.ImplFile(ParsedImplFileInput(filename,true, ComputeQualifiedNameOfFileFromUniquePath (rangeStdin,prefixPath),[],[],[impl],true (* isLastCompiland *) )) + let impl = SynModuleOrNamespace(prefix,(*isRec*)false, (* isModule: *) true,defs,PreXmlDoc.Empty,[],None,rangeStdin) + let input = ParsedInput.ImplFile(ParsedImplFileInput(filename,true, ComputeQualifiedNameOfFileFromUniquePath (rangeStdin,prefixPath),[],[],[impl],(true (* isLastCompiland *), false (* isExe *)) )) let istate,tcEnvAtEndOfLastInput,declaredImpls = ProcessInputs (errorLogger, istate, [input], showTypes, true, isInteractiveItExpr, prefix) let tcState = istate.tcState let newState = { istate with tcState = tcState.NextStateAfterIncrementalFragment(tcEnvAtEndOfLastInput) } @@ -1223,6 +1220,8 @@ type internal FsiDynamicCompiler else fsiConsoleOutput.uprintnf " %s %s" (FSIstrings.SR.fsiLoadingFilesPrefixText()) sourceFile) fsiConsoleOutput.uprintfn "]" + closure.NoWarns |> Seq.map (fun (n,ms) -> ms |> Seq.map (fun m -> m,n)) |> Seq.concat |> Seq.iter tcConfigB.TurnWarningOff + // Play errors and warnings from closures of the surface (root) script files. closure.RootErrors |> List.iter errorSink closure.RootWarnings |> List.iter warnSink @@ -1233,7 +1232,7 @@ type internal FsiDynamicCompiler |> List.map (fun (filename, input)-> let parsedInput = match input with - | None -> ParseOneInputFile(tcConfig,lexResourceManager,["INTERACTIVE"],filename,true,errorLogger,(*retryLocked*)false) + | None -> ParseOneInputFile(tcConfig,lexResourceManager,["INTERACTIVE"],filename,(true,false),errorLogger,(*retryLocked*)false) | _-> input filename, parsedInput) |> List.unzip @@ -2248,7 +2247,7 @@ type internal FsiInteractionProcessor let tcState = istate.tcState let amap = istate.tcImports.GetImportMap() - let infoReader = new Infos.InfoReader(istate.tcGlobals,amap) + let infoReader = new InfoReader(istate.tcGlobals,amap) let ncenv = new NameResolver(istate.tcGlobals,amap,infoReader,FakeInstantiationGenerator) let ad = tcState.TcEnvFromImpls.AccessRights let nenv = tcState.TcEnvFromImpls.NameEnv diff --git a/src/fsharp/import.fs b/src/fsharp/import.fs index 35b282c9f4..7f29cacc8e 100755 --- a/src/fsharp/import.fs +++ b/src/fsharp/import.fs @@ -3,8 +3,6 @@ /// Functions to import .NET binary metadata as TAST objects module internal Microsoft.FSharp.Compiler.Import -#nowarn "44" // This construct is deprecated. please use List.item - open System.Reflection open System.Collections.Generic open Internal.Utilities @@ -164,13 +162,13 @@ let rec ImportILType (env:ImportMap) m tinst typ = ImportTyconRefApp env tcref inst | ILType.Byref ty -> mkByrefTy env.g (ImportILType env m tinst ty) - | ILType.Ptr ty -> mkNativePtrType env.g (ImportILType env m tinst ty) + | ILType.Ptr ty -> mkNativePtrTy env.g (ImportILType env m tinst ty) | ILType.FunctionPointer _ -> env.g.nativeint_ty (* failwith "cannot import this kind of type (ptr, fptr)" *) | ILType.Modified(_,_,ty) -> // All custom modifiers are ignored ImportILType env m tinst ty | ILType.TypeVar u16 -> - try List.nth tinst (int u16) + try List.item (int u16) tinst with _ -> error(Error(FSComp.SR.impNotEnoughTypeParamsInScopeWhileImporting(),m)) @@ -246,7 +244,7 @@ let rec ImportProvidedType (env:ImportMap) (m:range) (* (tinst:TypeInst) *) (st: mkByrefTy g elemTy elif st.PUntaint((fun st -> st.IsPointer),m) then let elemTy = (ImportProvidedType env m (* tinst *) (st.PApply((fun st -> st.GetElementType()),m))) - mkNativePtrType g elemTy + mkNativePtrTy g elemTy else // REVIEW: Extension type could try to be its own generic arg (or there could be a type loop) diff --git a/src/fsharp/infos.fs b/src/fsharp/infos.fs index 2db53893c7..a45459049e 100755 --- a/src/fsharp/infos.fs +++ b/src/fsharp/infos.fs @@ -8,11 +8,11 @@ module internal Microsoft.FSharp.Compiler.Infos open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger @@ -20,7 +20,6 @@ open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Tastops.DebugPrint open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Core.Printf @@ -30,7 +29,7 @@ open Microsoft.FSharp.Core.CompilerServices #endif #if FX_RESHAPED_REFLECTION - open Microsoft.FSharp.Core.ReflectionAdapters +open Microsoft.FSharp.Core.ReflectionAdapters #endif //------------------------------------------------------------------------- @@ -38,10 +37,10 @@ open Microsoft.FSharp.Core.CompilerServices //------------------------------------------------------------------------- /// Import an IL type as an F# type. importInst gives the context for interpreting type variables. -let ImportType scoref amap m importInst ilty = +let ImportILType scoref amap m importInst ilty = ilty |> rescopeILType scoref |> Import.ImportILType amap m importInst -let CanImportType scoref amap m ilty = +let CanImportILType scoref amap m ilty = ilty |> rescopeILType scoref |> Import.CanImportILType amap m //------------------------------------------------------------------------- @@ -75,7 +74,7 @@ let GetSuperTypeOfType g amap m typ = let _,tinst = destAppTy g typ match tdef.Extends with | None -> None - | Some ilty -> Some (ImportType scoref amap m tinst ilty) + | Some ilty -> Some (ImportILType scoref amap m tinst ilty) | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> @@ -88,6 +87,8 @@ let GetSuperTypeOfType g amap m typ = Some g.obj_ty elif isTupleStructTy g typ then Some g.obj_ty + elif isRecdTy g typ || isUnionTy g typ then + Some g.obj_ty else None @@ -126,7 +127,7 @@ let rec GetImmediateInterfacesOfType skipUnref g amap m typ = #endif | ILTypeMetadata (scoref,tdef) -> - // ImportType may fail for an interface if the assembly load set is incomplete and the interface + // ImportILType may fail for an interface if the assembly load set is incomplete and the interface // comes from another assembly. In this case we simply skip the interface: // if we don't skip it, then compilation will just fail here, and if type checking // succeeds with fewer non-dereferencable interfaces reported then it would have @@ -134,8 +135,8 @@ let rec GetImmediateInterfacesOfType skipUnref g amap m typ = // doesn't apply: e.g. for mscorlib interfaces like IComparable, but we can always // assume those are present. [ for ity in tdef.Implements |> ILList.toList do - if skipUnref = SkipUnrefInterfaces.No || CanImportType scoref amap m ity then - yield ImportType scoref amap m tinst ity ] + if skipUnref = SkipUnrefInterfaces.No || CanImportILType scoref amap m ity then + yield ImportILType scoref amap m tinst ity ] | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> tcref.ImmediateInterfaceTypesOfFSharpTycon |> List.map (instType (mkInstForAppTy g typ)) @@ -277,8 +278,8 @@ let ExistsHeadTypeInEntireHierarchy g amap m typeToSearchFrom tcrefToLookFor = /// Read an Abstract IL type from metadata and convert to an F# type. -let ImportTypeFromMetadata amap m scoref tinst minst ilty = - ImportType scoref amap m (tinst@minst) ilty +let ImportILTypeFromMetadata amap m scoref tinst minst ilty = + ImportILType scoref amap m (tinst@minst) ilty /// Get the return type of an IL method, taking into account instantiations for type and method generic parameters, and @@ -286,7 +287,7 @@ let ImportTypeFromMetadata amap m scoref tinst minst ilty = let ImportReturnTypeFromMetaData amap m ty scoref tinst minst = match ty with | ILType.Void -> None - | retTy -> Some (ImportTypeFromMetadata amap m scoref tinst minst retTy) + | retTy -> Some (ImportILTypeFromMetadata amap m scoref tinst minst retTy) /// Copy constraints. If the constraint comes from a type parameter associated /// with a type constructor then we are simply renaming type variables. If it comes @@ -512,12 +513,20 @@ type OptionalArgInfo = else MissingValue else DefaultValue - CallerSide (analyze (ImportTypeFromMetadata amap m ilScope ilTypeInst [] ilParam.Type)) + CallerSide (analyze (ImportILTypeFromMetadata amap m ilScope ilTypeInst [] ilParam.Type)) | Some v -> CallerSide (Constant v) else NotOptional +type CallerInfoInfo = + | NoCallerInfo + | CallerLineNumber + | CallerMemberName + | CallerFilePath + + override x.ToString() = sprintf "%+A" x + [] type ReflectedArgInfo = | None @@ -540,8 +549,8 @@ type ParamNameAndType = [] /// Full information about a parameter returned for use by the type checker and language service. type ParamData = - /// ParamData(isParamArray, isOut, optArgInfo, nameOpt, reflArgInfo, ttype) - ParamData of bool * bool * OptionalArgInfo * Ident option * ReflectedArgInfo * TType + /// ParamData(isParamArray, isOut, optArgInfo, callerInfoInfo, nameOpt, reflArgInfo, ttype) + ParamData of bool * bool * OptionalArgInfo * CallerInfoInfo * Ident option * ReflectedArgInfo * TType //------------------------------------------------------------------------- @@ -754,17 +763,17 @@ type ILMethInfo = /// Get the argument types of the the IL method. If this is an C#-style extension method /// then drop the object argument. member x.GetParamTypes(amap,m,minst) = - x.ParamMetadata |> List.map (fun p -> ImportTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst p.Type) + x.ParamMetadata |> List.map (fun p -> ImportILTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst p.Type) /// Get all the argument types of the IL method. Include the object argument even if this is /// an C#-style extension method. member x.GetRawArgTypes(amap,m,minst) = - x.RawMetadata.Parameters |> ILList.toList |> List.map (fun p -> ImportTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst p.Type) + x.RawMetadata.Parameters |> ILList.toList |> List.map (fun p -> ImportILTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst p.Type) /// Get info about the arguments of the IL method. If this is an C#-style extension method then /// drop the object argument. member x.GetParamNamesAndTypes(amap,m,minst) = - x.ParamMetadata |> List.map (fun p -> ParamNameAndType(Option.map (mkSynId m) p.Name, ImportTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst p.Type) ) + x.ParamMetadata |> List.map (fun p -> ParamNameAndType(Option.map (mkSynId m) p.Name, ImportILTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst p.Type) ) /// Get a reference to the method (dropping all generic instantiations), as an Abstract IL ILMethodRef. member x.ILMethodRef = @@ -784,7 +793,7 @@ type ILMethInfo = // All C#-style extension methods are instance. We have to re-read the 'obj' type w.r.t. the // method instantiation. if x.IsILExtensionMethod then - [ImportTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst x.RawMetadata.Parameters.Head.Type] + [ImportILTypeFromMetadata amap m x.MetadataScope x.DeclaringTypeInst minst x.RawMetadata.Parameters.Head.Type] else if x.IsInstance then [ x.ApparentEnclosingType ] else @@ -1276,8 +1285,25 @@ type MethInfo = | _ -> ReflectedArgInfo.None let isOutArg = (p.IsOut && not p.IsIn) // Note: we get default argument values from VB and other .NET language metadata - let optArgInfo = OptionalArgInfo.FromILParameter g amap m ilMethInfo.MetadataScope ilMethInfo.DeclaringTypeInst p - yield (isParamArrayArg, isOutArg, optArgInfo, reflArgInfo) ] ] + let optArgInfo = OptionalArgInfo.FromILParameter g amap m ilMethInfo.MetadataScope ilMethInfo.DeclaringTypeInst p + + let isCallerLineNumberArg = TryFindILAttribute g.attrib_CallerLineNumberAttribute p.CustomAttrs + let isCallerFilePathArg = TryFindILAttribute g.attrib_CallerFilePathAttribute p.CustomAttrs + let isCallerMemberNameArg = TryFindILAttribute g.attrib_CallerMemberNameAttribute p.CustomAttrs + + let callerInfoInfo = + match isCallerLineNumberArg, isCallerFilePathArg, isCallerMemberNameArg with + | false, false, false -> NoCallerInfo + | true, false, false -> CallerLineNumber + | false, true, false -> CallerFilePath + | false, false, true -> CallerMemberName + | _, _, _ -> + // if multiple caller info attributes are specified, pick the "wrong" one here + // so that we get an error later + if p.Type.TypeRef.FullName = "System.Int32" then CallerFilePath + else CallerLineNumber + + yield (isParamArrayArg, isOutArg, optArgInfo, callerInfoInfo, reflArgInfo) ] ] | FSMeth(g,_,vref,_) -> GetArgInfosOfMember x.IsCSharpStyleExtensionMember g vref @@ -1291,7 +1317,29 @@ type MethInfo = let isOptArg = HasFSharpAttribute g g.attrib_OptionalArgumentAttribute argInfo.Attribs // Note: can't specify caller-side default arguments in F#, by design (default is specified on the callee-side) let optArgInfo = if isOptArg then CalleeSide else NotOptional - (isParamArrayArg, isOutArg, optArgInfo, reflArgInfo)) + + let isCallerLineNumberArg = HasFSharpAttribute g g.attrib_CallerLineNumberAttribute argInfo.Attribs + let isCallerFilePathArg = HasFSharpAttribute g g.attrib_CallerFilePathAttribute argInfo.Attribs + let isCallerMemberNameArg = HasFSharpAttribute g g.attrib_CallerMemberNameAttribute argInfo.Attribs + + let callerInfoInfo = + match isCallerLineNumberArg, isCallerFilePathArg, isCallerMemberNameArg with + | false, false, false -> NoCallerInfo + | true, false, false -> CallerLineNumber + | false, true, false -> CallerFilePath + | false, false, true -> CallerMemberName + | false, true, true -> match TryFindFSharpAttribute g g.attrib_CallerMemberNameAttribute argInfo.Attribs with + | Some(Attrib(_,_,_,_,_,_,callerMemberNameAttributeRange)) -> warning(Error(FSComp.SR.CallerMemberNameIsOverriden(argInfo.Name.Value.idText), callerMemberNameAttributeRange)) + CallerFilePath + | _ -> failwith "Impossible" + | _, _, _ -> + // if multiple caller info attributes are specified, pick the "wrong" one here + // so that we get an error later + match tryDestOptionTy g ty with + | Some optTy when typeEquiv g g.int32_ty optTy -> CallerFilePath + | _ -> CallerLineNumber + + (isParamArrayArg, isOutArg, optArgInfo, callerInfoInfo, reflArgInfo)) | DefaultStructCtor _ -> [[]] @@ -1307,7 +1355,7 @@ type MethInfo = | Some ([ Some (:? bool as b) ], _) -> ReflectedArgInfo.Quote b | Some _ -> ReflectedArgInfo.Quote false | None -> ReflectedArgInfo.None - yield (isParamArrayArg, p.PUntaint((fun p -> p.IsOut), m), optArgInfo, reflArgInfo)] ] + yield (isParamArrayArg, p.PUntaint((fun p -> p.IsOut), m), optArgInfo, NoCallerInfo, reflArgInfo)] ] #endif @@ -1356,7 +1404,7 @@ type MethInfo = let formalRetTy = ImportReturnTypeFromMetaData amap m ilminfo.RawMetadata.Return.Type ftinfo.ILScopeRef ftinfo.TypeInst formalMethTyparTys let formalParams = [ [ for p in ilminfo.RawMetadata.Parameters do - let paramType = ImportTypeFromMetadata amap m ftinfo.ILScopeRef ftinfo.TypeInst formalMethTyparTys p.Type + let paramType = ImportILTypeFromMetadata amap m ftinfo.ILScopeRef ftinfo.TypeInst formalMethTyparTys p.Type yield TSlotParam(p.Name, paramType, p.IsIn, p.IsOut, p.IsOptional, []) ] ] formalRetTy, formalParams #if EXTENSIONTYPING @@ -1406,8 +1454,8 @@ type MethInfo = #endif let paramAttribs = x.GetParamAttribs(amap, m) - (paramAttribs,paramNamesAndTypes) ||> List.map2 (List.map2 (fun (isParamArrayArg,isOutArg,optArgInfo,reflArgInfo) (ParamNameAndType(nmOpt,pty)) -> - ParamData(isParamArrayArg,isOutArg,optArgInfo,nmOpt,reflArgInfo,pty))) + (paramAttribs,paramNamesAndTypes) ||> List.map2 (List.map2 (fun (isParamArrayArg,isOutArg,optArgInfo,callerInfoInfo,reflArgInfo) (ParamNameAndType(nmOpt,pty)) -> + ParamData(isParamArrayArg,isOutArg,optArgInfo,callerInfoInfo,nmOpt,reflArgInfo,pty))) /// Select all the type parameters of the declaring type of a method. @@ -1534,7 +1582,7 @@ type ILFieldInfo = /// Get the type of the field as an F# type member x.FieldType(amap,m) = match x with - | ILFieldInfo (tinfo,fdef) -> ImportTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] fdef.Type + | ILFieldInfo (tinfo,fdef) -> ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] fdef.Type #if EXTENSIONTYPING | ProvidedField(amap,fi,m) -> Import.ImportProvidedType amap m (fi.PApply((fun fi -> fi.FieldType),m)) #endif @@ -1662,17 +1710,17 @@ type ILPropInfo = /// Get the names and types of the indexer arguments associated with the IL property. member x.GetParamNamesAndTypes(amap,m) = let (ILPropInfo (tinfo,pdef)) = x - pdef.Args |> ILList.toList |> List.map (fun ty -> ParamNameAndType(None, ImportTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] ty) ) + pdef.Args |> ILList.toList |> List.map (fun ty -> ParamNameAndType(None, ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] ty) ) /// Get the types of the indexer arguments associated with the IL property. member x.GetParamTypes(amap,m) = let (ILPropInfo (tinfo,pdef)) = x - pdef.Args |> ILList.toList |> List.map (fun ty -> ImportTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] ty) + pdef.Args |> ILList.toList |> List.map (fun ty -> ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] ty) /// Get the return type of the IL property. member x.GetPropertyType (amap,m) = let (ILPropInfo (tinfo,pdef)) = x - ImportTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] pdef.Type + ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] pdef.Type override x.ToString() = x.ILTypeInfo.ToString() + "::" + x.PropertyName @@ -1932,7 +1980,7 @@ type PropInfo = /// Get the details of the indexer parameters associated with the property member x.GetParamDatas(amap,m) = x.GetParamNamesAndTypes(amap,m) - |> List.map (fun (ParamNameAndType(nmOpt,pty)) -> ParamData(false, false, NotOptional, nmOpt, ReflectedArgInfo.None, pty)) + |> List.map (fun (ParamNameAndType(nmOpt,pty)) -> ParamData(false, false, NotOptional, NoCallerInfo, nmOpt, ReflectedArgInfo.None, pty)) /// Get the types of the indexer parameters associated with the property member x.GetParamTypes(amap,m) = @@ -2171,7 +2219,7 @@ type EventInfo = // Get the delegate type associated with an IL event, taking into account the instantiation of the // declaring type. if isNone edef.Type then error (nonStandardEventError x.EventName m) - ImportTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] edef.Type.Value + ImportILTypeFromMetadata amap m tinfo.ILScopeRef tinfo.TypeInst [] edef.Type.Value | FSEvent(g,p,_,_) -> FindDelegateTypeOfPropertyEvent g amap x.EventName m (p.GetPropertyType(amap,m)) @@ -2265,1613 +2313,3 @@ let PropInfosEquivByNameAndSig erasureFlag g amap m (pinfo:PropInfo) (pinfo2:Pro typeEquivAux erasureFlag g retTy retTy2 -//------------------------------------------------------------------------- -// Basic accessibility logic -//------------------------------------------------------------------------- - -/// Represents the 'keys' a particular piece of code can use to access other constructs?. -[] -type AccessorDomain = - /// AccessibleFrom(cpaths, tyconRefOpt) - /// - /// cpaths: indicates we have the keys to access any members private to the given paths - /// tyconRefOpt: indicates we have the keys to access any protected members of the super types of 'TyconRef' - | AccessibleFrom of CompilationPath list * TyconRef option - - /// An AccessorDomain which returns public items - | AccessibleFromEverywhere - - /// An AccessorDomain which returns everything but .NET private/internal items. - /// This is used - /// - when solving member trait constraints, which are solved independently of accessibility - /// - for failure paths in error reporting, e.g. to produce an error that an F# item is not accessible - /// - an adhoc use in service.fs to look up a delegate signature - | AccessibleFromSomeFSharpCode - - /// An AccessorDomain which returns all items - | AccessibleFromSomewhere - - // Hashing and comparison is used for the memoization tables keyed by an accessor domain. - // It is dependent on a TcGlobals because of the TyconRef in the data structure - static member CustomGetHashCode(ad:AccessorDomain) = - match ad with - | AccessibleFrom _ -> 1 - | AccessibleFromEverywhere -> 2 - | AccessibleFromSomeFSharpCode -> 3 - | AccessibleFromSomewhere -> 4 - static member CustomEquals(g:TcGlobals, ad1:AccessorDomain, ad2:AccessorDomain) = - match ad1, ad2 with - | AccessibleFrom(cs1,tc1), AccessibleFrom(cs2,tc2) -> (cs1 = cs2) && (match tc1,tc2 with None,None -> true | Some tc1, Some tc2 -> tyconRefEq g tc1 tc2 | _ -> false) - | AccessibleFromEverywhere, AccessibleFromEverywhere -> true - | AccessibleFromSomeFSharpCode, AccessibleFromSomeFSharpCode -> true - | AccessibleFromSomewhere, AccessibleFromSomewhere -> true - | _ -> false - -module AccessibilityLogic = - - /// Indicates if an F# item is accessible - let IsAccessible ad taccess = - match ad with - | AccessibleFromEverywhere -> canAccessFromEverywhere taccess - | AccessibleFromSomeFSharpCode -> canAccessFromSomewhere taccess - | AccessibleFromSomewhere -> true - | AccessibleFrom (cpaths,_tcrefViewedFromOption) -> - List.exists (canAccessFrom taccess) cpaths - - /// Indicates if an IL member is accessible (ignoring its enclosing type) - let private IsILMemberAccessible g amap m (tcrefOfViewedItem : TyconRef) ad access = - match ad with - | AccessibleFromEverywhere -> - access = ILMemberAccess.Public - | AccessibleFromSomeFSharpCode -> - (access = ILMemberAccess.Public || - access = ILMemberAccess.Family || - access = ILMemberAccess.FamilyOrAssembly) - | AccessibleFrom (cpaths,tcrefViewedFromOption) -> - let accessibleByFamily = - ((access = ILMemberAccess.Family || - access = ILMemberAccess.FamilyOrAssembly) && - match tcrefViewedFromOption with - | None -> false - | Some tcrefViewedFrom -> - ExistsHeadTypeInEntireHierarchy g amap m (generalizedTyconRef tcrefViewedFrom) tcrefOfViewedItem) - let accessibleByInternalsVisibleTo = - (access = ILMemberAccess.Assembly && canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath) - (access = ILMemberAccess.Public) || accessibleByFamily || accessibleByInternalsVisibleTo - | AccessibleFromSomewhere -> - true - - /// Indicates if tdef is accessible. If tdef.Access = ILTypeDefAccess.Nested then encTyconRefOpt s TyconRef of enclosing type - /// and visibility of tdef is obtained using member access rules - let private IsILTypeDefAccessible (amap : Import.ImportMap) m ad encTyconRefOpt (tdef: ILTypeDef) = - match tdef.Access with - | ILTypeDefAccess.Nested nestedAccess -> - match encTyconRefOpt with - | None -> assert false; true - | Some encTyconRef -> IsILMemberAccessible amap.g amap m encTyconRef ad nestedAccess - | _ -> - match ad with - | AccessibleFromSomewhere -> true - | AccessibleFromEverywhere - | AccessibleFromSomeFSharpCode - | AccessibleFrom _ -> tdef.Access = ILTypeDefAccess.Public - - /// Indicates if a TyconRef is visible through the AccessibleFrom(cpaths,_). - /// Note that InternalsVisibleTo extends those cpaths. - let private IsTyconAccessibleViaVisibleTo ad (tcrefOfViewedItem:TyconRef) = - match ad with - | AccessibleFromEverywhere - | AccessibleFromSomewhere - | AccessibleFromSomeFSharpCode -> false - | AccessibleFrom (cpaths,_tcrefViewedFromOption) -> - canAccessFromOneOf cpaths tcrefOfViewedItem.CompilationPath - - /// Indicates if given IL based TyconRef is accessible. If TyconRef is nested then we'll - /// walk though the list of enclosing types and test if all of them are accessible - let private IsILTypeInfoAccessible amap m ad (tcrefOfViewedItem : TyconRef) = - let scoref, enc, tdef = tcrefOfViewedItem.ILTyconInfo - let rec check parentTycon path = - let ilTypeDefAccessible = - match parentTycon with - | None -> - match path with - | [] -> assert false; true // in this case path should have at least one element - | [x] -> IsILTypeDefAccessible amap m ad None x // shortcut for non-nested types - | x::xs -> - // check if enclosing type x is accessible. - // if yes - create parent tycon for type 'x' and continue with the rest of the path - IsILTypeDefAccessible amap m ad None x && - ( - let parentILTyRef = mkRefForNestedILTypeDef scoref ([], x) - let parentTycon = Import.ImportILTypeRef amap m parentILTyRef - check (Some (parentTycon, [x])) xs - ) - | (Some (parentTycon, parentPath)) -> - match path with - | [] -> true // end of path is reached - success - | x::xs -> - // check if x is accessible from the parent tycon - // if yes - create parent tycon for type 'x' and continue with the rest of the path - IsILTypeDefAccessible amap m ad (Some parentTycon) x && - ( - let parentILTyRef = mkRefForNestedILTypeDef scoref (parentPath, x) - let parentTycon = Import.ImportILTypeRef amap m parentILTyRef - check (Some (parentTycon, parentPath @ [x])) xs - ) - ilTypeDefAccessible || IsTyconAccessibleViaVisibleTo ad tcrefOfViewedItem - - check None (enc @ [tdef]) - - /// Indicates if an IL member associated with the given ILType is accessible - let private IsILTypeAndMemberAccessible g amap m adType ad (ILTypeInfo(tcrefOfViewedItem, _, _, _)) access = - IsILTypeInfoAccessible amap m adType tcrefOfViewedItem && IsILMemberAccessible g amap m tcrefOfViewedItem ad access - - /// Indicates if an entity is accessible - let IsEntityAccessible amap m ad (tcref:TyconRef) = - if tcref.IsILTycon then - IsILTypeInfoAccessible amap m ad tcref - else - tcref.Accessibility |> IsAccessible ad - - /// Check that an entity is accessible - let CheckTyconAccessible amap m ad tcref = - let res = IsEntityAccessible amap m ad tcref - if not res then - errorR(Error(FSComp.SR.typeIsNotAccessible tcref.DisplayName,m)) - res - - /// Indicates if a type definition and its representation contents are accessible - let IsTyconReprAccessible amap m ad tcref = - IsEntityAccessible amap m ad tcref && - IsAccessible ad tcref.TypeReprAccessibility - - /// Check that a type definition and its representation contents are accessible - let CheckTyconReprAccessible amap m ad tcref = - CheckTyconAccessible amap m ad tcref && - (let res = IsAccessible ad tcref.TypeReprAccessibility - if not res then - errorR (Error (FSComp.SR.unionCasesAreNotAccessible tcref.DisplayName,m)) - res) - - /// Indicates if a type is accessible (both definition and instantiation) - let rec IsTypeAccessible g amap m ad ty = - not (isAppTy g ty) || - let tcref,tinst = destAppTy g ty - IsEntityAccessible amap m ad tcref && IsTypeInstAccessible g amap m ad tinst - - and IsTypeInstAccessible g amap m ad tinst = - match tinst with - | [] -> true - | _ -> List.forall (IsTypeAccessible g amap m ad) tinst - - /// Indicate if a provided member is accessible - let IsProvidedMemberAccessible (amap:Import.ImportMap) m ad ty access = - let g = amap.g - let isTyAccessible = IsTypeAccessible g amap m ad ty - if not isTyAccessible then false - else - not (isAppTy g ty) || - let tcrefOfViewedItem,_ = destAppTy g ty - IsILMemberAccessible g amap m tcrefOfViewedItem ad access - - /// Compute the accessibility of a provided member - let ComputeILAccess isPublic isFamily isFamilyOrAssembly isFamilyAndAssembly = - if isPublic then ILMemberAccess.Public - elif isFamily then ILMemberAccess.Family - elif isFamilyOrAssembly then ILMemberAccess.FamilyOrAssembly - elif isFamilyAndAssembly then ILMemberAccess.FamilyAndAssembly - else ILMemberAccess.Private - - /// IndiCompute the accessibility of a provided member - let IsILFieldInfoAccessible g amap m ad x = - match x with - | ILFieldInfo (tinfo,fd) -> IsILTypeAndMemberAccessible g amap m ad ad tinfo fd.Access -#if EXTENSIONTYPING - | ProvidedField (amap, tpfi, m) as pfi -> - let access = tpfi.PUntaint((fun fi -> ComputeILAccess fi.IsPublic fi.IsFamily fi.IsFamilyOrAssembly fi.IsFamilyAndAssembly), m) - IsProvidedMemberAccessible amap m ad pfi.EnclosingType access -#endif - - let GetILAccessOfILEventInfo (ILEventInfo (tinfo,edef)) = - (resolveILMethodRef tinfo.RawMetadata edef.AddMethod).Access - - let IsILEventInfoAccessible g amap m ad einfo = - let access = GetILAccessOfILEventInfo einfo - IsILTypeAndMemberAccessible g amap m ad ad einfo.ILTypeInfo access - - let private IsILMethInfoAccessible g amap m adType ad ilminfo = - match ilminfo with - | ILMethInfo (_,typ,None,mdef,_) -> IsILTypeAndMemberAccessible g amap m adType ad (ILTypeInfo.FromType g typ) mdef.Access - | ILMethInfo (_,_,Some declaringTyconRef,mdef,_) -> IsILMemberAccessible g amap m declaringTyconRef ad mdef.Access - - let GetILAccessOfILPropInfo (ILPropInfo(tinfo,pdef)) = - let tdef = tinfo.RawMetadata - let ilAccess = - match pdef.GetMethod with - | Some mref -> (resolveILMethodRef tdef mref).Access - | None -> - match pdef.SetMethod with - | None -> ILMemberAccess.Public - | Some mref -> (resolveILMethodRef tdef mref).Access - ilAccess - - let IsILPropInfoAccessible g amap m ad pinfo = - let ilAccess = GetILAccessOfILPropInfo pinfo - IsILTypeAndMemberAccessible g amap m ad ad pinfo.ILTypeInfo ilAccess - - let IsValAccessible ad (vref:ValRef) = - vref.Accessibility |> IsAccessible ad - - let CheckValAccessible m ad (vref:ValRef) = - if not (IsValAccessible ad vref) then - errorR (Error (FSComp.SR.valueIsNotAccessible vref.DisplayName,m)) - - let IsUnionCaseAccessible amap m ad (ucref:UnionCaseRef) = - IsTyconReprAccessible amap m ad ucref.TyconRef && - IsAccessible ad ucref.UnionCase.Accessibility - - let CheckUnionCaseAccessible amap m ad (ucref:UnionCaseRef) = - CheckTyconReprAccessible amap m ad ucref.TyconRef && - (let res = IsAccessible ad ucref.UnionCase.Accessibility - if not res then - errorR (Error (FSComp.SR.unionCaseIsNotAccessible ucref.CaseName,m)) - res) - - let IsRecdFieldAccessible amap m ad (rfref:RecdFieldRef) = - IsTyconReprAccessible amap m ad rfref.TyconRef && - IsAccessible ad rfref.RecdField.Accessibility - - let CheckRecdFieldAccessible amap m ad (rfref:RecdFieldRef) = - CheckTyconReprAccessible amap m ad rfref.TyconRef && - (let res = IsAccessible ad rfref.RecdField.Accessibility - if not res then - errorR (Error (FSComp.SR.fieldIsNotAccessible rfref.FieldName,m)) - res) - - let CheckRecdFieldInfoAccessible amap m ad (rfinfo:RecdFieldInfo) = - CheckRecdFieldAccessible amap m ad rfinfo.RecdFieldRef |> ignore - - let CheckILFieldInfoAccessible g amap m ad finfo = - if not (IsILFieldInfoAccessible g amap m ad finfo) then - errorR (Error (FSComp.SR.structOrClassFieldIsNotAccessible finfo.FieldName,m)) - - /// Uses a separate accessibility domains for containing type and method itself - /// This makes sense cases like - /// type A() = - /// type protected B() = - /// member this.Public() = () - /// member protected this.Protected() = () - /// type C() = - /// inherit A() - /// let x = A.B() - /// do x.Public() - /// when calling x.SomeMethod() we need to use 'adTyp' do verify that type of x is accessible from C - /// and 'ad' to determine accessibility of SomeMethod. - /// I.e when calling x.Public() and x.Protected() -in both cases first check should succeed and second - should fail in the latter one. - let IsTypeAndMethInfoAccessible amap m adTyp ad = function - | ILMeth (g,x,_) -> IsILMethInfoAccessible g amap m adTyp ad x - | FSMeth (_,_,vref,_) -> IsValAccessible ad vref - | DefaultStructCtor(g,typ) -> IsTypeAccessible g amap m ad typ -#if EXTENSIONTYPING - | ProvidedMeth(amap,tpmb,_,m) as etmi -> - let access = tpmb.PUntaint((fun mi -> ComputeILAccess mi.IsPublic mi.IsFamily mi.IsFamilyOrAssembly mi.IsFamilyAndAssembly), m) - IsProvidedMemberAccessible amap m ad etmi.EnclosingType access -#endif - let IsMethInfoAccessible amap m ad minfo = IsTypeAndMethInfoAccessible amap m ad ad minfo - - let IsPropInfoAccessible g amap m ad = function - | ILProp (_,x) -> IsILPropInfoAccessible g amap m ad x - | FSProp (_,_,Some vref,_) - | FSProp (_,_,_,Some vref) -> IsValAccessible ad vref -#if EXTENSIONTYPING - | ProvidedProp (amap, tppi, m) as pp-> - let access = - let a = tppi.PUntaint((fun ppi -> - let tryGetILAccessForProvidedMethodBase (mi : ProvidedMethodBase) = - match mi with - | null -> None - | mi -> Some(ComputeILAccess mi.IsPublic mi.IsFamily mi.IsFamilyOrAssembly mi.IsFamilyAndAssembly) - match tryGetILAccessForProvidedMethodBase(ppi.GetGetMethod()) with - | None -> tryGetILAccessForProvidedMethodBase(ppi.GetSetMethod()) - | x -> x), m) - defaultArg a ILMemberAccess.Public - IsProvidedMemberAccessible amap m ad pp.EnclosingType access -#endif - | _ -> false - - let IsFieldInfoAccessible ad (rfref:RecdFieldInfo) = - IsAccessible ad rfref.RecdField.Accessibility - -open AccessibilityLogic - - - -//------------------------------------------------------------------------- -// Check custom attributes -//------------------------------------------------------------------------- - -exception ObsoleteWarning of string * range -exception ObsoleteError of string * range - -let fail() = failwith "This custom attribute has an argument that can not yet be converted using this API" - -let rec evalILAttribElem e = - match e with - | ILAttribElem.String (Some x) -> box x - | ILAttribElem.String None -> null - | ILAttribElem.Bool x -> box x - | ILAttribElem.Char x -> box x - | ILAttribElem.SByte x -> box x - | ILAttribElem.Int16 x -> box x - | ILAttribElem.Int32 x -> box x - | ILAttribElem.Int64 x -> box x - | ILAttribElem.Byte x -> box x - | ILAttribElem.UInt16 x -> box x - | ILAttribElem.UInt32 x -> box x - | ILAttribElem.UInt64 x -> box x - | ILAttribElem.Single x -> box x - | ILAttribElem.Double x -> box x - | ILAttribElem.Null -> null - | ILAttribElem.Array (_, a) -> box [| for i in a -> evalILAttribElem i |] - // TODO: typeof<..> in attribute values - | ILAttribElem.Type (Some _t) -> fail() - | ILAttribElem.Type None -> null - | ILAttribElem.TypeRef (Some _t) -> fail() - | ILAttribElem.TypeRef None -> null - -let rec evalFSharpAttribArg g e = - match e with - | Expr.Const(c,_,_) -> - match c with - | Const.Bool b -> box b - | Const.SByte i -> box i - | Const.Int16 i -> box i - | Const.Int32 i -> box i - | Const.Int64 i -> box i - | Const.Byte i -> box i - | Const.UInt16 i -> box i - | Const.UInt32 i -> box i - | Const.UInt64 i -> box i - | Const.Single i -> box i - | Const.Double i -> box i - | Const.Char i -> box i - | Const.Zero -> null - | Const.String s -> box s - | _ -> fail() - | Expr.Op (TOp.Array,_,a,_) -> box [| for i in a -> evalFSharpAttribArg g i |] - | TypeOfExpr g ty -> box ty - // TODO: | TypeDefOfExpr g ty - | _ -> fail() - -type AttribInfo = - | FSAttribInfo of TcGlobals * Attrib - | ILAttribInfo of TcGlobals * Import.ImportMap * ILScopeRef * ILAttribute * range - - member x.TyconRef = - match x with - | FSAttribInfo(_g,Attrib(tcref,_,_,_,_,_,_)) -> tcref - | ILAttribInfo (g, amap, scoref, a, m) -> - let ty = ImportType scoref amap m [] a.Method.EnclosingType - tcrefOfAppTy g ty - - member x.ConstructorArguments = - match x with - | FSAttribInfo(g,Attrib(_,_,unnamedArgs,_,_,_,_)) -> - unnamedArgs - |> List.map (fun (AttribExpr(origExpr,evaluatedExpr)) -> - let ty = tyOfExpr g origExpr - let obj = evalFSharpAttribArg g evaluatedExpr - ty,obj) - | ILAttribInfo (g, amap, scoref, cattr, m) -> - let parms, _args = decodeILAttribData g.ilg cattr - [ for (argty,argval) in Seq.zip cattr.Method.FormalArgTypes parms -> - let ty = ImportType scoref amap m [] argty - let obj = evalILAttribElem argval - ty,obj ] - - member x.NamedArguments = - match x with - | FSAttribInfo(g,Attrib(_,_,_,namedArgs,_,_,_)) -> - namedArgs - |> List.map (fun (AttribNamedArg(nm,_,isField,AttribExpr(origExpr,evaluatedExpr))) -> - let ty = tyOfExpr g origExpr - let obj = evalFSharpAttribArg g evaluatedExpr - ty, nm, isField, obj) - | ILAttribInfo (g, amap, scoref, cattr, m) -> - let _parms, namedArgs = decodeILAttribData g.ilg cattr - [ for (nm, argty, isProp, argval) in namedArgs -> - let ty = ImportType scoref amap m [] argty - let obj = evalILAttribElem argval - let isField = not isProp - ty, nm, isField, obj ] - - -/// Check custom attributes. This is particularly messy because custom attributes come in in three different -/// formats. -module AttributeChecking = - - let AttribInfosOfIL g amap scoref m (attribs: ILAttributes) = - attribs.AsList |> List.map (fun a -> ILAttribInfo (g, amap, scoref, a, m)) - - let AttribInfosOfFS g attribs = - attribs |> List.map (fun a -> FSAttribInfo (g, a)) - - let GetAttribInfosOfEntity g amap m (tcref:TyconRef) = - match metadataOfTycon tcref.Deref with -#if EXTENSIONTYPING - // TODO: provided attributes - | ProvidedTypeMetadata _info -> [] - //let provAttribs = info.ProvidedType.PApply((fun a -> (a :> IProvidedCustomAttributeProvider)),m) - //match provAttribs.PUntaint((fun a -> a. .GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), atref.FullName)),m) with - //| Some args -> f3 args - //| None -> None -#endif - | ILTypeMetadata (scoref,tdef) -> - tdef.CustomAttrs |> AttribInfosOfIL g amap scoref m - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - tcref.Attribs |> List.map (fun a -> FSAttribInfo (g, a)) - - - let GetAttribInfosOfMethod amap m minfo = - match minfo with - | ILMeth (g,ilminfo,_) -> ilminfo.RawMetadata.CustomAttrs |> AttribInfosOfIL g amap ilminfo.MetadataScope m - | FSMeth (g,_,vref,_) -> vref.Attribs |> AttribInfosOfFS g - | DefaultStructCtor _ -> [] -#if EXTENSIONTYPING - // TODO: provided attributes - | ProvidedMeth (_,_mi,_,_m) -> - [] - -#endif - - let GetAttribInfosOfProp amap m pinfo = - match pinfo with - | ILProp(g,ilpinfo) -> ilpinfo.RawMetadata.CustomAttrs |> AttribInfosOfIL g amap ilpinfo.ILTypeInfo.ILScopeRef m - | FSProp(g,_,Some vref,_) - | FSProp(g,_,_,Some vref) -> vref.Attribs |> AttribInfosOfFS g - | FSProp _ -> failwith "GetAttribInfosOfProp: unreachable" -#if EXTENSIONTYPING - // TODO: provided attributes - | ProvidedProp _ -> [] -#endif - - let GetAttribInfosOfEvent amap m einfo = - match einfo with - | ILEvent(g, x) -> x.RawMetadata.CustomAttrs |> AttribInfosOfIL g amap x.ILTypeInfo.ILScopeRef m - | FSEvent(_, pi, _vref1, _vref2) -> GetAttribInfosOfProp amap m pi -#if EXTENSIONTYPING - // TODO: provided attributes - | ProvidedEvent _ -> [] -#endif - - /// Analyze three cases for attributes declared on type definitions: IL-declared attributes, F#-declared attributes and - /// provided attributes. - // - // This is used for AttributeUsageAttribute, DefaultMemberAttribute and ConditionalAttribute (on attribute types) - let TryBindTyconRefAttribute g m (AttribInfo (atref,_) as args) (tcref:TyconRef) f1 f2 f3 = - ignore m; ignore f3 - match metadataOfTycon tcref.Deref with -#if EXTENSIONTYPING - | ProvidedTypeMetadata info -> - let provAttribs = info.ProvidedType.PApply((fun a -> (a :> IProvidedCustomAttributeProvider)),m) - match provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), atref.FullName)),m) with - | Some args -> f3 args - | None -> None -#endif - | ILTypeMetadata (_,tdef) -> - match TryDecodeILAttribute g atref tdef.CustomAttrs with - | Some attr -> f1 attr - | _ -> None - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - match TryFindFSharpAttribute g args tcref.Attribs with - | Some attr -> f2 attr - | _ -> None - - /// Analyze three cases for attributes declared on methods: IL-declared attributes, F#-declared attributes and - /// provided attributes. - let BindMethInfoAttributes m minfo f1 f2 f3 = - ignore m; ignore f3 - match minfo with - | ILMeth (_,x,_) -> f1 x.RawMetadata.CustomAttrs - | FSMeth (_,_,vref,_) -> f2 vref.Attribs - | DefaultStructCtor _ -> f2 [] -#if EXTENSIONTYPING - | ProvidedMeth (_,mi,_,_) -> f3 (mi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) -#endif - - /// Analyze three cases for attributes declared on methods: IL-declared attributes, F#-declared attributes and - /// provided attributes. - let TryBindMethInfoAttribute g m (AttribInfo(atref,_) as attribSpec) minfo f1 f2 f3 = -#if EXTENSIONTYPING -#else - // to prevent unused parameter warning - ignore f3 -#endif - BindMethInfoAttributes m minfo - (fun ilAttribs -> TryDecodeILAttribute g atref ilAttribs |> Option.bind f1) - (fun fsAttribs -> TryFindFSharpAttribute g attribSpec fsAttribs |> Option.bind f2) -#if EXTENSIONTYPING - (fun provAttribs -> - match provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), atref.FullName)),m) with - | Some args -> f3 args - | None -> None) -#else - (fun _provAttribs -> None) -#endif - - /// Try to find a specific attribute on a method, where the attribute accepts a string argument. - /// - /// This is just used for the 'ConditionalAttribute' attribute - let TryFindMethInfoStringAttribute g m attribSpec minfo = - TryBindMethInfoAttribute g m attribSpec minfo - (function ([ILAttribElem.String (Some msg) ],_) -> Some msg | _ -> None) - (function (Attrib(_,_,[ AttribStringArg msg ],_,_,_,_)) -> Some msg | _ -> None) - (function ([ Some ((:? string as msg) : obj) ],_) -> Some msg | _ -> None) - - /// Check if a method has a specific attribute. - let MethInfoHasAttribute g m attribSpec minfo = - TryBindMethInfoAttribute g m attribSpec minfo - (fun _ -> Some ()) - (fun _ -> Some ()) - (fun _ -> Some ()) - |> Option.isSome - - - - /// Check IL attributes for 'ObsoleteAttribute', returning errors and warnings as data - let private CheckILAttributes g cattrs m = - let (AttribInfo(tref,_)) = g.attrib_SystemObsolete - match TryDecodeILAttribute g tref cattrs with - | Some ([ILAttribElem.String (Some msg) ],_) -> - WarnD(ObsoleteWarning(msg,m)) - | Some ([ILAttribElem.String (Some msg); ILAttribElem.Bool isError ],_) -> - if isError then - ErrorD (ObsoleteError(msg,m)) - else - WarnD (ObsoleteWarning(msg,m)) - | Some ([ILAttribElem.String None ],_) -> - WarnD(ObsoleteWarning("",m)) - | Some _ -> - WarnD(ObsoleteWarning("",m)) - | None -> - CompleteD - - /// Check F# attributes for 'ObsoleteAttribute', 'CompilerMessageAttribute' and 'ExperimentalAttribute', - /// returning errors and warnings as data - let CheckFSharpAttributes g attribs m = - if isNil attribs then CompleteD - else - (match TryFindFSharpAttribute g g.attrib_SystemObsolete attribs with - | Some(Attrib(_,_,[ AttribStringArg s ],_,_,_,_)) -> - WarnD(ObsoleteWarning(s,m)) - | Some(Attrib(_,_,[ AttribStringArg s; AttribBoolArg(isError) ],_,_,_,_)) -> - if isError then - ErrorD (ObsoleteError(s,m)) - else - WarnD (ObsoleteWarning(s,m)) - | Some _ -> - WarnD(ObsoleteWarning("", m)) - | None -> - CompleteD - ) ++ (fun () -> - - match TryFindFSharpAttribute g g.attrib_CompilerMessageAttribute attribs with - | Some(Attrib(_,_,[ AttribStringArg s ; AttribInt32Arg n ],namedArgs,_,_,_)) -> - let msg = UserCompilerMessage(s,n,m) - let isError = - match namedArgs with - | ExtractAttribNamedArg "IsError" (AttribBoolArg v) -> v - | _ -> false - if isError then ErrorD msg else WarnD msg - - | _ -> - CompleteD - ) ++ (fun () -> - - match TryFindFSharpAttribute g g.attrib_ExperimentalAttribute attribs with - | Some(Attrib(_,_,[ AttribStringArg(s) ],_,_,_,_)) -> - WarnD(Experimental(s,m)) - | Some _ -> - WarnD(Experimental(FSComp.SR.experimentalConstruct (), m)) - | _ -> - CompleteD - ) ++ (fun () -> - - match TryFindFSharpAttribute g g.attrib_UnverifiableAttribute attribs with - | Some _ -> - WarnD(PossibleUnverifiableCode(m)) - | _ -> - CompleteD - ) - -#if EXTENSIONTYPING - /// Check a list of provided attributes for 'ObsoleteAttribute', returning errors and warnings as data - let private CheckProvidedAttributes g m (provAttribs: Tainted) = - let (AttribInfo(tref,_)) = g.attrib_SystemObsolete - match provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), tref.FullName)),m) with - | Some ([ Some (:? string as msg) ], _) -> WarnD(ObsoleteWarning(msg,m)) - | Some ([ Some (:? string as msg); Some (:?bool as isError) ], _) -> - if isError then - ErrorD (ObsoleteError(msg,m)) - else - WarnD (ObsoleteWarning(msg,m)) - | Some ([ None ], _) -> - WarnD(ObsoleteWarning("",m)) - | Some _ -> - WarnD(ObsoleteWarning("",m)) - | None -> - CompleteD -#endif - - /// Indicate if a list of IL attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. - let CheckILAttributesForUnseen g cattrs _m = - let (AttribInfo(tref,_)) = g.attrib_SystemObsolete - isSome (TryDecodeILAttribute g tref cattrs) - - /// Checks the attributes for CompilerMessageAttribute, which has an IsHidden argument that allows - /// items to be suppressed from intellisense. - let CheckFSharpAttributesForHidden g attribs = - nonNil attribs && - (match TryFindFSharpAttribute g g.attrib_CompilerMessageAttribute attribs with - | Some(Attrib(_,_,[AttribStringArg _; AttribInt32Arg messageNumber], - ExtractAttribNamedArg "IsHidden" (AttribBoolArg v),_,_,_)) -> - // Message number 62 is for "ML Compatibility". Items labelled with this are visible in intellisense - // when mlCompatibility is set. - v && not (messageNumber = 62 && g.mlCompatibility) - | _ -> false) - - /// Indicate if a list of F# attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. - let CheckFSharpAttributesForObsolete g attribs = - nonNil attribs && (HasFSharpAttribute g g.attrib_SystemObsolete attribs) - - /// Indicate if a list of F# attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. - /// Also check the attributes for CompilerMessageAttribute, which has an IsHidden argument that allows - /// items to be suppressed from intellisense. - let CheckFSharpAttributesForUnseen g attribs _m = - nonNil attribs && - (CheckFSharpAttributesForObsolete g attribs || - CheckFSharpAttributesForHidden g attribs) - -#if EXTENSIONTYPING - /// Indicate if a list of provided attributes contains 'ObsoleteAttribute'. Used to suppress the item in intellisense. - let CheckProvidedAttributesForUnseen (provAttribs: Tainted) m = - provAttribs.PUntaint((fun a -> a.GetAttributeConstructorArgs(provAttribs.TypeProvider.PUntaintNoFailure(id), typeof.FullName).IsSome),m) -#endif - - /// Check the attributes associated with a property, returning warnings and errors as data. - let CheckPropInfoAttributes pinfo m = - match pinfo with - | ILProp(g,ILPropInfo(_,pdef)) -> CheckILAttributes g pdef.CustomAttrs m - | FSProp(g,_,Some vref,_) - | FSProp(g,_,_,Some vref) -> CheckFSharpAttributes g vref.Attribs m - | FSProp _ -> failwith "CheckPropInfoAttributes: unreachable" -#if EXTENSIONTYPING - | ProvidedProp (amap,pi,m) -> - CheckProvidedAttributes amap.g m (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) - -#endif - - - /// Check the attributes associated with a IL field, returning warnings and errors as data. - let CheckILFieldAttributes g (finfo:ILFieldInfo) m = - match finfo with - | ILFieldInfo(_,pd) -> - CheckILAttributes g pd.CustomAttrs m |> CommitOperationResult -#if EXTENSIONTYPING - | ProvidedField (amap,fi,m) -> - CheckProvidedAttributes amap.g m (fi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) |> CommitOperationResult -#endif - - /// Check the attributes associated with a method, returning warnings and errors as data. - let CheckMethInfoAttributes g m tyargsOpt minfo = - let search = - BindMethInfoAttributes m minfo - (fun ilAttribs -> Some(CheckILAttributes g ilAttribs m)) - (fun fsAttribs -> - let res = - CheckFSharpAttributes g fsAttribs m ++ (fun () -> - if isNone tyargsOpt && HasFSharpAttribute g g.attrib_RequiresExplicitTypeArgumentsAttribute fsAttribs then - ErrorD(Error(FSComp.SR.tcFunctionRequiresExplicitTypeArguments(minfo.LogicalName),m)) - else - CompleteD) - Some res) -#if EXTENSIONTYPING - (fun provAttribs -> Some (CheckProvidedAttributes g m provAttribs)) -#else - (fun _provAttribs -> None) -#endif - match search with - | Some res -> res - | None -> CompleteD // no attribute = no errors - - /// Indicate if a method has 'Obsolete', 'CompilerMessageAttribute' or 'TypeProviderEditorHideMethodsAttribute'. - /// Used to suppress the item in intellisense. - let MethInfoIsUnseen g m typ minfo = - let isUnseenByObsoleteAttrib = - match BindMethInfoAttributes m minfo - (fun ilAttribs -> Some(CheckILAttributesForUnseen g ilAttribs m)) - (fun fsAttribs -> Some(CheckFSharpAttributesForUnseen g fsAttribs m)) -#if EXTENSIONTYPING - (fun provAttribs -> Some(CheckProvidedAttributesForUnseen provAttribs m)) -#else - (fun _provAttribs -> None) -#endif - with - | Some res -> res - | None -> false - - let isUnseenByHidingAttribute = -#if EXTENSIONTYPING - not (isObjTy g typ) && - isAppTy g typ && - isObjTy g minfo.EnclosingType && - let tcref = tcrefOfAppTy g typ - match tcref.TypeReprInfo with - | TProvidedTypeExtensionPoint info -> - info.ProvidedType.PUntaint((fun st -> (st :> IProvidedCustomAttributeProvider).GetHasTypeProviderEditorHideMethodsAttribute(info.ProvidedType.TypeProvider.PUntaintNoFailure(id))), m) - | _ -> - // This attribute check is done by name to ensure compilation doesn't take a dependency - // on Microsoft.FSharp.Core.CompilerServices.TypeProviderEditorHideMethodsAttribute. - // - // We are only interested in filtering out the method on System.Object, so it is sufficient - // just to look at the attributes on IL methods. - if tcref.IsILTycon then - tcref.ILTyconRawMetadata.CustomAttrs.AsList - |> List.exists (fun attr -> attr.Method.EnclosingType.TypeSpec.Name = typeof.FullName) - else - false -#else - typ |> ignore - false -#endif - isUnseenByObsoleteAttrib || isUnseenByHidingAttribute - - /// Indicate if a property has 'Obsolete' or 'CompilerMessageAttribute'. - /// Used to suppress the item in intellisense. - let PropInfoIsUnseen m pinfo = - match pinfo with - | ILProp (g,ILPropInfo(_,pdef)) -> CheckILAttributesForUnseen g pdef.CustomAttrs m - | FSProp (g,_,Some vref,_) - | FSProp (g,_,_,Some vref) -> CheckFSharpAttributesForUnseen g vref.Attribs m - | FSProp _ -> failwith "CheckPropInfoAttributes: unreachable" -#if EXTENSIONTYPING - | ProvidedProp (_amap,pi,m) -> - CheckProvidedAttributesForUnseen (pi.PApply((fun st -> (st :> IProvidedCustomAttributeProvider)),m)) m -#endif - - /// Check the attributes on an entity, returning errors and warnings as data. - let CheckEntityAttributes g (x:TyconRef) m = - if x.IsILTycon then - CheckILAttributes g x.ILTyconRawMetadata.CustomAttrs m - else - CheckFSharpAttributes g x.Attribs m - - /// Check the attributes on a union case, returning errors and warnings as data. - let CheckUnionCaseAttributes g (x:UnionCaseRef) m = - CheckEntityAttributes g x.TyconRef m ++ (fun () -> - CheckFSharpAttributes g x.Attribs m) - - /// Check the attributes on a record field, returning errors and warnings as data. - let CheckRecdFieldAttributes g (x:RecdFieldRef) m = - CheckEntityAttributes g x.TyconRef m ++ (fun () -> - CheckFSharpAttributes g x.PropertyAttribs m) - - /// Check the attributes on an F# value, returning errors and warnings as data. - let CheckValAttributes g (x:ValRef) m = - CheckFSharpAttributes g x.Attribs m - - /// Check the attributes on a record field, returning errors and warnings as data. - let CheckRecdFieldInfoAttributes g (x:RecdFieldInfo) m = - CheckRecdFieldAttributes g x.RecdFieldRef m - - -open AttributeChecking - -//------------------------------------------------------------------------- -// Build calls -//------------------------------------------------------------------------- - - -/// Build an expression node that is a call to a .NET method. -let BuildILMethInfoCall g amap m isProp (minfo:ILMethInfo) valUseFlags minst direct args = - let valu = isStructTy g minfo.ApparentEnclosingType - let ctor = minfo.IsConstructor - if minfo.IsClassConstructor then - error (InternalError (minfo.ILName+": cannot call a class constructor",m)) - let useCallvirt = - not valu && not direct && minfo.IsVirtual - let isProtected = minfo.IsProtectedAccessibility - let ilMethRef = minfo.ILMethodRef - let newobj = ctor && (match valUseFlags with NormalValUse -> true | _ -> false) - let exprTy = if ctor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnTy(amap, m, minst) - let retTy = (if not ctor && (ilMethRef.ReturnType = ILType.Void) then [] else [exprTy]) - let isDllImport = minfo.IsDllImport g - Expr.Op(TOp.ILCall(useCallvirt,isProtected,valu,newobj,valUseFlags,isProp,isDllImport,ilMethRef,minfo.DeclaringTypeInst,minst,retTy),[],args,m), - exprTy - -/// Build a call to the System.Object constructor taking no arguments, -let BuildObjCtorCall g m = - let ilMethRef = (mkILCtorMethSpecForTy(g.ilg.typ_Object,[])).MethodRef - Expr.Op(TOp.ILCall(false,false,false,false,CtorValUsedAsSuperInit,false,true,ilMethRef,[],[],[g.obj_ty]),[],[],m) - - -/// Build a call to an F# method. -/// -/// Consume the arguments in chunks and build applications. This copes with various F# calling signatures -/// all of which ultimately become 'methods'. -/// -/// QUERY: this looks overly complex considering that we are doing a fundamentally simple -/// thing here. -let BuildFSharpMethodApp g m (vref: ValRef) vexp vexprty (args: Exprs) = - let arities = (arityOfVal vref.Deref).AritiesOfArgs - - let args3,(leftover,retTy) = - ((args,vexprty), arities) ||> List.mapFold (fun (args,fty) arity -> - match arity,args with - | (0|1),[] when typeEquiv g (domainOfFunTy g fty) g.unit_ty -> mkUnit g m, (args, rangeOfFunTy g fty) - | 0,(arg::argst)-> - warning(InternalError(sprintf "Unexpected zero arity, args = %s" (Layout.showL (Layout.sepListL (Layout.rightL ";") (List.map exprL args))),m)); - arg, (argst, rangeOfFunTy g fty) - | 1,(arg :: argst) -> arg, (argst, rangeOfFunTy g fty) - | 1,[] -> error(InternalError("expected additional arguments here",m)) - | _ -> - if args.Length < arity then error(InternalError("internal error in getting arguments, n = "+string arity+", #args = "+string args.Length,m)); - let tupargs,argst = List.chop arity args - let tuptys = tupargs |> List.map (tyOfExpr g) - (mkTupled g m tupargs tuptys), - (argst, rangeOfFunTy g fty) ) - if not leftover.IsEmpty then error(InternalError("Unexpected "+string(leftover.Length)+" remaining arguments in method application",m)) - mkApps g ((vexp,vexprty),[],args3,m), - retTy - -/// Build a call to an F# method. -let BuildFSharpMethodCall g m (typ,vref:ValRef) valUseFlags minst args = - let vexp = Expr.Val (vref,valUseFlags,m) - let vexpty = vref.Type - let tpsorig,tau = vref.TypeScheme - let vtinst = argsOfAppTy g typ @ minst - if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected List.length mismatch",m)) - let expr = mkTyAppExpr m (vexp,vexpty) vtinst - let exprty = instType (mkTyparInst tpsorig vtinst) tau - BuildFSharpMethodApp g m vref expr exprty args - - -/// Make a call to a method info. Used by the optimizer and code generator to build -/// calls to the type-directed solutions to member constraints. -let MakeMethInfoCall amap m minfo minst args = - let valUseFlags = NormalValUse // correct unless if we allow wild trait constraints like "T has a ctor and can be used as a parent class" - match minfo with - | ILMeth(g,ilminfo,_) -> - let direct = not minfo.IsVirtual - let isProp = false // not necessarily correct, but this is only used post-creflect where this flag is irrelevant - BuildILMethInfoCall g amap m isProp ilminfo valUseFlags minst direct args |> fst - | FSMeth(g,typ,vref,_) -> - BuildFSharpMethodCall g m (typ,vref) valUseFlags minst args |> fst - | DefaultStructCtor(_,typ) -> - mkDefault (m,typ) -#if EXTENSIONTYPING - | ProvidedMeth(amap,mi,_,m) -> - let isProp = false // not necessarily correct, but this is only used post-creflect where this flag is irrelevant - let ilMethodRef = Import.ImportProvidedMethodBaseAsILMethodRef amap m mi - let isConstructor = mi.PUntaint((fun c -> c.IsConstructor), m) - let valu = mi.PUntaint((fun c -> c.DeclaringType.IsValueType), m) - let actualTypeInst = [] // GENERIC TYPE PROVIDERS: for generics, we would have something here - let actualMethInst = [] // GENERIC TYPE PROVIDERS: for generics, we would have something here - let ilReturnTys = Option.toList (minfo.GetCompiledReturnTy(amap, m, [])) // GENERIC TYPE PROVIDERS: for generics, we would have more here - // REVIEW: Should we allow protected calls? - Expr.Op(TOp.ILCall(false,false, valu, isConstructor,valUseFlags,isProp,false,ilMethodRef,actualTypeInst,actualMethInst, ilReturnTys),[],args,m) - -#endif -//--------------------------------------------------------------------------- -// Helpers when selecting members -//--------------------------------------------------------------------------- - - -/// Use the given function to select some of the member values from the members of an F# type -let SelectImmediateMemberVals g optFilter f (tcref:TyconRef) = - let chooser (vref:ValRef) = - match vref.MemberInfo with - // The 'when' condition is a workaround for the fact that values providing - // override and interface implementations are published in inferred module types - // These cannot be selected directly via the "." notation. - // However, it certainly is useful to be able to publish these values, as we can in theory - // optimize code to make direct calls to these methods. - | Some membInfo when not (ValRefIsExplicitImpl g vref) -> - f membInfo vref - | _ -> - None - - match optFilter with - | None -> tcref.MembersOfFSharpTyconByName |> NameMultiMap.chooseRange chooser - | Some nm -> tcref.MembersOfFSharpTyconByName |> NameMultiMap.find nm |> List.choose chooser - -/// Check whether a name matches an optional filter -let checkFilter optFilter (nm:string) = match optFilter with None -> true | Some n2 -> nm = n2 - -/// Try to select an F# value when querying members, and if so return a MethInfo that wraps the F# value. -let TrySelectMemberVal g optFilter typ pri _membInfo (vref:ValRef) = - if checkFilter optFilter vref.LogicalName then - Some(FSMeth(g,typ,vref,pri)) - else - None - -/// Query the immediate methods of an F# type, not taking into account inherited methods. The optFilter -/// parameter is an optional name to restrict the set of properties returned. -let GetImmediateIntrinsicMethInfosOfType (optFilter,ad) g amap m typ = - let minfos = - - match metadataOfTy g typ with -#if EXTENSIONTYPING - | ProvidedTypeMetadata info -> - let st = info.ProvidedType - let meths = - match optFilter with - | Some name -> st.PApplyArray ((fun st -> st.GetMethods() |> Array.filter (fun mi -> mi.Name = name) ), "GetMethods", m) - | None -> st.PApplyArray ((fun st -> st.GetMethods()), "GetMethods", m) - [ for mi in meths -> ProvidedMeth(amap,mi.Coerce(m),None,m) ] -#endif - | ILTypeMetadata (_,tdef) -> - let mdefs = tdef.Methods - let mdefs = (match optFilter with None -> mdefs.AsList | Some nm -> mdefs.FindByName nm) - mdefs |> List.map (fun mdef -> MethInfo.CreateILMeth(amap, m, typ, mdef)) - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - if not (isAppTy g typ) then [] - else SelectImmediateMemberVals g optFilter (TrySelectMemberVal g optFilter typ None) (tcrefOfAppTy g typ) - let minfos = minfos |> List.filter (IsMethInfoAccessible amap m ad) - minfos - -/// A helper type to help collect properties. -/// -/// Join up getters and setters which are not associated in the F# data structure -type PropertyCollector(g,amap,m,typ,optFilter,ad) = - - let hashIdentity = - Microsoft.FSharp.Collections.HashIdentity.FromFunctions - (fun (pinfo:PropInfo) -> hash pinfo.PropertyName) - (fun pinfo1 pinfo2 -> - pinfo1.IsStatic = pinfo2.IsStatic && - PropInfosEquivByNameAndPartialSig EraseNone g amap m pinfo1 pinfo2 && - pinfo1.IsDefiniteFSharpOverride = pinfo2.IsDefiniteFSharpOverride ) - let props = new System.Collections.Generic.Dictionary(hashIdentity) - let add pinfo = - if props.ContainsKey(pinfo) then - match props.[pinfo], pinfo with - | FSProp (_,typ,Some vref1,_), FSProp (_,_,_,Some vref2) - | FSProp (_,typ,_,Some vref2), FSProp (_,_,Some vref1,_) -> - let pinfo = FSProp (g,typ,Some vref1,Some vref2) - props.[pinfo] <- pinfo - | _ -> - // This assert fires while editing bad code. We will give a warning later in check.fs - //assert ("unexpected case"= "") - () - else - props.[pinfo] <- pinfo - - member x.Collect(membInfo:ValMemberInfo,vref:ValRef) = - match membInfo.MemberFlags.MemberKind with - | MemberKind.PropertyGet -> - let pinfo = FSProp(g,typ,Some vref,None) - if checkFilter optFilter vref.PropertyName && IsPropInfoAccessible g amap m ad pinfo then - add pinfo - | MemberKind.PropertySet -> - let pinfo = FSProp(g,typ,None,Some vref) - if checkFilter optFilter vref.PropertyName && IsPropInfoAccessible g amap m ad pinfo then - add pinfo - | _ -> - () - - member x.Close() = [ for KeyValue(_,pinfo) in props -> pinfo ] - -/// Query the immediate properties of an F# type, not taking into account inherited properties. The optFilter -/// parameter is an optional name to restrict the set of properties returned. -let GetImmediateIntrinsicPropInfosOfType (optFilter,ad) g amap m typ = - let pinfos = - - match metadataOfTy g typ with -#if EXTENSIONTYPING - | ProvidedTypeMetadata info -> - let st = info.ProvidedType - let matchingProps = - match optFilter with - | Some name -> - match st.PApply((fun st -> st.GetProperty name), m) with - | Tainted.Null -> [||] - | pi -> [|pi|] - | None -> - st.PApplyArray((fun st -> st.GetProperties()), "GetProperties", m) - matchingProps - |> Seq.map(fun pi -> ProvidedProp(amap,pi,m)) - |> List.ofSeq -#endif - | ILTypeMetadata (_,tdef) -> - let tinfo = ILTypeInfo.FromType g typ - let pdefs = tdef.Properties - let pdefs = match optFilter with None -> pdefs.AsList | Some nm -> pdefs.LookupByName nm - pdefs |> List.map (fun pd -> ILProp(g,ILPropInfo(tinfo,pd))) - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - - if not (isAppTy g typ) then [] - else - let propCollector = new PropertyCollector(g,amap,m,typ,optFilter,ad) - SelectImmediateMemberVals g None - (fun membInfo vref -> propCollector.Collect(membInfo,vref); None) - (tcrefOfAppTy g typ) |> ignore - propCollector.Close() - - let pinfos = pinfos |> List.filter (IsPropInfoAccessible g amap m ad) - pinfos - - -//--------------------------------------------------------------------------- -// - -/// Sets of methods up the hierarchy, ignoring duplicates by name and sig. -/// Used to collect sets of virtual methods, protected methods, protected -/// properties etc. -type HierarchyItem = - | MethodItem of MethInfo list list - | PropertyItem of PropInfo list list - | RecdFieldItem of RecdFieldInfo - | EventItem of EventInfo list - | ILFieldItem of ILFieldInfo list - -/// An InfoReader is an object to help us read and cache infos. -/// We create one of these for each file we typecheck. -/// -/// REVIEW: We could consider sharing one InfoReader across an entire compilation -/// run or have one global one for each (g,amap) pair. -type InfoReader(g:TcGlobals, amap:Import.ImportMap) = - - /// Get the declared IL fields of a type, not including inherited fields - let GetImmediateIntrinsicILFieldsOfType (optFilter,ad) m typ = - let infos = - match metadataOfTy g typ with -#if EXTENSIONTYPING - | ProvidedTypeMetadata info -> - let st = info.ProvidedType - match optFilter with - | None -> - [ for fi in st.PApplyArray((fun st -> st.GetFields()), "GetFields" , m) -> ProvidedField(amap,fi,m) ] - | Some name -> - match st.PApply ((fun st -> st.GetField name), m) with - | Tainted.Null -> [] - | fi -> [ ProvidedField(amap,fi,m) ] -#endif - | ILTypeMetadata (_,tdef) -> - let tinfo = ILTypeInfo.FromType g typ - let fdefs = tdef.Fields - let fdefs = match optFilter with None -> fdefs.AsList | Some nm -> fdefs.LookupByName nm - fdefs |> List.map (fun pd -> ILFieldInfo(tinfo,pd)) - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - [] - let infos = infos |> List.filter (IsILFieldInfoAccessible g amap m ad) - infos - - /// Get the declared events of a type, not including inherited events - let ComputeImmediateIntrinsicEventsOfType (optFilter,ad) m typ = - let infos = - match metadataOfTy g typ with -#if EXTENSIONTYPING - | ProvidedTypeMetadata info -> - let st = info.ProvidedType - match optFilter with - | None -> - [ for ei in st.PApplyArray((fun st -> st.GetEvents()), "GetEvents" , m) -> ProvidedEvent(amap,ei,m) ] - | Some name -> - match st.PApply ((fun st -> st.GetEvent name), m) with - | Tainted.Null -> [] - | ei -> [ ProvidedEvent(amap,ei,m) ] -#endif - | ILTypeMetadata (_,tdef) -> - let tinfo = ILTypeInfo.FromType g typ - let edefs = tdef.Events - let edefs = match optFilter with None -> edefs.AsList | Some nm -> edefs.LookupByName nm - [ for edef in edefs do - let einfo = ILEventInfo(tinfo,edef) - if IsILEventInfoAccessible g amap m ad einfo then - yield ILEvent(g,einfo) ] - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - [] - infos - - /// Make a reference to a record or class field - let MakeRecdFieldInfo g typ (tcref:TyconRef) fspec = - RecdFieldInfo(argsOfAppTy g typ,tcref.MakeNestedRecdFieldRef fspec) - - /// Get the F#-declared record fields or class 'val' fields of a type - let GetImmediateIntrinsicRecdOrClassFieldsOfType (optFilter,_ad) _m typ = - match tryDestAppTy g typ with - | None -> [] - | Some tcref -> - // Note;secret fields are not allowed in lookups here, as we're only looking - // up user-visible fields in name resolution. - match optFilter with - | Some nm -> - match tcref.GetFieldByName nm with - | Some rfield when not rfield.IsCompilerGenerated -> [MakeRecdFieldInfo g typ tcref rfield] - | _ -> [] - | None -> - [ for fdef in tcref.AllFieldsArray do - if not fdef.IsCompilerGenerated then - yield MakeRecdFieldInfo g typ tcref fdef ] - - - /// The primitive reader for the method info sets up a hierarchy - let GetIntrinsicMethodSetsUncached ((optFilter,ad,allowMultiIntfInst),m,typ) = - FoldPrimaryHierarchyOfType (fun typ acc -> GetImmediateIntrinsicMethInfosOfType (optFilter,ad) g amap m typ :: acc) g amap m allowMultiIntfInst typ [] - - /// The primitive reader for the property info sets up a hierarchy - let GetIntrinsicPropertySetsUncached ((optFilter,ad,allowMultiIntfInst),m,typ) = - FoldPrimaryHierarchyOfType (fun typ acc -> GetImmediateIntrinsicPropInfosOfType (optFilter,ad) g amap m typ :: acc) g amap m allowMultiIntfInst typ [] - - let GetIntrinsicILFieldInfosUncached ((optFilter,ad),m,typ) = - FoldPrimaryHierarchyOfType (fun typ acc -> GetImmediateIntrinsicILFieldsOfType (optFilter,ad) m typ @ acc) g amap m AllowMultiIntfInstantiations.Yes typ [] - - let GetIntrinsicEventInfosUncached ((optFilter,ad),m,typ) = - FoldPrimaryHierarchyOfType (fun typ acc -> ComputeImmediateIntrinsicEventsOfType (optFilter,ad) m typ @ acc) g amap m AllowMultiIntfInstantiations.Yes typ [] - - let GetIntrinsicRecdOrClassFieldInfosUncached ((optFilter,ad),m,typ) = - FoldPrimaryHierarchyOfType (fun typ acc -> GetImmediateIntrinsicRecdOrClassFieldsOfType (optFilter,ad) m typ @ acc) g amap m AllowMultiIntfInstantiations.Yes typ [] - - let GetEntireTypeHierachyUncached (allowMultiIntfInst,m,typ) = - FoldEntireHierarchyOfType (fun typ acc -> typ :: acc) g amap m allowMultiIntfInst typ [] - - let GetPrimaryTypeHierachyUncached (allowMultiIntfInst,m,typ) = - FoldPrimaryHierarchyOfType (fun typ acc -> typ :: acc) g amap m allowMultiIntfInst typ [] - - /// The primitive reader for the named items up a hierarchy - let GetIntrinsicNamedItemsUncached ((nm,ad),m,typ) = - if nm = ".ctor" then None else // '.ctor' lookups only ever happen via constructor syntax - let optFilter = Some nm - FoldPrimaryHierarchyOfType (fun typ acc -> - let minfos = GetImmediateIntrinsicMethInfosOfType (optFilter,ad) g amap m typ - let pinfos = GetImmediateIntrinsicPropInfosOfType (optFilter,ad) g amap m typ - let finfos = GetImmediateIntrinsicILFieldsOfType (optFilter,ad) m typ - let einfos = ComputeImmediateIntrinsicEventsOfType (optFilter,ad) m typ - let rfinfos = GetImmediateIntrinsicRecdOrClassFieldsOfType (optFilter,ad) m typ - match acc with - | Some(MethodItem(inheritedMethSets)) when nonNil minfos -> Some(MethodItem (minfos::inheritedMethSets)) - | _ when nonNil minfos -> Some(MethodItem ([minfos])) - | Some(PropertyItem(inheritedPropSets)) when nonNil pinfos -> Some(PropertyItem(pinfos::inheritedPropSets)) - | _ when nonNil pinfos -> Some(PropertyItem([pinfos])) - | _ when nonNil finfos -> Some(ILFieldItem(finfos)) - | _ when nonNil einfos -> Some(EventItem(einfos)) - | _ when nonNil rfinfos -> - match rfinfos with - | [single] -> Some(RecdFieldItem(single)) - | _ -> failwith "Unexpected multiple fields with the same name" // Because an explicit name (i.e., nm) was supplied, there will be only one element at most. - | _ -> acc) - g amap m - AllowMultiIntfInstantiations.Yes - typ - None - - /// Make a cache for function 'f' keyed by type (plus some additional 'flags') that only - /// caches computations for monomorphic types. - - let MakeInfoCache f (flagsEq : System.Collections.Generic.IEqualityComparer<_>) = - new MemoizationTable<_,_> - (compute=f, - // Only cache closed, monomorphic types (closed = all members for the type - // have been processed). Generic type instantiations could be processed if we had - // a decent hash function for these. - canMemoize=(fun (_flags,(_:range),typ) -> - match stripTyEqns g typ with - | TType_app(tcref,[]) -> tcref.TypeContents.tcaug_closed - | _ -> false), - - keyComparer= - { new System.Collections.Generic.IEqualityComparer<_> with - member x.Equals((flags1,_,typ1),(flags2,_,typ2)) = - // Ignoring the ranges - that's OK. - flagsEq.Equals(flags1,flags2) && - match stripTyEqns g typ1, stripTyEqns g typ2 with - | TType_app(tcref1,[]),TType_app(tcref2,[]) -> tyconRefEq g tcref1 tcref2 - | _ -> false - member x.GetHashCode((flags,_,typ)) = - // Ignoring the ranges - that's OK. - flagsEq.GetHashCode flags + - (match stripTyEqns g typ with - | TType_app(tcref,[]) -> hash tcref.LogicalName - | _ -> 0) }) - - - let hashFlags0 = - { new System.Collections.Generic.IEqualityComparer<_> with - member x.GetHashCode((filter: string option, ad: AccessorDomain, _allowMultiIntfInst1)) = hash filter + AccessorDomain.CustomGetHashCode ad - member x.Equals((filter1, ad1, allowMultiIntfInst1), (filter2,ad2, allowMultiIntfInst2)) = - (filter1 = filter2) && AccessorDomain.CustomEquals(g,ad1,ad2) && allowMultiIntfInst1 = allowMultiIntfInst2 } - - let hashFlags1 = - { new System.Collections.Generic.IEqualityComparer<_> with - member x.GetHashCode((filter: string option,ad: AccessorDomain)) = hash filter + AccessorDomain.CustomGetHashCode ad - member x.Equals((filter1,ad1), (filter2,ad2)) = (filter1 = filter2) && AccessorDomain.CustomEquals(g,ad1,ad2) } - - let hashFlags2 = - { new System.Collections.Generic.IEqualityComparer<_> with - member x.GetHashCode((nm: string,ad: AccessorDomain)) = hash nm + AccessorDomain.CustomGetHashCode ad - member x.Equals((nm1,ad1), (nm2,ad2)) = (nm1 = nm2) && AccessorDomain.CustomEquals(g,ad1,ad2) } - - let methodInfoCache = MakeInfoCache GetIntrinsicMethodSetsUncached hashFlags0 - let propertyInfoCache = MakeInfoCache GetIntrinsicPropertySetsUncached hashFlags0 - let recdOrClassFieldInfoCache = MakeInfoCache GetIntrinsicRecdOrClassFieldInfosUncached hashFlags1 - let ilFieldInfoCache = MakeInfoCache GetIntrinsicILFieldInfosUncached hashFlags1 - let eventInfoCache = MakeInfoCache GetIntrinsicEventInfosUncached hashFlags1 - let namedItemsCache = MakeInfoCache GetIntrinsicNamedItemsUncached hashFlags2 - - let entireTypeHierarchyCache = MakeInfoCache GetEntireTypeHierachyUncached HashIdentity.Structural - let primaryTypeHierarchyCache = MakeInfoCache GetPrimaryTypeHierachyUncached HashIdentity.Structural - - member x.g = g - member x.amap = amap - - /// Read the raw method sets of a type, including inherited ones. Cache the result for monomorphic types - member x.GetRawIntrinsicMethodSetsOfType (optFilter,ad,allowMultiIntfInst,m,typ) = - methodInfoCache.Apply(((optFilter,ad,allowMultiIntfInst),m,typ)) - - /// Read the raw property sets of a type, including inherited ones. Cache the result for monomorphic types - member x.GetRawIntrinsicPropertySetsOfType (optFilter,ad,allowMultiIntfInst,m,typ) = - propertyInfoCache.Apply(((optFilter,ad,allowMultiIntfInst),m,typ)) - - /// Read the record or class fields of a type, including inherited ones. Cache the result for monomorphic types. - member x.GetRecordOrClassFieldsOfType (optFilter,ad,m,typ) = - recdOrClassFieldInfoCache.Apply(((optFilter,ad),m,typ)) - - /// Read the IL fields of a type, including inherited ones. Cache the result for monomorphic types. - member x.GetILFieldInfosOfType (optFilter,ad,m,typ) = - ilFieldInfoCache.Apply(((optFilter,ad),m,typ)) - - member x.GetImmediateIntrinsicEventsOfType (optFilter,ad,m,typ) = ComputeImmediateIntrinsicEventsOfType (optFilter,ad) m typ - - /// Read the events of a type, including inherited ones. Cache the result for monomorphic types. - member x.GetEventInfosOfType (optFilter,ad,m,typ) = - eventInfoCache.Apply(((optFilter,ad),m,typ)) - - /// Try and find a record or class field for a type. - member x.TryFindRecdOrClassFieldInfoOfType (nm,m,typ) = - match recdOrClassFieldInfoCache.Apply((Some nm,AccessibleFromSomewhere),m,typ) with - | [] -> None - | [single] -> Some single - | flds -> - // multiple fields with the same name can come from different classes, - // so filter them by the given type name - match tryDestAppTy g typ with - | None -> None - | Some tcref -> - match flds |> List.filter (fun rfinfo -> tyconRefEq g tcref rfinfo.TyconRef) with - | [] -> None - | [single] -> Some single - | _ -> failwith "unexpected multiple fields with same name" // Because it should have been already reported as duplicate fields - - /// Try and find an item with the given name in a type. - member x.TryFindNamedItemOfType (nm,ad,m,typ) = - namedItemsCache.Apply(((nm,ad),m,typ)) - - /// Get the super-types of a type, including interface types. - member x.GetEntireTypeHierachy (allowMultiIntfInst,m,typ) = - entireTypeHierarchyCache.Apply((allowMultiIntfInst,m,typ)) - - /// Get the super-types of a type, excluding interface types. - member x.GetPrimaryTypeHierachy (allowMultiIntfInst,m,typ) = - primaryTypeHierarchyCache.Apply((allowMultiIntfInst,m,typ)) - - -//------------------------------------------------------------------------- -// Constructor infos - - -/// Get the declared constructors of any F# type -let GetIntrinsicConstructorInfosOfType (infoReader:InfoReader) m ty = - let g = infoReader.g - let amap = infoReader.amap - if isAppTy g ty then - match metadataOfTy g ty with -#if EXTENSIONTYPING - | ProvidedTypeMetadata info -> - let st = info.ProvidedType - [ for ci in st.PApplyArray((fun st -> st.GetConstructors()), "GetConstructors", m) do - yield ProvidedMeth(amap,ci.Coerce(m),None,m) ] -#endif - | ILTypeMetadata _ -> - let tinfo = ILTypeInfo.FromType g ty - tinfo.RawMetadata.Methods.FindByName ".ctor" - |> List.filter (fun md -> match md.mdKind with MethodKind.Ctor -> true | _ -> false) - |> List.map (fun mdef -> MethInfo.CreateILMeth (amap, m, ty, mdef)) - - | FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata -> - let tcref = tcrefOfAppTy g ty - tcref.MembersOfFSharpTyconByName - |> NameMultiMap.find ".ctor" - |> List.choose(fun vref -> - match vref.MemberInfo with - | Some membInfo when (membInfo.MemberFlags.MemberKind = MemberKind.Constructor) -> Some vref - | _ -> None) - |> List.map (fun x -> FSMeth(g,ty,x,None)) - else [] - -//------------------------------------------------------------------------- -// Collecting methods and properties taking into account hiding rules in the hierarchy - - -/// Indicates if we prefer overrides or abstract slots. -type FindMemberFlag = - /// Prefer items toward the top of the hierarchy, which we do if the items are virtual - /// but not when resolving base calls. - | IgnoreOverrides - /// Get overrides instead of abstract slots when measuring whether a class/interface implements all its required slots. - | PreferOverrides - -/// The input list is sorted from most-derived to least-derived type, so any System.Object methods -/// are at the end of the list. Return a filtered list where prior/subsequent members matching by name and -/// that are in the same equivalence class have been removed. We keep a name-indexed table to -/// be more efficient when we check to see if we've already seen a particular named method. -type private IndexedList<'T>(itemLists: 'T list list, itemsByName: NameMultiMap<'T>) = - - /// Get the item sets - member x.Items = itemLists - - /// Get the items with a particular name - member x.ItemsWithName(nm) = NameMultiMap.find nm itemsByName - - /// Add new items, extracting the names using the given function. - member x.AddItems(items,nmf) = IndexedList<'T>(items::itemLists,List.foldBack (fun x acc -> NameMultiMap.add (nmf x) x acc) items itemsByName ) - - /// Get an empty set of items - static member Empty = IndexedList<'T>([],NameMultiMap.empty) - - /// Filter a set of new items to add according to the content of the list. Only keep an item - /// if it passes 'keepTest' for all matching items already in the list. - member x.FilterNewItems keepTest nmf itemsToAdd = - // Have we already seen an item with the same name and that is in the same equivalence class? - // If so, ignore this one. Note we can check against the original incoming 'ilist' because we are assuming that - // none the elements of 'itemsToAdd' are equivalent. - itemsToAdd |> List.filter (fun item -> List.forall (keepTest item) (x.ItemsWithName(nmf item))) - -/// Add all the items to the IndexedList, preferring the ones in the super-types. This is used to hide methods -/// in super classes and/or hide overrides of methods in subclasses. -/// -/// Assume no items in 'items' are equivalent according to 'equivTest'. This is valid because each step in a -/// .NET class hierarchy introduces a consistent set of methods, none of which hide each other within the -/// given set. This is an important optimization because it means we don't have filter for equivalence between the -/// large overload sets introduced by methods like System.WriteLine. -/// -/// Assume items can be given names by 'nmf', where two items with different names are -/// not equivalent. - -let private FilterItemsInSubTypesBasedOnItemsInSuperTypes nmf keepTest itemLists = - let rec loop itemLists = - match itemLists with - | [] -> IndexedList.Empty - | items :: itemsInSuperTypes -> - let ilist = loop itemsInSuperTypes - let itemsToAdd = ilist.FilterNewItems keepTest nmf items - ilist.AddItems(itemsToAdd,nmf) - (loop itemLists).Items - -/// Add all the items to the IndexedList, preferring the ones in the sub-types. -let private FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf keepTest itemLists = - let rec loop itemLists (indexedItemsInSubTypes:IndexedList<_>) = - match itemLists with - | [] -> List.rev indexedItemsInSubTypes.Items - | items :: itemsInSuperTypes -> - let itemsToAdd = items |> List.filter (fun item -> keepTest item (indexedItemsInSubTypes.ItemsWithName(nmf item))) - let ilist = indexedItemsInSubTypes.AddItems(itemsToAdd,nmf) - loop itemsInSuperTypes ilist - - loop itemLists IndexedList.Empty - -let private ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes nmf equivTest itemLists = - FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf (fun item1 items -> not (items |> List.exists (fun item2 -> equivTest item1 item2))) itemLists - -/// Filter the overrides of methods or properties, either keeping the overrides or keeping the dispatch slots. -let private FilterOverrides findFlag (isVirt:'a->bool,isNewSlot,isDefiniteOverride,isFinal,equivSigs,nmf:'a->string) items = - let equivVirts x y = isVirt x && isVirt y && equivSigs x y - - match findFlag with - | PreferOverrides -> - items - // For each F#-declared override, get rid of any equivalent abstract member in the same type - // This is because F# abstract members with default overrides give rise to two members with the - // same logical signature in the same type, e.g. - // type ClassType1() = - // abstract VirtualMethod1: string -> int - // default x.VirtualMethod1(s) = 3 - - |> List.map (fun items -> - let definiteOverrides = items |> List.filter isDefiniteOverride - items |> List.filter (fun item -> (isDefiniteOverride item || not (List.exists (equivVirts item) definiteOverrides)))) - - // only keep virtuals that are not signature-equivalent to virtuals in subtypes - |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes nmf equivVirts - | IgnoreOverrides -> - let equivNewSlots x y = isNewSlot x && isNewSlot y && equivSigs x y - items - // Remove any F#-declared overrides. THese may occur in the same type as the abstract member (unlike with .NET metadata) - // Include any 'newslot' declared methods. - |> List.map (List.filter (fun x -> not (isDefiniteOverride x))) - - // Remove any virtuals that are signature-equivalent to virtuals in subtypes, except for newslots - // That is, keep if it's - /// (a) not virtual - // (b) is a new slot or - // (c) not equivalent - // We keep virtual finals around for error detection later on - |> FilterItemsInSubTypesBasedOnItemsInSuperTypes nmf (fun newItem priorItem -> - (isVirt newItem && isFinal newItem) || not (isVirt newItem) || isNewSlot newItem || not (equivVirts newItem priorItem) ) - - // Remove any abstract slots in supertypes that are (a) hidden by another newslot and (b) implemented - // We leave unimplemented ones around to give errors, e.g. for - // [] - // type PA() = - // abstract M : int -> unit - // - // [] - // type PB<'a>() = - // inherit PA() - // abstract M : 'a -> unit - // - // [] - // type PC() = - // inherit PB() - // // Here, PA.M and PB.M have the same signature, so PA.M is unimplementable. - // // REVIEW: in future we may give a friendly error at this point - // - // type PD() = - // inherit PC() - // override this.M(x:int) = () - - |> FilterItemsInSuperTypesBasedOnItemsInSubTypes nmf (fun item1 superTypeItems -> - not (isNewSlot item1 && - superTypeItems |> List.exists (equivNewSlots item1) && - superTypeItems |> List.exists (fun item2 -> isDefiniteOverride item1 && equivVirts item1 item2))) - - -/// Filter the overrides of methods, either keeping the overrides or keeping the dispatch slots. -let private FilterOverridesOfMethInfos findFlag g amap m minfos = - FilterOverrides findFlag ((fun (minfo:MethInfo) -> minfo.IsVirtual),(fun minfo -> minfo.IsNewSlot),(fun minfo -> minfo.IsDefiniteFSharpOverride),(fun minfo -> minfo.IsFinal),MethInfosEquivByNameAndSig EraseNone true g amap m,(fun minfo -> minfo.LogicalName)) minfos - -/// Filter the overrides of properties, either keeping the overrides or keeping the dispatch slots. -let private FilterOverridesOfPropInfos findFlag g amap m props = - FilterOverrides findFlag ((fun (pinfo:PropInfo) -> pinfo.IsVirtualProperty),(fun pinfo -> pinfo.IsNewSlot),(fun pinfo -> pinfo.IsDefiniteFSharpOverride),(fun _ -> false),PropInfosEquivByNameAndSig EraseNone g amap m, (fun pinfo -> pinfo.PropertyName)) props - -/// Exclude methods from super types which have the same signature as a method in a more specific type. -let ExcludeHiddenOfMethInfos g amap m (minfos:MethInfo list list) = - minfos - |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes - (fun minfo -> minfo.LogicalName) - (fun m1 m2 -> - // only hide those truly from super classes - not (tyconRefEq g (tcrefOfAppTy g m1.EnclosingType) (tcrefOfAppTy g m2.EnclosingType)) && - MethInfosEquivByNameAndPartialSig EraseNone true g amap m m1 m2) - - |> List.concat - -/// Exclude properties from super types which have the same name as a property in a more specific type. -let ExcludeHiddenOfPropInfos g amap m pinfos = - pinfos - |> ExcludeItemsInSuperTypesBasedOnEquivTestWithItemsInSubTypes (fun (pinfo:PropInfo) -> pinfo.PropertyName) (PropInfosEquivByNameAndPartialSig EraseNone g amap m) - |> List.concat - -/// Get the sets of intrinsic methods in the hierarchy (not including extension methods) -let GetIntrinsicMethInfoSetsOfType (infoReader:InfoReader) (optFilter,ad,allowMultiIntfInst) findFlag m typ = - infoReader.GetRawIntrinsicMethodSetsOfType(optFilter,ad,allowMultiIntfInst,m,typ) - |> FilterOverridesOfMethInfos findFlag infoReader.g infoReader.amap m - -/// Get the sets intrinsic properties in the hierarchy (not including extension properties) -let GetIntrinsicPropInfoSetsOfType (infoReader:InfoReader) (optFilter,ad,allowMultiIntfInst) findFlag m typ = - infoReader.GetRawIntrinsicPropertySetsOfType(optFilter,ad,allowMultiIntfInst,m,typ) - |> FilterOverridesOfPropInfos findFlag infoReader.g infoReader.amap m - -/// Get the flattened list of intrinsic methods in the hierarchy -let GetIntrinsicMethInfosOfType infoReader (optFilter,ad,allowMultiIntfInst) findFlag m typ = - GetIntrinsicMethInfoSetsOfType infoReader (optFilter,ad,allowMultiIntfInst) findFlag m typ |> List.concat - -/// Get the flattened list of intrinsic properties in the hierarchy -let GetIntrinsicPropInfosOfType infoReader (optFilter,ad,allowMultiIntfInst) findFlag m typ = - GetIntrinsicPropInfoSetsOfType infoReader (optFilter,ad,allowMultiIntfInst) findFlag m typ |> List.concat - -/// Perform type-directed name resolution of a particular named member in an F# type -let TryFindIntrinsicNamedItemOfType (infoReader:InfoReader) (nm,ad) findFlag m typ = - match infoReader.TryFindNamedItemOfType(nm, ad, m, typ) with - | Some item -> - match item with - | PropertyItem psets -> Some(PropertyItem (psets |> FilterOverridesOfPropInfos findFlag infoReader.g infoReader.amap m)) - | MethodItem msets -> Some(MethodItem (msets |> FilterOverridesOfMethInfos findFlag infoReader.g infoReader.amap m)) - | _ -> Some(item) - | None -> None - -/// Try to detect the existence of a method on a type. -/// Used for -/// -- getting the GetEnumerator, get_Current, MoveNext methods for enumerable types -/// -- getting the Dispose method when resolving the 'use' construct -/// -- getting the various methods used to desugar the computation expression syntax -let TryFindIntrinsicMethInfo infoReader m ad nm ty = - GetIntrinsicMethInfosOfType infoReader (Some nm,ad,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m ty - -/// Try to find a particular named property on a type. Only used to ensure that local 'let' definitions and property names -/// are distinct, a somewhat adhoc check in tc.fs. -let TryFindPropInfo infoReader m ad nm ty = - GetIntrinsicPropInfosOfType infoReader (Some nm,ad,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m ty - -//------------------------------------------------------------------------- -// Helpers related to delegates and events -//------------------------------------------------------------------------- - -/// The Invoke MethInfo, the function argument types, the function return type -/// and the overall F# function type for the function type associated with a .NET delegate type -[] -type SigOfFunctionForDelegate = SigOfFunctionForDelegate of MethInfo * TType list * TType * TType - -/// Given a delegate type work out the minfo, argument types, return type -/// and F# function type by looking at the Invoke signature of the delegate. -let GetSigOfFunctionForDelegate (infoReader:InfoReader) delty m ad = - let g = infoReader.g - let amap = infoReader.amap - let invokeMethInfo = - match GetIntrinsicMethInfosOfType infoReader (Some "Invoke",ad,AllowMultiIntfInstantiations.Yes) IgnoreOverrides m delty with - | [h] -> h - | [] -> error(Error(FSComp.SR.noInvokeMethodsFound (),m)) - | h :: _ -> warning(InternalError(FSComp.SR.moreThanOneInvokeMethodFound (),m)); h - - let minst = [] // a delegate's Invoke method is never generic - let compiledViewOfDelArgTys = - match invokeMethInfo.GetParamTypes(amap, m, minst) with - | [args] -> args - | _ -> error(Error(FSComp.SR.delegatesNotAllowedToHaveCurriedSignatures (),m)) - let fsharpViewOfDelArgTys = - match compiledViewOfDelArgTys with - | [] -> [g.unit_ty] - | _ -> compiledViewOfDelArgTys - let delRetTy = invokeMethInfo.GetFSharpReturnTy(amap, m, minst) - CheckMethInfoAttributes g m None invokeMethInfo |> CommitOperationResult - let fty = mkIteratedFunTy fsharpViewOfDelArgTys delRetTy - SigOfFunctionForDelegate(invokeMethInfo,compiledViewOfDelArgTys,delRetTy,fty) - -/// Try and interpret a delegate type as a "standard" .NET delegate type associated with an event, with a "sender" parameter. -let TryDestStandardDelegateTyp (infoReader:InfoReader) m ad delTy = - let g = infoReader.g - let (SigOfFunctionForDelegate(_,compiledViewOfDelArgTys,delRetTy,_)) = GetSigOfFunctionForDelegate infoReader delTy m ad - match compiledViewOfDelArgTys with - | senderTy :: argTys when (isObjTy g senderTy) && not (List.exists (isByrefTy g) argTys) -> Some(mkTupledTy g argTys,delRetTy) - | _ -> None - - -/// Indicates if an event info is associated with a delegate type that is a "standard" .NET delegate type -/// with a sender parameter. -// -/// In the F# design, we take advantage of the following idiom to simplify away the bogus "object" parameter of the -/// of the "Add" methods associated with events. If you want to access it you -/// can use AddHandler instead. - -/// The .NET Framework guidelines indicate that the delegate type used for -/// an event should take two parameters, an "object source" parameter -/// indicating the source of the event, and an "e" parameter that -/// encapsulates any additional information about the event. The type of -/// the "e" parameter should derive from the EventArgs class. For events -/// that do not use any additional information, the .NET Framework has -/// already defined an appropriate delegate type: EventHandler. -/// (from http://msdn.microsoft.com/library/default.asp?url=/library/en-us/csref/html/vcwlkEventsTutorial.asp) -let IsStandardEventInfo (infoReader:InfoReader) m ad (einfo:EventInfo) = - let dty = einfo.GetDelegateType(infoReader.amap,m) - match TryDestStandardDelegateTyp infoReader m ad dty with - | Some _ -> true - | None -> false - -/// Get the (perhaps tupled) argument type accepted by an event -let ArgsTypOfEventInfo (infoReader:InfoReader) m ad (einfo:EventInfo) = - let amap = infoReader.amap - let dty = einfo.GetDelegateType(amap,m) - match TryDestStandardDelegateTyp infoReader m ad dty with - | Some(argtys,_) -> argtys - | None -> error(nonStandardEventError einfo.EventName m) - -/// Get the type of the event when looked at as if it is a property -/// Used when displaying the property in Intellisense -let PropTypOfEventInfo (infoReader:InfoReader) m ad (einfo:EventInfo) = - let g = infoReader.g - let amap = infoReader.amap - let delTy = einfo.GetDelegateType(amap,m) - let argsTy = ArgsTypOfEventInfo infoReader m ad einfo - mkIEventType g delTy argsTy - - diff --git a/src/fsharp/lex.fsl b/src/fsharp/lex.fsl index 6532490338..89bf263e4b 100755 --- a/src/fsharp/lex.fsl +++ b/src/fsharp/lex.fsl @@ -82,7 +82,13 @@ let parseOctalUInt64 (s:string) p l = let rec parse n acc = if n < l then parse (n+1) (acc * 8UL + (let c = s.[n] in if c >= '0' && c <= '7' then Convert.ToUInt64 c - Convert.ToUInt64 '0' else formatError())) else acc parse p 0UL +let removeUnderscores (s:string) = + match s with + | null -> null + | s -> s.Replace("_", "") + let parseInt32 (s:string) = + let s = removeUnderscores s let l = s.Length let mutable p = 0 let sign = getSign32 s &p l @@ -175,11 +181,12 @@ let anychar = [^'\n''\r'] let anystring = anychar* let op_char = '!'|'$'|'%'|'&'|'*'|'+'|'-'|'.'|'/'|'<'|'='|'>'|'?'|'@'|'^'|'|'|'~'|':' let ignored_op_char = '.' | '$' | '?' +let separator = '_' let xinteger = - ( '0' ('x'| 'X') hex + - | '0' ('o'| 'O') (['0'-'7']) + - | '0' ('b'| 'B') (['0'-'1']) + ) -let integer = digit+ + ( '0' ('x'| 'X') hex ((hex | separator)* hex)? + | '0' ('o'| 'O') (['0'-'7']) (((['0'-'7']) | separator)* (['0'-'7']))? + | '0' ('b'| 'B') (['0'-'1']) (((['0'-'1']) | separator)* (['0'-'1']))?) +let integer = digit ((digit | separator)* digit)? let int8 = integer 'y' let uint8 = (xinteger | integer) 'u' 'y' let int16 = integer 's' @@ -196,8 +203,8 @@ let xint8 = xinteger 'y' let xint16 = xinteger 's' let xint = xinteger let xint32 = xinteger 'l' -let floatp = digit+ '.' digit* -let floate = digit+ ('.' digit* )? ('e'| 'E') ['+' '-']? digit+ +let floatp = digit ((digit | separator)* digit)? '.' (digit ((digit | separator)* digit)?)? +let floate = digit ((digit | separator)* digit)? ('.' (digit ((digit | separator)* digit)?)? )? ('e'| 'E') ['+' '-']? digit ((digit | separator)* digit)? let float = floatp | floate let bignum = integer ('I' | 'N' | 'Z' | 'Q' | 'R' | 'G') let ieee64 = float @@ -606,7 +613,7 @@ rule token args skip = parse | anywhite* "#if" anywhite+ anystring { let m = lexbuf.LexemeRange - let lookup id = List.mem id args.defines + let lookup id = List.contains id args.defines let lexed = lexeme lexbuf let isTrue = evalIfDefExpression lexbuf.StartPos args lookup lexed args.ifdefStack := (IfDefIf,m) :: !(args.ifdefStack); diff --git a/src/fsharp/lexhelp.fs b/src/fsharp/lexhelp.fs index 6aa2c1f18d..fcdef62559 100755 --- a/src/fsharp/lexhelp.fs +++ b/src/fsharp/lexhelp.fs @@ -218,6 +218,7 @@ module Keywords = FSHARP, "extern" ,EXTERN; ALWAYS, "false" ,FALSE; ALWAYS, "finally" ,FINALLY; + FSHARP, "fixed" ,FIXED; ALWAYS, "for" ,FOR; ALWAYS, "fun" ,FUN; ALWAYS, "function" ,FUNCTION; @@ -281,18 +282,15 @@ module Keywords = ] (*------- reserved keywords which are ml-compatibility ids *) @ List.map (fun s -> (FSHARP,s,RESERVED)) - [ "atomic"; "break"; - "checked"; "component"; "constraint"; "constructor"; "continue"; - "eager"; - "fixed"; "fori"; "functor"; + [ "break"; + "checked"; "component"; "constraint"; "continue"; + "fori"; "include"; - "measure"; "method"; "mixin"; - "object"; + "mixin"; "parallel"; "params"; "process"; "protected"; "pure"; - "recursive"; "sealed"; "trait"; "tailcall"; - "virtual"; "volatile"; ] + "virtual"; ] let private unreserveWords = keywordList |> List.choose (function (mode,keyword,_) -> if mode = FSHARP then Some keyword else None) @@ -305,48 +303,44 @@ module Keywords = keywordList |> List.map (fun (_, w, _) -> w) let keywordTable = - // TODO: this doesn't need to be a multi-map, a dictionary will do let tab = System.Collections.Generic.Dictionary(100) - for (_mode,keyword,token) in keywordList do tab.Add(keyword,token) + for _,keyword,token in keywordList do + tab.Add(keyword,token) tab let KeywordToken s = keywordTable.[s] - /// ++GLOBAL MUTABLE STATE. Note this is a deprecated, undocumented command line option anyway, we can ignore it. - let mutable permitFsharpKeywords = true - let IdentifierToken args (lexbuf:UnicodeLexing.Lexbuf) (s:string) = if IsCompilerGeneratedName s then warning(Error(FSComp.SR.lexhlpIdentifiersContainingAtSymbolReserved(), lexbuf.LexemeRange)); args.resourceManager.InternIdentifierToken s let KeywordOrIdentifierToken args (lexbuf:UnicodeLexing.Lexbuf) s = - if not permitFsharpKeywords && List.mem s unreserveWords then - // You can assume this condition never fires - this is a deprecated, undocumented command line option anyway, we can ignore it. - IdentifierToken args lexbuf s - else - let mutable v = Unchecked.defaultof<_> - if keywordTable.TryGetValue(s, &v) then - if (match v with RESERVED -> true | _ -> false) then - warning(ReservedKeyword(FSComp.SR.lexhlpIdentifierReserved(s), lexbuf.LexemeRange)); - IdentifierToken args lexbuf s - else v - else + match keywordTable.TryGetValue s with + | true,v -> + match v with + | RESERVED -> + warning(ReservedKeyword(FSComp.SR.lexhlpIdentifierReserved(s), lexbuf.LexemeRange)); + IdentifierToken args lexbuf s + | _ -> v + | _ -> match s with | "__SOURCE_DIRECTORY__" -> let filename = fileOfFileIndex lexbuf.StartPos.FileIndex - let dirname = if filename = stdinMockFilename then - System.IO.Directory.GetCurrentDirectory() - else - filename |> FileSystem.GetFullPathShim (* asserts that path is already absolute *) - |> System.IO.Path.GetDirectoryName + let dirname = + if filename = stdinMockFilename then + System.IO.Directory.GetCurrentDirectory() + else + filename + |> FileSystem.GetFullPathShim (* asserts that path is already absolute *) + |> System.IO.Path.GetDirectoryName KEYWORD_STRING dirname | "__SOURCE_FILE__" -> - KEYWORD_STRING (System.IO.Path.GetFileName((fileOfFileIndex lexbuf.StartPos.FileIndex))) + KEYWORD_STRING (System.IO.Path.GetFileName((fileOfFileIndex lexbuf.StartPos.FileIndex))) | "__LINE__" -> - KEYWORD_STRING (string lexbuf.StartPos.Line) + KEYWORD_STRING (string lexbuf.StartPos.Line) | _ -> - IdentifierToken args lexbuf s + IdentifierToken args lexbuf s /// A utility to help determine if an identifier needs to be quoted let QuoteIdentifierIfNeeded (s : string) : string = diff --git a/src/fsharp/lexhelp.fsi b/src/fsharp/lexhelp.fsi index 4ef4e5edfb..2d42776079 100755 --- a/src/fsharp/lexhelp.fsi +++ b/src/fsharp/lexhelp.fsi @@ -67,5 +67,4 @@ module Keywords = val KeywordOrIdentifierToken : lexargs -> UnicodeLexing.Lexbuf -> string -> Parser.token val IdentifierToken : lexargs -> UnicodeLexing.Lexbuf -> string -> Parser.token val QuoteIdentifierIfNeeded : string -> string - val mutable permitFsharpKeywords : bool val keywordNames : string list diff --git a/src/fsharp/lib.fs b/src/fsharp/lib.fs index af894e2556..3ed305323e 100755 --- a/src/fsharp/lib.fs +++ b/src/fsharp/lib.fs @@ -105,29 +105,29 @@ module NameMap = //------------------------------------------------------------------------- module Check = - /// Throw System.InvalidOperationException() if argument is None. - /// If there is a value (e.g. Some(value)) then value is returned. + /// Throw System.InvalidOperationException() if argument is None. + /// If there is a value (e.g. Some(value)) then value is returned. let NotNone argname (arg:'T option) : 'T = match arg with | None -> raise (new System.InvalidOperationException(argname)) | Some x -> x - /// Throw System.ArgumentNullException() if argument is null. + /// Throw System.ArgumentNullException() if argument is null. let ArgumentNotNull arg argname = match box(arg) with | null -> raise (new System.ArgumentNullException(argname)) | _ -> () - /// Throw System.ArgumentNullException() if array argument is null. - /// Throw System.ArgumentOutOfRangeException() is array argument is empty. + /// Throw System.ArgumentNullException() if array argument is null. + /// Throw System.ArgumentOutOfRangeException() is array argument is empty. let ArrayArgumentNotNullOrEmpty (arr:'T[]) argname = ArgumentNotNull arr argname if (0 = arr.Length) then raise (new System.ArgumentOutOfRangeException(argname)) - /// Throw System.ArgumentNullException() if string argument is null. - /// Throw System.ArgumentOutOfRangeException() is string argument is empty. + /// Throw System.ArgumentNullException() if string argument is null. + /// Throw System.ArgumentOutOfRangeException() is string argument is empty. let StringArgumentNotNullOrEmpty (s:string) argname = ArgumentNotNull s argname if s.Length = 0 then @@ -268,9 +268,7 @@ let fmap2Of2 f z (a1,a2) = let z,a2 = f z a2 in z,(a1,a2) module List = let noRepeats xOrder xs = let s = Zset.addList xs (Zset.empty xOrder) // build set - Zset.elements s // get elements... no repeats - - let groupBy f (xs:list<'T>) = xs |> Seq.groupBy f |> Seq.map (map2Of2 Seq.toList) |> Seq.toList + Zset.elements s // get elements... no repeats //--------------------------------------------------------------------------- // Zmap rebinds @@ -402,9 +400,9 @@ let inline cacheOptRef cache f = // The bug manifests itself as an ExecutionEngine failure or fast-fail process exit which comes // and goes depending on whether components are NGEN'd or not, e.g. 'ngen install FSharp.COmpiler.dll' // One workaround for the bug is to break NGEN loading and fixups into smaller fragments. Roughly speaking, the NGEN -// loading process works by doing delayed fixups of references in NGEN code. This happens on a per-method -// basis. For example, one manifestation is that a "print" before calling a method like LexFilter.create gets -// displayed but the corresponding "print" in the body of that function doesn't get displayed. In between, the NGEN +// loading process works by doing delayed fixups of references in NGEN code. This happens on a per-method basis. +// e.g. one manifestation is that a 'print' before calling a method like LexFilter.create gets +// displayed but the corresponding 'print' in the body of that function doesn't get displayed. In between, the NGEN // image loader is performing a whole bunch of fixups of the NGEN code for the body of that method, and also for // bodies of methods referred to by that method. That second bit is very important: the fixup causing the crash may // be a couple of steps down the dependency chain. @@ -442,7 +440,7 @@ module internal AsyncUtil = open System.Threading open Microsoft.FSharp.Control - /// Represents the reified result of an asynchronous computation + /// Represents the reified result of an asynchronous computation. [] type AsyncResult<'T> = | AsyncOk of 'T @@ -456,7 +454,7 @@ module internal AsyncUtil = | AsyncException exn -> econt exn | AsyncCanceled exn -> ccont exn) - /// When using .NET 4.0 you can replace this type by Task<'T> + /// When using .NET 4.0 you can replace this type by [] type AsyncResultCell<'T>() = let mutable result = None @@ -496,7 +494,7 @@ module internal AsyncUtil = | _ -> grabbedConts |> List.iter postOrQueue - /// Get the reified result + /// Get the reified result. member private x.AsyncPrimitiveResult = Async.FromContinuations(fun (cont,_,_) -> let grabbedResult = @@ -515,7 +513,7 @@ module internal AsyncUtil = | Some res -> cont res) - /// Get the result and commit it + /// Get the result and Commit(...). member x.AsyncResult = async { let! res = x.AsyncPrimitiveResult return! AsyncResult.Commit(res) } diff --git a/src/fsharp/pars.fsy b/src/fsharp/pars.fsy index 1f0a17b7d3..27aab7b257 100755 --- a/src/fsharp/pars.fsy +++ b/src/fsharp/pars.fsy @@ -252,6 +252,7 @@ let rangeOfLongIdent(lid:LongIdent) = %token OBLOCKEND OBLOCKEND_COMING_SOON OBLOCKEND_IS_HERE /* LexFilter #light inserts when closing CtxtSeqBlock(_,_,AddBlockEnd) */ %token OINTERFACE_MEMBER /* inserted for non-paranthetical use of 'INTERFACE', i.e. not INTERFACE/END */ +%token FIXED %token ODUMMY /* These are artificial */ @@ -281,7 +282,7 @@ let rangeOfLongIdent(lid:LongIdent) = %type <(Ast.SynEnumCase, Ast.SynUnionCase) Choice list> unionTypeRepr %type tyconDefnAugmentation %type exconDefn -%type exconCore +%type exconCore %type moduleDefnsOrExprPossiblyEmptyOrBlock %type openDecl %type path @@ -616,28 +617,28 @@ signatureFile: /* The start of a module declaration */ moduleIntro: - | moduleKeyword opt_access path - { $3.Lid,grabXmlDoc(parseState,1),$2 } + | moduleKeyword opt_access opt_rec path + { $3, $4.Lid, grabXmlDoc(parseState,1), $2 } /* The start of a namespace declaration */ namespaceIntro: - | NAMESPACE path - { $2.Lid,grabXmlDoc(parseState,1) } + | NAMESPACE opt_rec path + { $2, $3.Lid, grabXmlDoc(parseState,1) } /* The contents of a signature file */ fileNamespaceSpecs: | fileModuleSpec - { ParsedSigFile([],[ ($1 ([],PreXmlDoc.Empty)) ]) } + { ParsedSigFile([],[ ($1 (false,[],PreXmlDoc.Empty)) ]) } | fileModuleSpec fileNamespaceSpecList { // If there are namespaces, the first fileModuleImpl may only contain # directives let decls = - match ($1 ([],PreXmlDoc.Empty)) with + match ($1 (false,[],PreXmlDoc.Empty)) with | ParsedSigFileFragment.AnonModule(decls,m) -> decls - | ParsedSigFileFragment.NamespaceFragment(_,_, decls, _,_,_) -> decls - | ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(_,_,_,_,_,_,m)) -> + | ParsedSigFileFragment.NamespaceFragment(_,_,_, decls, _,_,_) -> decls + | ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(_,_,_,_,_,_,_,m)) -> raiseParseErrorAt m (FSComp.SR.parsOnlyHashDirectivesAllowed()) let decls = decls |> List.collect (function @@ -657,7 +658,7 @@ fileNamespaceSpecList: fileNamespaceSpec: | namespaceIntro deprecated_opt_equals fileModuleSpec - { let path,xml = $1 in ($3 (path,xml)) } + { let isRec,path,xml = $1 in ($3 (isRec,path,xml)) } /* The single module declaration that can make up a signature file */ @@ -666,18 +667,18 @@ fileModuleSpec: { if isSome $2 then errorR(Error(FSComp.SR.parsVisibilityDeclarationsShouldComePriorToIdentifier(),rhs parseState 2)); let m2 = rhs parseState 3 let m = (rhs2 parseState 3 4) - (fun (path,_) -> + let isRec,path2,xml,vis = $3 + (fun (isRec2,path,_) -> if nonNil path then errorR(Error(FSComp.SR.parsNamespaceOrModuleNotBoth(),m2)); - let path2,xml,vis = $3 let lid = path@path2 - ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid,true, $4, xml,$1,vis,m))) } + ParsedSigFileFragment.NamedModule(SynModuleOrNamespaceSig(lid, (isRec || isRec2), true, $4, xml,$1,vis,m))) } | moduleSpfnsPossiblyEmptyBlock { let m = (rhs parseState 1) - (fun (path,xml) -> + (fun (isRec, path, xml) -> match path with | [] -> ParsedSigFileFragment.AnonModule($1, m) - | _ -> ParsedSigFileFragment.NamespaceFragment(path,false, $1, xml,[],m)) } + | _ -> ParsedSigFileFragment.NamespaceFragment(path, isRec, false, $1, xml,[],m)) } moduleSpfnsPossiblyEmptyBlock: @@ -728,18 +729,20 @@ moduleSpfn: | opt_attributes opt_declVisibility moduleIntro colonOrEquals namedModuleAbbrevBlock { if isSome $2 then errorR(Error(FSComp.SR.parsVisibilityDeclarationsShouldComePriorToIdentifier(),rhs parseState 2)); - let path,xml,vis = $3 + let isRec, path, xml, vis = $3 + if isRec then raiseParseErrorAt (rhs parseState 3) (FSComp.SR.parsInvalidUseOfRec()); if List.length path <> 1 then raiseParseErrorAt (rhs parseState 3) (FSComp.SR.parsModuleAbbreviationMustBeSimpleName()); if List.length $1 <> 0 then raiseParseErrorAt (rhs parseState 1) (FSComp.SR.parsIgnoreAttributesOnModuleAbbreviation()); if isSome(vis) then raiseParseErrorAt (rhs parseState 1) (FSComp.SR.parsIgnoreVisibilityOnModuleAbbreviationAlwaysPrivate()); SynModuleSigDecl.ModuleAbbrev(List.head path,$5,rhs2 parseState 3 5) } | opt_attributes opt_declVisibility moduleIntro colonOrEquals moduleSpecBlock - { let path,xml,vis = $3 + { let isRec, path, xml, vis = $3 if List.length path <> 1 then raiseParseErrorAt (rhs parseState 3) (FSComp.SR.parsModuleDefnMustBeSimpleName()); + if isRec then raiseParseErrorAt (rhs parseState 3) (FSComp.SR.parsInvalidUseOfRec()); let info = ComponentInfo($1,[],[],path,xml,false,vis,rhs parseState 3) if isSome($2) then errorR(Error(FSComp.SR.parsVisibilityDeclarationsShouldComePriorToIdentifier(),rhs parseState 2)); - SynModuleSigDecl.NestedModule(info,$5,rhs2 parseState 3 5) } + SynModuleSigDecl.NestedModule(info, isRec, $5, rhs2 parseState 3 5) } | opt_attributes opt_declVisibility tyconSpfns { if isSome $2 then errorR(Error(FSComp.SR.parsVisibilityDeclarationsShouldComePriorToIdentifier(),rhs parseState 2)); @@ -752,8 +755,8 @@ moduleSpfn: | opt_attributes opt_declVisibility exconSpfn { if isSome $2 then errorR(Error(FSComp.SR.parsVisibilityDeclarationsShouldComePriorToIdentifier(),rhs parseState 2)); - let (ExceptionSig(ExceptionDefnRepr(cas,a,b,c,d,d2),e,f)) = $3 - let ec = (ExceptionSig(ExceptionDefnRepr($1@cas,a,b,c,d,d2),e,f)) + let (SynExceptionSig(SynExceptionDefnRepr(cas,a,b,c,d,d2),e,f)) = $3 + let ec = (SynExceptionSig(SynExceptionDefnRepr($1@cas,a,b,c,d,d2),e,f)) SynModuleSigDecl.Exception(ec, rhs parseState 3) } | OPEN path @@ -1011,7 +1014,7 @@ memberSpecFlags: /* Part of an exception definition in a signature file */ exconSpfn: | exconCore opt_classSpfn - { ExceptionSig($1,$2,lhs parseState) } + { SynExceptionSig($1,$2,lhs parseState) } /* The optional augmentation on a type definition in a signature */ @@ -1045,15 +1048,15 @@ implementationFile: /* The sequence of namespace definitions or a single module definition that makes up an implementation file */ fileNamespaceImpls: | fileModuleImpl - { ParsedImplFile([], [ ($1 ([],PreXmlDoc.Empty)) ]) } + { ParsedImplFile([], [ ($1 (false,[],PreXmlDoc.Empty)) ]) } | fileModuleImpl fileNamespaceImplList { // If there are namespaces, the first fileModuleImpl may only contain # directives let decls = - match ($1 ([],PreXmlDoc.Empty)) with + match ($1 (false,[],PreXmlDoc.Empty)) with | ParsedImplFileFragment.AnonModule(decls,m) -> decls - | ParsedImplFileFragment.NamespaceFragment(_,_, decls, _,_,_) -> decls - | ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(_,_,_,_,_,_,m)) -> + | ParsedImplFileFragment.NamespaceFragment(_,_,_, decls, _,_,_) -> decls + | ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(_,_,_,_,_,_,_,m)) -> raiseParseErrorAt m (FSComp.SR.parsOnlyHashDirectivesAllowed()) let decls = decls |> List.collect (function @@ -1076,7 +1079,7 @@ fileNamespaceImplList: /* A single namespace definition in an implementation file */ fileNamespaceImpl: | namespaceIntro deprecated_opt_equals fileModuleImpl - { let path,xml = $1 in ($3 (path,xml)) } + { let isRec, path, xml = $1 in ($3 (isRec, path, xml)) } /* A single module definition in an implementation file */ @@ -1085,18 +1088,18 @@ fileModuleImpl: { if isSome $2 then errorR(Error(FSComp.SR.parsVisibilityDeclarationsShouldComePriorToIdentifier(),rhs parseState 2)); let m2 = rhs parseState 3 let m = (m2, $4) ||> unionRangeWithListBy (fun modu -> modu.Range) - (fun (path,_) -> + let isRec2,path2,xml,vis = $3 + (fun (isRec, path, _) -> if nonNil path then errorR(Error(FSComp.SR.parsNamespaceOrModuleNotBoth(),m2)); - let path2,xml,vis = $3 let lid = path@path2 - ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid,true, $4, xml,$1,vis,m))) } + ParsedImplFileFragment.NamedModule(SynModuleOrNamespace(lid, (isRec || isRec2), true, $4, xml,$1,vis,m))) } | moduleDefnsOrExprPossiblyEmptyOrBlock { let m = (rhs parseState 1) - (fun (path,xml) -> + (fun (isRec, path, xml) -> match path with | [] -> ParsedImplFileFragment.AnonModule($1,m) - | _ -> ParsedImplFileFragment.NamespaceFragment(path,false, $1, xml,[],m)) } + | _ -> ParsedImplFileFragment.NamespaceFragment(path, isRec, false, $1, xml,[],m)) } /* A collection/block of definitions or expressions making up a module or namespace, possibly empty */ @@ -1212,18 +1215,19 @@ moduleDefn: /* 'exception' definitions */ | opt_attributes opt_declVisibility exconDefn { if isSome $2 then errorR(Error(FSComp.SR.parsVisibilityDeclarationsShouldComePriorToIdentifier(),rhs parseState 2)); - let (ExceptionDefn(ExceptionDefnRepr(cas,a,b,c,d,d2),e,f)) = $3 + let (SynExceptionDefn(SynExceptionDefnRepr(cas,a,b,c,d,d2),e,f)) = $3 let f = (f, $1) ||> unionRangeWithListBy (fun a -> a.Range) - let ec = (ExceptionDefn(ExceptionDefnRepr($1@cas,a,b,c,d,d2),e,f)) + let ec = (SynExceptionDefn(SynExceptionDefnRepr($1@cas,a,b,c,d,d2),e,f)) [ SynModuleDecl.Exception(ec, f) ] } /* 'module' definitions */ | opt_attributes opt_declVisibility moduleIntro EQUALS namedModuleDefnBlock { if isSome $2 then errorR(Error(FSComp.SR.parsVisibilityDeclarationsShouldComePriorToIdentifier(),rhs parseState 2)); - let attribs,(path,xml,vis) = $1,$3 + let attribs, (isRec, path, xml, vis) = $1,$3 match $5 with | Choice1Of2 eqn -> if isSome $2 then errorR(Error(FSComp.SR.parsVisibilityDeclarationsShouldComePriorToIdentifier(),rhs parseState 2)); + if isRec then raiseParseErrorAt (rhs parseState 3) (FSComp.SR.parsInvalidUseOfRec()); if List.length path <> 1 then raiseParseErrorAt (rhs parseState 3) (FSComp.SR.parsModuleAbbreviationMustBeSimpleName()); if List.length $1 <> 0 then raiseParseErrorAt (rhs parseState 1) (FSComp.SR.parsIgnoreAttributesOnModuleAbbreviation()); if isSome vis then raiseParseErrorAt (rhs parseState 1) (FSComp.SR.parsIgnoreAttributesOnModuleAbbreviationAlwaysPrivate()); @@ -1231,7 +1235,7 @@ moduleDefn: | Choice2Of2 def -> if List.length path <> 1 then raiseParseErrorAt (rhs parseState 3) (FSComp.SR.parsModuleAbbreviationMustBeSimpleName()); let info = ComponentInfo(attribs,[],[],path,xml,false,vis,rhs parseState 3) - [ SynModuleDecl.NestedModule(info,def,false,(rhs2 parseState 3 4, def) ||> unionRangeWithListBy (fun d -> d.Range) ) ] } + [ SynModuleDecl.NestedModule(info, isRec, def, false,(rhs2 parseState 3 4, def) ||> unionRangeWithListBy (fun d -> d.Range) ) ] } /* unattached custom attributes */ | attributes recover @@ -2310,7 +2314,7 @@ fieldDecl: /* An exception definition */ exconDefn: | exconCore opt_classDefn - { ExceptionDefn($1,$2, ($1.Range,$2) ||> unionRangeWithListBy (fun cd -> cd.Range) ) } + { SynExceptionDefn($1,$2, ($1.Range,$2) ||> unionRangeWithListBy (fun cd -> cd.Range) ) } /* Part of an exception definition */ exceptionAndGrabDoc: @@ -2319,7 +2323,7 @@ exceptionAndGrabDoc: /* Part of an exception definition */ exconCore: | exceptionAndGrabDoc opt_attributes opt_access exconIntro exconRepr - { ExceptionDefnRepr($2,$4,$5,$1,$3,(match $5 with None -> rhs2 parseState 1 4 | Some p -> unionRanges (rangeOfLongIdent p) (rhs2 parseState 1 4))) } + { SynExceptionDefnRepr($2,$4,$5,$1,$3,(match $5 with None -> rhs2 parseState 1 4 | Some p -> unionRanges (rangeOfLongIdent p) (rhs2 parseState 1 4))) } /* Part of an exception definition */ exconIntro: @@ -2957,7 +2961,8 @@ seqExpr: | hardwhiteLetBindings %prec prec_args_error { let hwlb,m = $1 let mLetKwd,isUse = match hwlb with (BindingSetPreAttrs(m,_,isUse,_,_)) -> m,isUse - reportParseErrorAt mLetKwd (FSComp.SR.parsExpectedStatementAfterLet(if isUse then "use" else "let")) + let usedKeyword = if isUse then "use" else "let" + reportParseErrorAt mLetKwd (FSComp.SR.parsExpectedExpressionAfterLet(usedKeyword,usedKeyword)) let fauxRange = m.EndRange // zero width range at end of m mkLocalBindings (m,hwlb,arbExpr("seqExpr",fauxRange)) } @@ -3280,6 +3285,9 @@ declExpr: { let spBind = SequencePointAtForLoop(rhs2 parseState 1 2) let (a,b,_) = $2 in SynExpr.ForEach(spBind,SeqExprOnly true,true,a,b,$4,unionRanges (rhs parseState 1) $4.Range) } + | FIXED declExpr + { SynExpr.Fixed($2, (unionRanges (rhs parseState 1) $2.Range)) } + | RARROW typedSeqExprBlockR { errorR(Error(FSComp.SR.parsArrowUseIsLimited(),lhs parseState)); SynExpr.YieldOrReturn((true,true),$2, (unionRanges (rhs parseState 1) $2.Range)) } diff --git a/src/fsharp/range.fs b/src/fsharp/range.fs index 7524cf746f..abad7849d9 100755 --- a/src/fsharp/range.fs +++ b/src/fsharp/range.fs @@ -133,7 +133,7 @@ let maxFileIndex = pown32 fileIndexBitCount // WARNING: Global Mutable State, holding a mapping between integers and filenames let fileIndexTable = new FileIndexTable() -// Note if we exceed the maximum number of files we'll start to report incorrect file names +// If we exceed the maximum number of files we'll start to report incorrect file names let fileIndexOfFile f = fileIndexTable.FileToIndex(f) % maxFileIndex let fileOfFileIndex n = fileIndexTable.IndexToFile(n) @@ -189,7 +189,7 @@ let posEq (p1:pos) (p2:pos) = (p1.Line = p2.Line && p1.Column = p2.Column) let posGeq p1 p2 = posEq p1 p2 || posGt p1 p2 let posLt p1 p2 = posGt p2 p1 -// Note, this is deliberately written in an allocation-free way, i.e. m1.Start, m1.End etc. are not called +// This is deliberately written in an allocation-free way, i.e. m1.Start, m1.End etc. are not called let unionRanges (m1:range) (m2:range) = if m1.FileIndex <> m2.FileIndex then m2 else let b = diff --git a/src/fsharp/tast.fs b/src/fsharp/tast.fs index 1b023611e3..0156aae390 100755 --- a/src/fsharp/tast.fs +++ b/src/fsharp/tast.fs @@ -110,133 +110,140 @@ type ValFlags(flags:int64) = new (recValInfo, baseOrThis, isCompGen, inlineInfo, isMutable, isModuleOrMemberBinding, isExtensionMember, isIncrClassSpecialMember, isTyFunc, allowTypeInst, isGeneratedEventVal) = let flags = (match baseOrThis with - | BaseVal -> 0b000000000000000000L - | CtorThisVal -> 0b000000000000000010L - | NormalVal -> 0b000000000000000100L - | MemberThisVal -> 0b000000000000000110L) ||| - (if isCompGen then 0b000000000000001000L - else 0b000000000000000000L) ||| + | BaseVal -> 0b0000000000000000000L + | CtorThisVal -> 0b0000000000000000010L + | NormalVal -> 0b0000000000000000100L + | MemberThisVal -> 0b0000000000000000110L) ||| + (if isCompGen then 0b0000000000000001000L + else 0b00000000000000000000L) ||| (match inlineInfo with - | ValInline.PseudoVal -> 0b000000000000000000L - | ValInline.Always -> 0b000000000000010000L - | ValInline.Optional -> 0b000000000000100000L - | ValInline.Never -> 0b000000000000110000L) ||| + | ValInline.PseudoVal -> 0b0000000000000000000L + | ValInline.Always -> 0b0000000000000010000L + | ValInline.Optional -> 0b0000000000000100000L + | ValInline.Never -> 0b0000000000000110000L) ||| (match isMutable with - | Immutable -> 0b000000000000000000L - | Mutable -> 0b000000000001000000L) ||| + | Immutable -> 0b0000000000000000000L + | Mutable -> 0b0000000000001000000L) ||| (match isModuleOrMemberBinding with - | false -> 0b000000000000000000L - | true -> 0b000000000010000000L) ||| + | false -> 0b0000000000000000000L + | true -> 0b0000000000010000000L) ||| (match isExtensionMember with - | false -> 0b000000000000000000L - | true -> 0b000000000100000000L) ||| + | false -> 0b0000000000000000000L + | true -> 0b0000000000100000000L) ||| (match isIncrClassSpecialMember with - | false -> 0b000000000000000000L - | true -> 0b000000001000000000L) ||| + | false -> 0b0000000000000000000L + | true -> 0b0000000001000000000L) ||| (match isTyFunc with - | false -> 0b000000000000000000L - | true -> 0b000000010000000000L) ||| + | false -> 0b0000000000000000000L + | true -> 0b0000000010000000000L) ||| (match recValInfo with - | ValNotInRecScope -> 0b000000000000000000L - | ValInRecScope true -> 0b000000100000000000L - | ValInRecScope false -> 0b000001000000000000L) ||| + | ValNotInRecScope -> 0b0000000000000000000L + | ValInRecScope true -> 0b0000000100000000000L + | ValInRecScope false -> 0b0000001000000000000L) ||| (match allowTypeInst with - | false -> 0b000000000000000000L - | true -> 0b000100000000000000L) ||| + | false -> 0b0000000000000000000L + | true -> 0b0000100000000000000L) ||| (match isGeneratedEventVal with - | false -> 0b000000000000000000L - | true -> 0b100000000000000000L) + | false -> 0b0000000000000000000L + | true -> 0b0100000000000000000L) ValFlags(flags) member x.BaseOrThisInfo = - match (flags &&& 0b000000000000000110L) with - | 0b000000000000000000L -> BaseVal - | 0b000000000000000010L -> CtorThisVal - | 0b000000000000000100L -> NormalVal - | 0b000000000000000110L -> MemberThisVal + match (flags &&& 0b0000000000000000110L) with + | 0b0000000000000000000L -> BaseVal + | 0b0000000000000000010L -> CtorThisVal + | 0b0000000000000000100L -> NormalVal + | 0b0000000000000000110L -> MemberThisVal | _ -> failwith "unreachable" - member x.IsCompilerGenerated = (flags &&& 0b000000000000001000L) <> 0x0L + member x.IsCompilerGenerated = (flags &&& 0b0000000000000001000L) <> 0x0L member x.SetIsCompilerGenerated(isCompGen) = - let flags = (flags &&& ~~~0b000000000000001000L) ||| + let flags = (flags &&& ~~~0b0000000000000001000L) ||| (match isCompGen with - | false -> 0b000000000000000000L - | true -> 0b000000000000001000L) + | false -> 0b0000000000000000000L + | true -> 0b0000000000000001000L) ValFlags(flags) member x.InlineInfo = - match (flags &&& 0b000000000000110000L) with - | 0b000000000000000000L -> ValInline.PseudoVal - | 0b000000000000010000L -> ValInline.Always - | 0b000000000000100000L -> ValInline.Optional - | 0b000000000000110000L -> ValInline.Never + match (flags &&& 0b0000000000000110000L) with + | 0b0000000000000000000L -> ValInline.PseudoVal + | 0b0000000000000010000L -> ValInline.Always + | 0b0000000000000100000L -> ValInline.Optional + | 0b0000000000000110000L -> ValInline.Never | _ -> failwith "unreachable" member x.MutabilityInfo = - match (flags &&& 0b000000000001000000L) with - | 0b000000000000000000L -> Immutable - | 0b000000000001000000L -> Mutable + match (flags &&& 0b0000000000001000000L) with + | 0b0000000000000000000L -> Immutable + | 0b0000000000001000000L -> Mutable | _ -> failwith "unreachable" member x.IsMemberOrModuleBinding = - match (flags &&& 0b000000000010000000L) with - | 0b000000000000000000L -> false - | 0b000000000010000000L -> true + match (flags &&& 0b0000000000010000000L) with + | 0b0000000000000000000L -> false + | 0b0000000000010000000L -> true | _ -> failwith "unreachable" - member x.SetIsMemberOrModuleBinding = ValFlags(flags ||| 0b000000000010000000L) + member x.SetIsMemberOrModuleBinding = ValFlags(flags ||| 0b0000000000010000000L) - member x.IsExtensionMember = (flags &&& 0b000000000100000000L) <> 0L - member x.IsIncrClassSpecialMember = (flags &&& 0b000000001000000000L) <> 0L - member x.IsTypeFunction = (flags &&& 0b000000010000000000L) <> 0L + member x.IsExtensionMember = (flags &&& 0b0000000000100000000L) <> 0L + member x.IsIncrClassSpecialMember = (flags &&& 0b0000000001000000000L) <> 0L + member x.IsTypeFunction = (flags &&& 0b0000000010000000000L) <> 0L - member x.RecursiveValInfo = match (flags &&& 0b000001100000000000L) with - | 0b000000000000000000L -> ValNotInRecScope - | 0b000000100000000000L -> ValInRecScope(true) - | 0b000001000000000000L -> ValInRecScope(false) + member x.RecursiveValInfo = match (flags &&& 0b0000001100000000000L) with + | 0b0000000000000000000L -> ValNotInRecScope + | 0b0000000100000000000L -> ValInRecScope(true) + | 0b0000001000000000000L -> ValInRecScope(false) | _ -> failwith "unreachable" member x.SetRecursiveValInfo(recValInfo) = let flags = - (flags &&& ~~~0b000001100000000000L) ||| + (flags &&& ~~~0b0000001100000000000L) ||| (match recValInfo with - | ValNotInRecScope -> 0b000000000000000000L - | ValInRecScope(true) -> 0b000000100000000000L - | ValInRecScope(false) -> 0b000001000000000000L) + | ValNotInRecScope -> 0b0000000000000000000L + | ValInRecScope(true) -> 0b0000000100000000000L + | ValInRecScope(false) -> 0b0000001000000000000L) ValFlags(flags) - member x.MakesNoCriticalTailcalls = (flags &&& 0b000010000000000000L) <> 0L + member x.MakesNoCriticalTailcalls = (flags &&& 0b0000010000000000000L) <> 0L - member x.SetMakesNoCriticalTailcalls = ValFlags(flags ||| 0b000010000000000000L) + member x.SetMakesNoCriticalTailcalls = ValFlags(flags ||| 0b0000010000000000000L) - member x.PermitsExplicitTypeInstantiation = (flags &&& 0b000100000000000000L) <> 0L - member x.HasBeenReferenced = (flags &&& 0b001000000000000000L) <> 0L + member x.PermitsExplicitTypeInstantiation = (flags &&& 0b0000100000000000000L) <> 0L + member x.HasBeenReferenced = (flags &&& 0b0001000000000000000L) <> 0L - member x.SetHasBeenReferenced = ValFlags(flags ||| 0b001000000000000000L) + member x.SetHasBeenReferenced = ValFlags(flags ||| 0b0001000000000000000L) - member x.IsCompiledAsStaticPropertyWithoutField = (flags &&& 0b010000000000000000L) <> 0L + member x.IsCompiledAsStaticPropertyWithoutField = (flags &&& 0b0010000000000000000L) <> 0L - member x.SetIsCompiledAsStaticPropertyWithoutField = ValFlags(flags ||| 0b010000000000000000L) + member x.SetIsCompiledAsStaticPropertyWithoutField = ValFlags(flags ||| 0b0010000000000000000L) - member x.IsGeneratedEventVal = (flags &&& 0b100000000000000000L) <> 0L + + member x.IsGeneratedEventVal = (flags &&& 0b0100000000000000000L) <> 0L + + member x.IsFixed = (flags &&& 0b1000000000000000000L) <> 0L + + member x.SetIsFixed = ValFlags(flags ||| 0b1000000000000000000L) + + /// Get the flags as included in the F# binary metadata member x.PickledBits = // Clear the RecursiveValInfo, only used during inference and irrelevant across assembly boundaries // Clear the IsCompiledAsStaticPropertyWithoutField, only used to determine whether to use a true field for a value, and to eliminate the optimization info for observable bindings // Clear the HasBeenReferenced, only used to report "unreferenced variable" warnings and to help collect 'it' values in FSI.EXE // Clear the IsGeneratedEventVal, since there's no use in propagating specialname information for generated add/remove event vals - (flags &&& ~~~0b011001100000000000L) + (flags &&& ~~~0b0011001100000000000L) /// Represents the kind of a type parameter [] @@ -350,11 +357,12 @@ type TyparFlags(flags:int32) = [] type EntityFlags(flags:int64) = - new (usesPrefixDisplay, isModuleOrNamespace, preEstablishedHasDefaultCtor, hasSelfReferentialCtor) = + new (usesPrefixDisplay, isModuleOrNamespace, preEstablishedHasDefaultCtor, hasSelfReferentialCtor, isStructRecordOrUnionType) = EntityFlags((if isModuleOrNamespace then 0b00000000001L else 0L) ||| (if usesPrefixDisplay then 0b00000000010L else 0L) ||| (if preEstablishedHasDefaultCtor then 0b00000000100L else 0L) ||| - (if hasSelfReferentialCtor then 0b00000001000L else 0L)) + (if hasSelfReferentialCtor then 0b00000001000L else 0L) ||| + (if isStructRecordOrUnionType then 0b00000100000L else 0L)) member x.IsModuleOrNamespace = (flags &&& 0b00000000001L) <> 0x0L member x.IsPrefixDisplay = (flags &&& 0b00000000010L) <> 0x0L @@ -368,7 +376,10 @@ type EntityFlags(flags:int64) = // case sub-classes must protect themselves against early access to their contents. member x.HasSelfReferentialConstructor = (flags &&& 0b00000001000L) <> 0x0L - /// This bit is reserved for us in the pickle format, see pickle.fs, it's bing listed here to stop it ever being used for anything else + /// This bit represents a F# record that is a value type, or a struct record. + member x.IsStructRecordOrUnionType = (flags &&& 0b00000100000L) <> 0x0L + + /// This bit is reserved for us in the pickle format, see pickle.fs, it's being listed here to stop it ever being used for anything else static member ReservedBitForPickleFormatTyconReprFlag = 0b00000010000L /// Get the flags as included in the F# binary metadata @@ -384,7 +395,11 @@ assert (sizeof = 4) let unassignedTyparName = "?" -exception UndefinedName of int * (* error func that expects identifier name *)(string -> string) * Ident * string list +type Predictions = Set + +let NoPredictions = Set.empty + +exception UndefinedName of int * (* error func that expects identifier name *)(string -> string) * Ident * Predictions exception InternalUndefinedItemRef of (string * string * string -> int * string) * string * string * string let KeyTyconByDemangledNameAndArity nm (typars: _ list) x = @@ -673,7 +688,7 @@ type Entity = /// static fields, 'val' declarations and hidden fields from the compilation of implicit class constructions. member x.AllFieldTable = match x.TypeReprInfo with - | TRecdRepr x | TFsObjModelRepr {fsobjmodel_rfields=x} -> x + | TRecdRepr x | TFSharpObjectRepr {fsobjmodel_rfields=x} -> x | _ -> match x.ExceptionInfo with | TExnFresh x -> x @@ -709,12 +724,12 @@ type Entity = member x.GetFieldByName n = x.AllFieldTable.FieldByName n /// Indicate if this is a type whose r.h.s. is known to be a union type definition. - member x.IsUnionTycon = match x.TypeReprInfo with | TFiniteUnionRepr _ -> true | _ -> false + member x.IsUnionTycon = match x.TypeReprInfo with | TUnionRepr _ -> true | _ -> false /// Get the union cases and other union-type information for a type, if any member x.UnionTypeInfo = match x.TypeReprInfo with - | TFiniteUnionRepr x -> Some x + | TUnionRepr x -> Some x | _ -> None /// Get the union cases for a type, if any @@ -751,15 +766,15 @@ type Entity = /// Get the blob of information associated with an F# object-model type definition, i.e. class, interface, struct etc. member x.FSharpObjectModelTypeInfo = match x.TypeReprInfo with - | TFsObjModelRepr x -> x + | TFSharpObjectRepr x -> x | _ -> assert false; failwith "not an F# object model type definition" /// Indicate if this is a type definition backed by Abstract IL metadata. - member x.IsILTycon = match x.TypeReprInfo with | TILObjModelRepr _ -> true | _ -> false + member x.IsILTycon = match x.TypeReprInfo with | TILObjectRepr _ -> true | _ -> false /// Get the Abstract IL scope, nesting and metadata for this /// type definition, assuming it is backed by Abstract IL metadata. - member x.ILTyconInfo = match x.TypeReprInfo with | TILObjModelRepr (a,b,c) -> (a,b,c) | _ -> assert false; failwith "not a .NET type definition" + member x.ILTyconInfo = match x.TypeReprInfo with | TILObjectRepr (a,b,c) -> (a,b,c) | _ -> assert false; failwith "not a .NET type definition" /// Get the Abstract IL metadata for this type definition, assuming it is backed by Abstract IL metadata. member x.ILTyconRawMetadata = let _,_,td = x.ILTyconInfo in td @@ -767,8 +782,11 @@ type Entity = /// Indicates if this is an F# type definition whose r.h.s. is known to be a record type definition. member x.IsRecordTycon = match x.TypeReprInfo with | TRecdRepr _ -> true | _ -> false + /// Indicates if this is an F# type definition whose r.h.s. is known to be a record type definition that is a value type. + member x.IsStructRecordOrUnionTycon = match x.TypeReprInfo with TRecdRepr _ | TUnionRepr _ -> x.Data.entity_flags.IsStructRecordOrUnionType | _ -> false + /// Indicates if this is an F# type definition whose r.h.s. is known to be some kind of F# object model definition - member x.IsFSharpObjectModelTycon = match x.TypeReprInfo with | TFsObjModelRepr _ -> true | _ -> false + member x.IsFSharpObjectModelTycon = match x.TypeReprInfo with | TFSharpObjectRepr _ -> true | _ -> false /// Indicates if this is an F# type definition which is one of the special types in FSharp.Core.dll which uses /// an assembly-code representation for the type, e.g. the primitive array type constructor. @@ -810,10 +828,14 @@ type Entity = /// Indicates if this is an F#-defined struct or enum type definition , i.e. a value type definition member x.IsFSharpStructOrEnumTycon = - x.IsFSharpObjectModelTycon && - match x.FSharpObjectModelTypeInfo.fsobjmodel_kind with - | TTyconClass | TTyconInterface | TTyconDelegate _ -> false - | TTyconStruct | TTyconEnum -> true + match x.TypeReprInfo with + | TRecdRepr _ -> x.IsStructRecordOrUnionTycon + | TUnionRepr _ -> x.IsStructRecordOrUnionTycon + | TFSharpObjectRepr info -> + match info.fsobjmodel_kind with + | TTyconClass | TTyconInterface | TTyconDelegate _ -> false + | TTyconStruct | TTyconEnum -> true + | _ -> false /// Indicates if this is a .NET-defined struct or enum type definition , i.e. a value type definition member x.IsILStructOrEnumTycon = @@ -924,7 +946,7 @@ type Entity = let boxity = if x.IsStructOrEnumTycon then AsValue else AsObject let ilTypeRef = match x.TypeReprInfo with - | TILObjModelRepr (ilScopeRef,ilEnclosingTypeDefs,ilTypeDef) -> IL.mkRefForNestedILTypeDef ilScopeRef (ilEnclosingTypeDefs, ilTypeDef) + | TILObjectRepr (ilScopeRef,ilEnclosingTypeDefs,ilTypeDef) -> IL.mkRefForNestedILTypeDef ilScopeRef (ilEnclosingTypeDefs, ilTypeDef) | _ -> ilTypeRefForCompilationPath x.CompilationPath x.CompiledName // Pre-allocate a ILType for monomorphic types, to reduce memory usage from Abstract IL nodes let ilTypeOpt = @@ -949,6 +971,8 @@ type Entity = /// Set the custom attributes on an F# type definition. member x.SetAttribs attribs = x.Data.entity_attribs <- attribs + /// Sets the structness of a record or union type definition + member x.SetIsStructRecordOrUnion b = let x = x.Data in let flags = x.entity_flags in x.entity_flags <- EntityFlags(flags.IsPrefixDisplay, flags.IsModuleOrNamespace, flags.PreEstablishedHasDefaultConstructor, flags.HasSelfReferentialConstructor, b) and @@ -1111,18 +1135,18 @@ and TyconRepresentation = /// Indicates the type is a class, struct, enum, delegate or interface - | TFsObjModelRepr of TyconObjModelData + | TFSharpObjectRepr of TyconObjModelData /// Indicates the type is a record | TRecdRepr of TyconRecdFields /// Indicates the type is a discriminated union - | TFiniteUnionRepr of TyconUnionData + | TUnionRepr of TyconUnionData - /// TILObjModelRepr(scope, nesting, definition) + /// TILObjectRepr(scope, nesting, definition) /// /// Indicates the type is a type from a .NET assembly without F# metadata. - | TILObjModelRepr of ILScopeRef * ILTypeDef list * ILTypeDef + | TILObjectRepr of ILScopeRef * ILTypeDef list * ILTypeDef /// Indicates the type is implemented as IL assembly code using the given closed Abstract IL type | TAsmRepr of ILType @@ -1717,7 +1741,7 @@ and Construct = entity_kind=kind entity_range=m entity_other_range=None - entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false,preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false) + entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false,preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordOrUnionType=false) entity_attribs=[] // fetched on demand via est.fs API entity_typars= LazyWithContext.NotLazy [] entity_tycon_abbrev = None @@ -1746,7 +1770,7 @@ and Construct = entity_stamp=stamp entity_kind=TyparKind.Type entity_modul_contents = mtype - entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=true, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false) + entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=true, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false,isStructRecordOrUnionType=false) entity_typars=LazyWithContext.NotLazy [] entity_tycon_abbrev = None entity_tycon_repr = TNoRepr @@ -2174,6 +2198,9 @@ and /// Indicates if the backing field for a static value is suppressed. member x.IsCompiledAsStaticPropertyWithoutField = x.Data.val_flags.IsCompiledAsStaticPropertyWithoutField + /// Indicates if the value is pinned/fixed + member x.IsFixed = x.Data.val_flags.IsFixed + /// Indicates if this value allows the use of an explicit type instantiation (i.e. does it itself have explicit type arguments, /// or does it have a signature?) member x.PermitsExplicitTypeInstantiation = x.Data.val_flags.PermitsExplicitTypeInstantiation @@ -2366,6 +2393,7 @@ and member x.SetMakesNoCriticalTailcalls() = x.Data.val_flags <- x.Data.val_flags.SetMakesNoCriticalTailcalls member x.SetHasBeenReferenced() = x.Data.val_flags <- x.Data.val_flags.SetHasBeenReferenced member x.SetIsCompiledAsStaticPropertyWithoutField() = x.Data.val_flags <- x.Data.val_flags.SetIsCompiledAsStaticPropertyWithoutField + member x.SetIsFixed() = x.Data.val_flags <- x.Data.val_flags.SetIsFixed member x.SetValReprInfo info = x.Data.val_repr_info <- info member x.SetType ty = x.Data.val_type <- ty member x.SetOtherRange m = x.Data.val_other_range <- Some m @@ -3560,15 +3588,16 @@ and /// TDSwitch(input, cases, default, range) /// /// Indicates a decision point in a decision tree. - /// input -- the expression being tested - /// cases -- the list of tests and their subsequent decision trees - /// default -- the default decision tree, if any + /// input -- The expression being tested. If switching over a struct union this + /// must be the address of the expression being tested. + /// cases -- The list of tests and their subsequent decision trees + /// default -- The default decision tree, if any /// range -- (precise documentation needed) | TDSwitch of Expr * DecisionTreeCase list * DecisionTree option * range /// TDSuccess(results, targets) /// - /// Indicates the decision tree has terminated with success, calling the given target with the given parameters. + /// Indicates the decision tree has terminated with success, transferring control to the given target with the given parameters. /// results -- the expressions to be bound to the variables at the target /// target -- the target number for the continuation | TDSuccess of FlatExprs * int @@ -3812,6 +3841,8 @@ and | UnionCaseProof of UnionCaseRef /// An operation representing a field-get from a union value, where that value has been proven to be of the corresponding union case. | UnionCaseFieldGet of UnionCaseRef * int + /// An operation representing a field-get from a union value, where that value has been proven to be of the corresponding union case. + | UnionCaseFieldGetAddr of UnionCaseRef * int /// An operation representing a field-get from a union value. The value is not assumed to have been proven to be of the corresponding union case. | UnionCaseFieldSet of UnionCaseRef * int /// An operation representing a field-get from an F# exception value. @@ -3964,12 +3995,15 @@ and ModuleOrNamespaceExpr = | TMDefLet of Binding * range /// Indicates the module fragment is an evaluation of expression for side-effects | TMDefDo of Expr * range - /// Indicates the module fragment is a 'rec' definition of types, values and modules - | TMDefRec of Tycon list * Bindings * ModuleOrNamespaceBinding list * range + /// Indicates the module fragment is a 'rec' or 'non-rec' definition of types and modules + | TMDefRec of isRec:bool * Tycon list * ModuleOrNamespaceBinding list * range /// A named module-or-namespace-fragment definition -and ModuleOrNamespaceBinding = - | ModuleOrNamespaceBinding of +and [] + ModuleOrNamespaceBinding = + //| Do of Expr + | Binding of Binding + | Module of /// This ModuleOrNamespace that represents the compilation of a module as a class. /// The same set of tycons etc. are bound in the ModuleOrNamespace as in the ModuleOrNamespaceExpr ModuleOrNamespace * @@ -4111,7 +4145,6 @@ let arityOfVal (v:Val) = (match v.ValReprInfo with None -> ValReprInfo.emptyValD //--------------------------------------------------------------------------- let mapTImplFile f (TImplFile(fragName,pragmas,moduleExpr,hasExplicitEntryPoint,isScript)) = TImplFile(fragName, pragmas,f moduleExpr,hasExplicitEntryPoint,isScript) -let fmapTImplFile f z (TImplFile(fragName,pragmas,moduleExpr,hasExplicitEntryPoint,isScript)) = let z,moduleExpr = f z moduleExpr in z,TImplFile(fragName,pragmas,moduleExpr,hasExplicitEntryPoint,isScript) let mapAccImplFile f z (TImplFile(fragName,pragmas,moduleExpr,hasExplicitEntryPoint,isScript)) = let moduleExpr,z = f z moduleExpr in TImplFile(fragName,pragmas,moduleExpr,hasExplicitEntryPoint,isScript), z let foldTImplFile f z (TImplFile(_,_,moduleExpr,_,_)) = f z moduleExpr @@ -4399,19 +4432,18 @@ let fslibValRefEq fslibCcu vref1 vref2 = /// This takes into account the possibility that they may have type forwarders let primEntityRefEq compilingFslib fslibCcu (x : EntityRef) (y : EntityRef) = x === y || - match x.IsResolved,y.IsResolved with - | true, true when not compilingFslib -> x.ResolvedTarget === y.ResolvedTarget - | _ -> - match x.IsLocalRef,y.IsLocalRef with - | false, false when + + if x.IsResolved && y.IsResolved && not compilingFslib then + x.ResolvedTarget === y.ResolvedTarget + elif not x.IsLocalRef && not y.IsLocalRef && (// Two tcrefs with identical paths are always equal nonLocalRefEq x.nlr y.nlr || // The tcrefs may have forwarders. If they may possibly be equal then resolve them to get their canonical references // and compare those using pointer equality. - (not (nonLocalRefDefinitelyNotEq x.nlr y.nlr) && x.Deref === y.Deref)) -> + (not (nonLocalRefDefinitelyNotEq x.nlr y.nlr) && x.Deref === y.Deref)) then true - | _ -> - compilingFslib && fslibEntityRefEq fslibCcu x y + else + compilingFslib && fslibEntityRefEq fslibCcu x y /// Primitive routine to compare two UnionCaseRef's for equality let primUnionCaseRefEq compilingFslib fslibCcu (UCRef(tcr1,c1) as uc1) (UCRef(tcr2,c2) as uc2) = @@ -4426,12 +4458,10 @@ let primUnionCaseRefEq compilingFslib fslibCcu (UCRef(tcr1,c1) as uc1) (UCRef(tc /// Note this routine doesn't take type forwarding into account let primValRefEq compilingFslib fslibCcu (x : ValRef) (y : ValRef) = x === y || - match x.IsResolved,y.IsResolved with - | true, true when x.ResolvedTarget === y.ResolvedTarget -> true - | _ -> - match x.IsLocalRef,y.IsLocalRef with - | true,true when valEq x.PrivateTarget y.PrivateTarget -> true - | _ -> + if (x.IsResolved && y.IsResolved && x.ResolvedTarget === y.ResolvedTarget) || + (x.IsLocalRef && y.IsLocalRef && valEq x.PrivateTarget y.PrivateTarget) then + true + else (// Use TryDeref to guard against the platforms/times when certain F# language features aren't available, // e.g. CompactFramework doesn't have support for quotations. let v1 = x.TryDeref @@ -4506,7 +4536,7 @@ let MakeUnionCases ucs : TyconUnionData = { CasesTable=MakeUnionCasesTable ucs CompiledRepresentation=newCache() } -let MakeUnionRepr ucs = TFiniteUnionRepr (MakeUnionCases ucs) +let MakeUnionRepr ucs = TUnionRepr (MakeUnionCases ucs) let NewTypar (kind,rigid,Typar(id,staticReq,isCompGen),isFromError,dynamicReq,attribs,eqDep,compDep) = Typar.New @@ -4558,7 +4588,7 @@ let NewExn cpath (id:Ident) access repr attribs doc = entity_typars=LazyWithContext.NotLazy [] entity_tycon_abbrev = None entity_tycon_repr = TNoRepr - entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false) + entity_flags=EntityFlags(usesPrefixDisplay=false, isModuleOrNamespace=false, preEstablishedHasDefaultCtor=false, hasSelfReferentialCtor=false, isStructRecordOrUnionType=false) entity_il_repr_cache= newCache() } let NewRecdField stat konst id ty isMutable isVolatile pattribs fattribs docOption access secret = @@ -4586,7 +4616,7 @@ let NewTycon (cpath, nm, m, access, reprAccess, kind, typars, docOption, usesPre entity_kind=kind entity_range=m entity_other_range=None - entity_flags=EntityFlags(usesPrefixDisplay=usesPrefixDisplay, isModuleOrNamespace=false,preEstablishedHasDefaultCtor=preEstablishedHasDefaultCtor, hasSelfReferentialCtor=hasSelfReferentialCtor) + entity_flags=EntityFlags(usesPrefixDisplay=usesPrefixDisplay, isModuleOrNamespace=false,preEstablishedHasDefaultCtor=preEstablishedHasDefaultCtor, hasSelfReferentialCtor=hasSelfReferentialCtor, isStructRecordOrUnionType=false) entity_attribs=[] // fixed up after entity_typars=typars entity_tycon_abbrev = None @@ -4609,7 +4639,7 @@ let NewILTycon nlpath (nm,m) tps (scoref:ILScopeRef, enc, tdef:ILTypeDef) mtyp = let hasSelfReferentialCtor = tdef.IsClass && (not scoref.IsAssemblyRef && scoref.AssemblyRef.Name = "mscorlib") let tycon = NewTycon(nlpath, nm, m, taccessPublic, taccessPublic, TyparKind.Type, tps, XmlDoc.Empty, true, false, hasSelfReferentialCtor, mtyp) - tycon.Data.entity_tycon_repr <- TILObjModelRepr (scoref,enc,tdef) + tycon.Data.entity_tycon_repr <- TILObjectRepr (scoref,enc,tdef) tycon.TypeContents.tcaug_closed <- true tycon diff --git a/src/fsharp/vs/Exprs.fs b/src/fsharp/vs/Exprs.fs index 2d64cf90d3..89bd03b55f 100644 --- a/src/fsharp/vs/Exprs.fs +++ b/src/fsharp/vs/Exprs.fs @@ -57,7 +57,7 @@ module ExprUtilsImpl = // TODO: this will not work for curried methods in F# classes. // This is difficult to solve as the information in the ILMethodRef // is not sufficient to resolve to a symbol unambiguously in these cases. - let argtys = [ ilMethRef.ArgTypes |> List.map (ImportTypeFromMetadata cenv.amap m scoref tinst1 tinst2) ] + let argtys = [ ilMethRef.ArgTypes |> List.map (ImportILTypeFromMetadata cenv.amap m scoref tinst1 tinst2) ] let rty = match ImportReturnTypeFromMetaData cenv.amap m ilMethRef.ReturnType scoref tinst1 tinst2 with | None -> if isCtor then enclosingType else cenv.g.unit_ty @@ -935,15 +935,17 @@ and FSharpImplementationFileContents(cenv, mimpl) = and getDecls mdef = match mdef with - | TMDefRec(tycons,binds,mbinds,_m) -> + | TMDefRec(isRec,tycons,mbinds,_m) -> [ for tycon in tycons do let entity = FSharpEntity(cenv, mkLocalEntityRef tycon) yield FSharpImplementationFileDeclaration.Entity(entity, []) - for bind in binds do - yield getBind bind - for (ModuleOrNamespaceBinding(mspec, def)) in mbinds do - let entity = FSharpEntity(cenv, mkLocalEntityRef mspec) - yield FSharpImplementationFileDeclaration.Entity (entity, getDecls def) ] + for mbind in mbinds do + match mbind with + | ModuleOrNamespaceBinding.Module(mspec, def) -> + let entity = FSharpEntity(cenv, mkLocalEntityRef mspec) + yield FSharpImplementationFileDeclaration.Entity (entity, getDecls def) + | ModuleOrNamespaceBinding.Binding(bind) -> + yield getBind bind ] | TMAbstract(mexpr) -> getDecls2 mexpr | TMDefLet(bind,_m) -> [ yield getBind bind ] diff --git a/src/fsharp/vs/IncrementalBuild.fs b/src/fsharp/vs/IncrementalBuild.fs index eea23b29ac..e82c8f46a8 100755 --- a/src/fsharp/vs/IncrementalBuild.fs +++ b/src/fsharp/vs/IncrementalBuild.fs @@ -1265,8 +1265,8 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig // Mark up the source files with an indicator flag indicating if they are the last source file in the project let sourceFiles = - let flags = tcConfig.ComputeCanContainEntryPoint(sourceFiles |> List.map snd) - (sourceFiles,flags) ||> List.map2 (fun (m,nm) flag -> (m,nm,flag)) + let flags, isExe = tcConfig.ComputeCanContainEntryPoint(sourceFiles |> List.map snd) + ((sourceFiles,flags) ||> List.map2 (fun (m,nm) flag -> (m,nm,(flag, isExe)))) let defaultTimeStamp = DateTime.Now let getFileTimeStamp (cache: TimeStampCache) fileName = @@ -1349,7 +1349,7 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig /// This is a build task function that gets placed into the build rules as the computation for a VectorStamp /// /// Get the timestamp of the given file name. - let StampFileNameTask cache (_m:range, _filename:string, _isLastCompiland:bool, timeStamper: (TimeStampCache -> DateTime)) = + let StampFileNameTask cache (_m:range, _filename:string, _isLastCompiland, timeStamper: (TimeStampCache -> DateTime)) = timeStamper cache /// This is a build task function that gets placed into the build rules as the computation for a VectorMap @@ -1576,7 +1576,7 @@ type IncrementalBuilder(frameworkTcImportsCache: FrameworkImportsCache, tcConfig // START OF BUILD DESCRIPTION // Inputs - let fileNamesNode = InputVectorDateTime)> "FileNames" + let fileNamesNode = InputVectorDateTime)> "FileNames" let referencedAssembliesNode = InputVector*(TimeStampCache->DateTime)> "ReferencedAssemblies" // Build diff --git a/src/fsharp/vs/Reactor.fs b/src/fsharp/vs/Reactor.fs old mode 100644 new mode 100755 diff --git a/src/fsharp/vs/ServiceDeclarations.fs b/src/fsharp/vs/ServiceDeclarations.fs index ec5bdedc28..941ebe0405 100644 --- a/src/fsharp/vs/ServiceDeclarations.fs +++ b/src/fsharp/vs/ServiceDeclarations.fs @@ -8,25 +8,29 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices open System +open System.Collections.Generic open System.IO open System.Text -open System.Collections.Generic + open Microsoft.FSharp.Core.Printf open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics -open Microsoft.FSharp.Compiler.PrettyNaming -open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.Range + +open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.Lib +open Microsoft.FSharp.Compiler.PrettyNaming +open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops -open Microsoft.FSharp.Compiler.Lib -open Microsoft.FSharp.Compiler.Layout +open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.SourceCodeServices.ItemDescriptionIcons module EnvMisc2 = @@ -74,6 +78,7 @@ type FSharpToolTipText = | FSharpToolTipText of FSharpToolTipElement list +[] module internal ItemDescriptionsImpl = let isFunction g typ = @@ -1118,9 +1123,9 @@ module internal ItemDescriptionsImpl = let GlyphOfItem(denv,d) = /// Find the glyph for the given representation. - let ReprToGlyph(repr) = + let reprToGlyph repr = match repr with - | TFsObjModelRepr om -> + | TFSharpObjectRepr om -> match om.fsobjmodel_kind with | TTyconClass -> iIconGroupClass | TTyconInterface -> iIconGroupInterface @@ -1128,28 +1133,27 @@ module internal ItemDescriptionsImpl = | TTyconDelegate _ -> iIconGroupDelegate | TTyconEnum _ -> iIconGroupEnum | TRecdRepr _ -> iIconGroupType - | TFiniteUnionRepr _ -> iIconGroupUnion - | TILObjModelRepr(_,_,{tdKind=kind}) -> - match kind with + | TUnionRepr _ -> iIconGroupUnion + | TILObjectRepr(_,_,td) -> + match td.tdKind with | ILTypeDefKind.Class -> iIconGroupClass | ILTypeDefKind.ValueType -> iIconGroupStruct | ILTypeDefKind.Interface -> iIconGroupInterface | ILTypeDefKind.Enum -> iIconGroupEnum | ILTypeDefKind.Delegate -> iIconGroupDelegate - | ILTypeDefKind.Other _ -> iIconGroupTypedef | TAsmRepr _ -> iIconGroupTypedef - | TMeasureableRepr _-> iIconGroupTypedef // $$$$ TODO: glyph for units-of-measure + | TMeasureableRepr _-> iIconGroupTypedef #if EXTENSIONTYPING | TProvidedTypeExtensionPoint _-> iIconGroupTypedef | TProvidedNamespaceExtensionPoint _-> iIconGroupTypedef #endif - | TNoRepr -> iIconGroupClass // $$$$ TODO: glyph for abstract (no-representation) types + | TNoRepr -> iIconGroupClass /// Find the glyph for the given type representation. - let rec TypToGlyph(typ) = + let typeToGlyph typ = if isAppTy denv.g typ then let tcref = tcrefOfAppTy denv.g typ - tcref.TypeReprInfo |> ReprToGlyph + tcref.TypeReprInfo |> reprToGlyph elif isTupleTy denv.g typ then iIconGroupStruct elif isFunction denv.g typ then iIconGroupDelegate elif isTyparTy denv.g typ then iIconGroupStruct @@ -1157,19 +1161,19 @@ module internal ItemDescriptionsImpl = /// Find the glyph for the given value representation. - let ValueToGlyph(typ) = + let ValueToGlyph typ = if isFunction denv.g typ then iIconGroupMethod else iIconGroupConstant /// Find the major glyph of the given named item. - let NamedItemToMajorGlyph item = + let namedItemToMajorGlyph item = // This may explore assemblies that are not in the reference set, // e.g. for type abbreviations to types not in the reference set. // In this case just use iIconGroupClass. protectAssemblyExploration iIconGroupClass (fun () -> match item with | Item.Value(vref) | Item.CustomBuilder (_,vref) -> ValueToGlyph(vref.Type) - | Item.Types(_,typ::_) -> TypToGlyph(stripTyEqns denv.g typ) + | Item.Types(_,typ::_) -> typeToGlyph (stripTyEqns denv.g typ) | Item.UnionCase _ | Item.ActivePatternCase _ -> iIconGroupEnumMember | Item.ExnCase _ -> iIconGroupException @@ -1191,7 +1195,7 @@ module internal ItemDescriptionsImpl = | _ -> iIconGroupError) /// Find the minor glyph of the given named item. - let NamedItemToMinorGlyph item = + let namedItemToMinorGlyph item = // This may explore assemblies that are not in the reference set, // e.g. for type abbreviations to types not in the reference set. // In this case just use iIconItemNormal. @@ -1200,16 +1204,9 @@ module internal ItemDescriptionsImpl = | Item.Value(vref) when isFunction denv.g vref.Type -> iIconItemSpecial | _ -> iIconItemNormal) - (6 * NamedItemToMajorGlyph(d)) + NamedItemToMinorGlyph(d) + (6 * namedItemToMajorGlyph d) + namedItemToMinorGlyph d - let string_is_prefix_of m n = String.length n >= String.length m && String.sub n 0 (String.length m) = m - - - -open ItemDescriptionsImpl - - /// An intellisense declaration [] type FSharpDeclarationListItem(name, glyph:int, info) = diff --git a/src/fsharp/vs/ServiceDeclarations.fsi b/src/fsharp/vs/ServiceDeclarations.fsi index a1d9b8dcc8..fae3e56b68 100755 --- a/src/fsharp/vs/ServiceDeclarations.fsi +++ b/src/fsharp/vs/ServiceDeclarations.fsi @@ -12,6 +12,7 @@ open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Infos open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops diff --git a/src/fsharp/vs/ServiceLexing.fs b/src/fsharp/vs/ServiceLexing.fs old mode 100644 new mode 100755 index 93b08a9cc0..9dd62e444a --- a/src/fsharp/vs/ServiceLexing.fs +++ b/src/fsharp/vs/ServiceLexing.fs @@ -250,7 +250,7 @@ module internal TokenClassifications = | FINALLY | LAZY | MATCH | MUTABLE | NEW | OF | OPEN | OR | VOID | EXTERN | INTERFACE | REC | TO | TRUE | TRY | TYPE | VAL | INLINE | WHEN | WHILE | WITH | IF | THEN | ELSE | DO | DONE | LET(_) | IN (*| NAMESPACE*) | CONST - | HIGH_PRECEDENCE_PAREN_APP + | HIGH_PRECEDENCE_PAREN_APP | FIXED | HIGH_PRECEDENCE_BRACK_APP | TYPE_COMING_SOON | TYPE_IS_HERE | MODULE_COMING_SOON | MODULE_IS_HERE -> (FSharpTokenColorKind.Keyword,FSharpTokenCharKind.Keyword,FSharpTokenTriggerClass.None) diff --git a/src/fsharp/vs/ServiceLexing.fsi b/src/fsharp/vs/ServiceLexing.fsi index 1cf65e725e..059db28113 100755 --- a/src/fsharp/vs/ServiceLexing.fsi +++ b/src/fsharp/vs/ServiceLexing.fsi @@ -15,7 +15,7 @@ open System.Collections.Generic open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.Range -/// Represents encoded information for the end-of-line continutation of lexing +/// Represents encoded information for the end-of-line continuation of lexing type FSharpTokenizerLexState = int64 /// Represents stable information for the state of the laxing engine at the end of a line diff --git a/src/fsharp/vs/ServiceNavigation.fs b/src/fsharp/vs/ServiceNavigation.fs index 7666e90b89..52dafb4c99 100755 --- a/src/fsharp/vs/ServiceNavigation.fs +++ b/src/fsharp/vs/ServiceNavigation.fs @@ -136,9 +136,19 @@ module NavigationImpl = | _ -> [] // Process a class declaration or F# type declaration - let rec processTycon baseName (TypeDefn(ComponentInfo(_, _, _, lid, _, _, _, _), repr, membDefns, m)) = + let rec processExnDefnRepr baseName nested (SynExceptionDefnRepr(_, (UnionCase(_, id, fldspec, _, _, _)), _, _, _, m)) = + // Exception declaration + [ createDecl(baseName, id, ExnDecl, iIconGroupException, m, fldspecRange fldspec, nested) ] + + // Process a class declaration or F# type declaration + and processExnDefn baseName (SynExceptionDefn(repr, membDefns, _)) = + let nested = processMembers membDefns |> snd + processExnDefnRepr baseName nested repr + + and processTycon baseName (TypeDefn(ComponentInfo(_, _, _, lid, _, _, _, _), repr, membDefns, m)) = let topMembers = processMembers membDefns |> snd match repr with + | SynTypeDefnRepr.Exception repr -> processExnDefnRepr baseName [] repr | SynTypeDefnRepr.ObjectModel(_, membDefns, mb) -> // F# class declaration let members = processMembers membDefns |> snd @@ -205,7 +215,7 @@ module NavigationImpl = | SynModuleDecl.ModuleAbbrev(id, lid, m) -> [ createDecl(baseName, id, ModuleDecl, iIconGroupModule, m, rangeOfLid lid, []) ] - | SynModuleDecl.NestedModule(ComponentInfo(_, _, _, lid, _, _, _, _), decls, _, m) -> + | SynModuleDecl.NestedModule(ComponentInfo(_, _, _, lid, _, _, _, _), _isRec, decls, _, m) -> // Find let bindings (for the right dropdown) let nested = processNestedDeclarations(decls) let newBaseName = (if (baseName = "") then "" else baseName+".") + (textOfLid lid) @@ -215,18 +225,14 @@ module NavigationImpl = createDeclLid(baseName, lid, ModuleDecl, iIconGroupModule, m, unionRangesChecked (rangeOfDecls nested) (moduleRange (rangeOfLid lid) other), nested)::other | SynModuleDecl.Types(tydefs, _) -> tydefs |> List.collect (processTycon baseName) - - | SynModuleDecl.Exception(ExceptionDefn(ExceptionDefnRepr(_, (UnionCase(_, id, fldspec, _, _, _)), _, _, _, _), membDefns, _), m) -> - // Exception declaration - let nested = processMembers membDefns |> snd - [ createDecl(baseName, id, ExnDecl, iIconGroupException, m, fldspecRange fldspec, nested) ] + | SynModuleDecl.Exception (defn,_) -> processExnDefn baseName defn | _ -> [] ) // Collect all the items let items = // Show base name for this module only if it's not the root one let singleTopLevel = (modules.Length = 1) - modules |> List.collect (fun (SynModuleOrNamespace(id,isModule,decls,_,_,_,m)) -> + modules |> List.collect (fun (SynModuleOrNamespace(id, _isRec, isModule, decls, _, _, _, m)) -> let baseName = if (not singleTopLevel) then textOfLid id else "" // Find let bindings (for the right dropdown) let nested = processNestedDeclarations(decls) diff --git a/src/fsharp/vs/ServiceParseTreeWalk.fs b/src/fsharp/vs/ServiceParseTreeWalk.fs index fdf68fabd0..980d02eb15 100755 --- a/src/fsharp/vs/ServiceParseTreeWalk.fs +++ b/src/fsharp/vs/ServiceParseTreeWalk.fs @@ -136,7 +136,7 @@ module (*internal*) AstTraversal = let path = TraverseStep.Module m :: path match m with | SynModuleDecl.ModuleAbbrev(_ident, _longIdent, _range) -> None - | SynModuleDecl.NestedModule(_synComponentInfo, synModuleDecls, _, _range) -> synModuleDecls |> List.map (fun x -> dive x x.Range (traverseSynModuleDecl path)) |> pick decl + | SynModuleDecl.NestedModule(_synComponentInfo, _isRec, synModuleDecls, _, _range) -> synModuleDecls |> List.map (fun x -> dive x x.Range (traverseSynModuleDecl path)) |> pick decl | SynModuleDecl.Let(_, synBindingList, _range) -> synBindingList |> List.map (fun x -> dive x x.RangeOfBindingAndRhs (traverseSynBinding path)) |> pick decl | SynModuleDecl.DoExpr(_sequencePointInfoForBinding, synExpr, _range) -> traverseSynExpr path synExpr | SynModuleDecl.Types(synTypeDefnList, _range) -> synTypeDefnList |> List.map (fun x -> dive x x.Range (traverseSynTypeDefn path)) |> pick decl @@ -147,7 +147,7 @@ module (*internal*) AstTraversal = | SynModuleDecl.NamespaceFragment(synModuleOrNamespace) -> traverseSynModuleOrNamespace path synModuleOrNamespace visitor.VisitModuleDecl(defaultTraverse, decl) - and traverseSynModuleOrNamespace path (SynModuleOrNamespace(_longIdent, _isModule, synModuleDecls, _preXmlDoc, _synAttributes, _synAccessOpt, range) as mors) = + and traverseSynModuleOrNamespace path (SynModuleOrNamespace(_longIdent, _isRec, _isModule, synModuleDecls, _preXmlDoc, _synAttributes, _synAccessOpt, range) as mors) = let path = TraverseStep.ModuleOrNamespace mors :: path synModuleDecls |> List.map (fun x -> dive x x.Range (traverseSynModuleDecl path)) |> pick range mors and traverseSynExpr path (expr:SynExpr) = @@ -317,6 +317,7 @@ module (*internal*) AstTraversal = |> pick expr | SynExpr.Do(synExpr, _range) -> traverseSynExpr synExpr | SynExpr.Assert(synExpr, _range) -> traverseSynExpr synExpr + | SynExpr.Fixed(synExpr, _range) -> traverseSynExpr synExpr | SynExpr.App(_exprAtomicFlag, isInfix, synExpr, synExpr2, _range) -> if isInfix then [dive synExpr2 synExpr2.Range traverseSynExpr @@ -455,12 +456,16 @@ module (*internal*) AstTraversal = let path = TraverseStep.TypeDefn tydef :: path [ match synTypeDefnRepr with - | ObjectModel(synTypeDefnKind, synMemberDefns, _oRange) -> + | SynTypeDefnRepr.Exception _ -> + // This node is generated in TypeChecker.fs, not in the AST. + // But note exception declarations are missing from this tree walk. + () + | SynTypeDefnRepr.ObjectModel(synTypeDefnKind, synMemberDefns, _oRange) -> // traverse inherit function is used to capture type specific data required for processing Inherit part let traverseInherit (synType : SynType, range : range) = visitor.VisitInheritSynMemberDefn(synComponentInfo, synTypeDefnKind, synType, synMemberDefns, range) yield! synMemberDefns |> normalizeMembersToDealWithPeculiaritiesOfGettersAndSetters path traverseInherit - | Simple(synTypeDefnSimpleRepr, _range) -> + | SynTypeDefnRepr.Simple(synTypeDefnSimpleRepr, _range) -> match synTypeDefnSimpleRepr with | SynTypeDefnSimpleRepr.TypeAbbrev(_,synType,m) -> yield dive synTypeDefnRepr synTypeDefnRepr.Range (fun _ -> visitor.VisitTypeAbbrev(synType,m)) diff --git a/src/fsharp/vs/ServiceUntypedParse.fs b/src/fsharp/vs/ServiceUntypedParse.fs index be4ddabed8..65827a9dbd 100755 --- a/src/fsharp/vs/ServiceUntypedParse.fs +++ b/src/fsharp/vs/ServiceUntypedParse.fs @@ -171,6 +171,7 @@ type FSharpParseFileResults(errors : FSharpErrorInfo[], input : Ast.ParsedInput | SynExpr.DiscardAfterMissingQualificationAfterDot (e,_) | SynExpr.Do (e,_) | SynExpr.Assert (e,_) + | SynExpr.Fixed (e,_) | SynExpr.DotGet (e,_,_,_) | SynExpr.LongIdentSet (_,e,_) | SynExpr.New (_,_,e,_) @@ -312,20 +313,20 @@ type FSharpParseFileResults(errors : FSharpErrorInfo[], input : Ast.ParsedInput yield! walkExpr false expr | SynModuleDecl.ModuleAbbrev _ -> () - | SynModuleDecl.NestedModule(_, decls, _, m) -> + | SynModuleDecl.NestedModule(_, _isRec, decls, _, m) -> if rangeContainsPos m pos then for d in decls do yield! walkDecl d | SynModuleDecl.Types(tydefs, m) -> if rangeContainsPos m pos then for d in tydefs do yield! walkTycon d - | SynModuleDecl.Exception(ExceptionDefn(ExceptionDefnRepr(_, _, _, _, _, _), membDefns, _), m) -> + | SynModuleDecl.Exception(SynExceptionDefn(SynExceptionDefnRepr(_, _, _, _, _, _), membDefns, _), m) -> if rangeContainsPos m pos then for m in membDefns do yield! walkMember m | _ -> () ] // Collect all the items - let walkModule (SynModuleOrNamespace(_,_,decls,_,_,_,m)) = + let walkModule (SynModuleOrNamespace(_,_,_,decls,_,_,_,m)) = if rangeContainsPos m pos then [ for d in decls do yield! walkDecl d ] else diff --git a/src/fsharp/vs/Symbols.fs b/src/fsharp/vs/Symbols.fs index 6bcc57fa69..4685c9a50e 100644 --- a/src/fsharp/vs/Symbols.fs +++ b/src/fsharp/vs/Symbols.fs @@ -9,6 +9,9 @@ open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.AttributeChecking +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.Range open Microsoft.FSharp.Compiler.Ast open Microsoft.FSharp.Compiler.CompileOps @@ -371,7 +374,7 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member __.FSharpDelegateSignature = checkIsResolved() match entity.TypeReprInfo with - | TFsObjModelRepr r when entity.IsFSharpDelegateTycon -> + | TFSharpObjectRepr r when entity.IsFSharpDelegateTycon -> match r.fsobjmodel_kind with | TTyconDelegate ss -> FSharpDelegateSignature(cenv, ss) | _ -> invalidOp "not a delegate type" @@ -506,7 +509,7 @@ and FSharpEntity(cenv:cenv, entity:EntityRef) = member __.Attributes = if isUnresolved() then makeReadOnlyCollection[] else - AttributeChecking.GetAttribInfosOfEntity cenv.g cenv.amap range0 entity + GetAttribInfosOfEntity cenv.g cenv.amap range0 entity |> List.map (fun a -> FSharpAttribute(cenv, a)) |> makeReadOnlyCollection @@ -805,7 +808,7 @@ and FSharpAccessibility(a:Accessibility, ?isProtected) = override x.ToString() = stringOfAccess a -and [] FSharpAccessibilityRights(thisCcu: CcuThunk, ad:Infos.AccessorDomain) = +and [] FSharpAccessibilityRights(thisCcu: CcuThunk, ad:AccessorDomain) = member internal __.ThisCcu = thisCcu member internal __.Contents = ad @@ -1534,7 +1537,7 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = match d with | P p -> - [ [ for (ParamData(isParamArrayArg,isOutArg,optArgInfo,nmOpt,_reflArgInfo,pty)) in p.GetParamDatas(cenv.amap,range0) do + [ [ for (ParamData(isParamArrayArg,isOutArg,optArgInfo,_callerInfoInfo,nmOpt,_reflArgInfo,pty)) in p.GetParamDatas(cenv.amap,range0) do // INCOMPLETENESS: Attribs is empty here, so we can't look at attributes for // either .NET or F# parameters let argInfo : ArgReprInfo = { Name=nmOpt; Attribs= [] } @@ -1546,7 +1549,7 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = | M m -> [ for argtys in m.GetParamDatas(cenv.amap,range0,m.FormalMethodInst) do yield - [ for (ParamData(isParamArrayArg,isOutArg,optArgInfo,nmOpt,_reflArgInfo,pty)) in argtys do + [ for (ParamData(isParamArrayArg,isOutArg,optArgInfo,_callerInfoInfo,nmOpt,_reflArgInfo,pty)) in argtys do // INCOMPLETENESS: Attribs is empty here, so we can't look at attributes for // either .NET or F# parameters let argInfo : ArgReprInfo = { Name=nmOpt; Attribs= [] } @@ -1627,11 +1630,11 @@ and FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) = let m = range0 match d with | E einfo -> - AttributeChecking.GetAttribInfosOfEvent cenv.amap m einfo |> List.map (fun a -> FSharpAttribute(cenv, a)) + GetAttribInfosOfEvent cenv.amap m einfo |> List.map (fun a -> FSharpAttribute(cenv, a)) | P pinfo -> - AttributeChecking.GetAttribInfosOfProp cenv.amap m pinfo |> List.map (fun a -> FSharpAttribute(cenv, a)) + GetAttribInfosOfProp cenv.amap m pinfo |> List.map (fun a -> FSharpAttribute(cenv, a)) | M minfo -> - AttributeChecking.GetAttribInfosOfMethod cenv.amap m minfo |> List.map (fun a -> FSharpAttribute(cenv, a)) + GetAttribInfosOfMethod cenv.amap m minfo |> List.map (fun a -> FSharpAttribute(cenv, a)) | V v -> v.Attribs |> List.map (fun a -> FSharpAttribute(cenv, AttribInfo.FSAttribInfo(cenv.g, a))) |> makeReadOnlyCollection diff --git a/src/fsharp/vs/Symbols.fsi b/src/fsharp/vs/Symbols.fsi index 0610f12a94..105b5a6f62 100644 --- a/src/fsharp/vs/Symbols.fsi +++ b/src/fsharp/vs/Symbols.fsi @@ -13,10 +13,11 @@ namespace Microsoft.FSharp.Compiler.SourceCodeServices open System.Collections.Generic open Microsoft.FSharp.Compiler -open Microsoft.FSharp.Compiler.TcGlobals -open Microsoft.FSharp.Compiler.Tast -open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.AccessibilityLogic open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.Range +open Microsoft.FSharp.Compiler.Tast +open Microsoft.FSharp.Compiler.TcGlobals module internal Impl = type internal cenv = @@ -434,8 +435,8 @@ and [] FSharpField = /// Represents the rights of a compilation to access symbols and [] FSharpAccessibilityRights = - internal new : CcuThunk * Infos.AccessorDomain -> FSharpAccessibilityRights - member internal Contents : Infos.AccessorDomain + internal new : CcuThunk * AccessorDomain -> FSharpAccessibilityRights + member internal Contents : AccessorDomain /// Indicates the accessibility of a symbol, as seen by the F# language and [] FSharpAccessibility = diff --git a/src/fsharp/vs/service.fs b/src/fsharp/vs/service.fs old mode 100644 new mode 100755 index 397ea0eef2..90ba909e93 --- a/src/fsharp/vs/service.fs +++ b/src/fsharp/vs/service.fs @@ -15,32 +15,36 @@ open System.Collections.Generic open Microsoft.FSharp.Core.Printf open Microsoft.FSharp.Compiler open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL +open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.AbstractIL.Internal open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library + +open Microsoft.FSharp.Compiler.AccessibilityLogic +open Microsoft.FSharp.Compiler.Ast +open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.ErrorLogger +open Microsoft.FSharp.Compiler.Lib open Microsoft.FSharp.Compiler.MSBuildResolver -open Microsoft.FSharp.Compiler.AbstractIL.Diagnostics open Microsoft.FSharp.Compiler.PrettyNaming - -open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Parser open Microsoft.FSharp.Compiler.Range -open Microsoft.FSharp.Compiler.Ast -open Microsoft.FSharp.Compiler.ErrorLogger open Microsoft.FSharp.Compiler.Lexhelp -open Microsoft.FSharp.Compiler.CompileOps +open Microsoft.FSharp.Compiler.Layout open Microsoft.FSharp.Compiler.Tast open Microsoft.FSharp.Compiler.Tastops open Microsoft.FSharp.Compiler.Tastops.DebugPrint -open Microsoft.FSharp.Compiler.Lib -open Microsoft.FSharp.Compiler.AbstractIL.IL -open Microsoft.FSharp.Compiler.Layout -open Microsoft.FSharp.Compiler.TypeChecker +open Microsoft.FSharp.Compiler.TcGlobals open Microsoft.FSharp.Compiler.Infos +open Microsoft.FSharp.Compiler.InfoReader open Microsoft.FSharp.Compiler.NameResolution +open Microsoft.FSharp.Compiler.TypeChecker + open Internal.Utilities.Collections open Internal.Utilities.Debug open Internal.Utilities open Internal.Utilities.StructuredFormat + open Microsoft.FSharp.Compiler.SourceCodeServices.ItemDescriptionsImpl [] @@ -88,13 +92,13 @@ module internal Params = let ParamOfUnionCaseField g denv isGenerated (i : int) f = let initial = ParamOfRecdField g denv f - let display = if isGenerated i f then initial.Display else NicePrint.stringOfParamData denv (ParamData(false, false, NotOptional, Some f.rfield_id, ReflectedArgInfo.None, f.rfield_type)) + let display = if isGenerated i f then initial.Display else NicePrint.stringOfParamData denv (ParamData(false, false, NotOptional, NoCallerInfo, Some f.rfield_id, ReflectedArgInfo.None, f.rfield_type)) FSharpMethodGroupItemParameter( name=initial.ParameterName, canonicalTypeTextForSorting=initial.CanonicalTypeTextForSorting, display=display) - let ParamOfParamData g denv (ParamData(_isParamArrayArg, _isOutArg, _optArgInfo, nmOpt, _reflArgInfo, pty) as paramData) = + let ParamOfParamData g denv (ParamData(_isParamArrayArg, _isOutArg, _optArgInfo, _callerInfoInfo, nmOpt, _reflArgInfo, pty) as paramData) = FSharpMethodGroupItemParameter( name = (match nmOpt with None -> "" | Some pn -> pn.idText), canonicalTypeTextForSorting = printCanonicalizedTypeName g denv pty, @@ -104,7 +108,7 @@ module internal Params = let ParamsOfParamDatas g denv (paramDatas:ParamData list) rty = let paramNames,paramPrefixes,paramTypes = paramDatas - |> List.map (fun (ParamData(isParamArrayArg, _isOutArg, optArgInfo, nmOpt, _reflArgInfo, pty)) -> + |> List.map (fun (ParamData(isParamArrayArg, _isOutArg, optArgInfo, _callerInfoInfo, nmOpt, _reflArgInfo, pty)) -> let isOptArg = optArgInfo.IsOptional match nmOpt, isOptArg, tryDestOptionTy denv.g pty with // Layout an optional argument @@ -251,7 +255,7 @@ module internal Params = let paramDatas = argInfo |> List.map ParamNameAndType.FromArgInfo - |> List.map (fun (ParamNameAndType(nmOpt, pty)) -> ParamData(false, false, NotOptional, nmOpt, ReflectedArgInfo.None, pty)) + |> List.map (fun (ParamNameAndType(nmOpt, pty)) -> ParamData(false, false, NotOptional, NoCallerInfo, nmOpt, ReflectedArgInfo.None, pty)) ParamsOfParamDatas g denv paramDatas returnTy | Item.UnionCase(ucr,_) -> match ucr.UnionCase.RecdFields with @@ -281,7 +285,7 @@ module internal Params = | None -> let argNamesAndTys = ItemDescriptionsImpl.ParamNameAndTypesOfUnaryCustomOperation g minfo let _, argTys, _ = PrettyTypes.PrettifyTypesN g (argNamesAndTys |> List.map (fun (ParamNameAndType(_,ty)) -> ty)) - let paramDatas = (argNamesAndTys, argTys) ||> List.map2 (fun (ParamNameAndType(nmOpt, _)) argTy -> ParamData(false, false, NotOptional, nmOpt, ReflectedArgInfo.None,argTy)) + let paramDatas = (argNamesAndTys, argTys) ||> List.map2 (fun (ParamNameAndType(nmOpt, _)) argTy -> ParamData(false, false, NotOptional, NoCallerInfo, nmOpt, ReflectedArgInfo.None,argTy)) let rty = minfo.GetFSharpReturnTy(amap, m, minfo.FormalMethodInst) ParamsOfParamDatas g denv paramDatas rty | Some _ -> @@ -290,7 +294,7 @@ module internal Params = | Item.FakeInterfaceCtor _ -> [] | Item.DelegateCtor delty -> let (SigOfFunctionForDelegate(_, _, _, fty)) = GetSigOfFunctionForDelegate infoReader delty m AccessibleFromSomeFSharpCode - ParamsOfParamDatas g denv [ParamData(false, false, NotOptional, None, ReflectedArgInfo.None, fty)] delty + ParamsOfParamDatas g denv [ParamData(false, false, NotOptional, NoCallerInfo, None, ReflectedArgInfo.None, fty)] delty | _ -> [] @@ -657,7 +661,7 @@ type TypeCheckInfo methods |> List.collect (fun meth -> match meth.GetParamDatas(amap, m, meth.FormalMethodInst) with - | x::_ -> x |> List.choose(fun (ParamData(_isParamArray, _isOut, _optArgInfo, name, _, ty)) -> + | x::_ -> x |> List.choose(fun (ParamData(_isParamArray, _isOut, _optArgInfo, _callerInfoInfo, name, _, ty)) -> match name with | Some n -> Some (Item.ArgName(n, ty, Some (ArgumentContainer.Method meth))) | None -> None @@ -1580,12 +1584,11 @@ module internal Parser = None else let isLastCompiland = - tcConfig.target.IsExe && projectSourceFiles.Length >= 1 && System.String.Compare(projectSourceFiles.[projectSourceFiles.Length-1],mainInputFileName,StringComparison.CurrentCultureIgnoreCase)=0 let isLastCompiland = isLastCompiland || CompileOps.IsScript(mainInputFileName) - - let parseResult = ParseInput(lexfun,errHandler.ErrorLogger,lexbuf,None,mainInputFileName,isLastCompiland) + let isExe = tcConfig.target.IsExe + let parseResult = ParseInput(lexfun,errHandler.ErrorLogger,lexbuf,None,mainInputFileName,(isLastCompiland,isExe)) Some parseResult with e -> errHandler.ErrorLogger.ErrorR(e) diff --git a/src/ilx/EraseClosures.fs b/src/ilx/EraseClosures.fs index 19505c55ff..e49ac9ab34 100755 --- a/src/ilx/EraseClosures.fs +++ b/src/ilx/EraseClosures.fs @@ -125,7 +125,7 @@ type cenv = tref_Func: ILTypeRef[]; mkILTyFuncTy: ILType } -let new_cenv(ilg) = +let newIlxPubCloEnv(ilg) = { ilg=ilg; tref_Func= Array.init 10 (fun i -> mkFuncTypeRef(i+1)); mkILTyFuncTy=ILType.Boxed (mkILNonGenericTySpec (mkILTyRef (IlxSettings.ilxFsharpCoreLibScopeRef (), IlxSettings.ilxNamespace () ^ ".FSharpTypeFunc"))) } @@ -173,11 +173,9 @@ let mkMethSpecForMultiApp cenv (argtys': ILType list,rty) = formalRetTy, inst.Tail.Tail)) -let mkCallBlockForMultiValueApp cenv doTailCall (args',rty') inplab outlab = +let mkCallBlockForMultiValueApp cenv doTailCall (args',rty') = let callvirt,mr = mkMethSpecForMultiApp cenv (args',rty') - let instrs = [ ( if callvirt then I_callvirt (doTailCall,mr, None) else I_call (doTailCall,mr, None) ) ] - if doTailCall = Tailcall then mkNonBranchingInstrs inplab instrs - else mkNonBranchingInstrsThenBr inplab instrs outlab + [ ( if callvirt then I_callvirt (doTailCall,mr, None) else I_call (doTailCall,mr, None) ) ] let mkMethSpecForClosureCall cenv (clospec: IlxClosureSpec) = let tyargsl,argtys,rstruct = stripSupportedAbstraction clospec.FormalLambdas @@ -196,19 +194,12 @@ let mkMethSpecForClosureCall cenv (clospec: IlxClosureSpec) = let mkLdFreeVar (clospec: IlxClosureSpec) (fv: IlxClosureFreeVar) = [ mkLdarg0; mkNormalLdfld (mkILFieldSpecInTy (clospec.ILType,fv.fvName,fv.fvType) ) ] -let rec convInstr cenv (tmps: ILLocalsAllocator, thisGenParams: ILGenericParameterDefs) inplab outlab instr = - match instr with - | I_other e when isIlxExtInstr e -> - match destIlxExtInstr e with - | i when (match i with EI_callfunc _ -> true | _ -> false) -> +let mkCallFunc cenv allocLocal numThisGenParams tl apps = + // "callfunc" and "callclo" instructions become a series of indirect // calls or a single direct call. - let varCount = thisGenParams.Length - let tl,apps = - match i with - | EI_callfunc (tl,apps) -> tl,apps - | _ -> failwith "Unexpected call instruction" + let varCount = numThisGenParams // Unwind the stack until the arguments given in the apps have // all been popped off. The apps given to this function is @@ -226,7 +217,7 @@ let rec convInstr cenv (tmps: ILLocalsAllocator, thisGenParams: ILGenericParamet | Apps_app (arg,rest) -> let storers, loaders = unwind rest let argStorers,argLoaders = - let locn = tmps.AllocLocal (mkILLocal arg None) + let locn = allocLocal arg [mkStloc locn], [mkLdloc locn] argStorers :: storers, argLoaders :: loaders | Apps_done _ -> @@ -239,7 +230,7 @@ let rec convInstr cenv (tmps: ILLocalsAllocator, thisGenParams: ILGenericParamet else stripUpTo n (function (_x::_y) -> true | _ -> false) (function (x::y) -> (x,y) | _ -> failwith "no!") loaders - let rec buildApp fst loaders apps inplab outlab = + let rec buildApp fst loaders apps = // Strip off one valid indirect call. [fst] indicates if this is the // first indirect call we're making. The code below makes use of the // fact that term and type applications are never currently mixed for @@ -258,21 +249,15 @@ let rec convInstr cenv (tmps: ILLocalsAllocator, thisGenParams: ILGenericParamet let doTailCall = andTailness tl false let instrs1 = precall @ - [ I_callvirt (doTailCall, - - (mkILInstanceMethSpecInTy (cenv.mkILTyFuncTy,"Specialize",[],cenv.ilg.typ_Object, instTyargs)), None) ] + [ I_callvirt (doTailCall, (mkILInstanceMethSpecInTy (cenv.mkILTyFuncTy,"Specialize",[],cenv.ilg.typ_Object, instTyargs)), None) ] let instrs1 = // TyFunc are represented as Specialize<_> methods returning an object. // For value types, recover result via unbox and load. // For reference types, recover via cast. let rtnTy = mkTyOfApps cenv rest' instrs1 @ [ I_unbox_any rtnTy] - if doTailCall = Tailcall then mkNonBranchingInstrs inplab instrs1 - else - let endOfCallBlock = generateCodeLabel () - let block1 = mkNonBranchingInstrsThenBr inplab instrs1 endOfCallBlock - let block2 = buildApp false loaders' rest' endOfCallBlock outlab - mkGroupBlock ([endOfCallBlock],[ block1; block2 ]) + if doTailCall = Tailcall then instrs1 + else instrs1 @ buildApp false loaders' rest' // Term applications | [],args,rest when nonNil args -> @@ -281,62 +266,52 @@ let rec convInstr cenv (tmps: ILLocalsAllocator, thisGenParams: ILGenericParamet let rty = mkTyOfApps cenv rest let doTailCall = andTailness tl isLast - let startOfCallBlock = generateCodeLabel () - let preCallBlock = mkNonBranchingInstrsThenBr inplab precall startOfCallBlock + let preCallBlock = precall if doTailCall = Tailcall then - let callBlock = mkCallBlockForMultiValueApp cenv doTailCall (args,rty) startOfCallBlock outlab - mkGroupBlock ([startOfCallBlock],[ preCallBlock; callBlock ]) + let callBlock = mkCallBlockForMultiValueApp cenv doTailCall (args,rty) + preCallBlock @ callBlock else - let endOfCallBlock = generateCodeLabel () - let callBlock = mkCallBlockForMultiValueApp cenv doTailCall (args,rty) startOfCallBlock endOfCallBlock - let restBlock = buildApp false loaders' rest endOfCallBlock outlab - mkGroupBlock ([startOfCallBlock; endOfCallBlock],[ preCallBlock; callBlock; restBlock ]) - - | [],[],Apps_done _rty -> - // "void" return values are allowed in function types - // but are translated to empty value classes. These - // values need to be popped. - mkNonBranchingInstrsThen inplab ([]) (if tl = Tailcall then I_ret else I_br outlab) + let callBlock = mkCallBlockForMultiValueApp cenv doTailCall (args,rty) + let restBlock = buildApp false loaders' rest + preCallBlock @ callBlock @ restBlock + + | [],[],Apps_done _rty -> [ ] | _ -> failwith "*** Error: internal error: unknown indirect calling convention returned by stripSupportedIndirectCall" - InstrMorph (buildApp true [] apps inplab outlab) - | _ -> InstrMorph [instr] - - | _ -> InstrMorph [instr] + buildApp true [] apps -// Fix up I_ret instruction. Generalise to selected instr. -let convReturnInstr ty _inplab _outlab instr = +// Fix up I_ret instruction. Generalise to selected instr. Remove tailcalls. +let convReturnInstr ty instr = match instr with - | I_ret -> InstrMorph [I_box ty;I_ret] - | _ -> InstrMorph [instr] + | I_ret -> [I_box ty;I_ret] + | I_call (_,mspec,varargs) -> [I_call (Normalcall,mspec,varargs)] + | I_callvirt (_,mspec,varargs) -> [I_callvirt (Normalcall,mspec,varargs)] + | I_callconstraint (_,ty,mspec,varargs) -> [I_callconstraint (Normalcall,ty,mspec,varargs)] + | I_calli (_,csig,varargs) -> [I_calli (Normalcall,csig,varargs)] + | _ -> [instr] -let convILMethodBody cenv (thisGenParams,thisClo,boxReturnTy) il = - let tmps = ILLocalsAllocator il.Locals.Length - let locals = il.Locals - // Add a local to keep the result value of a thunk while storing it - // into the result field and returning it. - // Record the local slot number in the environment passed in thisClo +let convILMethodBody (thisClo,boxReturnTy) (il: ILMethodBody) = + // This increase in maxstack is historical, though it's harmless let newMax = match thisClo with - | Some _ -> il.MaxStack+2 (* for calls *) + | Some _ -> il.MaxStack+2 | None -> il.MaxStack - let code' = morphExpandILInstrsInILCode (convInstr cenv (tmps,thisGenParams)) il.Code - let code' = match boxReturnTy with - | None -> code' - | Some ty -> (* box before returning? e.g. in the case of a TyFunc returning a struct, which compiles to a Specialise<_> method returning an object *) - morphExpandILInstrsInILCode (convReturnInstr ty) code' - {il with MaxStack=newMax; - IsZeroInit=true; - Code= code' ; - Locals = ILList.ofList (ILList.toList locals @ tmps.Close()) } - -let convMethodBody cenv (thisGenParams,thisClo) = function - | MethodBody.IL il -> MethodBody.IL (convILMethodBody cenv (thisGenParams,thisClo,None) il) + let code = il.Code + // Box before returning? e.g. in the case of a TyFunc returning a struct, which + // compiles to a Specialise<_> method returning an object + let code = + match boxReturnTy with + | None -> code + | Some ty -> morphILInstrsInILCode (convReturnInstr ty) code + {il with MaxStack=newMax; IsZeroInit=true; Code= code } + +let convMethodBody thisClo = function + | MethodBody.IL il -> MethodBody.IL (convILMethodBody (thisClo,None) il) | x -> x -let convMethodDef cenv (thisGenParams,thisClo) (md: ILMethodDef) = - let b' = convMethodBody cenv ((thisGenParams @ md.GenericParams) ,thisClo) (md.mdBody.Contents) +let convMethodDef thisClo (md: ILMethodDef) = + let b' = convMethodBody thisClo (md.mdBody.Contents) {md with mdBody=mkMethBodyAux b'} // -------------------------------------------------------------------- @@ -370,8 +345,8 @@ let mkILCloFldDefs cenv flds = // it's a type abstraction or a term abstraction. // -------------------------------------------------------------------- -let rec convIlxClosureDef cenv mdefGen encl (td: ILTypeDef) clo = - let newTypeDefs,newMethodDefs = +let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo = + let newTypeDefs = // the following are shared between cases 1 && 2 let nowFields = clo.cloFreeVars @@ -383,7 +358,7 @@ let rec convIlxClosureDef cenv mdefGen encl (td: ILTypeDef) clo = let tagApp = (Lazy.force clo.cloCode).SourceMarker let tyargsl,tmargsl,laterStruct = stripSupportedAbstraction clo.cloStructure - let laterAccess = td.Access (* (if td.Access = ILTypeDefAccess.Public then ILTypeDefAccess.Nested ILMemberAccess.Public else ILTypeDefAccess.Nested ILMemberAccess.Assembly) in*) + let laterAccess = td.Access // Adjust all the argument and environment accesses let rewriteCodeToAccessArgsFromEnv laterCloSpec (argToFreeVarMap: (int * IlxClosureFreeVar) list) = @@ -451,7 +426,7 @@ let rec convIlxClosureDef cenv mdefGen encl (td: ILTypeDef) clo = let laterCode = rewriteCodeToAccessArgsFromEnv laterCloSpec [(0, selfFreeVar)] let laterTypeDefs = - convIlxClosureDef cenv mdefGen encl + convIlxClosureDef cenv encl {td with GenericParams=laterGenericParams; Access=laterAccess; Name=laterTypeName} @@ -479,14 +454,11 @@ let rec convIlxClosureDef cenv mdefGen encl (td: ILTypeDef) clo = tagApp) let nowTypeDefs = - convIlxClosureDef cenv mdefGen encl - td {clo with cloStructure=nowStruct; - cloCode=notlazy nowCode} - nowTypeDefs @ laterTypeDefs, [] + convIlxClosureDef cenv encl td {clo with cloStructure=nowStruct; + cloCode=notlazy nowCode} + nowTypeDefs @ laterTypeDefs else // CASE 1b. Build a type application. - // Currently the sole mbody defines a class and uses - // virtual methods. let boxReturnTy = Some nowReturnTy (* box prior to all I_ret *) let nowApplyMethDef = mkILGenericVirtualMethod @@ -495,8 +467,7 @@ let rec convIlxClosureDef cenv mdefGen encl (td: ILTypeDef) clo = addedGenParams, (* method is generic over added ILGenericParameterDefs *) [], mkILReturn(cenv.ilg.typ_Object), - MethodBody.IL (convILMethodBody cenv (td.GenericParams@addedGenParams,Some nowCloSpec,boxReturnTy) - (Lazy.force clo.cloCode))) + MethodBody.IL (convILMethodBody (Some nowCloSpec,boxReturnTy) (Lazy.force clo.cloCode))) let ctorMethodDef = mkILStorageCtor (tagClo, @@ -529,7 +500,7 @@ let rec convIlxClosureDef cenv mdefGen encl (td: ILTypeDef) clo = HasSecurity=false; SecurityDecls=emptyILSecurityDecls; tdKind = ILTypeDefKind.Class;} - [ cloTypeDef], [] + [ cloTypeDef] // CASE 2 - Term Application | [], (_ :: _ as nowParams),_ -> @@ -564,22 +535,20 @@ let rec convIlxClosureDef cenv mdefGen encl (td: ILTypeDef) clo = end, tagApp) let nowTypeDefs = - convIlxClosureDef cenv mdefGen encl - td - {clo with cloStructure=nowStruct; - cloCode=notlazy nowCode} + convIlxClosureDef cenv encl td {clo with cloStructure=nowStruct; + cloCode=notlazy nowCode} let laterCode = rewriteCodeToAccessArgsFromEnv laterCloSpec argToFreeVarMap let laterTypeDefs = - convIlxClosureDef cenv mdefGen encl + convIlxClosureDef cenv encl {td with GenericParams=laterGenericParams; - Access=laterAccess; - Name=laterTypeName} + Access=laterAccess; + Name=laterTypeName} {clo with cloStructure=laterStruct; - cloFreeVars=laterFields; - cloCode=notlazy laterCode} + cloFreeVars=laterFields; + cloCode=notlazy laterCode} // add 'compiler generated' to all the methods in the 'now' classes let laterTypeDefs = laterTypeDefs |> List.map (addMethodGeneratedAttrsToTypeDef cenv.ilg) - nowTypeDefs @ laterTypeDefs, [] + nowTypeDefs @ laterTypeDefs else // CASE 2b - Build an Term Application Apply method @@ -592,7 +561,7 @@ let rec convIlxClosureDef cenv mdefGen encl (td: ILTypeDef) clo = ("Invoke",ILMemberAccess.Public, nowParams, mkILReturn nowReturnTy, - MethodBody.IL (convILMethodBody cenv (td.GenericParams,Some nowCloSpec,None) (Lazy.force clo.cloCode))) + MethodBody.IL (convILMethodBody (Some nowCloSpec,None) (Lazy.force clo.cloCode))) let ctorMethodDef = mkILStorageCtor (tagClo, @@ -623,13 +592,13 @@ let rec convIlxClosureDef cenv mdefGen encl (td: ILTypeDef) clo = HasSecurity=false; SecurityDecls=emptyILSecurityDecls; tdKind = ILTypeDefKind.Class; } - [cloTypeDef],[] + [cloTypeDef] | [],[ ],Lambdas_return _ -> // No code is being declared: just bake a (mutable) environment let cloCode' = match td.Extends with | None -> (mkILNonGenericEmptyCtor tagClo cenv.ilg.typ_Object).MethodBody - | Some _ -> convILMethodBody cenv (td.GenericParams,Some nowCloSpec,None) (Lazy.force clo.cloCode) + | Some _ -> convILMethodBody (Some nowCloSpec,None) (Lazy.force clo.cloCode) let ctorMethodDef = let flds = (mkILCloFldSpecs cenv nowFields) @@ -654,37 +623,12 @@ let rec convIlxClosureDef cenv mdefGen encl (td: ILTypeDef) clo = Extends= (match td.Extends with None -> Some cenv.ilg.typ_Object | Some x -> Some(x)); Name = td.Name; GenericParams= td.GenericParams; - Methods= mkILMethods (ctorMethodDef :: List.map (convMethodDef cenv ( td.GenericParams,Some nowCloSpec)) td.Methods.AsList); + Methods= mkILMethods (ctorMethodDef :: List.map (convMethodDef (Some nowCloSpec)) td.Methods.AsList); Fields= mkILFields (mkILCloFldDefs cenv nowFields @ td.Fields.AsList); tdKind = ILTypeDefKind.Class; } - [cloTypeDef],[] + [cloTypeDef] | a,b,_ -> failwith ("Unexpected unsupported abstraction sequence, #tyabs = "^string a.Length ^ ", #tmabs = "^string b.Length) - mdefGen := !mdefGen@newMethodDefs; newTypeDefs -// -------------------------------------------------------------------- -// Convert a class -// -------------------------------------------------------------------- - -let rec convTypeDef cenv mdefGen encl td = - match td.tdKind with - | ILTypeDefKind.Other e when isIlxExtTypeDefKind e && (match destIlxExtTypeDefKind e with IlxTypeDefKind.Closure _ -> true | _ -> false) -> - match destIlxExtTypeDefKind e with - | IlxTypeDefKind.Closure cloinfo -> convIlxClosureDef cenv mdefGen encl td cloinfo - | IlxTypeDefKind.Union _ -> failwith "classunions should have been erased by this time" - | _ -> - [ {td with - NestedTypes = convTypeDefs cenv mdefGen (encl@[td.Name]) td.NestedTypes; - Methods=morphILMethodDefs (convMethodDef cenv (td.GenericParams,None)) td.Methods; } ] - -and convTypeDefs cenv mdefGen encl tdefs = - morphExpandILTypeDefs (convTypeDef cenv mdefGen encl) tdefs - -let ConvModule ilg modul = - let cenv = new_cenv(ilg) - let mdefGen = ref [] - let newTypes = convTypeDefs cenv mdefGen [] modul.TypeDefs - {modul with TypeDefs=newTypes} - diff --git a/src/ilx/EraseClosures.fsi b/src/ilx/EraseClosures.fsi index 9c268e8453..0cea96a892 100755 --- a/src/ilx/EraseClosures.fsi +++ b/src/ilx/EraseClosures.fsi @@ -8,10 +8,13 @@ open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types -val ConvModule: ILGlobals -> ILModuleDef -> ILModuleDef - type cenv +val mkCallFunc : cenv -> allocLocal:(ILType -> uint16) -> numThisGenParams:int -> ILTailcall -> IlxClosureApps -> ILInstr list + val mkILFuncTy : cenv -> ILType -> ILType -> ILType val mkILTyFuncTy : cenv -> ILType -val new_cenv : ILGlobals -> cenv +val newIlxPubCloEnv : ILGlobals -> cenv val mkTyOfLambdas: cenv -> IlxClosureLambdas -> ILType + +val convIlxClosureDef : cenv -> encl: string list -> ILTypeDef -> IlxClosureInfo -> ILTypeDef list + diff --git a/src/ilx/EraseUnions.fs b/src/ilx/EraseUnions.fs index bf7431e0de..6edcb4c663 100755 --- a/src/ilx/EraseUnions.fs +++ b/src/ilx/EraseUnions.fs @@ -7,15 +7,16 @@ module internal Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.EraseUnions +open System.Collections.Generic open Internal.Utilities open Microsoft.FSharp.Compiler.AbstractIL +open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Internal +open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX +open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types open Microsoft.FSharp.Compiler.AbstractIL.Morphs -open Microsoft.FSharp.Compiler.AbstractIL.IL -open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types -open Microsoft.FSharp.Compiler.AbstractIL.Internal.Library [] let TagNil = 0 @@ -25,13 +26,20 @@ let TagCons = 1 let ALT_NAME_CONS = "Cons" type DiscriminationTechnique = + /// Indicates a special representation for the F# list type where the "empty" value has a tail field of value null | TailOrNull + /// Indicates a type with either number of cases < 4, and not a single-class type with an integer tag (IntegerTag) | RuntimeTypes + /// Indicates a type with a single case, e.g. ``type X = ABC of string * int`` | SingleCase + /// Indicates a type with either cases >= 4, or a type like + // type X = A | B | C + // or type X = A | B | C of string + // where at most one case is non-nullary. These can be represented using a single + // class (no subclasses), but an integer tag is stored to discriminate between the objects. | IntegerTag -// FLATTEN_SINGLE_NON_NULLARY_AND_ALWAYS_USE_TAGS looks like a useful representation -// optimization - it trades an extra integer tag in the root type +// A potentially useful additional representation trades an extra integer tag in the root type // for faster discrimination, and in the important single-non-nullary constructor case // // type Tree = Tip | Node of int * Tree * Tree @@ -51,14 +59,15 @@ type UnionReprDecisions<'Union,'Alt,'Type> nullPermitted:'Union->bool, isNullary:'Alt->bool, isList:'Union->bool, + isStruct:'Union->bool, nameOfAlt : 'Alt -> string, makeRootType: 'Union -> 'Type, makeNestedType: 'Union * string -> 'Type) = static let TaggingThresholdFixedConstant = 4 - member repr.OptimizeAllAlternativesToConstantFieldsInRootClass cu = - Array.forall isNullary (getAlternatives cu) + member repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu = + cu |> getAlternatives |> Array.forall isNullary member repr.DiscriminationTechnique cu = if isList cu then @@ -68,18 +77,15 @@ type UnionReprDecisions<'Union,'Alt,'Type> if alts.Length = 1 then SingleCase elif -#if FLATTEN_SINGLE_NON_NULLARY_AND_ALWAYS_USE_TAGS - nullPermitted cu then -#else + not (isStruct cu) && alts.Length < TaggingThresholdFixedConstant && - not (repr.OptimizeAllAlternativesToConstantFieldsInRootClass cu) then -#endif + not (repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu) then RuntimeTypes else IntegerTag // WARNING: this must match IsUnionTypeWithNullAsTrueValue in the F# compiler - member repr.OptimizeAlternativeToNull (cu,alt) = + member repr.RepresentAlternativeAsNull (cu,alt) = let alts = getAlternatives cu nullPermitted cu && (repr.DiscriminationTechnique cu = RuntimeTypes) && (* don't use null for tags, lists or single-case *) @@ -87,54 +93,52 @@ type UnionReprDecisions<'Union,'Alt,'Type> Array.exists (isNullary >> not) alts && isNullary alt (* is this the one? *) - member repr.OptimizingOneAlternativeToNull cu = + member repr.RepresentOneAlternativeAsNull cu = let alts = getAlternatives cu nullPermitted cu && - alts |> Array.existsOne (fun alt -> repr.OptimizeAlternativeToNull (cu,alt)) + alts |> Array.existsOne (fun alt -> repr.RepresentAlternativeAsNull (cu,alt)) - member repr.OptimizeSingleNonNullaryAlternativeToRootClassAndAnyOtherAlternativesToNull (cu,alt) = + member repr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull (cu,alt) = // Check all nullary constructors are being represented without using sub-classes let alts = getAlternatives cu + not (isStruct cu) && not (isNullary alt) && - (alts |> Array.forall (fun alt2 -> not (isNullary alt2) || repr.OptimizeAlternativeToNull (cu,alt2))) && + (alts |> Array.forall (fun alt2 -> not (isNullary alt2) || repr.RepresentAlternativeAsNull (cu,alt2))) && // Check this is the one and only non-nullary constructor Array.existsOne (isNullary >> not) alts -#if FLATTEN_SINGLE_NON_NULLARY_AND_ALWAYS_USE_TAGS - member repr.OptimizeSingleNonNullaryAlternativeToRootClassAndOtherAlternativesToTagged (cu,alt) = - let alts = getAlternatives cu - not (isNullary alt) && - alts.Length > 1 && - Array.existsOne (isNullary >> not) alts && - not (nullPermitted cu) -#endif - - member repr.OptimizeSingleNonNullaryAlternativeToRootClass (cu,alt) = + member repr.RepresentAlternativeAsFreshInstancesOfRootClass (cu,alt) = + // Flattening + isStruct cu || // Check all nullary constructors are being represented without using sub-classes (isList cu && nameOfAlt alt = ALT_NAME_CONS) || - repr.OptimizeSingleNonNullaryAlternativeToRootClassAndAnyOtherAlternativesToNull (cu, alt) -#if FLATTEN_SINGLE_NON_NULLARY_AND_ALWAYS_USE_TAGS - repr.OptimizeSingleNonNullaryAlternativeToRootClassAndOtherAlternativesToTagged (cu,alt) -#endif + repr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull (cu, alt) - member repr.OptimizeAlternativeToConstantFieldInTaggedRootClass (cu,alt) = + member repr.RepresentAlternativeAsConstantFieldInTaggedRootClass (cu,alt) = + not (isStruct cu) && isNullary alt && - not (repr.OptimizeAlternativeToNull (cu,alt)) && + not (repr.RepresentAlternativeAsNull (cu,alt)) && (repr.DiscriminationTechnique cu <> RuntimeTypes) + member repr.Flatten cu = + isStruct cu + member repr.OptimizeAlternativeToRootClass (cu,alt) = // The list type always collapses to the root class isList cu || - repr.OptimizeAllAlternativesToConstantFieldsInRootClass cu || - repr.OptimizeAlternativeToConstantFieldInTaggedRootClass (cu,alt) || - repr.OptimizeSingleNonNullaryAlternativeToRootClass(cu,alt) + // Structs are always flattened + repr.Flatten cu || + repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu || + repr.RepresentAlternativeAsConstantFieldInTaggedRootClass (cu,alt) || + repr.RepresentAlternativeAsFreshInstancesOfRootClass(cu,alt) member repr.MaintainPossiblyUniqueConstantFieldForAlternative(cu,alt) = - not (repr.OptimizeAlternativeToNull (cu,alt)) && + not (isStruct cu) && + not (repr.RepresentAlternativeAsNull (cu,alt)) && isNullary alt member repr.TypeForAlternative (cuspec,alt) = - if repr.OptimizeAlternativeToRootClass (cuspec,alt) || repr.OptimizeAlternativeToNull (cuspec,alt) then + if repr.OptimizeAlternativeToRootClass (cuspec,alt) || repr.RepresentAlternativeAsNull (cuspec,alt) then makeRootType cuspec else let altName = nameOfAlt alt @@ -144,7 +148,7 @@ type UnionReprDecisions<'Union,'Alt,'Type> let baseTyOfUnionSpec (cuspec : IlxUnionSpec) = - mkILBoxedTyRaw cuspec.TypeRef cuspec.GenericArgs + mkILNamedTyRaw cuspec.Boxity cuspec.TypeRef cuspec.GenericArgs let mkMakerName (cuspec: IlxUnionSpec) nm = match cuspec.HasHelpers with @@ -152,6 +156,7 @@ let mkMakerName (cuspec: IlxUnionSpec) nm = | SpecialFSharpOptionHelpers -> nm // Leave 'Some', 'None', 'Cons', 'Empty' as is | AllHelpers | NoHelpers -> "New" + nm + let mkCasesTypeRef (cuspec: IlxUnionSpec) = cuspec.TypeRef let cuspecRepr = @@ -160,27 +165,22 @@ let cuspecRepr = (fun (cuspec:IlxUnionSpec) -> cuspec.IsNullPermitted), (fun (alt:IlxUnionAlternative) -> alt.IsNullary), (fun cuspec -> cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers), + (fun cuspec -> cuspec.Boxity = ILBoxity.AsValue), (fun (alt:IlxUnionAlternative) -> alt.Name), - (fun cuspec -> mkILBoxedTyRaw cuspec.TypeRef cuspec.GenericArgs), - (fun (cuspec,nm) -> mkILBoxedTyRaw (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs)) + (fun cuspec -> cuspec.EnclosingType), + (fun (cuspec,nm) -> mkILNamedTyRaw cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs)) type NoTypesGeneratedViaThisReprDecider = NoTypesGeneratedViaThisReprDecider let cudefRepr = UnionReprDecisions - ((fun (_enc,_td,cud) -> cud.cudAlternatives), - (fun (_enc,_td,cud) -> cud.cudNullPermitted), + ((fun (_td,cud) -> cud.cudAlternatives), + (fun (_td,cud) -> cud.cudNullPermitted), (fun (alt:IlxUnionAlternative) -> alt.IsNullary), - (fun (_enc,_td,cud) -> cud.cudHasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers), + (fun (_td,cud) -> cud.cudHasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers), + (fun (td,_cud) -> match td.tdKind with ILTypeDefKind.ValueType -> true | _ -> false), (fun (alt:IlxUnionAlternative) -> alt.Name), - (fun (_enc,_td,_cud) -> NoTypesGeneratedViaThisReprDecider), - (fun ((_enc,_td,_cud),_nm) -> NoTypesGeneratedViaThisReprDecider)) - - -type cenv = - { ilg: ILGlobals } - -let mkBasicBlock2 (a,b) = - mkBasicBlock { Label=a; Instructions= Array.ofList b} + (fun (_td,_cud) -> NoTypesGeneratedViaThisReprDecider), + (fun ((_td,_cud),_nm) -> NoTypesGeneratedViaThisReprDecider)) let mkTesterName nm = "Is" + nm @@ -195,7 +195,7 @@ let refToFieldInTy ty (nm, fldTy) = mkILFieldSpecInTy (ty, nm, fldTy) let formalTypeArgs (baseTy:ILType) = ILList.mapi (fun i _ -> mkILTyvarTy (uint16 i)) baseTy.GenericArgs let constFieldName nm = "_unique_" + nm let constFormalFieldTy (baseTy:ILType) = - ILType.Boxed (mkILTySpecRaw (baseTy.TypeRef, formalTypeArgs baseTy)) + mkILNamedTyRaw baseTy.Boxity baseTy.TypeRef (formalTypeArgs baseTy) let mkConstFieldSpecFromId (baseTy:ILType) constFieldId = refToFieldInTy baseTy constFieldId @@ -227,25 +227,25 @@ let altOfUnionSpec (cuspec:IlxUnionSpec) cidx = let doesRuntimeTypeDiscriminateUseHelper avoidHelpers (cuspec: IlxUnionSpec) (alt: IlxUnionAlternative) = not avoidHelpers && alt.IsNullary && cuspec.HasHelpers = IlxUnionHasHelpers.AllHelpers -let mkRuntimeTypeDiscriminate cenv avoidHelpers cuspec alt altName altTy = +let mkRuntimeTypeDiscriminate ilg avoidHelpers cuspec alt altName altTy = let useHelper = doesRuntimeTypeDiscriminateUseHelper avoidHelpers cuspec alt if useHelper then let baseTy = baseTyOfUnionSpec cuspec - [ mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + mkTesterName altName, [], cenv.ilg.typ_Bool)) ] + [ mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + mkTesterName altName, [], ilg.typ_Bool)) ] else [ I_isinst altTy; AI_ldnull; AI_cgt_un ] -let mkRuntimeTypeDiscriminateThen cenv avoidHelpers cuspec alt altName altTy after = +let mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy after = let useHelper = doesRuntimeTypeDiscriminateUseHelper avoidHelpers cuspec alt match after with - | I_brcmp (BI_brfalse,_,_) - | I_brcmp (BI_brtrue,_,_) when not useHelper -> + | I_brcmp (BI_brfalse,_) + | I_brcmp (BI_brtrue,_) when not useHelper -> [ I_isinst altTy; after ] | _ -> - mkRuntimeTypeDiscriminate cenv avoidHelpers cuspec alt altName altTy @ [ after ] + mkRuntimeTypeDiscriminate ilg avoidHelpers cuspec alt altName altTy @ [ after ] -let mkGetTagFromField cenv cuspec baseTy = - [ mkNormalLdfld (refToFieldInTy baseTy (mkTagFieldId cenv.ilg cuspec)) ] +let mkGetTagFromField ilg cuspec baseTy = + [ mkNormalLdfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) ] let adjustFieldName hasHelpers nm = match hasHelpers, nm with @@ -253,328 +253,322 @@ let adjustFieldName hasHelpers nm = | SpecialFSharpListHelpers, "Tail" -> "TailOrNull" | _ -> nm -let mkLdData avoidHelpers cuspec cidx fidx = +let mkLdData (avoidHelpers, cuspec, cidx, fidx) = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAlt cuspec alt let fieldDef = alt.FieldDef fidx if avoidHelpers then - mkNormalLdfld (mkILFieldSpecInTy(altTy,fieldDef.LowerName, fieldDef.Type)) + [ mkNormalLdfld (mkILFieldSpecInTy(altTy,fieldDef.LowerName, fieldDef.Type)) ] else - mkNormalCall (mkILNonGenericInstanceMethSpecInTy(altTy,"get_" + adjustFieldName cuspec.HasHelpers fieldDef.Name,[],fieldDef.Type)) + [ mkNormalCall (mkILNonGenericInstanceMethSpecInTy(altTy,"get_" + adjustFieldName cuspec.HasHelpers fieldDef.Name,[],fieldDef.Type)) ] + +let mkLdDataAddr (avoidHelpers, cuspec, cidx, fidx) = + let alt = altOfUnionSpec cuspec cidx + let altTy = tyForAlt cuspec alt + let fieldDef = alt.FieldDef fidx + if avoidHelpers then + [ mkNormalLdflda (mkILFieldSpecInTy(altTy,fieldDef.LowerName, fieldDef.Type)) ] + else + failwith (sprintf "can't load address using helpers, for fieldDef %s" fieldDef.LowerName) let mkGetTailOrNull avoidHelpers cuspec = - mkLdData avoidHelpers cuspec 1 1 (* tail is in alternative 1, field number 1 *) + mkLdData (avoidHelpers, cuspec, 1, 1) (* tail is in alternative 1, field number 1 *) -let mkGetTagFromHelpers cenv (cuspec: IlxUnionSpec) = +let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = let baseTy = baseTyOfUnionSpec cuspec - if cuspecRepr.OptimizingOneAlternativeToNull cuspec then - mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [baseTy], mkTagFieldFormalType cenv.ilg cuspec)) + if cuspecRepr.RepresentOneAlternativeAsNull cuspec then + mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [baseTy], mkTagFieldFormalType ilg cuspec)) else - mkNormalCall (mkILNonGenericInstanceMethSpecInTy(baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType cenv.ilg cuspec)) + mkNormalCall (mkILNonGenericInstanceMethSpecInTy(baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec)) -let mkGetTag cenv (cuspec: IlxUnionSpec) = +let mkGetTag ilg (cuspec: IlxUnionSpec) = match cuspec.HasHelpers with - | AllHelpers -> [ mkGetTagFromHelpers cenv cuspec ] - | _hasHelpers -> mkGetTagFromField cenv cuspec (baseTyOfUnionSpec cuspec) + | AllHelpers -> [ mkGetTagFromHelpers ilg cuspec ] + | _hasHelpers -> mkGetTagFromField ilg cuspec (baseTyOfUnionSpec cuspec) let mkCeqThen after = match after with - | I_brcmp (BI_brfalse,a,b) -> [I_brcmp (BI_bne_un,a,b)] - | I_brcmp (BI_brtrue,a,b) -> [I_brcmp (BI_beq,a,b)] + | I_brcmp (BI_brfalse,a) -> [I_brcmp (BI_bne_un,a)] + | I_brcmp (BI_brtrue,a) -> [I_brcmp (BI_beq,a)] | _ -> [AI_ceq; after] -let mkTagDiscriminate cenv cuspec _baseTy cidx = - mkGetTag cenv cuspec - @ [ mkLdcInt32 (cidx); - AI_ceq ] +let mkTagDiscriminate ilg cuspec _baseTy cidx = + mkGetTag ilg cuspec @ [ mkLdcInt32 cidx; AI_ceq ] -let mkTagDiscriminateThen cenv cuspec cidx after = - mkGetTag cenv cuspec - @ [ mkLdcInt32 cidx ] - @ mkCeqThen after +let mkTagDiscriminateThen ilg cuspec cidx after = + mkGetTag ilg cuspec @ [ mkLdcInt32 cidx ] @ mkCeqThen after -let convNewDataInstrInternal cenv cuspec cidx = +let convNewDataInstrInternal ilg cuspec cidx = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAlt cuspec alt let altName = alt.Name - if cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) then + if cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) then [ AI_ldnull ] elif cuspecRepr.MaintainPossiblyUniqueConstantFieldForAlternative (cuspec,alt) then let baseTy = baseTyOfUnionSpec cuspec [ I_ldsfld (Nonvolatile,mkConstFieldSpec altName baseTy) ] - elif cuspecRepr.OptimizeSingleNonNullaryAlternativeToRootClass (cuspec,alt) then + elif cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass (cuspec,alt) then let baseTy = baseTyOfUnionSpec cuspec let instrs, tagfields = match cuspecRepr.DiscriminationTechnique cuspec with - | IntegerTag -> [ mkLdcInt32 cidx ], [mkTagFieldType cenv.ilg cuspec] + | IntegerTag -> [ mkLdcInt32 cidx ], [mkTagFieldType ilg cuspec] | _ -> [], [] - instrs @ [ mkNormalNewobj(mkILCtorMethSpecForTy (baseTy,(Array.toList alt.FieldTypes @ tagfields))) ] + let ctorFieldTys = alt.FieldTypes |> Array.toList + instrs @ [ mkNormalNewobj(mkILCtorMethSpecForTy (baseTy,(ctorFieldTys @ tagfields))) ] else [ mkNormalNewobj(mkILCtorMethSpecForTy (altTy,Array.toList alt.FieldTypes)) ] -let rec convInstr cenv (tmps: ILLocalsAllocator) inplab outlab instr = - match instr with - | I_other e when isIlxExtInstr e -> - match (destIlxExtInstr e) with - | (EI_newdata (cuspec, cidx)) -> - - let alt = altOfUnionSpec cuspec cidx - let altName = alt.Name - let baseTy = baseTyOfUnionSpec cuspec - let i = - // If helpers exist, use them - match cuspec.HasHelpers with - | AllHelpers - | SpecialFSharpListHelpers - | SpecialFSharpOptionHelpers -> - if cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) then - [ AI_ldnull ] - elif alt.IsNullary then - [ mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "get_" + altName, [], constFormalFieldTy baseTy)) ] - else - [ mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, mkMakerName cuspec altName, Array.toList alt.FieldTypes, constFormalFieldTy baseTy)) ] +// The stdata 'instruction' is only ever used for the F# "List" type within FSharp.Core.dll +let mkStData (cuspec, cidx, fidx) = + let alt = altOfUnionSpec cuspec cidx + let altTy = tyForAlt cuspec alt + let fieldDef = alt.FieldDef fidx + [ mkNormalStfld (mkILFieldSpecInTy(altTy,fieldDef.LowerName, fieldDef.Type)) ] - | NoHelpers -> - if cuspecRepr.MaintainPossiblyUniqueConstantFieldForAlternative (cuspec,alt) then - // This method is only available if not AllHelpers. It fetches the unique object for the alternative - // without exposing direct access to the underlying field - [ mkNormalCall (mkILNonGenericStaticMethSpecInTy(baseTy, "get_" + altName, [], constFormalFieldTy baseTy)) ] - else - convNewDataInstrInternal cenv cuspec cidx +let mkNewData ilg (cuspec, cidx) = + let alt = altOfUnionSpec cuspec cidx + let altName = alt.Name + let baseTy = baseTyOfUnionSpec cuspec + // If helpers exist, use them + match cuspec.HasHelpers with + | AllHelpers + | SpecialFSharpListHelpers + | SpecialFSharpOptionHelpers -> + if cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) then + [ AI_ldnull ] + elif alt.IsNullary then + [ mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "get_" + altName, [], constFormalFieldTy baseTy)) ] + else + [ mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, mkMakerName cuspec altName, Array.toList alt.FieldTypes, constFormalFieldTy baseTy)) ] - InstrMorph i + | NoHelpers -> + if cuspecRepr.MaintainPossiblyUniqueConstantFieldForAlternative (cuspec,alt) then + // This method is only available if not AllHelpers. It fetches the unique object for the alternative + // without exposing direct access to the underlying field + [ mkNormalCall (mkILNonGenericStaticMethSpecInTy(baseTy, "get_" + altName, [], constFormalFieldTy baseTy)) ] + else + convNewDataInstrInternal ilg cuspec cidx - | (EI_stdata (cuspec, cidx,fidx)) -> - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt - let fieldDef = alt.FieldDef fidx - InstrMorph [ mkNormalStfld (mkILFieldSpecInTy(altTy,fieldDef.LowerName, fieldDef.Type)) ] - - | (EI_lddata (avoidHelpers, cuspec,cidx,fidx)) -> - // The stdata instruction is only ever used for the F# "List" type within FSharp.Core.dll - InstrMorph [ mkLdData avoidHelpers cuspec cidx fidx ] - - | (EI_lddatatag (avoidHelpers,cuspec)) -> - // If helpers exist, use them - match cuspec.HasHelpers with - | SpecialFSharpListHelpers - | AllHelpers - when not avoidHelpers -> InstrMorph [ mkGetTagFromHelpers cenv cuspec ] - | _ -> +let mkIsData ilg (avoidHelpers, cuspec, cidx) = + let alt = altOfUnionSpec cuspec cidx + let altTy = tyForAlt cuspec alt + let altName = alt.Name + if cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) then + [ AI_ldnull; AI_ceq ] + elif cuspecRepr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull (cuspec,alt) then + // in this case we can use a null test + [ AI_ldnull; AI_cgt_un ] + else + match cuspecRepr.DiscriminationTechnique cuspec with + | SingleCase -> [ mkLdcInt32 1 ] + | RuntimeTypes -> mkRuntimeTypeDiscriminate ilg avoidHelpers cuspec alt altName altTy + | IntegerTag -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx + | TailOrNull -> + match cidx with + | TagNil -> mkGetTailOrNull avoidHelpers cuspec @ [ AI_ldnull; AI_ceq ] + | TagCons -> mkGetTailOrNull avoidHelpers cuspec @ [ AI_ldnull; AI_cgt_un ] + | _ -> failwith "unexpected" + +type ICodeGen<'Mark> = + abstract CodeLabel: 'Mark -> ILCodeLabel + abstract GenerateDelayMark: unit -> 'Mark + abstract GenLocal: ILType -> uint16 + abstract SetMarkToHere: 'Mark -> unit + abstract EmitInstr : ILInstr -> unit + abstract EmitInstrs : ILInstr list -> unit + +let genWith g : ILCode = + let instrs = ResizeArray() + let lab2pc = Dictionary() + g { new ICodeGen with + member __.CodeLabel(m) = m + member __.GenerateDelayMark() = generateCodeLabel() + member __.GenLocal(ilty) = failwith "not needed" + member __.SetMarkToHere(m) = lab2pc.[m] <- instrs.Count + member __.EmitInstr x = instrs.Add x + member cg.EmitInstrs xs = for i in xs do cg.EmitInstr i } + + { Labels = lab2pc + Instrs = instrs.ToArray() + Exceptions = [] + Locals = [] } + + +let mkBrIsNotData ilg (avoidHelpers, cuspec,cidx,tg) = + let alt = altOfUnionSpec cuspec cidx + let altTy = tyForAlt cuspec alt + let altName = alt.Name + if cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) then + [ I_brcmp (BI_brtrue,tg) ] + elif cuspecRepr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull (cuspec,alt) then + // in this case we can use a null test + [ I_brcmp (BI_brfalse,tg) ] + else + match cuspecRepr.DiscriminationTechnique cuspec with + | SingleCase -> [ ] + | RuntimeTypes -> mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy (I_brcmp (BI_brfalse,tg)) + | IntegerTag -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp (BI_brfalse,tg)) + | TailOrNull -> + match cidx with + | TagNil -> mkGetTailOrNull avoidHelpers cuspec @ [I_brcmp (BI_brtrue,tg)] + | TagCons -> mkGetTailOrNull avoidHelpers cuspec @ [ I_brcmp (BI_brfalse,tg)] + | _ -> failwith "unexpected" + + +let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers,cuspec: IlxUnionSpec) = + // If helpers exist, use them + match cuspec.HasHelpers with + | (SpecialFSharpListHelpers | AllHelpers) when not avoidHelpers -> + ldOpt |> Option.iter cg.EmitInstr + cg.EmitInstr (mkGetTagFromHelpers ilg cuspec) + | _ -> - let alts = cuspec.Alternatives - match cuspecRepr.DiscriminationTechnique cuspec with - | TailOrNull -> - // leaves 1 if cons, 0 if not - InstrMorph [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_cgt_un ] - | IntegerTag -> - let baseTy = baseTyOfUnionSpec cuspec - InstrMorph (mkGetTagFromField cenv cuspec baseTy) - | SingleCase -> - InstrMorph [ AI_pop; (AI_ldc (DT_I4, ILConst.I4 0)) ] - | RuntimeTypes -> - let baseTy = baseTyOfUnionSpec cuspec - let locn = tmps.AllocLocal (mkILLocal baseTy None) - - let mkCase last inplab cidx failLab = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt - let altName = alt.Name - let internalLab = generateCodeLabel () - let cmpNull = cuspecRepr.OptimizeAlternativeToNull (cuspec, alt) - if last then - mkBasicBlock2 (inplab,[ (AI_ldc (DT_I4, ILConst.I4 cidx)); - I_br outlab ]) - else - let test = I_brcmp ((if cmpNull then BI_brtrue else BI_brfalse),failLab,internalLab) - let test_block = - if cmpNull || cuspecRepr.OptimizeSingleNonNullaryAlternativeToRootClass (cuspec,alt) then - [ test ] - else - mkRuntimeTypeDiscriminateThen cenv avoidHelpers cuspec alt altName altTy test - mkGroupBlock - ([internalLab], - [ mkBasicBlock2 (inplab, mkLdloc locn ::test_block); - mkBasicBlock2 (internalLab,[(AI_ldc(DT_I4,ILConst.I4(cidx))); I_br outlab ]) ]) - - // Make the block for the last test. - let lastInpLab = generateCodeLabel () - let lastBlock = mkCase true lastInpLab 0 outlab - - // Make the blocks for the remaining tests. - let _, firstInpLab, overallBlock = - List.foldBack - (fun _ (n, continueInpLab, continueBlock) -> - let newInpLab = generateCodeLabel () - n+1, - newInpLab, - mkGroupBlock - ([continueInpLab], - [ mkCase false newInpLab n continueInpLab; - continueBlock ])) - (List.tail alts) - (1,lastInpLab, lastBlock) - - // Add on a branch to the first input label. This gets optimized away by the printer/emitter. - InstrMorph - (mkGroupBlock - ([firstInpLab], - [ mkBasicBlock2 (inplab, [ mkStloc locn; I_br firstInpLab ]); - overallBlock ])) - - | (EI_castdata (canfail,cuspec,cidx)) -> - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt - if cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) then - if canfail then - let internal1 = generateCodeLabel () - InstrMorph - (mkGroupBlock - ([internal1], - [ mkBasicBlock2 (inplab, - [ AI_dup; - I_brcmp (BI_brfalse,outlab, internal1) ]); - mkBasicBlock2 (internal1, - [ mkPrimaryAssemblyExnNewobj cenv.ilg "System.InvalidCastException"; - I_throw ]); - ] )) - else - // If it can't fail, it's still verifiable just to leave the value on the stack unchecked - InstrMorph [] - - elif cuspecRepr.OptimizeAlternativeToRootClass (cuspec,alt) then - InstrMorph [] - - else InstrMorph [ I_castclass altTy ] + let alts = cuspec.Alternatives + match cuspecRepr.DiscriminationTechnique cuspec with + | TailOrNull -> + // leaves 1 if cons, 0 if not + ldOpt |> Option.iter cg.EmitInstr + cg.EmitInstrs (mkGetTailOrNull avoidHelpers cuspec @ [ AI_ldnull; AI_cgt_un]) + | IntegerTag -> + let baseTy = baseTyOfUnionSpec cuspec + ldOpt |> Option.iter cg.EmitInstr + cg.EmitInstrs (mkGetTagFromField ilg cuspec baseTy) + | SingleCase -> + ldOpt |> Option.iter cg.EmitInstr + cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] + | RuntimeTypes -> + let baseTy = baseTyOfUnionSpec cuspec + let ld = + match ldOpt with + | None -> + let locn = cg.GenLocal baseTy + // Add on a branch to the first input label. This gets optimized away by the printer/emitter. + cg.EmitInstr (mkStloc locn) + mkLdloc locn + | Some i -> i + + let outlab = cg.GenerateDelayMark() + + let emitCase cidx = + let alt = altOfUnionSpec cuspec cidx + let internalLab = cg.GenerateDelayMark() + let failLab = cg.GenerateDelayMark () + let cmpNull = cuspecRepr.RepresentAlternativeAsNull (cuspec, alt) + let test = I_brcmp ((if cmpNull then BI_brtrue else BI_brfalse),cg.CodeLabel failLab) + let testBlock = + if cmpNull || cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass (cuspec,alt) then + [ test ] + else + let altName = alt.Name + let altTy = tyForAlt cuspec alt + mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy test + cg.EmitInstrs (ld :: testBlock) + cg.SetMarkToHere internalLab + cg.EmitInstrs [mkLdcInt32 cidx; I_br (cg.CodeLabel outlab) ] + cg.SetMarkToHere failLab + + // Make the blocks for the remaining tests. + for n in alts.Length-1 .. -1 .. 1 do + emitCase n + + // Make the block for the last test. + cg.EmitInstr (mkLdcInt32 0) + cg.SetMarkToHere outlab + +let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (avoidHelpers,cuspec: IlxUnionSpec) = + emitLdDataTagPrim ilg None cg (avoidHelpers,cuspec) + +let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail,avoidHelpers,cuspec,cidx) = + let alt = altOfUnionSpec cuspec cidx + if cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) then + if canfail then + let outlab = cg.GenerateDelayMark () + let internal1 = cg.GenerateDelayMark () + cg.EmitInstrs [AI_dup; I_brcmp (BI_brfalse, cg.CodeLabel outlab) ] + cg.SetMarkToHere internal1 + cg.EmitInstrs [mkPrimaryAssemblyExnNewobj ilg "System.InvalidCastException"; I_throw ] + cg.SetMarkToHere outlab + else + // If it can't fail, it's still verifiable just to leave the value on the stack unchecked + () + elif cuspecRepr.Flatten cuspec then + if canfail then + let outlab = cg.GenerateDelayMark () + let internal1 = cg.GenerateDelayMark () + cg.EmitInstrs [ AI_dup ] + emitLdDataTagPrim ilg None cg (avoidHelpers,cuspec) + cg.EmitInstrs [ mkLdcInt32 cidx; I_brcmp (BI_beq, cg.CodeLabel outlab) ] + cg.SetMarkToHere internal1 + cg.EmitInstrs [mkPrimaryAssemblyExnNewobj ilg "System.InvalidCastException"; I_throw ] + cg.SetMarkToHere outlab + else + // If it can't fail, it's still verifiable just to leave the value on the stack unchecked + () + elif cuspecRepr.OptimizeAlternativeToRootClass (cuspec,alt) then + () + else + let altTy = tyForAlt cuspec alt + cg.EmitInstr (I_castclass altTy) - | (EI_brisdata (avoidHelpers, cuspec,cidx,tg,failLab)) -> - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt - let altName = alt.Name - if cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) then - InstrMorph [ I_brcmp (BI_brtrue,failLab,tg) ] - elif cuspecRepr.OptimizeSingleNonNullaryAlternativeToRootClassAndAnyOtherAlternativesToNull (cuspec,alt) then - // in this case we can use a null test - InstrMorph [ I_brcmp (BI_brfalse,failLab,tg) ] - else - match cuspecRepr.DiscriminationTechnique cuspec with - | SingleCase -> InstrMorph [ I_br tg ] - | RuntimeTypes -> InstrMorph (mkRuntimeTypeDiscriminateThen cenv avoidHelpers cuspec alt altName altTy (I_brcmp (BI_brfalse,failLab,tg))) - | IntegerTag -> InstrMorph (mkTagDiscriminateThen cenv cuspec cidx (I_brcmp (BI_brfalse,failLab,tg))) - | TailOrNull -> - match cidx with - | TagNil -> InstrMorph [ mkGetTailOrNull avoidHelpers cuspec; I_brcmp (BI_brtrue,failLab,tg) ] - | TagCons -> InstrMorph [ mkGetTailOrNull avoidHelpers cuspec; I_brcmp (BI_brfalse,failLab,tg) ] - | _ -> failwith "unexpected" - - | (EI_isdata (avoidHelpers, cuspec, cidx)) -> +let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = + let baseTy = baseTyOfUnionSpec cuspec + + match cuspecRepr.DiscriminationTechnique cuspec with + | RuntimeTypes -> + let locn = cg.GenLocal baseTy + + cg.EmitInstr (mkStloc locn) + + for (cidx,tg) in cases do let alt = altOfUnionSpec cuspec cidx let altTy = tyForAlt cuspec alt let altName = alt.Name - if cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) then - InstrMorph [ AI_ldnull; AI_ceq ] - elif cuspecRepr.OptimizeSingleNonNullaryAlternativeToRootClassAndAnyOtherAlternativesToNull (cuspec,alt) then - // in this case we can use a null test - InstrMorph [ AI_ldnull; AI_cgt_un ] + let failLab = cg.GenerateDelayMark () + let cmpNull = cuspecRepr.RepresentAlternativeAsNull (cuspec,alt) + + cg.EmitInstr (mkLdloc locn) + let testInstr = I_brcmp ((if cmpNull then BI_brfalse else BI_brtrue),tg) + if cmpNull || cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass (cuspec,alt) then + cg.EmitInstr testInstr else - match cuspecRepr.DiscriminationTechnique cuspec with - | SingleCase -> InstrMorph [ mkLdcInt32 1 ] - | RuntimeTypes -> InstrMorph (mkRuntimeTypeDiscriminate cenv avoidHelpers cuspec alt altName altTy) - | IntegerTag -> InstrMorph (mkTagDiscriminate cenv cuspec (baseTyOfUnionSpec cuspec) cidx) - | TailOrNull -> - match cidx with - | TagNil -> InstrMorph [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_ceq ] - | TagCons -> InstrMorph [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_cgt_un ] - | _ -> failwith "unexpected" - - | (EI_datacase (avoidHelpers, cuspec, cases, cont)) -> - let baseTy = baseTyOfUnionSpec cuspec - - match cuspecRepr.DiscriminationTechnique cuspec with - | RuntimeTypes -> - let locn = tmps.AllocLocal (mkILLocal baseTy None) - let mkCase _last inplab (cidx,tg) failLab = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt - let altName = alt.Name - let _internalLab = generateCodeLabel () - let cmpNull = cuspecRepr.OptimizeAlternativeToNull (cuspec,alt) - - let test = - let testInstr = I_brcmp ((if cmpNull then BI_brfalse else BI_brtrue),tg,failLab) - - [ mkLdloc locn ] @ - (if cmpNull || cuspecRepr.OptimizeSingleNonNullaryAlternativeToRootClass (cuspec,alt) then - [ testInstr ] - else - mkRuntimeTypeDiscriminateThen cenv avoidHelpers cuspec alt altName altTy testInstr) - - mkBasicBlock2 (inplab, test) - - // Make the block for the last test. - let lastInpLab = generateCodeLabel () - let lastCase, firstCases = - let l2 = List.rev cases - List.head l2, List.rev (List.tail l2) - - let lastBlock = mkCase true lastInpLab lastCase cont + cg.EmitInstrs (mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy testInstr) + cg.SetMarkToHere failLab - // Make the blocks for the remaining tests. - let firstInpLab,overallBlock = - List.foldBack - (fun caseInfo (continueInpLab, continueBlock) -> - let newInpLab = generateCodeLabel () - (newInpLab, mkGroupBlock - ([continueInpLab], - [ mkCase false newInpLab caseInfo continueInpLab; - continueBlock ]))) - firstCases - (lastInpLab, lastBlock) - - // Add on a branch to the first input label. This gets optimized - // away by the printer/emitter. - InstrMorph - (mkGroupBlock - ([firstInpLab], - [ mkBasicBlock2 (inplab, [ mkStloc locn; I_br firstInpLab ]); - overallBlock ])) - | IntegerTag -> - // Use a dictionary to avoid quadratic lookup in case list - let dict = System.Collections.Generic.Dictionary() - for (i,case) in cases do dict.[i] <- case - let mkCase i _ = - let mutable res = Unchecked.defaultof<_> - let ok = dict.TryGetValue(i, &res) - if ok then res else cont - - let dests = List.mapi mkCase cuspec.Alternatives - InstrMorph (mkGetTag cenv cuspec @ [ I_switch (dests,cont) ]) - | SingleCase -> - match cases with - | [(0,tg)] -> InstrMorph [ AI_pop; I_br tg ] - | [] -> InstrMorph [ AI_pop; I_br cont ] - | _ -> failwith "unexpected: strange switch on single-case unions should not be present" - | TailOrNull -> - failwith "unexpected: switches on lists should have been eliminated to brisdata tests" - - | _ -> InstrMorph [instr] - - | _ -> InstrMorph [instr] + | IntegerTag -> + match cases with + | [] -> cg.EmitInstrs [ AI_pop ] + | _ -> + // Use a dictionary to avoid quadratic lookup in case list + let dict = System.Collections.Generic.Dictionary() + for (i,case) in cases do dict.[i] <- case + let failLab = cg.GenerateDelayMark () + let emitCase i _ = + let mutable res = Unchecked.defaultof<_> + let ok = dict.TryGetValue(i, &res) + if ok then res else cg.CodeLabel failLab + + let dests = Array.mapi emitCase cuspec.AlternativesArray + cg.EmitInstrs (mkGetTag ilg cuspec) + cg.EmitInstr (I_switch (Array.toList dests)) + cg.SetMarkToHere failLab + + | SingleCase -> + match cases with + | [(0,tg)] -> cg.EmitInstrs [ AI_pop; I_br tg ] + | [] -> cg.EmitInstrs [ AI_pop ] + | _ -> failwith "unexpected: strange switch on single-case unions should not be present" + + | TailOrNull -> + failwith "unexpected: switches on lists should have been eliminated to brisdata tests" + -let convILMethodBody cenv il = - let tmps = ILLocalsAllocator il.Locals.Length - let code= morphExpandILInstrsInILCode (convInstr cenv tmps) il.Code - {il with - Locals = ILList.ofList (ILList.toList il.Locals @ tmps.Close()); - Code=code; - MaxStack=il.MaxStack+2 } -let convMethodDef cenv md = - {md with mdBody= morphILMethodBody (convILMethodBody cenv) md.mdBody } +//--------------------------------------------------- +// Generate the union classes let mkHiddenGeneratedInstanceFieldDef ilg (nm,ty,init,access) = mkILInstanceField (nm,ty,init,access) @@ -587,42 +581,38 @@ let mkHiddenGeneratedStaticFieldDef ilg (a,b,c,d,e) = |> addFieldGeneratedAttrs ilg -let mkMethodsAndPropertiesForFields cenv access attr hasHelpers (typ: ILType) (fields: IlxUnionField[]) = +let mkMethodsAndPropertiesForFields ilg access attr hasHelpers (typ: ILType) (fields: IlxUnionField[]) = let basicProps = fields |> Array.map (fun field -> - { Name=adjustFieldName hasHelpers field.Name; - IsRTSpecialName=false; - IsSpecialName=false; - SetMethod=None; - GetMethod = Some (mkILMethRef (typ.TypeRef, ILCallingConv.Instance, "get_" + adjustFieldName hasHelpers field.Name, 0, [], field.Type)); - CallingConv=ILThisConvention.Instance; - Type=field.Type; - Init=None; - Args=mkILTypes []; - CustomAttrs= field.ILField.CustomAttrs; } - |> addPropertyGeneratedAttrs cenv.ilg + { Name=adjustFieldName hasHelpers field.Name + IsRTSpecialName=false + IsSpecialName=false + SetMethod=None + GetMethod = Some (mkILMethRef (typ.TypeRef, ILCallingConv.Instance, "get_" + adjustFieldName hasHelpers field.Name, 0, [], field.Type)) + CallingConv=ILThisConvention.Instance + Type=field.Type + Init=None + Args=mkILTypes [] + CustomAttrs= field.ILField.CustomAttrs } + |> addPropertyGeneratedAttrs ilg ) |> Array.toList let basicMethods = - [ for field in fields do let fspec = mkILFieldSpecInTy(typ,field.LowerName,field.Type) yield mkILNonGenericInstanceMethod ("get_" + adjustFieldName hasHelpers field.Name, access, [], mkILReturn field.Type, - mkMethodBody(true,emptyILLocals,2, - nonBranchingInstrsToCode - [ mkLdarg 0us; - mkNormalLdfld fspec ], attr)) - |> convMethodDef cenv - |> addMethodGeneratedAttrs cenv.ilg ] + mkMethodBody(true,emptyILLocals,2,nonBranchingInstrsToCode [ mkLdarg 0us; mkNormalLdfld fspec ], attr)) + |> addMethodGeneratedAttrs ilg ] basicProps, basicMethods + -let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (alt:IlxUnionAlternative) = +let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (alt:IlxUnionAlternative) = let attr = cud.cudWhere let altName = alt.Name let fields = alt.FieldDefs @@ -656,8 +646,7 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( mkMethodBody(true,emptyILLocals,fields.Length, nonBranchingInstrsToCode [ I_ldsfld (Nonvolatile,mkConstFieldSpec altName baseTy) ], attr)) - |> convMethodDef cenv - |> addMethodGeneratedAttrs cenv.ilg + |> addMethodGeneratedAttrs ilg [meth] else @@ -672,29 +661,27 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( let baseTesterMeths, baseTesterProps = if cud.cudAlternatives.Length <= 1 then [], [] - elif repr.OptimizingOneAlternativeToNull info then [], [] + elif repr.RepresentOneAlternativeAsNull info then [], [] else [ mkILNonGenericInstanceMethod ("get_" + mkTesterName altName, cud.cudHelpersAccess,[], - mkILReturn cenv.ilg.typ_bool, + mkILReturn ilg.typ_bool, mkMethodBody(true,emptyILLocals,2,nonBranchingInstrsToCode - [ mkLdarg0; - (mkIlxInstr (EI_isdata (true,cuspec, num))) ], attr)) - |> convMethodDef cenv - |> addMethodGeneratedAttrs cenv.ilg ], - [ { Name=mkTesterName altName; - IsRTSpecialName=false; - IsSpecialName=false; - SetMethod=None; - GetMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Instance, "get_" + mkTesterName altName, 0, [], cenv.ilg.typ_bool)); - CallingConv=ILThisConvention.Instance; - Type=cenv.ilg.typ_bool; - Init=None; - Args=mkILTypes []; - CustomAttrs=emptyILCustomAttrs; } - |> addPropertyGeneratedAttrs cenv.ilg - |> addPropertyNeverAttrs cenv.ilg ] + ([ mkLdarg0 ] @ mkIsData ilg (true, cuspec, num)), attr)) + |> addMethodGeneratedAttrs ilg ], + [ { Name=mkTesterName altName + IsRTSpecialName=false + IsSpecialName=false + SetMethod=None + GetMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Instance, "get_" + mkTesterName altName, 0, [], ilg.typ_bool)) + CallingConv=ILThisConvention.Instance + Type=ilg.typ_bool + Init=None + Args=mkILTypes [] + CustomAttrs=emptyILCustomAttrs } + |> addPropertyGeneratedAttrs ilg + |> addPropertyNeverAttrs ilg ] @@ -706,25 +693,24 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( mkILNonGenericStaticMethod ("get_" + altName, cud.cudHelpersAccess, [], mkILReturn baseTy, - mkMethodBody(true,emptyILLocals,fields.Length, nonBranchingInstrsToCode (convNewDataInstrInternal cenv cuspec num), attr)) - |> convMethodDef cenv - |> addMethodGeneratedAttrs cenv.ilg + mkMethodBody(true,emptyILLocals,fields.Length, nonBranchingInstrsToCode (convNewDataInstrInternal ilg cuspec num), attr)) + |> addMethodGeneratedAttrs ilg |> addAltAttribs let nullaryProp = - { Name=altName; - IsRTSpecialName=false; - IsSpecialName=false; - SetMethod=None; - GetMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Static, "get_" + altName, 0, [], baseTy)); - CallingConv=ILThisConvention.Static; - Type=baseTy; - Init=None; - Args=mkILTypes []; - CustomAttrs=emptyILCustomAttrs; } - |> addPropertyGeneratedAttrs cenv.ilg - |> addPropertyNeverAttrs cenv.ilg + { Name=altName + IsRTSpecialName=false + IsSpecialName=false + SetMethod=None + GetMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Static, "get_" + altName, 0, [], baseTy)) + CallingConv=ILThisConvention.Static + Type=baseTy + Init=None + Args=mkILTypes [] + CustomAttrs=emptyILCustomAttrs } + |> addPropertyGeneratedAttrs ilg + |> addPropertyNeverAttrs ilg [nullaryMeth],[nullaryProp] @@ -738,9 +724,8 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( mkMethodBody(true,emptyILLocals,fields.Length, nonBranchingInstrsToCode (Array.toList (Array.mapi (fun i _ -> mkLdarg (uint16 i)) fields) @ - (convNewDataInstrInternal cenv cuspec num)), attr)) - |> convMethodDef cenv - |> addMethodGeneratedAttrs cenv.ilg + (convNewDataInstrInternal ilg cuspec num)), attr)) + |> addMethodGeneratedAttrs ilg |> addAltAttribs [mdef],[] @@ -751,15 +736,14 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( [], [] let typeDefs, altDebugTypeDefs, altNullaryFields = - if repr.OptimizeAlternativeToNull (info,alt) then [], [], [] - elif repr.OptimizeSingleNonNullaryAlternativeToRootClass (info,alt) then [], [], [] + if repr.RepresentAlternativeAsNull (info,alt) then [], [], [] + elif repr.RepresentAlternativeAsFreshInstancesOfRootClass (info,alt) then [], [], [] else let altNullaryFields = if repr.MaintainPossiblyUniqueConstantFieldForAlternative(info,alt) then - let basic = mkHiddenGeneratedStaticFieldDef cenv.ilg (constFieldName altName, baseTy, None, None, ILMemberAccess.Assembly) + let basic = mkHiddenGeneratedStaticFieldDef ilg (constFieldName altName, baseTy, None, None, ILMemberAccess.Assembly) let uniqObjField = { basic with IsInitOnly=true } let inRootClass = cuspecRepr.OptimizeAlternativeToRootClass (cuspec,alt) - [ (info,alt, altTy,num,uniqObjField,inRootClass) ] else [] @@ -776,7 +760,7 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( let debugProxyFieldName = "_obj" let debugProxyFields = - [ mkHiddenGeneratedInstanceFieldDef cenv.ilg (debugProxyFieldName,altTy, None, ILMemberAccess.Assembly) ] + [ mkHiddenGeneratedInstanceFieldDef ilg (debugProxyFieldName,altTy, None, ILMemberAccess.Assembly) ] let debugProxyCtor = mkILCtor(ILMemberAccess.Public (* must always be public - see jared parson blog entry on implementing debugger type proxy *), @@ -785,12 +769,12 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( (false,emptyILLocals,3, nonBranchingInstrsToCode [ yield mkLdarg0 - yield mkNormalCall (mkILCtorMethSpecForTy (cenv.ilg.typ_Object,[])) + yield mkNormalCall (mkILCtorMethSpecForTy (ilg.typ_Object,[])) yield mkLdarg0 - yield mkLdarg 1us; - yield mkNormalStfld (mkILFieldSpecInTy (debugProxyTy,debugProxyFieldName,altTy)); ],None)) + yield mkLdarg 1us + yield mkNormalStfld (mkILFieldSpecInTy (debugProxyTy,debugProxyFieldName,altTy)) ],None)) - |> addMethodGeneratedAttrs cenv.ilg + |> addMethodGeneratedAttrs ilg let debugProxyGetterMeths = fields @@ -802,33 +786,34 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( mkILReturn field.Type, mkMethodBody(true,emptyILLocals,2, nonBranchingInstrsToCode - [ mkLdarg0; - mkNormalLdfld (mkILFieldSpecInTy (debugProxyTy,debugProxyFieldName,altTy)); - mkNormalLdfld (mkILFieldSpecInTy(altTy,fldName,fldTy));],None)) - |> convMethodDef cenv - |> addMethodGeneratedAttrs cenv.ilg) + [ mkLdarg0 + (match td.tdKind with ILTypeDefKind.ValueType -> mkNormalLdflda | _ -> mkNormalLdfld) + (mkILFieldSpecInTy (debugProxyTy,debugProxyFieldName,altTy)) + mkNormalLdfld (mkILFieldSpecInTy(altTy,fldName,fldTy))],None)) + |> addMethodGeneratedAttrs ilg) |> Array.toList let debugProxyGetterProps = fields |> Array.map (fun fdef -> - { Name=fdef.Name; - IsRTSpecialName=false; - IsSpecialName=false; - SetMethod=None; - GetMethod=Some(mkILMethRef(debugProxyTy.TypeRef,ILCallingConv.Instance,"get_" + fdef.Name,0,[],fdef.Type)); - CallingConv=ILThisConvention.Instance; - Type=fdef.Type; - Init=None; - Args=mkILTypes []; - CustomAttrs= fdef.ILField.CustomAttrs; } - |> addPropertyGeneratedAttrs cenv.ilg) + { Name=fdef.Name + IsRTSpecialName=false + IsSpecialName=false + SetMethod=None + GetMethod=Some(mkILMethRef(debugProxyTy.TypeRef,ILCallingConv.Instance,"get_" + fdef.Name,0,[],fdef.Type)) + CallingConv=ILThisConvention.Instance + Type=fdef.Type + Init=None + Args=mkILTypes [] + CustomAttrs= fdef.ILField.CustomAttrs } + |> addPropertyGeneratedAttrs ilg) |> Array.toList + let debugProxyTypeDef = mkILGenericClass (debugProxyTypeName, ILTypeDefAccess.Nested ILMemberAccess.Assembly, td.GenericParams, - cenv.ilg.typ_Object, [], + ilg.typ_Object, [], mkILMethods ([debugProxyCtor] @ debugProxyGetterMeths), mkILFields debugProxyFields, emptyILTypeDefs, @@ -836,20 +821,21 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( emptyILEvents, emptyILCustomAttrs, ILTypeInit.BeforeField) + [ { debugProxyTypeDef with IsSpecialName=true } ], - ( [cenv.ilg.mkDebuggerTypeProxyAttribute debugProxyTy] @ cud.cudDebugDisplayAttributes) + ( [ilg.mkDebuggerTypeProxyAttribute debugProxyTy] @ cud.cudDebugDisplayAttributes) let altTypeDef = let basicFields = fields |> Array.map (fun field -> let fldName,fldTy = mkUnionCaseFieldId field - let fdef = mkHiddenGeneratedInstanceFieldDef cenv.ilg (fldName,fldTy, None, ILMemberAccess.Assembly) + let fdef = mkHiddenGeneratedInstanceFieldDef ilg (fldName,fldTy, None, ILMemberAccess.Assembly) { fdef with IsInitOnly=isTotallyImmutable }) |> Array.toList - let basicProps, basicMethods = mkMethodsAndPropertiesForFields cenv cud.cudReprAccess attr cud.cudHasHelpers altTy fields + let basicProps, basicMethods = mkMethodsAndPropertiesForFields ilg cud.cudReprAccess attr cud.cudHasHelpers altTy fields let basicCtorMeth = @@ -858,8 +844,8 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( [ yield mkLdarg0 match repr.DiscriminationTechnique info with | IntegerTag -> - yield (AI_ldc(DT_I4,ILConst.I4(num))) - yield mkNormalCall (mkILCtorMethSpecForTy (baseTy,[mkTagFieldType cenv.ilg cuspec])) + yield mkLdcInt32 num + yield mkNormalCall (mkILCtorMethSpecForTy (baseTy,[mkTagFieldType ilg cuspec])) | SingleCase | RuntimeTypes -> yield mkNormalCall (mkILCtorMethSpecForTy (baseTy,[])) @@ -868,7 +854,7 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( altTy, (basicFields |> List.map (fun fdef -> fdef.Name, fdef.Type) ), (if cuspec.HasHelpers = AllHelpers then ILMemberAccess.Assembly else cud.cudReprAccess)) - |> addMethodGeneratedAttrs cenv.ilg + |> addMethodGeneratedAttrs ilg let altTypeDef = mkILGenericClass (altTy.TypeSpec.Name, @@ -883,8 +869,8 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( emptyILEvents, mkILCustomAttrs debugAttrs, ILTypeInit.BeforeField) - { altTypeDef with IsSerializable=td.IsSerializable; - IsSpecialName=true } + + { altTypeDef with IsSerializable=td.IsSerializable; IsSpecialName=true } [ altTypeDef ], altDebugTypeDefs @@ -894,17 +880,18 @@ let convAlternativeDef cenv num (td:ILTypeDef) cud info cuspec (baseTy:ILType) ( baseMakerMeths, baseMakerProps, altUniqObjMeths, typeDefs, altDebugTypeDefs, altNullaryFields -let rec convClassUnionDef cenv enc td cud = - let baseTy = mkILFormalBoxedTy (mkRefForNestedILTypeDef ILScopeRef.Local (enc,td)) td.GenericParams - let cuspec = IlxUnionSpec(IlxUnionRef(baseTy.TypeRef, cud.cudAlternatives, cud.cudNullPermitted, cud.cudHasHelpers), baseTy.GenericArgs) - let info = (enc,td,cud) +let mkClassUnionDef ilg tref td cud = + let boxity = match td.tdKind with ILTypeDefKind.ValueType -> ILBoxity.AsValue | _ -> ILBoxity.AsObject + let baseTy = mkILFormalNamedTy boxity tref td.GenericParams + let cuspec = IlxUnionSpec(IlxUnionRef(boxity,baseTy.TypeRef, cud.cudAlternatives, cud.cudNullPermitted, cud.cudHasHelpers), baseTy.GenericArgs) + let info = (td,cud) let repr = cudefRepr let isTotallyImmutable = (cud.cudHasHelpers <> SpecialFSharpListHelpers) let results = cud.cudAlternatives |> List.ofArray - |> List.mapi (fun i alt -> convAlternativeDef cenv i td cud info cuspec baseTy alt) + |> List.mapi (fun i alt -> convAlternativeDef ilg i td cud info cuspec baseTy alt) let baseMethsFromAlt = results |> List.collect (fun (a,_,_,_,_,_) -> a) let basePropsFromAlt = results |> List.collect (fun (_,a,_,_,_,_) -> a) @@ -916,46 +903,55 @@ let rec convClassUnionDef cenv enc td cud = let tagFieldsInObject = match repr.DiscriminationTechnique info with | SingleCase | RuntimeTypes | TailOrNull -> [] - | IntegerTag -> [ mkTagFieldId cenv.ilg cuspec ] + | IntegerTag -> [ mkTagFieldId ilg cuspec ] + + let isStruct = match td.tdKind with ILTypeDefKind.ValueType -> true | _ -> false + + let selfFields, selfMeths, selfProps = + + [ for alt in cud.cudAlternatives do + if repr.RepresentAlternativeAsFreshInstancesOfRootClass (info,alt) then + // TODO + let fields = alt.FieldDefs |> Array.toList |> List.map mkUnionCaseFieldId + let baseInit = + if isStruct then None else + match td.Extends with + | None -> Some ilg.tspec_Object + | Some typ -> Some typ.TypeSpec - let selfFields, selfMeths, selfProps, _ = - match cud.cudAlternatives |> Array.toList |> List.findi 0 (fun alt -> repr.OptimizeSingleNonNullaryAlternativeToRootClass (info,alt)) with - | Some (alt,altNum) -> - let fields = (alt.FieldDefs |> Array.toList |> List.map mkUnionCaseFieldId) let ctor = mkILSimpleStorageCtor (cud.cudWhere, - (match td.Extends with None -> Some cenv.ilg.tspec_Object | Some typ -> Some typ.TypeSpec), + baseInit, baseTy, (fields @ tagFieldsInObject), (if cuspec.HasHelpers = AllHelpers then ILMemberAccess.Assembly else cud.cudReprAccess)) - |> addMethodGeneratedAttrs cenv.ilg - - let props, meths = mkMethodsAndPropertiesForFields cenv cud.cudReprAccess cud.cudWhere cud.cudHasHelpers baseTy alt.FieldDefs - fields,([ctor] @ meths),props,altNum + |> addMethodGeneratedAttrs ilg - | None -> - [],[],[],0 + let props, meths = mkMethodsAndPropertiesForFields ilg cud.cudReprAccess cud.cudWhere cud.cudHasHelpers baseTy alt.FieldDefs + yield (fields,([ctor] @ meths),props) ] + |> List.unzip3 + |> (fun (a,b,c) -> List.concat a, List.concat b, List.concat c) let selfAndTagFields = [ for (fldName,fldTy) in (selfFields @ tagFieldsInObject) do - let fdef = mkHiddenGeneratedInstanceFieldDef cenv.ilg (fldName,fldTy, None, ILMemberAccess.Assembly) - yield { fdef with IsInitOnly=isTotallyImmutable } ] + let fdef = mkHiddenGeneratedInstanceFieldDef ilg (fldName,fldTy, None, ILMemberAccess.Assembly) + yield { fdef with IsInitOnly= (not isStruct && isTotallyImmutable) } ] let ctorMeths = if (isNil selfFields && isNil tagFieldsInObject && nonNil selfMeths) - || cud.cudAlternatives |> Array.forall (fun alt -> repr.OptimizeSingleNonNullaryAlternativeToRootClass (info,alt)) then + || cud.cudAlternatives |> Array.forall (fun alt -> repr.RepresentAlternativeAsFreshInstancesOfRootClass (info,alt)) then [] (* no need for a second ctor in these cases *) else [ mkILSimpleStorageCtor (cud.cudWhere, - (match td.Extends with None -> Some cenv.ilg.tspec_Object | Some typ -> Some typ.TypeSpec), + (match td.Extends with None -> Some ilg.tspec_Object | Some typ -> Some typ.TypeSpec), baseTy, tagFieldsInObject, ILMemberAccess.Assembly) // cud.cudReprAccess) - |> addMethodGeneratedAttrs cenv.ilg ] + |> addMethodGeneratedAttrs ilg ] // Now initialize the constant fields wherever they are stored... let addConstFieldInit cd = @@ -970,88 +966,60 @@ let rec convClassUnionDef cenv enc td cud = | SingleCase | RuntimeTypes | TailOrNull -> - yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[])); + yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[])) | IntegerTag -> if inRootClass then - yield (AI_ldc(DT_I4,ILConst.I4(fidx))); - yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[mkTagFieldType cenv.ilg cuspec] )) + yield mkLdcInt32 fidx + yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[mkTagFieldType ilg cuspec] )) else - yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[])); + yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[])) yield mkNormalStsfld constFieldSpec ] cud.cudWhere cd let tagMeths, tagProps, tagEnumFields = - let tagFieldType = mkTagFieldType cenv.ilg cuspec + let tagFieldType = mkTagFieldType ilg cuspec let tagEnumFields = cud.cudAlternatives |> Array.mapi (fun num alt -> mkILLiteralField (alt.Name, tagFieldType, ILFieldInit.Int32 num, None, ILMemberAccess.Public)) |> Array.toList + let tagMeths,tagProps = + + let body = mkMethodBody(true,emptyILLocals,2,genWith (fun cg -> emitLdDataTagPrim ilg (Some mkLdarg0) cg (true, cuspec); cg.EmitInstr I_ret), cud.cudWhere) // // If we are using NULL as a representation for an element of this type then we cannot // // use an instance method - if (repr.OptimizingOneAlternativeToNull info) then - [ mkILNonGenericStaticMethod - ("Get" + tagPropertyName, - cud.cudHelpersAccess, - [mkILParamAnon baseTy], - mkILReturn tagFieldType, - mkMethodBody(true,emptyILLocals,2, - nonBranchingInstrsToCode - [ mkLdarg0; - (mkIlxInstr (EI_lddatatag (true, cuspec))) ], - cud.cudWhere)) - |> convMethodDef cenv - |> addMethodGeneratedAttrs cenv.ilg ], + if (repr.RepresentOneAlternativeAsNull info) then + [ mkILNonGenericStaticMethod("Get" + tagPropertyName,cud.cudHelpersAccess,[mkILParamAnon baseTy],mkILReturn tagFieldType,body) + |> addMethodGeneratedAttrs ilg ], [] else - [ mkILNonGenericInstanceMethod - ("get_" + tagPropertyName, - cud.cudHelpersAccess,[], - mkILReturn tagFieldType, - mkMethodBody(true,emptyILLocals,2, - nonBranchingInstrsToCode - [ mkLdarg0; - (mkIlxInstr (EI_lddatatag (true, cuspec))) ], - cud.cudWhere)) - |> convMethodDef cenv - |> addMethodGeneratedAttrs cenv.ilg ], + [ mkILNonGenericInstanceMethod("get_" + tagPropertyName,cud.cudHelpersAccess,[],mkILReturn tagFieldType,body) + |> addMethodGeneratedAttrs ilg ], - [ { Name=tagPropertyName; - IsRTSpecialName=false; - IsSpecialName=false; - SetMethod=None; - GetMethod=Some(mkILMethRef(baseTy.TypeRef,ILCallingConv.Instance,"get_" + tagPropertyName,0,[], tagFieldType)); - CallingConv=ILThisConvention.Instance; - Type=tagFieldType; - Init=None; - Args=mkILTypes []; - CustomAttrs=emptyILCustomAttrs; } - |> addPropertyGeneratedAttrs cenv.ilg - |> addPropertyNeverAttrs cenv.ilg ] + [ { Name=tagPropertyName + IsRTSpecialName=false + IsSpecialName=false + SetMethod=None + GetMethod=Some(mkILMethRef(baseTy.TypeRef,ILCallingConv.Instance,"get_" + tagPropertyName,0,[], tagFieldType)) + CallingConv=ILThisConvention.Instance + Type=tagFieldType + Init=None + Args=mkILTypes [] + CustomAttrs=emptyILCustomAttrs } + |> addPropertyGeneratedAttrs ilg + |> addPropertyNeverAttrs ilg ] tagMeths, tagProps, tagEnumFields // The class can be abstract if each alternative is represented by a derived type let isAbstract = (altTypeDefs.Length = cud.cudAlternatives.Length) - let existingMeths = - td.Methods.AsList - // Filter out the F#-compiler supplied implementation of the get_Empty method. This is because we will replace - // its implementation by one that loads the unique private static field for lists - |> List.filter (fun md -> not (cud.cudHasHelpers = SpecialFSharpListHelpers && (md.Name = "get_Empty" || md.Name = "Cons" || md.Name = "get_IsEmpty")) && - not (cud.cudHasHelpers = SpecialFSharpOptionHelpers && (md.Name = "get_Value" || md.Name = "get_None" || md.Name = "Some"))) - // Convert the user-defined methods - |> List.map (convMethodDef cenv) - - let existingProps = - td.Properties.AsList - // Filter out the F#-compiler supplied implementation of the Empty property. - |> List.filter (fun pd -> not (cud.cudHasHelpers = SpecialFSharpListHelpers && (pd.Name = "Empty" || pd.Name = "IsEmpty" )) && - not (cud.cudHasHelpers = SpecialFSharpOptionHelpers && (pd.Name = "Value" || pd.Name = "None"))) - + let existingMeths = td.Methods.AsList + let existingProps = td.Properties.AsList + let enumTypeDef = // The nested Tags type is elided if there is only one tag // The Tag property is NOT elided if there is only one tag @@ -1059,87 +1027,45 @@ let rec convClassUnionDef cenv enc td cud = None else Some - { Name = "Tags"; - NestedTypes = emptyILTypeDefs; - GenericParams= td.GenericParams; - Access = ILTypeDefAccess.Nested cud.cudReprAccess; - IsAbstract = true; - IsSealed = true; - IsSerializable=false; - IsComInterop=false; - Layout=ILTypeDefLayout.Auto; - IsSpecialName=false; - Encoding=ILDefaultPInvokeEncoding.Ansi; - Implements = mkILTypes []; - Extends= Some cenv.ilg.typ_Object ; - Methods= emptyILMethods; - SecurityDecls=emptyILSecurityDecls; - HasSecurity=false; - Fields=mkILFields tagEnumFields; - MethodImpls=emptyILMethodImpls; - InitSemantics=ILTypeInit.OnAny; - Events=emptyILEvents; - Properties=emptyILProperties; - CustomAttrs= emptyILCustomAttrs; - tdKind = ILTypeDefKind.Enum; } + { Name = "Tags" + NestedTypes = emptyILTypeDefs + GenericParams= td.GenericParams + Access = ILTypeDefAccess.Nested cud.cudReprAccess + IsAbstract = true + IsSealed = true + IsSerializable=false + IsComInterop=false + Layout=ILTypeDefLayout.Auto + IsSpecialName=false + Encoding=ILDefaultPInvokeEncoding.Ansi + Implements = mkILTypes [] + Extends= Some ilg.typ_Object + Methods= emptyILMethods + SecurityDecls=emptyILSecurityDecls + HasSecurity=false + Fields=mkILFields tagEnumFields + MethodImpls=emptyILMethodImpls + InitSemantics=ILTypeInit.OnAny + Events=emptyILEvents + Properties=emptyILProperties + CustomAttrs= emptyILCustomAttrs + tdKind = ILTypeDefKind.Enum } let baseTypeDef = - { Name = td.Name; - NestedTypes = mkILTypeDefs (Option.toList enumTypeDef @ - altTypeDefs @ - altDebugTypeDefs @ - (convTypeDefs cenv (enc@[td]) td.NestedTypes).AsList); - GenericParams= td.GenericParams; - Access = td.Access; - IsAbstract = isAbstract; - IsSealed = altTypeDefs.IsEmpty; - IsSerializable=td.IsSerializable; - IsComInterop=false; - Layout=td.Layout; - IsSpecialName=td.IsSpecialName; - Encoding=td.Encoding ; - Implements = td.Implements; - Extends= (match td.Extends with None -> Some cenv.ilg.typ_Object | _ -> td.Extends) ; - Methods= mkILMethods (ctorMeths @ - baseMethsFromAlt @ - selfMeths @ - tagMeths @ - altUniqObjMeths @ - existingMeths); - - SecurityDecls=td.SecurityDecls; - HasSecurity=td.HasSecurity; - Fields=mkILFields (selfAndTagFields @ List.map (fun (_,_,_,_,fdef,_) -> fdef) altNullaryFields @ td.Fields.AsList); - MethodImpls=td.MethodImpls; - InitSemantics=ILTypeInit.BeforeField; - Events=td.Events; - Properties=mkILProperties (tagProps @ basePropsFromAlt @ selfProps @ existingProps); - CustomAttrs=td.CustomAttrs; - tdKind = ILTypeDefKind.Class; } + { td with + NestedTypes = mkILTypeDefs (Option.toList enumTypeDef @ altTypeDefs @ altDebugTypeDefs @ td.NestedTypes.AsList) + IsAbstract = isAbstract + IsSealed = altTypeDefs.IsEmpty + IsComInterop=false + Extends= (match td.Extends with None -> Some ilg.typ_Object | _ -> td.Extends) + Methods= mkILMethods (ctorMeths @ baseMethsFromAlt @ selfMeths @ tagMeths @ altUniqObjMeths @ existingMeths) + Fields=mkILFields (selfAndTagFields @ List.map (fun (_,_,_,_,fdef,_) -> fdef) altNullaryFields @ td.Fields.AsList) + InitSemantics=ILTypeInit.BeforeField + Properties=mkILProperties (tagProps @ basePropsFromAlt @ selfProps @ existingProps) + tdKind = ILTypeDefKind.Class } // The .cctor goes on the Cases type since that's where the constant fields for nullary constructors live |> addConstFieldInit baseTypeDef -and convTypeDef cenv enc td = - match td.tdKind with - | ILTypeDefKind.Other e when isIlxExtTypeDefKind e -> - begin match destIlxExtTypeDefKind e with - | IlxTypeDefKind.Closure cloinfo -> - {td with NestedTypes = convTypeDefs cenv (enc@[td]) td.NestedTypes; - Methods=morphILMethodDefs (convMethodDef cenv) td.Methods; - tdKind= mkIlxTypeDefKind(IlxTypeDefKind.Closure (morphIlxClosureInfo (convILMethodBody cenv) cloinfo)) } - | IlxTypeDefKind.Union cud -> convClassUnionDef cenv enc td cud - end - | _ -> - {td with NestedTypes = convTypeDefs cenv (enc@[td]) td.NestedTypes; - Methods=morphILMethodDefs (convMethodDef cenv) td.Methods; } - -and convTypeDefs cenv enc tdefs : ILTypeDefs = - morphILTypeDefs (convTypeDef cenv enc) tdefs - -let ConvModule ilg modul = - let cenv = { ilg=ilg; } - morphILTypeDefsInILModule (convTypeDefs cenv []) modul - diff --git a/src/ilx/EraseUnions.fsi b/src/ilx/EraseUnions.fsi index 96ed542478..47311b2770 100755 --- a/src/ilx/EraseUnions.fsi +++ b/src/ilx/EraseUnions.fsi @@ -9,5 +9,44 @@ module internal Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.EraseUnions open Microsoft.FSharp.Compiler.AbstractIL.IL open Microsoft.FSharp.Compiler.AbstractIL.Extensions.ILX.Types -val ConvModule: ILGlobals -> ILModuleDef -> ILModuleDef +/// Make the instruction sequence for a "newdata" operation +val mkNewData : ILGlobals -> IlxUnionSpec * int -> ILInstr list + +/// Make the instruction sequence for a "isdata" operation +val mkIsData : ILGlobals -> bool * IlxUnionSpec * int -> ILInstr list + +/// Make the instruction sequence for a "lddata" operation +val mkLdData : bool * IlxUnionSpec * int * int -> ILInstr list + +/// Make the instruction sequence for a "lddataa" operation +val mkLdDataAddr : bool * IlxUnionSpec * int * int -> ILInstr list + +/// Make the instruction sequence for a "stdata" operation +val mkStData : IlxUnionSpec * int * int -> ILInstr list + +/// Make the instruction sequence for a "brisnotdata" operation +val mkBrIsNotData : ILGlobals -> avoidHelpers:bool * IlxUnionSpec * int * ILCodeLabel -> ILInstr list + +/// Make the type definition for a union type +val mkClassUnionDef : ILGlobals -> ILTypeRef -> ILTypeDef -> IlxUnionInfo -> ILTypeDef + +/// Make the IL type for a union type alternative val GetILTypeForAlternative : IlxUnionSpec -> int -> ILType + +/// Used to emit instructions (an interface to the IlxGen.fs code generator) +type ICodeGen<'Mark> = + abstract CodeLabel: 'Mark -> ILCodeLabel + abstract GenerateDelayMark: unit -> 'Mark + abstract GenLocal: ILType -> uint16 + abstract SetMarkToHere: 'Mark -> unit + abstract EmitInstr : ILInstr -> unit + abstract EmitInstrs : ILInstr list -> unit + +/// Emit the instruction sequence for a "castdata" operation +val emitCastData : ILGlobals -> ICodeGen<'Mark> -> canfail: bool * avoidHelpers:bool * IlxUnionSpec * int -> unit + +/// Emit the instruction sequence for a "lddatatag" operation +val emitLdDataTag : ILGlobals -> ICodeGen<'Mark> -> avoidHelpers:bool * IlxUnionSpec -> unit + +/// Emit the instruction sequence for a "switchdata" operation +val emitDataSwitch : ILGlobals -> ICodeGen<'Mark> -> avoidHelpers:bool * IlxUnionSpec * (int * ILCodeLabel) list -> unit diff --git a/src/utils/EditDistance.fs b/src/utils/EditDistance.fs new file mode 100644 index 0000000000..b1271f1b76 --- /dev/null +++ b/src/utils/EditDistance.fs @@ -0,0 +1,47 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. + +/// Functions to compute the edit distance between two strings +module internal Internal.Utilities.EditDistance + +/// Computes the DamerauLevenstein distance +/// - read more at https://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance +/// - Implementation taken from http://www.navision-blog.de/2008/11/01/damerau-levenshtein-distance-in-fsharp-part-ii/ +let private calcDamerauLevenshtein (a:string, b:string) = + let m = b.Length + 1 + let mutable lastLine = Array.init m (fun i -> i) + let mutable lastLastLine = Array.create m 0 + let mutable actLine = Array.create m 0 + + for i in [1..a.Length] do + actLine.[0] <- i + for j in [1..b.Length] do + let cost = if a.[i-1] = b.[j-1] then 0 else 1 + let deletion = lastLine.[j] + 1 + let insertion = actLine.[j-1] + 1 + let substitution = lastLine.[j-1] + cost + actLine.[j] <- + deletion + |> min insertion + |> min substitution + + if i > 1 && j > 1 then + if a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1] then + let transposition = lastLastLine.[j-2] + cost + actLine.[j] <- min actLine.[j] transposition + + // swap lines + let temp = lastLastLine + lastLastLine <- lastLine + lastLine <- actLine + actLine <- temp + + lastLine.[b.Length] + +/// Calculates the edit distance between two strings. +/// The edit distance is a metric that allows to measure the amount of difference between two strings +/// and shows how many edit operations (insert, delete, substitution) are needed to transform one string into the other. +let CalcEditDistance(a:string, b:string) = + if a.Length > b.Length then + calcDamerauLevenshtein(a, b) + else + calcDamerauLevenshtein(b, a) \ No newline at end of file diff --git a/src/utils/HashMultiMap.fs b/src/utils/HashMultiMap.fs index 213b0c118c..3c19849a4d 100755 --- a/src/utils/HashMultiMap.fs +++ b/src/utils/HashMultiMap.fs @@ -84,7 +84,7 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) member x.Remove(y) = let mutable res = Unchecked.defaultof<'Value> let ok = firstEntries.TryGetValue(y,&res) - // Note, if not ok then nothing to remove - nop + // NOTE: If not ok then nothing to remove - nop if ok then // We drop the FirstEntry. Here we compute the new FirstEntry and residue MoreEntries let mutable res = [] @@ -98,7 +98,6 @@ type internal HashMultiMap<'Key,'Value>(n: int, hasheq: IEqualityComparer<'Key>) firstEntries.[y] <- h rest.[y] <- t | _ -> - // note: broken invariant () else firstEntries.Remove(y) |> ignore diff --git a/src/utils/HashMultiMap.fsi b/src/utils/HashMultiMap.fsi index 449708c89b..c08edd73ff 100755 --- a/src/utils/HashMultiMap.fsi +++ b/src/utils/HashMultiMap.fsi @@ -10,52 +10,52 @@ open System.Collections.Generic /// The table may map a single key to multiple bindings. [] type internal HashMultiMap<'Key,'Value> = - /// Create a new empty mutable HashMultiMap with the given key hash/equality functions + /// Create a new empty mutable HashMultiMap with the given key hash/equality functions. new : comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> /// Create a new empty mutable HashMultiMap with an internal bucket array of the given approximate size - /// and with the given key hash/equality functions + /// and with the given key hash/equality functions. new : size:int * comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> - /// Build a map that contains the bindings of the given IEnumerable + /// Build a map that contains the bindings of the given IEnumerable. new : entries:seq<'Key * 'Value> * comparer:IEqualityComparer<'Key> -> HashMultiMap<'Key,'Value> - /// Make a shallow copy of the collection + /// Make a shallow copy of the collection. member Copy : unit -> HashMultiMap<'Key,'Value> - /// Add a binding for the element to the table + /// Add a binding for the element to the table. member Add : 'Key * 'Value -> unit - /// Clear all elements from the collection + /// Clear all elements from the collection. member Clear : unit -> unit - /// Test if the collection contains any bindings for the given element + /// Test if the collection contains any bindings for the given element. member ContainsKey: 'Key -> bool - /// Remove the latest binding (if any) for the given element from the table + /// Remove the latest binding if any for the given element from the table. member Remove : 'Key -> unit - /// Replace the latest binding (if any) for the given element. + /// Replace the latest binding if any for the given element. member Replace : 'Key * 'Value -> unit /// Lookup or set the given element in the table. Set replaces all existing bindings for a value with a single /// bindings. Raise KeyNotFoundException if the element is not found. member Item : 'Key -> 'Value with get,set - /// Lookup the given element in the table, returning the result as an Option + /// Lookup the given element in the table, returning the result as an Option. member TryFind : 'Key -> 'Value option - /// Find all bindings for the given element in the table, if any + /// Find all bindings for the given element in the table, if any. member FindAll : 'Key -> 'Value list /// Apply the given function to each element in the collection threading the accumulating parameter - /// through the sequence of function applications + /// through the sequence of function applications. member Fold : ('Key -> 'Value -> 'State -> 'State) -> 'State -> 'State - /// The total number of keys in the hash table + /// The total number of keys in the hash table. member Count : int - ///Apply the given function to each binding in the hash table + /// Apply the given function to each binding in the hash table. member Iterate : ('Key -> 'Value -> unit) -> unit interface IDictionary<'Key, 'Value> diff --git a/src/utils/ResizeArray.fsi b/src/utils/ResizeArray.fsi index 15c4212187..eaf0893701 100755 --- a/src/utils/ResizeArray.fsi +++ b/src/utils/ResizeArray.fsi @@ -27,29 +27,29 @@ module internal ResizeArray = /// Create an array by calling the given generator on each index. val init: int -> (int -> 'T) -> ResizeArray<'T> - ///Build a new array that contains the elements of the first array followed by the elements of the second array + /// Build a new array that contains the elements of the first array followed by the elements of the second array. val append: ResizeArray<'T> -> ResizeArray<'T> -> ResizeArray<'T> - ///Build a new array that contains the elements of each of the given list of arrays + /// Build a new array that contains the elements of each of the given list of arrays. val concat: ResizeArray<'T> list -> ResizeArray<'T> - ///Build a new array that contains the given subrange specified by - ///starting index and length. + /// Build a new array that contains the given subrange specified by + /// starting index and length. val sub: ResizeArray<'T> -> int -> int -> ResizeArray<'T> - ///Build a new array that contains the elements of the given array + /// Build a new array that contains the elements of the given array. val copy: ResizeArray<'T> -> ResizeArray<'T> - ///Fill a range of the collection with the given element + /// Fill a range of the collection with the given element. val fill: ResizeArray<'T> -> int -> int -> 'T -> unit - ///Read a range of elements from the first array and write them into the second. + /// Read a range of elements from the first array and write them into the second. val blit: ResizeArray<'T> -> int -> ResizeArray<'T> -> int -> int -> unit - ///Build a list from the given array + /// Build a list from the given array. val toList: ResizeArray<'T> -> 'T list - ///Build an array from the given list + /// Build an array from the given list. val ofList: 'T list -> ResizeArray<'T> /// Apply a function to each element of the collection, threading an accumulator argument @@ -62,30 +62,30 @@ module internal ResizeArray = /// computes f i0 (...(f iN s)). val foldBack: ('T -> 'U -> 'U) -> ResizeArray<'T> -> 'U -> 'U - ///Apply the given function to each element of the array. + /// Apply the given function to each element of the array. val iter: ('T -> unit) -> ResizeArray<'T> -> unit - ///Build a new array whose elements are the results of applying the given function - ///to each of the elements of the array. + /// Build a new array whose elements are the results of applying the given function + /// to each of the elements of the array. val map: ('T -> 'U) -> ResizeArray<'T> -> ResizeArray<'U> - ///Apply the given function to two arrays simultaneously. The - ///two arrays must have the same lengths, otherwise an Invalid_argument exception is - ///raised. + /// Apply the given function to two arrays simultaneously. The + /// two arrays must have the same lengths, otherwise an Invalid_argument exception is + /// raised. val iter2: ('T -> 'U -> unit) -> ResizeArray<'T> -> ResizeArray<'U> -> unit - ///Build a new collection whose elements are the results of applying the given function - ///to the corresponding elements of the two collections pairwise. The two input - ///arrays must have the same lengths. + /// Build a new collection whose elements are the results of applying the given function + /// to the corresponding elements of the two collections pairwise. The two input + /// arrays must have the same lengths. val map2: ('T -> 'U -> 'c) -> ResizeArray<'T> -> ResizeArray<'U> -> ResizeArray<'c> - ///Apply the given function to each element of the array. The integer passed to the - ///function indicates the index of element. + /// Apply the given function to each element of the array. The integer passed to the + /// function indicates the index of element. val iteri: (int -> 'T -> unit) -> ResizeArray<'T> -> unit - ///Build a new array whose elements are the results of applying the given function - ///to each of the elements of the array. The integer index passed to the - ///function indicates the index of element being transformed. + /// Build a new array whose elements are the results of applying the given function + /// to each of the elements of the array. The integer index passed to the + /// function indicates the index of element being transformed. val mapi: (int -> 'T -> 'U) -> ResizeArray<'T> -> ResizeArray<'U> /// Test if any element of the array satisfies the given predicate. @@ -98,46 +98,48 @@ module internal ResizeArray = /// then computes p i0 && ... && p iN. val forall: ('T -> bool) -> ResizeArray<'T> -> bool - ///Return a new collection containing only the elements of the collection - ///for which the given predicate returns true + /// Return a new collection containing only the elements of the collection + /// for which the given predicate returns True. val filter: ('T -> bool) -> ResizeArray<'T> -> ResizeArray<'T> - ///Split the collection into two collections, containing the - ///elements for which the given predicate returns true and false - ///respectively + /// Split the collection into two collections, containing the + /// elements for which the given predicate returns True and False + /// respectively. val partition: ('T -> bool) -> ResizeArray<'T> -> ResizeArray<'T> * ResizeArray<'T> - ///Apply the given function to each element of the array. Return - ///the array comprised of the results "x" for each element where - ///the function returns Some(x) + /// Apply the given function to each element of the array. Return + /// the array comprised of the results "x" for each element where + /// the function returns Some(x). val choose: ('T -> 'U option) -> ResizeArray<'T> -> ResizeArray<'U> - ///Return the first element for which the given function returns true. - ///Raise KeyNotFoundException if no such element exists. + /// Return the first element for which the given function returns True. + /// Raise KeyNotFoundException if no such element exists. val find: ('T -> bool) -> ResizeArray<'T> -> 'T - ///Return the first element for which the given function returns true. - ///Return None if no such element exists. + /// Return the first element for which the given function returns True. + /// Return None if no such element exists. val tryFind: ('T -> bool) -> ResizeArray<'T> -> 'T option - ///Apply the given function to successive elements, returning the first - ///result where function returns "Some(x)" for some x. + /// Apply the given function to successive elements, returning the first + /// result where function returns Some(x) for some x. val tryPick: ('T -> 'U option) -> ResizeArray<'T> -> 'U option - ///Return a new array with the elements in reverse order + /// Return a new array with the elements in reverse order. val rev: ResizeArray<'T> -> ResizeArray<'T> - /// Sort the elements using the given comparison function + /// Sort the elements using the given comparison function. val sort: ('T -> 'T -> int) -> ResizeArray<'T> -> unit - /// Sort the elements using the key extractor and generic comparison on the keys + /// Sort the elements using the key extractor and generic comparison on the keys. val sortBy: ('T -> 'Key) -> ResizeArray<'T> -> unit when 'Key : comparison - /// Return a fixed-length array containing the elements of the input ResizeArray + /// Return a fixed-length array containing the elements of the input ResizeArray. val toArray : ResizeArray<'T> -> 'T[] - /// Build a ResizeArray from the given elements + + /// Build a ResizeArray from the given elements. val ofArray : 'T[] -> ResizeArray<'T> - /// Return a view of the array as an enumerable object + + /// Return a view of the array as an enumerable object. val toSeq : ResizeArray<'T> -> seq<'T> /// Test elements of the two arrays pairwise to see if any pair of element satisfies the given predicate. @@ -178,10 +180,10 @@ module internal ResizeArray = val foldBack2 : ('a1 -> 'a2 -> 'U -> 'U) -> ResizeArray<'a1> -> ResizeArray<'a2> -> 'U -> 'U /// Test elements of the two arrays pairwise to see if all pairs of elements satisfy the given predicate. - /// Raise ArgumentException if the arrays have different lengths. + /// Raise ArgumentException if the arrays have different lengths. val forall2 : ('T -> 'U -> bool) -> ResizeArray<'T> -> ResizeArray<'U> -> bool - /// Return true if the given array is empty, otherwise false + /// Return True if the given array is empty, otherwise False. val isEmpty : ResizeArray<'T> -> bool /// Apply the given function to pair of elements drawn from matching indices in two arrays, @@ -195,13 +197,13 @@ module internal ResizeArray = /// raised. val mapi2 : (int -> 'T -> 'U -> 'c) -> ResizeArray<'T> -> ResizeArray<'U> -> ResizeArray<'c> - /// Like fold, but return the intermediary and final results + /// Like fold, but return the intermediary and final results. val scan : ('U -> 'T -> 'U) -> 'U -> ResizeArray<'T> -> ResizeArray<'U> - /// Like foldBack, but return both the intermediary and final results + /// Like foldBack, but return both the intermediary and final results. val scanBack : ('T -> 'c -> 'c) -> ResizeArray<'T> -> 'c -> ResizeArray<'c> - /// Return an array containing the given element + /// Return an array containing the given element. val singleton : 'T -> ResizeArray<'T> /// Return the index of the first element in the array @@ -216,5 +218,5 @@ module internal ResizeArray = /// raised.. val zip : ResizeArray<'T> -> ResizeArray<'U> -> ResizeArray<'T * 'U> - /// Split an array of pairs into two arrays + /// Split an array of pairs into two arrays. val unzip : ResizeArray<'T * 'U> -> ResizeArray<'T> * ResizeArray<'U> diff --git a/src/utils/TaggedCollections.fs b/src/utils/TaggedCollections.fs index 1e39f71a25..dc966ab347 100755 --- a/src/utils/TaggedCollections.fs +++ b/src/utils/TaggedCollections.fs @@ -711,9 +711,6 @@ namespace Internal.Utilities.Collections.Tagged #if ONE | MapOne of 'Key * 'T #endif - // Note: performance rumour has it that the data held in this node should be - // exactly one cache line. It is currently ~7 words. Thus it might be better to - // move to a n-way tree. | MapNode of 'Key * 'T * MapTree<'Key,'T> * MapTree<'Key,'T> * int diff --git a/src/utils/TaggedCollections.fsi b/src/utils/TaggedCollections.fsi index f70b592826..efbe031a04 100755 --- a/src/utils/TaggedCollections.fsi +++ b/src/utils/TaggedCollections.fsi @@ -12,62 +12,62 @@ namespace Internal.Utilities.Collections.Tagged [] type internal Set<'T,'ComparerTag> when 'ComparerTag :> IComparer<'T> = - /// A useful shortcut for Set.add. Note this operation produces a new set + /// A useful shortcut for Set.add. Note this operation produces a new set /// and does not mutate the original set. The new set will share many storage - /// nodes with the original. See the Set module for further operations on sets. + /// nodes with the original. See the Set module for further operations on sets. member Add : 'T -> Set<'T,'ComparerTag> - /// A useful shortcut for Set.remove. Note this operation produces a new set + /// A useful shortcut for Set.remove. Note this operation produces a new set /// and does not mutate the original set. The new set will share many storage - /// nodes with the original. See the Set module for further operations on sets. + /// nodes with the original. See the Set module for further operations on sets. member Remove : 'T -> Set<'T,'ComparerTag> - /// Return the number of elements in the set + /// Return the number of elements in the set. member Count : int - /// A useful shortcut for Set.contains. See the Set module for further operations on sets. + /// A useful shortcut for Set.contains. See the Set module for further operations on sets. member Contains : 'T -> bool - /// A useful shortcut for Set.isEmpty. See the Set module for further operations on sets. + /// A useful shortcut for Set.isEmpty. See the Set module for further operations on sets. member IsEmpty : bool - /// Apply the given function to each binding in the collection + /// Apply the given function to each binding in the collection. member Iterate : ('T -> unit) -> unit - /// Apply the given accumulating function to all the elements of the set + /// Apply the given accumulating function to all the elements of the set. member Fold : ('T -> 'State -> 'State) -> 'State -> 'State - /// Build two new sets, one containing the elements for which the given predicate returns 'true', - /// and the other the remaining elements. + /// Build two new sets, one containing the elements for which the given predicate returns True, + /// and another with the remaining elements. member Partition: predicate:('T -> bool) -> Set<'T,'ComparerTag> * Set<'T,'ComparerTag> /// Return a new collection containing only the elements of the collection - /// for which the given predicate returns "true" + /// for which the given predicate returns True. member Filter: predicate:('T -> bool) -> Set<'T,'ComparerTag> /// Test if any element of the collection satisfies the given predicate. - /// If the input function is f and the elements are i0...iN then computes - /// p i0 or ... or p iN. + /// If the input function is f and the elements are i0...iN then computes + /// p i0 or ... or p iN. member Exists: predicate:('T -> bool) -> bool /// Test if all elements of the collection satisfy the given predicate. - /// If the input function is f and the elements are i0...iN and j0...jN then - /// computes p i0 && ... && p iN. + /// If the input function is f and the elements are i0...iN and j0...jN then + /// computes p i0 && ... && p iN. member ForAll: predicate:('T -> bool) -> bool - /// A set based on the given comparer containing the given initial elements + /// A set based on the given comparer containing the given initial elements. static member Create: 'ComparerTag * seq<'T> -> Set<'T,'ComparerTag> - /// The empty set based on the given comparer + /// The empty set based on the given comparer. static member Empty: 'ComparerTag -> Set<'T,'ComparerTag> - /// A singleton set based on the given comparison operator + /// A singleton set based on the given comparison operator. static member Singleton: 'ComparerTag * 'T -> Set<'T,'ComparerTag> - /// Compares two sets and returns true if they are equal or false otherwise + /// Compares two sets and returns True if they are equal or False otherwise. static member Equality : Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> bool - /// Compares a and b and returns 1 if a > b, -1 if b < a and 0 if a = b + /// Compares a and b and returns 1 if a > b, -1 if b < a and 0 if a = b. static member Compare : a:Set<'T,'ComparerTag> * b:Set<'T,'ComparerTag> -> int /// Return a new set with the elements of the second set removed from the first. @@ -85,19 +85,19 @@ namespace Internal.Utilities.Collections.Tagged /// Return a new set with the elements of the second set removed from the first. static member Difference: Set<'T,'ComparerTag> * Set<'T,'ComparerTag> -> Set<'T,'ComparerTag> - /// The number of elements in the set + /// The number of elements in the set. member Choose : 'T - /// Returns the lowest element in the set according to the ordering being used for the set + /// Returns the lowest element in the set according to the ordering being used for the set. member MinimumElement: 'T - /// Returns the highest element in the set according to the ordering being used for the set + /// Returns the highest element in the set according to the ordering being used for the set. member MaximumElement: 'T - /// Evaluates to "true" if all elements of the second set are in the first + /// Evaluates to True if all elements of the second set are in the first. member IsSubsetOf: Set<'T,'ComparerTag> -> bool - /// Evaluates to "true" if all elements of the first set are in the second + /// Evaluates to True if all elements of the first set are in the second. member IsSupersetOf: Set<'T,'ComparerTag> -> bool /// The elements of the set as a list. @@ -131,7 +131,7 @@ namespace Internal.Utilities.Collections.Tagged /// Return a new map with the binding added to the given map. member Add: 'Key * 'Value -> Map<'Key,'Value,'ComparerTag> - /// Return true if there are no bindings in the map. + /// Return True if there are no bindings in the map. member IsEmpty: bool //member Comparer : 'ComparerTag @@ -142,32 +142,32 @@ namespace Internal.Utilities.Collections.Tagged static member FromList : 'ComparerTag * ('Key * 'Value) list -> Map<'Key,'Value,'ComparerTag> - /// Build a map that contains the bindings of the given IEnumerable - /// and where comparison of elements is based on the given comparison function + /// Build a map that contains the bindings of the given IEnumerable + /// and where comparison of elements is based on the given comparison function. static member Create: 'ComparerTag * seq<'Key * 'Value> -> Map<'Key,'Value,'ComparerTag> - /// Test is an element is in the domain of the map + /// Test is an element is in the domain of the map. member ContainsKey: 'Key -> bool - /// The number of bindings in the map + /// The number of bindings in the map. member Count: int /// Lookup an element in the map. Raise KeyNotFoundException if no binding /// exists in the map. member Item : 'Key -> 'Value with get - /// Search the map looking for the first element where the given function returns a Some value + /// Search the map looking for the first element where the given function returns a Some value. member First: ('Key -> 'Value -> 'T option) -> 'T option - /// Return true if the given predicate returns true for all of the + /// Return True if the given predicate returns true for all of the /// bindings in the map. Always returns true if the map is empty. member ForAll: ('Key -> 'Value -> bool) -> bool - /// Return true if the given predicate returns true for one of the + /// Return True if the given predicate returns true for one of the /// bindings in the map. Always returns false if the map is empty. member Exists: ('Key -> 'Value -> bool) -> bool - /// Build a new map containing the bindings for which the given predicate returns 'true'. + /// Build a new map containing the bindings for which the given predicate returns True. member Filter: ('Key -> 'Value -> bool) -> Map<'Key,'Value,'ComparerTag> /// Fold over the bindings in the map. @@ -181,7 +181,7 @@ namespace Internal.Utilities.Collections.Tagged /// Fold over the bindings in the map. member FoldAndMap: ('Key -> 'Value -> 'State -> 'T * 'State) -> 'State -> Map<'Key,'T,'ComparerTag> * 'State - /// Apply the given function to each binding in the dictionary + /// Apply the given function to each binding in the dictionary. member Iterate: action:('Key -> 'Value -> unit) -> unit /// Build a new collection whose elements are the results of applying the given function @@ -193,21 +193,21 @@ namespace Internal.Utilities.Collections.Tagged /// to each of the elements of the collection. member MapRange: mapping:('Value -> 'T) -> Map<'Key,'T,'ComparerTag> - /// Build two new maps, one containing the bindings for which the given predicate returns 'true', - /// and the other the remaining bindings. + /// Build two new maps, one containing the bindings for which the given predicate returns True, + /// and another for the remaining bindings. member Partition: ('Key -> 'Value -> bool) -> Map<'Key,'Value,'ComparerTag> * Map<'Key,'Value,'ComparerTag> /// Remove an element from the domain of the map. No exception is raised if the element is not present. member Remove: 'Key -> Map<'Key,'Value,'ComparerTag> - /// Lookup an element in the map, returning a Some value if the element is in the domain - /// of the map and None if not. + /// Lookup an element in the map, returning a Some value if the element is in the domain + /// of the map and None if not. member TryFind: 'Key -> 'Value option /// The elements of the set as a list. member ToList : unit -> ('Key * 'Value) list - /// The elements of the set as an array + /// The elements of the set as an array. member ToArray: unit -> ('Key * 'Value) array interface IEnumerable> diff --git a/src/utils/filename.fsi b/src/utils/filename.fsi index 7a8a8e1cbc..14a40e915f 100755 --- a/src/utils/filename.fsi +++ b/src/utils/filename.fsi @@ -5,24 +5,24 @@ module internal Internal.Utilities.Filename exception IllegalFileNameChar of string * char -/// "checkSuffix f s" returns true if filename "f" ends in suffix "s", +/// checkSuffix f s returns True if filename "f" ends in suffix "s", /// e.g. checkSuffix "abc.fs" ".fs" returns true. val checkSuffix: string -> string -> bool -/// "chopExtension f" removes the extension from the given -/// filename. Raises ArgumentException if no extension is present. +/// chopExtension f removes the extension from the given +/// filename. Raises ArgumentException if no extension is present. val chopExtension: string -> string -/// "directoryName" " decomposes a filename into a directory name +/// "directoryName" " decomposes a filename into a directory name. val directoryName: string -> string -/// Return true if the filename has a "." extension +/// Return True if the filename has a "." extension. val hasExtension: string -> bool -/// Get the filename of the given path +/// Get the filename of the given path. val fileNameOfPath: string -> string -/// Get the filename without extension of the given path +/// Get the filename without extension of the given path. val fileNameWithoutExtension: string -> string diff --git a/src/utils/prim-lexing.fs b/src/utils/prim-lexing.fs index 0a4c5c2f11..19098f4f2e 100755 --- a/src/utils/prim-lexing.fs +++ b/src/utils/prim-lexing.fs @@ -75,15 +75,15 @@ namespace Internal.Utilities.Text.Lexing internal LexBuffer<'Char>(filler: LexBufferFiller<'Char>) = let context = new Dictionary(1) let mutable buffer=[||]; - /// number of valid characters beyond bufferScanStart + /// number of valid characters beyond bufferScanStart. let mutable bufferMaxScanLength=0; - /// count into the buffer when scanning + /// count into the buffer when scanning. let mutable bufferScanStart=0; - /// number of characters scanned so far + /// number of characters scanned so far. let mutable bufferScanLength=0; - /// length of the scan at the last accepting state + /// length of the scan at the last accepting state. let mutable lexemeLength=0; - /// action related to the last accepting state + /// action related to the last accepting state. let mutable bufferAcceptAction=0; let mutable eof = false; let mutable startPos = Position.Empty ; @@ -100,12 +100,12 @@ namespace Internal.Utilities.Text.Lexing member lexbuf.EndOfScan () : int = - // Printf.eprintf "endOfScan, lexBuffer.lexemeLength = %d\n" lexBuffer.lexemeLength; + //Printf.eprintf "endOfScan, lexBuffer.lexemeLength = %d\n" lexBuffer.lexemeLength; if bufferAcceptAction < 0 then failwith "unrecognized input" - // printf "endOfScan %d state %d on unconsumed input '%c' (%d)\n" a s (Char.chr inp) inp; - // Printf.eprintf "accept, lexeme = %s\n" (lexeme lexBuffer); + //printf "endOfScan %d state %d on unconsumed input '%c' (%d)\n" a s (Char.chr inp) inp; + //Printf.eprintf "accept, lexeme = %s\n" (lexeme lexBuffer); lexbuf.StartPos <- endPos; lexbuf.EndPos <- endPos.EndOfToken(lexbuf.LexemeLength); bufferAcceptAction @@ -183,10 +183,10 @@ namespace Internal.Utilities.Text.Lexing else if lexBuffer.IsPastEndOfStream then failwith "End of file on lexing stream"; lexBuffer.IsPastEndOfStream <- true; - // printf "state %d --> %d on eof\n" state snew; - scanUntilSentinel(lexBuffer,snew) + //printf "state %d --> %d on eof\n" state snew; + scanUntilSentinel lexBuffer snew else - scanUntilSentinel(lexBuffer, state) + scanUntilSentinel lexBuffer state let onAccept (lexBuffer:LexBuffer,a) = lexBuffer.LexemeLength <- lexBuffer.BufferScanLength; @@ -201,7 +201,7 @@ namespace Internal.Utilities.Text.Lexing let numUnicodeCategories = 30 let numLowUnicodeChars = 128 let numSpecificUnicodeChars = (trans.[0].Length - 1 - numLowUnicodeChars - numUnicodeCategories)/2 - let lookupUnicodeCharacters (state,inp) = + let lookupUnicodeCharacters state inp = let inpAsInt = int inp // Is it a fast ASCII character? if inpAsInt < numLowUnicodeChars then @@ -235,7 +235,7 @@ namespace Internal.Utilities.Text.Lexing loop 0 let eofPos = numLowUnicodeChars + 2*numSpecificUnicodeChars + numUnicodeCategories - let rec scanUntilSentinel(lexBuffer,state) = + let rec scanUntilSentinel lexBuffer state = // Return an endOfScan after consuming the input let a = int accept.[state] if a <> sentinel then @@ -251,14 +251,14 @@ namespace Internal.Utilities.Text.Lexing let inp = lexBuffer.Buffer.[lexBuffer.BufferScanPos] // Find the new state - let snew = lookupUnicodeCharacters (state,inp) + let snew = lookupUnicodeCharacters state inp if snew = sentinel then lexBuffer.EndOfScan() else lexBuffer.BufferScanLength <- lexBuffer.BufferScanLength + 1; - // printf "state %d --> %d on '%c' (%d)\n" s snew (char inp) inp; - scanUntilSentinel(lexBuffer,snew) + //printf "state %d --> %d on '%c' (%d)\n" s snew (char inp) inp; + scanUntilSentinel lexBuffer snew // Each row for the Unicode table has format // 128 entries for ASCII characters @@ -268,6 +268,6 @@ namespace Internal.Utilities.Text.Lexing member tables.Interpret(initialState,lexBuffer : LexBuffer) = startInterpret(lexBuffer) - scanUntilSentinel(lexBuffer, initialState) + scanUntilSentinel lexBuffer initialState static member Create(trans,accept) = new UnicodeTables(trans,accept) diff --git a/src/utils/prim-lexing.fsi b/src/utils/prim-lexing.fsi index 6898b3d9d1..97ef334b33 100755 --- a/src/utils/prim-lexing.fsi +++ b/src/utils/prim-lexing.fsi @@ -12,66 +12,67 @@ open Microsoft.FSharp.Control /// Position information stored for lexing tokens [] type internal Position = - /// The file index for the file associated with the input stream, use fileOfFileIndex in range.fs to decode + /// The file index for the file associated with the input stream, use fileOfFileIndex in range.fs to decode val FileIndex : int /// The line number in the input stream, assuming fresh positions have been updated /// for the new line by modifying the EndPos property of the LexBuffer. val Line : int /// The line number for the position in the input stream, assuming fresh positions have been updated - /// using for the new line + /// using for the new line. val OriginalLine : int - /// The character number in the input stream + /// The character number in the input stream. val AbsoluteOffset : int - /// Return absolute offset of the start of the line marked by the position + /// Return absolute offset of the start of the line marked by the position. val StartOfLineAbsoluteOffset : int - /// Return the column number marked by the position, i.e. the difference between the AbsoluteOffset and the StartOfLineAbsoluteOffset + /// Return the column number marked by the position, + /// i.e. the difference between the AbsoluteOffset and the StartOfLineAbsoluteOffset member Column : int - // Given a position just beyond the end of a line, return a position at the start of the next line + // Given a position just beyond the end of a line, return a position at the start of the next line. member NextLine : Position - /// Given a position at the start of a token of length n, return a position just beyond the end of the token + /// Given a position at the start of a token of length n, return a position just beyond the end of the token. member EndOfToken: n:int -> Position - /// Gives a position shifted by specified number of characters + /// Gives a position shifted by specified number of characters. member ShiftColumnBy: by:int -> Position - // Same line, column -1 + // Same line, column -1. member ColumnMinusOne : Position - /// Apply a #line directive + /// Apply a #line directive. member ApplyLineDirective : fileIdx:int * line:int -> Position - /// Get an arbitrary position, with the empty string as filename, and + /// Get an arbitrary position, with the empty string as filename. static member Empty : Position static member FirstLine : fileIdx:int -> Position [] -/// Input buffers consumed by lexers generated by fslex.exe +/// Input buffers consumed by lexers generated by fslex.exe. type internal LexBuffer<'Char> = - /// The start position for the lexeme + /// The start position for the lexeme. member StartPos: Position with get,set - /// The end position for the lexeme + /// The end position for the lexeme. member EndPos: Position with get,set - /// The matched string + /// The matched string. member Lexeme: 'Char [] - /// Fast helper to turn the matched characters into a string, avoiding an intermediate array + /// Fast helper to turn the matched characters into a string, avoiding an intermediate array. static member LexemeString : LexBuffer -> string - /// Dynamically typed, non-lexically scoped parameter table + /// Dynamically typed, non-lexically scoped parameter table. member BufferLocalStore : IDictionary - /// True if the refill of the buffer ever failed , or if explicitly set to true. + /// True if the refill of the buffer ever failed , or if explicitly set to True. member IsPastEndOfStream: bool with get,set - /// Create a lex buffer suitable for Unicode lexing that reads characters from the given array + /// Create a lex buffer suitable for Unicode lexing that reads characters from the given array. static member FromChars: char[] -> LexBuffer - /// Create a lex buffer that reads character or byte inputs by using the given function + /// Create a lex buffer that reads character or byte inputs by using the given function. static member FromFunction: ('Char[] * int * int -> int) -> LexBuffer<'Char> -/// The type of tables for an unicode lexer generated by fslex. +/// The type of tables for an unicode lexer generated by fslex.exe. [] type internal UnicodeTables = static member Create : uint16[][] * uint16[] -> UnicodeTables - /// Interpret tables for a unicode lexer generated by fslex. + /// Interpret tables for a unicode lexer generated by fslex.exe. member Interpret: initialState:int * LexBuffer -> int diff --git a/src/utils/prim-parsing.fs b/src/utils/prim-parsing.fs index 938e3a12f3..ba71bd5d93 100755 --- a/src/utils/prim-parsing.fs +++ b/src/utils/prim-parsing.fs @@ -62,8 +62,8 @@ type internal Tables<'tok> = stateToProdIdxsTableElements: uint16[]; stateToProdIdxsTableRowOffsets: uint16[]; productionToNonTerminalTable: uint16[]; - /// For fsyacc.exe, this entry is filled in by context from the generated parser file. If no 'parse_error' function - /// is defined by the user then ParseHelpers.parse_error is used by default (ParseHelpers is opened + /// For fsyacc.exe, this entry is filled in by context from the generated parser file. If no 'parse_error' function + /// is defined by the user then ParseHelpers.parse_error is used by default (ParseHelpers is opened /// at the top of the generated parser file) parseError: ParseErrorContext<'tok> -> unit; numTerminals: int; @@ -72,8 +72,8 @@ type internal Tables<'tok> = //------------------------------------------------------------------------- // An implementation of stacks. -// This type is in System.dll so for the moment we can't use it in FSharp.Core.dll -//type Stack<'a> = System.Collections.Generic.Stack<'a> +// This type is in System.dll so for the moment we can't use it in FSharp.Core.dll +// type Stack<'a> = System.Collections.Generic.Stack<'a> type Stack<'a>(n) = let mutable contents = Array.zeroCreate<'a>(n) @@ -150,7 +150,7 @@ module internal Implementation = // takes up around 10% of of parsing time // for parsing intensive samples such as the bootstrapped F# compiler. // - // Note: using a .NET Dictionary for this int -> int table looks like it could be sub-optimal. + // NOTE: using a .NET Dictionary for this int -> int table looks like it could be sub-optimal. // Some other better sparse lookup table may be better. assert (rowNumber < 0x10000) assert (keyToFind < 0x10000) @@ -288,7 +288,7 @@ module internal Implementation = #endif let nextState = actionValue action // The "error" non terminal needs position information, though it tends to be unreliable. - // Use the StartPos/EndPos from the lex buffer + // Use the StartPos/EndPos from the lex buffer. valueStack.Push(ValueInfo(box (), lexbuf.StartPos, lexbuf.EndPos)); stateStack.Push(nextState) else diff --git a/src/utils/prim-parsing.fsi b/src/utils/prim-parsing.fsi index 4898174184..36c32ff4e3 100755 --- a/src/utils/prim-parsing.fsi +++ b/src/utils/prim-parsing.fsi @@ -8,87 +8,88 @@ open System.Collections.Generic [] type internal IParseState = - /// Get the start and end position for the terminal or non-terminal at a given index matched by the production + /// Get the start and end position for the terminal or non-terminal at a given index matched by the production. member InputRange: index:int -> Position * Position - /// Get the end position for the terminal or non-terminal at a given index matched by the production + /// Get the end position for the terminal or non-terminal at a given index matched by the production. member InputEndPosition: int -> Position - /// Get the start position for the terminal or non-terminal at a given index matched by the production + /// Get the start position for the terminal or non-terminal at a given index matched by the production. member InputStartPosition: int -> Position - /// Get the start of the range of positions matched by the production + /// Get the start of the range of positions matched by the production. member ResultStartPosition: Position - /// Get the end of the range of positions matched by the production + /// Get the end of the range of positions matched by the production. member ResultEndPosition: Position - /// Get the full range of positions matched by the production + /// Get the full range of positions matched by the production. member ResultRange: Position * Position - /// Get the value produced by the terminal or non-terminal at the given position + /// Get the value produced by the terminal or non-terminal at the given position. member GetInput : int -> obj - /// Raise an error in this parse context + /// Raise an error in this parse context. member RaiseError<'b> : unit -> 'b - /// Return the LexBuffer for this parser instance + /// Return the LexBuffer for this parser instance. member LexBuffer : LexBuffer [] -/// The context provided when a parse error occurs +/// The context provided when a parse error occurs. type internal ParseErrorContext<'tok> = - /// The stack of state indexes active at the parse error + /// The stack of state indexes active at the parse error . member StateStack : int list - /// The state active at the parse error + /// The state active at the parse error. member ParseState : IParseState - /// The tokens that would cause a reduction at the parse error + /// The tokens that would cause a reduction at the parse error. member ReduceTokens: int list - /// The stack of productions that would be reduced at the parse error + /// The stack of productions that would be reduced at the parse error. member ReducibleProductions : int list list - /// The token that caused the parse error + /// The token that caused the parse error. member CurrentToken : 'tok option - /// The token that would cause a shift at the parse error + /// The token that would cause a shift at the parse error. member ShiftTokens : int list - /// The message associated with the parse error + /// The message associated with the parse error. member Message : string /// Tables generated by fsyacc -/// The type of the tables contained in a file produced by the fsyacc.exe parser generator. +/// The type of the tables contained in a file produced by the fsyacc.exe parser generator. type internal Tables<'tok> = - { /// The reduction table + { + /// The reduction table. reductions: (IParseState -> obj) array ; - /// The token number indicating the end of input + /// The token number indicating the end of input. endOfInputTag: int; - /// A function to compute the tag of a token + /// A function to compute the tag of a token. tagOfToken: 'tok -> int; - /// A function to compute the data carried by a token + /// A function to compute the data carried by a token. dataOfToken: 'tok -> obj; - /// The sparse action table elements + /// The sparse action table elements. actionTableElements: uint16[]; - /// The sparse action table row offsets + /// The sparse action table row offsets. actionTableRowOffsets: uint16[]; - /// The number of symbols for each reduction + /// The number of symbols for each reduction. reductionSymbolCounts: uint16[]; - /// The immediate action table + /// The immediate action table. immediateActions: uint16[]; - /// The sparse goto table + /// The sparse goto table. gotos: uint16[]; - /// The sparse goto table row offsets + /// The sparse goto table row offsets. sparseGotoTableRowOffsets: uint16[]; - /// The sparse table for the productions active for each state + /// The sparse table for the productions active for each state. stateToProdIdxsTableElements: uint16[]; - /// The sparse table offsets for the productions active for each state + /// The sparse table offsets for the productions active for each state. stateToProdIdxsTableRowOffsets: uint16[]; - /// This table is logically part of the Goto table + /// This table is logically part of the Goto table. productionToNonTerminalTable: uint16[]; - /// This function is used to hold the user specified "parse_error" or "parse_error_rich" functions + /// This function is used to hold the user specified "parse_error" or "parse_error_rich" functions. parseError: ParseErrorContext<'tok> -> unit; - /// The total number of terminals + /// The total number of terminals. numTerminals: int; - /// The tag of the error terminal + /// The tag of the error terminal. tagOfErrorTerminal: int } /// Interpret the parser table taking input from the given lexer, using the given lex buffer, and the given start state. /// Returns an object indicating the final synthesized value for the parse. member Interpret : lexer:(LexBuffer -> 'tok) * lexbuf:LexBuffer * startState:int -> obj -/// Indicates an accept action has occurred +/// Indicates an accept action has occurred. exception internal Accept of obj -/// Indicates a parse error has occurred and parse recovery is in progress +/// Indicates a parse error has occurred and parse recovery is in progress. exception internal RecoverableParseError #if DEBUG @@ -98,8 +99,8 @@ module internal Flags = /// Helpers used by generated parsers. module internal ParseHelpers = - /// The default implementation of the parse_error_rich function + /// The default implementation of the parse_error_rich function. val parse_error_rich: (ParseErrorContext<'tok> -> unit) option - /// The default implementation of the parse_error function + /// The default implementation of the parse_error function. val parse_error: string -> unit diff --git a/src/utils/reshapedmsbuild.fs b/src/utils/reshapedmsbuild.fs index 9fda2ca917..13fdd0366b 100644 --- a/src/utils/reshapedmsbuild.fs +++ b/src/utils/reshapedmsbuild.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Open Technologies, Inc. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. +// Copyright (c) Microsoft. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. namespace Microsoft.Build.Tasks namespace Microsoft.Build.Utilities @@ -117,9 +117,10 @@ module internal ToolLocationHelper = let visualStudioVersion110 = new Version(11, 0); let visualStudioVersion120 = new Version(12, 0); let visualStudioVersion140 = new Version(14, 0); + let visualStudioVersion150 = new Version(15, 0); // keep this up-to-date; always point to the latest visual studio version. - let visualStudioVersionLatest = visualStudioVersion140; + let visualStudioVersionLatest = visualStudioVersion150; let dotNetFrameworkRegistryPath = "SOFTWARE\\Microsoft\\.NETFramework"; let dotNetFrameworkSetupRegistryPath = "SOFTWARE\\Microsoft\\NET Framework Setup\\NDP"; @@ -735,6 +736,7 @@ module internal ToolLocationHelper = CreateDotNetFrameworkSpecForV4 dotNetFrameworkVersion45 visualStudioVersion110 // v4.5 CreateDotNetFrameworkSpecForV4 dotNetFrameworkVersion451 visualStudioVersion120 // v4.5.1 CreateDotNetFrameworkSpecForV4 dotNetFrameworkVersion46 visualStudioVersion140 // v4.6 + CreateDotNetFrameworkSpecForV4 dotNetFrameworkVersion46 visualStudioVersion150 // v4.6 |] array.ToDictionary(fun spec -> spec.Version) diff --git a/src/utils/reshapedreflection.fs b/src/utils/reshapedreflection.fs index 752e7b36ef..af1bfb3cf2 100644 --- a/src/utils/reshapedreflection.fs +++ b/src/utils/reshapedreflection.fs @@ -1,4 +1,4 @@ -// Copyright (c) Microsoft Open Technologies, Inc. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. +// Copyright (c) Microsoft. All Rights Reserved. Licensed under the Apache License, Version 2.0. See License.txt in the project root for license information. namespace Microsoft.FSharp.Core @@ -48,6 +48,7 @@ module internal ReflectionAdapters = let exit (_n:int) = failwith "System.Environment.Exit does not exist!" #endif +#if !FX_HAS_TYPECODE [] type TypeCode = | Int32 = 0 @@ -61,7 +62,8 @@ module internal ReflectionAdapters = | Single = 8 | Double = 9 | Decimal = 10 - | Other = 11 + | Object = 11 +#endif let isAcceptable bindingFlags isStatic isPublic = // 1. check if member kind (static\instance) was specified in flags @@ -232,6 +234,7 @@ module internal ReflectionAdapters = ) ) |> commit + static member GetTypeCode(ty : Type) = if typeof.Equals ty then TypeCode.Int32 elif typeof.Equals ty then TypeCode.Int64 @@ -244,7 +247,8 @@ module internal ReflectionAdapters = elif ty = typeof then TypeCode.Single elif ty = typeof then TypeCode.Double elif ty = typeof then TypeCode.Decimal - else TypeCode.Other + else TypeCode.Object + member this.Module = this.GetTypeInfo().Module diff --git a/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net45_with_resource_using_bootstrap/Sample_VS2012_FSharp_ConsoleApp_net45/Sample_VS2012_FSharp_ConsoleApp_net45.fsproj b/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net45_with_resource_using_bootstrap/Sample_VS2012_FSharp_ConsoleApp_net45/Sample_VS2012_FSharp_ConsoleApp_net45.fsproj index 2c8551baac..db388c633c 100644 --- a/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net45_with_resource_using_bootstrap/Sample_VS2012_FSharp_ConsoleApp_net45/Sample_VS2012_FSharp_ConsoleApp_net45.fsproj +++ b/tests/projects/Sample_VS2012_FSharp_ConsoleApp_net45_with_resource_using_bootstrap/Sample_VS2012_FSharp_ConsoleApp_net45/Sample_VS2012_FSharp_ConsoleApp_net45.fsproj @@ -13,8 +13,8 @@ Sample_VS2012_FSharp_ConsoleApp_net45 10.0.0 False - 4.3.0.0 - $(MSBuildProjectDirectory)\..\..\..\..\lib\bootstrap\4.0 + 4.4.0.0 + $(MSBuildProjectDirectory)\..\..\..\..\packages\FSharp.Compiler.Tools.4.0.0.1\tools True diff --git a/tests/service/EditorTests.fs b/tests/service/EditorTests.fs index 7064370cde..5cff7f7e64 100644 --- a/tests/service/EditorTests.fs +++ b/tests/service/EditorTests.fs @@ -650,14 +650,14 @@ let ``Test TPProject errors`` () = errorMessages |> shouldEqual [(15, 47, 15, 48, "Expected type argument or static argument"); (6, 8, 6, 32, "This provided method requires static parameters"); - (7, 39, 7, 42, "This expression was expected to have type string but here has type unit "); - (8, 40, 8, 43, "This expression was expected to have type string but here has type unit "); - (9, 40, 9, 49, "This expression was expected to have type string but here has type unit "); + (7, 39, 7, 42, "This expression was expected to have type 'string' but here has type 'unit' "); + (8, 40, 8, 43, "This expression was expected to have type 'string' but here has type 'unit' "); + (9, 40, 9, 49, "This expression was expected to have type 'string' but here has type 'unit' "); (11, 8, 11, 35, "The static parameter 'pattern1' of the provided type or method 'IsMatch' requires a value. Static parameters to type providers may be optionally specified using named arguments, e.g. 'IsMatch'."); (12, 8, 12, 41, "The static parameter 'pattern1' of the provided type or method 'IsMatch' requires a value. Static parameters to type providers may be optionally specified using named arguments, e.g. 'IsMatch'."); - (14, 46, 14, 50, "This expression was expected to have type string but here has type unit "); + (14, 46, 14, 50, "This expression was expected to have type 'string' but here has type 'unit' "); (15, 33, 15, 38, "No static parameter exists with name ''"); - (16, 40, 16, 50, "This expression was expected to have type string but here has type unit ")] + (16, 40, 16, 50, "This expression was expected to have type 'string' but here has type 'unit' ")] let internal extractToolTipText (FSharpToolTipText(els)) = [ for e in els do diff --git a/tests/service/FileSystemTests.fs b/tests/service/FileSystemTests.fs index 1e7758f7ce..cb8eabc5e9 100644 --- a/tests/service/FileSystemTests.fs +++ b/tests/service/FileSystemTests.fs @@ -93,8 +93,7 @@ let ``FileSystem compilation test``() = yield "--target:library"; for r in [ @"C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.0\mscorlib.dll"; @"C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.0\System.dll"; - @"C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.0\System.Core.dll"; - @"C:\Program Files (x86)\Reference Assemblies\Microsoft\FSharp\.NETFramework\v4.0\4.3.0.0\FSharp.Core.dll"] do + @"C:\Program Files (x86)\Reference Assemblies\Microsoft\Framework\.NETFramework\v4.0\System.Core.dll"] do yield "-r:" + r |] { ProjectFileName = @"c:\mycode\compilation.fsproj" // Make a name that is unique in this directory. @@ -113,4 +112,4 @@ let ``FileSystem compilation test``() = results.AssemblySignature.Entities.[0].MembersFunctionsAndValues.Count |> shouldEqual 1 results.AssemblySignature.Entities.[0].MembersFunctionsAndValues.[0].DisplayName |> shouldEqual "B" -#endif \ No newline at end of file +#endif