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}\nType 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}\nUppercase 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.exefsyacc.exefalse
@@ -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.dllTrueTrue
@@ -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
- // [