dotnet
/
fsharp
зеркало из https://github.com/dotnet/fsharp.git
1
0
Форкнуть 0
Код Задачи Пакеты Проекты Релизы Вики Активность

Merge branch 'main' into merges/release/dev17.3-to-main

This commit is contained in:
Kevin Ransom (msft) 2022-08-11 11:37:12 -07:00 коммит произвёл GitHub
Родитель d5218142e9 a3741b1de7
Коммит 1fb9c87c0a
Не найден ключ, соответствующий данной подписи
Идентификатор ключа GPG: 4AEE18F83AFDEB23
525 изменённых файлов: 26947 добавлений и 15757 удалений
Показать статистику Скачать Patch файл Скачать Diff файл Показать все файлы Свернуть все файлы

2
.config/dotnet-tools.json
Просмотреть файл

@ -3,7 +3,7 @@
"isRoot": true,
"tools": {
"fantomas": {
"version": "5.0.0-alpha-008",
"version": "5.0.0-beta-005",
"commands": [
"fantomas"
]

4
.devcontainer/Dockerfile
Просмотреть файл

@ -3,8 +3,8 @@
# Licensed under the MIT License. See https://go.microsoft.com/fwlink/?linkid=2090316 for license information.
#-------------------------------------------------------------------------------------------------------------
ARG VARIANT=6.0-focal
FROM mcr.microsoft.com/vscode/devcontainers/dotnet:0-${VARIANT}
ARG VARIANT=7.0-bullseye-slim
FROM mcr.microsoft.com/dotnet/sdk:${VARIANT}
# Avoid warnings by switching to noninteractive
ENV DEBIAN_FRONTEND=noninteractive

25
.devcontainer/devcontainer.json
Просмотреть файл

@ -1,12 +1,12 @@
// For format details, see https://aka.ms/vscode-remote/devcontainer.json or this file's README at:
{
"name": "F# (.NET 6)",
"name": "F# (.NET 7)",
"build": {
"dockerfile": "Dockerfile",
"args": {
// Update 'VARIANT' to pick a .NET Core version: 3.1, 5.0, 6.0
// Append -bullseye or -focal to pin to an OS version.
"VARIANT": "6.0-focal"
// Update 'VARIANT' to pick a .NET Core version: 3.1, 5.0, 6.0, 7.0
// Append -bullseye(-slim), -focal, or -jammy to pin to an OS version.
"VARIANT": "7.0-bullseye-slim"
}
},
"hostRequirements": {
@ -20,19 +20,16 @@
// Add the IDs of extensions you want installed when the container is created.
"extensions": [
"ms-vscode.test-adapter-converter",
"hbenl.vscode-test-explorer",
"formulahendry.dotnet-test-explorer",
"ms-dotnettools.csharp",
"Ionide.Ionide-fsharp",
"tintoy.msbuild-project-tools"
],
"onCreateCommand": [
"/bin/bash",
"-c",
"./build.sh",
"-c",
"Debug"
],
//"onCreateCommand": [ // It is a bit buggy in codespaces, so for now, need to run it manually.
// "/bin/bash",
// "-c",
// "./build.sh",
// "-c",
// "Debug"
//],
"waitFor": "onCreateCommand"
}

2
.gitignore поставляемый
Просмотреть файл

@ -123,3 +123,5 @@ nCrunchTemp_*
/test.fs
/test.fsx
tests/FSharp.Compiler.Service.Tests/FSharp.CompilerService.SurfaceArea.netstandard.actual

4
.vscode/launch.json поставляемый
Просмотреть файл

@ -23,7 +23,7 @@
"internalConsoleOptions": "neverOpen",
"suppressJITOptimizations": true,
"stopAtEntry": false,
"justMyCode": false,
"justMyCode": true,
"enableStepFiltering": true,
"symbolOptions": {
"searchMicrosoftSymbolServer": true,
@ -73,7 +73,7 @@
"enabled": true
}
},
"justMyCode": false,
"justMyCode": true,
"enableStepFiltering": false,
}
]

8
.vscode/settings.json поставляемый
Просмотреть файл

@ -16,7 +16,7 @@
"*.fs": "${capture}.fsi"
},
"FSharp.suggestGitignore": false,
"FSharp.enableMSBuildProjectGraph": false,
"FSharp.enableMSBuildProjectGraph": true,
"FSharp.workspacePath": "FSharp.Compiler.Service.sln",
"FSharp.workspaceModePeekDeepLevel": 1,
"FSharp.enableBackgroundServices": false,
@ -34,7 +34,7 @@
"csharp.suppressDotnetInstallWarning": true,
"csharp.suppressDotnetRestoreNotification": true,
"csharp.suppressHiddenDiagnostics": true,
"omnisharp.autoStart": false,
"omnisharp.autoStart": true,
"omnisharp.defaultLaunchSolution": "FSharp.Compiler.Service.sln",
"omnisharp.enableMsBuildLoadProjectsOnDemand": true,
"omnisharp.disableMSBuildDiagnosticWarning": true,
@ -45,10 +45,6 @@
"powershell.promptToUpdatePowerShell": false,
"powershell.integratedConsole.showOnStartup": false,
"powershell.startAutomatically": false,
"dotnet-test-explorer.testProjectPath": "tests/+(FSharp.Compiler.Service.Tests|FSharp.Compiler.UnitTests|FSharp.Core.UnitTests|FSharp.Build.UnitTests|FSharp.Compiler.ComponentTests)/*Tests.fsproj",
"dotnet-test-explorer.addProblems": true,
"dotnet-test-explorer.autoWatch": false,
"dotnet-test-explorer.treeMode": "merged",
"testExplorer.useNativeTesting": true,
"markdownlint.config": {
"MD028": false,

5
Directory.Build.props
Просмотреть файл

@ -3,4 +3,9 @@
<Import Project="FSharpBuild.Directory.Build.props" Condition = " '$(FSharpTestCompilerVersion)' == '' "/>
<Import Project="FSharpTests.Directory.Build.props" Condition = " '$(FSharpTestCompilerVersion)' != '' "/>
<ItemGroup>
<!-- If there is a README.md next to a project file, include it (for easier access in the IDE) -->
<None Include="README.md" Condition="Exists('README.md')" />
</ItemGroup>
</Project>

28
FSharp.Compiler.Service.sln
Просмотреть файл

@ -22,6 +22,19 @@ Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharp.Compiler.ComponentTe
{38A23D53-E2BF-4B76-907F-49F41D60C88E} = {38A23D53-E2BF-4B76-907F-49F41D60C88E}
EndProjectSection
EndProject
Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Benchmarks", "Benchmarks", "{AF321816-B4A0-41DD-9A1D-484E8A20C6F6}"
ProjectSection(SolutionItems) = preProject
tests\benchmarks\FCSBenchmarks\decentlySizedStandAloneFile.fs = tests\benchmarks\FCSBenchmarks\decentlySizedStandAloneFile.fs
tests\benchmarks\FCSBenchmarks\README.md = tests\benchmarks\FCSBenchmarks\README.md
tests\benchmarks\FCSBenchmarks\SmokeTestAllBenchmarks.ps1 = tests\benchmarks\FCSBenchmarks\SmokeTestAllBenchmarks.ps1
EndProjectSection
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "HistoricalBenchmark", "tests\benchmarks\FCSBenchmarks\BenchmarkComparison\HistoricalBenchmark.fsproj", "{35F5F1C5-AE4F-4B5A-8D94-1AF708724FD5}"
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Compiler.Benchmarks", "tests\benchmarks\FCSBenchmarks\CompilerServiceBenchmarks\FSharp.Compiler.Benchmarks.fsproj", "{C1950E28-1CB7-4DEC-BB3A-8A0443A17282}"
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "HistoricalBenchmark.Runner", "tests\benchmarks\FCSBenchmarks\BenchmarkComparison\HistoricalBenchmark.Runner\HistoricalBenchmark.Runner.fsproj", "{07CD957A-3C31-4F75-A735-16CE72E1BD71}"
EndProject
Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution Items", "{DD4D4A7E-D519-4409-89DA-16DCA3EF80AA}"
ProjectSection(SolutionItems) = preProject
src\Compiler\FSComp.txt = src\Compiler\FSComp.txt
@ -61,6 +74,18 @@ Global
{2A182B7D-EDA3-4BF2-84B8-C7553BB7A5A7}.Debug|Any CPU.Build.0 = Debug|Any CPU
{2A182B7D-EDA3-4BF2-84B8-C7553BB7A5A7}.Release|Any CPU.ActiveCfg = Release|Any CPU
{2A182B7D-EDA3-4BF2-84B8-C7553BB7A5A7}.Release|Any CPU.Build.0 = Release|Any CPU
{35F5F1C5-AE4F-4B5A-8D94-1AF708724FD5}.Debug|Any CPU.ActiveCfg = Release|Any CPU
{35F5F1C5-AE4F-4B5A-8D94-1AF708724FD5}.Debug|Any CPU.Build.0 = Release|Any CPU
{35F5F1C5-AE4F-4B5A-8D94-1AF708724FD5}.Release|Any CPU.ActiveCfg = Release|Any CPU
{35F5F1C5-AE4F-4B5A-8D94-1AF708724FD5}.Release|Any CPU.Build.0 = Release|Any CPU
{C1950E28-1CB7-4DEC-BB3A-8A0443A17282}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{C1950E28-1CB7-4DEC-BB3A-8A0443A17282}.Debug|Any CPU.Build.0 = Debug|Any CPU
{C1950E28-1CB7-4DEC-BB3A-8A0443A17282}.Release|Any CPU.ActiveCfg = Release|Any CPU
{C1950E28-1CB7-4DEC-BB3A-8A0443A17282}.Release|Any CPU.Build.0 = Release|Any CPU
{07CD957A-3C31-4F75-A735-16CE72E1BD71}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{07CD957A-3C31-4F75-A735-16CE72E1BD71}.Debug|Any CPU.Build.0 = Debug|Any CPU
{07CD957A-3C31-4F75-A735-16CE72E1BD71}.Release|Any CPU.ActiveCfg = Release|Any CPU
{07CD957A-3C31-4F75-A735-16CE72E1BD71}.Release|Any CPU.Build.0 = Release|Any CPU
EndGlobalSection
GlobalSection(SolutionProperties) = preSolution
HideSolutionNode = FALSE
@ -69,6 +94,9 @@ Global
{BFE6E6F1-1B73-404F-A3A5-30B57E5E0731} = {875D91AC-BA4C-4191-AB11-AE461DB9B8DB}
{2EF674B9-8B56-4796-9933-42B2629E52C3} = {875D91AC-BA4C-4191-AB11-AE461DB9B8DB}
{38A23D53-E2BF-4B76-907F-49F41D60C88E} = {875D91AC-BA4C-4191-AB11-AE461DB9B8DB}
{35F5F1C5-AE4F-4B5A-8D94-1AF708724FD5} = {AF321816-B4A0-41DD-9A1D-484E8A20C6F6}
{C1950E28-1CB7-4DEC-BB3A-8A0443A17282} = {AF321816-B4A0-41DD-9A1D-484E8A20C6F6}
{07CD957A-3C31-4F75-A735-16CE72E1BD71} = {AF321816-B4A0-41DD-9A1D-484E8A20C6F6}
EndGlobalSection
GlobalSection(ExtensibilityGlobals) = postSolution
SolutionGuid = {F9A60F3B-D894-4C8E-BA0F-C51115B25A5A}

12
FSharp.Profiles.props
Просмотреть файл

@ -4,23 +4,11 @@
<Choose>
<When Condition=" '$(TargetFrameworkIdentifier)' == '.NETFramework' ">
<PropertyGroup>
<DefineConstants Condition="'$(MonoPackaging)' == 'true'">$(DefineConstants);CROSS_PLATFORM_COMPILER</DefineConstants>
<DefineConstants>$(DefineConstants);ENABLE_MONO_SUPPORT</DefineConstants>
</PropertyGroup>
</When>
<Otherwise>
<PropertyGroup>
<DefineConstants>$(DefineConstants);NETSTANDARD</DefineConstants>
<DefineConstants>$(DefineConstants);FX_NO_APP_DOMAINS</DefineConstants>
<DefineConstants>$(DefineConstants);FX_NO_CORHOST_SIGNER</DefineConstants>
<DefineConstants>$(DefineConstants);FX_NO_PDB_READER</DefineConstants>
<DefineConstants>$(DefineConstants);FX_NO_PDB_WRITER</DefineConstants>
<DefineConstants>$(DefineConstants);FX_NO_SYMBOLSTORE</DefineConstants>
<DefineConstants>$(DefineConstants);FX_NO_SYSTEM_CONFIGURATION</DefineConstants>
<DefineConstants>$(DefineConstants);FX_NO_WIN_REGISTRY</DefineConstants>
<DefineConstants>$(DefineConstants);FX_NO_WINFORMS</DefineConstants>
<DefineConstants>$(DefineConstants);FX_RESHAPED_REFEMIT</DefineConstants>
<OtherFlags>$(OtherFlags) --simpleresolution</OtherFlags>
</PropertyGroup>
</Otherwise>

32
FSharp.sln
Просмотреть файл

@ -40,6 +40,9 @@ EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharp.Compiler.Service", "src\Compiler\FSharp.Compiler.Service.fsproj", "{9B4CF83C-C215-4EA0-9F8B-B5A77090F634}"
EndProject
Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Benchmarks", "Benchmarks", "{CE70D631-C5DC-417E-9CDA-B16097BEF1AC}"
ProjectSection(SolutionItems) = preProject
tests\benchmarks\README.md = tests\benchmarks\README.md
EndProjectSection
EndProject
Project("{9A19103F-16F7-4668-BE54-9A1E7A4F7556}") = "MicroPerfCSharp", "tests\benchmarks\CompiledCodeBenchmarks\MicroPerf\CS\MicroPerfCSharp.csproj", "{348DCC13-DD3E-4214-B040-5A74E8C6B782}"
EndProject
@ -101,6 +104,9 @@ Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "fsiAnyCpu", "src\fsi\fsiAny
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "fsiArm64", "src\fsi\fsiArm64Project\fsiArm64.fsproj", "{209C7D37-8C01-413C-8698-EC25F4C86976}"
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "HistoricalBenchmark", "tests\benchmarks\FCSBenchmarks\BenchmarkComparison\HistoricalBenchmark.fsproj", "{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}"
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FSharp.Compiler.Benchmarks", "tests\benchmarks\FCSBenchmarks\CompilerServiceBenchmarks\FSharp.Compiler.Benchmarks.fsproj", "{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}"
Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution Items", "Solution Items", "{D58BFE8B-7C85-4D3B-B5F3-9A7BB90FF1EE}"
ProjectSection(SolutionItems) = preProject
src\Compiler\FSComp.txt = src\Compiler\FSComp.txt
@ -440,6 +446,30 @@ Global
{209C7D37-8C01-413C-8698-EC25F4C86976}.Release|Any CPU.Build.0 = Release|Any CPU
{209C7D37-8C01-413C-8698-EC25F4C86976}.Release|x86.ActiveCfg = Release|Any CPU
{209C7D37-8C01-413C-8698-EC25F4C86976}.Release|x86.Build.0 = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Debug|Any CPU.ActiveCfg = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Debug|Any CPU.Build.0 = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Debug|x86.ActiveCfg = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Debug|x86.Build.0 = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Proto|Any CPU.ActiveCfg = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Proto|Any CPU.Build.0 = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Proto|x86.ActiveCfg = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Proto|x86.Build.0 = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Release|Any CPU.ActiveCfg = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Release|Any CPU.Build.0 = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Release|x86.ActiveCfg = Release|Any CPU
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF}.Release|x86.Build.0 = Release|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Debug|Any CPU.ActiveCfg = Debug|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Debug|Any CPU.Build.0 = Debug|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Debug|x86.ActiveCfg = Debug|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Debug|x86.Build.0 = Debug|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Proto|Any CPU.ActiveCfg = Debug|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Proto|Any CPU.Build.0 = Debug|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Proto|x86.ActiveCfg = Debug|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Proto|x86.Build.0 = Debug|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Release|Any CPU.ActiveCfg = Release|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Release|Any CPU.Build.0 = Release|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Release|x86.ActiveCfg = Release|Any CPU
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1}.Release|x86.Build.0 = Release|Any CPU
EndGlobalSection
GlobalSection(SolutionProperties) = preSolution
HideSolutionNode = FALSE
@ -472,6 +502,8 @@ Global
{68EEAB5F-8AED-42A2-BFEC-343D0AD5CB52} = {B8DDA694-7939-42E3-95E5-265C2217C142}
{B6271954-3BCD-418A-BD24-56FEB923F3D3} = {B8DDA694-7939-42E3-95E5-265C2217C142}
{209C7D37-8C01-413C-8698-EC25F4C86976} = {B8DDA694-7939-42E3-95E5-265C2217C142}
{BEC6E796-7E53-4888-AAFC-B8FD55C425DF} = {CE70D631-C5DC-417E-9CDA-B16097BEF1AC}
{9C7523BA-7AB2-4604-A5FD-653E82C2BAD1} = {CE70D631-C5DC-417E-9CDA-B16097BEF1AC}
EndGlobalSection
GlobalSection(ExtensibilityGlobals) = postSolution
SolutionGuid = {BD5177C7-1380-40E7-94D2-7768E1A8B1B8}

20
INTERNAL.md
Просмотреть файл

@ -57,6 +57,26 @@ Note that insertions for other teams will also be listed.
Insertions to any other VS branch (e.g., `main`) will have the auto-merge flag set and should handle themselves, but
it's a good idea to check the previous link for any old or stalled insertions into VS `main`.
## Preparing for a new VS release branch
### When a VS branch snaps from `main` to `rel/d*` and switches to ask mode:
Update the `insertTargetBranch` value at the bottom of `azure-pipelines.yml` in the appropriate release branch. E.g., when VS 17.3 snapped and switched to ask mode, [this PR](https://github.com/dotnet/fsharp/pull/13456/files) correctly updates the insertion target so that future builds from that F# branch will get auto-inserted to VS.
### When VS `main` is open for insertions for preview releases of VS:
1. Create a new `release/dev*` branch (e.g., `release/dev17.4`) and initially set its HEAD commit to that of the previous release (e.g., `release/dev17.3` in this case).
2. Set the new branch to receive auto-merges from `main`, and also set the old release branch to flow into the new one. [This PR](https://github.com/dotnet/roslyn-tools/pull/1245/files) is a good example of what to do when a new `release/dev17.4` branch is created that should receive merges from both `main` and the previous release branch, `release/dev17.3`.
3. Set the packages from the new branch to flow into the correct package feeds via the `darc` tool. To do this:
1. Ensure the latest `darc` tool is installed by running `eng/common/darc-init.ps1`.
2. (only needed once) Run the command `darc authenticate`. A text file will be opened with instructions on how to populate access tokens.
3. Check the current package/channel subscriptions by running `darc get-default-channels --source-repo fsharp`. For this example, notice that the latest subscription shows the F# branch `release/dev17.3` is getting added to the `VS 17.3` channel.
4. Get the list of `darc` channels and determine the appropriate one to use for the new branch via the command `darc get-channels`. For this example, notice that a channel named `VS 17.4` is listed.
5. Add the new F# branch to the appropriate `darc` channel. In this example, run `darc add-default-channel --channel "VS 17.4" --branch release/dev17.4 --repo https://github.com/dotnet/fsharp`
6. Ensure the subscription was added by repeating step 3 above.
7. Note, the help in the `darc` tool is really good. E.g., you can simply run `darc` to see a list of all commands available, and if you run `darc <some-command>` with no arguments, you'll be given a list of arguments you can use.
8. Ensure that version numbers are bumped for a new branch.
## Less interesting links
[FSharp.Core (Official NuGet Release)](https://dev.azure.com/dnceng/internal/_release?_a=releases&definitionId=72).

34
Proto.sln Normal file
Просмотреть файл

@ -0,0 +1,34 @@

Microsoft Visual Studio Solution File, Format Version 12.00
# Visual Studio Version 17
VisualStudioVersion = 17.2.32630.192
MinimumVisualStudioVersion = 10.0.40219.1
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharp.Build", "src\FSharp.Build\FSharp.Build.fsproj", "{C02D44B2-BB67-4A17-9678-9D21D93B3930}"
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "fsc", "src\fsc\fscProject\fsc.fsproj", "{5BEC9F77-5AE6-4EC3-BDE9-63CF8E1D0086}"
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "fsi", "src\fsi\fsiProject\fsi.fsproj", "{07CB51BF-8E98-4CFF-A7BA-99C4A0BC6037}"
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharp.Core", "src\FSharp.Core\FSharp.Core.fsproj", "{8A772476-D857-4810-9A9C-E67AC61497AB}"
EndProject
Global
GlobalSection(SolutionConfigurationPlatforms) = preSolution
Proto|Any CPU = Proto|Any CPU
EndGlobalSection
GlobalSection(ProjectConfigurationPlatforms) = postSolution
{C02D44B2-BB67-4A17-9678-9D21D93B3930}.Proto|Any CPU.ActiveCfg = Proto|Any CPU
{C02D44B2-BB67-4A17-9678-9D21D93B3930}.Proto|Any CPU.Build.0 = Proto|Any CPU
{5BEC9F77-5AE6-4EC3-BDE9-63CF8E1D0086}.Proto|Any CPU.ActiveCfg = Proto|Any CPU
{5BEC9F77-5AE6-4EC3-BDE9-63CF8E1D0086}.Proto|Any CPU.Build.0 = Proto|Any CPU
{07CB51BF-8E98-4CFF-A7BA-99C4A0BC6037}.Proto|Any CPU.ActiveCfg = Proto|Any CPU
{07CB51BF-8E98-4CFF-A7BA-99C4A0BC6037}.Proto|Any CPU.Build.0 = Proto|Any CPU
{8A772476-D857-4810-9A9C-E67AC61497AB}.Proto|Any CPU.ActiveCfg = Proto|Any CPU
{8A772476-D857-4810-9A9C-E67AC61497AB}.Proto|Any CPU.Build.0 = Proto|Any CPU
EndGlobalSection
GlobalSection(SolutionProperties) = preSolution
HideSolutionNode = FALSE
EndGlobalSection
GlobalSection(ExtensibilityGlobals) = postSolution
SolutionGuid = {53F11F0A-D5FC-4410-B875-DC432F12B5AF}
EndGlobalSection
EndGlobal

38
VisualFSharp.sln
Просмотреть файл

@ -84,6 +84,14 @@ EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharp.Test.Utilities", "tests\FSharp.Test.Utilities\FSharp.Test.Utilities.fsproj", "{60D275B0-B14A-41CB-A1B2-E815A7448FCB}"
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharpSuite.Tests", "tests\fsharp\FSharpSuite.Tests.fsproj", "{C163E892-5BF7-4B59-AA99-B0E8079C67C4}"
ProjectSection(ProjectDependencies) = postProject
{0973C362-585C-4838-9459-D7E45C6B784B} = {0973C362-585C-4838-9459-D7E45C6B784B}
{37EB3E54-ABC6-4CF5-8273-7CE4B61A42C1} = {37EB3E54-ABC6-4CF5-8273-7CE4B61A42C1}
{511C95D9-3BA6-451F-B6F8-F033F40878A5} = {511C95D9-3BA6-451F-B6F8-F033F40878A5}
{597D9896-4B90-4E9E-9C99-445C2CB9FF60} = {597D9896-4B90-4E9E-9C99-445C2CB9FF60}
{E54456F4-D51A-4334-B225-92EBBED92B40} = {E54456F4-D51A-4334-B225-92EBBED92B40}
{EB015235-1E07-4CDA-9CC6-3FBCC27910D1} = {EB015235-1E07-4CDA-9CC6-3FBCC27910D1}
EndProjectSection
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharp.Compiler.UnitTests", "tests\FSharp.Compiler.UnitTests\FSharp.Compiler.UnitTests.fsproj", "{A8D9641A-9170-4CF4-8FE0-6DB8C134E1B5}"
EndProject
@ -149,13 +157,16 @@ Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharp.Compiler.Service", "
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharp.Compiler.Service.Tests", "tests\FSharp.Compiler.Service.Tests\FSharp.Compiler.Service.Tests.fsproj", "{14F3D3D6-5C8E-43C2-98A2-17EA704D4DEA}"
ProjectSection(ProjectDependencies) = postProject
{FF76BD3C-5E0A-4752-B6C3-044F6E15719B} = {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}
{887630A3-4B1D-40EA-B8B3-2D842E9C40DB} = {887630A3-4B1D-40EA-B8B3-2D842E9C40DB}
{FF76BD3C-5E0A-4752-B6C3-044F6E15719B} = {FF76BD3C-5E0A-4752-B6C3-044F6E15719B}
EndProjectSection
EndProject
Project("{9A19103F-16F7-4668-BE54-9A1E7A4F7556}") = "VisualFSharpDebug", "vsintegration\Vsix\VisualFSharpFull\VisualFSharpDebug.csproj", "{A422D673-8E3B-4924-821B-DD3174173426}"
EndProject
Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Benchmarks", "Benchmarks", "{DFB6ADD7-3149-43D9-AFA0-FC4A818B472B}"
ProjectSection(SolutionItems) = preProject
tests\benchmarks\README.md = tests\benchmarks\README.md
EndProjectSection
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "FSharp.Compiler.Benchmarks", "tests\benchmarks\FCSBenchmarks\CompilerServiceBenchmarks\FSharp.Compiler.Benchmarks.fsproj", "{564E7DC5-11CB-4FCF-ABDD-23AD93AF3A61}"
EndProject
@ -181,6 +192,15 @@ Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "fsiAnyCpu", "src\fsi\fsiAny
EndProject
Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "fsiArm64", "src\fsi\fsiArm64Project\fsiArm64.fsproj", "{EB015235-1E07-4CDA-9CC6-3FBCC27910D1}"
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "HistoricalBenchmark", "tests\benchmarks\FCSBenchmarks\BenchmarkComparison\HistoricalBenchmark.fsproj", "{583182E1-3484-4A8F-AC06-7C0D232C0CA4}"
EndProject
Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "FCSBenchmarks", "FCSBenchmarks", "{39CDF34B-FB23-49AE-AB27-0975DA379BB5}"
ProjectSection(SolutionItems) = preProject
tests\benchmarks\FCSBenchmarks\decentlySizedStandAloneFile.fs = tests\benchmarks\FCSBenchmarks\decentlySizedStandAloneFile.fs
tests\benchmarks\FCSBenchmarks\README.md = tests\benchmarks\FCSBenchmarks\README.md
tests\benchmarks\FCSBenchmarks\SmokeTestAllBenchmarks.ps1 = tests\benchmarks\FCSBenchmarks\SmokeTestAllBenchmarks.ps1
EndProjectSection
EndProject
Global
GlobalSection(SolutionConfigurationPlatforms) = preSolution
Debug|Any CPU = Debug|Any CPU
@ -1031,6 +1051,18 @@ Global
{EB015235-1E07-4CDA-9CC6-3FBCC27910D1}.Release|Any CPU.Build.0 = Release|Any CPU
{EB015235-1E07-4CDA-9CC6-3FBCC27910D1}.Release|x86.ActiveCfg = Release|Any CPU
{EB015235-1E07-4CDA-9CC6-3FBCC27910D1}.Release|x86.Build.0 = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Debug|Any CPU.ActiveCfg = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Debug|Any CPU.Build.0 = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Debug|x86.ActiveCfg = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Debug|x86.Build.0 = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Proto|Any CPU.ActiveCfg = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Proto|Any CPU.Build.0 = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Proto|x86.ActiveCfg = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Proto|x86.Build.0 = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Release|Any CPU.ActiveCfg = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Release|Any CPU.Build.0 = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Release|x86.ActiveCfg = Release|Any CPU
{583182E1-3484-4A8F-AC06-7C0D232C0CA4}.Release|x86.Build.0 = Release|Any CPU
EndGlobalSection
GlobalSection(SolutionProperties) = preSolution
HideSolutionNode = FALSE
@ -1101,7 +1133,6 @@ Global
{B5A9BBD9-2F45-4722-A6CA-BAE3C64CD4E2} = {3881429D-A97A-49EB-B7AE-A82BA5FE9C77}
{14F3D3D6-5C8E-43C2-98A2-17EA704D4DEA} = {CFE3259A-2D30-4EB0-80D5-E8B5F3D01449}
{A422D673-8E3B-4924-821B-DD3174173426} = {4C7B48D7-19AF-4AE7-9D1D-3BB289D5480D}
{564E7DC5-11CB-4FCF-ABDD-23AD93AF3A61} = {DFB6ADD7-3149-43D9-AFA0-FC4A818B472B}
{208E36EE-665C-42D2-B767-C6DB03C4FEB2} = {47112E07-9FF1-43E7-8021-F2A21D6A19A0}
{EE08E954-AE91-4EFA-8595-10931D29E628} = {47112E07-9FF1-43E7-8021-F2A21D6A19A0}
{47112E07-9FF1-43E7-8021-F2A21D6A19A0} = {DFB6ADD7-3149-43D9-AFA0-FC4A818B472B}
@ -1113,6 +1144,9 @@ Global
{511C95D9-3BA6-451F-B6F8-F033F40878A5} = {B8DDA694-7939-42E3-95E5-265C2217C142}
{37EB3E54-ABC6-4CF5-8273-7CE4B61A42C1} = {B8DDA694-7939-42E3-95E5-265C2217C142}
{EB015235-1E07-4CDA-9CC6-3FBCC27910D1} = {B8DDA694-7939-42E3-95E5-265C2217C142}
{39CDF34B-FB23-49AE-AB27-0975DA379BB5} = {DFB6ADD7-3149-43D9-AFA0-FC4A818B472B}
{564E7DC5-11CB-4FCF-ABDD-23AD93AF3A61} = {39CDF34B-FB23-49AE-AB27-0975DA379BB5}
{583182E1-3484-4A8F-AC06-7C0D232C0CA4} = {39CDF34B-FB23-49AE-AB27-0975DA379BB5}
EndGlobalSection
GlobalSection(ExtensibilityGlobals) = postSolution
SolutionGuid = {48EDBBBE-C8EE-4E3C-8B19-97184A487B37}

4
azure-pipelines.yml
Просмотреть файл

@ -12,6 +12,9 @@ trigger:
exclude:
- .github/*
- docs/
- .vscode/*
- .devcontainer/*
- tests/scripts/
- attributions.md
- CODE_OF_CONDUCT.md
- DEVGUIDE.md
@ -584,6 +587,7 @@ stages:
-TsaRepositoryName "FSharp"
-TsaCodebaseName "FSharp-GitHub"
-TsaPublish $True
-PoliCheckAdditionalRunConfigParams @("UserExclusionPath < $(Build.SourcesDirectory)/eng/policheck_exclusions.xml")
#---------------------------------------------------------------------------------------------------------------------#
# VS Insertion #

2
docs/fcs/index.md
Просмотреть файл

@ -93,7 +93,7 @@ Some of the projects using the F# Compiler Services are:
* [**F# in Visual Studio**](https://github.com/dotnet/fsharp/)
* [**F# in Visual Studio for Mac**](https://github.com/mono/monodevelop/tree/master/main/external/fsharpbinding)
* [**FsAutoComplete**](https://github.com/fsharp/FsAutoComplete)
* [**F# in JetBrains Rider**](https://www.jetbrains.com/help/rider/F_Sharp.html)
* [**F# in JetBrains Rider**](https://github.com/JetBrains/resharper-fsharp)
* [**F# in .NET Interactive Notebooks**](https://github.com/dotnet/interactive)
* [**Fantomas**](https://github.com/fsprojects/fantomas/) - Source code formatting for F#
* [**FSharpLint**](https://fsprojects.github.io/FSharpLint/) - Lint tool for F#

206
docs/names.md Normal file
Просмотреть файл

@ -0,0 +1,206 @@
---
title: Display names, logical names and compiled names
category: Compiler Internals
categoryindex: 200
index: 350
---
# Names of entities and values in the F# Compiler
The F# tooling distinguishes between the following concepts of "name" for values, union cases, class/record fields and entities:
* Display names as they appear in code
Characteristics:
- For most identifiers, have double backticks, e.g. ` ``Module name with spaces`` `
- For operator names, are short and parenthesized, e.g. `(+)` for the logical name `op_Addition`
- For active patterns, are parenthesized, e.g. `(|A|_|)`
- etc., see exact specification below
Used in:
- Code outputs, e.g. signature files
- Diagnostics (BUG: not consistently the case today)
Current aliases in code:
- `vref.DisplayName`
- `entity.DisplayName`
- `entity.DisplayNameWithStaticParameters`
- `entity.DisplayNameWithStaticParametersAndUnderscoreTypars`
- `minfo.DisplayName`
- `pinfo.DisplayName`
- `einfo.DisplayName`
- etc.
* Display names as they appear in declaration lists, navigation etc.
Characteristics:
- Same as above without the double backticks or parentheses
Current aliases in code:
- `vref.DisplayNameCore`
- `entity.DisplayNameCore`
- `minfo.DisplayNameCore`
- `pinfo.DisplayNameCore`
- `einfo.DisplayNameCore`
- etc.
* Logical names
Characteristics:
- Are used in `TypedTree`, often "canonical"
- Sometimes require extra flags to qualify the meaning of the name
Current aliases in code:
- `vref.LogicalName`
- `entity.LogicalName`
- `minfo.LogicalName`
- `pinfo.PropertyName`
- `einfo.EventName`
- etc.
* Compiled names
Characterists:
- Mark the names that appear in the .NET IL
Current aliases in code:
- `vref.CompiledName`
- `entity.CompiledName`
- etc.
## Specification of all logical names
The following tables loosely characterise the variations in logical names, how
they correspond to F# source constructs and the `SyntaxTree`/`TypedTree` metadata for these.
Entities:
Display name in code | Logical name | Notes
----------------------------|----------------|-------
C | C | type definition
C | C`1 | e.g. generic type, see notes below for variations of display names
M | M | module definition
M | MModule | "ModuleSuffix" attribute for F# modules, now somewhat legacy, rarely used, but still allowed; also where "ModuleSuffix" is implied because type and module have the same name
JsonProvider<"foo.json"> | JsonProvider,Schema=\"xyz\" | static parameters, see notes below for variations of display names
Values:
Display name in code | Relation | Logical name | Notes
---------------------|----------|----------------------|------
(+) | <--> | op_Addition |
(+ ) | --> | op_Addition | not reversed
op_Addition | --> | op_Addition | not reversed
(*) | <--> | op_Multiply |
( * ) | --> | op_Multiply | not reversed
op_Multiply | --> | op_Multiply | not reversed
( *+ ) | <--> | op_MultiplyPlus |
( *+ ) | --> | op_MultiplyPlus | not reversed
op_MultiplyPlus | --> | op_MultiplyPlus | not reversed
(+++) | <--> | op_PlusPlusPlus |
op_PlusPlusPlus | --> | op_PlusPlusPlus | not reversed
(%) | <--> | op_Modulus |
op_Modulus | --> | op_Modulus |
(?) | <--> | op_Dynamic | not defined by default, for x?SomeThing
(?<-) | <--> | op_DynamicAssignment | not defined by default, for x?SomeThing <- "a"
(..) | <--> | op_Range | for "3 .. 5"
(.. ..) | <--> | op_RangeStep | for "5 .. -1 .. 3"
or | <--> | or |
mod | <--> | mod |
``let`` | <--> | let | this is a keyword, in code it appears as ``let``
``type`` | <--> | type | this is a keyword, in code it appears as ``type``
base | <--> | base | for IsBaseVal=true only. Base is a keyword, this is a special base val
``base`` | <--> | base | for IsBaseVal=false only. Base is a keyword, this is not a special base val
SomeClass | <--> | .ctor | IsConstructor=true
``.ctor`` | <--> | .ctor | IsConstructor=false, this is only allowed for let-definitions, e.g. let ``.ctor`` x = 1
<not-shown> | <--> | .cctor | IsClassConstructor=true, should never really appear in diagnostics or user-facing output
``.cctor`` | <--> | .cctor | IsClassConstructor=false, this is only allowed for let-definitions, e.g. let ``.cctor`` x = 1
(\|A\|_\|) | <--> | \|A\|_\| |
(\|A \|_ \|) | --> | \|A\|_\| | not reversed
P | <--> | get_P | IsPropertyGetterMethod = true
P | <--> | set_P | IsPropertySetterMethod = true
Other Val constructs less problematic for naming are:
Display name in code | Relation | Logical name | Notes
---------------------|----------|----------------------|------
this | <--> | this | IsCtorThisVal = true; From `type C() as this`; Can have any name, not particularly special with regard to names; This has a 'ref' type for initialization checks
this | <--> | this | IsMemberThisVal = true; From `member this.M() = ...`; This can have a 'ref' type for initialization checks; Can have any name, not particularly special with regard to names
\<not-shown\> | <--> | System.IDisposable.Dispose | ImplementedSlotSigs is non-empty, i.e. length 1, should never really appear in diagnostics or user-facing output
Union cases:
Display name in code | Relation | Logical name | Notes
---------------------|----------|----------------------|------
SomeCase | <--> | SomeCase
` ``Case with space`` ` | <--> | Case with space
` ``type`` ` | <--> | type | This is a keyword
(::) | <--> | op_ColonColon | This is the logical name for the cons union case on `FSharpList` only
[] | <--> | op_Nil | This is the logical name for the nil case on `FSharpList` only
Class and record fields, enum cases, active pattern cases, anonymous record fields:
Display name in code | Relation | Logical name | Notes
---------------------|----------|----------------------|------
SomeField | <--> | SomeField
` ``Field with space`` `| <--> | Field with space
` ``type`` ` | <--> | type | This is a keyword
Generic parameters:
Display name in code | Relation | Logical name | Notes
---------------------|----------|----------------------|------
'T | <--> | T
'` ``T T T`` ` | <--> | T T T | BUG: the backticks are not currently added
'` ``type`` ` | <--> | type | This is a keyword, BUG: the backticks are not currently added
## Variations on display names
In different display settings, Entities/Types/Modules can have some variations on display names. For example, when showing some kinds of output we may set `shortTypeNames=true` which will never show full names.
* `SomeTypeProvider`
- Used for omitting static parameters
- Alias in code: `entity.CompiledName`
* `SomeTypeProvider<...>`
- Used for eliding static parameters
* `SomeTypeProvider<"foo.json">`
- Used for showing static parameters. These can be very large, e.g. entire connection strings, so better to elide or omit.
- Alias in code: `entity.DisplayNameWithStaticParameters`
* `List<_>`
- Used with underscore typars
- Alias in code: `entity.DisplayNameWithStaticParametersAndUnderscoreTypars`
* `Dictionary<'TKey,'TResult>`
- Used with general typars
* Full name
Examples:
- `SomeNamespace.OtherNamespace.SomeType`
- ``` ``Some Namespace With Spaces``.SomeType``` <-- BUG: not double-ticks today
- `SomeEnclosingType<_>.SomeStaticMethod` <-- BUG: the mangled generic type counts are shown today
## Compiled names
The name that appears in the .NET IL.
Affected by:
- `CompiledName` attribute
- some heuristics for generic type parameters
Also the name from signature is generally preferred; if there is any difference, a warning is emitted.
Example of how signature affects compiled names
```fsharp
Foo.fsi
val SomeFunction: x: int -> y: int -> int
Foo.fs
let SomeFunction a b = a + b // compiled name of parameters is x, y - warning emitted
```

4
docs/overview.md
Просмотреть файл

@ -129,11 +129,11 @@ stateDiagram-v2
The following are the key phases and high-level logical operations of the F# compiler code in its various configurations:
* _Basic lexing_. Produces a token stream from input source file text.
* _Basic lexing_. Produces a token stream from input source file text. F# uses the [FsLex](http://fsprojects.github.io/FsLexYacc/) tool to process a declarative specification of the tokenizer in [lex.fsl](https://github.com/dotnet/fsharp/blob/main/src/Compiler/lex.fsl). This compiles the tokenizer specification to a number of tables which are then interpreted by the code in [prim-lexing.fs](https://github.com/dotnet/fsharp/blob/main/src/Compiler/Facilities/prim-lexing.fs) (see also [prim-lexing.fsi](https://github.com/dotnet/fsharp/blob/main/src/Compiler/Facilities/prim-lexing.fsi).
* _White-space sensitive lexing_. Accepts and produces a token stream, augmenting per the [F# Language Specification](https://fsharp.org/specs/language-spec/).
* _Parsing_. Accepts a token stream and produces an AST per the grammar in the [F# Language Specification](https://fsharp.org/specs/language-spec/).
* _Parsing_. Accepts a token stream and produces an AST per the grammar in the [F# Language Specification](https://fsharp.org/specs/language-spec/). F# uses the [FsYacc](http://fsprojects.github.io/FsLexYacc/) tool to process a declarative specification of the parser in [pars.fsy](https://github.com/dotnet/fsharp/blob/main/src/Compiler/pars.fsy). This compiles the grammar to a number of tables which are then interpreted by the code in [prim-parsing.fs](https://github.com/dotnet/fsharp/blob/main/src/Compiler/Facilities/prim-parsing.fs) (see also [prim-parsing.fsi](https://github.com/dotnet/fsharp/blob/main/src/Compiler/Facilities/prim-parsing.fsi).
* _Resolving references_. For .NET SDK generally references are resolved explicitly by external tooling.
There is a legacy aspect to this if references use old .NET Framework references including for

58
docs/representations.md Normal file
Просмотреть файл

@ -0,0 +1,58 @@
---
title: Representations
category: Compiler Internals
categoryindex: 200
index: 350
---
# Representation Decisions in the F# Compiler
Consider the following declarations, all of which look very similar.
```fsharp
module M =
let z = 1
let f = x + z
type C(w: int, z: int) =
let f x = x + z
let f x = f 3 + x
let g (z: int) =
let f x = x + 1
```
Part of the job of the F# compiler is to "decide" how these declarations are compiled. The following acts as a guide to how these different bindings are represented and where these decisions are made.
First for module-level `let` bindings. These representations are decided by code in `CheckExpressions.fs` and `CheckDeclarations.fs` based on syntax.
```fsharp
module M =
let z = 1 // z --> static property + field, required by spec, compiled name mandated
let f x = x + z // f --> static method, required by spec, compiled name mandated
```
Next for class-level `let` bindings. These representations are decided by code in `CheckIncrementalClasses.fs` based on analysis of use.
```fsharp
// Decided in CheckIncrementalClasses.fs based on analysis of use
type C(w: int, z: int) = // w --> local to object constructor, required by spec
// z --> private instance field, required by spec
let f x = x + z // f --> private instance method, required by spec, compiled name not mandated
// Note: initially uses an ephemeral 'f' Val then creates a member Val with compiled name
let f x = f 3 + x // f --> private instance method, required by spec, compiled name not mandated
// Note: initially uses an ephemeral 'f' Val then creates a member Val with compiled name
static let g x = x + 1 // g --> private static method, required by spec, compiled name not mandated, initially uses an ephemeral 'g' Val then creates a member Val with compiled name
static let g x = g 3 // g --> private static method, required by spec, compiled name not mandated, initially uses an ephemeral 'g' Val then creates a member Val with compiled name
```
Next for expression-level `let` bindings. These representations are decided by code in various optimization phases.
```fsharp
let g (z: int) = // z --> local + field in closure for 'f', not mandated
let f x = x + 1 // f --> FSharpFunc value, or maybe a static method, not mandated
// Decided in various optimization phases
```
> NOTE: The representation decision is implied by the addition of ValReprInfo to the `Val` node.

24
eng/Build.ps1
Просмотреть файл

@ -425,7 +425,6 @@ try {
[System.Environment]::SetEnvironmentVariable('DOTNET_ROLL_FORWARD_TO_PRERELEASE', '1', [System.EnvironmentVariableTarget]::User)
$env:NativeToolsOnMachine = $true
Process-Arguments
@ -438,6 +437,10 @@ try {
Get-ChildItem ENV: | Sort-Object Name
Write-Host ""
if($env:NativeToolsOnMachine) {
$variable:NativeToolsOnMachine = $env:NativeToolsOnMachine
}
if ($ci) {
Prepare-TempDir
EnablePreviewSdks
@ -447,10 +450,19 @@ try {
$toolsetBuildProj = InitializeToolset
TryDownloadDotnetFrameworkSdk
$nativeToolsDir = InitializeNativeTools
write-host "Native tools: $nativeToolsDir"
$env:PERL5Path = Join-Path "$nativeToolsDir" "perl\5.32.1.1\perl\bin\perl.exe"
$env:PERL5LIB = Join-Path "$nativeToolsDir" "perl\5.32.1.1\perl\vendor\lib"
$nativeTools = InitializeNativeTools
if (-not (Test-Path variable:NativeToolsOnMachine)) {
$env:PERL5Path = Join-Path $nativeTools "perl\5.32.1.1\perl\bin\perl.exe"
write-host "variable:NativeToolsOnMachine = unset or false"
$nativeTools
write-host "Path = $env:PERL5Path"
}
else {
$env:PERL5Path = Join-Path $nativeTools["perl"] "perl\bin\perl.exe"
write-host "variable:NativeToolsOnMachine = $variable:NativeToolsOnMachine"
$nativeTools.values
write-host "Path = $env:PERL5Path"
}
$dotnetPath = InitializeDotNetCli
$env:DOTNET_ROOT = "$dotnetPath"
@ -517,7 +529,9 @@ try {
$env:FSCOREDLLPATH = "$ArtifactsDir\bin\fsc\$configuration\net472\FSharp.Core.dll"
$env:LINK_EXE = "$RepoRoot\tests\fsharpqa\testenv\bin\link\link.exe"
$env:OSARCH = $env:PROCESSOR_ARCHITECTURE
write-host "Exec-Console $env:PERL5Path"
Exec-Console $env:PERL5Path """$RepoRoot\tests\fsharpqa\testenv\bin\runall.pl"" -resultsroot ""$resultsRoot"" -results $resultsLog -log $errorLog -fail $failLog -cleanup:no -procs:$env:NUMBER_OF_PROCESSORS"
write-host "Exec-Console finished"
Pop-Location
}

4
eng/Version.Details.xml
Просмотреть файл

@ -8,9 +8,9 @@
</Dependency>
</ProductDependencies>
<ToolsetDependencies>
<Dependency Name="Microsoft.DotNet.Arcade.Sdk" Version="7.0.0-beta.22327.2">
<Dependency Name="Microsoft.DotNet.Arcade.Sdk" Version="7.0.0-beta.22410.3">
<Uri>https://github.com/dotnet/arcade</Uri>
<Sha>a264eb13fea14125f3ef8d4056586cd66fa55309</Sha>
<Sha>fd9941799bb6983a7d00ed72682378b46a45f396</Sha>
<SourceBuild RepoName="arcade" ManagedOnly="true" />
</Dependency>
</ToolsetDependencies>

125
eng/Versions.props
Просмотреть файл

@ -112,82 +112,83 @@
<SystemThreadingThreadPoolVersion>4.3.0</SystemThreadingThreadPoolVersion>
<SystemRuntimeCompilerServicesUnsafeVersion>6.0.0</SystemRuntimeCompilerServicesUnsafeVersion>
<SystemValueTupleVersion>4.5.0</SystemValueTupleVersion>
<!-- VisualStudio package versions -->
<VisualStudioImplementationPackagesVersion>17.2.178-preview</VisualStudioImplementationPackagesVersion>
<VisualStudioContractPackagesVersion>17.2.0-preview-1-32131-009</VisualStudioContractPackagesVersion>
<!-- Versions for package groups -->
<RoslynVersion>4.4.0-1.22368.2</RoslynVersion>
<VisualStudioEditorPackagesVersion>17.3.133-preview</VisualStudioEditorPackagesVersion>
<MicrosoftVisualStudioShellPackagesVersion>17.3.0-preview-1-32407-044</MicrosoftVisualStudioShellPackagesVersion>
<VisualStudioProjectSystemPackagesVersion>17.0.77-pre-g62a6cb5699</VisualStudioProjectSystemPackagesVersion>
<MicrosoftVisualStudioInteropVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioInteropVersion>
<MicrosoftInternalVisualStudioInteropVersion>$(VisualStudioContractPackagesVersion)</MicrosoftInternalVisualStudioInteropVersion>
<MicrosoftVisualStudioImagingInterop140DesignTimeVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioImagingInterop140DesignTimeVersion>
<VisualStudioLanguageAndShellInteropVersion>17.0.0-preview-1-31115-307</VisualStudioLanguageAndShellInteropVersion>
<MicrosoftVisualStudioShellInterop80Version>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioShellInterop80Version>
<MicrosoftVisualStudioShellInterop90Version>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioShellInterop90Version>
<MicrosoftVisualStudioShellInterop100Version>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioShellInterop100Version>
<MicrosoftVisualStudioShellInterop110Version>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioShellInterop110Version>
<MicrosoftVisualStudioShellInterop120Version>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioShellInterop120Version>
<MicrosoftVisualStudioImageCatalogVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioImageCatalogVersion>
<MicrosoftVisualStudioShellInteropVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioShellInteropVersion>
<MicrosoftVisualStudioTextManagerInteropVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioTextManagerInteropVersion>
<MicrosoftVisualStudioTextManagerInterop80Version>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioTextManagerInterop80Version>
<MicrosoftVisualStudioTextManagerInterop100Version>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioTextManagerInterop100Version>
<MicrosoftVisualStudioTextManagerInterop120Version>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioTextManagerInterop120Version>
<MicrosoftVisualStudioOLEInteropVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioOLEInteropVersion>
<EnvDTEVersion>$(VisualStudioContractPackagesVersion)</EnvDTEVersion>
<EnvDTE80Version>$(VisualStudioContractPackagesVersion)</EnvDTE80Version>
<MicrosoftVisualStudioThreadingPackagesVersion>17.3.1-alpha</MicrosoftVisualStudioThreadingPackagesVersion>
<MicrosoftBuildOverallPackagesVersion>17.1.0</MicrosoftBuildOverallPackagesVersion>
<!-- Roslyn packages -->
<RoslynVersion>4.2.0-3.22154.1</RoslynVersion>
<MicrosoftCodeAnalysisEditorFeaturesVersion>$(RoslynVersion)</MicrosoftCodeAnalysisEditorFeaturesVersion>
<MicrosoftCodeAnalysisEditorFeaturesTextVersion>$(RoslynVersion)</MicrosoftCodeAnalysisEditorFeaturesTextVersion>
<MicrosoftCodeAnalysisEditorFeaturesWpfVersion>$(RoslynVersion)</MicrosoftCodeAnalysisEditorFeaturesWpfVersion>
<MicrosoftCodeAnalysisExternalAccessFSharpVersion>$(RoslynVersion)</MicrosoftCodeAnalysisExternalAccessFSharpVersion>
<MicrosoftCodeAnalysisWorkspacesCommonVersion>$(RoslynVersion)</MicrosoftCodeAnalysisWorkspacesCommonVersion>
<MicrosoftCodeAnalysisCSharpVersion>$(RoslynVersion)</MicrosoftCodeAnalysisCSharpVersion>
<MicrosoftCodeAnalysisTestResourcesProprietaryVersion>2.0.28</MicrosoftCodeAnalysisTestResourcesProprietaryVersion>
<MicrosoftVisualStudioLanguageServicesVersion>$(RoslynVersion)</MicrosoftVisualStudioLanguageServicesVersion>
<!-- Microsoft Build packages -->
<MicrosoftBuildOverallPackagesVersion>17.0.0</MicrosoftBuildOverallPackagesVersion>
<MicrosoftBuildVersion>$(MicrosoftBuildOverallPackagesVersion)</MicrosoftBuildVersion>
<MicrosoftBuildFrameworkVersion>$(MicrosoftBuildOverallPackagesVersion)</MicrosoftBuildFrameworkVersion>
<MicrosoftBuildTasksCoreVersion>$(MicrosoftBuildOverallPackagesVersion)</MicrosoftBuildTasksCoreVersion>
<MicrosoftBuildUtilitiesCoreVersion>$(MicrosoftBuildOverallPackagesVersion)</MicrosoftBuildUtilitiesCoreVersion>
<MicrosoftVSSDKBuildToolsVersion>17.1.4054</MicrosoftVSSDKBuildToolsVersion>
<!-- Visual Studio editor packages -->
<MicrosoftVisualStudioCoreUtilityVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioCoreUtilityVersion>
<MicrosoftVisualStudioEditorVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioEditorVersion>
<MicrosoftVisualStudioLanguageStandardClassificationVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioLanguageStandardClassificationVersion>
<MicrosoftVisualStudioLanguageVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioLanguageVersion>
<MicrosoftVisualStudioLanguageIntellisenseVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioLanguageIntellisenseVersion>
<MicrosoftVisualStudioPlatformVSEditorVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioPlatformVSEditorVersion>
<MicrosoftVisualStudioTextUIVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioTextUIVersion>
<MicrosoftVisualStudioTextUIWpfVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioTextUIWpfVersion>
<MicrosoftVisualStudioTextDataVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioTextDataVersion>
<MicrosoftVisualStudioTextInternalVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioTextInternalVersion>
<!-- Visual Studio language+shell packages -->
<VisualStudioLanguageAndShellVersion>16.7.30329.88</VisualStudioLanguageAndShellVersion>
<MicrosoftVisualStudioShell150Version>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioShell150Version>
<MicrosoftVisualStudioShellDesignVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioShellDesignVersion>
<MicrosoftVisualStudioShellFrameworkVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioShellFrameworkVersion>
<MicrosoftVisualStudioPackageLanguageService150Version>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioPackageLanguageService150Version>
<!-- Misc. Visual Studio packages -->
<MicrosoftVisualStudioRpcContractsVersion>17.2.22-alpha</MicrosoftVisualStudioRpcContractsVersion>
<MicrosoftVisualStudioComponentModelHostVersion>$(VisualStudioImplementationPackagesVersion)</MicrosoftVisualStudioComponentModelHostVersion>
<MicrosoftVisualFSharpMicrosoftVisualStudioShellUIInternalVersion>17.0.0</MicrosoftVisualFSharpMicrosoftVisualStudioShellUIInternalVersion>
<MicrosoftVisualStudioDesignerInterfacesVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioDesignerInterfacesVersion>
<MicrosoftVisualStudioGraphModelVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioGraphModelVersion>
<MicrosoftVisualStudioImagingVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioImagingVersion>
<MicrosoftVisualStudioManagedInterfacesVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioManagedInterfacesVersion>
<MicrosoftVisualStudioProjectAggregatorVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioProjectAggregatorVersion>
<MicrosoftVisualStudioProjectSystemVersion>$(VisualStudioProjectSystemPackagesVersion)</MicrosoftVisualStudioProjectSystemVersion>
<MicrosoftVisualStudioProjectSystemManagedVersion>2.3.6152103</MicrosoftVisualStudioProjectSystemManagedVersion>
<MicrosoftCodeAnalysisTestResourcesProprietaryVersion>2.0.28</MicrosoftCodeAnalysisTestResourcesProprietaryVersion>
<!-- Visual Studio Shell packages -->
<MicrosoftVisualStudioInteropVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioInteropVersion>
<MicrosoftInternalVisualStudioInteropVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftInternalVisualStudioInteropVersion>
<MicrosoftVisualStudioImagingInterop140DesignTimeVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioImagingInterop140DesignTimeVersion>
<MicrosoftVisualStudioShellInterop80Version>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioShellInterop80Version>
<MicrosoftVisualStudioShellInterop90Version>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioShellInterop90Version>
<MicrosoftVisualStudioShellInterop100Version>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioShellInterop100Version>
<MicrosoftVisualStudioShellInterop110Version>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioShellInterop110Version>
<MicrosoftVisualStudioShellInterop120Version>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioShellInterop120Version>
<MicrosoftVisualStudioImageCatalogVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioImageCatalogVersion>
<MicrosoftVisualStudioShellInteropVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioShellInteropVersion>
<MicrosoftVisualStudioTextManagerInteropVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioTextManagerInteropVersion>
<MicrosoftVisualStudioTextManagerInterop80Version>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioTextManagerInterop80Version>
<MicrosoftVisualStudioTextManagerInterop100Version>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioTextManagerInterop100Version>
<MicrosoftVisualStudioTextManagerInterop120Version>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioTextManagerInterop120Version>
<MicrosoftVisualStudioOLEInteropVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioOLEInteropVersion>
<MicrosoftVisualStudioShell150Version>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioShell150Version>
<MicrosoftVisualStudioShellDesignVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioShellDesignVersion>
<MicrosoftVisualStudioShellFrameworkVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioShellFrameworkVersion>
<MicrosoftVisualStudioPackageLanguageService150Version>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioPackageLanguageService150Version>
<MicrosoftVisualStudioManagedInterfacesVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioManagedInterfacesVersion>
<MicrosoftVisualStudioProjectAggregatorVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioProjectAggregatorVersion>
<MicrosoftVisualStudioGraphModelVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioGraphModelVersion>
<MicrosoftVisualStudioImagingVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioImagingVersion>
<MicrosoftVisualStudioDesignerInterfacesVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioDesignerInterfacesVersion>
<MicrosoftVisualStudioUtilitiesVersion>$(MicrosoftVisualStudioShellPackagesVersion)</MicrosoftVisualStudioUtilitiesVersion>
<EnvDTEVersion>$(MicrosoftVisualStudioShellPackagesVersion)</EnvDTEVersion>
<EnvDTE80Version>$(MicrosoftVisualStudioShellPackagesVersion)</EnvDTE80Version>
<MicrosoftVisualStudioShell140Version>14.3.25407</MicrosoftVisualStudioShell140Version>
<MicrosoftVisualStudioShellImmutable100Version>10.0.30319</MicrosoftVisualStudioShellImmutable100Version>
<MicrosoftVisualStudioShellImmutable110Version>11.0.50727</MicrosoftVisualStudioShellImmutable110Version>
<MicrosoftVisualStudioShellImmutable150Version>15.0.25123-Dev15Preview</MicrosoftVisualStudioShellImmutable150Version>
<MicrosoftVisualStudioShellInterop160DesignTimeVersion>16.0.1</MicrosoftVisualStudioShellInterop160DesignTimeVersion>
<MicrosoftVisualStudioShellInterop16DesignTimeVersion>16.0.28924.11111</MicrosoftVisualStudioShellInterop16DesignTimeVersion>
<MicrosoftVisualStudioThreadingVersion>17.2.10-alpha</MicrosoftVisualStudioThreadingVersion>
<MicrosoftVisualStudioUtilitiesVersion>$(VisualStudioContractPackagesVersion)</MicrosoftVisualStudioUtilitiesVersion>
<MicrosoftVisualStudioValidationVersion>17.0.46</MicrosoftVisualStudioValidationVersion>
<!-- Microsoft Build packages -->
<MicrosoftBuildVersion>$(MicrosoftBuildOverallPackagesVersion)</MicrosoftBuildVersion>
<MicrosoftBuildFrameworkVersion>$(MicrosoftBuildOverallPackagesVersion)</MicrosoftBuildFrameworkVersion>
<MicrosoftBuildTasksCoreVersion>$(MicrosoftBuildOverallPackagesVersion)</MicrosoftBuildTasksCoreVersion>
<MicrosoftBuildUtilitiesCoreVersion>$(MicrosoftBuildOverallPackagesVersion)</MicrosoftBuildUtilitiesCoreVersion>
<!-- Visual Studio Editor packages -->
<MicrosoftVisualStudioCoreUtilityVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioCoreUtilityVersion>
<MicrosoftVisualStudioEditorVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioEditorVersion>
<MicrosoftVisualStudioLanguageStandardClassificationVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioLanguageStandardClassificationVersion>
<MicrosoftVisualStudioLanguageVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioLanguageVersion>
<MicrosoftVisualStudioLanguageIntellisenseVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioLanguageIntellisenseVersion>
<MicrosoftVisualStudioPlatformVSEditorVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioPlatformVSEditorVersion>
<MicrosoftVisualStudioTextUIVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioTextUIVersion>
<MicrosoftVisualStudioTextUIWpfVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioTextUIWpfVersion>
<MicrosoftVisualStudioTextDataVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioTextDataVersion>
<MicrosoftVisualStudioTextInternalVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioTextInternalVersion>
<MicrosoftVisualStudioComponentModelHostVersion>$(VisualStudioEditorPackagesVersion)</MicrosoftVisualStudioComponentModelHostVersion>
<!-- Visual Studio Threading packags -->
<MicrosoftVisualStudioThreadingVersion>$(MicrosoftVisualStudioThreadingPackagesVersion)</MicrosoftVisualStudioThreadingVersion>
<!-- Visual Studio Project System packages-->
<MicrosoftVisualStudioProjectSystemVersion>$(VisualStudioProjectSystemPackagesVersion)</MicrosoftVisualStudioProjectSystemVersion>
<MicrosoftVisualStudioProjectSystemManagedVersion>2.3.6152103</MicrosoftVisualStudioProjectSystemManagedVersion>
<!-- Misc. Visual Studio packages -->
<MicrosoftVSSDKBuildToolsVersion>17.1.4054</MicrosoftVSSDKBuildToolsVersion>
<MicrosoftVisualStudioRpcContractsVersion>17.3.3-alpha</MicrosoftVisualStudioRpcContractsVersion>
<MicrosoftVisualFSharpMicrosoftVisualStudioShellUIInternalVersion>17.0.0</MicrosoftVisualFSharpMicrosoftVisualStudioShellUIInternalVersion>
<MicrosoftVisualStudioValidationVersion>17.0.53</MicrosoftVisualStudioValidationVersion>
<MicrosoftVisualStudioWCFReferenceInteropVersion>9.0.30729</MicrosoftVisualStudioWCFReferenceInteropVersion>
<SystemRuntimeCompilerServicesUnsafeVersion>6.0.0</SystemRuntimeCompilerServicesUnsafeVersion>
<VSSDKDebuggerVisualizersVersion>12.0.4</VSSDKDebuggerVisualizersVersion>
@ -216,7 +217,7 @@
<NUnitLiteVersion>3.11.0</NUnitLiteVersion>
<NunitXmlTestLoggerVersion>2.1.80</NunitXmlTestLoggerVersion>
<RoslynToolsSignToolVersion>1.0.0-beta2-dev3</RoslynToolsSignToolVersion>
<StreamJsonRpcVersion>2.11.34</StreamJsonRpcVersion>
<StreamJsonRpcVersion>2.12.7-alpha</StreamJsonRpcVersion>
<NerdbankStreamsVersion>2.8.57</NerdbankStreamsVersion>
<XUnitVersion>2.4.1</XUnitVersion>
<XUnitRunnerVersion>2.4.2</XUnitRunnerVersion>

4
eng/build-utils.ps1
Просмотреть файл

@ -256,8 +256,8 @@ function Make-BootstrapBuild() {
Copy-Item "$ArtifactsDir\bin\AssemblyCheck\$bootstrapConfiguration\net6.0" -Destination "$dir\AssemblyCheck" -Force -Recurse
# prepare compiler
$protoProject = "`"$RepoRoot\proto.proj`""
$args = "build $protoProject -c $bootstrapConfiguration -v $verbosity -f $bootstrapTfm" + $argNoRestore + $argNoIncremental
$protoProject = "`"$RepoRoot\proto.sln`""
$args = "build $protoProject -c $bootstrapConfiguration -v $verbosity " + $argNoRestore + $argNoIncremental
if ($binaryLog) {
$logFilePath = Join-Path $LogDir "protoBootstrapLog.binlog"
$args += " /bl:`"$logFilePath`""

50
eng/build.sh
Просмотреть файл

@ -8,30 +8,31 @@ set -u
usage()
{
echo "Common settings:"
echo " --configuration <value> Build configuration: 'Debug' or 'Release' (short: -c)"
echo " --verbosity <value> Msbuild verbosity: q[uiet], m[inimal], n[ormal], d[etailed], and diag[nostic] (short: -v)"
echo " --binaryLog Create MSBuild binary log (short: -bl)"
echo " --configuration <value> Build configuration: 'Debug' or 'Release' (short: -c)"
echo " --verbosity <value> Msbuild verbosity: q[uiet], m[inimal], n[ormal], d[etailed], and diag[nostic] (short: -v)"
echo " --binaryLog Create MSBuild binary log (short: -bl)"
echo ""
echo "Actions:"
echo " --bootstrap Force the build of the bootstrap compiler"
echo " --restore Restore projects required to build (short: -r)"
echo " --norestore Don't restore projects required to build"
echo " --build Build all projects (short: -b)"
echo " --rebuild Rebuild all projects"
echo " --pack Build nuget packages"
echo " --publish Publish build artifacts"
echo " --help Print help and exit"
echo " --bootstrap Force the build of the bootstrap compiler"
echo " --restore Restore projects required to build (short: -r)"
echo " --norestore Don't restore projects required to build"
echo " --build Build all projects (short: -b)"
echo " --rebuild Rebuild all projects"
echo " --pack Build nuget packages"
echo " --publish Publish build artifacts"
echo " --help Print help and exit"
echo ""
echo "Test actions:"
echo " --testcoreclr Run unit tests on .NET Core (short: --test, -t)"
echo " --testcoreclr Run unit tests on .NET Core (short: --test, -t)"
echo " --testCompilerComponentTests Run FSharp.Compiler.ComponentTests on .NET Core"
echo ""
echo "Advanced settings:"
echo " --ci Building in CI"
echo " --docker Run in a docker container if applicable"
echo " --skipAnalyzers Do not run analyzers during build operations"
echo " --skipBuild Do not run the build"
echo " --prepareMachine Prepare machine for CI run, clean up processes after build"
echo " --sourceBuild Simulate building for source-build"
echo " --ci Building in CI"
echo " --docker Run in a docker container if applicable"
echo " --skipAnalyzers Do not run analyzers during build operations"
echo " --skipBuild Do not run the build"
echo " --prepareMachine Prepare machine for CI run, clean up processes after build"
echo " --sourceBuild Simulate building for source-build"
echo ""
echo "Command line arguments starting with '/p:' are passed through to MSBuild."
}
@ -54,7 +55,7 @@ rebuild=false
pack=false
publish=false
test_core_clr=false
test_compilercomponent_tests=false
configuration="Debug"
verbosity='minimal'
binary_log=false
@ -122,6 +123,9 @@ while [[ $# > 0 ]]; do
--testcoreclr|--test|-t)
test_core_clr=true
;;
--testcompilercomponenttests)
test_compilercomponent_tests=true
;;
--ci)
ci=true
;;
@ -262,7 +266,7 @@ function BuildSolution {
fi
if [ ! -f "$bootstrap_dir/fsc.exe" ]; then
BuildMessage="Error building bootstrap"
MSBuild "$repo_root/proto.proj" \
MSBuild "$repo_root/Proto.sln" \
/restore \
/p:Configuration=$bootstrap_config
@ -275,7 +279,6 @@ function BuildSolution {
BuildMessage="Error building solution"
MSBuild $toolset_build_proj \
$bl \
/v:$verbosity \
/p:Configuration=$configuration \
/p:Projects="$projects" \
/p:RepoRoot="$repo_root" \
@ -318,4 +321,9 @@ if [[ "$test_core_clr" == true ]]; then
TestUsingNUnit --testproject "$repo_root/tests/FSharp.Core.UnitTests/FSharp.Core.UnitTests.fsproj" --targetframework $coreclrtestframework
fi
if [[ "$test_compilercomponent_tests" == true ]]; then
coreclrtestframework=net6.0
TestUsingNUnit --testproject "$repo_root/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj" --targetframework $coreclrtestframework --notestfilter
fi
ExitWithExitCode 0

18
eng/common/SetupNugetSources.ps1
Просмотреть файл

@ -146,22 +146,22 @@ $userName = "dn-bot"
# Insert credential nodes for Maestro's private feeds
InsertMaestroPrivateFeedCredentials -Sources $sources -Creds $creds -Username $userName -Password $Password
# 3.1 uses a different feed url format so it's handled differently here
$dotnet31Source = $sources.SelectSingleNode("add[@key='dotnet3.1']")
if ($dotnet31Source -ne $null) {
AddPackageSource -Sources $sources -SourceName "dotnet3.1-internal" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/_packaging/dotnet3.1-internal/nuget/v2" -Creds $creds -Username $userName -Password $Password
AddPackageSource -Sources $sources -SourceName "dotnet3.1-internal-transport" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/_packaging/dotnet3.1-internal-transport/nuget/v2" -Creds $creds -Username $userName -Password $Password
}
$dotnet5Source = $sources.SelectSingleNode("add[@key='dotnet5']")
if ($dotnet5Source -ne $null) {
AddPackageSource -Sources $sources -SourceName "dotnet5-internal" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/internal/_packaging/dotnet5-internal/nuget/v2" -Creds $creds -Username $userName -Password $Password
AddPackageSource -Sources $sources -SourceName "dotnet5-internal-transport" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/internal/_packaging/dotnet5-internal-transport/nuget/v2" -Creds $creds -Username $userName -Password $Password
}
$dotnetVersions = @('5','6','7')
$dotnet6Source = $sources.SelectSingleNode("add[@key='dotnet6']")
if ($dotnet6Source -ne $null) {
AddPackageSource -Sources $sources -SourceName "dotnet6-internal" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/internal/_packaging/dotnet6-internal/nuget/v2" -Creds $creds -Username $userName -Password $Password
AddPackageSource -Sources $sources -SourceName "dotnet6-internal-transport" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/internal/_packaging/dotnet6-internal-transport/nuget/v2" -Creds $creds -Username $userName -Password $Password
foreach ($dotnetVersion in $dotnetVersions) {
$feedPrefix = "dotnet" + $dotnetVersion;
$dotnetSource = $sources.SelectSingleNode("add[@key='$feedPrefix']")
if ($dotnetSource -ne $null) {
AddPackageSource -Sources $sources -SourceName "$feedPrefix-internal" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/internal/_packaging/$feedPrefix-internal/nuget/v2" -Creds $creds -Username $userName -Password $Password
AddPackageSource -Sources $sources -SourceName "$feedPrefix-internal-transport" -SourceEndPoint "https://pkgs.dev.azure.com/dnceng/internal/_packaging/$feedPrefix-internal-transport/nuget/v2" -Creds $creds -Username $userName -Password $Password
}
}
$doc.Save($filename)

70
eng/common/SetupNugetSources.sh
Просмотреть файл

@ -105,53 +105,33 @@ if [ "$?" == "0" ]; then
PackageSources+=('dotnet3.1-internal-transport')
fi
# Ensure dotnet5-internal and dotnet5-internal-transport are in the packageSources if the public dotnet5 feeds are present
grep -i "<add key=\"dotnet5\"" $ConfigFile
if [ "$?" == "0" ]; then
grep -i "<add key=\"dotnet5-internal\"" $ConfigFile
if [ "$?" != "0" ]; then
echo "Adding dotnet5-internal to the packageSources."
PackageSourcesNodeFooter="</packageSources>"
PackageSourceTemplate="${TB}<add key=\"dotnet5-internal\" value=\"https://pkgs.dev.azure.com/dnceng/internal/_packaging/dotnet5-internal/nuget/v2\" />"
DotNetVersions=('5' '6' '7')
sed -i.bak "s|$PackageSourcesNodeFooter|$PackageSourceTemplate${NL}$PackageSourcesNodeFooter|" $ConfigFile
for DotNetVersion in ${DotNetVersions[@]} ; do
FeedPrefix="dotnet${DotNetVersion}";
grep -i "<add key=\"$FeedPrefix\"" $ConfigFile
if [ "$?" == "0" ]; then
grep -i "<add key=\"$FeedPrefix-internal\"" $ConfigFile
if [ "$?" != "0" ]; then
echo "Adding $FeedPrefix-internal to the packageSources."
PackageSourcesNodeFooter="</packageSources>"
PackageSourceTemplate="${TB}<add key=\"$FeedPrefix-internal\" value=\"https://pkgs.dev.azure.com/dnceng/internal/_packaging/$FeedPrefix-internal/nuget/v2\" />"
sed -i.bak "s|$PackageSourcesNodeFooter|$PackageSourceTemplate${NL}$PackageSourcesNodeFooter|" $ConfigFile
fi
PackageSources+=("$FeedPrefix-internal")
grep -i "<add key=\"$FeedPrefix-internal-transport\">" $ConfigFile
if [ "$?" != "0" ]; then
echo "Adding $FeedPrefix-internal-transport to the packageSources."
PackageSourcesNodeFooter="</packageSources>"
PackageSourceTemplate="${TB}<add key=\"$FeedPrefix-internal-transport\" value=\"https://pkgs.dev.azure.com/dnceng/internal/_packaging/$FeedPrefix-internal-transport/nuget/v2\" />"
sed -i.bak "s|$PackageSourcesNodeFooter|$PackageSourceTemplate${NL}$PackageSourcesNodeFooter|" $ConfigFile
fi
PackageSources+=("$FeedPrefix-internal-transport")
fi
PackageSources+=('dotnet5-internal')
grep -i "<add key=\"dotnet5-internal-transport\">" $ConfigFile
if [ "$?" != "0" ]; then
echo "Adding dotnet5-internal-transport to the packageSources."
PackageSourcesNodeFooter="</packageSources>"
PackageSourceTemplate="${TB}<add key=\"dotnet5-internal-transport\" value=\"https://pkgs.dev.azure.com/dnceng/internal/_packaging/dotnet5-internal-transport/nuget/v2\" />"
sed -i.bak "s|$PackageSourcesNodeFooter|$PackageSourceTemplate${NL}$PackageSourcesNodeFooter|" $ConfigFile
fi
PackageSources+=('dotnet5-internal-transport')
fi
# Ensure dotnet6-internal and dotnet6-internal-transport are in the packageSources if the public dotnet6 feeds are present
grep -i "<add key=\"dotnet6\"" $ConfigFile
if [ "$?" == "0" ]; then
grep -i "<add key=\"dotnet6-internal\"" $ConfigFile
if [ "$?" != "0" ]; then
echo "Adding dotnet6-internal to the packageSources."
PackageSourcesNodeFooter="</packageSources>"
PackageSourceTemplate="${TB}<add key=\"dotnet6-internal\" value=\"https://pkgs.dev.azure.com/dnceng/internal/_packaging/dotnet6-internal/nuget/v2\" />"
sed -i.bak "s|$PackageSourcesNodeFooter|$PackageSourceTemplate${NL}$PackageSourcesNodeFooter|" $ConfigFile
fi
PackageSources+=('dotnet6-internal')
grep -i "<add key=\"dotnet6-internal-transport\">" $ConfigFile
if [ "$?" != "0" ]; then
echo "Adding dotnet6-internal-transport to the packageSources."
PackageSourcesNodeFooter="</packageSources>"
PackageSourceTemplate="${TB}<add key=\"dotnet6-internal-transport\" value=\"https://pkgs.dev.azure.com/dnceng/internal/_packaging/dotnet6-internal-transport/nuget/v2\" />"
sed -i.bak "s|$PackageSourcesNodeFooter|$PackageSourceTemplate${NL}$PackageSourcesNodeFooter|" $ConfigFile
fi
PackageSources+=('dotnet6-internal-transport')
fi
done
# I want things split line by line
PrevIFS=$IFS

17
eng/common/build.sh
Просмотреть файл

@ -19,6 +19,9 @@ usage()
echo "Actions:"
echo " --restore Restore dependencies (short: -r)"
echo " --build Build solution (short: -b)"
echo " --sourceBuild Source-build the solution (short: -sb)"
echo " Will additionally trigger the following actions: --restore, --build, --pack"
echo " If --configuration is not set explicitly, will also set it to 'Release'"
echo " --rebuild Rebuild solution"
echo " --test Run all unit tests in the solution (short: -t)"
echo " --integrationTest Run all integration tests in the solution"
@ -55,6 +58,7 @@ scriptroot="$( cd -P "$( dirname "$source" )" && pwd )"
restore=false
build=false
source_build=false
rebuild=false
test=false
integration_test=false
@ -73,7 +77,7 @@ exclude_ci_binary_log=false
pipelines_log=false
projects=''
configuration='Debug'
configuration=''
prepare_machine=false
verbosity='minimal'
runtime_source_feed=''
@ -119,6 +123,12 @@ while [[ $# > 0 ]]; do
-pack)
pack=true
;;
-sourcebuild|-sb)
build=true
source_build=true
restore=true
pack=true
;;
-test|-t)
test=true
;;
@ -168,6 +178,10 @@ while [[ $# > 0 ]]; do
shift
done
if [[ -z "$configuration" ]]; then
if [[ "$source_build" = true ]]; then configuration="Release"; else configuration="Debug"; fi
fi
if [[ "$ci" == true ]]; then
pipelines_log=true
node_reuse=false
@ -205,6 +219,7 @@ function Build {
/p:RepoRoot="$repo_root" \
/p:Restore=$restore \
/p:Build=$build \
/p:ArcadeBuildFromSource=$source_build \
/p:Rebuild=$rebuild \
/p:Test=$test \
/p:Pack=$pack \

277
eng/common/cross/build-rootfs.sh
Просмотреть файл

@ -5,22 +5,26 @@ set -e
usage()
{
echo "Usage: $0 [BuildArch] [CodeName] [lldbx.y] [llvmx[.y]] [--skipunmount] --rootfsdir <directory>]"
echo "BuildArch can be: arm(default), armel, arm64, x86"
echo "BuildArch can be: arm(default), arm64, armel, armv6, ppc64le, riscv64, s390x, x64, x86"
echo "CodeName - optional, Code name for Linux, can be: xenial(default), zesty, bionic, alpine, alpine3.13 or alpine3.14. If BuildArch is armel, LinuxCodeName is jessie(default) or tizen."
echo " for FreeBSD can be: freebsd12, freebsd13"
echo " for illumos can be: illumos."
echo " for illumos can be: illumos"
echo " for Haiku can be: haiku."
echo "lldbx.y - optional, LLDB version, can be: lldb3.9(default), lldb4.0, lldb5.0, lldb6.0 no-lldb. Ignored for alpine and FreeBSD"
echo "llvmx[.y] - optional, LLVM version for LLVM related packages."
echo "--skipunmount - optional, will skip the unmount of rootfs folder."
echo "--use-mirror - optional, use mirror URL to fetch resources, when available."
echo "--jobs N - optional, restrict to N jobs."
exit 1
}
__CodeName=xenial
__CrossDir=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )
__InitialDir=$PWD
__BuildArch=arm
__AlpineArch=armv7
__FreeBSDArch=arm
__FreeBSDMachineArch=armv7
__IllumosArch=arm7
__QEMUArch=arm
__UbuntuArch=armhf
__UbuntuRepo="http://ports.ubuntu.com/"
@ -40,7 +44,7 @@ __AlpinePackages+=" libedit"
# symlinks fixer
__UbuntuPackages+=" symlinks"
# CoreCLR and CoreFX dependencies
# runtime dependencies
__UbuntuPackages+=" libicu-dev"
__UbuntuPackages+=" liblttng-ust-dev"
__UbuntuPackages+=" libunwind8-dev"
@ -51,7 +55,7 @@ __AlpinePackages+=" libunwind-dev"
__AlpinePackages+=" lttng-ust-dev"
__AlpinePackages+=" compiler-rt-static"
# CoreFX dependencies
# runtime libraries' dependencies
__UbuntuPackages+=" libcurl4-openssl-dev"
__UbuntuPackages+=" libkrb5-dev"
__UbuntuPackages+=" libssl-dev"
@ -77,21 +81,33 @@ __IllumosPackages+=" mit-krb5-1.16.2nb4"
__IllumosPackages+=" openssl-1.1.1e"
__IllumosPackages+=" zlib-1.2.11"
__HaikuPackages="gmp"
__HaikuPackages+=" gmp_devel"
__HaikuPackages+=" krb5"
__HaikuPackages+=" krb5_devel"
__HaikuPackages+=" libiconv"
__HaikuPackages+=" libiconv_devel"
__HaikuPackages+=" llvm12_libunwind"
__HaikuPackages+=" llvm12_libunwind_devel"
__HaikuPackages+=" mpfr"
__HaikuPackages+=" mpfr_devel"
# ML.NET dependencies
__UbuntuPackages+=" libomp5"
__UbuntuPackages+=" libomp-dev"
__Keyring=
__UseMirror=0
__UnprocessedBuildArgs=
while :; do
if [ $# -le 0 ]; then
if [[ "$#" -le 0 ]]; then
break
fi
lowerI="$(echo $1 | tr "[:upper:]" "[:lower:]")"
lowerI="$(echo "$1" | tr "[:upper:]" "[:lower:]")"
case $lowerI in
-?|-h|--help)
-\?|-h|--help)
usage
exit 1
;;
@ -101,6 +117,20 @@ while :; do
__AlpineArch=armv7
__QEMUArch=arm
;;
arm64)
__BuildArch=arm64
__UbuntuArch=arm64
__AlpineArch=aarch64
__QEMUArch=aarch64
__FreeBSDArch=arm64
__FreeBSDMachineArch=aarch64
;;
armel)
__BuildArch=armel
__UbuntuArch=armel
__UbuntuRepo="http://ftp.debian.org/debian/"
__CodeName=jessie
;;
armv6)
__BuildArch=armv6
__UbuntuArch=armhf
@ -108,19 +138,10 @@ while :; do
__UbuntuRepo="http://raspbian.raspberrypi.org/raspbian/"
__CodeName=buster
__LLDB_Package="liblldb-6.0-dev"
__Keyring="/usr/share/keyrings/raspbian-archive-keyring.gpg"
;;
arm64)
__BuildArch=arm64
__UbuntuArch=arm64
__AlpineArch=aarch64
__QEMUArch=aarch64
;;
armel)
__BuildArch=armel
__UbuntuArch=armel
__UbuntuRepo="http://ftp.debian.org/debian/"
__CodeName=jessie
if [[ -e "/usr/share/keyrings/raspbian-archive-keyring.gpg" ]]; then
__Keyring="--keyring /usr/share/keyrings/raspbian-archive-keyring.gpg"
fi
;;
ppc64le)
__BuildArch=ppc64le
@ -131,6 +152,18 @@ while :; do
__UbuntuPackages=$(echo ${__UbuntuPackages} | sed 's/ libomp5//')
unset __LLDB_Package
;;
riscv64)
__BuildArch=riscv64
__UbuntuArch=riscv64
__UbuntuRepo="http://deb.debian.org/debian-ports"
__CodeName=sid
__UbuntuPackages=$(echo ${__UbuntuPackages} | sed 's/ libunwind8-dev//')
unset __LLDB_Package
if [[ -e "/usr/share/keyrings/debian-ports-archive-keyring.gpg" ]]; then
__Keyring="--keyring /usr/share/keyrings/debian-ports-archive-keyring.gpg --include=debian-ports-archive-keyring"
fi
;;
s390x)
__BuildArch=s390x
__UbuntuArch=s390x
@ -140,6 +173,14 @@ while :; do
__UbuntuPackages=$(echo ${__UbuntuPackages} | sed 's/ libomp5//')
unset __LLDB_Package
;;
x64)
__BuildArch=x64
__UbuntuArch=amd64
__FreeBSDArch=amd64
__FreeBSDMachineArch=amd64
__illumosArch=x86_64
__UbuntuRepo=
;;
x86)
__BuildArch=x86
__UbuntuArch=i386
@ -176,17 +217,17 @@ while :; do
fi
;;
xenial) # Ubuntu 16.04
if [ "$__CodeName" != "jessie" ]; then
if [[ "$__CodeName" != "jessie" ]]; then
__CodeName=xenial
fi
;;
zesty) # Ubuntu 17.04
if [ "$__CodeName" != "jessie" ]; then
if [[ "$__CodeName" != "jessie" ]]; then
__CodeName=zesty
fi
;;
bionic) # Ubuntu 18.04
if [ "$__CodeName" != "jessie" ]; then
if [[ "$__CodeName" != "jessie" ]]; then
__CodeName=bionic
fi
;;
@ -205,11 +246,6 @@ while :; do
__LLDB_Package="liblldb-6.0-dev"
;;
tizen)
if [ "$__BuildArch" != "arm" ] && [ "$__BuildArch" != "armel" ] && [ "$__BuildArch" != "arm64" ] && [ "$__BuildArch" != "x86" ] ; then
echo "Tizen is available only for arm, armel, arm64 and x86."
usage;
exit 1;
fi
__CodeName=
__UbuntuRepo=
__Tizen=tizen
@ -228,18 +264,20 @@ while :; do
;;
freebsd12)
__CodeName=freebsd
__BuildArch=x64
__SkipUnmount=1
;;
freebsd13)
__CodeName=freebsd
__FreeBSDBase="13.0-RELEASE"
__FreeBSDABI="13"
__BuildArch=x64
__SkipUnmount=1
;;
illumos)
__CodeName=illumos
__SkipUnmount=1
;;
haiku)
__CodeName=haiku
__BuildArch=x64
__SkipUnmount=1
;;
@ -248,11 +286,15 @@ while :; do
;;
--rootfsdir|-rootfsdir)
shift
__RootfsDir=$1
__RootfsDir="$1"
;;
--use-mirror)
__UseMirror=1
;;
--use-jobs)
shift
MAXJOBS=$1
;;
*)
__UnprocessedBuildArgs="$__UnprocessedBuildArgs $1"
;;
@ -261,81 +303,76 @@ while :; do
shift
done
if [ -e "$__Keyring" ]; then
__Keyring="--keyring=$__Keyring"
else
__Keyring=""
fi
if [ "$__BuildArch" == "armel" ]; then
if [[ "$__BuildArch" == "armel" ]]; then
__LLDB_Package="lldb-3.5-dev"
fi
__UbuntuPackages+=" ${__LLDB_Package:-}"
if [ ! -z "$__LLVM_MajorVersion" ]; then
if [[ -n "$__LLVM_MajorVersion" ]]; then
__UbuntuPackages+=" libclang-common-${__LLVM_MajorVersion}${__LLVM_MinorVersion:+.$__LLVM_MinorVersion}-dev"
fi
if [ -z "$__RootfsDir" ] && [ ! -z "$ROOTFS_DIR" ]; then
__RootfsDir=$ROOTFS_DIR
if [[ -z "$__RootfsDir" && -n "$ROOTFS_DIR" ]]; then
__RootfsDir="$ROOTFS_DIR"
fi
if [ -z "$__RootfsDir" ]; then
if [[ -z "$__RootfsDir" ]]; then
__RootfsDir="$__CrossDir/../../../.tools/rootfs/$__BuildArch"
fi
if [ -d "$__RootfsDir" ]; then
if [ $__SkipUnmount == 0 ]; then
umount $__RootfsDir/* || true
if [[ -d "$__RootfsDir" ]]; then
if [[ "$__SkipUnmount" == "0" ]]; then
umount "$__RootfsDir"/* || true
fi
rm -rf $__RootfsDir
rm -rf "$__RootfsDir"
fi
mkdir -p $__RootfsDir
mkdir -p "$__RootfsDir"
__RootfsDir="$( cd "$__RootfsDir" && pwd )"
if [[ "$__CodeName" == "alpine" ]]; then
__ApkToolsVersion=2.9.1
__ApkToolsDir=$(mktemp -d)
wget https://github.com/alpinelinux/apk-tools/releases/download/v$__ApkToolsVersion/apk-tools-$__ApkToolsVersion-x86_64-linux.tar.gz -P $__ApkToolsDir
tar -xf $__ApkToolsDir/apk-tools-$__ApkToolsVersion-x86_64-linux.tar.gz -C $__ApkToolsDir
mkdir -p $__RootfsDir/usr/bin
cp -v /usr/bin/qemu-$__QEMUArch-static $__RootfsDir/usr/bin
__ApkToolsDir="$(mktemp -d)"
wget "https://github.com/alpinelinux/apk-tools/releases/download/v$__ApkToolsVersion/apk-tools-$__ApkToolsVersion-x86_64-linux.tar.gz" -P "$__ApkToolsDir"
tar -xf "$__ApkToolsDir/apk-tools-$__ApkToolsVersion-x86_64-linux.tar.gz" -C "$__ApkToolsDir"
mkdir -p "$__RootfsDir"/usr/bin
cp -v "/usr/bin/qemu-$__QEMUArch-static" "$__RootfsDir/usr/bin"
$__ApkToolsDir/apk-tools-$__ApkToolsVersion/apk \
-X http://dl-cdn.alpinelinux.org/alpine/v$__AlpineVersion/main \
-X http://dl-cdn.alpinelinux.org/alpine/v$__AlpineVersion/community \
-U --allow-untrusted --root $__RootfsDir --arch $__AlpineArch --initdb \
"$__ApkToolsDir/apk-tools-$__ApkToolsVersion/apk" \
-X "http://dl-cdn.alpinelinux.org/alpine/v$__AlpineVersion/main" \
-X "http://dl-cdn.alpinelinux.org/alpine/v$__AlpineVersion/community" \
-U --allow-untrusted --root "$__RootfsDir" --arch "$__AlpineArch" --initdb \
add $__AlpinePackages
rm -r $__ApkToolsDir
rm -r "$__ApkToolsDir"
elif [[ "$__CodeName" == "freebsd" ]]; then
mkdir -p $__RootfsDir/usr/local/etc
JOBS="$(getconf _NPROCESSORS_ONLN)"
wget -O - https://download.freebsd.org/ftp/releases/amd64/${__FreeBSDBase}/base.txz | tar -C $__RootfsDir -Jxf - ./lib ./usr/lib ./usr/libdata ./usr/include ./usr/share/keys ./etc ./bin/freebsd-version
echo "ABI = \"FreeBSD:${__FreeBSDABI}:amd64\"; FINGERPRINTS = \"${__RootfsDir}/usr/share/keys\"; REPOS_DIR = [\"${__RootfsDir}/etc/pkg\"]; REPO_AUTOUPDATE = NO; RUN_SCRIPTS = NO;" > ${__RootfsDir}/usr/local/etc/pkg.conf
echo "FreeBSD: { url: "pkg+http://pkg.FreeBSD.org/\${ABI}/quarterly", mirror_type: \"srv\", signature_type: \"fingerprints\", fingerprints: \"${__RootfsDir}/usr/share/keys/pkg\", enabled: yes }" > ${__RootfsDir}/etc/pkg/FreeBSD.conf
mkdir -p $__RootfsDir/tmp
mkdir -p "$__RootfsDir"/usr/local/etc
JOBS=${MAXJOBS:="$(getconf _NPROCESSORS_ONLN)"}
wget -O - "https://download.freebsd.org/ftp/releases/${__FreeBSDArch}/${__FreeBSDMachineArch}/${__FreeBSDBase}/base.txz" | tar -C "$__RootfsDir" -Jxf - ./lib ./usr/lib ./usr/libdata ./usr/include ./usr/share/keys ./etc ./bin/freebsd-version
echo "ABI = \"FreeBSD:${__FreeBSDABI}:${__FreeBSDMachineArch}\"; FINGERPRINTS = \"${__RootfsDir}/usr/share/keys\"; REPOS_DIR = [\"${__RootfsDir}/etc/pkg\"]; REPO_AUTOUPDATE = NO; RUN_SCRIPTS = NO;" > "${__RootfsDir}"/usr/local/etc/pkg.conf
echo "FreeBSD: { url: \"pkg+http://pkg.FreeBSD.org/\${ABI}/quarterly\", mirror_type: \"srv\", signature_type: \"fingerprints\", fingerprints: \"${__RootfsDir}/usr/share/keys/pkg\", enabled: yes }" > "${__RootfsDir}"/etc/pkg/FreeBSD.conf
mkdir -p "$__RootfsDir"/tmp
# get and build package manager
wget -O - https://github.com/freebsd/pkg/archive/${__FreeBSDPkg}.tar.gz | tar -C $__RootfsDir/tmp -zxf -
cd $__RootfsDir/tmp/pkg-${__FreeBSDPkg}
wget -O - "https://github.com/freebsd/pkg/archive/${__FreeBSDPkg}.tar.gz" | tar -C "$__RootfsDir"/tmp -zxf -
cd "$__RootfsDir/tmp/pkg-${__FreeBSDPkg}"
# needed for install to succeed
mkdir -p $__RootfsDir/host/etc
./autogen.sh && ./configure --prefix=$__RootfsDir/host && make -j "$JOBS" && make install
rm -rf $__RootfsDir/tmp/pkg-${__FreeBSDPkg}
mkdir -p "$__RootfsDir"/host/etc
./autogen.sh && ./configure --prefix="$__RootfsDir"/host && make -j "$JOBS" && make install
rm -rf "$__RootfsDir/tmp/pkg-${__FreeBSDPkg}"
# install packages we need.
INSTALL_AS_USER=$(whoami) $__RootfsDir/host/sbin/pkg -r $__RootfsDir -C $__RootfsDir/usr/local/etc/pkg.conf update
INSTALL_AS_USER=$(whoami) $__RootfsDir/host/sbin/pkg -r $__RootfsDir -C $__RootfsDir/usr/local/etc/pkg.conf install --yes $__FreeBSDPackages
INSTALL_AS_USER=$(whoami) "$__RootfsDir"/host/sbin/pkg -r "$__RootfsDir" -C "$__RootfsDir"/usr/local/etc/pkg.conf update
INSTALL_AS_USER=$(whoami) "$__RootfsDir"/host/sbin/pkg -r "$__RootfsDir" -C "$__RootfsDir"/usr/local/etc/pkg.conf install --yes $__FreeBSDPackages
elif [[ "$__CodeName" == "illumos" ]]; then
mkdir "$__RootfsDir/tmp"
pushd "$__RootfsDir/tmp"
JOBS="$(getconf _NPROCESSORS_ONLN)"
JOBS=${MAXJOBS:="$(getconf _NPROCESSORS_ONLN)"}
echo "Downloading sysroot."
wget -O - https://github.com/illumos/sysroot/releases/download/20181213-de6af22ae73b-v1/illumos-sysroot-i386-20181213-de6af22ae73b-v1.tar.gz | tar -C "$__RootfsDir" -xzf -
echo "Building binutils. Please wait.."
wget -O - https://ftp.gnu.org/gnu/binutils/binutils-2.33.1.tar.bz2 | tar -xjf -
mkdir build-binutils && cd build-binutils
../binutils-2.33.1/configure --prefix="$__RootfsDir" --target="x86_64-sun-solaris2.10" --program-prefix="x86_64-illumos-" --with-sysroot="$__RootfsDir"
../binutils-2.33.1/configure --prefix="$__RootfsDir" --target="${__illumosArch}-sun-solaris2.10" --program-prefix="${__illumosArch}-illumos-" --with-sysroot="$__RootfsDir"
make -j "$JOBS" && make install && cd ..
echo "Building gcc. Please wait.."
wget -O - https://ftp.gnu.org/gnu/gcc/gcc-8.4.0/gcc-8.4.0.tar.xz | tar -xJf -
@ -345,7 +382,7 @@ elif [[ "$__CodeName" == "illumos" ]]; then
CFLAGS_FOR_TARGET="-fPIC"
export CFLAGS CXXFLAGS CXXFLAGS_FOR_TARGET CFLAGS_FOR_TARGET
mkdir build-gcc && cd build-gcc
../gcc-8.4.0/configure --prefix="$__RootfsDir" --target="x86_64-sun-solaris2.10" --program-prefix="x86_64-illumos-" --with-sysroot="$__RootfsDir" --with-gnu-as \
../gcc-8.4.0/configure --prefix="$__RootfsDir" --target="${__illumosArch}-sun-solaris2.10" --program-prefix="${__illumosArch}-illumos-" --with-sysroot="$__RootfsDir" --with-gnu-as \
--with-gnu-ld --disable-nls --disable-libgomp --disable-libquadmath --disable-libssp --disable-libvtv --disable-libcilkrts --disable-libada --disable-libsanitizer \
--disable-libquadmath-support --disable-shared --enable-tls
make -j "$JOBS" && make install && cd ..
@ -353,7 +390,7 @@ elif [[ "$__CodeName" == "illumos" ]]; then
if [[ "$__UseMirror" == 1 ]]; then
BaseUrl=http://pkgsrc.smartos.skylime.net
fi
BaseUrl="$BaseUrl"/packages/SmartOS/2020Q1/x86_64/All
BaseUrl="$BaseUrl/packages/SmartOS/2020Q1/${__illumosArch}/All"
echo "Downloading dependencies."
read -ra array <<<"$__IllumosPackages"
for package in "${array[@]}"; do
@ -371,26 +408,90 @@ elif [[ "$__CodeName" == "illumos" ]]; then
wget -P "$__RootfsDir"/usr/include/net https://raw.githubusercontent.com/illumos/illumos-gate/master/usr/src/uts/common/io/bpf/net/dlt.h
wget -P "$__RootfsDir"/usr/include/netpacket https://raw.githubusercontent.com/illumos/illumos-gate/master/usr/src/uts/common/inet/sockmods/netpacket/packet.h
wget -P "$__RootfsDir"/usr/include/sys https://raw.githubusercontent.com/illumos/illumos-gate/master/usr/src/uts/common/sys/sdt.h
elif [[ -n $__CodeName ]]; then
qemu-debootstrap $__Keyring --arch $__UbuntuArch $__CodeName $__RootfsDir $__UbuntuRepo
cp $__CrossDir/$__BuildArch/sources.list.$__CodeName $__RootfsDir/etc/apt/sources.list
chroot $__RootfsDir apt-get update
chroot $__RootfsDir apt-get -f -y install
chroot $__RootfsDir apt-get -y install $__UbuntuPackages
chroot $__RootfsDir symlinks -cr /usr
chroot $__RootfsDir apt-get clean
elif [[ "$__CodeName" == "haiku" ]]; then
JOBS=${MAXJOBS:="$(getconf _NPROCESSORS_ONLN)"}
if [ $__SkipUnmount == 0 ]; then
umount $__RootfsDir/* || true
echo "Building Haiku sysroot for x86_64"
mkdir -p "$__RootfsDir/tmp"
cd "$__RootfsDir/tmp"
git clone -b hrev56235 https://review.haiku-os.org/haiku
git clone -b btrev43195 https://review.haiku-os.org/buildtools
cd "$__RootfsDir/tmp/buildtools" && git checkout 7487388f5110021d400b9f3b88e1a7f310dc066d
# Fetch some unmerged patches
cd "$__RootfsDir/tmp/haiku"
## Add development build profile (slimmer than nightly)
git fetch origin refs/changes/64/4164/1 && git -c commit.gpgsign=false cherry-pick FETCH_HEAD
# Build jam
cd "$__RootfsDir/tmp/buildtools/jam"
make
# Configure cross tools
echo "Building cross-compiler"
mkdir -p "$__RootfsDir/generated"
cd "$__RootfsDir/generated"
"$__RootfsDir/tmp/haiku/configure" -j"$JOBS" --sysroot "$__RootfsDir" --cross-tools-source "$__RootfsDir/tmp/buildtools" --build-cross-tools x86_64
# Build Haiku packages
echo "Building Haiku"
echo 'HAIKU_BUILD_PROFILE = "development-raw" ;' > UserProfileConfig
"$__RootfsDir/tmp/buildtools/jam/jam0" -j"$JOBS" -q '<build>package' '<repository>Haiku'
BaseUrl="https://depot.haiku-os.org/__api/v2/pkg/get-pkg"
# Download additional packages
echo "Downloading additional required packages"
read -ra array <<<"$__HaikuPackages"
for package in "${array[@]}"; do
echo "Downloading $package..."
# API documented here: https://github.com/haiku/haikudepotserver/blob/master/haikudepotserver-api2/src/main/resources/api2/pkg.yaml#L60
# The schema here: https://github.com/haiku/haikudepotserver/blob/master/haikudepotserver-api2/src/main/resources/api2/pkg.yaml#L598
hpkgDownloadUrl="$(wget -qO- --post-data='{"name":"'"$package"'","repositorySourceCode":"haikuports_x86_64","versionType":"LATEST","naturalLanguageCode":"en"}' \
--header='Content-Type:application/json' "$BaseUrl" | jq -r '.result.versions[].hpkgDownloadURL')"
wget -P "$__RootfsDir/generated/download" "$hpkgDownloadUrl"
done
# Setup the sysroot
echo "Setting up sysroot and extracting needed packages"
mkdir -p "$__RootfsDir/boot/system"
for file in "$__RootfsDir/generated/objects/haiku/x86_64/packaging/packages/"*.hpkg; do
"$__RootfsDir/generated/objects/linux/x86_64/release/tools/package/package" extract -C "$__RootfsDir/boot/system" "$file"
done
for file in "$__RootfsDir/generated/download/"*.hpkg; do
"$__RootfsDir/generated/objects/linux/x86_64/release/tools/package/package" extract -C "$__RootfsDir/boot/system" "$file"
done
# Cleaning up temporary files
echo "Cleaning up temporary files"
rm -rf "$__RootfsDir/tmp"
for name in "$__RootfsDir/generated/"*; do
if [[ "$name" =~ "cross-tools-" ]]; then
: # Keep the cross-compiler
else
rm -rf "$name"
fi
done
elif [[ -n "$__CodeName" ]]; then
qemu-debootstrap $__Keyring --arch "$__UbuntuArch" "$__CodeName" "$__RootfsDir" "$__UbuntuRepo"
cp "$__CrossDir/$__BuildArch/sources.list.$__CodeName" "$__RootfsDir/etc/apt/sources.list"
chroot "$__RootfsDir" apt-get update
chroot "$__RootfsDir" apt-get -f -y install
chroot "$__RootfsDir" apt-get -y install $__UbuntuPackages
chroot "$__RootfsDir" symlinks -cr /usr
chroot "$__RootfsDir" apt-get clean
if [[ "$__SkipUnmount" == "0" ]]; then
umount "$__RootfsDir"/* || true
fi
if [[ "$__BuildArch" == "armel" && "$__CodeName" == "jessie" ]]; then
pushd $__RootfsDir
patch -p1 < $__CrossDir/$__BuildArch/armel.jessie.patch
pushd "$__RootfsDir"
patch -p1 < "$__CrossDir/$__BuildArch/armel.jessie.patch"
popd
fi
elif [[ "$__Tizen" == "tizen" ]]; then
ROOTFS_DIR=$__RootfsDir $__CrossDir/$__BuildArch/tizen-build-rootfs.sh
ROOTFS_DIR="$__RootfsDir" "$__CrossDir/$__BuildArch/tizen-build-rootfs.sh"
else
echo "Unsupported target platform."
usage;

1
eng/common/cross/riscv64/sources.list.sid Normal file
Просмотреть файл

@ -0,0 +1 @@
deb http://deb.debian.org/debian-ports sid main

100
eng/common/cross/toolchain.cmake
Просмотреть файл

@ -7,6 +7,8 @@ if(EXISTS ${CROSS_ROOTFS}/bin/freebsd-version)
elseif(EXISTS ${CROSS_ROOTFS}/usr/platform/i86pc)
set(CMAKE_SYSTEM_NAME SunOS)
set(ILLUMOS 1)
elseif(EXISTS ${CROSS_ROOTFS}/boot/system/develop/headers/config/HaikuConfig.h)
set(CMAKE_SYSTEM_NAME Haiku)
else()
set(CMAKE_SYSTEM_NAME Linux)
set(LINUX 1)
@ -19,13 +21,7 @@ elseif(EXISTS ${CROSS_ROOTFS}/android_platform)
set(ANDROID 1)
endif()
if(TARGET_ARCH_NAME STREQUAL "armel")
set(CMAKE_SYSTEM_PROCESSOR armv7l)
set(TOOLCHAIN "arm-linux-gnueabi")
if(TIZEN)
set(TIZEN_TOOLCHAIN "armv7l-tizen-linux-gnueabi/9.2.0")
endif()
elseif(TARGET_ARCH_NAME STREQUAL "arm")
if(TARGET_ARCH_NAME STREQUAL "arm")
set(CMAKE_SYSTEM_PROCESSOR armv7l)
if(EXISTS ${CROSS_ROOTFS}/usr/lib/gcc/armv7-alpine-linux-musleabihf)
set(TOOLCHAIN "armv7-alpine-linux-musleabihf")
@ -37,6 +33,24 @@ elseif(TARGET_ARCH_NAME STREQUAL "arm")
if(TIZEN)
set(TIZEN_TOOLCHAIN "armv7hl-tizen-linux-gnueabihf/9.2.0")
endif()
elseif(TARGET_ARCH_NAME STREQUAL "arm64")
set(CMAKE_SYSTEM_PROCESSOR aarch64)
if(EXISTS ${CROSS_ROOTFS}/usr/lib/gcc/aarch64-alpine-linux-musl)
set(TOOLCHAIN "aarch64-alpine-linux-musl")
elseif(LINUX)
set(TOOLCHAIN "aarch64-linux-gnu")
if(TIZEN)
set(TIZEN_TOOLCHAIN "aarch64-tizen-linux-gnu/9.2.0")
endif()
elseif(FREEBSD)
set(triple "aarch64-unknown-freebsd12")
endif()
elseif(TARGET_ARCH_NAME STREQUAL "armel")
set(CMAKE_SYSTEM_PROCESSOR armv7l)
set(TOOLCHAIN "arm-linux-gnueabi")
if(TIZEN)
set(TIZEN_TOOLCHAIN "armv7l-tizen-linux-gnueabi/9.2.0")
endif()
elseif(TARGET_ARCH_NAME STREQUAL "armv6")
set(CMAKE_SYSTEM_PROCESSOR armv6l)
if(EXISTS ${CROSS_ROOTFS}/usr/lib/gcc/armv6-alpine-linux-musleabihf)
@ -44,36 +58,37 @@ elseif(TARGET_ARCH_NAME STREQUAL "armv6")
else()
set(TOOLCHAIN "arm-linux-gnueabihf")
endif()
elseif(TARGET_ARCH_NAME STREQUAL "arm64")
set(CMAKE_SYSTEM_PROCESSOR aarch64)
if(EXISTS ${CROSS_ROOTFS}/usr/lib/gcc/aarch64-alpine-linux-musl)
set(TOOLCHAIN "aarch64-alpine-linux-musl")
else()
set(TOOLCHAIN "aarch64-linux-gnu")
endif()
if(TIZEN)
set(TIZEN_TOOLCHAIN "aarch64-tizen-linux-gnu/9.2.0")
endif()
elseif(TARGET_ARCH_NAME STREQUAL "ppc64le")
set(CMAKE_SYSTEM_PROCESSOR ppc64le)
set(TOOLCHAIN "powerpc64le-linux-gnu")
elseif(TARGET_ARCH_NAME STREQUAL "riscv64")
set(CMAKE_SYSTEM_PROCESSOR riscv64)
set(TOOLCHAIN "riscv64-linux-gnu")
elseif(TARGET_ARCH_NAME STREQUAL "s390x")
set(CMAKE_SYSTEM_PROCESSOR s390x)
set(TOOLCHAIN "s390x-linux-gnu")
elseif(TARGET_ARCH_NAME STREQUAL "x64")
set(CMAKE_SYSTEM_PROCESSOR x86_64)
if(LINUX)
set(TOOLCHAIN "x86_64-linux-gnu")
if(TIZEN)
set(TIZEN_TOOLCHAIN "x86_64-tizen-linux-gnu/9.2.0")
endif()
elseif(FREEBSD)
set(triple "x86_64-unknown-freebsd12")
elseif(ILLUMOS)
set(TOOLCHAIN "x86_64-illumos")
elseif(HAIKU)
set(TOOLCHAIN "x64_64-unknown-haiku")
endif()
elseif(TARGET_ARCH_NAME STREQUAL "x86")
set(CMAKE_SYSTEM_PROCESSOR i686)
set(TOOLCHAIN "i686-linux-gnu")
if(TIZEN)
set(TIZEN_TOOLCHAIN "i586-tizen-linux-gnu/9.2.0")
endif()
elseif (FREEBSD)
set(CMAKE_SYSTEM_PROCESSOR "x86_64")
set(triple "x86_64-unknown-freebsd12")
elseif (ILLUMOS)
set(CMAKE_SYSTEM_PROCESSOR "x86_64")
set(TOOLCHAIN "x86_64-illumos")
else()
message(FATAL_ERROR "Arch is ${TARGET_ARCH_NAME}. Only armel, arm, armv6, arm64, ppc64le, s390x and x86 are supported!")
message(FATAL_ERROR "Arch is ${TARGET_ARCH_NAME}. Only arm, arm64, armel, armv6, ppc64le, riscv64, s390x, x64 and x86 are supported!")
endif()
if(DEFINED ENV{TOOLCHAIN})
@ -159,6 +174,41 @@ elseif(ILLUMOS)
set(CMAKE_C_STANDARD_LIBRARIES "${CMAKE_C_STANDARD_LIBRARIES} -lssp")
set(CMAKE_CXX_STANDARD_LIBRARIES "${CMAKE_CXX_STANDARD_LIBRARIES} -lssp")
elseif(HAIKU)
set(CMAKE_SYSROOT "${CROSS_ROOTFS}")
set(TOOLSET_PREFIX ${TOOLCHAIN}-)
function(locate_toolchain_exec exec var)
string(TOUPPER ${exec} EXEC_UPPERCASE)
if(NOT "$ENV{CLR_${EXEC_UPPERCASE}}" STREQUAL "")
set(${var} "$ENV{CLR_${EXEC_UPPERCASE}}" PARENT_SCOPE)
return()
endif()
set(SEARCH_PATH "${CROSS_ROOTFS}/generated/cross-tools-x86_64/bin")
find_program(EXEC_LOCATION_${exec}
PATHS ${SEARCH_PATH}
NAMES
"${TOOLSET_PREFIX}${exec}${CLR_CMAKE_COMPILER_FILE_NAME_VERSION}"
"${TOOLSET_PREFIX}${exec}")
if (EXEC_LOCATION_${exec} STREQUAL "EXEC_LOCATION_${exec}-NOTFOUND")
message(FATAL_ERROR "Unable to find toolchain executable. Name: ${exec}, Prefix: ${TOOLSET_PREFIX}.")
endif()
set(${var} ${EXEC_LOCATION_${exec}} PARENT_SCOPE)
endfunction()
set(CMAKE_SYSTEM_PREFIX_PATH "${CROSS_ROOTFS}")
locate_toolchain_exec(gcc CMAKE_C_COMPILER)
locate_toolchain_exec(g++ CMAKE_CXX_COMPILER)
set(CMAKE_C_STANDARD_LIBRARIES "${CMAKE_C_STANDARD_LIBRARIES} -lssp")
set(CMAKE_CXX_STANDARD_LIBRARIES "${CMAKE_CXX_STANDARD_LIBRARIES} -lssp")
# let CMake set up the correct search paths
include(Platform/Haiku)
else()
set(CMAKE_SYSROOT "${CROSS_ROOTFS}")
@ -218,7 +268,7 @@ endif()
# Specify compile options
if((TARGET_ARCH_NAME MATCHES "^(arm|armv6|armel|arm64|ppc64le|s390x)$" AND NOT ANDROID) OR ILLUMOS)
if((TARGET_ARCH_NAME MATCHES "^(arm|arm64|armel|armv6|ppc64le|riscv64|s390x)$" AND NOT ANDROID AND NOT FREEBSD) OR ILLUMOS OR HAIKU)
set(CMAKE_C_COMPILER_TARGET ${TOOLCHAIN})
set(CMAKE_CXX_COMPILER_TARGET ${TOOLCHAIN})
set(CMAKE_ASM_COMPILER_TARGET ${TOOLCHAIN})

14
eng/common/generate-locproject.ps1
Просмотреть файл

@ -10,9 +10,7 @@ Param(
Set-StrictMode -Version 2.0
$ErrorActionPreference = "Stop"
. $PSScriptRoot\tools.ps1
Import-Module -Name (Join-Path $PSScriptRoot 'native\CommonLibrary.psm1')
. $PSScriptRoot\pipeline-logging-functions.ps1
$exclusionsFilePath = "$SourcesDirectory\eng\Localize\LocExclusions.json"
$exclusions = @{ Exclusions = @() }
@ -28,7 +26,7 @@ $jsonFiles = @()
$jsonTemplateFiles = Get-ChildItem -Recurse -Path "$SourcesDirectory" | Where-Object { $_.FullName -Match "\.template\.config\\localize\\.+\.en\.json" } # .NET templating pattern
$jsonTemplateFiles | ForEach-Object {
$null = $_.Name -Match "(.+)\.[\w-]+\.json" # matches '[filename].[langcode].json
$destinationFile = "$($_.Directory.FullName)\$($Matches.1).json"
$jsonFiles += Copy-Item "$($_.FullName)" -Destination $destinationFile -PassThru
}
@ -46,7 +44,7 @@ if ($allXlfFiles) {
}
$langXlfFiles | ForEach-Object {
$null = $_.Name -Match "(.+)\.[\w-]+\.xlf" # matches '[filename].[langcode].xlf
$destinationFile = "$($_.Directory.FullName)\$($Matches.1).xlf"
$xlfFiles += Copy-Item "$($_.FullName)" -Destination $destinationFile -PassThru
}
@ -59,7 +57,7 @@ $locJson = @{
LanguageSet = $LanguageSet
LocItems = @(
$locFiles | ForEach-Object {
$outputPath = "$(($_.DirectoryName | Resolve-Path -Relative) + "\")"
$outputPath = "$(($_.DirectoryName | Resolve-Path -Relative) + "\")"
$continue = $true
foreach ($exclusion in $exclusions.Exclusions) {
if ($outputPath.Contains($exclusion))
@ -108,10 +106,10 @@ else {
if ((Get-FileHash "$SourcesDirectory\eng\Localize\LocProject-generated.json").Hash -ne (Get-FileHash "$SourcesDirectory\eng\Localize\LocProject.json").Hash) {
Write-PipelineTelemetryError -Category "OneLocBuild" -Message "Existing LocProject.json differs from generated LocProject.json. Download LocProject-generated.json and compare them."
exit 1
}
else {
Write-Host "Generated LocProject.json and current LocProject.json are identical."
}
}
}

2
eng/common/generate-sbom-prep.ps1
Просмотреть файл

@ -2,6 +2,8 @@ Param(
[Parameter(Mandatory=$true)][string] $ManifestDirPath # Manifest directory where sbom will be placed
)
. $PSScriptRoot\pipeline-logging-functions.ps1
Write-Host "Creating dir $ManifestDirPath"
# create directory for sbom manifest to be placed
if (!(Test-Path -path $ManifestDirPath))

12
eng/common/generate-sbom-prep.sh
Просмотреть файл

@ -2,6 +2,18 @@
source="${BASH_SOURCE[0]}"
# resolve $SOURCE until the file is no longer a symlink
while [[ -h $source ]]; do
scriptroot="$( cd -P "$( dirname "$source" )" && pwd )"
source="$(readlink "$source")"
# if $source was a relative symlink, we need to resolve it relative to the path where the
# symlink file was located
[[ $source != /* ]] && source="$scriptroot/$source"
done
scriptroot="$( cd -P "$( dirname "$source" )" && pwd )"
. $scriptroot/pipeline-logging-functions.sh
manifest_dir=$1
if [ ! -d "$manifest_dir" ] ; then

4
eng/common/init-tools-native.ps1
Просмотреть файл

@ -87,6 +87,7 @@ try {
$NativeTools.PSObject.Properties | ForEach-Object {
$ToolName = $_.Name
$ToolVersion = $_.Value
$InstalledTools = @{}
if ((Get-Command "$ToolName" -ErrorAction SilentlyContinue) -eq $null) {
if ($ToolVersion -eq "latest") {
@ -111,9 +112,10 @@ try {
$ToolPath = Convert-Path -Path $BinPath
Write-Host "Adding $ToolName to the path ($ToolPath)..."
Write-Host "##vso[task.prependpath]$ToolPath"
$InstalledTools += @{ $ToolName = $ToolDirectory.FullName }
}
}
exit 0
return $InstalledTools
} else {
$NativeTools.PSObject.Properties | ForEach-Object {
$ToolName = $_.Name

2
eng/common/native/init-compiler.sh
Просмотреть файл

@ -71,7 +71,7 @@ if [[ -z "$CLR_CC" ]]; then
# Set default versions
if [[ -z "$majorVersion" ]]; then
# note: gcc (all versions) and clang versions higher than 6 do not have minor version in file name, if it is zero.
if [[ "$compiler" == "clang" ]]; then versions=( 13 12 11 10 9 8 7 6.0 5.0 4.0 3.9 3.8 3.7 3.6 3.5 )
if [[ "$compiler" == "clang" ]]; then versions=( 15 14 13 12 11 10 9 8 7 6.0 5.0 4.0 3.9 3.8 3.7 3.6 3.5 )
elif [[ "$compiler" == "gcc" ]]; then versions=( 12 11 10 9 8 7 6 5 4.9 ); fi
for version in "${versions[@]}"; do

2
eng/common/templates/job/execute-sdl.yml
Просмотреть файл

@ -54,7 +54,7 @@ jobs:
# If it's not devdiv, it's dnceng
${{ if ne(variables['System.TeamProject'], 'DevDiv') }}:
name: NetCore1ESPool-Internal
demands: ImageOverride -equals Build.Server.Amd64.VS2019
demands: ImageOverride -equals windows.vs2019.amd64
steps:
- checkout: self
clean: true

2
eng/common/templates/job/onelocbuild.yml
Просмотреть файл

@ -41,7 +41,7 @@ jobs:
# If it's not devdiv, it's dnceng
${{ if ne(variables['System.TeamProject'], 'DevDiv') }}:
name: NetCore1ESPool-Internal
demands: ImageOverride -equals Build.Server.Amd64.VS2019
demands: ImageOverride -equals windows.vs2019.amd64
variables:
- group: OneLocBuildVariables # Contains the CeapexPat and GithubPat

6
eng/common/templates/job/source-index-stage1.yml
Просмотреть файл

@ -1,6 +1,6 @@
parameters:
runAsPublic: false
sourceIndexPackageVersion: 1.0.1-20210614.1
sourceIndexPackageVersion: 1.0.1-20220804.1
sourceIndexPackageSource: https://pkgs.dev.azure.com/dnceng/public/_packaging/dotnet-tools/nuget/v3/index.json
sourceIndexBuildCommand: powershell -NoLogo -NoProfile -ExecutionPolicy Bypass -Command "eng/common/build.ps1 -restore -build -binarylog -ci"
preSteps: []
@ -29,10 +29,10 @@ jobs:
pool:
${{ if eq(variables['System.TeamProject'], 'public') }}:
name: NetCore1ESPool-Public
demands: ImageOverride -equals Build.Server.Amd64.VS2019.Open
demands: ImageOverride -equals windows.vs2019.amd64.open
${{ if eq(variables['System.TeamProject'], 'internal') }}:
name: NetCore1ESPool-Internal
demands: ImageOverride -equals Build.Server.Amd64.VS2019
demands: ImageOverride -equals windows.vs2019.amd64
steps:
- ${{ each preStep in parameters.preSteps }}:

2
eng/common/templates/jobs/jobs.yml
Просмотреть файл

@ -96,7 +96,7 @@ jobs:
# If it's not devdiv, it's dnceng
${{ if ne(variables['System.TeamProject'], 'DevDiv') }}:
name: NetCore1ESPool-Internal
demands: ImageOverride -equals Build.Server.Amd64.VS2019
demands: ImageOverride -equals windows.vs2019.amd64
runAsPublic: ${{ parameters.runAsPublic }}
publishUsingPipelines: ${{ parameters.enablePublishUsingPipelines }}

10
eng/common/templates/post-build/post-build.yml
Просмотреть файл

@ -49,6 +49,7 @@ parameters:
type: object
default:
enable: false
publishGdn: false
continueOnError: false
params: ''
artifactNames: ''
@ -106,7 +107,7 @@ stages:
# If it's not devdiv, it's dnceng
${{ else }}:
name: NetCore1ESPool-Internal
demands: ImageOverride -equals Build.Server.Amd64.VS2019
demands: ImageOverride -equals windows.vs2019.amd64
steps:
- template: setup-maestro-vars.yml
@ -143,7 +144,7 @@ stages:
# If it's not devdiv, it's dnceng
${{ else }}:
name: NetCore1ESPool-Internal
demands: ImageOverride -equals Build.Server.Amd64.VS2019
demands: ImageOverride -equals windows.vs2019.amd64
steps:
- template: setup-maestro-vars.yml
parameters:
@ -203,7 +204,7 @@ stages:
# If it's not devdiv, it's dnceng
${{ else }}:
name: NetCore1ESPool-Internal
demands: ImageOverride -equals Build.Server.Amd64.VS2019
demands: ImageOverride -equals windows.vs2019.amd64
steps:
- template: setup-maestro-vars.yml
parameters:
@ -235,6 +236,7 @@ stages:
- template: /eng/common/templates/job/execute-sdl.yml
parameters:
enable: ${{ parameters.SDLValidationParameters.enable }}
publishGuardianDirectoryToPipeline: ${{ parameters.SDLValidationParameters.publishGdn }}
additionalParameters: ${{ parameters.SDLValidationParameters.params }}
continueOnError: ${{ parameters.SDLValidationParameters.continueOnError }}
artifactNames: ${{ parameters.SDLValidationParameters.artifactNames }}
@ -261,7 +263,7 @@ stages:
# If it's not devdiv, it's dnceng
${{ else }}:
name: NetCore1ESPool-Internal
demands: ImageOverride -equals Build.Server.Amd64.VS2019
demands: ImageOverride -equals windows.vs2019.amd64
steps:
- template: setup-maestro-vars.yml
parameters:

21
eng/common/templates/steps/execute-sdl.yml
Просмотреть файл

@ -62,7 +62,28 @@ steps:
c
i
condition: succeededOrFailed()
- publish: $(Agent.BuildDirectory)/.gdn
artifact: GuardianConfiguration
displayName: Publish GuardianConfiguration
condition: succeededOrFailed()
# Publish the SARIF files in a container named CodeAnalysisLogs to enable integration
# with the "SARIF SAST Scans Tab" Azure DevOps extension
- task: CopyFiles@2
displayName: Copy SARIF files
inputs:
flattenFolders: true
sourceFolder: $(Agent.BuildDirectory)/.gdn/rc/
contents: '**/*.sarif'
targetFolder: $(Build.SourcesDirectory)/CodeAnalysisLogs
condition: succeededOrFailed()
# Use PublishBuildArtifacts because the SARIF extension only checks this case
# see microsoft/sarif-azuredevops-extension#4
- task: PublishBuildArtifacts@1
displayName: Publish SARIF files to CodeAnalysisLogs container
inputs:
pathToPublish: $(Build.SourcesDirectory)/CodeAnalysisLogs
artifactName: CodeAnalysisLogs
condition: succeededOrFailed()

11
eng/common/tools.ps1
Просмотреть файл

@ -368,7 +368,14 @@ function InitializeVisualStudioMSBuild([bool]$install, [object]$vsRequirements =
# https://dev.azure.com/dnceng/public/_packaging?_a=package&feed=dotnet-eng&package=RoslynTools.MSBuild&protocolType=NuGet&version=17.1.0&view=overview
$defaultXCopyMSBuildVersion = '17.1.0'
if (!$vsRequirements) { $vsRequirements = $GlobalJson.tools.vs }
if (!$vsRequirements) {
if (Get-Member -InputObject $GlobalJson.tools -Name 'vs') {
$vsRequirements = $GlobalJson.tools.vs
}
else {
$vsRequirements = New-Object PSObject -Property @{ version = $vsMinVersionReqdStr }
}
}
$vsMinVersionStr = if ($vsRequirements.version) { $vsRequirements.version } else { $vsMinVersionReqdStr }
$vsMinVersion = [Version]::new($vsMinVersionStr)
@ -635,7 +642,7 @@ function InitializeNativeTools() {
InstallDirectory = "$ToolsDir"
}
}
if (Test-Path variable:NativeToolsOnMachine) {
if ($env:NativeToolsOnMachine) {
Write-Host "Variable NativeToolsOnMachine detected, enabling native tool path promotion..."
$nativeArgs += @{ PathPromotion = $true }
}

20
eng/policheck_exclusions.xml Normal file
Просмотреть файл

@ -0,0 +1,20 @@
<PoliCheckExclusions>
<!-- All strings must be UPPER CASE -->
<!--Each of these exclusions is a folder name -if \[name]\exists in the file path, it will be skipped -->
<!--<Exclusion Type="FolderPathFull">ABC|XYZ</Exclusion>-->
<!--Each of these exclusions is a folder name -if any folder or file starts with "\[name]", it will be skipped -->
<!--<Exclusion Type="FolderPathStart">ABC|XYZ</Exclusion>-->
<!--Each of these file types will be completely skipped for the entire scan -->
<!--<Exclusion Type="FileType">.ABC|.XYZ</Exclusion>-->
<!--The specified file names will be skipped during the scan regardless which folder they are in -->
<!--<Exclusion Type="FileName">ABC.TXT|XYZ.CS</Exclusion>-->
<Exclusion Type="FileName">RELEASE-NOTES.MD</Exclusion>
<Exclusion Type="FileName">DEBUG-EMIT.MD</Exclusion>
<Exclusion Type="FileName">PRINTF.FSI</Exclusion>
<Exclusion Type="FileName">CHECKFORMATSTRINGS.FS</Exclusion>
<Exclusion Type="FileName">TUTORIAL.FSX</Exclusion>
<Exclusion Type="FileName">TUTORIAL.FSX.ES.XLF</Exclusion>
<Exclusion Type="FileName">TUTORIAL.FSX.FR.XLF</Exclusion>
<Exclusion Type="FileName">TUTORIAL.FSX.PT-BR.XLF</Exclusion>
</PoliCheckExclusions>

75
fcs-samples/FscExe/FscMain.fs
Просмотреть файл

@ -8,7 +8,6 @@ open System.IO
open System.Reflection
open System.Runtime.CompilerServices
open FSharp.Compiler.SourceCodeServices
open FSharp.Compiler.AbstractIL.Utils // runningOnMono
open FSharp.Compiler.AbstractIL.Library
open FSharp.Compiler.ErrorLogger
@ -51,17 +50,9 @@ module FSharpResidentCompiler =
static let userName = Environment.GetEnvironmentVariable (if onWindows then "USERNAME" else "USER")
// Use different base channel names on mono and CLR as a CLR remoting process can't talk
// to a mono server
static let baseChannelName =
if runningOnMono then
"FSCChannelMono"
else
"FSCChannel"
static let baseChannelName = "FSCChannel"
static let channelName = baseChannelName + "_" + domainName + "_" + userName
static let serverName =
if runningOnMono then
"FSCServerMono"
else
"FSCSever"
static let serverName = "FSCSever"
static let mutable serverExists = true
let outputCollector = new OutputCollector()
@ -119,30 +110,8 @@ module FSharpResidentCompiler =
ChannelServices.RegisterChannel(chan,false);
RemotingServices.Marshal(server,serverName) |> ignore
// On Unix, the file permissions of the implicit socket need to be set correctly to make this
// private to the user.
if runningOnMono then
try
let monoPosix = System.Reflection.Assembly.Load(new System.Reflection.AssemblyName("Mono.Posix, Version=2.0.0.0, Culture=neutral, PublicKeyToken=0738eb9f132ed756"))
let monoUnixFileInfo = monoPosix.GetType("Mono.Unix.UnixFileSystemInfo")
let socketName = Path.Combine(FileSystem.GetTempPathShim(), channelName)
let fileEntry = monoUnixFileInfo.InvokeMember("GetFileSystemEntry", (BindingFlags.InvokeMethod ||| BindingFlags.Static ||| BindingFlags.Public), null, null, [| box socketName |],System.Globalization.CultureInfo.InvariantCulture)
// Add 0x00000180 (UserReadWriteExecute) to the access permissions on Unix
monoUnixFileInfo.InvokeMember("set_FileAccessPermissions", (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), null, fileEntry, [| box 0x00000180 |],System.Globalization.CultureInfo.InvariantCulture) |> ignore
#if DEBUG
if !progress then printfn "server: good, set permissions on socket name '%s'" socketName
let fileEntry = monoUnixFileInfo.InvokeMember("GetFileSystemEntry", (BindingFlags.InvokeMethod ||| BindingFlags.Static ||| BindingFlags.Public), null, null, [| box socketName |],System.Globalization.CultureInfo.InvariantCulture)
let currPermissions = monoUnixFileInfo.InvokeMember("get_FileAccessPermissions", (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), null, fileEntry, [| |],System.Globalization.CultureInfo.InvariantCulture) |> unbox<int>
if !progress then printfn "server: currPermissions = '%o' (octal)" currPermissions
#endif
with e ->
#if DEBUG
printfn "server: failed to set permissions on socket, perhaps on windows? Is is not needed there."
#endif
()
// Fail silently
server.Run()
static member private ConnectToServer() =
Activator.GetObject(typeof<FSharpCompilationServer>,"ipc://" + channelName + "/" + serverName)
:?> FSharpCompilationServer
@ -164,27 +133,11 @@ module FSharpResidentCompiler =
Some client
with _ ->
if !progress then printfn "client: error while creating client, starting client instead"
let procInfo =
if runningOnMono then
let shellName, useShellExecute =
match System.Environment.GetEnvironmentVariable("FSC_MONO") with
| null ->
if onWindows then
// e.g. "C:\Program Files\Mono-2.6.1\lib\mono\2.0\mscorlib.dll" --> "C:\Program Files\Mono-2.6.1\bin\mono.exe"
Path.Combine(Path.GetDirectoryName (typeof<Object>.Assembly.Location), @"..\..\..\bin\mono.exe"), false
else
"mono-sgen", true
| path -> path, true
ProcessStartInfo(FileName = shellName,
Arguments = fscServerExe + " /server",
CreateNoWindow = true,
UseShellExecute = useShellExecute)
else
ProcessStartInfo(FileName=fscServerExe,
Arguments = "/server",
CreateNoWindow = true,
UseShellExecute = false)
let procInfo =
ProcessStartInfo(FileName=fscServerExe,
Arguments = "/server",
CreateNoWindow = true,
UseShellExecute = false)
let cmdProcess = new Process(StartInfo=procInfo)
//let exitE = cmdProcess.Exited |> Observable.map (fun x -> x)
@ -261,7 +214,7 @@ module Driver =
System.Console.ReadKey() |> ignore
#if RESIDENT_COMPILER
if runningOnMono && hasArgument "resident" argv then
if hasArgument "resident" argv then
let argv = stripArgument "resident" argv
let fscServerExe = typeof<TypeInThisAssembly>.Assembly.Location
@ -272,10 +225,6 @@ module Driver =
let errors, exitCode = FSharpChecker.Create().Compile (argv) |> Async.RunSynchronously
for error in errors do eprintfn "%s" (error.ToString())
exitCode
elif runningOnMono && hasArgument "server" argv then
FSharpResidentCompiler.FSharpCompilationServer.RunServer()
0
#endif
else
let errors, exitCode = FSharpChecker.Create().Compile (argv) |> Async.RunSynchronously
@ -290,12 +239,6 @@ let main(argv) =
System.Runtime.GCSettings.LatencyMode <- System.Runtime.GCLatencyMode.Batch
use unwindBuildPhase = PushThreadBuildPhaseUntilUnwind BuildPhase.Parameter
//#if NO_HEAPTERMINATION
//#else
// if not runningOnMono then Lib.UnmanagedProcessExecutionOptions.EnableHeapTerminationOnCorruption() (* SDL recommendation *)
// Lib.UnmanagedProcessExecutionOptions.EnableHeapTerminationOnCorruption() (* SDL recommendation *)
//#endif
try
Driver.main(Array.append [| "fsc.exe" |] argv);
with e ->

12
fcs-samples/FsiExe/fsimain.fs
Просмотреть файл

@ -211,13 +211,11 @@ let MainMain argv =
// Route GUI application exceptions to the exception handlers
Application.add_ThreadException(new ThreadExceptionEventHandler(fun _ args -> fsiSession.ReportUnhandledException args.Exception));
let runningOnMono = try System.Type.GetType("Mono.Runtime") <> null with e-> false
if not runningOnMono then
try
TrySetUnhandledExceptionMode()
with _ ->
()
try
TrySetUnhandledExceptionMode()
with _ ->
()
#if USE_WINFORMS_EVENT_LOOP
try fsi.EventLoop <- WinFormsEventLoop(fsiSession.LCID)
with e ->

6
global.json
Просмотреть файл

@ -1,11 +1,11 @@
{
"sdk": {
"version": "6.0.301",
"version": "7.0.100-preview.5.22307.18",
"allowPrerelease": true,
"rollForward": "latestMajor"
},
"tools": {
"dotnet": "7.0.100-preview.2.22153.17",
"dotnet": "7.0.100-preview.5.22307.18",
"vs": {
"version": "17.0",
"components": [
@ -18,7 +18,7 @@
"perl": "5.32.1.1"
},
"msbuild-sdks": {
"Microsoft.DotNet.Arcade.Sdk": "7.0.0-beta.22327.1",
"Microsoft.DotNet.Arcade.Sdk": "7.0.0-beta.22410.3",
"Microsoft.DotNet.Helix.Sdk": "2.0.0-beta.19069.2"
}
}

40
proto.proj
Просмотреть файл

@ -1,40 +0,0 @@
<Project DefaultTargets="Build">
<PropertyGroup>
<Configuration Condition="'$(Configuration)' == ''">Proto</Configuration>
<CustomProps>AssemblySearchPaths={HintPathFromItem};{TargetFrameworkDirectory};{RawFileName}</CustomProps>
</PropertyGroup>
<ItemGroup>
<Projects Include="src\FSharp.Build\FSharp.Build.fsproj">
<AdditionalProperties>TargetFramework=netstandard2.0</AdditionalProperties>
</Projects>
<Projects Include="src\fsc\fscProject\fsc.fsproj">
<AdditionalProperties Condition="'$(OS)' == 'Unix'">TargetFramework=net6.0</AdditionalProperties>
</Projects>
<Projects Include="src\fsi\fsiProject\fsi.fsproj">
<AdditionalProperties Condition="'$(OS)' == 'Unix'">TargetFramework=net6.0</AdditionalProperties>
</Projects>
</ItemGroup>
<Target Name="Build">
<MSBuild Projects="@(Projects)" Targets="Build" Properties="Configuration=$(Configuration);BUILD_PUBLICSIGN=$(BUILD_PUBLICSIGN);$(CustomProps)" />
</Target>
<Target Name="Rebuild">
<MSBuild Projects="@(Projects)" Targets="Rebuild" Properties="Configuration=$(Configuration);BUILD_PUBLICSIGN=$(BUILD_PUBLICSIGN);$(CustomProps)" />
</Target>
<Target Name="Publish">
<MSBuild Projects="@(Projects)" Targets="Publish" Properties="Configuration=$(Configuration);BUILD_PUBLICSIGN=$(BUILD_PUBLICSIGN);$(CustomProps)" />
</Target>
<Target Name="Clean">
<MSBuild Projects="@(Projects)" Targets="Clean" Properties="Configuration=$(Configuration);BUILD_PUBLICSIGN=$(BUILD_PUBLICSIGN);$(CustomProps)" />
</Target>
<Target Name="Restore">
<MSBuild Projects="@(Projects)" Targets="Restore" Properties="Configuration=$(Configuration);BUILD_PUBLICSIGN=$(BUILD_PUBLICSIGN);$(CustomProps)" />
</Target>
</Project>

3
release-notes.md
Просмотреть файл

@ -35,6 +35,9 @@ These release notes track our current efforts to document changes to the F# proj
* `SynMeasure` was extended with [SynMeasure.Paren](https://fsharp.github.io/fsharp-compiler-docs/reference/fsharp-compiler-syntax-synmeasure.html#Paren) case.
* Dynamic expressions (like `x?y`) are now represented as [SynExpr.Dynamic](https://fsharp.github.io/fsharp-compiler-docs/reference/fsharp-compiler-syntax-synexpr.html#Dynamic) in the Untyped Syntax Tree.
* Members with `get` and/or `set` are now represented as [SynMemberDefn.GetSetMember](https://fsharp.github.io/fsharp-compiler-docs/reference/fsharp-compiler-syntax-synmemberdefn.html#GetSetMember) in the Untyped Syntax Tree.
* `DoesIdentifierNeedBackticks` is removed, it should always be sufficient to call `NormalizeIdentifierBackticks` or else call something in `PrettyNaming`
* `AddBackticksToIdentifierIfNeeded` is removed, it should always be sufficient to call `NormalizeIdentifierBackticks`
* `DeclarationListItem.Name` --> `DeclarationListItem.NameInList`
### F# 6.0 / Visual Studio 17.0

2
setup/Swix/Microsoft.FSharp.Compiler.MSBuild/Microsoft.FSharp.Compiler.MSBuild.csproj
Просмотреть файл

@ -49,7 +49,7 @@
folder "InstallDir:Common7\IDE\CommonExtensions\Microsoft\FSharp\Tools\%(_XlfLanguages.Identity)"
file source="$(BinariesFolder)FSharp.Build\$(Configuration)\netstandard2.0\%(_XlfLanguages.Identity)\FSharp.Build.resources.dll"
file source="$(BinariesFolder)FSharp.Compiler.Interactive.Settings\$(Configuration)\netstandard2.0\%(_XlfLanguages.Identity)\FSharp.Compiler.Interactive.Settings.resources.dll"
file source="$(BinariesFolder)FSharp.Compiler.Service\$(Configuration)\$(TargetFramework)\%(_XlfLanguages.Identity)\FSharp.Compiler.Service.resources.dll"
file source="$(BinariesFolder)FSharp.Compiler.Service\$(Configuration)\netstandard2.0\%(_XlfLanguages.Identity)\FSharp.Compiler.Service.resources.dll"
file source="$(BinariesFolder)FSharp.Core\$(Configuration)\netstandard2.0\%(_XlfLanguages.Identity)\FSharp.Core.resources.dll"
]]>
</_Line>

107
src/Compiler/AbstractIL/il.fs
Просмотреть файл

@ -25,7 +25,9 @@ open Internal.Utilities
let logging = false
let _ = if logging then dprintn "* warning: Il.logging is on"
let _ =
if logging then
dprintn "* warning: Il.logging is on"
let int_order = LanguagePrimitives.FastGenericComparer<int>
@ -68,11 +70,13 @@ let memoizeNamespaceRightTable =
let memoizeNamespacePartTable = ConcurrentDictionary<string, string>()
let splitNameAt (nm: string) idx =
if idx < 0 then failwith "splitNameAt: idx < 0"
if idx < 0 then
failwith "splitNameAt: idx < 0"
let last = nm.Length - 1
if idx > last then failwith "splitNameAt: idx > last"
if idx > last then
failwith "splitNameAt: idx > last"
(nm.Substring(0, idx)), (if idx < last then nm.Substring(idx + 1, last - idx) else "")
@ -551,7 +555,8 @@ type ILAssemblyRef(data) =
addC (convDigit (int32 v / 16))
addC (convDigit (int32 v % 16))
// retargetable can be true only for system assemblies that definitely have Version
if aref.Retargetable then add ", Retargetable=Yes"
if aref.Retargetable then
add ", Retargetable=Yes"
b.ToString()
@ -1198,10 +1203,11 @@ type ILAttribute =
[<NoEquality; NoComparison; Struct>]
type ILAttributes(array: ILAttribute[]) =
member _.AsArray() = array
member x.AsArray() = array
member _.AsList() = array |> Array.toList
member x.AsList() = array |> Array.toList
static member val internal Empty = ILAttributes([||])
[<NoEquality; NoComparison>]
type ILAttributesStored =
@ -1364,7 +1370,7 @@ type ILInstr =
| I_call of ILTailcall * ILMethodSpec * ILVarArgs
| I_callvirt of ILTailcall * ILMethodSpec * ILVarArgs
| I_callconstraint of ILTailcall * ILType * ILMethodSpec * ILVarArgs
| I_callconstraint of callvirt: bool * ILTailcall * ILType * ILMethodSpec * ILVarArgs
| I_calli of ILTailcall * ILCallingSignature * ILVarArgs
| I_ldftn of ILMethodSpec
| I_newobj of ILMethodSpec * ILVarArgs
@ -2497,8 +2503,10 @@ let typeKindOfFlags nm (super: ILType option) flags =
if name = "System.Enum" then
ILTypeDefKind.Enum
elif (name = "System.Delegate" && nm <> "System.MulticastDelegate")
|| name = "System.MulticastDelegate" then
elif
(name = "System.Delegate" && nm <> "System.MulticastDelegate")
|| name = "System.MulticastDelegate"
then
ILTypeDefKind.Delegate
elif name = "System.ValueType" && nm <> "System.Enum" then
ILTypeDefKind.ValueType
@ -3402,9 +3410,6 @@ let mkNormalCall mspec = I_call(Normalcall, mspec, None)
let mkNormalCallvirt mspec = I_callvirt(Normalcall, mspec, None)
let mkNormalCallconstraint (ty, mspec) =
I_callconstraint(Normalcall, ty, mspec, None)
let mkNormalNewobj mspec = I_newobj(mspec, None)
/// Comment on common object cache sizes:
@ -3814,18 +3819,24 @@ let mkILClassCtor impl =
let mk_ospec (ty: ILType, callconv, nm, genparams, formal_args, formal_ret) =
OverridesSpec(mkILMethRef (ty.TypeRef, callconv, nm, genparams, formal_args, formal_ret), ty)
let mkILGenericVirtualMethod (nm, access, genparams, actual_args, actual_ret, impl) =
let mkILGenericVirtualMethod (nm, callconv: ILCallingConv, access, genparams, actual_args, actual_ret, impl) =
let attributes =
convertMemberAccess access
||| MethodAttributes.CheckAccessOnOverride
||| (match impl with
| MethodBody.Abstract -> MethodAttributes.Abstract ||| MethodAttributes.Virtual
| _ -> MethodAttributes.Virtual)
||| (if callconv.IsInstance then
enum 0
else
MethodAttributes.Static)
ILMethodDef(
name = nm,
attributes =
(convertMemberAccess access
||| MethodAttributes.CheckAccessOnOverride
||| (match impl with
| MethodBody.Abstract -> MethodAttributes.Abstract ||| MethodAttributes.Virtual
| _ -> MethodAttributes.Virtual)),
attributes = attributes,
implAttributes = MethodImplAttributes.Managed,
genericParams = genparams,
callingConv = ILCallingConv.Instance,
callingConv = callconv,
parameters = actual_args,
ret = actual_ret,
isEntryPoint = false,
@ -3834,8 +3845,11 @@ let mkILGenericVirtualMethod (nm, access, genparams, actual_args, actual_ret, im
body = notlazy impl
)
let mkILNonGenericVirtualMethod (nm, access, args, ret, impl) =
mkILGenericVirtualMethod (nm, access, mkILEmptyGenericParams, args, ret, impl)
let mkILNonGenericVirtualMethod (nm, callconv, access, args, ret, impl) =
mkILGenericVirtualMethod (nm, callconv, access, mkILEmptyGenericParams, args, ret, impl)
let mkILNonGenericVirtualInstanceMethod (nm, access, args, ret, impl) =
mkILNonGenericVirtualMethod (nm, ILCallingConv.Instance, access, args, ret, impl)
let mkILGenericNonVirtualMethod (nm, access, genparams, actual_args, actual_ret, impl) =
ILMethodDef(
@ -3925,7 +3939,8 @@ let cdef_cctorCode2CodeOrCreate tag imports f (cd: ILTypeDef) =
[|
yield f cctor
for md in mdefs do
if md.Name <> ".cctor" then yield md
if md.Name <> ".cctor" then
yield md
|])
cd.With(methods = methods)
@ -4199,7 +4214,7 @@ let mkILSimpleModule
AssemblyLongevity = ILAssemblyLongevity.Unspecified
DisableJitOptimizations = 0 <> (flags &&& 0x4000)
JitTracking = (0 <> (flags &&& 0x8000)) // always turn these on
IgnoreSymbolStoreSequencePoints = (0 <> (flags &&& 0x2000))
IgnoreSymbolStoreSequencePoints = false
Retargetable = (0 <> (flags &&& 0x100))
ExportedTypes = exportedTypes
EntrypointElsewhere = None
@ -4258,7 +4273,7 @@ let mkILDelegateMethods access (ilg: ILGlobals) (iltyp_AsyncCallback, iltyp_IAsy
let one nm args ret =
let mdef =
mkILNonGenericVirtualMethod (nm, access, args, mkILReturn ret, MethodBody.Abstract)
mkILNonGenericVirtualInstanceMethod (nm, access, args, mkILReturn ret, MethodBody.Abstract)
mdef.WithAbstract(false).WithHideBySig(true).WithRuntime(true)
@ -4888,7 +4903,8 @@ type ILTypeSigParser(tstring: string) =
// Does the type name start with a leading '['? If so, ignore it
// (if the specialization type is in another module, it will be wrapped in bracket)
if here () = '[' then drop ()
if here () = '[' then
drop ()
// 1. Iterate over beginning of type, grabbing the type name and determining if it's generic or an array
let typeName =
@ -4947,8 +4963,11 @@ type ILTypeSigParser(tstring: string) =
let scope =
if (here () = ',' || here () = ' ') && (peek () <> '[' && peekN 2 <> '[') then
let grabScopeComponent () =
if here () = ',' then drop () // ditch the ','
if here () = ' ' then drop () // ditch the ' '
if here () = ',' then
drop () // ditch the ','
if here () = ' ' then
drop () // ditch the ' '
while (peek () <> ',' && peek () <> ']' && peek () <> nil) do
step ()
@ -4969,8 +4988,11 @@ type ILTypeSigParser(tstring: string) =
ILScopeRef.Local
// strip any extraneous trailing brackets or commas
if (here () = ']') then drop ()
if (here () = ',') then drop ()
if (here () = ']') then
drop ()
if (here () = ',') then
drop ()
// build the IL type
let tref = mkILTyRef (scope, typeName)
@ -5282,7 +5304,7 @@ and refsOfILInstr s x =
| I_callvirt (_, mr, varargs) ->
refsOfILMethodSpec s mr
refsOfILVarArgs s varargs
| I_callconstraint (_, tr, mr, varargs) ->
| I_callconstraint (_, _, tr, mr, varargs) ->
refsOfILType s tr
refsOfILMethodSpec s mr
refsOfILVarArgs s varargs
@ -5549,17 +5571,18 @@ let resolveILMethodRefWithRescope r (td: ILTypeDef) (mref: ILMethodRef) =
let argTypes = mref.ArgTypes |> List.map r
let retType: ILType = r mref.ReturnType
match possibles
|> List.filter (fun md ->
mref.CallingConv = md.CallingConv
&&
// REVIEW: this uses equality on ILType. For CMOD_OPTIONAL this is not going to be correct
(md.Parameters, argTypes)
||> List.lengthsEqAndForall2 (fun p1 p2 -> r p1.Type = p2)
&&
// REVIEW: this uses equality on ILType. For CMOD_OPTIONAL this is not going to be correct
r md.Return.Type = retType)
with
match
possibles
|> List.filter (fun md ->
mref.CallingConv = md.CallingConv
&&
// REVIEW: this uses equality on ILType. For CMOD_OPTIONAL this is not going to be correct
(md.Parameters, argTypes)
||> List.lengthsEqAndForall2 (fun p1 p2 -> r p1.Type = p2)
&&
// REVIEW: this uses equality on ILType. For CMOD_OPTIONAL this is not going to be correct
r md.Return.Type = retType)
with
| [] ->
failwith (
"no method named "

34
src/Compiler/AbstractIL/il.fsi
Просмотреть файл

@ -523,7 +523,7 @@ type internal ILInstr =
// Method call
| I_call of ILTailcall * ILMethodSpec * ILVarArgs
| I_callvirt of ILTailcall * ILMethodSpec * ILVarArgs
| I_callconstraint of ILTailcall * ILType * ILMethodSpec * ILVarArgs
| I_callconstraint of callvirt: bool * ILTailcall * ILType * ILMethodSpec * ILVarArgs
| I_calli of ILTailcall * ILCallingSignature * ILVarArgs
| I_ldftn of ILMethodSpec
| I_newobj of ILMethodSpec * ILVarArgs
@ -783,20 +783,14 @@ type ILDebugImports =
/// IL method bodies
[<RequireQualifiedAccess; NoComparison; NoEquality>]
type internal ILMethodBody =
{
IsZeroInit: bool
MaxStack: int32
NoInlining: bool
AggressiveInlining: bool
Locals: ILLocals
Code: ILCode
/// Indicates the entire range of the method. Emitted for full PDB but not currently for portable PDB.
/// Additionally, if the range is not set, then no debug points are emitted.
DebugRange: ILDebugPoint option
DebugImports: ILDebugImports option
}
{ IsZeroInit: bool
MaxStack: int32
NoInlining: bool
AggressiveInlining: bool
Locals: ILLocals
Code: ILCode
DebugRange: ILDebugPoint option
DebugImports: ILDebugImports option }
/// Member Access
[<RequireQualifiedAccess>]
@ -861,6 +855,8 @@ type ILAttributes =
member AsList: unit -> ILAttribute list
static member internal Empty: ILAttributes
/// Represents the efficiency-oriented storage of ILAttributes in another item.
[<NoEquality; NoComparison>]
type ILAttributesStored
@ -1695,7 +1691,6 @@ type ILAssemblyManifest =
JitTracking: bool
IgnoreSymbolStoreSequencePoints: bool
Retargetable: bool
/// Records the types implemented by this assembly in auxiliary
@ -1975,7 +1970,6 @@ type internal ILLocalsAllocator =
/// Derived functions for making some common patterns of instructions.
val internal mkNormalCall: ILMethodSpec -> ILInstr
val internal mkNormalCallvirt: ILMethodSpec -> ILInstr
val internal mkNormalCallconstraint: ILType * ILMethodSpec -> ILInstr
val internal mkNormalNewobj: ILMethodSpec -> ILInstr
val internal mkCallBaseConstructor: ILType * ILType list -> ILInstr list
val internal mkNormalStfld: ILFieldSpec -> ILInstr
@ -2030,12 +2024,16 @@ val internal mkILNonGenericStaticMethod:
string * ILMemberAccess * ILParameter list * ILReturn * MethodBody -> ILMethodDef
val internal mkILGenericVirtualMethod:
string * ILMemberAccess * ILGenericParameterDefs * ILParameter list * ILReturn * MethodBody -> ILMethodDef
string * ILCallingConv * ILMemberAccess * ILGenericParameterDefs * ILParameter list * ILReturn * MethodBody ->
ILMethodDef
val internal mkILGenericNonVirtualMethod:
string * ILMemberAccess * ILGenericParameterDefs * ILParameter list * ILReturn * MethodBody -> ILMethodDef
val internal mkILNonGenericVirtualMethod:
string * ILCallingConv * ILMemberAccess * ILParameter list * ILReturn * MethodBody -> ILMethodDef
val internal mkILNonGenericVirtualInstanceMethod:
string * ILMemberAccess * ILParameter list * ILReturn * MethodBody -> ILMethodDef
val internal mkILNonGenericInstanceMethod:

26
src/Compiler/AbstractIL/ilmorph.fs
Просмотреть файл

@ -212,7 +212,8 @@ let morphILTypesInILInstr ((factualTy, fformalTy)) i =
| I_calli (a, mref, varargs) -> I_calli(a, callsig_ty2ty factualTy mref, morphILVarArgs factualTy varargs)
| I_call (a, mr, varargs) -> I_call(a, conv_mspec mr, morphILVarArgs factualTy varargs)
| I_callvirt (a, mr, varargs) -> I_callvirt(a, conv_mspec mr, morphILVarArgs factualTy varargs)
| I_callconstraint (a, ty, mr, varargs) -> I_callconstraint(a, factualTy ty, conv_mspec mr, morphILVarArgs factualTy varargs)
| I_callconstraint (callvirt, a, ty, mr, varargs) ->
I_callconstraint(callvirt, a, factualTy ty, conv_mspec mr, morphILVarArgs factualTy varargs)
| I_newobj (mr, varargs) -> I_newobj(conv_mspec mr, morphILVarArgs factualTy varargs)
| I_ldftn mr -> I_ldftn(conv_mspec mr)
| I_ldvirtftn mr -> I_ldvirtftn(conv_mspec mr)
@ -265,12 +266,31 @@ let morphILTypeDefs f (tdefs: ILTypeDefs) =
let morphILLocals f locals = List.map (morphILLocal f) locals
let morphILDebugImport fs debugImport =
let _, f = fs
match debugImport with
| ILDebugImport.ImportType ty -> ILDebugImport.ImportType(f ty)
| ILDebugImport.ImportNamespace _ns -> debugImport
let morphILDebugImports fs ilDebugImports =
ilDebugImports |> Array.map (morphILDebugImport fs)
let ilmbody_instr2instr_ty2ty fs (ilmbody: ILMethodBody) =
let finstr, fTyInCtxt = fs
let _, fTyInCtxt = fs
{ ilmbody with
Code = code_instr2instr_ty2ty (finstr, fTyInCtxt) ilmbody.Code
Code = code_instr2instr_ty2ty fs ilmbody.Code
Locals = morphILLocals fTyInCtxt ilmbody.Locals
DebugImports =
match ilmbody.DebugImports with
| None -> None
| Some imports ->
Some(
{ imports with
Imports = morphILDebugImports fs imports.Imports
}
)
}
let morphILMethodBody fMethBody (x: MethodBody) =

12
src/Compiler/AbstractIL/ilnativeres.fs
Просмотреть файл

@ -96,8 +96,10 @@ type CvtResFile() =
reader.Read(pAdditional.data, 0, pAdditional.data.Length) |> ignore<int>
stream.Position <- stream.Position + 3L &&& ~~~ 3L
if pAdditional.pstringType.theString = Unchecked.defaultof<_>
&& (pAdditional.pstringType.Ordinal = uint16 CvtResFile.RT_DLGINCLUDE) then
if
pAdditional.pstringType.theString = Unchecked.defaultof<_>
&& (pAdditional.pstringType.Ordinal = uint16 CvtResFile.RT_DLGINCLUDE)
then
() (* ERROR ContinueNotSupported *)
else
resourceNames.Add pAdditional
@ -454,7 +456,8 @@ type VersionHelper() =
doBreak <- false
() (* ERROR ContinueNotSupported *)
(* ERROR BreakNotSupported *)
if not breakLoop then i <- i + 1
if not breakLoop then
i <- i + 1
if hasWildcard then
let mutable (i: int) = lastExplicitValue
@ -1149,7 +1152,8 @@ type NativeResourceWriter() =
if id >= 0 then
writer.WriteInt32 id
else
if name = Unchecked.defaultof<_> then name <- String.Empty
if name = Unchecked.defaultof<_> then
name <- String.Empty
writer.WriteUInt32(nameOffset ||| 0x80000000u)
dataWriter.WriteUInt16(uint16 name.Length)

64
src/Compiler/AbstractIL/ilprint.fs
Просмотреть файл

@ -661,16 +661,20 @@ let goutput_fdef _tref env os (fd: ILFieldDef) =
output_member_access os fd.Access
output_string os " "
if fd.IsStatic then output_string os " static "
if fd.IsStatic then
output_string os " static "
if fd.IsLiteral then output_string os " literal "
if fd.IsLiteral then
output_string os " literal "
if fd.IsSpecialName then
output_string os " specialname rtspecialname "
if fd.IsInitOnly then output_string os " initonly "
if fd.IsInitOnly then
output_string os " initonly "
if fd.NotSerialized then output_string os " notserialized "
if fd.NotSerialized then
output_string os " notserialized "
goutput_typ env os fd.FieldType
output_string os " "
@ -740,7 +744,8 @@ let output_code_label os lab = output_string os (formatCodeLabel lab)
let goutput_local env os (l: ILLocal) =
goutput_typ env os l.Type
if l.IsPinned then output_string os " pinned"
if l.IsPinned then
output_string os " pinned"
let goutput_param env os (l: ILParameter) =
match l.Name with
@ -888,11 +893,11 @@ let rec goutput_instr env os inst =
output_string os "callvirt "
goutput_vararg_mspec env os (mspec, varargs)
output_after_tailcall os tl
| I_callconstraint (tl, ty, mspec, varargs) ->
| I_callconstraint (callvirt, tl, ty, mspec, varargs) ->
output_tailness os tl
output_string os "constraint. "
goutput_typ env os ty
output_string os " callvirt "
output_string os (if callvirt then " callvirt " else " call ")
goutput_vararg_mspec env os (mspec, varargs)
output_after_tailcall os tl
| I_castclass ty ->
@ -985,7 +990,8 @@ let rec goutput_instr env os inst =
let rank = shape.Rank
output_parens (output_array ", " (goutput_typ env)) os (Array.create rank PrimaryAssemblyILGlobals.typ_Int32)
| I_ldelema (ro, _, shape, tok) ->
if ro = ReadonlyAddress then output_string os "readonly. "
if ro = ReadonlyAddress then
output_string os "readonly. "
if shape = ILArrayShape.SingleDimensional then
output_string os "ldelema "
@ -1034,7 +1040,8 @@ let rec goutput_instr env os inst =
| _ -> output_string os "<printing for this instruction is not implemented>"
let goutput_ilmbody env os (il: ILMethodBody) =
if il.IsZeroInit then output_string os " .zeroinit\n"
if il.IsZeroInit then
output_string os " .zeroinit\n"
output_string os " .maxstack "
output_i32 os il.MaxStack
@ -1067,7 +1074,8 @@ let goutput_mbody is_entrypoint env os (md: ILMethodDef) =
| MethodBody.IL il -> goutput_ilmbody env os il.Value
| _ -> ()
if is_entrypoint then output_string os " .entrypoint"
if is_entrypoint then
output_string os " .entrypoint"
output_string os "\n"
output_string os "}\n"
@ -1125,11 +1133,14 @@ let goutput_mdef env os (md: ILMethodDef) =
let menv = ppenv_enter_method (List.length md.GenericParams) env
output_string os " .method "
if md.IsHideBySig then output_string os "hidebysig "
if md.IsHideBySig then
output_string os "hidebysig "
if md.IsReqSecObj then output_string os "reqsecobj "
if md.IsReqSecObj then
output_string os "reqsecobj "
if md.IsSpecialName then output_string os "specialname "
if md.IsSpecialName then
output_string os "specialname "
if md.IsUnmanagedExport then
output_string os "unmanagedexp "
@ -1149,13 +1160,17 @@ let goutput_mdef env os (md: ILMethodDef) =
(goutput_params menv) os md.Parameters
output_string os " "
if md.IsSynchronized then output_string os "synchronized "
if md.IsSynchronized then
output_string os "synchronized "
if md.IsMustRun then output_string os "/* mustrun */ "
if md.IsMustRun then
output_string os "/* mustrun */ "
if md.IsPreserveSig then output_string os "preservesig "
if md.IsPreserveSig then
output_string os "preservesig "
if md.IsNoInline then output_string os "noinlining "
if md.IsNoInline then
output_string os "noinlining "
if md.IsAggressiveInline then
output_string os "aggressiveinlining "
@ -1255,13 +1270,17 @@ let rec goutput_tdef enc env contents os (cd: ILTypeDef) =
output_string os layout_attr
output_string os " "
if cd.IsSealed then output_string os "sealed "
if cd.IsSealed then
output_string os "sealed "
if cd.IsAbstract then output_string os "abstract "
if cd.IsAbstract then
output_string os "abstract "
if cd.IsSerializable then output_string os "serializable "
if cd.IsSerializable then
output_string os "serializable "
if cd.IsComInterop then output_string os "import "
if cd.IsComInterop then
output_string os "import "
output_sqstring os cd.Name
goutput_gparams env os cd.GenericParams
@ -1339,7 +1358,8 @@ let output_assemblyRef os (aref: ILAssemblyRef) =
output_string os " .assembly extern "
output_sqstring os aref.Name
if aref.Retargetable then output_string os " retargetable "
if aref.Retargetable then
output_string os " retargetable "
output_string os " { "
output_option output_hash os aref.Hash

351
src/Compiler/AbstractIL/ilread.fs
Просмотреть файл

@ -626,17 +626,23 @@ let instrs () =
i_stsfld, I_field_instr(volatilePrefix (fun x fspec -> I_stsfld(x, fspec)))
i_ldflda, I_field_instr(noPrefixes I_ldflda)
i_ldsflda, I_field_instr(noPrefixes I_ldsflda)
i_call, I_method_instr(tailPrefix (fun tl (mspec, y) -> I_call(tl, mspec, y)))
(i_call,
I_method_instr(
constraintOrTailPrefix (fun (c, tl) (mspec, y) ->
match c with
| Some ty -> I_callconstraint(false, tl, ty, mspec, y)
| None -> I_call(tl, mspec, y))
))
i_ldftn, I_method_instr(noPrefixes (fun (mspec, _y) -> I_ldftn mspec))
i_ldvirtftn, I_method_instr(noPrefixes (fun (mspec, _y) -> I_ldvirtftn mspec))
i_newobj, I_method_instr(noPrefixes I_newobj)
i_callvirt,
I_method_instr(
constraintOrTailPrefix (fun (c, tl) (mspec, y) ->
match c with
| Some ty -> I_callconstraint(tl, ty, mspec, y)
| None -> I_callvirt(tl, mspec, y))
)
(i_callvirt,
I_method_instr(
constraintOrTailPrefix (fun (c, tl) (mspec, y) ->
match c with
| Some ty -> I_callconstraint(true, tl, ty, mspec, y)
| None -> I_callvirt(tl, mspec, y))
))
i_leave_s, I_unconditional_i8_instr(noPrefixes (fun x -> I_leave x))
i_br_s, I_unconditional_i8_instr(noPrefixes I_br)
i_leave, I_unconditional_i32_instr(noPrefixes (fun x -> I_leave x))
@ -1118,11 +1124,6 @@ type VarArgMethodData =
type PEReader =
{
fileName: string
#if FX_NO_PDB_READER
pdb: obj option
#else
pdb: (PdbReader * (string -> ILSourceDocument)) option
#endif
entryPointToken: TableName * int
pefile: BinaryFile
textSegmentPhysicalLoc: int32
@ -1379,7 +1380,8 @@ let seekReadGuidIdx (ctxt: ILMetadataReader) mdv (addr: byref<int>) = seekReadId
let seekReadBlobIdx (ctxt: ILMetadataReader) mdv (addr: byref<int>) = seekReadIdx ctxt.blobsBigness mdv &addr
let seekReadModuleRow (ctxt: ILMetadataReader) mdv idx =
if idx = 0 then failwith "cannot read Module table row 0"
if idx = 0 then
failwith "cannot read Module table row 0"
let mutable addr = ctxt.rowAddr TableNames.Module idx
let generation = seekReadUInt16Adv mdv &addr
@ -1846,7 +1848,9 @@ let getDataEndPointsDelayed (pectxt: PEReader) ctxtH =
|> List.sort
let rvaToData (ctxt: ILMetadataReader) (pectxt: PEReader) nm rva =
if rva = 0x0 then failwith "rva is zero"
if rva = 0x0 then
failwith "rva is zero"
let start = pectxt.anyV2P (nm, rva)
let endPoints = (Lazy.force ctxt.dataEndPoints)
@ -1965,7 +1969,7 @@ and seekReadAssemblyManifest (ctxt: ILMetadataReader) pectxt idx =
Retargetable = 0 <> (flags &&& 0x100)
DisableJitOptimizations = 0 <> (flags &&& 0x4000)
JitTracking = 0 <> (flags &&& 0x8000)
IgnoreSymbolStoreSequencePoints = 0 <> (flags &&& 0x2000)
IgnoreSymbolStoreSequencePoints = false
}
and seekReadAssemblyRef (ctxt: ILMetadataReader) idx = ctxt.seekReadAssemblyRef idx
@ -2565,7 +2569,8 @@ and sigptrGetTy (ctxt: ILMetadataReader) numTypars bytes sigptr =
let ccByte, sigptr = sigptrGetByte bytes sigptr
let generic, cc = byteAsCallConv ccByte
if generic then failwith "fptr sig may not be generic"
if generic then
failwith "fptr sig may not be generic"
let struct (numparams, sigptr) = sigptrGetZInt32 bytes sigptr
let retTy, sigptr = sigptrGetTy ctxt numTypars bytes sigptr
@ -2923,7 +2928,7 @@ and seekReadMethod (ctxt: ILMetadataReader) mdv numTypars (idx: int) =
else
match ctxt.pectxtCaptured with
| None -> methBodyNotAvailable
| Some pectxt -> seekReadMethodRVA pectxt ctxt (idx, nm, internalcall, noinline, aggressiveinline, numTypars) codeRVA
| Some pectxt -> seekReadMethodRVA pectxt ctxt (nm, noinline, aggressiveinline, numTypars) codeRVA
ILMethodDef(
name = nm,
@ -3082,16 +3087,15 @@ and seekReadEvents (ctxt: ILMetadataReader) numTypars tidx =
let mdv = ctxt.mdfile.GetView()
match
seekReadOptionalIndexedRow
(
ctxt.getNumRows TableNames.EventMap,
(fun i -> i, seekReadEventMapRow ctxt mdv i),
(fun (_, row) -> fst row),
compare tidx,
false,
(fun (i, row) -> (i, snd row))
)
with
seekReadOptionalIndexedRow (
ctxt.getNumRows TableNames.EventMap,
(fun i -> i, seekReadEventMapRow ctxt mdv i),
(fun (_, row) -> fst row),
compare tidx,
false,
(fun (i, row) -> (i, snd row))
)
with
| None -> []
| Some (rowNum, beginEventIdx) ->
let endEventIdx =
@ -3150,16 +3154,15 @@ and seekReadProperties (ctxt: ILMetadataReader) numTypars tidx =
let mdv = ctxt.mdfile.GetView()
match
seekReadOptionalIndexedRow
(
ctxt.getNumRows TableNames.PropertyMap,
(fun i -> i, seekReadPropertyMapRow ctxt mdv i),
(fun (_, row) -> fst row),
compare tidx,
false,
(fun (i, row) -> (i, snd row))
)
with
seekReadOptionalIndexedRow (
ctxt.getNumRows TableNames.PropertyMap,
(fun i -> i, seekReadPropertyMapRow ctxt mdv i),
(fun (_, row) -> fst row),
compare tidx,
false,
(fun (i, row) -> (i, snd row))
)
with
| None -> []
| Some (rowNum, beginPropIdx) ->
let endPropIdx =
@ -3357,7 +3360,7 @@ and seekReadImplMap (ctxt: ILMetadataReader) nm midx =
}
)
and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numTypars (sz: int) start seqpoints =
and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numTypars (sz: int) start =
let labelsOfRawOffsets = Dictionary<_, _>(sz / 2)
let ilOffsetsOfLabels = Dictionary<_, _>(sz / 2)
@ -3401,7 +3404,7 @@ and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numTypars (sz: int) start s
else
lastb
let mutable seqPointsRemaining = seqpoints
let mutable seqPointsRemaining = []
while curr < sz do
// registering "+string !curr+" as start of an instruction")
@ -3592,17 +3595,21 @@ and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numTypars (sz: int) start s
curr <- curr + 4
(* REVIEW: this incorrectly labels all MemberRef tokens as ILMethod's: we should go look at the MemberRef sig to determine if it is a field or method *)
let token_info =
if tab = TableNames.Method
|| tab = TableNames.MemberRef (* REVIEW: generics or tab = TableNames.MethodSpec *) then
if
tab = TableNames.Method
|| tab = TableNames.MemberRef (* REVIEW: generics or tab = TableNames.MethodSpec *)
then
let (MethodData (enclTy, cc, nm, argTys, retTy, methInst)) =
seekReadMethodDefOrRefNoVarargs ctxt numTypars (uncodedTokenToMethodDefOrRef (tab, idx))
ILToken.ILMethod(mkILMethSpecInTy (enclTy, cc, nm, argTys, retTy, methInst))
elif tab = TableNames.Field then
ILToken.ILField(seekReadFieldDefAsFieldSpec ctxt idx)
elif tab = TableNames.TypeDef
|| tab = TableNames.TypeRef
|| tab = TableNames.TypeSpec then
elif
tab = TableNames.TypeDef
|| tab = TableNames.TypeRef
|| tab = TableNames.TypeSpec
then
ILToken.ILType(seekReadTypeDefOrRef ctxt numTypars AsObject [] (uncodedTokenToTypeDefOrRefOrSpec (tab, idx)))
else
failwith "bad token for ldtoken"
@ -3640,36 +3647,11 @@ and seekReadTopCode (ctxt: ILMetadataReader) pev mdv numTypars (sz: int) start s
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 = 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,
// apart from a final label which refers to the end of the method. This function finds
// the start of the next instruction referred to by the raw offset.
let raw2nextLab rawOffset =
let isInstrStart x =
match labelsOfRawOffsets.TryGetValue x with
| true, lab -> ilOffsetsOfLabels.ContainsKey lab
| _ -> false
if isInstrStart rawOffset then
rawToLabel rawOffset
elif isInstrStart (rawOffset + 1) then
rawToLabel (rawOffset + 1)
else
failwith (
"the bytecode raw offset "
+ string rawOffset
+ " did not refer either to the start or end of an instruction"
)
let instrs = ibuf.ToArray()
instrs, rawToLabel, lab2pc, raw2nextLab
#if FX_NO_PDB_READER
and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (_idx, nm, _internalcall, noinline, aggressiveinline, numTypars) rva =
#else
and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _internalcall, noinline, aggressiveinline, numTypars) rva =
#endif
instrs, rawToLabel, lab2pc
and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (nm, noinline, aggressiveinline, numTypars) rva =
lazy
let pev = pectxt.pefile.GetView()
let baseRVA = pectxt.anyV2P ("method rva", rva)
@ -3680,7 +3662,8 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int
let isFatFormat = (b &&& e_CorILMethod_FormatMask) = e_CorILMethod_FatFormat
if not isTinyFormat && not isFatFormat then
if logging then failwith "unknown format"
if logging then
failwith "unknown format"
MethodBody.Abstract
else
@ -3694,91 +3677,14 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int
// -- a list of locals, marked with the raw offsets (actually closures which accept the resolution function that maps raw offsets to labels)
// -- an overall range for the method
// -- the sequence points for the method
let localPdbInfos, methRangePdbInfo, seqpoints =
#if FX_NO_PDB_READER
[], None, []
#else
match pectxt.pdb with
| None -> [], None, []
| Some (pdbr, get_doc) ->
try
let pdbm = pdbReaderGetMethod pdbr (uncodedToken TableNames.Method idx)
let sps = pdbMethodGetDebugPoints pdbm
(* let roota, rootb = pdbScopeGetOffsets rootScope in *)
let seqpoints =
let arr =
sps
|> Array.map (fun sp ->
// It is VERY annoying to have to call GetURL for the document for
// each sequence point. This appears to be a short coming of the PDB
// reader API. They should return an index into the array of documents for the reader
let sourcedoc = get_doc (pdbDocumentGetURL sp.pdbSeqPointDocument)
let source =
ILDebugPoint.Create(
document = sourcedoc,
line = sp.pdbSeqPointLine,
column = sp.pdbSeqPointColumn,
endLine = sp.pdbSeqPointEndLine,
endColumn = sp.pdbSeqPointEndColumn
)
(sp.pdbSeqPointOffset, source))
Array.sortInPlaceBy fst arr
Array.toList arr
let rec scopes scp =
let a, b = pdbScopeGetOffsets scp
let lvs = pdbScopeGetLocals scp
let ilvs =
lvs
|> Array.toList
|> List.filter (fun l ->
let k, _idx = pdbVariableGetAddressAttributes l
k = 1 (* ADDR_IL_OFFSET *) )
let ilinfos: ILLocalDebugMapping list =
ilvs
|> List.map (fun ilv ->
let _k, idx = pdbVariableGetAddressAttributes ilv
let n = pdbVariableGetName ilv
{ LocalIndex = idx; LocalName = n })
let thisOne =
(fun raw2nextLab ->
{
Range = (raw2nextLab a, raw2nextLab b)
DebugMappings = ilinfos
}: ILLocalDebugInfo)
let others =
List.foldBack (scopes >> (@)) (Array.toList (pdbScopeGetChildren scp)) []
thisOne :: others
let localPdbInfos =
[] (* <REVIEW> scopes fail for mscorlib </REVIEW> scopes rootScope *)
// REVIEW: look through sps to get ranges? Use GetRanges?? Change AbsIL??
(localPdbInfos, None, seqpoints)
with e ->
// "* Warning: PDB info for method "+nm+" could not be read and will be ignored: "+e.Message
[], None, []
#endif
if isTinyFormat then
let codeBase = baseRVA + 1
let codeSize = (int32 b >>>& 2)
// tiny format for "+nm+", code size = " + string codeSize)
let instrs, _, lab2pc, raw2nextLab =
seekReadTopCode ctxt pev mdv numTypars codeSize codeBase seqpoints
let instrs, _, lab2pc = seekReadTopCode ctxt pev mdv numTypars codeSize codeBase
// Convert the linear code format to the nested code format
let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos
let code = buildILCode nm lab2pc instrs [] localPdbInfos2
let code = buildILCode nm lab2pc instrs [] []
{
IsZeroInit = false
@ -3787,7 +3693,7 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int
AggressiveInlining = aggressiveinline
Locals = List.empty
Code = code
DebugRange = methRangePdbInfo
DebugRange = None
DebugImports = None
}
@ -3811,8 +3717,8 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int
// fat format for "+nm+", code size = " + string codeSize+", hasMoreSections = "+(if hasMoreSections then "true" else "false")+", b = "+string b)
// Read the method body
let instrs, rawToLabel, lab2pc, raw2nextLab =
seekReadTopCode ctxt pev mdv numTypars codeSize codeBase seqpoints
let instrs, rawToLabel, lab2pc =
seekReadTopCode ctxt pev mdv numTypars codeSize codeBase
// Read all the sections that follow the method body.
// These contain the exception clauses.
@ -3923,17 +3829,10 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int
moreSections <- (sectionFlag &&& e_CorILMethod_Sect_MoreSects) <> 0x0uy
nextSectionBase <- sectionBase + sectionSize
// Convert the linear code format to the nested code format
if logging then dprintn "doing localPdbInfos2"
let localPdbInfos2 = List.map (fun f -> f raw2nextLab) localPdbInfos
let code = buildILCode nm lab2pc instrs seh []
if logging then
dprintn "done localPdbInfos2, checking code..."
let code = buildILCode nm lab2pc instrs seh localPdbInfos2
if logging then dprintn "done checking code."
dprintn "done checking code."
{
IsZeroInit = initlocals
@ -3942,7 +3841,7 @@ and seekReadMethodRVA (pectxt: PEReader) (ctxt: ILMetadataReader) (idx, nm, _int
AggressiveInlining = aggressiveinline
Locals = locals
Code = code
DebugRange = methRangePdbInfo
DebugRange = None
DebugImports = None
}
)
@ -4150,40 +4049,6 @@ and seekReadTopExportedTypes (ctxt: ILMetadataReader) =
]
)
#if !FX_NO_PDB_READER
let getPdbReader pdbDirPath fileName =
match pdbDirPath with
| None -> None
| Some pdbpath ->
try
let pdbr = pdbReadOpen fileName pdbpath
let pdbdocs = pdbReaderGetDocuments pdbr
let tab = new Dictionary<_, _>(Array.length pdbdocs)
pdbdocs
|> Array.iter (fun pdbdoc ->
let url = pdbDocumentGetURL pdbdoc
tab.[url] <-
ILSourceDocument.Create(
language = Some(pdbDocumentGetLanguage pdbdoc),
vendor = Some(pdbDocumentGetLanguageVendor pdbdoc),
documentType = Some(pdbDocumentGetType pdbdoc),
file = url
))
let docfun url =
match tab.TryGetValue url with
| true, doc -> doc
| _ -> failwith ("Document with URL " + url + " not found in list of documents in the PDB file")
Some(pdbr, docfun)
with e ->
dprintn ("* Warning: PDB file could not be read and will be ignored: " + e.Message)
None
#endif
// Note, pectxtEager and pevEager must not be captured by the results of this function
let openMetadataReader
(
@ -4254,10 +4119,10 @@ let openMetadataReader
| Some positions -> positions
let tablesStreamPhysLoc, _tablesStreamSize =
match tryFindStream [| 0x23; 0x7e |] (* #~ *) with
match tryFindStream [| 0x23; 0x7e |] (* #~ *) with
| Some res -> res
| None ->
match tryFindStream [| 0x23; 0x2d |] (* #-: at least one DLL I've seen uses this! *) with
match tryFindStream [| 0x23; 0x2d |] (* #-: at least one DLL I've seen uses this! *) with
| Some res -> res
| None ->
let firstStreamOffset = seekReadInt32 mdv (streamHeadersStart + 0)
@ -4668,7 +4533,7 @@ let openMetadataReader
// read of the AbsIL module.
// ----------------------------------------------------------------------
let openPEFileReader (fileName, pefile: BinaryFile, pdbDirPath, noFileOnDisk) =
let openPEFileReader (fileName, pefile: BinaryFile, noFileOnDisk) =
let pev = pefile.GetView()
(* MSDOS HEADER *)
let peSignaturePhysLoc = seekReadInt32 pev 0x3c
@ -4934,24 +4799,9 @@ let openPEFileReader (fileName, pefile: BinaryFile, pdbDirPath, noFileOnDisk) =
dprintn (fileName + ": nativeResourcesSize = " + string nativeResourcesSize)
let metadataPhysLoc = anyV2P ("metadata", metadataAddr)
//-----------------------------------------------------------------------
// Set up the PDB reader so we can read debug info for methods.
// ----------------------------------------------------------------------
#if FX_NO_PDB_READER
let pdb =
ignore pdbDirPath
None
#else
let pdb =
if runningOnMono then
None
else
getPdbReader pdbDirPath fileName
#endif
let pectxt: PEReader =
{
pdb = pdb
textSegmentPhysicalLoc = textSegmentPhysicalLoc
textSegmentPhysicalSize = textSegmentPhysicalSize
dataSegmentPhysicalLoc = dataSegmentPhysicalLoc
@ -4984,32 +4834,22 @@ let openPEFileReader (fileName, pefile: BinaryFile, pdbDirPath, noFileOnDisk) =
alignPhys,
imageBaseReal)
(metadataPhysLoc, metadataSize, peinfo, pectxt, pev, pdb)
(metadataPhysLoc, metadataSize, peinfo, pectxt, pev)
let openPE (fileName, pefile, pdbDirPath, reduceMemoryUsage, noFileOnDisk) =
let metadataPhysLoc, _metadataSize, peinfo, pectxt, pev, pdb =
openPEFileReader (fileName, pefile, pdbDirPath, noFileOnDisk)
let openPE (fileName, pefile, reduceMemoryUsage, noFileOnDisk) =
let metadataPhysLoc, _metadataSize, peinfo, pectxt, pev =
openPEFileReader (fileName, pefile, noFileOnDisk)
let ilModule, ilAssemblyRefs =
openMetadataReader (fileName, pefile, metadataPhysLoc, peinfo, pectxt, pev, Some pectxt, reduceMemoryUsage)
ilModule, ilAssemblyRefs, pdb
ilModule, ilAssemblyRefs
let openPEMetadataOnly (fileName, peinfo, pectxtEager, pevEager, mdfile: BinaryFile, reduceMemoryUsage) =
openMetadataReader (fileName, mdfile, 0, peinfo, pectxtEager, pevEager, None, reduceMemoryUsage)
let ClosePdbReader pdb =
#if FX_NO_PDB_READER
ignore pdb
()
#else
match pdb with
| Some (pdbr, _) -> pdbReadClose pdbr
| None -> ()
#endif
type ILReaderMetadataSnapshot = obj * nativeint * int
type ILReaderTryGetMetadataSnapshot = (* path: *) string (* snapshotTimeStamp: *) * DateTime -> ILReaderMetadataSnapshot option
type ILReaderTryGetMetadataSnapshot = (* path: *) string (* snapshotTimeStamp: *) * DateTime -> ILReaderMetadataSnapshot option
[<RequireQualifiedAccess>]
type MetadataOnlyFlag =
@ -5037,11 +4877,11 @@ type ILModuleReader =
inherit IDisposable
[<Sealed>]
type ILModuleReaderImpl(ilModule: ILModuleDef, ilAssemblyRefs: Lazy<ILAssemblyRef list>, dispose: unit -> unit) =
type ILModuleReaderImpl(ilModule: ILModuleDef, ilAssemblyRefs: Lazy<ILAssemblyRef list>) =
interface ILModuleReader with
member x.ILModuleDef = ilModule
member x.ILAssemblyRefs = ilAssemblyRefs.Force()
member x.Dispose() = dispose ()
member x.Dispose() = ()
// ++GLOBAL MUTABLE STATE (concurrency safe via locking)
type ILModuleReaderCacheKey = ILModuleReaderCacheKey of string * DateTime * bool * ReduceMemoryFlag * MetadataOnlyFlag
@ -5073,8 +4913,10 @@ let stableFileHeuristicApplies fileName =
let createByteFileChunk opts fileName chunk =
// If we're trying to reduce memory usage then we are willing to go back and re-read the binary, so we can use
// a weakly-held handle to an array of bytes.
if opts.reduceMemoryUsage = ReduceMemoryFlag.Yes
&& stableFileHeuristicApplies fileName then
if
opts.reduceMemoryUsage = ReduceMemoryFlag.Yes
&& stableFileHeuristicApplies fileName
then
WeakByteFile(fileName, chunk) :> BinaryFile
else
let bytes =
@ -5109,10 +4951,10 @@ let getBinaryFile fileName useMemoryMappedFile =
let OpenILModuleReaderFromBytes fileName assemblyContents options =
let pefile = ByteFile(fileName, assemblyContents) :> BinaryFile
let ilModule, ilAssemblyRefs, pdb =
openPE (fileName, pefile, options.pdbDirPath, (options.reduceMemoryUsage = ReduceMemoryFlag.Yes), true)
let ilModule, ilAssemblyRefs =
openPE (fileName, pefile, (options.reduceMemoryUsage = ReduceMemoryFlag.Yes), true)
new ILModuleReaderImpl(ilModule, ilAssemblyRefs, (fun () -> ClosePdbReader pdb)) :> ILModuleReader
new ILModuleReaderImpl(ilModule, ilAssemblyRefs) :> ILModuleReader
let OpenILModuleReaderFromStream fileName (peStream: Stream) options =
let peReader =
@ -5120,10 +4962,10 @@ let OpenILModuleReaderFromStream fileName (peStream: Stream) options =
let pefile = PEFile(fileName, peReader) :> BinaryFile
let ilModule, ilAssemblyRefs, pdb =
openPE (fileName, pefile, options.pdbDirPath, (options.reduceMemoryUsage = ReduceMemoryFlag.Yes), true)
let ilModule, ilAssemblyRefs =
openPE (fileName, pefile, (options.reduceMemoryUsage = ReduceMemoryFlag.Yes), true)
new ILModuleReaderImpl(ilModule, ilAssemblyRefs, (fun () -> ClosePdbReader pdb)) :> ILModuleReader
new ILModuleReaderImpl(ilModule, ilAssemblyRefs) :> ILModuleReader
let ClearAllILModuleReaderCache () =
ilModuleReaderCache1.Clear(ILModuleReaderCache1LockToken())
@ -5187,7 +5029,7 @@ let OpenILModuleReader fileName opts =
//
let ilModuleReader =
// Check if we are doing metadataOnly reading (the most common case in both the compiler and IDE)
if not runningOnMono && metadataOnly then
if metadataOnly then
// See if tryGetMetadata gives us a BinaryFile for the metadata section alone.
let mdfileOpt =
@ -5200,8 +5042,8 @@ let OpenILModuleReader fileName opts =
let disposer, pefileEager = getBinaryFile fullPath false
use _disposer = disposer
let metadataPhysLoc, metadataSize, peinfo, pectxtEager, pevEager, _pdb =
openPEFileReader (fullPath, pefileEager, None, false)
let metadataPhysLoc, metadataSize, peinfo, pectxtEager, pevEager =
openPEFileReader (fullPath, pefileEager, false)
let mdfile =
match mdfileOpt with
@ -5213,16 +5055,15 @@ let OpenILModuleReader fileName opts =
let ilModule, ilAssemblyRefs =
openPEMetadataOnly (fullPath, peinfo, pectxtEager, pevEager, mdfile, reduceMemoryUsage)
new ILModuleReaderImpl(ilModule, ilAssemblyRefs, ignore)
new ILModuleReaderImpl(ilModule, ilAssemblyRefs)
else
// If we are not doing metadata-only, then just go ahead and read all the bytes and hold them either strongly or weakly
// depending on the heuristic
let pefile = createByteFileChunk opts fullPath None
let ilModule, ilAssemblyRefs, _pdb =
openPE (fullPath, pefile, None, reduceMemoryUsage, false)
let ilModule, ilAssemblyRefs = openPE (fullPath, pefile, reduceMemoryUsage, false)
new ILModuleReaderImpl(ilModule, ilAssemblyRefs, ignore)
new ILModuleReaderImpl(ilModule, ilAssemblyRefs)
let ilModuleReader = ilModuleReader :> ILModuleReader
@ -5244,17 +5085,15 @@ let OpenILModuleReader fileName opts =
// multi-proc build. So use memory mapping, but only for stable files. Other files
// still use an in-memory ByteFile
let pefile =
if not runningOnMono && (alwaysMemoryMapFSC || stableFileHeuristicApplies fullPath) then
if alwaysMemoryMapFSC || stableFileHeuristicApplies fullPath then
let _, pefile = getBinaryFile fullPath false
pefile
else
createByteFileChunk opts fullPath None
let ilModule, ilAssemblyRefs, pdb =
openPE (fullPath, pefile, opts.pdbDirPath, reduceMemoryUsage, false)
let ilModule, ilAssemblyRefs = openPE (fullPath, pefile, reduceMemoryUsage, false)
let ilModuleReader =
new ILModuleReaderImpl(ilModule, ilAssemblyRefs, (fun () -> ClosePdbReader pdb))
let ilModuleReader = new ILModuleReaderImpl(ilModule, ilAssemblyRefs)
let ilModuleReader = ilModuleReader :> ILModuleReader

260
src/Compiler/AbstractIL/ilreflect.fs
Просмотреть файл

@ -31,32 +31,16 @@ let logRefEmitCalls = false
type AssemblyBuilder with
member asmB.DefineDynamicModuleAndLog(a, b, c) =
#if FX_RESHAPED_REFEMIT
ignore b
ignore c
let modB = asmB.DefineDynamicModule a
#else
let modB = asmB.DefineDynamicModule(a, b, c)
if logRefEmitCalls then
printfn "let moduleBuilder%d = assemblyBuilder%d.DefineDynamicModule(%A, %A, %A)" (abs <| hash modB) (abs <| hash asmB) a b c
#endif
member this.DefineDynamicModuleAndLog(assemblyName) =
let modB = this.DefineDynamicModule assemblyName
modB
member asmB.SetCustomAttributeAndLog(cinfo, bytes) =
member this.SetCustomAttributeAndLog(cinfo, bytes) =
if logRefEmitCalls then
printfn "assemblyBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash asmB) cinfo bytes
printfn "assemblyBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash this) cinfo bytes
wrapCustomAttr asmB.SetCustomAttribute (cinfo, bytes)
wrapCustomAttr this.SetCustomAttribute (cinfo, bytes)
#if !FX_RESHAPED_REFEMIT
member asmB.AddResourceFileAndLog(nm1, nm2, attrs) =
if logRefEmitCalls then
printfn "assemblyBuilder%d.AddResourceFile(%A, %A, enum %d)" (abs <| hash asmB) nm1 nm2 (LanguagePrimitives.EnumToValue attrs)
asmB.AddResourceFile(nm1, nm2, attrs)
#endif
member asmB.SetCustomAttributeAndLog cab =
if logRefEmitCalls then
printfn "assemblyBuilder%d.SetCustomAttribute(%A)" (abs <| hash asmB) cab
@ -71,22 +55,6 @@ type ModuleBuilder with
modB.GetArrayMethod(arrayTy, nm, flags, retTy, argTys)
#if !FX_RESHAPED_REFEMIT
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
symDoc
#endif
member modB.GetTypeAndLog(nameInModule, flag1, flag2) =
if logRefEmitCalls then
printfn "moduleBuilder%d.GetType(%A, %A, %A) |> ignore" (abs <| hash modB) nameInModule flag1 flag2
@ -106,18 +74,6 @@ type ModuleBuilder with
typB
#if !FX_RESHAPED_REFEMIT
member modB.DefineManifestResourceAndLog(name, stream, attrs) =
if logRefEmitCalls then
printfn
"moduleBuilder%d.DefineManifestResource(%A, %A, enum %d)"
(abs <| hash modB)
name
stream
(LanguagePrimitives.EnumToValue attrs)
modB.DefineManifestResource(name, stream, attrs)
#endif
member modB.SetCustomAttributeAndLog(cinfo, bytes) =
if logRefEmitCalls then
printfn "moduleBuilder%d.SetCustomAttribute(%A, %A)" (abs <| hash modB) cinfo bytes
@ -206,11 +162,9 @@ type TypeBuilder with
member typB.CreateTypeAndLog() =
if logRefEmitCalls then
printfn "typeBuilder%d.CreateType()" (abs <| hash typB)
#if FX_RESHAPED_REFEMIT
typB.CreateTypeInfo().AsType()
#else
typB.CreateType()
#endif
member typB.DefineNestedTypeAndLog(name, attrs) =
let res = typB.DefineNestedType(name, attrs)
@ -308,7 +262,6 @@ type TypeBuilder with
typB.AddInterfaceImplementation ty
member typB.InvokeMemberAndLog(nm, _flags, args) =
#if FX_RESHAPED_REFEMIT
let t = typB.CreateTypeAndLog()
let m =
@ -321,17 +274,6 @@ type TypeBuilder with
m.Invoke(null, args)
else
raise (MissingMethodException nm)
#else
if logRefEmitCalls then
printfn
"typeBuilder%d.InvokeMember(\"%s\", enum %d, null, null, %A, Globalization.CultureInfo.InvariantCulture)"
(abs <| hash typB)
nm
(LanguagePrimitives.EnumToValue _flags)
args
typB.InvokeMember(nm, _flags, null, null, args, Globalization.CultureInfo.InvariantCulture)
#endif
member typB.SetCustomAttributeAndLog(cinfo, bytes) =
if logRefEmitCalls then
@ -360,13 +302,6 @@ type ILGenerator with
ilG.MarkLabel lab
#if !FX_RESHAPED_REFEMIT
member ilG.MarkSequencePointAndLog(symDoc, l1, c1, l2, c2) =
if logRefEmitCalls then
printfn "ilg%d.MarkSequencePoint(docWriter%d, %A, %A, %A, %A)" (abs <| hash ilG) (abs <| hash symDoc) l1 c1 l2 c2
ilG.MarkSequencePoint(symDoc, l1, c1, l2, c2)
#endif
member ilG.BeginExceptionBlockAndLog() =
if logRefEmitCalls then
printfn "ilg%d.BeginExceptionBlock()" (abs <| hash ilG)
@ -479,11 +414,11 @@ module Zmap =
let equalTypes (s: Type) (t: Type) = s.Equals t
let equalTypeLists ss tt =
List.lengthsEqAndForall2 equalTypes ss tt
let equalTypeLists (tys1: Type list) (tys2: Type list) =
List.lengthsEqAndForall2 equalTypes tys1 tys2
let equalTypeArrays ss tt =
Array.lengthsEqAndForall2 equalTypes ss tt
let equalTypeArrays (tys1: Type[]) (tys2: Type[]) =
Array.lengthsEqAndForall2 equalTypes tys1 tys2
let getGenericArgumentsOfType (typT: Type) =
if typT.IsGenericType then
@ -631,24 +566,7 @@ let envUpdateCreatedTypeRef emEnv (tref: ILTypeRef) =
if typB.IsCreated() then
let ty = typB.CreateTypeAndLog()
#if ENABLE_MONO_SUPPORT
// Mono has a bug where executing code that includes an array type
// match "match x with :? C[] -> ..." before the full loading of an object of type
// causes a failure when C is later loaded. One workaround for this is to attempt to do a fake allocation
// of objects. We use System.Runtime.Serialization.FormatterServices.GetUninitializedObject to do
// the fake allocation - this creates an "empty" object, even if the object doesn't have
// a constructor. It is not usable in partial trust code.
if runningOnMono
&& ty.IsClass
&& not ty.IsAbstract
&& not ty.IsGenericType
&& not ty.IsGenericTypeDefinition then
try
System.Runtime.Serialization.FormatterServices.GetUninitializedObject ty
|> ignore
with _ ->
()
#endif
{ emEnv with
emTypMap = Zmap.add tref (typT, typB, typeDef, Some ty) emEnv.emTypMap
}
@ -896,17 +814,7 @@ let convReturnModifiers cenv emEnv (p: ILReturn) =
// have to use alternative means for various Method/Field/Constructor lookups. However since
// it isn't we resort to this technique...
let TypeBuilderInstantiationT =
let ty =
#if ENABLE_MONO_SUPPORT
if runningOnMono then
let ty = Type.GetType("System.Reflection.MonoGenericClass")
match ty with
| null -> Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation")
| _ -> ty
else
#endif
Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation")
let ty = Type.GetType("System.Reflection.Emit.TypeBuilderInstantiation")
assert (not (isNull ty))
ty
@ -972,7 +880,9 @@ let convFieldSpec cenv emEnv fspec =
nonQueryableTypeGetField parentTI fieldB
else
// Prior type.
if typeIsNotQueryable parentTI then
if
typeIsNotQueryable parentTI
then
let parentT = getTypeConstructor parentTI
let fieldInfo = queryableTypeGetField emEnv parentT fref
nonQueryableTypeGetField parentTI fieldInfo
@ -1009,10 +919,12 @@ let queryableTypeGetMethodBySearch cenv emEnv parentT (mref: ILMethodRef) =
| Some a ->
if
// obvious case
p.IsAssignableFrom a then
p.IsAssignableFrom a
then
true
elif
p.IsGenericType && a.IsGenericType
p.IsGenericType
&& a.IsGenericType
// non obvious due to contravariance: Action<T> where T: IFoo accepts Action<FooImpl> (for FooImpl: IFoo)
&& p.GetGenericTypeDefinition().IsAssignableFrom(a.GetGenericTypeDefinition())
then
@ -1124,8 +1036,10 @@ let queryableTypeGetMethod cenv emEnv parentT (mref: ILMethodRef) : MethodInfo =
queryableTypeGetMethodBySearch cenv emEnv parentT mref
let nonQueryableTypeGetMethod (parentTI: Type) (methInfo: MethodInfo) : MethodInfo MaybeNull =
if (parentTI.IsGenericType
&& not (equalTypes parentTI (getTypeConstructor parentTI))) then
if
(parentTI.IsGenericType
&& not (equalTypes parentTI (getTypeConstructor parentTI)))
then
TypeBuilder.GetMethod(parentTI, methInfo)
else
methInfo
@ -1141,7 +1055,9 @@ let convMethodRef cenv emEnv (parentTI: Type) (mref: ILMethodRef) =
nonQueryableTypeGetMethod parentTI methB
else
// Prior type.
if typeIsNotQueryable parentTI then
if
typeIsNotQueryable parentTI
then
let parentT = getTypeConstructor parentTI
let methInfo = queryableTypeGetMethod cenv emEnv parentT mref
nonQueryableTypeGetMethod parentTI methInfo
@ -1216,7 +1132,9 @@ let convConstructorSpec cenv emEnv (mspec: ILMethodSpec) =
nonQueryableTypeGetConstructor parentTI consB
else
// Prior type.
if typeIsNotQueryable parentTI then
if
typeIsNotQueryable parentTI
then
let parentT = getTypeConstructor parentTI
let ctorG = queryableTypeGetConstructor cenv emEnv parentT mref
nonQueryableTypeGetConstructor parentTI ctorG
@ -1473,9 +1391,10 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr =
emitSilverlightCheck ilG
emitInstrCall cenv emEnv ilG OpCodes.Callvirt tail mspec varargs
| I_callconstraint (tail, ty, mspec, varargs) ->
| I_callconstraint (callvirt, tail, ty, mspec, varargs) ->
ilG.Emit(OpCodes.Constrained, convType cenv emEnv ty)
emitInstrCall cenv emEnv ilG OpCodes.Callvirt tail mspec varargs
let instr = if callvirt then OpCodes.Callvirt else OpCodes.Call
emitInstrCall cenv emEnv ilG instr tail mspec varargs
| I_calli (tail, callsig, None) ->
emitInstrTail cenv ilG tail (fun () ->
@ -1621,12 +1540,6 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr =
let elemTy = arrayTy.GetElementType()
let meth =
#if ENABLE_MONO_SUPPORT
// See bug 6254: Mono has a bug in reflection-emit dynamic calls to the "Get", "Address" or "Set" methods on arrays
if runningOnMono then
getArrayMethInfo shape.Rank elemTy
else
#endif
modB.GetArrayMethodAndLog(arrayTy, "Get", CallingConventions.HasThis, elemTy, Array.create shape.Rank typeof<int>)
ilG.EmitAndLog(OpCodes.Call, meth)
@ -1639,12 +1552,6 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr =
let elemTy = arrayTy.GetElementType()
let meth =
#if ENABLE_MONO_SUPPORT
// See bug 6254: Mono has a bug in reflection-emit dynamic calls to the "Get", "Address" or "Set" methods on arrays
if runningOnMono then
setArrayMethInfo shape.Rank elemTy
else
#endif
modB.GetArrayMethodAndLog(
arrayTy,
"Set",
@ -1672,27 +1579,7 @@ let rec emitInstr cenv (modB: ModuleBuilder) emEnv (ilG: ILGenerator) instr =
| I_refanyval ty -> ilG.EmitAndLog(OpCodes.Refanyval, convType cenv emEnv ty)
| I_rethrow -> ilG.EmitAndLog OpCodes.Rethrow
| I_break -> ilG.EmitAndLog OpCodes.Break
| I_seqpoint src ->
#if FX_RESHAPED_REFEMIT
ignore src
()
#else
if cenv.generatePdb && not (src.Document.File.EndsWithOrdinal("stdin")) 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
)
ilG.MarkSequencePointAndLog(symDoc, src.Line, src.Column, src.EndLine, src.EndColumn)
#endif
| I_seqpoint _ -> ()
| I_arglist -> ilG.EmitAndLog OpCodes.Arglist
| I_localloc -> ilG.EmitAndLog OpCodes.Localloc
@ -1801,11 +1688,6 @@ let emitCode cenv modB emEnv (ilG: ILGenerator) (code: ILCode) =
let emitLocal cenv emEnv (ilG: ILGenerator) (local: ILLocal) =
let ty = convType cenv emEnv local.Type
let locBuilder = ilG.DeclareLocalAndLog(ty, local.IsPinned)
#if !FX_NO_PDB_WRITER
match local.DebugInfo with
| Some (nm, start, finish) -> locBuilder.SetLocalSymInfo(nm, start, finish)
| None -> ()
#endif
locBuilder
let emitILMethodBody cenv modB emEnv (ilG: ILGenerator) (ilmbody: ILMethodBody) =
@ -1916,12 +1798,6 @@ let emitParameter cenv emEnv (defineParameter: int * ParameterAttributes * strin
// buildMethodPass2
//----------------------------------------------------------------------------
#if !FX_RESHAPED_REFEMIT || NETCOREAPP3_1
let enablePInvoke = true
#else
// Use reflection to invoke the api when we are executing on a platform that doesn't directly have this API.
let definePInvokeMethod =
typeof<TypeBuilder>.GetMethod
@ -1943,7 +1819,6 @@ let definePInvokeMethod =
|])
let enablePInvoke = definePInvokeMethod <> null
#endif
let rec buildMethodPass2 cenv tref (typB: TypeBuilder) emEnv (mdef: ILMethodDef) =
let attrs = mdef.Attributes
@ -1982,12 +1857,6 @@ let rec buildMethodPass2 cenv tref (typB: TypeBuilder) emEnv (mdef: ILMethodDef)
// p.CharBestFit
// p.NoMangle
#if !FX_RESHAPED_REFEMIT || NETCOREAPP3_1
// DefinePInvokeMethod was removed in early versions of coreclr, it was added back in NETCOREAPP3.
// It has always been available in the desktop framework
let methB =
typB.DefinePInvokeMethod(mdef.Name, p.Where.Name, p.Name, attrs, cconv, retTy, null, null, argTys, null, null, pcc, pcs)
#else
// Use reflection to invoke the api when we are executing on a platform that doesn't directly have this API.
let methB =
System.Diagnostics.Debug.Assert(definePInvokeMethod <> null, "Runtime does not have DefinePInvokeMethod") // Absolutely can't happen
@ -2011,7 +1880,7 @@ let rec buildMethodPass2 cenv tref (typB: TypeBuilder) emEnv (mdef: ILMethodDef)
|]
)
:?> MethodBuilder
#endif
methB.SetImplementationFlagsAndLog implflags
envBindMethodRef emEnv mref methB
@ -2134,9 +2003,11 @@ let buildFieldPass2 cenv tref (typB: TypeBuilder) emEnv (fdef: ILFieldDef) =
match fdef.LiteralValue with
| None -> emEnv
| Some initial ->
if not fieldT.IsEnum
// it is ok to init fields with type = enum that are defined in other assemblies
|| not fieldT.Assembly.IsDynamic then
if
not fieldT.IsEnum
// it is ok to init fields with type = enum that are defined in other assemblies
|| not fieldT.Assembly.IsDynamic
then
fieldB.SetConstant(initial.AsObject())
emEnv
else
@ -2267,9 +2138,10 @@ let typeAttributesOfTypeLayout cenv emEnv x =
if p.Size = None && p.Pack = None then
None
else
match cenv.tryFindSysILTypeRef "System.Runtime.InteropServices.StructLayoutAttribute",
cenv.tryFindSysILTypeRef "System.Runtime.InteropServices.LayoutKind"
with
match
cenv.tryFindSysILTypeRef "System.Runtime.InteropServices.StructLayoutAttribute",
cenv.tryFindSysILTypeRef "System.Runtime.InteropServices.LayoutKind"
with
| Some tref1, Some tref2 ->
Some(
convCustomAttr
@ -2564,7 +2436,8 @@ let createTypeRef (visited: Dictionary<_, _>, created: Dictionary<_, _>) emEnv t
match emEnv.emTypMap.TryFind typeRef with
| Some (_, tb, _, _) ->
if not (tb.IsCreated()) then tb.CreateTypeAndLog() |> ignore
if not (tb.IsCreated()) then
tb.CreateTypeAndLog() |> ignore
tb.Assembly
| None -> null)
@ -2590,7 +2463,8 @@ let createTypeRef (visited: Dictionary<_, _>, created: Dictionary<_, _>) emEnv t
traverseTypeRef tref
let rec buildTypeDefPass4 (visited, created) nesting emEnv (tdef: ILTypeDef) =
if verbose2 then dprintf "buildTypeDefPass4 %s\n" tdef.Name
if verbose2 then
dprintf "buildTypeDefPass4 %s\n" tdef.Name
let tref = mkRefForNestedILTypeDef ILScopeRef.Local (nesting, tdef)
createTypeRef (visited, created) emEnv tref
@ -2620,7 +2494,7 @@ let buildModuleTypePass4 visited emEnv tdef = buildTypeDefPass4 visited [] emEnv
// buildModuleFragment - only the types the fragment get written
//----------------------------------------------------------------------------
let buildModuleFragment cenv emEnv (asmB: AssemblyBuilder) (modB: ModuleBuilder) (m: ILModuleDef) =
let buildModuleFragment cenv emEnv (modB: ModuleBuilder) (m: ILModuleDef) =
let tdefs = m.TypeDefs.AsList()
let emEnv = (emEnv, tdefs) ||> List.fold (buildModuleTypePass1 cenv modB)
@ -2638,35 +2512,14 @@ let buildModuleFragment cenv emEnv (asmB: AssemblyBuilder) (modB: ModuleBuilder)
tdefs |> List.iter (buildModuleTypePass4 (visited, created) emEnv)
let emEnv = Seq.fold envUpdateCreatedTypeRef emEnv created.Keys // update typT with the created typT
emitCustomAttrs cenv emEnv modB.SetCustomAttributeAndLog m.CustomAttrs
#if FX_RESHAPED_REFEMIT
ignore asmB
#else
m.Resources.AsList()
|> List.iter (fun r ->
let attribs =
(match r.Access with
| ILResourceAccess.Public -> ResourceAttributes.Public
| ILResourceAccess.Private -> ResourceAttributes.Private)
match r.Location with
| ILResourceLocation.Local bytes ->
use stream = bytes.GetByteMemory().AsStream()
modB.DefineManifestResourceAndLog(r.Name, stream, attribs)
| ILResourceLocation.File (mr, _) -> asmB.AddResourceFileAndLog(r.Name, mr.Name, attribs)
| ILResourceLocation.Assembly _ -> failwith "references to resources other assemblies may not be emitted using System.Reflection")
#endif
emEnv
//----------------------------------------------------------------------------
// test hook
//----------------------------------------------------------------------------
let defineDynamicAssemblyAndLog (asmName, flags, asmDir: string) =
#if FX_NO_APP_DOMAINS
let asmB = AssemblyBuilder.DefineDynamicAssembly(asmName, flags)
#else
let currentDom = System.AppDomain.CurrentDomain
let asmB = currentDom.DefineDynamicAssembly(asmName, flags, asmDir)
#endif
if logRefEmitCalls then
printfn "open System"
printfn "open System.Reflection"
@ -2681,8 +2534,7 @@ let defineDynamicAssemblyAndLog (asmName, flags, asmDir: string) =
asmB
let mkDynamicAssemblyAndModule (assemblyName, optimize, debugInfo: bool, collectible) =
let fileName = assemblyName + ".dll"
let mkDynamicAssemblyAndModule (assemblyName, optimize, collectible) =
let asmDir = "."
let asmName = AssemblyName()
asmName.Name <- assemblyName
@ -2690,13 +2542,9 @@ let mkDynamicAssemblyAndModule (assemblyName, optimize, debugInfo: bool, collect
let asmAccess =
if collectible then
AssemblyBuilderAccess.RunAndCollect
#if FX_RESHAPED_REFEMIT
else
AssemblyBuilderAccess.Run
#else
else
AssemblyBuilderAccess.RunAndSave
#endif
let asmB = defineDynamicAssemblyAndLog (asmName, asmAccess, asmDir)
if not optimize then
@ -2716,7 +2564,7 @@ let mkDynamicAssemblyAndModule (assemblyName, optimize, debugInfo: bool, collect
asmB.SetCustomAttributeAndLog daBuilder
let modB = asmB.DefineDynamicModuleAndLog(assemblyName, fileName, debugInfo)
let modB = asmB.DefineDynamicModuleAndLog(assemblyName)
asmB, modB
let EmitDynamicAssemblyFragment
@ -2740,7 +2588,7 @@ let EmitDynamicAssemblyFragment
tryFindSysILTypeRef = tryFindSysILTypeRef
}
let emEnv = buildModuleFragment cenv emEnv asmB modB modul
let emEnv = buildModuleFragment cenv emEnv modB modul
match modul.Manifest with
| None -> ()

2
src/Compiler/AbstractIL/ilreflect.fsi
Просмотреть файл

@ -9,7 +9,7 @@ open System.Reflection.Emit
open FSharp.Compiler.AbstractIL.IL
val mkDynamicAssemblyAndModule:
assemblyName: string * optimize: bool * debugInfo: bool * collectible: bool -> AssemblyBuilder * ModuleBuilder
assemblyName: string * optimize: bool * collectible: bool -> AssemblyBuilder * ModuleBuilder
type cenv =
{ ilg: ILGlobals

311
src/Compiler/AbstractIL/ilsign.fs
Просмотреть файл

@ -352,277 +352,6 @@ let signerSignFileWithKeyPair (fileName: string) (kp: keyPair) : unit = signFile
let signerSignFileWithKeyContainer (_fileName: string) (_kcName: keyContainerName) : unit =
raise (NotImplementedException("signerSignFileWithKeyContainer is not yet implemented"))
#if !FX_NO_CORHOST_SIGNER
open System.Runtime.CompilerServices
// New mscoree functionality
// This type represents methods that we don't currently need, so I'm leaving unimplemented
type UnusedCOMMethod = unit -> unit
[<System.Security.SecurityCritical; Interface>]
[<ComImport; InterfaceType(ComInterfaceType.InterfaceIsIUnknown); Guid("D332DB9E-B9B3-4125-8207-A14884F53216")>]
type ICLRMetaHost =
[<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType = MethodCodeType.Runtime)>]
abstract GetRuntime:
[<In; MarshalAs(UnmanagedType.LPWStr)>] version: string * [<In; MarshalAs(UnmanagedType.LPStruct)>] interfaceId: System.Guid ->
[<MarshalAs(UnmanagedType.Interface)>] System.Object
// Methods that we don't need are stubbed out for now...
abstract GetVersionFromFile: UnusedCOMMethod
abstract EnumerateInstalledRuntimes: UnusedCOMMethod
abstract EnumerateLoadedRuntimes: UnusedCOMMethod
abstract Reserved01: UnusedCOMMethod
// We don't currently support ComConversionLoss
[<System.Security.SecurityCritical; Interface>]
[<ComImport; ComConversionLoss; InterfaceType(ComInterfaceType.InterfaceIsIUnknown); Guid("9FD93CCF-3280-4391-B3A9-96E1CDE77C8D")>]
type ICLRStrongName =
// Methods that we don't need are stubbed out for now...
abstract GetHashFromAssemblyFile: UnusedCOMMethod
abstract GetHashFromAssemblyFileW: UnusedCOMMethod
abstract GetHashFromBlob: UnusedCOMMethod
abstract GetHashFromFile: UnusedCOMMethod
abstract GetHashFromFileW: UnusedCOMMethod
abstract GetHashFromHandle: UnusedCOMMethod
abstract StrongNameCompareAssemblies: UnusedCOMMethod
[<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType = MethodCodeType.Runtime)>]
abstract StrongNameFreeBuffer: [<In>] pbMemory: nativeint -> unit
abstract StrongNameGetBlob: UnusedCOMMethod
abstract StrongNameGetBlobFromImage: UnusedCOMMethod
[<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType = MethodCodeType.Runtime)>]
abstract StrongNameGetPublicKey:
[<In; MarshalAs(UnmanagedType.LPWStr)>] pwzKeyContainer: string *
[<In; MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 2s)>] pbKeyBlob: byte[] *
[<In; MarshalAs(UnmanagedType.U4)>] cbKeyBlob: uint32 *
[<Out>] ppbPublicKeyBlob: nativeint byref *
[<Out; MarshalAs(UnmanagedType.U4)>] pcbPublicKeyBlob: uint32 byref ->
unit
abstract StrongNameHashSize: UnusedCOMMethod
[<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType = MethodCodeType.Runtime)>]
abstract StrongNameKeyDelete: [<In; MarshalAs(UnmanagedType.LPWStr)>] pwzKeyContainer: string -> unit
abstract StrongNameKeyGen: UnusedCOMMethod
abstract StrongNameKeyGenEx: UnusedCOMMethod
abstract StrongNameKeyInstall: UnusedCOMMethod
[<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType = MethodCodeType.Runtime)>]
abstract StrongNameSignatureGeneration:
[<In; MarshalAs(UnmanagedType.LPWStr)>] pwzFilePath: string *
[<In; MarshalAs(UnmanagedType.LPWStr)>] pwzKeyContainer: string *
[<In; MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 3s)>] pbKeyBlob: byte[] *
[<In; MarshalAs(UnmanagedType.U4)>] cbKeyBlob: uint32 *
[<Out>] ppbSignatureBlob: nativeint *
[<MarshalAs(UnmanagedType.U4)>] pcbSignatureBlob: uint32 byref ->
unit
abstract StrongNameSignatureGenerationEx: UnusedCOMMethod
[<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType = MethodCodeType.Runtime)>]
abstract StrongNameSignatureSize:
[<In; MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 1s)>] pbPublicKeyBlob: byte[] *
[<In; MarshalAs(UnmanagedType.U4)>] cbPublicKeyBlob: uint32 *
[<Out; MarshalAs(UnmanagedType.U4)>] pcbSize: uint32 byref ->
unit
abstract StrongNameSignatureVerification: UnusedCOMMethod
[<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType = MethodCodeType.Runtime)>]
abstract StrongNameSignatureVerificationEx:
[<In; MarshalAs(UnmanagedType.LPWStr)>] pwzFilePath: string *
[<In; MarshalAs(UnmanagedType.I1)>] fForceVerification: bool *
[<In; MarshalAs(UnmanagedType.I1)>] pfWasVerified: bool byref ->
[<MarshalAs(UnmanagedType.I1)>] bool
abstract StrongNameSignatureVerificationFromImage: UnusedCOMMethod
abstract StrongNameTokenFromAssembly: UnusedCOMMethod
abstract StrongNameTokenFromAssemblyEx: UnusedCOMMethod
abstract StrongNameTokenFromPublicKey: UnusedCOMMethod
[<System.Security.SecurityCritical; Interface>]
[<ComImport; InterfaceType(ComInterfaceType.InterfaceIsIUnknown); Guid("BD39D1D2-BA2F-486A-89B0-B4B0CB466891")>]
type ICLRRuntimeInfo =
// REVIEW: Methods that we don't need will be stubbed out for now...
abstract GetVersionString: unit -> unit
abstract GetRuntimeDirectory: unit -> unit
abstract IsLoaded: unit -> unit
abstract LoadErrorString: unit -> unit
abstract LoadLibrary: unit -> unit
abstract GetProcAddress: unit -> unit
[<MethodImpl(MethodImplOptions.InternalCall, MethodCodeType = MethodCodeType.Runtime)>]
abstract GetInterface:
[<In; MarshalAs(UnmanagedType.LPStruct)>] coClassId: System.Guid *
[<In; MarshalAs(UnmanagedType.LPStruct)>] interfaceId: System.Guid ->
[<MarshalAs(UnmanagedType.Interface)>] System.Object
[<System.Security.SecurityCritical>]
[<DllImport("mscoree.dll", SetLastError = true, PreserveSig = false, EntryPoint = "CreateInterface")>]
let CreateInterface
(
([<MarshalAs(UnmanagedType.LPStruct)>] _clsidguid: System.Guid),
([<MarshalAs(UnmanagedType.LPStruct)>] _guid: System.Guid),
([<MarshalAs(UnmanagedType.Interface)>] _metaHost: ICLRMetaHost byref)
) : unit =
failwith "CreateInterface"
let legacySignerOpenPublicKeyFile filePath =
FileSystem.OpenFileForReadShim(filePath).ReadAllBytes()
let legacySignerOpenKeyPairFile filePath =
FileSystem.OpenFileForReadShim(filePath).ReadAllBytes()
let mutable iclrsn: ICLRStrongName option = None
let getICLRStrongName () =
match iclrsn with
| None ->
let CLSID_CLRStrongName =
System.Guid(0xB79B0ACDu, 0xF5CDus, 0x409bus, 0xB5uy, 0xA5uy, 0xA1uy, 0x62uy, 0x44uy, 0x61uy, 0x0Buy, 0x92uy)
let IID_ICLRStrongName =
System.Guid(0x9FD93CCFu, 0x3280us, 0x4391us, 0xB3uy, 0xA9uy, 0x96uy, 0xE1uy, 0xCDuy, 0xE7uy, 0x7Cuy, 0x8Duy)
let CLSID_CLRMetaHost =
System.Guid(0x9280188Du, 0x0E8Eus, 0x4867us, 0xB3uy, 0x0Cuy, 0x7Fuy, 0xA8uy, 0x38uy, 0x84uy, 0xE8uy, 0xDEuy)
let IID_ICLRMetaHost =
System.Guid(0xD332DB9Eu, 0xB9B3us, 0x4125us, 0x82uy, 0x07uy, 0xA1uy, 0x48uy, 0x84uy, 0xF5uy, 0x32uy, 0x16uy)
let clrRuntimeInfoGuid =
System.Guid(0xBD39D1D2u, 0xBA2Fus, 0x486aus, 0x89uy, 0xB0uy, 0xB4uy, 0xB0uy, 0xCBuy, 0x46uy, 0x68uy, 0x91uy)
let runtimeVer =
System.Runtime.InteropServices.RuntimeEnvironment.GetSystemVersion()
let mutable metaHost = Unchecked.defaultof<ICLRMetaHost>
CreateInterface(CLSID_CLRMetaHost, IID_ICLRMetaHost, &metaHost)
if Unchecked.defaultof<ICLRMetaHost> = metaHost then
failwith "Unable to obtain ICLRMetaHost object - check freshness of mscoree.dll"
let runtimeInfo =
metaHost.GetRuntime(runtimeVer, clrRuntimeInfoGuid) :?> ICLRRuntimeInfo
let sn =
runtimeInfo.GetInterface(CLSID_CLRStrongName, IID_ICLRStrongName) :?> ICLRStrongName
if Unchecked.defaultof<ICLRStrongName> = sn then
failwith "Unable to obtain ICLRStrongName object"
iclrsn <- Some sn
sn
| Some sn -> sn
let legacySignerGetPublicKeyForKeyPair kp =
if runningOnMono then
let snt = System.Type.GetType("Mono.Security.StrongName")
let sn = System.Activator.CreateInstance(snt, [| box kp |])
snt.InvokeMember(
"PublicKey",
(BindingFlags.GetProperty ||| BindingFlags.Instance ||| BindingFlags.Public),
null,
sn,
[||],
Globalization.CultureInfo.InvariantCulture
)
:?> byte[]
else
let mutable pSize = 0u
let mutable pBuffer: nativeint = (nativeint) 0
let iclrSN = getICLRStrongName ()
iclrSN.StrongNameGetPublicKey(Unchecked.defaultof<string>, kp, (uint32) kp.Length, &pBuffer, &pSize)
|> ignore
let mutable keybuffer: byte[] = Bytes.zeroCreate (int pSize)
// Copy the marshalled data over - we'll have to free this ourselves
Marshal.Copy(pBuffer, keybuffer, 0, int pSize)
iclrSN.StrongNameFreeBuffer pBuffer |> ignore
keybuffer
let legacySignerGetPublicKeyForKeyContainer kc =
let mutable pSize = 0u
let mutable pBuffer: nativeint = (nativeint) 0
let iclrSN = getICLRStrongName ()
iclrSN.StrongNameGetPublicKey(kc, Unchecked.defaultof<byte[]>, 0u, &pBuffer, &pSize)
|> ignore
let mutable keybuffer: byte[] = Bytes.zeroCreate (int pSize)
// Copy the marshalled data over - we'll have to free this ourselves later
Marshal.Copy(pBuffer, keybuffer, 0, int pSize)
iclrSN.StrongNameFreeBuffer pBuffer |> ignore
keybuffer
let legacySignerCloseKeyContainer kc =
let iclrSN = getICLRStrongName ()
iclrSN.StrongNameKeyDelete kc |> ignore
let legacySignerSignatureSize (pk: byte[]) =
if runningOnMono then
if pk.Length > 32 then pk.Length - 32 else 128
else
let mutable pSize = 0u
let iclrSN = getICLRStrongName ()
iclrSN.StrongNameSignatureSize(pk, uint32 pk.Length, &pSize) |> ignore
int pSize
let legacySignerSignFileWithKeyPair fileName kp =
if runningOnMono then
let snt = System.Type.GetType("Mono.Security.StrongName")
let sn = System.Activator.CreateInstance(snt, [| box kp |])
let conv (x: obj) = if (unbox x: bool) then 0 else -1
snt.InvokeMember(
"Sign",
(BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public),
null,
sn,
[| box fileName |],
Globalization.CultureInfo.InvariantCulture
)
|> conv
|> check "Sign"
snt.InvokeMember(
"Verify",
(BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public),
null,
sn,
[| box fileName |],
Globalization.CultureInfo.InvariantCulture
)
|> conv
|> check "Verify"
else
let mutable pcb = 0u
let mutable ppb = (nativeint) 0
let mutable ok = false
let iclrSN = getICLRStrongName ()
iclrSN.StrongNameSignatureGeneration(fileName, Unchecked.defaultof<string>, kp, uint32 kp.Length, ppb, &pcb)
|> ignore
iclrSN.StrongNameSignatureVerificationEx(fileName, true, &ok) |> ignore
let legacySignerSignFileWithKeyContainer fileName kcName =
let mutable pcb = 0u
let mutable ppb = (nativeint) 0
let mutable ok = false
let iclrSN = getICLRStrongName ()
iclrSN.StrongNameSignatureGeneration(fileName, kcName, Unchecked.defaultof<byte[]>, 0u, ppb, &pcb)
|> ignore
iclrSN.StrongNameSignatureVerificationEx(fileName, true, &ok) |> ignore
#endif
let failWithContainerSigningUnsupportedOnThisPlatform () =
failwith (FSComp.SR.containerSigningUnsupportedOnThisPlatform () |> snd)
@ -647,13 +376,8 @@ type ILStrongNameSigner =
| PublicKeySigner _
| PublicKeyOptionsSigner _
| KeyPair _ -> ()
| KeyContainer containerName ->
#if !FX_NO_CORHOST_SIGNER
legacySignerCloseKeyContainer containerName
#else
ignore containerName
failWithContainerSigningUnsupportedOnThisPlatform ()
#endif
| KeyContainer _ -> failWithContainerSigningUnsupportedOnThisPlatform ()
member s.IsFullySigned =
match s with
| PublicKeySigner _ -> false
@ -661,12 +385,7 @@ type ILStrongNameSigner =
let _, usePublicSign = pko
usePublicSign
| KeyPair _ -> true
| KeyContainer _ ->
#if !FX_NO_CORHOST_SIGNER
true
#else
failWithContainerSigningUnsupportedOnThisPlatform ()
#endif
| KeyContainer _ -> failWithContainerSigningUnsupportedOnThisPlatform ()
member s.PublicKey =
match s with
@ -675,13 +394,7 @@ type ILStrongNameSigner =
let pk, _ = pko
pk
| KeyPair kp -> signerGetPublicKeyForKeyPair kp
| KeyContainer containerName ->
#if !FX_NO_CORHOST_SIGNER
legacySignerGetPublicKeyForKeyContainer containerName
#else
ignore containerName
failWithContainerSigningUnsupportedOnThisPlatform ()
#endif
| KeyContainer _ -> failWithContainerSigningUnsupportedOnThisPlatform ()
member s.SignatureSize =
let pkSignatureSize pk =
@ -697,23 +410,11 @@ type ILStrongNameSigner =
let pk, _ = pko
pkSignatureSize pk
| KeyPair kp -> pkSignatureSize (signerGetPublicKeyForKeyPair kp)
| KeyContainer containerName ->
#if !FX_NO_CORHOST_SIGNER
pkSignatureSize (legacySignerGetPublicKeyForKeyContainer containerName)
#else
ignore containerName
failWithContainerSigningUnsupportedOnThisPlatform ()
#endif
| KeyContainer _ -> failWithContainerSigningUnsupportedOnThisPlatform ()
member s.SignFile file =
match s with
| PublicKeySigner _ -> ()
| PublicKeyOptionsSigner _ -> ()
| KeyPair kp -> signerSignFileWithKeyPair file kp
| KeyContainer containerName ->
#if !FX_NO_CORHOST_SIGNER
legacySignerSignFileWithKeyContainer file containerName
#else
ignore containerName
failWithContainerSigningUnsupportedOnThisPlatform ()
#endif
| KeyContainer _ -> failWithContainerSigningUnsupportedOnThisPlatform ()

548
src/Compiler/AbstractIL/ilsupp.fs
Просмотреть файл

@ -5,15 +5,10 @@ module internal FSharp.Compiler.AbstractIL.Support
open System
open System.IO
open System.Reflection
#if !FX_NO_SYMBOLSTORE
open System.Diagnostics.SymbolStore
#endif
open System.Runtime.InteropServices
open Internal.Utilities.Library
open FSharp.Compiler.AbstractIL.NativeRes
open FSharp.Compiler.IO
#if FX_NO_CORHOST_SIGNER
#endif
let DateTime1970Jan01 =
DateTime(1970, 1, 1, 0, 0, 0, DateTimeKind.Utc) (* ECMA Spec (Oct2002), Part II, 24.2.2 PE File Header. *)
@ -611,7 +606,8 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink
let bNil = Bytes.zeroCreate 3
// Align remaining fields on DWORD (nb. poor bit twiddling code taken from ildasm's dres.cpp)
if (dwFiller &&& 0x1) <> 0 then SaveChunk(bNil, 2)
if (dwFiller &&& 0x1) <> 0 then
SaveChunk(bNil, 2)
//---- Constant part of the header: DWORD, WORD, WORD, DWORD, DWORD
SaveChunk(dwToBytes resHdr.DataVersion)
@ -627,7 +623,8 @@ type ResFormatNode(tid: int32, nid: int32, lid: int32, dataOffset: int32, pbLink
dwFiller <- dataEntry.Size &&& 0x3
if dwFiller <> 0 then SaveChunk(bNil, 4 - dwFiller)
if dwFiller <> 0 then
SaveChunk(bNil, 4 - dwFiller)
size
@ -769,540 +766,3 @@ let unlinkResource (ulLinkedResourceBaseRVA: int32) (pbLinkedResource: byte[]) =
.Save(ulLinkedResourceBaseRVA, pbLinkedResource, pResBuffer, resBufferOffset)
pResBuffer
#if !FX_NO_PDB_WRITER
// PDB Writing
[<ComImport; Interface>]
[<Guid("809c652e-7396-11d2-9771-00a0c9b4d50c"); InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>]
type IMetaDataDispenser =
abstract DefineScope: unit -> unit // need this here to fill the first vtable slot
abstract OpenScope:
[<In; MarshalAs(UnmanagedType.LPWStr)>] szScope: string *
[<In>] dwOpenFlags: Int32 *
[<In>] riid: System.Guid byref *
[<Out; MarshalAs(UnmanagedType.IUnknown)>] punk: Object byref ->
unit
[<ComImport; Interface>]
[<Guid("7DAC8207-D3AE-4c75-9B67-92801A497D44"); InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>]
[<CLSCompliant(true)>]
type IMetadataImport =
abstract Placeholder: unit -> unit
[<ComImport; Interface>]
[<Guid("BA3FEE4C-ECB9-4E41-83B7-183FA41CD859"); InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>]
[<CLSCompliant(true)>]
type IMetadataEmit =
abstract Placeholder: unit -> unit
[<ComImport; Interface>]
[<Guid("B01FAFEB-C450-3A4D-BEEC-B4CEEC01E006"); InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>]
[<ComVisible(false)>]
type ISymUnmanagedDocumentWriter =
abstract SetSource: sourceSize: int * [<MarshalAs(UnmanagedType.LPArray)>] source: byte[] -> unit
abstract SetCheckSum: algorithmId: System.Guid * checkSumSize: int * [<MarshalAs(UnmanagedType.LPArray)>] checkSum: byte[] -> unit
// Struct used to retrieve info on the debug output
[<Struct; StructLayout(LayoutKind.Sequential)>]
type ImageDebugDirectory =
val Characteristics: int32
val TimeDateStamp: int32
val MajorVersion: int16
val MinorVersion: int16
val Type: int32
val SizeOfData: int32
val AddressOfRawData: int32
val PointerToRawData: int32
[<ComImport; Interface>]
[<Guid("0B97726E-9E6D-4f05-9A26-424022093CAA"); InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>]
type ISymUnmanagedWriter2 =
abstract DefineDocument:
[<MarshalAs(UnmanagedType.LPWStr)>] url: string *
language: System.Guid byref *
languageVendor: System.Guid byref *
documentType: System.Guid byref *
[<MarshalAs(UnmanagedType.Interface)>] RetVal: ISymUnmanagedDocumentWriter byref ->
unit
abstract SetUserEntryPoint: entryMethod: uint32 -> unit
abstract OpenMethod: meth: int -> unit
abstract CloseMethod: unit -> unit
abstract OpenScope: startOffset: int * pRetVal: int byref -> unit
abstract CloseScope: endOffset: int -> unit
abstract SetScopeRange: scopeID: int * startOffset: int * endOffset: int -> unit
abstract DefineLocalVariable:
[<MarshalAs(UnmanagedType.LPWStr)>] varName: string *
attributes: int *
cSig: int *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 2s)>] signature: byte[] *
addressKind: int *
addr1: int *
addr2: int *
addr3: int *
startOffset: int *
endOffset: int ->
unit
abstract DefineParameter:
[<MarshalAs(UnmanagedType.LPWStr)>] paramName: string *
attributes: int *
sequence: int *
addressKind: int *
addr1: int *
addr2: int *
addr3: int ->
unit
abstract DefineField:
parent: int *
[<MarshalAs(UnmanagedType.LPWStr)>] fieldName: string *
attributes: int *
cSig: int *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 3s)>] signature: byte[] *
addressKind: int *
addr1: int *
addr2: int *
addr3: int ->
unit
abstract DefineGlobalVariable:
[<MarshalAs(UnmanagedType.LPWStr)>] globalVarName: string *
attributes: int *
cSig: int *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 2s)>] signature: byte[] *
addressKind: int *
addr1: int *
addr2: int *
addr3: int ->
unit
abstract Close: unit -> unit
abstract SetSymAttribute:
parent: int *
[<MarshalAs(UnmanagedType.LPWStr)>] attName: string *
cData: int *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 2s)>] data: byte[] ->
unit
abstract OpenNamespace: [<MarshalAs(UnmanagedType.LPWStr)>] nsname: string -> unit
abstract CloseNamespace: unit -> unit
abstract UsingNamespace: [<MarshalAs(UnmanagedType.LPWStr)>] fullName: string -> unit
abstract SetMethodSourceRange:
startDoc: ISymUnmanagedDocumentWriter *
startLine: int *
startColumn: int *
endDoc: ISymUnmanagedDocumentWriter *
endLine: int *
endColumn: int ->
unit
abstract Initialize:
emitter: nativeint * [<MarshalAs(UnmanagedType.LPWStr)>] fileName: string * stream: IStream * fullBuild: bool -> unit
abstract GetDebugInfo:
iDD: ImageDebugDirectory byref *
cData: int *
pcData: int byref *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 1s)>] data: byte[] ->
unit
abstract DefineSequencePoints:
document: ISymUnmanagedDocumentWriter *
spCount: int *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 1s)>] offsets: int[] *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 1s)>] lines: int[] *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 1s)>] columns: int[] *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 1s)>] endLines: int[] *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 1s)>] endColumns: int[] ->
unit
abstract RemapToken: oldToken: int * newToken: int -> unit
abstract Initialize2:
emitter: nativeint *
[<MarshalAs(UnmanagedType.LPWStr)>] tempFileName: string *
stream: IStream *
fullBuild: bool *
[<MarshalAs(UnmanagedType.LPWStr)>] finalFileName: string ->
unit
abstract DefineConstant:
[<MarshalAs(UnmanagedType.LPWStr)>] constName: string *
value: Object *
cSig: int *
[<MarshalAs(UnmanagedType.LPArray, SizeParamIndex = 2s)>] signature: byte[] ->
unit
abstract Abort: unit -> unit
abstract DefineLocalVariable2:
[<MarshalAs(UnmanagedType.LPWStr)>] localVarName2: string *
attributes: int *
sigToken: int *
addressKind: int *
addr1: int *
addr2: int *
addr3: int *
startOffset: int *
endOffset: int ->
unit
abstract DefineGlobalVariable2:
[<MarshalAs(UnmanagedType.LPWStr)>] globalVarName2: string *
attributes: int *
sigToken: int *
addressKind: int *
addr1: int *
addr2: int *
addr3: int ->
unit
abstract DefineConstant2: [<MarshalAs(UnmanagedType.LPWStr)>] constantName2: string * value: Object * sigToken: int -> unit
abstract OpenMethod2: method2: int * isect: int * offset: int -> unit
type PdbWriter = { symWriter: ISymUnmanagedWriter2 }
type PdbDocumentWriter =
{
symDocWriter: ISymUnmanagedDocumentWriter
} (* pointer to pDocumentWriter COM object *)
type idd =
{
iddCharacteristics: int32
iddMajorVersion: int32 (* actually u16 in IMAGE_DEBUG_DIRECTORY *)
iddMinorVersion: int32 (* actually u16 in IMAGE_DEBUG_DIRECTORY *)
iddType: int32
iddData: byte[]
}
#endif
#if !FX_NO_PDB_WRITER
let pdbInitialize (binaryName: string) (pdbName: string) =
// collect necessary COM types
let CorMetaDataDispenser =
System.Type.GetTypeFromProgID("CLRMetaData.CorMetaDataDispenser")
// get the importer pointer
let mdd =
System.Activator.CreateInstance(CorMetaDataDispenser) :?> IMetaDataDispenser
let mutable IID_IMetaDataEmit = new Guid("BA3FEE4C-ECB9-4E41-83B7-183FA41CD859")
let mutable o = Object()
mdd.OpenScope(binaryName, 0x1, &IID_IMetaDataEmit, &o) // 0x1 = ofWrite
let emitterPtr = Marshal.GetComInterfaceForObject(o, typeof<IMetadataEmit>)
let writer =
try
let writer =
Activator.CreateInstance(System.Type.GetTypeFromProgID("CorSymWriter_SxS")) :?> ISymUnmanagedWriter2
writer.Initialize(emitterPtr, pdbName, Unchecked.defaultof<IStream>, true)
writer
finally
// Marshal.GetComInterfaceForObject adds an extra ref for emitterPtr
if IntPtr.Zero <> emitterPtr then
Marshal.Release emitterPtr |> ignore
{ symWriter = writer }
let pdbCloseDocument (documentWriter: PdbDocumentWriter) =
Marshal.ReleaseComObject(documentWriter.symDocWriter) |> ignore
let pdbClose (writer: PdbWriter) dllFilename pdbFilename =
writer.symWriter.Close()
// CorSymWriter objects (ISymUnmanagedWriter) lock the files they're operating
// on (both the pdb and the binary). The locks are released only when their ref
// count reaches zero, but since we're dealing with RCWs, there's no telling when
// that will be. The result is that sometimes, the pdb and object files will
// still be locked well after the call to this function.
// The SymReader class gets around this problem by implementing the ISymUnmanagedDispose
// interface, which the SymWriter class, unfortunately, does not.
// Right now, take the same approach as mdbg, and manually forcing a collection.
let rc = Marshal.ReleaseComObject(writer.symWriter)
for i = 0 to (rc - 1) do
Marshal.ReleaseComObject(writer.symWriter) |> ignore
let isLocked fileName =
try
use _holder =
FileSystem.OpenFileForWriteShim(fileName, FileMode.Open, FileAccess.ReadWrite, FileShare.None)
false
with _ ->
true
let mutable attempts = 0
while (isLocked dllFilename || isLocked pdbFilename) && attempts < 3 do
// Need to induce two full collections for finalizers to run
System.GC.Collect()
System.GC.Collect()
System.GC.WaitForPendingFinalizers()
attempts <- attempts + 1
let pdbSetUserEntryPoint (writer: PdbWriter) (entryMethodToken: int32) =
writer.symWriter.SetUserEntryPoint((uint32) entryMethodToken)
// Document checksum algorithms
let guidSourceHashMD5 =
System.Guid(0x406ea660u, 0x64cfus, 0x4c82us, 0xb6uy, 0xf0uy, 0x42uy, 0xd4uy, 0x81uy, 0x72uy, 0xa7uy, 0x99uy) //406ea660-64cf-4c82-b6f0-42d48172a799
let hashSizeOfMD5 = 16
// If the FIPS algorithm policy is enabled on the computer (e.g., for US government employees and contractors)
// then obtaining the MD5 implementation in BCL will throw.
// In this case, catch the failure, and not set a checksum.
let internal setCheckSum (url: string, writer: ISymUnmanagedDocumentWriter) =
try
use file = FileSystem.OpenFileForReadShim(url)
use md5 = System.Security.Cryptography.MD5.Create()
let checkSum = md5.ComputeHash file
if (checkSum.Length = hashSizeOfMD5) then
writer.SetCheckSum(guidSourceHashMD5, hashSizeOfMD5, checkSum)
with _ ->
()
let pdbDefineDocument (writer: PdbWriter) (url: string) =
//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)
let mutable corSymDocumentTypeText =
System.Guid(0x5a869d0bu, 0x6611us, 0x11d3us, 0xbduy, 0x2auy, 0x0uy, 0x0uy, 0xf8uy, 0x8uy, 0x49uy, 0xbduy)
let mutable docWriter = Unchecked.defaultof<ISymUnmanagedDocumentWriter>
writer.symWriter.DefineDocument(url, &corSymLanguageTypeFSharp, &corSymLanguageVendorMicrosoft, &corSymDocumentTypeText, &docWriter)
setCheckSum (url, docWriter)
{ symDocWriter = docWriter }
let pdbOpenMethod (writer: PdbWriter) (methodToken: int32) = writer.symWriter.OpenMethod methodToken
let pdbCloseMethod (writer: PdbWriter) = writer.symWriter.CloseMethod()
let pdbOpenScope (writer: PdbWriter) (startOffset: int32) =
let mutable retInt = 0
writer.symWriter.OpenScope(startOffset, &retInt)
check "action" (retInt)
let pdbCloseScope (writer: PdbWriter) (endOffset: int32) = writer.symWriter.CloseScope endOffset
let pdbDefineLocalVariable (writer: PdbWriter) (name: string) (signature: byte[]) (addr1: int32) =
writer.symWriter.DefineLocalVariable(
name,
0,
signature.Length,
signature,
int System.Diagnostics.SymbolStore.SymAddressKind.ILOffset,
addr1,
0,
0,
0,
0
)
let pdbSetMethodRange
(writer: PdbWriter)
(docWriter1: PdbDocumentWriter)
(startLine: int)
(startCol: int)
(docWriter2: PdbDocumentWriter)
(endLine: int)
(endCol: int)
=
writer.symWriter.SetMethodSourceRange(docWriter1.symDocWriter, startLine, startCol, docWriter2.symDocWriter, endLine, endCol)
let pdbDefineSequencePoints (writer: PdbWriter) (docWriter: PdbDocumentWriter) (pts: (int * int * int * int * int)[]) =
let offsets = (Array.map (fun (x, _, _, _, _) -> x) pts)
let lines = (Array.map (fun (_, x, _, _, _) -> x) pts)
let columns = (Array.map (fun (_, _, x, _, _) -> x) pts)
let endLines = (Array.map (fun (_, _, _, x, _) -> x) pts)
let endColumns = (Array.map (fun (_, _, _, _, x) -> x) pts)
writer.symWriter.DefineSequencePoints(docWriter.symDocWriter, pts.Length, offsets, lines, columns, endLines, endColumns)
let pdbWriteDebugInfo (writer: PdbWriter) =
let mutable iDD = new ImageDebugDirectory()
let mutable length = 0
writer.symWriter.GetDebugInfo(&iDD, 0, &length, null)
let mutable data: byte[] = Array.zeroCreate length
writer.symWriter.GetDebugInfo(&iDD, length, &length, data)
{
iddCharacteristics = iDD.Characteristics
iddMajorVersion = int32 iDD.MajorVersion
iddMinorVersion = int32 iDD.MinorVersion
iddType = iDD.Type
iddData = data
}
#endif
#if !FX_NO_PDB_WRITER
// PDB reading
type PdbReader = { symReader: ISymbolReader }
type PdbDocument = { symDocument: ISymbolDocument }
type PdbMethod = { symMethod: ISymbolMethod }
type PdbVariable = { symVariable: ISymbolVariable }
type PdbMethodScope = { symScope: ISymbolScope }
type PdbDebugPoint =
{
pdbSeqPointOffset: int
pdbSeqPointDocument: PdbDocument
pdbSeqPointLine: int
pdbSeqPointColumn: int
pdbSeqPointEndLine: int
pdbSeqPointEndColumn: int
}
let pdbReadOpen (moduleName: string) (path: string) : PdbReader =
let CorMetaDataDispenser =
System.Type.GetTypeFromProgID("CLRMetaData.CorMetaDataDispenser")
let mutable IID_IMetaDataImport = new Guid("7DAC8207-D3AE-4c75-9B67-92801A497D44")
let mdd =
System.Activator.CreateInstance(CorMetaDataDispenser) :?> IMetaDataDispenser
let mutable o: Object = new Object()
mdd.OpenScope(moduleName, 0, &IID_IMetaDataImport, &o)
let importerPtr = Marshal.GetComInterfaceForObject(o, typeof<IMetadataImport>)
try
#if ENABLE_MONO_SUPPORT
// ISymWrapper.dll is not available as a compile-time dependency for the cross-platform compiler, since it is Windows-only
// Access it via reflection instead.System.Diagnostics.SymbolStore.SymBinder
try
let isym =
System.Reflection.Assembly.Load("ISymWrapper, Version=4.0.0.0, Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a")
let symbolBinder = isym.CreateInstance("System.Diagnostics.SymbolStore.SymBinder")
let symbolBinderTy = symbolBinder.GetType()
let reader =
symbolBinderTy.InvokeMember(
"GetReader",
BindingFlags.Public ||| BindingFlags.InvokeMethod ||| BindingFlags.Instance,
null,
symbolBinder,
[| box importerPtr; box moduleName; box path |]
)
{ symReader = reader :?> ISymbolReader }
with _ ->
{ symReader = null }
#else
let symbolBinder = new System.Diagnostics.SymbolStore.SymBinder()
{
symReader = symbolBinder.GetReader(importerPtr, moduleName, path)
}
#endif
finally
// Marshal.GetComInterfaceForObject adds an extra ref for importerPtr
if IntPtr.Zero <> importerPtr then
Marshal.Release importerPtr |> ignore
// 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 = ()
let pdbReaderGetMethod (reader: PdbReader) (token: int32) : PdbMethod =
{
symMethod = reader.symReader.GetMethod(SymbolToken token)
}
let pdbReaderGetMethodFromDocumentPosition (reader: PdbReader) (document: PdbDocument) (line: int) (column: int) : PdbMethod =
{
symMethod = reader.symReader.GetMethodFromDocumentPosition(document.symDocument, line, column)
}
let pdbReaderGetDocuments (reader: PdbReader) : PdbDocument[] =
let arr = reader.symReader.GetDocuments()
Array.map (fun i -> { symDocument = i }) arr
let pdbReaderGetDocument
(reader: PdbReader)
(url: string)
(language: byte[])
(languageVendor: byte[])
(documentType: byte[])
: PdbDocument =
{
symDocument = reader.symReader.GetDocument(url, Guid language, Guid languageVendor, System.Guid documentType)
}
let pdbDocumentGetURL (document: PdbDocument) : string = document.symDocument.URL
let pdbDocumentGetType (document: PdbDocument) : byte (* guid *) [] =
let guid = document.symDocument.DocumentType
guid.ToByteArray()
let pdbDocumentGetLanguage (document: PdbDocument) : byte (* guid *) [] =
let guid = document.symDocument.Language
guid.ToByteArray()
let pdbDocumentGetLanguageVendor (document: PdbDocument) : byte[] =
let guid = document.symDocument.LanguageVendor
guid.ToByteArray()
let pdbDocumentFindClosestLine (document: PdbDocument) (line: int) : int =
document.symDocument.FindClosestLine line
let pdbMethodGetToken (meth: PdbMethod) : int32 =
let token = meth.symMethod.Token
token.GetToken()
let pdbMethodGetDebugPoints (meth: PdbMethod) : PdbDebugPoint[] =
let pSize = meth.symMethod.SequencePointCount
let offsets = Array.zeroCreate pSize
let docs = Array.zeroCreate pSize
let lines = Array.zeroCreate pSize
let cols = Array.zeroCreate pSize
let endLines = Array.zeroCreate pSize
let endColumns = Array.zeroCreate pSize
meth.symMethod.GetSequencePoints(offsets, docs, lines, cols, endLines, endColumns)
Array.init pSize (fun i ->
{
pdbSeqPointOffset = offsets.[i]
pdbSeqPointDocument = { symDocument = docs.[i] }
pdbSeqPointLine = lines.[i]
pdbSeqPointColumn = cols.[i]
pdbSeqPointEndLine = endLines.[i]
pdbSeqPointEndColumn = endColumns.[i]
})
let pdbScopeGetChildren (scope: PdbMethodScope) : PdbMethodScope[] =
let arr = scope.symScope.GetChildren()
Array.map (fun i -> { symScope = i }) arr
let pdbScopeGetOffsets (scope: PdbMethodScope) : int * int =
(scope.symScope.StartOffset, scope.symScope.EndOffset)
let pdbScopeGetLocals (scope: PdbMethodScope) : PdbVariable[] =
let arr = scope.symScope.GetLocals()
Array.map (fun i -> { symVariable = i }) arr
let pdbVariableGetName (variable: PdbVariable) : string = variable.symVariable.Name
let pdbVariableGetSignature (variable: PdbVariable) : byte[] = variable.symVariable.GetSignature()
// The tuple is (AddressKind, AddressField1)
let pdbVariableGetAddressAttributes (variable: PdbVariable) : (int32 * int32) =
(int32 variable.symVariable.AddressKind, variable.symVariable.AddressField1)
#endif

85
src/Compiler/AbstractIL/ilsupp.fsi
Просмотреть файл

@ -7,20 +7,6 @@
/// The implementation of the functions can be found in ilsupp-*.fs
module internal FSharp.Compiler.AbstractIL.Support
#if !FX_NO_SYMBOLSTORE
open System.Diagnostics.SymbolStore
#endif
#if !FX_NO_PDB_WRITER
type PdbWriter
val pdbInitialize: string -> string -> PdbWriter
#endif
#if !FX_NO_PDB_READER
type PdbReader
val pdbReadClose: PdbReader -> unit
#endif
val absilWriteGetTimeStamp: unit -> int32
type IStream = System.Runtime.InteropServices.ComTypes.IStream
@ -32,74 +18,3 @@ type IStream = System.Runtime.InteropServices.ComTypes.IStream
val linkNativeResources: unlinkedResources: byte[] list -> rva: int32 -> byte[]
val unlinkResource: int32 -> byte[] -> byte[]
#if !FX_NO_PDB_WRITER
/// PDB reader and associated types
type PdbDocument
type PdbMethod
type PdbVariable
type PdbMethodScope
type PdbDebugPoint =
{ pdbSeqPointOffset: int
pdbSeqPointDocument: PdbDocument
pdbSeqPointLine: int
pdbSeqPointColumn: int
pdbSeqPointEndLine: int
pdbSeqPointEndColumn: int }
val pdbReadOpen: string (* module *) -> string (* path *) -> PdbReader
val pdbReadClose: PdbReader -> unit
val pdbReaderGetMethod: PdbReader -> int32 (* token *) -> PdbMethod
val pdbReaderGetMethodFromDocumentPosition: PdbReader -> PdbDocument -> int (* line *) -> int (* col *) -> PdbMethod
val pdbReaderGetDocuments: PdbReader -> PdbDocument array
val pdbReaderGetDocument:
PdbReader -> string (* url *) -> byte (* guid *) [] -> byte (* guid *) [] -> byte (* guid *) [] -> PdbDocument
val pdbDocumentGetURL: PdbDocument -> string
val pdbDocumentGetType: PdbDocument -> byte (* guid *) []
val pdbDocumentGetLanguage: PdbDocument -> byte (* guid *) []
val pdbDocumentGetLanguageVendor: PdbDocument -> byte (* guid *) []
val pdbDocumentFindClosestLine: PdbDocument -> int -> int
val pdbMethodGetToken: PdbMethod -> int32
val pdbMethodGetDebugPoints: PdbMethod -> PdbDebugPoint array
val pdbScopeGetChildren: PdbMethodScope -> PdbMethodScope array
val pdbScopeGetOffsets: PdbMethodScope -> int * int
val pdbScopeGetLocals: PdbMethodScope -> PdbVariable array
val pdbVariableGetName: PdbVariable -> string
val pdbVariableGetSignature: PdbVariable -> byte[]
val pdbVariableGetAddressAttributes: PdbVariable -> int32 (* kind *) * int32 (* addrField1 *)
#endif
#if !FX_NO_PDB_WRITER
//---------------------------------------------------------------------
// PDB writer.
//---------------------------------------------------------------------
type PdbDocumentWriter
type idd =
{ iddCharacteristics: int32
iddMajorVersion: int32 (* actually u16 in IMAGE_DEBUG_DIRECTORY *)
iddMinorVersion: int32 (* actually u16 in IMAGE_DEBUG_DIRECTORY *)
iddType: int32
iddData: byte[] }
val pdbInitialize: string (* .exe/.dll already written and closed *) -> string (* .pdb to write *) -> PdbWriter
val pdbClose: PdbWriter -> string -> string -> unit
val pdbCloseDocument: PdbDocumentWriter -> unit
val pdbSetUserEntryPoint: PdbWriter -> int32 -> unit
val pdbDefineDocument: PdbWriter -> string -> PdbDocumentWriter
val pdbOpenMethod: PdbWriter -> int32 -> unit
val pdbCloseMethod: PdbWriter -> unit
val pdbOpenScope: PdbWriter -> int -> unit
val pdbCloseScope: PdbWriter -> int -> unit
val pdbDefineLocalVariable: PdbWriter -> string -> byte[] -> int32 -> unit
val pdbSetMethodRange: PdbWriter -> PdbDocumentWriter -> int -> int -> PdbDocumentWriter -> int -> int -> unit
val pdbDefineSequencePoints: PdbWriter -> PdbDocumentWriter -> (int * int * int * int * int) array -> unit
val pdbWriteDebugInfo: PdbWriter -> idd
#endif

92
src/Compiler/AbstractIL/ilwrite.fs
Просмотреть файл

@ -1137,14 +1137,17 @@ let TryGetMethodRefAsMethodDefIdx cenv (mref: ILMethodRef) =
let canGenMethodDef (tdef: ILTypeDef) cenv (mdef: ILMethodDef) =
if not cenv.referenceAssemblyOnly then
true
// If the method is part of attribute type, generate get_* and set_* methods for it, consider the following case:
// If the method is part of attribute type, generate get_* and set_* methods and .ctors for it, consider the following case:
// [<AttributeUsage(AttributeTargets.All)>]
// type PublicWithInternalSetterPropertyAttribute() =
// inherit Attribute()
// member val internal Prop1 : int = 0 with get, set
// [<PublicWithInternalSetterPropertyAttribute(Prop1=4)>]
// type ClassPublicWithAttributes() = class end
else if tdef.IsKnownToBeAttribute && mdef.IsSpecialName && (not mdef.IsConstructor) && (not mdef.IsClassInitializer) then
// We want to generate pretty much everything for attributes, because of serialization scenarios, and the fact that non-visible constructors, properties and fields can still be part of reference assembly.
// Example: NoDynamicInvocationAttribute has an internal constructor, which should be included in the reference assembly.
else if tdef.IsKnownToBeAttribute && mdef.IsSpecialName && (not mdef.IsClassInitializer) then
true
else
match mdef.Access with
@ -1919,10 +1922,11 @@ module Codebuf =
emitTailness cenv codebuf tl
emitMethodSpecInstr cenv codebuf env i_callvirt (mspec, varargs)
//emitAfterTailcall codebuf tl
| I_callconstraint (tl, ty, mspec, varargs) ->
| I_callconstraint (callvirt, tl, ty, mspec, varargs) ->
emitTailness cenv codebuf tl
emitConstrained cenv codebuf env ty
emitMethodSpecInstr cenv codebuf env i_callvirt (mspec, varargs)
let instr = if callvirt then i_callvirt else i_call
emitMethodSpecInstr cenv codebuf env instr (mspec, varargs)
//emitAfterTailcall codebuf tl
| I_newobj (mspec, varargs) ->
emitMethodSpecInstr cenv codebuf env i_newobj (mspec, varargs)
@ -3197,29 +3201,6 @@ module FileSystemUtilities =
open System.Reflection
open System.Globalization
let progress = try Environment.GetEnvironmentVariable("FSharp_DebugSetFilePermissions") <> null with _ -> false
let setExecutablePermission (fileName: string) =
#if ENABLE_MONO_SUPPORT
if runningOnMono then
try
let monoPosix = Assembly.Load("Mono.Posix, Version=2.0.0.0, Culture=neutral, PublicKeyToken=0738eb9f132ed756")
if progress then eprintf "loading type Mono.Unix.UnixFileInfo...\n"
let monoUnixFileInfo = monoPosix.GetType("Mono.Unix.UnixFileSystemInfo")
let fileEntry = monoUnixFileInfo.InvokeMember("GetFileSystemEntry", (BindingFlags.InvokeMethod ||| BindingFlags.Static ||| BindingFlags.Public), null, null, [| box fileName |], CultureInfo.InvariantCulture)
let prevPermissions = monoUnixFileInfo.InvokeMember("get_FileAccessPermissions", (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), null, fileEntry, [| |], CultureInfo.InvariantCulture)
let prevPermissionsValue = prevPermissions |> unbox<int>
let newPermissionsValue = prevPermissionsValue ||| 0x000001ED
let newPermissions = Enum.ToObject(prevPermissions.GetType(), newPermissionsValue)
// Add 0x000001ED (UserReadWriteExecute, GroupReadExecute, OtherReadExecute) to the access permissions on Unix
monoUnixFileInfo.InvokeMember("set_FileAccessPermissions", (BindingFlags.InvokeMethod ||| BindingFlags.Instance ||| BindingFlags.Public), null, fileEntry, [| newPermissions |], CultureInfo.InvariantCulture) |> ignore
with exn ->
if progress then eprintf "failure: %s...\n" (exn.ToString())
// Fail silently
else
#else
ignore fileName
#endif
()
/// Arbitrary value
[<Literal>]
@ -3708,7 +3689,6 @@ let writeBytes (os: BinaryWriter) (chunk: byte[]) = os.Write(chunk, 0, chunk.Len
let writePdb (
dumpDebugInfo,
showTimes,
portablePDB,
embeddedPDB,
pdbfile,
outfile,
@ -3734,10 +3714,6 @@ let writePdb (
// Now we've done the bulk of the binary, do the PDB file and fixup the binary.
match pdbfile with
| None -> ()
#if ENABLE_MONO_SUPPORT
| Some fmdb when runningOnMono && not portablePDB ->
writeMdbInfo fmdb outfile pdbData
#endif
| Some pdbfile ->
let idd =
match pdbInfoOpt with
@ -3751,16 +3727,17 @@ let writePdb (
ms.Close()
pdbBytes <- Some (ms.ToArray())
else
let outfileInfo = FileInfo(outfile).FullName
let pdbfileInfo = FileInfo(pdbfile).FullName
// If pdbfilepath matches output filepath then error
if String.Compare(outfileInfo, pdbfileInfo, StringComparison.InvariantCulture) = 0 then
errorR(Error(FSComp.SR.optsPdbMatchesOutputFileName(), rangeStartup))
try FileSystem.FileDeleteShim pdbfile with _ -> ()
use fs = FileSystem.OpenFileForWriteShim(pdbfile, fileMode = FileMode.Create, fileAccess = FileAccess.ReadWrite)
stream.WriteTo fs
getInfoForPortablePdb contentId pdbfile pathMap debugDataChunk debugDeterministicPdbChunk debugChecksumPdbChunk algorithmName checkSum embeddedPDB deterministic
| None ->
#if FX_NO_PDB_WRITER
[| |]
#else
writePdbInfo showTimes outfile pdbfile pdbData debugDataChunk
#endif
| None -> [| |]
reportTime showTimes "Generate PDB Info"
// Now we have the debug data we can go back and fill in the debug directory in the image
@ -4550,21 +4527,27 @@ let writeBinaryFiles (options: options, modul, normalizeAssemblyRefs) =
try FileSystem.FileDeleteShim options.outfile with | _ -> ()
reraise()
try
FileSystemUtilities.setExecutablePermission options.outfile
with _ ->
()
let reopenOutput () =
FileSystem.OpenFileForWriteShim(options.outfile, FileMode.Open, FileAccess.Write, FileShare.Read)
writePdb (options.dumpDebugInfo,
options.showTimes, options.portablePDB,
options.embeddedPDB, options.pdbfile, options.outfile,
reopenOutput, false, options.signer, options.deterministic, options.pathMap,
pdbData, pdbInfoOpt, debugDirectoryChunk,
debugDataChunk, debugChecksumPdbChunk, debugEmbeddedPdbChunk,
debugDeterministicPdbChunk, textV2P) |> ignore
options.showTimes,
options.embeddedPDB,
options.pdbfile,
options.outfile,
reopenOutput,
false,
options.signer,
options.deterministic,
options.pathMap,
pdbData,
pdbInfoOpt,
debugDirectoryChunk,
debugDataChunk,
debugChecksumPdbChunk,
debugEmbeddedPdbChunk,
debugDeterministicPdbChunk,
textV2P) |> ignore
mappings
@ -4580,7 +4563,6 @@ let writeBinaryInMemory (options: options, modul, normalizeAssemblyRefs) =
let pdbBytes =
writePdb (options.dumpDebugInfo,
options.showTimes,
options.portablePDB,
options.embeddedPDB,
options.pdbfile,
options.outfile,
@ -4589,9 +4571,13 @@ let writeBinaryInMemory (options: options, modul, normalizeAssemblyRefs) =
options.signer,
options.deterministic,
options.pathMap,
pdbData, pdbInfoOpt, debugDirectoryChunk, debugDataChunk,
debugChecksumPdbChunk, debugEmbeddedPdbChunk,
debugDeterministicPdbChunk, textV2P)
pdbData, pdbInfoOpt,
debugDirectoryChunk,
debugDataChunk,
debugChecksumPdbChunk,
debugEmbeddedPdbChunk,
debugDeterministicPdbChunk,
textV2P)
stream.Close()

290
src/Compiler/AbstractIL/ilwritepdb.fs
Просмотреть файл

@ -313,14 +313,7 @@ let pdbGetDebugInfo
//------------------------------------------------------------------------------
// This function takes output file name and returns debug file name.
let getDebugFileName outfile (portablePDB: bool) =
#if ENABLE_MONO_SUPPORT
if runningOnMono && not portablePDB then
outfile + ".mdb"
else
#else
ignore portablePDB
#endif
let getDebugFileName outfile =
(FileSystemUtils.chopExtension outfile) + ".pdb"
let sortMethods showTimes info =
@ -751,10 +744,12 @@ type PortablePdbGenerator
builder.WriteCompressedInteger offsetDelta
// Check for hidden-sequence-point-record
if startLine = 0xfeefee
|| endLine = 0xfeefee
|| (startColumn = 0 && endColumn = 0)
|| ((endLine - startLine) = 0 && (endColumn - startColumn) = 0) then
if
startLine = 0xfeefee
|| endLine = 0xfeefee
|| (startColumn = 0 && endColumn = 0)
|| ((endLine - startLine) = 0 && (endColumn - startColumn) = 0)
then
// Hidden-sequence-point-record
builder.WriteCompressedInteger 0
builder.WriteCompressedInteger 0
@ -911,271 +906,6 @@ let getInfoForEmbeddedPortablePdb
true
deterministic
#if !FX_NO_PDB_WRITER
open Microsoft.Win32
//---------------------------------------------------------------------
// PDB Writer. The function [WritePdbInfo] abstracts the
// imperative calls to the Symbol Writer API.
//---------------------------------------------------------------------
let writePdbInfo showTimes outfile pdbfile info cvChunk =
try
FileSystem.FileDeleteShim pdbfile
with _ ->
()
let pdbw =
try
pdbInitialize outfile pdbfile
with _ ->
error (Error(FSComp.SR.ilwriteErrorCreatingPdb pdbfile, rangeCmdArgs))
match info.EntryPoint with
| None -> ()
| Some x -> pdbSetUserEntryPoint pdbw x
let docs = info.Documents |> Array.map (fun doc -> pdbDefineDocument pdbw doc.File)
let getDocument i =
if i < 0 || i > docs.Length then
failwith "getDocument: bad doc number"
docs.[i]
reportTime showTimes (sprintf "PDB: Defined %d documents" info.Documents.Length)
Array.sortInPlaceBy (fun x -> x.MethToken) info.Methods
reportTime showTimes (sprintf "PDB: Sorted %d methods" info.Methods.Length)
let spCounts = info.Methods |> Array.map (fun x -> x.DebugPoints.Length)
let allSps = Array.collect (fun x -> x.DebugPoints) info.Methods |> Array.indexed
let mutable spOffset = 0
info.Methods
|> Array.iteri (fun i minfo ->
let sps = Array.sub allSps spOffset spCounts.[i]
spOffset <- spOffset + spCounts.[i]
(match minfo.DebugRange with
| None -> ()
| Some (a, b) ->
pdbOpenMethod pdbw minfo.MethToken
pdbSetMethodRange pdbw (getDocument a.Document) a.Line a.Column (getDocument b.Document) b.Line b.Column
// Partition the sequence points by document
let spsets =
let res = Dictionary<int, PdbDebugPoint list ref>()
for (_, sp) in sps do
let k = sp.Document
match res.TryGetValue(k) with
| true, xsR -> xsR.Value <- sp :: xsR.Value
| _ -> res.[k] <- ref [ sp ]
res
spsets
|> Seq.iter (fun (KeyValue (_, vref)) ->
let spset = vref.Value
if not spset.IsEmpty then
let spset = Array.ofList spset
Array.sortInPlaceWith SequencePoint.orderByOffset spset
let sps =
spset
|> Array.map (fun sp ->
// Ildiag.dprintf "token 0x%08lx has an sp at offset 0x%08x\n" minfo.MethToken sp.Offset
(sp.Offset, sp.Line, sp.Column, sp.EndLine, sp.EndColumn))
// Use of alloca in implementation of pdbDefineSequencePoints can give stack overflow here
if sps.Length < 5000 then
pdbDefineSequencePoints pdbw (getDocument spset.[0].Document) sps)
// Avoid stack overflow when writing linearly nested scopes
let stackGuard = StackGuard(100)
// Write the scopes
let rec writePdbScope parent sco =
stackGuard.Guard(fun () ->
if parent = None || sco.Locals.Length <> 0 || sco.Children.Length <> 0 then
// Only nest scopes if the child scope is a different size from
let nested =
match parent with
| Some p -> sco.StartOffset <> p.StartOffset || sco.EndOffset <> p.EndOffset
| None -> true
if nested then pdbOpenScope pdbw sco.StartOffset
sco.Locals
|> Array.iter (fun v -> pdbDefineLocalVariable pdbw v.Name v.Signature v.Index)
sco.Children |> Array.iter (writePdbScope (if nested then Some sco else parent))
if nested then pdbCloseScope pdbw sco.EndOffset)
match minfo.RootScope with
| None -> ()
| Some rootscope -> writePdbScope None rootscope
pdbCloseMethod pdbw))
reportTime showTimes "PDB: Wrote methods"
let res = pdbWriteDebugInfo pdbw
for pdbDoc in docs do
pdbCloseDocument pdbDoc
pdbClose pdbw outfile pdbfile
reportTime showTimes "PDB: Closed"
[|
{
iddCharacteristics = res.iddCharacteristics
iddMajorVersion = res.iddMajorVersion
iddMinorVersion = res.iddMinorVersion
iddType = res.iddType
iddTimestamp = info.Timestamp
iddData = res.iddData
iddChunk = cvChunk
}
|]
#endif
#if ENABLE_MONO_SUPPORT
//---------------------------------------------------------------------
// Support functions for calling 'Mono.CompilerServices.SymbolWriter'
// assembly dynamically if it is available to the compiler
//---------------------------------------------------------------------
open Microsoft.FSharp.Reflection
// Dynamic invoke operator. Implements simple overload resolution based
// on the name and number of parameters only.
// Supports the following cases:
// obj?Foo() // call with no arguments
// obj?Foo(1, "a") // call with two arguments (extracted from tuple)
// NOTE: This doesn't actually handle all overloads. It just picks first entry with right
// number of arguments.
let (?) this memb (args: 'Args) : 'R =
// Get array of 'obj' arguments for the reflection call
let args =
if typeof<'Args> = typeof<unit> then
[||]
elif FSharpType.IsTuple typeof<'Args> then
FSharpValue.GetTupleFields args
else
[| box args |]
// Get methods and perform overload resolution
let methods = this.GetType().GetMethods()
let bestMatch =
methods
|> Array.tryFind (fun mi -> mi.Name = memb && mi.GetParameters().Length = args.Length)
match bestMatch with
| Some mi -> unbox (mi.Invoke(this, args))
| None -> error (Error(FSComp.SR.ilwriteMDBMemberMissing memb, rangeCmdArgs))
// Creating instances of needed classes from 'Mono.CompilerServices.SymbolWriter' assembly
let monoCompilerSvc =
AssemblyName("Mono.CompilerServices.SymbolWriter, Version=2.0.0.0, Culture=neutral, PublicKeyToken=0738eb9f132ed756")
let ctor (asmName: AssemblyName) clsName (args: obj[]) =
let asm = Assembly.Load asmName
let ty = asm.GetType clsName
Activator.CreateInstance(ty, args)
let createSourceMethodImpl (name: string) (token: int) (namespaceID: int) =
ctor monoCompilerSvc "Mono.CompilerServices.SymbolWriter.SourceMethodImpl" [| box name; box token; box namespaceID |]
let createWriter (f: string) =
ctor monoCompilerSvc "Mono.CompilerServices.SymbolWriter.MonoSymbolWriter" [| box f |]
//---------------------------------------------------------------------
// MDB Writer. Generate debug symbols using the MDB format
//---------------------------------------------------------------------
let writeMdbInfo fmdb f info =
// Note, if we can't delete it code will fail later
try
FileSystem.FileDeleteShim fmdb
with _ ->
()
// Try loading the MDB symbol writer from an assembly available on Mono dynamically
// Report an error if the assembly is not available.
let wr =
try
createWriter f
with _ ->
error (Error(FSComp.SR.ilwriteErrorCreatingMdb (), rangeCmdArgs))
// NOTE: MonoSymbolWriter doesn't need information about entrypoints, so 'info.EntryPoint' is unused here.
// Write information about Documents. Returns '(SourceFileEntry*CompileUnitEntry)[]'
let docs =
[|
for doc in info.Documents do
let doc = wr?DefineDocument (doc.File)
let unit = wr?DefineCompilationUnit doc
yield doc, unit
|]
let getDocument i =
if i < 0 || i >= Array.length docs then
failwith "getDocument: bad doc number"
else
docs[i]
// Sort methods and write them to the MDB file
Array.sortInPlaceBy (fun x -> x.MethToken) info.Methods
for meth in info.Methods do
// Creates an instance of 'SourceMethodImpl' which is a private class that implements 'IMethodDef' interface
// We need this as an argument to 'OpenMethod' below. Using private class is ugly, but since we don't reference
// the assembly, the only way to implement 'IMethodDef' interface would be dynamically using Reflection.Emit...
let sm = createSourceMethodImpl meth.MethName meth.MethToken 0
match meth.DebugRange with
| Some (mstart, _) ->
// NOTE: 'meth.Params' is not needed, Mono debugger apparently reads this from meta-data
let _, cue = getDocument mstart.Document
wr?OpenMethod (cue, 0, sm) |> ignore
// Write sequence points
for sp in meth.DebugPoints do
wr?MarkSequencePoint (sp.Offset, cue?get_SourceFile (), sp.Line, sp.Column, false)
// Walk through the tree of scopes and write all variables
let rec writeScope (scope: PdbMethodScope) =
wr?OpenScope (scope.StartOffset) |> ignore
for local in scope.Locals do
wr?DefineLocalVariable (local.Index, local.Name)
for child in scope.Children do
writeScope child
wr?CloseScope (scope.EndOffset)
match meth.RootScope with
| None -> ()
| Some rootscope -> writeScope rootscope
// Finished generating debug information for the curretn method
wr?CloseMethod ()
| _ -> ()
// Finalize - MDB requires the MVID of the generated .NET module
let moduleGuid = Guid(info.ModuleID |> Array.map byte)
wr?WriteSymbolFile moduleGuid
#endif
//---------------------------------------------------------------------
// Dumps debug info into a text file for testing purposes
//---------------------------------------------------------------------
@ -1242,8 +972,10 @@ and allNamesOfScopes acc (scopes: PdbMethodScope[]) =
let rec pushShadowedLocals (stackGuard: StackGuard) (localsToPush: PdbLocalVar[]) (scope: PdbMethodScope) =
stackGuard.Guard(fun () ->
// Check if child scopes are properly nested
if scope.Children
|> Array.forall (fun child -> child.StartOffset >= scope.StartOffset && child.EndOffset <= scope.EndOffset) then
if
scope.Children
|> Array.forall (fun child -> child.StartOffset >= scope.StartOffset && child.EndOffset <= scope.EndOffset)
then
let children = scope.Children |> Array.sortWith scopeSorter

11
src/Compiler/AbstractIL/ilwritepdb.fsi
Просмотреть файл

@ -80,17 +80,13 @@ type PdbData =
}
/// Takes the output file name and returns debug file name.
val getDebugFileName: string -> bool -> string
val getDebugFileName: string -> string
/// 28 is the size of the IMAGE_DEBUG_DIRECTORY in ntimage.h
val sizeof_IMAGE_DEBUG_DIRECTORY: System.Int32
val logDebugInfo: string -> PdbData -> unit
#if ENABLE_MONO_SUPPORT
val writeMdbInfo<'a> : string -> string -> PdbData -> 'a
#endif
type BinaryChunk = { size: int32; addr: int32 }
type idd =
@ -145,11 +141,6 @@ val getInfoForPortablePdb:
deterministic: bool ->
idd[]
#if !FX_NO_PDB_WRITER
val writePdbInfo:
showTimes: bool -> outfile: string -> pdbfile: string -> info: PdbData -> cvChunk: BinaryChunk -> idd[]
#endif
/// Check to see if a scope has a local with the same name as any of its children
///
/// If so, do not emit 'scope' itself. Instead,

4
src/Compiler/AbstractIL/ilx.fs
Просмотреть файл

@ -39,7 +39,7 @@ type IlxUnionHasHelpers =
| SpecialFSharpListHelpers
| SpecialFSharpOptionHelpers
type IlxUnionRef = IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionCase[] * bool (* hasHelpers: *) * IlxUnionHasHelpers
type IlxUnionRef = IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionCase[] * bool (* hasHelpers: *) * IlxUnionHasHelpers
type IlxUnionSpec =
| IlxUnionSpec of IlxUnionRef * ILGenericArgs
@ -75,7 +75,7 @@ type IlxClosureApps =
let rec instAppsAux n inst apps =
match apps with
| Apps_tyapp (ty, rest) -> Apps_tyapp(instILTypeAux n inst ty, instAppsAux n inst rest)
| Apps_app (dty, rest) -> Apps_app(instILTypeAux n inst dty, instAppsAux n inst rest)
| Apps_app (domainTy, rest) -> Apps_app(instILTypeAux n inst domainTy, instAppsAux n inst rest)
| Apps_done retTy -> Apps_done(instILTypeAux n inst retTy)
let rec instLambdasAux n inst lambdas =

2
src/Compiler/AbstractIL/ilx.fsi
Просмотреть файл

@ -39,7 +39,7 @@ type IlxUnionRef =
boxity: ILBoxity *
ILTypeRef *
IlxUnionCase[] *
bool (* IsNullPermitted *) *
bool (* IsNullPermitted *) *
IlxUnionHasHelpers (* HasHelpers *)
type IlxUnionSpec =

36
src/Compiler/Checking/AttributeChecking.fs
Просмотреть файл

@ -21,6 +21,8 @@ open FSharp.Compiler.TypeHierarchy
#if !NO_TYPEPROVIDERS
open FSharp.Compiler.TypeProviders
open FSharp.Core.CompilerServices
open Features
#endif
exception ObsoleteWarning of string * range
@ -229,22 +231,36 @@ let MethInfoHasAttribute g m attribSpec minfo =
|> Option.isSome
let private CheckCompilerFeatureRequiredAttribute (g: TcGlobals) cattrs msg m =
// In some cases C# will generate both ObsoleteAttribute and CompilerFeatureRequiredAttribute.
// Specifically, when default constructor is generated for class with any reqired members in them.
// ObsoleteAttribute should be ignored if CompilerFeatureRequiredAttribute is present, and its name is "RequiredMembers".
let (AttribInfo(tref,_)) = g.attrib_CompilerFeatureRequiredAttribute
match TryDecodeILAttribute tref cattrs with
| Some([ILAttribElem.String (Some featureName) ], _) when featureName = "RequiredMembers" ->
CompleteD
| _ ->
ErrorD (ObsoleteError(msg, m))
/// Check IL attributes for 'ObsoleteAttribute', returning errors and warnings as data
let private CheckILAttributes (g: TcGlobals) isByrefLikeTyconRef cattrs m =
let private CheckILAttributes (g: TcGlobals) isByrefLikeTyconRef cattrs m =
let (AttribInfo(tref,_)) = g.attrib_SystemObsolete
match TryDecodeILAttribute tref cattrs with
| Some ([ILAttribElem.String (Some msg) ], _) when not isByrefLikeTyconRef ->
match TryDecodeILAttribute tref cattrs with
| Some ([ILAttribElem.String (Some msg) ], _) when not isByrefLikeTyconRef ->
WarnD(ObsoleteWarning(msg, m))
| Some ([ILAttribElem.String (Some msg); ILAttribElem.Bool isError ], _) when not isByrefLikeTyconRef ->
if isError then
ErrorD (ObsoleteError(msg, m))
else
| Some ([ILAttribElem.String (Some msg); ILAttribElem.Bool isError ], _) when not isByrefLikeTyconRef ->
if isError then
if g.langVersion.SupportsFeature(LanguageFeature.RequiredPropertiesSupport) then
CheckCompilerFeatureRequiredAttribute g cattrs msg m
else
ErrorD (ObsoleteError(msg, m))
else
WarnD (ObsoleteWarning(msg, m))
| Some ([ILAttribElem.String None ], _) when not isByrefLikeTyconRef ->
| Some ([ILAttribElem.String None ], _) when not isByrefLikeTyconRef ->
WarnD(ObsoleteWarning("", m))
| Some _ when not isByrefLikeTyconRef ->
| Some _ when not isByrefLikeTyconRef ->
WarnD(ObsoleteWarning("", m))
| _ ->
| _ ->
CompleteD
let langVersionPrefix = "--langversion:preview"

6
src/Compiler/Checking/AugmentWithHashCompare.fs
Просмотреть файл

@ -855,6 +855,7 @@ let slotImplMethod (final, c, slotsig) : ValMemberInfo =
IsDispatchSlot=false
IsFinal=final
IsOverrideOrExplicitImpl=true
GetterOrSetterIsCompilerGenerated=false
MemberKind=SynMemberKind.Member
Trivia=SynMemberFlagsTrivia.Zero}
IsImplemented=false
@ -866,6 +867,7 @@ let nonVirtualMethod c : ValMemberInfo =
IsDispatchSlot=false
IsFinal=false
IsOverrideOrExplicitImpl=false
GetterOrSetterIsCompilerGenerated=false
MemberKind=SynMemberKind.Member
Trivia=SynMemberFlagsTrivia.Zero}
IsImplemented=false
@ -888,8 +890,8 @@ let mkValSpec g (tcref: TyconRef) ty vis slotsig methn valTy argData =
slotImplMethod(final, tcref, slotsig)
let inl = ValInline.Optional
let args = ValReprInfo.unnamedTopArg :: argData
let topValInfo = Some (ValReprInfo (ValReprInfo.InferTyparInfo tps, args, ValReprInfo.unnamedRetVal))
Construct.NewVal (methn, m, None, valTy, Immutable, true, topValInfo, vis, ValNotInRecScope, Some membInfo, NormalVal, [], inl, XmlDoc.Empty, true, false, false, false, false, false, None, Parent tcref)
let valReprInfo = Some (ValReprInfo (ValReprInfo.InferTyparInfo tps, args, ValReprInfo.unnamedRetVal))
Construct.NewVal (methn, m, None, valTy, Immutable, true, valReprInfo, vis, ValNotInRecScope, Some membInfo, NormalVal, [], inl, XmlDoc.Empty, true, false, false, false, false, false, None, Parent tcref)
let MakeValsForCompareAugmentation g (tcref: TyconRef) =
let m = tcref.Range

28
src/Compiler/Checking/CheckComputationExpressions.fs
Просмотреть файл

@ -224,10 +224,10 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol
// Give bespoke error messages for the FSharp.Core "query" builder
let isQuery =
match stripDebugPoints interpExpr with
| Expr.Val (vf, _, m) ->
let item = Item.CustomBuilder (vf.DisplayName, vf)
| Expr.Val (vref, _, m) ->
let item = Item.CustomBuilder (vref.DisplayName, vref)
CallNameResolutionSink cenv.tcSink (m, env.NameEnv, item, emptyTyparInst, ItemOccurence.Use, env.eAccessRights)
valRefEq cenv.g vf cenv.g.query_value_vref
valRefEq cenv.g vref cenv.g.query_value_vref
| _ -> false
/// Make a builder.Method(...) call
@ -468,7 +468,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol
match info with
| None -> false
| Some args ->
args |> List.exists (fun (isParamArrayArg, _isInArg, isOutArg, optArgInfo, _callerInfo, _reflArgInfo) -> isParamArrayArg || isOutArg || optArgInfo.IsOptional))
args |> List.exists (fun (ParamAttribs(isParamArrayArg, _isInArg, isOutArg, optArgInfo, _callerInfo, _reflArgInfo)) -> isParamArrayArg || isOutArg || optArgInfo.IsOptional))
else
false
@ -728,7 +728,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol
let checkForBinaryApp comp =
match comp with
| StripApps(SingleIdent nm, [StripApps(SingleIdent nm2, args); arg2]) when
IsMangledInfixOperator nm.idText &&
IsLogicalInfixOpName nm.idText &&
(match tryExpectedArgCountForCustomOperator nm2 with Some n -> n > 0 | _ -> false) &&
not (List.isEmpty args) ->
let estimatedRangeOfIntendedLeftAndRightArguments = unionRanges (List.last args).Range arg2.Range
@ -876,8 +876,12 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol
SynExpr.Sequential (DebugPointAtSequential.SuppressNeither, true, l, (arbExpr(caption, l.Range.EndRange)), l.Range)
let mkOverallExprGivenVarSpaceExpr, varSpaceInner =
let isNullableOp opId =
match DecompileOpName opId with "?=" | "=?" | "?=?" -> true | _ -> false
match ConvertValLogicalNameToDisplayNameCore opId with
| "?=" | "=?" | "?=?" -> true
| _ -> false
match secondResultPatOpt, keySelectorsOpt with
// groupJoin
| Some secondResultPat, Some relExpr when customOperationIsLikeGroupJoin nm ->
@ -889,7 +893,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol
| BinOpExpr (opId, l, r) ->
if isNullableOp opId.idText then
// When we cannot resolve NullableOps, recommend the relevant namespace to be added
errorR(Error(FSComp.SR.cannotResolveNullableOperators(DecompileOpName opId.idText), relExpr.Range))
errorR(Error(FSComp.SR.cannotResolveNullableOperators(ConvertValLogicalNameToDisplayNameCore opId.idText), relExpr.Range))
else
errorR(Error(FSComp.SR.tcInvalidRelationInJoin(nm.idText), relExpr.Range))
let l = wrapInArbErrSequence l "_keySelector1"
@ -911,7 +915,7 @@ let TcComputationExpression (cenv: cenv) env (overallTy: OverallTy) tpenv (mWhol
| BinOpExpr (opId, l, r) ->
if isNullableOp opId.idText then
// When we cannot resolve NullableOps, recommend the relevant namespace to be added
errorR(Error(FSComp.SR.cannotResolveNullableOperators(DecompileOpName opId.idText), relExpr.Range))
errorR(Error(FSComp.SR.cannotResolveNullableOperators(ConvertValLogicalNameToDisplayNameCore opId.idText), relExpr.Range))
else
errorR(Error(FSComp.SR.tcInvalidRelationInJoin(nm.idText), relExpr.Range))
// this is not correct JoinRelation but it is still binary operation
@ -1909,8 +1913,8 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m =
// This transformation is visible in quotations and thus needs to remain.
| (TPat_as (TPat_wild _, PatternValBinding (v, _), _),
[_],
DebugPoints(Expr.App (Expr.Val (vf, _, _), _, [genEnumElemTy], [yieldExpr], _mYield), recreate))
when valRefEq cenv.g vf cenv.g.seq_singleton_vref ->
DebugPoints(Expr.App (Expr.Val (vref, _, _), _, [genEnumElemTy], [yieldExpr], _mYield), recreate))
when valRefEq cenv.g vref cenv.g.seq_singleton_vref ->
// The debug point mFor is attached to the 'map'
// The debug point mIn is attached to the lambda
@ -2051,11 +2055,11 @@ let TcSequenceExpression (cenv: cenv) env tpenv comp (overallTy: OverallTy) m =
error(Error(FSComp.SR.tcUseForInSequenceExpression(), m))
| SynExpr.Match (spMatch, expr, clauses, _m, _trivia) ->
let inputExpr, matchty, tpenv = TcExprOfUnknownType cenv env tpenv expr
let inputExpr, inputTy, tpenv = TcExprOfUnknownType cenv env tpenv expr
let tclauses, tpenv =
(tpenv, clauses) ||> List.mapFold (fun tpenv (SynMatchClause(pat, cond, innerComp, _, sp, _)) ->
let patR, condR, vspecs, envinner, tpenv = TcMatchPattern cenv matchty env tpenv pat cond
let patR, condR, vspecs, envinner, tpenv = TcMatchPattern cenv inputTy env tpenv pat cond
let envinner =
match sp with
| DebugPointAtTarget.Yes -> { envinner with eIsControlFlow = true }

156
src/Compiler/Checking/CheckDeclarations.fs
Просмотреть файл

@ -291,9 +291,9 @@ let OpenModuleOrNamespaceRefs tcSink g amap scopem root env mvvs openDeclaration
env
/// Adjust the TcEnv to account for opening a type implied by an `open type` declaration
let OpenTypeContent tcSink g amap scopem env (typ: TType) openDeclaration =
let OpenTypeContent tcSink g amap scopem env (ty: TType) openDeclaration =
let env =
{ env with eNameResEnv = AddTypeContentsToNameEnv g amap env.eAccessRights scopem env.eNameResEnv typ }
{ env with eNameResEnv = AddTypeContentsToNameEnv g amap env.eAccessRights scopem env.eNameResEnv ty }
CallEnvSink tcSink (scopem, env.NameEnv, env.eAccessRights)
CallOpenDeclarationSink tcSink openDeclaration
env
@ -366,7 +366,8 @@ let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath (env:
match ResolveLongIdentAsModuleOrNamespace tcSink ResultCollectionSettings.AllResults amap scopem true OpenQualified env.eNameResEnv ad id rest true with
| Result modrefs ->
let modrefs = List.map p23 modrefs
let openTarget = SynOpenDeclTarget.ModuleOrNamespace(enclosingNamespacePathToOpen, scopem)
let lid = SynLongIdent(enclosingNamespacePathToOpen, [] , [])
let openTarget = SynOpenDeclTarget.ModuleOrNamespace(lid, scopem)
let openDecl = OpenDeclaration.Create (openTarget, modrefs, [], scopem, true)
OpenModuleOrNamespaceRefs tcSink g amap scopem false env modrefs openDecl
| Exception _ -> env
@ -378,6 +379,8 @@ let ImplicitlyOpenOwnNamespace tcSink g amap scopem enclosingNamespacePath (env:
exception NotUpperCaseConstructor of range: range
exception NotUpperCaseConstructorWithoutRQA of range: range
let CheckNamespaceModuleOrTypeName (g: TcGlobals) (id: Ident) =
// type names '[]' etc. are used in fslib
if not g.compilingFSharpCore && id.idText.IndexOfAny IllegalCharactersInTypeAndNamespaceNames <> -1 then
@ -411,7 +414,7 @@ module TcRecdUnionAndEnumDeclarations =
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)
let tyR, _ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType env tpenv ty
let tyR, _ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv ty
let zeroInit = HasFSharpAttribute g g.attrib_DefaultValueAttribute attrsForField
let isVolatile = HasFSharpAttribute g g.attrib_VolatileFieldAttribute attrsForField
@ -453,7 +456,7 @@ module TcRecdUnionAndEnumDeclarations =
// Bind other elements of type definitions (constructors etc.)
//-------------------------------------------------------------------------
let CheckUnionCaseName (cenv: cenv) (id: Ident) =
let CheckUnionCaseName (cenv: cenv) (id: Ident) hasRQAAttribute =
let g = cenv.g
let name = id.idText
if name = "Tags" then
@ -461,8 +464,13 @@ module TcRecdUnionAndEnumDeclarations =
CheckNamespaceModuleOrTypeName g id
if not (String.isLeadingIdentifierCharacterUpperCase name) && name <> opNameCons && name <> opNameNil then
errorR(NotUpperCaseConstructor(id.idRange))
if g.langVersion.SupportsFeature(LanguageFeature.LowercaseDUWhenRequireQualifiedAccess) then
if not (String.isLeadingIdentifierCharacterUpperCase name) && not hasRQAAttribute && name <> opNameCons && name <> opNameNil then
errorR(NotUpperCaseConstructorWithoutRQA(id.idRange))
else
if not (String.isLeadingIdentifierCharacterUpperCase name) && name <> opNameCons && name <> opNameNil then
errorR(NotUpperCaseConstructor(id.idRange))
let ValidateFieldNames (synFields: SynField list, tastFields: RecdField list) =
let seen = Dictionary()
@ -479,13 +487,13 @@ module TcRecdUnionAndEnumDeclarations =
| _ ->
seen.Add(f.LogicalName, sf))
let TcUnionCaseDecl (cenv: cenv) env parent thisTy thisTyInst tpenv (SynUnionCase(Attributes synAttrs, SynIdent(id, _), args, xmldoc, vis, m, _)) =
let TcUnionCaseDecl (cenv: cenv) env parent thisTy thisTyInst tpenv hasRQAAttribute (SynUnionCase(Attributes synAttrs, SynIdent(id, _), args, xmldoc, vis, m, _)) =
let g = cenv.g
let attrs = TcAttributes cenv env AttributeTargets.UnionCaseDecl synAttrs // the attributes of a union case decl get attached to the generated "static factory" method
let vis, _ = ComputeAccessAndCompPath env None m vis None parent
let vis = CombineReprAccess parent vis
CheckUnionCaseName cenv id
CheckUnionCaseName cenv id hasRQAAttribute
let rfields, recordTy =
match args with
@ -504,7 +512,7 @@ module TcRecdUnionAndEnumDeclarations =
rfields, thisTy
| SynUnionCaseKind.FullType (ty, arity) ->
let tyR, _ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType env tpenv ty
let tyR, _ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv ty
let curriedArgTys, recordTy = GetTopTauTypeInFSharpForm g (arity |> TranslateSynValInfo m (TcAttributes cenv env) |> TranslatePartialValReprInfo []).ArgInfos tyR m
if curriedArgTys.Length > 1 then
@ -526,8 +534,8 @@ module TcRecdUnionAndEnumDeclarations =
let xmlDoc = xmldoc.ToXmlDoc(true, Some names)
Construct.NewUnionCase id rfields recordTy attrs xmlDoc vis
let TcUnionCaseDecls cenv env parent (thisTy: TType) thisTyInst tpenv unionCases =
let unionCasesR = unionCases |> List.map (TcUnionCaseDecl cenv env parent thisTy thisTyInst tpenv)
let TcUnionCaseDecls (cenv: cenv) env (parent: ParentRef) (thisTy: TType) (thisTyInst: TypeInst) hasRQAAttribute tpenv unionCases =
let unionCasesR = unionCases |> List.map (TcUnionCaseDecl cenv env parent thisTy thisTyInst tpenv hasRQAAttribute)
unionCasesR |> CheckDuplicates (fun uc -> uc.Id) "union case"
let TcEnumDecl cenv env parent thisTy fieldTy (SynEnumCase(attributes=Attributes synAttrs; ident= SynIdent(id,_); value=v; xmlDoc=xmldoc; range=m)) =
@ -649,7 +657,7 @@ let TcOpenModuleOrNamespaceDecl tcSink g amap scopem env (longId, m) =
let modrefs = List.map p23 modrefs
modrefs |> List.iter (fun modref -> CheckEntityAttributes g modref m |> CommitOperationResult)
let openDecl = OpenDeclaration.Create (SynOpenDeclTarget.ModuleOrNamespace (longId, m), modrefs, [], scopem, false)
let openDecl = OpenDeclaration.Create (SynOpenDeclTarget.ModuleOrNamespace (SynLongIdent(longId, [], []), m), modrefs, [], scopem, false)
let env = OpenModuleOrNamespaceRefs tcSink g amap scopem false env modrefs openDecl
env, [openDecl]
@ -658,23 +666,23 @@ let TcOpenTypeDecl (cenv: cenv) mOpenDecl scopem env (synType: SynType, m) =
checkLanguageFeatureError g.langVersion LanguageFeature.OpenTypeDeclaration mOpenDecl
let typ, _tpenv = TcType cenv NoNewTypars CheckCxs ItemOccurence.Open env emptyUnscopedTyparEnv synType
let ty, _tpenv = TcType cenv NoNewTypars CheckCxs ItemOccurence.Open WarnOnIWSAM.Yes env emptyUnscopedTyparEnv synType
if not (isAppTy g typ) then
if not (isAppTy g ty) then
error(Error(FSComp.SR.tcNamedTypeRequired("open type"), m))
if isByrefTy g typ then
if isByrefTy g ty then
error(Error(FSComp.SR.tcIllegalByrefsInOpenTypeDeclaration(), m))
let openDecl = OpenDeclaration.Create (SynOpenDeclTarget.Type (synType, m), [], [typ], scopem, false)
let env = OpenTypeContent cenv.tcSink g cenv.amap scopem env typ openDecl
let openDecl = OpenDeclaration.Create (SynOpenDeclTarget.Type (synType, m), [], [ty], scopem, false)
let env = OpenTypeContent cenv.tcSink g cenv.amap scopem env ty openDecl
env, [openDecl]
let TcOpenDecl (cenv: cenv) mOpenDecl scopem env target =
let g = cenv.g
match target with
| SynOpenDeclTarget.ModuleOrNamespace (longId, m) ->
TcOpenModuleOrNamespaceDecl cenv.tcSink g cenv.amap scopem env (longId, m)
TcOpenModuleOrNamespaceDecl cenv.tcSink g cenv.amap scopem env (longId.LongIdent, m)
| SynOpenDeclTarget.Type (synType, m) ->
TcOpenTypeDecl cenv mOpenDecl scopem env (synType, m)
@ -892,7 +900,7 @@ module MutRecBindingChecking =
| Some _ -> envForTycon
let rbind = NormalizedRecBindingDefn(containerInfo, newslotsOK, declKind, bind)
let overridesOK = DeclKind.CanOverrideOrImplement declKind
let overridesOK = declKind.CanOverrideOrImplement
let (binds, _values), (tpenv, recBindIdx) = AnalyzeAndMakeAndPublishRecursiveValue overridesOK false cenv envForMember (tpenv, recBindIdx) rbind
let cbinds = [ for rbind in binds -> Phase2AMember rbind ]
@ -1046,7 +1054,7 @@ module MutRecBindingChecking =
// 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 baseTy, tpenv = TcType cenv NoNewTypars CheckCxs ItemOccurence.Use WarnOnIWSAM.Yes envInstance tpenv synBaseTy
let baseTy = baseTy |> convertToTypeWithMetadataIfPossible g
let inheritsExpr, tpenv =
try
@ -1060,7 +1068,7 @@ module MutRecBindingChecking =
Phase2BInherit (inheritsExpr, baseValOpt), innerState
// Phase2B: let and let rec value and function definitions
| Phase2AIncrClassBindings (tcref, binds, isStatic, isRec, bindsm) ->
| Phase2AIncrClassBindings (tcref, binds, isStatic, isRec, mBinds) ->
let envForBinding = if isStatic then envStatic else envInstance
let binds, bindRs, env, tpenv =
if isRec then
@ -1073,12 +1081,12 @@ module MutRecBindingChecking =
else
// Type check local binding
let binds, env, tpenv = TcLetBindings cenv envForBinding ExprContainerInfo (ClassLetBinding isStatic) tpenv (binds, bindsm, scopem)
let binds, env, tpenv = TcLetBindings cenv envForBinding ExprContainerInfo (ClassLetBinding isStatic) tpenv (binds, mBinds, scopem)
let binds, bindRs =
binds
|> List.map (function
| TMDefLet(bind, _) -> [bind], IncrClassBindingGroup([bind], isStatic, false)
| TMDefDo(e, _) -> [], IncrClassDo(e, isStatic, bindsm)
| TMDefDo(e, _) -> [], IncrClassDo(e, isStatic, mBinds)
| _ -> error(InternalError("unexpected definition kind", tcref.Range)))
|> List.unzip
List.concat binds, bindRs, env, tpenv
@ -1473,7 +1481,7 @@ module MutRecBindingChecking =
envForDecls)
/// Phase 2: Check the members and 'let' definitions in a mutually recursive group of definitions.
let TcMutRecDefns_Phase2_Bindings (cenv: cenv) envInitial tpenv bindsm scopem mutRecNSInfo (envMutRecPrelimWithReprs: TcEnv) (mutRecDefns: MutRecDefnsPhase2Info) =
let TcMutRecDefns_Phase2_Bindings (cenv: cenv) envInitial tpenv mBinds scopem mutRecNSInfo (envMutRecPrelimWithReprs: TcEnv) (mutRecDefns: MutRecDefnsPhase2Info) =
let g = cenv.g
let denv = envMutRecPrelimWithReprs.DisplayEnv
@ -1596,21 +1604,23 @@ module MutRecBindingChecking =
// Phase2E - rewrite values to initialization graphs
let defnsEs =
EliminateInitializationGraphs
//(fun morpher (tyconOpt, fixupValueExprBinds, methodBinds) -> (tyconOpt, morpher fixupValueExprBinds @ methodBinds))
g true denv defnsDs
g
true
denv
defnsDs
(fun morpher shape -> shape |> MutRecShapes.iterTyconsAndLets (p23 >> morpher) morpher)
MutRecShape.Lets
(fun morpher shape -> shape |> MutRecShapes.mapTyconsAndLets (fun (tyconOpt, fixupValueExprBinds, methodBinds) -> tyconOpt, (morpher fixupValueExprBinds @ methodBinds)) morpher)
bindsm
mBinds
defnsEs, envMutRec
/// Check and generalize the interface implementations, members, 'let' definitions in a mutually recursive group of definitions.
let TcMutRecDefns_Phase2 (cenv: cenv) envInitial bindsm scopem mutRecNSInfo (envMutRec: TcEnv) (mutRecDefns: MutRecDefnsPhase2Data) =
let TcMutRecDefns_Phase2 (cenv: cenv) envInitial mBinds scopem mutRecNSInfo (envMutRec: TcEnv) (mutRecDefns: MutRecDefnsPhase2Data) =
let g = cenv.g
let interfacesFromTypeDefn envForTycon tyconMembersData =
let (MutRecDefnsPhase2DataForTycon(_, _, declKind, tcref, _, _, declaredTyconTypars, members, _, _, _)) = tyconMembersData
let overridesOK = DeclKind.CanOverrideOrImplement declKind
let overridesOK = declKind.CanOverrideOrImplement
members |> List.collect (function
| SynMemberDefn.Interface(interfaceType=intfTy; members=defnOpt) ->
let ty = if tcref.Deref.IsFSharpException then g.exn_ty else generalizedTyconRef g tcref
@ -1620,7 +1630,7 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial bindsm scopem mutRecNSInfo (env
let intfTyR =
let envinner = AddDeclaredTypars CheckForDuplicateTypars declaredTyconTypars envForTycon
TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType envinner emptyUnscopedTyparEnv intfTy |> fst
TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType WarnOnIWSAM.No envinner emptyUnscopedTyparEnv intfTy |> fst
if not (tcref.HasInterface g intfTyR) then
error(Error(FSComp.SR.tcAllImplementedInterfacesShouldBeDeclared(), intfTy.Range))
@ -1720,7 +1730,7 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial bindsm scopem mutRecNSInfo (env
(intfTypes, slotImplSets) ||> List.map2 (interfaceMembersFromTypeDefn tyconData) |> List.concat
MutRecDefnsPhase2InfoForTycon(tyconOpt, tcref, declaredTyconTypars, declKind, obinds @ ibinds, fixupFinalAttrs))
MutRecBindingChecking.TcMutRecDefns_Phase2_Bindings cenv envInitial tpenv bindsm scopem mutRecNSInfo envMutRec binds
MutRecBindingChecking.TcMutRecDefns_Phase2_Bindings cenv envInitial tpenv mBinds scopem mutRecNSInfo envMutRec binds
with exn -> errorRecovery exn scopem; [], envMutRec
@ -2348,11 +2358,11 @@ module EstablishTypeDefinitionCores =
match args with
| SynUnionCaseKind.Fields flds ->
for SynField(_, _, _, ty, _, _, _, m) in flds do
let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty
let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv ty
yield (tyR, m)
| SynUnionCaseKind.FullType (ty, arity) ->
let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty
let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv ty
let curriedArgTys, _ = GetTopTauTypeInFSharpForm g (arity |> TranslateSynValInfo m (TcAttributes cenv env) |> TranslatePartialValReprInfo []).ArgInfos tyR m
if curriedArgTys.Length > 1 then
@ -2363,9 +2373,10 @@ module EstablishTypeDefinitionCores =
yield (argTy, m)
| SynTypeDefnSimpleRepr.General (_, _, _, fields, _, _, implicitCtorSynPats, _) when tycon.IsFSharpStructOrEnumTycon -> // for structs
for SynField(_, isStatic, _, ty, _, _, _, m) in fields do
for field in fields do
let (SynField(_, isStatic, _, ty, _, _, _, m)) = field
if not isStatic then
let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty
let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv ty
yield (tyR, m)
match implicitCtorSynPats with
@ -2384,7 +2395,7 @@ module EstablishTypeDefinitionCores =
| SynTypeDefnSimpleRepr.Record (_, fields, _) ->
for SynField(_, _, _, ty, _, _, _, m) in fields do
let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType env tpenv ty
let tyR, _ = TcTypeAndRecover cenv NoNewTypars NoCheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv ty
yield (tyR, m)
| _ ->
@ -2918,7 +2929,7 @@ module EstablishTypeDefinitionCores =
// This case deals with ordinary type and measure abbreviations
if not hasMeasureableAttr then
let kind = if hasMeasureAttr then TyparKind.Measure else TyparKind.Type
let ty, _ = TcTypeOrMeasureAndRecover (Some kind) cenv NoNewTypars checkConstraints ItemOccurence.UseInType envinner tpenv rhsType
let ty, _ = TcTypeOrMeasureAndRecover (Some kind) cenv NoNewTypars checkConstraints ItemOccurence.UseInType WarnOnIWSAM.No envinner tpenv rhsType
if not firstPass then
let ftyvs = freeInTypeLeftToRight g false ty
@ -2952,7 +2963,7 @@ module EstablishTypeDefinitionCores =
let envinner = AddDeclaredTypars CheckForDuplicateTypars (tycon.Typars m) envinner
let envinner = MakeInnerEnvForTyconRef envinner tcref false
let implementedTys, _ = List.mapFold (mapFoldFst (TcTypeAndRecover cenv NoNewTypars checkConstraints ItemOccurence.UseInType envinner)) tpenv explicitImplements
let implementedTys, _ = List.mapFold (mapFoldFst (TcTypeAndRecover cenv NoNewTypars checkConstraints ItemOccurence.UseInType WarnOnIWSAM.No envinner)) tpenv explicitImplements
if firstPass then
tycon.entity_attribs <- attrs
@ -2964,7 +2975,7 @@ module EstablishTypeDefinitionCores =
let kind = InferTyconKind g (kind, attrs, slotsigs, fields, inSig, isConcrete, m)
let inherits = inherits |> List.map (fun (ty, m, _) -> (ty, m))
let inheritedTys = fst (List.mapFold (mapFoldFst (TcTypeAndRecover cenv NoNewTypars checkConstraints ItemOccurence.UseInType envinner)) tpenv inherits)
let inheritedTys = fst (List.mapFold (mapFoldFst (TcTypeAndRecover cenv NoNewTypars checkConstraints ItemOccurence.UseInType WarnOnIWSAM.No envinner)) tpenv inherits)
let implementedTys, inheritedTys =
match kind with
| SynTypeDefnKind.Interface ->
@ -3188,7 +3199,9 @@ module EstablishTypeDefinitionCores =
structLayoutAttributeCheck false
noAllowNullLiteralAttributeCheck()
TcRecdUnionAndEnumDeclarations.CheckUnionCaseName cenv unionCaseName
let hasRQAAttribute = HasFSharpAttribute cenv.g cenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs
TcRecdUnionAndEnumDeclarations.CheckUnionCaseName cenv unionCaseName hasRQAAttribute
let unionCase = Construct.NewUnionCase unionCaseName [] thisTy [] XmlDoc.Empty tycon.Accessibility
writeFakeUnionCtorsToSink [ unionCase ]
Construct.MakeUnionRepr [ unionCase ], None, NoSafeInitInfo
@ -3203,7 +3216,7 @@ module EstablishTypeDefinitionCores =
noAllowNullLiteralAttributeCheck()
if hasMeasureableAttr then
let kind = if hasMeasureAttr then TyparKind.Measure else TyparKind.Type
let theTypeAbbrev, _ = TcTypeOrMeasureAndRecover (Some kind) cenv NoNewTypars CheckCxs ItemOccurence.UseInType envinner tpenv rhsType
let theTypeAbbrev, _ = TcTypeOrMeasureAndRecover (Some kind) cenv NoNewTypars CheckCxs ItemOccurence.UseInType WarnOnIWSAM.No envinner tpenv rhsType
TMeasureableRepr theTypeAbbrev, None, NoSafeInitInfo
// If we already computed a representation, e.g. for a generative type definition, then don't change it here.
@ -3219,8 +3232,9 @@ module EstablishTypeDefinitionCores =
noAbstractClassAttributeCheck()
noAllowNullLiteralAttributeCheck()
structLayoutAttributeCheck false
let unionCases = TcRecdUnionAndEnumDeclarations.TcUnionCaseDecls cenv envinner innerParent thisTy thisTyInst tpenv unionCases
let hasRQAAttribute = HasFSharpAttribute cenv.g cenv.g.attrib_RequireQualifiedAccessAttribute tycon.Attribs
let unionCases = TcRecdUnionAndEnumDeclarations.TcUnionCaseDecls cenv envinner innerParent thisTy thisTyInst hasRQAAttribute tpenv unionCases
if tycon.IsStructRecordOrUnionTycon && unionCases.Length > 1 then
let fieldNames = [ for uc in unionCases do for ft in uc.FieldTable.TrueInstanceFieldsAsList do yield ft.LogicalName ]
if fieldNames |> List.distinct |> List.length <> fieldNames.Length then
@ -3326,8 +3340,8 @@ module EstablishTypeDefinitionCores =
noAbstractClassAttributeCheck()
noFieldsCheck userFields
primaryConstructorInDelegateCheck(implicitCtorSynPats)
let tyR, _ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType envinner tpenv ty
let _, _, curriedArgInfos, returnTy, _ = GetTopValTypeInCompiledForm g (arity |> TranslateSynValInfo m (TcAttributes cenv envinner) |> TranslatePartialValReprInfo []) 0 tyR m
let tyR, _ = TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes envinner tpenv ty
let _, _, curriedArgInfos, returnTy, _ = GetValReprTypeInCompiledForm g (arity |> TranslateSynValInfo m (TcAttributes cenv envinner) |> TranslatePartialValReprInfo []) 0 tyR m
if curriedArgInfos.Length < 1 then error(Error(FSComp.SR.tcInvalidDelegateSpecification(), m))
if curriedArgInfos.Length > 1 then error(Error(FSComp.SR.tcDelegatesCannotBeCurried(), m))
let ttps = thisTyconRef.Typars m
@ -3426,37 +3440,37 @@ module EstablishTypeDefinitionCores =
match stripTyparEqns ty with
| TType_anon (_,l)
| TType_tuple (_, l) -> accInAbbrevTypes l acc
| TType_ucase (UnionCaseRef(tc, _), tinst)
| TType_app (tc, tinst, _) ->
let tycon2 = tc.Deref
| TType_ucase (UnionCaseRef(tcref2, _), tinst)
| TType_app (tcref2, tinst, _) ->
let tycon2 = tcref2.Deref
let acc = accInAbbrevTypes tinst acc
// Record immediate recursive references
if ListSet.contains (===) tycon2 tycons then
(tycon, tycon2) :: acc
// Expand the representation of abbreviations
elif tc.IsTypeAbbrev then
accInAbbrevType (reduceTyconRefAbbrev tc tinst) acc
elif tcref2.IsTypeAbbrev then
accInAbbrevType (reduceTyconRefAbbrev tcref2 tinst) acc
// Otherwise H<inst> - explore the instantiation.
else
acc
| TType_fun (d, r, _) ->
accInAbbrevType d (accInAbbrevType r acc)
| TType_fun (domainTy, rangeTy, _) ->
accInAbbrevType domainTy (accInAbbrevType rangeTy acc)
| TType_var _ -> acc
| TType_forall (_, r) -> accInAbbrevType r acc
| TType_forall (_, bodyTy) -> accInAbbrevType bodyTy acc
| TType_measure ms -> accInMeasure ms acc
| TType_measure measureTy -> accInMeasure measureTy acc
and accInMeasure ms acc =
match stripUnitEqns ms with
| Measure.Con tc when ListSet.contains (===) tc.Deref tycons ->
(tycon, tc.Deref) :: acc
| Measure.Con tc when tc.IsTypeAbbrev ->
accInMeasure (reduceTyconRefAbbrevMeasureable tc) acc
and accInMeasure measureTy acc =
match stripUnitEqns measureTy with
| Measure.Const tcref when ListSet.contains (===) tcref.Deref tycons ->
(tycon, tcref.Deref) :: acc
| Measure.Const tcref when tcref.IsTypeAbbrev ->
accInMeasure (reduceTyconRefAbbrevMeasureable tcref) acc
| Measure.Prod (ms1, ms2) -> accInMeasure ms1 (accInMeasure ms2 acc)
| Measure.Inv ms -> accInMeasure ms acc
| Measure.Inv invTy -> accInMeasure invTy acc
| _ -> acc
and accInAbbrevTypes tys acc =
@ -3467,7 +3481,7 @@ module EstablishTypeDefinitionCores =
| Some ty -> accInAbbrevType ty []
let edges = List.collect edgesFrom tycons
let graph = Graph<Tycon, Stamp> ((fun tc -> tc.Stamp), tycons, edges)
let graph = Graph<Tycon, Stamp> ((fun tycon -> tycon.Stamp), tycons, edges)
graph.IterateCycles (fun path ->
let tycon = path.Head
// The thing is cyclic. Set the abbreviation and representation to be "None" to stop later VS crashes
@ -4014,13 +4028,15 @@ module TcDeclarations =
// Convert auto properties to member bindings in the post-list
let rec postAutoProps memb =
match memb with
| SynMemberDefn.AutoProperty(attributes=Attributes attribs; isStatic=isStatic; ident=id; typeOpt=tyOpt; propKind=propKind; memberFlags=memberFlags; xmlDoc=xmlDoc; accessibility=access; getSetRange=mGetSetOpt) ->
| SynMemberDefn.AutoProperty(attributes=Attributes attribs; isStatic=isStatic; ident=id; typeOpt=tyOpt; propKind=propKind; memberFlags=memberFlags; memberFlagsForSet=memberFlagsForSet; xmlDoc=xmlDoc; accessibility=access; getSetRange=mGetSetOpt) ->
let mMemberPortion = id.idRange
// Only the keep the non-field-targeted attributes
let attribs = attribs |> List.filter (fun a -> match a.Target with Some t when t.idText = "field" -> false | _ -> true)
let fldId = ident (CompilerGeneratedName id.idText, mMemberPortion)
let headPatIds = if isStatic then [id] else [ident ("__", mMemberPortion);id]
let headPat = SynPat.LongIdent (SynLongIdent(headPatIds, [], List.replicate headPatIds.Length None), None, Some noInferredTypars, SynArgPats.Pats [], None, mMemberPortion)
let memberFlags = { memberFlags with GetterOrSetterIsCompilerGenerated = true }
let memberFlagsForSet = { memberFlagsForSet with GetterOrSetterIsCompilerGenerated = true }
match propKind, mGetSetOpt with
| SynMemberKind.PropertySet, Some m -> errorR(Error(FSComp.SR.parsMutableOnAutoPropertyShouldBeGetSetNotJustSet(), m))
@ -4035,7 +4051,7 @@ module TcDeclarations =
let rhsExpr = SynExpr.Ident fldId
let retInfo = match tyOpt with None -> None | Some ty -> Some (SynReturnInfo((ty, SynInfo.unnamedRetVal), ty.Range))
let attribs = mkAttributeList attribs mMemberPortion
let binding = mkSynBinding (xmlDoc, headPat) (access, false, false, mMemberPortion, DebugPointAtBinding.NoneAtInvisible, retInfo, rhsExpr, rhsExpr.Range, [], attribs, Some (memberFlags SynMemberKind.Member), SynBindingTrivia.Zero)
let binding = mkSynBinding (xmlDoc, headPat) (access, false, false, mMemberPortion, DebugPointAtBinding.NoneAtInvisible, retInfo, rhsExpr, rhsExpr.Range, [], attribs, Some memberFlags, SynBindingTrivia.Zero)
SynMemberDefn.Member (binding, mMemberPortion)
yield getter
| _ -> ()
@ -4047,8 +4063,7 @@ module TcDeclarations =
let vId = ident("v", mMemberPortion)
let headPat = SynPat.LongIdent (SynLongIdent(headPatIds, [], List.replicate headPatIds.Length None), None, Some noInferredTypars, SynArgPats.Pats [mkSynPatVar None vId], None, mMemberPortion)
let rhsExpr = mkSynAssign (SynExpr.Ident fldId) (SynExpr.Ident vId)
//let retInfo = match tyOpt with None -> None | Some ty -> Some (SynReturnInfo((ty, SynInfo.unnamedRetVal), ty.Range))
let binding = mkSynBinding (xmlDoc, headPat) (access, false, false, mMemberPortion, DebugPointAtBinding.NoneAtInvisible, None, rhsExpr, rhsExpr.Range, [], [], Some (memberFlags SynMemberKind.PropertySet), SynBindingTrivia.Zero)
let binding = mkSynBinding (xmlDoc, headPat) (access, false, false, mMemberPortion, DebugPointAtBinding.NoneAtInvisible, None, rhsExpr, rhsExpr.Range, [], [], Some memberFlagsForSet, SynBindingTrivia.Zero)
SynMemberDefn.Member (binding, mMemberPortion)
yield setter
| _ -> ()]
@ -4513,7 +4528,7 @@ and TcSignatureElementsMutRec cenv parent typeNames m mutRecNSInfo envInitial (d
| SynModuleSigDecl.Exception (exnSig=SynExceptionSig(exnRepr=exnRepr; withKeyword=withKeyword; members=members)) ->
let ( SynExceptionDefnRepr(synAttrs, SynUnionCase(ident=SynIdent(id,_)), _, xmlDoc, vis, m)) = exnRepr
let compInfo = SynComponentInfo(synAttrs, None, [], [id], xmlDoc, false, vis, id.idRange)
let decls = [ MutRecShape.Tycon(SynTypeDefnSig.SynTypeDefnSig(compInfo, None, SynTypeDefnSigRepr.Exception exnRepr, withKeyword, members, m)) ]
let decls = [ MutRecShape.Tycon(SynTypeDefnSig.SynTypeDefnSig(compInfo, SynTypeDefnSigRepr.Exception exnRepr, members, m, { TypeKeyword = None; WithKeyword = withKeyword; EqualsRange = None })) ]
decls, (false, false)
| SynModuleSigDecl.Val (vspec, _) ->
@ -4620,7 +4635,8 @@ let rec TcModuleOrNamespaceElementNonMutRec (cenv: cenv) parent typeNames scopem
let env = MutRecBindingChecking.TcModuleAbbrevDecl cenv scopem env (id, p, m)
return ([], [], []), env, env
| SynModuleDecl.Exception (edef, m) ->
| SynModuleDecl.Exception (SynExceptionDefn(exnRepr, withKeyword, ms, mExDefn), m) ->
let edef = SynExceptionDefn(exnRepr, withKeyword, desugarGetSetMembers ms, mExDefn)
let binds, decl, env = TcExceptionDeclarations.TcExnDefn cenv env parent (edef, scopem)
let defn = TMDefRec(true, [], [decl], binds |> List.map ModuleOrNamespaceBinding.Binding, m)
return ([defn], [], []), env, env
@ -4971,7 +4987,7 @@ let ApplyAssemblyLevelAutoOpenAttributeToTcEnv g amap (ccu: CcuThunk) scopem env
match modref.TryDeref with
| ValueNone -> warn()
| ValueSome _ ->
let openTarget = SynOpenDeclTarget.ModuleOrNamespace([], scopem)
let openTarget = SynOpenDeclTarget.ModuleOrNamespace(SynLongIdent([],[],[]), scopem)
let openDecl = OpenDeclaration.Create (openTarget, [modref], [], scopem, false)
let envinner = OpenModuleOrNamespaceRefs TcResultsSink.NoSink g amap scopem root env [modref] openDecl
[openDecl], envinner

2
src/Compiler/Checking/CheckDeclarations.fsi
Просмотреть файл

@ -76,3 +76,5 @@ val CheckOneSigFile:
Cancellable<TcEnv * ModuleOrNamespaceType * bool>
exception NotUpperCaseConstructor of range: range
exception NotUpperCaseConstructorWithoutRQA of range: range

1190
src/Compiler/Checking/CheckExpressions.fs
Просмотреть файл

Разница между файлами не показана из-за своего большого размера Загрузить разницу

38
src/Compiler/Checking/CheckExpressions.fsi
Просмотреть файл

@ -480,24 +480,7 @@ type DeclKind =
/// A binding in an expression
| ExpressionBinding
static member IsModuleOrMemberOrExtensionBinding: DeclKind -> bool
static member MustHaveArity: DeclKind -> bool
member CanBeDllImport: bool
static member IsAccessModifierPermitted: DeclKind -> bool
static member ImplicitlyStatic: DeclKind -> bool
static member AllowedAttribTargets: SynMemberFlags option -> DeclKind -> AttributeTargets
// Note: now always true
static member CanGeneralizeConstrainedTypars: DeclKind -> bool
static member ConvertToLinearBindings: DeclKind -> bool
static member CanOverrideOrImplement: DeclKind -> OverridesOK
member CanOverrideOrImplement: OverridesOK
/// Indicates whether a syntactic type is allowed to include new type variables
/// not declared anywhere, e.g. `let f (x: 'T option) = x.Value`
@ -506,6 +489,13 @@ type ImplicitlyBoundTyparsAllowed =
| NewTyparsOK
| NoNewTypars
/// Indicates whether the position being checked is precisely the r.h.s. of a "'T :> ***" constraint or a similar
/// places where IWSAM types do not generate a warning
[<RequireQualifiedAccess>]
type WarnOnIWSAM =
| Yes
| No
/// Indicates if a member binding is an object expression binding
type IsObjExprBinding =
| ObjExprBinding
@ -584,12 +574,13 @@ type RecursiveBindingInfo =
[<Sealed>]
type CheckedBindingInfo
/// Represnts the results of the second phase of checking simple values
/// Represents the results of the second phase of checking simple values
type ValScheme =
| ValScheme of
id: Ident *
typeScheme: GeneralizedType *
valReprInfo: ValReprInfo option *
valReprInfoForDisplay: ValReprInfo option *
memberInfo: PrelimMemberInfo option *
isMutable: bool *
inlineInfo: ValInline *
@ -744,7 +735,7 @@ val CompilePatternForMatchClauses:
/// The functions must iterate the actual bindings and process them to the overall result.
val EliminateInitializationGraphs:
g: TcGlobals ->
mustHaveArity: bool ->
mustHaveValReprInfo: bool ->
denv: DisplayEnv ->
bindings: 'Binding list ->
iterBindings: ((PreInitializationGraphEliminationBinding list -> unit) -> 'Binding list -> unit) ->
@ -988,7 +979,7 @@ val TcMatchPattern:
val (|BinOpExpr|_|): SynExpr -> (Ident * SynExpr * SynExpr) option
/// Check a set of let bindings
/// Check a set of let bindings in a class or module
val TcLetBindings:
cenv: TcFileState ->
env: TcEnv ->
@ -1081,6 +1072,7 @@ val TcType:
newOk: ImplicitlyBoundTyparsAllowed ->
checkConstraints: CheckConstraints ->
occ: ItemOccurence ->
iwsam: WarnOnIWSAM ->
env: TcEnv ->
tpenv: UnscopedTyparEnv ->
ty: SynType ->
@ -1093,6 +1085,7 @@ val TcTypeOrMeasureAndRecover:
newOk: ImplicitlyBoundTyparsAllowed ->
checkConstraints: CheckConstraints ->
occ: ItemOccurence ->
iwsam: WarnOnIWSAM ->
env: TcEnv ->
tpenv: UnscopedTyparEnv ->
ty: SynType ->
@ -1104,6 +1097,7 @@ val TcTypeAndRecover:
newOk: ImplicitlyBoundTyparsAllowed ->
checkConstraints: CheckConstraints ->
occ: ItemOccurence ->
iwsam: WarnOnIWSAM ->
env: TcEnv ->
tpenv: UnscopedTyparEnv ->
ty: SynType ->
@ -1179,7 +1173,7 @@ val TcPatLongIdentActivePatternCase:
vFlags: TcPatValFlags ->
patEnv: TcPatLinearEnv ->
ty: TType ->
lidRange: range * item: Item * apref: ActivePatternElemRef * args: SynPat list * m: range ->
mLongId: range * item: Item * apref: ActivePatternElemRef * args: SynPat list * m: range ->
(TcPatPhase2Input -> Pattern) * TcPatLinearEnv
/// The pattern syntax can also represent active pattern arguments. This routine

28
src/Compiler/Checking/CheckFormatStrings.fs
Просмотреть файл

@ -16,25 +16,25 @@ open FSharp.Compiler.TcGlobals
type FormatItem = Simple of TType | FuncAndVal
let copyAndFixupFormatTypar m tp =
let _,_,tinst = FreshenAndFixupTypars m TyparRigidity.Flexible [] [] [tp]
let copyAndFixupFormatTypar g m tp =
let _,_,tinst = FreshenAndFixupTypars g m TyparRigidity.Flexible [] [] [tp]
List.head tinst
let lowestDefaultPriority = 0 (* See comment on TyparConstraint.DefaultsTo *)
let mkFlexibleFormatTypar m tys dflt =
let mkFlexibleFormatTypar g m tys dfltTy =
let tp = Construct.NewTypar (TyparKind.Type, TyparRigidity.Rigid, SynTypar(mkSynId m "fmt",TyparStaticReq.HeadType,true),false,TyparDynamicReq.Yes,[],false,false)
tp.SetConstraints [ TyparConstraint.SimpleChoice (tys,m); TyparConstraint.DefaultsTo (lowestDefaultPriority,dflt,m)]
copyAndFixupFormatTypar m tp
tp.SetConstraints [ TyparConstraint.SimpleChoice (tys,m); TyparConstraint.DefaultsTo (lowestDefaultPriority,dfltTy,m)]
copyAndFixupFormatTypar g m tp
let mkFlexibleIntFormatTypar (g: TcGlobals) m =
mkFlexibleFormatTypar m [ g.byte_ty; g.int16_ty; g.int32_ty; g.int64_ty; g.sbyte_ty; g.uint16_ty; g.uint32_ty; g.uint64_ty;g.nativeint_ty;g.unativeint_ty; ] g.int_ty
mkFlexibleFormatTypar g m [ g.byte_ty; g.int16_ty; g.int32_ty; g.int64_ty; g.sbyte_ty; g.uint16_ty; g.uint32_ty; g.uint64_ty;g.nativeint_ty;g.unativeint_ty; ] g.int_ty
let mkFlexibleDecimalFormatTypar (g: TcGlobals) m =
mkFlexibleFormatTypar m [ g.decimal_ty ] g.decimal_ty
mkFlexibleFormatTypar g m [ g.decimal_ty ] g.decimal_ty
let mkFlexibleFloatFormatTypar (g: TcGlobals) m =
mkFlexibleFormatTypar m [ g.float_ty; g.float32_ty; g.decimal_ty ] g.float_ty
mkFlexibleFormatTypar g m [ g.float_ty; g.float32_ty; g.decimal_ty ] g.float_ty
type FormatInfoRegister =
{ mutable leftJustify : bool
@ -449,19 +449,19 @@ let parseFormatStringInternal
| Some '+' ->
collectSpecifierLocation fragLine fragCol 1
let i = skipPossibleInterpolationHole (i+1)
let xty = NewInferenceType g
percentATys.Add(xty)
parseLoop ((posi, xty) :: acc) (i, fragLine, fragCol+1) fragments
let aTy = NewInferenceType g
percentATys.Add(aTy)
parseLoop ((posi, aTy) :: acc) (i, fragLine, fragCol+1) fragments
| Some n ->
failwith (FSComp.SR.forDoesNotSupportPrefixFlag(ch.ToString(), n.ToString()))
| 'a' ->
checkOtherFlags ch
let xty = NewInferenceType g
let fty = mkFunTy g printerArgTy (mkFunTy g xty printerResidueTy)
let aTy = NewInferenceType g
let fTy = mkFunTy g printerArgTy (mkFunTy g aTy printerResidueTy)
collectSpecifierLocation fragLine fragCol 2
let i = skipPossibleInterpolationHole (i+1)
parseLoop ((Option.map ((+)1) posi, xty) :: (posi, fty) :: acc) (i, fragLine, fragCol+1) fragments
parseLoop ((Option.map ((+)1) posi, aTy) :: (posi, fTy) :: acc) (i, fragLine, fragCol+1) fragments
| 't' ->
checkOtherFlags ch

44
src/Compiler/Checking/CheckIncrementalClasses.fs
Просмотреть файл

@ -132,9 +132,9 @@ let TcImplicitCtorLhs_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, attr
let prelimValReprInfo = TranslateSynValInfo m (TcAttributes cenv env) valSynData
let prelimTyschemeG = GeneralizedType(copyOfTyconTypars, ctorTy)
let isComplete = ComputeIsComplete copyOfTyconTypars [] ctorTy
let topValInfo = InferGenericArityFromTyScheme prelimTyschemeG prelimValReprInfo
let ctorValScheme = ValScheme(id, prelimTyschemeG, Some topValInfo, Some memberInfo, false, ValInline.Never, NormalVal, vis, false, true, false, false)
let paramNames = topValInfo.ArgNames
let varReprInfo = InferGenericArityFromTyScheme prelimTyschemeG prelimValReprInfo
let ctorValScheme = ValScheme(id, prelimTyschemeG, Some varReprInfo, None, Some memberInfo, false, ValInline.Never, NormalVal, vis, false, true, false, false)
let paramNames = varReprInfo.ArgNames
let xmlDoc = xmlDoc.ToXmlDoc(true, Some paramNames)
let ctorVal = MakeAndPublishVal cenv env (Parent tcref, false, ModuleOrMemberBinding, ValInRecScope isComplete, ctorValScheme, attribs, xmlDoc, None, false)
ctorValScheme, ctorVal
@ -153,8 +153,8 @@ let TcImplicitCtorLhs_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, attr
let memberInfo = MakeMemberDataAndMangledNameForMemberVal(g, tcref, false, [], [], (ClassCtorMemberFlags SynMemberFlagsTrivia.Zero), valSynData, id, false)
let prelimValReprInfo = TranslateSynValInfo m (TcAttributes cenv env) valSynData
let prelimTyschemeG = GeneralizedType(copyOfTyconTypars, cctorTy)
let topValInfo = InferGenericArityFromTyScheme prelimTyschemeG prelimValReprInfo
let cctorValScheme = ValScheme(id, prelimTyschemeG, Some topValInfo, Some memberInfo, false, ValInline.Never, NormalVal, Some (SynAccess.Private Range.Zero), false, true, false, false)
let valReprInfo = InferGenericArityFromTyScheme prelimTyschemeG prelimValReprInfo
let cctorValScheme = ValScheme(id, prelimTyschemeG, Some valReprInfo, None, Some memberInfo, false, ValInline.Never, NormalVal, Some (SynAccess.Private Range.Zero), false, true, false, false)
let cctorVal = MakeAndPublishVal cenv env (Parent tcref, false, ModuleOrMemberBinding, ValNotInRecScope, cctorValScheme, [(* no attributes*)], XmlDoc.Empty, None, false)
cctorArgs, cctorVal, cctorValScheme
@ -162,7 +162,7 @@ let TcImplicitCtorLhs_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, attr
let thisVal =
// --- 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 thisValScheme = ValScheme(thisId, NonGenericTypeScheme thisTy, None, None, None, false, ValInline.Never, CtorThisVal, None, true, false, false, false)
let thisVal = MakeAndPublishVal cenv env (ParentNone, false, ClassLetBinding false, ValNotInRecScope, thisValScheme, [], XmlDoc.Empty, None, false)
thisVal
@ -245,7 +245,7 @@ type IncrClassReprInfo =
if isUnitTy g v.Type then
false
else
let arity = InferArityOfExprBinding g AllowTypeDirectedDetupling.Yes v bind.Expr
let arity = InferValReprInfoOfBinding g AllowTypeDirectedDetupling.Yes v bind.Expr
not arity.HasNoArgs && not v.IsMutable
@ -292,7 +292,7 @@ type IncrClassReprInfo =
warning (Error(FSComp.SR.chkUnusedValue(v.DisplayName), v.Range))
let repr =
match InferArityOfExprBinding g AllowTypeDirectedDetupling.Yes v bind.Expr with
match InferValReprInfoOfBinding g AllowTypeDirectedDetupling.Yes v bind.Expr with
| arity when arity.HasNoArgs || v.IsMutable ->
// all mutable variables are forced into fields, since they may escape into closures within the implicit constructor
// e.g.
@ -317,9 +317,9 @@ type IncrClassReprInfo =
// (staticForcedFieldVars |> Seq.map (fun v -> v.LogicalName) |> String.concat ",")
// (instanceForcedFieldVars |> Seq.map (fun v -> v.LogicalName) |> String.concat ",")
InVar isCtorArg
| topValInfo ->
| valReprInfo ->
//dprintfn "Representing %s as a method %s" v.LogicalName name
let tps, _, argInfos, _, _ = GetTopValTypeInCompiledForm g topValInfo 0 v.Type v.Range
let tps, _, argInfos, _, _ = GetValReprTypeInCompiledForm g valReprInfo 0 v.Type v.Range
let valSynInfo = SynValInfo(argInfos |> List.mapSquared (fun (_, argInfo) -> SynArgInfo([], false, argInfo.Name)), SynInfo.unnamedRetVal)
let memberFlags = (if isStatic then StaticMemberFlags else NonVirtualMemberFlags) SynMemberFlagsTrivia.Zero SynMemberKind.Member
@ -328,34 +328,34 @@ type IncrClassReprInfo =
let copyOfTyconTypars = ctorInfo.GetNormalizedInstanceCtorDeclaredTypars cenv env.DisplayEnv ctorInfo.TyconRef.Range
AdjustValToTopVal v (Parent tcref) topValInfo
AdjustValToHaveValReprInfo v (Parent tcref) valReprInfo
// Add the 'this' pointer on to the function
let memberTauTy, topValInfo =
let memberTauTy, valReprInfo =
let tauTy = v.TauType
if isStatic then
tauTy, topValInfo
tauTy, valReprInfo
else
let tauTy = mkFunTy g ctorInfo.InstanceCtorThisVal.Type v.TauType
let (ValReprInfo(tpNames, args, ret)) = topValInfo
let topValInfo = ValReprInfo(tpNames, ValReprInfo.selfMetadata :: args, ret)
tauTy, topValInfo
let (ValReprInfo(tpNames, args, ret)) = valReprInfo
let valReprInfo = ValReprInfo(tpNames, ValReprInfo.selfMetadata :: args, ret)
tauTy, valReprInfo
// Add the enclosing type parameters on to the function
let topValInfo =
let (ValReprInfo(tpNames, args, ret)) = topValInfo
let valReprInfo =
let (ValReprInfo(tpNames, args, ret)) = valReprInfo
ValReprInfo(tpNames@ValReprInfo.InferTyparInfo copyOfTyconTypars, args, ret)
let prelimTyschemeG = GeneralizedType(copyOfTyconTypars@tps, memberTauTy)
// NOTE: putting isCompilerGenerated=true here is strange. The method is not public, nor is
// it a "member" in the F# sense, but the F# spec says it is generated and it is reasonable to reflect on it.
let memberValScheme = ValScheme(id, prelimTyschemeG, Some topValInfo, Some memberInfo, false, ValInline.Never, NormalVal, None, true (* isCompilerGenerated *), true (* isIncrClass *), false, false)
let memberValScheme = ValScheme(id, prelimTyschemeG, Some valReprInfo, None, Some memberInfo, false, ValInline.Never, NormalVal, None, true (* isCompilerGenerated *), true (* isIncrClass *), false, false)
let methodVal = MakeAndPublishVal cenv env (Parent tcref, false, ModuleOrMemberBinding, ValNotInRecScope, memberValScheme, v.Attribs, XmlDoc.Empty, None, false)
reportIfUnused()
InMethod(isStatic, methodVal, topValInfo)
InMethod(isStatic, methodVal, valReprInfo)
repr, takenFieldNames
@ -401,9 +401,9 @@ type IncrClassReprInfo =
let expr = mkStaticRecdFieldGet (rfref, tinst, m)
MakeCheckSafeInit g tinst safeStaticInitInfo (mkInt g m idx) expr
| InMethod(isStatic, methodVal, topValInfo), _ ->
| InMethod(isStatic, methodVal, valReprInfo), _ ->
//dprintfn "Rewriting application of %s to be call to method %s" v.LogicalName methodVal.LogicalName
let expr, exprTy = AdjustValForExpectedArity g m (mkLocalValRef methodVal) NormalValUse topValInfo
let expr, exprTy = AdjustValForExpectedValReprInfo g m (mkLocalValRef methodVal) NormalValUse valReprInfo
// Prepend the the type arguments for the class
let tyargs = tinst @ tyargs
let thisArgs =

62
src/Compiler/Checking/CheckPatterns.fs
Просмотреть файл

@ -96,7 +96,7 @@ and TcSimplePat optionalArgsOK checkConstraints (cenv: cenv) ty env patEnv p =
id.idText, patEnvR
| SynSimplePat.Typed (p, cty, m) ->
let ctyR, tpenv = TcTypeAndRecover cenv NewTyparsOK checkConstraints ItemOccurence.UseInType env tpenv cty
let ctyR, tpenv = TcTypeAndRecover cenv NewTyparsOK checkConstraints ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv cty
match p with
// Optional arguments on members
@ -166,7 +166,7 @@ and TcSimplePats (cenv: cenv) optionalArgsOK checkConstraints ty env patEnv synS
ps', patEnvR
| SynSimplePats.Typed (p, cty, m) ->
let ctyR, tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv cty
let ctyR, tpenv = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv cty
match p with
// Solitary optional arguments on members
@ -277,7 +277,7 @@ and TcPat warnOnUpper (cenv: cenv) env valReprInfo vFlags (patEnv: TcPatLinearEn
| SynPat.Typed (p, cty, m) ->
let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
let ctyR, tpenvR = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType env tpenv cty
let ctyR, tpenvR = TcTypeAndRecover cenv NewTyparsOK CheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv cty
UnifyTypes cenv env m ty ctyR
let patEnvR = TcPatLinearEnv(tpenvR, names, takenNames)
TcPat warnOnUpper cenv env valReprInfo vFlags patEnvR ty p
@ -369,7 +369,7 @@ and TcPatNamed warnOnUpper cenv env vFlags patEnv id ty isMemberThis vis valRepr
and TcPatIsInstance warnOnUpper cenv env valReprInfo vFlags patEnv srcTy synPat synTargetTy m =
let (TcPatLinearEnv(tpenv, names, takenNames)) = patEnv
let tgtTy, tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurence.UseInType env tpenv synTargetTy
let tgtTy, tpenv = TcTypeAndRecover cenv NewTyparsOKButWarnIfNotRigid CheckCxs ItemOccurence.UseInType WarnOnIWSAM.Yes env tpenv synTargetTy
TcRuntimeTypeTest false true cenv env.DisplayEnv m tgtTy srcTy
let patEnv = TcPatLinearEnv(tpenv, names, takenNames)
match synPat with
@ -503,7 +503,7 @@ and TcPatLongIdent warnOnUpper cenv env ad valReprInfo vFlags (patEnv: TcPatLine
| SynArgPats.Pats [] -> warnOnUpper
| _ -> AllIdsOK
let lidRange = rangeOfLid longId
let mLongId = rangeOfLid longId
match ResolvePatternLongIdent cenv.tcSink cenv.nameResolver warnOnUpperForId false m ad env.NameEnv TypeNameResolutionInfo.Default longId with
| Item.NewDef id ->
@ -519,19 +519,19 @@ and TcPatLongIdent warnOnUpper cenv env ad valReprInfo vFlags (patEnv: TcPatLine
let args = GetSynArgPatterns args
TcPatLongIdentActivePatternCase warnOnUpper cenv env vFlags patEnv ty (lidRange, item, apref, args, m)
TcPatLongIdentActivePatternCase warnOnUpper cenv env vFlags patEnv ty (mLongId, item, apref, args, m)
| Item.UnionCase _ | Item.ExnCase _ as item ->
TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags patEnv ty (lidRange, item, args, m)
TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags patEnv ty (mLongId, item, args, m)
| Item.ILField finfo ->
TcPatLongIdentILField warnOnUpper cenv env vFlags patEnv ty (lidRange, finfo, args, m)
TcPatLongIdentILField warnOnUpper cenv env vFlags patEnv ty (mLongId, finfo, args, m)
| Item.RecdField rfinfo ->
TcPatLongIdentRecdField warnOnUpper cenv env vFlags patEnv ty (lidRange, rfinfo, args, m)
TcPatLongIdentRecdField warnOnUpper cenv env vFlags patEnv ty (mLongId, rfinfo, args, m)
| Item.Value vref ->
TcPatLongIdentLiteral warnOnUpper cenv env vFlags patEnv ty (lidRange, vref, args, m)
TcPatLongIdentLiteral warnOnUpper cenv env vFlags patEnv ty (mLongId, vref, args, m)
| _ -> error (Error(FSComp.SR.tcRequireVarConstRecogOrLiteral(), m))
@ -577,9 +577,9 @@ and ApplyUnionCaseOrExn m (cenv: cenv) env overallTy item =
let ucref = ucinfo.UnionCaseRef
CheckUnionCaseAttributes g ucref m |> CommitOperationResult
CheckUnionCaseAccessible cenv.amap m ad ucref |> ignore
let gtyp2 = actualResultTyOfUnionCase ucinfo.TypeInst ucref
let resTy = actualResultTyOfUnionCase ucinfo.TypeInst ucref
let inst = mkTyparInst ucref.TyconRef.TyparsNoRange ucinfo.TypeInst
UnifyTypes cenv env m overallTy gtyp2
UnifyTypes cenv env m overallTy resTy
let mkf mArgs args = TPat_unioncase(ucref, ucinfo.TypeInst, args, unionRanges m mArgs)
mkf, actualTysOfUnionCaseFields inst ucref, [ for f in ucref.AllFieldsAsList -> f.Id ]
@ -587,11 +587,11 @@ and ApplyUnionCaseOrExn m (cenv: cenv) env overallTy item =
invalidArg "item" "not a union case or exception reference"
/// Check a long identifier 'Case' or 'Case argsR that has been resolved to a union case or F# exception constructor
and TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags patEnv ty (lidRange, item, args, m) =
and TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags patEnv ty (mLongId, item, args, m) =
let g = cenv.g
// Report information about the case occurrence to IDE
CallNameResolutionSink cenv.tcSink (lidRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Pattern, env.eAccessRights)
CallNameResolutionSink cenv.tcSink (mLongId, env.NameEnv, item, emptyTyparInst, ItemOccurence.Pattern, env.eAccessRights)
let mkf, argTys, argNames = ApplyUnionCaseOrExn m cenv env ty item
let numArgTys = argTys.Length
@ -693,38 +693,38 @@ and TcPatLongIdentUnionCaseOrExnCase warnOnUpper cenv env ad vFlags patEnv ty (l
(fun values -> mkf m (List.map (fun f -> f values) argsR)), acc
/// Check a long identifier that has been resolved to an IL field - valid if a literal
and TcPatLongIdentILField warnOnUpper (cenv: cenv) env vFlags patEnv ty (lidRange, finfo, args, m) =
and TcPatLongIdentILField warnOnUpper (cenv: cenv) env vFlags patEnv ty (mLongId, finfo, args, m) =
let g = cenv.g
CheckILFieldInfoAccessible g cenv.amap lidRange env.AccessRights finfo
CheckILFieldInfoAccessible g cenv.amap mLongId env.AccessRights finfo
if not finfo.IsStatic then
errorR (Error (FSComp.SR.tcFieldIsNotStatic finfo.FieldName, lidRange))
errorR (Error (FSComp.SR.tcFieldIsNotStatic finfo.FieldName, mLongId))
CheckILFieldAttributes g finfo m
match finfo.LiteralValue with
| None ->
error (Error (FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern (), lidRange))
error (Error (FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern (), mLongId))
| Some lit ->
CheckNoArgsForLiteral args m
let _, acc = TcArgPats warnOnUpper cenv env vFlags patEnv args
UnifyTypes cenv env m ty (finfo.FieldType (cenv.amap, m))
let c' = TcFieldInit lidRange lit
let c' = TcFieldInit mLongId lit
let item = Item.ILField finfo
CallNameResolutionSink cenv.tcSink (lidRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Pattern, env.AccessRights)
CallNameResolutionSink cenv.tcSink (mLongId, env.NameEnv, item, emptyTyparInst, ItemOccurence.Pattern, env.AccessRights)
(fun _ -> TPat_const (c', m)), acc
/// Check a long identifier that has been resolved to a record field
and TcPatLongIdentRecdField warnOnUpper cenv env vFlags patEnv ty (lidRange, rfinfo, args, m) =
and TcPatLongIdentRecdField warnOnUpper cenv env vFlags patEnv ty (mLongId, rfinfo, args, m) =
let g = cenv.g
CheckRecdFieldInfoAccessible cenv.amap lidRange env.AccessRights rfinfo
if not rfinfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.DisplayName), lidRange))
CheckRecdFieldInfoAttributes g rfinfo lidRange |> CommitOperationResult
CheckRecdFieldInfoAccessible cenv.amap mLongId env.AccessRights rfinfo
if not rfinfo.IsStatic then errorR (Error (FSComp.SR.tcFieldIsNotStatic(rfinfo.DisplayName), mLongId))
CheckRecdFieldInfoAttributes g rfinfo mLongId |> CommitOperationResult
match rfinfo.LiteralValue with
| None -> error (Error(FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern(), lidRange))
| None -> error (Error(FSComp.SR.tcFieldNotLiteralCannotBeUsedInPattern(), mLongId))
| Some lit ->
CheckNoArgsForLiteral args m
let _, acc = TcArgPats warnOnUpper cenv env vFlags patEnv args
@ -733,26 +733,26 @@ and TcPatLongIdentRecdField warnOnUpper cenv env vFlags patEnv ty (lidRange, rfi
let item = Item.RecdField rfinfo
// FUTURE: can we do better than emptyTyparInst here, in order to display instantiations
// of type variables in the quick info provided in the IDE.
CallNameResolutionSink cenv.tcSink (lidRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Pattern, env.AccessRights)
CallNameResolutionSink cenv.tcSink (mLongId, env.NameEnv, item, emptyTyparInst, ItemOccurence.Pattern, env.AccessRights)
(fun _ -> TPat_const (lit, m)), acc
/// Check a long identifier that has been resolved to an F# value that is a literal
and TcPatLongIdentLiteral warnOnUpper (cenv: cenv) env vFlags patEnv ty (lidRange, vref, args, m) =
and TcPatLongIdentLiteral warnOnUpper (cenv: cenv) env vFlags patEnv ty (mLongId, vref, args, m) =
let g = cenv.g
let (TcPatLinearEnv(tpenv, _, _)) = patEnv
match vref.LiteralValue with
| None -> error (Error(FSComp.SR.tcNonLiteralCannotBeUsedInPattern(), m))
| Some lit ->
let _, _, _, vexpty, _, _ = TcVal true cenv env tpenv vref None None lidRange
CheckValAccessible lidRange env.AccessRights vref
CheckFSharpAttributes g vref.Attribs lidRange |> CommitOperationResult
let _, _, _, vexpty, _, _ = TcVal true cenv env tpenv vref None None mLongId
CheckValAccessible mLongId env.AccessRights vref
CheckFSharpAttributes g vref.Attribs mLongId |> CommitOperationResult
CheckNoArgsForLiteral args m
let _, acc = TcArgPats warnOnUpper cenv env vFlags patEnv args
UnifyTypes cenv env m ty vexpty
let item = Item.Value vref
CallNameResolutionSink cenv.tcSink (lidRange, env.NameEnv, item, emptyTyparInst, ItemOccurence.Pattern, env.AccessRights)
CallNameResolutionSink cenv.tcSink (mLongId, env.NameEnv, item, emptyTyparInst, ItemOccurence.Pattern, env.AccessRights)
(fun _ -> TPat_const (lit, m)), acc
and TcPatterns warnOnUpper cenv env vFlags s argTys args =

812
src/Compiler/Checking/ConstraintSolver.fs
Просмотреть файл

Разница между файлами не показана из-за своего большого размера Загрузить разницу

21
src/Compiler/Checking/ConstraintSolver.fsi
Просмотреть файл

@ -41,7 +41,13 @@ val NewInferenceTypes: TcGlobals -> 'T list -> TType list
/// 2. the instantiation mapping old type parameters to inference variables
/// 3. the inference type variables as a list of types.
val FreshenAndFixupTypars:
m: range -> rigid: TyparRigidity -> Typars -> TType list -> Typars -> Typars * TyparInstantiation * TType list
g: TcGlobals ->
m: range ->
rigid: TyparRigidity ->
Typars ->
TType list ->
Typars ->
Typars * TyparInstantiation * TType list
/// Given a set of type parameters, make new inference type variables for
/// each and ensure that the constraints on the new type variables are adjusted.
@ -50,13 +56,13 @@ val FreshenAndFixupTypars:
/// 1. the new type parameters
/// 2. the instantiation mapping old type parameters to inference variables
/// 3. the inference type variables as a list of types.
val FreshenTypeInst: range -> Typars -> Typars * TyparInstantiation * TType list
val FreshenTypeInst: g: TcGlobals -> range -> Typars -> Typars * TyparInstantiation * TType list
/// Given a set of type parameters, make new inference type variables for
/// each and ensure that the constraints on the new type variables are adjusted.
///
/// Returns the inference type variables as a list of types.
val FreshenTypars: range -> Typars -> TType list
val FreshenTypars: g: TcGlobals -> range -> Typars -> TType list
/// Given a method, which may be generic, make new inference type variables for
/// its generic parameters, and ensure that the constraints the new type variables are adjusted.
@ -251,7 +257,10 @@ val UnifyUniqueOverloading:
OverallTy ->
OperationResult<bool>
/// Remove the global constraints where these type variables appear in the support of the constraint
/// Re-assess the staticness of the type parameters
val UpdateStaticReqOfTypar: DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> Typar -> unit
/// Remove the global constraints related to generalized type variables
val EliminateConstraintsForGeneralizedTypars:
DisplayEnv -> ConstraintSolverState -> range -> OptionalTrace -> Typars -> unit
@ -304,6 +313,10 @@ val ApplyTyparDefaultAtPriority: DisplayEnv -> ConstraintSolverState -> priority
val CodegenWitnessExprForTraitConstraint:
TcValF -> TcGlobals -> ImportMap -> range -> TraitConstraintInfo -> Expr list -> OperationResult<Expr option>
/// Determine if a codegen witness for a trait will require witness args to be available, e.g. in generic code
val CodegenWitnessExprForTraitConstraintWillRequireWitnessArgs:
TcValF -> TcGlobals -> ImportMap -> range -> TraitConstraintInfo -> OperationResult<bool>
/// Generate the arguments passed when using a generic construct that accepts traits witnesses
val CodegenWitnessesForTyparInst:
TcValF ->

20
src/Compiler/Checking/FindUnsolved.fs
Просмотреть файл

@ -84,15 +84,15 @@ let rec accExpr (cenv: cenv) (env: env) expr =
accExprs cenv env argsl
| Expr.Lambda (_, _ctorThisValOpt, _baseValOpt, argvs, _body, m, bodyTy) ->
let topValInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal)
let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal)
let ty = mkMultiLambdaTy cenv.g m argvs bodyTy
accLambdas cenv env topValInfo expr ty
accLambdas cenv env valReprInfo expr ty
| Expr.TyLambda (_, tps, _body, _m, bodyTy) ->
let topValInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal)
let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal)
accTy cenv env bodyTy
let ty = mkForallTyIfNeeded tps bodyTy
accLambdas cenv env topValInfo expr ty
accLambdas cenv env valReprInfo expr ty
| Expr.TyChoose (_tps, e1, _m) ->
accExpr cenv env e1
@ -161,12 +161,12 @@ and accTraitInfo cenv env (TTrait(tys, _nm, _, argTys, retTy, _sln)) =
retTy |> Option.iter (accTy cenv env)
tys |> List.iter (accTy cenv env)
and accLambdas cenv env topValInfo expr exprTy =
and accLambdas cenv env valReprInfo expr exprTy =
match stripDebugPoints expr with
| Expr.TyChoose (_tps, bodyExpr, _m) -> accLambdas cenv env topValInfo bodyExpr exprTy
| Expr.TyChoose (_tps, bodyExpr, _m) -> accLambdas cenv env valReprInfo bodyExpr exprTy
| Expr.Lambda _
| Expr.TyLambda _ ->
let _tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destTopLambda cenv.g cenv.amap topValInfo (expr, exprTy)
let _tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo cenv.g cenv.amap valReprInfo (expr, exprTy)
accTy cenv env bodyTy
vsl |> List.iterSquared (accVal cenv env)
baseValOpt |> Option.iter (accVal cenv env)
@ -201,7 +201,7 @@ and accDiscrim cenv env d =
| DecisionTreeTest.ArrayLength(_, ty) -> accTy cenv env ty
| DecisionTreeTest.Const _
| DecisionTreeTest.IsNull -> ()
| DecisionTreeTest.IsInst (srcty, tgty) -> accTy cenv env srcty; accTy cenv env tgty
| DecisionTreeTest.IsInst (srcTy, tgtTy) -> accTy cenv env srcTy; accTy cenv env tgtTy
| DecisionTreeTest.ActivePatternCase (exp, tys, _, _, _, _) ->
accExpr cenv env exp
accTypeInst cenv env tys
@ -233,8 +233,8 @@ and accVal cenv env v =
and accBind cenv env (bind: Binding) =
accVal cenv env bind.Var
let topValInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData
accLambdas cenv env topValInfo bind.Expr bind.Var.Type
let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData
accLambdas cenv env valReprInfo bind.Expr bind.Var.Type
and accBinds cenv env binds =
binds |> List.iter (accBind cenv env)

177
src/Compiler/Checking/InfoReader.fs
Просмотреть файл

@ -5,6 +5,7 @@
module internal FSharp.Compiler.InfoReader
open System.Collections.Concurrent
open System.Collections.Generic
open Internal.Utilities.Library
open FSharp.Compiler
open FSharp.Compiler.AbstractIL.IL
@ -95,6 +96,51 @@ let rec GetImmediateIntrinsicMethInfosOfTypeAux (optFilter, ad) g amap m origTy
let GetImmediateIntrinsicMethInfosOfType (optFilter, ad) g amap m ty =
GetImmediateIntrinsicMethInfosOfTypeAux (optFilter, ad) g amap m ty ty
/// 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 GetImmediateTraitsInfosOfType optFilter g ty =
match tryDestTyparTy g ty with
| ValueSome tp ->
let infos = GetTraitConstraintInfosOfTypars g [tp]
match optFilter with
| None ->
[ for traitInfo in infos do
match traitInfo.MemberFlags.MemberKind with
| SynMemberKind.PropertySet ->
// A setter property trait only can be utilized via
// ^T.set_Property(v)
traitInfo.WithMemberKind(SynMemberKind.Member)
| _ ->
traitInfo ]
| Some nm ->
[ for traitInfo in infos do
match traitInfo.MemberFlags.MemberKind with
| SynMemberKind.PropertyGet ->
// A getter property trait can be utilized via
// ^T.Property
// ^T.get_Property()
// The latter doesn't appear in intellisense
if nm = traitInfo.MemberDisplayNameCore then
traitInfo
let traitInfo2 = traitInfo.WithMemberKind(SynMemberKind.Member)
if nm = traitInfo2.MemberDisplayNameCore then
traitInfo2
| SynMemberKind.PropertySet ->
// A setter property trait only can be utilized via
// ^T.set_Property(v)
let traitInfo2 = traitInfo.WithMemberKind(SynMemberKind.Member)
if nm = traitInfo2.MemberDisplayNameCore then
traitInfo2
| _ ->
// Method traits can be utilized via
// ^T.Member(v)
if nm = traitInfo.MemberDisplayNameCore then
traitInfo
]
| _ ->
[]
/// A helper type to help collect properties.
///
/// Join up getters and setters which are not associated in the F# data structure
@ -247,6 +293,7 @@ let FilterMostSpecificMethInfoSets g amap m (minfoSets: NameMultiMap<_>) : NameM
/// Used to collect sets of virtual methods, protected methods, protected
/// properties etc.
type HierarchyItem =
| TraitItem of TraitConstraintInfo list
| MethodItem of MethInfo list list
| PropertyItem of PropInfo list list
| RecdFieldItem of RecdFieldInfo
@ -393,16 +440,18 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this =
FoldPrimaryHierarchyOfType (fun ty acc -> ty :: acc) g amap m allowMultiIntfInst ty []
/// The primitive reader for the named items up a hierarchy
let GetIntrinsicNamedItemsUncached ((nm, ad), m, ty) =
let GetIntrinsicNamedItemsUncached ((nm, ad, includeConstraints), m, ty) =
if nm = ".ctor" then None else // '.ctor' lookups only ever happen via constructor syntax
let optFilter = Some nm
FoldPrimaryHierarchyOfType (fun ty acc ->
let qinfos = if includeConstraints then GetImmediateTraitsInfosOfType optFilter g ty else []
let minfos = GetImmediateIntrinsicMethInfosOfType (optFilter, ad) g amap m ty
let pinfos = GetImmediateIntrinsicPropInfosOfType (optFilter, ad) g amap m ty
let finfos = GetImmediateIntrinsicILFieldsOfType (optFilter, ad) m ty
let einfos = ComputeImmediateIntrinsicEventsOfType (optFilter, ad) m ty
let rfinfos = GetImmediateIntrinsicRecdOrClassFieldsOfType (optFilter, ad) m ty
match acc with
| _ when not (isNil qinfos) -> Some(TraitItem (qinfos))
| Some(MethodItem(inheritedMethSets)) when not (isNil minfos) -> Some(MethodItem (minfos :: inheritedMethSets))
| _ when not (isNil minfos) -> Some(MethodItem [minfos])
| Some(PropertyItem(inheritedPropSets)) when not (isNil pinfos) -> Some(PropertyItem(pinfos :: inheritedPropSets))
@ -615,7 +664,7 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this =
/// 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<_>) =
let MakeInfoCache f (flagsEq : IEqualityComparer<_>) =
MemoizationTable<_, _>
(compute=f,
// Only cache closed, monomorphic types (closed = all members for the type
@ -627,11 +676,11 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this =
| _ -> false),
keyComparer=
{ new System.Collections.Generic.IEqualityComparer<_> with
member _.Equals((flags1, _, typ1), (flags2, _, typ2)) =
{ new IEqualityComparer<_> with
member _.Equals((flags1, _, ty1), (flags2, _, ty2)) =
// Ignoring the ranges - that's OK.
flagsEq.Equals(flags1, flags2) &&
match stripTyEqns g typ1, stripTyEqns g typ2 with
match stripTyEqns g ty1, stripTyEqns g ty2 with
| TType_app(tcref1, [], _), TType_app(tcref2, [], _) -> tyconRefEq g tcref1 tcref2
| _ -> false
member _.GetHashCode((flags, _, ty)) =
@ -650,27 +699,44 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this =
else
this.TryFindIntrinsicMethInfo m ad "op_Implicit" ty
let IsInterfaceTypeWithMatchingStaticAbstractMemberUncached ((ad, nm), m, ty) =
ExistsInEntireHierarchyOfType (fun parentTy ->
let meths = this.TryFindIntrinsicMethInfo m ad nm parentTy
meths |> List.exists (fun meth ->
not meth.IsInstance &&
meth.IsDispatchSlot &&
isInterfaceTy g meth.ApparentEnclosingAppType
))
g amap m AllowMultiIntfInstantiations.Yes ty
let hashFlags0 =
{ new System.Collections.Generic.IEqualityComparer<string option * AccessorDomain * AllowMultiIntfInstantiations> with
{ new IEqualityComparer<string option * AccessorDomain * AllowMultiIntfInstantiations> with
member _.GetHashCode((filter: string option, ad: AccessorDomain, _allowMultiIntfInst1)) = hash filter + AccessorDomain.CustomGetHashCode ad
member _.Equals((filter1, ad1, allowMultiIntfInst1), (filter2, ad2, allowMultiIntfInst2)) =
(filter1 = filter2) && AccessorDomain.CustomEquals(g, ad1, ad2) && allowMultiIntfInst1 = allowMultiIntfInst2 }
let hashFlags1 =
{ new System.Collections.Generic.IEqualityComparer<string option * AccessorDomain> with
{ new IEqualityComparer<string option * AccessorDomain> with
member _.GetHashCode((filter: string option, ad: AccessorDomain)) = hash filter + AccessorDomain.CustomGetHashCode ad
member _.Equals((filter1, ad1), (filter2, ad2)) = (filter1 = filter2) && AccessorDomain.CustomEquals(g, ad1, ad2) }
let hashFlags2 =
{ new System.Collections.Generic.IEqualityComparer<string * AccessorDomain> with
member _.GetHashCode((nm: string, ad: AccessorDomain)) = hash nm + AccessorDomain.CustomGetHashCode ad
member _.Equals((nm1, ad1), (nm2, ad2)) = (nm1 = nm2) && AccessorDomain.CustomEquals(g, ad1, ad2) }
{ new IEqualityComparer<string * AccessorDomain * bool> with
member _.GetHashCode((nm: string, ad: AccessorDomain, includeConstraints)) =
hash nm + AccessorDomain.CustomGetHashCode ad + hash includeConstraints
member _.Equals((nm1, ad1, includeConstraints1), (nm2, ad2, includeConstraints2)) =
(nm1 = nm2) && AccessorDomain.CustomEquals(g, ad1, ad2) && (includeConstraints1 = includeConstraints2) }
let hashFlags3 =
{ new System.Collections.Generic.IEqualityComparer<AccessorDomain> with
{ new IEqualityComparer<AccessorDomain> with
member _.GetHashCode((ad: AccessorDomain)) = AccessorDomain.CustomGetHashCode ad
member _.Equals((ad1), (ad2)) = AccessorDomain.CustomEquals(g, ad1, ad2) }
let hashFlags4 =
{ new IEqualityComparer<AccessorDomain * string> with
member _.GetHashCode((ad, nm)) = AccessorDomain.CustomGetHashCode ad + hash nm
member _.Equals((ad1, nm1), (ad2, nm2)) = AccessorDomain.CustomEquals(g, ad1, ad2) && (nm1 = nm2) }
let methodInfoCache = MakeInfoCache GetIntrinsicMethodSetsUncached hashFlags0
let propertyInfoCache = MakeInfoCache GetIntrinsicPropertySetsUncached hashFlags0
let recdOrClassFieldInfoCache = MakeInfoCache GetIntrinsicRecdOrClassFieldInfosUncached hashFlags1
@ -682,23 +748,27 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this =
let entireTypeHierarchyCache = MakeInfoCache GetEntireTypeHierarchyUncached HashIdentity.Structural
let primaryTypeHierarchyCache = MakeInfoCache GetPrimaryTypeHierarchyUncached HashIdentity.Structural
let implicitConversionCache = MakeInfoCache FindImplicitConversionsUncached hashFlags3
let isInterfaceWithStaticAbstractMethodCache = MakeInfoCache IsInterfaceTypeWithMatchingStaticAbstractMemberUncached hashFlags4
// Runtime feature support
let isRuntimeFeatureSupported (infoReader: InfoReader) runtimeFeature =
let isRuntimeFeatureSupported runtimeFeature =
match g.System_Runtime_CompilerServices_RuntimeFeature_ty with
| Some runtimeFeatureTy ->
infoReader.GetILFieldInfosOfType (None, AccessorDomain.AccessibleFromEverywhere, range0, runtimeFeatureTy)
GetIntrinsicILFieldInfosUncached ((None, AccessorDomain.AccessibleFromEverywhere), range0, runtimeFeatureTy)
|> List.exists (fun (ilFieldInfo: ILFieldInfo) -> ilFieldInfo.FieldName = runtimeFeature)
| _ ->
false
let isRuntimeFeatureDefaultImplementationsOfInterfacesSupported =
lazy isRuntimeFeatureSupported this "DefaultImplementationsOfInterfaces"
lazy isRuntimeFeatureSupported "DefaultImplementationsOfInterfaces"
let isRuntimeFeatureVirtualStaticsInInterfacesSupported =
lazy isRuntimeFeatureSupported "VirtualStaticsInInterfaces"
member _.g = g
member _.amap = amap
/// Read the raw method sets of a type, including inherited ones. Cache the result for monomorphic types
member _.GetRawIntrinsicMethodSetsOfType (optFilter, ad, allowMultiIntfInst, m, ty) =
methodInfoCache.Apply(((optFilter, ad, allowMultiIntfInst), m, ty))
@ -739,8 +809,8 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this =
| _ -> 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 _.TryFindNamedItemOfType (nm, ad, m, ty) =
namedItemsCache.Apply(((nm, ad), m, ty))
member _.TryFindNamedItemOfType ((nm, ad, includeConstraints), m, ty) =
namedItemsCache.Apply(((nm, ad, includeConstraints), m, ty))
/// Read the raw method sets of a type that are the most specific overrides. Cache the result for monomorphic types
member _.GetIntrinsicMostSpecificOverrideMethodSetsOfType (optFilter, ad, allowMultiIntfInst, m, ty) =
@ -759,6 +829,7 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this =
match langFeature with
// Both default and static interface method consumption features are tied to the runtime support of DIMs.
| LanguageFeature.DefaultInterfaceMemberConsumption -> isRuntimeFeatureDefaultImplementationsOfInterfacesSupported.Value
| LanguageFeature.InterfacesWithAbstractStaticMembers -> isRuntimeFeatureVirtualStaticsInInterfacesSupported.Value
| _ -> true
/// Get the declared constructors of any F# type
@ -822,8 +893,11 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this =
member infoReader.GetIntrinsicPropInfosOfType optFilter ad allowMultiIntfInst findFlag m ty =
infoReader.GetIntrinsicPropInfoSetsOfType optFilter ad allowMultiIntfInst findFlag m ty |> List.concat
member infoReader.TryFindIntrinsicNamedItemOfType (nm, ad) findFlag m ty =
match infoReader.TryFindNamedItemOfType(nm, ad, m, ty) with
member _.GetTraitInfosInType optFilter ty =
GetImmediateTraitsInfosOfType optFilter g ty
member infoReader.TryFindIntrinsicNamedItemOfType (nm, ad, includeConstraints) findFlag m ty =
match infoReader.TryFindNamedItemOfType((nm, ad, includeConstraints), m, ty) with
| Some item ->
match item with
| PropertyItem psets -> Some(PropertyItem (psets |> FilterOverridesOfPropInfos findFlag infoReader.g infoReader.amap m))
@ -832,7 +906,7 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this =
| None -> None
/// Try to detect the existence of a method on a type.
member infoReader.TryFindIntrinsicMethInfo m ad nm ty =
member infoReader.TryFindIntrinsicMethInfo m ad nm ty : MethInfo list =
infoReader.GetIntrinsicMethInfosOfType (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
@ -843,22 +917,13 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this =
member _.FindImplicitConversions m ad ty =
implicitConversionCache.Apply((ad, m, ty))
let private tryLanguageFeatureRuntimeErrorAux (infoReader: InfoReader) langFeature m error =
member _.IsInterfaceTypeWithMatchingStaticAbstractMember m nm ad ty =
isInterfaceWithStaticAbstractMethodCache.Apply((ad, nm), m, ty)
let checkLanguageFeatureRuntimeAndRecover (infoReader: InfoReader) langFeature m =
if not (infoReader.IsLanguageFeatureRuntimeSupported langFeature) then
let featureStr = infoReader.g.langVersion.GetFeatureString langFeature
error (Error(FSComp.SR.chkFeatureNotRuntimeSupported featureStr, m))
false
else
true
let checkLanguageFeatureRuntimeError infoReader langFeature m =
tryLanguageFeatureRuntimeErrorAux infoReader langFeature m error |> ignore
let checkLanguageFeatureRuntimeErrorRecover infoReader langFeature m =
tryLanguageFeatureRuntimeErrorAux infoReader langFeature m errorR |> ignore
let tryLanguageFeatureRuntimeErrorRecover infoReader langFeature m =
tryLanguageFeatureRuntimeErrorAux infoReader langFeature m errorR
errorR (Error(FSComp.SR.chkFeatureNotRuntimeSupported featureStr, m))
let GetIntrinsicConstructorInfosOfType (infoReader: InfoReader) m ty =
infoReader.GetIntrinsicConstructorInfosOfTypeAux m ty ty
@ -881,8 +946,8 @@ let GetIntrinsicMethInfosOfType (infoReader: InfoReader) optFilter ad allowMulti
let GetIntrinsicPropInfosOfType (infoReader: InfoReader) optFilter ad allowMultiIntfInst findFlag m ty =
infoReader.GetIntrinsicPropInfosOfType optFilter ad allowMultiIntfInst findFlag m ty
let TryFindIntrinsicNamedItemOfType (infoReader: InfoReader) (nm, ad) findFlag m ty =
infoReader.TryFindIntrinsicNamedItemOfType (nm, ad) findFlag m ty
let TryFindIntrinsicNamedItemOfType (infoReader: InfoReader) (nm, ad, includeConstraints) findFlag m ty =
infoReader.TryFindIntrinsicNamedItemOfType (nm, ad, includeConstraints) findFlag m ty
let TryFindIntrinsicMethInfo (infoReader: InfoReader) m ad nm ty =
infoReader.TryFindIntrinsicMethInfo m ad nm ty
@ -910,11 +975,11 @@ type SigOfFunctionForDelegate =
/// 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 GetSigOfFunctionForDelegate (infoReader: InfoReader) delTy m ad =
let g = infoReader.g
let amap = infoReader.amap
let delInvokeMeth =
match GetIntrinsicMethInfosOfType infoReader (Some "Invoke") ad AllowMultiIntfInstantiations.Yes IgnoreOverrides m delty with
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
@ -964,26 +1029,26 @@ let TryDestStandardDelegateType (infoReader: InfoReader) m ad delTy =
// 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 TryDestStandardDelegateType infoReader m ad dty with
let delTy = einfo.GetDelegateType(infoReader.amap, m)
match TryDestStandardDelegateType infoReader m ad delTy with
| Some _ -> true
| None -> false
/// Get the (perhaps tupled) argument type accepted by an event
let ArgsTypOfEventInfo (infoReader: InfoReader) m ad (einfo: EventInfo) =
let ArgsTypeOfEventInfo (infoReader: InfoReader) m ad (einfo: EventInfo) =
let amap = infoReader.amap
let dty = einfo.GetDelegateType(amap, m)
match TryDestStandardDelegateType infoReader m ad dty with
let delTy = einfo.GetDelegateType(amap, m)
match TryDestStandardDelegateType infoReader m ad delTy 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 PropTypeOfEventInfo (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
let argsTy = ArgsTypeOfEventInfo infoReader m ad einfo
mkIEventType g delTy argsTy
/// Try to find the name of the metadata file for this external definition
@ -1029,11 +1094,11 @@ let GetXmlDocSigOfScopedValRef g (tcref: TyconRef) (vref: ValRef) =
let ccuFileName = libFileOfEntityRef tcref
let v = vref.Deref
if v.XmlDocSig = "" && v.HasDeclaringEntity then
let ap = buildAccessPath vref.TopValDeclaringEntity.CompilationPathOpt
let ap = buildAccessPath vref.DeclaringEntity.CompilationPathOpt
let path =
if vref.TopValDeclaringEntity.IsModule then
if vref.DeclaringEntity.IsModule then
let sep = if ap.Length > 0 then "." else ""
ap + sep + vref.TopValDeclaringEntity.CompiledName
ap + sep + vref.DeclaringEntity.CompiledName
else
ap
v.XmlDocSig <- XmlDocSigOfVal g false path v
@ -1061,7 +1126,7 @@ let GetXmlDocSigOfMethInfo (infoReader: InfoReader) m (minfo: MethInfo) =
| ILMeth (g, ilminfo, _) ->
let actualTypeName = ilminfo.DeclaringTyconRef.CompiledRepresentationForNamedType.FullName
let fmtps = ilminfo.FormalMethodTypars
let genArity = if fmtps.Length=0 then "" else sprintf "``%d" fmtps.Length
let genericArity = if fmtps.Length=0 then "" else sprintf "``%d" fmtps.Length
match TryFindMetadataInfoOfExternalEntityRef infoReader m ilminfo.DeclaringTyconRef with
| None -> None
@ -1079,8 +1144,14 @@ let GetXmlDocSigOfMethInfo (infoReader: InfoReader) m (minfo: MethInfo) =
// qualified name of the String constructor would be "System.String.#ctor".
let normalizedName = ilminfo.ILName.Replace(".", "#")
Some (ccuFileName, "M:"+actualTypeName+"."+normalizedName+genArity+XmlDocArgsEnc g (formalTypars, fmtps) args)
| DefaultStructCtor _ -> None
Some (ccuFileName, "M:"+actualTypeName+"."+normalizedName+genericArity+XmlDocArgsEnc g (formalTypars, fmtps) args)
| DefaultStructCtor(g, ty) ->
match tryTcrefOfAppTy g ty with
| ValueSome tcref ->
Some(None, $"M:{tcref.CompiledRepresentationForNamedType.FullName}.#ctor")
| _ -> None
#if !NO_TYPEPROVIDERS
| ProvidedMeth _ -> None
#endif
@ -1090,7 +1161,7 @@ let GetXmlDocSigOfValRef g (vref: ValRef) =
let ccuFileName = vref.nlr.Ccu.FileName
let v = vref.Deref
if v.XmlDocSig = "" && v.HasDeclaringEntity then
v.XmlDocSig <- XmlDocSigOfVal g false vref.TopValDeclaringEntity.CompiledRepresentationForNamedType.Name v
v.XmlDocSig <- XmlDocSigOfVal g false vref.DeclaringEntity.CompiledRepresentationForNamedType.Name v
Some (ccuFileName, v.XmlDocSig)
else
match vref.ApparentEnclosingEntity with

30
src/Compiler/Checking/InfoReader.fsi
Просмотреть файл

@ -73,6 +73,7 @@ val FilterMostSpecificMethInfoSets:
/// Used to collect sets of virtual methods, protected methods, protected
/// properties etc.
type HierarchyItem =
| TraitItem of TraitConstraintInfo list
| MethodItem of MethInfo list list
| PropertyItem of PropInfo list list
| RecdFieldItem of RecdFieldInfo
@ -150,7 +151,10 @@ type InfoReader =
ty: TType ->
MethInfo list list
/// Get the sets intrinsic properties in the hierarchy (not including extension properties)
/// Get the trait infos for a type variable (empty for everything else)
member GetTraitInfosInType: optFilter: string option -> ty: TType -> TraitConstraintInfo list
/// Get the sets of intrinsic properties in the hierarchy (not including extension properties)
member GetIntrinsicPropInfoSetsOfType:
optFilter: string option ->
ad: AccessorDomain ->
@ -182,20 +186,22 @@ type InfoReader =
/// Perform type-directed name resolution of a particular named member in an F# type
member TryFindIntrinsicNamedItemOfType:
nm: string * ad: AccessorDomain -> findFlag: FindMemberFlag -> m: range -> ty: TType -> HierarchyItem option
nm: string * ad: AccessorDomain * includeConstraints: bool ->
findFlag: FindMemberFlag ->
m: range ->
ty: TType ->
HierarchyItem option
/// Find the op_Implicit for a type
member FindImplicitConversions: m: range -> ad: AccessorDomain -> ty: TType -> MethInfo list
val checkLanguageFeatureRuntimeError:
infoReader: InfoReader -> langFeature: Features.LanguageFeature -> m: range -> unit
/// Determine if a type has a static abstract method with the given name somewhere in its hierarchy
member IsInterfaceTypeWithMatchingStaticAbstractMember:
m: range -> nm: string -> ad: AccessorDomain -> ty: TType -> bool
val checkLanguageFeatureRuntimeErrorRecover:
val checkLanguageFeatureRuntimeAndRecover:
infoReader: InfoReader -> langFeature: Features.LanguageFeature -> m: range -> unit
val tryLanguageFeatureRuntimeErrorRecover:
infoReader: InfoReader -> langFeature: Features.LanguageFeature -> m: range -> bool
/// Get the declared constructors of any F# type
val GetIntrinsicConstructorInfosOfType: infoReader: InfoReader -> m: range -> ty: TType -> MethInfo list
@ -252,7 +258,7 @@ val GetIntrinsicPropInfosOfType:
/// Perform type-directed name resolution of a particular named member in an F# type
val TryFindIntrinsicNamedItemOfType:
infoReader: InfoReader ->
nm: string * ad: AccessorDomain ->
nm: string * ad: AccessorDomain * includeConstraints: bool ->
findFlag: FindMemberFlag ->
m: range ->
ty: TType ->
@ -280,7 +286,7 @@ type SigOfFunctionForDelegate =
/// 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.
val GetSigOfFunctionForDelegate:
infoReader: InfoReader -> delty: TType -> m: range -> ad: AccessorDomain -> SigOfFunctionForDelegate
infoReader: InfoReader -> delTy: TType -> m: range -> ad: AccessorDomain -> SigOfFunctionForDelegate
/// Try and interpret a delegate type as a "standard" .NET delegate type associated with an event, with a "sender" parameter.
val TryDestStandardDelegateType:
@ -290,9 +296,9 @@ val TryDestStandardDelegateType:
/// with a sender parameter.
val IsStandardEventInfo: infoReader: InfoReader -> m: range -> ad: AccessorDomain -> einfo: EventInfo -> bool
val ArgsTypOfEventInfo: infoReader: InfoReader -> m: range -> ad: AccessorDomain -> einfo: EventInfo -> TType
val ArgsTypeOfEventInfo: infoReader: InfoReader -> m: range -> ad: AccessorDomain -> einfo: EventInfo -> TType
val PropTypOfEventInfo: infoReader: InfoReader -> m: range -> ad: AccessorDomain -> einfo: EventInfo -> TType
val PropTypeOfEventInfo: infoReader: InfoReader -> m: range -> ad: AccessorDomain -> einfo: EventInfo -> TType
/// Try to find the name of the metadata file for this external definition
val TryFindMetadataInfoOfExternalEntityRef:

284
src/Compiler/Checking/MethodCalls.fs
Просмотреть файл

@ -12,6 +12,7 @@ open FSharp.Compiler.AccessibilityLogic
open FSharp.Compiler.AttributeChecking
open FSharp.Compiler.DiagnosticsLogger
open FSharp.Compiler.Features
open FSharp.Compiler.Import
open FSharp.Compiler.InfoReader
open FSharp.Compiler.Infos
open FSharp.Compiler.IO
@ -101,7 +102,8 @@ type AssignedCalledArg<'T> =
/// 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 *)
// the MethInfo is a non-indexer setter property
| AssignedPropSetter of staticTyOpt: TType option * pinfo: PropInfo * minfo: MethInfo * pminst: TypeInst
| AssignedILFieldSetter of ILFieldInfo
| AssignedRecdFieldSetter of RecdFieldInfo
@ -181,7 +183,7 @@ let TryFindRelevantImplicitConversion (infoReader: InfoReader) ad reqdTy actualT
let reqdTy2 =
if isTyparTy g reqdTy then
let tp = destTyparTy g reqdTy
match tp.Constraints |> List.choose (function TyparConstraint.CoercesTo (c, _) -> Some c | _ -> None) with
match tp.Constraints |> List.choose (function TyparConstraint.CoercesTo (tgtTy, _) -> Some tgtTy | _ -> None) with
| [reqdTy2] when tp.Rigidity = TyparRigidity.Flexible -> reqdTy2
| _ -> reqdTy
else reqdTy
@ -197,11 +199,13 @@ let TryFindRelevantImplicitConversion (infoReader: InfoReader) ad reqdTy actualT
isTyparTy g actualTy && (let ftyvs = freeInType CollectAll reqdTy2 in ftyvs.FreeTypars.Contains(destTyparTy g actualTy))) then
let implicits =
infoReader.FindImplicitConversions m ad actualTy @
infoReader.FindImplicitConversions m ad reqdTy2
[ for conv in infoReader.FindImplicitConversions m ad actualTy do
(conv, actualTy)
for conv in infoReader.FindImplicitConversions m ad reqdTy2 do
(conv, reqdTy2) ]
let implicits =
implicits |> List.filter (fun minfo ->
implicits |> List.filter (fun (minfo, _staticTy) ->
not minfo.IsInstance &&
minfo.FormalMethodTyparInst.IsEmpty &&
(match minfo.GetParamTypes(amap, m, []) with
@ -212,12 +216,12 @@ let TryFindRelevantImplicitConversion (infoReader: InfoReader) ad reqdTy actualT
)
match implicits with
| [minfo] ->
Some (minfo, (reqdTy, reqdTy2, ignore))
| minfo :: _ ->
Some (minfo, (reqdTy, reqdTy2, fun denv ->
| [(minfo, staticTy) ] ->
Some (minfo, staticTy, (reqdTy, reqdTy2, ignore))
| (minfo, staticTy) :: _ ->
Some (minfo, staticTy, (reqdTy, reqdTy2, fun denv ->
let reqdTy2Text, actualTyText, _cxs = NicePrint.minimalStringsOfTwoTypes denv reqdTy2 actualTy
let implicitsText = NicePrint.multiLineStringOfMethInfos infoReader m denv implicits
let implicitsText = NicePrint.multiLineStringOfMethInfos infoReader m denv (List.map fst implicits)
errorR(Error(FSComp.SR.tcAmbiguousImplicitConversion(actualTyText, reqdTy2Text, implicitsText), m))))
| _ -> None
else
@ -289,7 +293,7 @@ let rec AdjustRequiredTypeForTypeDirectedConversions (infoReader: InfoReader) ad
// eliminate articifical constrained type variables.
elif g.langVersion.SupportsFeature LanguageFeature.AdditionalTypeDirectedConversions then
match TryFindRelevantImplicitConversion infoReader ad reqdTy actualTy m with
| Some (minfo, eqn) -> actualTy, TypeDirectedConversionUsed.Yes(warn (TypeDirectedConversion.Implicit minfo)), Some eqn
| Some (minfo, _staticTy, eqn) -> actualTy, TypeDirectedConversionUsed.Yes(warn (TypeDirectedConversion.Implicit minfo)), Some eqn
| None -> reqdTy, TypeDirectedConversionUsed.No, None
else reqdTy, TypeDirectedConversionUsed.No, None
@ -363,8 +367,8 @@ let AdjustCalledArgTypeForOptionals (infoReader: InfoReader) ad enforceNullableO
calledArgTy, TypeDirectedConversionUsed.No, None
| _ ->
let compgenId = mkSynId range0 unassignedTyparName
let tp = mkTyparTy (Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, SynTypar(compgenId, TyparStaticReq.None, true), false, TyparDynamicReq.No, [], false, false))
tp, TypeDirectedConversionUsed.No, None
let tpTy = mkTyparTy (Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, SynTypar(compgenId, TyparStaticReq.None, true), false, TyparDynamicReq.No, [], false, false))
tpTy, TypeDirectedConversionUsed.No, None
else
AdjustCalledArgTypeForTypeDirectedConversionsAndAutoQuote infoReader ad callerArgTy calledArgTy calledArg m
@ -456,7 +460,7 @@ type CalledMethArgSet<'T> =
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, isInArg, isOutArg, optArgInfo, callerInfoFlags, nmOpt, reflArgInfo, typeOfCalledArg)) ->
paramDatas |> List.mapiSquared (fun i j (ParamData(isParamArrayArg, isInArg, isOutArg, optArgInfo, callerInfoFlags, nmOpt, reflArgInfo, calledArgTy)) ->
{ Position=(i,j)
IsParamArray=isParamArrayArg
OptArgInfo=optArgInfo
@ -465,7 +469,7 @@ let MakeCalledArgs amap m (minfo: MethInfo) minst =
IsOutArg=isOutArg
ReflArgInfo=reflArgInfo
NameOpt=nmOpt
CalledArgumentType=typeOfCalledArg })
CalledArgumentType=calledArgTy })
/// <summary>
/// Represents the syntactic matching between a caller of a method and the called method.
@ -488,6 +492,7 @@ let MakeCalledArgs amap m (minfo: MethInfo) minst =
/// <param name='allowParamArgs'>Do we allow the use of a param args method in its "expanded" form?</param>
/// <param name='allowOutAndOptArgs'>Do we allow the use of the transformation that converts out arguments as tuple returns?</param>
/// <param name='tyargsOpt'>Method parameters</param>
/// <param name='staticTyOpt'>The optional static type governing a constrained static virtual interface call</param>
type CalledMeth<'T>
(infoReader: InfoReader,
nameEnv: NameResolutionEnv option,
@ -503,7 +508,8 @@ type CalledMeth<'T>
callerArgs: CallerArgs<'T>,
allowParamArgs: bool,
allowOutAndOptArgs: bool,
tyargsOpt: TType option)
tyargsOpt: TType option,
staticTyOpt: TType option)
=
let g = infoReader.g
let methodRetTy = if minfo.IsConstructor then minfo.ApparentEnclosingType else minfo.GetFSharpReturnType(infoReader.amap, m, calledTyArgs)
@ -617,7 +623,8 @@ type CalledMeth<'T>
| [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 propStaticTyOpt = if isTyparTy g returnedObjTy then Some returnedObjTy else None
Choice1Of2(AssignedItemSetter(id, AssignedPropSetter(propStaticTyOpt, pinfo, pminfo, pminst), e))
| _ ->
let epinfos =
match nameEnv with
@ -636,7 +643,8 @@ type CalledMeth<'T>
| Some(TType_app(_, types, _)) -> types
| _ -> pminst
Choice1Of2(AssignedItemSetter(id, AssignedPropSetter(pinfo, pminfo, pminst), e))
let propStaticTyOpt = if isTyparTy g returnedObjTy then Some returnedObjTy else None
Choice1Of2(AssignedItemSetter(id, AssignedPropSetter(propStaticTyOpt, pinfo, pminfo, pminst), e))
| _ ->
match infoReader.GetILFieldInfosOfType(Some(nm), ad, m, returnedObjTy) with
| finfo :: _ ->
@ -792,6 +800,8 @@ type CalledMeth<'T>
member x.TotalNumAssignedNamedArgs = x.ArgSets |> List.sumBy (fun x -> x.NumAssignedNamedArgs)
member x.OptionalStaticType = staticTyOpt
override x.ToString() = "call to " + minfo.ToString()
let NamesOfCalledArgs (calledArgs: CalledArg list) =
@ -869,11 +879,14 @@ let IsBaseCall objArgs =
/// 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 ComputeConstrainedCallInfo g amap m staticTyOpt args (minfo: MethInfo) =
match args, staticTyOpt with
| _, Some staticTy when not minfo.IsExtensionMember && not minfo.IsInstance && minfo.IsAbstract -> Some staticTy
| (objArgExpr :: _), _ when minfo.IsInstance && not minfo.IsExtensionMember ->
let methObjTy = minfo.ApparentEnclosingType
let objArgTy = tyOfExpr g objArgExpr
let objArgTy = if isByrefTy g objArgTy then destByrefTy g objArgTy else objArgTy
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
@ -891,8 +904,8 @@ let ComputeConstrainedCallInfo g amap m (objArgs, minfo: MethInfo) =
/// 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 TakeObjAddrForMethodCall g amap (minfo: MethInfo) isMutable m staticTyOpt objArgs f =
let ccallInfo = ComputeConstrainedCallInfo g amap m staticTyOpt objArgs minfo
let wrap, objArgs =
@ -969,7 +982,7 @@ let BuildILMethInfoCall g amap m isProp (minfo: ILMethInfo) valUseFlags minst di
///
/// 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 BuildFSharpMethodApp g m (vref: ValRef) vExpr vexprty (args: Exprs) =
let arities = (arityOfVal vref.Deref).AritiesOfArgs
let args3, (leftover, retTy) =
@ -990,28 +1003,35 @@ let BuildFSharpMethodApp g m (vref: ValRef) vexp vexprty (args: Exprs) =
(mkRefTupled 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),
mkApps g ((vExpr, vexprty), [], args3, m),
retTy
/// Build a call to an F# method.
let BuildFSharpMethodCall g m (ty, vref: ValRef) valUseFlags minst args =
let vexp = Expr.Val (vref, valUseFlags, m)
let vexpty = vref.Type
let vExpr = Expr.Val (vref, valUseFlags, m)
let vExprTy = vref.Type
let tpsorig, tau = vref.GeneralizedType
let vtinst = argsOfAppTy g ty @ minst
if tpsorig.Length <> vtinst.Length then error(InternalError("BuildFSharpMethodCall: unexpected List.length mismatch", m))
let expr = mkTyAppExpr m (vexp, vexpty) vtinst
let expr = mkTyAppExpr m (vExpr, vExprTy) 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"
let MakeMethInfoCall (amap: ImportMap) m (minfo: MethInfo) minst args staticTyOpt =
let g = amap.g
let ccallInfo = ComputeConstrainedCallInfo g amap m staticTyOpt args minfo
let valUseFlags =
match ccallInfo with
| Some ty ->
// printfn "possible constrained call to '%s' at %A" minfo.LogicalName m
PossibleConstrainedCall ty
| None ->
NormalValUse
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
@ -1069,10 +1089,10 @@ let TryImportProvidedMethodBaseAsLibraryIntrinsic (amap: Import.ImportMap, m: ra
// 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 BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objArgs args staticTyOpt =
let direct = IsBaseCall objArgs
TakeObjAddrForMethodCall g amap minfo isMutable m objArgs (fun ccallInfo objArgs ->
TakeObjAddrForMethodCall g amap minfo isMutable m staticTyOpt objArgs (fun ccallInfo objArgs ->
let allArgs = objArgs @ args
let valUseFlags =
if direct && (match valUseFlags with NormalValUse -> true | _ -> false) then
@ -1113,8 +1133,8 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA
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
let vExpr, vExprTy = tcVal fsValRef valUseFlags (minfo.DeclaringTypeInst @ minst) m
BuildFSharpMethodApp g m fsValRef vExpr vExprTy allArgs
| None ->
let ilMethRef = Import.ImportProvidedMethodBaseAsILMethodRef amap m providedMeth
let isNewObj = isCtor && (match valUseFlags with NormalValUse -> true | _ -> false)
@ -1139,8 +1159,8 @@ let BuildMethodCall tcVal g amap isMutable m isProp minfo valUseFlags minst objA
// 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
let vExpr, vExprTy = tcVal vref valUseFlags (minfo.DeclaringTypeInst @ minst) m
BuildFSharpMethodApp g m vref vExpr vExprTy allArgs
// Build a 'call' to a struct default constructor
| DefaultStructCtor (g, ty) ->
@ -1154,7 +1174,7 @@ let ILFieldStaticChecks g amap infoReader ad m (finfo : ILFieldInfo) =
// Static IL interfaces fields are not supported in lower F# versions.
if isInterfaceTy g finfo.ApparentEnclosingType then
checkLanguageFeatureRuntimeErrorRecover infoReader LanguageFeature.DefaultInterfaceMemberConsumption m
checkLanguageFeatureRuntimeAndRecover infoReader LanguageFeature.DefaultInterfaceMemberConsumption m
checkLanguageFeatureAndRecover g.langVersion LanguageFeature.DefaultInterfaceMemberConsumption m
CheckILFieldAttributes g finfo m
@ -1211,7 +1231,7 @@ let BuildObjCtorCall (g: TcGlobals) m =
let BuildNewDelegateExpr (eventInfoOpt: EventInfo option, g, amap, delegateTy, delInvokeMeth: MethInfo, delArgTys, delFuncExpr, delFuncTy, m) =
let slotsig = delInvokeMeth.GetSlotSig(amap, m)
let delArgVals, expr =
let topValInfo = ValReprInfo([], List.replicate (max 1 (List.length delArgTys)) ValReprInfo.unnamedTopArg, ValReprInfo.unnamedRetVal)
let valReprInfo = ValReprInfo([], List.replicate (max 1 (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
@ -1219,7 +1239,7 @@ let BuildNewDelegateExpr (eventInfoOpt: EventInfo option, g, amap, delegateTy, d
if Option.isSome eventInfoOpt then
None
else
tryDestTopLambda g amap topValInfo (delFuncExpr, delFuncTy)
tryDestLambdaWithValReprInfo g amap valReprInfo (delFuncExpr, delFuncTy)
match lambdaContents with
| None ->
@ -1244,7 +1264,7 @@ let BuildNewDelegateExpr (eventInfoOpt: EventInfo option, g, amap, delegateTy, d
delArgVals, expr
| Some _ ->
let _, _, _, vsl, body, _ = IteratedAdjustArityOfLambda g amap topValInfo delFuncExpr
let _, _, _, vsl, body, _ = IteratedAdjustLambdaToMatchValReprInfo g amap valReprInfo delFuncExpr
List.concat vsl, body
let meth = TObjExprMethod(slotsig, [], [], [delArgVals], expr, m)
@ -1287,9 +1307,10 @@ let rec AdjustExprForTypeDirectedConversions tcVal (g: TcGlobals) amap infoReade
else
match TryFindRelevantImplicitConversion infoReader ad reqdTy actualTy m with
| Some (minfo, _) ->
| Some (minfo, staticTy, _) ->
MethInfoChecks g amap false None [] ad m minfo
let callExpr, _ = BuildMethodCall tcVal g amap Mutates.NeverMutates m false minfo ValUseFlag.NormalValUse [] [] [expr]
let staticTyOpt = if isTyparTy g staticTy then Some staticTy else None
let callExpr, _ = BuildMethodCall tcVal g amap Mutates.NeverMutates m false minfo ValUseFlag.NormalValUse [] [] [expr] staticTyOpt
assert (let resTy = tyOfExpr g callExpr in typeEquiv g reqdTy resTy)
callExpr
| None -> mkCoerceIfNeeded g reqdTy actualTy expr
@ -1438,7 +1459,7 @@ let MakeNullableExprIfNeeded (infoReader: InfoReader) calledArgTy callerArgTy ca
let calledNonOptTy = destNullableTy g calledArgTy
let minfo = GetIntrinsicConstructorInfosOfType infoReader m calledArgTy |> List.head
let callerArgExprCoerced = mkCoerceIfNeeded g calledNonOptTy callerArgTy callerArgExpr
MakeMethInfoCall amap m minfo [] [callerArgExprCoerced]
MakeMethInfoCall amap m minfo [] [callerArgExprCoerced] None
// Adjust all the optional arguments, filling in values for defaults,
let AdjustCallerArgForOptional tcVal tcFieldInit eCallerMemberName (infoReader: InfoReader) ad (assignedArg: AssignedCalledArg<_>) =
@ -1793,6 +1814,7 @@ module ProvidedMethodCalls =
for v, e in Seq.zip (paramVars |> Seq.map (fun x -> x.PUntaint(id, m))) (Option.toList thisArg @ allArgs) do
dict.Add(v, (None, e))
dict
let rec exprToExprAndWitness top (ea: Tainted<ProvidedExpr>) =
let fail() = error(Error(FSComp.SR.etUnsupportedProvidedExpression(ea.PUntaint((fun etree -> etree.UnderlyingExpressionString), m)), m))
match ea with
@ -1806,139 +1828,139 @@ module ProvidedMethodCalls =
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)
let exprR = mkCoerceIfNeeded g targetTy sourceTy srcExpr
None, (exprR, tyOfExpr g exprR)
| ProvidedTypeTestExpr (expr, targetTy) ->
let expr, targetTy = exprType.PApply2((fun _ -> (expr, targetTy)), 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)
let exprR = mkCallTypeTest g m targetTy srcExpr
None, (exprR, tyOfExpr g exprR)
| ProvidedIfThenElseExpr (test, thenBranch, elseBranch) ->
let test, thenBranch, elseBranch = exprType.PApply3((fun _ -> (test, thenBranch, elseBranch)), m)
let testExpr = exprToExpr test
let ifTrueExpr = exprToExpr thenBranch
let ifFalseExpr = exprToExpr elseBranch
let te = mkCond DebugPointAtBinding.NoneAtSticky m (tyOfExpr g ifTrueExpr) testExpr ifTrueExpr ifFalseExpr
None, (te, tyOfExpr g te)
let exprR = mkCond DebugPointAtBinding.NoneAtSticky m (tyOfExpr g ifTrueExpr) testExpr ifTrueExpr ifFalseExpr
None, (exprR, tyOfExpr g exprR)
| ProvidedVarExpr providedVar ->
let _, vTe = varToExpr (exprType.PApply((fun _ -> providedVar), m))
None, (vTe, tyOfExpr g vTe)
| ProvidedConstantExpr (obj, prType) ->
let ce = convertConstExpr g amap m (exprType.PApply((fun _ -> (obj, prType)), m))
None, (ce, tyOfExpr g ce)
let exprR = convertConstExpr g amap m (exprType.PApply((fun _ -> (obj, prType)), m))
None, (exprR, tyOfExpr g exprR)
| ProvidedNewTupleExpr info ->
let elems = exprType.PApplyArray((fun _ -> info), "GetInvokerExpression", m)
let elemsT = elems |> Array.map exprToExpr |> Array.toList
let exprT = mkRefTupledNoTypes g m elemsT
None, (exprT, tyOfExpr g exprT)
let elemsR = elems |> Array.map exprToExpr |> Array.toList
let exprR = mkRefTupledNoTypes g m elemsR
None, (exprR, tyOfExpr g exprR)
| ProvidedNewArrayExpr (ty, elems) ->
let ty, elems = exprType.PApply2((fun _ -> (ty, elems)), m)
let tyT = Import.ImportProvidedType amap m ty
let tyR = Import.ImportProvidedType amap m ty
let elems = elems.PApplyArray(id, "GetInvokerExpression", m)
let elemsT = elems |> Array.map exprToExpr |> Array.toList
let exprT = Expr.Op (TOp.Array, [tyT], elemsT, m)
None, (exprT, tyOfExpr g exprT)
let elemsR = elems |> Array.map exprToExpr |> Array.toList
let exprR = Expr.Op (TOp.Array, [tyR], elemsR, m)
None, (exprR, tyOfExpr g exprR)
| ProvidedTupleGetExpr (inp, n) ->
let inp, n = exprType.PApply2((fun _ -> (inp, n)), m)
let inpT = inp |> exprToExpr
let inpR = 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
let exprTy =
let t = tyOfExpr g inpR
stripTyEqnsWrtErasure EraseMeasures g t
let tupInfo, tysT = tryDestAnyTupleTy g typeOfExpr
let exprT = mkTupleFieldGet g (tupInfo, inpT, tysT, n.PUntaint(id, m), m)
None, (exprT, tyOfExpr g exprT)
let tupInfo, tysT = tryDestAnyTupleTy g exprTy
let exprR = mkTupleFieldGet g (tupInfo, inpR, tysT, n.PUntaint(id, m), m)
None, (exprR, tyOfExpr g exprR)
| ProvidedLambdaExpr (v, b) ->
let v, b = exprType.PApply2((fun _ -> (v, b)), m)
let vT = addVar v
let bT = exprToExpr b
let vR = addVar v
let bR = exprToExpr b
removeVar v
let exprT = mkLambda m vT (bT, tyOfExpr g bT)
None, (exprT, tyOfExpr g exprT)
let exprR = mkLambda m vR (bR, tyOfExpr g bR)
None, (exprR, tyOfExpr g exprR)
| ProvidedLetExpr (v, e, b) ->
let v, e, b = exprType.PApply3((fun _ -> (v, e, b)), m)
let eT = exprToExpr e
let vT = addVar v
let bT = exprToExpr b
let eR = exprToExpr e
let vR = addVar v
let bR = exprToExpr b
removeVar v
let exprT = mkCompGenLet m vT eT bT
None, (exprT, tyOfExpr g exprT)
let exprR = mkCompGenLet m vR eR bR
None, (exprR, tyOfExpr g exprR)
| ProvidedVarSetExpr (v, e) ->
let v, e = exprType.PApply2((fun _ -> (v, e)), m)
let eT = exprToExpr e
let vTopt, _ = varToExpr v
match vTopt with
let eR = exprToExpr e
let vOptR, _ = varToExpr v
match vOptR with
| None ->
fail()
| Some vT ->
let exprT = mkValSet m (mkLocalValRef vT) eT
None, (exprT, tyOfExpr g exprT)
| Some vR ->
let exprR = mkValSet m (mkLocalValRef vR) eR
None, (exprR, tyOfExpr g exprR)
| ProvidedWhileLoopExpr (guardExpr, bodyExpr) ->
let guardExpr, bodyExpr = (exprType.PApply2((fun _ -> (guardExpr, bodyExpr)), m))
let guardExprT = exprToExpr guardExpr
let bodyExprT = exprToExpr bodyExpr
let exprT = mkWhile g (DebugPointAtWhile.No, SpecialWhileLoopMarker.NoSpecialWhileLoopMarker, guardExprT, bodyExprT, m)
None, (exprT, tyOfExpr g exprT)
let guardExprR = exprToExpr guardExpr
let bodyExprR = exprToExpr bodyExpr
let exprR = mkWhile g (DebugPointAtWhile.No, SpecialWhileLoopMarker.NoSpecialWhileLoopMarker, guardExprR, bodyExprR, m)
None, (exprR, tyOfExpr g exprR)
| ProvidedForIntegerRangeLoopExpr (v, e1, e2, e3) ->
let v, e1, e2, e3 = exprType.PApply4((fun _ -> (v, e1, e2, e3)), m)
let e1T = exprToExpr e1
let e2T = exprToExpr e2
let vT = addVar v
let e3T = exprToExpr e3
let e1R = exprToExpr e1
let e2R = exprToExpr e2
let vR = addVar v
let e3R = exprToExpr e3
removeVar v
let exprT = mkFastForLoop g (DebugPointAtFor.No, DebugPointAtInOrTo.No, m, vT, e1T, true, e2T, e3T)
None, (exprT, tyOfExpr g exprT)
let exprR = mkFastForLoop g (DebugPointAtFor.No, DebugPointAtInOrTo.No, m, vR, e1R, true, e2R, e3R)
None, (exprR, tyOfExpr g exprR)
| ProvidedNewDelegateExpr (delegateTy, boundVars, delegateBodyExpr) ->
let delegateTy, boundVars, delegateBodyExpr = exprType.PApply3((fun _ -> (delegateTy, boundVars, delegateBodyExpr)), m)
let delegateTyT = Import.ImportProvidedType amap m delegateTy
let delegateTyR = Import.ImportProvidedType amap m delegateTy
let vs = boundVars.PApplyArray(id, "GetInvokerExpression", m) |> Array.toList
let vsT = List.map addVar vs
let delegateBodyExprT = exprToExpr delegateBodyExpr
let delegateBodyExprR = exprToExpr delegateBodyExpr
List.iter removeVar vs
let lambdaExpr = mkLambdas g m [] vsT (delegateBodyExprT, tyOfExpr g delegateBodyExprT)
let lambdaExpr = mkLambdas g m [] vsT (delegateBodyExprR, tyOfExpr g delegateBodyExprR)
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)
let exprR = CoerceFromFSharpFuncToDelegate g amap infoReader AccessorDomain.AccessibleFromSomewhere lambdaExprTy m lambdaExpr delegateTyR
None, (exprR, tyOfExpr g exprR)
#if PROVIDED_ADDRESS_OF
| ProvidedAddressOfExpr e ->
let eT = exprToExpr (exprType.PApply((fun _ -> e), m))
let wrap,ce, _readonly, _writeonly = mkExprAddrOfExpr g true false DefinitelyMutates eT None m
let ce = wrap ce
None, (ce, tyOfExpr g ce)
let eR = exprToExpr (exprType.PApply((fun _ -> e), m))
let wrap,exprR, _readonly, _writeonly = mkExprAddrOfExpr g true false DefinitelyMutates eR None m
let exprR = wrap exprR
None, (exprR, tyOfExpr g exprR)
#endif
| ProvidedDefaultExpr pty ->
let ty = Import.ImportProvidedType amap m (exprType.PApply((fun _ -> pty), m))
let ce = mkDefault (m, ty)
None, (ce, tyOfExpr g ce)
let exprR = mkDefault (m, ty)
None, (exprR, tyOfExpr g exprR)
| ProvidedCallExpr (e1, e2, e3) ->
methodCallToExpr top ea (exprType.PApply((fun _ -> (e1, e2, e3)), m))
| ProvidedSequentialExpr (e1, e2) ->
let e1, e2 = exprType.PApply2((fun _ -> (e1, e2)), m)
let e1T = exprToExpr e1
let e2T = exprToExpr e2
let ce = mkCompGenSequential m e1T e2T
None, (ce, tyOfExpr g ce)
let e1R = exprToExpr e1
let e2R = exprToExpr e2
let exprR = mkCompGenSequential m e1R e2R
None, (exprR, tyOfExpr g exprR)
| ProvidedTryFinallyExpr (e1, e2) ->
let e1, e2 = exprType.PApply2((fun _ -> (e1, e2)), m)
let e1T = exprToExpr e1
let e2T = exprToExpr e2
let ce = mkTryFinally g (e1T, e2T, m, tyOfExpr g e1T, DebugPointAtTry.No, DebugPointAtFinally.No)
None, (ce, tyOfExpr g ce)
let e1R = exprToExpr e1
let e2R = exprToExpr e2
let exprR = mkTryFinally g (e1R, e2R, m, tyOfExpr g e1R, DebugPointAtTry.No, DebugPointAtFinally.No)
None, (exprR, tyOfExpr g exprR)
| ProvidedTryWithExpr (e1, e2, e3, e4, e5) ->
let info = exprType.PApply((fun _ -> (e1, e2, e3, e4, e5)), m)
let bT = exprToExpr (info.PApply((fun (x, _, _, _, _) -> x), m))
let bR = 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))
let v1R = addVar v1
let e1R = 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))
let v2R = addVar v2
let e2R = exprToExpr (info.PApply((fun (_, _, _, _, x) -> x), m))
removeVar v2
let ce = mkTryWith g (bT, v1T, e1T, v2T, e2T, m, tyOfExpr g bT, DebugPointAtTry.No, DebugPointAtWith.No)
None, (ce, tyOfExpr g ce)
let exprR = mkTryWith g (bR, v1R, e1R, v2R, e2R, m, tyOfExpr g bR, DebugPointAtTry.No, DebugPointAtWith.No)
None, (exprR, tyOfExpr g exprR)
| ProvidedNewObjectExpr (e1, e2) ->
None, ctorCallToExpr (exprType.PApply((fun _ -> (e1, e2)), m))
@ -1948,17 +1970,17 @@ module ProvidedMethodCalls =
let targetMethInfo = ProvidedMeth(amap, ctor.PApply((fun ne -> upcast ne), m), None, m)
let objArgs = []
let arguments = [ for ea in args.PApplyArray(id, "GetInvokerExpression", m) -> exprToExpr ea ]
let callExpr = BuildMethodCall tcVal g amap Mutates.PossiblyMutates m false targetMethInfo isSuperInit [] objArgs arguments
let callExpr = BuildMethodCall tcVal g amap Mutates.PossiblyMutates m false targetMethInfo isSuperInit [] objArgs arguments None
callExpr
and addVar (v: Tainted<ProvidedVar>) =
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
let tyR = Import.ImportProvidedType amap m (v.PApply ((fun v -> v.Type), m))
let vR, vTe = if mut then mkMutableCompGenLocal m nm tyR else mkCompGenLocal m nm tyR
varConv[vRaw] <- (Some vR, vTe)
vR
and removeVar (v: Tainted<ProvidedVar>) =
let vRaw = v.PUntaint (id, m)
@ -1983,7 +2005,7 @@ module ProvidedMethodCalls =
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
let callExpr = BuildMethodCall tcVal g amap mut m isProp targetMethInfo isSuperInit replacementGenericArguments objArgs arguments None
Some meth, callExpr
and varToExpr (pe: Tainted<ProvidedVar>) =
@ -2058,7 +2080,7 @@ let CheckRecdFieldMutation m denv (rfinfo: RecdFieldInfo) =
if not rfinfo.RecdField.IsMutable then
errorR (FieldNotMutable (denv, rfinfo.RecdFieldRef, m))
/// Generate a witness for the given (solved) constraint. Five possiblilities are taken
/// Generate a witness for the given (solved) constraint. Five possibilities are taken
/// into account.
/// 1. The constraint is solved by a .NET-declared method or an F#-declared method
/// 2. The constraint is solved by an F# record field
@ -2080,7 +2102,7 @@ let GenWitnessExpr amap g m (traitInfo: TraitConstraintInfo) argExprs =
// Given the solution information, reconstruct the MethInfo for the solution
match sln with
| ILMethSln(origTy, extOpt, mref, minst) ->
| ILMethSln(origTy, extOpt, mref, minst, staticTyOpt) ->
let metadataTy = convertToTypeWithMetadataIfPossible g origTy
let tcref = tcrefOfAppTy g metadataTy
let mdef = resolveILMethodRef tcref.ILTyconRawMetadata mref
@ -2090,10 +2112,10 @@ let GenWitnessExpr amap g m (traitInfo: TraitConstraintInfo) argExprs =
| Some ilActualTypeRef ->
let actualTyconRef = Import.ImportILTypeRef amap m ilActualTypeRef
MethInfo.CreateILExtensionMeth(amap, m, origTy, actualTyconRef, None, mdef)
Choice1Of5 (ilMethInfo, minst)
Choice1Of5 (ilMethInfo, minst, staticTyOpt)
| FSMethSln(ty, vref, minst) ->
Choice1Of5 (FSMeth(g, ty, vref, None), minst)
| FSMethSln(ty, vref, minst, staticTyOpt) ->
Choice1Of5 (FSMeth(g, ty, vref, None), minst, staticTyOpt)
| FSRecdFieldSln(tinst, rfref, isSetProp) ->
Choice2Of5 (tinst, rfref, isSetProp)
@ -2108,7 +2130,7 @@ let GenWitnessExpr amap g m (traitInfo: TraitConstraintInfo) argExprs =
Choice5Of5 ()
match sln with
| Choice1Of5(minfo, methArgTys) ->
| Choice1Of5(minfo, methArgTys, staticTyOpt) ->
let argExprs =
// FIX for #421894 - typechecker assumes that coercion can be applied for the trait
// calls arguments but codegen doesn't emit coercion operations
@ -2148,9 +2170,9 @@ let GenWitnessExpr amap g m (traitInfo: TraitConstraintInfo) argExprs =
let wrap, h', _readonly, _writeonly = mkExprAddrOfExpr g true false PossiblyMutates h None m
Some (wrap (Expr.Op (TOp.TraitCall traitInfo, [], (h' :: t), m)))
| _ ->
Some (MakeMethInfoCall amap m minfo methArgTys argExprs)
Some (MakeMethInfoCall amap m minfo methArgTys argExprs staticTyOpt)
else
Some (MakeMethInfoCall amap m minfo methArgTys argExprs)
Some (MakeMethInfoCall amap m minfo methArgTys argExprs staticTyOpt)
| Choice2Of5 (tinst, rfref, isSet) ->
match isSet, rfref.RecdField.IsStatic, argExprs.Length with
@ -2207,7 +2229,7 @@ let GenWitnessExpr amap g m (traitInfo: TraitConstraintInfo) argExprs =
/// Generate a lambda expression for the given solved trait.
let GenWitnessExprLambda amap g m (traitInfo: TraitConstraintInfo) =
let witnessInfo = traitInfo.TraitKey
let witnessInfo = traitInfo.GetWitnessInfo()
let argTysl = GenWitnessArgTys g witnessInfo
let vse = argTysl |> List.mapiSquared (fun i j ty -> mkCompGenLocal m ("arg" + string i + "_" + string j) ty)
let vsl = List.mapSquared fst vse

18
src/Compiler/Checking/MethodCalls.fsi
Просмотреть файл

@ -83,7 +83,7 @@ type AssignedCalledArg<'T> =
/// Represents the possibilities for a named-setter argument (a property, field, or a record field setter)
type AssignedItemSetterTarget =
| AssignedPropSetter of PropInfo * MethInfo * TypeInst
| AssignedPropSetter of staticTyOpt: TType option * pinfo: PropInfo * minfo: MethInfo * pminst: TypeInst
| AssignedILFieldSetter of ILFieldInfo
| AssignedRecdFieldSetter of RecdFieldInfo
@ -205,7 +205,8 @@ type CalledMeth<'T> =
callerArgs: CallerArgs<'T> *
allowParamArgs: bool *
allowOutAndOptArgs: bool *
tyargsOpt: TType option ->
tyargsOpt: TType option *
staticTyOpt: TType option ->
CalledMeth<'T>
static member GetMethod: x: CalledMeth<'T> -> MethInfo
@ -302,6 +303,8 @@ type CalledMeth<'T> =
member UsesParamArrayConversion: bool
member OptionalStaticType: TType option
member amap: ImportMap
member infoReader: InfoReader
@ -338,7 +341,14 @@ val BuildILMethInfoCall:
/// 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.
val MakeMethInfoCall: amap: ImportMap -> m: range -> minfo: MethInfo -> minst: TType list -> args: Exprs -> Expr
val MakeMethInfoCall:
amap: ImportMap ->
m: range ->
minfo: MethInfo ->
minst: TType list ->
args: Exprs ->
staticTyOpt: TType option ->
Expr
/// Build an expression that calls a given method info.
/// This is called after overload resolution, and also to call other
@ -348,6 +358,7 @@ val MakeMethInfoCall: amap: ImportMap -> m: range -> minfo: MethInfo -> minst: T
// minst: the instantiation to apply for a generic method
// objArgs: the 'this' argument, if any
// args: the arguments, if any
// staticTyOpt: the static type that governs the call, different to the nominal type containing the member, e.g. 'T.CallSomeMethod()
val BuildMethodCall:
tcVal: (ValRef -> ValUseFlag -> TType list -> range -> Expr * TType) ->
g: TcGlobals ->
@ -360,6 +371,7 @@ val BuildMethodCall:
minst: TType list ->
objArgs: Expr list ->
args: Expr list ->
staticTyOpt: TType option ->
Expr * TType
/// Build a call to the System.Object constructor taking no arguments,

57
src/Compiler/Checking/MethodOverrides.fs
Просмотреть файл

@ -160,7 +160,7 @@ module DispatchSlotChecking =
let belongsToReqdTy =
match overrideBy.MemberInfo.Value.ImplementedSlotSigs with
| [] -> false
| ss :: _ -> isInterfaceTy g ss.ImplementedType && typeEquiv g reqdTy ss.ImplementedType
| ss :: _ -> isInterfaceTy g ss.DeclaringType && typeEquiv g reqdTy ss.DeclaringType
if belongsToReqdTy then
CanImplementAnyInterfaceSlot
else
@ -178,12 +178,14 @@ module DispatchSlotChecking =
Override(implKind, overrideBy.MemberApparentEntity, 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) =
let GetObjectExprOverrideInfo g amap (implTy, id: Ident, memberFlags, ty, arityInfo, bindingAttribs, rhsExpr) =
// Dissect the type. The '0' indicates there are no enclosing generic class type parameters relevant here.
let tps, _, argInfos, retTy, _ = GetMemberTypeInMemberForm g memberFlags arityInfo 0 ty id.idRange
let argTys = argInfos |> List.mapSquared fst
// Dissect the implementation
let _, ctorThisValOpt, baseValOpt, vsl, rhsExpr, _ = destTopLambda g amap arityInfo (rhsExpr, ty)
let _, ctorThisValOpt, baseValOpt, vsl, rhsExpr, _ = destLambdaWithValReprInfo g amap arityInfo (rhsExpr, ty)
assert ctorThisValOpt.IsNone
// Drop 'this'
@ -192,13 +194,13 @@ module DispatchSlotChecking =
// Check for empty variable list from a () arg
let vs = if List.isSingleton vs && argInfos.IsEmpty then [] else vs
let implKind =
if isInterfaceTy g implty then
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)
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))
@ -344,7 +346,7 @@ module DispatchSlotChecking =
// Always try to raise a target runtime error if we have a DIM.
if reqdSlot.HasDefaultInterfaceImplementation then
checkLanguageFeatureRuntimeErrorRecover infoReader LanguageFeature.DefaultInterfaceMemberConsumption m
checkLanguageFeatureRuntimeAndRecover infoReader LanguageFeature.DefaultInterfaceMemberConsumption m
let maybeResolvedSlot =
NameMultiMap.find dispatchSlot.LogicalName overridesKeyed
@ -741,6 +743,8 @@ module DispatchSlotChecking =
yield SlotImplSet(dispatchSlots, dispatchSlotsKeyed, availPriorOverrides, reqdProperties) ]
let IsStaticAbstractImpl (overrideBy: ValRef) = (not overrideBy.IsInstanceMember) && overrideBy.IsOverrideOrExplicitImpl
/// 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) =
@ -749,7 +753,7 @@ module DispatchSlotChecking =
let amap = infoReader.amap
let tcaug = tycon.TypeContents
let interfaces = tycon.ImmediateInterfacesOfFSharpTycon |> List.map (fun (ity, _compgen, m) -> (ity, m))
let interfaces = tycon.ImmediateInterfacesOfFSharpTycon |> List.map (fun (intfTy, _compgen, m) -> (intfTy, m))
let overallTy = generalizedTyconRef g (mkLocalTyconRef tycon)
@ -765,10 +769,14 @@ module DispatchSlotChecking =
let allImpls = List.zip allReqdTys slotImplSets
// Find the methods relevant to implementing the abstract slots listed under the reqdType being checked.
//
// Methods that are
// - Not static OR Static in the interface
// - override/default
let allImmediateMembersThatMightImplementDispatchSlots =
allImmediateMembers |> List.filter (fun overrideBy ->
overrideBy.IsInstanceMember && // exclude static
overrideBy.IsVirtualMember && // exclude non virtual (e.g. keep override/default). [4469]
(overrideBy.IsInstanceMember || IsStaticAbstractImpl overrideBy) &&
overrideBy.IsVirtualMember &&
not overrideBy.IsDispatchSlotMember)
let mustOverrideSomething reqdTy (overrideBy: ValRef) =
@ -780,9 +788,9 @@ module DispatchSlotChecking =
| [] ->
// 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
| slotSigs ->
slotSigs |> List.forall (fun slotSig ->
let ty = slotSig.DeclaringType
if isInterfaceTy g ty then
// Is this a method impl listed under the reqdTy?
typeEquiv g ty reqdTy
@ -916,10 +924,16 @@ let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader: InfoReader, nenv
&& 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 GetAbstractMethInfosForSynMethodDecl(infoReader: InfoReader, ad, memberName: Ident, bindm, typToSearchForAbstractMembers, valSynData, memberFlags: SynMemberFlags) =
let g = infoReader.g
if not memberFlags.IsInstance && memberFlags.IsOverrideOrExplicitImpl then
checkLanguageFeatureRuntimeAndRecover infoReader LanguageFeature.InterfacesWithAbstractStaticMembers bindm
checkLanguageFeatureAndRecover g.langVersion LanguageFeature.InterfacesWithAbstractStaticMembers bindm
let minfos =
match typToSearchForAbstractMembers with
| _, Some(SlotImplSet(_, dispatchSlotsKeyed, _, _)) ->
@ -927,10 +941,17 @@ let GetAbstractMethInfosForSynMethodDecl(infoReader: InfoReader, ad, memberName:
| 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 List.isEmpty topValSynArities then topValSynArities else topValSynArities.Tail
let dispatchSlotsArityMatch = dispatchSlots |> List.filter (fun minfo -> minfo.NumArgs = topValSynArities)
dispatchSlots, dispatchSlotsArityMatch
let valReprSynArities = SynInfo.AritiesOfArgs valSynData
// We only return everything if it's empty or if it's a non-instance member.
// If it's an instance member, we are getting rid of `this` (by only taking tail).
let valReprSynArities =
if List.isEmpty valReprSynArities || (not memberFlags.IsInstance) then
valReprSynArities
else
valReprSynArities.Tail
let dispatchSlotsArityMatch = dispatchSlots |> List.filter (fun minfo -> minfo.NumArgs = valReprSynArities)
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

5
src/Compiler/Checking/MethodOverrides.fsi
Просмотреть файл

@ -89,7 +89,7 @@ module DispatchSlotChecking =
val GetObjectExprOverrideInfo:
g: TcGlobals ->
amap: ImportMap ->
implty: TType *
implTy: TType *
id: Ident *
memberFlags: SynMemberFlags *
ty: TType *
@ -155,7 +155,8 @@ val GetAbstractMethInfosForSynMethodDecl:
memberName: Ident *
bindm: range *
typToSearchForAbstractMembers: (TType * SlotImplSet option) *
valSynData: SynValInfo ->
valSynData: SynValInfo *
memberFlags: SynMemberFlags ->
MethInfo list * MethInfo list
/// Get the properties relevant to determining if a uniquely-identified-override exists based on the syntactic information

152
src/Compiler/Checking/NameResolution.fs
Просмотреть файл

@ -122,20 +122,12 @@ let ActivePatternElemsOfModuleOrNamespace g (modref: ModuleOrNamespaceRef) : Nam
cacheOptRef mtyp.ActivePatternElemRefLookupTable (fun () ->
mtyp.AllValsAndMembers
|> Seq.collect (ActivePatternElemsOfVal g modref)
|> Seq.fold (fun acc apref -> NameMap.add apref.Name apref acc) Map.empty)
|> Seq.fold (fun acc apref -> NameMap.add apref.LogicalName apref acc) Map.empty)
//---------------------------------------------------------------------------
// Name Resolution Items
//-------------------------------------------------------------------------
/// Detect a use of a nominal type, including type abbreviations.
///
/// When reporting symbols, we care about abbreviations, e.g. 'int' and 'int32' count as two separate symbols
let (|AbbrevOrAppTy|_|) (ty: TType) =
match stripTyparEqns ty with
| TType_app (tcref, _, _) -> Some tcref
| _ -> None
/// Represents the item with which a named argument is associated.
[<NoEquality; NoComparison; RequireQualifiedAccess>]
type ArgumentContainer =
@ -174,6 +166,9 @@ type Item =
/// Represents the resolution of a name to an F# record or exception field.
| RecdField of RecdFieldInfo
/// Represents the resolution of a name to an F# trait
| Trait of TraitConstraintInfo
/// Represents the resolution of a name to a union case field.
| UnionCaseField of UnionCaseInfo * fieldIndex: int
@ -228,7 +223,17 @@ type Item =
| ImplicitOp of Ident * TraitConstraintSln option ref
/// Represents the resolution of a name to a named argument
| ArgName of Ident * TType * ArgumentContainer option
//
// In the FCS API, Item.ArgName corresponds to FSharpParameter symbols.
// Not all parameters have names, e.g. for 'g' in this:
//
// let f (g: int -> int) x = ...
//
// then the symbol for 'g' reports FSharpParameters via CurriedParameterGroups
// based on analyzing the type of g as a function type.
//
// For these parameters, the identifier will be missing.
| ArgName of ident: Ident option * argType: TType * container: ArgumentContainer option * range: range
/// Represents the resolution of a name to a named property setter
| SetterArg of Ident * Item
@ -247,33 +252,42 @@ type Item =
member d.DisplayNameCore =
match d with
| Item.Value v -> v.DisplayNameCore
| Item.ActivePatternResult (apinfo, _ty, n, _) -> apinfo.ActiveTags[n]
| Item.ActivePatternCase apref -> apref.Name
| Item.ActivePatternResult (apinfo, _ty, n, _) -> apinfo.DisplayNameCoreByIdx n
| Item.ActivePatternCase apref -> apref.DisplayNameCore
| Item.UnionCase(uinfo, _) -> uinfo.DisplayNameCore
| Item.ExnCase tcref -> tcref.DisplayNameCore
| Item.RecdField rfinfo -> rfinfo.DisplayNameCore
| Item.UnionCaseField (uci, fieldIndex) -> uci.UnionCase.GetFieldByIndex(fieldIndex).DisplayNameCore
| Item.AnonRecdField (anonInfo, _tys, i, _m) -> anonInfo.SortedNames[i]
| Item.AnonRecdField (anonInfo, _tys, fieldIndex, _m) -> anonInfo.DisplayNameCoreByIdx fieldIndex
| Item.NewDef id -> id.idText
| Item.ILField finfo -> finfo.FieldName
| Item.Event einfo -> einfo.EventName
| Item.Property(_, FSProp(_, _, Some v, _) :: _)
| Item.Property(_, FSProp(_, _, _, Some v) :: _) -> v.DisplayNameCore
| Item.Property(nm, _) -> nm |> DecompileOpName
| Item.ILField finfo -> finfo.DisplayNameCore
| Item.Event einfo -> einfo.DisplayNameCore
| Item.Property(_, pinfo :: _) -> pinfo.DisplayNameCore
| Item.Property(nm, _) -> nm |> ConvertValLogicalNameToDisplayNameCore
| Item.MethodGroup(_, FSMeth(_, _, v, _) :: _, _) -> v.DisplayNameCore
| Item.MethodGroup(nm, _, _) -> nm |> DecompileOpName
| Item.MethodGroup(nm, _, _) -> nm |> ConvertValLogicalNameToDisplayNameCore
| Item.CtorGroup(nm, _) -> nm |> DemangleGenericTypeName
| Item.FakeInterfaceCtor (AbbrevOrAppTy tcref)
| Item.DelegateCtor (AbbrevOrAppTy tcref) -> tcref.DisplayNameCore
| Item.Types(nm, _) -> nm |> DemangleGenericTypeName
| Item.FakeInterfaceCtor ty
| Item.DelegateCtor ty ->
match ty with
| AbbrevOrAppTy tcref -> tcref.DisplayNameCore
// This case is not expected
| _ -> ""
| Item.UnqualifiedType(tcref :: _) -> tcref.DisplayNameCore
| Item.Types(nm, _) -> nm |> DemangleGenericTypeName
| Item.TypeVar (nm, _) -> nm
| Item.Trait traitInfo -> traitInfo.MemberDisplayNameCore
| Item.ModuleOrNamespaces(modref :: _) -> modref.DisplayNameCore
| Item.ArgName (id, _, _) -> id.idText
| Item.ArgName (Some id, _, _, _) -> id.idText
| Item.ArgName (None, _, _, _) -> ""
| Item.SetterArg (id, _) -> id.idText
| Item.CustomOperation (customOpName, _, _) -> customOpName
| Item.CustomBuilder (nm, _) -> nm
| _ -> ""
| Item.ImplicitOp (id, _) -> id.idText
//| _ -> ""
// These singleton cases are not expected
| Item.ModuleOrNamespaces [] -> ""
| Item.UnqualifiedType [] -> ""
member d.DisplayName =
match d with
@ -282,14 +296,18 @@ type Item =
| Item.ExnCase tcref -> tcref.DisplayName
| Item.RecdField rfinfo -> rfinfo.DisplayName
| Item.UnionCaseField (uci, fieldIndex) -> uci.UnionCase.GetFieldByIndex(fieldIndex).DisplayName
| Item.Property(_, FSProp(_, _, Some v, _) :: _)
| Item.Property(_, FSProp(_, _, _, Some v) :: _) -> v.DisplayName
| Item.MethodGroup(_, FSMeth(_, _, v, _) :: _, _) -> v.DisplayName
| Item.AnonRecdField (anonInfo, _tys, fieldIndex, _m) -> anonInfo.DisplayNameByIdx fieldIndex
| Item.ActivePatternCase apref -> apref.DisplayName
| Item.Property(_, pinfo :: _) -> pinfo.DisplayName
| Item.Event einfo -> einfo.DisplayName
| Item.MethodGroup(_, minfo :: _, _) -> minfo.DisplayName
| Item.DelegateCtor (AbbrevOrAppTy tcref) -> tcref.DisplayName
| Item.UnqualifiedType(tcref :: _) -> tcref.DisplayName
| Item.ModuleOrNamespaces(modref :: _) -> modref.DisplayName
| Item.TypeVar (nm, _) -> nm
| _ -> d.DisplayNameCore |> ConvertNameToDisplayName
| Item.TypeVar (nm, _) -> nm |> ConvertLogicalNameToDisplayName
| Item.ArgName (Some id, _, _, _) -> id.idText |> ConvertValLogicalNameToDisplayName false
| Item.ArgName (None, _, _, _) -> ""
| _ -> d.DisplayNameCore |> ConvertLogicalNameToDisplayName
let valRefHash (vref: ValRef) =
match vref.TryDeref with
@ -730,7 +748,7 @@ let AddValRefsToActivePatternsNameEnv g ePatItems (vref: ValRef) =
let ePatItems =
(ActivePatternElemsOfValRef g vref, ePatItems)
||> List.foldBack (fun apref tab ->
NameMap.add apref.Name (Item.ActivePatternCase apref) tab)
NameMap.add apref.LogicalName (Item.ActivePatternCase apref) tab)
// Add literal constants to the environment available for resolving items in patterns
let ePatItems =
@ -763,8 +781,8 @@ let AddValRefToNameEnv g nenv (vref: ValRef) =
/// Add a set of active pattern result tags to the environment.
let AddActivePatternResultTagsToNameEnv (apinfo: ActivePatternInfo) nenv apOverallTy m =
if List.isEmpty apinfo.Names then nenv else
let apResultNameList = List.indexed apinfo.Names
if List.isEmpty apinfo.ActiveTags then nenv else
let apResultNameList = List.indexed apinfo.ActiveTags
{ nenv with
eUnqualifiedItems =
(apResultNameList, nenv.eUnqualifiedItems)
@ -1059,7 +1077,7 @@ let ChooseMethInfosForNameEnv g m ty (minfos: MethInfo list) =
|> List.filter (fun minfo ->
not (minfo.IsInstance || minfo.IsClassConstructor || minfo.IsConstructor) && typeEquiv g minfo.ApparentEnclosingType ty &&
not (IsMethInfoPlainCSharpStyleExtensionMember g m isExtTy minfo) &&
not (IsMangledOpName minfo.LogicalName))
not (IsLogicalOpName minfo.LogicalName))
|> List.groupBy (fun minfo -> minfo.LogicalName)
|> List.filter (fun (_, methGroup) -> not methGroup.IsEmpty)
|> List.map (fun (methName, methGroup) -> KeyValuePair(methName, Item.MethodGroup(methName, methGroup, None)))
@ -1420,10 +1438,10 @@ and AddModuleOrNamespaceContentsToNameEnv (g: TcGlobals) amap (ad: AccessorDomai
and AddModuleOrNamespaceRefsContentsToNameEnv g amap ad m root nenv modrefs =
(modrefs, nenv) ||> List.foldBack (fun modref acc -> AddModuleOrNamespaceRefContentsToNameEnv g amap ad m root acc modref)
and AddTypeContentsToNameEnv g amap ad m nenv (typ: TType) =
assert (isAppTy g typ)
assert not (tcrefOfAppTy g typ).IsModuleOrNamespace
AddStaticContentOfTypeToNameEnv g amap ad m nenv typ
and AddTypeContentsToNameEnv g amap ad m nenv (ty: TType) =
assert (isAppTy g ty)
assert not (tcrefOfAppTy g ty).IsModuleOrNamespace
AddStaticContentOfTypeToNameEnv g amap ad m nenv ty
and AddModuleOrNamespaceRefContentsToNameEnv g amap ad m root nenv (modref: EntityRef) =
assert modref.IsModuleOrNamespace
@ -1804,10 +1822,10 @@ let ItemsAreEffectivelyEqual g orig other =
| Some vref1, Some vref2 -> valRefDefnEq g vref1 vref2
| _ -> false
| Item.ArgName (id1, _, _), Item.ArgName (id2, _, _) ->
(id1.idText = id2.idText && equals id1.idRange id2.idRange)
| Item.ArgName (Some id1, _, _, m1), Item.ArgName (Some id2, _, _, m2) ->
(id1.idText = id2.idText && equals m1 m2)
| Item.ArgName (id, _, _), ValUse vref | ValUse vref, Item.ArgName (id, _, _) ->
| Item.ArgName (Some id, _, _, _), ValUse vref | ValUse vref, Item.ArgName (Some id, _, _, _) ->
((equals id.idRange vref.DefinitionRange || equals id.idRange vref.SigRange) && id.idText = vref.DisplayName)
| Item.AnonRecdField(anon1, _, i1, _), Item.AnonRecdField(anon2, _, i2, _) -> anonInfoEquiv anon1 anon2 && i1 = i2
@ -1834,6 +1852,9 @@ let ItemsAreEffectivelyEqual g orig other =
| Item.ModuleOrNamespaces modrefs1, Item.ModuleOrNamespaces modrefs2 ->
modrefs1 |> List.exists (fun modref1 -> modrefs2 |> List.exists (fun r -> tyconRefDefnEq g modref1 r || fullDisplayTextOfModRef modref1 = fullDisplayTextOfModRef r))
| Item.Trait traitInfo1, Item.Trait traitInfo2 ->
traitInfo1.MemberLogicalName = traitInfo2.MemberLogicalName
| _ -> false
/// Given the Item 'orig' - returns function 'other: Item -> bool', that will yield true if other and orig represents the same item and false - otherwise
@ -1841,11 +1862,12 @@ let ItemsAreEffectivelyEqualHash (g: TcGlobals) orig =
match orig with
| EntityUse tcref -> tyconRefDefnHash g tcref
| Item.TypeVar (nm, _)-> hash nm
| Item.Trait traitInfo -> hash traitInfo.MemberLogicalName
| ValUse vref -> valRefDefnHash g vref
| ActivePatternCaseUse (_, _, idx)-> hash idx
| MethodUse minfo -> minfo.ComputeHashCode()
| PropertyUse pinfo -> pinfo.ComputeHashCode()
| Item.ArgName (id, _, _) -> hash id.idText
| Item.ArgName (Some id, _, _, _) -> hash id.idText
| ILFieldUse ilfinfo -> ilfinfo.ComputeHashCode()
| UnionCaseUse ucase -> hash ucase.CaseName
| RecordFieldUse (name, _) -> hash name
@ -1969,7 +1991,7 @@ type TcResultsSinkImpl(tcGlobals, ?sourceText: ISourceText) =
let keyOpt =
match item with
| Item.Value vref -> Some (endPos, vref.DisplayName)
| Item.ArgName (id, _, _) -> Some (endPos, id.idText)
| Item.ArgName (Some id, _, _, _) -> Some (endPos, id.idText)
| _ -> None
match keyOpt with
@ -2128,6 +2150,7 @@ let CheckAllTyparsInferrable amap m item =
let free = Zset.diff freeInDeclaringType.FreeTypars freeInArgsAndRetType.FreeTypars
free.IsEmpty)
| Item.Trait _
| Item.CtorGroup _
| Item.FakeInterfaceCtor _
| Item.DelegateCtor _
@ -2426,8 +2449,8 @@ let TryFindUnionCaseOfType g ty nm =
ValueNone
/// Try to find a union case of a type, with the given name
let TryFindAnonRecdFieldOfType g typ nm =
match tryDestAnonRecdTy g typ with
let TryFindAnonRecdFieldOfType g ty nm =
match tryDestAnonRecdTy g ty with
| ValueSome (anonInfo, tys) ->
match anonInfo.SortedIds |> Array.tryFindIndex (fun x -> x.idText = nm) with
| Some i -> Some (Item.AnonRecdField(anonInfo, tys, i, anonInfo.SortedIds[i].idRange))
@ -2507,7 +2530,10 @@ let rec ResolveLongIdentInTypePrim (ncenv: NameResolver) nenv lookupKind (resInf
OneResult (success(resInfo, item, rest))
| None ->
let isLookUpExpr = (lookupKind = LookupKind.Expr)
match TryFindIntrinsicNamedItemOfType ncenv.InfoReader (nm, ad) findFlag m ty with
match TryFindIntrinsicNamedItemOfType ncenv.InfoReader (nm, ad, true) findFlag m ty with
| Some (TraitItem (traitInfo :: _)) when isLookUpExpr ->
success [resInfo, Item.Trait traitInfo, rest]
| Some (PropertyItem psets) when isLookUpExpr ->
let pinfos = psets |> ExcludeHiddenOfPropInfos g ncenv.amap m
@ -2862,7 +2888,7 @@ let rec ResolveExprLongIdentPrim sink (ncenv: NameResolver) first fullyQualified
ChooseTyconRefInExpr (ncenv, m, ad, nenv, id, typeNameResInfo, tcrefs)
let implicitOpSearch() =
if IsMangledOpName id.idText then
if IsLogicalOpName id.idText then
success [(ResolutionInfo.Empty, Item.ImplicitOp(id, ref None))]
else
NoResultsOrUsefulErrors
@ -3635,7 +3661,7 @@ let NeedsWorkAfterResolution namedItem =
| Item.MethodGroup(_, minfos, _)
| Item.CtorGroup(_, minfos) -> minfos.Length > 1 || minfos |> List.exists (fun minfo -> not (isNil minfo.FormalMethodInst))
| Item.Property(_, pinfos) -> pinfos.Length > 1
| Item.ImplicitOp(_, { contents = Some(TraitConstraintSln.FSMethSln(_, vref, _)) })
| Item.ImplicitOp(_, { contents = Some(TraitConstraintSln.FSMethSln(vref=vref)) })
| Item.Value vref | Item.CustomBuilder (_, vref) -> not (List.isEmpty vref.Typars)
| Item.CustomOperation (_, _, Some minfo) -> not (isNil minfo.FormalMethodInst)
| Item.ActivePatternCase apref -> not (List.isEmpty apref.ActivePatternVal.Typars)
@ -3908,6 +3934,11 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv (completionTargets: Reso
x.IsStatic = statics &&
IsILFieldInfoAccessible g amap m ad x)
let qinfos =
ncenv.InfoReader.GetTraitInfosInType None ty
|> List.filter (fun x ->
x.MemberFlags.IsInstance = not statics)
let pinfosIncludingUnseen =
AllPropInfosOfTypeInScope ResultCollectionSettings.AllResults ncenv.InfoReader nenv None ad PreferOverrides m ty
|> List.filter (fun x ->
@ -4071,6 +4102,7 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv (completionTargets: Reso
List.map Item.RecdField rfinfos @
pinfoItems @
anonFields @
List.map Item.Trait qinfos @
List.map Item.ILField finfos @
List.map Item.Event einfos @
List.map (ItemOfTy g) nestedTypes @
@ -4113,7 +4145,7 @@ let rec ResolvePartialLongIdentInType (ncenv: NameResolver) nenv isApplicableMet
// e.g. <val-id>.<event-id>.<more>
for einfo in ncenv.InfoReader.GetEventInfosOfType(Some id, ad, m, ty) do
let einfoTy = PropTypOfEventInfo ncenv.InfoReader m ad einfo
let einfoTy = PropTypeOfEventInfo ncenv.InfoReader m ad einfo
yield! ResolvePartialLongIdentInType ncenv nenv isApplicableMeth m ad false rest einfoTy
// nested types
@ -4427,7 +4459,15 @@ let rec ResolvePartialLongIdentPrim (ncenv: NameResolver) (nenv: NameResolutionE
for tcref in LookupTypeNameInEnvNoArity OpenQualified id nenv do
let tcref = ResolveNestedTypeThroughAbbreviation ncenv tcref m
let ty = FreshenTycon ncenv m tcref
yield! ResolvePartialLongIdentInType ncenv nenv isApplicableMeth m ad true rest ty ]
yield! ResolvePartialLongIdentInType ncenv nenv isApplicableMeth m ad true rest ty
// 'T.Ident: lookup a static something in a type parameter
// ^T.Ident: lookup a static something in a type parameter
match nenv.eTypars.TryGetValue id with
| true, tp ->
let ty = mkTyparTy tp
yield! ResolvePartialLongIdentInType ncenv nenv isApplicableMeth m ad true rest ty
| _ -> () ]
namespaces @ values @ staticSomethingInType
@ -4587,6 +4627,8 @@ and ResolvePartialLongIdentToClassOrRecdFieldsImpl (ncenv: NameResolver) (nenv:
| _-> []
modsOrNs @ qualifiedFields
// This is "on-demand" reimplementation of completion logic that is only used along one
// pathway - `IsRelativeNameResolvableFromSymbol` - in the editor support for simplifying names
let ResolveCompletionsInTypeForItem (ncenv: NameResolver) nenv m ad statics ty (item: Item) : seq<Item> =
seq {
let g = ncenv.g
@ -4776,6 +4818,8 @@ let ResolveCompletionsInTypeForItem (ncenv: NameResolver) nenv m ad statics ty (
| _ -> ()
}
// This is "on-demand" reimplementation of completion logic that is only used along one
// pathway - `IsRelativeNameResolvableFromSymbol` - in the editor support for simplifying names
let rec ResolvePartialLongIdentInTypeForItem (ncenv: NameResolver) nenv m ad statics plid (item: Item) ty =
seq {
let g = ncenv.g
@ -4811,7 +4855,7 @@ let rec ResolvePartialLongIdentInTypeForItem (ncenv: NameResolver) nenv m ad sta
// e.g. <val-id>.<event-id>.<more>
for einfo in ncenv.InfoReader.GetEventInfosOfType(Some id, ad, m, ty) do
let tyinfo = PropTypOfEventInfo ncenv.InfoReader m ad einfo
let tyinfo = PropTypeOfEventInfo ncenv.InfoReader m ad einfo
yield! ResolvePartialLongIdentInTypeForItem ncenv nenv m ad false rest item tyinfo
// nested types!
@ -4824,6 +4868,8 @@ let rec ResolvePartialLongIdentInTypeForItem (ncenv: NameResolver) nenv m ad sta
yield! finfo.FieldType(amap, m) |> ResolvePartialLongIdentInTypeForItem ncenv nenv m ad false rest item
}
// This is "on-demand" reimplementation of completion logic that is only used along one
// pathway - `IsRelativeNameResolvableFromSymbol` - in the editor support for simplifying names
let rec ResolvePartialLongIdentInModuleOrNamespaceForItem (ncenv: NameResolver) nenv m ad (modref: ModuleOrNamespaceRef) plid (item: Item) =
let g = ncenv.g
let mty = modref.ModuleOrNamespaceType
@ -4914,6 +4960,8 @@ let rec ResolvePartialLongIdentInModuleOrNamespaceForItem (ncenv: NameResolver)
yield! ResolvePartialLongIdentInTypeForItem ncenv nenv m ad true rest item ty
}
// This is "on-demand" reimplementation of completion logic that is only used along one
// pathway - `IsRelativeNameResolvableFromSymbol` - in the editor support for simplifying names
let rec PartialResolveLookupInModuleOrNamespaceAsModuleOrNamespaceThenLazy f plid (modref: ModuleOrNamespaceRef) =
let mty = modref.ModuleOrNamespaceType
match plid with
@ -4924,6 +4972,8 @@ let rec PartialResolveLookupInModuleOrNamespaceAsModuleOrNamespaceThenLazy f pli
PartialResolveLookupInModuleOrNamespaceAsModuleOrNamespaceThenLazy f rest (modref.NestedTyconRef mty)
| _ -> Seq.empty
// This is "on-demand" reimplementation of completion logic that is only used along one
// pathway - `IsRelativeNameResolvableFromSymbol` - in the editor support for simplifying names
let PartialResolveLongIdentAsModuleOrNamespaceThenLazy (nenv: NameResolutionEnv) plid f =
seq {
match plid with
@ -4936,6 +4986,8 @@ let PartialResolveLongIdentAsModuleOrNamespaceThenLazy (nenv: NameResolutionEnv)
| [] -> ()
}
// This is "on-demand" reimplementation of completion logic that is only used along one
// pathway - `IsRelativeNameResolvableFromSymbol` - in the editor support for simplifying names
let rec GetCompletionForItem (ncenv: NameResolver) (nenv: NameResolutionEnv) m ad plid (item: Item) : seq<Item> =
seq {
let g = ncenv.g

19
src/Compiler/Checking/NameResolution.fsi
Просмотреть файл

@ -41,10 +41,6 @@ type ArgumentContainer =
/// The named argument is a static parameter to a provided type.
| Type of TyconRef
/// Detect a use of a nominal type, including type abbreviations.
/// When reporting symbols, we care about abbreviations, e.g. 'int' and 'int32' count as two separate symbols.
val (|AbbrevOrAppTy|_|): TType -> TyconRef option
type EnclosingTypeInst = TypeInst
/// Represents an item that results from name resolution
@ -68,6 +64,9 @@ type Item =
/// Represents the resolution of a name to an F# record or exception field.
| RecdField of RecdFieldInfo
/// Represents the resolution of a name to an F# trait
| Trait of TraitConstraintInfo
/// Represents the resolution of a name to a union case field.
| UnionCaseField of UnionCaseInfo * fieldIndex: int
@ -122,7 +121,17 @@ type Item =
| ImplicitOp of Ident * TraitConstraintSln option ref
/// Represents the resolution of a name to a named argument
| ArgName of Ident * TType * ArgumentContainer option
//
// In the FCS API, Item.ArgName corresponds to FSharpParameter symbols.
// Not all parameters have names, e.g. for 'g' in this:
//
// let f (g: int -> int) x = ...
//
// then the symbol for 'g' reports FSharpParameters via CurriedParameterGroups
// based on analyzing the type of g as a function type.
//
// For these parameters, the identifier will be missing.
| ArgName of ident: Ident option * argType: TType * container: ArgumentContainer option * range: range
/// Represents the resolution of a name to a named property setter
| SetterArg of Ident * Item

308
src/Compiler/Checking/NicePrint.fs
Просмотреть файл

@ -445,7 +445,7 @@ module PrintIL =
| Some s -> WordL.equals ^^ wordL s
let layoutILEnumCase nm litVal =
let nameL = ConvertNameToDisplayLayout (tagEnum >> wordL) nm
let nameL = ConvertLogicalNameToDisplayLayout (tagEnum >> wordL) nm
WordL.bar ^^ nameL ^^ layoutILFieldInit litVal
module PrintTypes =
@ -497,7 +497,7 @@ module PrintTypes =
| _ -> itemL
/// Layout a reference to a type
let layoutTyconRef denv tycon = layoutTyconRefImpl false denv tycon
let layoutTyconRef denv tcref = layoutTyconRefImpl false denv tcref
/// Layout the flags of a member
let layoutMemberFlags (memFlags: SynMemberFlags) =
@ -546,8 +546,8 @@ module PrintTypes =
| TypeDefOfExpr denv.g ty ->
LeftL.keywordTypedefof ^^ wordL (tagPunctuation "<") ^^ layoutType denv ty ^^ rightL (tagPunctuation ">")
| Expr.Op (TOp.Coerce, [tgTy;_], [arg2], _) ->
leftL (tagPunctuation "(") ^^ layoutAttribArg denv arg2 ^^ wordL (tagPunctuation ":>") ^^ layoutType denv tgTy ^^ rightL (tagPunctuation ")")
| Expr.Op (TOp.Coerce, [tgtTy;_], [arg2], _) ->
leftL (tagPunctuation "(") ^^ layoutAttribArg denv arg2 ^^ wordL (tagPunctuation ":>") ^^ layoutType denv tgtTy ^^ rightL (tagPunctuation ")")
| AttribBitwiseOrExpr denv.g (arg1, arg2) ->
layoutAttribArg denv arg1 ^^ wordL (tagPunctuation "|||") ^^ layoutAttribArg denv arg2
@ -726,8 +726,8 @@ module PrintTypes =
and layoutConstraintWithInfo denv env (tp, tpc) =
let longConstraintPrefix l = (layoutTyparRefWithInfo denv env tp |> addColonL) ^^ l
match tpc with
| TyparConstraint.CoercesTo(tpct, _) ->
[layoutTyparRefWithInfo denv env tp ^^ wordL (tagOperator ":>") --- layoutTypeWithInfo denv env tpct]
| TyparConstraint.CoercesTo(tgtTy, _) ->
[layoutTyparRefWithInfo denv env tp ^^ wordL (tagOperator ":>") --- layoutTypeWithInfo denv env tgtTy]
| TyparConstraint.MayResolveMember(traitInfo, _) ->
[layoutTraitWithInfo denv env traitInfo]
@ -795,28 +795,54 @@ module PrintTypes =
WordL.arrow ^^
(layoutTyparRefWithInfo denv env tp)) |> longConstraintPrefix]
and layoutTraitWithInfo denv env (TTrait(tys, nm, memFlags, argTys, retTy, _)) =
let nameL = ConvertValNameToDisplayLayout false (tagMember >> wordL) nm
and layoutTraitWithInfo denv env traitInfo =
let g = denv.g
let (TTrait(tys, _, memFlags, _, _, _)) = traitInfo
let nm = traitInfo.MemberDisplayNameCore
let nameL = ConvertValLogicalNameToDisplayLayout false (tagMember >> wordL) nm
if denv.shortConstraints then
WordL.keywordMember ^^ nameL
else
let retTy = GetFSharpViewOfReturnType denv.g retTy
let retTy = traitInfo.GetReturnType(g)
let argTys = traitInfo.GetLogicalArgumentTypes(g)
let argTys, retTy =
match memFlags.MemberKind with
| SynMemberKind.PropertySet ->
match List.tryFrontAndBack argTys with
| Some res -> res
| None -> argTys, retTy
| _ ->
argTys, retTy
let stat = layoutMemberFlags memFlags
let tys = ListSet.setify (typeEquiv denv.g) tys
let tys = ListSet.setify (typeEquiv g) tys
let tysL =
match tys with
| [ty] -> layoutTypeWithInfo denv env ty
| tys -> bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagKeyword "or")) tys)
let argTysL = layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) argTys
let retTyL = layoutReturnType denv env retTy
let sigL = curriedLayoutsL "->" [argTysL] retTyL
(tysL |> addColonL) --- bracketL (stat ++ (nameL |> addColonL) --- sigL)
let sigL =
match argTys with
// Empty arguments indicates a non-indexer property constraint
| [] -> retTyL
| _ ->
let argTysL = layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "*")) argTys
curriedLayoutsL "->" [argTysL] retTyL
let getterSetterL =
match memFlags.MemberKind with
| SynMemberKind.PropertyGet when not argTys.IsEmpty ->
wordL (tagKeyword "with") ^^ wordL (tagText "get")
| SynMemberKind.PropertySet ->
wordL (tagKeyword "with") ^^ wordL (tagText "set")
| _ ->
emptyL
(tysL |> addColonL) --- bracketL (stat ++ (nameL |> addColonL) --- sigL --- getterSetterL)
/// Layout a unit of measure expression
and layoutMeasure denv unt =
let sortVars vs = vs |> List.sortBy (fun (v: Typar, _) -> v.DisplayName)
let sortCons cs = cs |> List.sortBy (fun (c: TyconRef, _) -> c.DisplayName)
let sortVars vs = vs |> List.sortBy (fun (tp: Typar, _) -> tp.DisplayName)
let sortCons cs = cs |> List.sortBy (fun (tcref: TyconRef, _) -> tcref.DisplayName)
let negvs, posvs = ListMeasureVarOccsWithNonZeroExponents unt |> sortVars |> List.partition (fun (_, e) -> SignRational e < 0)
let negcs, poscs = ListMeasureConOccsWithNonZeroExponents denv.g false unt |> sortCons |> List.partition (fun (_, e) -> SignRational e < 0)
let unparL uv = layoutTyparRef denv uv
@ -832,14 +858,14 @@ module PrintTypes =
| _ -> prefix ^^ sepL (tagPunctuation "/") ^^ (if List.length negvs + List.length negcs > 1 then sepL (tagPunctuation "(") ^^ postfix ^^ sepL (tagPunctuation ")") else postfix)
/// Layout type arguments, either NAME<ty, ..., ty> or (ty, ..., ty) NAME *)
and layoutTypeAppWithInfoAndPrec denv env tcL prec prefix args =
and layoutTypeAppWithInfoAndPrec denv env tcL prec prefix argTys =
if prefix then
match args with
match argTys with
| [] -> tcL
| [arg] -> tcL ^^ sepL (tagPunctuation "<") ^^ (layoutTypeWithInfoAndPrec denv env 4 arg) ^^ rightL (tagPunctuation">")
| args -> bracketIfL (prec <= 1) (tcL ^^ angleL (layoutTypesWithInfoAndPrec denv env 2 (sepL (tagPunctuation ",")) args))
| [argTy] -> tcL ^^ sepL (tagPunctuation "<") ^^ (layoutTypeWithInfoAndPrec denv env 4 argTy) ^^ rightL (tagPunctuation">")
| _ -> bracketIfL (prec <= 1) (tcL ^^ angleL (layoutTypesWithInfoAndPrec denv env 2 (sepL (tagPunctuation ",")) argTys))
else
match args with
match argTys with
| [] -> tcL
| [arg] -> layoutTypeWithInfoAndPrec denv env 2 arg ^^ tcL
| args -> bracketIfL (prec <= 1) (bracketL (layoutTypesWithInfoAndPrec denv env 2 (sepL (tagPunctuation ",")) args) --- tcL)
@ -932,7 +958,7 @@ module PrintTypes =
match argInfo.Name, isOptionalArg, isParamArray, tryDestOptionTy g ty with
// Layout an optional argument
| Some id, true, _, ValueSome ty ->
let idL = ConvertValNameToDisplayLayout false (tagParameter >> rightL) id.idText
let idL = ConvertValLogicalNameToDisplayLayout false (tagParameter >> rightL) id.idText
LeftL.questionMark ^^
(idL |> addColonL) ^^
layoutTypeWithInfoAndPrec denv env 2 ty
@ -943,7 +969,7 @@ module PrintTypes =
// Layout a named argument
| Some id, _, isParamArray, _ ->
let idL = ConvertValNameToDisplayLayout false (tagParameter >> wordL) id.idText
let idL = ConvertValLogicalNameToDisplayLayout false (tagParameter >> wordL) id.idText
let prefix =
if isParamArray then
layoutBuiltinAttribute denv g.attrib_ParamArrayAttribute ^^ idL
@ -972,7 +998,6 @@ module PrintTypes =
/// Layout a single type used as the type of a member or value
let layoutTopType denv env argInfos retTy cxs =
// Parenthesize the return type to match the topValInfo
let retTyL = layoutReturnType denv env retTy
let cxsL = layoutConstraintsWithInfo denv env cxs
match argInfos with
@ -1001,7 +1026,10 @@ module PrintTypes =
else
bracketL coreL --- nmL
let layoutTyparConstraint denv (tp, tpc) =
let layoutTrait denv traitInfo =
layoutTraitWithInfo denv SimplifyTypes.typeSimplificationInfo0 traitInfo
let layoutTyparConstraint denv (tp, tpc) =
match layoutConstraintWithInfo denv SimplifyTypes.typeSimplificationInfo0 (tp, tpc) with
| h :: _ -> h
| [] -> emptyL
@ -1051,8 +1079,8 @@ module PrintTypes =
prettyTyparInst, niceMethodTypars, layout
let prettyLayoutOfMemberType denv v typarInst argInfos retTy =
match PartitionValRefTypars denv.g v with
let prettyLayoutOfMemberType denv vref typarInst argInfos retTy =
match PartitionValRefTypars denv.g vref with
| Some(_, _, memberMethodTypars, memberToParentInst, _) ->
prettyLayoutOfMemberSigCore denv memberToParentInst (typarInst, memberMethodTypars, argInfos, retTy)
| None ->
@ -1061,7 +1089,7 @@ module PrintTypes =
let prettyLayoutOfMemberSig denv (memberToParentInst, nm, methTypars, argInfos, retTy) =
let _, niceMethodTypars, tauL = prettyLayoutOfMemberSigCore denv memberToParentInst (emptyTyparInst, methTypars, argInfos, retTy)
let nameL = ConvertValNameToDisplayLayout false (tagMember >> wordL) nm
let nameL = ConvertValLogicalNameToDisplayLayout false (tagMember >> wordL) nm
let nameL =
if denv.showTyparBinding then
layoutTyparDecls denv nameL true niceMethodTypars
@ -1120,18 +1148,31 @@ module PrintTypes =
let cxsL = layoutConstraintsWithInfo denv env env.postfixConstraints
layoutTypeWithInfoAndPrec denv env 2 ty --- cxsL
let prettyLayoutOfTypeNoConstraints denv ty =
let prettyLayoutOfTrait denv traitInfo =
let compgenId = SyntaxTreeOps.mkSynId Range.range0 unassignedTyparName
let fakeTypar = Construct.NewTypar (TyparKind.Type, TyparRigidity.Flexible, SynTypar(compgenId, TyparStaticReq.None, true), false, TyparDynamicReq.No, [], false, false)
fakeTypar.SetConstraints [TyparConstraint.MayResolveMember(traitInfo, Range.range0)]
let ty, cxs = PrettyTypes.PrettifyType denv.g (mkTyparTy fakeTypar)
let env = SimplifyTypes.CollectInfo true [ty] cxs
// We expect one constraint, since we put one in.
match env.postfixConstraints with
| cx :: _ ->
// We expect at most one per constraint
sepListL emptyL (layoutConstraintWithInfo denv env cx)
| [] -> emptyL
let prettyLayoutOfTypeNoConstraints denv ty =
let ty, _cxs = PrettyTypes.PrettifyType denv.g ty
layoutTypeWithInfoAndPrec denv SimplifyTypes.typeSimplificationInfo0 5 ty
let layoutOfValReturnType denv (v: ValRef) =
match v.ValReprInfo with
let layoutOfValReturnType denv (vref: ValRef) =
match vref.ValReprInfo with
| None ->
let tau = v.TauType
let tau = vref.TauType
let _argTysl, retTy = stripFunTy denv.g tau
layoutReturnType denv SimplifyTypes.typeSimplificationInfo0 retTy
| Some (ValReprInfo(_typars, argInfos, _retInfo)) ->
let tau = v.TauType
let tau = vref.TauType
let _c, retTy = GetTopTauTypeInFSharpForm denv.g argInfos tau Range.range0
layoutReturnType denv SimplifyTypes.typeSimplificationInfo0 retTy
@ -1148,22 +1189,22 @@ module PrintTastMemberOrVals =
else
nameL
let layoutMemberName (denv: DisplayEnv) (v: ValRef) niceMethodTypars tagFunction name =
let nameL = ConvertValNameToDisplayLayout v.IsBaseVal (tagFunction >> mkNav v.DefinitionRange >> wordL) name
let layoutMemberName (denv: DisplayEnv) (vref: ValRef) niceMethodTypars tagFunction name =
let nameL = ConvertValLogicalNameToDisplayLayout vref.IsBaseVal (tagFunction >> mkNav vref.DefinitionRange >> wordL) name
let nameL =
if denv.showMemberContainers then
layoutTyconRef denv v.MemberApparentEntity ^^ SepL.dot ^^ nameL
layoutTyconRef denv vref.MemberApparentEntity ^^ SepL.dot ^^ nameL
else
nameL
let nameL = if denv.showTyparBinding then layoutTyparDecls denv nameL true niceMethodTypars else nameL
let nameL = layoutAccessibility denv v.Accessibility nameL
let nameL = layoutAccessibility denv vref.Accessibility nameL
nameL
let prettyLayoutOfMemberShortOption denv typarInst (v: Val) short =
let v = mkLocalValRef v
let membInfo = Option.get v.MemberInfo
let vref = mkLocalValRef v
let membInfo = Option.get vref.MemberInfo
let stat = layoutMemberFlags membInfo.MemberFlags
let _tps, argInfos, retTy, _ = GetTypeOfMemberInFSharpForm denv.g v
let _tps, argInfos, retTy, _ = GetTypeOfMemberInFSharpForm denv.g vref
if short then
for argInfo in argInfos do
@ -1174,22 +1215,22 @@ module PrintTastMemberOrVals =
let prettyTyparInst, memberL =
match membInfo.MemberFlags.MemberKind with
| SynMemberKind.Member ->
let prettyTyparInst, niceMethodTypars,tauL = prettyLayoutOfMemberType denv v typarInst argInfos retTy
let prettyTyparInst, niceMethodTypars,tauL = prettyLayoutOfMemberType denv vref typarInst argInfos retTy
let resL =
if short then tauL
else
let nameL = layoutMemberName denv v niceMethodTypars tagMember v.DisplayNameCoreMangled
let nameL = if short then nameL else mkInlineL denv v.Deref nameL
let nameL = layoutMemberName denv vref niceMethodTypars tagMember vref.DisplayNameCoreMangled
let nameL = if short then nameL else mkInlineL denv vref.Deref nameL
stat --- ((nameL |> addColonL) ^^ tauL)
prettyTyparInst, resL
| SynMemberKind.ClassConstructor
| SynMemberKind.Constructor ->
let prettyTyparInst, _, tauL = prettyLayoutOfMemberType denv v typarInst argInfos retTy
let prettyTyparInst, _, tauL = prettyLayoutOfMemberType denv vref typarInst argInfos retTy
let resL =
if short then tauL
else
let newL = layoutAccessibility denv v.Accessibility WordL.keywordNew
let newL = layoutAccessibility denv vref.Accessibility WordL.keywordNew
stat ++ (newL |> addColonL) ^^ tauL
prettyTyparInst, resL
@ -1199,8 +1240,8 @@ module PrintTastMemberOrVals =
| SynMemberKind.PropertyGet ->
if isNil argInfos then
// use error recovery because intellisense on an incomplete file will show this
errorR(Error(FSComp.SR.tastInvalidFormForPropertyGetter(), v.Id.idRange))
let nameL = layoutMemberName denv v [] tagProperty v.DisplayNameCoreMangled
errorR(Error(FSComp.SR.tastInvalidFormForPropertyGetter(), vref.Id.idRange))
let nameL = layoutMemberName denv vref [] tagProperty vref.DisplayNameCoreMangled
let resL =
if short then nameL --- (WordL.keywordWith ^^ WordL.keywordGet)
else stat --- nameL --- (WordL.keywordWith ^^ WordL.keywordGet)
@ -1210,31 +1251,31 @@ module PrintTastMemberOrVals =
match argInfos with
| [[(ty, _)]] when isUnitTy denv.g ty -> []
| _ -> argInfos
let prettyTyparInst, niceMethodTypars,tauL = prettyLayoutOfMemberType denv v typarInst argInfos retTy
let prettyTyparInst, niceMethodTypars,tauL = prettyLayoutOfMemberType denv vref typarInst argInfos retTy
let resL =
if short then
if isNil argInfos then tauL
else tauL --- (WordL.keywordWith ^^ WordL.keywordGet)
else
let nameL = layoutMemberName denv v niceMethodTypars tagProperty v.DisplayNameCoreMangled
let nameL = layoutMemberName denv vref niceMethodTypars tagProperty vref.DisplayNameCoreMangled
stat --- ((nameL |> addColonL) ^^ (if isNil argInfos then tauL else tauL --- (WordL.keywordWith ^^ WordL.keywordGet)))
prettyTyparInst, resL
| SynMemberKind.PropertySet ->
if argInfos.Length <> 1 || isNil argInfos.Head then
// use error recovery because intellisense on an incomplete file will show this
errorR(Error(FSComp.SR.tastInvalidFormForPropertySetter(), v.Id.idRange))
let nameL = layoutMemberName denv v [] tagProperty v.DisplayNameCoreMangled
errorR(Error(FSComp.SR.tastInvalidFormForPropertySetter(), vref.Id.idRange))
let nameL = layoutMemberName denv vref [] tagProperty vref.DisplayNameCoreMangled
let resL = stat --- nameL --- (WordL.keywordWith ^^ WordL.keywordSet)
emptyTyparInst, resL
else
let argInfos, valueInfo = List.frontAndBack argInfos.Head
let prettyTyparInst, niceMethodTypars, tauL = prettyLayoutOfMemberType denv v typarInst (if isNil argInfos then [] else [argInfos]) (fst valueInfo)
let prettyTyparInst, niceMethodTypars, tauL = prettyLayoutOfMemberType denv vref typarInst (if isNil argInfos then [] else [argInfos]) (fst valueInfo)
let resL =
if short then
(tauL --- (WordL.keywordWith ^^ WordL.keywordSet))
else
let nameL = layoutMemberName denv v niceMethodTypars tagProperty v.DisplayNameCoreMangled
let nameL = layoutMemberName denv vref niceMethodTypars tagProperty vref.DisplayNameCoreMangled
stat --- ((nameL |> addColonL) ^^ (tauL --- (WordL.keywordWith ^^ WordL.keywordSet)))
prettyTyparInst, resL
@ -1271,7 +1312,8 @@ module PrintTastMemberOrVals =
let layoutNonMemberVal denv (tps, v: Val, tau, cxs) =
let env = SimplifyTypes.CollectInfo true [tau] cxs
let cxs = env.postfixConstraints
let argInfos, retTy = GetTopTauTypeInFSharpForm denv.g (arityOfVal v).ArgInfos tau v.Range
let valReprInfo = arityOfValForDisplay v
let argInfos, retTy = GetTopTauTypeInFSharpForm denv.g valReprInfo.ArgInfos tau v.Range
let nameL =
let tagF =
@ -1339,7 +1381,9 @@ module PrintTastMemberOrVals =
let prettyLayoutOfValOrMemberNoInst denv infoReader v =
prettyLayoutOfValOrMember denv infoReader emptyTyparInst v |> snd
let layoutTyparConstraint denv x = x |> PrintTypes.layoutTyparConstraint denv
let layoutTrait denv x = x |> PrintTypes.layoutTrait denv
let layoutTyparConstraint denv x = x |> PrintTypes.layoutTyparConstraint denv
let outputType denv os x = x |> PrintTypes.layoutType denv |> bufferL os
@ -1373,7 +1417,7 @@ module InfoMemberPrinting =
match isParamArray, nmOpt, isOptArg with
// Layout an optional argument
| _, Some id, true ->
let idL = ConvertValNameToDisplayLayout false (tagParameter >> rightL) id.idText
let idL = ConvertValLogicalNameToDisplayLayout false (tagParameter >> rightL) id.idText
let pty = match ptyOpt with ValueSome x -> x | _ -> pty
LeftL.questionMark ^^
(idL |> addColonL) ^^
@ -1385,14 +1429,14 @@ module InfoMemberPrinting =
// Layout a named ParamArray argument
| true, Some id, _ ->
let idL = ConvertValNameToDisplayLayout false (tagParameter >> wordL) id.idText
let idL = ConvertValLogicalNameToDisplayLayout false (tagParameter >> wordL) id.idText
layoutBuiltinAttribute denv denv.g.attrib_ParamArrayAttribute ^^
(idL |> addColonL) ^^
PrintTypes.layoutType denv pty
// Layout a named normal argument
| false, Some id, _ ->
let idL = ConvertValNameToDisplayLayout false (tagParameter >> wordL) id.idText
let idL = ConvertValLogicalNameToDisplayLayout false (tagParameter >> wordL) id.idText
(idL |> addColonL) ^^
PrintTypes.layoutType denv pty
@ -1420,7 +1464,7 @@ module InfoMemberPrinting =
if minfo.IsConstructor then
WordL.keywordNew
else
let idL = ConvertValNameToDisplayLayout false (tagMethod >> tagNavArbValRef minfo.ArbitraryValRef >> wordL) minfo.LogicalName
let idL = ConvertValLogicalNameToDisplayLayout false (tagMethod >> tagNavArbValRef minfo.ArbitraryValRef >> wordL) minfo.LogicalName
WordL.keywordMember ^^
PrintTypes.layoutTyparDecls denv idL true minfo.FormalMethodTypars
@ -1466,7 +1510,7 @@ module InfoMemberPrinting =
if minfo.IsConstructor then
SepL.leftParen
else
let idL = ConvertValNameToDisplayLayout false (tagMethod >> tagNavArbValRef minfo.ArbitraryValRef >> wordL) minfo.LogicalName
let idL = ConvertValLogicalNameToDisplayLayout false (tagMethod >> tagNavArbValRef minfo.ArbitraryValRef >> wordL) minfo.LogicalName
SepL.dot ^^
PrintTypes.layoutTyparDecls denv idL true minfo.FormalMethodTypars ^^
SepL.leftParen
@ -1534,7 +1578,7 @@ module InfoMemberPrinting =
let retTy = pinfo.GetPropertyType(amap, m)
let retTy = if pinfo.IsIndexer then mkFunTy g (mkRefTupledTy g (pinfo.GetParamTypes(amap, m))) retTy else retTy
let retTy, _ = PrettyTypes.PrettifyType g retTy
let nameL = ConvertValNameToDisplayLayout false (tagProperty >> tagNavArbValRef pinfo.ArbitraryValRef >> wordL) pinfo.PropertyName
let nameL = ConvertValLogicalNameToDisplayLayout false (tagProperty >> tagNavArbValRef pinfo.ArbitraryValRef >> wordL) pinfo.PropertyName
let getterSetter =
match pinfo.HasGetter, pinfo.HasSetter with
| true, false ->
@ -1553,6 +1597,10 @@ module InfoMemberPrinting =
layoutType denv retTy ^^
getterSetter
let formatPropInfoToBufferFreeStyle g amap m denv os (pinfo: PropInfo) =
let resL = prettyLayoutOfPropInfoFreeStyle g amap m denv pinfo
resL |> bufferL os
let formatMethInfoToBufferFreeStyle amap m denv os (minfo: MethInfo) =
let _, resL = prettyLayoutOfMethInfoFreeStyle amap m denv emptyTyparInst minfo
resL |> bufferL os
@ -1584,7 +1632,7 @@ module TastDefinitionPrinting =
aboveListL (List.map (layoutExtensionMember denv infoReader) vs)
let layoutRecdField prefix isClassDecl denv infoReader (enclosingTcref: TyconRef) (fld: RecdField) =
let lhs = ConvertNameToDisplayLayout (tagRecordField >> mkNav fld.DefinitionRange >> wordL) fld.DisplayNameCore
let lhs = ConvertLogicalNameToDisplayLayout (tagRecordField >> mkNav fld.DefinitionRange >> wordL) fld.DisplayNameCore
let lhs = (if isClassDecl then layoutAccessibility denv fld.Accessibility lhs else lhs)
let lhs = if fld.IsMutable then wordL (tagKeyword "mutable") --- lhs else lhs
let fieldL =
@ -1625,7 +1673,7 @@ module TastDefinitionPrinting =
sepListL WordL.star (List.mapi (layoutUnionOrExceptionField denv infoReader isGenerated enclosingTcref) fields)
let layoutUnionCase denv infoReader prefixL enclosingTcref (ucase: UnionCase) =
let nmL = ConvertNameToDisplayLayout (tagUnionCase >> mkNav ucase.DefinitionRange >> wordL) ucase.Id.idText
let nmL = ConvertLogicalNameToDisplayLayout (tagUnionCase >> mkNav ucase.DefinitionRange >> wordL) ucase.Id.idText
//let nmL = layoutAccessibility denv ucase.Accessibility nmL
let caseL =
match ucase.RecdFields with
@ -1657,7 +1705,7 @@ module TastDefinitionPrinting =
let layoutILFieldInfo denv (infoReader: InfoReader) m (finfo: ILFieldInfo) =
let staticL = if finfo.IsStatic then WordL.keywordStatic else emptyL
let nameL = ConvertNameToDisplayLayout (tagField >> wordL) finfo.FieldName
let nameL = ConvertLogicalNameToDisplayLayout (tagField >> wordL) finfo.FieldName
let typL = layoutType denv (finfo.FieldType(infoReader.amap, m))
let fieldL = staticL ^^ WordL.keywordVal ^^ (nameL |> addColonL) ^^ typL
layoutXmlDocOfILFieldInfo denv infoReader finfo fieldL
@ -1665,7 +1713,7 @@ module TastDefinitionPrinting =
let layoutEventInfo denv (infoReader: InfoReader) m (einfo: EventInfo) =
let amap = infoReader.amap
let staticL = if einfo.IsStatic then WordL.keywordStatic else emptyL
let nameL = ConvertValNameToDisplayLayout false (tagEvent >> tagNavArbValRef einfo.ArbitraryValRef >> wordL) einfo.EventName
let nameL = ConvertValLogicalNameToDisplayLayout false (tagEvent >> tagNavArbValRef einfo.ArbitraryValRef >> wordL) einfo.EventName
let typL = layoutType denv (einfo.GetDelegateType(amap, m))
let overallL = staticL ^^ WordL.keywordMember ^^ (nameL |> addColonL) ^^ typL
layoutXmlDocOfEventInfo denv infoReader einfo overallL
@ -1684,7 +1732,7 @@ module TastDefinitionPrinting =
else
WordL.keywordMember
let nameL = ConvertValNameToDisplayLayout false (tagProperty >> tagNavArbValRef pinfo.ArbitraryValRef >> wordL) pinfo.PropertyName
let nameL = ConvertValLogicalNameToDisplayLayout false (tagProperty >> tagNavArbValRef pinfo.ArbitraryValRef >> wordL) pinfo.PropertyName
let typL = layoutType denv (pinfo.GetPropertyType(amap, m))
let overallL = modifierAndMember ^^ (nameL |> addColonL) ^^ typL
layoutXmlDocOfPropInfo denv infoReader pinfo overallL
@ -1719,7 +1767,7 @@ module TastDefinitionPrinting =
else
None, tagUnknownType
let nameL = ConvertNameToDisplayLayout (tagger >> mkNav tycon.DefinitionRange >> wordL) tycon.DisplayNameCore
let nameL = ConvertLogicalNameToDisplayLayout (tagger >> mkNav tycon.DefinitionRange >> wordL) tycon.DisplayNameCore
let nameL = layoutAccessibility denv tycon.Accessibility nameL
let denv = denv.AddAccessibility tycon.Accessibility
@ -1730,23 +1778,23 @@ module TastDefinitionPrinting =
typewordL ^^ tpsL
let sortKey (v: MethInfo) =
(not v.IsConstructor,
not v.IsInstance, // instance first
v.DisplayNameCore, // sort by name
List.sum v.NumArgs, // sort by #curried
v.NumArgs.Length) // sort by arity
let sortKey (minfo: MethInfo) =
(not minfo.IsConstructor,
not minfo.IsInstance, // instance first
minfo.DisplayNameCore, // sort by name
List.sum minfo.NumArgs, // sort by #curried
minfo.NumArgs.Length) // sort by arity
let shouldShow (valRef: ValRef option) =
match valRef with
let shouldShow (vrefOpt: ValRef option) =
match vrefOpt with
| None -> true
| Some(vr) ->
(denv.showObsoleteMembers || not (CheckFSharpAttributesForObsolete denv.g vr.Attribs)) &&
(denv.showHiddenMembers || not (CheckFSharpAttributesForHidden denv.g vr.Attribs))
| Some vref ->
(denv.showObsoleteMembers || not (CheckFSharpAttributesForObsolete denv.g vref.Attribs)) &&
(denv.showHiddenMembers || not (CheckFSharpAttributesForHidden denv.g vref.Attribs))
let ctors =
GetIntrinsicConstructorInfosOfType infoReader m ty
|> List.filter (fun v -> IsMethInfoAccessible amap m ad v && not v.IsClassConstructor && shouldShow v.ArbitraryValRef)
|> List.filter (fun minfo -> IsMethInfoAccessible amap m ad minfo && not minfo.IsClassConstructor && shouldShow minfo.ArbitraryValRef)
let iimpls =
if suppressInheritanceAndInterfacesForTyInSimplifiedDisplays g amap m ty then
@ -1760,15 +1808,15 @@ module TastDefinitionPrinting =
let iimplsLs =
iimpls
|> List.map (fun ity -> wordL (tagKeyword (if isInterfaceTy g ty then "inherit" else "interface")) -* layoutType denv ity)
|> List.map (fun intfTy -> wordL (tagKeyword (if isInterfaceTy g ty then "inherit" else "interface")) -* layoutType denv intfTy)
let props =
GetImmediateIntrinsicPropInfosOfType (None, ad) g amap m ty
|> List.filter (fun v -> shouldShow v.ArbitraryValRef)
|> List.filter (fun pinfo -> shouldShow pinfo.ArbitraryValRef)
let events =
infoReader.GetEventInfosOfType(None, ad, m, ty)
|> List.filter (fun v -> shouldShow v.ArbitraryValRef && typeEquiv g ty v.ApparentEnclosingType)
|> List.filter (fun einfo -> shouldShow einfo.ArbitraryValRef && typeEquiv g ty einfo.ApparentEnclosingType)
let impliedNames =
try
@ -1883,8 +1931,8 @@ module TastDefinitionPrinting =
let inherits =
[ if not (suppressInheritanceAndInterfacesForTyInSimplifiedDisplays g amap m ty) then
match GetSuperTypeOfType g amap m ty with
| Some super when not (isObjTy g super) && not (isValueTypeTy g super) ->
super
| Some superTy when not (isObjTy g superTy) && not (isValueTypeTy g superTy) ->
superTy
| _ -> ()
]
@ -2052,8 +2100,8 @@ module TastDefinitionPrinting =
|> addLhs
| TNoRepr when tycon.TypeAbbrev.IsSome ->
let abbreviatedType = tycon.TypeAbbrev.Value
(lhsL ^^ WordL.equals) -* (layoutType { denv with shortTypeNames = false } abbreviatedType)
let abbreviatedTy = tycon.TypeAbbrev.Value
(lhsL ^^ WordL.equals) -* (layoutType { denv with shortTypeNames = false } abbreviatedTy)
| _ when isNil allDecls ->
lhsL
@ -2074,7 +2122,7 @@ module TastDefinitionPrinting =
let layoutExnDefn denv infoReader (exncref: EntityRef) =
let (-*) = if denv.printVerboseSignatures then (-----) else (---)
let exnc = exncref.Deref
let nameL = ConvertNameToDisplayLayout (tagClass >> mkNav exncref.DefinitionRange >> wordL) exnc.DisplayNameCore
let nameL = ConvertLogicalNameToDisplayLayout (tagClass >> mkNav exncref.DefinitionRange >> wordL) exnc.DisplayNameCore
let nameL = layoutAccessibility denv exnc.TypeReprAccessibility nameL
let exnL = wordL (tagKeyword "exception") ^^ nameL // need to tack on the Exception at the right of the name for goto definition
let reprL =
@ -2125,19 +2173,19 @@ module TastDefinitionPrinting =
let headerL =
if mspec.IsNamespace then
// This is a container namespace. We print the header when we get to the first concrete module.
let pathL = path |> List.map (ConvertNameToDisplayLayout (tagNamespace >> wordL))
let pathL = path |> List.map (ConvertLogicalNameToDisplayLayout (tagNamespace >> wordL))
wordL (tagKeyword "namespace") ^^ sepListL SepL.dot pathL
else
// This is a module
let name = path |> List.last
let nameL = ConvertNameToDisplayLayout (tagModule >> mkNav mspec.DefinitionRange >> wordL) name
let nameL = ConvertLogicalNameToDisplayLayout (tagModule >> mkNav mspec.DefinitionRange >> wordL) name
let nameL =
match path with
| [_] ->
nameL
| _ ->
let innerPath = path[..path.Length - 2]
let innerPathL = innerPath |> List.map (ConvertNameToDisplayLayout (tagNamespace >> wordL))
let innerPathL = innerPath |> List.map (ConvertLogicalNameToDisplayLayout (tagNamespace >> wordL))
sepListL SepL.dot innerPathL ^^ SepL.dot ^^ nameL
let modNameL = wordL (tagKeyword "module") ^^ nameL
@ -2317,7 +2365,7 @@ module InferredSigPrinting =
let basicL =
// Check if this namespace contains anything interesting
if isConcreteNamespace def then
let pathL = innerPath |> List.map (fst >> ConvertNameToDisplayLayout (tagNamespace >> wordL))
let pathL = innerPath |> List.map (fst >> ConvertLogicalNameToDisplayLayout (tagNamespace >> wordL))
// This is a container namespace. We print the header when we get to the first concrete module.
let headerL =
wordL (tagKeyword "namespace") ^^ sepListL SepL.dot pathL
@ -2331,7 +2379,7 @@ module InferredSigPrinting =
basicL
else
// This is a module
let nmL = ConvertNameToDisplayLayout (tagModule >> mkNav mspec.DefinitionRange >> wordL) mspec.DisplayNameCore
let nmL = ConvertLogicalNameToDisplayLayout (tagModule >> mkNav mspec.DefinitionRange >> wordL) mspec.DisplayNameCore
let nmL = layoutAccessibility denv mspec.Accessibility nmL
let denv = denv.AddAccessibility mspec.Accessibility
let basic = imdefL denv def
@ -2386,8 +2434,8 @@ module PrintData =
else
layoutConst denv.g ty c
| Expr.Val (v, _, _) ->
wordL (tagLocal v.DisplayName)
| Expr.Val (vref, _, _) ->
wordL (tagLocal vref.DisplayName)
| Expr.Link rX ->
dataExprWrapL denv isAtomic rX.Value
@ -2435,21 +2483,28 @@ let outputValOrMember denv infoReader os x = x |> PrintTastMemberOrVals.prettyLa
let stringValOrMember denv infoReader x = x |> PrintTastMemberOrVals.prettyLayoutOfValOrMemberNoInst denv infoReader |> showL
/// Print members with a qualification showing the type they are contained in
let layoutQualifiedValOrMember denv infoReader typarInst v = PrintTastMemberOrVals.prettyLayoutOfValOrMember { denv with showMemberContainers=true; } infoReader typarInst v
let layoutQualifiedValOrMember denv infoReader typarInst vref =
PrintTastMemberOrVals.prettyLayoutOfValOrMember { denv with showMemberContainers=true; } infoReader typarInst vref
let outputQualifiedValOrMember denv infoReader os v = outputValOrMember { denv with showMemberContainers=true; } infoReader os v
let outputQualifiedValOrMember denv infoReader os vref =
outputValOrMember { denv with showMemberContainers=true; } infoReader os vref
let outputQualifiedValSpec denv infoReader os v = outputQualifiedValOrMember denv infoReader os v
let outputQualifiedValSpec denv infoReader os vref =
outputQualifiedValOrMember denv infoReader os vref
let stringOfQualifiedValOrMember denv infoReader v = PrintTastMemberOrVals.prettyLayoutOfValOrMemberNoInst { denv with showMemberContainers=true; } infoReader v |> showL
let stringOfQualifiedValOrMember denv infoReader vref =
PrintTastMemberOrVals.prettyLayoutOfValOrMemberNoInst { denv with showMemberContainers=true; } infoReader vref |> showL
/// Convert a MethInfo to a string
let formatMethInfoToBufferFreeStyle infoReader m denv buf d = InfoMemberPrinting.formatMethInfoToBufferFreeStyle infoReader m denv buf d
let formatMethInfoToBufferFreeStyle infoReader m denv buf d =
InfoMemberPrinting.formatMethInfoToBufferFreeStyle infoReader m denv buf d
let prettyLayoutOfMethInfoFreeStyle infoReader m denv typarInst minfo = InfoMemberPrinting.prettyLayoutOfMethInfoFreeStyle infoReader m denv typarInst minfo
let prettyLayoutOfMethInfoFreeStyle infoReader m denv typarInst minfo =
InfoMemberPrinting.prettyLayoutOfMethInfoFreeStyle infoReader m denv typarInst minfo
/// Convert a PropInfo to a string
let prettyLayoutOfPropInfoFreeStyle g amap m denv d = InfoMemberPrinting.prettyLayoutOfPropInfoFreeStyle g amap m denv d
let prettyLayoutOfPropInfoFreeStyle g amap m denv d =
InfoMemberPrinting.prettyLayoutOfPropInfoFreeStyle g amap m denv d
/// Convert a MethInfo to a string
let stringOfMethInfo infoReader m denv minfo =
@ -2462,6 +2517,16 @@ let multiLineStringOfMethInfos infoReader m denv minfos =
|> List.map (sprintf "%s %s" Environment.NewLine)
|> String.concat ""
let stringOfPropInfo g amap m denv pinfo =
buildString (fun buf -> InfoMemberPrinting.formatPropInfoToBufferFreeStyle g amap m denv buf pinfo)
/// Convert PropInfos to lines separated by newline including a newline as the first character
let multiLineStringOfPropInfos g amap m denv pinfos =
pinfos
|> List.map (stringOfPropInfo g amap m denv)
|> List.map (sprintf "%s %s" Environment.NewLine)
|> String.concat ""
/// Convert a ParamData to a string
let stringOfParamData denv paramData = buildString (fun buf -> InfoMemberPrinting.formatParamDataToBuffer denv buf paramData)
@ -2488,6 +2553,8 @@ let stringOfTy denv x = x |> PrintTypes.layoutType denv |> showL
let prettyLayoutOfType denv x = x |> PrintTypes.prettyLayoutOfType denv
let prettyLayoutOfTrait denv x = x |> PrintTypes.prettyLayoutOfTrait denv
let prettyLayoutOfTypeNoCx denv x = x |> PrintTypes.prettyLayoutOfTypeNoConstraints denv
let prettyLayoutOfTypar denv x = x |> PrintTypes.layoutTyparRef denv
@ -2509,13 +2576,15 @@ let stringOfILAttrib denv x = x |> PrintTypes.layoutILAttrib denv |> squareAngle
let layoutImpliedSignatureOfModuleOrNamespace showHeader denv infoReader ad m contents =
InferredSigPrinting.layoutImpliedSignatureOfModuleOrNamespace showHeader denv infoReader ad m contents
let prettyLayoutOfValOrMember denv infoReader typarInst v = PrintTastMemberOrVals.prettyLayoutOfValOrMember denv infoReader typarInst v
let prettyLayoutOfValOrMember denv infoReader typarInst vref =
PrintTastMemberOrVals.prettyLayoutOfValOrMember denv infoReader typarInst vref
let prettyLayoutOfValOrMemberNoInst denv infoReader v = PrintTastMemberOrVals.prettyLayoutOfValOrMemberNoInst denv infoReader v
let prettyLayoutOfValOrMemberNoInst denv infoReader vref =
PrintTastMemberOrVals.prettyLayoutOfValOrMemberNoInst denv infoReader vref
let prettyLayoutOfMemberNoInstShort denv v = PrintTastMemberOrVals.prettyLayoutOfMemberNoInstShort denv v
let layoutOfValReturnType denv v = v |> PrintTypes.layoutOfValReturnType denv
let layoutOfValReturnType denv vref = vref |> PrintTypes.layoutOfValReturnType denv
let prettyLayoutOfInstAndSig denv x = PrintTypes.prettyLayoutOfInstAndSig denv x
@ -2523,14 +2592,14 @@ let prettyLayoutOfInstAndSig denv x = PrintTypes.prettyLayoutOfInstAndSig denv x
///
/// If the output text is different without showing constraints and/or imperative type variable
/// annotations and/or fully qualifying paths then don't show them!
let minimalStringsOfTwoTypes denv t1 t2=
let (t1, t2), tpcs = PrettyTypes.PrettifyTypePair denv.g (t1, t2)
let minimalStringsOfTwoTypes denv ty1 ty2 =
let (ty1, ty2), tpcs = PrettyTypes.PrettifyTypePair denv.g (ty1, ty2)
// try denv + no type annotations
let attempt1 =
let denv = { denv with showInferenceTyparAnnotations=false; showStaticallyResolvedTyparAnnotations=false }
let min1 = stringOfTy denv t1
let min2 = stringOfTy denv t2
let min1 = stringOfTy denv ty1
let min2 = stringOfTy denv ty2
if min1 <> min2 then Some (min1, min2, "") else None
match attempt1 with
@ -2540,8 +2609,8 @@ let minimalStringsOfTwoTypes denv t1 t2=
// try denv + no type annotations + show full paths
let attempt2 =
let denv = { denv with showInferenceTyparAnnotations=false; showStaticallyResolvedTyparAnnotations=false }.SetOpenPaths []
let min1 = stringOfTy denv t1
let min2 = stringOfTy denv t2
let min1 = stringOfTy denv ty1
let min2 = stringOfTy denv ty2
if min1 <> min2 then Some (min1, min2, "") else None
match attempt2 with
@ -2549,8 +2618,8 @@ let minimalStringsOfTwoTypes denv t1 t2=
| None ->
let attempt3 =
let min1 = stringOfTy denv t1
let min2 = stringOfTy denv t2
let min1 = stringOfTy denv ty1
let min2 = stringOfTy denv ty2
if min1 <> min2 then Some (min1, min2, stringOfTyparConstraints denv tpcs) else None
match attempt3 with
@ -2561,8 +2630,8 @@ let minimalStringsOfTwoTypes denv t1 t2=
// try denv + show full paths + static parameters
let denv = denv.SetOpenPaths []
let denv = { denv with includeStaticParametersInTypeNames=true }
let min1 = stringOfTy denv t1
let min2 = stringOfTy denv t2
let min1 = stringOfTy denv ty1
let min2 = stringOfTy denv ty2
if min1 <> min2 then Some (min1, min2, stringOfTyparConstraints denv tpcs) else None
match attempt4 with
@ -2576,23 +2645,22 @@ let minimalStringsOfTwoTypes denv t1 t2=
let assemblyName = PrintTypes.layoutAssemblyName denv t |> function | null | "" -> "" | name -> sprintf " (%s)" name
sprintf "%s%s" (stringOfTy denv t) assemblyName
(makeName t1, makeName t2, stringOfTyparConstraints denv tpcs)
(makeName ty1, makeName ty2, stringOfTyparConstraints denv tpcs)
// Note: Always show imperative annotations when comparing value signatures
let minimalStringsOfTwoValues denv infoReader v1 v2=
let minimalStringsOfTwoValues denv infoReader vref1 vref2 =
let denvMin = { denv with showInferenceTyparAnnotations=true; showStaticallyResolvedTyparAnnotations=false }
let min1 = buildString (fun buf -> outputQualifiedValOrMember denvMin infoReader buf v1)
let min2 = buildString (fun buf -> outputQualifiedValOrMember denvMin infoReader buf v2)
let min1 = buildString (fun buf -> outputQualifiedValOrMember denvMin infoReader buf vref1)
let min2 = buildString (fun buf -> outputQualifiedValOrMember denvMin infoReader buf vref2)
if min1 <> min2 then
(min1, min2)
else
let denvMax = { denv with showInferenceTyparAnnotations=true; showStaticallyResolvedTyparAnnotations=true }
let max1 = buildString (fun buf -> outputQualifiedValOrMember denvMax infoReader buf v1)
let max2 = buildString (fun buf -> outputQualifiedValOrMember denvMax infoReader buf v2)
let max1 = buildString (fun buf -> outputQualifiedValOrMember denvMax infoReader buf vref1)
let max2 = buildString (fun buf -> outputQualifiedValOrMember denvMax infoReader buf vref2)
max1, max2
let minimalStringOfType denv ty =
let ty, _cxs = PrettyTypes.PrettifyType denv.g ty
let denvMin = { denv with showInferenceTyparAnnotations=false; showStaticallyResolvedTyparAnnotations=false }
showL (PrintTypes.layoutTypeWithInfoAndPrec denvMin SimplifyTypes.typeSimplificationInfo0 2 ty)

26
src/Compiler/Checking/NicePrint.fsi
Просмотреть файл

@ -54,14 +54,14 @@ val layoutQualifiedValOrMember:
denv: DisplayEnv ->
infoReader: InfoReader ->
typarInst: TyparInstantiation ->
v: ValRef ->
vref: ValRef ->
TyparInstantiation * Layout
val outputQualifiedValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> os: StringBuilder -> v: ValRef -> unit
val outputQualifiedValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> os: StringBuilder -> vref: ValRef -> unit
val outputQualifiedValSpec: denv: DisplayEnv -> infoReader: InfoReader -> os: StringBuilder -> v: ValRef -> unit
val outputQualifiedValSpec: denv: DisplayEnv -> infoReader: InfoReader -> os: StringBuilder -> vref: ValRef -> unit
val stringOfQualifiedValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> v: ValRef -> string
val stringOfQualifiedValOrMember: denv: DisplayEnv -> infoReader: InfoReader -> vref: ValRef -> string
val formatMethInfoToBufferFreeStyle:
infoReader: InfoReader -> m: range -> denv: DisplayEnv -> buf: StringBuilder -> d: MethInfo -> unit
@ -82,6 +82,11 @@ val stringOfMethInfo: infoReader: InfoReader -> m: range -> denv: DisplayEnv ->
val multiLineStringOfMethInfos:
infoReader: InfoReader -> m: range -> denv: DisplayEnv -> minfos: MethInfo list -> string
val stringOfPropInfo: g: TcGlobals -> amap: ImportMap -> m: range -> denv: DisplayEnv -> pinfo: PropInfo -> string
val multiLineStringOfPropInfos:
g: TcGlobals -> amap: ImportMap -> m: range -> denv: DisplayEnv -> pinfos: PropInfo list -> string
val stringOfParamData: denv: DisplayEnv -> paramData: ParamData -> string
val layoutOfParamData: denv: DisplayEnv -> paramData: ParamData -> Layout
@ -108,6 +113,8 @@ val stringOfTy: denv: DisplayEnv -> x: TType -> string
val prettyLayoutOfType: denv: DisplayEnv -> x: TType -> Layout
val prettyLayoutOfTrait: denv: DisplayEnv -> x: TraitConstraintInfo -> Layout
val prettyLayoutOfTypeNoCx: denv: DisplayEnv -> x: TType -> Layout
val prettyLayoutOfTypar: denv: DisplayEnv -> x: Typar -> Layout
@ -139,22 +146,23 @@ val prettyLayoutOfValOrMember:
denv: DisplayEnv ->
infoReader: InfoReader ->
typarInst: TyparInstantiation ->
v: ValRef ->
vref: ValRef ->
TyparInstantiation * Layout
val prettyLayoutOfValOrMemberNoInst: denv: DisplayEnv -> infoReader: InfoReader -> v: ValRef -> Layout
val prettyLayoutOfValOrMemberNoInst: denv: DisplayEnv -> infoReader: InfoReader -> vref: ValRef -> Layout
val prettyLayoutOfMemberNoInstShort: denv: DisplayEnv -> v: Val -> Layout
val layoutOfValReturnType: denv: DisplayEnv -> v: ValRef -> Layout
val layoutOfValReturnType: denv: DisplayEnv -> vref: ValRef -> Layout
val prettyLayoutOfInstAndSig:
denv: DisplayEnv ->
TyparInstantiation * TTypes * TType ->
TyparInstantiation * (TTypes * TType) * (Layout list * Layout) * Layout
val minimalStringsOfTwoTypes: denv: DisplayEnv -> t1: TType -> t2: TType -> string * string * string
val minimalStringsOfTwoTypes: denv: DisplayEnv -> ty1: TType -> ty2: TType -> string * string * string
val minimalStringsOfTwoValues: denv: DisplayEnv -> infoReader: InfoReader -> v1: ValRef -> v2: ValRef -> string * string
val minimalStringsOfTwoValues:
denv: DisplayEnv -> infoReader: InfoReader -> vref1: ValRef -> vref2: ValRef -> string * string
val minimalStringOfType: denv: DisplayEnv -> ty: TType -> string

113
src/Compiler/Checking/PatternMatchCompilation.fs
Просмотреть файл

@ -312,8 +312,8 @@ let RefuteDiscrimSet g m path discrims =
raise CannotRefute
go path tm
let rec CombineRefutations g r1 r2 =
match r1, r2 with
let rec CombineRefutations g refutation1 refutation2 =
match refutation1, refutation2 with
| Expr.Val (vref, _, _), other | other, Expr.Val (vref, _, _) when vref.LogicalName = "_" -> other
| Expr.Val (vref, _, _), other | other, Expr.Val (vref, _, _) when vref.LogicalName = notNullText -> other
| Expr.Val (vref, _, _), other | other, Expr.Val (vref, _, _) when vref.LogicalName = otherSubtypeText -> other
@ -326,9 +326,9 @@ let rec CombineRefutations g r1 r2 =
Expr.Op (op1, tinst1, List.map2 (CombineRefutations g) flds1 flds2, m1)
(* Choose the greater of the two ucrefs based on name ordering *)
elif ucref1.CaseName < ucref2.CaseName then
r2
refutation2
else
r1
refutation1
| Expr.Op (op1, tinst1, flds1, m1), Expr.Op (_, _, flds2, _) ->
Expr.Op (op1, tinst1, List.map2 (CombineRefutations g) flds1 flds2, m1)
@ -352,7 +352,7 @@ let rec CombineRefutations g r1 r2 =
Expr.Const (c12, m1, ty1)
| _ -> r1
| _ -> refutation1
let ShowCounterExample g denv m refuted =
try
@ -418,17 +418,17 @@ type Implication =
/// Indicates nothing in particular
| Nothing
/// Work out what one successful type test implies about a null test
/// Work out what a successful type test (against tgtTy1) implies about a null test for the same input value.
///
/// Example:
/// match x with
/// | :? string -> ...
/// | :? string when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
/// | null -> ...
/// For any inputs where ':? string' succeeds, 'null' will fail
///
/// Example:
/// match x with
/// | :? (int option) -> ...
/// | :? (int option) when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
/// | null -> ...
/// Nothing can be learned. If ':? (int option)' succeeds, 'null' may still have to be run.
let computeWhatSuccessfulTypeTestImpliesAboutNullTest g tgtTy1 =
@ -437,7 +437,7 @@ let computeWhatSuccessfulTypeTestImpliesAboutNullTest g tgtTy1 =
else
Implication.Fails
/// Work out what a failing type test implies about a null test.
/// Work out what a failing type test (against tgtTy1) implies about a null test for the same input value.
///
/// Example:
/// match x with
@ -450,17 +450,17 @@ let computeWhatFailingTypeTestImpliesAboutNullTest g tgtTy1 =
else
Implication.Nothing
/// Work out what one successful null test implies about a type test.
/// Work out what one successful null test implies about a type test (against tgtTy2) for the same input value.
///
/// Example:
/// match x with
/// | null -> ...
/// | null when false -> ... // note: "when false" used so null test succeeds but proceed to next type test
/// | :? string -> ...
/// For any inputs where 'null' succeeds, ':? string' will fail
///
/// Example:
/// match x with
/// | null -> ...
/// | null when false -> ... // note: "when false" used so null test succeeds but proceed to next type test
/// | :? (int option) -> ...
/// For any inputs where 'null' succeeds, ':? (int option)' will succeed
let computeWhatSuccessfulNullTestImpliesAboutTypeTest g tgtTy2 =
@ -469,67 +469,79 @@ let computeWhatSuccessfulNullTestImpliesAboutTypeTest g tgtTy2 =
else
Implication.Fails
/// Work out what a failing null test implies about a type test. The answer is "nothing" but it's included for symmetry.
/// Work out what a failing null test implies about a type test (against tgtTy2) for the same
/// input balue. The answer is "nothing" but it's included for symmetry.
let computeWhatFailingNullTestImpliesAboutTypeTest _g _tgtTy2 =
Implication.Nothing
/// Work out what one successful type test implies about another type test
/// Work out what one successful type test (against tgtTy1) implies about another type test (against tgtTy2)
/// for the same input value.
let computeWhatSuccessfulTypeTestImpliesAboutTypeTest g amap m tgtTy1 tgtTy2 =
let tgtTy1 = stripTyEqnsWrtErasure EraseAll g tgtTy1
let tgtTy2 = stripTyEqnsWrtErasure EraseAll g tgtTy2
// A successful type test on any type implies all supertypes always succeed
// A successful type test of an input value against a type (tgtTy1)
// implies all type tests of the same input value on equivalent or
// supertypes (tgtTy2) always succeed.
//
// Example:
// match x with
// | :? string -> ...
// | :? string when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
// | :? IComparable -> ...
//
// Example:
// match x with
// | :? string -> ...
// | :? string when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
// | :? string -> ...
//
if TypeDefinitelySubsumesTypeNoCoercion 0 g amap m tgtTy2 tgtTy1 then
Implication.Succeeds
// A successful type test on a sealed type implies all non-related types fail
// A successful type test of an input value against a sealed target type (tgtTy1) implies all
// type tests of the same object against a unrelated target type (tgtTy2) fails.
//
// Example:
// match x with
// | :? int -> ...
// | :? int when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
// | :? string -> ...
//
// For any inputs where ':? int' succeeds, ':? string' will fail
//
// This doesn't apply to related types:
//
// This only applies if tgtTy2 is not potetnially related to the sealed type tgtTy1:
// match x with
// | :? int -> ...
// | :? int when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
// | :? IComparable -> ...
//
// Here IComparable neither fails nor is redundant
// Here IComparable is not known to fail (NOTE: indeed it is actually known to succeed,
// give ":? int" succeeded, however this is not utilised in the analysis, because it involves coercion).
//
// This doesn't apply to unsealed types:
//
// This rule also doesn't apply to unsealed types:
// match x with
// | :? SomeClass -> ...
// | :? SomeUnsealedClass when false -> ... // note: "when false" used so type test succeeds but proceed to next type test
// | :? SomeInterface -> ...
// because the input may be some subtype of SomeUnsealedClass and that type could implement SomeInterface even if
// SomeUnsealedClass doesnt.
//
// This doesn't apply to types with null as true value:
//
// This rule also doesn't apply to types with null as true value:
// match x with
// | :? (int option) -> ...
// | :? (int option) when false -> ... // "when false" means type test succeeds but proceed to next type test
// | :? (string option) -> ...
//
// Here on 'null' input the first pattern succeeds, and the second pattern will also succeed
elif isSealedTy g tgtTy1 &&
not (TypeNullIsTrueValue g tgtTy1) &&
not (TypeDefinitelySubsumesTypeNoCoercion 0 g amap m tgtTy2 tgtTy1) then
not (TypeFeasiblySubsumesType 0 g amap m tgtTy2 CanCoerce tgtTy1) then
Implication.Fails
// A successful type test on an unsealed class type implies type tests on unrelated non-interface types always fail
// A successful type test of an input value against an unsealed class type (tgtTy1) implies
// a type test of the same input value against an unrelated non-interface type (tgtTy2) always fails
//
// Example:
// match x with
// | :? SomeUnsealedClass -> ...
// | :? SomeUnsealedClass when false -> ... // "when false" used so type test succeeds but proceed to next type test
// | :? SomeUnrelatedClass -> ...
//
// For any inputs where ':? SomeUnsealedClass' succeeds, ':? SomeUnrelatedClass' will fail
@ -543,11 +555,13 @@ let computeWhatSuccessfulTypeTestImpliesAboutTypeTest g amap m tgtTy1 tgtTy2 =
not (TypeFeasiblySubsumesType 0 g amap m tgtTy2 CanCoerce tgtTy1) then
Implication.Fails
// A successful type test on an interface type refutes sealed types that do not support that interface
// A successful type test of an input value against an interface type (tgtTy1) implies
// a type test of the same object against a sealed types (tgtTy2) that does not support that interface
// always fails.
//
// Example:
// match x with
// | :? IComparable -> ...
// | :? IComparable when false -> ... // "when false" used so type test succeeds but proceed to next type test
// | :? SomeOtherSealedClass -> ...
//
// For any inputs where ':? IComparable' succeeds, ':? SomeOtherSealedClass' will fail
@ -561,12 +575,13 @@ let computeWhatSuccessfulTypeTestImpliesAboutTypeTest g amap m tgtTy1 tgtTy2 =
else
Implication.Nothing
/// Work out what one successful type test implies about another type test
/// Work out what one failing type test (tgtTy1) implies about another type test (tgtTy2)
let computeWhatFailingTypeTestImpliesAboutTypeTest g amap m tgtTy1 tgtTy2 =
let tgtTy1 = stripTyEqnsWrtErasure EraseAll g tgtTy1
let tgtTy2 = stripTyEqnsWrtErasure EraseAll g tgtTy2
// A failing type test on any type implies all subtypes fail
// If testing an input value against a target type (tgtTy1) fails then
// testing the same input value against an equivalent or subtype type (tgtTy2) always fails.
//
// Example:
// match x with
@ -592,8 +607,8 @@ let getDiscrimOfPattern (g: TcGlobals) tpinst t =
match t with
| TPat_null _m ->
Some(DecisionTreeTest.IsNull)
| TPat_isinst (srcty, tgty, _, _m) ->
Some(DecisionTreeTest.IsInst (instType tpinst srcty, instType tpinst tgty))
| TPat_isinst (srcTy, tgtTy, _, _m) ->
Some(DecisionTreeTest.IsInst (instType tpinst srcTy, instType tpinst tgtTy))
| TPat_exnconstr(tcref, _, _m) ->
Some(DecisionTreeTest.IsInst (g.exn_ty, mkAppTy tcref []))
| TPat_const (c, _m) ->
@ -624,7 +639,7 @@ let discrimsEq (g: TcGlobals) d1 d2 =
| DecisionTreeTest.ArrayLength (n1, _), DecisionTreeTest.ArrayLength(n2, _) -> (n1=n2)
| DecisionTreeTest.Const c1, DecisionTreeTest.Const c2 -> (c1=c2)
| DecisionTreeTest.IsNull, DecisionTreeTest.IsNull -> true
| DecisionTreeTest.IsInst (srcty1, tgty1), DecisionTreeTest.IsInst (srcty2, tgty2) -> typeEquiv g srcty1 srcty2 && typeEquiv g tgty1 tgty2
| DecisionTreeTest.IsInst (srcTy1, tgtTy1), DecisionTreeTest.IsInst (srcTy2, tgtTy2) -> typeEquiv g srcTy1 srcTy2 && typeEquiv g tgtTy1 tgtTy2
| DecisionTreeTest.ActivePatternCase (_, _, _, vrefOpt1, n1, _), DecisionTreeTest.ActivePatternCase (_, _, _, vrefOpt2, n2, _) ->
match vrefOpt1, vrefOpt2 with
| Some (vref1, tinst1), Some (vref2, tinst2) -> valRefEq g vref1 vref2 && n1 = n2 && not (doesActivePatternHaveFreeTypars g vref1) && List.lengthsEqAndForall2 (typeEquiv g) tinst1 tinst2
@ -1063,11 +1078,11 @@ let CompilePatternBasic
| Some (ediCaptureMethInfo, ediThrowMethInfo) ->
let edi, _ =
BuildMethodCall tcVal g amap NeverMutates mMatch false
ediCaptureMethInfo ValUseFlag.NormalValUse [] [] [ (exprForVal mMatch origInputVal) ]
ediCaptureMethInfo ValUseFlag.NormalValUse [] [] [ (exprForVal mMatch origInputVal) ] None
let e, _ =
BuildMethodCall tcVal g amap NeverMutates mMatch false
ediThrowMethInfo ValUseFlag.NormalValUse [] [edi] [ ]
ediThrowMethInfo ValUseFlag.NormalValUse [] [edi] [ ] None
mkCompGenSequential mMatch e (mkDefault (mMatch, resultTy))
@ -1213,15 +1228,15 @@ let CompilePatternBasic
// This is really an optimization that could be done more effectively in opt.fs
// if we flowed a bit of information through
| [EdgeDiscrim(_i', DecisionTreeTest.IsInst (_srcty, tgty), m)]
| [EdgeDiscrim(_i', DecisionTreeTest.IsInst (_srcTy, tgtTy), m)]
// check we can use a simple 'isinst' instruction
when isRefTy g tgty && canUseTypeTestFast g tgty && isNil origInputValTypars ->
when isRefTy g tgtTy && canUseTypeTestFast g tgtTy && isNil origInputValTypars ->
let v, vExpr = mkCompGenLocal m "typeTestResult" tgty
let v, vExpr = mkCompGenLocal m "typeTestResult" tgtTy
if origInputVal.IsMemberOrModuleBinding then
AdjustValToTopVal v origInputVal.DeclaringEntity ValReprInfo.emptyValData
AdjustValToHaveValReprInfo v origInputVal.TryDeclaringEntity ValReprInfo.emptyValData
let argExpr = GetSubExprOfInput subexpr
let appExpr = mkIsInst tgty argExpr mMatch
let appExpr = mkIsInst tgtTy argExpr mMatch
Some vExpr, Some(mkInvisibleBind v appExpr)
// Any match on a struct union must take the address of its input.
@ -1239,7 +1254,7 @@ let CompilePatternBasic
| None -> Some addrExp, None
| Some (v, e) ->
if origInputVal.IsMemberOrModuleBinding then
AdjustValToTopVal v origInputVal.DeclaringEntity ValReprInfo.emptyValData
AdjustValToHaveValReprInfo v origInputVal.TryDeclaringEntity ValReprInfo.emptyValData
Some addrExp, Some (mkInvisibleBind v e)
@ -1255,7 +1270,7 @@ let CompilePatternBasic
let ucaseTy = (mkProvenUnionCaseTy g.cons_ucref tinst)
let v, vExpr = mkCompGenLocal m "unionTestResult" ucaseTy
if origInputVal.IsMemberOrModuleBinding then
AdjustValToTopVal v origInputVal.DeclaringEntity ValReprInfo.emptyValData
AdjustValToHaveValReprInfo v origInputVal.DeclaringEntity ValReprInfo.emptyValData
let argExpr = GetSubExprOfInput subexpr
let appExpr = mkIsInst ucaseTy argExpr mMatch
Some vExpr, Some (mkInvisibleBind v appExpr)
@ -1276,11 +1291,11 @@ let CompilePatternBasic
| None ->
let v, vExpr = mkCompGenLocal m ("activePatternResult" + string (newUnique())) resTy
if origInputVal.IsMemberOrModuleBinding then
AdjustValToTopVal v origInputVal.DeclaringEntity ValReprInfo.emptyValData
AdjustValToHaveValReprInfo v origInputVal.TryDeclaringEntity ValReprInfo.emptyValData
Some vExpr, Some(mkInvisibleBind v addrExp)
| Some (v, e) ->
if origInputVal.IsMemberOrModuleBinding then
AdjustValToTopVal v origInputVal.DeclaringEntity ValReprInfo.emptyValData
AdjustValToHaveValReprInfo v origInputVal.TryDeclaringEntity ValReprInfo.emptyValData
Some addrExp, Some (mkInvisibleBind v e)
| _ -> None, None
@ -1328,7 +1343,7 @@ let CompilePatternBasic
let discrim' =
match discrim with
| DecisionTreeTest.ActivePatternCase(_pexp, resTys, isStructRetTy, _apatVrefOpt, idx, apinfo) ->
let aparity = apinfo.Names.Length
let aparity = apinfo.ActiveTags.Length
let total = apinfo.IsTotal
if not total && aparity > 1 then
error(Error(FSComp.SR.patcPartialActivePatternsGenerateOneResult(), m))
@ -1410,7 +1425,7 @@ let CompilePatternBasic
// Total active patterns always return choice values
let hasParam = (match apatVrefOpt with None -> true | Some (vref, _) -> doesActivePatternHaveFreeTypars g vref)
if (hasParam && i = iInvestigated) || (discrimsEq g discrim (Option.get (getDiscrimOfPattern patAtActive))) then
let aparity = apinfo.Names.Length
let aparity = apinfo.ActiveTags.Length
let subAccess j tpinst _e' =
assert inpExprOpt.IsSome
if aparity <= 1 then

81
src/Compiler/Checking/PostInferenceChecks.fs
Просмотреть файл

@ -416,8 +416,8 @@ and CheckTypeConstraintDeep cenv f g env x =
| TyparConstraint.MayResolveMember(traitInfo, _) -> CheckTraitInfoDeep cenv f g env traitInfo
| TyparConstraint.DefaultsTo(_, ty, _) -> CheckTypeDeep cenv f g env true ty
| TyparConstraint.SimpleChoice(tys, _) -> CheckTypesDeep cenv f g env tys
| TyparConstraint.IsEnum(uty, _) -> CheckTypeDeep cenv f g env true uty
| TyparConstraint.IsDelegate(aty, bty, _) -> CheckTypeDeep cenv f g env true aty; CheckTypeDeep cenv f g env true bty
| TyparConstraint.IsEnum(underlyingTy, _) -> CheckTypeDeep cenv f g env true underlyingTy
| TyparConstraint.IsDelegate(argTys, retTy, _) -> CheckTypeDeep cenv f g env true argTys; CheckTypeDeep cenv f g env true retTy
| TyparConstraint.SupportsComparison _
| TyparConstraint.SupportsEquality _
| TyparConstraint.SupportsNull _
@ -591,8 +591,8 @@ let mkArgsPermit n =
/// Work out what byref-values are allowed at input positions to named F# functions or members
let mkArgsForAppliedVal isBaseCall (vref: ValRef) argsl =
match vref.ValReprInfo with
| Some topValInfo ->
let argArities = topValInfo.AritiesOfArgs
| Some valReprInfo ->
let argArities = valReprInfo.AritiesOfArgs
let argArities = if isBaseCall && argArities.Length >= 1 then List.tail argArities else argArities
// Check for partial applications: arguments to partial applications don't get to use byrefs
if List.length argsl >= argArities.Length then
@ -651,7 +651,7 @@ let CheckTypeAux permitByRefLike (cenv: cenv) env m ty onInnerByrefError =
let visitTraitSolution info =
match info with
| FSMethSln(_, vref, _) ->
| FSMethSln(_, vref, _, _) ->
//printfn "considering %s..." vref.DisplayName
if valRefInThisAssembly cenv.g.compilingFSharpCore vref && not (cenv.boundVals.ContainsKey(vref.Stamp)) then
//printfn "recording %s..." vref.DisplayName
@ -717,39 +717,42 @@ type TTypeEquality =
| FeasiblyEqual
| NotEqual
let compareTypesWithRegardToTypeVariablesAndMeasures g amap m typ1 typ2 =
let compareTypesWithRegardToTypeVariablesAndMeasures g amap m ty1 ty2 =
if (typeEquiv g typ1 typ2) then
if (typeEquiv g ty1 ty2) then
ExactlyEqual
else
if (typeEquiv g typ1 typ2 || TypesFeasiblyEquivStripMeasures g amap m typ1 typ2) then
if (typeEquiv g ty1 ty2 || TypesFeasiblyEquivStripMeasures g amap m ty1 ty2) then
FeasiblyEqual
else
NotEqual
let CheckMultipleInterfaceInstantiations cenv (typ:TType) (interfaces:TType list) isObjectExpression m =
let keyf ty = assert isAppTy cenv.g ty; (tcrefOfAppTy cenv.g ty).Stamp
let groups = interfaces |> List.groupBy keyf
let keyTyByStamp g ty =
assert isAppTy g ty
(tcrefOfAppTy g ty).Stamp
let CheckMultipleInterfaceInstantiations cenv (ty:TType) (interfaces:TType list) isObjectExpression m =
let groups = interfaces |> List.groupBy (keyTyByStamp cenv.g)
let errors = seq {
for _, items in groups do
for i1 in 0 .. items.Length - 1 do
for i2 in i1 + 1 .. items.Length - 1 do
let typ1 = items[i1]
let typ2 = items[i2]
let tcRef1 = tcrefOfAppTy cenv.g typ1
match compareTypesWithRegardToTypeVariablesAndMeasures cenv.g cenv.amap m typ1 typ2 with
let ty1 = items[i1]
let ty2 = items[i2]
let tcRef1 = tcrefOfAppTy cenv.g ty1
match compareTypesWithRegardToTypeVariablesAndMeasures cenv.g cenv.amap m ty1 ty2 with
| ExactlyEqual -> ()
| FeasiblyEqual ->
match tryLanguageFeatureErrorOption cenv.g.langVersion LanguageFeature.InterfacesWithMultipleGenericInstantiation m with
| None -> ()
| Some exn -> exn
let typ1Str = NicePrint.minimalStringOfType cenv.denv typ1
let typ2Str = NicePrint.minimalStringOfType cenv.denv typ2
let typ1Str = NicePrint.minimalStringOfType cenv.denv ty1
let typ2Str = NicePrint.minimalStringOfType cenv.denv ty2
if isObjectExpression then
Error(FSComp.SR.typrelInterfaceWithConcreteAndVariableObjectExpression(tcRef1.DisplayNameWithStaticParametersAndUnderscoreTypars, typ1Str, typ2Str),m)
else
let typStr = NicePrint.minimalStringOfType cenv.denv typ
let typStr = NicePrint.minimalStringOfType cenv.denv ty
Error(FSComp.SR.typrelInterfaceWithConcreteAndVariable(typStr, tcRef1.DisplayNameWithStaticParametersAndUnderscoreTypars, typ1Str, typ2Str),m)
| NotEqual ->
@ -804,7 +807,7 @@ and CheckValUse (cenv: cenv) (env: env) (vref: ValRef, vFlags, m) (ctxt: PermitB
let isCallOfConstructorOfAbstractType =
(match vFlags with NormalValUse -> true | _ -> false) &&
vref.IsConstructor &&
(match vref.DeclaringEntity with Parent tcref -> isAbstractTycon tcref.Deref | _ -> false)
(match vref.TryDeclaringEntity with Parent tcref -> isAbstractTycon tcref.Deref | _ -> false)
if isCallOfConstructorOfAbstractType then
errorR(Error(FSComp.SR.tcAbstractTypeCannotBeInstantiated(), m))
@ -1352,14 +1355,14 @@ and CheckApplication cenv env expr (f, tyargs, argsl, m) ctxt =
CheckCall cenv env m returnTy argsl ctxts ctxt
and CheckLambda cenv env expr (argvs, m, bodyTy) =
let topValInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal)
let valReprInfo = ValReprInfo ([], [argvs |> List.map (fun _ -> ValReprInfo.unnamedTopArg1)], ValReprInfo.unnamedRetVal)
let ty = mkMultiLambdaTy cenv.g m argvs bodyTy in
CheckLambdas false None cenv env false topValInfo false expr m ty PermitByRefExpr.Yes
CheckLambdas false None cenv env false valReprInfo false expr m ty PermitByRefExpr.Yes
and CheckTyLambda cenv env expr (tps, m, bodyTy) =
let topValInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal)
let valReprInfo = ValReprInfo (ValReprInfo.InferTyparInfo tps, [], ValReprInfo.unnamedRetVal)
let ty = mkForallTyIfNeeded tps bodyTy in
CheckLambdas false None cenv env false topValInfo false expr m ty PermitByRefExpr.Yes
CheckLambdas false None cenv env false valReprInfo false expr m ty PermitByRefExpr.Yes
and CheckMatch cenv env ctxt (dtree, targets, m, ty) =
CheckTypeNoInnerByrefs cenv env m ty // computed byrefs allowed at each branch
@ -1575,8 +1578,8 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr =
errorR(Error(FSComp.SR.chkNoWriteToLimitedSpan(rf.FieldName), m))
NoLimit
| TOp.Coerce, [tgty;srcty], [x] ->
if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgty srcty then
| TOp.Coerce, [tgtTy;srcTy], [x] ->
if TypeDefinitelySubsumesTypeNoCoercion 0 g cenv.amap m tgtTy srcTy then
CheckExpr cenv env x ctxt
else
CheckTypeInstNoByrefs cenv env m tyargs
@ -1699,20 +1702,20 @@ and CheckExprOp cenv env (op, tyargs, args, m) ctxt expr =
CheckTypeInstNoByrefs cenv env m tyargs
CheckExprsNoByRefLike cenv env args
and CheckLambdas isTop (memberVal: Val option) cenv env inlined topValInfo alwaysCheckNoReraise expr mOrig ety ctxt =
and CheckLambdas isTop (memberVal: Val option) cenv env inlined valReprInfo alwaysCheckNoReraise expr mOrig ety ctxt =
let g = cenv.g
let memInfo = memberVal |> Option.bind (fun v -> v.MemberInfo)
// The topValInfo here says we are _guaranteeing_ to compile a function value
// The valReprInfo here says we are _guaranteeing_ to compile a function value
// as a .NET method with precisely the corresponding argument counts.
match stripDebugPoints expr with
| Expr.TyChoose (tps, e1, m) ->
let env = BindTypars g env tps
CheckLambdas isTop memberVal cenv env inlined topValInfo alwaysCheckNoReraise e1 m ety ctxt
CheckLambdas isTop memberVal cenv env inlined valReprInfo alwaysCheckNoReraise e1 m ety ctxt
| Expr.Lambda (_, _, _, _, _, m, _)
| Expr.TyLambda (_, _, _, m, _) ->
let tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destTopLambda g cenv.amap topValInfo (expr, ety)
let tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo g cenv.amap valReprInfo (expr, ety)
let env = BindTypars g env tps
let thisAndBase = Option.toList ctorThisValOpt @ Option.toList baseValOpt
let restArgs = List.concat vsl
@ -2004,7 +2007,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin
// Check accessibility
if (v.IsMemberOrModuleBinding || v.IsMember) && not v.IsIncrClassGeneratedMember then
let access = AdjustAccess (IsHiddenVal env.sigToImplRemapInfo v) (fun () -> v.TopValDeclaringEntity.CompilationPath) v.Accessibility
let access = AdjustAccess (IsHiddenVal env.sigToImplRemapInfo v) (fun () -> v.DeclaringEntity.CompilationPath) v.Accessibility
CheckTypeForAccess cenv env (fun () -> NicePrint.stringOfQualifiedValOrMember cenv.denv cenv.infoReader vref) access v.Range v.Type
let env = if v.IsConstructor && not v.IsIncrClassConstructor then { env with ctorLimitedZone=true } else env
@ -2032,7 +2035,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin
// Also check the enclosing type for members - for historical reasons, in the TAST member values
// are stored in the entity that encloses the type, hence we will not have noticed the ReflectedDefinition
// on the enclosing type at this point.
HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.TopValDeclaringEntity.Attribs) then
HasFSharpAttribute g g.attrib_ReflectedDefinitionAttribute v.DeclaringEntity.Attribs) then
if v.IsInstanceMember && v.MemberApparentEntity.IsStructOrEnumTycon then
errorR(Error(FSComp.SR.chkNoReflectedDefinitionOnStructMember(), v.Range))
@ -2071,7 +2074,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin
| _ -> ()
let topValInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData
let valReprInfo = match bind.Var.ValReprInfo with Some info -> info | _ -> ValReprInfo.emptyValData
// If the method has ResumableCode argument or return type it must be inline
// unless warning is suppressed (user must know what they're doing).
@ -2089,7 +2092,7 @@ and CheckBinding cenv env alwaysCheckNoReraise ctxt (TBind(v, bindRhs, _) as bin
else
env
CheckLambdas isTop (Some v) cenv env v.MustInline topValInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt
CheckLambdas isTop (Some v) cenv env v.MustInline valReprInfo alwaysCheckNoReraise bindRhs v.Range v.Type ctxt
and CheckBindings cenv env binds =
for bind in binds do
@ -2129,10 +2132,10 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) =
// Skip explicit implementations of interface methods
if ValIsExplicitImpl g v then () else
match v.DeclaringEntity with
match v.TryDeclaringEntity with
| ParentNone -> () // this case can happen after error recovery from earlier error
| Parent _ ->
let tcref = v.TopValDeclaringEntity
let tcref = v.DeclaringEntity
let hasDefaultAugmentation =
tcref.IsUnionTycon &&
match TryFindFSharpAttribute g g.attrib_DefaultAugmentationAttribute tcref.Attribs with
@ -2279,8 +2282,8 @@ let CheckEntityDefn cenv env (tycon: Entity) =
let allVirtualMethsInParent =
match GetSuperTypeOfType g cenv.amap m ty with
| Some super ->
GetIntrinsicMethInfosOfType cenv.infoReader None AccessibleFromSomewhere AllowMultiIntfInstantiations.Yes IgnoreOverrides m super
| Some superTy ->
GetIntrinsicMethInfosOfType cenv.infoReader None AccessibleFromSomewhere AllowMultiIntfInstantiations.Yes IgnoreOverrides m superTy
|> List.filter (fun minfo -> minfo.IsVirtual)
| None -> []
@ -2479,8 +2482,8 @@ let CheckEntityDefn cenv env (tycon: Entity) =
// Abstract slots can have byref arguments and returns
for vref in abstractSlotValsOfTycons [tycon] do
match vref.ValReprInfo with
| Some topValInfo ->
let tps, argTysl, retTy, _ = GetTopValTypeInFSharpForm g topValInfo vref.Type m
| Some valReprInfo ->
let tps, argTysl, retTy, _ = GetValReprTypeInFSharpForm g valReprInfo vref.Type m
let env = BindTypars g env tps
for argTys in argTysl do
for argTy, _ in argTys do

65
src/Compiler/Checking/QuotationTranslator.fs
Просмотреть файл

@ -172,9 +172,9 @@ let (|ModuleValueOrMemberUse|_|) g expr =
match stripExpr expr with
| Expr.App (InnerExprPat(Expr.Val (vref, vFlags, _) as f), fty, tyargs, actualArgs, _m) when vref.IsMemberOrModuleBinding ->
Some(vref, vFlags, f, fty, tyargs, actualArgs @ args)
| Expr.App (f, _fty, [], actualArgs, _) ->
| Expr.App (f, _fTy, [], actualArgs, _) ->
loop f (actualArgs @ args)
| Expr.Val (vref, vFlags, _m) as f when (match vref.DeclaringEntity with ParentNone -> false | _ -> true) ->
| Expr.Val (vref, vFlags, _m) as f when (match vref.TryDeclaringEntity with ParentNone -> false | _ -> true) ->
let fty = tyOfExpr g f
Some(vref, vFlags, f, fty, [], args)
| _ ->
@ -260,7 +260,7 @@ and GetWitnessArgs cenv (env : QuotationTranslationEnv) m tps tyargs =
and ConvWitnessInfo cenv env m traitInfo =
let g = cenv.g
let witnessInfo = traitInfo.TraitKey
let witnessInfo = traitInfo.GetWitnessInfo()
let env = { env with suppressWitnesses = true }
// First check if this is a witness in ReflectedDefinition code
if env.witnessesInScope.ContainsKey witnessInfo then
@ -292,8 +292,8 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
// Recognize applications of module functions.
match expr with
// Detect expression tree exprSplices
| Expr.App (InnerExprPat(Expr.Val (vf, _, _)), _, _, x0 :: rest, m)
when isSplice g vf ->
| Expr.App (InnerExprPat(Expr.Val (vref, _, _)), _, _, x0 :: rest, m)
when isSplice g vref ->
let idx = cenv.exprSplices.Count
let ty = tyOfExpr g expr
@ -305,7 +305,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
let hole = QP.mkHole(ConvType cenv env m ty, idx)
(hole, rest) ||> List.fold (fun fR arg -> QP.mkApp (fR, ConvExpr cenv env arg))
| ModuleValueOrMemberUse g (vref, vFlags, _f, _fty, tyargs, curriedArgs)
| ModuleValueOrMemberUse g (vref, vFlags, _f, _fTy, tyargs, curriedArgs)
when not (isSplice g vref) ->
let m = expr.Range
@ -323,7 +323,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
// This is an application of a module value or extension member
let arities = arityOfVal vref.Deref
let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal vref.Deref
let tps, witnessInfos, curriedArgInfos, retTy, _ = GetTopValTypeInCompiledForm g arities numEnclosingTypars vref.Type m
let tps, witnessInfos, curriedArgInfos, retTy, _ = GetValReprTypeInCompiledForm g arities numEnclosingTypars vref.Type m
false, tps, witnessInfos, curriedArgInfos, retTy
// Compute the object arguments as they appear in a compiled call
@ -348,12 +348,12 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
dprintfn "vref.DisplayName = %A was under applied" vref.DisplayName
// Too few arguments or incorrect tupling? Convert to a lambda and beta-reduce the
// partially applied arguments to 'let' bindings
let topValInfo =
let valReprInfo =
match vref.ValReprInfo with
| None -> error(InternalError("no arity information found for F# value " + vref.LogicalName, vref.Range))
| Some a -> a
let expr, exprTy = AdjustValForExpectedArity g m vref vFlags topValInfo
let expr, exprTy = AdjustValForExpectedValReprInfo g m vref vFlags valReprInfo
ConvExpr cenv env (MakeApplicationAndBetaReduce g (expr, exprTy, [tyargs], curriedArgs, m))
else
// Too many arguments? Chop
@ -385,7 +385,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
let subCall =
if isMember then
let parentTyconR = ConvTyconRef cenv vref.TopValDeclaringEntity m
let parentTyconR = ConvTyconRef cenv vref.DeclaringEntity m
let isNewObj = isNewObj || valUseFlags || isSelfInit
// The signature types are w.r.t. to the formal context
let envinner = BindFormalTypars env tps
@ -419,16 +419,16 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
List.fold (fun fR arg -> QP.mkApp (fR, ConvExpr cenv env arg)) callR laterArgs
// Blast type application nodes and expression application nodes apart so values are left with just their type arguments
| Expr.App (f, fty, (_ :: _ as tyargs), (_ :: _ as args), m) ->
let rfty = applyForallTy g fty tyargs
ConvExpr cenv env (primMkApp (primMkApp (f, fty) tyargs [] m, rfty) [] args m)
| Expr.App (f, fTy, (_ :: _ as tyargs), (_ :: _ as args), m) ->
let reducedTy = applyForallTy g fTy tyargs
ConvExpr cenv env (primMkApp (primMkApp (f, fTy) tyargs [] m, reducedTy) [] args m)
// Uses of possibly-polymorphic values
| Expr.App (InnerExprPat(Expr.Val (vref, _vFlags, m)), _fty, tyargs, [], _) ->
| Expr.App (InnerExprPat(Expr.Val (vref, _vFlags, m)), _fTy, tyargs, [], _) ->
ConvValRef true cenv env m vref tyargs
// Simple applications
| Expr.App (f, _fty, tyargs, args, m) ->
| Expr.App (f, _fTy, tyargs, args, m) ->
if not (List.isEmpty tyargs) then wfail(Error(FSComp.SR.crefQuotationsCantContainGenericExprs(), m))
List.fold (fun fR arg -> QP.mkApp (fR, ConvExpr cenv env arg)) (ConvExpr cenv env f) args
@ -636,7 +636,7 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
| TOp.LValueOp (LSet, vref), [], [e] ->
// Sets of module values become property sets
match vref.DeclaringEntity with
match vref.TryDeclaringEntity with
| Parent tcref when IsCompiledAsStaticProperty g vref.Deref ->
let parentTyconR = ConvTyconRef cenv tcref m
let propName = vref.CompiledName g.CompilerGlobalState
@ -712,7 +712,8 @@ and private ConvExprCore cenv (env : QuotationTranslationEnv) (expr: Expr) : QP.
let inWitnessPassingScope = not env.witnessesInScope.IsEmpty
let witnessArgInfo =
if g.generateWitnesses && inWitnessPassingScope then
match env.witnessesInScope.TryGetValue traitInfo.TraitKey with
let witnessInfo = traitInfo.GetWitnessInfo()
match env.witnessesInScope.TryGetValue witnessInfo with
| true, storage -> Some storage
| _ -> None
else
@ -828,12 +829,12 @@ and ConvLValueExprCore cenv env expr =
| TOp.UnionCaseFieldGetAddr (ucref, n, _), [e], _ -> ConvUnionFieldGet cenv env m ucref n tyargs e
| TOp.ILAsm ([ I_ldflda(fspec) ], _), _, _ -> ConvLdfld cenv env m fspec tyargs args
| TOp.ILAsm ([ I_ldsflda(fspec) ], _), _, _ -> ConvLdfld cenv env m fspec tyargs args
| TOp.ILAsm ([ I_ldelema(_ro, _isNativePtr, shape, _tyarg) ], _), arr :: idxs, [elemty] ->
| TOp.ILAsm ([ I_ldelema(_ro, _isNativePtr, shape, _tyarg) ], _), arr :: idxs, [elemTy] ->
match shape.Rank, idxs with
| 1, [idx1] -> ConvExpr cenv env (mkCallArrayGet cenv.g m elemty arr idx1)
| 2, [idx1; idx2] -> ConvExpr cenv env (mkCallArray2DGet cenv.g m elemty arr idx1 idx2)
| 3, [idx1; idx2; idx3] -> ConvExpr cenv env (mkCallArray3DGet cenv.g m elemty arr idx1 idx2 idx3)
| 4, [idx1; idx2; idx3; idx4] -> ConvExpr cenv env (mkCallArray4DGet cenv.g m elemty arr idx1 idx2 idx3 idx4)
| 1, [idx1] -> ConvExpr cenv env (mkCallArrayGet cenv.g m elemTy arr idx1)
| 2, [idx1; idx2] -> ConvExpr cenv env (mkCallArray2DGet cenv.g m elemTy arr idx1 idx2)
| 3, [idx1; idx2; idx3] -> ConvExpr cenv env (mkCallArray3DGet cenv.g m elemTy arr idx1 idx2 idx3)
| 4, [idx1; idx2; idx3; idx4] -> ConvExpr cenv env (mkCallArray4DGet cenv.g m elemTy arr idx1 idx2 idx3 idx4)
| _ -> ConvExpr cenv env expr
| _ -> ConvExpr cenv env expr
| _ -> ConvExpr cenv env expr
@ -901,7 +902,7 @@ and ConvModuleValueApp cenv env m (vref:ValRef) tyargs witnessArgs (args: Expr l
EmitDebugInfoIfNecessary cenv env m (ConvModuleValueAppCore cenv env m vref tyargs witnessArgs args)
and ConvModuleValueAppCore cenv env m (vref: ValRef) tyargs witnessArgsR (curriedArgs: Expr list list) =
match vref.DeclaringEntity with
match vref.TryDeclaringEntity with
| ParentNone -> failwith "ConvModuleValueAppCore"
| Parent(tcref) ->
let isProperty = IsCompiledAsStaticProperty cenv.g vref.Deref
@ -937,15 +938,15 @@ and private ConvValRefCore holeOk cenv env m (vref: ValRef) tyargs =
elif v.IsCtorThisVal && cenv.isReflectedDefinition = IsReflectedDefinition.Yes then
QP.mkThisVar(ConvType cenv env m v.Type)
else
let vty = v.Type
match v.DeclaringEntity with
let vTy = v.Type
match v.TryDeclaringEntity with
| ParentNone ->
// References to local values are embedded by value
if not holeOk then wfail(Error(FSComp.SR.crefNoSetOfHole(), m))
let idx = cenv.exprSplices.Count
let liftExpr = mkCallLiftValueWithName cenv.g m vty v.LogicalName (exprForValRef m vref)
let liftExpr = mkCallLiftValueWithName cenv.g m vTy v.LogicalName (exprForValRef m vref)
cenv.exprSplices.Add((liftExpr, m))
QP.mkHole(ConvType cenv env m vty, idx)
QP.mkHole(ConvType cenv env m vTy, idx)
| Parent _ ->
// First-class use or use of type function
@ -1106,9 +1107,9 @@ and ConvDecisionTree cenv env tgs typR x =
let eqR = ConvExpr cenv env eq
QP.mkCond (eqR, ConvDecisionTree cenv env tgs typR dtree, acc)
| DecisionTreeTest.IsInst (_srcty, tgty) ->
| DecisionTreeTest.IsInst (_srcTy, tgtTy) ->
let e1R = ConvExpr cenv env e1
QP.mkCond (QP.mkTypeTest (ConvType cenv env m tgty, e1R), ConvDecisionTree cenv env tgs typR dtree, acc)
QP.mkCond (QP.mkTypeTest (ConvType cenv env m tgtTy, e1R), ConvDecisionTree cenv env tgs typR dtree, acc)
| DecisionTreeTest.ActivePatternCase _ ->
wfail(InternalError( "DecisionTreeTest.ActivePatternCase test in quoted expression", m))
@ -1264,7 +1265,7 @@ let ConvExprPublic cenv suppressWitnesses e =
let ConvMethodBase cenv env (methName, v: Val) =
let m = v.Range
let parentTyconR = ConvTyconRef cenv v.TopValDeclaringEntity m
let parentTyconR = ConvTyconRef cenv v.DeclaringEntity m
match v.MemberInfo with
| Some vspr when not v.IsExtensionMember ->
@ -1300,7 +1301,7 @@ let ConvMethodBase cenv env (methName, v: Val) =
| _ when v.IsExtensionMember ->
let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v
let tps, witnessInfos, argInfos, retTy, _ = GetTopValTypeInCompiledForm cenv.g v.ValReprInfo.Value numEnclosingTypars v.Type v.Range
let tps, witnessInfos, argInfos, retTy, _ = GetValReprTypeInCompiledForm cenv.g v.ValReprInfo.Value numEnclosingTypars v.Type v.Range
let argTys = argInfos |> List.concat |> List.map fst
let envinner = BindFormalTypars env tps
let witnessArgTysR = ConvTypes cenv envinner m (GenWitnessTys cenv.g witnessInfos)
@ -1317,7 +1318,7 @@ let ConvMethodBase cenv env (methName, v: Val) =
| _ ->
let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal v
let tps, witnessInfos, _argInfos, _retTy, _ = GetTopValTypeInCompiledForm cenv.g v.ValReprInfo.Value numEnclosingTypars v.Type v.Range
let tps, witnessInfos, _argInfos, _retTy, _ = GetValReprTypeInCompiledForm cenv.g v.ValReprInfo.Value numEnclosingTypars v.Type v.Range
let envinner = BindFormalTypars env tps
let witnessArgTysR = ConvTypes cenv envinner m (GenWitnessTys cenv.g witnessInfos)
let nWitnesses = witnessArgTysR.Length

35
src/Compiler/Checking/SignatureConformance.fs
Просмотреть файл

@ -11,6 +11,7 @@ open Internal.Utilities.Library
open Internal.Utilities.Library.Extras
open FSharp.Compiler
open FSharp.Compiler.DiagnosticsLogger
open FSharp.Compiler.Features
open FSharp.Compiler.Infos
open FSharp.Compiler.InfoReader
open FSharp.Compiler.Syntax
@ -122,9 +123,15 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) =
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))
let check =
if g.langVersion.SupportsFeature LanguageFeature.InterfacesWithAbstractStaticMembers then
implTypar.StaticReq = TyparStaticReq.HeadType && sigTypar.StaticReq = TyparStaticReq.None
else
implTypar.StaticReq <> sigTypar.StaticReq
if check 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)
@ -187,26 +194,26 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) =
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 implIntfTys = implTycon.ImmediateInterfaceTypesOfFSharpTycon
let sigIntfTys = sigTycon.ImmediateInterfaceTypesOfFSharpTycon
let implUserIntfTys = 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 fintfs = flatten fintfs
let implIntfTys = flatten implIntfTys
let sigIntfTys = flatten sigIntfTys
let unimpl = ListSet.subtract (fun fity aity -> typeAEquiv g aenv aity fity) fintfs aintfs
(unimpl
let unimplIntfTys = ListSet.subtract (fun sigIntfTy implIntfTy -> typeAEquiv g aenv implIntfTy sigIntfTy) sigIntfTys implIntfTys
(unimplIntfTys
|> List.forall (fun ity ->
let errorMessage = FSComp.SR.DefinitionsInSigAndImplNotCompatibleMissingInterface(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, NicePrint.minimalStringOfType denv ity)
errorR (Error(errorMessage, m)); false)) &&
let aintfsUser = flatten aintfsUser
let implUserIntfTys = flatten implUserIntfTys
let hidden = ListSet.subtract (typeAEquiv g aenv) aintfsUser fintfs
let hidden = ListSet.subtract (typeAEquiv g aenv) implUserIntfTys sigIntfTys
let continueChecks, warningOrError = if implTycon.IsFSharpInterfaceTycon then false, errorR else true, warning
(hidden |> List.forall (fun ity -> warningOrError (InterfaceNotRevealed(denv, ity, implTycon.Range)); continueChecks)) &&
@ -328,12 +335,12 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) =
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.GeneralizedType
let sigTypars, ftau = sigVal.GeneralizedType
let implTypars, implValTy = implVal.GeneralizedType
let sigTypars, sigValTy = sigVal.GeneralizedType
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
if not (typeAEquiv g aenv implValTy sigValTy) 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

73
src/Compiler/Checking/TypeHierarchy.fs
Просмотреть файл

@ -9,6 +9,7 @@ open FSharp.Compiler
open FSharp.Compiler.AbstractIL.IL
open FSharp.Compiler.DiagnosticsLogger
open FSharp.Compiler.Import
open FSharp.Compiler.Features
open FSharp.Compiler.Syntax
open FSharp.Compiler.SyntaxTreeOps
open FSharp.Compiler.TcGlobals
@ -92,8 +93,8 @@ let GetImmediateInterfacesOfMetadataType g amap m skipUnref ty (tcref: TyconRef)
match metadataOfTy g ty with
#if !NO_TYPEPROVIDERS
| ProvidedTypeMetadata info ->
for ity in info.ProvidedType.PApplyArray((fun st -> st.GetInterfaces()), "GetInterfaces", m) do
ImportProvidedType amap m ity
for intfTy in info.ProvidedType.PApplyArray((fun st -> st.GetInterfaces()), "GetInterfaces", m) do
ImportProvidedType amap m intfTy
#endif
| ILTypeMetadata (TILObjectReprData(scoref, _, tdef)) ->
// ImportILType may fail for an interface if the assembly load set is incomplete and the interface
@ -103,12 +104,12 @@ let GetImmediateInterfacesOfMetadataType g amap m skipUnref ty (tcref: TyconRef)
// succeeded with more reported. There are pathological corner cases where this
// doesn't apply: e.g. for mscorlib interfaces like IComparable, but we can always
// assume those are present.
for ity in tdef.Implements do
if skipUnref = SkipUnrefInterfaces.No || CanRescopeAndImportILType scoref amap m ity then
RescopeAndImportILType scoref amap m tinst ity
for intfTy in tdef.Implements do
if skipUnref = SkipUnrefInterfaces.No || CanRescopeAndImportILType scoref amap m intfTy then
RescopeAndImportILType scoref amap m tinst intfTy
| FSharpOrArrayOrByrefOrTupleOrExnTypeMetadata ->
for ity in tcref.ImmediateInterfaceTypesOfFSharpTycon do
instType (mkInstForAppTy g ty) ity ]
for intfTy in tcref.ImmediateInterfaceTypesOfFSharpTycon do
instType (mkInstForAppTy g ty) intfTy ]
/// Collect the set of immediate declared interface types for an F# type, but do not
/// traverse the type hierarchy to collect further interfaces.
@ -151,22 +152,27 @@ let rec GetImmediateInterfacesOfType skipUnref g amap m ty =
// This measure-annotated type is considered to support the interfaces on its representation type A,
// with the exception that
//
// 1. we rewrite the IComparable and IEquatable interfaces, so that
// 1. Rewrite the IComparable and IEquatable interfaces, so that
// IComparable<A> --> IComparable<A<'m>>
// IEquatable<A> --> IEquatable<A<'m>>
//
// 2. we emit any other interfaces that derive from IComparable and IEquatable interfaces
// 2. Omit any other interfaces that derive from IComparable and IEquatable interfaces
//
// This rule is conservative and only applies to IComparable and IEquatable interfaces.
//
// This rule may in future be extended to rewrite the "trait" interfaces associated with .NET 7.
// We also:
// 3. Omit any interfaces in System.Numerics, since pretty much none of them are adequate for units of measure
// There are some exceptions, e.g. IAdditiveIdentity, but these are available3 by different routes in F# and for clarity
// it is better to imply omit all
and GetImmediateInterfacesOfMeasureAnnotatedType skipUnref g amap m ty reprTy =
[
// Report any interfaces that don't derive from IComparable<_> or IEquatable<_>
for ity in GetImmediateInterfacesOfType skipUnref g amap m reprTy do
if not (ExistsHeadTypeInInterfaceHierarchy g.system_GenericIComparable_tcref skipUnref g amap m ity) &&
not (ExistsHeadTypeInInterfaceHierarchy g.system_GenericIEquatable_tcref skipUnref g amap m ity) then
ity
// Suppress any interfaces that derive from IComparable<_> or IEquatable<_>
// Suppress any interfaces in System.Numerics, since none of them are adequate for units of measure
for intfTy in GetImmediateInterfacesOfType skipUnref g amap m reprTy do
if not (ExistsHeadTypeInInterfaceHierarchy g.system_GenericIComparable_tcref skipUnref g amap m intfTy) &&
not (ExistsHeadTypeInInterfaceHierarchy g.system_GenericIEquatable_tcref skipUnref g amap m intfTy) &&
not (ExistsSystemNumericsTypeInInterfaceHierarchy skipUnref g amap m intfTy) then
intfTy
// NOTE: we should really only report the IComparable<A<'m>> interface for measure-annotated types
// if the original type supports IComparable<A> somewhere in the hierarchy, likeiwse IEquatable<A<'m>>.
@ -180,16 +186,29 @@ and GetImmediateInterfacesOfMeasureAnnotatedType skipUnref g amap m ty reprTy =
mkAppTy g.system_GenericIEquatable_tcref [ty]
]
// Check for IComparable<A>, IEquatable<A> and interfaces that derive from these
and ExistsHeadTypeInInterfaceHierarchy target skipUnref g amap m ity =
ExistsInInterfaceHierarchy (function AppTy g (tcref,_) -> tyconRefEq g tcref target | _ -> false) skipUnref g amap m ity
// Check for any System.Numerics type in the interface hierarchy
and ExistsSystemNumericsTypeInInterfaceHierarchy skipUnref g amap m ity =
g.langVersion.SupportsFeature LanguageFeature.InterfacesWithAbstractStaticMembers &&
ExistsInInterfaceHierarchy
(fun ity2 ->
match ity2 with
| AppTy g (tcref,_) ->
match tcref.CompilationPath.AccessPath with
| [("System", _); ("Numerics", _)] -> true
| _ -> false
| _ -> false)
skipUnref g amap m ity
// Check for IComparable<A>, IEquatable<A> and interfaces that derive from these
and ExistsInInterfaceHierarchy p skipUnref g amap m ity =
match ity with
and ExistsHeadTypeInInterfaceHierarchy target skipUnref g amap m intfTy =
ExistsInInterfaceHierarchy (function AppTy g (tcref,_) -> tyconRefEq g tcref target | _ -> false) skipUnref g amap m intfTy
// Check for IComparable<A>, IEquatable<A> and interfaces that derive from these
and ExistsInInterfaceHierarchy p skipUnref g amap m intfTy =
match intfTy with
| AppTy g (tcref, tinst) ->
p ity ||
(GetImmediateInterfacesOfMetadataType g amap m skipUnref ity tcref tinst
p intfTy ||
(GetImmediateInterfacesOfMetadataType g amap m skipUnref intfTy tcref tinst
|> List.exists (ExistsInInterfaceHierarchy p skipUnref g amap m))
| _ -> false
@ -199,7 +218,7 @@ type AllowMultiIntfInstantiations = Yes | No
/// Traverse the type hierarchy, e.g. f D (f C (f System.Object acc)).
/// Visit base types and interfaces first.
let private FoldHierarchyOfTypeAux followInterfaces allowMultiIntfInst skipUnref visitor g amap m ty acc =
let FoldHierarchyOfTypeAux followInterfaces allowMultiIntfInst skipUnref visitor g amap m ty acc =
let rec loop ndeep ty (visitedTycon, visited: TyconRefMultiMap<_>, acc as state) =
let seenThisTycon =
@ -369,14 +388,14 @@ let CopyTyparConstraints m tprefInst (tporig: Typar) =
TyparConstraint.DefaultsTo (priority, instType tprefInst ty, m)
| TyparConstraint.SupportsNull _ ->
TyparConstraint.SupportsNull m
| TyparConstraint.IsEnum (uty, _) ->
TyparConstraint.IsEnum (instType tprefInst uty, m)
| TyparConstraint.IsEnum (underlyingTy, _) ->
TyparConstraint.IsEnum (instType tprefInst underlyingTy, m)
| TyparConstraint.SupportsComparison _ ->
TyparConstraint.SupportsComparison m
| TyparConstraint.SupportsEquality _ ->
TyparConstraint.SupportsEquality m
| TyparConstraint.IsDelegate(aty, bty, _) ->
TyparConstraint.IsDelegate (instType tprefInst aty, instType tprefInst bty, m)
| TyparConstraint.IsDelegate(argTys, retTy, _) ->
TyparConstraint.IsDelegate (instType tprefInst argTys, instType tprefInst retTy, m)
| TyparConstraint.IsNonNullableStruct _ ->
TyparConstraint.IsNonNullableStruct m
| TyparConstraint.IsUnmanaged _ ->

108
src/Compiler/Checking/TypeRelations.fs
Просмотреть файл

@ -46,24 +46,25 @@ let rec TypeDefinitelySubsumesTypeNoCoercion ndeep g amap m ty1 ty2 =
type CanCoerce = CanCoerce | NoCoerce
let stripAll stripMeasures g ty =
if stripMeasures then
ty |> stripTyEqnsWrtErasure EraseAll g |> stripMeasuresFromTy g
else
ty |> stripTyEqns g
/// The feasible equivalence relation. Part of the language spec.
let rec TypesFeasiblyEquivalent stripMeasures ndeep g amap m ty1 ty2 =
if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeFeasiblySubsumesType), ty1 = " + (DebugPrint.showType ty1), m));
let stripAll ty =
if stripMeasures then
ty |> stripTyEqnsWrtErasure EraseAll g |> stripMeasuresFromTType g
else
ty |> stripTyEqns g
let ty1str = stripAll ty1
let ty2str = stripAll ty2
let ty1 = stripAll stripMeasures g ty1
let ty2 = stripAll stripMeasures g ty2
match ty1str, ty2str with
match ty1, ty2 with
| TType_var _, _
| _, TType_var _ -> true
| TType_app (tc1, l1, _), TType_app (tc2, l2, _) when tyconRefEq g tc1 tc2 ->
| TType_app (tcref1, l1, _), TType_app (tcref2, l2, _) when tyconRefEq g tcref1 tcref2 ->
List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2
| TType_anon (anonInfo1, l1),TType_anon (anonInfo2, l2) ->
@ -76,9 +77,9 @@ let rec TypesFeasiblyEquivalent stripMeasures ndeep g amap m ty1 ty2 =
evalTupInfoIsStruct tupInfo1 = evalTupInfoIsStruct tupInfo2 &&
List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2
| TType_fun (d1, r1, _), TType_fun (d2, r2, _) ->
TypesFeasiblyEquivalent stripMeasures ndeep g amap m d1 d2 &&
TypesFeasiblyEquivalent stripMeasures ndeep g amap m r1 r2
| TType_fun (domainTy1, rangeTy1, _), TType_fun (domainTy2, rangeTy2, _) ->
TypesFeasiblyEquivalent stripMeasures ndeep g amap m domainTy1 domainTy2 &&
TypesFeasiblyEquivalent stripMeasures ndeep g amap m rangeTy1 rangeTy2
| TType_measure _, TType_measure _ ->
true
@ -133,51 +134,51 @@ let rec TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce ty2 =
/// Here x gets a generalized type "list<'T>".
let ChooseTyparSolutionAndRange (g: TcGlobals) amap (tp:Typar) =
let m = tp.Range
let max, m =
let initial =
let maxTy, m =
let initialTy =
match tp.Kind with
| TyparKind.Type -> g.obj_ty
| TyparKind.Measure -> TType_measure Measure.One
// Loop through the constraints computing the lub
((initial, m), tp.Constraints) ||> List.fold (fun (maxSoFar, _) tpc ->
((initialTy, m), tp.Constraints) ||> List.fold (fun (maxTy, _) tpc ->
let join m x =
if TypeFeasiblySubsumesType 0 g amap m x CanCoerce maxSoFar then maxSoFar
elif TypeFeasiblySubsumesType 0 g amap m maxSoFar CanCoerce x then x
else errorR(Error(FSComp.SR.typrelCannotResolveImplicitGenericInstantiation((DebugPrint.showType x), (DebugPrint.showType maxSoFar)), m)); maxSoFar
if TypeFeasiblySubsumesType 0 g amap m x CanCoerce maxTy then maxTy
elif TypeFeasiblySubsumesType 0 g amap m maxTy CanCoerce x then x
else errorR(Error(FSComp.SR.typrelCannotResolveImplicitGenericInstantiation((DebugPrint.showType x), (DebugPrint.showType maxTy)), m)); maxTy
// Don't continue if an error occurred and we set the value eagerly
if tp.IsSolved then maxSoFar, m else
if tp.IsSolved then maxTy, m else
match tpc with
| TyparConstraint.CoercesTo(x, m) ->
join m x, m
| TyparConstraint.MayResolveMember(_traitInfo, m) ->
maxSoFar, m
maxTy, m
| TyparConstraint.SimpleChoice(_, m) ->
errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInPrintf(), m))
maxSoFar, m
maxTy, m
| TyparConstraint.SupportsNull m ->
maxSoFar, m
maxTy, m
| TyparConstraint.SupportsComparison m ->
join m g.mk_IComparable_ty, m
| TyparConstraint.SupportsEquality m ->
maxSoFar, m
maxTy, m
| TyparConstraint.IsEnum(_, m) ->
errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInEnum(), m))
maxSoFar, m
maxTy, m
| TyparConstraint.IsDelegate(_, _, m) ->
errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInDelegate(), m))
maxSoFar, m
maxTy, m
| TyparConstraint.IsNonNullableStruct m ->
join m g.int_ty, m
| TyparConstraint.IsUnmanaged m ->
errorR(Error(FSComp.SR.typrelCannotResolveAmbiguityInUnmanaged(), m))
maxSoFar, m
maxTy, m
| TyparConstraint.RequiresDefaultConstructor m ->
maxSoFar, m
maxTy, m
| TyparConstraint.IsReferenceType m ->
maxSoFar, m
maxTy, m
| TyparConstraint.DefaultsTo(_priority, _ty, m) ->
maxSoFar, m)
max, m
maxTy, m)
maxTy, m
let ChooseTyparSolution g amap tp =
let ty, _m = ChooseTyparSolutionAndRange g amap tp
@ -227,9 +228,11 @@ let ChooseTyparSolutionsForFreeChoiceTypars g amap e =
| _ -> e
/// Break apart lambdas. Needs ChooseTyparSolutionsForFreeChoiceTypars because it's used in
/// Break apart lambdas according to a given expected ValReprInfo that the lambda implements.
/// Needs ChooseTyparSolutionsForFreeChoiceTypars because it's used in
/// PostTypeCheckSemanticChecks before we've eliminated these nodes.
let tryDestTopLambda g amap (ValReprInfo (tpNames, _, _) as tvd) (e, ty) =
let tryDestLambdaWithValReprInfo g amap valReprInfo (lambdaExpr, ty) =
let (ValReprInfo (tpNames, _, _)) = valReprInfo
let rec stripLambdaUpto n (e, ty) =
match stripDebugPoints e with
| Expr.Lambda (_, None, None, v, b, _, retTy) when n > 0 ->
@ -248,20 +251,23 @@ let tryDestTopLambda g amap (ValReprInfo (tpNames, _, _) as tvd) (e, ty) =
| _ ->
(None, None, [], e, ty)
let n = tvd.NumCurriedArgs
let tps, taue, tauty =
match stripDebugPoints e with
let n = valReprInfo.NumCurriedArgs
let tps, bodyExpr, bodyTy =
match stripDebugPoints lambdaExpr with
| Expr.TyLambda (_, tps, b, _, retTy) when not (isNil tpNames) -> tps, b, retTy
| _ -> [], e, ty
let ctorThisValOpt, baseValOpt, vsl, body, retTy = startStripLambdaUpto n (taue, tauty)
| _ -> [], lambdaExpr, ty
let ctorThisValOpt, baseValOpt, vsl, body, retTy = startStripLambdaUpto n (bodyExpr, bodyTy)
if vsl.Length <> n then
None
else
Some (tps, ctorThisValOpt, baseValOpt, vsl, body, retTy)
let destTopLambda g amap topValInfo (e, ty) =
match tryDestTopLambda g amap topValInfo (e, ty) with
| None -> error(Error(FSComp.SR.typrelInvalidValue(), e.Range))
let destLambdaWithValReprInfo g amap valReprInfo (lambdaExpr, ty) =
match tryDestLambdaWithValReprInfo g amap valReprInfo (lambdaExpr, ty) with
| None -> error(Error(FSComp.SR.typrelInvalidValue(), lambdaExpr.Range))
| Some res -> res
let IteratedAdjustArityOfLambdaBody g arities vsl body =
@ -269,16 +275,22 @@ let IteratedAdjustArityOfLambdaBody g arities vsl body =
let vs, body = AdjustArityOfLambdaBody g arities vs body
vs :: allvs, body)
/// Do AdjustArityOfLambdaBody for a series of
/// iterated lambdas, producing one method.
/// The required iterated function arity (List.length topValInfo) must be identical
/// Do IteratedAdjustArityOfLambdaBody for a series of iterated lambdas, producing one method.
/// The required iterated function arity (List.length valReprInfo) must be identical
/// to the iterated function arity of the input lambda (List.length vsl)
let IteratedAdjustArityOfLambda g amap topValInfo e =
let tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destTopLambda g amap topValInfo (e, tyOfExpr g e)
let arities = topValInfo.AritiesOfArgs
let IteratedAdjustLambdaToMatchValReprInfo g amap valReprInfo lambdaExpr =
let lambdaExprTy = tyOfExpr g lambdaExpr
let tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy = destLambdaWithValReprInfo g amap valReprInfo (lambdaExpr, lambdaExprTy)
let arities = valReprInfo.AritiesOfArgs
if arities.Length <> vsl.Length then
errorR(InternalError(sprintf "IteratedAdjustArityOfLambda, List.length arities = %d, List.length vsl = %d" arities.Length vsl.Length, body.Range))
errorR(InternalError(sprintf "IteratedAdjustLambdaToMatchValReprInfo, #arities = %d, #vsl = %d" arities.Length vsl.Length, body.Range))
let vsl, body = IteratedAdjustArityOfLambdaBody g arities vsl body
tps, ctorThisValOpt, baseValOpt, vsl, body, bodyTy
/// "Single Feasible Type" inference
@ -286,5 +298,3 @@ let IteratedAdjustArityOfLambda g amap topValInfo e =
let FindUniqueFeasibleSupertype g amap m ty1 ty2 =
let supertypes = Option.toList (GetSuperTypeOfType g amap m ty2) @ (GetImmediateInterfacesOfType SkipUnrefInterfaces.Yes g amap m ty2)
supertypes |> List.tryFind (TypeFeasiblySubsumesType 0 g amap m ty1 NoCoerce)

26
src/Compiler/Checking/TypeRelations.fsi
Просмотреть файл

@ -51,30 +51,28 @@ val IterativelySubstituteTyparSolutions: g: TcGlobals -> tps: Typars -> solution
val ChooseTyparSolutionsForFreeChoiceTypars: g: TcGlobals -> amap: ImportMap -> e: Expr -> Expr
/// Break apart lambdas. Needs ChooseTyparSolutionsForFreeChoiceTypars because it's used in
/// PostTypeCheckSemanticChecks before we've eliminated these nodes.
val tryDestTopLambda:
/// Break apart lambdas according to a given expected ValReprInfo that the lambda implements.
val tryDestLambdaWithValReprInfo:
g: TcGlobals ->
amap: ImportMap ->
ValReprInfo ->
e: Expr * ty: TType ->
valReprInfo: ValReprInfo ->
lambdaExpr: Expr * ty: TType ->
(Typars * Val option * Val option * Val list list * Expr * TType) option
val destTopLambda:
/// Break apart lambdas according to a given expected ValReprInfo that the lambda implements.
val destLambdaWithValReprInfo:
g: TcGlobals ->
amap: ImportMap ->
topValInfo: ValReprInfo ->
e: Expr * ty: TType ->
valReprInfo: ValReprInfo ->
lambdaExpr: Expr * ty: TType ->
Typars * Val option * Val option * Val list list * Expr * TType
/// Do AdjustArityOfLambdaBody for a series of iterated lambdas, producing one method.
/// The required iterated function arity (List.length topValInfo) must be identical
/// to the iterated function arity of the input lambda (List.length vsl)
val IteratedAdjustArityOfLambda:
/// Adjust a lambda expression to match the argument counts expected in the ValReprInfo
val IteratedAdjustLambdaToMatchValReprInfo:
g: TcGlobals ->
amap: ImportMap ->
topValInfo: ValReprInfo ->
e: Expr ->
valReprInfo: ValReprInfo ->
lambdaExpr: Expr ->
Typars * Val option * Val option * Val list list * Expr * TType
/// "Single Feasible Type" inference

10
src/Compiler/Checking/import.fs
Просмотреть файл

@ -174,8 +174,8 @@ let rec ImportILType (env: ImportMap) m tinst ty =
| ILType.Array(bounds, ty) ->
let n = bounds.Rank
let elementType = ImportILType env m tinst ty
mkArrayTy env.g n elementType m
let elemTy = ImportILType env m tinst ty
mkArrayTy env.g n elemTy m
| ILType.Boxed tspec | ILType.Value tspec ->
let tcref = ImportILTypeRef env m tspec.TypeRef
@ -335,10 +335,10 @@ let rec ImportProvidedType (env: ImportMap) (m: range) (* (tinst: TypeInst) *) (
if tp.Kind = TyparKind.Measure then
let rec conv ty =
match ty with
| TType_app (tcref, [t1;t2], _) when tyconRefEq g tcref g.measureproduct_tcr -> Measure.Prod (conv t1, conv t2)
| TType_app (tcref, [t1], _) when tyconRefEq g tcref g.measureinverse_tcr -> Measure.Inv (conv t1)
| TType_app (tcref, [ty1;ty2], _) when tyconRefEq g tcref g.measureproduct_tcr -> Measure.Prod (conv ty1, conv ty2)
| TType_app (tcref, [ty1], _) when tyconRefEq g tcref g.measureinverse_tcr -> Measure.Inv (conv ty1)
| TType_app (tcref, [], _) when tyconRefEq g tcref g.measureone_tcr -> Measure.One
| TType_app (tcref, [], _) when tcref.TypeOrMeasureKind = TyparKind.Measure -> Measure.Con tcref
| TType_app (tcref, [], _) when tcref.TypeOrMeasureKind = TyparKind.Measure -> Measure.Const tcref
| TType_app (tcref, _, _) ->
errorR(Error(FSComp.SR.impInvalidMeasureArgument1(tcref.CompiledName, tp.Name), m))
Measure.One

270
src/Compiler/Checking/infos.fs
Просмотреть файл

@ -22,6 +22,8 @@ open FSharp.Compiler.Xml
#if !NO_TYPEPROVIDERS
open FSharp.Compiler.TypeProviders
open FSharp.Compiler.AbstractIL
#endif
//-------------------------------------------------------------------------
@ -55,7 +57,7 @@ type ValRef with
| Some membInfo ->
not membInfo.MemberFlags.IsDispatchSlot &&
(match membInfo.ImplementedSlotSigs with
| TSlotSig(_, oty, _, _, _, _) :: _ -> isInterfaceTy g oty
| slotSig :: _ -> isInterfaceTy g slotSig.DeclaringType
| [] -> false)
member vref.ImplementedSlotSignatures =
@ -116,14 +118,14 @@ let private AnalyzeTypeOfMemberVal isCSharpExt g (ty, vref: ValRef) =
/// Get the object type for a member value which is an extension method (C#-style or F#-style)
let private GetObjTypeOfInstanceExtensionMethod g (vref: ValRef) =
let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal vref.Deref
let _, _, curriedArgInfos, _, _ = GetTopValTypeInCompiledForm g vref.ValReprInfo.Value numEnclosingTypars vref.Type vref.Range
let _, _, curriedArgInfos, _, _ = GetValReprTypeInCompiledForm g vref.ValReprInfo.Value numEnclosingTypars vref.Type vref.Range
curriedArgInfos.Head.Head |> fst
/// Get the object type for a member value, which might be a C#-style extension method
let private GetArgInfosOfMember isCSharpExt g (vref: ValRef) =
if isCSharpExt then
let numEnclosingTypars = CountEnclosingTyparsOfActualParentOfVal vref.Deref
let _, _, curriedArgInfos, _, _ = GetTopValTypeInCompiledForm g vref.ValReprInfo.Value numEnclosingTypars vref.Type vref.Range
let _, _, curriedArgInfos, _, _ = GetValReprTypeInCompiledForm g vref.ValReprInfo.Value numEnclosingTypars vref.Type vref.Range
[ curriedArgInfos.Head.Tail ]
else
ArgInfosOfMember g vref
@ -152,6 +154,11 @@ let private GetInstantiationForPropertyVal g (ty, vref) =
let memberParentTypars, memberMethodTypars, _retTy, parentTyArgs = AnalyzeTypeOfMemberVal false g (ty, vref)
CombineMethInsts memberParentTypars memberMethodTypars parentTyArgs (generalizeTypars memberMethodTypars)
let private HasExternalInit (mref: ILMethodRef) : bool =
match mref.ReturnType with
| ILType.Modified(_, cls, _) -> cls.FullName = "System.Runtime.CompilerServices.IsExternalInit"
| _ -> false
/// Describes the sequence order of the introduction of an extension method. Extension methods that are introduced
/// later through 'open' get priority in overload resolution.
type ExtensionMethodPriority = uint64
@ -266,6 +273,70 @@ type ParamData =
reflArgInfo: ReflectedArgInfo *
ttype: TType
type ParamAttribs = ParamAttribs of isParamArrayArg: bool * isInArg: bool * isOutArg: bool * optArgInfo: OptionalArgInfo * callerInfo: CallerInfo * reflArgInfo: ReflectedArgInfo
let CrackParamAttribsInfo g (ty: TType, argInfo: ArgReprInfo) =
let isParamArrayArg = HasFSharpAttribute g g.attrib_ParamArrayAttribute argInfo.Attribs
let reflArgInfo =
match TryFindFSharpBoolAttributeAssumeFalse g g.attrib_ReflectedDefinitionAttribute argInfo.Attribs with
| Some b -> ReflectedArgInfo.Quote b
| None -> ReflectedArgInfo.None
let isOutArg = (HasFSharpAttribute g g.attrib_OutAttribute argInfo.Attribs && isByrefTy g ty) || isOutByrefTy g ty
let isInArg = (HasFSharpAttribute g g.attrib_InAttribute argInfo.Attribs && isByrefTy g ty) || isInByrefTy g ty
let isCalleeSideOptArg = HasFSharpAttribute g g.attrib_OptionalArgumentAttribute argInfo.Attribs
let isCallerSideOptArg = HasFSharpAttributeOpt g g.attrib_OptionalAttribute argInfo.Attribs
let optArgInfo =
if isCalleeSideOptArg then
CalleeSide
elif isCallerSideOptArg then
let defaultParameterValueAttribute = TryFindFSharpAttributeOpt g g.attrib_DefaultParameterValueAttribute argInfo.Attribs
match defaultParameterValueAttribute with
| None ->
// Do a type-directed analysis of the type to determine the default value to pass.
// Similar rules as OptionalArgInfo.FromILParameter are applied here, except for the COM and byref-related stuff.
CallerSide (if isObjTy g ty then MissingValue else DefaultValue)
| Some attr ->
let defaultValue = OptionalArgInfo.ValueOfDefaultParameterValueAttrib attr
match defaultValue with
| Some (Expr.Const (_, m, ty2)) when not (typeEquiv g ty2 ty) ->
// the type of the default value does not match the type of the argument.
// Emit a warning, and ignore the DefaultParameterValue argument altogether.
warning(Error(FSComp.SR.DefaultParameterValueNotAppropriateForArgument(), m))
NotOptional
| Some (Expr.Const (ConstToILFieldInit fi, _, _)) ->
// Good case - all is well.
CallerSide (Constant fi)
| _ ->
// Default value is not appropriate, i.e. not a constant.
// Compiler already gives an error in that case, so just ignore here.
NotOptional
else NotOptional
let isCallerLineNumberArg = HasFSharpAttribute g g.attrib_CallerLineNumberAttribute argInfo.Attribs
let isCallerFilePathArg = HasFSharpAttribute g g.attrib_CallerFilePathAttribute argInfo.Attribs
let isCallerMemberNameArg = HasFSharpAttribute g g.attrib_CallerMemberNameAttribute argInfo.Attribs
let callerInfo =
match isCallerLineNumberArg, isCallerFilePathArg, isCallerMemberNameArg with
| false, false, false -> NoCallerInfo
| true, false, false -> CallerLineNumber
| false, true, false -> CallerFilePath
| false, false, true -> CallerMemberName
| false, true, true ->
match TryFindFSharpAttribute g g.attrib_CallerMemberNameAttribute argInfo.Attribs with
| Some(Attrib(_, _, _, _, _, _, callerMemberNameAttributeRange)) ->
warning(Error(FSComp.SR.CallerMemberNameIsOverriden(argInfo.Name.Value.idText), callerMemberNameAttributeRange))
CallerFilePath
| _ -> failwith "Impossible"
| _, _, _ ->
// if multiple caller info attributes are specified, pick the "wrong" one here
// so that we get an error later
match tryDestOptionTy g ty with
| ValueSome optTy when typeEquiv g g.int32_ty optTy -> CallerFilePath
| _ -> CallerLineNumber
ParamAttribs(isParamArrayArg, isInArg, isOutArg, optArgInfo, callerInfo, reflArgInfo)
#if !NO_TYPEPROVIDERS
type ILFieldInit with
@ -312,8 +383,8 @@ let OptionalArgInfoOfProvidedParameter (amap: ImportMap) m (provParam : Tainted<
elif isObjTy g ty then MissingValue
else DefaultValue
let pty = ImportProvidedType amap m (provParam.PApply((fun p -> p.ParameterType), m))
CallerSide (analyze pty)
let paramTy = ImportProvidedType amap m (provParam.PApply((fun p -> p.ParameterType), m))
CallerSide (analyze paramTy)
| _ ->
let v = provParam.PUntaint((fun p -> p.RawDefaultValue), m)
CallerSide (Constant (ILFieldInit.FromProvidedObj m v))
@ -589,7 +660,7 @@ type MethInfo =
member x.DeclaringTyconRef =
match x with
| ILMeth(_, ilminfo, _) when x.IsExtensionMember -> ilminfo.DeclaringTyconRef
| FSMeth(_, _, vref, _) when x.IsExtensionMember && vref.HasDeclaringEntity -> vref.TopValDeclaringEntity
| FSMeth(_, _, vref, _) when x.IsExtensionMember && vref.HasDeclaringEntity -> vref.DeclaringEntity
| _ -> x.ApparentEnclosingTyconRef
/// Get the information about provided static parameters, if any
@ -625,8 +696,9 @@ type MethInfo =
/// Get the method name in DebuggerDisplayForm
member x.DebuggerDisplayName =
match x with
| ILMeth(_, y, _) -> "ILMeth: " + y.ILName
| FSMeth(_, _, vref, _) -> "FSMeth: " + vref.LogicalName
| ILMeth(_, y, _) -> y.DeclaringTyconRef.DisplayNameWithStaticParametersAndUnderscoreTypars + "::" + y.ILName
| FSMeth(_, AbbrevOrAppTy tcref, vref, _) -> tcref.DisplayNameWithStaticParametersAndUnderscoreTypars + "::" + vref.LogicalName
| FSMeth(_, _, vref, _) -> "??::" + vref.LogicalName
#if !NO_TYPEPROVIDERS
| ProvidedMeth(_, mi, _, m) -> "ProvidedMeth: " + mi.PUntaint((fun mi -> mi.Name), m)
#endif
@ -646,13 +718,13 @@ type MethInfo =
member x.DisplayName =
match x with
| FSMeth(_, _, vref, _) -> vref.DisplayName
| _ -> x.LogicalName |> PrettyNaming.ConvertValNameToDisplayName false
| _ -> x.LogicalName |> PrettyNaming.ConvertValLogicalNameToDisplayName false
/// Get the method name in DisplayName form
member x.DisplayNameCore =
match x with
| FSMeth(_, _, vref, _) -> vref.DisplayNameCore
| _ -> x.LogicalName |> PrettyNaming.DecompileOpName
| _ -> x.LogicalName |> PrettyNaming.ConvertValLogicalNameToDisplayNameCore
/// Indicates if this is a method defined in this assembly with an internal XML comment
member x.HasDirectXmlComment =
@ -663,7 +735,7 @@ type MethInfo =
#endif
| _ -> false
override x.ToString() = x.ApparentEnclosingType.ToString() + x.LogicalName
override x.ToString() = x.ApparentEnclosingType.ToString() + "::" + x.LogicalName
/// Get the actual type instantiation of the declaring type associated with this use of the method.
///
@ -933,6 +1005,12 @@ type MethInfo =
| FSMeth _ -> false // F# defined methods not supported yet. Must be a language feature.
| _ -> false
/// Indicates, wheter this method has `IsExternalInit` modreq.
member x.HasExternalInit =
match x with
| ILMeth (_, ilMethInfo, _) -> HasExternalInit ilMethInfo.ILMethodRef
| _ -> false
/// Indicates if this method is an extension member that is read-only.
/// An extension member is considered read-only if the first argument is a read-only byref (inref) type.
member x.IsReadOnlyExtensionMember (amap: ImportMap, m) =
@ -1053,6 +1131,12 @@ type MethInfo =
else []
#endif
/// Get custom attributes for method (only applicable for IL methods)
member x.GetCustomAttrs() =
match x with
| ILMeth(_, ilMethInfo, _) -> ilMethInfo.RawMetadata.CustomAttrs
| _ -> ILAttributes.Empty
/// Get the parameter attributes of a method info, which get combined with the parameter names and types
member x.GetParamAttribs(amap, m) =
match x with
@ -1086,72 +1170,11 @@ type MethInfo =
if p.Type.TypeRef.FullName = "System.Int32" then CallerFilePath
else CallerLineNumber
yield (isParamArrayArg, isInArg, isOutArg, optArgInfo, callerInfo, reflArgInfo) ] ]
ParamAttribs(isParamArrayArg, isInArg, isOutArg, optArgInfo, callerInfo, reflArgInfo) ] ]
| FSMeth(g, _, vref, _) ->
GetArgInfosOfMember x.IsCSharpStyleExtensionMember g vref
|> List.mapSquared (fun (ty, argInfo) ->
let isParamArrayArg = HasFSharpAttribute g g.attrib_ParamArrayAttribute argInfo.Attribs
let reflArgInfo =
match TryFindFSharpBoolAttributeAssumeFalse g g.attrib_ReflectedDefinitionAttribute argInfo.Attribs with
| Some b -> ReflectedArgInfo.Quote b
| None -> ReflectedArgInfo.None
let isOutArg = (HasFSharpAttribute g g.attrib_OutAttribute argInfo.Attribs && isByrefTy g ty) || isOutByrefTy g ty
let isInArg = (HasFSharpAttribute g g.attrib_InAttribute argInfo.Attribs && isByrefTy g ty) || isInByrefTy g ty
let isCalleeSideOptArg = HasFSharpAttribute g g.attrib_OptionalArgumentAttribute argInfo.Attribs
let isCallerSideOptArg = HasFSharpAttributeOpt g g.attrib_OptionalAttribute argInfo.Attribs
let optArgInfo =
if isCalleeSideOptArg then
CalleeSide
elif isCallerSideOptArg then
let defaultParameterValueAttribute = TryFindFSharpAttributeOpt g g.attrib_DefaultParameterValueAttribute argInfo.Attribs
match defaultParameterValueAttribute with
| None ->
// Do a type-directed analysis of the type to determine the default value to pass.
// Similar rules as OptionalArgInfo.FromILParameter are applied here, except for the COM and byref-related stuff.
CallerSide (if isObjTy g ty then MissingValue else DefaultValue)
| Some attr ->
let defaultValue = OptionalArgInfo.ValueOfDefaultParameterValueAttrib attr
match defaultValue with
| Some (Expr.Const (_, m, ty2)) when not (typeEquiv g ty2 ty) ->
// the type of the default value does not match the type of the argument.
// Emit a warning, and ignore the DefaultParameterValue argument altogether.
warning(Error(FSComp.SR.DefaultParameterValueNotAppropriateForArgument(), m))
NotOptional
| Some (Expr.Const (ConstToILFieldInit fi, _, _)) ->
// Good case - all is well.
CallerSide (Constant fi)
| _ ->
// Default value is not appropriate, i.e. not a constant.
// Compiler already gives an error in that case, so just ignore here.
NotOptional
else NotOptional
let isCallerLineNumberArg = HasFSharpAttribute g g.attrib_CallerLineNumberAttribute argInfo.Attribs
let isCallerFilePathArg = HasFSharpAttribute g g.attrib_CallerFilePathAttribute argInfo.Attribs
let isCallerMemberNameArg = HasFSharpAttribute g g.attrib_CallerMemberNameAttribute argInfo.Attribs
let callerInfo =
match isCallerLineNumberArg, isCallerFilePathArg, isCallerMemberNameArg with
| false, false, false -> NoCallerInfo
| true, false, false -> CallerLineNumber
| false, true, false -> CallerFilePath
| false, false, true -> CallerMemberName
| false, true, true ->
match TryFindFSharpAttribute g g.attrib_CallerMemberNameAttribute argInfo.Attribs with
| Some(Attrib(_, _, _, _, _, _, callerMemberNameAttributeRange)) ->
warning(Error(FSComp.SR.CallerMemberNameIsOverriden(argInfo.Name.Value.idText), callerMemberNameAttributeRange))
CallerFilePath
| _ -> failwith "Impossible"
| _, _, _ ->
// if multiple caller info attributes are specified, pick the "wrong" one here
// so that we get an error later
match tryDestOptionTy g ty with
| ValueSome optTy when typeEquiv g g.int32_ty optTy -> CallerFilePath
| _ -> CallerLineNumber
(isParamArrayArg, isInArg, isOutArg, optArgInfo, callerInfo, reflArgInfo))
|> List.mapSquared (CrackParamAttribsInfo g)
| DefaultStructCtor _ ->
[[]]
@ -1168,7 +1191,7 @@ type MethInfo =
| None -> ReflectedArgInfo.None
let isOutArg = p.PUntaint((fun p -> p.IsOut && not p.IsIn), m)
let isInArg = p.PUntaint((fun p -> p.IsIn && not p.IsOut), m)
yield (isParamArrayArg, isInArg, isOutArg, optArgInfo, NoCallerInfo, reflArgInfo)] ]
ParamAttribs(isParamArrayArg, isInArg, isOutArg, optArgInfo, NoCallerInfo, reflArgInfo)] ]
#endif
/// Get the signature of an abstract method slot.
@ -1205,9 +1228,9 @@ type MethInfo =
// REVIEW: should we copy down attributes to slot params?
let tcref = tcrefOfAppTy g x.ApparentEnclosingAppType
let formalEnclosingTyparsOrig = tcref.Typars m
let formalEnclosingTypars = copyTypars formalEnclosingTyparsOrig
let formalEnclosingTypars = copyTypars false formalEnclosingTyparsOrig
let _, formalEnclosingTyparTys = FixupNewTypars m [] [] formalEnclosingTyparsOrig formalEnclosingTypars
let formalMethTypars = copyTypars x.FormalMethodTypars
let formalMethTypars = copyTypars false x.FormalMethodTypars
let _, formalMethTyparTys = FixupNewTypars m formalEnclosingTypars formalEnclosingTyparTys x.FormalMethodTypars formalMethTypars
let formalRetTy, formalParams =
@ -1217,8 +1240,8 @@ type MethInfo =
let formalRetTy = ImportReturnTypeFromMetadata amap m ilminfo.RawMetadata.Return.Type (fun _ -> ilminfo.RawMetadata.Return.CustomAttrs) ftinfo.ILScopeRef ftinfo.TypeInstOfRawMetadata formalMethTyparTys
let formalParams =
[ [ for p in ilminfo.RawMetadata.Parameters do
let paramType = ImportILTypeFromMetadataWithAttributes amap m ftinfo.ILScopeRef ftinfo.TypeInstOfRawMetadata formalMethTyparTys p.Type (fun _ -> p.CustomAttrs)
yield TSlotParam(p.Name, paramType, p.IsIn, p.IsOut, p.IsOptional, []) ] ]
let paramTy = ImportILTypeFromMetadataWithAttributes amap m ftinfo.ILScopeRef ftinfo.TypeInstOfRawMetadata formalMethTyparTys p.Type (fun _ -> p.CustomAttrs)
yield TSlotParam(p.Name, paramTy, p.IsIn, p.IsOut, p.IsOptional, []) ] ]
formalRetTy, formalParams
#if !NO_TYPEPROVIDERS
| ProvidedMeth (_, mi, _, _) ->
@ -1230,9 +1253,9 @@ type MethInfo =
let formalParams =
[ [ for p in mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters", m) do
let paramName = p.PUntaint((fun p -> match p.Name with null -> None | s -> Some s), m)
let paramType = ImportProvidedType amap m (p.PApply((fun p -> p.ParameterType), m))
let paramTy = ImportProvidedType amap m (p.PApply((fun p -> p.ParameterType), m))
let isIn, isOut, isOptional = p.PUntaint((fun p -> p.IsIn, p.IsOut, p.IsOptional), m)
yield TSlotParam(paramName, paramType, isIn, isOut, isOptional, []) ] ]
yield TSlotParam(paramName, paramTy, isIn, isOut, isOptional, []) ] ]
formalRetTy, formalParams
#endif
| _ -> failwith "unreachable"
@ -1256,20 +1279,21 @@ type MethInfo =
| ProvidedMeth(amap, mi, _, _) ->
// A single set of tupled parameters
[ [for p in mi.PApplyArray((fun mi -> mi.GetParameters()), "GetParameters", m) do
let pname =
let paramName =
match p.PUntaint((fun p -> p.Name), m) with
| null -> None
| name -> Some (mkSynId m name)
let pty =
let paramTy =
match p.PApply((fun p -> p.ParameterType), m) with
| Tainted.Null -> amap.g.unit_ty
| parameterType -> ImportProvidedType amap m parameterType
yield ParamNameAndType(pname, pty) ] ]
yield ParamNameAndType(paramName, paramTy) ] ]
#endif
let paramAttribs = x.GetParamAttribs(amap, m)
(paramAttribs, paramNamesAndTypes) ||> List.map2 (List.map2 (fun (isParamArrayArg, isInArg, isOutArg, optArgInfo, callerInfo, reflArgInfo) (ParamNameAndType(nmOpt, pty)) ->
(paramAttribs, paramNamesAndTypes) ||> List.map2 (List.map2 (fun info (ParamNameAndType(nmOpt, pty)) ->
let (ParamAttribs(isParamArrayArg, isInArg, isOutArg, optArgInfo, callerInfo, reflArgInfo)) = info
ParamData(isParamArrayArg, isInArg, isOutArg, optArgInfo, callerInfo, nmOpt, reflArgInfo, pty)))
/// Get the ParamData objects for the parameters of a MethInfo
@ -1358,6 +1382,8 @@ type ILFieldInfo =
| ProvidedField(_, fi, m) -> fi.PUntaint((fun fi -> fi.Name), m)
#endif
member x.DisplayNameCore = x.FieldName
/// Indicates if the field is readonly (in the .NET/C# sense of readonly)
member x.IsInitOnly =
match x with
@ -1504,14 +1530,14 @@ type UnionCaseInfo =
///
/// Backticks and parens are not added for non-identifiers.
///
/// Note logical names op_Nil and op_ConsCons become [] and :: respectively.
/// Note logical names op_Nil and op_ColonColon become [] and :: respectively.
member x.DisplayNameCore = x.UnionCase.DisplayNameCore
/// Get the display name of the union case
///
/// Backticks and parens are added implicitly for non-identifiers.
///
/// Note logical names op_Nil and op_ConsCons become ([]) and (::) respectively.
/// Note logical names op_Nil and op_ColonColon become ([]) and (::) respectively.
member x.DisplayName = x.UnionCase.DisplayName
/// Get the instantiation of the type parameters of the declaring type of the union case
@ -1562,6 +1588,10 @@ type ILPropInfo =
/// Indicates if the IL property has a 'set' method
member x.HasSetter = Option.isSome x.RawMetadata.SetMethod
/// Indidcates whether IL property has an init-only setter (i.e. has the `System.Runtime.CompilerServices.IsExternalInit` modifer)
member x.IsSetterInitOnly =
x.HasSetter && HasExternalInit x.SetterMethod.ILMethodRef
/// Indicates if the IL property is static
member x.IsStatic = (x.RawMetadata.CallingConv = ILThisConvention.Static)
@ -1575,6 +1605,9 @@ type ILPropInfo =
(x.HasGetter && x.GetterMethod.IsNewSlot) ||
(x.HasSetter && x.SetterMethod.IsNewSlot)
/// Indicates if the property is required, i.e. has RequiredMemberAttribute applied.
member x.IsRequired = TryFindILAttribute x.TcGlobals.attrib_RequiredMemberAttribute x.RawMetadata.CustomAttrs
/// Get the names and types of the indexer arguments associated with the IL property.
///
/// Any type parameters of the enclosing type are instantiated in the type returned.
@ -1638,7 +1671,7 @@ type PropInfo =
/// holding the value for the extension method.
member x.DeclaringTyconRef =
match x.ArbitraryValRef with
| Some vref when x.IsExtensionMember && vref.HasDeclaringEntity -> vref.TopValDeclaringEntity
| Some vref when x.IsExtensionMember && vref.HasDeclaringEntity -> vref.DeclaringEntity
| _ -> x.ApparentEnclosingTyconRef
/// Try to get an arbitrary F# ValRef associated with the member. This is to determine if the member is virtual, amongst other things.
@ -1670,6 +1703,20 @@ type PropInfo =
#endif
| FSProp _ -> failwith "unreachable"
/// Get the property name in DisplayName form
member x.DisplayName =
match x with
| FSProp(_, _, Some vref, _)
| FSProp(_, _, _, Some vref) -> vref.DisplayName
| _ -> x.PropertyName |> PrettyNaming.ConvertValLogicalNameToDisplayName false
/// Get the property name in DisplayNameCore form
member x.DisplayNameCore =
match x with
| FSProp(_, _, Some vref, _)
| FSProp(_, _, _, Some vref) -> vref.DisplayNameCore
| _ -> x.PropertyName |> PrettyNaming.ConvertValLogicalNameToDisplayNameCore
/// Indicates if this property has an associated getter method.
member x.HasGetter =
match x with
@ -1688,6 +1735,22 @@ type PropInfo =
| ProvidedProp(_, pi, m) -> pi.PUntaint((fun pi -> pi.CanWrite), m)
#endif
member x.IsSetterInitOnly =
match x with
| ILProp ilpinfo -> ilpinfo.IsSetterInitOnly
| FSProp _ -> false
#if !NO_TYPEPROVIDERS
| ProvidedProp _ -> false
#endif
member x.IsRequired =
match x with
| ILProp ilpinfo -> ilpinfo.IsRequired
| FSProp _ -> false
#if !NO_TYPEPROVIDERS
| ProvidedProp _ -> false
#endif
/// Indicates if this is an extension member
member x.IsExtensionMember =
match x.ArbitraryValRef with
@ -1866,14 +1929,14 @@ type PropInfo =
| ProvidedProp (_, pi, m) ->
[ for p in pi.PApplyArray((fun pi -> pi.GetIndexParameters()), "GetIndexParameters", m) do
let paramName = p.PUntaint((fun p -> match p.Name with null -> None | s -> Some (mkSynId m s)), m)
let paramType = ImportProvidedType amap m (p.PApply((fun p -> p.ParameterType), m))
yield ParamNameAndType(paramName, paramType) ]
let paramTy = ImportProvidedType amap m (p.PApply((fun p -> p.ParameterType), m))
yield ParamNameAndType(paramName, paramTy) ]
#endif
/// Get the details of the indexer parameters associated with the property
member x.GetParamDatas(amap, m) =
x.GetParamNamesAndTypes(amap, m)
|> List.map (fun (ParamNameAndType(nmOpt, pty)) -> ParamData(false, false, false, NotOptional, NoCallerInfo, nmOpt, ReflectedArgInfo.None, pty))
|> List.map (fun (ParamNameAndType(nmOpt, paramTy)) -> ParamData(false, false, false, NotOptional, NoCallerInfo, nmOpt, ReflectedArgInfo.None, paramTy))
/// Get the types of the indexer parameters associated with the property
member x.GetParamTypes(amap, m) =
@ -1908,14 +1971,16 @@ type PropInfo =
/// Uses the same techniques as 'MethInfosUseIdenticalDefinitions'.
/// Must be compatible with ItemsAreEffectivelyEqual relation.
static member PropInfosUseIdenticalDefinitions x1 x2 =
let optVrefEq g = function
| Some v1, Some v2 -> valRefEq g v1 v2
| Some vref1, Some vref2 -> valRefEq g vref1 vref2
| None, None -> true
| _ -> false
match x1, x2 with
| ILProp ilpinfo1, ILProp ilpinfo2 -> (ilpinfo1.RawMetadata === ilpinfo2.RawMetadata)
| FSProp(g, _, vrefa1, vrefb1), FSProp(_, _, vrefa2, vrefb2) ->
(optVrefEq g (vrefa1, vrefa2)) && (optVrefEq g (vrefb1, vrefb2))
optVrefEq g (vrefa1, vrefa2) && optVrefEq g (vrefb1, vrefb2)
#if !NO_TYPEPROVIDERS
| ProvidedProp(_, pi1, _), ProvidedProp(_, pi2, _) -> ProvidedPropertyInfo.TaintedEquals (pi1, pi2)
#endif
@ -1927,7 +1992,7 @@ type PropInfo =
| ILProp ilpinfo -> hash ilpinfo.RawMetadata.Name
| FSProp(_, _, vrefOpt1, vrefOpt2) ->
// Hash on string option * string option
let vth = (vrefOpt1 |> Option.map (fun vr -> vr.LogicalName), (vrefOpt2 |> Option.map (fun vr -> vr.LogicalName)))
let vth = (vrefOpt1 |> Option.map (fun vr -> vr.LogicalName), (vrefOpt2 |> Option.map (fun vref -> vref.LogicalName)))
hash vth
#if !NO_TYPEPROVIDERS
| ProvidedProp(_, pi, _) -> ProvidedPropertyInfo.TaintedGetHashCode pi
@ -2039,6 +2104,7 @@ type EventInfo =
#if !NO_TYPEPROVIDERS
| ProvidedEvent (amap, ei, m) -> ImportProvidedType amap m (ei.PApply((fun ei -> ei.DeclaringType), m))
#endif
/// Get the enclosing type of the method info, using a nominal type for tuple types
member x.ApparentEnclosingAppType =
match x with
@ -2053,7 +2119,7 @@ type EventInfo =
/// holding the value for the extension method.
member x.DeclaringTyconRef =
match x.ArbitraryValRef with
| Some vref when x.IsExtensionMember && vref.HasDeclaringEntity -> vref.TopValDeclaringEntity
| Some vref when x.IsExtensionMember && vref.HasDeclaringEntity -> vref.DeclaringEntity
| _ -> x.ApparentEnclosingTyconRef
/// Indicates if this event has an associated XML comment authored in this assembly.
@ -2085,6 +2151,18 @@ type EventInfo =
| ProvidedEvent (_, ei, m) -> ei.PUntaint((fun ei -> ei.Name), m)
#endif
/// Get the event name in DisplayName form
member x.DisplayName =
match x with
| FSEvent (_, p, _, _) -> p.DisplayName
| _ -> x.EventName |> PrettyNaming.ConvertValLogicalNameToDisplayName false
/// Get the event name in DisplayNameCore form
member x.DisplayNameCore =
match x with
| FSEvent (_, p, _, _) -> p.DisplayNameCore
| _ -> x.EventName |> PrettyNaming.ConvertValLogicalNameToDisplayNameCore
/// Indicates if this property is static.
member x.IsStatic =
match x with
@ -2261,4 +2339,4 @@ let PropInfosEquivByNameAndSig erasureFlag g amap m (pinfo: PropInfo) (pinfo2: P
let SettersOfPropInfos (pinfos: PropInfo list) = pinfos |> List.choose (fun pinfo -> if pinfo.HasSetter then Some(pinfo.SetterMethod, Some pinfo) else None)
let GettersOfPropInfos (pinfos: PropInfo list) = pinfos |> List.choose (fun pinfo -> if pinfo.HasGetter then Some(pinfo.GetterMethod, Some pinfo) else None)
let GettersOfPropInfos (pinfos: PropInfo list) = pinfos |> List.choose (fun pinfo -> if pinfo.HasGetter then Some(pinfo.GetterMethod, Some pinfo) else None)

53
src/Compiler/Checking/infos.fsi
Просмотреть файл

@ -136,6 +136,18 @@ type ParamData =
reflArgInfo: ReflectedArgInfo *
ttype: TType
// Adhoc information - could be unified with ParamData
type ParamAttribs =
| ParamAttribs of
isParamArrayArg: bool *
isInArg: bool *
isOutArg: bool *
optArgInfo: OptionalArgInfo *
callerInfo: CallerInfo *
reflArgInfo: ReflectedArgInfo
val CrackParamAttribsInfo: TcGlobals -> ty: TType * argInfo: ArgReprInfo -> ParamAttribs
/// Describes an F# use of an IL type, including the type instantiation associated with the type at a particular usage point.
[<NoComparison; NoEquality>]
type ILTypeInfo =
@ -423,6 +435,9 @@ type MethInfo =
/// Receiver must be a struct type.
member IsReadOnly: bool
/// Indicates, wheter this method has `IsExternalInit` modreq.
member HasExternalInit: bool
/// Indicates if the enclosing type for the method is a value type.
///
/// For an extension method, this indicates if the method extends a struct type.
@ -493,9 +508,11 @@ type MethInfo =
/// An instance method returns one object argument.
member GetObjArgTypes: amap: ImportMap * m: range * minst: TypeInst -> TType list
/// Get custom attributes for method (only applicable for IL methods)
member GetCustomAttrs: unit -> ILAttributes
/// Get the parameter attributes of a method info, which get combined with the parameter names and types
member GetParamAttribs:
amap: ImportMap * m: range -> (bool * bool * bool * OptionalArgInfo * CallerInfo * ReflectedArgInfo) list list
member GetParamAttribs: amap: ImportMap * m: range -> ParamAttribs list list
/// Get the ParamData objects for the parameters of a MethInfo
member GetParamDatas: amap: ImportMap * m: range * minst: TType list -> ParamData list list
@ -546,6 +563,9 @@ type ILFieldInfo =
/// Get the name of the field
member FieldName: string
/// Get the core of the display name for the field. This is the same as the logical name.
member DisplayNameCore: string
/// Get an (uninstantiated) reference to the field as an Abstract IL ILFieldRef
member ILFieldRef: ILFieldRef
@ -642,14 +662,14 @@ type UnionCaseInfo =
///
/// Backticks and parens are not added for non-identifiers.
///
/// Note logical names op_Nil and op_ConsCons become [] and :: respectively.
/// Note logical names op_Nil and op_ColonColon become [] and :: respectively.
member DisplayNameCore: string
/// Get the display name of the union case
///
/// Backticks and parens are added implicitly for non-identifiers.
///
/// Note logical names op_Nil and op_ConsCons become ([]) and (::) respectively.
/// Note logical names op_Nil and op_ColonColon become ([]) and (::) respectively.
member DisplayName: string
/// Get the F# metadata for the declaring union type
@ -695,6 +715,9 @@ type ILPropInfo =
/// Get the declaring IL type of the IL property, including any generic instantiation
member ILTypeInfo: ILTypeInfo
/// Is the property requied (has the RequiredMemberAttribute).
member IsRequired: bool
/// Indicates if the IL property is logically a 'newslot', i.e. hides any previous slots of the same name.
member IsNewSlot: bool
@ -787,6 +810,12 @@ type PropInfo =
/// Indicates if this property has an associated setter method.
member HasSetter: bool
/// Indidcates whether IL property has an init-only setter (i.e. has the `System.Runtime.CompilerServices.IsExternalInit` modifer)
member IsSetterInitOnly: bool
/// Is the property requied (has the RequiredMemberAttribute).
member IsRequired: bool
member ImplementedSlotSignatures: SlotSig list
/// Indicates if this property is marked 'override' and thus definitely overrides another property.
@ -823,6 +852,14 @@ type PropInfo =
/// Get the logical name of the property.
member PropertyName: string
/// Get the display name of the property.
///
/// Backticks and parens are added implicitly for non-identifiers.
member DisplayName: string
/// Get the property name in core DisplayName form (no backticks or parens added)
member DisplayNameCore: string
/// Get a MethInfo for the 'setter' method associated with the property
member SetterMethod: MethInfo
@ -927,6 +964,14 @@ type EventInfo =
/// Get the logical name of the event.
member EventName: string
/// Get the display name of the event.
///
/// Backticks and parens are added implicitly for non-identifiers.
member DisplayName: string
/// Get the event name in core DisplayName form (no backticks or parens added)
member DisplayNameCore: string
/// Indicates if this event has an associated XML comment authored in this assembly.
member HasDirectXmlComment: bool

21
src/Compiler/CodeGen/EraseClosures.fs
Просмотреть файл

@ -366,7 +366,7 @@ let convReturnInstr ty instr =
| I_ret -> [ I_box ty; I_ret ]
| I_call (_, mspec, varargs) -> [ I_call(Normalcall, mspec, varargs) ]
| I_callvirt (_, mspec, varargs) -> [ I_callvirt(Normalcall, mspec, varargs) ]
| I_callconstraint (_, ty, mspec, varargs) -> [ I_callconstraint(Normalcall, ty, mspec, varargs) ]
| I_callconstraint (callvirt, _, ty, mspec, varargs) -> [ I_callconstraint(callvirt, Normalcall, ty, mspec, varargs) ]
| I_calli (_, csig, varargs) -> [ I_calli(Normalcall, csig, varargs) ]
| _ -> [ instr ]
@ -500,9 +500,11 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo =
// nb. should combine the term and type abstraction cases for
// to allow for term and type variables to be mixed in a single
// application.
if (match laterStruct with
| Lambdas_return _ -> false
| _ -> true) then
if
(match laterStruct with
| Lambdas_return _ -> false
| _ -> true)
then
let nowStruct =
List.foldBack (fun x y -> Lambdas_forall(x, y)) tyargsl (Lambdas_return nowReturnTy)
@ -571,6 +573,7 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo =
let nowApplyMethDef =
mkILGenericVirtualMethod (
"Specialize",
ILCallingConv.Instance,
ILMemberAccess.Public,
addedGenParams (* method is generic over added ILGenericParameterDefs *) ,
[],
@ -622,9 +625,11 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo =
let nowReturnTy = mkTyOfLambdas cenv laterStruct
// CASE 2a - Too Many Term Arguments or Remaining Type arguments - Split the Closure Class in Two
if (match laterStruct with
| Lambdas_return _ -> false
| _ -> true) then
if
(match laterStruct with
| Lambdas_return _ -> false
| _ -> true)
then
let nowStruct =
List.foldBack (fun l r -> Lambdas_lambda(l, r)) nowParams (Lambdas_return nowReturnTy)
@ -703,7 +708,7 @@ let rec convIlxClosureDef cenv encl (td: ILTypeDef) clo =
let convil = convILMethodBody (Some nowCloSpec, None) (Lazy.force clo.cloCode)
let nowApplyMethDef =
mkILNonGenericVirtualMethod (
mkILNonGenericVirtualInstanceMethod (
"Invoke",
ILMemberAccess.Public,
nowParams,

17
src/Compiler/CodeGen/EraseUnions.fs
Просмотреть файл

@ -76,7 +76,8 @@ type UnionReprDecisions<'Union, 'Alt, 'Type>
if alts.Length = 1 then
SingleCase
elif
not (isStruct cu) && alts.Length < TaggingThresholdFixedConstant
not (isStruct cu)
&& alts.Length < TaggingThresholdFixedConstant
&& not (repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu)
then
RuntimeTypes
@ -1280,12 +1281,14 @@ let mkClassUnionDef
]
let ctorMeths =
if (List.isEmpty selfFields
&& List.isEmpty tagFieldsInObject
&& not (List.isEmpty selfMeths))
|| isStruct
|| cud.UnionCases
|> Array.forall (fun alt -> repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt)) then
if
(List.isEmpty selfFields
&& List.isEmpty tagFieldsInObject
&& not (List.isEmpty selfMeths))
|| isStruct
|| cud.UnionCases
|> Array.forall (fun alt -> repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt))
then
[] (* no need for a second ctor in these cases *)

798
src/Compiler/CodeGen/IlxGen.fs
Просмотреть файл

Разница между файлами не показана из-за своего большого размера Загрузить разницу

Некоторые файлы не были показаны из-за слишком большого количества измененных файлов Показать больше