diff --git a/.github/workflows/ci-main.yml b/.github/workflows/ci-main.yml index 34ada9d..2a925a9 100644 --- a/.github/workflows/ci-main.yml +++ b/.github/workflows/ci-main.yml @@ -29,6 +29,9 @@ jobs: with: dotnet-version: 10.0.401 + - name: Install Native AOT toolchain + run: sudo apt-get update && sudo apt-get install -y clang zlib1g-dev + - name: Restore run: dotnet restore FScript.sln diff --git a/.github/workflows/ci-pr.yml b/.github/workflows/ci-pr.yml index 3aa4add..e28f47d 100644 --- a/.github/workflows/ci-pr.yml +++ b/.github/workflows/ci-pr.yml @@ -35,6 +35,9 @@ jobs: with: dotnet-version: 10.0.401 + - name: Install Native AOT toolchain + run: sudo apt-get update && sudo apt-get install -y clang zlib1g-dev + - name: Restore run: dotnet restore FScript.sln diff --git a/.gitignore b/.gitignore index b1162d5..160ce82 100644 --- a/.gitignore +++ b/.gitignore @@ -37,6 +37,7 @@ TestResults/ .DS_Store Thumbs.db .out +/out/ vscode-fscript/dist/ vscode-fscript/*.vsix diff --git a/CHANGELOG.md b/CHANGELOG.md index d171027..fd53b5b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,10 @@ All notable changes to FScript are documented in this file. ## [Unreleased] +- Added C# and .NET compilation with FFI support, self-contained executables, and Native AOT publishing. +- Added typed HIR/LIR, versioned `.fsir` artifacts, and a reference LIR interpreter, with specialization, `Pure`-guided pruning, common-subexpression elimination, and .NET tail-call optimizations. +- Added execution-local `Env.setExitCode` and `--no-result` controls, and updated the website and documentation for compilation and embedding. + ## [0.83.3] diff --git a/FScript.sln b/FScript.sln index b7b61f4..d9ca142 100644 --- a/FScript.sln +++ b/FScript.sln @@ -7,12 +7,16 @@ Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "src", "src", "{827E0CD3-B72 EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Language", "src\FScript.Language\FScript.Language.fsproj", "{73C9C013-4E93-45EC-A69D-E490788D8E2B}" EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Compiler", "src\FScript.Compiler\FScript.Compiler.fsproj", "{D2D66D0D-2D54-4B13-A847-C94732038E17}" +EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript", "src\FScript\FScript.fsproj", "{56151E59-268A-4A4B-BE94-B7AD2E8B32FA}" EndProject Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "tests", "tests", "{0AB3BF05-4346-4AA6-1389-037BE0695223}" EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Language.Tests", "tests\FScript.Language.Tests\FScript.Language.Tests.fsproj", "{9C62883E-EFB0-4D9E-84F3-4138C123F55E}" EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Compiler.Tests", "tests\FScript.Compiler.Tests\FScript.Compiler.Tests.fsproj", "{61460CC8-4B1A-4A32-B95B-85DF17DCC54B}" +EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Runtime", "src\FScript.Runtime\FScript.Runtime.fsproj", "{8C2C5767-857A-44B0-80C2-DC90E0A60F4D}" EndProject Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Runtime.Tests", "tests\FScript.Runtime.Tests\FScript.Runtime.Tests.fsproj", "{1E2C7B34-04B8-42C9-880D-CC47DEC156A7}" @@ -43,6 +47,18 @@ Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Cli.Tests.Fixtures. EndProject Project("{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}") = "FScript.DebugAdapter", "src\FScript.DebugAdapter\FScript.DebugAdapter.csproj", "{FE5D4A9E-1936-489C-B489-8133DB47E063}" EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Interpreter.Lir", "src\FScript.Interpreter.Lir\FScript.Interpreter.Lir.fsproj", "{88B1BFFA-B93F-49FE-8C70-AB070A21135F}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Interpreter.Lir.Tests", "tests\FScript.Interpreter.Lir.Tests\FScript.Interpreter.Lir.Tests.fsproj", "{CCC7F576-D284-4B29-A30F-9685929F4E36}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Conformance.Tests", "tests\FScript.Conformance.Tests\FScript.Conformance.Tests.fsproj", "{A5495111-E8DD-4862-BF4E-BE13CB96F9DC}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Backend.CSharp", "src\FScript.Backend.CSharp\FScript.Backend.CSharp.fsproj", "{2BDE00DA-0440-4AB4-8E42-DB0F690CC146}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Backend.DotNet", "src\FScript.Backend.DotNet\FScript.Backend.DotNet.fsproj", "{32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}" +EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "FScript.Backend.DotNet.Tests", "tests\FScript.Backend.DotNet.Tests\FScript.Backend.DotNet.Tests.fsproj", "{65E0671A-8A76-4E25-979E-BCA7D57DF84E}" +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -65,6 +81,18 @@ Global {73C9C013-4E93-45EC-A69D-E490788D8E2B}.Release|x64.Build.0 = Release|Any CPU {73C9C013-4E93-45EC-A69D-E490788D8E2B}.Release|x86.ActiveCfg = Release|Any CPU {73C9C013-4E93-45EC-A69D-E490788D8E2B}.Release|x86.Build.0 = Release|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Debug|Any CPU.Build.0 = Debug|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Debug|x64.ActiveCfg = Debug|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Debug|x64.Build.0 = Debug|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Debug|x86.ActiveCfg = Debug|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Debug|x86.Build.0 = Debug|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Release|Any CPU.ActiveCfg = Release|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Release|Any CPU.Build.0 = Release|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Release|x64.ActiveCfg = Release|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Release|x64.Build.0 = Release|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Release|x86.ActiveCfg = Release|Any CPU + {D2D66D0D-2D54-4B13-A847-C94732038E17}.Release|x86.Build.0 = Release|Any CPU {56151E59-268A-4A4B-BE94-B7AD2E8B32FA}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {56151E59-268A-4A4B-BE94-B7AD2E8B32FA}.Debug|Any CPU.Build.0 = Debug|Any CPU {56151E59-268A-4A4B-BE94-B7AD2E8B32FA}.Debug|x64.ActiveCfg = Debug|Any CPU @@ -89,6 +117,18 @@ Global {9C62883E-EFB0-4D9E-84F3-4138C123F55E}.Release|x64.Build.0 = Release|Any CPU {9C62883E-EFB0-4D9E-84F3-4138C123F55E}.Release|x86.ActiveCfg = Release|Any CPU {9C62883E-EFB0-4D9E-84F3-4138C123F55E}.Release|x86.Build.0 = Release|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Debug|Any CPU.Build.0 = Debug|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Debug|x64.ActiveCfg = Debug|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Debug|x64.Build.0 = Debug|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Debug|x86.ActiveCfg = Debug|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Debug|x86.Build.0 = Debug|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Release|Any CPU.ActiveCfg = Release|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Release|Any CPU.Build.0 = Release|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Release|x64.ActiveCfg = Release|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Release|x64.Build.0 = Release|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Release|x86.ActiveCfg = Release|Any CPU + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B}.Release|x86.Build.0 = Release|Any CPU {8C2C5767-857A-44B0-80C2-DC90E0A60F4D}.Debug|Any CPU.ActiveCfg = Debug|Any CPU {8C2C5767-857A-44B0-80C2-DC90E0A60F4D}.Debug|Any CPU.Build.0 = Debug|Any CPU {8C2C5767-857A-44B0-80C2-DC90E0A60F4D}.Debug|x64.ActiveCfg = Debug|Any CPU @@ -245,14 +285,88 @@ Global {FE5D4A9E-1936-489C-B489-8133DB47E063}.Release|x64.Build.0 = Release|Any CPU {FE5D4A9E-1936-489C-B489-8133DB47E063}.Release|x86.ActiveCfg = Release|Any CPU {FE5D4A9E-1936-489C-B489-8133DB47E063}.Release|x86.Build.0 = Release|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Debug|Any CPU.Build.0 = Debug|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Debug|x64.ActiveCfg = Debug|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Debug|x64.Build.0 = Debug|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Debug|x86.ActiveCfg = Debug|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Debug|x86.Build.0 = Debug|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Release|Any CPU.ActiveCfg = Release|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Release|Any CPU.Build.0 = Release|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Release|x64.ActiveCfg = Release|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Release|x64.Build.0 = Release|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Release|x86.ActiveCfg = Release|Any CPU + {88B1BFFA-B93F-49FE-8C70-AB070A21135F}.Release|x86.Build.0 = Release|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Debug|Any CPU.Build.0 = Debug|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Debug|x64.ActiveCfg = Debug|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Debug|x64.Build.0 = Debug|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Debug|x86.ActiveCfg = Debug|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Debug|x86.Build.0 = Debug|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Release|Any CPU.ActiveCfg = Release|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Release|Any CPU.Build.0 = Release|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Release|x64.ActiveCfg = Release|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Release|x64.Build.0 = Release|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Release|x86.ActiveCfg = Release|Any CPU + {CCC7F576-D284-4B29-A30F-9685929F4E36}.Release|x86.Build.0 = Release|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Debug|Any CPU.Build.0 = Debug|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Debug|x64.ActiveCfg = Debug|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Debug|x64.Build.0 = Debug|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Debug|x86.ActiveCfg = Debug|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Debug|x86.Build.0 = Debug|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Release|Any CPU.ActiveCfg = Release|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Release|Any CPU.Build.0 = Release|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Release|x64.ActiveCfg = Release|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Release|x64.Build.0 = Release|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Release|x86.ActiveCfg = Release|Any CPU + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC}.Release|x86.Build.0 = Release|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Debug|Any CPU.Build.0 = Debug|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Debug|x64.ActiveCfg = Debug|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Debug|x64.Build.0 = Debug|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Debug|x86.ActiveCfg = Debug|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Debug|x86.Build.0 = Debug|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Release|Any CPU.ActiveCfg = Release|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Release|Any CPU.Build.0 = Release|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Release|x64.ActiveCfg = Release|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Release|x64.Build.0 = Release|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Release|x86.ActiveCfg = Release|Any CPU + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146}.Release|x86.Build.0 = Release|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Debug|Any CPU.Build.0 = Debug|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Debug|x64.ActiveCfg = Debug|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Debug|x64.Build.0 = Debug|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Debug|x86.ActiveCfg = Debug|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Debug|x86.Build.0 = Debug|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Release|Any CPU.ActiveCfg = Release|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Release|Any CPU.Build.0 = Release|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Release|x64.ActiveCfg = Release|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Release|x64.Build.0 = Release|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Release|x86.ActiveCfg = Release|Any CPU + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A}.Release|x86.Build.0 = Release|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Debug|Any CPU.Build.0 = Debug|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Debug|x64.ActiveCfg = Debug|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Debug|x64.Build.0 = Debug|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Debug|x86.ActiveCfg = Debug|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Debug|x86.Build.0 = Debug|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Release|Any CPU.ActiveCfg = Release|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Release|Any CPU.Build.0 = Release|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Release|x64.ActiveCfg = Release|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Release|x64.Build.0 = Release|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Release|x86.ActiveCfg = Release|Any CPU + {65E0671A-8A76-4E25-979E-BCA7D57DF84E}.Release|x86.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE EndGlobalSection GlobalSection(NestedProjects) = preSolution {73C9C013-4E93-45EC-A69D-E490788D8E2B} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} + {D2D66D0D-2D54-4B13-A847-C94732038E17} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} {56151E59-268A-4A4B-BE94-B7AD2E8B32FA} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} {9C62883E-EFB0-4D9E-84F3-4138C123F55E} = {0AB3BF05-4346-4AA6-1389-037BE0695223} + {61460CC8-4B1A-4A32-B95B-85DF17DCC54B} = {0AB3BF05-4346-4AA6-1389-037BE0695223} {8C2C5767-857A-44B0-80C2-DC90E0A60F4D} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} {1E2C7B34-04B8-42C9-880D-CC47DEC156A7} = {0AB3BF05-4346-4AA6-1389-037BE0695223} {B734E1E1-59C2-47E0-8D19-A9C5C95938F1} = {0AB3BF05-4346-4AA6-1389-037BE0695223} @@ -267,5 +381,11 @@ Global {CCD6A5F1-38D4-4719-9BB2-B17BB4E2D423} = {0AB3BF05-4346-4AA6-1389-037BE0695223} {D5E47861-ECF0-4678-8B8E-4B30B4FFC52C} = {0AB3BF05-4346-4AA6-1389-037BE0695223} {FE5D4A9E-1936-489C-B489-8133DB47E063} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} + {88B1BFFA-B93F-49FE-8C70-AB070A21135F} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} + {CCC7F576-D284-4B29-A30F-9685929F4E36} = {0AB3BF05-4346-4AA6-1389-037BE0695223} + {A5495111-E8DD-4862-BF4E-BE13CB96F9DC} = {0AB3BF05-4346-4AA6-1389-037BE0695223} + {2BDE00DA-0440-4AB4-8E42-DB0F690CC146} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} + {32CFD1D1-1087-4275-8D15-73EC0D4CEA9A} = {827E0CD3-B72D-47B6-A68D-7590B98EB39B} + {65E0671A-8A76-4E25-979E-BCA7D57DF84E} = {0AB3BF05-4346-4AA6-1389-037BE0695223} EndGlobalSection EndGlobal diff --git a/Makefile b/Makefile index df868b3..8c8d3aa 100644 --- a/Makefile +++ b/Makefile @@ -35,6 +35,7 @@ smoke-tests: dotnet run --project src/FScript -- samples/ffi/main.fss -- --headless; \ echo "All smoke tests passed." + verify-changelog: REQUIRE_CHANGELOG_ALWAYS=true .github/scripts/check-unreleased-changelog.sh diff --git a/README.md b/README.md index 4196c55..27b52b5 100644 --- a/README.md +++ b/README.md @@ -20,6 +20,12 @@ It is designed for host applications that need: - **Host-first extensibility**: add external functions with explicit type schemes and runtime implementations. - **Security-aware embedding**: script capabilities are defined by what the host exposes. +## Compilation + +FScript also compiles to optimized .NET assemblies and independently buildable C# projects. The .NET backend supports self-contained single-file and Native AOT executables, including typed FFI bindings. + +See [Compilation](docs/guides/compilation.md) for target selection, [.NET output](docs/guides/compile-to-dotnet.md), [C# projects](docs/guides/compile-to-csharp.md), and [optimization behavior](docs/guides/compiler-optimizations.md). + ## Language Snapshot FScript currently includes: diff --git a/docs/README.md b/docs/README.md index c3ce4c5..d15f6ab 100644 --- a/docs/README.md +++ b/docs/README.md @@ -13,6 +13,15 @@ This folder is organized into three layers: - FScript vs F# / OCaml: [`guides/fsharp-ocaml-differences.md`](./guides/fsharp-ocaml-differences.md) - Language rationale: [`guides/language-choices.md`](./guides/language-choices.md) +## Compilation + +- [Choose a compilation target](./guides/compilation.md) +- [Compile to .NET](./guides/compile-to-dotnet.md): assemblies, single-file executables, Native AOT, and typed FFI +- [Compile to C#](./guides/compile-to-csharp.md): generated projects, source layout, and managed references +- [Compilation and optimizations](./guides/compiler-optimizations.md): shared passes, assembly-only transformations, and pruning limits +- [Compiler CLI reference](./guides/compiler-cli.md) +- [Compile and interpret IR](./guides/interpret-ir.md) + ## User references The [website manual sources](../website/docs/intro.md) separate a guided learning path from lookup material: diff --git a/docs/architecture/README.md b/docs/architecture/README.md index 5ad77a4..2a147d2 100644 --- a/docs/architecture/README.md +++ b/docs/architecture/README.md @@ -4,3 +4,4 @@ How the repository and assemblies are organized. - Assemblies and roles: [`assemblies-and-roles.md`](./assemblies-and-roles.md) - REPL architecture: [`repl-architecture.md`](./repl-architecture.md) +- Typed IR and backends: [`typed-ir-and-backends.md`](./typed-ir-and-backends.md) diff --git a/docs/architecture/assemblies-and-roles.md b/docs/architecture/assemblies-and-roles.md index 94a410c..2f864e4 100644 --- a/docs/architecture/assemblies-and-roles.md +++ b/docs/architecture/assemblies-and-roles.md @@ -38,6 +38,38 @@ Use this when: - You want to embed the language in another .NET application. - You need language processing independently from default runtime extern catalog. +### `FScript.Compiler` +Role: +- Reusable .NET compiler pipeline for typed HIR, executable LIR, and IR artifacts. + +Responsibilities: +- Consume the resolved typed result produced by `FScript.Language`. +- Validate and lower HIR to backend-independent LIR. +- Serialize and validate whole-program `.fsir` artifacts. + +`FScript.Compiler` depends on `FScript.Language` and is intentionally excluded from the Fable JavaScript package. + +### `FScript.Interpreter.Lir` +Role: +- Backend-independent execution engine for validated LIR. + +Responsibilities: +- Execute LIR values, closures, decision trees, aggregates, intrinsics, and failures. +- Validate caller-provided LIR and return one structured execution diagnostic on failure. +- Supply script identity and arguments through `InterpreterContext`. +- Reject reachable unsupported target or host linkage with interpreter diagnostics. + +`FScript.Interpreter.Lir` depends on `FScript.Compiler`; the core compiler has no dependency on the interpreter. + +### `FScript.Backend.CSharp` and `FScript.Backend.DotNet` +Role: +- Consume validated LIR to emit an independent C# project or optimized .NET assembly. +- Share concrete HM specialization and simplification in `FScript.Compiler`. +- Bind FFI calls and external types to the CLR; report target-specific diagnostics. +- Optionally publish self-contained or Native AOT executables through the .NET SDK. + +Consumer tests follow the same boundary: `FScript.Interpreter.Lir.Tests` owns LIR execution; `FScript.Backend.DotNet.Tests` owns native generation. `FScript.Compiler.Tests` covers HIR, lowering, LIR validation, and artifacts. + NuGet: - `MagnusOpera.FScript.Language` @@ -141,11 +173,14 @@ Use this when: ## Dependency direction - `FScript.Language` has no dependency on `FScript.Runtime`. +- `FScript.Compiler` depends only on `FScript.Language`. +- `FScript.Interpreter.Lir` and `FScript.Backend.CSharp` each depend on `FScript.Compiler`. +- `FScript.Backend.CSharp` depends on `FScript.Compiler`; `FScript.Backend.DotNet` uses that emitter and Roslyn to produce PE assemblies. - `FScript.JavaScript` depends on `FScript.Language` and Fable packages. - `FScript.Runtime` depends on `FScript.Language` types. - `FScript.CSharpInterop` depends on both `FScript.Language` and `FScript.Runtime`. - `FScript.LanguageServer` depends on `FScript.CSharpInterop`. -- `FScript` depends on both `FScript.Language` and `FScript.Runtime`. +- `FScript` depends on `FScript.Language`, `FScript.Runtime`, `FScript.Compiler`, `FScript.Interpreter.Lir`, `FScript.Backend.CSharp`, and `FScript.Backend.DotNet`. This keeps the language engine reusable while runtime capabilities remain host-configurable. The JavaScript facade is intentionally separate from `.NET` runtime externs: v1 exposes core language hosting, virtual imports, tagged values, and JS-provided externs, while filesystem, console, task, and other runtime modules stay in the .NET runtime layer. diff --git a/docs/architecture/typed-ir-and-backends.md b/docs/architecture/typed-ir-and-backends.md new file mode 100644 index 0000000..618d4f4 --- /dev/null +++ b/docs/architecture/typed-ir-and-backends.md @@ -0,0 +1,78 @@ +# Typed IR and Backend Architecture + +## Pipeline + +```text +source -> parser/includes -> inference + resolved typed tree -> HIR -> LIR + | + +-> serialization + +-> LIR interpreter + +-> C# source backend + +-> optimized .NET assembly backend +``` + +`FScript.Language` owns parsing, inference, and the reference evaluator and remains Fable-compatible. Its compiler inference path emits a recursive resolved typed tree in the same inference pass as the compatibility `TypedProgram`. Expressions carry final instantiated types, source spans, lexical reference kinds, primitive operations, and structural/named-record coercion evidence. Ordinary inference and evaluation APIs retain their direct path without constructing compiler telemetry. + +Resolved inference assigns deterministic artifact-local IDs to builtins, externs, types, union cases, declarations, parameters, pattern bindings, and locals in source order. Type variables normalize independently of global inference counters. Non-recursive initializers see preceding bindings; recursive groups see every peer atomically. Repeated included source locations and shadowed names retain distinct lexical identities. + +`FScript.Compiler` owns HIR, LIR, validation, lowering, optimization, specialization, and artifact serialization. It depends on Language and references no backend. Exported signatures come from the same inference result, avoiding duplicate inference for embedded hosts. + +Validated LIR consumers are separate leaf assemblies: `FScript.Interpreter.Lir` owns LIR values and execution, `FScript.Backend.CSharp` emits independent source projects, and `FScript.Backend.DotNet` emits optimized assemblies. Public modules retain the `FScript.Compiler` namespace while assembly ownership remains explicit. + +## IR boundaries + +HIR consumes the semantic resolved tree rather than parser AST nodes or compatibility telemetry. It retains complete semantic types, schemes, attributes, declaration shapes, imports, exports, source spans, and explicit record conversions. Source IDs remain unchanged; compiler-synthesized IDs occupy a separate higher range. HIR and LIR contain no target-language storage types. + +LIR is structured, executable, and non-SSA. Lambdas become lifted functions with explicit ordered captures; closure creation references function IDs. Pattern matching becomes ordered projection, check, binding, and map-consumption plans. Consumers execute these plans rather than interpreting source patterns. A scrutinee is evaluated once, guards follow source order, and repeated bindings require structural equality. + +Named references remain nominal, with record and union declaration shapes carried separately. Local pattern bindings reuse decision trees. Ranges, loops, interpolation, indexing, record updates, and conversions preserve reference evaluation order. Top-level expressions become ordered synthetic declarations; the final entry references the last result without evaluating it twice. Recursive closure groups initialize atomically, including local mutual recursion. + +The pipeline is resolved inference, HIR lowering and validation, LIR lowering, `LirOptimization.optimize`, and LIR validation. Shared optimization performs conservative effect/use analysis, Boolean simplification, unused pure-binding elimination, deterministic reachability, and proper-tail-call marking. Ordered roots include observable initializers and exports. Captures and function IDs are rebuilt after pruning. Ordinary and pipeline calls remain distinct, preserving function-first and value-first evaluation respectively. + +Validation checks IDs, references, types, schemes, spans, closure captures, call signatures, branches, pattern projections, aggregates, primitives, and import linkage. Artifact loading and every execution/generation entry point validate caller-provided LIR. Canonical debug printers normalize type variables, paths, source locations, and ordering; snapshots protect determinism. + +## Native specialization and assembly optimization + +`NativeSpecialization`, `LirMonomorphization`, and `LirSimplification` are shared by the C# and .NET backends. They instantiate reachable polymorphic declarations, functions, local bindings, and captures at concrete use types. Keys combine source identity and normalized concrete types, and recursive bodies are memoized before traversal. Unused pure generalized declarations may disappear; effectful generalized initializers cannot be cloned. Bottom expressions do not need an invented storage representation. + +Shared specialization diagnostics use `FSL21xx`; native consumers translate them into their target diagnostic families. Open reachable types and unsafe effectful cloning remain explicit failures. Simplification beta-reduces small known closures, propagates constants and direct projections, removes unused pure calls, refreshes captures, and repeats reachability. Unknown callbacks, imports, failures, and I/O remain observable. + +`LirCommonSubexpressions` is shared by both compiled targets and runs after their other LIR reductions. It uses `LirEffects` and external-type immutability contracts for dominance-based value numbering. It retains first-evaluation order, separates conditional regions and loop bodies, clears availability at observable operations, and emits ordinary lexical lets. Function invocations have independent local bindings. Key normalization excludes spans but includes type identity and floating-point bits. Temporary cleanup removes administrative bindings that are not shared. No new LIR/artifact representation, runtime cache, or interpreter pass is required. + +The .NET backend adds an assembly-only optimization path: static saturated calls, partial-application reduction, closure propagation, self-tail-call loops, typed collection callbacks, immediate-block lowering, and generated-member pruning. It reuses the C# representation emitter through an internal entry point; the ordinary C# source target does not run these extra passes. Roslyn emits valid release IL. See the [native backend specification](../specs/dotnet-backends.md). + +The .NET backend can publish its optimized PE as a self-contained single-file or Native AOT executable. A temporary SDK project's post-compile target replaces its placeholder assembly with that PE before publication. No interpreter or hosting layer participates. The CLI defaults the .NET runtime identifier to the current host and accepts an explicit override; the backend API receives the resolved identifier. Publishing requires the installed SDK/toolchain. + +## Interpretation, runtime context, and FFI + +The LIR interpreter uses its own tagged values and environments, not source AST nodes or the reference evaluator. It implements the pure scalar, string, list, option, and ordered-map catalog, with curried callback invocation and structural equality. Explicit tail calls run through a stack-safe trampoline. It can initialize a validated program once and invoke exports repeatedly without repeating top-level effects. + +Host linkage in artifacts consists of names, schemes, arity, and target descriptors, never executable delegates or opaque payloads. Unused unsupported handles are inert; fully applying unsupported linkage produces a stage-specific diagnostic. Interpreter callback registrations are separate from serialized LIR. Task signatures survive every IR stage, although fully applied tasks without interpreter adapters report `FSI3021`. + +`Env` is an intrinsic runtime-context value. LIR receives script name and arguments through `InterpreterContext`; native executables use process arguments. Console output preserves order, and the LIR interpreter exposes captured lines through `ExecutionResult.Stdout`. Native backends implement runtime services according to their documented catalog. + +`Compiler.compileWithRegistration` accepts the frontend's `ExtensionRegistration`, retaining registered structural and host-managed types, unions, and constructors. `ClrBindings.bindMethod` and `bindType` serialize exact CLR linkage without embedding reflection objects. Typed provider companions enable direct calls; legacy SDK adapters remain available for managed output. Reachability removes unused external types and provider dependencies; static bindings allow executable publishing to trim provider methods and types. + +Backend `Import` attributes remain structured language metadata on bodyless typed function declarations and imported type schemas. They do not create a second type system. Each consumer accepts only linkage it supports. Unused target imports are inert; the LIR interpreter reports `FSI3023` when an unsupported import is fully applied. + +## Trusted host purity + +A separate `PurityContracts` value supplies registered pure function and type names without changing SDK record shapes. Provider companion methods expose this metadata using BCL `IEnumerable` values; the CLI reads them before resolved inference. Native consumers receive declarative flags and external application arities through HIR/LIR and serialization, with conservative defaults for older artifacts. + +`LirEffects` centralizes native totality/effect analysis, propagating known function summaries and callback conditions while treating recursive cycles, potentially failing operations, and unknown external reads conservatively. Unused pure calls can disappear before emission, allowing their SDK adapters and provider dependencies to become unreachable. The AST interpreter does not query these compiler-only companions or change evaluation order. See [FFI purity](../guides/compile-to-dotnet.md#pure-ffi-and-external-values). + +## Artifacts and conformance + +Versioned `.fsir` artifacts contain the complete LIR program, compiler/language versions, normalized source paths and SHA-256 hashes, and ordered foreign dependencies. Deserialization rejects incompatible format/version, malformed metadata, and programs that fail LIR validation. The format is internal and carries no backward-compatibility guarantee. + +The conformance suite compares the reference evaluator with serialized/deserialized LIR execution for values, stdout, and failure categories. Native backend tests independently execute emitted assemblies, validate IL, and cover FFI, external types, collections, recursion, and specialization. + +## Reference execution + +The `feature/in-memory-execution` experiment is reference material only; its dynamic assembly architecture is neither copied nor referenced. Normal CLI and `ScriptHost` execution retain the reference AST evaluator. JavaScript embedding remains unchanged. The LIR interpreter is a separate execution/reference consumer, and native compilation is explicit. + +## Result display and exit status + +Result display defaults to enabled and is independent of shell status. CLI `--no-result` disables it; native consumers run `LirResultPolicy.discard` before specialization so unused pure result work can be pruned while observable initialization remains rooted. `LirTraversal` supplies common child mapping and complete symbol census for transformations and fresh lexical bindings. + +`Env.setExitCode` is a reserved effectful core operation that coexists with the runtime `Env` record. The evaluator owns a locked status cell shared with its tasks; generated programs use an atomic per-program field and return its value from `Main`. Neither embedding surface sets the host process status. LIR exposes status alongside values. Fable/JavaScript ignores the setter and keeps returning/displaying ordinary values. Task ordering remains scheduling-dependent, and existing task failure/lifetime rules are unchanged. diff --git a/docs/guides/compilation.md b/docs/guides/compilation.md new file mode 100644 index 0000000..b8bf2ca --- /dev/null +++ b/docs/guides/compilation.md @@ -0,0 +1,58 @@ +# Compilation + +FScript can run inside a host application or compile into a program that runs on its own. Compilation checks the same language types, resolves imported scripts, and produces ordinary .NET code. Generated programs do not load FScript source or start an interpreter. + +## Choose an output + +| Output | Command options | Use it when | +| --- | --- | --- | +| .NET assembly | `--target dotnet` | You want compiled execution with FScript's assembly optimizations. Run the DLL with .NET 10. | +| Self-contained executable | `--target dotnet --single-file [--runtime ]` | You want one distributable executable that includes the .NET runtime. | +| Native AOT executable | `--target dotnet --aot [--runtime ]` | You want dependencies trimmed and compiled into a native executable. | +| C# project | `--target csharp` | You want to inspect, edit, or integrate generated source in a .NET build. | + +The [optimization guide](./compiler-optimizations.md) explains the shared passes and the additional work performed by the assembly target. + +## Compile a first program + +Save this as `hello.fss`: + +```fsharp +let name = + match Env.Arguments with + | first :: _ -> first + | [] -> "world" + +Console.writeLine $"Hello {name}!" +``` + +Compile and run it: + +```sh +fscript compile hello.fss --target dotnet --output out/hello +dotnet out/hello/hello.dll Ada +``` + +The program writes `Hello Ada!`, followed by `()`, its final FScript result. Arguments after the assembly or executable name become `Env.Arguments`. `Env.ScriptName` contains the running assembly or executable filename. + +From a checkout, replace `fscript` with `dotnet run --project src/FScript --` in these commands. + +## Language and runtime behavior + +Records, unions, tuples, lists, options, maps, closures, patterns, and recursive functions retain their FScript semantics. Equality remains structural, collections remain immutable, Boolean operators short-circuit, and top-level effects execute once in source order. An exported binding uses `export let`. + +Script imports are resolved at compile time. An application needs its managed dependencies and any files it reads as input, but does not need the original `.fss` files to execute. + +Standalone applications use the process working directory and operating-system permissions. Interpreter sandbox restrictions and execution budgets are not carried into compiled binaries. + +## Host integration + +Both targets support .NET FFI selected through the normal environment configuration. Existing SDK providers can run through generated adapters. Typed CLR mappings enable direct calls and make provider code suitable for trimming and Native AOT when its dependencies support them. + +See [Compile to .NET](./compile-to-dotnet.md) for FFI configuration, typed bindings, publishing, and runtime identifiers, or [Compile to C#](./compile-to-csharp.md) for project layout and reference handling. + +## Compiling and embedding + +Compilation is an explicit CLI or compiler API operation. Running `fscript program.fss` or using ordinary `ScriptHost` embedding continues to use the AST interpreter. JavaScript embedding also remains interpreted. + +The separate [IR workflow](./interpret-ir.md) produces a versioned `.fsir` artifact and executes it with the LIR interpreter. It is useful for compiler tooling and conformance work; it is not required to run compiled .NET programs. diff --git a/docs/guides/compile-to-csharp.md b/docs/guides/compile-to-csharp.md new file mode 100644 index 0000000..3e0fbb5 --- /dev/null +++ b/docs/guides/compile-to-csharp.md @@ -0,0 +1,67 @@ +# Compile to C# + +The C# backend writes an independently buildable .NET 10 project. Use it when generated source belongs in your build, when you need to inspect a translated program, or when you want to make further changes in C#. + +For FScript's additional call, closure, tail-recursion, and pruning optimizations, use the [.NET assembly target](./compile-to-dotnet.md). Building generated C# does not enable those assembly-only passes. + +## Generate, build, and run + +```sh +fscript compile hello.fss --target csharp --output out/hello-csharp +dotnet build out/hello-csharp/Program.csproj -c Release +dotnet run --project out/hello-csharp/Program.csproj -c Release -- Ada +``` + +Building the generated project requires the .NET 10 SDK. From the FScript checkout, generation can instead use: + +```sh +dotnet run --project src/FScript -- compile samples/hello.fss --target csharp --output out/hello-csharp +``` + +Generation writes source and a project file; it does not invoke the SDK to build that project. After building, execution uses the generated program and its dependencies, without an interpreter, source script, or `.fsir` artifact. + +Generated executables print the final value by default. Add `--no-result` when compiling to suppress that display and permit pure discarded work to be pruned. Explicit `Console.writeLine` calls remain observable. Successful execution returns status `0`, independently of the final value; `Env.setExitCode` selects another status without stopping execution. The generated `Program.ExitCode` property exposes the selected status to callers without changing the host process. See [results and shell status](./compiler-cli.md#results-and-shell-status). + +## Project layout + +```text +out/hello-csharp/ + Program.cs + Runtime.cs + Program.csproj + RuntimeSDK.cs # when SDK provider adapters are needed +``` + +`Program.cs` contains generated declarations, concrete data types, helper methods, and the entry point. `Runtime.cs` supplies collection and runtime support. SDK-backed programs also receive `RuntimeSDK.cs` and explicit managed assembly references. + +The default generated class is `FScript.Generated.Program`. Its entry point calls `Run`, formats the final FScript value, and writes it to stdout. Console writes in the script appear before that final result. Exports use typed public properties; genuine function values use typed delegates. + +Generated names and internal layout may change between compiler versions. Regeneration replaces compiler-owned files, so keep hand-written changes separately or work in another directory. + +## Types and functions + +Reachable polymorphic uses are specialized to concrete types. Integers become `long`, floats become `double`, Booleans become `bool`, and strings become `string`. Lists use arrays, options use typed structs, maps use ordered entries, and records, tuples, and unions use generated typed declarations. FScript equality and formatting use dedicated helpers. + +A curried function may appear as nested `Func` delegates. Captures and partial applications can remain visible in the output. The source target shares specialization and simplification with the assembly target, but does not run its additional native-call lowering, self-tail-call loop conversion, or aggressive generated-member pruning. Ordinary C# release compilation and the .NET JIT still perform their own optimizations. + +See [Compilation and optimizations](./compiler-optimizations.md) for the full distinction. + +## .NET FFI and references + +Provider selection uses the same `fscript.toml`, `--config`, `--extern-assembly`, and `--no-default-externs` options as other CLR compilation workflows. Add explicit dependencies with repeated `--reference` arguments: + +```sh +fscript compile extension.fss --target csharp --output out/extension-csharp --extern-assembly path/to/Provider.dll --reference path/to/Dependency.dll +``` + +The generated project records assembly references using paths resolved on the compiling machine. Keep those assemblies available while building. When moving the project, update reference paths or replace them with your own project/package references. The SDK copies private managed dependencies into the application's build output. + +Generated adapters support registered host values, callbacks, and tasks. Compiler-only typed mappings can instead link exact CLR methods and native types. See [typed FFI bindings](./compile-to-dotnet.md#prunable-typed-ffi-bindings) for the provider contract and compatibility requirements. + +`--single-file`, `--aot`, and `--runtime` are FScript CLI options for `--target dotnet`; they are rejected with `--target csharp`. Use that target for FScript-managed publishing. You can also maintain and publish an owned C# project through your normal .NET build process, subject to its dependencies' trimming and AOT requirements. + +## Diagnostics + +The C# backend reports `FSC6xxx` diagnostics, including unsupported CLR signatures and representations that cannot be specialized. Shared frontend and IR errors retain their own codes and source spans. + +An unconstrained result such as `let identity value = value` followed by `identity` has no concrete native signature. Apply it at a concrete type or give its boundary an explicit concrete annotation. A generalized initializer is also rejected when specialization would duplicate an observable effect. diff --git a/docs/guides/compile-to-dotnet.md b/docs/guides/compile-to-dotnet.md new file mode 100644 index 0000000..db19983 --- /dev/null +++ b/docs/guides/compile-to-dotnet.md @@ -0,0 +1,181 @@ +# Compile to .NET + +The .NET backend compiles a typed FScript program into an optimized .NET assembly. For a buildable source project, use [the C# backend](./compile-to-csharp.md). Generated programs do not require the source script, a `.fsir` file, `ScriptHost`, or an interpreter. + +## Build-machine requirements + +| Operation | Requirements | +| --- | --- | +| Generate a `.dll` with `--target dotnet` | FScript and a .NET 10 runtime; no SDK required. Roslyn is bundled with FScript and emits the assembly in-process. | +| Publish with `--single-file` | .NET 10 SDK available through `dotnet` on PATH. | +| Publish with `--aot` | .NET 10 SDK plus the target platform's native build tools; build on the target OS. | + +Running FScript itself from source with `dotnet run` requires the SDK to build FScript. That is separate from the installed compiler's requirements. A generated ordinary DLL needs a .NET 10 runtime to run; published single-file and AOT executables do not require a .NET installation on the destination machine. + +## Runnable .NET assembly + +```sh +dotnet run --project src/FScript -- compile samples/fibonacci.fss --target dotnet --output out/fibonacci-dotnet +dotnet out/fibonacci-dotnet/fibonacci.dll +``` + +Compiled entry points print the final value by default. Add `--no-result` when compiling to suppress it and allow proven-pure discarded computations to be pruned. Explicit output, failures, and exit-code writes remain observable. Without this flag, library callers can retrieve the typed value through `Run` and format it explicitly with `FormatResult`; in discard mode, `Run` returns unit. + +Output includes a `.dll`, runtime configuration, and required external managed dependencies. The minimum runtime is .NET 10. Arguments after the assembly name become `Env.Arguments`. + +```sh +dotnet run --project src/FScript -- compile samples/basic/basic.fss --target dotnet --output out/basic-dotnet +dotnet out/basic-dotnet/basic.dll samples/basic/helloworld.bas +``` + +Compiled filesystem operations use the process working directory and OS permissions. Interpreter sandbox and execution-budget settings do not apply to standalone binaries. + +Assembly compilation resolves known calls and partial applications, lowers self tail calls to loops, and removes unused generated support code. Functions that escape into collections or FFI still use typed delegates. These optimizations apply to the assembly target. See [Compilation and optimizations](./compiler-optimizations.md) for the pass-by-pass comparison and its limits. + +## Single-file and Native AOT executables + +Both options produce one executable containing the compiled program and its dependencies. A .NET runtime installation is not required on the destination machine. + +```sh +# Self-contained bundle with the .NET runtime +fscript compile samples/hello.fss --target dotnet --single-file --output out/hello-single +./out/hello-single/hello Ada + +# Ahead-of-time compiled native executable +fscript compile samples/hello.fss --target dotnet --aot --output out/hello-native +./out/hello-native/hello Ada +``` + +These flags are available only for `--target dotnet`. When `--runtime` is omitted, publishing targets the current .NET host runtime identifier (`RuntimeInformation.RuntimeIdentifier`), so both commands above build for the current platform. Pass `--runtime ` to select another target. An explicitly supplied `--runtime` still requires a value. Use .NET runtime identifiers: + +| Platform | x64 | Arm64 | +| --- | --- | --- | +| macOS | `osx-x64` | `osx-arm64` | +| Linux | `linux-x64` | `linux-arm64` | +| Windows | `win-x64` | `win-arm64` | + +Invalid or unsupported identifiers produce `FSN7101` before SDK publishing. The diagnostic includes the supplied identifier and supported values; `darwin-arm64`, for example, suggests `osx-arm64`. + +When invoking FScript from source, put `--` between `dotnet run` options and FScript arguments: + +```sh +dotnet run --project src/FScript -- compile samples/hello.fss --target dotnet --aot --output out/hello-native +``` + +Without that separator, `dotnet run` can consume `--runtime` itself and fail while building FScript, before its CLI starts. Such SDK errors cannot be reported by FScript. + +Windows output has an `.exe` extension; macOS and Linux output has no extension. Use a fresh output directory when switching from DLL output: existing files are not deleted. External data such as BASIC source files remains program input and is not bundled. + +Publishing requires a .NET 10 SDK on the build machine and may restore runtime/compiler packs from NuGet. Native AOT additionally requires the platform's native build tools (Xcode Command Line Tools on macOS; Clang and zlib headers on Linux; Visual Studio C++ build tools on Windows). Native AOT must be built on the target OS; single-file managed publishing can target another OS. The executables still use normal OS libraries. See Microsoft's [single-file](https://learn.microsoft.com/dotnet/core/deploying/single-file/) and [Native AOT](https://learn.microsoft.com/dotnet/core/deploying/native-aot/) deployment documentation. + +Single-file publishing trims dependencies when all reachable FFI calls have static CLR bindings. Reachable legacy provider dispatch disables managed trimming to preserve its registration contract. Bundled native runtime libraries may be extracted by the .NET host at startup. Native AOT trims and compiles dependencies, so FFI libraries must be AOT-compatible. Dynamic loading or reflection-heavy providers may produce SDK diagnostics instead of a runnable native binary. Packaging failures are reported as `FSN710x`, including the SDK's diagnostics. + +The compiler packages its optimized assembly; it does not recompile the script through the C# source target. The ordinary DLL target remains available without invoking `dotnet publish`. + +## C# source project + +`--target csharp` generates source instead of an assembly. Its project layout, build commands, and reference handling are covered in [Compile to C#](./compile-to-csharp.md). + +## Existing FFI providers + +Compilation uses ordinary `fscript.toml` discovery. `--config`, `--no-config`, `--extern-assembly`, and `--no-default-externs` select the environment. Repeat `--reference ` to add managed references. + +```sh +dotnet build samples/ffi/FfiSample.fsproj -c Release +dotnet run --project src/FScript -- compile samples/ffi/main.fss --target dotnet --output out/graphics-dotnet +dotnet out/graphics-dotnet/main.dll --headless +``` + +Generated adapters call existing providers through the extension SDK and transport records, collections, unions, opaque payloads, callbacks, and tasks. `ExternalCallContext.Apply` invokes compiled functions. Provider factories run during compilation for metadata and once in the generated process when needed. + +## Prunable typed FFI bindings + +Existing interpreter providers remain unchanged. To make compiled calls direct and suitable for Native AOT, a provider class can additionally expose these public static parameterless metadata methods: + +- `FScriptCompiledFunctions() : IEnumerable>` +- `FScriptCompiledTypes() : IEnumerable>` + +They run only during compilation. Keys are the registered FScript function/type names. Functions map to exact public, closed CLR methods; instance receivers are explicit first arguments. Types map to their CLR representations. Provide semantically equivalent typed entry points and immutable or snapshot-compatible external values. Unsupported native shapes can use explicit scalar/record adapters. + +For example, an existing provider can map its `Ext.add` declaration to a typed method: + +```csharp +public static long Add(long left, long right) => left + right; + +public static IEnumerable> + FScriptCompiledFunctions() => new[] + { + KeyValuePair.Create("Ext.add", typeof(MyProvider).GetMethod( + nameof(Add), new[] { typeof(long), typeof(long) })!) + }; +``` + +The compiler emits a direct CLR call without constructing the provider registration, searching a function list, or transporting SDK values for that binding. Only used bindings and external types become compilation roots. Unused provider assemblies are omitted from emitted dependencies. The JIT can inline direct calls; trimmed single-file publishing and Native AOT remove unreachable provider methods and types. Metadata methods themselves are not runtime roots. + +No SDK record shape or interpreter registration API change is needed: the optional metadata uses BCL types. `ClrBindings.bindCompiledProviders` exposes the same linking step for compiler API consumers; the CLI discovers the companions automatically for CLR targets. The resulting CLR links remain serializable in LIR. + +Legacy SDK provider factories can still be used in DLL and managed single-file output. Their opaque delegate registrations may retain sibling implementations. Native AOT rejects a reachable legacy SDK dispatch bridge with `FSN7105` and requests typed mappings instead of silently suppressing linker warnings. + +## Pure FFI and external values + +Providers can optionally declare a trusted `Pure` guarantee. Undeclared functions and external types remain conservative. + +- A **pure function** is deterministic, has no observable effects, and terminates successfully for valid inputs. Required runtime initialization is part of this promise. Returning the same value while logging, mutating hidden state, reading a clock, or sometimes failing does not qualify. +- A **pure external type** has deeply immutable visible data and opaque payloads. Registered field reads, structural equality, and formatting must also be deterministic, effect-free, and terminating successfully. A readonly CLR property alone does not establish this guarantee. Constructors and ordinary methods need their own function declarations. + +For callback-taking functions, the promise applies when supplied callbacks satisfy the same guarantee. The optimizer separately checks callback effects and remains conservative for unknown callbacks. A pure factory does not automatically make a returned callable pure. + +Expose these public static parameterless methods on the provider class: + +```csharp +public static IEnumerable FScriptPureFunctions() => new[] +{ + "Ext.add" +}; + +public static IEnumerable FScriptPureTypes() => new[] +{ + "Point" +}; +``` + +Names must exactly match the provider's registered script functions and types. The example assumes the provider registers both `Ext.add` and `Point`. Empty or absent metadata means no guarantees. Unknown names and attempts to override protected runtime contracts are compilation errors. + +The CLI reads this metadata during compilation for IR, C#, and .NET output. It can be used with either existing SDK adapters or direct [typed CLR mappings](#prunable-typed-ffi-bindings). Existing SDK registration records do not need to change. These methods are not runtime roots and do not add FScript declaration syntax. + +Compiler API users can supply the same information explicitly: + +```fsharp +open FScript.Language +open FScript.Compiler + +let purity = + { PurityContracts.empty with + PureFunctions = Set.singleton "Ext.add" + PureTypes = Set.singleton "Point" } + +// registration and input are the host's existing compiler inputs. +Compiler.compileWithRegistrationAndPurity registration purity input +``` + +`Compiler.compileWithPurity` accepts contracts with ordinary `CompileInput.Externs`; `ClrBindings.providerPurity` discovers contracts from provider `MethodInfo` values. Ordinary compilation APIs default to empty contracts. + +The compiler can remove an unused pure call and then prune its binding, adapters, and dependencies when no other retained code needs them. Effects or failures in its argument expressions are still preserved. A type guarantee permits removal of unused field reads, equality, and formatting when the complete computation is proven pure. It does not make its factory or methods pure. + +Declarations are trusted, not verified by executing arbitrary provider code. Incorrect claims can remove behavior or failures after optimization. Normal AST interpretation and SDK boundary validation are unchanged. See [Compilation and optimizations](./compiler-optimizations.md#trusted-external-purity) for the pruning rules. + +## Compiler APIs + +Use `Compiler.compileWithRegistration` for host signatures. `ClrBindings.bindMethod` links an exact public CLR method or constructor; instance receivers are explicit first arguments. `ClrBindings.bindType` projects a native CLR type. `ClrBindings.bindProvider` preserves SDK providers. These declarative links survive IR serialization. + +`DotNetBackend.generate` accepts `OutputKind = Library` for library assemblies or `ConsoleApplication` for executables. Generated classes expose `Run`, `FormatResult`, and exported bindings. `CSharpBackend.generate` emits source files instead. See the [backend specification](../specs/dotnet-backends.md). + +Representation and CLR linkage diagnostics use `FSC6xxx`, including failures from the assembly target's shared emitter. Assembly emission and publishing diagnostics use `FSN7xxx`. Frontend and IR errors retain their own codes and source spans. Roslyn errors or warnings prevent assembly output. Reachable open polymorphic results and generalized initializers with effects remain compilation diagnostics under whole-program specialization. + +## Exit status and embedding + +`Env.setExitCode : int -> unit` selects the eventual shell status without stopping evaluation or task execution. Valid codes are `0` through `255`; the default is `0`. The last completed write wins. Writes from tasks are synchronized, but their scheduling order can change the final code. For a predictable code, await the tasks and set it in the main flow. Existing task completion and failure rules still apply; the setter does not add cancellation or bypass shutdown. + +The generated `Program.ExitCode` property exposes status to embedding callers. Calling `Run` or an exported function does not change the host process's `Environment.ExitCode`. The executable `Main` returns the selected status after normal completion. Unhandled failures take precedence and return a nonzero process status. + +The compiler APIs `CSharpBackend.generateWithResultOutput`, `DotNetBackend.generateWithResultOutput`, and `DotNetBackend.generateExecutableWithResultOutput` take a Boolean display policy before their ordinary options. Existing generation APIs default to printing. Passing `false` discards the entry value before specialization and prunes unused pure work; exported library bindings remain roots. diff --git a/docs/guides/compiler-cli.md b/docs/guides/compiler-cli.md new file mode 100644 index 0000000..440762f --- /dev/null +++ b/docs/guides/compiler-cli.md @@ -0,0 +1,41 @@ +# Compiler CLI + +The compiler emits a versioned FScript LIR artifact, a C# source project, or a standalone .NET assembly. + +```text +fscript compile --target ir --output +fscript compile --target csharp --output +fscript compile --target dotnet --output +``` + +The IR form writes `/.fsir`. + +All targets create missing parent directories and deterministically replace files owned by the selected output on a repeated invocation. An unknown target is rejected before the output directory is created. Filesystem failures are reported as `FSA5101` diagnostics. + +The C# target writes an independently buildable .NET 10 project. The .NET target writes `.dll`, runtime configuration, and managed dependencies. Both support existing FFI providers selected through `fscript.toml` or `--extern-assembly`; `--reference` adds managed dependencies. Generated programs execute compiled methods without an interpreter. Compiled entry points display the final value by default; `--no-result` suppresses that display. + +For a self-contained executable, add `--single-file` to the .NET target. For a Native AOT executable, use `--aot`. Publishing defaults to the current platform; pass `--runtime ` to select another target. An explicitly supplied `--runtime` requires a value. Runtime identifiers use .NET names such as `osx-arm64`, `linux-x64`, and `win-x64`. Both options require a .NET 10 SDK for publishing and are rejected for other backends. + +See [Compilation](./compilation.md), [Compile to .NET](./compile-to-dotnet.md), [Compile to C#](./compile-to-csharp.md), [Compilation and optimizations](./compiler-optimizations.md), and [Compile and Interpret FScript IR](./interpret-ir.md). The normative representations are documented in the [typed HIR](../specs/typed-hir.md) and [executable LIR](../specs/executable-lir.md) specifications. + +## Results and shell status + +Printing the final value is the default for interpreted file/stdin execution and compiled applications. Use `--no-result` to suppress that display: + +```sh +fscript --no-result program.fss +fscript compile program.fss --target dotnet --no-result --output out/program +fscript compile program.fss --target csharp --no-result --output out/source +``` + +The compilation flag is baked into the generated entry point; it is not consumed from a compiled application's arguments. Explicit `Console.writeLine` output and diagnostics remain visible. The REPL also accepts `--no-result`. IR artifacts retain their program values and do not accept this compilation flag. + +The final value never becomes a process exit status. Successful execution returns `0` unless `Env.setExitCode` selects another status. An unhandled failure still returns a nonzero status, even if the program selected `0` beforehand. Suppressing a result does not suppress failures or stop evaluation. Compilers may remove discarded work only when it is proven pure and total. + +```fsharp +Env.setExitCode 7 +Console.writeLine "Evaluation continues." +42 +``` + +This prints the explicit message and, by default, `42`; the shell receives status `7`. With `--no-result`, only the explicit message is printed and the status remains `7`. diff --git a/docs/guides/compiler-optimizations.md b/docs/guides/compiler-optimizations.md new file mode 100644 index 0000000..a796f5d --- /dev/null +++ b/docs/guides/compiler-optimizations.md @@ -0,0 +1,147 @@ +# Compilation and optimizations + +Both native targets use the same inferred FScript types. The .NET assembly target adds passes intended to reduce calls, closure work, and unused generated code. The C# target produces a complete buildable source project and does not run those additional assembly passes. + +These passes run automatically. There is no FScript CLI optimization-level switch. Native AOT is a publishing choice after assembly optimization, rather than a separate FScript language mode. + +## Which target performs which work? + +| Transformation | C# project | .NET assembly | +| --- | --- | --- | +| Specialize reachable polymorphic uses | Yes | Yes | +| Simplify constants, branches, aliases, and unused pure bindings in shared IR | Yes | Yes | +| Use declared FFI purity and external-type guarantees | Yes | Yes | +| Eliminate repeated proven-pure expressions | Yes | Yes | +| Additional known-call and partial-application reduction | No | Yes | +| Native methods for saturated calls | No | Yes | +| Proven self-tail calls converted to loops | No | Yes | +| Typed loops for known collection callbacks | No | Yes | +| Aggressive pruning of generated methods, fields, and support types | No | Yes | +| FScript-managed single-file or Native AOT publishing | No | Yes, when requested | + +Building C# in Release mode still enables the C# compiler's normal optimizations. Managed assemblies receive JIT optimization at runtime; Native AOT performs native compilation at publish time. FScript does not guarantee that either toolchain will inline a particular CLR method. + +## Concrete specialization + +A polymorphic declaration can be instantiated at several concrete types: + +```fsharp +let identity value = value +(identity 42, identity "answer") +``` + +Each reachable use receives a concrete representation and function signature. Specialization keys deduplicate matching instantiations and handle recursive functions before traversing their bodies. An unused pure polymorphic declaration need not appear in the output. + +A reachable value must have a representable type. A final unconstrained function is a compilation error; a function with concrete arguments and a concrete result can remain a first-class value. Exported library bindings also need concrete native types. Specialization can increase code size when a function is used at many types. + +## Calls, currying, and captures + +The .NET backend follows known function values through bindings and partial applications. When it can prove the callee and make its captures available, it reduces a nonrecursive call into the caller's body or emits a typed method call with the supplied arguments. + +```fsharp +let add amount value = amount + value +let increment = add 1 +List.map increment [1..4] +``` + +This need not allocate a general partial-application object on each iteration. Known applications can become direct work in a typed collection loop. Captured expressions still evaluate once at the correct source position. + +Functions that escape, depend on an unknown higher-order parameter, or cross an FFI callback boundary may retain typed delegates and captured environments. Compilation does not remove every closure, delegate invocation, or allocation. + +## Tail recursion + +Proven saturated self calls in tail position become loops in the .NET assembly target: + +```fsharp +let rec sum remaining total = + if remaining = 0 then total + else sum (remaining - 1) (total + remaining) + +sum 1000000 0 +``` + +The recursive call is the complete result of that branch. Next arguments are evaluated before parameters are reassigned and execution continues. The compiler recognizes tail calls behind local bindings, conditionals, and pattern decisions. Escaping closures retain captured values from their original iteration. + +A call with pending work is not a tail call: + +```fsharp +let rec fibonacci n = + if n < 2 then n + else fibonacci (n - 1) + fibonacci (n - 2) + +fibonacci 20 +``` + +The additions still need the call results, so this remains recursive. Mutual recursion is also not converted into a native loop by the current assembly pass. Do not assume arbitrary recursion is stack-safe in compiled output. + +## Collections and Boolean expressions + +Known list callbacks can lower to typed loops and direct calls for mapping, iteration, folding, filtering, choosing, collecting, existence tests, and searches. This avoids some delegate machinery; operations that create changed immutable collections still allocate their results. + +Constant Boolean terms and branches are simplified when doing so preserves evaluation. A condition such as `condition && true` can become `condition`. Short-circuiting still skips the right operand when the left operand determines the result. An effectful or potentially failing expression cannot be dropped merely because a later term is constant. + +## Common-subexpression elimination + +Both compiled targets reuse a proven-pure computation when the same typed expression has already been evaluated on every path reaching the later use: + +```fsharp +let score n = + ((n + 1) * (n + 1), (n + 1) * (n + 1)) +``` + +The addition and multiplication can each execute once per call to `score`. The pass also handles repeated intrinsic calls, explicitly pure FFI calls, immutable aggregates, and field observations backed by pure external-type contracts. It follows immutable aliases and preserves concrete types, lexical identities, and floating-point bits, including signed zero. + +Reuse starts at the first evaluation; the compiler does not move branch-local work ahead of its condition. A value computed before a branch can serve either arm, but values computed inside an arm do not escape into another arm or the continuation. Short-circuit operands, pattern guards, and loop bodies retain their conditional execution. Observable operations invalidate available computations; unmarked external values and potentially failing or nonterminating computations remain conservative. + +Shared values are ordinary local bindings or previously initialized globals. Function invocations and loop iterations have separate local evaluations. No runtime lookup table, persistent cache, or memoization is introduced. Computations that are not shared retain their original expression shape after temporary cleanup. + +## Dead code and effects + +Generated-member reachability begins at program execution, result formatting, the executable entry point, and exported bindings. Unused generated methods, fields, runtime helpers, and types can be removed. Closed exports remain available to callers even if the script itself does not invoke them. + +Observable initialization remains ordered: + +```fsharp +let unused value = value + 1 +let announced = Console.writeLine "starting" +42 +``` + +The unused function can disappear, but the console write must remain. Console operations, filesystem access, tasks, imports, unknown callbacks, and failures are treated conservatively. Neither an unused result nor immutability makes I/O pure. + +A generalized initializer cannot be duplicated if it performs observable work. The compiler reports a diagnostic rather than introducing a value restriction or silently repeating the effect. Move one-time effects outside the generalized function or give its boundary a concrete type. + +## Trusted external purity + +[FFI providers](./compile-to-dotnet.md#pure-ffi-and-external-values) can declare the same strong `Pure` guarantee used by the optimizer: deterministic, effect-free, and guaranteed to terminate successfully for valid inputs. External type guarantees additionally cover deep immutability and safe, terminating registered field reads, equality, and formatting. No callable member becomes pure just because its receiver type is pure. Implicit imported-record construction, updates, and conversions remain conservative because they may invoke CLR constructors. A pure type does not make those constructors pure; use an explicitly pure factory binding when that guarantee holds. + +Both source and assembly specialization can use these contracts. An unused pure call may be removed, including through known FScript wrappers. Afterward, unused bindings and adapters can disappear; the assembly target can also omit provider dependencies that are no longer referenced. Argument expressions are analyzed separately, so `pureFunction (1 / 0)` must still fail and an argument that writes to the console must still execute. + +Curried application boundaries are retained in IR. Creating a pure function value and invoking a callable returned from it are separate operations. Callback-taking FFI and known higher-order collection operations require sufficiently strong callback proofs; unknown or effectful callbacks preserve the call. + +Failure is observable. Division is not considered pure unless its divisor and any signed-overflow case are proven safe. Explicit failures, potentially exhausted matches, and unproven recursive cycles remain observable even without mutation or I/O. Tail-call lowering does not establish termination. Observable generalized initializers that cannot be represented safely receive a diagnostic rather than silently disappearing. + +The contracts survive resolved inference, HIR, LIR, CLR linkage, specialization, and `.fsir` serialization. Older artifacts without them load conservatively. Provider declarations are trusted promises; FScript cannot generally verify their implementations. These contracts support pruning, safe local propagation, and common-subexpression elimination in both compiled targets. They do not enable automatic memoization. + +## FFI pruning and executable publishing + +There are two levels of pruning: + +- **Assembly generation:** remove unused generated code and external type declarations, and omit provider assemblies that the emitted program does not reference. Referenced provider DLLs remain intact. +- **Trimmed publishing:** remove unreachable code inside dependencies as well. Managed single-file output enables this when all reachable FFI bindings are static; Native AOT trims dependencies before native compilation. + +SDK provider factories can return opaque delegate registrations. Sibling implementations may remain reachable through registration, and managed single-file output disables trimming when that legacy dispatch path is used. Native AOT reports `FSN7105` for a reachable legacy SDK adapter. [Typed FFI mappings](./compile-to-dotnet.md#prunable-typed-ffi-bindings) provide exact CLR calls so the linker can follow their dependencies and trim unused implementations. + +Self-contained single-file output still includes a managed runtime. Native AOT produces native machine code, but neither mode embeds arbitrary input files or removes the need for normal OS libraries. See [the .NET publishing guide](./compile-to-dotnet.md#single-file-and-native-aot-executables) for runtime identifiers and toolchain requirements. + +## Interpreted execution + +Ordinary CLI execution and `ScriptHost` still use the AST interpreter; JavaScript embedding remains interpreted. Native specialization, call lowering, and assembly pruning are not enabled on those paths. The separate LIR interpreter executes validated IR and has its own tail-call trampoline; it does not run the .NET assembly backend's passes. + +For API contracts, representations, and validation details, see the [.NET backend specification](../specs/dotnet-backends.md). + +## Discarding the entry value + +Compile with `--no-result` to remove the entry value as a reachability root before specialization. Pure and total computations used only for that value can disappear, including their functions, helpers, and dependencies. This can also permit an unused open pure value such as `None` to be discarded. Observable calls, potential failures, and `Env.setExitCode` writes remain roots; the option never licenses dropping failures or effects. No result-based exit-code inference is performed. + +Printing remains the default. Setting an exit code is never pure, including when two writes use the same integer. Tasks may share this status, so synchronized writes remain scheduling-dependent and are not deduplicated or reordered. diff --git a/docs/guides/interpret-ir.md b/docs/guides/interpret-ir.md new file mode 100644 index 0000000..ccd559a --- /dev/null +++ b/docs/guides/interpret-ir.md @@ -0,0 +1,132 @@ +# Compile and Interpret FScript IR + +FScript can compile one complete source program into a versioned `.fsir` artifact and execute its LIR from .NET without returning to parser AST evaluation. + +## Produce an artifact + +```bash +fscript compile program.fss --target ir --output ./out +``` + +For `program.fss`, this writes: + +```text +out/program.fsir +``` + +From the repository: + +```bash +dotnet run --project src/FScript -- \ + compile program.fss --target ir --output ./out +``` + +The artifact is canonical indented JSON. It contains the complete validated LIR program, format/version metadata, compiler and language versions, source hashes for file-backed inputs, and ordered foreign dependencies. + +Treat `.fsir` as an internal build artifact. Version 1 has no backward-compatibility guarantee; use matching compiler and interpreter builds. + +## Reference the interpreter + +The compiler and interpreter are separate assemblies. In a repository-local .NET project, add: + +```xml + + + + +``` + +`FScript.Compiler` owns LIR and artifact serialization. `FScript.Interpreter.Lir` owns execution. Both APIs currently use the `FScript.Compiler` namespace. + +## Load and execute + +```fsharp +open System +open System.IO +open FScript.Compiler + +let artifact = File.ReadAllBytes "out/program.fsir" + +match IrArtifact.deserialize artifact with +| Error diagnostics -> + for diagnostic in diagnostics do + eprintfn "%s: %s" diagnostic.Code diagnostic.Message + 1 +| Ok program -> + let context = + { ScriptName = Some "program.fss" + Arguments = [ "first"; "second" ] } + + match LirInterpreter.execute context program with + | Error diagnostic -> + eprintfn "%s: %s" diagnostic.Code diagnostic.Message + 1 + | Ok execution -> + for line in execution.Stdout do + printfn "%s" line + + printfn "Result: %A" execution.Value + 0 +``` + +`ExecutionResult.Stdout` contains `Console.writeLine` output in execution order. `Console.readLine` reads the interpreter process stdin and returns `None` at EOF; an embedding host can provide deterministic input with `Console.SetIn` around execution. `ExecutionResult.Value` is an `LirValue`, with cases for primitives, tuples, lists, records, options, unions, ordered maps, type tokens, and callable/runtime handles. + +Applications should pattern-match `LirValue` when they need a stable domain conversion instead of relying on `%A` formatting. + +## Compile in memory + +Source can also be compiled and executed without writing `.fsir`: + +```fsharp +open FScript.Compiler +open FScript.Language + +let input = + { Program = Parser.parseProgram "let add x y = x + y\nadd 1 2" + Externs = [] } + +match Compiler.compile input with +| Error diagnostics -> Error diagnostics +| Ok compiled -> + LirInterpreter.execute + { ScriptName = None; Arguments = [] } + compiled.Lir + |> Result.mapError List.singleton +``` + +Use `parseFileWithIncludes` through the normal host/CLI path when compiling file-backed programs with include resolution. `Parser.parseProgram` parses only the supplied source text. + +## Validation and failures + +Deserialization performs all of these checks before returning a program: + +1. JSON and required metadata are valid. +2. `format` is `fscript-lir`. +3. `irVersion` is supported. +4. DTO fields reconstruct a complete LIR program. +5. `LirValidation.validate` accepts the reconstructed program. + +`LirInterpreter.execute` validates caller-created LIR again before execution. + +Diagnostic families are: + +- `FSA5xxx`: artifact format, version, metadata, or reconstruction; +- `FSL2xxx`: malformed or inconsistent LIR; +- `FSI3xxx`: execution failure or unsupported reachable linkage. + +An executed `raise`, failed match, integer division by zero, or invalid collection operation returns a structured interpreter diagnostic. The interpreter rejects reachable target imports, Tasks, and arbitrary host externs. Unused unsupported declarations remain inert. + +## Runtime context + +`InterpreterContext` supplies the compiler runtime-context intrinsic: + +```fsharp +type Environment = { + ScriptName: string option + Arguments: string list +} + +let Env : Environment +``` + +The interpreter does not read process arguments implicitly. The embedding host decides exactly which script name and arguments the program receives. diff --git a/docs/specs/README.md b/docs/specs/README.md index 53d0d05..ee4e37a 100644 --- a/docs/specs/README.md +++ b/docs/specs/README.md @@ -4,6 +4,10 @@ Normative behavior for the language, runtime surface, hosting model, and editor/ ## Language and type system +- Compiler semantic baseline: [`compiler-semantics-baseline.md`](./compiler-semantics-baseline.md) +- Typed high-level IR (HIR): [`typed-hir.md`](./typed-hir.md) +- Executable low-level IR (LIR): [`executable-lir.md`](./executable-lir.md) +- C# and .NET compilation: [`dotnet-backends.md`](./dotnet-backends.md) - Syntax and indentation: [`syntax-and-indentation.md`](./syntax-and-indentation.md) - Supported types: [`supported-types.md`](./supported-types.md) - Function annotations: [`function-annotations.md`](./function-annotations.md) diff --git a/docs/specs/compiler-semantics-baseline.md b/docs/specs/compiler-semantics-baseline.md new file mode 100644 index 0000000..8a2674e --- /dev/null +++ b/docs/specs/compiler-semantics-baseline.md @@ -0,0 +1,94 @@ +# Compiler Semantic Baseline + +## Purpose + +This document records the behavior that the typed IR, LIR interpreter, and compiled backends must preserve. The current type inference and evaluator are the reference until cross-runtime conformance replaces that dependency. + +## Frontend and execution + +- Includes are resolved into one flattened program before inference. Alias-qualified declarations are rewritten by the include resolver; unresolved `SImport` nodes are rejected by inference. +- Hindley-Milner inference generalizes top-level and local let bindings after applying substitutions. Recursive bindings are inferred monomorphically inside their recursive group and generalized afterward. +- The active typed program stores top-level types but retains parser expressions in bodies. Compiler lowering therefore requires a new resolved, recursively typed result emitted by the inference pass; types cannot safely be reconstructed afterward. The legacy typed-program API projects this result's `TypedProgram`, so it does not maintain a second inference path. +- Resolved inference exposes parser-independent semantic statement, expression, and pattern trees whose nodes carry their final instantiated type, span, lexical reference kind, resolved primitive operation, and named/structural record-coercion evidence. It also exposes deterministic symbols for every lexical binding category and links each captured reference to its target ID. Repeated occurrences of one pattern binding reuse one ID so equality constraints cannot be lost during lowering. Type-variable numbering in resolved schemes and reference types is normalized independently of prior inference calls. +- Interpolation placeholder expressions retain their absolute file, line, and column positions. Identical placeholder text in different lexical scopes therefore resolves to the parameter or pattern binding visible at its actual source location. +- Top-level declarations resolve sequentially: a non-recursive shadowing initializer refers to the preceding binding, recursive groups see every peer atomically, and subsequent expressions refer to the newest binding. +- HIR reuses those resolved IDs unchanged for source symbols even when type and value declarations are interleaved; compiler-synthesized temporaries and constructor payload parameters occupy IDs above the resolved frontend range. +- Top-level statements execute in source order. Every non-final expression must have type `unit`; the final expression is the program result. +- LIR expression children execute strictly from left to right and stop at the first failure; later arguments, aggregate fields, interpolation parts, map entries, and ordinary operands are not evaluated after that failure. Boolean operators additionally skip an unnecessary right operand. +- Boolean `&&` and `||` evaluate the left operand first and skip the right operand when the result is already known. The legacy evaluator, LIR interpreter, and compiled backends share this short-circuit behavior. +- Pipeline application retains its distinct value-then-function evaluation order through resolved inference, HIR, LIR, interpretation, serialization, and native generation; it is not rewritten into ordinary function-first application. +- Compiled top-level expressions execute exactly once in source order even when interleaved with declarations. Top-level pattern bindings evaluate their scrutinee once, fail before later statements when unmatched, and expose all bound names to subsequent statements. + +The first aggregate compiler slice preserves tuple field order, record field names, option presence, list element order, list cons/append behavior, and recursively structural equality through HIR, serialized LIR, interpretation, and native generation. + +Ranges preserve inclusive ascending or descending order. List indexing returns an option and never throws for an out-of-range integer. Record updates allocate a new value, interpolation evaluates embedded expressions from left to right, and generated program output uses FScript value formatting rather than host-language default aggregate formatting. + +Declared unions retain their type and case identity plus an optional erased payload. Constructors are deterministic compiler declarations, qualified and unqualified case references share one identity, pattern tests check both type and case tags, and equality recursively compares payloads. + +Compiled maps use an ordered entry representation for string and integer keys. Explicit key/value entries replace an earlier value; spread entries retain values already present on their left. Indexing returns an option, and deterministic ordering participates in artifacts, equality, formatting, and compiled-program behavior. +- `Map.ofList` and `Map.add` restore canonical key order after insertion or replacement rather than exposing source-list insertion order. +- Functions are curried. Multi-argument declarations are nested lambdas, application is one argument at a time, and LIR closures record only their deterministic free-symbol capture set. Single and mutual recursive function groups are supported. +- Local mutual-recursive function groups initialize atomically: every peer is visible from every closure before the group body executes. + +## Types and values + +- Primitive runtime values are unit, signed 64-bit integer, IEEE-754 double, Boolean, and string. +- Tuples and lists preserve element order. Options distinguish `None` from `Some value`. +- Maps currently accept string keys through inference and have deterministic ordered-map behavior. Runtime support for integer map keys is legacy representation detail, not permission for newly compiled programs. +- Declared records retain declaration identity for named annotations. Structural record annotations retain field-shape compatibility and may accept additional fields where current inference permits it. Inference records coercion evidence at the accepting application; HIR and LIR retain an explicit conversion node so backends convert representations without changing compatibility rules. +- HIR, LIR, and version-1 artifacts carry ordinary record and union declarations separately from nominal references. Native backends select concrete representations and preserve structural/named conversions, immutable updates, field projection, formatting, and recursive equality. +- HIR, LIR, and version-1 artifacts also carry the intrinsic `Environment` record and `FsKind` union. Structural record conversions include width conversions from a record with extra fields to a required structural or nominal shape, and recursive named representations are validated without unbounded type expansion. +- Discriminated unions retain their declared type name, case name, and optional payload. Recursive types require `type rec`; mutually recursive type-definition graphs are rejected. +- `typeof` produces an FScript type token and `nameof` produces the resolved source name. +- Compiled local pattern bindings evaluate their source once and use the ordinary match-failure path. Compiled `for` evaluates its list once, executes bodies from first to last, discards their values, and returns unit. Compiled `typeof` retains the resolved declared record or union shape in the artifact instead of performing a name lookup at execution time. + +## Expressions, patterns, and equality + +- Conditionals and match guards require Boolean values and evaluate only the selected branch. +- Match clauses are tried in source order. A guard runs only after its pattern binds successfully. Failure to find a clause is a runtime error. +- HIR patterns lower into LIR projection/check/binding/map-consumption plans. LIR consumers execute that plan vocabulary and never receive source-shaped pattern nodes. +- Patterns cover literals, variables, wildcards, lists, tuples, records, ordered maps, options, union cases, and type-reference tests. Let-pattern failure is a runtime error. +- Compiled map patterns consume entries deterministically in map order, merge repeated bindings only when structurally equal, and bind an optional tail to the remaining ordered map. Compiled type-reference patterns use resolved types rather than source text lookup. +- Record updates evaluate the base once and then updates in source order. Ranges, loops, interpolation, indexing, raise, append, and cons preserve the evaluator's existing evaluation order and failures. +- Equality is structural for primitives, tuples, records, maps, options, lists, unions, and type tokens, recursively. Functions, tasks, constructors, and extern handles are not structurally equal. Backend host-language comparability must not leak into this behavior. +- Integer and floating-point comparisons share the same resolved numeric operations and are executable in both compiled runtimes. Whole-program specialization gives native operands concrete numeric types. Pure collection functions retain their failure behavior, including an explicit runtime error for `List.tail []`. +- Cross-runtime failure conformance classifies explicit `raise`, exhausted pattern matches, and integer division by zero independently of each host runtime's exception or panic text. +- Cross-runtime tests compare the legacy evaluator with artifact-round-tripped LIR execution and compiled backends for successful values and failure categories. Named records passed through typed function boundaries keep record field projection semantics; their nominal annotation must not select a union runtime representation. +- Cross-runtime result formatting quotes strings at every nesting level, renders unit as `()`, renders ordered maps as `map { key => value }`, uses compact semicolon separators for lists, and retains comma-space separators for tuples. +- HIR and LIR are accepted only when artifact-local references resolve, source spans are valid, declaration and expression types agree, calls and control-flow nodes have consistent signatures, aggregate representations match their semantic types, and referenced primitives/imports are available and complete. +- Task signatures and host linkage remain representable in compiled artifacts. An unused task function handle is inert. Fully applying `Task.spawn` or `Task.await` in the LIR interpreter reports `FSI3021`. +- Compiler extern input is declarative: it carries a name, type scheme, arity, and linkage classification, never an executable `.NET` delegate. Host execution values remain confined to the legacy/runtime API. +- `Console.writeLine` evaluates its string argument once, appends one stdout line, and returns unit. LIR reports captured lines in order through `ExecutionResult.Stdout`; native backends emit them in the same order before the final formatted result. +- `Console.readLine ()` consumes one line from process stdin, strips the line terminator, and returns `Some text`. It returns `None` only when stdin is exhausted before any text is read; a final unterminated line is still returned. +- `Fs.readText path` reads the complete text file and returns `Some text`; missing, inaccessible, or otherwise unreadable paths return `None`. This read-only operation is portable so generated command-line programs can load their inputs. +- Tuples and lists remain observably distinct in compiled backends: tuples format with parentheses, lists with brackets, tuple patterns require tuple values, and map pair inputs consume tuple values. + +## Builtins, externs, attributes, and tasks + +- Scalar conversions, string helpers, `List`, `Option`, and `Map` functions are protected builtin symbols with explicit polymorphic schemes. They are initial compiler/runtime intrinsics even where a future implementation can compile their FScript source. +- The LIR interpreter and native backends execute the complete pure builtin catalog, including higher-order list, option, and ordered-map functions. Callback invocation remains curried and follows source collection order. +- Compiled `Env` is a runtime-context intrinsic. The LIR interpreter uses its explicit script name and arguments; native backends use the executable name and process arguments. +- `Task.spawn` and `Task.await` are host externs with tracked-task semantics, background error propagation, and an error for unawaited tasks. HIR may represent them before LIR interpreters or backends support them. +- `export let` marks declarations for embedding hosts and does not change inference. Backend `Import` metadata is separate and will not weaken the declared FScript type. +- The `export let` prefix produces structured `Export` metadata in resolved statements and HIR; this is internal metadata, not source attribute syntax. `Import` attributes retain their two arguments and attribute span on ordinary HIR function/type declarations in addition to dedicated backend linkage. +- Other top-level declaration attributes remain case-sensitive and flow unchanged through resolved statements and HIR; they carry string or identifier arguments but have no evaluator semantics unless a future consumer recognizes them. + +The compiler-owned runtime catalog is declarative and contains no executable host delegates: + +| Classification | Current bindings | +| --- | --- | +| Compiler context intrinsic | `Env` | +| Portable runtime intrinsic | `Console.writeLine`, `Console.readLine`, `Fs.readText` | +| Host filesystem | `Fs.exists`, `Fs.kind`, `Fs.createDirectory`, `Fs.writeText`, `Fs.glob`, `Fs.enumerateFiles`, `Fs.combinePath`, `Fs.parentDirectory`, `Fs.extension`, `Fs.fileNameWithoutExtension` | +| Host regex | `Regex.matchGroups` | +| Pure host candidates | `Hash.md5` | +| Host-only/deferred data services | `Guid.new`, `Json.deserialize`, `Json.serialize`, `Xml.queryValues` | +| Task runtime | `Task.spawn`, `Task.await` | + +All entries are type-checkable and retained as linkage in HIR/LIR. The LIR interpreter supplies the compiler context and portable intrinsics; other linkage requires a registered callback or produces an unsupported diagnostic. Native runtime support is specified in [the .NET backend specification](./dotnet-backends.md). Unused linkage remains inert. + +## Diagnostics + +Parse, type, and evaluation failures currently use source spans and exceptions. Compiler entry points translate expected failures into structured stage diagnostics while leaving existing embedding APIs behavior-compatible. + +Version-1 `.fsir` artifacts require compiler and language versions, source metadata, ordered dependencies, and a complete program. Unknown formats and versions are rejected before LIR construction; malformed metadata receives `FSA5xxx`, while reconstructed programs containing unknown named types, unresolved symbols, or invalid nested spans are rejected by the shared `FSL2xxx` validator before execution or generation. diff --git a/docs/specs/dotnet-backends.md b/docs/specs/dotnet-backends.md new file mode 100644 index 0000000..2d82153 --- /dev/null +++ b/docs/specs/dotnet-backends.md @@ -0,0 +1,77 @@ +# C# and .NET backends + +`FScript.Backend.CSharp` emits a C# project from validated LIR. `FScript.Backend.DotNet` has a separate assembly optimization pipeline and uses Roslyn for verified PE emission. Generated code contains ordinary compiled methods and typed delegates where functions escape, and depends on BCL support helpers rather than the AST evaluator, LIR interpreter, or ScriptHost. + +Both backends share `LirMonomorphization` and `LirSimplification`. Reachable polymorphic uses receive concrete instantiations; reachable open results and effectful generalized initializers receive diagnostics. + +For target selection and executable workflows, see [Compilation](../guides/compilation.md). The user-facing [optimization guide](../guides/compiler-optimizations.md) compares both targets and illustrates the limits described below. + +## Purity contracts + +`PurityContracts` contains `PureFunctions` and `PureTypes` sets of registered script names. The compiler API's explicit contract overloads default to empty sets through legacy entry points. The CLI discovers optional `FScriptPureFunctions`/`FScriptPureTypes` provider methods returning `IEnumerable`. Function contracts include totality and effects; type contracts include deep immutability and safe registered-field reads. Provider initialization and callbacks must satisfy the documented conditional guarantee. Declarations are trusted; protected runtime contracts cannot be overridden. + +`LirEffects` performs conservative contract-aware analysis shared by specialization and simplification. Recursive summaries start observable, avoiding circular proofs of termination. Unproven failures, non-exhaustive matches, external reads without type guarantees, and unknown callback effects remain observable. Pure calls can be pruned only with pure arguments and a correctly retained application boundary. Generated-member/dependency pruning then removes newly unreachable code. This does not change the AST evaluator or SDK validation. + +## Assembly optimization + +Both native consumers run `LirCommonSubexpressions.optimize` after specialization, simplification, and any target-specific LIR reduction. Dominance-based value numbering reuses identical typed pure expressions through lexical bindings and initialized globals. Keys omit source spans and retain exact floating-point bits. Trusted external-type immutability is required for external value observations and dependencies. Function- or task-containing result values are not shared, including aggregates whose elements contain these handles. Observable operations clear availability; branches, short-circuit operands, match guards, and loop bodies maintain separate conditional scopes. Earlier effectful guards invalidate availability for later alternatives. Function bodies start with empty availability and do not acquire caches across invocations. Administrative temporaries that have no sharing purpose are removed. The output uses existing LIR nodes and is validated before emission; artifacts and interpreted entry points do not enable this pass automatically. No memoization or runtime cache is introduced. + +The .NET assembly pipeline additionally beta-reduces known nonrecursive calls with fresh lexical identities, propagates known partial applications, and hoists their top-level captures so effects execute once in source order. Recursive components are detected before expansion. Saturated calls use methods with multiple typed parameters. Exported or genuinely escaping functions retain typed delegates. + +Saturated self calls in tail position become loops, including calls behind lets, branches, and pattern decisions. Next arguments are evaluated into temporaries before parameter reassignment. Escaping closures snapshot captures to preserve each iteration's immutable values. Mutual recursion and calls with pending work remain direct recursive calls. + +Known list callbacks use typed loops and direct calls for mapping, iteration, folding, filtering, choosing, collecting, existence tests, and searches. Immediate helper blocks become static methods instead of delegate invocations. Constant boolean terms and branches are simplified while preserving observable evaluation. The CLR JIT can inline small native helpers. + +Reachability starts at `Run`, result formatting, exported bindings, and the executable entry point. Unused generated methods, fields, and support types are removed. Reached constructors and interface implementations remain available. Native aggregates use immutable classes/structs without synthesized CLR record printing, equality, cloning, or deconstruction; FScript equality and formatting use dedicated reachable helpers. Ordinary assembly generation preserves provider assemblies; executable publishing can trim them as described below. + +These passes apply only to `DotNetBackend.generate`. The C# target, serialized LIR, and LIR interpreter retain their existing optimization policy. Roslyn remains the final IL emitter; FScript makes the optimization decisions before emission. + +Namespace qualification is not a reachability edge to a namespace's syntax body. Reaching a generated type or method through its fully qualified name retains that declaration and its actual dependencies, without retaining unrelated stdlib members in the same namespace. This rule applies to both libraries and executables. + +## Public API + +- `CSharpBackend.generate : CSharpOptions -> Lir.Program -> Result` +- `DotNetBackend.generate : DotNetOptions -> Lir.Program -> Result` +- `DotNetBackend.generateExecutable : DotNetExecutableOptions -> DotNetOptions -> Lir.Program -> Result` +- `ClrBindings.bindMethod : string -> MethodBase -> Lir.Program -> Lir.Program` +- `ClrBindings.bindType : string -> System.Type -> Lir.Program -> Lir.Program` + +CLR linkage is serializable. Exact public overloads, instance receivers, and constructors are explicit. Native type projections use their actual CLR type. Existing extension providers use `ClrBindings.bindProvider`: generated typed adapters marshal values through `FScript.Extensibility`, invoke the provider directly, and service compiled callbacks and tasks through `ExternalCallContext`. Opaque values retain their SDK payload and immutable field snapshots. Providers taking `HostContext` receive the process working directory and compiled default functions. The CLI preserves provider metadata from environment loading rather than executing provider factories twice during compilation. No interpreter or ScriptHost participates in generated execution. + +## Representation and execution + +Provider classes may expose public static parameterless `FScriptCompiledFunctions` and `FScriptCompiledTypes` methods returning `IEnumerable>` and `IEnumerable>` respectively. Keys name registered script bindings. Compiler-only discovery links reachable declarations to exact typed CLR methods/types, overriding the legacy SDK adapter for those bindings. Metadata factories and unused bindings do not become runtime roots. This optional BCL contract preserves the frozen SDK registration records. Typed entry points must preserve the registered semantics and use immutable or snapshot-compatible external representations; unsupported shapes can use explicit adapters. + +CLR type reachability is computed from retained expression/function signatures, patterns, constructors, and type tokens, including recursive references. Unused imported types are removed before resolving their native metadata. Emitted dependency copying starts at the PE's actual assembly references and follows the supplied adjacent managed closure; simply loading a provider during frontend registration does not retain its assembly. + +Compiled `Env.ScriptName` contains the running assembly or executable filename; `Env.Arguments` contains its command-line arguments. The BASIC sample uses that name in its usage message, so compiled output does not advertise an interpreter invocation. + +Closed exported bindings are specialization roots even when a library has no program entry. An export with an open polymorphic signature receives `FSC6009`; it cannot silently disappear during pruning. A known closure is devirtualized only when its captured values are available in the caller's lexical scope. Otherwise its delegate environment is preserved. + +Scalars use `long`, `double`, `bool`, and `string`. Functions use typed `Func` delegates. Lists use arrays, options use typed value structs, maps use sorted immutable entry arrays, tuples and records use generated immutable records, and unions use enums or sealed typed cases. Recursive records/unions use CLR references. Collection operations allocate changed values and retain source order. Structural equality and result formatting are generated per semantic type, including recursive aggregate equality and non-equality of functions/tasks. + +Generated console entry points print `FormatResult(Run())` by default. `--no-result` suppresses this display for C# projects, ordinary assemblies, single-file bundles, and AOT output. Before specialization, `LirResultPolicy.discard` replaces the entry value with unit while retaining any observable entry evaluation; unused pure declarations/functions can then be pruned. In discard mode `Run` returns unit. Exports remain explicit roots. Program effects and failures remain intact. Entry points return the execution-local `ExitCode`, defaulting to zero, rather than interpreting the program value as a status. `Env.setExitCode` performs an atomic validated write in the generated program; it does not mutate the host process status when the assembly is embedded. It accepts `0..255`, uses last-completed-write-wins semantics, and is always observable. Unhandled failures override selected successful completion. + +Match targets are evaluated once. Typed checks/projections, repeated bindings, guards, and deterministic ordered-map selection follow the LIR pattern plans. An unbound variable key selects the first remaining entry; other key/value patterns select their first local match. Selection is committed before later clauses or remainder checks. Failures are ordinary runtime failures. Top-level initialization executes once and in source order through a lazy initializer outside CLR type initialization, allowing spawned tasks to call compiled functions without a type-initialization deadlock. + +## Output and verification + +`DotNetExecutableOptions` contains the explicit portable .NET `RuntimeIdentifier` and an `AheadOfTime` flag. `generateExecutable` accepts console output only. False produces a self-contained single-file bundle; true uses Native AOT. Both return exactly one executable (`.exe` for Windows targets). The CLI enables Unix execute permissions when writing Unix targets. DLL generation and the other backends do not invoke SDK publishing. + +The CLI forms are `--target dotnet --single-file [--runtime ]` and `--target dotnet --aot [--runtime ]`. Omitting `--runtime` selects the current .NET host runtime identifier (`System.Runtime.InteropServices.RuntimeInformation.RuntimeIdentifier`). Explicit `--runtime` options without a value, runtime identifiers without a publishing mode, and executable flags on other targets are rejected. The backend API retains an explicit runtime identifier. Runtime identifiers use .NET spelling, including `osx-arm64`, `linux-x64`, and `win-x64`. Unsupported identifiers produce `FSN7101` with the supplied value, supported identifiers, and a correction for recognized macOS aliases before invoking the publishing SDK. With source invocation, application arguments must follow `dotnet run --`; options consumed by `dotnet run` cannot be validated by FScript. Native AOT cross-OS compilation is rejected; cross-architecture support depends on the installed toolchain. + +Publishing stages the optimized PE and managed dependency closure in an isolated temporary SDK project. Its `CoreCompile` placeholder is replaced with the optimized PE before publish targets consume it. Single-file publishing embeds the runtime and native runtime assets for extraction. Native AOT consumes the same PE, with SDK trimming and native compilation. Managed bundles enable trimming for static bindings and disable it for reachable legacy SDK dispatch. Only IL2040 (missing resources requested for removal by dependency linker descriptors, including optional FSharp.Core compiler metadata) is suppressed; reflection, trimming and AOT compatibility warnings remain errors. Remaining unbundled publish assets cause a diagnostic rather than incomplete output. Debug-symbol files are optional and are not returned. + +Publishing requires a .NET 10 SDK on PATH and, for Native AOT, the platform native toolchain and compatible dependencies. SDK restore may need network access. `FSN7101` reports invalid publishing options, `FSN7102` reports an unavailable SDK command, `FSN7103` reports SDK publishing failures/timeouts or incomplete bundling, and `FSN7104` reports Native AOT cross-OS requests. The compiler captures SDK diagnostics and cleans its temporary project. Existing unrelated output-directory files are preserved. + +C# output includes `Program.cs`, `Runtime.cs`, and `Program.csproj`. .NET output includes the assembly and, for console applications, a runtime configuration. External assembly references are explicit. Source generation does not invoke an installed compiler. Ordinary assembly generation requires the .NET 10 runtime but not an installed SDK; Roslyn dependencies ship with FScript. Running the compiler from source through `dotnet run` and SDK publishing do require the SDK. Assembly generation uses Roslyn in-process with release optimization, deterministic output, unsafe code disabled, and nullable checks enabled. Compiler errors and warnings prevent publication of an output assembly. + +Tests load emitted assemblies, JIT every closed generated method, execute representative semantic programs and CLR calls, and build generated C# as an independent project. This checks valid IL and execution behavior without relying on FScript hosting. + +Native AOT reports `FSN7105` when the optimized PE still contains reachable legacy `SdkInterop` dispatch. Such calls require typed companions or explicit CLR bindings, allowing individual FFI implementations to be inlined/trimmed without retaining a provider factory. Managed bundle mode continues to support legacy dispatch. Integration tests execute both output modes from a directory containing only the executable, with absent runtime roots, and cover direct typed FFI plus external values with an unused reflection-based sibling. + +The standalone BASIC and headless graphics assemblies are also checked with ILVerify against the installed .NET runtime and emitted managed dependencies. C# output is syntax-checked and normalized before publication; generated projects explicitly include compiler-owned source files so stale files cannot enter a later build. + +SDK programs additionally include `RuntimeSDK.cs` and explicit references to the extension SDK and FSharp.Core. Colocated managed dependencies are resolved transitively and copied beside emitted assemblies. Generated programs never load the source file or a serialized IR at runtime. The headless graphics sample exercises opaque graphics resources, geometry values, and callback invocation entirely through compiled code. + +`generateWithResultOutput` on both backends and `generateExecutableWithResultOutput` on the .NET backend accept an explicit Boolean printing policy. Existing generation methods select printing. Native `Main` returns `int`; `Run`, `FormatResult`, exported bindings, and the public `ExitCode` property form the generated host surface. diff --git a/docs/specs/embedding-fscript-language.md b/docs/specs/embedding-fscript-language.md index 0be3aad..dfc01d4 100644 --- a/docs/specs/embedding-fscript-language.md +++ b/docs/specs/embedding-fscript-language.md @@ -471,3 +471,9 @@ lets hosts control scheduling of background FScript continuations. CLI environment binding. See [debugger behavior](debugger.md) for callback affinity, watch restrictions, reference lifetime, and cancellation. The Extensibility SDK contract is unchanged, and Fable has no debugger support. + +## Execution-local shell status + +`Eval.ProgramState.ExitCode` and `ScriptHost.LoadedScript.ExitCode` report the status selected during evaluation. `ScriptHost.invokeWithExitCode` and `Eval.invokeValueWithExitCode` return `{ Value; ExitCode }` for an individual invocation. Each fresh evaluation/invocation starts at zero; interactive submissions preserve their session status. Existing value-returning APIs remain available. No API invokes process exit or mutates `System.Environment.ExitCode` on behalf of the script. + +The language-level `ExternalCallContext.SetExitCode` callback updates the evaluator's execution-local status. The separate extension SDK context and provider registration contract are unchanged. `Env.setExitCode` is a reserved, effectful core operation with portable range `0..255`; task writes share the owning execution and are synchronized, with scheduling-dependent last-write-wins ordering. diff --git a/docs/specs/executable-lir.md b/docs/specs/executable-lir.md new file mode 100644 index 0000000..90df25b --- /dev/null +++ b/docs/specs/executable-lir.md @@ -0,0 +1,167 @@ +# Executable Low-Level IR (LIR) + +## Status and purpose + +This document specifies FScript's executable low-level intermediate representation. LIR is backend-independent, structured, non-SSA, and suitable for both direct interpretation and source generation. + +LIR is produced only from validated HIR: + +```text +Hir.Program + -> LirLowering.lower + -> LirOptimization.optimize + -> LirValidation.validate + -> Lir.Program +``` + +The optimization pass performs conservative effect analysis, constant Boolean control-flow simplification, unused pure-local elimination, and whole-program reachability pruning. Observable top-level initializers and exports remain ordered roots; calls, failures, loops, and potentially failing integer division/remainder are never discarded. Closure captures are recomputed and surviving function IDs are deterministically compacted before validation. Backends may specialize representation-neutral control flow further. LIR and the JSON DTO schema used by `.fsir` are internal versioned contracts, not stable public interchange standards. + +## Program model + +`Lir.Program` contains: + +- concrete named type declarations; +- imported record linkage and field schemas; +- lifted functions; +- ordered top-level declarations; +- an optional entry expression. + +`SymbolId` identifies values and bindings. `FunctionId` independently identifies lifted function bodies. Both are deterministic artifact-local integers. + +Every expression carries its semantic FScript type and source span. Rich types remain available for validation, interpretation, and backend-specific specialization and representation selection. + +## Functions and closures + +Every source lambda is lifted into a `Lir.Function` containing: + +- one parameter ID and type; +- an ordered, explicit capture list; +- a return type; +- a source span; +- a body expression. + +`MakeClosure(functionId, captures)` constructs a closure. `CallClosure` applies one argument. `PipeClosure` preserves value-first pipeline evaluation. The optimizer rewrites calls in function tail position to `TailCallClosure` or `TailPipeClosure`; keeping two nodes preserves their distinct evaluation order. Partial application follows naturally from nested unary closures. + +`LetRecursiveGroup` establishes all recursive values before their bodies run. Lifted functions validate their capture list against the ordered free-symbol set of their body. + +Tail position propagates through selected branch and decision-tree bodies and through the body of lexical binding nodes, but never through operands, guards, aggregate construction, or a call whose result is subsequently consumed. The LIR interpreter trampolines explicit tail calls across closures, so deep proper-tail recursion does not consume the host stack. Native backends may lower proven tail calls to loops while retaining ordinary calls in other cases. + +## Operations and control flow + +LIR uses explicit operations for integer and floating arithmetic, integer remainder, structural equality, numeric comparisons, and Boolean operations. + +Control flow remains structured: + +- `Branch` represents `if`; +- `Let` and `LetRecursiveGroup` represent lexical scope; +- `Fail` represents `raise`; +- `ForEach` represents ordered list iteration; +- `DecisionTree` represents pattern matching. + +Operands normally evaluate left to right and stop at the first failure. `BooleanAnd` and `BooleanOr` short-circuit. Branches evaluate only the selected body. + +## Runtime values and aggregates + +LIR directly constructs and projects: + +- unit, integer, float, Boolean, and string constants; +- tuples and lists; +- options; +- records and record updates; +- declared tagged unions; +- ordered maps; +- type tokens. + +Named records and unions retain declarations in the program type table. `RecordConvert` carries frontend-proven structural conversion evidence between distinct representations. + +LIR prescribes semantic values rather than a backend storage strategy. The .NET interpreter may use tagged runtime values; native backends specialize reachable polymorphic uses into closed concrete representations. + +Maps use ordered comparable keys (strings, integers, booleans, and supported payload-free unions) according to current FScript semantics. Consumers must not substitute host-language hash-map iteration order. + +Structural equality recursively covers primitives, tuples, records, maps, options, lists, unions, and type tokens. Closures, task values, constructors, and extern handles are not structurally equal. + +## Pattern decision plans + +Pattern lowering produces a `DecisionTree` whose target expression is evaluated exactly once. Each case contains a `PatternPlan`, optional guard, body, and source span. + +A plan consists of: + +- projection steps such as list head/tail, tuple item, record field, option value, and union payload; +- checks for literals, list shape, tuple arity, record fields, options, union cases, and type shape; +- symbol bindings associated with deterministic projections; +- ordered map matching plans, including remainder handling. + +Map patterns preserve the evaluator's deterministic selection: a new variable key selects the first remaining entry, while other key/value patterns select their first local match. Later clause or remainder failure does not reconsider that selection. Repeated pattern bindings compare against the original binding. + +Consumers execute this plan rather than reimplementing source-pattern semantics. + +Cases are attempted in source order. Bindings become visible only after a plan succeeds. Guards run after bindings and before the body. Exhausting every case produces the standard match failure. + +## Linkage and reachability + +LIR retains the same explicit linkage categories as HIR: + +- portable `Intrinsic` values; +- `RuntimeContext` for `Env`; +- `HostExternal` handles; +- `TargetImport` handles. + +The LIR interpreter rejects a reachable fully-applied target import, Task operation, or unsupported host external with an `FSI3xxx` diagnostic. Unused unsupported declarations remain inert. + +## Validation + +`LirValidation.validate` returns `Result` and checks at least: + +- unique symbol and function IDs; +- known named types and valid recursive type references; +- valid nested spans; +- resolved loads, captures, and function IDs; +- exact closure capture lists and call signatures; +- primitive arity and operand/result types; +- aggregate, projection, update, and conversion representations; +- decision-plan checks, bindings, and map projections; +- declaration and function result types; +- known intrinsic names and complete linkage metadata. + +LIR/lowering diagnostics use `FSL2xxx` codes. + +`LirInterpreter.execute`, `CSharpBackend.generate`, and `DotNetBackend.generate` validate caller-provided LIR before consuming it. + +## Artifact format + +`IrArtifact.serialize` writes one complete `Lir.Program` as canonical indented UTF-8 JSON. The artifact includes: + +- `format = "fscript-lir"`; +- `irVersion = 1`; +- compiler and language versions; +- normalized source paths and SHA-256 hashes when file-backed sources are available; +- ordered foreign dependencies; +- the complete LIR program. + +`IrArtifact.deserialize` rejects an unknown format or version before constructing LIR, validates required metadata, reconstructs the program through explicit DTO parsing, and runs LIR validation before returning it. Artifact diagnostics use `FSA5xxx` codes. + +No backward-compatibility guarantee is made for version 1. Producers and consumers should use matching FScript builds. + +## Execution APIs + +The principal APIs are: + +```fsharp +IrArtifact.serialize : Lir.Program -> byte array +IrArtifact.deserialize : byte array -> Result + +LirInterpreter.execute : + InterpreterContext -> Lir.Program -> Result +``` + +`InterpreterContext` supplies an optional script name and argument list. `ExecutionResult` contains the final `LirValue` and ordered `Console.writeLine` output. `Console.readLine` consumes the interpreter process stdin and returns `None` at end of input; hosts that need controlled input can temporarily supply a `TextReader` through `Console.SetIn` around execution. + +`Lir.format : Lir.Program -> string` is a deterministic debug/snapshot representation and is not the artifact encoding. + +## External purity metadata + +External declarations retain `IsPure` and nullable `ExternalArity`; type declarations retain `IsPure`. A function's external application boundary is independent of the number of arrows in its type, because applying a returned callback is another operation. Validation rejects incompatible purity/arity metadata with `FSL2018`. Serialized version-1 declarations include `pure` and `externalArity`; type declarations include `pure`. Missing fields in older artifacts mean false/unknown, never an implicit guarantee. Wrong JSON types or inconsistent metadata are rejected on load. + +These are trusted optimization contracts, not executable host delegates. Native effect analysis may prune a claimed-pure call only when its arguments and invoked callbacks are also safe. Observable failures and unproven termination remain conservative. Ordinary LIR interpretation does not infer or enforce the provider's promise. See [FFI contracts](external-functions.md#compiler-purity-contracts). + +The core intrinsic `Env.setExitCode : int -> unit` is observable and validates `0..255`. LIR `LoadResult` and `ExecutionResult` expose `ExitCode`, initially zero for each load/invocation, without touching process-global status. Nested host-initiated executions keep status isolated. Invalid codes report `FSI3027`. This execution metadata does not change the artifact representation. diff --git a/docs/specs/external-functions.md b/docs/specs/external-functions.md index 9f35f06..0eccdae 100644 --- a/docs/specs/external-functions.md +++ b/docs/specs/external-functions.md @@ -70,6 +70,7 @@ Higher-order externs are implemented in runtime extern modules and receive an `E ### Regex - `Regex.matchGroups : string -> string -> string list option` + ### Hash and GUID - `Hash.md5 : string -> string option` - `Guid.new : 'a -> string option` (dummy argument to preserve call shape) @@ -81,6 +82,7 @@ Higher-order externs are implemented in runtime extern modules and receive an `E ### Task - `Task.spawn : (unit -> 'a) -> 'a task` - `Task.await : 'a task -> 'a` + - These are part of the default runtime extern registry, so hosts may omit them. ### Collections and prelude @@ -172,3 +174,13 @@ Provider trust, atomic loading, configuration selection, and reload rules are un ## NuGet-distributed extensions `[[runtime.packages]]` declares a required package `name` and optional exact `version`; an omitted version selects latest stable. The shared Runtime loader restores dependencies without the .NET SDK and discovers the existing SDK `[FScriptExternProvider]` methods in explicitly requested package runtime assemblies. Providers return the same SDK registrations used by local DLLs. `EnvironmentLoader.loadWithInfo` additionally exposes resolved package versions and concrete assembly paths; `load` retains its registration-only result. Parsing settings does not restore or execute packages. See [environment configuration](environment-configuration.md) for cache, dependency selection, trust, and failure rules. + +## Compiler purity contracts + +Purity is an opt-in, trusted host contract. Pure functions must be deterministic, effect-free, and terminating successfully for valid inputs, including any required runtime initialization. For higher-order bindings, this guarantee is conditional on pure, total callbacks; the optimizer checks callbacks conservatively. A returned callable does not inherit its factory's guarantee. + +Pure external types promise deeply immutable visible data and opaque payloads, plus deterministic, effect-free, successfully terminating registered field reads, equality, and formatting. Constructors and ordinary methods require separate function contracts. Incorrect declarations are provider contract violations; compiler transformations may remove the claimed-pure computation. + +Providers expose optional public static parameterless `FScriptPureFunctions()` and `FScriptPureTypes()` methods returning `IEnumerable` of registered script names. The compiler CLI reads these for every compilation target. Invalid names, empty entries, and protected runtime contract overrides are rejected. Existing SDK records and ordinary runtime execution remain unchanged. + +The .NET compiler API exposes `PurityContracts`, `Compiler.compileWithPurity`, `Compiler.compileWithRegistrationAndPurity`, and `ClrBindings.providerPurity`. Metadata survives resolved inference, HIR, LIR, serialization, and native linkage. No new FScript annotation syntax is introduced. See [the provider guide](../guides/compile-to-dotnet.md#pure-ffi-and-external-values) for examples and [optimization rules](../guides/compiler-optimizations.md#trusted-external-purity) for limitations. diff --git a/docs/specs/host-managed-types.md b/docs/specs/host-managed-types.md index c8f4067..cd7c07b 100644 --- a/docs/specs/host-managed-types.md +++ b/docs/specs/host-managed-types.md @@ -86,3 +86,7 @@ Constructible provided types follow existing ordinary record literal resolution, `HostTypes.describeUnion<'T>()` derives this descriptor from an F# discriminated union marked `[]`. Nullary cases have no payload, one-field cases use that field's type, and multiple fields form a tuple payload. Every payload type must use a supported projection and every referenced descriptor must be registered. Opaque and recursive union projections are rejected. `HostTypes.wrap`, `unwrap`, and `HostFunctions.create` convert these unions recursively, including inside records and containers. F# sets project as script lists. Host-to-script snapshots follow CLR set iteration order. Script-to-host conversion applies CLR set ordering and deduplication; list order and duplicates are not preserved in the reconstructed set. + +## Compiler purity + +External values are not assumed pure because their visible schema is immutable. A provider may separately declare the strong pure-type contract: deeply immutable visible data and opaque payloads, and safe, deterministic, terminating, effect-free registered field reads, structural equality, and formatting. This can enable pruning of otherwise unused projections and structural operations. It does not mark constructors or ordinary methods pure and does not skip runtime boundary validation. See [FFI purity contracts](external-functions.md#compiler-purity-contracts). diff --git a/docs/specs/stdlib-functions.md b/docs/specs/stdlib-functions.md index 73ecb7c..0c8ccce 100644 --- a/docs/specs/stdlib-functions.md +++ b/docs/specs/stdlib-functions.md @@ -5,7 +5,7 @@ This document lists core standard-library functions and the optional default .NE ## Modules -- Core: `List`, `Option`, `Map`, `Int`, `Float`, `Bool`, `String`. +- Core: `Env.setExitCode`, `List`, `Option`, `Map`, `Int`, `Float`, `Bool`, `String`. - Default .NET runtime: `Console`, `Task`, `Fs`, `Json`, `Regex`, `Xml`, `Hash`, `Guid`. ## Top-level surface @@ -138,6 +138,7 @@ Map keys may be `string`, `int`, `bool`, or a union whose cases all have no payl ## String - `String.replace : string -> string -> string -> string` - argument order: `oldValue -> newValue -> source` + - Replaces all non-overlapping occurrences using ordinal, case-sensitive matching. An empty `oldValue` returns `source` unchanged; an empty `newValue` removes matches. This operation always returns a string. - `String.indexOf : string -> string -> int option` - argument order: `value -> source` - `String.toLower : string -> string` @@ -204,3 +205,21 @@ match Env.Arguments with | scriptPath :: _ -> Console.writeLine scriptPath | [] -> Console.writeLine "no args" ``` + +## Env.setExitCode + +`Env.setExitCode : int -> unit` is an always-available core operation, including in embedding and JavaScript. It coexists with host-provided `Env.ScriptName` and `Env.Arguments` without adding a field to the `Environment` record. The qualified operation is reserved even when an `Env` value is in scope. + +On .NET and compiled targets, the code must be in the portable shell range `0..255`; other values fail with an evaluation error. It selects the eventual shell status and returns unit normally. It never calls process exit, cancels tasks, or changes a host process's exit status during embedded evaluation. The default is `0`, repeated calls use the last completed write, and unhandled execution failures still produce failure rather than a selected success code. + +This operation is effectful and is not `Pure`. Its writes survive pruning and common-subexpression elimination. Writes from tasks share the execution status and are synchronized, but their order is scheduling-dependent. For deterministic status, await tasks and set it afterward in the main flow. Existing task lifetime and failure rules are preserved. + +```fsharp +Env.setExitCode 7 +42 // still evaluated; shell status is 7 +``` + +Result printing is independent of this status. `--no-result` suppresses automatic display in the CLI and can be baked into compiled applications. + + +Fable/JavaScript deliberately treats this operation as a no-op (including shell-range validation). Arguments still evaluate normally, returned values remain unchanged, and the website displays the returned value as before. diff --git a/docs/specs/syntax-and-indentation.md b/docs/specs/syntax-and-indentation.md index 34054a4..6ea1dd8 100644 --- a/docs/specs/syntax-and-indentation.md +++ b/docs/specs/syntax-and-indentation.md @@ -14,6 +14,8 @@ This document describes the concrete syntax accepted by the interpreter and the - Parsing is layout-aware: the lexer emits `Indent`/`Dedent` tokens from leading whitespace. - Comments use `//` line-comment syntax. +Backend `Import` requires exactly a target module path and member name, a complete function signature, and no body. It cannot be combined with `export` and is not allowed in expression blocks. The legacy evaluator reports an explicit error if an imported function is called; compiled consumers use the retained target linkage. + ## Core expression forms - Literals: `int`, `float`, `bool`, `string`, `()` - Variables and function application by whitespace: @@ -31,7 +33,8 @@ This document describes the concrete syntax accepted by the interpreter and the - tuple destructuring is supported for non-`rec` `let` bindings only - `export let` requires a single identifier binding (tuple patterns are rejected) - `export let` is only valid on top-level `let` bindings - - `export` is a contextual, case-sensitive modifier recognized only immediately before top-level `let`; it remains a valid ordinary binding, parameter, and field name. Script attributes are unsupported. + - `export` is a contextual, case-sensitive modifier recognized only immediately before top-level `let`; it remains a valid ordinary binding, parameter, and field name. + - Only the `export let` declaration prefix marks an export, including through the JavaScript facade. Other forms are ordinary syntax errors. - Conditionals: - `if cond then a else b` - `elif` desugars to nested `if` @@ -243,3 +246,11 @@ let ops = - imports are effectively deduplicated. - `import` must appear before executable/type code in a file. - Parse/type/eval errors include file-aware spans (`file`, `line`, `column`) so failures in imported files point to the offending source. + +## Backend import attributes + +- A bodyless target function import uses `[] let name : complete -> signature`. +- An imported record schema uses `[] type Name = { Field: type; ... }`. +- `Import` takes exactly two non-empty arguments and is valid only on a top-level type declaration or bodyless typed `let`. +- Imported record field spelling is preserved exactly for backend adapters. Target-specific restrictions are enforced by each backend. +- Other top-level type and `let` attributes are retained as structured name, string/identifier arguments, and source span for compiler consumers. Unknown attributes do not change language semantics by themselves. diff --git a/docs/specs/typed-hir.md b/docs/specs/typed-hir.md new file mode 100644 index 0000000..cd94139 --- /dev/null +++ b/docs/specs/typed-hir.md @@ -0,0 +1,143 @@ +# Typed High-Level IR (HIR) + +## Status and purpose + +This document specifies the high-level intermediate representation produced by `FScript.Compiler`. HIR is the first compiler-owned form after parsing, name resolution, and Hindley–Milner inference. It is fully resolved, fully typed, platform-neutral, and still preserves FScript language structure. + +HIR is an internal compiler contract. It is not the `.fsir` artifact format and has no compatibility guarantee between FScript versions. + +The public construction path is: + +```text +Program + -> TypeInfer.inferResolvedProgramWithExterns + -> HirLowering.lower + -> HirValidation.validate + -> Hir.Program +``` + +Callers normally use `Compiler.compile`, which performs this pipeline and also produces validated LIR. + +## Program model + +`Hir.Program` contains, in source-semantic order: + +- `Types`: named record and union declarations; +- `ImportedRecords`: backend-imported record representation declarations; +- `Declarations`: top-level values and functions; +- `Entry`: the optional final top-level expression. + +Includes are resolved before HIR construction. One `Hir.Program` therefore represents the complete source program rather than one source file. + +Every type, declaration, parameter, pattern binding, local binding, builtin, intrinsic, and extern reference uses a deterministic program-local `SymbolId`. IDs identify declarations; names are retained for diagnostics and readable debug output but never define binding identity. + +## Type information + +Every `Hir.Expression` and `Hir.Pattern` carries: + +- its final instantiated FScript `Type`; +- its originating `Span`; +- a semantic node. + +Top-level declarations additionally retain their normalized `Scheme`. Type-variable numbering is deterministic and independent of process-global inference counters. + +HIR preserves: + +- primitive, tuple, list, option, map, function, task, record, union, named, and type-token types; +- named type identity; +- structural record shapes; +- recursive type references; +- polymorphic declaration schemes; +- explicit named/structural record conversion evidence through `RecordConvert`. + +A backend must not repeat FScript compatibility checking or infer structural conversions from its host representation. + +## Declarations and metadata + +A value declaration contains its symbol ID, source name, normalized scheme, recursive/export flags, structured attributes, span, and value expression. + +`Export` metadata records the exported source name and attribute span. Other attributes retain their name, ordered string arguments, and span. + +A type declaration contains its symbol ID, name, recursion flag, complete semantic definition, attributes, optional import metadata, and span. Imported records remain ordinary FScript record types; import metadata changes their backend representation, not their FScript typing rules. + +## Expressions + +HIR directly represents: + +- constants and resolved references; +- lambdas, application, and value-first pipelines; +- `if`, local `let`, recursive bindings, and mutually recursive groups; +- resolved primitive operations; +- tuples, records, record updates, explicit record conversions, and field access; +- lists, options, maps, map spread, ranges, cons, append, and indexing; +- declared union construction; +- interpolation, `raise`, `for`, `typeof`, and matches; +- portable intrinsics, unsupported host extern handles, runtime context, and target imports. + +Primitive nodes distinguish integer and floating arithmetic. Structural equality and numeric/Boolean operations are resolved before HIR so consumers never dispatch an operator by source spelling. + +Function application is unary and curried. A multi-argument source function is represented as nested lambdas and applications. + +## Patterns and matches + +HIR retains FScript patterns before decision-tree lowering: + +- wildcard and binding patterns; +- literal patterns; +- empty/cons list patterns; +- tuple and record patterns; +- ordered map clauses and optional remainder patterns; +- option and declared-union patterns; +- runtime type-reference patterns. + +A match case contains a pattern, optional Boolean guard, body, and case span. Cases and guards retain source order. Pattern bindings use the same deterministic IDs as references in guards and bodies. + +## Evaluation semantics + +HIR child order is semantic: + +- declarations and top-level expressions execute in source order; +- expression operands and aggregate elements evaluate left to right; +- failures stop subsequent evaluation; +- `&&` and `||` short-circuit their right operand; +- a match scrutinee is evaluated once; +- cases and guards are attempted in source order; +- a non-recursive binding initializer does not see its new binding; +- a recursive group sees every member of that group. + +## Linkage + +Compiler linkage is declarative and contains no executable .NET delegate: + +- `Intrinsic name` identifies a supported portable builtin; +- `RuntimeContext` identifies `Env`; +- `HostExternal(name, arity)` identifies a host-only extern; +- `TargetImport(modulePath, memberName)` identifies backend-provided code. + +Unsupported linkage remains representable in HIR so reachability-sensitive consumers can reject only executed or generated uses. + +## Validation + +`HirValidation.validate` returns `Result` and enforces at least: + +- unique type and value symbol IDs; +- valid spans, including nested expressions and patterns; +- known named types and union cases; +- resolved references and pattern bindings; +- expression, branch, call, aggregate, and declaration type consistency; +- valid recursive groups and declaration schemes; +- valid primitive signatures; +- valid record conversion evidence; +- complete import and export metadata. + +HIR diagnostics use `FSH1xxx` codes and preserve an originating FScript span whenever one exists. + +## Deterministic debugging + +`Hir.format : Hir.Program -> string` produces a canonical, human-readable representation with stable ordering, symbol IDs, and normalized types. It is intended for diagnostics and snapshot tests, not serialization. + +The compiler serializes validated LIR, not formatted HIR. + +## Host purity metadata + +External declarations carry `IsPure` and `ExternalArity`; external type declarations carry `IsPure`. These originate in trusted `PurityContracts` retained by resolved inference. Function flags include successful termination and effects, not merely absence of mutation. Declaration contracts require external linkage and an application boundary. `FSH1110` rejects inconsistent metadata. Native consumers preserve these fields while linking and specializing declarations. See [external function contracts](external-functions.md#compiler-purity-contracts). diff --git a/samples/basic/README.md b/samples/basic/README.md index cc66eeb..904423f 100644 --- a/samples/basic/README.md +++ b/samples/basic/README.md @@ -16,6 +16,15 @@ fscript samples/basic/basic.fss -- helloworld.bas The first script argument after `--` is the BASIC program path. BASIC files are read relative to the sample root when you run `samples/basic/basic.fss`. +Compile it to a standalone .NET assembly with: + +```bash +dotnet run --project src/FScript -- compile samples/basic/basic.fss --target dotnet --output out/dotnet/basic +dotnet out/dotnet/basic/basic.dll samples/basic/helloworld.bas +``` + +Compiled file paths are relative to the working directory. With no arguments, the usage message uses the running program's name from `Env.ScriptName`, for example `Usage: basic.dll `. + ## Supported Program Format - Line-numbered BASIC source only. diff --git a/samples/basic/basic.fss b/samples/basic/basic.fss index 9f0b083..0b23dc3 100644 --- a/samples/basic/basic.fss +++ b/samples/basic/basic.fss @@ -4,7 +4,9 @@ import "runtime.fss" as BasicRuntime let load_program_path = match Env.Arguments with | path :: _ -> path - | [] -> raise "Usage: fscript samples/basic/basic.fss -- " + | [] -> + let program_name = Option.defaultValue "basic" Env.ScriptName + raise $"Usage: {program_name} " let read_program path = match Fs.readText path with diff --git a/src/FScript.Backend.CSharp/AssemblyInfo.fs b/src/FScript.Backend.CSharp/AssemblyInfo.fs new file mode 100644 index 0000000..62643a2 --- /dev/null +++ b/src/FScript.Backend.CSharp/AssemblyInfo.fs @@ -0,0 +1,6 @@ +namespace FScript.Compiler + +open System.Runtime.CompilerServices + +[] +do () diff --git a/src/FScript.Backend.CSharp/CSharpBackend.fs b/src/FScript.Backend.CSharp/CSharpBackend.fs new file mode 100644 index 0000000..f94dd83 --- /dev/null +++ b/src/FScript.Backend.CSharp/CSharpBackend.fs @@ -0,0 +1,1103 @@ +namespace FScript.Compiler + +open System +open System.IO +open System.Reflection +open System.Text +open System.Text.Json +open System.Security.Cryptography +open Microsoft.CodeAnalysis +open Microsoft.CodeAnalysis.CSharp +open FScript.Language + +type CSharpOptions = + { Namespace: string + ClassName: string + References: string list } + +module CSharpBackend = + let private comma = ", " + let private space = " " + let private itemCode = "item" + let private aCode = "a" + let private bCode = "b" + let private valueCode = "value" + let private stringCode = "string" + let private valueMember code = code + ".Value" + exception private Failure of CompilerDiagnostic + let private fail code message span = + raise (Failure { Code = code; Stage = CSharpGeneration; Message = message; Span = span }) + let private quote (value: string) = JsonSerializer.Serialize(value) + let private ident (value: string) = + "v_" + (value |> Seq.map (fun c -> if Char.IsLetterOrDigit c || c = '_' then c else '_') |> Seq.toArray |> String) + let private hash value = + SHA256.HashData(Encoding.UTF8.GetBytes(sprintf "%A" value)) |> Convert.ToHexString |> fun s -> s.Substring(0, 12).ToLowerInvariant() + let private sym id = "v" + string (Lir.symbolNumber id) + let private funName id = "Function" + string (Lir.functionNumber id) + let private wrap resultType body = $"((Func<{resultType}>)(() => {{ {body} }}))()" + let private typeName (value: System.Type) = + let rec render (value: System.Type) = + if value.IsArray then render ((value.GetElementType() |> nonNull)) + "[]" + elif value.IsGenericType then + let name = (value.GetGenericTypeDefinition().FullName |> nonNull) + let name = name.Substring(0, name.IndexOf('`')).Replace('+', '.') + "global::" + name + "<" + (value.GetGenericArguments() |> Array.map render |> String.concat comma) + ">" + else "global::" + (value.FullName |> nonNull).Replace('+', '.') + render value + + let private emit assemblyMode printResult options (program: Lir.Program) = + let hasSdk = program.Declarations |> List.exists (fun d -> match d.Value.Node with Lir.TargetImport(path,_) -> path.StartsWith("clr-sdk:",StringComparison.Ordinal) | _ -> false) + let definitions = program.Types |> List.map (fun d -> d.Name, d.Definition) |> Map.ofList + let imports = program.ImportedRecords |> List.map (fun d -> d.Name, d) |> Map.ofList + let nativeTypes = + program.ImportedRecords |> List.map (fun imported -> + if not (imported.ModulePath.StartsWith("clr:", StringComparison.Ordinal)) then + fail "FSC6002" $"Target import '{imported.Name}' has no CLR binding." (Some imported.Span) + let value = System.Type.GetType(imported.ModulePath.Substring(4), false) + if isNull value then fail "FSC6003" $"Cannot resolve CLR type '{imported.ModulePath.Substring(4)}'. Supply its assembly in References." (Some imported.Span) + imported.Name, nonNull value) |> Map.ofList + let rec resolve = function TNamed name when definitions.ContainsKey name -> definitions.[name] | value -> value + let rec csType = function + | TUnit -> "Unit" | TInt -> "long" | TFloat -> "double" | TBool -> "bool" | TString -> "string" + | TTypeToken -> "TypeToken" + | TFun(argument, result) -> $"Func<{csType argument}, {csType result}>" + | TList item -> csType item + "[]" + | TOption item -> $"Option<{csType item}>" + | TTask item -> $"Task<{csType item}>" + | TMap(key, value) -> $"OrderedMap<{csType key}, {csType value}>" + | TNamed name | THostManaged(name, _) -> + match nativeTypes.TryFind name with + | Some value -> typeName value + | None when hasSdk && (match definitions.TryFind name with Some(THostManaged _) -> true | _ -> false) -> "global::FScript.Extensibility.HostManagedValue" + | None when (match definitions.TryFind name with Some(THostManaged _) -> true | _ -> false) -> + fail "FSC6003" $"Host-managed type '{name}' requires ClrBindings.bindType." None + | None -> ident name + | (TRecord _ | TTuple _ | TUnion _) as value -> "Shape_" + hash value + | value -> fail "FSC6004" $"Cannot represent open type '{Types.typeToString value}' in C#." None + let fieldName target name = + match target with + | TNamed typeName | THostManaged(typeName, _) when nativeTypes.ContainsKey typeName -> "@" + name + | _ -> "Field_" + ident name + let fields value = match resolve value with TRecord fields | THostManaged(_, fields) -> fields | _ -> Map.empty + let types = Collections.Generic.HashSet() + let rec addType value = + if types.Add value then + match value with + | TFun(a,b) | TMap(a,b) -> addType a; addType b + | TList item | TOption item | TTask item -> addType item + | TTuple items -> List.iter addType items + | TRecord fields | THostManaged(_, fields) -> fields |> Map.iter (fun _ -> addType) + | TUnion(_, cases) -> cases |> Map.iter (fun _ -> Option.iter addType) + | TNamed name -> definitions.TryFind name |> Option.iter addType + | _ -> () + let rec collect (expression: Lir.Expression) = + addType expression.Type + let visit = collect + match expression.Node with + | Lir.CallClosure(a,b) | Lir.PipeClosure(a,b) | Lir.TailCallClosure(a,b) | Lir.TailPipeClosure(a,b) + | Lir.Cons(a,b) | Lir.Append(a,b) | Lir.Range(a,b) | Lir.IndexGet(a,b) -> visit a; visit b + | Lir.Branch(a,b,c) -> visit a; visit b; visit c + | Lir.Operation(_,items) | Lir.List items | Lir.Tuple items -> List.iter visit items + | Lir.Record items -> items |> List.iter (snd >> visit) + | Lir.FieldGet(item,_) | Lir.SomeValue item | Lir.Fail item -> visit item + | Lir.RecordConvert(item,target) -> visit item; addType target + | Lir.Let(_,_,_,a,b) -> visit a; visit b + | Lir.LetRecursiveGroup(bindings,body) -> bindings |> List.iter (fun (_,_,t,v) -> addType t; visit v); visit body + | Lir.DecisionTree(target,cases) -> + visit target + let rec plan (value: Lir.PatternPlan) = + value.Bindings |> List.iter (_.Type >> addType) + for map in value.Maps do + for clause in map.Clauses do plan clause.Key; plan clause.Value + Option.iter plan map.Tail + for case in cases do plan case.Plan; Option.iter visit case.Guard; visit case.Body + | Lir.RecordUpdate(target,items) -> visit target; items |> List.iter (snd >> visit) + | Lir.Interpolate parts -> parts |> List.iter (function Lir.ValuePart item -> visit item | _ -> ()) + | Lir.UnionCase(_,_,payload) -> Option.iter visit payload + | Lir.Map items -> items |> List.iter (function Lir.KeyValue(a,b) -> visit a; visit b | Lir.Spread item -> visit item) + | Lir.ForEach(_,_,t,source,body) -> addType t; visit source; visit body + | Lir.TypeToken t -> addType t + | _ -> () + program.Declarations |> List.iter (fun d -> addType d.Type; collect d.Value) + program.Functions |> List.iter (fun f -> addType f.ParameterType; addType f.ReturnType; collect f.Body) + Option.iter collect program.Entry + if assemblyMode then addType (program.Entry |> Option.map _.Type |> Option.defaultValue TUnit) + let symbolTypes = Collections.Generic.Dictionary() + let knownBindings = Collections.Generic.Dictionary() + let rec collectBindings (value: Lir.Expression) = + match value.Node with + | Lir.Load id -> symbolTypes.TryAdd(id,value.Type) |> ignore + | _ -> () + // Captures also carry their use types in the lifted function body. + let rec walk (v: Lir.Expression) = + match v.Node with + | Lir.Load id -> symbolTypes.TryAdd(id,v.Type) |> ignore + | Lir.Let(id,_,_,binding,body) -> + symbolTypes.[id] <- binding.Type + knownBindings.[id] <- binding + walk binding + walk body + | Lir.LetRecursiveGroup(bindings,body) -> + for id,_,t,item in bindings do + symbolTypes.[id] <- t + knownBindings.[id] <- item + walk item + walk body + | Lir.ForEach(id,_,t,source,body) -> symbolTypes.[id] <- t; walk source; walk body + | Lir.CallClosure(a,b) | Lir.PipeClosure(a,b) | Lir.TailCallClosure(a,b) | Lir.TailPipeClosure(a,b) + | Lir.Cons(a,b) | Lir.Append(a,b) | Lir.Range(a,b) | Lir.IndexGet(a,b) -> walk a; walk b + | Lir.Branch(a,b,c) -> walk a; walk b; walk c + | Lir.Operation(_,items) | Lir.Tuple items | Lir.List items -> List.iter walk items + | Lir.Record items -> List.iter (snd >> walk) items + | Lir.FieldGet(item,_) | Lir.SomeValue item | Lir.Fail item | Lir.RecordConvert(item,_) -> walk item + | Lir.DecisionTree(target,cases) -> walk target; for case in cases do Option.iter walk case.Guard; walk case.Body + | Lir.RecordUpdate(target,items) -> walk target; List.iter (snd >> walk) items + | Lir.Interpolate parts -> List.iter (function Lir.ValuePart item -> walk item | _ -> ()) parts + | Lir.UnionCase(_,_,payload) -> Option.iter walk payload + | Lir.Map entries -> List.iter (function Lir.KeyValue(a,b) -> walk a; walk b | Lir.Spread item -> walk item) entries + | _ -> () + walk value + for declaration in program.Declarations do symbolTypes.[declaration.Id] <- declaration.Type; collectBindings declaration.Value + for fn in program.Functions do symbolTypes.[fn.Parameter] <- fn.ParameterType; collectBindings fn.Body + let functions = program.Functions |> List.map (fun f -> f.Id,f) |> Map.ofList + let globalIds = program.Declarations |> List.map _.Id |> Set.ofList + let mutable temporary = 0 + let fresh prefix = temporary <- temporary + 1; prefix + string temporary + let constant = function + | Lir.Unit -> "default(Unit)" + | Lir.Int value -> if value = Int64.MinValue then "long.MinValue" else string value + "L" + | Lir.Float value -> if Double.IsNaN value then "double.NaN" elif Double.IsPositiveInfinity value then "double.PositiveInfinity" elif Double.IsNegativeInfinity value then "double.NegativeInfinity" else value.ToString("R", Globalization.CultureInfo.InvariantCulture) + "d" + | Lir.Bool value -> if value then "true" else "false" + | Lir.String value -> quote value + let eqName t = "Equal_" + hash t + let fmtName t = "Format_" + hash t + let interpName t = "Interpolate_" + hash t + let encName t = "Encode_" + hash t + let decName t = "Decode_" + hash t + let jsonEncodeName t = "JsonEncode_" + hash t + let jsonDecodeName t = "JsonDecode_" + hash t + let rec sdkType t = + let st="global::FScript.Extensibility.ScriptType" + let unary name item = $"{st}.New{name}({sdkType item})" + match t with + | TUnit -> st+".TUnit" | TInt -> st+".TInt" | TFloat -> st+".TFloat" | TBool -> st+".TBool" | TString -> st+".TString" | TTypeToken -> st+".TTypeToken" + | TVar id -> $"{st}.NewTVar({id})" | TNumeric id -> $"{st}.NewTNumeric({id})" + | TNamed name -> $"{st}.NewTNamed({quote name})" + | TList item -> unary "TList" item | TOption item -> unary "TOption" item | TTask item -> unary "TTask" item + | TFun(a,b) -> $"{st}.NewTFun({sdkType a},{sdkType b})" | TMap(a,b) -> $"{st}.NewTMap({sdkType a},{sdkType b})" + | TTuple items -> + let values=items |> List.map sdkType |> String.concat comma + $"{st}.NewTTuple(global::Microsoft.FSharp.Collections.ListModule.OfArray(new {st}[] {{ {values} }}))" + | TRecord fields | THostManaged(_,fields) -> + let values=fields |> Map.toList |> List.map (fun (name,t) -> $"Tuple.Create({quote name}, {sdkType t})") |> String.concat comma + let map= $"global::Microsoft.FSharp.Collections.MapModule.OfSeq(new Tuple[] {{ {values} }})" + match t with THostManaged(name,_) -> $"{st}.NewTHostManaged({quote name},{map})" | _ -> $"{st}.NewTRecord({map})" + | TUnion(name,cases) -> + let values=cases |> Map.toList |> List.map (fun (name,t) -> + let payload=t |> Option.map (fun t -> $"global::Microsoft.FSharp.Core.FSharpOption<{st}>.Some({sdkType t})") |> Option.defaultValue "null" + $"Tuple.Create?>({quote name},{payload})") |> String.concat comma + $"{st}.NewTUnion({quote name},global::Microsoft.FSharp.Collections.MapModule.OfSeq(new Tuple?>[] {{ {values} }}))" + | TRecordShape _ -> fail "FSC6008" "Unresolved structural witness in SDK signature." None + let readField target name code = + match resolve target with + | THostManaged(typeName,required) when hasSdk && not (nativeTypes.ContainsKey typeName) -> + $"{decName required.[name]}(({code}).Fields[{quote name}])" + | _ -> $"({code}).{fieldName target name}" + let rec coerce source target code = + if csType source = csType target then code + else + match resolve source, resolve target with + | (TRecord _ | THostManaged _), TRecord destination -> + let original = fresh "converted" + let args = destination |> Map.toList |> List.map (fun (name,t) -> coerce (fields source).[name] t (readField source name original)) |> String.concat comma + wrap (csType target) $"var {original} = {code}; return new {csType target}({args});" + | TOption a,TOption b -> + let original = fresh "option" + wrap (csType target) $"var {original} = {code}; return {original}.HasValue ? {csType target}.Some({coerce a b (valueMember original)}) : default;" + | TList a,TList b -> $"({code}).Select(item => {coerce a b itemCode}).ToArray()" + | TTuple sourceItems,TTuple targetItems when sourceItems.Length=targetItems.Length -> + let original=fresh "tuple" + let args=List.zip sourceItems targetItems |> List.mapi (fun i (a,b) -> coerce a b $"{original}.Item{i}") |> String.concat comma + wrap (csType target) $"var {original}={code}; return new {csType target}({args});" + | TFun(sa,sr),TFun(ta,tr) -> + let original=fresh "function" + let argument=fresh "argument" + let call= $"{original}.Invoke({coerce ta sa argument})" + wrap (csType target) $"var {original}={code}; return ({csType ta} {argument}) => {coerce sr tr call};" + | _ -> code + let rec curryApplied supplied current args build = + match supplied,current with + | argument::rest,TFun(_,result) -> curryApplied rest result (args @ [argument]) build + | _,TFun(argument,result) -> + let parameter = fresh "argument" + $"(({csType current})(({csType argument} {parameter}) => {curryApplied [] result (args @ [parameter]) build}))" + | _,result -> build args result + let rec intrinsic name signature supplied = + let build body = curryApplied supplied signature [] body + let arrayType = function TList item -> item | _ -> invalidOp "Expected list." + let rec argsOf = function TFun(a,b) -> a :: argsOf b | _ -> [] + let parameters = argsOf signature + match name, signature with + | "List.empty", TList t -> $"Array.Empty<{csType t}>()" + | "Map.empty", TMap _ -> $"new {csType signature}()" + | "ignore", _ -> build (fun _ _ -> "default(Unit)") + | "Int.toString", _ -> build (fun a _ -> $"{a.[0]}.ToString(CultureInfo.InvariantCulture)") + | "Float.toString", _ -> build (fun a _ -> $"FsRuntime.FloatText({a.[0]})") + | "Bool.toString", _ -> build (fun a _ -> $"({a.[0]} ? \"true\" : \"false\")") + | "Int.tryParse", _ -> build (fun a _ -> $"FsRuntime.ParseInt({a.[0]})") + | "Float.tryParse", _ -> build (fun a _ -> $"FsRuntime.ParseFloat({a.[0]})") + | "Bool.tryParse", _ -> build (fun a _ -> $"FsRuntime.ParseBool({a.[0]})") + | "String.replace", _ -> build (fun a _ -> $"FsRuntime.Replace({a.[0]}, {a.[1]}, {a.[2]})") + | "String.indexOf", _ -> build (fun a _ -> $"FsRuntime.IndexOf({a.[0]}, {a.[1]})") + | "String.toLower", _ -> build (fun a _ -> $"{a.[0]}.ToLowerInvariant()") + | "String.toUpper", _ -> build (fun a _ -> $"{a.[0]}.ToUpperInvariant()") + | "String.substring", _ -> build (fun a _ -> $"FsRuntime.Substring({a.[0]}, {a.[1]}, {a.[2]})") + | "String.concat", _ -> build (fun a _ -> $"string.Join({a.[0]}, {a.[1]})") + | "String.split", _ -> build (fun a _ -> $"{a.[1]}.Split(new string[] {{ {a.[0]} }}, StringSplitOptions.None)") + | "String.endsWith", _ -> build (fun a _ -> $"{a.[1]}.EndsWith({a.[0]}, StringComparison.Ordinal)") + | "List.map", _ -> build (fun a _ -> $"{a.[1]}.Select(item => {a.[0]}(item)).ToArray()") + | "List.iter", _ -> build (fun a _ -> $"FsRuntime.Iter({a.[0]}, {a.[1]})") + | "List.choose", _ -> build (fun a _ -> $"{a.[1]}.Select(item => {a.[0]}(item)).Where(item => item.HasValue).Select(item => item.Value).ToArray()") + | "List.collect", _ -> build (fun a _ -> $"{a.[1]}.SelectMany(item => {a.[0]}(item)).ToArray()") + | "List.exists", _ -> build (fun a _ -> $"{a.[1]}.Any(item => {a.[0]}(item))") + | "List.contains", _ -> build (fun a _ -> $"{a.[1]}.Any(item => {eqName parameters.[0]}({a.[0]}, item))") + | "List.rev", _ -> build (fun a _ -> $"{a.[0]}.Reverse().ToArray()") + | "List.distinct", _ -> build (fun a _ -> $"FsRuntime.Distinct({a.[0]}, {eqName (arrayType parameters.[0])})") + | "List.fold", _ -> build (fun a _ -> $"FsRuntime.Fold({a.[0]}, {a.[1]}, {a.[2]})") + | "List.filter", _ -> build (fun a _ -> $"{a.[1]}.Where(item => {a.[0]}(item)).ToArray()") + | "List.length", _ -> build (fun a _ -> $"{a.[0]}.LongLength") + | "List.tryFind", _ -> build (fun a _ -> $"FsRuntime.Find({a.[0]}, {a.[1]})") + | "List.tryGet", _ -> build (fun a _ -> $"FsRuntime.FindIndex({a.[0]}, {a.[1]})") + | "List.tryItem", _ -> build (fun a _ -> $"FsRuntime.At({a.[0]}, {a.[1]})") + | "List.tryHead", _ -> build (fun a _ -> $"FsRuntime.At(0, {a.[0]})") + | "List.tail", _ -> build (fun a _ -> $"{a.[0]}.Skip(1).ToArray()") + | "List.append", _ -> build (fun a _ -> $"{a.[0]}.Concat({a.[1]}).ToArray()") + | "Option.defaultValue", _ -> build (fun a _ -> $"({a.[1]}.HasValue ? {a.[1]}.Value : {a.[0]})") + | "Option.defaultWith", _ -> build (fun a _ -> $"({a.[1]}.HasValue ? {a.[1]}.Value : {a.[0]}(default(Unit)))") + | "Option.isNone", _ -> build (fun a _ -> $"!{a.[0]}.HasValue") + | "Option.isSome", _ -> build (fun a _ -> $"{a.[0]}.HasValue") + | "Option.map", _ -> build (fun a r -> $"({a.[1]}.HasValue ? {csType r}.Some({a.[0]}({a.[1]}.Value)) : default)") + | "Map.tryGet", _ -> build (fun a _ -> $"{a.[1]}.Find({a.[0]})") + | "Map.containsKey", _ -> build (fun a _ -> $"{a.[1]}.Find({a.[0]}).HasValue") + | "Map.count", _ -> build (fun a _ -> $"{a.[0]}.Entries.LongLength") + | "Map.add", _ -> build (fun a _ -> $"{a.[2]}.Add({a.[0]}, {a.[1]})") + | "Map.remove", _ -> build (fun a _ -> $"{a.[1]}.Remove({a.[0]})") + | "Map.ofList", _ -> build (fun a r -> + let tuple = arrayType parameters.[0] + let key,value = match tuple with TTuple [k;v] -> k,v | _ -> invalidOp "Expected pairs." + $"FsRuntime.MapOfArray<{csType key},{csType value}>({a.[0]}.Select(pair => (pair.Item0,pair.Item1)).ToArray())") + | "Map.fold", _ -> build (fun a _ -> $"FsRuntime.MapFold({a.[0]}, {a.[1]}, {a.[2]})") + | "Map.iter", _ -> build (fun a _ -> $"FsRuntime.MapIter({a.[0]}, {a.[1]})") + | "Map.filter", _ -> build (fun a r -> $"new {csType r}({a.[1]}.Entries.Where(e => {a.[0]}(e.Key)(e.Value)).ToArray())") + | "Map.map", _ -> build (fun a r -> $"new {csType r}({a.[1]}.Entries.Select(e => new {csType r}.Entry(e.Key, {a.[0]}(e.Value))).ToArray())") + | "Map.choose", _ -> build (fun a r -> $"new {csType r}({a.[1]}.Entries.Select(e => (e.Key, Value: {a.[0]}(e.Key)(e.Value))).Where(e => e.Value.HasValue).Select(e => new {csType r}.Entry(e.Key,e.Value.Value)).ToArray())") + | "Env.setExitCode", _ -> build (fun a _ -> $"SetExitCode({a.[0]})") + | "Console.writeLine", _ -> build (fun a _ -> $"FsRuntime.WriteLine({a.[0]})") + | "Console.readLine", _ -> build (fun a _ -> $"FsRuntime.ReadLine({a.[0]})") + | "Fs.readText", _ -> build (fun a _ -> $"FsRuntime.Try(() => File.ReadAllText({a.[0]}))") + | "Fs.exists", _ -> build (fun a _ -> $"(File.Exists({a.[0]}) || Directory.Exists({a.[0]}))") + | "Fs.kind", _ -> build (fun a r -> $"(File.Exists({a.[0]}) ? ({csType r})new {csType r}.v_File(Path.GetRelativePath(Directory.GetCurrentDirectory(),Path.GetFullPath({a.[0]}))) : Directory.Exists({a.[0]}) ? ({csType r})new {csType r}.v_Directory(Path.GetRelativePath(Directory.GetCurrentDirectory(),Path.GetFullPath({a.[0]}))) : new {csType r}.v_Missing())") + | "Fs.createDirectory", _ -> build (fun a _ -> $"FsRuntime.TryEffect(() => Directory.CreateDirectory({a.[0]}))") + | "Fs.writeText", _ -> build (fun a _ -> $"FsRuntime.TryEffect(() => File.WriteAllText({a.[0]}, {a.[1]}))") + | "Fs.combinePath", _ -> build (fun a _ -> $"Path.Combine({a.[0]}, {a.[1]})") + | "Fs.parentDirectory", _ -> build (fun a r -> wrap (csType r) $"var path=Path.GetDirectoryName({a.[0]}); return string.IsNullOrEmpty(path) ? default : {csType r}.Some(path);") + | "Fs.extension", _ -> build (fun a r -> wrap (csType r) $"var extension=Path.GetExtension({a.[0]}); return string.IsNullOrEmpty(extension) ? default : {csType r}.Some(extension);") + | "Fs.fileNameWithoutExtension", _ -> build (fun a _ -> $"Path.GetFileNameWithoutExtension({a.[0]})") + | "Fs.glob", _ -> build (fun a _ -> $"FsRuntime.Files(Directory.GetCurrentDirectory(), {a.[0]}, true)") + | "Fs.enumerateFiles", _ -> build (fun a _ -> $"FsRuntime.Files({a.[0]}, {a.[1]}, false)") + | "Regex.matchGroups", _ -> build (fun a _ -> $"FsRuntime.MatchGroups({a.[0]}, {a.[1]})") + | "Hash.md5", _ -> build (fun a _ -> $"FsRuntime.Try(() => Convert.ToHexString(System.Security.Cryptography.MD5.HashData(System.Text.Encoding.UTF8.GetBytes({a.[0]}))).ToLowerInvariant())") + | "Guid.new", _ -> build (fun _ _ -> "Option.Some(Guid.NewGuid().ToString())") + | "Json.serialize", _ -> build (fun a _ -> $"FsRuntime.Try(() => {jsonEncodeName parameters.[0]}({a.[0]}))") + | "Json.deserialize", _ -> build (fun a r -> match r with TOption item -> $"FsRuntime.ParseJson({a.[1]}, {jsonDecodeName item})" | _ -> invalidOp "Expected option.") + | "Xml.queryValues", _ -> build (fun a _ -> $"FsRuntime.QueryXml({a.[0]}, {a.[1]})") + | "Task.spawn", _ -> build (fun a _ -> $"Task.Run(() => {a.[0]}(default(Unit)))") + | "Task.await", _ -> build (fun a _ -> $"{a.[0]}.GetAwaiter().GetResult()") + | "Task.map", _ -> build (fun a _ -> $"Task.Run(() => {a.[0]}({a.[1]}.GetAwaiter().GetResult()))") + | "Task.bind", _ -> build (fun a _ -> $"Task.Run(async () => await {a.[0]}(await {a.[1]}))") + | "Task.parallel", _ -> build (fun a _ -> $"Task.WhenAll({a.[0]})") + | "Task.ignore", _ -> build (fun a _ -> $"Task.Run(async () => {{ await {a.[0]}; return default(Unit); }})") + | _ -> fail "FSC6005" $"External or intrinsic '{name}' has no compiled CLR implementation. Bind host functions with ClrBindings.bindMethod." None + let rec toClr semantic (native: System.Type) code = + if native = typeof then code + elif csType semantic = typeName native then code + elif native = typeof || native = typeof || native = typeof || native = typeof || native = typeof || native = typeof then $"(({typeName native})({code}))" + elif native = typeof then "default(global::Microsoft.FSharp.Core.Unit)" + elif native.IsArray then + match semantic with TList item -> $"({code}).Select(item => {toClr item ((native.GetElementType() |> nonNull)) itemCode}).ToArray()" | _ -> code + elif native.IsGenericType && native.GetGenericTypeDefinition() = typedefof> then + match semantic with TList item -> $"global::Microsoft.FSharp.Collections.ListModule.OfArray(({code}).Select(item => {toClr item (native.GetGenericArguments().[0]) itemCode}).ToArray())" | _ -> code + elif native.IsGenericType && native.GetGenericTypeDefinition() = typedefof> then + match semantic with TList item -> $"global::Microsoft.FSharp.Collections.SetModule.OfSeq(({code}).Select(item => {toClr item (native.GetGenericArguments().[0]) itemCode}))" | _ -> code + elif native.IsGenericType && native.GetGenericTypeDefinition() = typedefof> then + match semantic with TOption item -> $"(({code}).HasValue ? {typeName native}.Some({toClr item (native.GetGenericArguments().[0]) (valueMember code)}) : null)" | _ -> code + else code + and fromClr (native: System.Type) semantic code = + if native = typeof || native = typeof then wrap "Unit" $"{code}; return default;" + elif csType semantic = typeName native then code + else + match semantic with + | TInt | TFloat | TBool | TString -> $"(({csType semantic})({code}))" + | TList item when native.IsArray || native.IsGenericType -> + let element = if native.IsArray then (native.GetElementType() |> nonNull) else native.GetGenericArguments().[0] + $"({code}).Select(item => {fromClr element item itemCode}).ToArray()" + | TOption item when native.IsGenericType && native.GetGenericTypeDefinition() = typedefof> -> + let original = fresh "foreignOption" + wrap (csType semantic) $"var {original}={code}; return {original} is null ? default : {csType semantic}.Some({fromClr (native.GetGenericArguments().[0]) item (valueMember original)});" + | _ -> code + let sdkProviders = Collections.Generic.Dictionary() + let targetImport (path: string) memberName signature span supplied = + if path.StartsWith("clr-sdk:",StringComparison.Ordinal) then + let methodPath="clr:"+path.Substring(8) + let link=ClrBindings.tryMethodLink methodPath |> Option.defaultWith (fun () -> fail "FSC6006" "Invalid SDK provider linkage." (Some span)) + let key=path + let provider= + match sdkProviders.TryGetValue key with + | true,value -> value + | _ -> + let value=fresh "Provider" + sdkProviders.Add(key,value) + value + let rec argsOf = function TFun(a,b) -> a :: argsOf b | _ -> [] + let argumentTypes=argsOf signature + curryApplied supplied signature [] (fun args result -> + let encoded=List.map2 (fun t arg -> $"{encName t}({arg})") argumentTypes args |> String.concat comma + $"{decName result}(SdkInterop.Invoke(SdkInterop.Find({provider}.Value, {quote memberName}), new global::FScript.Extensibility.ScriptValue[] {{ {encoded} }}))") + else + match ClrBindings.tryMethodLink path with + | None -> fail "FSC6002" $"Import '{path}.{memberName}' has no compiled CLR method binding." (Some span) + | Some link -> + let declaring = System.Type.GetType(link.DeclaringType, false) + if isNull declaring then fail "FSC6003" $"Cannot resolve CLR declaring type '{link.DeclaringType}'." (Some span) + let declaring = nonNull declaring + let parameterTypes = link.Parameters |> Array.map (fun name -> + let t = System.Type.GetType(name,false) + if isNull t then fail "FSC6003" $"Cannot resolve CLR parameter type '{name}'." (Some span) + nonNull t) + let method: MethodBase | null = + if link.IsConstructor then declaring.GetConstructor(parameterTypes) + else declaring.GetMethod(memberName, BindingFlags.Public ||| BindingFlags.Static ||| BindingFlags.Instance, null, parameterTypes, null) + if isNull method then fail "FSC6006" $"Cannot resolve exact CLR overload '{declaring.FullName}.{memberName}'." (Some span) + let method = nonNull method + if method.IsStatic <> link.IsStatic || not method.IsPublic then fail "FSC6006" "CLR linkage accessibility or calling convention is invalid." (Some span) + let rec arguments = function TFun(a,b) -> a :: arguments b | _ -> [] + let argumentTypes = arguments signature + let receiverCount = if link.IsStatic || link.IsConstructor then 0 else 1 + if argumentTypes.Length <> parameterTypes.Length + receiverCount && not (parameterTypes.Length = 0 && argumentTypes = [TUnit]) then + fail "FSC6006" $"CLR binding '{memberName}' does not match the FScript arity." (Some span) + curryApplied supplied signature [] (fun args result -> + let inputs = if parameterTypes.Length = 0 then [] else args |> List.skip receiverCount + let semanticInputs = if parameterTypes.Length = 0 then [] else argumentTypes |> List.skip receiverCount + let converted = List.map3 (fun t native value -> toClr t native value) semanticInputs (Array.toList parameterTypes) inputs |> String.concat comma + let call = if link.IsConstructor then $"new {typeName declaring}({converted})" elif link.IsStatic then $"{typeName declaring}.@{memberName}({converted})" else $"({args.[0]}).@{memberName}({converted})" + let returnType = match method with :? MethodInfo as m -> m.ReturnType | _ -> declaring + fromClr returnType result call) + for declaration in program.Declarations do knownBindings.[declaration.Id] <- declaration.Value + let mutable available=Set.ofSeq globalIds + let within ids action = + let previous=available + available <- Set.union available (Set.ofSeq ids) + try action () finally available <- previous + let knownNode (root: Lir.Expression) = + match root.Node with + | Lir.Load id -> + match knownBindings.TryGetValue id with + | true,({Node=Lir.MakeClosure(_,captures)} as binding) when captures |> List.forall (fun capture -> Set.contains capture available) -> binding.Node + | true,({Node=(Lir.Intrinsic _ | Lir.HostExternal _ | Lir.TargetImport _)} as binding) -> binding.Node + | _ -> root.Node + | node -> node + let rec functionChain seen id = + let fn=functions.[id] + match fn.Body.Node with + | Lir.MakeClosure(next,_) when not (Set.contains next seen) -> fn :: functionChain (Set.add id seen) next + | _ -> [fn] + let rec expression (value: Lir.Expression) = + let emit = expression + let directApplication () = + let rec spine (node: Lir.Expression) = + match node.Node with + | Lir.CallClosure(fn,arg) | Lir.TailCallClosure(fn,arg) -> + let root,args,order=spine fn + let index=List.length args + root,args @ [index,arg],order @ [index,arg] + | Lir.PipeClosure(arg,fn) | Lir.TailPipeClosure(arg,fn) -> + let root,args,order=spine fn + let index=List.length args + root,args @ [index,arg],(index,arg)::order + | _ -> node,[],[] + let root,args,order=spine value + let rec signatureTypes = function TFun(a,b) -> a::signatureTypes b | _ -> [] + let parameters=signatureTypes root.Type + let rootNode=knownNode root + let supported = + match rootNode with + | Lir.Intrinsic _ | Lir.HostExternal _ | Lir.TargetImport _ -> args.Length=parameters.Length + | Lir.MakeClosure(id,_) -> args.Length=(functionChain Set.empty id).Length + | _ -> false + if not supported || args.IsEmpty then None else + let names=args |> List.map (fun (index,_) -> index,fresh "nativeArgument") |> Map.ofList + let collectionCallback= + match rootNode,args with + | Lir.Intrinsic name,(_,callback)::_ when List.contains name ["List.map";"List.iter";"List.filter";"List.choose";"List.collect";"List.exists";"List.tryFind";"List.tryGet";"List.fold"] -> + match knownNode callback with + | Lir.MakeClosure(id,captures) when (functionChain Set.empty id).Length=(if name="List.fold" then 2 else 1) -> Some(name,id,captures) + | _ -> None + | _ -> None + let callbackCaptures= + match collectionCallback with + | Some(_,_,captures) -> captures |> List.filter (fun id -> not (globalIds.Contains id)) |> List.map (fun id -> id,fresh "callbackCapture") + | None -> [] + let setup=order |> List.map (fun (index,argument) -> + if index=0 && collectionCallback.IsSome then + callbackCaptures |> List.map (fun (id,name) -> $"{csType symbolTypes.[id]} {name}={sym id};") |> String.concat space + else $"var {names.[index]}={emit argument};") |> String.concat space + let arguments=List.map2 (fun (index,(arg: Lir.Expression)) expected -> coerce arg.Type expected names.[index]) args (parameters |> List.take args.Length) + let result= + match collectionCallback,rootNode with + | Some(name,id,_),_ -> + let sourceIndex=if name="List.fold" then 2 else 1 + let source=fresh "callbackSource" + let item=fresh "nativeItem" + let index=fresh "nativeIndex" + let state=fresh "nativeState" + let result=fresh "nativeList" + let chain=functionChain Set.empty id + let itemType=match parameters.[sourceIndex] with TList t -> t | _ -> invalidOp "Expected list argument." + let values=if name="List.fold" then [state;item] else [item] + let inputTypes=if name="List.fold" then [parameters.[1];itemType] else [itemType] + let inputs=List.map3 (fun code actual (parameter: Lir.Function) -> coerce actual parameter.ParameterType code) values inputTypes chain + let rawCall= $"Native{funName id}({String.concat comma ((List.map snd callbackCaptures) @ inputs)})" + let expectedReturn= + match name,value.Type with + | "List.map",TList output -> output + | "List.collect",TList output -> TList output + | "List.choose",TList output -> TOption output + | "List.fold",_ -> value.Type + | _ -> (List.last chain).ReturnType + let call=coerce (List.last chain).ReturnType expectedReturn rawCall + let body= + match name,value.Type with + | "List.map",TList output -> $"var {result}=new {csType output}[{source}.Length]; for (int {index}=0; {index}<{source}.Length; {index}++) {{ var {item}={source}[{index}]; {result}[{index}]={call}; }} return {result};" + | "List.iter",_ -> $"foreach (var {item} in {source}) {{ _={call}; }} return default;" + | "List.fold",_ -> $"{csType parameters.[1]} {state}={arguments.[1]}; foreach (var {item} in {source}) {{ {state}={call}; }} return {state};" + | "List.exists",_ -> $"foreach (var {item} in {source}) {{ if ({call}) return true; }} return false;" + | "List.tryFind",_ -> $"foreach (var {item} in {source}) {{ if ({call}) return {csType value.Type}.Some({item}); }} return default;" + | "List.tryGet",_ -> $"for (int {index}=0; {index}<{source}.Length; {index}++) {{ var {item}={source}[{index}]; if ({call}) return {csType value.Type}.Some({index}); }} return default;" + | "List.filter",_ -> $"var {result}=new System.Collections.Generic.List<{csType itemType}>(); foreach (var {item} in {source}) {{ if ({call}) {result}.Add({item}); }} return {result}.ToArray();" + | "List.collect",TList output -> $"var {result}=new System.Collections.Generic.List<{csType output}>(); foreach (var {item} in {source}) {{ {result}.AddRange({call}); }} return {result}.ToArray();" + | "List.choose",TList output -> $"var {result}=new System.Collections.Generic.List<{csType output}>(); foreach (var {item} in {source}) {{ var chosen={call}; if(chosen.HasValue) {result}.Add(chosen.Value); }} return {result}.ToArray();" + | _ -> invalidOp "Invalid specialized collection callback." + wrap (csType value.Type) $"var {source}={arguments.[sourceIndex]}; {body}" + | _,Lir.Intrinsic name | _,Lir.HostExternal(name,_) -> intrinsic name root.Type arguments + | _,Lir.TargetImport(path,name) -> targetImport path name root.Type root.Span arguments + | _,Lir.MakeClosure(id,captures) -> + let chain=functionChain Set.empty id + let captures=captures |> List.filter (fun id -> not (globalIds.Contains id)) |> List.map sym + let call= $"Native{funName id}({String.concat comma (captures @ arguments)})" + coerce (List.last chain).ReturnType value.Type call + | _ -> invalidOp "Unsupported direct application." + // CLR unit arguments can be evaluated without being passed to a zero-argument + // method/constructor. Preserve their effects without an unread temporary. + let setup = names |> Map.fold (fun (setup: string) _ name -> + if Text.RegularExpressions.Regex.IsMatch(result, @"\b" + Text.RegularExpressions.Regex.Escape(name) + @"\b") then setup + else setup.Replace($"var {name}=", "_=")) setup + Some(wrap (csType value.Type) $"{setup} return {result};") + let code = + match (if assemblyMode then directApplication () else None) with + | Some direct -> direct + | None -> + match value.Node with + | Lir.Constant c -> constant c + | Lir.Load id -> coerce symbolTypes.[id] value.Type (sym id) + | Lir.MakeClosure(id,captures) -> + let fn = functions.[id] + let parameter = fresh "closureArg" + let captures = captures |> List.filter (fun id -> not (globalIds.Contains id)) |> List.map sym + let snapshots = if assemblyMode then captures |> List.map (fun original -> original,fresh "nativeCapture") else [] + let passedCaptures=if assemblyMode then List.map snd snapshots else captures + let parameterType,resultType = match value.Type with TFun(a,b) -> a,b | _ -> fn.ParameterType,fn.ReturnType + let args = String.concat comma (passedCaptures @ [coerce parameterType fn.ParameterType parameter]) + let call=coerce fn.ReturnType resultType $"{funName id}({args})" + let closure= $"(({csType value.Type})(({csType parameterType} {parameter}) => {call}))" + if assemblyMode && not snapshots.IsEmpty then + let setup=snapshots |> List.map (fun (original,snapshot) -> $"var {snapshot}={original};") |> String.concat space + wrap (csType value.Type) $"{setup} return {closure};" + else closure + | Lir.CallClosure(fn,arg) | Lir.TailCallClosure(fn,arg) -> + let parameterType,resultType = match fn.Type with TFun(a,b) -> a,b | _ -> arg.Type,value.Type + coerce resultType value.Type $"({emit fn}).Invoke({coerce arg.Type parameterType (emit arg)})" + | Lir.PipeClosure(arg,fn) | Lir.TailPipeClosure(arg,fn) -> + let parameter = fresh "pipelineArgument" + let parameterType,resultType=match fn.Type with TFun(a,b) -> a,b | _ -> arg.Type,value.Type + let call=coerce resultType value.Type $"({emit fn}).Invoke({coerce arg.Type parameterType parameter})" + wrap (csType value.Type) $"var {parameter} = {emit arg}; return {call};" + | Lir.Branch(condition,yes,no) -> + let yesCode=coerce yes.Type value.Type (emit yes) + let noCode=coerce no.Type value.Type (emit no) + if assemblyMode then $"({emit condition} ? ({csType value.Type})({yesCode}) : ({csType value.Type})({noCode}))" + else $"({emit condition} ? {yesCode} : {noCode})" + | Lir.Operation(operation,[left;right]) -> + let op = + match operation with + | Lir.IntAdd | Lir.FloatAdd | Lir.NumericAdd -> "+" | Lir.IntSubtract | Lir.FloatSubtract | Lir.NumericSubtract -> "-" + | Lir.IntMultiply | Lir.FloatMultiply | Lir.NumericMultiply -> "*" | Lir.IntDivide | Lir.FloatDivide | Lir.NumericDivide -> "/" + | Lir.IntRemainder -> "%" | Lir.NumericLessThan -> "<" | Lir.NumericGreaterThan -> ">" + | Lir.NumericLessThanOrEqual -> "<=" | Lir.NumericGreaterThanOrEqual -> ">=" + | Lir.BooleanAnd -> "&&" | Lir.BooleanOr -> "||" | Lir.StructuralEqual -> "=" + if op = "=" then $"{eqName left.Type}({emit left}, {coerce right.Type left.Type (emit right)})" else $"({emit left} {op} {emit right})" + | Lir.Tuple items -> + let itemTypes=match value.Type with TTuple items -> items | _ -> items |> List.map (fun (item: Lir.Expression) -> item.Type) + let args=List.map2 (fun t (item: Lir.Expression) -> coerce item.Type t (emit item)) itemTypes items |> String.concat comma + $"new {csType value.Type}({args})" + | Lir.List items -> + let itemType=match value.Type with TList t -> t | _ -> invalidOp "Expected list." + let args=items |> List.map (fun item -> coerce item.Type itemType (emit item)) |> String.concat comma + $"new {csType value.Type} {{ {args} }}" + | Lir.Record items -> + let byName = Map.ofList items + let destination = fields value.Type |> Map.toList + if List.map fst items = List.map fst destination || items |> List.forall (snd >> LirOptimization.effect >> (=) LirOptimization.Pure) then + let args = destination |> List.map (fun (name,t) -> coerce byName.[name].Type t (emit byName.[name])) |> String.concat comma + $"new {csType value.Type}({args})" + else + let temporaries = items |> List.map (fun (name,item) -> name,(fresh "recordField",item)) + let setup = temporaries |> List.map (fun (_, (temp,item)) -> $"var {temp}={emit item};") |> String.concat space + let temporaries = Map.ofList temporaries + let args = destination |> List.map (fun (name,t) -> let temp,item=temporaries.[name] in coerce item.Type t temp) |> String.concat comma + wrap (csType value.Type) $"{setup} return new {csType value.Type}({args});" + | Lir.FieldGet(target,name) -> + let code = readField target.Type name (emit target) + let nativeName = match target.Type with TNamed name | THostManaged(name,_) -> Some name | _ -> None + match nativeName |> Option.bind nativeTypes.TryFind with + | Some native -> + let prop = native.GetProperty name + let field = native.GetField name + if not (isNull prop) then fromClr (nonNull prop).PropertyType value.Type code + elif not (isNull field) then fromClr (nonNull field).FieldType value.Type code + else fail "FSC6007" $"CLR type '{native.FullName}' has no public field or property '{name}'." (Some value.Span) + | None -> code + | Lir.SomeValue item -> + let itemType=match value.Type with TOption t -> t | _ -> item.Type + $"{csType value.Type}.Some({coerce item.Type itemType (emit item)})" + | Lir.NoneValue -> $"default({csType value.Type})" + | Lir.Cons(head,tail) -> + let itemType=match value.Type with TList t -> t | _ -> head.Type + $"new[] {{ {coerce head.Type itemType (emit head)} }}.Concat({coerce tail.Type value.Type (emit tail)}).ToArray()" + | Lir.Append(a,b) -> $"({coerce a.Type value.Type (emit a)}).Concat({coerce b.Type value.Type (emit b)}).ToArray()" + | Lir.Let(id,_,recursive,binding,body) -> + let result=within [id] (fun () -> if assemblyMode then coerce body.Type value.Type (emit body) else emit body) + let bindingCode=if recursive then within [id] (fun () -> emit binding) else emit binding + if recursive then wrap (csType value.Type) $"{csType binding.Type} {sym id} = default!; {sym id} = {bindingCode}; return {result};" + else wrap (csType value.Type) $"{csType binding.Type} {sym id} = {bindingCode}; return {result};" + | Lir.LetRecursiveGroup(bindings,body) -> + let declarations = bindings |> List.map (fun (id,_,t,_) -> $"{csType t} {sym id} = default!;") |> String.concat space + let scope=bindings |> List.map (fun (id,_,_,_) -> id) + let assignments = within scope (fun () -> bindings |> List.map (fun (id,_,_,v) -> $"{sym id} = {emit v};") |> String.concat space) + let result=within scope (fun () -> if assemblyMode then coerce body.Type value.Type (emit body) else emit body) + wrap (csType value.Type) $"{declarations} {assignments} return {result};" + | Lir.Fail message -> $"FsRuntime.Fail<{csType value.Type}>({emit message})" + | Lir.Range(first,last) -> $"FsRuntime.Range({emit first}, {emit last})" + | Lir.RecordUpdate(target,updates) -> + let original = fresh "original" + let setup,changed = updates |> List.map (fun (name,item) -> let temp=fresh "updatedField" in $"var {temp}={emit item};",(name,(item.Type,temp))) |> List.unzip + let changed = Map.ofList changed + let args = fields value.Type |> Map.toList |> List.map (fun (name,t) -> + match changed.TryFind name with Some(source,code) -> coerce source t code | None -> coerce (fields target.Type).[name] t $"{original}.{fieldName target.Type name}") |> String.concat comma + wrap (csType value.Type) $"var {original} = {emit target}; {String.concat space setup} return new {csType value.Type}({args});" + | Lir.RecordConvert(target,t) -> coerce target.Type t (emit target) + | Lir.IndexGet(target,index) -> + match target.Type with + | TList _ -> + let values=fresh "indexedValues" + wrap (csType value.Type) $"var {values}={emit target}; return FsRuntime.At({emit index}, {values});" + | _ -> $"({emit target}).Find({emit index})" + | Lir.Interpolate parts -> + parts |> List.map (function Lir.TextPart text -> quote text | Lir.ValuePart item -> $"{interpName item.Type}({emit item})") |> function [] -> "\"\"" | parts -> "(" + String.concat " + " parts + ")" + | Lir.UnionCase(_,caseName,payload) -> + let cases = match resolve value.Type with TUnion(_,cases) -> cases | _ -> Map.empty + if cases |> Map.forall (fun _ -> Option.isNone) then $"{csType value.Type}.{ident caseName}" + elif nativeTypes |> Map.exists (fun _ native -> typeName native = csType value.Type) then + match payload with None -> $"{csType value.Type}.@{caseName}" | Some item -> $"{csType value.Type}.New{caseName}({emit item})" + else $"new {csType value.Type}.{ident caseName}({payload |> Option.map emit |> Option.defaultValue String.Empty})" + | Lir.Map entries -> + let target = fresh "map" + let operations = entries |> List.map (function + | Lir.KeyValue(key,item) -> $"{target} = {target}.Add({emit key}, {emit item});" + | Lir.Spread item -> $"foreach (var entry in ({emit item}).Entries) {{ if (!{target}.Find(entry.Key).HasValue) {target} = {target}.Add(entry.Key,entry.Value); }}") |> String.concat space + wrap (csType value.Type) $"var {target} = new {csType value.Type}(); {operations} return {target};" + | Lir.Intrinsic name | Lir.HostExternal(name,_) -> intrinsic name value.Type [] + | Lir.TargetImport(path,memberName) -> targetImport path memberName value.Type value.Span [] + | Lir.RuntimeContext -> + $"new {csType value.Type}(Environment.GetCommandLineArgs().Skip(1).ToArray(), Option.Some(Path.GetFileName(Environment.GetCommandLineArgs()[0])))" + | Lir.ForEach(id,_,t,source,body) -> + let bodyCode=within [id] (fun () -> emit body) + wrap "Unit" $"foreach ({csType t} {sym id} in {emit source}) {{ _ = {bodyCode}; }} return default;" + | Lir.TypeToken t -> $"new TypeToken({quote (Types.typeToString t)})" + | Lir.DecisionTree(target,cases) -> decision target cases value.Type None + | _ -> fail "FSC6008" "Invalid LIR expression reached C# generation." (Some value.Span) + code + and decision target cases resultType returnBody = + let root = fresh "matchValue" + let allChecks checks = + if List.contains "false" checks then "false" + else match List.filter ((<>) "true") checks with [] -> "true" | values -> String.concat " && " (values |> List.map (fun value -> "("+value+")")) + let rec typeTest code actual expected = + match resolve expected,resolve actual with + | (TRecord required | TRecordShape(_,required,_)),(TRecord present | TRecordShape(_,present,_) | THostManaged(_,present)) -> + required |> Map.toList |> List.map (fun (name,t) -> + match Map.tryFind name present with + | Some fieldType -> typeTest (readField actual name code) fieldType t + | None -> "false") |> allChecks + | TList required,TList present -> + let item=fresh "typeItem" + match typeTest item present required with + | "true" -> "true" + | "false" -> $"({code}).Length == 0" + | test -> $"({code}).All({item} => {test})" + | TOption required,TOption present -> + match typeTest $"({code}).Value" present required with + | "true" -> "true" + | "false" -> $"!({code}).HasValue" + | test -> $"(!({code}).HasValue || ({test}))" + | TTuple required,TTuple present when required.Length=present.Length -> + List.zip required present |> List.mapi (fun index (r,p) -> typeTest $"({code}).Item{index}" p r) |> allChecks + | TMap _,TMap _ | TTask _,TTask _ -> "true" + | required,present -> if required=present then "true" else "false" + let projection checks root rootType path = + let rec loop prefix root rootType path = + match path with + | [] -> root,rootType + | step :: rest -> + let code,t = + match step,resolve rootType with + | Lir.ListHead,TList t -> $"({root})[0]",t + | Lir.ListTail,TList t -> $"({root}).Skip(1).ToArray()",TList t + | Lir.TupleItem index,TTuple items -> $"({root}).Item{index}",items.[index] + | Lir.RecordField name,(TRecord fields | THostManaged(_,fields)) -> readField rootType name root,fields.[name] + | Lir.OptionValue,TOption t -> $"({root}).Value",t + | Lir.UnionPayload,TUnion(_,cases) -> + let caseName = checks |> List.tryPick (function Lir.UnionCaseCheck(path,_,name,true) when path=prefix -> Some name | _ -> None) |> Option.defaultWith (fun () -> fail "FSC6008" "Union payload projection requires a preceding case check." None) + let payload = cases.[caseName] |> Option.get + $"(({csType rootType}.{ident caseName})({root})).Value",payload + | _ -> fail "FSC6008" "Invalid pattern projection." None + loop (prefix @ [step]) code t rest + loop [] root rootType path + let rec bindings (plan: Lir.PatternPlan) = + plan.Bindings @ (plan.Maps |> List.collect (fun map -> (map.Clauses |> List.collect (fun clause -> bindings clause.Key @ bindings clause.Value)) @ (map.Tail |> Option.map bindings |> Option.defaultValue []))) + let caseCode (case: Lir.DecisionCase) = + let declared = bindings case.Plan |> List.distinctBy _.Id |> List.map (fun b -> $"{csType b.Type} {sym b.Id} = default!;") |> String.concat space + let rec planCode root rootType (plan: Lir.PatternPlan) seen success = + let checks = plan.Checks |> List.map (fun check -> + let checkAt path predicate = let code,t=projection plan.Checks root rootType path in predicate code t + match check with + | Lir.LiteralCheck(path,c) -> checkAt path (fun code t -> $"{eqName t}({code},{constant c})") + | Lir.EmptyListCheck path -> checkAt path (fun code _ -> $"({code}).Length == 0") + | Lir.NonEmptyListCheck path -> checkAt path (fun code _ -> $"({code}).Length > 0") + | Lir.SomeCheck path -> checkAt path (fun code _ -> $"({code}).HasValue") + | Lir.NoneCheck path -> checkAt path (fun code _ -> $"!({code}).HasValue") + | Lir.UnionCaseCheck(path,_,name,_) -> checkAt path (fun code t -> + let allEmpty = match resolve t with TUnion(_,cases) -> cases |> Map.forall (fun _ -> Option.isNone) | _ -> false + if allEmpty then $"({code}) == {csType t}.{ident name}" else $"({code}) is {csType t}.{ident name}") + | Lir.TypeCheck(path,expected) -> checkAt path (fun code actual -> typeTest code actual expected) + | Lir.TupleArityCheck _ | Lir.RecordFieldCheck _ -> "true") + let mutable seen = seen + let bindingCode = plan.Bindings |> List.map (fun b -> + let projected,sourceType = projection plan.Checks root rootType b.Projection + if Set.contains b.Id seen then $"if (!{eqName b.Type}({sym b.Id},{projected})) return false;" + else seen <- Set.add b.Id seen; $"{sym b.Id} = {coerce sourceType b.Type projected};") |> String.concat space + let boundIds plan = bindings plan |> List.map _.Id |> Set.ofList + let rec maps (remaining: Lir.MapPlan list) seen = + match remaining with + | [] -> success + | map :: rest -> + let source,t = projection plan.Checks root rootType map.Projection + let keyType,valueType = match t with TMap(k,v) -> k,v | _ -> invalidOp "Expected map pattern." + let entries = fresh "entries" + let mapBindings = + [ yield! map.Clauses |> List.collect (fun clause -> [boundIds clause.Key; boundIds clause.Value]) + yield! map.Tail |> Option.map boundIds |> Option.toList ] |> Set.unionMany + let afterMap=Set.union seen mapBindings + let rec clauses index remainingEntries seen locallyBound = + if index = map.Clauses.Length then + let remaining=maps rest afterMap + let tail = match map.Tail with Some tail -> planCode $"new {csType t}({remainingEntries})" t tail seen remaining | None -> if map.RequireEmptyRemainder then $"if ({remainingEntries}.Length != 0) return false; {remaining}" else remaining + tail + else + let candidate = fresh "candidate" + let next = fresh "remaining" + let attempt = fresh "attempt" + let clause = map.Clauses.[index] + let afterKey=Set.union seen (boundIds clause.Key) + let afterValue=Set.union afterKey (boundIds clause.Value) + let local=Set.union locallyBound (Set.union (boundIds clause.Key) (boundIds clause.Value)) + let continuation = $"var {next} = {remainingEntries}.Where((entry,index) => index != {candidate}).ToArray(); {clauses (index+1) next afterValue local}" + let code = planCode $"{remainingEntries}[{candidate}].Key" keyType clause.Key seen (planCode $"{remainingEntries}[{candidate}].Value" valueType clause.Value afterKey "return true;") + let firstOnly=Lir.simpleKeyBinding clause.Key |> Option.exists (fun id -> not (Set.contains id locallyBound)) + let limit=if firstOnly then $"Math.Min(1,{remainingEntries}.Length)" else $"{remainingEntries}.Length" + $"for (int {candidate}=0; {candidate}<{limit}; {candidate}++) {{ bool {attempt}() {{ {code} }} if ({attempt}()) {{ {continuation} }} }} return false;" + $"var {entries} = ({source}).Entries; {clauses 0 entries seen Set.empty}" + let checks = checks |> List.filter ((<>) "true") + let prefix = if checks.IsEmpty then "" else "if (!(" + String.concat " && " (checks |> List.map (fun c -> "("+c+")")) + ")) return false; " + if List.contains "false" checks then "return false;" + else $"{prefix}{bindingCode} {maps plan.Maps seen}" + let matcher = fresh "matches" + let test = planCode root target.Type case.Plan Set.empty "return true;" + within (Lir.planBindingIds case.Plan) (fun () -> + let guard = case.Guard |> Option.map expression |> Option.defaultValue "true" + match returnBody with + | Some emit -> $"{{ {declared} bool {matcher}() {{ {test} }} if ({matcher}() && ({guard})) {{ {emit case.Body} }} }}" + | None -> $"{{ {declared} bool {matcher}() {{ {test} }} if ({matcher}() && ({guard})) return {coerce case.Body.Type resultType (expression case.Body)}; }}") + let cases = cases |> List.map caseCode |> String.concat "\n" + let targetType=if assemblyMode then csType target.Type else "var" + let statements= $"{targetType} {root} = {expression target}; {cases} throw new InvalidOperationException(\"Pattern match failure\");" + match returnBody with Some _ -> statements | None -> wrap (csType resultType) statements + let typeDeclarations = StringBuilder() + let addLine (value: string) = typeDeclarations.AppendLine(value) |> ignore + let emittedTypes = Collections.Generic.HashSet() + for t in types |> Seq.sort do + let name = csType t + if emittedTypes.Add name && not (nativeTypes |> Map.exists (fun _ native -> typeName native=name)) then + match resolve t with + | TTuple items -> + let args = items |> List.mapi (fun i t -> $"{csType t} Item{i}") |> String.concat comma + addLine $"public sealed record {name}({args});" + | TRecord fields -> + let args = fields |> Map.toList |> List.map (fun (field,t) -> $"{csType t} {fieldName t field}") |> String.concat comma + addLine $"public sealed record {name}({args});" + | TUnion(_,cases) when cases |> Map.forall (fun _ -> Option.isNone) -> + addLine $"public enum {name} {{ {cases |> Map.toList |> List.map (fst >> ident) |> String.concat comma} }}" + | TUnion(_,cases) -> + addLine $"public abstract record {name} {{" + for case,payload in cases |> Map.toList do + let arg = payload |> Option.map (fun t -> $"{csType t} Value") |> Option.defaultValue String.Empty + addLine $"public sealed record {ident case}({arg}) : {name};" + addLine "}" + | _ -> () + let helpers = StringBuilder() + let addHelper (value: string) = helpers.AppendLine(value) |> ignore + for t in types |> Seq.sort do + if not (NativeSpecialization.containsVariable t) then + let joinChecks values = if List.isEmpty values then "true" else String.concat " && " values + let equalBody,formatBody = + match resolve t with + | TUnit -> "true",quote "()" + | TInt -> "a == b","value.ToString(CultureInfo.InvariantCulture)" + | TFloat -> "a == b","FsRuntime.FloatText(value)" + | TBool -> "a == b","(value ? \"true\" : \"false\")" + | TString -> "a == b","FsRuntime.Quote(value)" + | TTypeToken -> (if assemblyMode then "a.Name == b.Name" else "a == b"),"\"\"" + | TFun _ -> "false",quote "" + | TTask _ -> "false",quote "" + | TList item -> $"a.Length == b.Length && a.Where((item,index) => !{eqName item}(item,b[index])).Any() == false",$"\"[\" + string.Join(\";\", value.Select(item => {fmtName item}(item))) + \"]\"" + | TOption item -> $"a.HasValue == b.HasValue && (!a.HasValue || {eqName item}(a.Value,b.Value))",$"(value.HasValue ? \"Some \" + {fmtName item}(value.Value) : \"None\")" + | TTuple items -> + items |> List.mapi (fun i t -> $"{eqName t}(a.Item{i},b.Item{i})") |> joinChecks, + "\"(\" + " + (items |> List.mapi (fun i t -> $"{fmtName t}(value.Item{i})") |> String.concat " + \", \" + ") + " + \")\"" + | TRecord fields | THostManaged(_,fields) -> + let checks = fields |> Map.toList |> List.map (fun (field,ft) -> $"{eqName ft}({readField t field aCode},{readField t field bCode})") |> joinChecks + let parts = fields |> Map.toList |> List.map (fun (field,ft) -> quote (field+" = ") + " + " + fmtName ft + "(" + readField t field "value" + ")") + checks, "\"{ \" + " + (if parts.IsEmpty then "\"\"" else String.concat " + \"; \" + " parts) + " + \" }\"" + | TMap(k,v) -> + $"a.Entries.Length == b.Entries.Length && !a.Entries.Where((e,i) => !{eqName k}(e.Key,b.Entries[i].Key) || !{eqName v}(e.Value,b.Entries[i].Value)).Any()", + $"\"map {{ \" + string.Join(\"; \",value.Entries.Select(e => {fmtName k}(e.Key) + \" => \" + {fmtName v}(e.Value))) + \" }}\"" + | TUnion(_,cases) when cases |> Map.forall (fun _ -> Option.isNone) -> + "a == b", "value switch { " + (cases |> Map.toList |> List.map (fun (case,_) -> $"{csType t}.{ident case} => {quote case}") |> String.concat comma) + ", _ => throw new InvalidOperationException() }" + | TUnion(_,cases) -> + let equal = cases |> Map.toList |> List.map (fun (case,payload) -> + let test = payload |> Option.map (fun p -> $"{eqName p}(x.Value,y.Value)") |> Option.defaultValue "true" + $"({csType t}.{ident case} x, {csType t}.{ident case} y) => {test}") |> String.concat comma + let format = cases |> Map.toList |> List.map (fun (case,payload) -> + let result = payload |> Option.map (fun p -> quote (case+" ") + " + " + fmtName p + "(item.Value)") |> Option.defaultValue (quote case) + $"{csType t}.{ident case} item => {result}") |> String.concat comma + $"(a,b) switch {{ {equal}, _ => false }}",$"value switch {{ {format}, _ => throw new InvalidOperationException() }}" + | value -> fail "FSC6004" $"Unsupported compiled value '{Types.typeToString value}'." None + addHelper $"private static bool {eqName t}({csType t} a, {csType t} b) => {equalBody};" + addHelper $"private static string {fmtName t}({csType t} value) => {formatBody};" + let interpolation = + match resolve t with + | TString -> "value" + | TMap(k,v) -> $"\"map {{ \" + string.Join(\"; \",value.Entries.Select(e => {fmtName k}(e.Key) + \" => \" + {interpName v}(e.Value))) + \" }}\"" + | _ -> Text.RegularExpressions.Regex.Replace(formatBody,@"\bFormat_([0-9a-f]{12})\(","Interpolate_$1(") + addHelper $"private static string {interpName t}({csType t} value) => {interpolation};" + for t in types |> Seq.sort do + if not (NativeSpecialization.containsVariable t) then + let unsupported="throw new InvalidOperationException(\"Unsupported JSON value\")" + let encode,decode = + match resolve t with + | TUnit -> quote "null","default(Unit)" + | TInt -> "value.ToString(CultureInfo.InvariantCulture)","value.GetInt64()" + | TFloat -> "value.ToString(CultureInfo.InvariantCulture)","value.GetDouble()" + | TBool -> "(value ? \"true\" : \"false\")","value.GetBoolean()" + | TString -> (if assemblyMode then "FsRuntime.JsonString(value)" else "JsonSerializer.Serialize(value)"),"value.GetString() ?? throw new InvalidOperationException()" + | TOption item -> + $"(value.HasValue ? {jsonEncodeName item}(value.Value) : \"null\")", + $"(value.ValueKind == JsonValueKind.Null ? default : {csType t}.Some({jsonDecodeName item}(value)))" + | TList item -> + $"\"[\" + string.Join(\",\",value.Select({jsonEncodeName item})) + \"]\"", + $"value.EnumerateArray().Select({jsonDecodeName item}).ToArray()" + | TTuple items -> + let encoded=items |> List.mapi (fun i t -> $"{jsonEncodeName t}(value.Item{i})") |> String.concat " + \",\" + " + let decoded=items |> List.mapi (fun i t -> $"{jsonDecodeName t}(value[{i}])") |> String.concat comma + $"\"[\" + {encoded} + \"]\"",$"(value.GetArrayLength()=={items.Length} ? new {csType t}({decoded}) : throw new InvalidOperationException())" + | TRecord fields | THostManaged(_,fields) -> + let encoded=fields |> Map.toList |> List.map (fun (name,ft) -> quote (quote name+":") + " + " + jsonEncodeName ft + "("+readField t name valueCode+")") |> String.concat " + \",\" + " + let decoded=fields |> Map.toList |> List.mapi (fun i (name,ft) -> + let missing=match ft with TOption _ -> "default" | _ -> "throw new InvalidOperationException()" + $"(value.TryGetProperty({quote name},out var field{i}) ? {jsonDecodeName ft}(field{i}) : {missing})") |> String.concat comma + let encode=if fields.IsEmpty then quote "{}" else $"\"{{\" + {encoded} + \"}}\"" + let decode=match resolve t with THostManaged _ -> unsupported | _ -> $"new {csType t}({decoded})" + encode,decode + | TMap(k,v) -> + let keyText,keyParse = + match resolve k with + | TString -> "e.Key","property.Name" + | TInt -> "e.Key.ToString(CultureInfo.InvariantCulture)","long.Parse(property.Name,CultureInfo.InvariantCulture)" + | TBool -> "(e.Key ? \"true\" : \"false\")","bool.Parse(property.Name)" + | _ -> unsupported,unsupported + if keyText=unsupported then unsupported,unsupported else + let quotedKey=if assemblyMode then $"FsRuntime.JsonString({keyText})" else $"JsonSerializer.Serialize({keyText})" + $"\"{{\" + string.Join(\",\",value.Entries.Select(e=>{quotedKey}+\":\"+{jsonEncodeName v}(e.Value))) + \"}}\"", + $"value.EnumerateObject().Aggregate(new {csType t}(),(map,property)=>map.Add({keyParse},{jsonDecodeName v}(property.Value)))" + | _ -> unsupported,unsupported + addHelper $"private static string {jsonEncodeName t}({csType t} value) => {encode};" + addHelper $"private static {csType t} {jsonDecodeName t}(JsonElement value) => {decode};" + if hasSdk then + let sv="global::FScript.Extensibility.ScriptValue" + let mapKey="global::FScript.Extensibility.MapKey" + let list values = "global::Microsoft.FSharp.Collections.ListModule.OfArray(new " + sv + "[] { " + String.concat comma values + " })" + let none="null" + let some value="SdkInterop.Some("+value+")" + let rec keyEncode t code = + match resolve t with + | TString -> $"{mapKey}.NewMKString({code})" | TInt -> $"{mapKey}.NewMKInt({code})" | TBool -> $"{mapKey}.NewMKBool({code})" + | TUnion(name,cases) -> + let names=cases |> Map.toList |> List.map (fun (case,_) -> $"{csType t}.{ident case} => {quote case}") |> String.concat comma + $"{mapKey}.NewMKUnionCase({quote name}, {code} switch {{ {names}, _ => throw new InvalidOperationException() }})" + | _ -> fail "FSC6008" "Unsupported SDK map key." None + let keyDecode t code = + match resolve t with + | TString -> $"(({mapKey}.MKString)({code})).Item" | TInt -> $"(({mapKey}.MKInt)({code})).Item" | TBool -> $"(({mapKey}.MKBool)({code})).Item" + | TUnion(_,cases) -> + let names=cases |> Map.toList |> List.map (fun (case,_) -> $"{quote case} => {csType t}.{ident case}") |> String.concat comma + $"(({mapKey}.MKUnionCase)({code})).Item2 switch {{ {names}, _ => throw new InvalidOperationException() }}" + | _ -> fail "FSC6008" "Unsupported SDK map key." None + for t in types |> Seq.sort do + if not (NativeSpecialization.containsVariable t) then + let encode,decode = + match resolve t with + | TUnit -> sv+".VUnit","default(Unit)" + | TInt -> sv+".NewVInt(value)",$"(({sv}.VInt)value).Item" + | TFloat -> sv+".NewVFloat(value)",$"(({sv}.VFloat)value).Item" + | TBool -> sv+".NewVBool(value)",$"(({sv}.VBool)value).Item" + | TString -> sv+".NewVString(value)",$"(({sv}.VString)value).Item" + | TList item -> + $"{sv}.NewVList(global::Microsoft.FSharp.Collections.ListModule.OfArray(value.Select({encName item}).ToArray()))", + $"(({sv}.VList)value).Item.Select({decName item}).ToArray()" + | TTuple items -> + let values=items |> List.mapi (fun i t -> $"{encName t}(value.Item{i})") + let decoded=items |> List.mapi (fun i t -> $"{decName t}((({sv}.VTuple)value).Item[{i}])") |> String.concat comma + $"{sv}.NewVTuple({list values})",$"new {csType t}({decoded})" + | TOption item -> + let encodedValue=some (encName item+"(value.Value)") + $"{sv}.NewVOption(value.HasValue ? {encodedValue} : null)", + wrap (csType t) $"var option = (({sv}.VOption)value).Item; return option is null ? default : {csType t}.Some({decName item}(option.Value));" + | TRecord fields -> + let values=fields |> Map.toList |> List.map (fun (name,ft) -> $"Tuple.Create({quote name}, {encName ft}({readField t name valueCode}))") |> String.concat comma + let decoded=fields |> Map.toList |> List.map (fun (name,ft) -> $"{decName ft}((({sv}.VRecord)value).Item[{quote name}])") |> String.concat comma + $"{sv}.NewVRecord(SdkInterop.Fields(new Tuple[] {{ {values} }}))",$"new {csType t}({decoded})" + | THostManaged(name,_) -> + if nativeTypes.ContainsKey name then fail "FSC6009" "A program cannot combine native and SDK projections of the same host-managed type." None + $"{sv}.NewVHostManaged(value)",$"((({sv}.VHostManaged)value).Item.Descriptor.Name == {quote name} ? (({sv}.VHostManaged)value).Item : throw new InvalidOperationException(\"Host type mismatch\"))" + | TFun(a,b) -> + $"SdkInterop.Callable(argument => {encName b}(value({decName a}(argument))))", + $"({csType a} argument) => {decName b}(SdkInterop.Apply(value, {encName a}(argument)))" + | TTask item -> + $"SdkInterop.TaskValue(Task.Run(async () => {encName item}(await value)))",$"Task.Run(() => {decName item}(SdkInterop.Await(value)))" + | TMap(k,v) -> + let encodedKey=keyEncode k "e.Key" + let decodedKey=keyDecode k "e.Key" + $"{sv}.NewVMap(global::Microsoft.FSharp.Collections.MapModule.OfSeq(value.Entries.Select(e => Tuple.Create({encodedKey},{encName v}(e.Value)))))", + $"new {csType t}((({sv}.VMap)value).Item.Select(e => new {csType t}.Entry({decodedKey},{decName v}(e.Value))).ToArray())" + | TUnion(name,cases) -> + let isEnum=cases |> Map.forall (fun _ -> Option.isNone) + let encoded=cases |> Map.toList |> List.map (fun (case,payload) -> + let pattern=if isEnum then $"{csType t}.{ident case}" else $"{csType t}.{ident case} item" + let payload=payload |> Option.map (fun t -> some (encName t+"(item.Value)")) |> Option.defaultValue none + $"{pattern} => {sv}.NewVUnionCase({quote name},{quote case},{payload})") |> String.concat comma + let decoded=cases |> Map.toList |> List.map (fun (case,payload) -> + let result=if isEnum then $"{csType t}.{ident case}" else + let arg=payload |> Option.map (fun t -> $"{decName t}(((({sv}.VUnionCase)value).Item3 ?? throw new InvalidOperationException()).Value)") |> Option.defaultValue String.Empty + $"new {csType t}.{ident case}({arg})" + $"{quote case} => {result}") |> String.concat comma + $"value switch {{ {encoded}, _ => throw new InvalidOperationException() }}", + $"(({sv}.VUnionCase)value).Item2 switch {{ {decoded}, _ => throw new InvalidOperationException() }}" + | TTypeToken -> + let names=types |> Seq.filter (NativeSpecialization.containsVariable >> not) |> Seq.distinctBy Types.typeToString |> Seq.map (fun t -> $"{quote (Types.typeToString t)} => {sdkType (resolve t)}") |> String.concat comma + $"{sv}.NewVTypeToken(value.Name switch {{ {names}, _ => throw new InvalidOperationException(\"Unknown type token\") }})",$"new TypeToken(global::FScript.Extensibility.Types.typeToString((({sv}.VTypeToken)value).Item))" + | _ -> fail "FSC6008" "Unresolved SDK transport type." None + addHelper $"private static {sv} {encName t}({csType t} value) => {encode};" + addHelper $"private static {csType t} {decName t}({sv} value) => {decode};" + let members = StringBuilder() + let addMember (value: string) = members.AppendLine(value) |> ignore + let nativeBody (fn: Lir.Function) (chain: Lir.Function list) = + let final=List.last chain + let mutable tailLoop=false + let rec emitReturn (value: Lir.Expression) = + let rec spine (node: Lir.Expression) = + match node.Node with + | Lir.CallClosure(callee,arg) | Lir.TailCallClosure(callee,arg) -> + let root,args,order=spine callee + let index=List.length args + root,args @ [index,arg],order @ [index,arg] + | Lir.PipeClosure(arg,callee) | Lir.TailPipeClosure(arg,callee) -> + let root,args,order=spine callee + let index=List.length args + root,args @ [index,arg],(index,arg)::order + | _ -> node,[],[] + let root,args,order=spine value + let rootNode=knownNode root + let self= + match rootNode with + | Lir.MakeClosure(id,captures) -> id=fn.Id && captures=fn.Captures && args.Length=List.length chain + | _ -> false + if self then + tailLoop <- true + let temps=args |> List.map (fun (index,_) -> index,fresh "tailNext") |> Map.ofList + let setup=order |> List.map (fun (index,arg) -> + let parameter=List.item index chain + $"{csType parameter.ParameterType} {temps.[index]}={coerce arg.Type parameter.ParameterType (expression arg)};") + let assign=chain |> List.mapi (fun index parameter -> $"{sym parameter.Parameter}={temps.[index]};") + String.concat space (setup @ assign @ ["continue;"]) + else + match value.Node with + | Lir.Let(id,_,false,binding,body) -> + let bindingCode=expression binding + let bodyCode=within [id] (fun () -> emitReturn body) + $"{{ {csType binding.Type} {sym id}={bindingCode}; {bodyCode} }}" + | Lir.Branch(condition,yes,no) -> $"if ({expression condition}) {{ {emitReturn yes} }} else {{ {emitReturn no} }}" + | Lir.DecisionTree(target,cases) -> decision target cases final.ReturnType (Some emitReturn) + | _ -> $"return {coerce value.Type final.ReturnType (expression value)};" + let body=emitReturn final.Body + if tailLoop then $"while (true) {{ {body} }}" else body + for declaration in program.Declarations do addMember $"private static {csType declaration.Type} {sym declaration.Id} = default!;" + for fn in program.Functions do + let captures = fn.Captures |> List.filter (fun id -> not (globalIds.Contains id)) |> List.map (fun id -> $"{csType symbolTypes.[id]} {sym id}") + let parameters = String.concat comma (captures @ [$"{csType fn.ParameterType} {sym fn.Parameter}"]) + let body=within (fn.Parameter::fn.Captures) (fun () -> coerce fn.Body.Type fn.ReturnType (expression fn.Body)) + addMember $"private static {csType fn.ReturnType} {funName fn.Id}({parameters}) {{ return {body}; }}" + if assemblyMode then + let chain=functionChain Set.empty fn.Id + let last=List.last chain + let parameters=String.concat comma (captures @ (chain |> List.map (fun parameter -> $"{csType parameter.ParameterType} {sym parameter.Parameter}"))) + let body=within (fn.Captures @ (chain |> List.map _.Parameter)) (fun () -> nativeBody fn chain) + addMember $"private static {csType last.ReturnType} Native{funName fn.Id}({parameters}) {{ {body} }}" + let needsInitialization=not assemblyMode || not program.Declarations.IsEmpty + let forceInitialization=if needsInitialization then "_ = Initialization.Value;" else "" + if needsInitialization then + addMember "private static readonly Lazy Initialization = new(Initialize);" + addMember "private static Unit Initialize() {" + for declaration in program.Declarations do addMember $"{sym declaration.Id} = {coerce declaration.Value.Type declaration.Type (expression declaration.Value)};" + addMember "return default; }" + for declaration in program.Declarations |> List.filter _.IsExported do + addMember $"public static {csType declaration.Type} {ident declaration.Name} {{ get {{ {forceInitialization} return {sym declaration.Id}; }} }}" + let resultType = program.Entry |> Option.map _.Type |> Option.defaultValue TUnit + let result = program.Entry |> Option.map expression |> Option.defaultValue "default(Unit)" + addType resultType + addMember $"public static {csType resultType} Run() {{ {forceInitialization} return {result}; }}" + addMember $"public static string FormatResult({csType resultType} value) => {fmtName resultType}(value);" + addMember "private static int ProcessExitCode = 0;" + addMember "public static int ExitCode => System.Threading.Volatile.Read(ref ProcessExitCode);" + addMember "private static Unit SetExitCode(long code) { if (code < 0 || code > 255) return FsRuntime.Fail(\"Env.setExitCode expects a code between 0 and 255.\"); System.Threading.Interlocked.Exchange(ref ProcessExitCode, (int)code); return default; }" + let display=if printResult then "Console.WriteLine(FormatResult(Run()));" else "_ = Run();" + addMember $"public static int Main(string[] args) {{ {display} return ExitCode; }}" + if hasSdk then + let sdk="global::FScript.Extensibility." + let sv=sdk+"ScriptValue" + let ctx=sdk+"ExternalCallContext" + let fnType=sdk+"ExternalFunction" + let listType= $"global::Microsoft.FSharp.Collections.FSharpList<{sv}>" + let wrappers=CompilerExternCatalog.defaults |> List.filter (fun fn -> fn.Name<>"Env") |> List.map (fun fn -> + let (Forall(variables,t))=fn.Scheme + let variables=variables |> List.map string |> String.concat comma + let scheme= $"{sdk}FunctionScheme.NewForall(global::Microsoft.FSharp.Collections.ListModule.OfArray(new int[] {{ {variables} }}),{sdkType t})" + let invoke= $"global::Microsoft.FSharp.Core.FuncConvert.FromFunc<{ctx},global::Microsoft.FSharp.Core.FSharpFunc<{listType},{sv}>>(ctx => global::Microsoft.FSharp.Core.FuncConvert.FromFunc<{listType},{sv}>(args => SdkInterop.Default({quote fn.Name},ctx,args.ToArray())))" + $"new {fnType}({quote fn.Name},{scheme},{invoke},{fn.Arity})") |> String.concat comma + addMember $"private static global::Microsoft.FSharp.Collections.FSharpList<{fnType}> ProviderDefaults() => global::Microsoft.FSharp.Collections.ListModule.OfArray(new {fnType}[] {{ {wrappers} }});" + for KeyValue(path,name) in sdkProviders do + let link=ClrBindings.tryMethodLink ("clr:"+path.Substring(8)) |> Option.get + let declaring=System.Type.GetType(link.DeclaringType,true) |> nonNull + let sdk="global::FScript.Extensibility." + let sdkExternalFunction=sdk+"ExternalFunction" + let sdkHostType=sdk+"HostTypeDescriptor" + let sdkHostUnion=sdk+"HostUnionDescriptor" + let empty element = $"global::Microsoft.FSharp.Collections.ListModule.Empty<{element}>()" + let arguments=if link.Parameters.Length=0 then "" else $"new {sdk}HostContext(Directory.GetCurrentDirectory(), {empty stringCode}, ProviderDefaults())" + let call= $"{typeName declaring}.@{link.MemberName}({arguments})" + let method=declaring.GetMethods(BindingFlags.Public ||| BindingFlags.Static) |> Array.find (fun m -> m.Name=link.MemberName && m.GetParameters().Length=link.Parameters.Length) + let call=if method.ReturnType.FullName="FScript.Extensibility.ExtensionRegistration" then call else $"new {sdk}ExtensionRegistration({empty sdkHostType},{empty sdkHostUnion},{call})" + addMember $"private static readonly Lazy<{sdk}ExtensionRegistration> {name} = new(() => {call});" + let header = "#nullable enable\nusing System;\nusing System.IO;\nusing System.Linq;\nusing System.Globalization;\nusing System.Text.Json;\nusing System.Threading.Tasks;\n" + let source = $"{header}\nnamespace {options.Namespace};\n{typeDeclarations}\npublic static class {options.ClassName} {{\n{helpers}\n{members}\n}}\n" + use stream = typeof.Assembly.GetManifestResourceStream("FScript.Backend.CSharp.Runtime.cs") |> nonNull + use reader = new StreamReader(stream) + let runtime = reader.ReadToEnd().Replace("__NAMESPACE__",options.Namespace) + let escapeXml (value: string) = System.Security.SecurityElement.Escape(value) |> nonNull + let references = options.References |> List.distinct |> List.map (fun path -> $" nonNull)}\">{escapeXml (Path.GetFullPath path)}true") |> String.concat "\n" + let compileItems = "" + (if hasSdk then "" else "") + let project = $"Exenet10.0enabletruefalse{compileItems}{references}\n" + [ yield { RelativePath = "Program.cs"; Content = source }; yield { RelativePath = "Runtime.cs"; Content = runtime }; yield { RelativePath = "Program.csproj"; Content = project } + if hasSdk then + use sdkStream=typeof.Assembly.GetManifestResourceStream("FScript.Backend.CSharp.RuntimeSDK.cs") |> nonNull + use sdkReader=new StreamReader(sdkStream) + yield {RelativePath="RuntimeSDK.cs"; Content=sdkReader.ReadToEnd().Replace("__NAMESPACE__",options.Namespace)} ] + + let private specializeAssembly (program: Lir.Program) = + let exports=program.Declarations |> List.filter _.IsExported + match exports with + | [] -> LirMonomorphization.specialize program + | first::_ -> + for declaration in exports do + if NativeSpecialization.containsVariable declaration.Type then + fail "FSC6009" $"Export '{declaration.Name}' requires a concrete native type." (Some declaration.Span) + // Analysis roots only: discard the synthetic tuple immediately after specialization. + let entry=program.Entry |> Option.defaultValue {Type=TUnit;Span=first.Span;Node=Lir.Constant Lir.Unit} + let roots=entry :: (exports |> List.map (fun declaration -> {Type=declaration.Type;Span=declaration.Span;Node=Lir.Load declaration.Id})) + let rooted={program with Entry=Some {Type=TTuple(List.map (fun (root: Lir.Expression) -> root.Type) roots);Span=entry.Span;Node=Lir.Tuple roots}} + LirMonomorphization.specialize rooted |> Result.map (fun specialized -> + let entry=match specialized.Entry with Some {Node=Lir.Tuple(first::_)} when program.Entry.IsSome -> Some first | _ -> None + {specialized with Entry=entry}) + + let private generateWith assemblyMode printResult optimize options (program: Lir.Program) = + try + for path in options.References do + if not (File.Exists path) then fail "FSC6003" $"Reference assembly does not exist: {path}" None + let options={options with References=ClrBindings.referenceClosure options.References} + let validIdentifier (value: string) = not (String.IsNullOrWhiteSpace value) && SyntaxFacts.IsValidIdentifier(value) && SyntaxFacts.GetKeywordKind(value)=SyntaxKind.None + if not (validIdentifier options.ClassName && options.Namespace.Split('.') |> Array.forall validIdentifier) then fail "FSC6001" "Namespace and class names must be valid C# identifiers." None + for path in options.References do + if not (File.Exists path) then fail "FSC6003" $"Reference assembly does not exist: {path}" None + Reflection.Assembly.LoadFrom(Path.GetFullPath path) |> ignore + program |> LirValidation.validate + |> Result.map (if printResult then id else LirResultPolicy.discard) + |> Result.bind (if assemblyMode then specializeAssembly else LirMonomorphization.specialize) + |> Result.map LirSimplification.optimize + |> Result.map optimize + |> Result.map LirCommonSubexpressions.optimize + |> Result.map (if assemblyMode then ClrBindings.pruneUnusedTypes else id) + |> Result.bind LirValidation.validate + |> Result.map (emit assemblyMode printResult options) + |> Result.map (List.map (fun file -> + if not (file.RelativePath.EndsWith(".cs",StringComparison.Ordinal)) then file else + let tree=CSharpSyntaxTree.ParseText(file.Content,CSharpParseOptions(LanguageVersion.Latest)) + let errors=tree.GetDiagnostics() |> Seq.filter (fun diagnostic -> diagnostic.Severity=DiagnosticSeverity.Error) |> Seq.map string |> Seq.toList + if not errors.IsEmpty then fail "FSC6008" (String.concat "\n" errors) None + {file with Content=tree.GetRoot().NormalizeWhitespace(" ","\n",false).ToFullString()+"\n"})) + |> Result.mapError (List.map (fun d -> if d.Code.StartsWith("FSL21",StringComparison.Ordinal) then { d with Stage=CSharpGeneration; Code=d.Code.Replace("FSL21","FSC60") } else d)) + with + | Failure diagnostic -> Error [diagnostic] + | ex -> Error [{ Code="FSC6000"; Stage=CSharpGeneration; Message=ex.Message; Span=None }] + + let generateWithResultOutput printResult options program = generateWith false printResult id options program + let generate options program = generateWithResultOutput true options program + + let internal generateForAssembly printResult optimize options program = generateWith true printResult optimize options program diff --git a/src/FScript.Backend.CSharp/FScript.Backend.CSharp.fsproj b/src/FScript.Backend.CSharp/FScript.Backend.CSharp.fsproj new file mode 100644 index 0000000..4eb8ae5 --- /dev/null +++ b/src/FScript.Backend.CSharp/FScript.Backend.CSharp.fsproj @@ -0,0 +1,14 @@ + + net10.0false + + + + + + + + + $(MSBuildToolsPath)/Roslyn/bincore/Microsoft.CodeAnalysis.dlltrue + $(MSBuildToolsPath)/Roslyn/bincore/Microsoft.CodeAnalysis.CSharp.dlltrue + + diff --git a/src/FScript.Backend.CSharp/Runtime.cs b/src/FScript.Backend.CSharp/Runtime.cs new file mode 100644 index 0000000..804e500 --- /dev/null +++ b/src/FScript.Backend.CSharp/Runtime.cs @@ -0,0 +1,135 @@ +// Generated FScript support code. Uses only the .NET base class libraries. +using System; +using System.IO; +using System.Linq; +using System.Globalization; +using System.Collections.Generic; +using System.Text.Json; +using System.Threading.Tasks; + +namespace __NAMESPACE__; + +public readonly record struct Unit; +public readonly record struct TypeToken(string Name); +public readonly record struct Option(bool HasValue, T Value) +{ + public static Option None => default; + public static Option Some(T value) => new(true, value); +} +public sealed class OrderedMap +{ + public readonly record struct Entry(K Key, V Value); + public Entry[] Entries { get; } + public OrderedMap() : this(Array.Empty()) { } + public OrderedMap(Entry[] entries) { Entries = entries; } + public Option Find(K key) + { + foreach (var entry in Entries) + if (EqualityComparer.Default.Equals(entry.Key, key)) return Option.Some(entry.Value); + return default; + } + public OrderedMap Add(K key, V value) + { + var entries = Entries.Where(e => !EqualityComparer.Default.Equals(e.Key, key)) + .Append(new Entry(key,value)).OrderBy(e => e.Key, Comparer.Default).ToArray(); + return new(entries); + } + public OrderedMap Remove(K key) => new(Entries.Where(e => !EqualityComparer.Default.Equals(e.Key,key)).ToArray()); +} +internal static class FsRuntime +{ + public static string JsonString(string value) => "\"" + JsonEncodedText.Encode(value).ToString() + "\""; + public static string Quote(string value) => "\"" + value.Replace("\\","\\\\").Replace("\"","\\\"").Replace("\r","\\r").Replace("\n","\\n").Replace("\t","\\t") + "\""; + public static T Fail(string message) => throw new InvalidOperationException(message); + public static Unit WriteLine(string value) { Console.WriteLine(value); return default; } + public static Option ReadLine(Unit _) { var text = Console.ReadLine(); return text is null ? default : Option.Some(text); } + public static Option Try(Func action) { try { return Option.Some(action()); } catch { return default; } } + public static bool TryEffect(Action action) { try { action(); return true; } catch { return false; } } + public static long[] Range(long first, long last) + { + var result = new List(); + if (first <= last) { for (long value = first;; value++) { result.Add(value); if (value == last) break; } } + else { for (long value = first;; value--) { result.Add(value); if (value == last) break; } } + return result.ToArray(); + } + public static Option At(long index, T[] values) => index >= 0 && index < values.LongLength ? Option.Some(values[index]) : default; + public static Unit Iter(Func fn, T[] values) { foreach(var value in values) fn(value); return default; } + public static S Fold(Func> fn, S state, T[] values) { foreach(var value in values) state = fn(state)(value); return state; } + public static T[] Distinct(T[] values, Func equal) + { + var result = new List(); + foreach(var value in values) if (!result.Any(item => equal(item,value))) result.Add(value); + return result.ToArray(); + } + public static Option Find(Func fn, T[] values) + { + foreach(var value in values) if(fn(value)) return Option.Some(value); + return default; + } + public static Option FindIndex(Func fn, T[] values) + { + for(int i=0;i.Some(i); + return default; + } + public static Option ParseInt(string value) => long.TryParse(value, NumberStyles.Integer, CultureInfo.InvariantCulture, out var result) ? Option.Some(result) : default; + public static Option ParseFloat(string value) => double.TryParse(value, NumberStyles.Float, CultureInfo.InvariantCulture, out var result) ? Option.Some(result) : default; + public static Option ParseBool(string value) => bool.TryParse(value, out var result) ? Option.Some(result) : default; + public static string Replace(string oldValue, string newValue, string source) => oldValue.Length == 0 ? source : source.Replace(oldValue, newValue, StringComparison.Ordinal); + public static Option IndexOf(string needle, string haystack) { long index = haystack.IndexOf(needle, StringComparison.Ordinal); return index < 0 ? default : Option.Some(index); } + public static Option Substring(long start, long length, string value) => start < 0 || length < 0 || start > value.Length || length > value.Length-start ? default : Option.Some(value.Substring((int)start,(int)length)); + public static S MapFold(Func>> fn, S state, OrderedMap values) { foreach(var e in values.Entries) state=fn(state)(e.Key)(e.Value); return state; } + public static Unit MapIter(Func> fn, OrderedMap values) { foreach(var e in values.Entries) fn(e.Key)(e.Value); return default; } + public static OrderedMap MapOfArray((K,V)[] values) { var result=new OrderedMap(); foreach(var e in values) result=result.Add(e.Item1,e.Item2); return result; } + public static Option MatchGroups(string pattern, string value) + { + try { var match=System.Text.RegularExpressions.Regex.Match(value,pattern); return match.Success ? Option.Some(match.Groups.Cast().Skip(1).Select(g=>g.Value).ToArray()) : default; } catch { return default; } + } + public static Option QueryXml(string query, string text) => Try(() => + { + query=query.Trim(); + bool descendants=query.StartsWith("//",StringComparison.Ordinal); + string body=descendants ? query[2..] : query; + int slash=body.LastIndexOf('/'); + if(slash<=0 || slash==body.Length-1) throw new InvalidOperationException("Invalid XML query."); + string selector=body[(slash+1)..]; + bool Valid(string name)=>!string.IsNullOrWhiteSpace(name) && !name.Contains(':') && name!="." && name!=".." && name!="*"; + bool attribute=selector.StartsWith('@'); + if(attribute ? !Valid(selector[1..]) : selector!="text()") throw new InvalidOperationException("Invalid XML selector."); + string[] steps=body[..slash].Split('/',StringSplitOptions.RemoveEmptyEntries); + if(steps.Length==0 || steps.Any(step=>!Valid(step))) throw new InvalidOperationException("Invalid XML path."); + var root=System.Xml.Linq.XDocument.Parse(text).Root; + if(root is null) return Array.Empty(); + var elements=descendants ? root.DescendantsAndSelf(System.Xml.Linq.XName.Get(steps[0])) : root.Name.LocalName==steps[0] ? new[]{root} : root.Elements(System.Xml.Linq.XName.Get(steps[0])); + foreach(string step in steps.Skip(1)) elements=elements.SelectMany(element=>element.Elements(System.Xml.Linq.XName.Get(step))); + return attribute ? elements.Select(element=>element.Attribute(System.Xml.Linq.XName.Get(selector[1..]))).Where(value=>value is not null).Select(value=>value!.Value).ToArray() : elements.Select(element=>element.Value.Trim()).Where(value=>value.Length!=0).ToArray(); + }); + public static Option ParseJson(string text, Func decode) => Try(() => { using var document=JsonDocument.Parse(text); return decode(document.RootElement); }); + public static Option Files(string directory, string glob, bool recursive) => Try(() => + { + directory=Path.GetFullPath(directory); + var escaped=System.Text.RegularExpressions.Regex.Escape(glob.Replace('\\','/')); + var pattern=escaped.Replace("\\*\\*/","___DOUBLESTAR_SLASH___").Replace("\\*\\*","___DOUBLESTAR___").Replace("\\*","[^/]*").Replace("___DOUBLESTAR_SLASH___","(?:.*/)?").Replace("___DOUBLESTAR___",".*").Replace("\\?","."); + var regex=new System.Text.RegularExpressions.Regex("^"+pattern+"$"); + bool descend=recursive || glob.Contains('/') || glob.Contains('\\'); + IEnumerable Walk(string parent) + { + string[] files; + string[] children; + try { files=Directory.GetFiles(parent); children=descend ? Directory.GetDirectories(parent) : Array.Empty(); } + catch { yield break; } + foreach(string path in files) yield return path; + foreach(string child in children) + if((File.GetAttributes(child) & FileAttributes.ReparsePoint)==0) + foreach(string path in Walk(child)) yield return path; + } + if(!Directory.Exists(directory)) throw new DirectoryNotFoundException(directory); + return Walk(directory).Where(path=>regex.IsMatch(Path.GetRelativePath(directory,path).Replace('\\','/'))).Select(path=>Path.GetRelativePath(Directory.GetCurrentDirectory(),path).Replace('\\','/')).ToArray(); + }); + public static string FloatText(double value) + { + if(double.IsNaN(value)) return "nan"; + if(double.IsPositiveInfinity(value)) return "infinity"; + if(double.IsNegativeInfinity(value)) return "-infinity"; + return value.ToString("G",CultureInfo.InvariantCulture); + } +} diff --git a/src/FScript.Backend.CSharp/RuntimeSDK.cs b/src/FScript.Backend.CSharp/RuntimeSDK.cs new file mode 100644 index 0000000..3b8ace5 --- /dev/null +++ b/src/FScript.Backend.CSharp/RuntimeSDK.cs @@ -0,0 +1,106 @@ +// SDK value transport at compiled FFI boundaries; no interpreter or script host. +using System; +using System.Linq; +using System.Threading.Tasks; +using System.IO; +using System.Text; +using System.Text.Json; +using System.Globalization; +using Microsoft.FSharp.Core; +using Microsoft.FSharp.Collections; +using FScript.Extensibility; +using SV = FScript.Extensibility.ScriptValue; +using ST = FScript.Extensibility.ScriptType; + +namespace __NAMESPACE__; + +internal static class SdkInterop +{ + private sealed class Callback(Func callback) : ICallableHandle { public SV Apply(SV argument) => callback(argument); } + private sealed class Pending(Task task) : ITaskHandle { public Task Value => task; } + public static SV Callable(Func fn) => SV.NewVCallable(new Callback(fn)); + public static SV TaskValue(Task task) => SV.NewVTask(new Pending(task)); + public static SV Apply(SV fn, SV argument) => fn is SV.VCallable callable && callable.Item is Callback callback ? callback.Apply(argument) : throw new ExtensionException("Foreign callable does not belong to this compiled program."); + public static SV Await(SV value) => value is SV.VTask pending && pending.Item is Pending task ? task.Value.GetAwaiter().GetResult() : throw new ExtensionException("Foreign task does not belong to this compiled program."); + private static readonly ExternalCallContext Context = new( + FuncConvert.FromFunc>(fn => FuncConvert.FromFunc(argument => Apply(fn,argument))), + FuncConvert.FromFunc(fn => TaskValue(Task.Run(() => Apply(fn,SV.VUnit)))), + FuncConvert.FromFunc(value => Await(value)), + FuncConvert.FromAction(() => { })); + public static SV Invoke(ExternalFunction fn, SV[] arguments) => fn.Impl.Invoke(Context).Invoke(ListModule.OfArray(arguments)); + public static ExternalFunction Find(ExtensionRegistration registration, string name) => registration.Functions.First(fn => fn.Name == name); + public static FSharpOption Some(SV value) => FSharpOption.Some(value); + public static FSharpMap Fields(Tuple[] values) => MapModule.OfSeq(values); + private static SV Optional(Func action) { try { return SV.NewVOption(Some(action())); } catch { return SV.NewVOption(null); } } + private static string Text(SV value) => ((SV.VString)value).Item; + private static SV Strings(string[] values) => SV.NewVList(ListModule.OfArray(values.Select(SV.NewVString).ToArray())); + public static SV Default(string name, ExternalCallContext context, SV[] args) + { + switch(name) + { + case "Console.writeLine": Console.WriteLine(Text(args[0])); return SV.VUnit; + case "Console.readLine": var line=Console.ReadLine(); return SV.NewVOption(line is null ? null : Some(SV.NewVString(line))); + case "Fs.readText": return Optional(() => SV.NewVString(File.ReadAllText(Text(args[0])))); + case "Fs.exists": return SV.NewVBool(File.Exists(Text(args[0])) || Directory.Exists(Text(args[0]))); + case "Fs.createDirectory": return SV.NewVBool(FsRuntime.TryEffect(() => Directory.CreateDirectory(Text(args[0])))); + case "Fs.writeText": return SV.NewVBool(FsRuntime.TryEffect(() => File.WriteAllText(Text(args[0]),Text(args[1])))); + case "Fs.combinePath": return SV.NewVString(Path.Combine(Text(args[0]),Text(args[1]))); + case "Fs.parentDirectory": var parent=Path.GetDirectoryName(Text(args[0])); return SV.NewVOption(string.IsNullOrEmpty(parent) ? null : Some(SV.NewVString(parent))); + case "Fs.extension": var extension=Path.GetExtension(Text(args[0])); return SV.NewVOption(string.IsNullOrEmpty(extension) ? null : Some(SV.NewVString(extension))); + case "Fs.fileNameWithoutExtension": return SV.NewVString(Path.GetFileNameWithoutExtension(Text(args[0]))); + case "Fs.glob": var files=FsRuntime.Files(Directory.GetCurrentDirectory(),Text(args[0]),true); return SV.NewVOption(files.HasValue ? Some(Strings(files.Value)) : null); + case "Fs.enumerateFiles": var entries=FsRuntime.Files(Text(args[0]),Text(args[1]),false); return SV.NewVOption(entries.HasValue ? Some(Strings(entries.Value)) : null); + case "Fs.kind": + var path=Text(args[0]); var kind=File.Exists(path) ? "File" : Directory.Exists(path) ? "Directory" : "Missing"; + return SV.NewVUnionCase("FsKind",kind,kind == "Missing" ? null : Some(SV.NewVString(Path.GetRelativePath(Directory.GetCurrentDirectory(),Path.GetFullPath(path)).Replace('\\','/')))); + case "Regex.matchGroups": var groups=FsRuntime.MatchGroups(Text(args[0]),Text(args[1])); return SV.NewVOption(groups.HasValue ? Some(Strings(groups.Value)) : null); + case "Guid.new": return SV.NewVOption(Some(SV.NewVString(Guid.NewGuid().ToString()))); + case "Hash.md5": return Optional(() => SV.NewVString(Convert.ToHexString(System.Security.Cryptography.MD5.HashData(Encoding.UTF8.GetBytes(Text(args[0])))).ToLowerInvariant())); + case "Json.serialize": return Optional(() => SV.NewVString(EncodeJson(args[0]))); + case "Json.deserialize": return Optional(() => { using var document=JsonDocument.Parse(Text(args[1])); return DecodeJson(((SV.VTypeToken)args[0]).Item,document.RootElement); }); + case "Xml.queryValues": var values=FsRuntime.QueryXml(Text(args[0]),Text(args[1])); return SV.NewVOption(values.HasValue ? Some(Strings(values.Value)) : null); + case "Task.spawn": return context.SpawnTask.Invoke(args[0]); + case "Task.await": return context.AwaitTask.Invoke(args[0]); + default: throw new ExtensionException("Unknown compiled default function: " + name); + } + } + private static string EncodeJson(SV value) => value switch + { + SV.VInt item => item.Item.ToString(CultureInfo.InvariantCulture), + SV.VFloat item => item.Item.ToString(CultureInfo.InvariantCulture), + SV.VBool item => item.Item ? "true" : "false", + SV.VString item => JsonSerializer.Serialize(item.Item), + SV.VList item => "["+string.Join(",",item.Item.Select(EncodeJson))+"]", + SV.VTuple item => "["+string.Join(",",item.Item.Select(EncodeJson))+"]", + SV.VRecord item => "{"+string.Join(",",item.Item.Select(field=>JsonSerializer.Serialize(field.Key)+":"+EncodeJson(field.Value)))+"}", + SV.VHostManaged item => "{"+string.Join(",",item.Item.Fields.Select(field=>JsonSerializer.Serialize(field.Key)+":"+EncodeJson(field.Value)))+"}", + SV.VMap item => "{"+string.Join(",",item.Item.Select(field=>JsonSerializer.Serialize(JsonKey(field.Key))+":"+EncodeJson(field.Value)))+"}", + SV.VOption item => item.Item is { } some ? EncodeJson(some.Value) : "null", + _ when value.IsVUnit => "null", + _ => throw new ExtensionException("Value cannot be serialized as JSON.") + }; + private static string JsonKey(MapKey value) => value switch { MapKey.MKString s=>s.Item, MapKey.MKInt n=>n.Item.ToString(CultureInfo.InvariantCulture), MapKey.MKBool b=>b.Item ? "true" : "false", _=>throw new ExtensionException("Union keys cannot be JSON properties.") }; + private static SV DecodeJson(ST type, JsonElement value) + { + if(type.IsTUnit) return SV.VUnit; + if(type.IsTString) return SV.NewVString(value.GetString() ?? throw new ExtensionException("Expected string.")); + if(type.IsTInt) return SV.NewVInt(value.GetInt64()); + if(type.IsTFloat) return SV.NewVFloat(value.GetDouble()); + if(type.IsTBool) return SV.NewVBool(value.GetBoolean()); + if(type is ST.TList list) return SV.NewVList(ListModule.OfArray(value.EnumerateArray().Select(item=>DecodeJson(list.Item,item)).ToArray())); + if(type is ST.TOption option) return SV.NewVOption(value.ValueKind==JsonValueKind.Null ? null : Some(DecodeJson(option.Item,value))); + if(type is ST.TTuple tuple) + { + var items=value.EnumerateArray().ToArray(); + if(items.Length != tuple.Item.Length) throw new ExtensionException("Tuple arity mismatch."); + return SV.NewVTuple(ListModule.OfArray(tuple.Item.Select((t,index)=>DecodeJson(t,items[index])).ToArray())); + } + if(type is ST.TRecord record) return SV.NewVRecord(Fields(record.Item.Select(field=>Tuple.Create(field.Key,value.TryGetProperty(field.Key,out var property) ? DecodeJson(field.Value,property) : field.Value is ST.TOption ? SV.NewVOption(null) : throw new ExtensionException("Missing JSON field."))).ToArray())); + if(type is ST.TMap map) + { + MapKey Key(string text) => map.Item1.IsTString ? MapKey.NewMKString(text) : map.Item1.IsTInt ? MapKey.NewMKInt(long.Parse(text,CultureInfo.InvariantCulture)) : map.Item1.IsTBool ? MapKey.NewMKBool(bool.Parse(text)) : throw new ExtensionException("Unsupported JSON map key."); + return SV.NewVMap(MapModule.OfSeq(value.EnumerateObject().Select(property=>Tuple.Create(Key(property.Name),DecodeJson(map.Item2,property.Value))))); + } + throw new ExtensionException("Unsupported JSON type."); + } +} diff --git a/src/FScript.Backend.DotNet/DotNetBackend.fs b/src/FScript.Backend.DotNet/DotNetBackend.fs new file mode 100644 index 0000000..7cf9ed6 --- /dev/null +++ b/src/FScript.Backend.DotNet/DotNetBackend.fs @@ -0,0 +1,81 @@ +namespace FScript.Compiler + +open System +open System.IO +open System.Text +open System.Reflection.PortableExecutable +open Microsoft.CodeAnalysis +open Microsoft.CodeAnalysis.CSharp + +/// Produces PE assemblies from compiled LIR. Generated binaries contain no FScript interpreter. +module DotNetBackend = + let private diagnostic code message = + { Code=code; Stage=DotNetGeneration; Message=message; Span=None } + + let generateWithResultOutput printResult (options: DotNetOptions) (program: Lir.Program) = + try + let referencesExist = options.References |> List.forall File.Exists + if not referencesExist then + invalidArg "References" "One or more reference assemblies do not exist." + let options={options with References=ClrBindings.referenceClosure options.References} + if String.IsNullOrWhiteSpace options.AssemblyName || options.AssemblyName.IndexOfAny(Path.GetInvalidFileNameChars()) >= 0 || options.AssemblyName.Contains('/') || options.AssemblyName.Contains('\\') then + Error [diagnostic "FSN7001" "AssemblyName must be a nonempty file name without path separators."] + else + let csharpOptions: CSharpOptions = { Namespace=options.Namespace; ClassName=options.ClassName; References=options.References } + match CSharpBackend.generateForAssembly printResult DotNetOptimization.optimize csharpOptions program with + | Error diagnostics -> Error diagnostics + | Ok files -> + let trees = files |> List.filter (fun f -> f.RelativePath.EndsWith(".cs",StringComparison.Ordinal)) |> List.map (fun f -> + CSharpSyntaxTree.ParseText(f.Content, CSharpParseOptions(LanguageVersion.Latest), f.RelativePath, Encoding.UTF8)) + let platformReferences = + match AppContext.GetData("TRUSTED_PLATFORM_ASSEMBLIES") with + | :? string as paths -> paths.Split(Path.PathSeparator) |> Array.toList + | _ -> [typeof.Assembly.Location; typeof.Assembly.Location] + let references = + platformReferences @ [typeof.Assembly.Location] @ options.References + |> List.distinct |> List.sort + |> List.map (fun path -> MetadataReference.CreateFromFile(Path.GetFullPath path) :> MetadataReference) + let kind = match options.OutputKind with Library -> OutputKind.DynamicallyLinkedLibrary | ConsoleApplication -> OutputKind.ConsoleApplication + let compilationOptions = CSharpCompilationOptions(kind, optimizationLevel=OptimizationLevel.Release, allowUnsafe=false, deterministic=true, nullableContextOptions=NullableContextOptions.Enable) + let compilation = + CSharpCompilation.Create(options.AssemblyName, trees, references, compilationOptions) + |> DotNetSourceOptimization.optimize options.ClassName (options.OutputKind=Library) + use output = new MemoryStream() + let result = compilation.Emit(output) + let diagnostics = result.Diagnostics |> Seq.filter (fun d -> d.Severity=DiagnosticSeverity.Error || d.Severity=DiagnosticSeverity.Warning) |> Seq.map (fun d -> diagnostic "FSN7002" (d.ToString())) |> Seq.toList + if not result.Success || not diagnostics.IsEmpty then Error diagnostics + else + let binary = { RelativePath=options.AssemblyName+".dll"; Content=output.ToArray() } + let runtimeConfig = + "{\"runtimeOptions\":{\"tfm\":\"net10.0\",\"framework\":{\"name\":\"Microsoft.NETCore.App\",\"version\":\"10.0.0\"},\"rollForward\":\"LatestMinor\"}}\n" + let dependencies = + ClrBindings.referencedDependencies binary.Content options.References + |> List.filter (fun path -> Path.GetFileNameWithoutExtension path <> options.AssemblyName) + |> List.map (fun path -> + let name=Reflection.AssemblyName.GetAssemblyName(path).Name |> nonNull + { RelativePath=name+".dll"; Content=File.ReadAllBytes path }) + let files = binary :: dependencies + if options.OutputKind=ConsoleApplication then + Ok(files @ [{ RelativePath=options.AssemblyName+".runtimeconfig.json"; Content=Encoding.UTF8.GetBytes(runtimeConfig) }]) + else Ok files + with ex -> Error [diagnostic "FSN7000" ex.Message] + + let generate options program = generateWithResultOutput true options program + + /// Produce one self-contained executable for an explicit .NET runtime identifier. + let generateExecutableWithResultOutput printResult executable options program = + DotNetPackaging.validate executable options.OutputKind + |> Result.bind (fun () -> generateWithResultOutput printResult options program) + |> Result.bind (fun files -> + let assembly=files |> List.find (fun file -> file.RelativePath=options.AssemblyName+".dll") + use stream=new MemoryStream(assembly.Content,false) + use pe=new PEReader(stream) + let metadata=System.Reflection.Metadata.PEReaderExtensions.GetMetadataReader(pe) + let legacyBridge=metadata.TypeDefinitions |> Seq.exists (fun handle -> + let typ=metadata.GetTypeDefinition(handle) + metadata.GetString(typ.Name)="SdkInterop" && metadata.GetString(typ.Namespace)=options.Namespace) + if executable.AheadOfTime && legacyBridge then + Error [diagnostic "FSN7105" "Native AOT requires static compiled FFI bindings. Add FScriptCompiledFunctions/FScriptCompiledTypes companions or bind exact CLR methods/types with ClrBindings; provider-factory SDK dispatch cannot be safely pruned. Managed single-file output still supports legacy providers."] + else DotNetPackaging.publish executable (not legacyBridge) options files) + + let generateExecutable executable options program = generateExecutableWithResultOutput true executable options program diff --git a/src/FScript.Backend.DotNet/DotNetOptimization.fs b/src/FScript.Backend.DotNet/DotNetOptimization.fs new file mode 100644 index 0000000..c5799eb --- /dev/null +++ b/src/FScript.Backend.DotNet/DotNetOptimization.fs @@ -0,0 +1,223 @@ +namespace FScript.Compiler + +open FScript.Language + +/// Assembly-only closure propagation and beta reduction over concrete LIR. +module internal DotNetOptimization = + let private mapChildren (mapper: Lir.Expression -> Lir.Expression) (expression: Lir.Expression) = + let recurse = mapper + let withNode node = { expression with Node = node } + match expression.Node with + | Lir.CallClosure(fn, argument) -> withNode (Lir.CallClosure(recurse fn, recurse argument)) + | Lir.PipeClosure(argument, fn) -> withNode (Lir.PipeClosure(recurse argument, recurse fn)) + | Lir.TailCallClosure(fn, argument) -> withNode (Lir.TailCallClosure(recurse fn, recurse argument)) + | Lir.TailPipeClosure(argument, fn) -> withNode (Lir.TailPipeClosure(recurse argument, recurse fn)) + | Lir.Branch(a, b, c) -> withNode (Lir.Branch(recurse a, recurse b, recurse c)) + | Lir.Operation(operation, values) -> withNode (Lir.Operation(operation, List.map recurse values)) + | Lir.Tuple values -> withNode (Lir.Tuple(List.map recurse values)) + | Lir.List values -> withNode (Lir.List(List.map recurse values)) + | Lir.Record fields -> withNode (Lir.Record(fields |> List.map (fun (name, value) -> name, recurse value))) + | Lir.FieldGet(target, name) -> withNode (Lir.FieldGet(recurse target, name)) + | Lir.SomeValue value -> withNode (Lir.SomeValue(recurse value)) + | Lir.Cons(left, right) -> withNode (Lir.Cons(recurse left, recurse right)) + | Lir.Append(left, right) -> withNode (Lir.Append(recurse left, recurse right)) + | Lir.Let(id, name, recursive, binding, body) -> withNode (Lir.Let(id, name, recursive, recurse binding, recurse body)) + | Lir.LetRecursiveGroup(bindings, body) -> withNode (Lir.LetRecursiveGroup(bindings |> List.map (fun (id, name, valueType, value) -> id, name, valueType, recurse value), recurse body)) + | Lir.Fail value -> withNode (Lir.Fail(recurse value)) + | Lir.DecisionTree(target, cases) -> withNode (Lir.DecisionTree(recurse target, cases |> List.map (fun item -> { item with Guard = Option.map recurse item.Guard; Body = recurse item.Body }))) + | Lir.Range(left, right) -> withNode (Lir.Range(recurse left, recurse right)) + | Lir.RecordUpdate(target, fields) -> withNode (Lir.RecordUpdate(recurse target, fields |> List.map (fun (name, value) -> name, recurse value))) + | Lir.RecordConvert(target, targetType) -> withNode (Lir.RecordConvert(recurse target, targetType)) + | Lir.IndexGet(target, index) -> withNode (Lir.IndexGet(recurse target, recurse index)) + | Lir.Interpolate parts -> withNode (Lir.Interpolate(parts |> List.map (function Lir.TextPart text -> Lir.TextPart text | Lir.ValuePart value -> Lir.ValuePart(recurse value)))) + | Lir.UnionCase(typeName, caseName, payload) -> withNode (Lir.UnionCase(typeName, caseName, Option.map recurse payload)) + | Lir.Map entries -> withNode (Lir.Map(entries |> List.map (function Lir.KeyValue(key, value) -> Lir.KeyValue(recurse key, recurse value) | Lir.Spread value -> Lir.Spread(recurse value)))) + | Lir.ForEach(id, name, itemType, source, body) -> withNode (Lir.ForEach(id, name, itemType, recurse source, recurse body)) + | _ -> expression + + let optimize (program: Lir.Program) = + let mutable functions = program.Functions |> List.map (fun fn -> fn.Id,fn) |> Map.ofList + let mutable origins = program.Functions |> List.map (fun fn -> fn.Id,fn.Id) |> Map.ofList + let mutable nextFunction=program.Functions |> List.map (fun fn -> Lir.functionNumber fn.Id) |> List.fold max -1 |> (+) 1 + let clones=System.Collections.Generic.Dictionary() + let mutable knownGlobals = + program.Declarations |> List.choose (fun declaration -> + match declaration.Value.Node with + | Lir.MakeClosure _ | Lir.Intrinsic _ | Lir.HostExternal _ -> Some(declaration.Id,declaration.Value) + | _ -> None) |> Map.ofList + let graph= + functions |> Map.map (fun _ fn -> + let mutable dependencies=Set.empty + let rec visit (value: Lir.Expression) = + match value.Node with + | Lir.MakeClosure(id,_) -> dependencies <- Set.add id dependencies + | Lir.Load symbol -> + match Map.tryFind symbol knownGlobals |> Option.map _.Node with + | Some(Lir.MakeClosure(id,_)) -> dependencies <- Set.add id dependencies + | _ -> () + | _ -> () + mapChildren (fun child -> visit child; child) value |> ignore + visit fn.Body + dependencies) + let recursiveFunctions= + graph |> Map.toList |> List.choose (fun (root,dependencies) -> + let rec reaches seen pending = + if Set.contains root pending then true else + let pending=Set.difference pending seen + if pending.IsEmpty then false else + let next=pending |> Seq.map (fun id -> Map.tryFind id graph |> Option.defaultValue Set.empty) |> Set.unionMany + reaches (Set.union seen pending) next + if reaches Set.empty dependencies then Some root else None) |> Set.ofList + let mutable nextSymbol = + [ yield! program.Declarations |> List.map (fun declaration -> Lir.symbolNumber declaration.Id) + for fn in program.Functions do + yield Lir.symbolNumber fn.Parameter + yield! LirOptimization.loadedSymbols fn.Body |> Seq.map Lir.symbolNumber + yield! program.Entry |> Option.map LirOptimization.loadedSymbols |> Option.defaultValue Set.empty |> Seq.map Lir.symbolNumber ] + |> List.fold max 0 |> (+) 1 + let rec reserve (value: Lir.Expression) = + let ids= + match value.Node with + | Lir.Let(id,_,_,_,_) | Lir.ForEach(id,_,_,_,_) -> [id] + | Lir.LetRecursiveGroup(bindings,_) -> bindings |> List.map (fun (id,_,_,_) -> id) + | Lir.DecisionTree(_,cases) -> cases |> List.collect (fun case -> Lir.planBindingIds case.Plan |> Set.toList) + | _ -> [] + for id in ids do nextSymbol <- max nextSymbol (Lir.symbolNumber id+1) + mapChildren (fun child -> reserve child; child) value |> ignore + program.Functions |> List.iter (fun fn -> reserve fn.Body) + program.Declarations |> List.iter (fun declaration -> reserve declaration.Value) + program.Entry |> Option.iter reserve + let fresh () = + let result=Lir.SymbolId nextSymbol + nextSymbol <- nextSymbol+1 + result + // Every expansion receives fresh lexical identities, including pattern bindings. + let rec clone (fn: Lir.Function) captures = + let mutable renamed=List.zip fn.Captures captures |> Map.ofList + let bind id = + match Map.tryFind id renamed with + | Some replacement -> replacement + | None -> let replacement=fresh () in renamed <- Map.add id replacement renamed; replacement + let parameter=bind fn.Parameter + let rec plan (value: Lir.PatternPlan) = + { value with + Bindings=value.Bindings |> List.map (fun binding -> {binding with Id=bind binding.Id}) + Maps=value.Maps |> List.map (fun map -> {map with Clauses=map.Clauses |> List.map (fun clause -> {Key=plan clause.Key;Value=plan clause.Value}); Tail=Option.map plan map.Tail}) } + let rec collect (value: Lir.Expression) = + match value.Node with + | Lir.Let(id,_,_,_,_) | Lir.ForEach(id,_,_,_,_) -> bind id |> ignore + | Lir.LetRecursiveGroup(bindings,_) -> bindings |> List.iter (fun (id,_,_,_) -> bind id |> ignore) + | Lir.DecisionTree(_,cases) -> cases |> List.iter (fun case -> plan case.Plan |> ignore) + | _ -> () + mapChildren (fun child -> collect child; child) value |> ignore + collect fn.Body + let rename id = Map.tryFind id renamed |> Option.defaultValue id + let rec rewrite value = + let value=mapChildren rewrite value + let node = + match value.Node with + | Lir.Load id -> Lir.Load(rename id) + | Lir.MakeClosure(id,captures) -> + let mapped=List.map rename captures + if mapped=captures then Lir.MakeClosure(id,captures) + else + let clonedId= + match clones.TryGetValue((id,mapped)) with + | true,existing -> existing + | _ -> + let newId=Lir.FunctionId nextFunction + nextFunction <- nextFunction+1 + clones.Add((id,mapped),newId) + let original=functions.[id] + // Reserve the identity before visiting recursive closure groups. + functions <- Map.add newId {original with Id=newId; Captures=List.sort mapped} functions + origins <- Map.add newId origins.[id] origins + let parameter,body=clone original mapped + functions <- Map.add newId {original with Id=newId; Parameter=parameter; Captures=List.sort mapped; Body=body} functions + newId + Lir.MakeClosure(clonedId,List.sort mapped) + | Lir.Let(id,name,recursive,binding,body) -> Lir.Let(rename id,name,recursive,binding,body) + | Lir.LetRecursiveGroup(bindings,body) -> Lir.LetRecursiveGroup(bindings |> List.map (fun (id,name,t,binding) -> rename id,name,t,binding),body) + | Lir.ForEach(id,name,t,source,body) -> Lir.ForEach(rename id,name,t,source,body) + | Lir.DecisionTree(target,cases) -> Lir.DecisionTree(target,cases |> List.map (fun case -> {case with Plan=plan case.Plan})) + | node -> node + {value with Node=node} + parameter,rewrite fn.Body + let replicable (value: Lir.Expression) = + match value.Node with + | Lir.Load _ | Lir.Constant _ | Lir.MakeClosure _ | Lir.Intrinsic _ | Lir.TargetImport _ | Lir.HostExternal _ -> true + | _ -> false + let fold (value: Lir.Expression) = + let constant= + match value.Node with + | Lir.Operation(operation,[{Node=Lir.Constant(Lir.Int a)};{Node=Lir.Constant(Lir.Int b)}]) -> + match operation with + | Lir.IntAdd | Lir.NumericAdd -> Some(Lir.Int(a+b)) + | Lir.IntSubtract | Lir.NumericSubtract -> Some(Lir.Int(a-b)) + | Lir.IntMultiply | Lir.NumericMultiply -> Some(Lir.Int(a*b)) + | Lir.NumericLessThan -> Some(Lir.Bool(a Some(Lir.Bool(a>b)) + | Lir.NumericLessThanOrEqual -> Some(Lir.Bool(a<=b)) + | Lir.NumericGreaterThanOrEqual -> Some(Lir.Bool(a>=b)) + | Lir.StructuralEqual -> Some(Lir.Bool(a=b)) + | _ -> None + | _ -> None + match constant with Some constant -> {value with Node=Lir.Constant constant} | None -> value + let rec rewrite active (known: Map) (expression: Lir.Expression) = + let recurse = rewrite active known + let reduceCall (fn: Lir.Expression) (argument: Lir.Expression) pipe = + match fn.Node with + | Lir.MakeClosure(id,captures) when not (Set.contains origins.[id] active || Set.contains origins.[id] recursiveFunctions) -> + let original=functions.[id] + // Captures of a lifted body still refer to their original lexical IDs. + // Local aliases provide the values after the enclosing expansion was cloned. + let parameter,body=clone original captures + let binding={expression with Node=Lir.Let(parameter,"$nativeArgument",false,argument,body)} + rewrite (Set.add origins.[id] active) known binding + | Lir.Let(id,name,false,binding,body) -> + if pipe then + let argumentId=fresh () + let load={argument with Node=Lir.Load argumentId} + rewrite active known {expression with Node=Lir.Let(argumentId,"$nativePipe",false,argument,{expression with Node=Lir.Let(id,name,false,binding,{expression with Node=Lir.CallClosure(body,load)})})} + else + rewrite active known {expression with Node=Lir.Let(id,name,false,binding,{expression with Node=Lir.CallClosure(body,argument)})} + | _ -> {expression with Node=if pipe then Lir.PipeClosure(argument,fn) else Lir.CallClosure(fn,argument)} + match expression.Node with + | Lir.Load id -> + match Map.tryFind id known with + | Some {Node=Lir.MakeClosure(functionId,_)} when Set.contains origins.[functionId] recursiveFunctions -> expression + | Some replacement -> replacement + | None -> expression + | Lir.Let(id,name,false,binding,body) -> + let binding=recurse binding + match binding.Node with + | Lir.Let(innerId,innerName,false,innerBinding,innerBody) -> + recurse {expression with Node=Lir.Let(innerId,innerName,false,innerBinding,{expression with Node=Lir.Let(id,name,false,innerBody,body)})} + | _ when replicable binding -> + let body=rewrite active (Map.add id binding known) body + {expression with Node=Lir.Let(id,name,false,binding,body)} + | _ -> {expression with Node=Lir.Let(id,name,false,binding,recurse body)} + | Lir.CallClosure(fn,argument) | Lir.TailCallClosure(fn,argument) -> reduceCall (recurse fn) (recurse argument) false + | Lir.PipeClosure(argument,fn) | Lir.TailPipeClosure(argument,fn) -> reduceCall (recurse fn) (recurse argument) true + | _ -> mapChildren recurse expression |> fold + let rec hoist (declaration: Lir.Declaration) (value: Lir.Expression) = + match value.Node with + | Lir.Let(id,name,false,binding,body) -> + {declaration with Id=id;Name=name;Type=binding.Type;Value=binding;IsExported=false;Export=None;IsRecursive=false} :: hoist declaration body + | _ -> + match value.Node with + | Lir.MakeClosure _ | Lir.Constant _ | Lir.NoneValue | Lir.TypeToken _ -> knownGlobals <- Map.add declaration.Id value knownGlobals + | _ -> () + [{declaration with Value=value}] + let optimizedDeclarations=program.Declarations |> List.collect (fun declaration -> hoist declaration (rewrite Set.empty knownGlobals declaration.Value)) + let optimizedEntry=program.Entry |> Option.map (rewrite Set.empty knownGlobals) + let optimizedFunctions=program.Functions |> List.map (fun fn -> {fn with Body=rewrite (Set.singleton fn.Id) knownGlobals fn.Body}) + let originalIds=program.Functions |> List.map _.Id |> Set.ofList + let clonedFunctions=functions |> Map.toList |> List.choose (fun (id,fn) -> if Set.contains id originalIds then None else Some fn) + let result= + { program with + Functions=optimizedFunctions @ clonedFunctions |> List.sortBy _.Id + Declarations=optimizedDeclarations + Entry=optimizedEntry } + result |> LirOptimization.optimize + diff --git a/src/FScript.Backend.DotNet/DotNetPackaging.fs b/src/FScript.Backend.DotNet/DotNetPackaging.fs new file mode 100644 index 0000000..54c6a7b --- /dev/null +++ b/src/FScript.Backend.DotNet/DotNetPackaging.fs @@ -0,0 +1,113 @@ +namespace FScript.Compiler + +open System +open System.Diagnostics +open System.IO +open System.Security + +/// Uses the SDK's supported bundler/native compiler with the optimized FScript PE as input. +module internal DotNetPackaging = + let private diagnostic code message = {Code=code;Stage=DotNetGeneration;Message=message;Span=None} + + let validate executable outputKind = + let supported= + set ["osx-x64";"osx-arm64";"linux-x64";"linux-arm64";"linux-arm";"linux-musl-x64";"linux-musl-arm64";"linux-musl-arm";"win-x64";"win-arm64";"win-x86"] + if outputKind<>ConsoleApplication then + Error [diagnostic "FSN7101" "Single-file and Native AOT output require a console application, not a library."] + elif not (Set.contains executable.RuntimeIdentifier supported) then + let rid=executable.RuntimeIdentifier + let suggestion= + ["darwin-";"macos-"] + |> List.tryPick (fun prefix -> + if rid.StartsWith(prefix,StringComparison.Ordinal) then + let candidate="osx-"+rid.Substring(prefix.Length) + if Set.contains candidate supported then Some $" For macOS, use '{candidate}'." else None + else None) + |> Option.defaultValue "" + let names=String.concat ", " (Set.toList supported) + Error [diagnostic "FSN7101" $"Unsupported .NET runtime identifier '{rid}'.{suggestion} Supported runtime identifiers: {names}."] + elif executable.AheadOfTime && + not ((OperatingSystem.IsMacOS() && executable.RuntimeIdentifier.StartsWith("osx-",StringComparison.Ordinal)) || + (OperatingSystem.IsLinux() && executable.RuntimeIdentifier.StartsWith("linux-",StringComparison.Ordinal)) || + (OperatingSystem.IsWindows() && executable.RuntimeIdentifier.StartsWith("win-",StringComparison.Ordinal))) then + Error [diagnostic "FSN7104" $"Native AOT cannot cross-compile operating systems. Build {executable.RuntimeIdentifier} on its matching OS with the native .NET toolchain; single-file managed output supports cross-OS publishing."] + else Ok () + + let publish executable trim (options: DotNetOptions) (files: GeneratedBinary list) = + let directory=Path.Combine(Path.GetTempPath(),"fscript-publish-"+Guid.NewGuid().ToString("N")) + let run () = + try + let payload=Path.Combine(directory,"payload") + let output=Path.Combine(directory,"publish") + Directory.CreateDirectory(payload) |> ignore + for file in files |> List.filter (fun file -> file.RelativePath.EndsWith(".dll",StringComparison.OrdinalIgnoreCase)) do + File.WriteAllBytes(Path.Combine(payload,file.RelativePath),file.Content) + let xml (value: string) = SecurityElement.Escape(value) |> nonNull + let references=files |> List.filter (fun file -> file.RelativePath.EndsWith(".dll",StringComparison.OrdinalIgnoreCase) && file.RelativePath<>options.AssemblyName+".dll") + |> List.map (fun file -> $" nonNull)}\">payload/{xml file.RelativePath}true") |> String.concat "\n" + let aot=if executable.AheadOfTime then "true" else "false" + let trim=if trim then "true" else "false" + let bundle=if executable.AheadOfTime then "false" else "true" + let project= $""" + + net10.0Exe + {xml options.AssemblyName}{xml executable.RuntimeIdentifier} + truetrue + {bundle}true + {aot}{trim} + + $(NoWarn);IL2040 + $(MSBuildProjectDirectory)/aot-output/ + nonefalsefalse + falsefalse + disableenabletrue + truefalse + + {references} + + + + + """ + // The SDK needs an executable project to resolve runtime packs and apphost assets. + // CoreCompile's placeholder is replaced before publishing; the final entry point, + // methods and optimization are those of the original FScript assembly. + File.WriteAllText(Path.Combine(directory,"Program.csproj"),project) + File.WriteAllText(Path.Combine(directory,"Entry.cs"),"internal static class Entry { public static void Main(string[] args) { } }\n") + let start=ProcessStartInfo("dotnet",WorkingDirectory=directory,RedirectStandardOutput=true,RedirectStandardError=true,UseShellExecute=false) + for argument in ["publish";"Program.csproj";"--configuration";"Release";"--output";output;"--nologo";"--verbosity";"minimal";"-p:ImportDirectoryBuildProps=false";"-p:ImportDirectoryBuildTargets=false"] do start.ArgumentList.Add(argument) + use proc=new Process(StartInfo=start) + try + proc.Start() |> ignore + let stdout=proc.StandardOutput.ReadToEndAsync() + let stderr=proc.StandardError.ReadToEndAsync() + if not (proc.WaitForExit(300000)) then + proc.Kill(true) + proc.WaitForExit() + Error [diagnostic "FSN7103" "Executable publishing exceeded five minutes. Check SDK restore access and the target native toolchain."] + else + let log=stdout.GetAwaiter().GetResult()+stderr.GetAwaiter().GetResult() + if proc.ExitCode<>0 then + let log=if log.Length>16000 then log.Substring(log.Length-16000) else log + Error [diagnostic "FSN7103" $".NET executable publishing failed for {executable.RuntimeIdentifier}. A .NET 10 SDK is required; Native AOT also requires the target's native compiler and AOT-compatible dependencies.\n{log.Trim()}"] + else + let name=options.AssemblyName+(if executable.RuntimeIdentifier.StartsWith("win-",StringComparison.Ordinal) then ".exe" else "") + let path=Path.Combine(output,name) + if not (File.Exists path) then Error [diagnostic "FSN7103" $"The SDK did not produce the expected executable '{name}'."] + else + // Refuse to silently drop a native/content dependency that the SDK + // could not embed. Symbol files are optional development artifacts. + let extras=Directory.GetFiles(output,"*",SearchOption.AllDirectories) |> Array.filter (fun file -> + let relative=Path.GetRelativePath(output,file).Replace('\\','/') + file<>path && not (relative.StartsWith(name+".dSYM/",StringComparison.Ordinal) || file.EndsWith(".pdb",StringComparison.OrdinalIgnoreCase) || file.EndsWith(".dbg",StringComparison.OrdinalIgnoreCase))) + let extraNames=extras |> Array.map (fun path -> Path.GetRelativePath(output,path)) |> String.concat ", " + if extras.Length<>0 then Error [diagnostic "FSN7103" $"Publishing left unbundled dependencies: {extraNames}."] + else Ok [{RelativePath=name;Content=File.ReadAllBytes(path)}] + with :? ComponentModel.Win32Exception as ex -> + Error [diagnostic "FSN7102" $"A .NET 10 SDK with dotnet on PATH is required for executable publishing: {ex.Message}"] + with ex -> Error [diagnostic "FSN7100" $"Cannot publish .NET executable: {ex.Message}"] + try run () + finally + if Directory.Exists directory then Directory.Delete(directory,true) diff --git a/src/FScript.Backend.DotNet/DotNetSourceOptimization.fs b/src/FScript.Backend.DotNet/DotNetSourceOptimization.fs new file mode 100644 index 0000000..b4583c1 --- /dev/null +++ b/src/FScript.Backend.DotNet/DotNetSourceOptimization.fs @@ -0,0 +1,255 @@ +namespace FScript.Compiler + +open System +open System.Collections.Generic +open System.Threading +open Microsoft.CodeAnalysis +open Microsoft.CodeAnalysis.CSharp +open Microsoft.CodeAnalysis.CSharp.Syntax + +/// Assembly-only lowering. The source target never runs these rewrites. +module internal DotNetSourceOptimization = + let rec private unwrap (expression: ExpressionSyntax) = + match expression with + | :? ParenthesizedExpressionSyntax as value -> unwrap value.Expression + | :? CastExpressionSyntax as value -> unwrap value.Expression + | _ -> expression + + let private boolean expression = + match unwrap expression with + | :? LiteralExpressionSyntax as value when value.IsKind SyntaxKind.TrueLiteralExpression -> Some true + | :? LiteralExpressionSyntax as value when value.IsKind SyntaxKind.FalseLiteralExpression -> Some false + | _ -> None + + type private Lowering(model: SemanticModel, className: string) = + inherit CSharpSyntaxRewriter() + let lifted=ResizeArray() + let mutable next=0 + let mutable insideProgram=false + + override this.VisitClassDeclaration(node) = + let previous=insideProgram + insideProgram <- node.Identifier.ValueText=className + let rewritten=(base.VisitClassDeclaration(node) |> nonNull) :?> ClassDeclarationSyntax + let result=if insideProgram then rewritten.AddMembers(lifted.ToArray()) else rewritten + insideProgram <- previous + result + + override this.VisitRecordDeclaration(node) = + let rewritten=(base.VisitRecordDeclaration(node) |> nonNull) :?> RecordDeclarationSyntax + let kind=if node.ClassOrStructKeyword.IsKind SyntaxKind.StructKeyword then "struct" else "class" + let parameters=if isNull rewritten.ParameterList then [] else (nonNull rewritten.ParameterList).Parameters |> Seq.toList + let properties=parameters |> List.map (fun parameter -> $"public {parameter.Type} {parameter.Identifier} {{ get; }}") |> String.concat "\n" + let constructor= + if parameters.IsEmpty then "" else + let signature=parameters |> List.map _.ToFullString() |> String.concat ", " + let assignments=parameters |> List.map (fun parameter -> $"this.{parameter.Identifier}={parameter.Identifier};") |> String.concat " " + $"public {node.Identifier}({signature}) {{ {assignments} }}" + let members=rewritten.Members |> Seq.map _.ToFullString() |> String.concat "\n" + // FScript equality and formatting have dedicated helpers; synthesized CLR record + // equality, cloning, printing, and deconstruction would all be unused baggage. + SyntaxFactory.ParseMemberDeclaration($"{node.Modifiers} {kind} {node.Identifier}{node.TypeParameterList} {node.BaseList} {node.ConstraintClauses} {{ {properties} {constructor} {members} }}") + + override this.VisitBinaryExpression(node) = + let rewritten=(base.VisitBinaryExpression(node) |> nonNull) :?> BinaryExpressionSyntax + let left,right=boolean rewritten.Left,boolean rewritten.Right + match rewritten.Kind(),left,right with + | SyntaxKind.LogicalAndExpression,Some true,_ + | SyntaxKind.LogicalOrExpression,Some false,_ -> rewritten.Right :> SyntaxNode + | SyntaxKind.LogicalAndExpression,_,Some true + | SyntaxKind.LogicalOrExpression,_,Some false -> rewritten.Left :> SyntaxNode + | SyntaxKind.LogicalAndExpression,Some false,_ + | SyntaxKind.LogicalOrExpression,Some true,_ -> rewritten.Left :> SyntaxNode + | _ -> rewritten + + override this.VisitIfStatement(node) = + let rewritten=(base.VisitIfStatement(node) |> nonNull) :?> IfStatementSyntax + match boolean rewritten.Condition with + | Some true -> rewritten.Statement :> SyntaxNode + | Some false -> if isNull rewritten.Else then SyntaxFactory.EmptyStatement() :> SyntaxNode else (nonNull rewritten.Else).Statement + | None -> rewritten + + override this.VisitConditionalExpression(node) = + let rewritten=(base.VisitConditionalExpression(node) |> nonNull) :?> ConditionalExpressionSyntax + match boolean rewritten.Condition,boolean rewritten.WhenTrue,boolean rewritten.WhenFalse with + | Some true,_,_ -> rewritten.WhenTrue :> SyntaxNode + | Some false,_,_ -> rewritten.WhenFalse :> SyntaxNode + | _,Some true,Some false -> rewritten.Condition :> SyntaxNode + | _,Some false,Some true -> SyntaxFactory.PrefixUnaryExpression(SyntaxKind.LogicalNotExpression,SyntaxFactory.ParenthesizedExpression(rewritten.Condition)) + | _ -> rewritten + + override this.VisitInvocationExpression(node) = + let rewritten=(base.VisitInvocationExpression(node) |> nonNull) :?> InvocationExpressionSyntax + let target= + match unwrap node.Expression with + | :? MemberAccessExpressionSyntax as memberAccess when memberAccess.Name.Identifier.ValueText="Invoke" -> unwrap memberAccess.Expression + | value -> value + match target with + | :? ParenthesizedLambdaExpressionSyntax as lambda when insideProgram && node.ArgumentList.Arguments.Count=0 && lambda.ParameterList.Parameters.Count=0 -> + let flow= + match lambda.Body with + | :? BlockSyntax as block -> model.AnalyzeDataFlow(block :> StatementSyntax) + | :? ExpressionSyntax as expression -> model.AnalyzeDataFlow(expression) + | _ -> null + if isNull flow || not (nonNull flow).Succeeded then rewritten else + let flow=nonNull flow + let captures=flow.DataFlowsIn |> Seq.filter (fun symbol -> symbol.Kind=SymbolKind.Local || symbol.Kind=SymbolKind.Parameter) |> Seq.sortBy _.Name |> Seq.toList + let writesCapture=captures |> List.exists (fun symbol -> flow.WrittenInside |> Seq.exists (fun written -> SymbolEqualityComparer.Default.Equals(written,symbol))) + let delegateType=model.GetTypeInfo(lambda).ConvertedType + match delegateType with + | :? INamedTypeSymbol as delegateType when not writesCapture -> + let invoke=delegateType.DelegateInvokeMethod |> nonNull + let returnType=invoke.ReturnType.ToDisplayString(SymbolDisplayFormat.FullyQualifiedFormat) + let parameters=captures |> List.map (fun symbol -> + let t=match symbol with :? ILocalSymbol as local -> local.Type | :? IParameterSymbol as parameter -> parameter.Type | _ -> invalidOp "Invalid capture." + t.ToDisplayString(SymbolDisplayFormat.FullyQualifiedFormat)+" @"+symbol.Name) |> String.concat ", " + let arguments=captures |> List.map (fun symbol -> "@"+symbol.Name) |> String.concat ", " + let visitedTarget= + match unwrap rewritten.Expression with + | :? MemberAccessExpressionSyntax as memberAccess -> unwrap memberAccess.Expression + | value -> value + let visitedLambda=visitedTarget :?> ParenthesizedLambdaExpressionSyntax + let body= + match visitedLambda.Body with + | :? BlockSyntax as block -> block.ToFullString() + | value -> "{ return "+value.ToFullString()+"; }" + let name="NativeBlock"+string next + next <- next+1 + lifted.Add(SyntaxFactory.ParseMemberDeclaration($"private static {returnType} {name}({parameters}) {body}") |> nonNull) + SyntaxFactory.ParseExpression($"{name}({arguments})") + | _ -> rewritten + | _ -> rewritten + + type private Pruning(retained: HashSet) = + inherit CSharpSyntaxRewriter() + override this.VisitClassDeclaration(node) = + if retained.Contains node then base.VisitClassDeclaration(node) else null + override this.VisitStructDeclaration(node) = + if retained.Contains node then base.VisitStructDeclaration(node) else null + override this.VisitRecordDeclaration(node) = + if retained.Contains node then base.VisitRecordDeclaration(node) else null + override this.VisitEnumDeclaration(node) = + if retained.Contains node then base.VisitEnumDeclaration(node) else null + override this.VisitMethodDeclaration(node) = + if retained.Contains node then base.VisitMethodDeclaration(node) else null + override this.VisitPropertyDeclaration(node) = + if retained.Contains node then base.VisitPropertyDeclaration(node) else null + override this.VisitFieldDeclaration(node) = + if retained.Contains node then base.VisitFieldDeclaration(node) else null + override this.VisitConstructorDeclaration(node) = + if retained.Contains node then base.VisitConstructorDeclaration(node) else null + + type private UnreadFields(model: SemanticModel, unread: HashSet) = + inherit CSharpSyntaxRewriter() + let mutable emptyInitializer=false + override this.VisitMethodDeclaration(node) = + let result=(base.VisitMethodDeclaration(node) |> nonNull) :?> MethodDeclarationSyntax + if node.Identifier.ValueText="Initialize" && not (isNull result.Body) then + emptyInitializer <- (nonNull result.Body).Statements |> Seq.forall (fun statement -> statement :? EmptyStatementSyntax || statement :? ReturnStatementSyntax) + result + override this.VisitExpressionStatement(node) = + match node.Expression with + | :? AssignmentExpressionSyntax as assignment when assignment.IsKind SyntaxKind.SimpleAssignmentExpression -> + let target=model.GetSymbolInfo(assignment.Left).Symbol + if not (isNull target) && unread.Contains(nonNull target) then + match unwrap assignment.Right with + | :? LambdaExpressionSyntax -> SyntaxFactory.EmptyStatement() :> SyntaxNode + | _ -> SyntaxFactory.ParseStatement($"_ = {assignment.Right.ToFullString()};") + elif emptyInitializer && assignment.Left.ToString()="_" && assignment.Right.ToString()="Initialization.Value" then + SyntaxFactory.EmptyStatement() :> SyntaxNode + else base.VisitExpressionStatement(node) |> nonNull + | _ -> base.VisitExpressionStatement(node) |> nonNull + + let optimize className isLibrary (compilation: CSharpCompilation) = + let lowered= + compilation.SyntaxTrees |> Seq.map (fun tree -> + let root=Lowering(compilation.GetSemanticModel(tree, false),className).Visit(tree.GetRoot()) |> nonNull + CSharpSyntaxTree.Create(root :?> CSharpSyntaxNode, tree.Options :?> CSharpParseOptions,tree.FilePath,tree.Encoding) ) |> Seq.toList + let compilation=compilation.RemoveAllSyntaxTrees().AddSyntaxTrees(lowered) + let candidates=HashSet(SymbolEqualityComparer.Default) + let reads=HashSet(SymbolEqualityComparer.Default) + for tree in compilation.SyntaxTrees do + let model=compilation.GetSemanticModel(tree,false) + for node in tree.GetRoot().DescendantNodes() do + match node with + | :? VariableDeclaratorSyntax as variable -> + match model.GetDeclaredSymbol(variable) with + | :? IFieldSymbol as field when field.IsStatic && field.DeclaredAccessibility=Accessibility.Private && field.ContainingType.Name=className -> candidates.Add(field) |> ignore + | _ -> () + | :? IdentifierNameSyntax as name -> + let value=model.GetSymbolInfo(name).Symbol + if not (isNull value) then + let onlyWrite=match name.Parent with :? AssignmentExpressionSyntax as assignment when assignment.IsKind SyntaxKind.SimpleAssignmentExpression -> obj.ReferenceEquals(assignment.Left,name) | _ -> false + if not onlyWrite then reads.Add(nonNull value) |> ignore + | _ -> () + candidates.ExceptWith(reads) + let stripped=compilation.SyntaxTrees |> Seq.map (fun tree -> + let root=UnreadFields(compilation.GetSemanticModel(tree,false),candidates).Visit(tree.GetRoot()) |> nonNull + CSharpSyntaxTree.Create(root :?> CSharpSyntaxNode,tree.Options :?> CSharpParseOptions,tree.FilePath,tree.Encoding)) |> Seq.toList + let compilation=compilation.RemoveAllSyntaxTrees().AddSyntaxTrees(stripped) + let retained=HashSet() + let visited=HashSet(SymbolEqualityComparer.Default) + let queue=Queue() + let models=compilation.SyntaxTrees |> Seq.map (fun tree -> tree,compilation.GetSemanticModel(tree,false)) |> dict + let rec retain (node: SyntaxNode) = + if retained.Add node then + queue.Enqueue node + node.Ancestors() |> Seq.tryPick (function :? BaseTypeDeclarationSyntax as parent -> Some(parent :> SyntaxNode) | _ -> None) |> Option.iter retain + let rec symbol (value: ISymbol) = + // A namespace qualifies names; it does not make every declaration in its + // syntax body reachable. Following its syntax reference roots the entire file. + if value.Kind<>SymbolKind.Namespace && visited.Add value then + match value with + | :? IArrayTypeSymbol as array -> symbol array.ElementType + | :? INamedTypeSymbol as named -> + named.TypeArguments |> Seq.iter symbol + // Instance constructors and interface implementations participate in runtime dispatch. + if SymbolEqualityComparer.Default.Equals(named.ContainingAssembly,compilation.Assembly) then + for memberSymbol in named.GetMembers() do + match memberSymbol with + | :? IMethodSymbol as method when method.MethodKind=MethodKind.Constructor || method.MethodKind=MethodKind.StaticConstructor || method.IsOverride || method.IsVirtual || (not method.IsStatic && named.AllInterfaces.Length<>0) -> symbol method + | :? IPropertySymbol as property when property.IsOverride || property.IsVirtual || (not property.IsStatic && named.AllInterfaces.Length<>0) -> symbol property + | _ -> () + | :? IMethodSymbol as method -> + symbol method.ReturnType + method.Parameters |> Seq.iter (fun parameter -> symbol parameter.Type) + method.TypeArguments |> Seq.iter symbol + | :? IFieldSymbol as field -> symbol field.Type + | :? IPropertySymbol as property -> symbol property.Type + | _ -> () + if not (isNull value.ContainingType) then symbol value.ContainingType + for reference in value.OriginalDefinition.DeclaringSyntaxReferences do + let declaration=reference.GetSyntax(CancellationToken.None) + declaration.AncestorsAndSelf() |> Seq.tryPick (function :? MemberDeclarationSyntax as memberNode -> Some(memberNode :> SyntaxNode) | _ -> None) |> Option.iter retain + for tree in compilation.SyntaxTrees do + let model=models.[tree] + for node in tree.GetRoot().DescendantNodes() do + match node with + | :? ClassDeclarationSyntax as typ when typ.Identifier.ValueText=className -> + for memberNode in typ.Members do + match memberNode with + | :? MethodDeclarationSyntax as method when method.Identifier.ValueText="Run" || method.Identifier.ValueText="FormatResult" || (not isLibrary && method.Identifier.ValueText="Main") -> retain method + | :? PropertyDeclarationSyntax as property when property.Modifiers |> Seq.exists (fun token -> token.IsKind SyntaxKind.PublicKeyword) -> retain property + | _ -> () + | _ -> () + while queue.Count<>0 do + let node=queue.Dequeue() + let model=models.[node.SyntaxTree] + let nodes= + match node with + | :? BaseTypeDeclarationSyntax -> + node.DescendantNodesAndSelf(fun child -> obj.ReferenceEquals(child,node) || not (child :? MemberDeclarationSyntax)) + | _ -> node.DescendantNodesAndSelf() + for child in nodes do + match child with + | :? ExpressionSyntax | :? TypeSyntax | :? ConstructorInitializerSyntax -> + let info=model.GetSymbolInfo child + if not (isNull info.Symbol) then symbol (nonNull info.Symbol) + info.CandidateSymbols |> Seq.iter symbol + let t=model.GetTypeInfo child + if not (isNull t.Type) then symbol (nonNull t.Type) + | _ -> () + let trees=compilation.SyntaxTrees |> Seq.map (fun tree -> + let root=Pruning(retained).Visit(tree.GetRoot()) |> nonNull + CSharpSyntaxTree.Create(root :?> CSharpSyntaxNode,tree.Options :?> CSharpParseOptions,tree.FilePath,tree.Encoding)) |> Seq.toList + compilation.RemoveAllSyntaxTrees().AddSyntaxTrees(trees) diff --git a/src/FScript.Backend.DotNet/DotNetTypes.fs b/src/FScript.Backend.DotNet/DotNetTypes.fs new file mode 100644 index 0000000..5222e57 --- /dev/null +++ b/src/FScript.Backend.DotNet/DotNetTypes.fs @@ -0,0 +1,16 @@ +namespace FScript.Compiler + +type DotNetOutputKind = Library | ConsoleApplication +type DotNetOptions = + { AssemblyName: string + Namespace: string + ClassName: string + OutputKind: DotNetOutputKind + References: string list } + +type GeneratedBinary = { RelativePath: string; Content: byte array } + +/// Executable publishing requires an explicit portable .NET runtime identifier. +type DotNetExecutableOptions = + { RuntimeIdentifier: string + AheadOfTime: bool } diff --git a/src/FScript.Backend.DotNet/FScript.Backend.DotNet.fsproj b/src/FScript.Backend.DotNet/FScript.Backend.DotNet.fsproj new file mode 100644 index 0000000..1efe30b --- /dev/null +++ b/src/FScript.Backend.DotNet/FScript.Backend.DotNet.fsproj @@ -0,0 +1,9 @@ + + net10.0false + + + + $(MSBuildToolsPath)/Roslyn/bincore/Microsoft.CodeAnalysis.dlltrue + $(MSBuildToolsPath)/Roslyn/bincore/Microsoft.CodeAnalysis.CSharp.dlltrue + + diff --git a/src/FScript.CSharpInterop/LanguageServer/LspSymbols.fs b/src/FScript.CSharpInterop/LanguageServer/LspSymbols.fs index e9ace92..9cd1ca5 100644 --- a/src/FScript.CSharpInterop/LanguageServer/LspSymbols.fs +++ b/src/FScript.CSharpInterop/LanguageServer/LspSymbols.fs @@ -35,6 +35,13 @@ let ignore : 'a -> unit let writeLine : string -> unit let readLine : unit -> string option +""" + + let private envStdlibDoc = + stdlibDoc "Env.fss" """module Env + +// Effectful. Set the eventual shell status without stopping evaluation. +let setExitCode : int -> unit """ let private taskStdlibDoc = @@ -178,6 +185,7 @@ let queryValues : string -> string -> string list option let private stdlibVirtualSources : Map = [ builtinsStdlibDoc consoleStdlibDoc + envStdlibDoc taskStdlibDoc listStdlibDoc optionStdlibDoc @@ -214,6 +222,7 @@ let queryValues : string -> string -> string list option let private stdlibDefinitionEntries : (string * string * string) list = [ ("ignore", stdlibVirtualUri "Builtins.fss", "ignore") + ("Env.setExitCode", stdlibVirtualUri "Env.fss", "setExitCode") ("Console.writeLine", stdlibVirtualUri "Console.fss", "writeLine") ("Console.readLine", stdlibVirtualUri "Console.fss", "readLine") ("Task.spawn", stdlibVirtualUri "Task.fss", "spawn") @@ -358,7 +367,8 @@ let queryValues : string -> string -> string list option |> Map.map (fun _ signature -> schemeTypeToString signature) let private builtinParameterNames : Map = - [ "ignore", [ "value" ] + [ "Env.setExitCode", [ "code" ] + "ignore", [ "value" ] "Int.tryParse", [ "value" ] "Float.tryParse", [ "value" ] "Bool.tryParse", [ "value" ] @@ -900,6 +910,7 @@ let queryValues : string -> string -> string list option bindings |> List.tryPick (fun (name, _, bindingType, _) -> if name = targetName then Some bindingType else None) + | TypeInfer.TSBackendImport(name, importedType, _, _) when name = targetName -> Some importedType | _ -> None) let keyOf (entry: TypeInfer.LocalVariableTypeInfo) = @@ -907,14 +918,19 @@ let queryValues : string -> string -> string list option (entry.Name, entry.Span.Start.Line, entry.Span.Start.Column, entry.Span.End.Line, entry.Span.End.Column, file) for stmt in program do + let rec withoutAttributes = function + | SAttributed(_, inner, _) -> withoutAttributes inner + | statement -> statement let targetNames = - match stmt with + match withoutAttributes stmt with | SLet(name, _, _, _, _, _, _) -> [ name ] | SLetPattern(pattern, _, _, _) -> collectPatternNames pattern | SLetRecGroup(bindings, _, _) -> bindings |> List.map (fun (name, _, _, _, _) -> name) + | SBackendImport(name, _, _, _) -> [ name ] | SType _ | SExpr _ - | SImport _ -> [] + | SImport _ + | SAttributed _ -> [] if not targetNames.IsEmpty then match tryInfer stmt with @@ -1221,6 +1237,10 @@ let queryValues : string -> string -> string list option let scopedWithArgs = pushBindings scoped argBindings resolveExpr scopedWithArgs valueExpr)) resolveStmts scopesWithNames rest (acc @ inBindings) + | SBackendImport(name, _, _, span) -> + resolveStmts (pushBindings scopes [ name, span ]) rest acc + | SAttributed(_, inner, _) -> + resolveStmts scopes (inner :: rest) acc | SExpr expr -> let inExpr = resolveExpr scopes expr resolveStmts scopes rest (acc @ inExpr) @@ -3075,6 +3095,7 @@ let queryValues : string -> string -> string list option match tryRecordFieldsForQualifier doc qualifier with | Some fields -> + let fields=if qualifier="Env" then fields @ ["setExitCode","int -> unit"] else fields let filtered = fields |> List.filter (fun (name, _) -> @@ -3085,7 +3106,7 @@ let queryValues : string -> string -> string list option |> List.map (fun (name, fieldType) -> let item = JsonObject() item["label"] <- JsonValue.Create(name) - item["kind"] <- JsonValue.Create(10) + item["kind"] <- JsonValue.Create(if qualifier="Env" && name="setExitCode" then 3 else 10) item["detail"] <- JsonValue.Create(fieldType) item["filterText"] <- JsonValue.Create(name) item["sortText"] <- JsonValue.Create($"0_{name}") diff --git a/src/FScript.Compiler/ClrBindings.fs b/src/FScript.Compiler/ClrBindings.fs new file mode 100644 index 0000000..682c258 --- /dev/null +++ b/src/FScript.Compiler/ClrBindings.fs @@ -0,0 +1,220 @@ +namespace FScript.Compiler + +open System +open System.Reflection +open System.Text.Json +open System.IO +open System.Reflection.Metadata +open System.Reflection.PortableExecutable +open FScript.Language + +/// Declarative CLR linkage, independent of executable interpreter registrations. +[] +type ClrMethodLink = + { DeclaringType: string + MemberName: string + Parameters: string array + IsStatic: bool + IsConstructor: bool } + +module ClrBindings = + /// Keep only explicitly supplied dependencies referenced by the emitted PE and their + /// adjacent managed dependency closure. Merely loading a provider is not a runtime root. + let referencedDependencies (assemblyBytes: byte array) paths = + let candidates=Collections.Generic.Dictionary(StringComparer.OrdinalIgnoreCase) + for path in paths do + let path=Path.GetFullPath path + use stream=File.OpenRead(path) + use pe=new PEReader(stream) + if pe.HasMetadata then + let metadata=pe.GetMetadataReader() + if metadata.IsAssembly then candidates.[metadata.GetString(metadata.GetAssemblyDefinition().Name)] <- path + let used=Collections.Generic.HashSet(StringComparer.OrdinalIgnoreCase) + let rec visitBytes bytes = + use stream=new MemoryStream(bytes,false) + use pe=new PEReader(stream) + if pe.HasMetadata then + let metadata=pe.GetMetadataReader() + for handle in metadata.AssemblyReferences do + let name=metadata.GetString(metadata.GetAssemblyReference(handle).Name) + match candidates.TryGetValue name with + | true,path when used.Add path -> visitBytes (File.ReadAllBytes path) + | _ -> () + visitBytes assemblyBytes + used |> Seq.sort |> Seq.toList + + /// Include managed dependencies colocated with explicit reference assemblies. + let referenceClosure paths = + let seen=Collections.Generic.HashSet(StringComparer.Ordinal) + let result=ResizeArray() + let rec visit path = + let path=Path.GetFullPath path + if File.Exists path && seen.Add path then + result.Add path + use stream=File.OpenRead path + use pe=new PEReader(stream) + if pe.HasMetadata then + let metadata=pe.GetMetadataReader() + for handle in metadata.AssemblyReferences do + let name=metadata.GetString(metadata.GetAssemblyReference(handle).Name) + let adjacent=Path.Combine(Path.GetDirectoryName(path) |> nonNull,name+".dll") + if File.Exists adjacent then visit adjacent + List.iter visit paths + result |> Seq.distinctBy Path.GetFileName |> Seq.sort |> Seq.toList + + let private typeName (value: System.Type) = + match value.AssemblyQualifiedName with null -> invalidArg "value" "CLR types must have assembly-qualified names." | name -> name + + let methodLink (method: MethodBase) = + let declaring = method.DeclaringType |> nonNull + if not method.IsPublic || method.ContainsGenericParameters || not declaring.IsVisible then + invalidArg "method" "Compiled FFI requires a public, closed method on a public CLR type." + if method.GetParameters() |> Array.exists (fun parameter -> parameter.ParameterType.IsByRef || parameter.ParameterType.IsPointer) then + invalidArg "method" "Compiled FFI does not accept by-reference or pointer parameters." + "clr:" + JsonSerializer.Serialize( + { DeclaringType = typeName declaring + MemberName = method.Name + Parameters = method.GetParameters() |> Array.map (fun parameter -> typeName parameter.ParameterType) + IsStatic = method.IsStatic + IsConstructor = method.IsConstructor }) + + let tryMethodLink (path: string) : ClrMethodLink option = + if path.StartsWith("clr:{", StringComparison.Ordinal) then + try JsonSerializer.Deserialize(path.Substring(4)) |> Option.ofObj with :? JsonException -> None + else None + + /// Bind an existing host-external declaration to an exact CLR overload. + /// Instance methods take their receiver as the first curried FScript argument. + let bindMethod name (method: MethodBase) (program: Lir.Program) = + let link = methodLink method + let mutable found = false + let declarations = program.Declarations |> List.map (fun declaration -> + if declaration.Name = name then + found <- true + { declaration with Value = { declaration.Value with Node = Lir.TargetImport(link, method.Name) } } + else declaration) + if not found then invalidArg "name" $"No reachable external declaration named '{name}' exists." + { program with Declarations = declarations } + + /// Link existing SDK providers without retaining compiler-process delegates. + /// Generated adapters invoke SDK implementations directly and marshal compiled callbacks. + let bindProvider names (method: MethodInfo) (program: Lir.Program) = + if not method.IsStatic then invalidArg "method" "SDK providers must be static methods." + let link = methodLink method + let target = "clr-sdk:" + link.Substring(4) + let names = Set.ofList names + let declarations = + program.Declarations |> List.map (fun declaration -> + if Set.contains declaration.Name names then + { declaration with Value = { declaration.Value with Node = Lir.TargetImport(target,declaration.Name) } } + else declaration) + { program with Declarations = declarations } + + /// Retain a native type projection in the ordinary serialized target-type linkage. + let bindType name (clrType: System.Type) (program: Lir.Program) = + if not clrType.IsVisible || clrType.ContainsGenericParameters || clrType.IsByRef || clrType.IsPointer then + invalidArg "clrType" "Compiled FFI requires a public, closed CLR type." + let definition = program.Types |> List.tryFind (fun declaration -> declaration.Name = name) + match definition with + | None -> invalidArg "name" $"No external type named '{name}' exists." + | Some definition -> + let fields = match definition.Definition with TRecord fields | THostManaged(_, fields) -> Map.toList fields | _ -> [] + let imported: Lir.ImportedRecord = + { Name = name; ModulePath = "clr:" + typeName clrType; MemberName = clrType.FullName |> nonNull + IsUnion = match definition.Definition with TUnion _ -> true | _ -> false + Fields = fields; Span = definition.Span } + { program with + Types = program.Types |> List.map (fun item -> if item.Name = name then { item with Import = Some imported } else item) + ImportedRecords = imported :: (program.ImportedRecords |> List.filter (fun item -> item.Name <> name)) } + + /// Remove unused declared/imported types before resolving target-specific metadata. + let pruneUnusedTypes (program: Lir.Program) = + let definitions=program.Types |> List.map (fun declaration -> declaration.Name,declaration.Definition) |> Map.ofList + let names=Collections.Generic.HashSet(StringComparer.Ordinal) + let rec named name = + if names.Add name then definitions.TryFind name |> Option.iter visitType + and visitType = function + | TNamed name -> named name + | THostManaged(name,fields) -> named name; fields |> Map.iter (fun _ t -> visitType t) + | TUnion(name,cases) -> named name; cases |> Map.iter (fun _ t -> Option.iter visitType t) + | TRecord fields | TRecordShape(_,fields,_) -> fields |> Map.iter (fun _ t -> visitType t) + | TFun(a,b) | TMap(a,b) -> visitType a; visitType b + | TTuple items -> List.iter visitType items + | TList t | TOption t | TTask t -> visitType t + | _ -> () + let rec pattern (plan: Lir.PatternPlan) = + for binding in plan.Bindings do visitType binding.Type + for check in plan.Checks do match check with Lir.TypeCheck(_,t) -> visitType t | Lir.UnionCaseCheck(_,name,_,_) -> named name | _ -> () + for map in plan.Maps do + for clause in map.Clauses do pattern clause.Key; pattern clause.Value + Option.iter pattern map.Tail + let rec expression (value: Lir.Expression) = + visitType value.Type + let both a b = expression a; expression b + match value.Node with + | Lir.CallClosure(a,b) | Lir.TailCallClosure(a,b) | Lir.PipeClosure(a,b) | Lir.TailPipeClosure(a,b) + | Lir.Cons(a,b) | Lir.Append(a,b) | Lir.Range(a,b) | Lir.IndexGet(a,b) -> both a b + | Lir.Branch(a,b,c) -> expression a; both b c + | Lir.Operation(_,items) | Lir.Tuple items | Lir.List items -> List.iter expression items + | Lir.Record fields -> fields |> List.iter (snd >> expression) + | Lir.FieldGet(v,_) | Lir.SomeValue v | Lir.Fail v -> expression v + | Lir.Let(_,_,_,binding,body) -> both binding body + | Lir.LetRecursiveGroup(bindings,body) -> + for _,_,t,binding in bindings do visitType t; expression binding + expression body + | Lir.DecisionTree(target,cases) -> expression target; for case in cases do pattern case.Plan; Option.iter expression case.Guard; expression case.Body + | Lir.RecordUpdate(target,fields) -> expression target; fields |> List.iter (snd >> expression) + | Lir.RecordConvert(target,t) -> expression target; visitType t + | Lir.Interpolate parts -> for part in parts do match part with Lir.ValuePart value -> expression value | _ -> () + | Lir.UnionCase(name,_,payload) -> named name; Option.iter expression payload + | Lir.Map entries -> for entry in entries do match entry with Lir.KeyValue(a,b) -> both a b | Lir.Spread value -> expression value + | Lir.ForEach(_,_,t,source,body) -> visitType t; both source body + | Lir.TypeToken t -> visitType t + | _ -> () + for declaration in program.Declarations do visitType declaration.Type; expression declaration.Value + for fn in program.Functions do visitType fn.ParameterType; visitType fn.ReturnType; expression fn.Body + Option.iter expression program.Entry + {program with Types=program.Types |> List.filter (fun declaration -> names.Contains declaration.Name) + ImportedRecords=program.ImportedRecords |> List.filter (fun record -> names.Contains record.Name)} + + /// Additive provider metadata; existing SDK registration records remain unchanged. + let providerPurity (providers: MethodInfo list) : PurityContracts = + let mutable functions = Set.empty + let mutable types = Set.empty + for typ in providers |> List.map (fun method -> method.DeclaringType |> nonNull) |> List.distinct do + let names methodName = + match typ.GetMethod(methodName, BindingFlags.Public ||| BindingFlags.Static, null, System.Type.EmptyTypes, null) |> Option.ofObj with + | None -> Set.empty + | Some factory -> + match factory.Invoke(null, [||]) with + | :? Collections.Generic.IEnumerable as values -> + values |> Seq.map (fun value -> if String.IsNullOrWhiteSpace value then invalidOp $"{typ.FullName}.{methodName} contains an empty binding name." else value) |> Set.ofSeq + | _ -> invalidOp $"{typ.FullName}.{methodName} must return IEnumerable." + functions <- Set.union functions (names "FScriptPureFunctions") + types <- Set.union types (names "FScriptPureTypes") + { PureFunctions = functions; PureTypes = types } + + /// Optional compiler-only companion contract. Uses BCL metadata types, so existing + /// SDK providers and their interpreter registration records remain binary-compatible. + let bindCompiledProviders (providers: MethodInfo list) (program: Lir.Program) = + let mutable program=pruneUnusedTypes program + let types=providers |> List.map (fun method -> method.DeclaringType |> nonNull) |> List.distinct + for typ in types do + let companion name = typ.GetMethod(name,BindingFlags.Public ||| BindingFlags.Static,null,System.Type.EmptyTypes,null) |> Option.ofObj + match companion "FScriptCompiledTypes" with + | Some factory -> + match factory.Invoke(null,[||]) with + | :? Collections.Generic.IEnumerable> as bindings -> + for binding in bindings do + if program.Types |> List.exists (fun declaration -> declaration.Name=binding.Key) then program <- bindType binding.Key binding.Value program + | _ -> invalidOp $"{typ.FullName}.FScriptCompiledTypes must return IEnumerable>." + | None -> () + match companion "FScriptCompiledFunctions" with + | Some factory -> + match factory.Invoke(null,[||]) with + | :? Collections.Generic.IEnumerable> as bindings -> + for binding in bindings do + if program.Declarations |> List.exists (fun declaration -> declaration.Name=binding.Key) then program <- bindMethod binding.Key binding.Value program + | _ -> invalidOp $"{typ.FullName}.FScriptCompiledFunctions must return IEnumerable>." + | None -> () + program diff --git a/src/FScript.Compiler/Compiler.fs b/src/FScript.Compiler/Compiler.fs new file mode 100644 index 0000000..ddb5589 --- /dev/null +++ b/src/FScript.Compiler/Compiler.fs @@ -0,0 +1,54 @@ +namespace FScript.Compiler + +open FScript.Language + +type CompileInput = + { Program: Program + Externs: CompilerExtern list } + +type CompiledProgram = + { Hir: Hir.Program + Lir: Lir.Program + ExportedFunctions: Map } + +module Compiler = + let compileWithRegistrationAndPurity (registration: ExtensionRegistration) (purity: PurityContracts) input = + try + let compilerBindings = CompilerExternCatalog.defaults + let reserved = compilerBindings |> List.map _.Name |> Set.ofList + let supplied = input.Externs |> List.map _.Name |> Set.ofList + let hostBindings = registration.Functions |> List.filter (fun fn -> not (Set.contains fn.Name supplied || Set.contains fn.Name reserved)) |> List.map (fun fn -> + { Name = fn.Name; Scheme = fn.Scheme; Arity = fn.Arity; Kind = UnsupportedHostExtern }) + let externs = compilerBindings @ (input.Externs |> List.filter (fun external -> not (Set.contains external.Name reserved))) @ hostBindings + let allowedFunctions = Set.union (hostBindings |> List.map _.Name |> Set.ofList) (Set.difference supplied reserved) + let allowedTypes = Set.union (registration.Types |> List.map _.Name |> Set.ofList) (registration.Unions |> List.map _.Name |> Set.ofList) + let unknownFunctions = Set.difference purity.PureFunctions allowedFunctions + let unknownTypes = Set.difference purity.PureTypes allowedTypes + if not unknownFunctions.IsEmpty || not unknownTypes.IsEmpty then + raise (TypeException { Message = "Purity contracts must name registered external functions/types, not protected runtime bindings: " + String.concat ", " (Set.toList (Set.union unknownFunctions unknownTypes)); Span = Span.mk (Span.pos 0 0) (Span.pos 0 0) }) + let inferenceExterns = + externs + |> List.map (fun external -> + ({ Name = external.Name; Scheme = external.Scheme; Arity = external.Arity; Impl = fun _ _ -> VUnit }: ExternalFunction)) + let resolved = TypeInfer.inferResolvedProgramWithRegistrationAndPurity { registration with Functions = inferenceExterns } purity input.Program + let exportedFunctions = ExportSignatures.fromTypedProgram resolved.TypedProgram + resolved + |> HirLowering.lower externs + |> Result.bind HirValidation.validate + |> Result.bind (fun hir -> + hir |> LirLowering.lower |> LirOptimization.optimize |> LirValidation.validate + |> Result.map (fun lir -> + { Hir = hir + Lir = lir + ExportedFunctions = exportedFunctions })) + with + | TypeException error -> + Error + [ { Code = "FSH1000" + Stage = Hir + Message = error.Message + Span = Some error.Span } ] + + let compileWithRegistration registration input = compileWithRegistrationAndPurity registration PurityContracts.empty input + let compileWithPurity purity input = compileWithRegistrationAndPurity HostInterop.empty purity input + let compile input = compileWithRegistration HostInterop.empty input diff --git a/src/FScript.Compiler/Diagnostics.fs b/src/FScript.Compiler/Diagnostics.fs new file mode 100644 index 0000000..c7706ff --- /dev/null +++ b/src/FScript.Compiler/Diagnostics.fs @@ -0,0 +1,83 @@ +namespace FScript.Compiler + +open FScript.Language + +type DiagnosticStage = + | Hir + | Lowering + | Interpreter + | CSharpGeneration + | DotNetGeneration + | Artifact + +type CompilerDiagnostic = + { Code: string + Stage: DiagnosticStage + Message: string + Span: Span option } + +type CompilerExternKind = + | RuntimeContextIntrinsic + | PortableRuntimeIntrinsic + | UnsupportedHostExtern + +type GeneratedFile = { RelativePath: string; Content: string } + +type CompilerExtern = + { Name: string + Scheme: Scheme + Arity: int + Kind: CompilerExternKind } + +module RuntimeIntrinsics = + let schemes = + Map.ofList + [ "Console.readLine", Forall([], TFun(TUnit, TOption TString)) + "Console.writeLine", Forall([], TFun(TString, TUnit)) + "Fs.readText", Forall([], TFun(TString, TOption TString)) ] + +/// Declarative descriptions of the runtime surface known to the compiler. +/// These values deliberately contain no executable .NET delegates. +module CompilerExternCatalog = + let private descriptor name scheme arity kind : CompilerExtern = + { Name = name + Scheme = scheme + Arity = arity + Kind = kind } + + let runtimeContext = + descriptor "Env" (Forall([], TNamed "Environment")) 0 RuntimeContextIntrinsic + + let portableRuntime = + RuntimeIntrinsics.schemes + |> Map.toList + |> List.map (fun (name, scheme) -> descriptor name scheme 1 PortableRuntimeIntrinsic) + + let unsupportedHostRuntime = + [ descriptor "Fs.exists" (Forall([], TFun(TString, TBool))) 1 UnsupportedHostExtern + descriptor "Fs.kind" (Forall([], TFun(TString, TNamed "FsKind"))) 1 UnsupportedHostExtern + descriptor "Fs.createDirectory" (Forall([], TFun(TString, TBool))) 1 UnsupportedHostExtern + descriptor "Fs.writeText" (Forall([], TFun(TString, TFun(TString, TBool)))) 2 UnsupportedHostExtern + descriptor "Fs.combinePath" (Forall([], TFun(TString, TFun(TString, TString)))) 2 UnsupportedHostExtern + descriptor "Fs.parentDirectory" (Forall([], TFun(TString, TOption TString))) 1 UnsupportedHostExtern + descriptor "Fs.extension" (Forall([], TFun(TString, TOption TString))) 1 UnsupportedHostExtern + descriptor "Fs.fileNameWithoutExtension" (Forall([], TFun(TString, TString))) 1 UnsupportedHostExtern + descriptor "Fs.glob" (Forall([], TFun(TString, TOption(TList TString)))) 1 UnsupportedHostExtern + descriptor "Fs.enumerateFiles" (Forall([], TFun(TString, TFun(TString, TOption(TList TString))))) 2 UnsupportedHostExtern + descriptor "Regex.matchGroups" (Forall([], TFun(TString, TFun(TString, TOption(TList TString))))) 2 UnsupportedHostExtern + descriptor "Hash.md5" (Forall([], TFun(TString, TOption TString))) 1 UnsupportedHostExtern + descriptor "Guid.new" (Forall([ 0 ], TFun(TVar 0, TOption TString))) 1 UnsupportedHostExtern + descriptor "Json.deserialize" (Forall([ 0 ], TFun(TTypeToken, TFun(TString, TOption(TVar 0))))) 2 UnsupportedHostExtern + descriptor "Json.serialize" (Forall([ 0 ], TFun(TVar 0, TOption TString))) 1 UnsupportedHostExtern + descriptor "Xml.queryValues" (Forall([], TFun(TString, TFun(TString, TOption(TList TString))))) 2 UnsupportedHostExtern + descriptor "Task.spawn" (Forall([ 0 ], TFun(TFun(TUnit, TVar 0), TTask(TVar 0)))) 1 UnsupportedHostExtern + descriptor "Task.await" (Forall([ 0 ], TFun(TTask(TVar 0), TVar 0))) 1 UnsupportedHostExtern ] + + let defaults = runtimeContext :: (portableRuntime @ unsupportedHostRuntime) + +module Diagnostic = + let hir code message span = + { Code = code + Stage = Hir + Message = message + Span = span } diff --git a/src/FScript.Compiler/FScript.Compiler.fsproj b/src/FScript.Compiler/FScript.Compiler.fsproj new file mode 100644 index 0000000..1e723df --- /dev/null +++ b/src/FScript.Compiler/FScript.Compiler.fsproj @@ -0,0 +1,25 @@ + + + net10.0 + false + + + + + + + + + + + + + + + + + + + + + diff --git a/src/FScript.Compiler/Hir.fs b/src/FScript.Compiler/Hir.fs new file mode 100644 index 0000000..c70b192 --- /dev/null +++ b/src/FScript.Compiler/Hir.fs @@ -0,0 +1,253 @@ +namespace FScript.Compiler + +open FScript.Language + +module Hir = + type SymbolId = SymbolId of int + + type LiteralValue = + | Unit + | Int of int64 + | Float of float + | Bool of bool + | String of string + + type PrimitiveOperation = + | NumericAdd | NumericSubtract | NumericMultiply | NumericDivide + | IntAdd + | FloatAdd + | IntSubtract + | FloatSubtract + | IntMultiply + | FloatMultiply + | IntDivide + | FloatDivide + | IntRemainder + | StructuralEqual + | NumericLessThan + | NumericGreaterThan + | NumericLessThanOrEqual + | NumericGreaterThanOrEqual + | BooleanAnd + | BooleanOr + + type Expression = + { Type: Type + Span: Span + Node: ExpressionNode } + + and ExpressionNode = + | Constant of LiteralValue + | Reference of SymbolId + | Lambda of SymbolId * string * Type * Expression + | Apply of Expression * Expression + | Pipe of Expression * Expression + | If of Expression * Expression * Expression + | Primitive of PrimitiveOperation * Expression list + | Tuple of Expression list + | List of Expression list + | Record of (string * Expression) list + | FieldGet of Expression * string + | SomeValue of Expression + | NoneValue + | Cons of Expression * Expression + | Append of Expression * Expression + | Let of SymbolId * string * bool * Expression * Expression + | LetRecursiveGroup of (SymbolId * string * Type * Expression) list * Expression + | Fail of Expression + | Match of Expression * MatchCase list + | Range of Expression * Expression + | RecordUpdate of Expression * (string * Expression) list + | RecordConvert of Expression * Type + | IndexGet of Expression * Expression + | Interpolate of InterpolationPart list + | UnionCase of string * string * Expression option + | Map of MapEntry list + | Intrinsic of string + | HostExternal of string * int + | RuntimeContext + | TargetImport of string * string + | ForEach of SymbolId * string * Type * Expression * Expression + | TypeToken of Type + + and MapEntry = + | KeyValue of Expression * Expression + | Spread of Expression + + and InterpolationPart = + | TextPart of string + | ValuePart of Expression + + and Pattern = + { Type: Type + Span: Span + Node: PatternNode } + + and PatternNode = + | Wildcard + | Binding of SymbolId * string + | LiteralPattern of LiteralValue + | EmptyList + | ConsPattern of Pattern * Pattern + | TuplePattern of Pattern list + | RecordPattern of (string * Pattern) list + | MapPattern of (Pattern * Pattern) list * Pattern option + | SomePattern of Pattern + | NonePattern + | UnionPattern of string * string * Pattern option + | TypePattern of Type + + and MatchCase = + { Pattern: Pattern + Guard: Expression option + Body: Expression + Span: Span } + + type Declaration = + { Id: SymbolId + Name: string + Scheme: Scheme + Attributes: AttributeMetadata list + IsRecursive: bool + IsExported: bool + IsPure: bool + ExternalArity: int option + Export: ExportMetadata option + Span: Span + Value: Expression } + + and ExportMetadata = + { Name: string + Span: Span } + + and AttributeMetadata = + { Name: string + Arguments: string list + Span: Span } + + type ImportedRecord = + { Name: string + ModulePath: string + MemberName: string + IsUnion: bool + Fields: (string * Type) list + Span: Span } + + type TypeDeclaration = + { Id: SymbolId + Name: string + IsRecursive: bool + IsPure: bool + Definition: Type + Attributes: AttributeMetadata list + Import: ImportedRecord option + Span: Span } + + type Program = + { Types: TypeDeclaration list + ImportedRecords: ImportedRecord list + Declarations: Declaration list + Entry: Expression option } + + let symbolNumber (SymbolId value) = value + + let rec formatType = Types.typeToString + + let private formatLiteral value = + match value with + | Unit -> "unit" + | Int value -> $"int {value}" + | Float value -> $"float {value:R}" + | Bool value -> $"bool {value.ToString().ToLowerInvariant()}" + | String value -> $"string {System.Text.Json.JsonSerializer.Serialize(value)}" + + let private formatPrimitive value = sprintf "%A" value + + let format (program: Program) = + let lines = ResizeArray() + let rec expression indent (value: Expression) = + let prefix = System.String(' ', indent) + let typed text = $"{prefix}{text} : {formatType value.Type}" + match value.Node with + | Constant literal -> lines.Add(typed $"const {formatLiteral literal}") + | Reference id -> lines.Add(typed (sprintf "ref %%%d" (symbolNumber id))) + | Lambda(id, name, parameterType, body) -> + lines.Add(typed (sprintf "lambda %%%d %s: %s" (symbolNumber id) name (formatType parameterType))) + expression (indent + 2) body + | Apply(fn, argument) -> + lines.Add(typed "apply") + expression (indent + 2) fn + expression (indent + 2) argument + | Pipe(value, fn) -> + lines.Add(typed "pipe") + expression (indent + 2) value + expression (indent + 2) fn + | If(condition, whenTrue, whenFalse) -> + lines.Add(typed "if") + expression (indent + 2) condition + expression (indent + 2) whenTrue + expression (indent + 2) whenFalse + | Primitive(operation, arguments) -> + lines.Add(typed $"primitive {formatPrimitive operation}") + arguments |> List.iter (expression (indent + 2)) + | Tuple items | List items -> + lines.Add(typed (match value.Node with Tuple _ -> "tuple" | _ -> "list")) + items |> List.iter (expression (indent + 2)) + | Record fields -> + lines.Add(typed "record") + fields |> List.iter (fun (name, item) -> lines.Add($"{prefix} field {name}"); expression (indent + 4) item) + | FieldGet(target, name) -> lines.Add(typed $"field-get {name}"); expression (indent + 2) target + | SomeValue item -> lines.Add(typed "some"); expression (indent + 2) item + | NoneValue -> lines.Add(typed "none") + | Cons(head, tail) -> lines.Add(typed "cons"); expression (indent + 2) head; expression (indent + 2) tail + | Append(left, right) -> lines.Add(typed "append"); expression (indent + 2) left; expression (indent + 2) right + | Let(id, name, recursive, binding, body) -> + lines.Add(typed (sprintf "let%s %%%d %s" (if recursive then " rec" else "") (symbolNumber id) name)) + expression (indent + 2) binding + expression (indent + 2) body + | LetRecursiveGroup(bindings, body) -> + lines.Add(typed "let-rec-group") + bindings |> List.iter (fun (id, name, _, binding) -> lines.Add(sprintf "%s binding %%%d %s" prefix (symbolNumber id) name); expression (indent + 4) binding) + expression (indent + 2) body + | Fail value -> lines.Add(typed "fail"); expression (indent + 2) value + | Match(target, cases) -> + lines.Add(typed $"match {cases.Length} cases") + expression (indent + 2) target + cases |> List.iter (fun case -> expression (indent + 2) case.Body) + | Range(startValue, endValue) -> lines.Add(typed "range"); expression (indent + 2) startValue; expression (indent + 2) endValue + | RecordUpdate(target, fields) -> + lines.Add(typed "record-update"); expression (indent + 2) target + fields |> List.iter (fun (_, item) -> expression (indent + 2) item) + | RecordConvert(target, targetType) -> lines.Add(typed $"record-convert {formatType targetType}"); expression (indent + 2) target + | IndexGet(target, index) -> lines.Add(typed "index-get"); expression (indent + 2) target; expression (indent + 2) index + | Interpolate parts -> + lines.Add(typed "interpolate") + parts |> List.iter (function TextPart _ -> () | ValuePart item -> expression (indent + 2) item) + | UnionCase(typeName, caseName, payload) -> + lines.Add(typed $"union {typeName}.{caseName}") + payload |> Option.iter (expression (indent + 2)) + | Map entries -> + lines.Add(typed "map") + entries |> List.iter (function KeyValue(key, value) -> expression (indent + 2) key; expression (indent + 2) value | Spread value -> expression (indent + 2) value) + | Intrinsic name -> lines.Add(typed $"intrinsic {name}") + | HostExternal(name, arity) -> lines.Add(typed $"host-extern {name}/{arity}") + | RuntimeContext -> lines.Add(typed "runtime-context") + | TargetImport(modulePath, memberName) -> lines.Add(typed $"target-import {modulePath}.{memberName}") + | ForEach(id, name, _, source, body) -> + lines.Add(typed (sprintf "for %%%d %s" (symbolNumber id) name)); expression (indent + 2) source; expression (indent + 2) body + | TypeToken tokenType -> lines.Add(typed $"typeof {formatType tokenType}") + + for typeDeclaration in program.Types do + let attributes = typeDeclaration.Attributes |> List.map _.Name |> function [] -> "" | values -> " attrs=" + String.concat "," values + lines.Add(sprintf "type %%%d %s%s%s = %s" (symbolNumber typeDeclaration.Id) typeDeclaration.Name ((if typeDeclaration.IsRecursive then " rec" else "") + (if typeDeclaration.IsPure then " pure" else "")) attributes (formatType typeDeclaration.Definition)) + for declaration in program.Declarations do + let export = declaration.Export |> Option.map (fun metadata -> $" export={metadata.Name}") |> Option.defaultValue "" + let attributes = declaration.Attributes |> List.map _.Name |> function [] -> "" | values -> " attrs=" + String.concat "," values + lines.Add(sprintf "decl %%%d %s%s%s: %s" (symbolNumber declaration.Id) declaration.Name (export + (if declaration.IsPure then " pure" else "")) attributes (formatType (let (Forall(_, value)) = declaration.Scheme in value))) + expression 2 declaration.Value + match program.Entry with + | Some entry -> + lines.Add("entry") + expression 2 entry + | None -> () + System.String.Join("\n", lines) + "\n" diff --git a/src/FScript.Compiler/HirLowering.fs b/src/FScript.Compiler/HirLowering.fs new file mode 100644 index 0000000..f439879 --- /dev/null +++ b/src/FScript.Compiler/HirLowering.fs @@ -0,0 +1,419 @@ +namespace FScript.Compiler + +open FScript.Language + +module HirLowering = + type private State = + { mutable NextSymbol: int + mutable AvailableSymbols: TypeInfer.ResolvedSymbol list + mutable Diagnostics: CompilerDiagnostic list } + + let private newSymbol state = + let value = state.NextSymbol + state.NextSymbol <- value + 1 + Hir.SymbolId value + + let private claimSymbol state kind name span = + match state.AvailableSymbols |> List.tryFind (fun symbol -> symbol.Kind = kind && symbol.Name = name && symbol.Span = span) with + | Some symbol -> + state.AvailableSymbols <- state.AvailableSymbols |> List.filter (fun candidate -> candidate.SymbolId <> symbol.SymbolId) + Hir.SymbolId symbol.SymbolId + | None -> + state.Diagnostics <- state.Diagnostics @ [ Diagnostic.hir "FSH1007" $"Resolved symbol '{name}' was not available during HIR lowering." (Some span) ] + newSymbol state + + let private findSymbol state kind name span = + state.AvailableSymbols + |> List.tryFind (fun symbol -> symbol.Kind = kind && symbol.Name = name && symbol.Span = span) + |> Option.map (fun symbol -> Hir.SymbolId symbol.SymbolId) + |> Option.defaultWith (fun () -> claimSymbol state kind name span) + + let rec private representationType state = function + | TNumeric id -> TVar id + | TRecordShape(id, fields, constructible) -> TRecordShape(id, Map.map (fun _ -> representationType state) fields, constructible) + | THostManaged(name, fields) -> THostManaged(name, Map.map (fun _ -> representationType state) fields) + | TFun(argument, result) -> TFun(representationType state argument, representationType state result) + | TTuple items -> TTuple(List.map (representationType state) items) + | TList item -> TList(representationType state item) + | TOption item -> TOption(representationType state item) + | TMap(key, value) -> TMap(representationType state key, representationType state value) + | TTask item -> TTask(representationType state item) + | TRecord fields -> TRecord(fields |> Map.map (fun _ -> representationType state)) + | TUnion(name, cases) -> TUnion(name, cases |> Map.map (fun _ -> Option.map (representationType state))) + | TNamed name -> TNamed name + | value -> value + + let private resolvedOperation = function + | TypeInfer.NumericAddition -> Hir.NumericAdd + | TypeInfer.NumericSubtraction -> Hir.NumericSubtract + | TypeInfer.NumericMultiplication -> Hir.NumericMultiply + | TypeInfer.NumericDivision -> Hir.NumericDivide + | TypeInfer.IntegerAddition -> Hir.IntAdd + | TypeInfer.FloatingAddition -> Hir.FloatAdd + | TypeInfer.IntegerSubtraction -> Hir.IntSubtract + | TypeInfer.FloatingSubtraction -> Hir.FloatSubtract + | TypeInfer.IntegerMultiplication -> Hir.IntMultiply + | TypeInfer.FloatingMultiplication -> Hir.FloatMultiply + | TypeInfer.IntegerDivision -> Hir.IntDivide + | TypeInfer.FloatingDivision -> Hir.FloatDivide + | TypeInfer.IntegerRemainder -> Hir.IntRemainder + | TypeInfer.StructuralEquality -> Hir.StructuralEqual + | TypeInfer.NumericComparison "<" -> Hir.NumericLessThan + | TypeInfer.NumericComparison ">" -> Hir.NumericGreaterThan + | TypeInfer.NumericComparison "<=" -> Hir.NumericLessThanOrEqual + | TypeInfer.NumericComparison ">=" -> Hir.NumericGreaterThanOrEqual + | TypeInfer.BooleanOperation "&&" -> Hir.BooleanAnd + | TypeInfer.BooleanOperation "||" -> Hir.BooleanOr + | value -> invalidOp $"Unsupported resolved primitive operation '{value}'." + + let private resolvedLiteral = function + | TypeInfer.ResolvedUnit -> Hir.Unit + | TypeInfer.ResolvedInt value -> Hir.Int value + | TypeInfer.ResolvedFloat value -> Hir.Float value + | TypeInfer.ResolvedBool value -> Hir.Bool value + | TypeInfer.ResolvedString value -> Hir.String value + + let rec private lowerResolvedPattern state (pattern: TypeInfer.ResolvedPattern) : Hir.Pattern * Map = + let make node = ({ Type = representationType state pattern.Type; Span = pattern.Span; Node = node }: Hir.Pattern) + match pattern.Node with + | TypeInfer.ResolvedWildcard -> make Hir.Wildcard, Map.empty + | TypeInfer.ResolvedPatternBinding binding -> + let id = Hir.SymbolId binding.SymbolId + make (Hir.Binding(id, binding.Name)), Map.ofList [ binding.Name, id ] + | TypeInfer.ResolvedLiteralPattern value -> make (Hir.LiteralPattern(resolvedLiteral value)), Map.empty + | TypeInfer.ResolvedEmptyList -> make Hir.EmptyList, Map.empty + | TypeInfer.ResolvedNonePattern -> make Hir.NonePattern, Map.empty + | TypeInfer.ResolvedSomePattern item -> + let lowered, bindings = lowerResolvedPattern state item + make (Hir.SomePattern lowered), bindings + | TypeInfer.ResolvedConsPattern(head, tail) -> + let loweredHead, headBindings = lowerResolvedPattern state head + let loweredTail, tailBindings = lowerResolvedPattern state tail + make (Hir.ConsPattern(loweredHead, loweredTail)), Map.fold (fun env name id -> Map.add name id env) headBindings tailBindings + | TypeInfer.ResolvedTuplePattern items -> + let values = List.map (lowerResolvedPattern state) items + make (Hir.TuplePattern(List.map fst values)), values |> List.map snd |> List.fold (Map.fold (fun env name id -> Map.add name id env)) Map.empty + | TypeInfer.ResolvedRecordPattern fields -> + let values = fields |> List.map (fun (name, item) -> let lowered, bindings = lowerResolvedPattern state item in (name, lowered), bindings) + make (Hir.RecordPattern(List.map fst values)), values |> List.map snd |> List.fold (Map.fold (fun env name id -> Map.add name id env)) Map.empty + | TypeInfer.ResolvedMapPattern(clauses, tail) -> + let values = clauses |> List.map (fun (key, value) -> + let loweredKey, keyBindings = lowerResolvedPattern state key + let loweredValue, valueBindings = lowerResolvedPattern state value + (loweredKey, loweredValue), Map.fold (fun env name id -> Map.add name id env) keyBindings valueBindings) + let loweredTail, tailBindings = + match tail with + | Some item -> let lowered, bindings = lowerResolvedPattern state item in Some lowered, bindings + | None -> None, Map.empty + let bindings = tailBindings :: List.map snd values |> List.fold (Map.fold (fun env name id -> Map.add name id env)) Map.empty + make (Hir.MapPattern(List.map fst values, loweredTail)), bindings + | TypeInfer.ResolvedUnionPattern(typeName, caseName, payload) -> + match payload with + | Some item -> + let lowered, bindings = lowerResolvedPattern state item + make (Hir.UnionPattern(typeName, caseName, Some lowered)), bindings + | None -> make (Hir.UnionPattern(typeName, caseName, None)), Map.empty + | TypeInfer.ResolvedTypePattern patternType -> make (Hir.TypePattern(representationType state patternType)), Map.empty + + let rec private lowerResolvedExpression state (expression: TypeInfer.ResolvedExpression) : Hir.Expression = + let expressionType = representationType state expression.Type + let make node = ({ Type = expressionType; Span = expression.Span; Node = node }: Hir.Expression) + let lower = lowerResolvedExpression state + match expression.Node with + | TypeInfer.ResolvedConstant value -> make (Hir.Constant(resolvedLiteral value)) + | TypeInfer.ResolvedReference reference -> make (Hir.Reference(Hir.SymbolId reference.SymbolId)) + | TypeInfer.ResolvedLambda(binding, body) -> + make (Hir.Lambda(Hir.SymbolId binding.SymbolId, binding.Name, representationType state binding.Type, lower body)) + | TypeInfer.ResolvedApply(fn, argument) -> + let loweredArgument = lower argument + let argumentWithEvidence = + expression.RecordCoercion + |> Option.map (fun evidence -> + let targetType = representationType state evidence.TargetType + ({ Type = targetType; Span = loweredArgument.Span; Node = Hir.RecordConvert(loweredArgument, targetType) }: Hir.Expression)) + |> Option.defaultValue loweredArgument + let loweredFunction = lower fn + let loweredFunction = + match expression.RecordCoercion, loweredFunction.Type with + | Some _, TFun(_, result) -> { loweredFunction with Type = TFun(argumentWithEvidence.Type, result) } + | _ -> loweredFunction + make (Hir.Apply(loweredFunction, argumentWithEvidence)) + | TypeInfer.ResolvedPipe(argument, fn) -> + let loweredArgument = lower argument + let argumentWithEvidence = + expression.RecordCoercion + |> Option.map (fun evidence -> + let targetType = representationType state evidence.TargetType + ({ Type = targetType; Span = loweredArgument.Span; Node = Hir.RecordConvert(loweredArgument, targetType) }: Hir.Expression)) + |> Option.defaultValue loweredArgument + let loweredFunction = lower fn + let loweredFunction = + match expression.RecordCoercion, loweredFunction.Type with + | Some _, TFun(_, result) -> { loweredFunction with Type = TFun(argumentWithEvidence.Type, result) } + | _ -> loweredFunction + make (Hir.Pipe(argumentWithEvidence, loweredFunction)) + | TypeInfer.ResolvedIf(condition, whenTrue, whenFalse) -> make (Hir.If(lower condition, lower whenTrue, lower whenFalse)) + | TypeInfer.ResolvedPrimitive(operation, arguments) -> make (Hir.Primitive(resolvedOperation operation, List.map lower arguments)) + | TypeInfer.ResolvedTuple items -> make (Hir.Tuple(List.map lower items)) + | TypeInfer.ResolvedList items -> make (Hir.List(List.map lower items)) + | TypeInfer.ResolvedRecord fields -> make (Hir.Record(fields |> List.map (fun (name, value) -> name, lower value))) + | TypeInfer.ResolvedFieldGet(target, name) -> make (Hir.FieldGet(lower target, name)) + | TypeInfer.ResolvedSome item -> make (Hir.SomeValue(lower item)) + | TypeInfer.ResolvedNone -> make Hir.NoneValue + | TypeInfer.ResolvedCons(head, tail) -> make (Hir.Cons(lower head, lower tail)) + | TypeInfer.ResolvedAppend(left, right) -> make (Hir.Append(lower left, lower right)) + | TypeInfer.ResolvedLet(binding, recursive, value, body) -> + make (Hir.Let(Hir.SymbolId binding.SymbolId, binding.Name, recursive, lower value, lower body)) + | TypeInfer.ResolvedLetRecursiveGroup(bindings, body) -> + let values = bindings |> List.map (fun binding -> Hir.SymbolId binding.Binding.SymbolId, binding.Binding.Name, representationType state binding.Binding.Type, lower binding.Value) + make (Hir.LetRecursiveGroup(values, lower body)) + | TypeInfer.ResolvedFail value -> make (Hir.Fail(lower value)) + | TypeInfer.ResolvedMatch(target, cases) -> + let loweredCases = + cases |> List.map (fun case -> + let pattern, _ = lowerResolvedPattern state case.Pattern + ({ Pattern = pattern; Guard = Option.map lower case.Guard; Body = lower case.Body; Span = case.Span }: Hir.MatchCase)) + make (Hir.Match(lower target, loweredCases)) + | TypeInfer.ResolvedRange(first, last) -> make (Hir.Range(lower first, lower last)) + | TypeInfer.ResolvedRecordUpdate(preserveTargetRepresentation, target, fields) -> + let loweredTarget = lower target + let resultType = if preserveTargetRepresentation then loweredTarget.Type else expressionType + ({ Type = resultType + Span = expression.Span + Node = Hir.RecordUpdate(loweredTarget, fields |> List.map (fun (name, value) -> name, lower value)) }: Hir.Expression) + | TypeInfer.ResolvedIndexGet(target, index) -> make (Hir.IndexGet(lower target, lower index)) + | TypeInfer.ResolvedInterpolate parts -> + parts |> List.map (function TypeInfer.ResolvedTextPart text -> Hir.TextPart text | TypeInfer.ResolvedValuePart value -> Hir.ValuePart(lower value)) |> Hir.Interpolate |> make + | TypeInfer.ResolvedMap entries -> + entries |> List.map (function TypeInfer.ResolvedKeyValue(key, value) -> Hir.KeyValue(lower key, lower value) | TypeInfer.ResolvedSpread value -> Hir.Spread(lower value)) |> Hir.Map |> make + | TypeInfer.ResolvedForEach(binding, source, body) -> + make (Hir.ForEach(Hir.SymbolId binding.SymbolId, binding.Name, representationType state binding.Type, lower source, lower body)) + | TypeInfer.ResolvedTypeToken tokenType -> make (Hir.TypeToken(representationType state tokenType)) + + let lower (externs: CompilerExtern list) (resolved: TypeInfer.ResolvedProgram) : Result = + let exportMetadata name span enabled = if enabled then Some({ Name = name; Span = span }: Hir.ExportMetadata) else None + let attributesOf (statement: TypeInfer.ResolvedStatement) = + statement.Attributes + |> List.map (fun attribute -> ({ Name = attribute.Name; Arguments = attribute.Arguments; Span = attribute.Span }: Hir.AttributeMetadata)) + let nextSynthetic = resolved.Symbols |> List.map _.SymbolId |> function [] -> 0 | values -> List.max values + 1 + let state = + { NextSymbol = nextSynthetic + AvailableSymbols = resolved.Symbols + Diagnostics = [] } + let resolvedSchemes = + resolved.Symbols + |> List.choose (fun symbol -> symbol.Scheme |> Option.map (fun scheme -> Hir.SymbolId symbol.SymbolId, scheme)) + |> Map.ofList + let schemeFor id fallback = resolvedSchemes |> Map.tryFind id |> Option.defaultValue fallback + let syntheticSpan = Span.mk (Span.pos 0 0) (Span.pos 0 0) + let builtins = + BuiltinSignatures.builtinSchemes + |> Map.toList + |> List.sortBy fst + |> List.map (fun (name, _) -> name, findSymbol state TypeInfer.BuiltinSymbol name syntheticSpan) + |> Map.ofList + let externSymbols = externs |> List.sortBy _.Name |> List.map (fun value -> value.Name, findSymbol state TypeInfer.ExternSymbol value.Name syntheticSpan) |> Map.ofList + let typeDefinitions = + resolved.ResolvedStatements + |> List.choose (fun statement -> + match statement.Node with + | TypeInfer.ResolvedTypeDeclaration definition -> Some(statement, definition) + | _ -> None) + let declaredTypeNames = typeDefinitions |> List.map (snd >> _.Binding.Name) |> Set.ofList + let builtinTypeDefinitions = + [ "Environment", TRecord(Map.ofList [ "ScriptName", TOption TString; "Arguments", TList TString ]) + "FsKind", TUnion("FsKind", Map.ofList [ "File", Some TString; "Directory", Some TString; "Missing", None ]) ] + |> List.filter (fun (name, _) -> not (Set.contains name declaredTypeNames)) + |> List.map (fun (name, definition) -> name, definition, findSymbol state TypeInfer.TypeSymbol name syntheticSpan) + let unionDefinitions = + typeDefinitions + |> List.choose (fun (statement, definition) -> + match definition.Definition with + | TUnion(name, cases) -> Some(statement, definition, name, cases) + | _ -> None) + let constructorDefinitions = + let referencedSymbols = resolved.SymbolReferences |> List.map _.SymbolId |> Set.ofList + let builtins = + builtinTypeDefinitions + |> List.collect (fun (name, definition, _) -> + match definition with + | TUnion(_, cases) -> + cases + |> Map.toList + |> List.map (fun (caseName, payload) -> + name, caseName, payload, syntheticSpan, + findSymbol state TypeInfer.UnionCaseSymbol $"{name}.{caseName}" syntheticSpan) + |> List.filter (fun (_, _, _, _, id) -> Set.contains (Hir.symbolNumber id) referencedSymbols) + | _ -> []) + let source = + unionDefinitions + |> List.collect (fun (_, definition, name, cases) -> + cases + |> Map.toList + |> List.map (fun (caseName, payload) -> + name, caseName, payload, definition.Binding.Span, + findSymbol state TypeInfer.UnionCaseSymbol $"{name}.{caseName}" definition.Binding.Span)) + builtins @ source + let mutable declarations = + let builtinDeclarations = + BuiltinSignatures.builtinSchemes |> Map.toList |> List.sortBy fst |> List.map (fun (name, scheme) -> + let (Forall(_, valueType)) = scheme + let span = Span.mk (Span.pos 0 0) (Span.pos 0 0) + ({ Id = builtins.[name]; Name = name; Scheme = schemeFor builtins.[name] scheme; Attributes = []; IsRecursive = false; IsExported = false; IsPure = false; ExternalArity = None; Export = None; Span = span; Value = { Type = valueType; Span = span; Node = Hir.Intrinsic name } }: Hir.Declaration)) + let externalDeclarations = + externs |> List.sortBy _.Name |> List.map (fun external -> + let (Forall(_, valueType)) = external.Scheme + let span = Span.mk (Span.pos 0 0) (Span.pos 0 0) + let node = + match external.Kind with + | RuntimeContextIntrinsic -> Hir.RuntimeContext + | PortableRuntimeIntrinsic -> Hir.Intrinsic external.Name + | UnsupportedHostExtern -> Hir.HostExternal(external.Name, external.Arity) + ({ Id = externSymbols.[external.Name]; Name = external.Name; Scheme = schemeFor externSymbols.[external.Name] external.Scheme; Attributes = []; IsRecursive = false; IsExported = false; IsPure = Set.contains external.Name resolved.Purity.PureFunctions; ExternalArity = Some external.Arity; Export = None; Span = span; Value = { Type = valueType; Span = span; Node = node } }: Hir.Declaration)) + builtinDeclarations @ externalDeclarations @ (constructorDefinitions |> List.map (fun (typeName, caseName, payloadType, span, id) -> + let unionType = TNamed typeName + let value = + match payloadType with + | None -> ({ Type = unionType; Span = span; Node = Hir.UnionCase(typeName, caseName, None) }: Hir.Expression) + | Some itemType -> + let parameter = newSymbol state + let body = ({ Type = unionType; Span = span; Node = Hir.UnionCase(typeName, caseName, Some({ Type = itemType; Span = span; Node = Hir.Reference parameter })) }: Hir.Expression) + ({ Type = TFun(itemType, unionType); Span = span; Node = Hir.Lambda(parameter, "value", itemType, body) }: Hir.Expression) + ({ Id = id; Name = $"{typeName}.{caseName}"; Scheme = Types.generalize Map.empty value.Type; Attributes = []; IsRecursive = false; IsExported = false; IsPure = false; ExternalArity = None; Export = None; Span = span; Value = value }: Hir.Declaration))) + let mutable entry: Hir.Expression option = None + let mutable errors = [] + for resolvedStatement in resolved.ResolvedStatements do + let isExported = resolvedStatement.Export.IsSome + match resolvedStatement.Node with + | TypeInfer.ResolvedValueDeclaration declaration -> + let binding = declaration.Binding + let value = lowerResolvedExpression state declaration.Value + declarations <- declarations @ + [ ({ Id = Hir.SymbolId binding.SymbolId + Name = binding.Name + Scheme = declaration.Scheme + Attributes = attributesOf resolvedStatement + IsRecursive = declaration.IsRecursive + IsExported = isExported + IsPure = false + ExternalArity = None + Export = exportMetadata binding.Name binding.Span isExported + Span = binding.Span + Value = value }: Hir.Declaration) ] + | TypeInfer.ResolvedExpressionStatement expression -> + let value = lowerResolvedExpression state expression + let id = newSymbol state + let name = $"$expression{Hir.symbolNumber id}" + declarations <- declarations @ + [ ({ Id = id + Name = name + Scheme = Types.generalize Map.empty value.Type + Attributes = [] + IsRecursive = false + IsExported = false + IsPure = false + ExternalArity = None + Export = None + Span = value.Span + Value = value }: Hir.Declaration) ] + entry <- Some { Type = value.Type; Span = value.Span; Node = Hir.Reference id } + | TypeInfer.ResolvedPatternDeclaration declaration -> + let span = resolvedStatement.Span + let value = lowerResolvedExpression state declaration.Value + let loweredPattern, patternBindings = lowerResolvedPattern state declaration.Pattern + let bindingType = value.Type + let temporaryId = newSymbol state + declarations <- declarations @ + [ ({ Id = temporaryId + Name = $"$pattern{Hir.symbolNumber temporaryId}" + Scheme = Types.generalize Map.empty bindingType + Attributes = [] + IsRecursive = false + IsExported = false + IsPure = false + ExternalArity = None + Export = None + Span = span + Value = value }: Hir.Declaration) ] + let target = ({ Type = bindingType; Span = span; Node = Hir.Reference temporaryId }: Hir.Expression) + let unitBody = ({ Type = TUnit; Span = span; Node = Hir.Constant Hir.Unit }: Hir.Expression) + let check = ({ Type = TUnit; Span = span; Node = Hir.Match(target, [ { Pattern = loweredPattern; Guard = None; Body = unitBody; Span = span } ]) }: Hir.Expression) + let checkId = newSymbol state + declarations <- declarations @ + [ ({ Id = checkId; Name = $"$patternCheck{Hir.symbolNumber checkId}"; Scheme = Forall([], TUnit); Attributes = []; IsRecursive = false; IsExported = false; IsPure = false; ExternalArity = None; Export = None; Span = span; Value = check }: Hir.Declaration) ] + for binding, scheme in declaration.Bindings do + let name = binding.Name + let inferred = representationType state binding.Type + match patternBindings |> Map.tryFind name with + | None -> errors <- errors @ [ Diagnostic.hir "FSH1006" $"Pattern binding '{name}' was not resolved." (Some span) ] + | Some patternId -> + let body = ({ Type = inferred; Span = span; Node = Hir.Reference patternId }: Hir.Expression) + let projection = ({ Type = inferred; Span = span; Node = Hir.Match(target, [ { Pattern = loweredPattern; Guard = None; Body = body; Span = span } ]) }: Hir.Expression) + declarations <- declarations @ + [ ({ Id = Hir.SymbolId binding.SymbolId; Name = name; Scheme = scheme; Attributes = attributesOf resolvedStatement; IsRecursive = false; IsExported = isExported; IsPure = false; ExternalArity = None; Export = (exportMetadata name span isExported); Span = span; Value = projection }: Hir.Declaration) ] + | TypeInfer.ResolvedRecursiveDeclarations recursiveDeclarations -> + for declaration in recursiveDeclarations do + let binding = declaration.Binding + let value = lowerResolvedExpression state declaration.Value + declarations <- declarations @ + [ ({ Id = Hir.SymbolId binding.SymbolId + Name = binding.Name + Scheme = declaration.Scheme + Attributes = attributesOf resolvedStatement + IsRecursive = true + IsExported = isExported + IsPure = false + ExternalArity = None + Export = exportMetadata binding.Name binding.Span isExported + Span = binding.Span + Value = value }: Hir.Declaration) ] + | TypeInfer.ResolvedImportedDeclaration declaration -> + let binding = declaration.Binding + declarations <- declarations @ + [ ({ Id = Hir.SymbolId binding.SymbolId + Name = binding.Name + Scheme = declaration.Scheme + Attributes = attributesOf resolvedStatement + IsRecursive = false + IsExported = false + IsPure = false + ExternalArity = None + Export = None + Span = binding.Span + Value = { Type = representationType state binding.Type; Span = binding.Span; Node = Hir.TargetImport(declaration.Import.ModulePath, declaration.Import.MemberName) } }: Hir.Declaration) ] + | TypeInfer.ResolvedTypeDeclaration _ -> () + let importedRecords = + typeDefinitions + |> List.choose (fun (_, definition) -> + definition.Import + |> Option.map (fun import -> + ({ Name = definition.Binding.Name + ModulePath = import.ModulePath + MemberName = import.MemberName + IsUnion = match definition.Definition with TUnion _ -> true | _ -> false + Fields = definition.Fields + Span = definition.Binding.Span }: Hir.ImportedRecord))) + let hirTypes = + (builtinTypeDefinitions + |> List.map (fun (name, definition, id) -> + ({ Id = id + Name = name + IsRecursive = false + IsPure = false + Definition = definition + Attributes = [] + Import = None + Span = syntheticSpan }: Hir.TypeDeclaration))) + @ (typeDefinitions + |> List.map (fun (statement, definition) -> + ({ Id = Hir.SymbolId definition.Binding.SymbolId + Name = definition.Binding.Name + IsRecursive = definition.IsRecursive + IsPure = Set.contains definition.Binding.Name resolved.Purity.PureTypes + Definition = definition.Definition + Attributes = attributesOf statement + Import = importedRecords |> List.tryFind (fun imported -> imported.Name = definition.Binding.Name) + Span = definition.Binding.Span }: Hir.TypeDeclaration))) + let diagnostics = errors @ state.Diagnostics + if diagnostics.IsEmpty then Ok { Types = hirTypes; ImportedRecords = importedRecords; Declarations = declarations; Entry = entry } + else Error diagnostics diff --git a/src/FScript.Compiler/HirValidation.fs b/src/FScript.Compiler/HirValidation.fs new file mode 100644 index 0000000..df6d0f5 --- /dev/null +++ b/src/FScript.Compiler/HirValidation.fs @@ -0,0 +1,201 @@ +namespace FScript.Compiler + +open FScript.Language + +module HirValidation = + let rec private compatible left right = + match left, right with + | TRecordShape _, TNamed _ | TNamed _, TRecordShape _ -> true + | TRecordShape(_, left, _), TRecord right | TRecord right, TRecordShape(_, left, _) -> + left |> Map.forall (fun name item -> right |> Map.tryFind name |> Option.exists (compatible item)) + | TVar _, _ | _, TVar _ -> true + | TFun(la, lr), TFun(ra, rr) -> compatible la ra && compatible lr rr + | TTuple left, TTuple right -> left.Length = right.Length && List.forall2 compatible left right + | TList left, TList right | TOption left, TOption right | TTask left, TTask right -> compatible left right + | TMap(lk, lv), TMap(rk, rv) -> compatible lk rk && compatible lv rv + | TRecord left, TRecord right -> left.Count = right.Count && (left |> Map.forall (fun name item -> right |> Map.tryFind name |> Option.exists (compatible item))) + | TUnion(ln, _), TUnion(rn, _) -> ln = rn + | TNamed name, TUnion(actual, _) | TUnion(actual, _), TNamed name -> name = actual + | TNamed _, TRecord _ | TRecord _, TNamed _ -> true + | _ -> left = right + + let private validSpan (span: Span) = + span.Start.Line >= 0 && span.Start.Column >= 0 && span.End.Line >= 0 && span.End.Column >= 0 + && (span.Start.File <> span.End.File || span.End.Line > span.Start.Line || (span.End.Line = span.Start.Line && span.End.Column >= span.Start.Column)) + + let validate (program: Hir.Program) = + let declarationIds = program.Declarations |> List.map (fun value -> value.Id) + let typeIds = program.Types |> List.map _.Id + let allIds = typeIds @ declarationIds + let duplicateIds = allIds |> List.countBy id |> List.filter (fun (_, count) -> count > 1) + let invalidTypes = + (program.Types |> List.map _.Name |> List.distinct |> List.length) <> program.Types.Length + || program.Types |> List.exists (fun declaration -> + not (validSpan declaration.Span) + || match declaration.Definition with + | TRecord _ | THostManaged _ -> false + | TUnion(name, _) -> name <> declaration.Name + | _ -> true + || declaration.Import |> Option.exists (fun imported -> imported.Name <> declaration.Name)) + let invalidAttributes = + [ yield! program.Types |> List.collect _.Attributes + yield! program.Declarations |> List.collect _.Attributes ] + |> List.exists (fun attribute -> System.String.IsNullOrWhiteSpace attribute.Name || not (validSpan attribute.Span)) + || program.Declarations |> List.exists (fun declaration -> + declaration.IsExported <> (declaration.Attributes |> List.exists (fun attribute -> attribute.Name = "Export"))) + let invalidImports = + program.ImportedRecords |> List.exists (fun record -> System.String.IsNullOrWhiteSpace(record.ModulePath) || System.String.IsNullOrWhiteSpace(record.MemberName)) + || (program.ImportedRecords |> List.map _.Name |> List.distinct |> List.length) <> program.ImportedRecords.Length + let knownTypes = program.Types |> List.map _.Name |> Set.ofList + let rec validType (quantified: Set) = function + | TVar variable -> variable >= 0 && (quantified.IsEmpty || Set.contains variable quantified) + | TFun(argument, result) -> validType quantified argument && validType quantified result + | TTuple items -> items |> List.forall (validType quantified) + | TList item | TOption item | TTask item -> validType quantified item + | TMap(key, value) -> validType quantified key && validType quantified value + | TRecord fields -> fields |> Map.forall (fun name fieldType -> not (System.String.IsNullOrWhiteSpace name) && validType quantified fieldType) + | TUnion(name, cases) -> + Set.contains name knownTypes + && cases |> Map.forall (fun caseName payload -> not (System.String.IsNullOrWhiteSpace caseName) && payload |> Option.forall (validType quantified)) + | TNamed name -> Set.contains name knownTypes + | _ -> true + let validClosedType = validType Set.empty + let validScheme (Forall(variables, valueType)) = + variables = [ 0 .. variables.Length - 1 ] && validType (Set.ofList variables) valueType + let rec validPattern (pattern: Hir.Pattern) = + validSpan pattern.Span + && validClosedType pattern.Type + && match pattern.Node with + | Hir.ConsPattern(head, tail) -> validPattern head && validPattern tail + | Hir.TuplePattern items -> items |> List.forall validPattern + | Hir.RecordPattern fields -> fields |> List.forall (fun (name, value) -> not (System.String.IsNullOrWhiteSpace name) && validPattern value) + | Hir.MapPattern(clauses, tail) -> clauses |> List.forall (fun (key, value) -> validPattern key && validPattern value) && tail |> Option.forall validPattern + | Hir.SomePattern item -> validPattern item + | Hir.UnionPattern(typeName, caseName, payload) -> Set.contains typeName knownTypes && not (System.String.IsNullOrWhiteSpace caseName) && payload |> Option.forall validPattern + | Hir.TypePattern patternType -> validClosedType patternType + | _ -> true + let rec validExpression (expression: Hir.Expression) = + let valid = validExpression + validSpan expression.Span + && validClosedType expression.Type + && match expression.Node with + | Hir.Lambda(_, name, parameterType, body) -> not (System.String.IsNullOrWhiteSpace name) && validClosedType parameterType && valid body + | Hir.Apply(fn, argument) | Hir.Pipe(argument, fn) | Hir.Cons(fn, argument) | Hir.Append(fn, argument) + | Hir.Range(fn, argument) | Hir.IndexGet(fn, argument) -> valid fn && valid argument + | Hir.If(condition, whenTrue, whenFalse) -> valid condition && valid whenTrue && valid whenFalse + | Hir.Primitive(_, arguments) | Hir.Tuple arguments | Hir.List arguments -> arguments |> List.forall valid + | Hir.Record fields -> fields |> List.forall (fun (name, value) -> not (System.String.IsNullOrWhiteSpace name) && valid value) + | Hir.FieldGet(target, name) -> valid target && not (System.String.IsNullOrWhiteSpace name) + | Hir.SomeValue target | Hir.Fail target -> valid target + | Hir.Let(_, name, _, binding, body) -> not (System.String.IsNullOrWhiteSpace name) && valid binding && valid body + | Hir.LetRecursiveGroup(bindings, body) -> + bindings |> List.forall (fun (_, name, bindingType, value) -> not (System.String.IsNullOrWhiteSpace name) && validClosedType bindingType && valid value) + && valid body + | Hir.Match(target, cases) -> + valid target + && cases |> List.forall (fun case -> validSpan case.Span && validPattern case.Pattern && case.Guard |> Option.forall valid && valid case.Body) + | Hir.RecordUpdate(target, fields) -> valid target && fields |> List.forall (fun (name, value) -> not (System.String.IsNullOrWhiteSpace name) && valid value) + | Hir.RecordConvert(target, targetType) -> valid target && validClosedType targetType + | Hir.Interpolate parts -> parts |> List.forall (function Hir.TextPart _ -> true | Hir.ValuePart value -> valid value) + | Hir.UnionCase(typeName, caseName, payload) -> Set.contains typeName knownTypes && not (System.String.IsNullOrWhiteSpace caseName) && payload |> Option.forall valid + | Hir.Map entries -> entries |> List.forall (function Hir.KeyValue(key, value) -> valid key && valid value | Hir.Spread value -> valid value) + | Hir.ForEach(_, name, itemType, source, body) -> not (System.String.IsNullOrWhiteSpace name) && validClosedType itemType && valid source && valid body + | Hir.TypeToken tokenType -> validClosedType tokenType + | _ -> true + let invalidTypeReferences = + program.Types |> List.exists (fun declaration -> not (validClosedType declaration.Definition)) + || program.ImportedRecords |> List.exists (fun record -> record.Fields |> List.exists (snd >> validClosedType >> not)) + || program.Declarations |> List.exists (fun declaration -> not (validScheme declaration.Scheme) || not (validExpression declaration.Value)) + || program.Entry |> Option.exists (validExpression >> not) + if invalidAttributes then + Error [ Diagnostic.hir "FSH1108" "HIR structured attribute metadata is invalid or inconsistent." None ] + elif program.Declarations |> List.exists (fun declaration -> (declaration.IsPure && (declaration.ExternalArity.IsNone || (match declaration.Value.Node with Hir.HostExternal _ | Hir.TargetImport _ -> false | _ -> true))) || (declaration.ExternalArity |> Option.exists (fun arity -> arity<0 || (match declaration.Value.Node with Hir.HostExternal(_,actual) -> actual<>arity | Hir.TargetImport _ | Hir.Intrinsic _ | Hir.RuntimeContext -> false | _ -> true)))) then + Error [ Diagnostic.hir "FSH1110" "Pure contracts may only annotate external function bindings." None ] + elif invalidTypes then + Error [ Diagnostic.hir "FSH1107" "HIR type declarations must be unique, well-formed, and consistently linked." None ] + elif invalidImports then + Error [ Diagnostic.hir "FSH1105" "HIR imported record linkage must be complete and uniquely named." None ] + elif invalidTypeReferences then + Error [ Diagnostic.hir "FSH1109" "HIR contains an unresolved or invalid semantic type, nested span, or field name." None ] + elif not duplicateIds.IsEmpty then + Error [ Diagnostic.hir "FSH1101" "HIR declaration IDs must be unique." None ] + elif program.Declarations |> List.exists (fun declaration -> declaration.IsExported <> declaration.Export.IsSome || (declaration.Export |> Option.exists (fun export -> export.Name <> declaration.Name || not (validSpan export.Span)))) then + Error [ Diagnostic.hir "FSH1106" "HIR export metadata is inconsistent." None ] + elif program.Declarations |> List.exists (fun declaration -> not (validSpan declaration.Span && validSpan declaration.Value.Span)) then + Error [ Diagnostic.hir "FSH1103" "HIR contains an invalid source span." None ] + elif program.Declarations |> List.exists (fun declaration -> let (Forall(_, declaredType)) = declaration.Scheme in not (compatible declaredType declaration.Value.Type)) then + Error [ Diagnostic.hir "FSH1104" "HIR declaration scheme does not match its value type." None ] + else + let rec references (expression: Hir.Expression) = + match expression.Node with + | Hir.Constant _ -> Set.empty + | Hir.Reference id -> Set.singleton id + | Hir.Lambda(parameter, _, _, body) -> references body |> Set.remove parameter + | Hir.Apply(fn, argument) | Hir.Pipe(argument, fn) -> Set.union (references fn) (references argument) + | Hir.If(condition, whenTrue, whenFalse) -> + Set.unionMany [ references condition; references whenTrue; references whenFalse ] + | Hir.Primitive(_, arguments) -> arguments |> List.map references |> Set.unionMany + | Hir.Tuple items | Hir.List items -> items |> List.map references |> Set.unionMany + | Hir.Record fields -> fields |> List.map (snd >> references) |> Set.unionMany + | Hir.FieldGet(target, _) | Hir.SomeValue target -> references target + | Hir.NoneValue -> Set.empty + | Hir.Cons(head, tail) | Hir.Append(head, tail) -> Set.union (references head) (references tail) + | Hir.Let(id, _, recursive, binding, body) -> + let bindingReferences = + let value = references binding + if recursive then Set.remove id value else value + Set.union bindingReferences (references body |> Set.remove id) + | Hir.LetRecursiveGroup(bindings, body) -> + let ids = bindings |> List.map (fun (id, _, _, _) -> id) |> Set.ofList + let allReferences = + references body :: (bindings |> List.map (fun (_, _, _, value) -> references value)) + |> Set.unionMany + Set.difference allReferences ids + | Hir.Fail value -> references value + | Hir.Match(target, cases) -> + let rec bindings (pattern: Hir.Pattern) = + match pattern.Node with + | Hir.Binding(id, _) -> Set.singleton id + | Hir.ConsPattern(head, tail) -> Set.union (bindings head) (bindings tail) + | Hir.TuplePattern items -> items |> List.map bindings |> Set.unionMany + | Hir.RecordPattern fields -> fields |> List.map (snd >> bindings) |> Set.unionMany + | Hir.MapPattern(clauses, tail) -> + let clauseBindings = clauses |> List.collect (fun (key, value) -> [ bindings key; bindings value ]) + tail |> Option.map bindings |> Option.toList |> (@) clauseBindings |> Set.unionMany + | Hir.SomePattern item -> bindings item + | Hir.UnionPattern(_, _, payload) -> payload |> Option.map bindings |> Option.defaultValue Set.empty + | Hir.TypePattern _ -> Set.empty + | _ -> Set.empty + let caseReferences (case: Hir.MatchCase) = + let bound = bindings case.Pattern + let values = Set.union (case.Guard |> Option.map references |> Option.defaultValue Set.empty) (references case.Body) + Set.difference values bound + Set.union (references target) (cases |> List.map caseReferences |> Set.unionMany) + | Hir.Range(startValue, endValue) | Hir.IndexGet(startValue, endValue) -> Set.union (references startValue) (references endValue) + | Hir.RecordUpdate(target, fields) -> Set.union (references target) (fields |> List.map (snd >> references) |> Set.unionMany) + | Hir.RecordConvert(target, _) -> references target + | Hir.Interpolate parts -> parts |> List.choose (function Hir.TextPart _ -> None | Hir.ValuePart item -> Some(references item)) |> Set.unionMany + | Hir.UnionCase(_, _, payload) -> payload |> Option.map references |> Option.defaultValue Set.empty + | Hir.Map entries -> + entries |> List.map (function Hir.KeyValue(key, value) -> Set.union (references key) (references value) | Hir.Spread value -> references value) |> Set.unionMany + | Hir.Intrinsic _ -> Set.empty + | Hir.HostExternal _ -> Set.empty + | Hir.RuntimeContext -> Set.empty + | Hir.TargetImport _ -> Set.empty + | Hir.ForEach(id, _, _, source, body) -> Set.union (references source) (references body |> Set.remove id) + | Hir.TypeToken _ -> Set.empty + let declared = declarationIds |> Set.ofList + let unresolved = + [ yield! program.Declarations |> List.collect (fun value -> references value.Value |> Set.toList) + match program.Entry with + | Some value -> yield! references value |> Set.toList + | None -> () ] + |> Set.ofList + |> Set.filter (fun id -> not (Set.contains id declared)) + if unresolved.IsEmpty then Ok program + else + let identifiers = + unresolved + |> Seq.map (Hir.symbolNumber >> string) + |> String.concat ", " + Error [ Diagnostic.hir "FSH1102" $"HIR contains unresolved symbol references: {identifiers}." None ] diff --git a/src/FScript.Compiler/IrArtifact.fs b/src/FScript.Compiler/IrArtifact.fs new file mode 100644 index 0000000..4179589 --- /dev/null +++ b/src/FScript.Compiler/IrArtifact.fs @@ -0,0 +1,600 @@ +namespace FScript.Compiler + +open System +open System.IO +open System.Text +open System.Text.Json +open FScript.Language + +module IrArtifact = + [] + let Format = "fscript-lir" + [] + let Version = 1 + + let private assemblyVersion (assembly: Reflection.Assembly) = + match assembly.GetName().Version with null -> "0.0.0" | value -> value.ToString() + + let private normalizePath (path: string) = path.Replace('\\', '/') + + let private sourceMetadata (program: Lir.Program) = + let paths = + [ yield! program.Types |> List.choose (fun declaration -> declaration.Span.Start.File) + yield! program.ImportedRecords |> List.choose (fun declaration -> declaration.Span.Start.File) + yield! program.Functions |> List.choose (fun fn -> fn.Span.Start.File) + yield! program.Declarations |> List.choose (fun declaration -> declaration.Span.Start.File) + match program.Entry with Some entry -> yield! entry.Span.Start.File |> Option.toList | None -> () ] + |> List.distinct + |> List.sort + paths |> List.choose (fun path -> + if File.Exists path then + let hash = + File.ReadAllBytes path + |> Security.Cryptography.SHA256.HashData + |> Convert.ToHexString + |> _.ToLowerInvariant() + Some(normalizePath path, hash) + else None) + + let private dependencies (program: Lir.Program) = + [ yield! program.ImportedRecords |> List.map (fun record -> $"target:{record.ModulePath}:{record.MemberName}") + yield! program.Declarations |> List.choose (fun declaration -> + match declaration.Value.Node with + | Lir.HostExternal(name, _) -> Some $"host:{name}" + | Lir.TargetImport(modulePath, memberName) -> Some $"target:{modulePath}:{memberName}" + | _ -> None) ] + |> List.distinct + |> List.sort + + let private writeOptionString (writer: Utf8JsonWriter) (name: string) (value: string option) = + match value with + | Some text -> writer.WriteString(name, text) + | None -> writer.WriteNull(name) + + let rec private writeType (writer: Utf8JsonWriter) value = + writer.WriteStartObject() + let kind, arguments, name = + match value with + | TUnit -> "unit", [], None | TInt -> "int", [], None | TFloat -> "float", [], None + | TBool -> "bool", [], None | TString -> "string", [], None | TTypeToken -> "type-token", [], None + | TList item -> "list", [ item ], None | TTask item -> "task", [ item ], None + | TOption item -> "option", [ item ], None | TTuple items -> "tuple", items, None + | TMap(key, item) -> "map", [ key; item ], None | TFun(argument, result) -> "function", [ argument; result ], None + | TNamed typeName -> "named", [], Some typeName + | TVar id -> "variable", [], Some(string id) + | TNumeric id -> "numeric", [], Some(string id) + | TRecordShape(id, fields, constructible) -> + writer.WriteString("kind", "record-shape") + writer.WriteNumber("id", id); writer.WriteBoolean("constructible", constructible) + writer.WriteStartArray("fields") + for fieldName, fieldType in fields |> Map.toList do + writer.WriteStartObject(); writer.WriteString("name", fieldName); writer.WritePropertyName("type") + writeType writer fieldType; writer.WriteEndObject() + writer.WriteEndArray(); writer.WriteEndObject() + "", [], None + | TRecord fields | THostManaged(_, fields) -> + match value with + | THostManaged(name, _) -> writer.WriteString("kind", "host-managed"); writer.WriteString("name", name) + | _ -> writer.WriteString("kind", "record") + writer.WriteStartArray("fields") + for fieldName, fieldType in fields |> Map.toList do + writer.WriteStartObject(); writer.WriteString("name", fieldName); writer.WritePropertyName("type") + writeType writer fieldType; writer.WriteEndObject() + writer.WriteEndArray(); writer.WriteEndObject() + "", [], None + | TUnion(typeName, cases) -> + writer.WriteString("kind", "union"); writer.WriteString("name", typeName) + writer.WriteStartArray("cases") + for caseName, payload in cases |> Map.toList do + writer.WriteStartObject(); writer.WriteString("name", caseName) + match payload with + | Some payloadType -> writer.WritePropertyName("payload"); writeType writer payloadType + | None -> writer.WriteNull("payload") + writer.WriteEndObject() + writer.WriteEndArray(); writer.WriteEndObject() + "", [], None + if kind <> "" then + writer.WriteString("kind", kind) + match name with Some value -> writer.WriteString("name", value) | None -> () + if not arguments.IsEmpty then + writer.WriteStartArray("arguments"); arguments |> List.iter (writeType writer); writer.WriteEndArray() + writer.WriteEndObject() + + let private writePosition (writer: Utf8JsonWriter) value = + writer.WriteStartObject(); writeOptionString writer "file" value.File + writer.WriteNumber("line", value.Line); writer.WriteNumber("column", value.Column); writer.WriteEndObject() + + let private writeSpan (writer: Utf8JsonWriter) value = + writer.WriteStartObject(); writer.WritePropertyName("start"); writePosition writer value.Start + writer.WritePropertyName("end"); writePosition writer value.End; writer.WriteEndObject() + + let private constantName = function + | Lir.Unit -> "unit" | Lir.Int _ -> "int" | Lir.Float _ -> "float" | Lir.Bool _ -> "bool" | Lir.String _ -> "string" + + let private writeConstantValue (writer: Utf8JsonWriter) constant = + writer.WriteString("constantKind", constantName constant) + match constant with + | Lir.Unit -> () | Lir.Int value -> writer.WriteNumber("intValue", value) | Lir.Float value -> writer.WriteNumber("floatValue", value) + | Lir.Bool value -> writer.WriteBoolean("boolValue", value) | Lir.String value -> writer.WriteString("stringValue", value) + + let private writeProjection (writer: Utf8JsonWriter) (name: string) (steps: Lir.ProjectionStep list) = + writer.WriteStartArray(name) + for step in steps do + writer.WriteStartObject() + match step with + | Lir.ListHead -> writer.WriteString("kind", "list-head") + | Lir.ListTail -> writer.WriteString("kind", "list-tail") + | Lir.TupleItem index -> writer.WriteString("kind", "tuple-item"); writer.WriteNumber("index", index) + | Lir.RecordField name -> writer.WriteString("kind", "record-field"); writer.WriteString("name", name) + | Lir.OptionValue -> writer.WriteString("kind", "option-value") + | Lir.UnionPayload -> writer.WriteString("kind", "union-payload") + writer.WriteEndObject() + writer.WriteEndArray() + + let private writeCheck (writer: Utf8JsonWriter) check = + writer.WriteStartObject() + match check with + | Lir.LiteralCheck(projection, value) -> writer.WriteString("kind", "literal"); writeProjection writer "projection" projection; writeConstantValue writer value + | Lir.EmptyListCheck projection -> writer.WriteString("kind", "empty-list"); writeProjection writer "projection" projection + | Lir.NonEmptyListCheck projection -> writer.WriteString("kind", "non-empty-list"); writeProjection writer "projection" projection + | Lir.TupleArityCheck(projection, arity) -> writer.WriteString("kind", "tuple-arity"); writeProjection writer "projection" projection; writer.WriteNumber("arity", arity) + | Lir.RecordFieldCheck(projection, name) -> writer.WriteString("kind", "record-field"); writeProjection writer "projection" projection; writer.WriteString("name", name) + | Lir.SomeCheck projection -> writer.WriteString("kind", "some"); writeProjection writer "projection" projection + | Lir.NoneCheck projection -> writer.WriteString("kind", "none"); writeProjection writer "projection" projection + | Lir.UnionCaseCheck(projection, typeName, caseName, hasPayload) -> + writer.WriteString("kind", "union-case"); writeProjection writer "projection" projection + writer.WriteString("typeName", typeName); writer.WriteString("caseName", caseName); writer.WriteBoolean("hasPayload", hasPayload) + | Lir.TypeCheck(projection, patternType) -> + writer.WriteString("kind", "type"); writeProjection writer "projection" projection + writer.WritePropertyName("patternType"); writeType writer patternType + writer.WriteEndObject() + + let rec private writePlan (writer: Utf8JsonWriter) (plan: Lir.PatternPlan) = + writer.WriteStartObject(); writer.WritePropertyName("span"); writeSpan writer plan.Span + writer.WriteStartArray("checks"); plan.Checks |> List.iter (writeCheck writer); writer.WriteEndArray() + writer.WriteStartArray("bindings") + for binding in plan.Bindings do + writer.WriteStartObject(); writer.WriteNumber("symbol", Lir.symbolNumber binding.Id); writer.WriteString("name", binding.Name) + writer.WritePropertyName("type"); writeType writer binding.Type; writeProjection writer "projection" binding.Projection + writer.WriteEndObject() + writer.WriteEndArray(); writer.WriteStartArray("maps") + for mapPlan in plan.Maps do + writer.WriteStartObject(); writeProjection writer "projection" mapPlan.Projection + writer.WriteBoolean("requireEmptyRemainder", mapPlan.RequireEmptyRemainder); writer.WriteStartArray("clauses") + for clause in mapPlan.Clauses do + writer.WriteStartObject(); writer.WritePropertyName("key"); writePlan writer clause.Key + writer.WritePropertyName("value"); writePlan writer clause.Value; writer.WriteEndObject() + writer.WriteEndArray() + match mapPlan.Tail with Some tail -> writer.WritePropertyName("tail"); writePlan writer tail | None -> writer.WriteNull("tail") + writer.WriteEndObject() + writer.WriteEndArray(); writer.WriteEndObject() + + let rec private writeExpression (writer: Utf8JsonWriter) (value: Lir.Expression) = + writer.WriteStartObject(); writer.WritePropertyName("type"); writeType writer value.Type + writer.WritePropertyName("span"); writeSpan writer value.Span + match value.Node with + | Lir.Constant constant -> + writer.WriteString("kind", "constant"); writeConstantValue writer constant + | Lir.Load id -> writer.WriteString("kind", "load"); writer.WriteNumber("symbol", Lir.symbolNumber id) + | Lir.MakeClosure(id, captures) -> + writer.WriteString("kind", "closure"); writer.WriteNumber("function", Lir.functionNumber id) + writer.WriteStartArray("captures"); captures |> List.iter (Lir.symbolNumber >> writer.WriteNumberValue); writer.WriteEndArray() + | Lir.CallClosure(fn, argument) -> + writer.WriteString("kind", "call"); writer.WritePropertyName("function"); writeExpression writer fn + writer.WritePropertyName("argument"); writeExpression writer argument + | Lir.PipeClosure(argument, fn) -> + writer.WriteString("kind", "pipe-call"); writer.WritePropertyName("argument"); writeExpression writer argument + writer.WritePropertyName("function"); writeExpression writer fn + | Lir.TailCallClosure(fn, argument) -> + writer.WriteString("kind", "tail-call"); writer.WritePropertyName("function"); writeExpression writer fn + writer.WritePropertyName("argument"); writeExpression writer argument + | Lir.TailPipeClosure(argument, fn) -> + writer.WriteString("kind", "tail-pipe-call"); writer.WritePropertyName("argument"); writeExpression writer argument + writer.WritePropertyName("function"); writeExpression writer fn + | Lir.Branch(condition, whenTrue, whenFalse) -> + writer.WriteString("kind", "branch"); writer.WritePropertyName("condition"); writeExpression writer condition + writer.WritePropertyName("whenTrue"); writeExpression writer whenTrue; writer.WritePropertyName("whenFalse"); writeExpression writer whenFalse + | Lir.Operation(operation, arguments) -> + writer.WriteString("kind", "operation"); writer.WriteString("operation", sprintf "%A" operation) + writer.WriteStartArray("arguments"); arguments |> List.iter (writeExpression writer); writer.WriteEndArray() + | Lir.Tuple items | Lir.List items -> + writer.WriteString("kind", match value.Node with Lir.Tuple _ -> "tuple" | _ -> "list") + writer.WriteStartArray("items"); items |> List.iter (writeExpression writer); writer.WriteEndArray() + | Lir.Record fields -> + writer.WriteString("kind", "record"); writer.WriteStartArray("fields") + for name, field in fields do + writer.WriteStartObject(); writer.WriteString("name", name); writer.WritePropertyName("value") + writeExpression writer field; writer.WriteEndObject() + writer.WriteEndArray() + | Lir.FieldGet(target, name) -> + writer.WriteString("kind", "field-get"); writer.WriteString("name", name) + writer.WritePropertyName("target"); writeExpression writer target + | Lir.SomeValue item -> + writer.WriteString("kind", "some"); writer.WritePropertyName("value"); writeExpression writer item + | Lir.NoneValue -> writer.WriteString("kind", "none") + | Lir.Cons(head, tail) -> + writer.WriteString("kind", "cons"); writer.WritePropertyName("head"); writeExpression writer head + writer.WritePropertyName("tail"); writeExpression writer tail + | Lir.Append(left, right) -> + writer.WriteString("kind", "append"); writer.WritePropertyName("left"); writeExpression writer left + writer.WritePropertyName("right"); writeExpression writer right + | Lir.Let(id, name, recursive, binding, body) -> + writer.WriteString("kind", "let"); writer.WriteNumber("symbol", Lir.symbolNumber id); writer.WriteString("name", name) + writer.WriteBoolean("recursive", recursive); writer.WritePropertyName("binding"); writeExpression writer binding + writer.WritePropertyName("body"); writeExpression writer body + | Lir.LetRecursiveGroup(bindings, body) -> + writer.WriteString("kind", "let-rec-group"); writer.WriteStartArray("bindings") + for id, name, bindingType, value in bindings do + writer.WriteStartObject(); writer.WriteNumber("symbol", Lir.symbolNumber id); writer.WriteString("name", name) + writer.WritePropertyName("bindingType"); writeType writer bindingType + writer.WritePropertyName("value"); writeExpression writer value; writer.WriteEndObject() + writer.WriteEndArray(); writer.WritePropertyName("body"); writeExpression writer body + | Lir.Fail value -> writer.WriteString("kind", "fail"); writer.WritePropertyName("value"); writeExpression writer value + | Lir.DecisionTree(target, cases) -> + writer.WriteString("kind", "decision-tree"); writer.WritePropertyName("target"); writeExpression writer target + writer.WriteStartArray("cases") + for case in cases do + writer.WriteStartObject(); writer.WritePropertyName("plan"); writePlan writer case.Plan + match case.Guard with Some guard -> writer.WritePropertyName("guard"); writeExpression writer guard | None -> writer.WriteNull("guard") + writer.WritePropertyName("body"); writeExpression writer case.Body; writer.WritePropertyName("span"); writeSpan writer case.Span + writer.WriteEndObject() + writer.WriteEndArray() + | Lir.Range(startValue, endValue) -> + writer.WriteString("kind", "range"); writer.WritePropertyName("start"); writeExpression writer startValue + writer.WritePropertyName("end"); writeExpression writer endValue + | Lir.RecordUpdate(target, fields) -> + writer.WriteString("kind", "record-update"); writer.WritePropertyName("target"); writeExpression writer target + writer.WriteStartArray("fields") + for name, field in fields do + writer.WriteStartObject(); writer.WriteString("name", name); writer.WritePropertyName("value"); writeExpression writer field; writer.WriteEndObject() + writer.WriteEndArray() + | Lir.RecordConvert(target, targetType) -> + writer.WriteString("kind", "record-convert"); writer.WritePropertyName("target"); writeExpression writer target + writer.WritePropertyName("targetType"); writeType writer targetType + | Lir.IndexGet(target, index) -> + writer.WriteString("kind", "index-get"); writer.WritePropertyName("target"); writeExpression writer target + writer.WritePropertyName("index"); writeExpression writer index + | Lir.Interpolate parts -> + writer.WriteString("kind", "interpolate"); writer.WriteStartArray("parts") + for part in parts do + writer.WriteStartObject() + match part with + | Lir.TextPart text -> writer.WriteString("kind", "text"); writer.WriteString("text", text) + | Lir.ValuePart item -> writer.WriteString("kind", "value"); writer.WritePropertyName("value"); writeExpression writer item + writer.WriteEndObject() + writer.WriteEndArray() + | Lir.UnionCase(typeName, caseName, payload) -> + writer.WriteString("kind", "union-case"); writer.WriteString("typeName", typeName); writer.WriteString("caseName", caseName) + match payload with Some item -> writer.WritePropertyName("payload"); writeExpression writer item | None -> writer.WriteNull("payload") + | Lir.Map entries -> + writer.WriteString("kind", "map"); writer.WriteStartArray("entries") + for entry in entries do + writer.WriteStartObject() + match entry with + | Lir.KeyValue(key, value) -> writer.WriteString("kind", "key-value"); writer.WritePropertyName("key"); writeExpression writer key; writer.WritePropertyName("value"); writeExpression writer value + | Lir.Spread value -> writer.WriteString("kind", "spread"); writer.WritePropertyName("value"); writeExpression writer value + writer.WriteEndObject() + writer.WriteEndArray() + | Lir.Intrinsic name -> writer.WriteString("kind", "intrinsic"); writer.WriteString("name", name) + | Lir.HostExternal(name, arity) -> writer.WriteString("kind", "host-external"); writer.WriteString("name", name); writer.WriteNumber("arity", arity) + | Lir.RuntimeContext -> writer.WriteString("kind", "runtime-context") + | Lir.TargetImport(modulePath, memberName) -> writer.WriteString("kind", "target-import"); writer.WriteString("modulePath", modulePath); writer.WriteString("memberName", memberName) + | Lir.ForEach(id, name, itemType, source, body) -> + writer.WriteString("kind", "for-each"); writer.WriteNumber("symbol", Lir.symbolNumber id); writer.WriteString("name", name) + writer.WritePropertyName("itemType"); writeType writer itemType; writer.WritePropertyName("source"); writeExpression writer source + writer.WritePropertyName("body"); writeExpression writer body + | Lir.TypeToken tokenType -> writer.WriteString("kind", "type-token"); writer.WritePropertyName("tokenType"); writeType writer tokenType + writer.WriteEndObject() + + let serialize (program: Lir.Program) = + use stream = new MemoryStream() + use writer = new Utf8JsonWriter(stream, JsonWriterOptions(Indented = true)) + writer.WriteStartObject(); writer.WriteString("format", Format); writer.WriteNumber("irVersion", Version) + writer.WriteString("compilerVersion", assemblyVersion typeof.Assembly) + writer.WriteString("languageVersion", assemblyVersion typeof.Assembly) + writer.WriteStartArray("sources") + for path, hash in sourceMetadata program do + writer.WriteStartObject(); writer.WriteString("path", path); writer.WriteString("sha256", hash); writer.WriteEndObject() + writer.WriteEndArray(); writer.WriteStartArray("dependencies") + dependencies program |> List.iter writer.WriteStringValue + writer.WriteEndArray() + writer.WriteStartObject("program"); writer.WriteStartArray("types") + for declaration in program.Types do + writer.WriteStartObject(); writer.WriteNumber("id", Lir.symbolNumber declaration.Id); writer.WriteString("name", declaration.Name) + writer.WriteBoolean("recursive", declaration.IsRecursive); writer.WriteBoolean("pure", declaration.IsPure); writer.WritePropertyName("definition"); writeType writer declaration.Definition + match declaration.Import with + | Some imported -> + writer.WriteStartObject("import"); writer.WriteString("name", imported.Name); writer.WriteString("modulePath", imported.ModulePath) + writer.WriteString("memberName", imported.MemberName); writer.WriteBoolean("union", imported.IsUnion); writer.WriteStartArray("fields") + for name, fieldType in imported.Fields do + writer.WriteStartObject(); writer.WriteString("name", name); writer.WritePropertyName("type"); writeType writer fieldType; writer.WriteEndObject() + writer.WriteEndArray(); writer.WritePropertyName("span"); writeSpan writer imported.Span; writer.WriteEndObject() + | None -> writer.WriteNull("import") + writer.WritePropertyName("span"); writeSpan writer declaration.Span; writer.WriteEndObject() + writer.WriteEndArray(); writer.WriteStartArray("importedRecords") + for record in program.ImportedRecords do + writer.WriteStartObject(); writer.WriteString("name", record.Name); writer.WriteString("modulePath", record.ModulePath); writer.WriteString("memberName", record.MemberName); writer.WriteBoolean("union", record.IsUnion) + writer.WriteStartArray("fields") + for name, fieldType in record.Fields do + writer.WriteStartObject(); writer.WriteString("name", name); writer.WritePropertyName("type"); writeType writer fieldType; writer.WriteEndObject() + writer.WriteEndArray(); writer.WritePropertyName("span"); writeSpan writer record.Span; writer.WriteEndObject() + writer.WriteEndArray(); writer.WriteStartArray("functions") + for fn in program.Functions do + writer.WriteStartObject(); writer.WriteNumber("id", Lir.functionNumber fn.Id) + writer.WriteNumber("parameter", Lir.symbolNumber fn.Parameter); writer.WriteString("name", fn.Name) + writer.WritePropertyName("parameterType"); writeType writer fn.ParameterType + writer.WriteStartArray("captures"); fn.Captures |> List.iter (Lir.symbolNumber >> writer.WriteNumberValue); writer.WriteEndArray() + writer.WritePropertyName("returnType"); writeType writer fn.ReturnType + writer.WritePropertyName("span"); writeSpan writer fn.Span + writer.WritePropertyName("body"); writeExpression writer fn.Body; writer.WriteEndObject() + writer.WriteEndArray(); writer.WriteStartArray("declarations") + for declaration in program.Declarations do + writer.WriteStartObject(); writer.WriteNumber("id", Lir.symbolNumber declaration.Id); writer.WriteString("name", declaration.Name) + writer.WritePropertyName("type"); writeType writer declaration.Type; writer.WriteBoolean("recursive", declaration.IsRecursive) + writer.WriteBoolean("exported", declaration.IsExported); writer.WriteBoolean("pure", declaration.IsPure) + match declaration.ExternalArity with Some arity -> writer.WriteNumber("externalArity",arity) | None -> writer.WriteNull("externalArity") + match declaration.Export with + | Some export -> writer.WriteStartObject("export"); writer.WriteString("name", export.Name); writer.WritePropertyName("span"); writeSpan writer export.Span; writer.WriteEndObject() + | None -> writer.WriteNull("export") + writer.WritePropertyName("span"); writeSpan writer declaration.Span + writer.WritePropertyName("value"); writeExpression writer declaration.Value; writer.WriteEndObject() + writer.WriteEndArray() + match program.Entry with Some entry -> writer.WritePropertyName("entry"); writeExpression writer entry | None -> writer.WriteNull("entry") + writer.WriteEndObject(); writer.WriteEndObject(); writer.Flush(); stream.ToArray() + + let private property (name: string) (element: JsonElement) = element.GetProperty(name) + let private hasProperty (name: string) (element: JsonElement) = + let mutable value = Unchecked.defaultof + element.TryGetProperty(name, &value) + let private stringProperty (name: string) (element: JsonElement) = + match (property name element).GetString() with null -> "" | value -> value + let private readPosition (element: JsonElement) = + let fileElement = property "file" element + { File = if fileElement.ValueKind = JsonValueKind.Null then None else fileElement.GetString() |> Option.ofObj + Line = (property "line" element).GetInt32(); Column = (property "column" element).GetInt32() } + let private readSpan (element: JsonElement) = { Start = readPosition (property "start" element); End = readPosition (property "end" element) } + + let rec private readType (element: JsonElement) = + let args () = (property "arguments" element).EnumerateArray() |> Seq.map readType |> Seq.toList + match stringProperty "kind" element with + | "unit" -> TUnit | "int" -> TInt | "float" -> TFloat | "bool" -> TBool | "string" -> TString | "type-token" -> TTypeToken + | "list" -> TList(args().Head) | "task" -> TTask(args().Head) | "option" -> TOption(args().Head) | "tuple" -> TTuple(args()) + | "map" -> let values = args() in TMap(values.[0], values.[1]) + | "function" -> let values = args() in TFun(values.[0], values.[1]) + | "named" -> TNamed(stringProperty "name" element) | "variable" -> TVar(Int32.Parse(stringProperty "name" element)) + | "numeric" -> TNumeric(Int32.Parse(stringProperty "name" element)) + | "host-managed" -> + THostManaged(stringProperty "name" element, property "fields" element |> _.EnumerateArray() + |> Seq.map (fun field -> stringProperty "name" field, readType (property "type" field)) |> Map.ofSeq) + | "record-shape" -> + TRecordShape((property "id" element).GetInt32(), property "fields" element |> _.EnumerateArray() + |> Seq.map (fun field -> stringProperty "name" field, readType (property "type" field)) |> Map.ofSeq, + (property "constructible" element).GetBoolean()) + | "record" -> + (property "fields" element).EnumerateArray() + |> Seq.map (fun field -> stringProperty "name" field, readType (property "type" field)) |> Map.ofSeq |> TRecord + | "union" -> + let cases = (property "cases" element).EnumerateArray() |> Seq.map (fun item -> + let payload = property "payload" item + stringProperty "name" item, if payload.ValueKind = JsonValueKind.Null then None else Some(readType payload)) |> Map.ofSeq + TUnion(stringProperty "name" element, cases) + | kind -> invalidOp $"Unknown IR type kind '{kind}'." + + let private readOperation = function + | "NumericAdd" -> Lir.NumericAdd | "NumericSubtract" -> Lir.NumericSubtract + | "NumericMultiply" -> Lir.NumericMultiply | "NumericDivide" -> Lir.NumericDivide + | "IntAdd" -> Lir.IntAdd | "FloatAdd" -> Lir.FloatAdd | "IntSubtract" -> Lir.IntSubtract | "FloatSubtract" -> Lir.FloatSubtract + | "IntMultiply" -> Lir.IntMultiply | "FloatMultiply" -> Lir.FloatMultiply | "IntDivide" -> Lir.IntDivide | "FloatDivide" -> Lir.FloatDivide + | "IntRemainder" -> Lir.IntRemainder | "StructuralEqual" -> Lir.StructuralEqual | "NumericLessThan" -> Lir.NumericLessThan + | "NumericGreaterThan" -> Lir.NumericGreaterThan | "NumericLessThanOrEqual" -> Lir.NumericLessThanOrEqual + | "NumericGreaterThanOrEqual" -> Lir.NumericGreaterThanOrEqual | "BooleanAnd" -> Lir.BooleanAnd | "BooleanOr" -> Lir.BooleanOr + | value -> invalidOp $"Unknown LIR operation '{value}'." + + let private readConstant (element: JsonElement) = + match stringProperty "constantKind" element with + | "unit" -> Lir.Unit | "int" -> Lir.Int((property "intValue" element).GetInt64()) + | "float" -> Lir.Float((property "floatValue" element).GetDouble()) + | "bool" -> Lir.Bool((property "boolValue" element).GetBoolean()) + | "string" -> Lir.String(stringProperty "stringValue" element) + | value -> invalidOp $"Unknown constant '{value}'." + + let private readProjection (element: JsonElement) name = + (property name element).EnumerateArray() + |> Seq.map (fun step -> + match stringProperty "kind" step with + | "list-head" -> Lir.ListHead + | "list-tail" -> Lir.ListTail + | "tuple-item" -> Lir.TupleItem((property "index" step).GetInt32()) + | "record-field" -> Lir.RecordField(stringProperty "name" step) + | "option-value" -> Lir.OptionValue + | "union-payload" -> Lir.UnionPayload + | kind -> invalidOp $"Unknown LIR projection step '{kind}'.") + |> Seq.toList + + let private readCheck (element: JsonElement) = + let projection = readProjection element "projection" + match stringProperty "kind" element with + | "literal" -> Lir.LiteralCheck(projection, readConstant element) + | "empty-list" -> Lir.EmptyListCheck projection + | "non-empty-list" -> Lir.NonEmptyListCheck projection + | "tuple-arity" -> Lir.TupleArityCheck(projection, (property "arity" element).GetInt32()) + | "record-field" -> Lir.RecordFieldCheck(projection, stringProperty "name" element) + | "some" -> Lir.SomeCheck projection + | "none" -> Lir.NoneCheck projection + | "union-case" -> Lir.UnionCaseCheck(projection, stringProperty "typeName" element, stringProperty "caseName" element, (property "hasPayload" element).GetBoolean()) + | "type" -> Lir.TypeCheck(projection, readType (property "patternType" element)) + | kind -> invalidOp $"Unknown LIR pattern-plan check '{kind}'." + + let rec private readPlan (element: JsonElement) : Lir.PatternPlan = + let bindings = + (property "bindings" element).EnumerateArray() + |> Seq.map (fun binding -> + ({ Id = Lir.SymbolId((property "symbol" binding).GetInt32()) + Name = stringProperty "name" binding + Type = readType (property "type" binding) + Projection = readProjection binding "projection" }: Lir.PatternBinding)) + |> Seq.toList + let maps = + (property "maps" element).EnumerateArray() + |> Seq.map (fun mapPlan -> + let tail = property "tail" mapPlan + ({ Projection = readProjection mapPlan "projection" + Clauses = + (property "clauses" mapPlan).EnumerateArray() + |> Seq.map (fun clause -> ({ Key = readPlan (property "key" clause); Value = readPlan (property "value" clause) }: Lir.MapClausePlan)) + |> Seq.toList + Tail = if tail.ValueKind = JsonValueKind.Null then None else Some(readPlan tail) + RequireEmptyRemainder = (property "requireEmptyRemainder" mapPlan).GetBoolean() }: Lir.MapPlan)) + |> Seq.toList + { Span = readSpan (property "span" element) + Checks = (property "checks" element).EnumerateArray() |> Seq.map readCheck |> Seq.toList + Bindings = bindings + Maps = maps } + + let rec private readExpression (element: JsonElement) : Lir.Expression = + let expressionType = readType (property "type" element) + let span = readSpan (property "span" element) + let node = + match stringProperty "kind" element with + | "constant" -> Lir.Constant(readConstant element) + | "load" -> Lir.Load(Lir.SymbolId((property "symbol" element).GetInt32())) + | "closure" -> + Lir.MakeClosure( + Lir.FunctionId((property "function" element).GetInt32()), + (property "captures" element).EnumerateArray() |> Seq.map (fun item -> Lir.SymbolId(item.GetInt32())) |> Seq.toList) + | "call" -> Lir.CallClosure(readExpression (property "function" element), readExpression (property "argument" element)) + | "pipe-call" -> Lir.PipeClosure(readExpression (property "argument" element), readExpression (property "function" element)) + | "tail-call" -> Lir.TailCallClosure(readExpression (property "function" element), readExpression (property "argument" element)) + | "tail-pipe-call" -> Lir.TailPipeClosure(readExpression (property "argument" element), readExpression (property "function" element)) + | "branch" -> Lir.Branch(readExpression (property "condition" element), readExpression (property "whenTrue" element), readExpression (property "whenFalse" element)) + | "operation" -> Lir.Operation(readOperation (stringProperty "operation" element), (property "arguments" element).EnumerateArray() |> Seq.map readExpression |> Seq.toList) + | "tuple" -> Lir.Tuple((property "items" element).EnumerateArray() |> Seq.map readExpression |> Seq.toList) + | "list" -> Lir.List((property "items" element).EnumerateArray() |> Seq.map readExpression |> Seq.toList) + | "record" -> + Lir.Record((property "fields" element).EnumerateArray() |> Seq.map (fun field -> stringProperty "name" field, readExpression (property "value" field)) |> Seq.toList) + | "field-get" -> Lir.FieldGet(readExpression (property "target" element), stringProperty "name" element) + | "some" -> Lir.SomeValue(readExpression (property "value" element)) + | "none" -> Lir.NoneValue + | "cons" -> Lir.Cons(readExpression (property "head" element), readExpression (property "tail" element)) + | "append" -> Lir.Append(readExpression (property "left" element), readExpression (property "right" element)) + | "let" -> Lir.Let(Lir.SymbolId((property "symbol" element).GetInt32()), stringProperty "name" element, + (property "recursive" element).GetBoolean(), readExpression (property "binding" element), readExpression (property "body" element)) + | "let-rec-group" -> + let bindings = (property "bindings" element).EnumerateArray() |> Seq.map (fun item -> + Lir.SymbolId((property "symbol" item).GetInt32()), stringProperty "name" item, + readType (property "bindingType" item), readExpression (property "value" item)) |> Seq.toList + Lir.LetRecursiveGroup(bindings, readExpression (property "body" element)) + | "fail" -> Lir.Fail(readExpression (property "value" element)) + | "decision-tree" -> + let cases = (property "cases" element).EnumerateArray() |> Seq.map (fun item -> + let guard = property "guard" item + ({ Plan = readPlan (property "plan" item) + Guard = if guard.ValueKind = JsonValueKind.Null then None else Some(readExpression guard) + Body = readExpression (property "body" item) + Span = readSpan (property "span" item) }: Lir.DecisionCase)) |> Seq.toList + Lir.DecisionTree(readExpression (property "target" element), cases) + | "range" -> Lir.Range(readExpression (property "start" element), readExpression (property "end" element)) + | "record-update" -> + let fields = (property "fields" element).EnumerateArray() |> Seq.map (fun item -> stringProperty "name" item, readExpression (property "value" item)) |> Seq.toList + Lir.RecordUpdate(readExpression (property "target" element), fields) + | "record-convert" -> Lir.RecordConvert(readExpression (property "target" element), readType (property "targetType" element)) + | "index-get" -> Lir.IndexGet(readExpression (property "target" element), readExpression (property "index" element)) + | "interpolate" -> + Lir.Interpolate((property "parts" element).EnumerateArray() |> Seq.map (fun item -> + match stringProperty "kind" item with + | "text" -> Lir.TextPart(stringProperty "text" item) + | "value" -> Lir.ValuePart(readExpression (property "value" item)) + | kind -> invalidOp $"Unknown interpolation part '{kind}'.") |> Seq.toList) + | "union-case" -> + let payload = property "payload" element + Lir.UnionCase(stringProperty "typeName" element, stringProperty "caseName" element, if payload.ValueKind = JsonValueKind.Null then None else Some(readExpression payload)) + | "map" -> + Lir.Map((property "entries" element).EnumerateArray() |> Seq.map (fun item -> + match stringProperty "kind" item with + | "key-value" -> Lir.KeyValue(readExpression (property "key" item), readExpression (property "value" item)) + | "spread" -> Lir.Spread(readExpression (property "value" item)) + | kind -> invalidOp $"Unknown map entry '{kind}'.") |> Seq.toList) + | "intrinsic" -> Lir.Intrinsic(stringProperty "name" element) + | "host-external" -> Lir.HostExternal(stringProperty "name" element, (property "arity" element).GetInt32()) + | "runtime-context" -> Lir.RuntimeContext + | "target-import" -> Lir.TargetImport(stringProperty "modulePath" element, stringProperty "memberName" element) + | "for-each" -> Lir.ForEach(Lir.SymbolId((property "symbol" element).GetInt32()), stringProperty "name" element, + readType (property "itemType" element), readExpression (property "source" element), readExpression (property "body" element)) + | "type-token" -> Lir.TypeToken(readType (property "tokenType" element)) + | kind -> invalidOp $"Unknown LIR expression kind '{kind}'." + { Type = expressionType; Span = span; Node = node } + + let deserialize (bytes: byte array) = + try + use document = JsonDocument.Parse(bytes) + let root = document.RootElement + if stringProperty "format" root <> Format then Error [ { Code = "FSA5001"; Stage = Artifact; Message = "Unsupported IR artifact format."; Span = None } ] + elif (property "irVersion" root).GetInt32() <> Version then Error [ { Code = "FSA5002"; Stage = Artifact; Message = "Incompatible IR artifact version."; Span = None } ] + elif [ "compilerVersion"; "languageVersion"; "sources"; "dependencies"; "program" ] |> List.exists (fun name -> not (hasProperty name root)) then + Error [ { Code = "FSA5004"; Stage = Artifact; Message = "IR artifact is missing required metadata."; Span = None } ] + else + let sourceElements = + if (property "sources" root).ValueKind = JsonValueKind.Array then + (property "sources" root).EnumerateArray() |> Seq.toList + else [] + let sourceValues = sourceElements |> List.map (fun source -> stringProperty "path" source, stringProperty "sha256" source) + let validHash (hash: string) = + hash.Length = 64 + && hash |> Seq.forall (fun character -> System.Char.IsDigit character || (character >= 'a' && character <= 'f')) + let sourcesValid = + (property "sources" root).ValueKind = JsonValueKind.Array + && sourceElements |> List.forall (fun source -> hasProperty "path" source && hasProperty "sha256" source) + && sourceValues |> List.forall (fun (path, hash) -> not (String.IsNullOrWhiteSpace path) && path = normalizePath path && validHash hash) + && sourceValues = (sourceValues |> List.distinct |> List.sortBy fst) + let dependencyElements = + if (property "dependencies" root).ValueKind = JsonValueKind.Array then + (property "dependencies" root).EnumerateArray() |> Seq.toList + else [] + let dependencyValues = dependencyElements |> List.map _.GetString() |> List.map (Option.ofObj >> Option.defaultValue "") + let versionsValid = + not (String.IsNullOrWhiteSpace(stringProperty "compilerVersion" root)) + && not (String.IsNullOrWhiteSpace(stringProperty "languageVersion" root)) + if not versionsValid || not sourcesValid || dependencyValues |> List.exists String.IsNullOrWhiteSpace || dependencyValues <> (dependencyValues |> List.distinct |> List.sort) then + Error [ { Code = "FSA5005"; Stage = Artifact; Message = "IR artifact metadata is invalid or non-canonical."; Span = None } ] + else + let programElement = property "program" root + let readImportedRecord (item: JsonElement) = + ({ Name = stringProperty "name" item; ModulePath = stringProperty "modulePath" item; MemberName = stringProperty "memberName" item; IsUnion = (property "union" item).GetBoolean() + Fields = (property "fields" item).EnumerateArray() |> Seq.map (fun field -> stringProperty "name" field, readType (property "type" field)) |> Seq.toList + Span = readSpan (property "span" item) }: Lir.ImportedRecord) + let importedRecords = (property "importedRecords" programElement).EnumerateArray() |> Seq.map (fun item -> + readImportedRecord item) |> Seq.toList + let types = (property "types" programElement).EnumerateArray() |> Seq.map (fun item -> + let importElement = property "import" item + ({ Id = Lir.SymbolId((property "id" item).GetInt32()); Name = stringProperty "name" item + IsRecursive = (property "recursive" item).GetBoolean(); IsPure = (match item.TryGetProperty("pure") with true,value -> value.GetBoolean() | _ -> false); Definition = readType (property "definition" item) + Import = if importElement.ValueKind = JsonValueKind.Null then None else Some(readImportedRecord importElement) + Span = readSpan (property "span" item) }: Lir.TypeDeclaration)) |> Seq.toList + let declarations = (property "declarations" programElement).EnumerateArray() |> Seq.map (fun (item: JsonElement) -> + let exportElement = property "export" item + let export = + if exportElement.ValueKind = JsonValueKind.Null then None + else Some({ Name = stringProperty "name" exportElement; Span = readSpan (property "span" exportElement) }: Lir.ExportMetadata) + ({ Id = Lir.SymbolId((property "id" item).GetInt32()); Name = stringProperty "name" item; Type = readType (property "type" item) + IsRecursive = (property "recursive" item).GetBoolean(); IsExported = (property "exported" item).GetBoolean(); IsPure = (match item.TryGetProperty("pure") with true,value -> value.GetBoolean() | _ -> false) + ExternalArity = (match item.TryGetProperty("externalArity") with true,value when value.ValueKind<>JsonValueKind.Null -> Some(value.GetInt32()) | _ -> None) + Export = export + Span = readSpan (property "span" item); Value = readExpression (property "value" item) }: Lir.Declaration)) |> Seq.toList + let functions = (property "functions" programElement).EnumerateArray() |> Seq.map (fun (item: JsonElement) -> + ({ Id = Lir.FunctionId((property "id" item).GetInt32()) + Parameter = Lir.SymbolId((property "parameter" item).GetInt32()) + Name = stringProperty "name" item + ParameterType = readType (property "parameterType" item) + Captures = (property "captures" item).EnumerateArray() |> Seq.map (fun capture -> Lir.SymbolId(capture.GetInt32())) |> Seq.toList + ReturnType = readType (property "returnType" item) + Span = readSpan (property "span" item) + Body = readExpression (property "body" item) }: Lir.Function)) |> Seq.toList + let entryElement = property "entry" programElement + let program : Lir.Program = + { Types = types + ImportedRecords = importedRecords + Functions = functions + Declarations = declarations + Entry = if entryElement.ValueKind = JsonValueKind.Null then None else Some(readExpression entryElement) } + LirValidation.validate program + with ex -> Error [ { Code = "FSA5003"; Stage = Artifact; Message = ex.Message; Span = None } ] diff --git a/src/FScript.Compiler/Lir.fs b/src/FScript.Compiler/Lir.fs new file mode 100644 index 0000000..91d4f5f --- /dev/null +++ b/src/FScript.Compiler/Lir.fs @@ -0,0 +1,980 @@ +namespace FScript.Compiler + +open FScript.Language + +module Lir = + type SymbolId = SymbolId of int + type FunctionId = FunctionId of int + + type Constant = + | Unit + | Int of int64 + | Float of float + | Bool of bool + | String of string + + type Operation = + | NumericAdd | NumericSubtract | NumericMultiply | NumericDivide + | IntAdd | FloatAdd | IntSubtract | FloatSubtract + | IntMultiply | FloatMultiply | IntDivide | FloatDivide | IntRemainder + | StructuralEqual + | NumericLessThan | NumericGreaterThan | NumericLessThanOrEqual | NumericGreaterThanOrEqual + | BooleanAnd | BooleanOr + + type Expression = + { Type: Type + Span: Span + Node: ExpressionNode } + and ExpressionNode = + | Constant of Constant + | Load of SymbolId + | MakeClosure of FunctionId * SymbolId list + | CallClosure of Expression * Expression + | PipeClosure of Expression * Expression + | TailCallClosure of Expression * Expression + | TailPipeClosure of Expression * Expression + | Branch of Expression * Expression * Expression + | Operation of Operation * Expression list + | Tuple of Expression list + | List of Expression list + | Record of (string * Expression) list + | FieldGet of Expression * string + | SomeValue of Expression + | NoneValue + | Cons of Expression * Expression + | Append of Expression * Expression + | Let of SymbolId * string * bool * Expression * Expression + | LetRecursiveGroup of (SymbolId * string * Type * Expression) list * Expression + | Fail of Expression + | DecisionTree of Expression * DecisionCase list + | Range of Expression * Expression + | RecordUpdate of Expression * (string * Expression) list + | RecordConvert of Expression * Type + | IndexGet of Expression * Expression + | Interpolate of InterpolationPart list + | UnionCase of string * string * Expression option + | Map of MapEntry list + | Intrinsic of string + | HostExternal of string * int + | RuntimeContext + | TargetImport of string * string + | ForEach of SymbolId * string * Type * Expression * Expression + | TypeToken of Type + + and MapEntry = + | KeyValue of Expression * Expression + | Spread of Expression + + and InterpolationPart = + | TextPart of string + | ValuePart of Expression + + and ProjectionStep = + | ListHead + | ListTail + | TupleItem of int + | RecordField of string + | OptionValue + | UnionPayload + + and PatternCheck = + | LiteralCheck of ProjectionStep list * Constant + | EmptyListCheck of ProjectionStep list + | NonEmptyListCheck of ProjectionStep list + | TupleArityCheck of ProjectionStep list * int + | RecordFieldCheck of ProjectionStep list * string + | SomeCheck of ProjectionStep list + | NoneCheck of ProjectionStep list + | UnionCaseCheck of ProjectionStep list * string * string * bool + | TypeCheck of ProjectionStep list * Type + + and PatternBinding = + { Id: SymbolId + Name: string + Type: Type + Projection: ProjectionStep list } + + and PatternPlan = + { Span: Span + Checks: PatternCheck list + Bindings: PatternBinding list + Maps: MapPlan list } + + and MapPlan = + { Projection: ProjectionStep list + Clauses: MapClausePlan list + Tail: PatternPlan option + RequireEmptyRemainder: bool } + + and MapClausePlan = + { Key: PatternPlan + Value: PatternPlan } + + and DecisionCase = + { Plan: PatternPlan + Guard: Expression option + Body: Expression + Span: Span } + + type Declaration = + { Id: SymbolId + Name: string + Type: Type + IsRecursive: bool + IsExported: bool + IsPure: bool + ExternalArity: int option + Export: ExportMetadata option + Span: Span + Value: Expression } + + and ExportMetadata = + { Name: string + Span: Span } + + type Function = + { Id: FunctionId + Parameter: SymbolId + Name: string + ParameterType: Type + Captures: SymbolId list + ReturnType: Type + Span: Span + Body: Expression } + + type ImportedRecord = + { Name: string + ModulePath: string + MemberName: string + IsUnion: bool + Fields: (string * Type) list + Span: Span } + + type TypeDeclaration = + { Id: SymbolId + Name: string + IsRecursive: bool + IsPure: bool + Definition: Type + Import: ImportedRecord option + Span: Span } + + type Program = + { Types: TypeDeclaration list + ImportedRecords: ImportedRecord list + Functions: Function list + Declarations: Declaration list + Entry: Expression option } + + let symbolNumber (SymbolId value) = value + let functionNumber (FunctionId value) = value + + let simpleKeyBinding (plan: PatternPlan) = + match plan.Checks,plan.Maps,plan.Bindings with + | [],[],[binding] when binding.Projection.IsEmpty -> Some binding.Id + | _ -> None + + let rec planBindingIds (plan: PatternPlan) = + [ yield! plan.Bindings |> List.map _.Id + for map in plan.Maps do + for clause in map.Clauses do + yield! planBindingIds clause.Key + yield! planBindingIds clause.Value + yield! map.Tail |> Option.map planBindingIds |> Option.defaultValue Set.empty ] |> Set.ofList + + let format (program: Program) = + let lines = ResizeArray() + let typeName = Types.typeToString + let symbols values = values |> List.map (symbolNumber >> string) |> String.concat "," |> fun value -> "[" + value + "]" + let rec expression indent (value: Expression) = + let prefix = System.String(' ', indent) + let add label = lines.Add($"{prefix}{label} : {typeName value.Type}") + let children label values = add label; values |> List.iter (expression (indent + 2)) + match value.Node with + | Constant constant -> add $"const {constant}" + | Load id -> add $"load %%{symbolNumber id}" + | MakeClosure(id, captures) -> add $"make-closure @{functionNumber id} captures={symbols captures}" + | CallClosure(fn, argument) -> children "call-closure" [ fn; argument ] + | PipeClosure(value, fn) -> children "pipe-closure" [ value; fn ] + | TailCallClosure(fn, argument) -> children "tail-call-closure" [ fn; argument ] + | TailPipeClosure(value, fn) -> children "tail-pipe-closure" [ value; fn ] + | Branch(condition, whenTrue, whenFalse) -> children "branch" [ condition; whenTrue; whenFalse ] + | Operation(operation, arguments) -> children $"operation {operation}" arguments + | Tuple items -> children "tuple" items + | List items -> children "list" items + | Record fields -> children ("record " + (fields |> List.map fst |> String.concat ",")) (List.map snd fields) + | FieldGet(target, name) -> children $"field-get {name}" [ target ] + | SomeValue item -> children "some" [ item ] + | NoneValue -> add "none" + | Cons(head, tail) -> children "cons" [ head; tail ] + | Append(left, right) -> children "append" [ left; right ] + | Let(id, name, recursive, binding, body) -> children $"let %%{symbolNumber id} {name} recursive={recursive}" [ binding; body ] + | LetRecursiveGroup(bindings, body) -> children ("let-rec-group " + (bindings |> List.map (fun (id, name, _, _) -> $"%%{symbolNumber id}:{name}") |> String.concat ",")) ((bindings |> List.map (fun (_, _, _, item) -> item)) @ [ body ]) + | Fail item -> children "fail" [ item ] + | DecisionTree(target, cases) -> + add $"decision-tree cases={cases.Length}"; expression (indent + 2) target + cases |> List.iter (fun case -> case.Guard |> Option.iter (expression (indent + 2)); expression (indent + 2) case.Body) + | Range(first, last) -> children "range" [ first; last ] + | RecordUpdate(target, fields) -> children ("record-update " + (fields |> List.map fst |> String.concat ",")) (target :: List.map snd fields) + | RecordConvert(target, targetType) -> children $"record-convert {typeName targetType}" [ target ] + | IndexGet(target, index) -> children "index-get" [ target; index ] + | Interpolate parts -> children "interpolate" (parts |> List.choose (function TextPart _ -> None | ValuePart item -> Some item)) + | UnionCase(typeName, caseName, payload) -> children $"union {typeName}.{caseName}" (Option.toList payload) + | Map entries -> children "map" (entries |> List.collect (function KeyValue(key, item) -> [ key; item ] | Spread item -> [ item ])) + | Intrinsic name -> add $"intrinsic {name}" + | HostExternal(name, arity) -> add $"host-external {name}/{arity}" + | RuntimeContext -> add "runtime-context" + | TargetImport(modulePath, memberName) -> add $"target-import {modulePath}.{memberName}" + | ForEach(id, name, _, source, body) -> children $"for-each %%{symbolNumber id} {name}" [ source; body ] + | TypeToken tokenType -> add $"type-token {typeName tokenType}" + for typeDeclaration in program.Types do + let purityLabel = if typeDeclaration.IsPure then " pure" else "" + lines.Add($"type %%{symbolNumber typeDeclaration.Id} {typeDeclaration.Name}{purityLabel}: {typeName typeDeclaration.Definition}") + for fn in program.Functions do + lines.Add($"function @{functionNumber fn.Id} %%{symbolNumber fn.Parameter} {fn.Name} captures={symbols fn.Captures}: {typeName fn.ParameterType} -> {typeName fn.ReturnType}") + expression 2 fn.Body + for declaration in program.Declarations do + let export = declaration.Export |> Option.map (fun metadata -> $" export={metadata.Name}") |> Option.defaultValue "" + let purityLabel = if declaration.IsPure then " pure" else "" + lines.Add($"decl %%{symbolNumber declaration.Id} {declaration.Name}{export}{purityLabel}: {typeName declaration.Type}") + expression 2 declaration.Value + program.Entry |> Option.iter (fun entry -> lines.Add("entry"); expression 2 entry) + System.String.Join("\n", lines) + "\n" + +module LirLowering = + type private State = + { mutable NextFunction: int + Functions: ResizeArray } + + let private newFunction state = + let id = Lir.FunctionId state.NextFunction + state.NextFunction <- state.NextFunction + 1 + id + + let private symbol (Hir.SymbolId value) = Lir.SymbolId value + + let private operation = function + | Hir.NumericAdd -> Lir.NumericAdd | Hir.NumericSubtract -> Lir.NumericSubtract + | Hir.NumericMultiply -> Lir.NumericMultiply | Hir.NumericDivide -> Lir.NumericDivide + | Hir.IntAdd -> Lir.IntAdd | Hir.FloatAdd -> Lir.FloatAdd + | Hir.IntSubtract -> Lir.IntSubtract | Hir.FloatSubtract -> Lir.FloatSubtract + | Hir.IntMultiply -> Lir.IntMultiply | Hir.FloatMultiply -> Lir.FloatMultiply + | Hir.IntDivide -> Lir.IntDivide | Hir.FloatDivide -> Lir.FloatDivide + | Hir.IntRemainder -> Lir.IntRemainder | Hir.StructuralEqual -> Lir.StructuralEqual + | Hir.NumericLessThan -> Lir.NumericLessThan | Hir.NumericGreaterThan -> Lir.NumericGreaterThan + | Hir.NumericLessThanOrEqual -> Lir.NumericLessThanOrEqual + | Hir.NumericGreaterThanOrEqual -> Lir.NumericGreaterThanOrEqual + | Hir.BooleanAnd -> Lir.BooleanAnd | Hir.BooleanOr -> Lir.BooleanOr + + let private constant = function + | Hir.Unit -> Lir.Unit | Hir.Int value -> Lir.Int value | Hir.Float value -> Lir.Float value + | Hir.Bool value -> Lir.Bool value | Hir.String value -> Lir.String value + + let private appendPlan (left: Lir.PatternPlan) (right: Lir.PatternPlan) : Lir.PatternPlan = + { Span = left.Span + Checks = left.Checks @ right.Checks + Bindings = left.Bindings @ right.Bindings + Maps = left.Maps @ right.Maps } + + let rec private patternPlan projection (value: Hir.Pattern) : Lir.PatternPlan = + let empty () : Lir.PatternPlan = { Span = value.Span; Checks = []; Bindings = []; Maps = [] } + let combine plans = plans |> List.fold appendPlan (empty ()) + match value.Node with + | Hir.Wildcard -> empty () + | Hir.Binding(id, name) -> + { empty () with + Bindings = [ { Id = symbol id; Name = name; Type = value.Type; Projection = projection } ] } + | Hir.LiteralPattern item -> { empty () with Checks = [ Lir.LiteralCheck(projection, constant item) ] } + | Hir.EmptyList -> { empty () with Checks = [ Lir.EmptyListCheck projection ] } + | Hir.ConsPattern(head, tail) -> + combine + [ { empty () with Checks = [ Lir.NonEmptyListCheck projection ] } + patternPlan (projection @ [ Lir.ListHead ]) head + patternPlan (projection @ [ Lir.ListTail ]) tail ] + | Hir.TuplePattern items -> + { empty () with Checks = [ Lir.TupleArityCheck(projection, items.Length) ] } + :: (items |> List.mapi (fun index item -> patternPlan (projection @ [ Lir.TupleItem index ]) item)) + |> combine + | Hir.RecordPattern fields -> + fields + |> List.collect (fun (name, item) -> + [ { empty () with Checks = [ Lir.RecordFieldCheck(projection, name) ] } + patternPlan (projection @ [ Lir.RecordField name ]) item ]) + |> combine + | Hir.MapPattern(clauses, tail) -> + let mapPlan : Lir.MapPlan = + { Projection = projection + Clauses = + clauses + |> List.map (fun (key, item) -> + { Key = patternPlan [] key + Value = patternPlan [] item }) + Tail = Option.map (patternPlan []) tail + RequireEmptyRemainder = clauses.IsEmpty && tail.IsNone } + { empty () with Maps = [ mapPlan ] } + | Hir.SomePattern item -> + combine + [ { empty () with Checks = [ Lir.SomeCheck projection ] } + patternPlan (projection @ [ Lir.OptionValue ]) item ] + | Hir.NonePattern -> { empty () with Checks = [ Lir.NoneCheck projection ] } + | Hir.UnionPattern(typeName, caseName, payload) -> + combine + [ { empty () with Checks = [ Lir.UnionCaseCheck(projection, typeName, caseName, payload.IsSome) ] } + yield! payload |> Option.map (patternPlan (projection @ [ Lir.UnionPayload ])) |> Option.toList ] + | Hir.TypePattern patternType -> { empty () with Checks = [ Lir.TypeCheck(projection, patternType) ] } + + let rec private patternBindings (plan: Lir.PatternPlan) = + [ plan.Bindings |> List.map _.Id |> Set.ofList + yield! + plan.Maps + |> List.collect (fun mapPlan -> + [ yield! mapPlan.Clauses |> List.collect (fun clause -> [ patternBindings clause.Key; patternBindings clause.Value ]) + yield! mapPlan.Tail |> Option.map patternBindings |> Option.toList ]) ] + |> Set.unionMany + + let rec capturedReferences bound (value: Lir.Expression) = + let free = capturedReferences bound + match value.Node with + | Lir.Load id -> if Set.contains id bound then Set.empty else Set.singleton id + | Lir.MakeClosure(_, captures) -> Set.difference (Set.ofList captures) bound + | Lir.CallClosure(fn, argument) | Lir.PipeClosure(argument, fn) + | Lir.TailCallClosure(fn, argument) | Lir.TailPipeClosure(argument, fn) + | Lir.Append(fn, argument) | Lir.Cons(fn, argument) + | Lir.Range(fn, argument) | Lir.IndexGet(fn, argument) -> Set.union (free fn) (free argument) + | Lir.Branch(condition, whenTrue, whenFalse) -> [ free condition; free whenTrue; free whenFalse ] |> Set.unionMany + | Lir.Operation(_, arguments) | Lir.Tuple arguments | Lir.List arguments -> arguments |> List.map free |> Set.unionMany + | Lir.Record fields -> fields |> List.map (snd >> free) |> Set.unionMany + | Lir.FieldGet(target, _) | Lir.SomeValue target | Lir.Fail target | Lir.RecordConvert(target, _) -> free target + | Lir.Let(id, _, recursive, binding, body) -> + let scope = Set.add id bound + Set.union (capturedReferences (if recursive then scope else bound) binding) (capturedReferences scope body) + | Lir.LetRecursiveGroup(bindings, body) -> + let scope = bindings |> List.fold (fun state (id, _, _, _) -> Set.add id state) bound + (capturedReferences scope body :: (bindings |> List.map (fun (_, _, _, binding) -> capturedReferences scope binding))) |> Set.unionMany + | Lir.DecisionTree(target, cases) -> + free target + :: (cases |> List.collect (fun case -> + let scope = Set.union bound (patternBindings case.Plan) + [ yield! case.Guard |> Option.map (capturedReferences scope) |> Option.toList + capturedReferences scope case.Body ])) + |> Set.unionMany + | Lir.RecordUpdate(target, fields) -> free target :: (fields |> List.map (snd >> free)) |> Set.unionMany + | Lir.Interpolate parts -> parts |> List.choose (function Lir.TextPart _ -> None | Lir.ValuePart item -> Some(free item)) |> Set.unionMany + | Lir.UnionCase(_, _, payload) -> payload |> Option.map free |> Option.defaultValue Set.empty + | Lir.Map entries -> entries |> List.map (function Lir.KeyValue(key, item) -> Set.union (free key) (free item) | Lir.Spread item -> free item) |> Set.unionMany + | Lir.ForEach(id, _, _, source, body) -> Set.union (free source) (capturedReferences (Set.add id bound) body) + | Lir.Constant _ | Lir.NoneValue | Lir.Intrinsic _ | Lir.HostExternal _ | Lir.RuntimeContext + | Lir.TargetImport _ | Lir.TypeToken _ -> Set.empty + + let rec private expression state (value: Hir.Expression) : Lir.Expression = + let node = + match value.Node with + | Hir.Constant value -> Lir.Constant(constant value) + | Hir.Reference id -> Lir.Load(symbol id) + | Hir.Lambda(id, name, parameterType, body) -> + let parameter = symbol id + let functionId = newFunction state + let loweredBody = expression state body + let captures = capturedReferences (Set.singleton parameter) loweredBody |> Set.toList |> List.sortBy Lir.symbolNumber + state.Functions.Add + { Id = functionId; Parameter = parameter; Name = name; ParameterType = parameterType + Captures = captures; ReturnType = loweredBody.Type; Span = value.Span; Body = loweredBody } + Lir.MakeClosure(functionId, captures) + | Hir.Apply(fn, argument) -> Lir.CallClosure(expression state fn, expression state argument) + | Hir.Pipe(argument, fn) -> Lir.PipeClosure(expression state argument, expression state fn) + | Hir.If(condition, whenTrue, whenFalse) -> Lir.Branch(expression state condition, expression state whenTrue, expression state whenFalse) + | Hir.Primitive(op, arguments) -> Lir.Operation(operation op, arguments |> List.map (expression state)) + | Hir.Tuple items -> Lir.Tuple(items |> List.map (expression state)) + | Hir.List items -> Lir.List(items |> List.map (expression state)) + | Hir.Record fields -> Lir.Record(fields |> List.map (fun (name, item) -> name, expression state item)) + | Hir.FieldGet(target, name) -> Lir.FieldGet(expression state target, name) + | Hir.SomeValue item -> Lir.SomeValue(expression state item) + | Hir.NoneValue -> Lir.NoneValue + | Hir.Cons(head, tail) -> Lir.Cons(expression state head, expression state tail) + | Hir.Append(left, right) -> Lir.Append(expression state left, expression state right) + | Hir.Let(id, name, recursive, binding, body) -> Lir.Let(symbol id, name, recursive, expression state binding, expression state body) + | Hir.LetRecursiveGroup(bindings, body) -> + Lir.LetRecursiveGroup(bindings |> List.map (fun (id, name, bindingType, value) -> symbol id, name, bindingType, expression state value), expression state body) + | Hir.Fail value -> Lir.Fail(expression state value) + | Hir.Match(target, cases) -> + Lir.DecisionTree(expression state target, cases |> List.map (fun case -> + ({ Plan = patternPlan [] case.Pattern + Guard = Option.map (expression state) case.Guard + Body = expression state case.Body + Span = case.Span }: Lir.DecisionCase))) + | Hir.Range(startValue, endValue) -> Lir.Range(expression state startValue, expression state endValue) + | Hir.RecordUpdate(target, fields) -> Lir.RecordUpdate(expression state target, fields |> List.map (fun (name, item) -> name, expression state item)) + | Hir.RecordConvert(target, targetType) -> Lir.RecordConvert(expression state target, targetType) + | Hir.IndexGet(target, index) -> Lir.IndexGet(expression state target, expression state index) + | Hir.Interpolate parts -> Lir.Interpolate(parts |> List.map (function Hir.TextPart text -> Lir.TextPart text | Hir.ValuePart item -> Lir.ValuePart(expression state item))) + | Hir.UnionCase(typeName, caseName, payload) -> Lir.UnionCase(typeName, caseName, Option.map (expression state) payload) + | Hir.Map entries -> Lir.Map(entries |> List.map (function Hir.KeyValue(key, item) -> Lir.KeyValue(expression state key, expression state item) | Hir.Spread item -> Lir.Spread(expression state item))) + | Hir.Intrinsic name -> Lir.Intrinsic name + | Hir.HostExternal(name, arity) -> Lir.HostExternal(name, arity) + | Hir.RuntimeContext -> Lir.RuntimeContext + | Hir.TargetImport(modulePath, memberName) -> Lir.TargetImport(modulePath, memberName) + | Hir.ForEach(id, name, itemType, source, body) -> Lir.ForEach(symbol id, name, itemType, expression state source, expression state body) + | Hir.TypeToken tokenType -> Lir.TypeToken tokenType + { Type = value.Type; Span = value.Span; Node = node } + + let lower (program: Hir.Program) : Lir.Program = + let state = { NextFunction = 0; Functions = ResizeArray() } + let declarations = + program.Declarations + |> List.map (fun value -> + ({ Id = symbol value.Id; Name = value.Name; Type = value.Value.Type + IsRecursive = value.IsRecursive; IsExported = value.IsExported; IsPure = value.IsPure; ExternalArity = value.ExternalArity + Export = value.Export |> Option.map (fun export -> { Name = export.Name; Span = export.Span }) + Span = value.Span; Value = expression state value.Value }: Lir.Declaration)) + let entry = program.Entry |> Option.map (expression state) + { ImportedRecords = + program.ImportedRecords + |> List.map (fun value -> + ({ Name = value.Name; ModulePath = value.ModulePath; MemberName = value.MemberName; IsUnion = value.IsUnion + Fields = value.Fields; Span = value.Span }: Lir.ImportedRecord)) + Types = + program.Types + |> List.map (fun value -> + ({ Id = symbol value.Id; Name = value.Name; IsRecursive = value.IsRecursive; IsPure = value.IsPure; Definition = value.Definition + Import = value.Import |> Option.map (fun imported -> + { Name = imported.Name; ModulePath = imported.ModulePath; MemberName = imported.MemberName + IsUnion = imported.IsUnion; Fields = imported.Fields; Span = imported.Span }) + Span = value.Span }: Lir.TypeDeclaration)) + Functions = state.Functions |> Seq.sortBy (_.Id >> Lir.functionNumber) |> Seq.toList + Declarations = declarations + Entry = entry } + +module LirValidation = + let rec private compatible left right = + match left, right with + | TVar _, _ | _, TVar _ -> true + | TFun(la, lr), TFun(ra, rr) -> compatible la ra && compatible lr rr + | TTuple left, TTuple right -> left.Length = right.Length && List.forall2 compatible left right + | TList left, TList right | TOption left, TOption right | TTask left, TTask right -> compatible left right + | TMap(lk, lv), TMap(rk, rv) -> compatible lk rk && compatible lv rv + | TRecord left, TRecord right -> + left.Count = right.Count + && (left |> Map.forall (fun name item -> right |> Map.tryFind name |> Option.exists (compatible item))) + | TUnion(ln, _), TUnion(rn, _) -> ln = rn + | _ -> left = right + + let private literalType = function + | Lir.Unit -> TUnit | Lir.Int _ -> TInt | Lir.Float _ -> TFloat + | Lir.Bool _ -> TBool | Lir.String _ -> TString + + let validate (program: Lir.Program) = + let ids = program.Declarations |> List.map _.Id + let typeIds = program.Types |> List.map _.Id + let typeDefinitions = program.Types |> List.map (fun declaration -> declaration.Name, declaration.Definition) |> Map.ofList + let knownTypes = typeDefinitions |> Map.keys |> Set.ofSeq + let resolve = function + | TNamed name as named -> typeDefinitions |> Map.tryFind name |> Option.defaultValue named + | TRecordShape(_, fields, _) -> TRecord fields + | value -> value + let compatible left right = + let rec loop visited left right = + let resolvedLeft, resolvedRight = resolve left, resolve right + let pair = resolvedLeft, resolvedRight + if Set.contains pair visited then true + else + let visited = Set.add pair visited + match resolvedLeft, resolvedRight with + | TVar _, _ | _, TVar _ -> true + | TFun(la, lr), TFun(ra, rr) -> loop visited la ra && loop visited lr rr + | TTuple left, TTuple right -> left.Length = right.Length && List.forall2 (loop visited) left right + | TList left, TList right | TOption left, TOption right | TTask left, TTask right -> loop visited left right + | TMap(lk, lv), TMap(rk, rv) -> loop visited lk rk && loop visited lv rv + | TRecord leftFields, TRecord rightFields when (match left, right with TRecordShape _, _ | _, TRecordShape _ -> true | _ -> false) -> + let required, actual = if leftFields.Count <= rightFields.Count then leftFields, rightFields else rightFields, leftFields + required |> Map.forall (fun name item -> actual |> Map.tryFind name |> Option.exists (loop visited item)) + | TRecord left, TRecord right -> + left.Count = right.Count + && (left |> Map.forall (fun name item -> right |> Map.tryFind name |> Option.exists (loop visited item))) + | TUnion(ln, _), TUnion(rn, _) -> ln = rn + | left, right -> left = right + loop Set.empty left right + let validSpan (span: Span) = + span.Start.Line >= 0 && span.Start.Column >= 0 && span.End.Line >= 0 && span.End.Column >= 0 + && (span.Start.File <> span.End.File + || span.End.Line > span.Start.Line + || (span.End.Line = span.Start.Line && span.End.Column >= span.Start.Column)) + let rec validType = function + | TVar variable -> variable >= 0 + | TFun(argument, result) -> validType argument && validType result + | TTuple items -> items |> List.forall validType + | TList item | TOption item | TTask item -> validType item + | TMap(key, value) -> validType key && validType value + | TRecord fields -> fields |> Map.forall (fun name fieldType -> not (System.String.IsNullOrWhiteSpace name) && validType fieldType) + | TUnion(name, cases) -> + Set.contains name knownTypes + && cases |> Map.forall (fun caseName payload -> not (System.String.IsNullOrWhiteSpace caseName) && payload |> Option.forall validType) + | TNamed name -> Set.contains name knownTypes + | _ -> true + let functionIds = program.Functions |> List.map _.Id + let functions = program.Functions |> List.map (fun fn -> fn.Id, fn) |> Map.ofList + let invalidImports = + program.ImportedRecords |> List.exists (fun record -> + System.String.IsNullOrWhiteSpace(record.ModulePath) || System.String.IsNullOrWhiteSpace(record.MemberName) + || not (validSpan record.Span) + || record.Fields |> List.exists (fun (name, fieldType) -> System.String.IsNullOrWhiteSpace name || not (validType fieldType))) + || (program.ImportedRecords |> List.map _.Name |> List.distinct |> List.length) <> program.ImportedRecords.Length + let invalidTypes = + (program.Types |> List.map _.Name |> List.distinct |> List.length) <> program.Types.Length + || (typeIds @ ids |> List.distinct |> List.length) <> typeIds.Length + ids.Length + || program.Types |> List.exists (fun declaration -> + not (validSpan declaration.Span) || not (validType declaration.Definition) + || match declaration.Definition with + | TRecord _ | THostManaged _ -> false + | TUnion(name, _) -> name <> declaration.Name + | _ -> true) + if invalidTypes then + Error [ { Code = "FSL2016"; Stage = Lowering; Message = "LIR type declarations must have unique IDs and names with valid definitions."; Span = None } ] + elif invalidImports then + Error [ { Code = "FSL2012"; Stage = Lowering; Message = "LIR imported record linkage must be complete and uniquely named."; Span = None } ] + elif ids.Length <> (ids |> Set.ofList |> Set.count) then + Error [ { Code = "FSL2001"; Stage = Lowering; Message = "LIR declaration IDs must be unique."; Span = None } ] + elif functionIds <> ([ 0 .. functionIds.Length - 1 ] |> List.map Lir.FunctionId) then + Error [ { Code = "FSL2014"; Stage = Lowering; Message = "LIR function IDs must be unique, contiguous, and ordered."; Span = None } ] + else + let diagnostics = ResizeArray() + let report code message span = + diagnostics.Add({ Code = code; Stage = Lowering; Message = message; Span = Some span }) + let checkSpan span = if not (validSpan span) then report "FSL2002" "LIR source span is invalid." span + let checkType span valueType = if not (validType valueType) then report "FSL2017" "LIR contains an unresolved or invalid semantic type." span + program.Declarations |> List.iter (fun declaration -> + if declaration.IsExported <> declaration.Export.IsSome || (declaration.Export |> Option.exists (fun export -> export.Name <> declaration.Name || not (validSpan export.Span))) then + report "FSL2015" "LIR export metadata is inconsistent." declaration.Span) + let rec projectionType checks traversed current = function + | [] -> Some current + | step :: rest -> + let next = + match step, resolve current with + | Lir.ListHead, TList item -> Some item + | Lir.ListTail, TList _ -> Some current + | Lir.TupleItem index, TTuple items when index >= 0 && index < items.Length -> Some items.[index] + | Lir.RecordField name, (TRecord fields | THostManaged(_,fields)) -> Map.tryFind name fields + | Lir.OptionValue, TOption item -> Some item + | Lir.UnionPayload, TUnion(_, cases) -> + checks + |> List.tryPick (function + | Lir.UnionCaseCheck(projection, _, caseName, true) when projection = traversed -> + Map.tryFind caseName cases |> Option.flatten + | _ -> None) + | _ -> None + next |> Option.bind (fun item -> projectionType checks (traversed @ [ step ]) item rest) + let rec checkPlan expected (plan: Lir.PatternPlan) = + checkSpan plan.Span + checkType plan.Span expected + let at projection = projectionType plan.Checks [] expected projection + let require projection predicate message = + match at projection with Some value when predicate (resolve value) -> () | _ -> report "FSL2003" message plan.Span + for check in plan.Checks do + match check with + | Lir.LiteralCheck(projection, value) -> require projection (compatible (literalType value)) "LIR literal plan has an inconsistent projection type." + | Lir.EmptyListCheck projection | Lir.NonEmptyListCheck projection -> require projection (function TList _ -> true | _ -> false) "LIR list plan requires a list projection." + | Lir.TupleArityCheck(projection, arity) -> require projection (function TTuple items -> items.Length = arity | _ -> false) "LIR tuple plan has an inconsistent arity." + | Lir.RecordFieldCheck(projection, name) -> require projection (function TRecord fields | THostManaged(_,fields) -> Map.containsKey name fields | _ -> false) $"LIR record plan references unknown field '{name}'." + | Lir.SomeCheck projection | Lir.NoneCheck projection -> require projection (function TOption _ -> true | _ -> false) "LIR option plan requires an option projection." + | Lir.UnionCaseCheck(projection, typeName, caseName, hasPayload) -> + require projection (function TUnion(actual, cases) when actual = typeName -> Map.tryFind caseName cases |> Option.exists (fun payload -> payload.IsSome = hasPayload) | _ -> false) "LIR union plan has inconsistent case metadata." + | Lir.TypeCheck(projection, patternType) -> checkType plan.Span patternType; require projection (fun _ -> true) "LIR type-test plan has an invalid projection." + for binding in plan.Bindings do + checkType plan.Span binding.Type + require binding.Projection (compatible binding.Type) "LIR pattern binding has an inconsistent projection type." + for mapPlan in plan.Maps do + match at mapPlan.Projection |> Option.map resolve with + | Some(TMap(keyType, valueType) as mapType) -> + mapPlan.Clauses |> List.iter (fun clause -> checkPlan keyType clause.Key; checkPlan valueType clause.Value) + mapPlan.Tail |> Option.iter (checkPlan mapType) + | _ -> report "FSL2003" "LIR map plan requires a map projection." plan.Span + let rec patternBindings (plan: Lir.PatternPlan) = + [ plan.Bindings |> List.map _.Id |> Set.ofList + yield! + plan.Maps + |> List.collect (fun mapPlan -> + [ yield! mapPlan.Clauses |> List.collect (fun clause -> [ patternBindings clause.Key; patternBindings clause.Value ]) + yield! mapPlan.Tail |> Option.map patternBindings |> Option.toList ]) ] + |> Set.unionMany + let declared = ids |> Set.ofList + let rec checkExpression locals (expression: Lir.Expression) = + checkSpan expression.Span + checkType expression.Span expression.Type + let check = checkExpression locals + match expression.Node with + | Lir.Constant value when not (compatible expression.Type (literalType value)) -> report "FSL2004" "LIR constant has an inconsistent type." expression.Span + | Lir.Load id when not (Set.contains id locals || Set.contains id declared) -> report "FSL2005" (sprintf "LIR reference %%%d is unresolved." (Lir.symbolNumber id)) expression.Span + | Lir.MakeClosure(functionId, captures) -> + if captures |> List.exists (fun id -> not (Set.contains id locals || Set.contains id declared)) then + let missing=captures |> List.filter (fun id -> not (Set.contains id locals || Set.contains id declared)) |> List.map Lir.symbolNumber + report "FSL2005" $"LIR closure {Lir.functionNumber functionId} contains unresolved captures {missing} at {expression.Span.Start.File}:{expression.Span.Start.Line}." expression.Span + match Map.tryFind functionId functions with + | None -> report "FSL2014" "LIR closure references an unknown lifted function." expression.Span + | Some fn -> + if captures <> fn.Captures then report "FSL2013" "LIR closure captures do not match its lifted function." expression.Span + match expression.Type with + | TFun(argument, result) when compatible argument fn.ParameterType && compatible result fn.ReturnType -> () + | _ -> report "FSL2006" "LIR closure signature is inconsistent with its lifted function." expression.Span + | Lir.CallClosure(fn, argument) | Lir.TailCallClosure(fn, argument) -> + check fn; check argument + match fn.Type with TFun(parameter, result) when compatible parameter argument.Type && compatible result expression.Type -> () | _ -> report "FSL2006" "LIR closure call signature is inconsistent." expression.Span + | Lir.PipeClosure(argument, fn) | Lir.TailPipeClosure(argument, fn) -> + check argument; check fn + match fn.Type with TFun(parameter, result) when compatible parameter argument.Type && compatible result expression.Type -> () | _ -> report "FSL2006" "LIR pipeline call signature is inconsistent." expression.Span + | Lir.Branch(condition, whenTrue, whenFalse) -> + check condition; check whenTrue; check whenFalse + if not (compatible condition.Type TBool && compatible expression.Type whenTrue.Type && compatible expression.Type whenFalse.Type) then report "FSL2007" "LIR branch types are inconsistent." expression.Span + | Lir.Operation(operation, arguments) -> + arguments |> List.iter check + let expected = + match operation with + | Lir.NumericAdd | Lir.NumericSubtract | Lir.NumericMultiply | Lir.NumericDivide -> Some(expression.Type, expression.Type) + | Lir.IntAdd | Lir.IntSubtract | Lir.IntMultiply | Lir.IntDivide | Lir.IntRemainder -> Some(TInt, TInt) + | Lir.FloatAdd | Lir.FloatSubtract | Lir.FloatMultiply | Lir.FloatDivide -> Some(TFloat, TFloat) + | Lir.BooleanAnd | Lir.BooleanOr -> Some(TBool, TBool) + | Lir.StructuralEqual -> None + | _ -> Some((arguments |> List.tryHead |> Option.map _.Type |> Option.defaultValue TInt), TBool) + if arguments.Length <> 2 then report "FSL2008" "LIR primitive operation requires two operands." expression.Span + match expected with Some(operand, result) when not (arguments |> List.forall (fun item -> compatible operand item.Type) && compatible result expression.Type) -> report "FSL2008" "LIR primitive operand or result type is inconsistent." expression.Span | _ -> () + | Lir.Tuple items -> items |> List.iter check; match expression.Type with TTuple types when types.Length = items.Length && List.forall2 (fun expected (item: Lir.Expression) -> compatible expected item.Type) types items -> () | _ -> report "FSL2004" "LIR tuple representation is inconsistent." expression.Span + | Lir.List items -> items |> List.iter check; match expression.Type with TList itemType when items |> List.forall (fun item -> compatible itemType item.Type) -> () | _ -> report "FSL2004" "LIR list representation is inconsistent." expression.Span + | Lir.Record fields -> fields |> List.iter (snd >> check); match resolve expression.Type with TRecord types when fields.Length = types.Count && fields |> List.forall (fun (name, item) -> Map.tryFind name types |> Option.exists (fun expected -> compatible expected item.Type)) -> () | _ -> report "FSL2004" "LIR record representation is inconsistent." expression.Span + | Lir.FieldGet(target, name) -> + check target + match resolve target.Type, name with + | TRecord fields, _ | THostManaged(_, fields), _ when Map.tryFind name fields |> Option.exists (compatible expression.Type) -> () + | TNamed "Environment", "ScriptName" when compatible expression.Type (TOption TString) -> () + | TNamed "Environment", "Arguments" when compatible expression.Type (TList TString) -> () + | _ -> report "FSL2004" $"LIR field projection '{name}' is inconsistent." expression.Span + | Lir.SomeValue item -> check item; match expression.Type with TOption itemType when compatible itemType item.Type -> () | _ -> report "FSL2004" "LIR option representation is inconsistent." expression.Span + | Lir.NoneValue -> match expression.Type with TOption _ -> () | _ -> report "FSL2004" "LIR none value requires an option type." expression.Span + | Lir.Cons(head, tail) -> check head; check tail; match expression.Type, tail.Type with TList item, TList tailItem when compatible item head.Type && compatible item tailItem -> () | _ -> report "FSL2004" "LIR cons representation is inconsistent." expression.Span + | Lir.Append(left, right) -> check left; check right; if not (compatible expression.Type left.Type && compatible expression.Type right.Type) then report "FSL2004" "LIR append representation is inconsistent." expression.Span + | Lir.Let(id, _, recursive, binding, body) -> let scope = Set.add id locals in checkExpression (if recursive then scope else locals) binding; checkExpression scope body; if not (compatible expression.Type body.Type) then report "FSL2004" "LIR let result type is inconsistent." expression.Span + | Lir.LetRecursiveGroup(bindings, body) -> let scope = bindings |> List.fold (fun value (id, _, _, _) -> Set.add id value) locals in bindings |> List.iter (fun (_, _, bindingType, value) -> checkType value.Span bindingType; checkExpression scope value; if not (compatible bindingType value.Type) then report "FSL2006" "LIR recursive binding signature is inconsistent." value.Span); checkExpression scope body; if not (compatible expression.Type body.Type) then report "FSL2004" "LIR recursive group result is inconsistent." expression.Span + | Lir.Fail value -> check value + | Lir.DecisionTree(target, cases) -> check target; cases |> List.iter (fun case -> let caseLocals = Set.union locals (patternBindings case.Plan) in checkPlan target.Type case.Plan; case.Guard |> Option.iter (fun guard -> checkExpression caseLocals guard; if not (compatible guard.Type TBool) then report "FSL2007" "LIR decision guard must be Boolean." guard.Span); checkExpression caseLocals case.Body; if not (compatible expression.Type case.Body.Type) then report "FSL2007" "LIR decision body type is inconsistent." case.Body.Span) + | Lir.Range(first, last) -> check first; check last; if not (compatible first.Type TInt && compatible last.Type TInt && compatible expression.Type (TList TInt)) then report "FSL2004" "LIR range representation is inconsistent." expression.Span + | Lir.RecordUpdate(target, fields) -> + check target + fields |> List.iter (snd >> check) + match resolve target.Type, resolve expression.Type with + | TRecord targetFields, TRecord resultFields -> + let preservesTarget = + targetFields + |> Map.forall (fun name fieldType -> + resultFields |> Map.tryFind name |> Option.exists (compatible fieldType)) + let validUpdates = + fields + |> List.forall (fun (name, value) -> + resultFields |> Map.tryFind name |> Option.exists (compatible value.Type)) + if not (preservesTarget && validUpdates) then + report "FSL2004" "LIR record update representation is inconsistent." expression.Span + | _ -> report "FSL2004" "LIR record update representation is inconsistent." expression.Span + | Lir.RecordConvert(target, targetType) -> check target; checkType expression.Span targetType; match resolve target.Type, resolve targetType with TRecord _, TRecord _ when compatible expression.Type targetType -> () | _ -> report "FSL2004" "LIR record conversion evidence is inconsistent." expression.Span + | Lir.IndexGet(target, index) -> check target; check index; match target.Type, expression.Type with TList item, TOption result when compatible index.Type TInt && compatible item result -> () | TMap(key, value), TOption result when compatible key index.Type && compatible value result -> () | _ -> report "FSL2004" "LIR index representation is inconsistent." expression.Span + | Lir.Interpolate parts -> parts |> List.iter (function Lir.TextPart _ -> () | Lir.ValuePart value -> check value); if not (compatible expression.Type TString) then report "FSL2004" "LIR interpolation must produce string." expression.Span + | Lir.UnionCase(typeName, caseName, payload) -> payload |> Option.iter check; match resolve expression.Type with TUnion(actual, cases) when actual = typeName && Map.containsKey caseName cases -> () | _ -> report "FSL2004" "LIR union representation is inconsistent." expression.Span + | Lir.Map entries -> entries |> List.iter (function Lir.KeyValue(key, value) -> check key; check value | Lir.Spread value -> check value); match expression.Type with TMap _ -> () | _ -> report "FSL2004" "LIR map node requires a map type." expression.Span + | Lir.Intrinsic name when not (Map.containsKey name BuiltinSignatures.builtinSchemes || Map.containsKey name RuntimeIntrinsics.schemes) -> report "FSL2009" $"Unknown LIR intrinsic '{name}'." expression.Span + | Lir.HostExternal(_, arity) when arity < 0 -> report "FSL2010" "LIR host external arity cannot be negative." expression.Span + | Lir.TargetImport(modulePath, memberName) when System.String.IsNullOrWhiteSpace(modulePath) || System.String.IsNullOrWhiteSpace(memberName) -> report "FSL2011" "LIR target import linkage is incomplete." expression.Span + | Lir.ForEach(id, _, itemType, source, body) -> checkType expression.Span itemType; check source; checkExpression (Set.add id locals) body; match source.Type with TList actual when compatible actual itemType && compatible expression.Type TUnit -> () | _ -> report "FSL2004" "LIR for-loop representation is inconsistent." expression.Span + | Lir.TypeToken tokenType -> checkType expression.Span tokenType; if not (compatible expression.Type TTypeToken) then report "FSL2004" "LIR type token has an inconsistent type." expression.Span + | _ -> () + program.Functions |> List.iter (fun fn -> + checkSpan fn.Span + checkType fn.Span fn.ParameterType + checkType fn.Span fn.ReturnType + let expected = LirLowering.capturedReferences (Set.singleton fn.Parameter) fn.Body |> Set.toList |> List.sortBy Lir.symbolNumber + if fn.Captures <> expected then report "FSL2013" "Lifted LIR function captures do not match its ordered free-symbol set." fn.Span + checkExpression (Set.add fn.Parameter (Set.ofList fn.Captures)) fn.Body + if not (compatible fn.ReturnType fn.Body.Type) then report "FSL2006" "Lifted LIR function return type is inconsistent." fn.Span) + program.Declarations |> List.iter (fun declaration -> checkSpan declaration.Span; checkType declaration.Span declaration.Type; checkExpression Set.empty declaration.Value; if not (compatible declaration.Type declaration.Value.Type) then report "FSL2004" $"LIR declaration '{declaration.Name}' type is inconsistent." declaration.Span) + for declaration in program.Declarations do + if declaration.IsPure then + match declaration.Value.Node,declaration.ExternalArity with + | Lir.HostExternal _,Some _ | Lir.TargetImport _,Some _ -> () + | _ -> report "FSL2018" "Pure contracts require an external function binding and its application arity." declaration.Span + match declaration.ExternalArity with + | Some arity -> + let valid = + match declaration.Value.Node with + | Lir.HostExternal(_,actual) -> actual=arity + | Lir.TargetImport _ | Lir.Intrinsic _ | Lir.RuntimeContext -> true + | _ -> false + if arity<0 || not valid then report "FSL2018" "External application arity is invalid or inconsistent." declaration.Span + | None -> () + program.Entry |> Option.iter (checkExpression Set.empty) + if diagnostics.Count = 0 then Ok program else Error(List.ofSeq diagnostics) + +module LirOptimization = + type Effect = + | Pure + | Observable + + let private combine effects = + if effects |> List.exists ((=) Observable) then Observable else Pure + + let rec private unknownExternalValue = function + | TNamed _ | THostManaged _ -> true + | TRecord fields | TRecordShape(_,fields,_) -> fields |> Map.exists (fun _ value -> unknownExternalValue value) + | TUnion(_,cases) -> cases |> Map.exists (fun _ value -> value |> Option.exists unknownExternalValue) + | TTuple values -> List.exists unknownExternalValue values + | TList value | TOption value | TTask value -> unknownExternalValue value + | TMap(key,value) -> unknownExternalValue key || unknownExternalValue value + | _ -> false + + let rec effect (expression: Lir.Expression) = + let child = effect + match expression.Node with + | Lir.Constant _ | Lir.Load _ | Lir.MakeClosure _ | Lir.NoneValue | Lir.Intrinsic _ + | Lir.HostExternal _ | Lir.RuntimeContext | Lir.TargetImport _ | Lir.TypeToken _ -> Pure + | Lir.CallClosure _ | Lir.PipeClosure _ | Lir.TailCallClosure _ | Lir.TailPipeClosure _ + | Lir.Fail _ | Lir.ForEach _ -> Observable + | Lir.Operation((Lir.IntDivide | Lir.IntRemainder | Lir.NumericDivide), _) -> Observable + | Lir.Operation(Lir.StructuralEqual, arguments) when arguments |> List.exists (fun value -> unknownExternalValue value.Type) -> Observable + | Lir.Operation(_, arguments) | Lir.Tuple arguments | Lir.List arguments -> arguments |> List.map child |> combine + | Lir.Branch(condition, whenTrue, whenFalse) -> [ child condition; child whenTrue; child whenFalse ] |> combine + | Lir.Record _ when unknownExternalValue expression.Type -> Observable + | Lir.Record fields -> fields |> List.map (snd >> child) |> combine + | Lir.FieldGet(target, _) -> + match target.Type with TNamed _ | THostManaged _ -> Observable | _ -> child target + | Lir.RecordConvert(target, resultType) -> + if unknownExternalValue target.Type || unknownExternalValue resultType then Observable else child target + | Lir.SomeValue target -> child target + | Lir.Cons(head, tail) | Lir.Append(head, tail) | Lir.Range(head, tail) | Lir.IndexGet(head, tail) -> [ child head; child tail ] |> combine + | Lir.Let(_, _, _, binding, body) -> [ child binding; child body ] |> combine + | Lir.LetRecursiveGroup(bindings, body) -> child body :: (bindings |> List.map (fun (_, _, _, value) -> child value)) |> combine + | Lir.DecisionTree(target, _) when unknownExternalValue target.Type -> Observable + | Lir.DecisionTree(_, cases) when not (cases |> List.tryLast |> Option.exists (fun case -> case.Guard.IsNone && case.Plan.Checks.IsEmpty && case.Plan.Maps.IsEmpty)) -> Observable + | Lir.DecisionTree(target, cases) -> + child target + :: (cases |> List.collect (fun case -> [ yield! case.Guard |> Option.map child |> Option.toList; child case.Body ])) + |> combine + | Lir.RecordUpdate(target, _) when unknownExternalValue target.Type -> Observable + | Lir.RecordUpdate(target, fields) -> child target :: (fields |> List.map (snd >> child)) |> combine + | Lir.Interpolate parts -> parts |> List.map (function Lir.TextPart _ -> Pure | Lir.ValuePart value -> if unknownExternalValue value.Type then Observable else child value) |> combine + | Lir.UnionCase(_, _, payload) -> payload |> Option.map child |> Option.defaultValue Pure + | Lir.Map entries -> + entries + |> List.collect (function Lir.KeyValue(key, value) -> [ child key; child value ] | Lir.Spread value -> [ child value ]) + |> combine + + let rec loadedSymbols (expression: Lir.Expression) = + let child = loadedSymbols + match expression.Node with + | Lir.Load id -> Set.singleton id + | Lir.MakeClosure(_, captures) -> Set.ofList captures + | Lir.CallClosure(fn, argument) | Lir.PipeClosure(argument, fn) + | Lir.TailCallClosure(fn, argument) | Lir.TailPipeClosure(argument, fn) + | Lir.Cons(fn, argument) + | Lir.Append(fn, argument) | Lir.Range(fn, argument) | Lir.IndexGet(fn, argument) -> Set.union (child fn) (child argument) + | Lir.Branch(condition, whenTrue, whenFalse) -> [ child condition; child whenTrue; child whenFalse ] |> Set.unionMany + | Lir.Operation(_, arguments) | Lir.Tuple arguments | Lir.List arguments -> arguments |> List.map child |> Set.unionMany + | Lir.Record fields -> fields |> List.map (snd >> child) |> Set.unionMany + | Lir.FieldGet(target, _) | Lir.SomeValue target | Lir.Fail target | Lir.RecordConvert(target, _) -> child target + | Lir.Let(_, _, _, binding, body) -> Set.union (child binding) (child body) + | Lir.LetRecursiveGroup(bindings, body) -> child body :: (bindings |> List.map (fun (_, _, _, value) -> child value)) |> Set.unionMany + | Lir.DecisionTree(target, cases) -> + child target + :: (cases |> List.collect (fun case -> [ yield! case.Guard |> Option.map child |> Option.toList; child case.Body ])) + |> Set.unionMany + | Lir.RecordUpdate(target, fields) -> child target :: (fields |> List.map (snd >> child)) |> Set.unionMany + | Lir.Interpolate parts -> parts |> List.choose (function Lir.TextPart _ -> None | Lir.ValuePart value -> Some(child value)) |> Set.unionMany + | Lir.UnionCase(_, _, payload) -> payload |> Option.map child |> Option.defaultValue Set.empty + | Lir.Map entries -> entries |> List.map (function Lir.KeyValue(key, value) -> Set.union (child key) (child value) | Lir.Spread value -> child value) |> Set.unionMany + | Lir.ForEach(_, _, _, source, body) -> Set.union (child source) (child body) + | Lir.Constant _ | Lir.NoneValue | Lir.Intrinsic _ | Lir.HostExternal _ + | Lir.RuntimeContext | Lir.TargetImport _ | Lir.TypeToken _ -> Set.empty + + let rec private simplify (expression: Lir.Expression) = + let recurse (value: Lir.Expression) : Lir.Expression = simplify value + let withNode node = { expression with Node = node } + match expression.Node with + | Lir.Branch(condition, whenTrue, whenFalse) -> + let condition = recurse condition + match condition.Node with + | Lir.Constant(Lir.Bool true) -> recurse whenTrue + | Lir.Constant(Lir.Bool false) -> recurse whenFalse + | _ -> withNode (Lir.Branch(condition, recurse whenTrue, recurse whenFalse)) + | Lir.Operation(Lir.BooleanAnd, [ left; right ]) -> + let left = recurse left + match left.Node with + | Lir.Constant(Lir.Bool false) -> left + | Lir.Constant(Lir.Bool true) -> recurse right + | _ -> withNode (Lir.Operation(Lir.BooleanAnd, [ left; recurse right ])) + | Lir.Operation(Lir.BooleanOr, [ left; right ]) -> + let left = recurse left + match left.Node with + | Lir.Constant(Lir.Bool true) -> left + | Lir.Constant(Lir.Bool false) -> recurse right + | _ -> withNode (Lir.Operation(Lir.BooleanOr, [ left; recurse right ])) + | Lir.Let(id, name, recursive, binding, body) -> + let binding, body = recurse binding, recurse body + match body.Node with + | Lir.Load loaded when loaded = id && not recursive -> binding + | _ when not (Set.contains id (loadedSymbols body)) && effect binding = Pure -> body + | _ -> withNode (Lir.Let(id, name, recursive, binding, body)) + | Lir.LetRecursiveGroup(bindings, body) -> + let bindings = bindings |> List.map (fun (id, name, valueType, value) -> id, name, valueType, recurse value) + let body = recurse body + let ids = bindings |> List.map (fun (id, _, _, _) -> id) |> Set.ofList + let used = Set.intersect ids (loadedSymbols body) + if used.IsEmpty && bindings |> List.forall (fun (_, _, _, value) -> effect value = Pure) then body + else withNode (Lir.LetRecursiveGroup(bindings, body)) + | Lir.CallClosure(fn, argument) -> withNode (Lir.CallClosure(recurse fn, recurse argument)) + | Lir.PipeClosure(argument, fn) -> withNode (Lir.PipeClosure(recurse argument, recurse fn)) + | Lir.TailCallClosure(fn, argument) -> withNode (Lir.TailCallClosure(recurse fn, recurse argument)) + | Lir.TailPipeClosure(argument, fn) -> withNode (Lir.TailPipeClosure(recurse argument, recurse fn)) + | Lir.Operation(operation, arguments) -> withNode (Lir.Operation(operation, List.map recurse arguments)) + | Lir.Tuple items -> withNode (Lir.Tuple(List.map recurse items)) + | Lir.List items -> withNode (Lir.List(List.map recurse items)) + | Lir.Record fields -> withNode (Lir.Record(fields |> List.map (fun (name, value) -> name, recurse value))) + | Lir.FieldGet(target, name) -> withNode (Lir.FieldGet(recurse target, name)) + | Lir.SomeValue value -> withNode (Lir.SomeValue(recurse value)) + | Lir.Cons(head, tail) -> withNode (Lir.Cons(recurse head, recurse tail)) + | Lir.Append(left, right) -> withNode (Lir.Append(recurse left, recurse right)) + | Lir.Fail value -> withNode (Lir.Fail(recurse value)) + | Lir.DecisionTree(target, cases) -> + withNode (Lir.DecisionTree(recurse target, cases |> List.map (fun case -> { case with Guard = Option.map recurse case.Guard; Body = recurse case.Body }))) + | Lir.Range(first, last) -> withNode (Lir.Range(recurse first, recurse last)) + | Lir.RecordUpdate(target, fields) -> withNode (Lir.RecordUpdate(recurse target, fields |> List.map (fun (name, value) -> name, recurse value))) + | Lir.RecordConvert(target, targetType) -> withNode (Lir.RecordConvert(recurse target, targetType)) + | Lir.IndexGet(target, index) -> withNode (Lir.IndexGet(recurse target, recurse index)) + | Lir.Interpolate parts -> withNode (Lir.Interpolate(parts |> List.map (function Lir.TextPart text -> Lir.TextPart text | Lir.ValuePart value -> Lir.ValuePart(recurse value)))) + | Lir.UnionCase(typeName, caseName, payload) -> withNode (Lir.UnionCase(typeName, caseName, Option.map recurse payload)) + | Lir.Map entries -> withNode (Lir.Map(entries |> List.map (function Lir.KeyValue(key, value) -> Lir.KeyValue(recurse key, recurse value) | Lir.Spread value -> Lir.Spread(recurse value)))) + | Lir.ForEach(id, name, itemType, source, body) -> withNode (Lir.ForEach(id, name, itemType, recurse source, recurse body)) + | _ -> expression + + let rec private rewriteClosures functionMap captureMap (expression: Lir.Expression) = + let recurse = rewriteClosures functionMap captureMap + let withNode node = { expression with Node = node } + match expression.Node with + | Lir.MakeClosure(id, captures) -> + let mapped = Map.tryFind id functionMap |> Option.defaultValue id + withNode (Lir.MakeClosure(mapped, Map.tryFind id captureMap |> Option.defaultValue captures)) + | Lir.CallClosure(fn, argument) -> withNode (Lir.CallClosure(recurse fn, recurse argument)) + | Lir.PipeClosure(argument, fn) -> withNode (Lir.PipeClosure(recurse argument, recurse fn)) + | Lir.TailCallClosure(fn, argument) -> withNode (Lir.TailCallClosure(recurse fn, recurse argument)) + | Lir.TailPipeClosure(argument, fn) -> withNode (Lir.TailPipeClosure(recurse argument, recurse fn)) + | Lir.Branch(condition, whenTrue, whenFalse) -> withNode (Lir.Branch(recurse condition, recurse whenTrue, recurse whenFalse)) + | Lir.Operation(operation, arguments) -> withNode (Lir.Operation(operation, List.map recurse arguments)) + | Lir.Tuple items -> withNode (Lir.Tuple(List.map recurse items)) + | Lir.List items -> withNode (Lir.List(List.map recurse items)) + | Lir.Record fields -> withNode (Lir.Record(fields |> List.map (fun (name, value) -> name, recurse value))) + | Lir.FieldGet(target, name) -> withNode (Lir.FieldGet(recurse target, name)) + | Lir.SomeValue value -> withNode (Lir.SomeValue(recurse value)) + | Lir.Cons(head, tail) -> withNode (Lir.Cons(recurse head, recurse tail)) + | Lir.Append(left, right) -> withNode (Lir.Append(recurse left, recurse right)) + | Lir.Let(id, name, recursive, binding, body) -> withNode (Lir.Let(id, name, recursive, recurse binding, recurse body)) + | Lir.LetRecursiveGroup(bindings, body) -> withNode (Lir.LetRecursiveGroup(bindings |> List.map (fun (id, name, valueType, value) -> id, name, valueType, recurse value), recurse body)) + | Lir.Fail value -> withNode (Lir.Fail(recurse value)) + | Lir.DecisionTree(target, cases) -> withNode (Lir.DecisionTree(recurse target, cases |> List.map (fun case -> { case with Guard = Option.map recurse case.Guard; Body = recurse case.Body }))) + | Lir.Range(first, last) -> withNode (Lir.Range(recurse first, recurse last)) + | Lir.RecordUpdate(target, fields) -> withNode (Lir.RecordUpdate(recurse target, fields |> List.map (fun (name, value) -> name, recurse value))) + | Lir.RecordConvert(target, targetType) -> withNode (Lir.RecordConvert(recurse target, targetType)) + | Lir.IndexGet(target, index) -> withNode (Lir.IndexGet(recurse target, recurse index)) + | Lir.Interpolate parts -> withNode (Lir.Interpolate(parts |> List.map (function Lir.TextPart text -> Lir.TextPart text | Lir.ValuePart value -> Lir.ValuePart(recurse value)))) + | Lir.UnionCase(typeName, caseName, payload) -> withNode (Lir.UnionCase(typeName, caseName, Option.map recurse payload)) + | Lir.Map entries -> withNode (Lir.Map(entries |> List.map (function Lir.KeyValue(key, value) -> Lir.KeyValue(recurse key, recurse value) | Lir.Spread value -> Lir.Spread(recurse value)))) + | Lir.ForEach(id, name, itemType, source, body) -> withNode (Lir.ForEach(id, name, itemType, recurse source, recurse body)) + | _ -> expression + + let rec private markTailCalls isTail (expression: Lir.Expression) = + let nested value = markTailCalls false value + let tail value = markTailCalls isTail value + let withNode node = { expression with Node = node } + match expression.Node with + | Lir.CallClosure(fn, argument) -> + let fn, argument = nested fn, nested argument + if isTail then withNode (Lir.TailCallClosure(fn, argument)) else withNode (Lir.CallClosure(fn, argument)) + | Lir.PipeClosure(argument, fn) -> + let argument, fn = nested argument, nested fn + if isTail then withNode (Lir.TailPipeClosure(argument, fn)) else withNode (Lir.PipeClosure(argument, fn)) + | Lir.TailCallClosure(fn, argument) -> withNode (Lir.TailCallClosure(nested fn, nested argument)) + | Lir.TailPipeClosure(argument, fn) -> withNode (Lir.TailPipeClosure(nested argument, nested fn)) + | Lir.Branch(condition, whenTrue, whenFalse) -> withNode (Lir.Branch(nested condition, tail whenTrue, tail whenFalse)) + | Lir.Let(id, name, recursive, binding, body) -> withNode (Lir.Let(id, name, recursive, nested binding, tail body)) + | Lir.LetRecursiveGroup(bindings, body) -> + withNode (Lir.LetRecursiveGroup(bindings |> List.map (fun (id, name, valueType, value) -> id, name, valueType, nested value), tail body)) + | Lir.DecisionTree(target, cases) -> + withNode (Lir.DecisionTree(nested target, cases |> List.map (fun case -> { case with Guard = Option.map nested case.Guard; Body = tail case.Body }))) + | Lir.Operation(operation, arguments) -> withNode (Lir.Operation(operation, List.map nested arguments)) + | Lir.Tuple items -> withNode (Lir.Tuple(List.map nested items)) + | Lir.List items -> withNode (Lir.List(List.map nested items)) + | Lir.Record fields -> withNode (Lir.Record(fields |> List.map (fun (name, value) -> name, nested value))) + | Lir.FieldGet(target, name) -> withNode (Lir.FieldGet(nested target, name)) + | Lir.SomeValue value -> withNode (Lir.SomeValue(nested value)) + | Lir.Cons(head, rest) -> withNode (Lir.Cons(nested head, nested rest)) + | Lir.Append(left, right) -> withNode (Lir.Append(nested left, nested right)) + | Lir.Fail value -> withNode (Lir.Fail(nested value)) + | Lir.Range(first, last) -> withNode (Lir.Range(nested first, nested last)) + | Lir.RecordUpdate(target, fields) -> withNode (Lir.RecordUpdate(nested target, fields |> List.map (fun (name, value) -> name, nested value))) + | Lir.RecordConvert(target, targetType) -> withNode (Lir.RecordConvert(nested target, targetType)) + | Lir.IndexGet(target, index) -> withNode (Lir.IndexGet(nested target, nested index)) + | Lir.Interpolate parts -> withNode (Lir.Interpolate(parts |> List.map (function Lir.TextPart text -> Lir.TextPart text | Lir.ValuePart value -> Lir.ValuePart(nested value)))) + | Lir.UnionCase(typeName, caseName, payload) -> withNode (Lir.UnionCase(typeName, caseName, Option.map nested payload)) + | Lir.Map entries -> withNode (Lir.Map(entries |> List.map (function Lir.KeyValue(key, value) -> Lir.KeyValue(nested key, nested value) | Lir.Spread value -> Lir.Spread(nested value)))) + | Lir.ForEach(id, name, itemType, source, body) -> withNode (Lir.ForEach(id, name, itemType, nested source, nested body)) + | _ -> expression + + let optimize (program: Lir.Program) = + let simplifiedFunctions = program.Functions |> List.map (fun fn -> { fn with Body = fn.Body |> simplify |> markTailCalls true }) + let identityFunctionMap = simplifiedFunctions |> List.map (fun fn -> fn.Id, fn.Id) |> Map.ofList + let rec stabilizeCaptures (functions: Lir.Function list) = + let captureMap = functions |> List.map (fun fn -> fn.Id, (LirLowering.capturedReferences (Set.singleton fn.Parameter) fn.Body |> Set.toList |> List.sortBy Lir.symbolNumber)) |> Map.ofList + let updated = functions |> List.map (fun fn -> { fn with Captures = captureMap.[fn.Id]; Body = rewriteClosures identityFunctionMap captureMap fn.Body }) + if updated = functions then updated,captureMap else stabilizeCaptures updated + let functions,captureMap = stabilizeCaptures simplifiedFunctions + let declarations = program.Declarations |> List.map (fun declaration -> { declaration with Value = declaration.Value |> simplify |> rewriteClosures identityFunctionMap captureMap }) + let entry = program.Entry |> Option.map (simplify >> rewriteClosures identityFunctionMap captureMap) + let declarationMap = declarations |> List.map (fun declaration -> declaration.Id, declaration) |> Map.ofList + let functionById = functions |> List.map (fun fn -> fn.Id, fn) |> Map.ofList + let reachableDeclarations = System.Collections.Generic.HashSet() + let reachableFunctions = System.Collections.Generic.HashSet() + let rec visitExpression (expression: Lir.Expression) = + for id in loadedSymbols expression do + match Map.tryFind id declarationMap with + | Some declaration when reachableDeclarations.Add id -> visitExpression declaration.Value + | _ -> () + let rec closures (value: Lir.Expression) = + match value.Node with + | Lir.MakeClosure(id, _) when reachableFunctions.Add id -> + match Map.tryFind id functionById with Some fn -> visitExpression fn.Body | None -> () + | _ -> + let collect child = closures child + match value.Node with + | Lir.CallClosure(fn, argument) | Lir.PipeClosure(argument, fn) + | Lir.TailCallClosure(fn, argument) | Lir.TailPipeClosure(argument, fn) + | Lir.Cons(fn, argument) + | Lir.Append(fn, argument) | Lir.Range(fn, argument) | Lir.IndexGet(fn, argument) -> collect fn; collect argument + | Lir.Branch(condition, whenTrue, whenFalse) -> collect condition; collect whenTrue; collect whenFalse + | Lir.Operation(_, arguments) | Lir.Tuple arguments | Lir.List arguments -> List.iter collect arguments + | Lir.Record fields -> fields |> List.iter (snd >> collect) + | Lir.FieldGet(target, _) | Lir.SomeValue target | Lir.Fail target | Lir.RecordConvert(target, _) -> collect target + | Lir.Let(_, _, _, binding, body) -> collect binding; collect body + | Lir.LetRecursiveGroup(bindings, body) -> bindings |> List.iter (fun (_, _, _, binding) -> collect binding); collect body + | Lir.DecisionTree(target, cases) -> collect target; cases |> List.iter (fun case -> Option.iter collect case.Guard; collect case.Body) + | Lir.RecordUpdate(target, fields) -> collect target; fields |> List.iter (snd >> collect) + | Lir.Interpolate parts -> parts |> List.iter (function Lir.TextPart _ -> () | Lir.ValuePart item -> collect item) + | Lir.UnionCase(_, _, payload) -> Option.iter collect payload + | Lir.Map entries -> entries |> List.iter (function Lir.KeyValue(key, item) -> collect key; collect item | Lir.Spread item -> collect item) + | Lir.ForEach(_, _, _, source, body) -> collect source; collect body + | _ -> () + closures expression + declarations + |> List.iter (fun declaration -> + if declaration.IsExported || effect declaration.Value = Observable then + if reachableDeclarations.Add declaration.Id then visitExpression declaration.Value) + Option.iter visitExpression entry + let retainedFunctions = functions |> List.filter (fun fn -> reachableFunctions.Contains fn.Id) + let functionMap = retainedFunctions |> List.mapi (fun index fn -> fn.Id, Lir.FunctionId index) |> Map.ofList + let finalFunctions = + retainedFunctions + |> List.map (fun fn -> { fn with Id = functionMap.[fn.Id]; Body = rewriteClosures functionMap captureMap fn.Body }) + let rewrite = rewriteClosures functionMap captureMap + { program with + Functions = finalFunctions + Declarations = declarations |> List.filter (fun declaration -> reachableDeclarations.Contains declaration.Id) |> List.map (fun declaration -> { declaration with Value = rewrite declaration.Value }) + Entry = Option.map rewrite entry } diff --git a/src/FScript.Compiler/LirCommonSubexpressions.fs b/src/FScript.Compiler/LirCommonSubexpressions.fs new file mode 100644 index 0000000..e970039 --- /dev/null +++ b/src/FScript.Compiler/LirCommonSubexpressions.fs @@ -0,0 +1,256 @@ +namespace FScript.Compiler + +open FScript.Language + +/// Dominance-based value numbering. No expression is moved ahead of its first evaluation. +module LirCommonSubexpressions = + // Spans are deliberately absent. Float bits retain signed zero and NaN payloads. + type private Key = Key of Type * string * string list * Key list + type private Environment = + { Available: Map + Values: Map } + + let optimize (program: Lir.Program) = + let classify = LirEffects.create program + let effects = System.Collections.Generic.Dictionary(HashIdentity.Reference) + let effect value = + match effects.TryGetValue value with + | true,result -> result + | _ -> let result=classify value in effects.Add(value,result);result + let types = program.Types |> List.map (fun value -> value.Name,value) |> Map.ofList + let functions = program.Functions |> List.map (fun value -> value.Id,value) |> Map.ofList + let mutable symbolTypes = Map.empty + let mutable definitions = Map.empty + let mutable maximum = -1 + let note id t = + maximum <- max maximum (Lir.symbolNumber id) + symbolTypes <- Map.add id t symbolTypes + let rec plan (value: Lir.PatternPlan) = + for binding in value.Bindings do note binding.Id binding.Type + for map in value.Maps do + for clause in map.Clauses do plan clause.Key; plan clause.Value + Option.iter plan map.Tail + let children = LirTraversal.mapChildren + let rec collect (value: Lir.Expression) = + match value.Node with + | Lir.Load id -> note id value.Type + | Lir.Let(id,_,_,binding,_) -> note id binding.Type; definitions <- Map.add id binding definitions + | Lir.LetRecursiveGroup(bindings,_) -> + for id,_,t,binding in bindings do note id t; definitions <- Map.add id binding definitions + | Lir.DecisionTree(_,cases) -> for case in cases do plan case.Plan + | Lir.ForEach(id,_,t,_,_) -> note id t + | _ -> () + children (fun child -> collect child;child) value |> ignore + for typ in program.Types do maximum <- max maximum (Lir.symbolNumber typ.Id) + for declaration in program.Declarations do + note declaration.Id declaration.Type + definitions <- Map.add declaration.Id declaration.Value definitions + collect declaration.Value + for fn in program.Functions do note fn.Parameter fn.ParameterType;collect fn.Body + Option.iter collect program.Entry + let generated = System.Collections.Generic.HashSet() + let pureGenerated = System.Collections.Generic.HashSet() + let fresh t = + maximum <- maximum+1 + let id=Lir.SymbolId maximum + symbolTypes <- Map.add id t symbolTypes + generated.Add id |> ignore + id + let rec immutable seen = function + | TNamed name | THostManaged(name,_) -> + if Set.contains name seen then true else + match Map.tryFind name types with + | Some value when value.IsPure -> true + | Some value when value.Import.IsNone -> + match value.Definition with THostManaged _ -> false | t -> immutable (Set.add name seen) t + | _ -> false + | TRecord fields -> fields |> Map.forall (fun _ t -> immutable seen t) + | TUnion(name,_) when Map.tryFind name types |> Option.exists (fun value -> value.Import.IsSome) -> + types.[name].IsPure + | TUnion(_,cases) -> cases |> Map.forall (fun _ t -> Option.forall (immutable seen) t) + | TTuple values -> List.forall (immutable seen) values + | TList t | TOption t -> immutable seen t + | TMap(a,b) -> immutable seen a && immutable seen b + | TFun _ | TTask _ | TVar _ | TNumeric _ | TRecordShape _ -> false + | _ -> true + let rec callableType = function + | TFun(a,b) -> callableType a && callableType b + | t -> immutable Set.empty t + let rec safeDependencies seen (value: Lir.Expression) = + let symbol id = + (Map.tryFind id symbolTypes |> Option.exists callableType) && + (if Set.contains id seen then true else + match Map.tryFind id symbolTypes,Map.tryFind id definitions with + | Some(TFun _),Some definition -> safeDependencies (Set.add id seen) definition + | _ -> true) + match value.Node with + | Lir.MakeClosure(id,captures) -> + List.forall symbol captures && + (Map.tryFind id functions |> Option.forall (fun fn -> + // Closed function dependencies include globals as well as explicit captures. + LirOptimization.loadedSymbols fn.Body |> Set.forall symbol)) + | Lir.Load id -> symbol id + | _ -> + let mutable safe=true + children (fun child -> safe <- safe && safeDependencies seen child; child) value |> ignore + safe + let key environment (value: Lir.Expression) = + let rec build (value: Lir.Expression) = + let node tag labels inputs = + let keys=List.map build inputs + if List.forall Option.isSome keys then Some(Key(value.Type,tag,labels,List.choose id keys)) else None + match value.Node with + | Lir.Load id -> Some(Map.tryFind id environment.Values |> Option.defaultValue (Key(value.Type,"load",[string (Lir.symbolNumber id)],[]))) + | Lir.Constant literal -> + let tag,text=match literal with + | Lir.Unit -> "unit","" | Lir.Int n -> "int",string n + | Lir.Float n -> "float",string (System.BitConverter.DoubleToInt64Bits n) + | Lir.Bool b -> "bool",string b | Lir.String s -> "string",s + node tag [text] [] + | Lir.Intrinsic name -> node "intrinsic" [name] [] + | Lir.HostExternal(name,arity) -> node "external" [name;string arity] [] + | Lir.TargetImport(path,name) -> node "import" [path;name] [] + | Lir.MakeClosure _ -> None // Separately constructed callable handles retain their identity. + | Lir.TypeToken t -> Some(Key(t,"type-token",[],[])) + | Lir.NoneValue -> node "none" [] [] + | Lir.CallClosure(a,b) -> node "call" [] [a;b] + | Lir.PipeClosure(a,b) -> node "call" [] [b;a] + | Lir.Operation(op,values) -> node "operation" [string op] values + | Lir.Tuple values -> node "tuple" [] values + | Lir.List values -> node "list" [] values + | Lir.Record fields -> node "record" (List.map fst fields) (List.map snd fields) + | Lir.FieldGet(a,name) -> node "field" [name] [a] + | Lir.SomeValue a -> node "some" [] [a] + | Lir.Cons(a,b) -> node "cons" [] [a;b] + | Lir.Append(a,b) -> node "append" [] [a;b] + | Lir.Range(a,b) -> node "range" [] [a;b] + | Lir.RecordUpdate(a,fields) -> node "update" (List.map fst fields) (a::List.map snd fields) + | Lir.RecordConvert(a,_) -> node "convert" [] [a] + | Lir.IndexGet(a,b) -> node "index" [] [a;b] + | Lir.UnionCase(name,case,payload) -> node "union" [name;case] (Option.toList payload) + | Lir.Interpolate parts -> + let labels=parts |> List.collect (function Lir.TextPart text -> ["text";text] | Lir.ValuePart _ -> ["value"]) + node "interpolate" labels (parts |> List.choose (function Lir.TextPart _ -> None | Lir.ValuePart item -> Some item)) + | Lir.Map entries -> + let labels=entries |> List.map (function Lir.KeyValue _ -> "pair" | Lir.Spread _ -> "spread") + let inputs=entries |> List.collect (function Lir.KeyValue(a,b) -> [a;b] | Lir.Spread a -> [a]) + node "map" labels inputs + | _ -> None + build value + let empty = {Available=Map.empty;Values=Map.empty} + let barrier environment = {environment with Available=Map.empty} + let candidate (value: Lir.Expression) = + match value.Node,value.Type with + | Lir.Constant _,_ | Lir.Load _,_ | Lir.NoneValue,_ | Lir.TypeToken _,_ + | _,TFun _ | _,TTask _ -> false + | _ -> immutable Set.empty value.Type && safeDependencies Set.empty value && effect value=LirEffects.Pure + let atom (value: Lir.Expression) = match value.Node with Lir.Constant _ | Lir.Load _ | Lir.NoneValue | Lir.TypeToken _ | Lir.MakeClosure _ | Lir.Intrinsic _ | Lir.HostExternal _ -> true | _ -> false + let finish _ value = value + let rec rewrite environment (value: Lir.Expression) continuation = + let bind environment rewritten reusable = + let signature = if reusable then key environment rewritten else None + match signature |> Option.bind (fun signature -> Map.tryFind signature environment.Available) with + | Some existing -> continuation environment {existing with Span=value.Span} + | None when atom rewritten -> continuation environment rewritten + | None -> + let id=fresh rewritten.Type + if reusable then pureGenerated.Add id |> ignore + let load={rewritten with Node=Lir.Load id} + let environment= + match signature with + | Some signature -> {environment with Available=Map.add signature load environment.Available; Values=Map.add id signature environment.Values} + | None -> environment + let body=continuation environment load + {value with Type=body.Type; Node=Lir.Let(id,"$cse",false,rewritten,body)} + let completed environment rewritten = + bind (if effect value=LirEffects.Observable then barrier environment else environment) rewritten (candidate value) + let rec operands environment values continuation = + match values with + | [] -> continuation environment [] + | first::rest -> rewrite environment first (fun environment first -> operands environment rest (fun environment rest -> continuation environment (first::rest))) + match value.Node with + | Lir.Let(id,name,false,binding,body) -> + rewrite environment binding (fun environment binding -> + let scoped=match key environment binding with Some signature -> {environment with Values=Map.add id signature environment.Values} | None -> environment + let body=rewrite scoped body continuation + {value with Type=body.Type; Node=Lir.Let(id,name,false,binding,body)}) + | Lir.Let(id,name,true,binding,body) -> + let binding=rewrite empty binding finish + let body=rewrite (barrier environment) body continuation + {value with Type=body.Type; Node=Lir.Let(id,name,true,binding,body)} + | Lir.LetRecursiveGroup(bindings,body) -> + let bindings=bindings |> List.map (fun (id,name,t,binding) -> id,name,t,rewrite empty binding finish) + let body=rewrite (barrier environment) body continuation + {value with Type=body.Type; Node=Lir.LetRecursiveGroup(bindings,body)} + | Lir.Branch(condition,left,right) -> + rewrite environment condition (fun environment condition -> + completed environment {value with Node=Lir.Branch(condition,rewrite environment left finish,rewrite environment right finish)}) + | Lir.Operation((Lir.BooleanAnd | Lir.BooleanOr) as op,[left;right]) -> + rewrite environment left (fun environment left -> completed environment {value with Node=Lir.Operation(op,[left;rewrite environment right finish])}) + | Lir.DecisionTree(target,cases) -> + rewrite environment target (fun environment target -> + let scoped=if immutable Set.empty target.Type then environment else barrier environment + let mutable preceding=scoped + let cases=cases |> List.map (fun case -> + let guardEnvironment=preceding + let bodyEnvironment=if case.Guard |> Option.exists (fun guard -> effect guard=LirEffects.Observable) then barrier preceding else preceding + preceding<-bodyEnvironment + {case with Guard=case.Guard |> Option.map (fun guard -> rewrite guardEnvironment guard finish);Body=rewrite bodyEnvironment case.Body finish}) + completed environment {value with Node=Lir.DecisionTree(target,cases)}) + | Lir.ForEach(id,name,t,source,body) -> + rewrite environment source (fun environment source -> completed environment {value with Node=Lir.ForEach(id,name,t,source,rewrite empty body finish)}) + | Lir.PipeClosure(argument,fn) | Lir.TailPipeClosure(argument,fn) -> + operands environment [argument;fn] (fun environment values -> + let node=match value.Node with Lir.PipeClosure _ -> Lir.PipeClosure(values.[0],values.[1]) | _ -> Lir.TailPipeClosure(values.[0],values.[1]) + completed environment {value with Node=node}) + | _ -> + // Rebuild strict children in precisely their source evaluation order. + let mutable inputs=[] + children (fun child -> inputs<-child::inputs;child) value |> ignore + operands environment (List.rev inputs) (fun environment values -> + let mutable remaining=values + let rewritten=children (fun _ -> let child=List.head remaining in remaining<-List.tail remaining;child) value + completed environment rewritten) + // Drop unshared administrative temporaries; retained ones are ordinary lexical lets. + let cleanup value = + let rec substitute id (binding: Lir.Expression) (value: Lir.Expression) = + match value.Node with Lir.Load found when found=id -> {binding with Span=value.Span} | _ -> children (substitute id binding) value + let mutable result=value + let mutable changed=true + while changed do + changed<-false + let counts=System.Collections.Generic.Dictionary() + let captured=System.Collections.Generic.HashSet() + let rec count (value: Lir.Expression) = + match value.Node with + | Lir.Load id -> counts.[id]<-(match counts.TryGetValue id with true,n -> n | _ -> 0)+1 + | Lir.MakeClosure(_,captures) -> for id in captures do captured.Add id |> ignore + | _ -> () + children (fun child -> count child;child) value |> ignore + count result + let rec clean value = + let value=children clean value + match value.Node with + | Lir.Let(id,_,false,binding,body) when generated.Contains id && not (captured.Contains id) -> + match counts.TryGetValue id with + | true,1 -> changed<-true;substitute id binding body + | false,_ when pureGenerated.Contains id -> changed<-true;body + | _ -> value + | _ -> value + result<-clean result + result + let optimizeExpression environment value = rewrite environment value finish |> cleanup + let functions=program.Functions |> List.map (fun fn -> {fn with Body=optimizeExpression empty fn.Body}) + let mutable globals=empty + let declarations=program.Declarations |> List.map (fun declaration -> + let original=declaration.Value + let value=optimizeExpression globals original + if effect original=LirEffects.Observable then globals<-barrier globals + elif immutable Set.empty original.Type || (match original.Node with Lir.Load _ -> true | _ -> false) then + match key globals original with + | Some signature -> + let load={original with Node=Lir.Load declaration.Id} + globals<-{globals with Available=(if candidate original then Map.add signature load globals.Available else globals.Available);Values=Map.add declaration.Id signature globals.Values} + | None -> () + {declaration with Value=value}) + {program with Functions=functions;Declarations=declarations;Entry=program.Entry |> Option.map (optimizeExpression globals)} diff --git a/src/FScript.Compiler/LirEffects.fs b/src/FScript.Compiler/LirEffects.fs new file mode 100644 index 0000000..89da104 --- /dev/null +++ b/src/FScript.Compiler/LirEffects.fs @@ -0,0 +1,175 @@ +namespace FScript.Compiler + +open FScript.Language + +/// Pure means total as well as deterministic and effect-free. Unknowns stay observable. +module LirEffects = + type Effect = Pure | Observable + let private combine values = if List.contains Observable values then Observable else Pure + + let private totalIntrinsics = + set [ "ignore"; "Int.tryParse"; "Float.tryParse"; "Bool.tryParse"; "Int.toString"; "Float.toString"; "Bool.toString" + "String.replace"; "String.indexOf"; "String.toLower"; "String.toUpper"; "String.substring"; "String.concat"; "String.split"; "String.endsWith" + "List.empty"; "List.contains"; "List.rev"; "List.distinct"; "List.length"; "List.tryItem"; "List.tryHead"; "List.append" + "Option.defaultValue"; "Option.isNone"; "Option.isSome" + "Map.empty"; "Map.tryGet"; "Map.containsKey"; "Map.add"; "Map.ofList"; "Map.count"; "Map.remove" ] + + let higherOrder = set ["List.map";"List.iter";"List.choose";"List.collect";"List.exists";"List.fold";"List.filter";"List.tryFind";"List.tryGet";"Option.defaultWith";"Option.map";"Map.fold";"Map.filter";"Map.choose";"Map.map";"Map.iter"] + + let create (program: Lir.Program) = + let declarations = program.Declarations |> List.map (fun value -> value.Id,value) |> Map.ofList + let functions = program.Functions |> List.map (fun value -> value.Id,value) |> Map.ofList + let types = program.Types |> List.map (fun value -> value.Name,value) |> Map.ofList + let mutable summaries = functions |> Map.map (fun _ _ -> Observable) + let rec arity = function TFun(_,result) -> 1 + arity result | _ -> 0 + let rec stable seen = function + | TNamed name | THostManaged(name,_) -> + if Set.contains name seen then true else + match Map.tryFind name types with + | Some value when value.IsPure -> true + | Some value when value.Import.IsNone -> + match value.Definition with + | THostManaged _ -> false + | definition -> stable (Set.add name seen) definition + | _ -> false + | TRecord fields -> fields |> Map.forall (fun _ value -> stable seen value) + | TUnion(_,cases) -> cases |> Map.forall (fun _ value -> value |> Option.forall (stable seen)) + | TTuple values -> List.forall (stable seen) values + | TList value | TOption value -> stable seen value + | TMap(key,value) -> stable seen key && stable seen value + | TVar _ | TNumeric _ | TRecordShape _ | TTask _ -> false + | _ -> true + let externalConstruction = function + | TNamed name | THostManaged(name,_) -> Map.tryFind name types |> Option.exists (fun value -> value.Import.IsSome) + | _ -> false + let rec hasCallback seen = function + | TFun _ -> true + | TTuple values -> List.exists (hasCallback seen) values + | TList value | TOption value | TTask value -> hasCallback seen value + | TMap(key,value) -> hasCallback seen key || hasCallback seen value + | TRecord fields | TRecordShape(_,fields,_) | THostManaged(_,fields) -> fields |> Map.exists (fun _ value -> hasCallback seen value) + | TUnion(_,cases) -> cases |> Map.exists (fun _ value -> value |> Option.exists (hasCallback seen)) + | TNamed name when not (Set.contains name seen) -> Map.tryFind name types |> Option.exists (fun value -> hasCallback (Set.add name seen) value.Definition) + | _ -> false + let rec resolve environment seen (value: Lir.Expression) = + match value.Node with + | Lir.Load id when not (Set.contains id seen) -> + match Map.tryFind id environment |> Option.orElseWith (fun () -> Map.tryFind id declarations |> Option.map _.Value) with + | Some binding -> resolve environment (Set.add id seen) binding + | None -> value + | _ -> value + let externalMetadata = + program.Declarations + |> List.choose (fun value -> match value.Value.Node with Lir.HostExternal _ | Lir.TargetImport _ -> Some(value.Value.Node,value) | _ -> None) + |> List.groupBy fst + |> List.map (fun (node,values) -> + let bindings=values |> List.map snd + let arity=match bindings |> List.map _.ExternalArity |> List.distinct with [Some count] -> Some count | _ -> None + node,(List.forall (fun (binding: Lir.Declaration) -> binding.IsPure) bindings,arity)) + |> Map.ofList + let declaredPure node = externalMetadata |> Map.tryFind node |> Option.exists fst + let declaredArity node = externalMetadata |> Map.tryFind node |> Option.bind snd + let nonzeroDivision operation (values: Lir.Expression list) = + match operation,values with + | Lir.NumericDivide,[left;_] when left.Type=TFloat -> true + | _,[left;{Node=Lir.Constant(Lir.Int divisor)}] when divisor<>0L -> + divisor <> -1L || (match left.Node with Lir.Constant(Lir.Int dividend) -> dividend<>System.Int64.MinValue | _ -> false) + | _ -> false + let exhaustive (cases: Lir.DecisionCase list) = + cases |> List.tryLast |> Option.exists (fun (case: Lir.DecisionCase) -> case.Guard.IsNone && case.Plan.Checks.IsEmpty && case.Plan.Maps.IsEmpty) + let rec effect environment (value: Lir.Expression) = + let child = effect environment + match value.Node with + | Lir.Constant _ | Lir.Load _ | Lir.MakeClosure _ | Lir.NoneValue | Lir.Intrinsic _ | Lir.HostExternal _ | Lir.RuntimeContext | Lir.TypeToken _ -> Pure + | Lir.TargetImport _ -> if declaredArity value.Node=Some 0 && not (declaredPure value.Node) then Observable else Pure + | Lir.CallClosure _ | Lir.PipeClosure _ | Lir.TailCallClosure _ | Lir.TailPipeClosure _ -> + let rec spine (value: Lir.Expression) (arguments: Lir.Expression list) = + match value.Node with + | Lir.CallClosure(fn,arg) | Lir.TailCallClosure(fn,arg) | Lir.PipeClosure(arg,fn) | Lir.TailPipeClosure(arg,fn) -> spine fn (arg::arguments) + | _ -> value,arguments + let root,args=spine value [] + combine (child root :: (args |> List.map child) @ [apply environment Set.empty root args]) + | Lir.Fail _ | Lir.ForEach _ -> Observable + | Lir.Operation((Lir.IntDivide | Lir.IntRemainder | Lir.NumericDivide) as operation,values) -> + if nonzeroDivision operation values then combine (List.map child values) else Observable + | Lir.Operation(Lir.StructuralEqual,values) -> if List.forall (fun (value: Lir.Expression) -> stable Set.empty value.Type) values then combine (List.map child values) else Observable + | Lir.Operation(_,values) | Lir.Tuple values | Lir.List values -> combine (List.map child values) + | Lir.Branch(a,b,c) -> combine [child a;child b;child c] + | Lir.Record fields -> if externalConstruction value.Type then Observable else combine (fields |> List.map (snd >> child)) + | Lir.FieldGet(target,_) -> if stable Set.empty target.Type then child target else Observable + | Lir.RecordConvert(target,resultType) -> if stable Set.empty target.Type && not (externalConstruction resultType) then child target else Observable + | Lir.SomeValue target -> child target + | Lir.Cons(a,b) | Lir.Append(a,b) | Lir.Range(a,b) | Lir.IndexGet(a,b) -> combine [child a;child b] + | Lir.Let(id,_,false,binding,body) -> combine [child binding;effect (Map.add id binding environment) body] + | Lir.Let(id,_,true,binding,body) -> + let scoped=Map.add id binding environment + combine [effect scoped binding;effect scoped body] + | Lir.LetRecursiveGroup(bindings,body) -> + let scoped=bindings |> List.fold (fun scoped (id,_,_,binding) -> Map.add id binding scoped) environment + combine (effect scoped body :: (bindings |> List.map (fun (_,_,_,binding) -> effect scoped binding))) + | Lir.DecisionTree(target,cases) -> + if not (stable Set.empty target.Type && exhaustive cases) then Observable else + combine (child target :: (cases |> List.collect (fun case -> child case.Body :: (case.Guard |> Option.map child |> Option.toList)))) + | Lir.RecordUpdate(target,fields) -> if stable Set.empty target.Type && not (externalConstruction value.Type) then combine (child target :: (fields |> List.map (snd >> child))) else Observable + | Lir.Interpolate parts -> + parts |> List.map (function Lir.TextPart _ -> Pure | Lir.ValuePart item -> if stable Set.empty item.Type then child item else Observable) |> combine + | Lir.UnionCase(_,_,payload) -> payload |> Option.map child |> Option.defaultValue Pure + | Lir.Map entries -> entries |> List.collect (function Lir.KeyValue(key,item) -> [child key;child item] | Lir.Spread item -> [child item]) |> combine + and apply environment seen (value: Lir.Expression) (arguments: Lir.Expression list) = + let resolved=resolve environment Set.empty value + let externalCall count isPure = + if arguments.Lengthcount || not isPure then Observable + else + arguments |> List.map (fun argument -> + match argument.Type with + | TFun _ -> + let rec dummyArguments valueType : Lir.Expression list = + match valueType with + | TFun(input,result) -> {Type=input;Span=argument.Span;Node=Lir.Load(Lir.SymbolId -1)} :: dummyArguments result + | _ -> [] + apply environment seen argument (dummyArguments argument.Type) + | t when hasCallback Set.empty t -> Observable + | _ -> Pure) |> combine + match resolved.Node with + | Lir.MakeClosure(id,_) -> + if Set.contains id seen then Observable else + match Map.tryFind id functions,arguments with + | Some fn,_::rest -> + let current=Map.tryFind id summaries |> Option.defaultValue Observable + if current=Observable || rest.IsEmpty then current + else apply environment (Set.add id seen) fn.Body rest + | _ -> Observable + | Lir.HostExternal(_,count) -> externalCall count (declaredPure resolved.Node) + | Lir.TargetImport _ -> + match declaredArity resolved.Node with + | Some count -> externalCall count (declaredPure resolved.Node) + | None -> Observable + | Lir.Intrinsic name -> + let count=Map.tryFind name BuiltinSignatures.builtinSchemes |> Option.map (fun (Forall(_,t)) -> arity t) |> Option.defaultValue (arity resolved.Type) + // Known intrinsic signatures identify which arguments are actually invoked. + if List.contains name ["Console.writeLine";"Console.readLine";"Fs.readText"] then Observable + elif arguments.Length List.forall (fun value -> stable Set.empty value.Type)) then Observable else Pure + elif arguments.Length=count && Set.contains name higherOrder then + match arguments,Map.tryFind name BuiltinSignatures.builtinSchemes with + | callback::_,Some(Forall(_,TFun(callbackType,_))) -> + let rec dummy valueType : Lir.Expression list = + match valueType with + | TFun(input,result) -> {Type=input;Span=callback.Span;Node=Lir.Load(Lir.SymbolId -1)} :: dummy result + | _ -> [] + apply environment seen callback (dummy callbackType) + | _ -> Observable + else Observable + | Lir.Let(id,_,false,binding,body) -> combine [effect environment binding;apply (Map.add id binding environment) seen body arguments] + | Lir.Branch(condition,left,right) -> combine [effect environment condition;apply environment seen left arguments;apply environment seen right arguments] + | _ -> Observable + // Starting at Observable prevents recursive cycles from being mistaken for totality. + let mutable changed=true + while changed do + changed <- false + for KeyValue(id,fn) in functions do + let next=effect Map.empty fn.Body + if next<>summaries.[id] then summaries<-Map.add id next summaries;changed<-true + effect Map.empty diff --git a/src/FScript.Compiler/LirMonomorphization.fs b/src/FScript.Compiler/LirMonomorphization.fs new file mode 100644 index 0000000..1a88c48 --- /dev/null +++ b/src/FScript.Compiler/LirMonomorphization.fs @@ -0,0 +1,519 @@ +namespace FScript.Compiler + +open System +open System.Collections.Generic +open FScript.Language + +module LirMonomorphization = + exception private Failure of CompilerDiagnostic + + type private State = + { Program: Lir.Program + Declarations: Map + Functions: Map + DeclarationKeys: Dictionary + FunctionKeys: Dictionary + OutputDeclarations: ResizeArray + OutputFunctions: ResizeArray + mutable NextSymbol: int + mutable NextFunction: int } + + let private diagnostic code message span = + { Code = code; Stage = Lowering; Message = message; Span = Some span } + + let private fail code message span = raise (Failure(diagnostic code message span)) + let private symbolNumber (Lir.SymbolId value) = value + let private functionNumber (Lir.FunctionId value) = value + + let private freshSymbol state = + let value = Lir.SymbolId state.NextSymbol + state.NextSymbol <- state.NextSymbol + 1 + value + + let private freshFunction state = + let value = Lir.FunctionId state.NextFunction + state.NextFunction <- state.NextFunction + 1 + value + + let private mergeSubstitution left right = right |> Map.fold (fun state key value -> Map.add key value state) left + let private closedType span value = + if NativeSpecialization.containsVariable value then + let source = span.Start.File |> Option.defaultValue "" + fail "FSL2107" $"Reachable value at {source}:{span.Start.Line}:{span.Start.Column} has open type '{Types.typeToString value}' after native specialization." span + value + + let private bindingKey value = Types.typeToString value + type private Environment = Map> + + let private bind original concrete replacement environment = + let values = environment |> Map.tryFind original |> Option.defaultValue Map.empty + environment |> Map.add original (values |> Map.add (bindingKey concrete) (concrete, replacement)) + + let private lookup span original concrete environment = + environment + |> Map.tryFind original + |> Option.bind (Map.tryFind (bindingKey concrete)) + |> Option.map snd + |> Option.defaultWith (fun () -> fail "FSL2107" $"No concrete specialization exists for local symbol {symbolNumber original} at '{Types.typeToString concrete}'." span) + + let rec private patternBindingIds (plan: Lir.PatternPlan) = + [ yield! plan.Bindings |> List.map _.Id + for mapPlan in plan.Maps do + for clause in mapPlan.Clauses do + yield! patternBindingIds clause.Key + yield! patternBindingIds clause.Value + yield! mapPlan.Tail |> Option.map patternBindingIds |> Option.defaultValue [] ] + + let rec private references bound (expression: Lir.Expression) = + let nested = references bound + let many values = values |> List.map nested |> Set.unionMany + match expression.Node with + | Lir.Load id -> if Set.contains id bound then Set.empty else Set.singleton id + | Lir.MakeClosure(_, captures) -> Set.difference (Set.ofList captures) bound + | Lir.CallClosure(left, right) | Lir.PipeClosure(left, right) + | Lir.TailCallClosure(left, right) | Lir.TailPipeClosure(left, right) + | Lir.Cons(left, right) + | Lir.Append(left, right) | Lir.Range(left, right) | Lir.IndexGet(left, right) -> Set.union (nested left) (nested right) + | Lir.Branch(condition, whenTrue, whenFalse) -> many [ condition; whenTrue; whenFalse ] + | Lir.Operation(_, values) | Lir.Tuple values | Lir.List values -> many values + | Lir.Record fields -> fields |> List.map (snd >> nested) |> Set.unionMany + | Lir.FieldGet(target, _) | Lir.SomeValue target | Lir.Fail target | Lir.RecordConvert(target, _) -> nested target + | Lir.Let(id, _, recursive, binding, body) -> + Set.union (references (if recursive then Set.add id bound else bound) binding) (references (Set.add id bound) body) + | Lir.LetRecursiveGroup(bindings, body) -> + let scope = bindings |> List.fold (fun current (id, _, _, _) -> Set.add id current) bound + references scope body :: (bindings |> List.map (fun (_, _, _, value) -> references scope value)) |> Set.unionMany + | Lir.DecisionTree(target, cases) -> + nested target :: (cases |> List.collect (fun item -> + let scope = Set.union bound (patternBindingIds item.Plan |> Set.ofList) + [ yield! item.Guard |> Option.map (references scope) |> Option.toList; references scope item.Body ])) |> Set.unionMany + | Lir.RecordUpdate(target, fields) -> nested target :: (fields |> List.map (snd >> nested)) |> Set.unionMany + | Lir.Interpolate parts -> parts |> List.choose (function Lir.TextPart _ -> None | Lir.ValuePart value -> Some(nested value)) |> Set.unionMany + | Lir.UnionCase(_, _, payload) -> payload |> Option.map nested |> Option.defaultValue Set.empty + | Lir.Map entries -> entries |> List.map (function Lir.KeyValue(key, value) -> Set.union (nested key) (nested value) | Lir.Spread value -> nested value) |> Set.unionMany + | Lir.ForEach(id, _, _, source, body) -> Set.union (nested source) (references (Set.add id bound) body) + | _ -> Set.empty + + let private collectLoads target substitution expression = + let results = ResizeArray() + let rec visit (value: Lir.Expression) = + match value.Node with + | Lir.Load id when id = target -> results.Add(NativeSpecialization.apply substitution value.Type) + | Lir.CallClosure(left, right) | Lir.PipeClosure(left, right) + | Lir.TailCallClosure(left, right) | Lir.TailPipeClosure(left, right) + | Lir.Cons(left, right) + | Lir.Append(left, right) | Lir.Range(left, right) | Lir.IndexGet(left, right) -> visit left; visit right + | Lir.Branch(a, b, c) -> visit a; visit b; visit c + | Lir.Operation(_, values) | Lir.Tuple values | Lir.List values -> List.iter visit values + | Lir.Record fields | Lir.RecordUpdate(_, fields) -> fields |> List.iter (snd >> visit); match value.Node with Lir.RecordUpdate(target, _) -> visit target | _ -> () + | Lir.FieldGet(target, _) | Lir.SomeValue target | Lir.Fail target | Lir.RecordConvert(target, _) -> visit target + | Lir.Let(_, _, _, binding, body) -> visit binding; visit body + | Lir.LetRecursiveGroup(bindings, body) -> bindings |> List.iter (fun (_, _, _, item) -> visit item); visit body + | Lir.DecisionTree(target, cases) -> visit target; cases |> List.iter (fun item -> Option.iter visit item.Guard; visit item.Body) + | Lir.Interpolate parts -> parts |> List.iter (function Lir.TextPart _ -> () | Lir.ValuePart item -> visit item) + | Lir.UnionCase(_, _, payload) -> Option.iter visit payload + | Lir.Map entries -> entries |> List.iter (function Lir.KeyValue(key, item) -> visit key; visit item | Lir.Spread item -> visit item) + | Lir.ForEach(_, _, _, source, body) -> visit source; visit body + | _ -> () + visit expression + results |> Seq.distinct |> Seq.sortBy Types.typeToString |> Seq.toList + + let specialize (program: Lir.Program) : Result = + try + let nativeEffect = LirEffects.create program + let allSymbols = + [ yield! program.Declarations |> List.map (_.Id >> symbolNumber) + yield! program.Types |> List.map (_.Id >> symbolNumber) + for fn in program.Functions do yield symbolNumber fn.Parameter ] + let state = + { Program = program + Declarations = program.Declarations |> List.map (fun item -> item.Id, item) |> Map.ofList + Functions = program.Functions |> List.map (fun item -> item.Id, item) |> Map.ofList + DeclarationKeys = Dictionary() + FunctionKeys = Dictionary() + OutputDeclarations = ResizeArray() + OutputFunctions = ResizeArray() + NextSymbol = (if List.isEmpty allSymbols then 1 else List.max allSymbols + 1) + NextFunction = (program.Functions |> List.map (_.Id >> functionNumber) |> function [] -> 1 | values -> List.max values + 1) } + + let typeDefinitions = program.Types |> List.map (fun declaration -> declaration.Name, declaration.Definition) |> Map.ofList + let resolveType = function + | TNamed name as named -> typeDefinitions |> Map.tryFind name |> Option.defaultValue named + | value -> value + let rec preserveNamedRepresentation template concrete = + match template, concrete with + | TNamed name, _ -> + match typeDefinitions |> Map.tryFind name with + | Some definition when NativeSpecialization.unifyInstantiation definition concrete |> Result.isOk -> template + | _ -> concrete + | TFun(templateArgument, templateResult), TFun(concreteArgument, concreteResult) -> + TFun(preserveNamedRepresentation templateArgument concreteArgument, preserveNamedRepresentation templateResult concreteResult) + | TList templateItem, TList concreteItem -> TList(preserveNamedRepresentation templateItem concreteItem) + | TOption templateItem, TOption concreteItem -> TOption(preserveNamedRepresentation templateItem concreteItem) + | TTask templateItem, TTask concreteItem -> TTask(preserveNamedRepresentation templateItem concreteItem) + | TTuple templateItems, TTuple concreteItems when templateItems.Length = concreteItems.Length -> + TTuple(List.map2 preserveNamedRepresentation templateItems concreteItems) + | TMap(templateKey, templateValue), TMap(concreteKey, concreteValue) -> + TMap(preserveNamedRepresentation templateKey concreteKey, preserveNamedRepresentation templateValue concreteValue) + | _, _ -> concrete + let rec projectionType checks traversed current = function + | [] -> Some current + | step :: rest -> + let next = + match step, resolveType current with + | Lir.ListHead, TList item -> Some item + | Lir.ListTail, TList _ -> Some current + | Lir.TupleItem index, TTuple items when index >= 0 && index < items.Length -> Some items.[index] + | Lir.RecordField name, TRecord fields -> Map.tryFind name fields + | Lir.OptionValue, TOption item -> Some item + | Lir.UnionPayload, TUnion(_, cases) -> + checks + |> List.tryPick (function + | Lir.UnionCaseCheck(projection, _, caseName, true) when projection = traversed -> Map.tryFind caseName cases |> Option.flatten + | _ -> None) + | _ -> None + next |> Option.bind (fun item -> projectionType checks (traversed @ [ step ]) item rest) + + let rec transformPattern substitution environment expectedType (plan: Lir.PatternPlan) = + let mutable scoped = environment + let bindings = + plan.Bindings |> List.map (fun binding -> + let concrete = + projectionType plan.Checks [] expectedType binding.Projection + |> Option.defaultValue (NativeSpecialization.apply substitution binding.Type) + |> closedType plan.Span + let replacement = + scoped |> Map.tryFind binding.Id |> Option.bind (Map.tryFind (bindingKey concrete)) + |> Option.map snd |> Option.defaultWith (fun () -> freshSymbol state) + scoped <- bind binding.Id concrete replacement scoped + { binding with Id = replacement; Type = concrete }) + let checks = + plan.Checks |> List.map (function + | Lir.TypeCheck(path, valueType) -> Lir.TypeCheck(path, NativeSpecialization.apply substitution valueType) + | value -> value) + let maps = + plan.Maps |> List.map (fun mapPlan -> + let keyType, valueType, mapType = + match projectionType plan.Checks [] expectedType mapPlan.Projection |> Option.map resolveType with + | Some(TMap(key, value) as mapType) -> key, value, mapType + | _ -> TVar -1, TVar -1, TVar -1 + let clauses = + mapPlan.Clauses |> List.map (fun clause -> + let key, keyEnvironment = transformPattern substitution scoped keyType clause.Key + scoped <- keyEnvironment + let value, valueEnvironment = transformPattern substitution scoped valueType clause.Value + scoped <- valueEnvironment + { clause with Key = key; Value = value }) + let tail = + mapPlan.Tail |> Option.map (fun tail -> + let transformed, tailEnvironment = transformPattern substitution scoped mapType tail + scoped <- tailEnvironment + transformed) + { mapPlan with Clauses = clauses; Tail = tail }) + { plan with Checks = checks; Bindings = bindings; Maps = maps }, scoped + + and requestFunction _substitution environment original concrete span = + let source = state.Functions.[original] + let concreteParameter, concreteResult = + match closedType span concrete with + | TFun(parameterType, resultType) -> + preserveNamedRepresentation source.ParameterType parameterType, + preserveNamedRepresentation source.Body.Type resultType + | value -> fail "FSL2107" $"Cannot specialize function {functionNumber original} ('{source.Name}') as non-function type '{Types.typeToString value}'." span + let concrete = TFun(concreteParameter, concreteResult) + let key = $"{functionNumber original}:{Types.typeToString concrete}" + match state.FunctionKeys.TryGetValue key with + | true, existing -> existing + | _ -> + let concreteParameter, concreteResult = + match concrete with + | TFun(parameterType, resultType) -> parameterType, resultType + | _ -> fail "FSL2107" $"Cannot specialize function {functionNumber original} ('{source.Name}') as non-function type '{Types.typeToString concrete}'." span + // Resolved expression types normalize their variables independently. The + // enclosing closure type is therefore authoritative for the parameter and + // result, while the body receives a fresh substitution derived from its + // expected concrete result. Reusing the caller substitution here can alias + // unrelated variables from nested curried parameters. + match NativeSpecialization.unifyInstantiation source.ParameterType concreteParameter with + | Error error -> fail "FSL2107" $"Cannot specialize parameter of function {functionNumber original} ('{source.Name}'): {error}" span + | Ok _ -> () + let bodySubstitution = + match NativeSpecialization.unifyInstantiation source.Body.Type concreteResult with + | Ok value -> value + | Error error -> fail "FSL2107" $"Cannot specialize result of function {functionNumber original} ('{source.Name}'): {error}" span + let replacement = freshFunction state + state.FunctionKeys.Add(key, replacement) + let parameter = freshSymbol state + let bodyEnvironment = bind source.Parameter concreteParameter parameter environment + let body = transform bodySubstitution bodyEnvironment source.Body + let captures = references (Set.singleton parameter) body |> Set.toList |> List.sortBy symbolNumber + state.OutputFunctions.Add + { source with Id = replacement; Parameter = parameter; ParameterType = concreteParameter + ReturnType = body.Type; Captures = captures; Body = body } + replacement + + and requestDeclaration original concrete span = + let source = state.Declarations.[original] + let rec rootName (value: Lir.Expression) = + match value.Node with + | Lir.Load id when state.Declarations.ContainsKey id -> Some state.Declarations.[id].Name + | Lir.CallClosure(fn, _) | Lir.TailCallClosure(fn, _) -> rootName fn + | _ -> None + let rec finalArgument (value: Lir.Expression) = match value.Node with Lir.CallClosure(_, argument) | Lir.TailCallClosure(_, argument) -> argument | _ -> value + let isBottom = + match source.Value.Node with + | Lir.Fail _ -> true + | (Lir.CallClosure _ | Lir.TailCallClosure _) when rootName source.Value = Some "List.tail" -> match (finalArgument source.Value).Node with Lir.List [] -> true | _ -> false + | _ -> false + let concrete = + (if isBottom then + let defaults = Types.ftvType concrete |> Seq.map (fun variable -> variable, TUnit) |> Map.ofSeq + NativeSpecialization.apply defaults concrete + else concrete) + |> preserveNamedRepresentation source.Type + |> closedType span + let key = NativeSpecialization.specializationKey (symbolNumber original) concrete + match state.DeclarationKeys.TryGetValue key with + | true, existing -> existing + | _ -> + let inferred = + match NativeSpecialization.unifyInstantiation source.Type concrete with + | Ok value -> value + | Error error -> fail "FSL2107" $"Cannot specialize declaration '{source.Name}': {error}" span + if NativeSpecialization.containsVariable source.Type && nativeEffect source.Value = LirEffects.Observable && not isBottom then + fail "FSL2108" $"Generalized binding '{source.Name}' has observable initialization and cannot be cloned safely." source.Span + let replacement = freshSymbol state + state.DeclarationKeys.Add(key, replacement) + let value = transform inferred Map.empty source.Value + state.OutputDeclarations.Add { source with Id = replacement; Type = concrete; Value = value } + replacement + + and transform substitution environment (expression: Lir.Expression) : Lir.Expression = + let rec rootDeclarationName (value: Lir.Expression) = + match value.Node with + | Lir.Load id when state.Declarations.ContainsKey id -> Some state.Declarations.[id].Name + | Lir.CallClosure(fn, _) | Lir.TailCallClosure(fn, _) -> rootDeclarationName fn + | _ -> None + let rec isBottom (value: Lir.Expression) = + match value.Node with + | Lir.Fail _ -> true + | (Lir.CallClosure _ | Lir.TailCallClosure _) when rootDeclarationName value = Some "List.tail" -> + let rec finalArgument (current: Lir.Expression) = match current.Node with Lir.CallClosure(_, argument) | Lir.TailCallClosure(_, argument) -> argument | _ -> current + match (finalArgument value).Node with Lir.List [] -> true | _ -> false + | Lir.Branch(_, whenTrue, whenFalse) -> isBottom whenTrue && isBottom whenFalse + | Lir.DecisionTree(_, cases) -> not cases.IsEmpty && cases |> List.forall (_.Body >> isBottom) + | _ -> false + let representationInsensitive = + match expression.Node with + | Lir.Operation(Lir.StructuralEqual, values) -> values |> List.exists (_.Type >> NativeSpecialization.containsVariable) + | Lir.CallClosure _ | Lir.TailCallClosure _ -> + match rootDeclarationName expression with + | Some("Option.isNone" | "Option.isSome" | "Map.count") -> true + | _ -> isBottom expression + | _ -> isBottom expression + let rec expressionVariables (value: Lir.Expression) = + let own = Types.ftvType (NativeSpecialization.apply substitution value.Type) + let children = + match value.Node with + | Lir.CallClosure(left, right) | Lir.PipeClosure(left, right) + | Lir.TailCallClosure(left, right) | Lir.TailPipeClosure(left, right) + | Lir.Cons(left, right) | Lir.Append(left, right) | Lir.Range(left, right) | Lir.IndexGet(left, right) -> [ left; right ] + | Lir.Branch(a, b, c) -> [ a; b; c ] + | Lir.Operation(_, values) | Lir.Tuple values | Lir.List values -> values + | Lir.Record fields -> List.map snd fields + | Lir.FieldGet(value, _) | Lir.SomeValue value | Lir.Fail value | Lir.RecordConvert(value, _) -> [ value ] + | Lir.Let(_, _, _, binding, body) -> [ binding; body ] + | Lir.LetRecursiveGroup(bindings, body) -> (bindings |> List.map (fun (_, _, _, item) -> item)) @ [ body ] + | Lir.DecisionTree(target, cases) -> target :: (cases |> List.collect (fun item -> (Option.toList item.Guard) @ [ item.Body ])) + | Lir.RecordUpdate(target, fields) -> target :: List.map snd fields + | Lir.Interpolate parts -> parts |> List.choose (function Lir.ValuePart item -> Some item | _ -> None) + | Lir.UnionCase(_, _, payload) -> Option.toList payload + | Lir.Map entries -> entries |> List.collect (function Lir.KeyValue(key, item) -> [ key; item ] | Lir.Spread item -> [ item ]) + | Lir.ForEach(_, _, _, source, body) -> [ source; body ] + | _ -> [] + children |> List.fold (fun variables child -> Set.union variables (expressionVariables child)) own + let effectiveSubstitution = + if representationInsensitive then + expressionVariables expression + |> Set.fold (fun current variable -> Map.add variable TUnit current) substitution + else substitution + let rec resolvedType (value: Lir.Expression) = + let applied = NativeSpecialization.apply effectiveSubstitution value.Type + match value.Node with + | Lir.Load id when not (state.Declarations.ContainsKey id) -> + match environment |> Map.tryFind id |> Option.map (Map.toList >> List.map snd) with + | Some bindings when bindings |> List.exists (fun (boundType, _) -> boundType = applied) -> applied + | Some [ (capturedType, _) ] -> capturedType + | _ -> applied + | Lir.Cons(_, tail) when NativeSpecialization.containsVariable applied -> resolvedType tail + | Lir.List(first :: _) when NativeSpecialization.containsVariable applied -> TList(resolvedType first) + | Lir.SomeValue item when NativeSpecialization.containsVariable applied -> TOption(resolvedType item) + | Lir.Tuple items when NativeSpecialization.containsVariable applied -> TTuple(List.map resolvedType items) + | _ -> applied + let concreteType = resolvedType expression + let recurse = transform effectiveSubstitution environment + let recurseInAs scoped expected (value: Lir.Expression) = + let template = NativeSpecialization.apply effectiveSubstitution value.Type + let contextual = + match NativeSpecialization.unifyInstantiation template expected with + | Ok extra -> mergeSubstitution effectiveSubstitution extra + | Error _ -> effectiveSubstitution + transform contextual scoped value + let recurseAs expected value = recurseInAs environment expected value + let node = + match expression.Node with + | Lir.Load id when state.Declarations.ContainsKey id -> + let declaration = state.Declarations.[id] + let requestedType = if NativeSpecialization.containsVariable declaration.Type then concreteType else declaration.Type + Lir.Load(requestDeclaration id requestedType expression.Span) + | Lir.Load id -> Lir.Load(lookup expression.Span id (closedType expression.Span concreteType) environment) + | Lir.MakeClosure(functionId, _) -> + let specialized = requestFunction effectiveSubstitution environment functionId concreteType expression.Span + let fn = state.OutputFunctions |> Seq.find (fun item -> item.Id = specialized) + Lir.MakeClosure(specialized, fn.Captures) + | Lir.CallClosure(fn, argument) -> + let argumentType = resolvedType argument + let transformedFunction = recurseAs (TFun(argumentType, concreteType)) fn + let concreteArgument = + match transformedFunction.Type with + | TFun(parameterType, _) -> parameterType + | _ -> argumentType + Lir.CallClosure(transformedFunction, recurseAs concreteArgument argument) + | Lir.TailCallClosure(fn, argument) -> + let argumentType = resolvedType argument + let transformedFunction = recurseAs (TFun(argumentType, concreteType)) fn + let concreteArgument = + match transformedFunction.Type with + | TFun(parameterType, _) -> parameterType + | _ -> argumentType + Lir.TailCallClosure(transformedFunction, recurseAs concreteArgument argument) + | Lir.PipeClosure(argument, fn) -> + let argumentType = resolvedType argument + let transformedFunction = recurseAs (TFun(argumentType, concreteType)) fn + let concreteArgument = + match transformedFunction.Type with + | TFun(parameterType, _) -> parameterType + | _ -> argumentType + Lir.PipeClosure(recurseAs concreteArgument argument, transformedFunction) + | Lir.TailPipeClosure(argument, fn) -> + let argumentType = resolvedType argument + let transformedFunction = recurseAs (TFun(argumentType, concreteType)) fn + let concreteArgument = + match transformedFunction.Type with + | TFun(parameterType, _) -> parameterType + | _ -> argumentType + Lir.TailPipeClosure(recurseAs concreteArgument argument, transformedFunction) + | Lir.Branch(condition, whenTrue, whenFalse) -> + Lir.Branch(recurseAs TBool condition, recurseAs concreteType whenTrue, recurseAs concreteType whenFalse) + | Lir.Operation(operation, values) -> + let operation = + match operation, concreteType with + | Lir.NumericAdd, TInt -> Lir.IntAdd | Lir.NumericAdd, TFloat -> Lir.FloatAdd + | Lir.NumericSubtract, TInt -> Lir.IntSubtract | Lir.NumericSubtract, TFloat -> Lir.FloatSubtract + | Lir.NumericMultiply, TInt -> Lir.IntMultiply | Lir.NumericMultiply, TFloat -> Lir.FloatMultiply + | Lir.NumericDivide, TInt -> Lir.IntDivide | Lir.NumericDivide, TFloat -> Lir.FloatDivide + | value, _ -> value + Lir.Operation(operation, List.map recurse values) + | Lir.Tuple values -> + let itemTypes = match concreteType with TTuple items -> items | _ -> List.map (fun (value: Lir.Expression) -> value.Type) values + Lir.Tuple(List.map2 (fun itemType (value: Lir.Expression) -> + let valueType = NativeSpecialization.apply substitution value.Type + let inferred = match NativeSpecialization.unifyInstantiation valueType itemType with Ok extra -> mergeSubstitution effectiveSubstitution extra | Error _ -> effectiveSubstitution + transform inferred environment value) itemTypes values) + | Lir.List values -> + let itemType = match concreteType with TList item -> item | _ -> TVar -1 + Lir.List(values |> List.map (fun (value: Lir.Expression) -> + let valueType = NativeSpecialization.apply substitution value.Type + let inferred = match NativeSpecialization.unifyInstantiation valueType itemType with Ok extra -> mergeSubstitution effectiveSubstitution extra | Error _ -> effectiveSubstitution + transform inferred environment value)) + | Lir.Record fields -> Lir.Record(fields |> List.map (fun (name, value) -> name, recurse value)) + | Lir.FieldGet(target, name) -> Lir.FieldGet(recurse target, name) + | Lir.SomeValue value -> Lir.SomeValue(recurse value) + | Lir.Cons(head, tail) -> Lir.Cons(recurse head, recurse tail) + | Lir.Append(left, right) -> Lir.Append(recurse left, recurse right) + | Lir.Let(id, name, recursive, binding, body) -> + let bindingType = NativeSpecialization.apply effectiveSubstitution binding.Type + if NativeSpecialization.containsVariable bindingType then + let uses = collectLoads id effectiveSubstitution body + if uses.IsEmpty then + if nativeEffect binding = LirEffects.Observable then + fail "FSL2108" $"Generalized local binding '{name}' has observable initialization and cannot be omitted." binding.Span + (transform effectiveSubstitution environment body).Node + else + if nativeEffect binding = LirEffects.Observable then + fail "FSL2108" $"Generalized local binding '{name}' has observable initialization and cannot be cloned safely." binding.Span + let mutable scoped = environment + let clones = + uses |> List.map (fun useType -> + let inferred = + match NativeSpecialization.unifyInstantiation bindingType useType with + | Ok value -> mergeSubstitution effectiveSubstitution value + | Error error -> fail "FSL2107" $"Cannot specialize local binding '{name}': {error}" binding.Span + let replacement = freshSymbol state + scoped <- bind id useType replacement scoped + replacement, transform inferred (if recursive then scoped else environment) binding) + let transformedBody = recurseInAs scoped concreteType body + (List.foldBack (fun (replacement, value) (current: Lir.Expression) -> + ({ Type = current.Type; Span = expression.Span; Node = Lir.Let(replacement, name, recursive, value, current) }: Lir.Expression)) clones transformedBody).Node + else + let replacement = freshSymbol state + let scoped = bind id bindingType replacement environment + Lir.Let(replacement, name, recursive, transform effectiveSubstitution (if recursive then scoped else environment) binding, recurseInAs scoped concreteType body) + | Lir.LetRecursiveGroup(bindings, body) -> + let concreteBindings = bindings |> List.map (fun (id, name, valueType, value) -> id, name, NativeSpecialization.apply effectiveSubstitution valueType, value) + if concreteBindings |> List.exists (fun (_, _, valueType, _) -> NativeSpecialization.containsVariable valueType) then + fail "FSL2107" "A reachable local recursive group remains polymorphic after specialization." expression.Span + let replacements = concreteBindings |> List.map (fun (id, _, valueType, _) -> id, valueType, freshSymbol state) + let scoped = replacements |> List.fold (fun current (id, valueType, replacement) -> bind id valueType replacement current) environment + Lir.LetRecursiveGroup( + List.map2 (fun (_, name, valueType, value) (_, _, replacement) -> replacement, name, valueType, transform effectiveSubstitution scoped value) concreteBindings replacements, + transform effectiveSubstitution scoped body) + | Lir.Fail value -> Lir.Fail(recurse value) + | Lir.DecisionTree(target, cases) -> + let targetType = resolvedType target + let transformedCases = cases |> List.map (fun item -> + let plan, scoped = transformPattern effectiveSubstitution environment targetType item.Plan + { item with Plan = plan + Guard = Option.map (recurseInAs scoped TBool) item.Guard + Body = recurseInAs scoped concreteType item.Body }) + Lir.DecisionTree(recurse target, transformedCases) + | Lir.Range(first, last) -> Lir.Range(recurse first, recurse last) + | Lir.RecordUpdate(target, fields) -> Lir.RecordUpdate(recurse target, fields |> List.map (fun (name, value) -> name, recurse value)) + | Lir.RecordConvert(target, targetType) -> Lir.RecordConvert(recurse target, NativeSpecialization.apply effectiveSubstitution targetType) + | Lir.IndexGet(target, index) -> Lir.IndexGet(recurse target, recurse index) + | Lir.Interpolate parts -> Lir.Interpolate(parts |> List.map (function Lir.TextPart text -> Lir.TextPart text | Lir.ValuePart value -> Lir.ValuePart(recurse value))) + | Lir.UnionCase(typeName, caseName, payload) -> Lir.UnionCase(typeName, caseName, Option.map recurse payload) + | Lir.Map entries -> Lir.Map(entries |> List.map (function Lir.KeyValue(key, value) -> Lir.KeyValue(recurse key, recurse value) | Lir.Spread value -> Lir.Spread(recurse value))) + | Lir.ForEach(id, name, itemType, source, body) -> + let concreteItem = NativeSpecialization.apply effectiveSubstitution itemType |> closedType expression.Span + let replacement = freshSymbol state + Lir.ForEach(replacement, name, concreteItem, recurse source, transform effectiveSubstitution (bind id concreteItem replacement environment) body) + | Lir.TypeToken valueType -> Lir.TypeToken(NativeSpecialization.apply effectiveSubstitution valueType) + | value -> value + let resultType = + match node with + | Lir.Load id -> state.OutputDeclarations |> Seq.tryFind (fun declaration -> declaration.Id = id) |> Option.map _.Type |> Option.defaultValue concreteType + | Lir.MakeClosure(id, _) -> + state.OutputFunctions + |> Seq.tryFind (fun fn -> fn.Id = id) + |> Option.map (fun fn -> TFun(fn.ParameterType, fn.ReturnType)) + |> Option.defaultValue concreteType + | _ -> concreteType + { expression with Type = resultType; Node = node } + + for declaration in program.Declarations do + if nativeEffect declaration.Value = LirEffects.Observable then + if NativeSpecialization.containsVariable declaration.Type then + match declaration.Value.Node with + | Lir.Fail _ -> requestDeclaration declaration.Id declaration.Type declaration.Span |> ignore + | _ -> fail "FSL2108" $"Generalized binding '{declaration.Name}' has observable initialization and cannot be omitted or cloned safely." declaration.Span + else requestDeclaration declaration.Id declaration.Type declaration.Span |> ignore + let entry = program.Entry |> Option.map (transform Map.empty Map.empty) + Ok + { program with + Functions = state.OutputFunctions |> Seq.sortBy (_.Id >> functionNumber) |> Seq.toList + Declarations = state.OutputDeclarations |> Seq.toList + Entry = entry } + with + | Failure value -> Error [ value ] + | ex -> Error [ { Code = "FSL2101"; Stage = Lowering; Message = ex.Message; Span = None } ] diff --git a/src/FScript.Compiler/LirSimplification.fs b/src/FScript.Compiler/LirSimplification.fs new file mode 100644 index 0000000..61e8249 --- /dev/null +++ b/src/FScript.Compiler/LirSimplification.fs @@ -0,0 +1,140 @@ +namespace FScript.Compiler + +/// Backend-private simplification over the closed, monomorphized LIR program. +module LirSimplification = + open LirEffects + + let private expressionSize expression = + let rec size (value: Lir.Expression) = + let many values = values |> List.sumBy size + 1 + + match value.Node with + | Lir.CallClosure(left, right) | Lir.PipeClosure(left, right) + | Lir.TailCallClosure(left, right) | Lir.TailPipeClosure(left, right) + | Lir.Cons(left, right) | Lir.Append(left, right) | Lir.Range(left, right) | Lir.IndexGet(left, right) -> many [ left; right ] + | Lir.Branch(a, b, c) -> many [ a; b; c ] + | Lir.Operation(_, values) | Lir.Tuple values | Lir.List values -> many values + | Lir.Record fields -> fields |> List.sumBy (snd >> size) + | Lir.FieldGet(target, _) | Lir.SomeValue target | Lir.Fail target | Lir.RecordConvert(target, _) -> size target + | Lir.Let(_, _, _, binding, body) -> many [ binding; body ] + | Lir.LetRecursiveGroup(bindings, body) -> size body + (bindings |> List.sumBy (fun (_, _, _, binding) -> size binding)) + | Lir.DecisionTree(target, cases) -> size target + (cases |> List.sumBy (fun item -> size item.Body + (item.Guard |> Option.map size |> Option.defaultValue 0))) + | Lir.RecordUpdate(target, fields) -> size target + (fields |> List.sumBy (snd >> size)) + | Lir.Interpolate parts -> parts |> List.sumBy (function Lir.TextPart _ -> 0 | Lir.ValuePart item -> size item) + | Lir.UnionCase(_, _, payload) -> payload |> Option.map size |> Option.defaultValue 0 + | Lir.Map entries -> entries |> List.sumBy (function Lir.KeyValue(key, item) -> size key + size item | Lir.Spread item -> size item) + | Lir.ForEach(_, _, _, source, body) -> size source + size body + | _ -> 0 + size expression + + let private mapExpression (mapper: Lir.Expression -> Lir.Expression) (expression: Lir.Expression) = + let recurse = mapper + let withNode node = { expression with Node = node } + match expression.Node with + | Lir.CallClosure(fn, argument) -> withNode (Lir.CallClosure(recurse fn, recurse argument)) + | Lir.PipeClosure(argument, fn) -> withNode (Lir.PipeClosure(recurse argument, recurse fn)) + | Lir.TailCallClosure(fn, argument) -> withNode (Lir.TailCallClosure(recurse fn, recurse argument)) + | Lir.TailPipeClosure(argument, fn) -> withNode (Lir.TailPipeClosure(recurse argument, recurse fn)) + | Lir.Branch(a, b, c) -> withNode (Lir.Branch(recurse a, recurse b, recurse c)) + | Lir.Operation(operation, values) -> withNode (Lir.Operation(operation, List.map recurse values)) + | Lir.Tuple values -> withNode (Lir.Tuple(List.map recurse values)) + | Lir.List values -> withNode (Lir.List(List.map recurse values)) + | Lir.Record fields -> withNode (Lir.Record(fields |> List.map (fun (name, value) -> name, recurse value))) + | Lir.FieldGet(target, name) -> withNode (Lir.FieldGet(recurse target, name)) + | Lir.SomeValue value -> withNode (Lir.SomeValue(recurse value)) + | Lir.Cons(left, right) -> withNode (Lir.Cons(recurse left, recurse right)) + | Lir.Append(left, right) -> withNode (Lir.Append(recurse left, recurse right)) + | Lir.Let(id, name, recursive, binding, body) -> withNode (Lir.Let(id, name, recursive, recurse binding, recurse body)) + | Lir.LetRecursiveGroup(bindings, body) -> withNode (Lir.LetRecursiveGroup(bindings |> List.map (fun (id, name, valueType, value) -> id, name, valueType, recurse value), recurse body)) + | Lir.Fail value -> withNode (Lir.Fail(recurse value)) + | Lir.DecisionTree(target, cases) -> withNode (Lir.DecisionTree(recurse target, cases |> List.map (fun item -> { item with Guard = Option.map recurse item.Guard; Body = recurse item.Body }))) + | Lir.Range(left, right) -> withNode (Lir.Range(recurse left, recurse right)) + | Lir.RecordUpdate(target, fields) -> withNode (Lir.RecordUpdate(recurse target, fields |> List.map (fun (name, value) -> name, recurse value))) + | Lir.RecordConvert(target, targetType) -> withNode (Lir.RecordConvert(recurse target, targetType)) + | Lir.IndexGet(target, index) -> withNode (Lir.IndexGet(recurse target, recurse index)) + | Lir.Interpolate parts -> withNode (Lir.Interpolate(parts |> List.map (function Lir.TextPart text -> Lir.TextPart text | Lir.ValuePart value -> Lir.ValuePart(recurse value)))) + | Lir.UnionCase(typeName, caseName, payload) -> withNode (Lir.UnionCase(typeName, caseName, Option.map recurse payload)) + | Lir.Map entries -> withNode (Lir.Map(entries |> List.map (function Lir.KeyValue(key, value) -> Lir.KeyValue(recurse key, recurse value) | Lir.Spread value -> Lir.Spread(recurse value)))) + | Lir.ForEach(id, name, itemType, source, body) -> withNode (Lir.ForEach(id, name, itemType, recurse source, recurse body)) + | _ -> expression + + let optimize (program: Lir.Program) = + let functions = program.Functions |> List.map (fun fn -> fn.Id, fn) |> Map.ofList + let declarations = program.Declarations |> List.map (fun declaration -> declaration.Id, declaration) |> Map.ofList + let effect = LirEffects.create program + + let rec substitute symbol replacement (expression: Lir.Expression) = + match expression.Node with + | Lir.Load id when id = symbol -> replacement + | _ -> mapExpression (substitute symbol replacement) expression + + let replicable (expression: Lir.Expression) = + match expression.Node with + | Lir.Constant _ | Lir.Load _ | Lir.NoneValue | Lir.TypeToken _ -> true + | Lir.FieldGet({ Node = Lir.Load _ }, _) -> true + | _ -> false + + let rec simplify (expression: Lir.Expression) = + let recurse = simplify + let value = mapExpression recurse expression + match value.Node with + | Lir.Branch({ Node = Lir.Constant(Lir.Bool true) }, whenTrue, _) -> whenTrue + | Lir.Branch({ Node = Lir.Constant(Lir.Bool false) }, _, whenFalse) -> whenFalse + | Lir.Let(id, _, false, binding, body) when body.Node = Lir.Load id -> binding + | Lir.Let(id, _, false, binding, body) when not (Set.contains id (LirOptimization.loadedSymbols body)) && effect binding = Pure -> body + | Lir.Let(id, _, false, binding, body) when replicable binding && effect binding = Pure -> substitute id binding body |> recurse + | Lir.CallClosure({ Node = Lir.MakeClosure(functionId, _) }, argument) + when functions |> Map.tryFind functionId |> Option.exists (fun fn -> expressionSize fn.Body <= 18) -> + let fn = functions.[functionId] + { expression with Node = Lir.Let(fn.Parameter, "$inline", false, argument, fn.Body) } |> recurse + | Lir.PipeClosure(argument, { Node = Lir.MakeClosure(functionId, _) }) + when functions |> Map.tryFind functionId |> Option.exists (fun fn -> expressionSize fn.Body <= 18) -> + let fn = functions.[functionId] + { expression with Node = Lir.Let(fn.Parameter, "$inline", false, argument, fn.Body) } |> recurse + | _ -> value + + let optimizedFunctions = program.Functions |> List.map (fun fn -> { fn with Body = simplify fn.Body }) + let captureMap = + optimizedFunctions + |> List.map (fun fn -> fn.Id, (LirLowering.capturedReferences (Set.singleton fn.Parameter) fn.Body |> Set.toList |> List.sortBy Lir.symbolNumber)) + |> Map.ofList + let rec rewriteCaptures expression = + let value = mapExpression rewriteCaptures expression + match value.Node with + | Lir.MakeClosure(id, captures) -> { value with Node = Lir.MakeClosure(id, Map.tryFind id captureMap |> Option.defaultValue captures) } + | _ -> value + let optimized = + { program with + Functions = optimizedFunctions |> List.map (fun fn -> { fn with Captures = captureMap.[fn.Id]; Body = rewriteCaptures fn.Body }) + Declarations = program.Declarations |> List.map (fun declaration -> { declaration with Value = declaration.Value |> simplify |> rewriteCaptures }) + Entry = program.Entry |> Option.map (simplify >> rewriteCaptures) } + let optimizedDeclarations = optimized.Declarations |> List.map (fun declaration -> declaration.Id, declaration) |> Map.ofList + let optimizedFunctions = optimized.Functions |> List.map (fun fn -> fn.Id, fn) |> Map.ofList + let reachableDeclarations = System.Collections.Generic.HashSet() + let reachableFunctions = System.Collections.Generic.HashSet() + let rec visitExpression (expression: Lir.Expression) = + for id in LirOptimization.loadedSymbols expression do + match Map.tryFind id optimizedDeclarations with + | Some declaration when reachableDeclarations.Add id -> visitExpression declaration.Value + | _ -> () + let rec visitClosures (value: Lir.Expression) = + match value.Node with + | Lir.MakeClosure(id, _) when reachableFunctions.Add id -> + match Map.tryFind id optimizedFunctions with Some fn -> visitExpression fn.Body | None -> () + | _ -> mapExpression (fun child -> visitClosures child; child) value |> ignore + visitClosures expression + for declaration in optimized.Declarations do + if declaration.IsExported || effect declaration.Value = Observable then + if reachableDeclarations.Add declaration.Id then visitExpression declaration.Value + optimized.Entry |> Option.iter visitExpression + let retainedFunctions = optimized.Functions |> List.filter (fun fn -> reachableFunctions.Contains fn.Id) + let functionMap = retainedFunctions |> List.mapi (fun index fn -> fn.Id, Lir.FunctionId index) |> Map.ofList + let rec rewriteFunctionIds expression = + let value = mapExpression rewriteFunctionIds expression + match value.Node with + | Lir.MakeClosure(id, captures) -> { value with Node = Lir.MakeClosure(functionMap.[id], captures) } + | _ -> value + { optimized with + Functions = retainedFunctions |> List.map (fun fn -> { fn with Id = functionMap.[fn.Id]; Body = rewriteFunctionIds fn.Body }) + Declarations = optimized.Declarations |> List.filter (fun declaration -> reachableDeclarations.Contains declaration.Id) |> List.map (fun declaration -> { declaration with Value = rewriteFunctionIds declaration.Value }) + Entry = optimized.Entry |> Option.map rewriteFunctionIds } diff --git a/src/FScript.Compiler/LirTraversal.fs b/src/FScript.Compiler/LirTraversal.fs new file mode 100644 index 0000000..b4d3a1e --- /dev/null +++ b/src/FScript.Compiler/LirTraversal.fs @@ -0,0 +1,69 @@ +namespace FScript.Compiler + +open FScript.Language + +module LirTraversal = + let mapChildren mapper (value: Lir.Expression) = + let node = + match value.Node with + | Lir.CallClosure(a,b) -> Lir.CallClosure(mapper a,mapper b) + | Lir.PipeClosure(a,b) -> Lir.PipeClosure(mapper a,mapper b) + | Lir.TailCallClosure(a,b) -> Lir.TailCallClosure(mapper a,mapper b) + | Lir.TailPipeClosure(a,b) -> Lir.TailPipeClosure(mapper a,mapper b) + | Lir.Branch(a,b,c) -> Lir.Branch(mapper a,mapper b,mapper c) + | Lir.Operation(op,values) -> Lir.Operation(op,List.map mapper values) + | Lir.Tuple values -> Lir.Tuple(List.map mapper values) + | Lir.List values -> Lir.List(List.map mapper values) + | Lir.Record fields -> Lir.Record(fields |> List.map (fun (name,item) -> name,mapper item)) + | Lir.FieldGet(a,name) -> Lir.FieldGet(mapper a,name) + | Lir.SomeValue a -> Lir.SomeValue(mapper a) + | Lir.Cons(a,b) -> Lir.Cons(mapper a,mapper b) + | Lir.Append(a,b) -> Lir.Append(mapper a,mapper b) + | Lir.Let(id,name,recursive,binding,body) -> Lir.Let(id,name,recursive,mapper binding,mapper body) + | Lir.LetRecursiveGroup(bindings,body) -> Lir.LetRecursiveGroup(bindings |> List.map (fun (id,name,t,binding) -> id,name,t,mapper binding),mapper body) + | Lir.Fail a -> Lir.Fail(mapper a) + | Lir.DecisionTree(a,cases) -> Lir.DecisionTree(mapper a,cases |> List.map (fun case -> {case with Guard=Option.map mapper case.Guard;Body=mapper case.Body})) + | Lir.Range(a,b) -> Lir.Range(mapper a,mapper b) + | Lir.RecordUpdate(a,fields) -> Lir.RecordUpdate(mapper a,fields |> List.map (fun (name,item) -> name,mapper item)) + | Lir.RecordConvert(a,t) -> Lir.RecordConvert(mapper a,t) + | Lir.IndexGet(a,b) -> Lir.IndexGet(mapper a,mapper b) + | Lir.Interpolate parts -> Lir.Interpolate(parts |> List.map (function Lir.TextPart text -> Lir.TextPart text | Lir.ValuePart item -> Lir.ValuePart(mapper item))) + | Lir.UnionCase(name,case,payload) -> Lir.UnionCase(name,case,Option.map mapper payload) + | Lir.Map entries -> Lir.Map(entries |> List.map (function Lir.KeyValue(a,b) -> Lir.KeyValue(mapper a,mapper b) | Lir.Spread a -> Lir.Spread(mapper a))) + | Lir.ForEach(id,name,t,source,body) -> Lir.ForEach(id,name,t,mapper source,mapper body) + | _ -> value.Node + {value with Node=node} + + let symbols (program: Lir.Program) = + let mutable result=Set.empty + let add id=result<-Set.add id result + let rec plan (value: Lir.PatternPlan) = + for binding in value.Bindings do add binding.Id + for map in value.Maps do + for clause in map.Clauses do plan clause.Key;plan clause.Value + Option.iter plan map.Tail + let rec walk (value: Lir.Expression) = + match value.Node with + | Lir.Load id -> add id + | Lir.MakeClosure(_,captures) -> List.iter add captures + | Lir.Let(id,_,_,_,_) | Lir.ForEach(id,_,_,_,_) -> add id + | Lir.LetRecursiveGroup(bindings,_) -> for id,_,_,_ in bindings do add id + | Lir.DecisionTree(_,cases) -> for case in cases do plan case.Plan + | _ -> () + mapChildren (fun child -> walk child;child) value |> ignore + for typ in program.Types do add typ.Id + for declaration in program.Declarations do add declaration.Id;walk declaration.Value + for fn in program.Functions do add fn.Parameter;List.iter add fn.Captures;walk fn.Body + Option.iter walk program.Entry + result + +module LirResultPolicy = + /// Preserve effects and failures, while removing the entry value as a reachability root. + let discard (program: Lir.Program) = + let effect=LirEffects.create program + let entry=program.Entry |> Option.map (fun entry -> + let unitValue: Lir.Expression={Type=TUnit;Span=entry.Span;Node=Lir.Constant Lir.Unit} + if effect entry=LirEffects.Pure then unitValue else + let maximum=LirTraversal.symbols program |> Seq.map Lir.symbolNumber |> Seq.fold max -1 + {unitValue with Node=Lir.Let(Lir.SymbolId(maximum+1),"$discardResult",false,entry,unitValue)}) + {program with Entry=entry} diff --git a/src/FScript.Compiler/NativeSpecialization.fs b/src/FScript.Compiler/NativeSpecialization.fs new file mode 100644 index 0000000..d92c380 --- /dev/null +++ b/src/FScript.Compiler/NativeSpecialization.fs @@ -0,0 +1,60 @@ +namespace FScript.Compiler + +open FScript.Language + +/// Shared concrete type substitutions and deterministic specialization identities. +module NativeSpecialization = + type Substitution = Map + + type SpecializationKey = + { Symbol: int + ConcreteType: string } + + let rec containsVariable = function + | TVar _ | TNumeric _ | TRecordShape _ -> true + | TFun(argument, result) | TMap(argument, result) -> containsVariable argument || containsVariable result + | TTuple items -> List.exists containsVariable items + | TList item | TOption item | TTask item -> containsVariable item + | TRecord fields -> fields |> Map.exists (fun _ -> containsVariable) + | TUnion(_, cases) -> cases |> Map.exists (fun _ -> Option.exists containsVariable) + | _ -> false + + let rec apply (substitution: Substitution) = function + | (TVar variable | TNumeric variable) as value -> substitution |> Map.tryFind variable |> Option.defaultValue value + | TRecordShape(id, fields, constructible) -> + substitution |> Map.tryFind id |> Option.defaultValue (TRecordShape(id, Map.map (fun _ -> apply substitution) fields, constructible)) + | TFun(argument, result) -> TFun(apply substitution argument, apply substitution result) + | TTuple items -> TTuple(List.map (apply substitution) items) + | TList item -> TList(apply substitution item) + | TOption item -> TOption(apply substitution item) + | TMap(key, value) -> TMap(apply substitution key, apply substitution value) + | TTask item -> TTask(apply substitution item) + | TRecord fields -> TRecord(fields |> Map.map (fun _ -> apply substitution)) + | TUnion(name, cases) -> TUnion(name, cases |> Map.map (fun _ -> Option.map (apply substitution))) + | value -> value + + let unifyInstantiation template concrete : Result = + let rec loop substitution template concrete = + match apply substitution template, concrete with + | TRecordShape(variable, _, _), value | TVar variable, value | TNumeric variable, value -> + match substitution |> Map.tryFind variable with + | None -> Ok(Map.add variable value substitution) + | Some existing when existing = value -> Ok substitution + | Some existing -> Error $"Type variable '{variable}' maps to both {Types.typeToString existing} and {Types.typeToString value}." + | TFun(ta, tr), TFun(ca, cr) | TMap(ta, tr), TMap(ca, cr) -> + loop substitution ta ca |> Result.bind (fun next -> loop next tr cr) + | TTuple left, TTuple right when left.Length = right.Length -> + List.zip left right |> List.fold (fun state (l, r) -> state |> Result.bind (fun next -> loop next l r)) (Ok substitution) + | TList left, TList right | TOption left, TOption right | TTask left, TTask right -> loop substitution left right + | TRecord left, TRecord right when left.Count = right.Count && (left |> Map.forall (fun name _ -> Map.containsKey name right)) -> + left |> Map.toList |> List.fold (fun state (name, item) -> state |> Result.bind (fun next -> loop next item right.[name])) (Ok substitution) + | TUnion(left, _), TUnion(right, _) when left = right -> Ok substitution + | left, right when left = right -> Ok substitution + | left, right -> Error $"Cannot specialize {Types.typeToString left} as {Types.typeToString right}." + loop Map.empty template concrete + + let private typeKey value = Types.typeToString value + + let specializationKey symbol concreteType = + { Symbol = symbol + ConcreteType = typeKey concreteType } diff --git a/src/FScript.Interpreter.Lir/FScript.Interpreter.Lir.fsproj b/src/FScript.Interpreter.Lir/FScript.Interpreter.Lir.fsproj new file mode 100644 index 0000000..3533c5b --- /dev/null +++ b/src/FScript.Interpreter.Lir/FScript.Interpreter.Lir.fsproj @@ -0,0 +1,12 @@ + + + net10.0 + false + + + + + + + + diff --git a/src/FScript.Interpreter.Lir/LirInterpreter.fs b/src/FScript.Interpreter.Lir/LirInterpreter.fs new file mode 100644 index 0000000..5c3b4b9 --- /dev/null +++ b/src/FScript.Interpreter.Lir/LirInterpreter.fs @@ -0,0 +1,747 @@ +namespace FScript.Compiler + +open System.Threading +open FScript.Language + +type InterpreterContext = + { ScriptName: string option + Arguments: string list } + +type LirValue = + | VUnit + | VInt of int64 + | VFloat of float + | VBool of bool + | VString of string + | VTuple of LirValue list + | VList of LirValue list + | VRecord of Map + | VOption of LirValue option + | VUnion of string * string * LirValue option + | VMap of (LirValue * LirValue) list + | VIntrinsic of string * LirValue list + | VExternal of string * int * LirValue list + | VTypeToken of Type + | VRuntimeContext + | VTargetImport of string * string * int * LirValue list + | VClosure of Lir.SymbolId * string * Lir.Expression * Map ref + +type ExecutionResult = + { Value: LirValue + Stdout: string list + ExitCode: int } + +type HostExternal = + { Name: string + Invoke: LirValue list -> Result } + +type LoadedProgram = + internal + { Program: Lir.Program + Environment: Map + Exports: Map + HostExternals: Map } + +type LoadResult = + { Program: LoadedProgram + Value: LirValue + Stdout: string list + ExitCode: int } + +module LirInterpreter = + let private currentExitCode = AsyncLocal() + let private currentOutput = AsyncLocal>() + let private currentFunctions = AsyncLocal>() + let private currentHostExternals = AsyncLocal>() + let private constantValue = function + | Lir.Unit -> VUnit | Lir.Int value -> VInt value | Lir.Float value -> VFloat value + | Lir.Bool value -> VBool value | Lir.String value -> VString value + + let rec private equal left right = + match left, right with + | VUnit, VUnit -> true + | VInt a, VInt b -> a = b + | VFloat a, VFloat b -> a = b + | VBool a, VBool b -> a = b + | VString a, VString b -> a = b + | VTuple a, VTuple b | VList a, VList b -> a.Length = b.Length && List.forall2 equal a b + | VRecord a, VRecord b -> a.Count = b.Count && (a |> Map.forall (fun key value -> b |> Map.tryFind key |> Option.exists (equal value))) + | VOption None, VOption None -> true + | VOption(Some a), VOption(Some b) -> equal a b + | VUnion(aType, aCase, aValue), VUnion(bType, bCase, bValue) -> aType = bType && aCase = bCase && equal (VOption aValue) (VOption bValue) + | VMap a, VMap b -> a.Length = b.Length && List.forall2 (fun (ak, av) (bk, bv) -> equal ak bk && equal av bv) a b + | VTypeToken a, VTypeToken b -> a = b + | _ -> false + + let rec private formatValue = function + | VUnit -> "()" | VInt value -> string value | VFloat value -> value.ToString("R", System.Globalization.CultureInfo.InvariantCulture) + | VBool value -> value.ToString().ToLowerInvariant() | VString value -> value + | VTuple values -> "(" + (values |> List.map formatValue |> String.concat ", ") + ")" + | VList values -> "[" + (values |> List.map formatValue |> String.concat ";") + "]" + | VRecord fields -> + let rendered = fields |> Map.toList |> List.map (fun (name, value) -> name + " = " + formatValue value) |> String.concat "; " + "{ " + rendered + " }" + | VOption None -> "None" | VOption(Some value) -> $"Some {formatValue value}" + | VUnion(_, caseName, None) -> caseName | VUnion(_, caseName, Some value) -> $"{caseName} {formatValue value}" + | VMap entries -> + entries + |> List.map (fun (key, value) -> + let renderedKey = + match key with + | VString text -> "\"" + text.Replace("\\", "\\\\").Replace("\"", "\\\"") + "\"" + | _ -> formatValue key + $"{renderedKey} => {formatValue value}") + |> String.concat "; " + |> fun value -> "map { " + value + " }" + | VClosure _ -> "" + | VIntrinsic _ -> "" + | VExternal _ -> "" + | VTypeToken value -> $"" + | VRuntimeContext -> "" + | VTargetImport _ -> "" + + let private fail code span message = + Error { Code = code; Stage = Interpreter; Message = message; Span = Some span } + + let private intrinsicArity name = + let scheme = + FScript.Language.BuiltinSignatures.builtinSchemes + |> Map.tryFind name + |> Option.orElseWith (fun () -> RuntimeIntrinsics.schemes |> Map.tryFind name) + |> Option.defaultWith (fun () -> invalidArg "name" $"Unknown intrinsic '{name}'.") + let (Forall(_, valueType)) = scheme + let rec count = function TFun(_, result) -> 1 + count result | _ -> 0 + count valueType + + let rec private arityFromType = function TFun(_, result) -> 1 + arityFromType result | _ -> 0 + + let private invokeIntrinsic apply span name arguments = + let unsupported () = fail "FSI3020" span $"Intrinsic '{name}' is not yet executable in LIR." + let expectBool = function Ok(VBool value) -> Ok value | Ok _ -> fail "FSI3022" span $"Intrinsic '{name}' callback must return bool." | Error errors -> Error errors + let rec mapCallback callback acc = function + | [] -> Ok(List.rev acc) + | value :: rest -> apply callback value |> Result.bind (fun mapped -> mapCallback callback (mapped :: acc) rest) + let rec filterCallback callback acc = function + | [] -> Ok(List.rev acc) + | value :: rest -> apply callback value |> expectBool |> Result.bind (fun keep -> filterCallback callback (if keep then value :: acc else acc) rest) + let mapSet key value entries = + let rec loop acc = function + | [] -> List.rev ((key, value) :: acc) + | (existing, _) :: rest when equal existing key -> List.rev acc @ ((key, value) :: rest) + | entry :: rest -> loop (entry :: acc) rest + loop [] entries |> List.sortBy (fst >> formatValue) + match name, arguments with + | "Env.setExitCode", [VInt code] when code >= 0L && code <= 255L -> currentExitCode.Value.Value <- int code; Ok VUnit + | "Env.setExitCode", [VInt _] -> fail "FSI3027" span "Env.setExitCode expects a code between 0 and 255." + | "Console.readLine", [ VUnit ] -> + match System.Console.ReadLine() with + | null -> Ok(VOption None) + | value -> Ok(VOption(Some(VString value))) + | "Console.writeLine", [ VString value ] -> currentOutput.Value.Add(value); Ok VUnit + | "Fs.readText", [ VString path ] -> + try Ok(VOption(Some(VString(System.IO.File.ReadAllText(path))))) + with _ -> Ok(VOption None) + | "ignore", [ _ ] -> Ok VUnit + | "Int.tryParse", [ VString value ] -> match System.Int64.TryParse value with true, parsed -> Ok(VOption(Some(VInt parsed))) | _ -> Ok(VOption None) + | "Float.tryParse", [ VString value ] -> match System.Double.TryParse(value, System.Globalization.NumberStyles.Float, System.Globalization.CultureInfo.InvariantCulture) with true, parsed -> Ok(VOption(Some(VFloat parsed))) | _ -> Ok(VOption None) + | "Bool.tryParse", [ VString value ] -> match System.Boolean.TryParse value with true, parsed -> Ok(VOption(Some(VBool parsed))) | _ -> Ok(VOption None) + | "Int.toString", [ VInt value ] -> Ok(VString(string value)) + | "Float.toString", [ VFloat value ] -> Ok(VString(value.ToString("R", System.Globalization.CultureInfo.InvariantCulture))) + | "Bool.toString", [ VBool value ] -> Ok(VString(value.ToString().ToLowerInvariant())) + | "String.replace", [ VString oldValue; VString newValue; VString value ] -> Ok(VString(if oldValue = "" then value else value.Replace(oldValue, newValue))) + | "String.indexOf", [ VString needle; VString value ] -> let index = value.IndexOf(needle, System.StringComparison.Ordinal) in Ok(VOption(if index < 0 then None else Some(VInt(int64 index)))) + | "String.toLower", [ VString value ] -> Ok(VString(value.ToLowerInvariant())) + | "String.toUpper", [ VString value ] -> Ok(VString(value.ToUpperInvariant())) + | "String.substring", [ VInt start; VInt length; VString value ] when start >= 0L && length >= 0L && start + length <= int64 value.Length -> Ok(VOption(Some(VString(value.Substring(int start, int length))))) + | "String.substring", [ VInt _; VInt _; VString _ ] -> Ok(VOption None) + | "String.concat", [ VString separator; VList values ] -> values |> List.choose (function VString value -> Some value | _ -> None) |> String.concat separator |> VString |> Ok + | "String.split", [ VString separator; VString value ] -> value.Split([| separator |], System.StringSplitOptions.None) |> Array.toList |> List.map VString |> VList |> Ok + | "String.endsWith", [ VString suffix; VString value ] -> Ok(VBool(value.EndsWith(suffix, System.StringComparison.Ordinal))) + | "List.length", [ VList values ] -> Ok(VInt(int64 values.Length)) + | "List.empty", [] -> Ok(VList []) + | "List.map", [ callback; VList values ] -> mapCallback callback [] values |> Result.map VList + | "List.iter", [ callback; VList values ] -> mapCallback callback [] values |> Result.map (fun _ -> VUnit) + | "List.choose", [ callback; VList values ] -> + mapCallback callback [] values |> Result.bind (fun mapped -> + mapped |> List.fold (fun state value -> + match state, value with + | Ok acc, VOption(Some item) -> Ok(item :: acc) + | Ok acc, VOption None -> Ok acc + | Ok _, _ -> fail "FSI3022" span "List.choose callback must return option." + | Error errors, _ -> Error errors) (Ok []) |> Result.map (List.rev >> VList)) + | "List.collect", [ callback; VList values ] -> + mapCallback callback [] values |> Result.bind (fun mapped -> + mapped |> List.fold (fun state value -> + match state, value with Ok acc, VList items -> Ok(acc @ items) | Ok _, _ -> fail "FSI3022" span "List.collect callback must return list." | Error errors, _ -> Error errors) (Ok []) |> Result.map VList) + | "List.exists", [ callback; VList values ] -> + let rec loop = function [] -> Ok(VBool false) | value :: rest -> apply callback value |> expectBool |> Result.bind (fun found -> if found then Ok(VBool true) else loop rest) + loop values + | "List.rev", [ VList values ] -> Ok(VList(List.rev values)) + | "List.distinct", [ VList values ] -> values |> List.fold (fun acc value -> if List.exists (equal value) acc then acc else acc @ [ value ]) [] |> VList |> Ok + | "List.fold", [ callback; state; VList values ] -> + values |> List.fold (fun result value -> result |> Result.bind (fun current -> apply callback current |> Result.bind (fun partial -> apply partial value))) (Ok state) + | "List.filter", [ callback; VList values ] -> filterCallback callback [] values |> Result.map VList + | "List.tryFind", [ callback; VList values ] -> + let rec loop = function [] -> Ok(VOption None) | value :: rest -> apply callback value |> expectBool |> Result.bind (fun found -> if found then Ok(VOption(Some value)) else loop rest) + loop values + | "List.tryGet", [ callback; VList values ] -> + let rec loop index = function [] -> Ok(VOption None) | value :: rest -> apply callback value |> expectBool |> Result.bind (fun found -> if found then Ok(VOption(Some(VInt index))) else loop (index + 1L) rest) + loop 0L values + | "List.tryItem", [ VInt index; VList values ] -> if index < 0L || index >= int64 values.Length then Ok(VOption None) else Ok(VOption(Some values.[int index])) + | "List.tryHead", [ VList values ] -> Ok(VOption(List.tryHead values)) + | "List.tail", [ VList(_ :: tail) ] -> Ok(VList tail) + | "List.tail", [ VList [] ] -> fail "FSI3022" span "List.tail expects a non-empty list." + | "List.append", [ VList left; VList right ] -> Ok(VList(left @ right)) + | "List.contains", [ value; VList values ] -> Ok(VBool(List.exists (equal value) values)) + | "Option.isNone", [ VOption value ] -> Ok(VBool value.IsNone) + | "Option.isSome", [ VOption value ] -> Ok(VBool value.IsSome) + | "Option.defaultValue", [ fallback; VOption value ] -> Ok(Option.defaultValue fallback value) + | "Option.defaultWith", [ fallback; VOption(Some value) ] -> Ok value + | "Option.defaultWith", [ fallback; VOption None ] -> apply fallback VUnit + | "Option.map", [ callback; VOption(Some value) ] -> apply callback value |> Result.map (Some >> VOption) + | "Option.map", [ _; VOption None ] -> Ok(VOption None) + | "Map.empty", [] -> Ok(VMap []) + | "Map.count", [ VMap entries ] -> Ok(VInt(int64 entries.Length)) + | "Map.containsKey", [ key; VMap entries ] -> Ok(VBool(entries |> List.exists (fst >> equal key))) + | "Map.tryGet", [ key; VMap entries ] -> Ok(VOption(entries |> List.tryPick (fun (itemKey, value) -> if equal itemKey key then Some value else None))) + | "Map.add", [ key; value; VMap entries ] -> Ok(VMap(mapSet key value entries)) + | "Map.ofList", [ VList pairs ] -> + pairs |> List.fold (fun state pair -> match state, pair with Ok entries, VTuple [ key; value ] -> Ok(mapSet key value entries) | Ok _, _ -> fail "FSI3022" span "Map.ofList expects key/value tuples." | Error errors, _ -> Error errors) (Ok []) |> Result.map VMap + | "Map.fold", [ callback; state; VMap entries ] -> + entries |> List.fold (fun result (key, value) -> result |> Result.bind (fun current -> apply callback current |> Result.bind (fun withKey -> apply withKey key |> Result.bind (fun withValue -> apply withValue value)))) (Ok state) + | "Map.filter", [ callback; VMap entries ] -> + let rec loop acc = function [] -> Ok(VMap(List.rev acc)) | (key, value as entry) :: rest -> apply callback key |> Result.bind (fun partial -> apply partial value |> expectBool |> Result.bind (fun keep -> loop (if keep then entry :: acc else acc) rest)) + loop [] entries + | "Map.choose", [ callback; VMap entries ] -> + let rec loop acc = function + | [] -> Ok(VMap(List.rev acc)) + | (key, value) :: rest -> apply callback key |> Result.bind (fun partial -> apply partial value |> Result.bind (function VOption(Some chosen) -> loop ((key, chosen) :: acc) rest | VOption None -> loop acc rest | _ -> fail "FSI3022" span "Map.choose callback must return option.")) + loop [] entries + | "Map.map", [ callback; VMap entries ] -> + let rec loop acc = function [] -> Ok(VMap(List.rev acc)) | (key, value) :: rest -> apply callback value |> Result.bind (fun mapped -> loop ((key, mapped) :: acc) rest) + loop [] entries + | "Map.iter", [ callback; VMap entries ] -> + let rec loop = function [] -> Ok VUnit | (key, value) :: rest -> apply callback key |> Result.bind (fun partial -> apply partial value |> Result.bind (fun _ -> loop rest)) + loop entries + | "Map.remove", [ key; VMap entries ] -> Ok(VMap(entries |> List.filter (fst >> equal key >> not))) + | _ -> unsupported () + + let rec private matchPlan (plan: Lir.PatternPlan) value = + let rec matchesType expected item = + match expected, item with + | TUnit, VUnit | TInt, VInt _ | TFloat, VFloat _ | TBool, VBool _ | TString, VString _ | TTypeToken, VTypeToken _ -> true + | TTuple types, VTuple values -> types.Length = values.Length && List.forall2 matchesType types values + | TList itemType, VList values -> values |> List.forall (matchesType itemType) + | TOption _, VOption None -> true + | TOption itemType, VOption(Some value) -> matchesType itemType value + | (TRecord fields | TRecordShape(_,fields,_) | THostManaged(_,fields)), VRecord values -> fields |> Map.forall (fun name fieldType -> values |> Map.tryFind name |> Option.exists (matchesType fieldType)) + | TMap(keyType, valueType), VMap entries -> entries |> List.forall (fun (key, value) -> matchesType keyType key && matchesType valueType value) + | TUnion(typeName, _), VUnion(valueType, _, _) | TNamed typeName, VUnion(valueType, _, _) -> typeName = valueType + | TNamed _, VRecord _ -> true + | TFun _, (VClosure _ | VIntrinsic _ | VExternal _) -> true + | TVar _, _ -> true + | _ -> false + let rec project (item: LirValue) (projection: Lir.ProjectionStep list) = + match projection with + | [] -> Some item + | step :: rest -> + let next = + match step, item with + | Lir.ListHead, VList(head :: _) -> Some head + | Lir.ListTail, VList(_ :: tail) -> Some(VList tail) + | Lir.TupleItem index, VTuple items when index >= 0 && index < items.Length -> Some items.[index] + | Lir.RecordField name, VRecord fields -> Map.tryFind name fields + | Lir.OptionValue, VOption(Some inner) -> Some inner + | Lir.UnionPayload, VUnion(_, _, Some inner) -> Some inner + | _ -> None + next |> Option.bind (fun inner -> project inner rest) + let addBinding (bindings: Map) id item = + match Map.tryFind id bindings with + | Some existing when not (equal existing item) -> None + | _ -> Some(Map.add id item bindings) + let rec run (currentPlan: Lir.PatternPlan) (root: LirValue) (bindings: Map) = + if not (currentPlan.Checks |> List.forall (fun item -> + // Checks are evaluated against the plan's current root. + match item with + | Lir.LiteralCheck(projection, literal) -> project root projection |> Option.exists (equal (constantValue literal)) + | Lir.EmptyListCheck projection -> project root projection |> Option.exists (function VList [] -> true | _ -> false) + | Lir.NonEmptyListCheck projection -> project root projection |> Option.exists (function VList(_ :: _) -> true | _ -> false) + | Lir.TupleArityCheck(projection, arity) -> project root projection |> Option.exists (function VTuple items -> items.Length = arity | _ -> false) + | Lir.RecordFieldCheck(projection, name) -> project root projection |> Option.exists (function VRecord fields -> Map.containsKey name fields | _ -> false) + | Lir.SomeCheck projection -> project root projection |> Option.exists (function VOption(Some _) -> true | _ -> false) + | Lir.NoneCheck projection -> project root projection |> Option.exists (function VOption None -> true | _ -> false) + | Lir.UnionCaseCheck(projection, typeName, caseName, hasPayload) -> project root projection |> Option.exists (function VUnion(actualType, actualCase, payload) -> actualType = typeName && actualCase = caseName && payload.IsSome = hasPayload | _ -> false) + | Lir.TypeCheck(projection, expected) -> project root projection |> Option.exists (matchesType expected))) then None + else + let withBindings = + currentPlan.Bindings + |> List.fold (fun state binding -> + state |> Option.bind (fun env -> project root binding.Projection |> Option.bind (addBinding env binding.Id))) (Some bindings) + let runMap env (mapPlan: Lir.MapPlan) = + project root mapPlan.Projection + |> Option.bind (function + | VMap entries -> + let rec clauses current remaining locallyBound (pending: Lir.MapClausePlan list) = + match pending with + | [] -> + match mapPlan.Tail with + | Some tail -> run tail (VMap remaining) current + | None when not mapPlan.RequireEmptyRemainder || remaining.IsEmpty -> Some current + | None -> None + | clause :: rest -> + let candidates = + if Lir.simpleKeyBinding clause.Key |> Option.exists (fun id -> not (Set.contains id locallyBound)) then remaining |> List.truncate 1 + else remaining + candidates + |> List.indexed + |> List.tryPick (fun (index, (key, item)) -> + run clause.Key key current + |> Option.bind (fun withKey -> run clause.Value item withKey) + |> Option.map (fun withValue -> index,withValue)) + |> Option.bind (fun (index,withValue) -> + let next = remaining |> List.indexed |> List.choose (fun (position, entry) -> if position=index then None else Some entry) + let local=Set.union locallyBound (Set.union (Lir.planBindingIds clause.Key) (Lir.planBindingIds clause.Value)) + clauses withValue next local rest) + clauses env entries Set.empty mapPlan.Clauses + | _ -> None) + currentPlan.Maps |> List.fold (fun state mapPlan -> state |> Option.bind (fun env -> runMap env mapPlan)) withBindings + run plan value Map.empty + + let rec private evaluate environment (expression: Lir.Expression) = + let binary work = + match expression.Node with + | Lir.Operation(_, [ left; right ]) -> + evaluate environment left + |> Result.bind (fun leftValue -> evaluate environment right |> Result.bind (work leftValue)) + | _ -> fail "FSI3002" expression.Span "Invalid primitive arity." + match expression.Node with + | Lir.Constant value -> + Ok(constantValue value) + | Lir.Load id -> + environment |> Map.tryFind id |> Option.map Ok + |> Option.defaultWith (fun () -> fail "FSI3001" expression.Span (sprintf "Unknown LIR symbol %%%d." (Lir.symbolNumber id))) + | Lir.MakeClosure(functionId, captures) -> + let captured = captures |> List.choose (fun symbol -> Map.tryFind symbol environment |> Option.map (fun value -> symbol, value)) |> Map.ofList + currentFunctions.Value + |> Map.tryFind functionId + |> Option.map (fun fn -> Ok(VClosure(fn.Parameter, fn.Name, fn.Body, ref captured))) + |> Option.defaultWith (fun () -> fail "FSI3024" expression.Span $"Unknown lifted LIR function {Lir.functionNumber functionId}.") + | Lir.CallClosure(fn, argument) -> + evaluate environment fn + |> Result.bind (fun fnValue -> evaluate environment argument |> Result.bind (applyValue expression.Span fnValue)) + | Lir.PipeClosure(argument, fn) -> + evaluate environment argument + |> Result.bind (fun argumentValue -> evaluate environment fn |> Result.bind (fun fnValue -> applyValue expression.Span fnValue argumentValue)) + | Lir.TailCallClosure(fn, argument) -> + evaluate environment fn + |> Result.bind (fun fnValue -> evaluate environment argument |> Result.bind (applyValue expression.Span fnValue)) + | Lir.TailPipeClosure(argument, fn) -> + evaluate environment argument + |> Result.bind (fun argumentValue -> evaluate environment fn |> Result.bind (fun fnValue -> applyValue expression.Span fnValue argumentValue)) + | Lir.Branch(condition, whenTrue, whenFalse) -> + match evaluate environment condition with + | Ok(VBool true) -> evaluate environment whenTrue + | Ok(VBool false) -> evaluate environment whenFalse + | Ok _ -> fail "FSI3004" expression.Span "Branch condition is not Boolean." + | Error errors -> Error errors + | Lir.Operation(Lir.BooleanAnd, [ left; right ]) -> + evaluate environment left + |> Result.bind (function + | VBool false -> Ok(VBool false) + | VBool true -> + evaluate environment right + |> Result.bind (function VBool value -> Ok(VBool value) | _ -> fail "FSI3006" expression.Span "Primitive operands do not match their LIR operation.") + | _ -> fail "FSI3006" expression.Span "Primitive operands do not match their LIR operation.") + | Lir.Operation(Lir.BooleanOr, [ left; right ]) -> + evaluate environment left + |> Result.bind (function + | VBool true -> Ok(VBool true) + | VBool false -> + evaluate environment right + |> Result.bind (function VBool value -> Ok(VBool value) | _ -> fail "FSI3006" expression.Span "Primitive operands do not match their LIR operation.") + | _ -> fail "FSI3006" expression.Span "Primitive operands do not match their LIR operation.") + | Lir.Operation(op, _) -> + binary (fun left right -> + match op, left, right with + | (Lir.IntAdd | Lir.NumericAdd), VInt a, VInt b -> Ok(VInt(a + b)) + | (Lir.FloatAdd | Lir.NumericAdd), VFloat a, VFloat b -> Ok(VFloat(a + b)) + | (Lir.IntSubtract | Lir.NumericSubtract), VInt a, VInt b -> Ok(VInt(a - b)) + | (Lir.FloatSubtract | Lir.NumericSubtract), VFloat a, VFloat b -> Ok(VFloat(a - b)) + | (Lir.IntMultiply | Lir.NumericMultiply), VInt a, VInt b -> Ok(VInt(a * b)) + | (Lir.FloatMultiply | Lir.NumericMultiply), VFloat a, VFloat b -> Ok(VFloat(a * b)) + | (Lir.IntDivide | Lir.NumericDivide), VInt _, VInt 0L -> fail "FSI3005" expression.Span "Division by zero." + | (Lir.IntDivide | Lir.NumericDivide), VInt a, VInt b -> Ok(VInt(a / b)) + | (Lir.FloatDivide | Lir.NumericDivide), VFloat a, VFloat b -> Ok(VFloat(a / b)) + | Lir.IntRemainder, VInt _, VInt 0L -> fail "FSI3005" expression.Span "Division by zero." + | Lir.IntRemainder, VInt a, VInt b -> Ok(VInt(a % b)) + | Lir.StructuralEqual, a, b -> Ok(VBool(equal a b)) + | Lir.NumericLessThan, VInt a, VInt b -> Ok(VBool(a < b)) + | Lir.NumericLessThan, VFloat a, VFloat b -> Ok(VBool(a < b)) + | Lir.NumericGreaterThan, VInt a, VInt b -> Ok(VBool(a > b)) + | Lir.NumericGreaterThan, VFloat a, VFloat b -> Ok(VBool(a > b)) + | Lir.NumericLessThanOrEqual, VInt a, VInt b -> Ok(VBool(a <= b)) + | Lir.NumericLessThanOrEqual, VFloat a, VFloat b -> Ok(VBool(a <= b)) + | Lir.NumericGreaterThanOrEqual, VInt a, VInt b -> Ok(VBool(a >= b)) + | Lir.NumericGreaterThanOrEqual, VFloat a, VFloat b -> Ok(VBool(a >= b)) + | Lir.BooleanAnd, VBool a, VBool b -> Ok(VBool(a && b)) + | Lir.BooleanOr, VBool a, VBool b -> Ok(VBool(a || b)) + | _ -> fail "FSI3006" expression.Span "Primitive operands do not match their LIR operation.") + | Lir.Tuple items -> evaluateMany environment items |> Result.map VTuple + | Lir.List items -> evaluateMany environment items |> Result.map VList + | Lir.Record fields -> + evaluateNamed environment fields |> Result.map (Map.ofList >> VRecord) + | Lir.FieldGet(target, name) -> + match evaluate environment target with + | Ok(VRecord fields) -> fields |> Map.tryFind name |> Option.map Ok |> Option.defaultWith (fun () -> fail "FSI3007" expression.Span $"Record field '{name}' was not found.") + | Ok _ -> fail "FSI3007" expression.Span "Field access requires a record." + | Error errors -> Error errors + | Lir.SomeValue item -> evaluate environment item |> Result.map (Some >> VOption) + | Lir.NoneValue -> Ok(VOption None) + | Lir.Cons(head, tail) -> + evaluate environment head + |> Result.bind (fun headValue -> + evaluate environment tail + |> Result.bind (function VList tailValues -> Ok(VList(headValue :: tailValues)) | _ -> fail "FSI3008" expression.Span "Cons tail must be a list.")) + | Lir.Append(left, right) -> + evaluate environment left + |> Result.bind (fun leftValue -> + evaluate environment right + |> Result.bind (fun rightValue -> + match leftValue, rightValue with + | VList leftValues, VList rightValues -> Ok(VList(leftValues @ rightValues)) + | _ -> fail "FSI3009" expression.Span "Append operands must be lists.")) + | Lir.Let(id, _, recursive, binding, body) -> + if recursive then + match evaluate environment binding with + | Ok(VClosure(_, _, _, captured) as closure) -> + let next = environment |> Map.add id closure + captured.Value <- next + evaluate next body + | Ok _ -> fail "FSI3010" expression.Span "Recursive local bindings must be functions." + | Error errors -> Error errors + else + evaluate environment binding |> Result.bind (fun value -> evaluate (environment |> Map.add id value) body) + | Lir.LetRecursiveGroup(bindings, body) -> + let evaluated = bindings |> List.map (fun (id, _, _, binding) -> id, evaluate environment binding) + let error = evaluated |> List.tryPick (fun (_, result) -> match result with Error value -> Some value | Ok _ -> None) + if error.IsSome then Error error.Value + elif evaluated |> List.exists (fun (_, result) -> match result with Ok(VClosure _) -> false | _ -> true) then + fail "FSI3010" expression.Span "Recursive local groups must contain only functions." + else + let recursiveEnvironment = evaluated |> List.fold (fun env (id, result) -> match result with Ok value -> Map.add id value env | Error _ -> env) environment + evaluated |> List.iter (fun (_, result) -> match result with Ok(VClosure(_, _, _, captured)) -> captured.Value <- recursiveEnvironment | _ -> ()) + evaluate recursiveEnvironment body + | Lir.Fail value -> + match evaluate environment value with + | Ok(VString message) -> fail "FSI3011" expression.Span message + | Ok _ -> fail "FSI3011" expression.Span "FScript program raised a non-string value." + | Error errors -> Error errors + | Lir.DecisionTree(target, cases) -> + evaluate environment target |> Result.bind (fun targetValue -> + let rec run (remaining: Lir.DecisionCase list) = + match remaining with + | [] -> fail "FSI3012" expression.Span "Match failure." + | case :: rest -> + match matchPlan case.Plan targetValue with + | None -> run rest + | Some bindings -> + let caseEnvironment = Map.fold (fun env id value -> Map.add id value env) environment bindings + match case.Guard with + | None -> evaluate caseEnvironment case.Body + | Some guard -> + match evaluate caseEnvironment guard with + | Ok(VBool true) -> evaluate caseEnvironment case.Body + | Ok(VBool false) -> run rest + | Ok _ -> fail "FSI3013" guard.Span "Match guard must evaluate to Boolean." + | Error errors -> Error errors + run cases) + | Lir.Range(startValue, endValue) -> + evaluate environment startValue + |> Result.bind (fun firstValue -> + evaluate environment endValue + |> Result.bind (fun lastValue -> + match firstValue, lastValue with + | VInt first, VInt last -> + let step = if first <= last then 1L else -1L + Ok(VList([ first .. step .. last ] |> List.map VInt)) + | _ -> fail "FSI3014" expression.Span "Range endpoints must be integers.")) + | Lir.RecordUpdate(target, fields) -> + match evaluate environment target with + | Ok(VRecord existing) -> + evaluateNamed environment fields + |> Result.map (fun updates -> VRecord(List.fold (fun state (name, value) -> Map.add name value state) existing updates)) + | Ok _ -> fail "FSI3015" expression.Span "Record update requires a record." + | Error errors -> Error errors + | Lir.RecordConvert(target, _) -> + match evaluate environment target with + | Ok(VRecord _ as record) -> Ok record + | Ok _ -> fail "FSI3015" expression.Span "Record conversion requires a record." + | Error errors -> Error errors + | Lir.IndexGet(target, index) -> + evaluate environment target + |> Result.bind (fun targetValue -> + evaluate environment index + |> Result.bind (fun indexValue -> + match targetValue, indexValue with + | VList values, VInt position -> + if position < 0L || position >= int64 values.Length then Ok(VOption None) + else Ok(VOption(Some values.[int position])) + | VMap entries, key -> Ok(VOption(entries |> List.tryPick (fun (itemKey, value) -> if equal itemKey key then Some value else None))) + | _ -> fail "FSI3016" expression.Span "Index access requires a list and integer index.")) + | Lir.Interpolate parts -> + evaluateInterpolation environment parts |> Result.map (String.concat "" >> VString) + | Lir.UnionCase(typeName, caseName, payload) -> + payload |> Option.map (fun value -> evaluate environment value |> Result.map Some) |> Option.defaultValue (Ok None) + |> Result.map (fun value -> VUnion(typeName, caseName, value)) + | Lir.Map entries -> + let add key value values = + let without = values |> List.filter (fun (existing, _) -> not (equal existing key)) + (key, value) :: without |> List.sortBy (fst >> formatValue) + let rec build values remaining = + match remaining with + | [] -> Ok(VMap values) + | Lir.KeyValue(key, item) :: rest -> + evaluate environment key + |> Result.bind (fun keyValue -> + evaluate environment item + |> Result.bind (fun itemValue -> build (add keyValue itemValue values) rest)) + | Lir.Spread item :: rest -> + match evaluate environment item with + | Ok(VMap spread) -> + let merged = spread |> List.fold (fun state (key, value) -> if state |> List.exists (fst >> equal key) then state else add key value state) values + build merged rest + | Ok _ -> fail "FSI3017" expression.Span "Map spread requires a map." + | Error errors -> Error errors + build [] entries + | Lir.Intrinsic name -> + if intrinsicArity name = 0 then invokeIntrinsic (applyValue expression.Span) expression.Span name [] + else Ok(VIntrinsic(name, [])) + | Lir.HostExternal(name, arity) -> Ok(VExternal(name, arity, [])) + | Lir.RuntimeContext -> Ok VRuntimeContext + | Lir.TargetImport(modulePath, memberName) -> Ok(VTargetImport(modulePath, memberName, arityFromType expression.Type, [])) + | Lir.ForEach(id, _, _, source, body) -> + match evaluate environment source with + | Ok(VList values) -> + let rec loop remaining = + match remaining with + | [] -> Ok VUnit + | value :: tail -> evaluate (environment |> Map.add id value) body |> Result.bind (fun _ -> loop tail) + loop values + | Ok _ -> fail "FSI3018" expression.Span "For-loop source must be a list." + | Error errors -> Error errors + | Lir.TypeToken tokenType -> Ok(VTypeToken tokenType) + + and private applyValue span fn value = + let rec loop currentFunction currentValue = + match currentFunction with + | VClosure(parameter, _, body, captured) -> tailEvaluate (captured.Value |> Map.add parameter currentValue) body + | VIntrinsic(name, existing) -> + let arguments = existing @ [ currentValue ] + if arguments.Length = intrinsicArity name then + match currentHostExternals.Value |> Map.tryFind name with + | Some external -> + match external.Invoke arguments with + | Ok result -> Ok result + | Error message -> fail "FSI3021" span $"Host external '{name}' failed: {message}" + | None -> invokeIntrinsic (applyValue span) span name arguments + else Ok(VIntrinsic(name, arguments)) + | VExternal(name, arity, existing) -> + let arguments = existing @ [ currentValue ] + if arguments.Length = arity then + match currentHostExternals.Value |> Map.tryFind name with + | Some external -> + match external.Invoke arguments with + | Ok result -> Ok result + | Error message -> fail "FSI3021" span $"Host external '{name}' failed: {message}" + | None -> fail "FSI3021" span $"Host external '{name}' is not executable from LIR." + else Ok(VExternal(name, arity, arguments)) + | VTargetImport(modulePath, memberName, arity, existing) -> + let arguments = existing @ [ currentValue ] + if arguments.Length = arity then fail "FSI3023" span $"Target import '{modulePath}.{memberName}' is not executable from LIR." + else Ok(VTargetImport(modulePath, memberName, arity, arguments)) + | _ -> fail "FSI3003" span "Attempted to call a non-function value." + and tailEvaluate environment (expression: Lir.Expression) = + match expression.Node with + | Lir.TailCallClosure(fn, argument) -> + evaluate environment fn + |> Result.bind (fun fnValue -> evaluate environment argument |> Result.bind (loop fnValue)) + | Lir.TailPipeClosure(argument, fn) -> + evaluate environment argument + |> Result.bind (fun argumentValue -> evaluate environment fn |> Result.bind (fun fnValue -> loop fnValue argumentValue)) + | Lir.Branch(condition, whenTrue, whenFalse) -> + evaluate environment condition + |> Result.bind (function + | VBool true -> tailEvaluate environment whenTrue + | VBool false -> tailEvaluate environment whenFalse + | _ -> fail "FSI3004" expression.Span "Branch condition is not Boolean.") + | Lir.Let(id, _, recursive, binding, body) -> + if recursive then + match evaluate environment binding with + | Ok(VClosure(_, _, _, captured) as closure) -> + let next = Map.add id closure environment + captured.Value <- next + tailEvaluate next body + | Ok _ -> fail "FSI3010" expression.Span "Recursive local bindings must be functions." + | Error errors -> Error errors + else + evaluate environment binding |> Result.bind (fun bound -> tailEvaluate (Map.add id bound environment) body) + | Lir.LetRecursiveGroup(bindings, body) -> + let evaluated = bindings |> List.map (fun (id, _, _, binding) -> id, evaluate environment binding) + match evaluated |> List.tryPick (fun (_, result) -> match result with Error error -> Some error | Ok _ -> None) with + | Some error -> Error error + | None when evaluated |> List.exists (fun (_, result) -> match result with Ok(VClosure _) -> false | _ -> true) -> + fail "FSI3010" expression.Span "Recursive local groups must contain only functions." + | None -> + let recursiveEnvironment = evaluated |> List.fold (fun env (id, result) -> match result with Ok bound -> Map.add id bound env | Error _ -> env) environment + evaluated |> List.iter (fun (_, result) -> match result with Ok(VClosure(_, _, _, captured)) -> captured.Value <- recursiveEnvironment | _ -> ()) + tailEvaluate recursiveEnvironment body + | Lir.DecisionTree(target, cases) -> + evaluate environment target + |> Result.bind (fun targetValue -> + let rec select (remaining: Lir.DecisionCase list) = + match remaining with + | [] -> fail "FSI3012" expression.Span "Match failure." + | case :: rest -> + match matchPlan case.Plan targetValue with + | None -> select rest + | Some bindings -> + let caseEnvironment = Map.fold (fun env id bound -> Map.add id bound env) environment bindings + match case.Guard with + | None -> tailEvaluate caseEnvironment case.Body + | Some guard -> + evaluate caseEnvironment guard + |> Result.bind (function + | VBool true -> tailEvaluate caseEnvironment case.Body + | VBool false -> select rest + | _ -> fail "FSI3013" guard.Span "Match guard must evaluate to Boolean.") + select cases) + | _ -> evaluate environment expression + loop fn value + + and private evaluateMany environment items = + match items with + | [] -> Ok [] + | item :: rest -> + evaluate environment item + |> Result.bind (fun value -> evaluateMany environment rest |> Result.map (fun values -> value :: values)) + + and private evaluateNamed environment fields = + match fields with + | [] -> Ok [] + | (name, item) :: rest -> + evaluate environment item + |> Result.bind (fun value -> evaluateNamed environment rest |> Result.map (fun values -> (name, value) :: values)) + + and private evaluateInterpolation environment parts = + match parts with + | [] -> Ok [] + | Lir.TextPart text :: rest -> evaluateInterpolation environment rest |> Result.map (fun values -> text :: values) + | Lir.ValuePart item :: rest -> + evaluate environment item + |> Result.bind (fun value -> evaluateInterpolation environment rest |> Result.map (fun values -> formatValue value :: values)) + + let private loadValidated (context: InterpreterContext) (hostExternals: HostExternal list) (program: Lir.Program) = + let output = ResizeArray() + currentExitCode.Value <- ref 0 + currentOutput.Value <- output + currentFunctions.Value <- program.Functions |> List.map (fun fn -> fn.Id, fn) |> Map.ofList + currentHostExternals.Value <- hostExternals |> List.map (fun external -> external.Name, external) |> Map.ofList + let runtimeContext = + VRecord(Map.ofList + [ "ScriptName", VOption(Option.map VString context.ScriptName) + "Arguments", VList(List.map VString context.Arguments) ]) + let environment = ref Map.empty + let mutable failure = None + let rec initialize (declarations: Lir.Declaration list) = + match declarations with + | [] -> () + | declaration :: rest when not declaration.IsRecursive -> + match evaluate environment.Value declaration.Value with + | Error errors -> failure <- Some errors + | Ok value -> + let initialized = match value with VRuntimeContext -> runtimeContext | _ -> value + environment.Value <- environment.Value |> Map.add declaration.Id initialized + initialize rest + | _ -> + let group = declarations |> List.takeWhile _.IsRecursive + let remainder = declarations |> List.skip group.Length + let closures = group |> List.map (fun declaration -> declaration, evaluate environment.Value declaration.Value) + let error = closures |> List.tryPick (fun (_, result) -> match result with Error value -> Some value | Ok _ -> None) + if error.IsSome then failure <- error + else + let next = closures |> List.fold (fun env (declaration, result) -> match result with Ok closure -> Map.add declaration.Id closure env | Error _ -> env) environment.Value + for _, result in closures do + match result with Ok(VClosure(_, _, _, captured)) -> captured.Value <- next | _ -> () + environment.Value <- next + initialize remainder + initialize program.Declarations + let finish value = + let exports = + program.Declarations + |> List.choose (fun declaration -> + declaration.Export + |> Option.bind (fun metadata -> environment.Value |> Map.tryFind declaration.Id |> Option.map (fun value -> metadata.Name, value))) + |> Map.ofList + { Program = + { Program = program + Environment = environment.Value + Exports = exports + HostExternals = currentHostExternals.Value } + Value = value + Stdout = List.ofSeq output + ExitCode = currentExitCode.Value.Value } + match failure, program.Entry with + | Some errors, _ -> Error errors + | None, Some entry -> evaluate environment.Value entry |> Result.map finish + | None, None -> Ok(finish VUnit) + + let load + (context: InterpreterContext) + (hostExternals: HostExternal list) + (program: Lir.Program) + : Result = + match LirValidation.validate program with + | Error diagnostics -> Error diagnostics.Head + | Ok validated -> + let previous=currentExitCode.Value + try loadValidated context hostExternals validated + finally currentExitCode.Value <- previous + + let private invokeCore (loaded: LoadedProgram) (exportName: string) (arguments: LirValue list) : Result = + let output = ResizeArray() + currentExitCode.Value <- ref 0 + currentOutput.Value <- output + currentFunctions.Value <- loaded.Program.Functions |> List.map (fun fn -> fn.Id, fn) |> Map.ofList + currentHostExternals.Value <- loaded.HostExternals + match loaded.Exports |> Map.tryFind exportName with + | None -> + Error + { Code = "FSI3024" + Stage = Interpreter + Message = $"Unknown exported value '{exportName}'." + Span = None } + | Some exported -> + let span = + loaded.Program.Declarations + |> List.tryFind (fun declaration -> declaration.Export |> Option.exists (fun metadata -> metadata.Name = exportName)) + |> Option.map _.Span + |> Option.defaultValue (Span.mk (Span.pos 0 0) (Span.pos 0 0)) + arguments + |> List.fold (fun state argument -> state |> Result.bind (fun fn -> applyValue span fn argument)) (Ok exported) + |> Result.map (fun value -> { Value = value; Stdout = List.ofSeq output; ExitCode = currentExitCode.Value.Value }) + + let invoke loaded exportName arguments = + let previous=currentExitCode.Value + try invokeCore loaded exportName arguments + finally currentExitCode.Value <- previous + + let executeWithHostExternals + (context: InterpreterContext) + (hostExternals: HostExternal list) + (program: Lir.Program) + : Result = + load context hostExternals program + |> Result.map (fun result -> { Value = result.Value; Stdout = result.Stdout; ExitCode = result.ExitCode }) + + let execute (context: InterpreterContext) (program: Lir.Program) : Result = + executeWithHostExternals context [] program diff --git a/src/FScript.JavaScript/README.md b/src/FScript.JavaScript/README.md index d1577d9..e6cadcc 100644 --- a/src/FScript.JavaScript/README.md +++ b/src/FScript.JavaScript/README.md @@ -9,3 +9,7 @@ Provide complete environments with `registration({types, unions, functions})` an `HostFunctions.create({name, parameters, result, invoke})` builds a typed function from explicit script types. Handlers receive tagged arguments and an invocation context with `apply` for synchronous script callbacks. Existing `extern` declarations still work. Fable task execution and Promise-returning handlers are unsupported. See the [JavaScript hosting reference](https://fscript.magnusopera.io/manual/embedding/fable-javascript) for descriptor tables and examples. Run the local sample after building: `node examples/hosting.mjs`. + +## Exit status + +JavaScript treats `Env.setExitCode` as a no-op for source portability. It does not change process status or enforce a shell-code range. Arguments are still evaluated normally, and the program's returned value is unchanged. The website continues displaying that value. Existing `run`, `evaluate`, and `invoke` APIs retain their tagged-value results. diff --git a/src/FScript.JavaScript/test/fable.test.mjs b/src/FScript.JavaScript/test/fable.test.mjs index 4b86d95..efe066d 100644 --- a/src/FScript.JavaScript/test/fable.test.mjs +++ b/src/FScript.JavaScript/test/fable.test.mjs @@ -26,6 +26,18 @@ test("run returns tagged primitive values", () => { assert.equal(result.value, 42n); }); +test("String.replace always returns, including empty search strings", () => { + for (const [search, replacement, source, expected] of [ + ["", "x", "abc", "abc"], + ["", "x", "", ""], + ["a", "", "banana", "bnn"], + ["aa", "b", "aaaa", "bb"] + ]) { + const args = [search, replacement, source].map(value => JSON.stringify(value)).join(" "); + assert.equal(run(`String.replace ${args}`).value, expected); + } +}); + test("map keys round-trip through tagged JavaScript values", () => { const value = run("type Color = | Red | Blue\n{ [Red] = 1; [Blue] = 2 }"); assert.equal(value.kind, "map"); @@ -136,4 +148,26 @@ test("export is a contextual declaration prefix rather than a reserved identifie assert.equal(getValue(loaded, "answer").value, 42n); assert.equal(invoke(loaded, "export", [7]).value, 7n); assert.throws(() => run("[] let answer = 42"), error => error.phase === "parse"); + assert.throws(() => run("let outer =\n export let answer = 42\n answer\nouter"), error => error.phase === "parse"); +}); + +test("attribute forms cannot declare exports", () => { + for (const attribute of ["export", "Export"]) { + for (const source of [ + `[<${attribute}>] let answer = 42`, + `[<${attribute}>] let echo value = value`, + `[<${attribute}("argument")>] let answer = 42`, + `[<${attribute}>] type Answer = { Value: int }` + ]) { + assert.throws(() => load(source), error => error.phase === "parse" && error.message === "Unexpected attribute"); + } + } +}); + +test("JavaScript ignores exit status and preserves the returned value", () => { + assert.equal(run("Env.setExitCode 7\n42").value, 42n); + assert.equal(run("Env.setExitCode 256\n42").value, 42n); + assert.equal(run("Env.setExitCode (0-1)\n42").value, 42n); + const loaded = load("export let configure code =\n Env.setExitCode code\n code+1\n42"); + assert.equal(invoke(loaded, "configure", [7]).value, 8n); }); diff --git a/src/FScript.Language/Ast.fs b/src/FScript.Language/Ast.fs index 1ef2cc8..d4bd3d4 100644 --- a/src/FScript.Language/Ast.fs +++ b/src/FScript.Language/Ast.fs @@ -1,10 +1,16 @@ namespace FScript.Language +type BackendImport = + { ModulePath: string + MemberName: string + Span: Span } + type TypeDef = { Name: string IsRecursive: bool Fields: (string * TypeRef) list Cases: (string * TypeRef option) list + Import: BackendImport option Span: Span } and TypeRef = @@ -21,6 +27,11 @@ type Param = Annotation: TypeRef option Span: Span } +type Attribute = + { Name: string + Arguments: string list + Span: Span } + type Literal = | LInt of int64 | LFloat of float @@ -88,6 +99,8 @@ and Stmt = | SLet of string * Param list * TypeRef option * Expr * bool * bool * Span | SLetPattern of Pattern * Expr * bool * Span | SLetRecGroup of (string * Param list * TypeRef option * Expr * Span) list * bool * Span + | SBackendImport of string * TypeRef * BackendImport * Span + | SAttributed of Attribute list * Stmt * Span | SExpr of Expr type Program = Stmt list @@ -141,3 +154,10 @@ module Ast = | ETypeOf (_, s) -> s | ENameOf (_, s) -> s | EInterpolatedString (_, s) -> s + + let spanOfStmt statement = + match statement with + | SType definition -> definition.Span + | SImport(_, _, span) | SLet(_, _, _, _, _, _, span) | SLetPattern(_, _, _, span) + | SLetRecGroup(_, _, span) | SBackendImport(_, _, _, span) | SAttributed(_, _, span) -> span + | SExpr expression -> spanOfExpr expression diff --git a/src/FScript.Language/BuiltinFunctions.fs b/src/FScript.Language/BuiltinFunctions.fs index 4f2ccd9..d892df1 100644 --- a/src/FScript.Language/BuiltinFunctions.fs +++ b/src/FScript.Language/BuiltinFunctions.fs @@ -212,7 +212,7 @@ module BuiltinFunctions = (fun _ args -> match args with | [ VString oldValue; VString newValue; VString source ] -> - VString(source.Replace(oldValue, newValue)) + VString(if oldValue = "" then source else source.Replace(oldValue, newValue)) | _ -> fail "String.replace expects (string, string, string)") } let private builtinStringIndexOf : ExternalFunction = @@ -702,8 +702,22 @@ module BuiltinFunctions = | [ key; VMap values ] -> values.Remove(valueToMapKey "Map.remove" key) |> VMap | _ -> fail "Map.remove expects (key, values)") } + let private builtinSetExitCode : ExternalFunction = + { Name = "Env.setExitCode" + Scheme = scheme "Env.setExitCode" + Arity = 1 + Impl = fun context -> function +#if FABLE_COMPILER + | [VInt _] -> VUnit +#else + | [VInt code] when code >= 0L && code <= 255L -> context.SetExitCode(int code); VUnit + | [VInt _] -> fail "Env.setExitCode expects a code between 0 and 255." +#endif + | _ -> fail "Env.setExitCode expects an integer." } + let builtinExterns : ExternalFunction list = - [ builtinIgnore + [ builtinSetExitCode + builtinIgnore builtinIntTryParse builtinFloatTryParse builtinBoolTryParse diff --git a/src/FScript.Language/BuiltinSignatures.fs b/src/FScript.Language/BuiltinSignatures.fs index e890ab3..1474b73 100644 --- a/src/FScript.Language/BuiltinSignatures.fs +++ b/src/FScript.Language/BuiltinSignatures.fs @@ -2,7 +2,8 @@ namespace FScript.Language module BuiltinSignatures = let builtinSchemes : Map = - [ "ignore", Forall([ 0 ], TFun(TVar 0, TUnit)) + [ "Env.setExitCode", Forall([], TFun(TInt, TUnit)) + "ignore", Forall([ 0 ], TFun(TVar 0, TUnit)) "Int.tryParse", Forall([], TFun(TString, TOption TInt)) "Float.tryParse", Forall([], TFun(TString, TOption TFloat)) "Bool.tryParse", Forall([], TFun(TString, TOption TBool)) @@ -58,7 +59,8 @@ module BuiltinSignatures = builtinSchemes |> Map.keys |> Seq.filter (fun name -> - name.StartsWith("List.", System.StringComparison.Ordinal) + name = "Env.setExitCode" + || name.StartsWith("List.", System.StringComparison.Ordinal) || name.StartsWith("Option.", System.StringComparison.Ordinal) || name.StartsWith("Map.", System.StringComparison.Ordinal)) |> Set.ofSeq diff --git a/src/FScript.Language/BuiltinTypes.fs b/src/FScript.Language/BuiltinTypes.fs index f807db5..bef862c 100644 --- a/src/FScript.Language/BuiltinTypes.fs +++ b/src/FScript.Language/BuiltinTypes.fs @@ -10,6 +10,7 @@ module BuiltinTypes = [ "ScriptName", TRPostfix(TRName "string", "option") "Arguments", TRPostfix(TRName "string", "list") ] Cases = [] + Import = None Span = unknownSpan } let fsKindType : TypeDef = @@ -20,6 +21,7 @@ module BuiltinTypes = [ "File", Some (TRName "string") "Directory", Some (TRName "string") "Missing", None ] + Import = None Span = unknownSpan } let typeDefs : TypeDef list = diff --git a/src/FScript.Language/Eval.fs b/src/FScript.Language/Eval.fs index d2931b1..fe83250 100644 --- a/src/FScript.Language/Eval.fs +++ b/src/FScript.Language/Eval.fs @@ -11,10 +11,14 @@ module Eval = type ProgramState = { TypeDefs: Map Env: Env - LastValue: Value } + LastValue: Value + ExitCode: int } + + type InvocationResult = { Value: Value; ExitCode: int } type private RuntimeState = { SyncRoot: obj + ExitCode: int ref Active: bool ref PendingTasks: ResizeArray BackgroundFailure: EvalError option ref @@ -438,6 +442,11 @@ module Eval = Apply = fun f a -> applyFunctionValue runtime typeDefs span f a |> Execution.run SpawnTask = spawnTaskValue runtime typeDefs AwaitTask = awaitTaskValue runtime +#if FABLE_COMPILER + SetExitCode = ignore +#else + SetExitCode = fun code -> withRuntimeLock runtime (fun () -> runtime.ExitCode.Value <- code) +#endif CheckRuntime = fun () -> raiseIfBackgroundFailed runtime #if !FABLE_COMPILER @@ -765,6 +774,7 @@ module Eval = | EStructuralRecordUpdate(target, updates, span) -> return! updateRecord runtime typeDefs env target updates span true | EFieldGet(target, field, span) -> let rec qualified = function + | EVar("Env", _) when field="setExitCode" -> Some "Env" | EVar(name, _) when not (env.ContainsKey name) -> Some name | EFieldGet(parent, name, _) -> qualified parent |> Option.map (fun prefix -> prefix + "." + name) | _ -> None @@ -791,6 +801,16 @@ module Eval = | VMap _, _ -> return raise (EvalException { Message = "Map index key must be string, int, bool, or a payload-free union case"; Span = span }) | VList _, _ -> return raise (EvalException { Message = "List index must be int"; Span = span }) | _ -> return raise (EvalException { Message = "Index access requires a list or map value"; Span = span }) + | EBinOp(("&&" | "||") as op, a, b, span) -> + let! first = evalExpr runtime typeDefs env a + match first with + | VBool value when (op = "&&" && not value) || (op = "||" && value) -> return VBool value + | VBool _ -> + let! second = evalExpr runtime typeDefs env b + match second with + | VBool _ -> return second + | _ -> return raise (EvalException { Message = "Boolean operands required"; Span = span }) + | _ -> return raise (EvalException { Message = "Boolean operands required"; Span = span }) | ECons(a, b, span) | EAppend(a, b, span) | EBinOp(_, a, b, span) -> let! av = evalExpr runtime typeDefs env a let! bv = evalExpr runtime typeDefs env b @@ -821,9 +841,10 @@ module Eval = return invalidOp "Immediate expressions are handled before compound evaluation." } - let invokeValue (typeDefs: Map) (fnValue: Value) (args: Value list) : Value = + let invokeValueWithExitCode (typeDefs: Map) (fnValue: Value) (args: Value list) : InvocationResult = let runtime = { SyncRoot = obj () + ExitCode = ref 0 Active = ref true PendingTasks = ResizeArray() BackgroundFailure = ref None @@ -864,9 +885,13 @@ module Eval = let next = applyFunctionValue runtime typeDefs unknownSpan value nextArg |> Execution.run applyMany next tailArgs - try applyMany fnValue args + try + let value=applyMany fnValue args + {Value=value;ExitCode=withRuntimeLock runtime (fun () -> runtime.ExitCode.Value)} finally withRuntimeLock runtime (fun () -> runtime.Active.Value <- false) + let invokeValue typeDefs fnValue args = (invokeValueWithExitCode typeDefs fnValue args).Value + let private validateTopLevelBindings (program: TypeInfer.TypedProgram) = let reserved = BuiltinSignatures.builtinReservedNames @@ -896,6 +921,14 @@ module Eval = match stmt with | TypeInfer.TSType _ -> () + | TypeInfer.TSBackendImport(name, importedType, import, span) -> + let rec arity = function TFun(_, result) -> 1 + arity result | _ -> 0 + let external = + { Name = name + Scheme = Forall([], importedType) + Arity = arity importedType + Impl = fun _ _ -> raise (EvalException { Message = $"Backend import '{import.ModulePath}.{import.MemberName}' is not executable in the legacy evaluator"; Span = span }) } + env <- Map.add name (VExternal(external, [])) env | TypeInfer.TSLet(name, expr, _, isRec, _, span) -> if isRec then match expr with @@ -947,11 +980,13 @@ module Eval = { TypeDefs = typeDefs Env = env - LastValue = lastValue } + LastValue = lastValue + ExitCode = withRuntimeLock runtime (fun () -> runtime.ExitCode.Value) } let evalProgramFromState (state: ProgramState) (program: TypeInfer.TypedProgram) : ProgramState = let runtime = { SyncRoot = obj () + ExitCode = ref state.ExitCode Active = ref true PendingTasks = ResizeArray() BackgroundFailure = ref None @@ -973,6 +1008,7 @@ module Eval = let reserved = BuiltinSignatures.builtinReservedNames let runtime = { SyncRoot = obj () + ExitCode = ref 0 Active = ref true PendingTasks = ResizeArray() BackgroundFailure = ref None diff --git a/src/FScript.Language/ExportSignatures.fs b/src/FScript.Language/ExportSignatures.fs new file mode 100644 index 0000000..bbea9fd --- /dev/null +++ b/src/FScript.Language/ExportSignatures.fs @@ -0,0 +1,51 @@ +namespace FScript.Language + +module ExportSignatures = + type ExportedFunctionSignature = + { Name: string + ParameterNames: string list + ParameterTypes: Type list + ReturnType: Type } + + let private flattenFunctionType (t: Type) : Type list * Type = + let rec loop (acc: Type list) (current: Type) = + match current with + | TFun (argument, returnType) -> loop (argument :: acc) returnType + | _ -> List.rev acc, current + loop [] t + + let private flattenParameterNames (expression: Expr) : string list = + let rec loop (acc: string list) (current: Expr) = + match current with + | ELambda (parameter, body, _) -> loop (parameter.Name :: acc) body + | _ -> List.rev acc + loop [] expression + + let private fromLet name expression expressionType = + let parameterNames = flattenParameterNames expression + let parameterTypes, returnType = flattenFunctionType expressionType + if parameterNames.IsEmpty || parameterTypes.IsEmpty then + None + elif parameterNames.Length <> parameterTypes.Length then + failwith $"Signature mismatch for function '{name}'" + else + Some + { Name = name + ParameterNames = parameterNames + ParameterTypes = parameterTypes + ReturnType = returnType } + + let fromTypedProgram (program: TypeInfer.TypedProgram) : Map = + program + |> List.collect (function + | TypeInfer.TSLet(name, expression, expressionType, _, isExported, _) when isExported -> + match fromLet name expression expressionType with + | Some signature -> [ signature.Name, signature ] + | None -> [] + | TypeInfer.TSLetRecGroup(bindings, isExported, _) when isExported -> + bindings + |> List.choose (fun (name, expression, expressionType, _) -> + fromLet name expression expressionType + |> Option.map (fun signature -> signature.Name, signature)) + | _ -> []) + |> Map.ofList diff --git a/src/FScript.Language/FScript.Language.fsproj b/src/FScript.Language/FScript.Language.fsproj index 0483fd5..dca041d 100644 --- a/src/FScript.Language/FScript.Language.fsproj +++ b/src/FScript.Language/FScript.Language.fsproj @@ -35,6 +35,7 @@ + diff --git a/src/FScript.Language/IncludeResolver.fs b/src/FScript.Language/IncludeResolver.fs index b54a095..92e004c 100644 --- a/src/FScript.Language/IncludeResolver.fs +++ b/src/FScript.Language/IncludeResolver.fs @@ -381,9 +381,12 @@ module IncludeResolver = loop [] expr let private rewriteModuleScopedStatements (selfPrefix: string option) (aliases: Map) (statements: Stmt list) : Stmt list = + let rec unwrap = function + | SAttributed(_, statement, _) -> unwrap statement + | statement -> statement let topLevelValueNames = statements - |> List.collect (function + |> List.collect (unwrap >> function | SLet(name, _, _, _, _, _, _) -> [ name ] | SLetPattern(pattern, _, _, _) -> collectPatternBindings pattern |> Set.toList | SLetRecGroup(bindings, _, _) -> bindings |> List.map (fun (name, _, _, _, _) -> name) @@ -392,7 +395,7 @@ module IncludeResolver = let topLevelTypeNames = statements - |> List.choose (function | SType def -> Some def.Name | _ -> None) + |> List.choose (unwrap >> function | SType def -> Some def.Name | _ -> None) |> Set.ofList let rewriteValueName boundNames name = @@ -526,8 +529,8 @@ module IncludeResolver = def.Cases |> List.map (fun (name, payload) -> name, payload |> Option.map (rewriteTypeRef aliases selfPrefix topLevelTypeNames)) } - statements - |> List.map (function + let rec rewriteStatement = function + | SAttributed(attributes, statement, span) -> SAttributed(attributes, rewriteStatement statement, span) | SType def -> SType (rewriteTypeDef def) | SLet(name, args, returnAnnotation, valueExpr, isRec, isExported, span) -> @@ -553,9 +556,12 @@ module IncludeResolver = let bound = rewrittenArgs |> List.fold (fun s p -> Set.add p.Name s) names rewrittenName, rewrittenArgs, rewrittenReturnAnnotation, rewriteExpr bound valueExpr, bindingSpan) SLetRecGroup(rewrittenBindings, isExported, span) + | SBackendImport(name, signature, import, span) -> + SBackendImport(qualifySelfName name, rewriteTypeRef aliases selfPrefix topLevelTypeNames signature, import, span) | SExpr expr -> SExpr (rewriteExpr Set.empty expr) - | SImport _ -> failwith "Unexpected unresolved import directive") + | SImport _ -> failwith "Unexpected unresolved import directive" + statements |> List.map rewriteStatement let private expandProgram (rootDirectoryWithSeparator: string) diff --git a/src/FScript.Language/Interactive.fs b/src/FScript.Language/Interactive.fs index 33d76f5..1b79ffe 100644 --- a/src/FScript.Language/Interactive.fs +++ b/src/FScript.Language/Interactive.fs @@ -55,6 +55,7 @@ module Interactive = groupBindings |> List.fold (fun state (name, _, bindingType, _) -> state |> Map.add name (inferenceBinding name bindingType)) current + | TypeInfer.TSBackendImport(name, importedType, _, _) -> current |> Map.add name (inferenceBinding name importedType) | TypeInfer.TSType _ | TypeInfer.TSExpr _ -> current) bindings diff --git a/src/FScript.Language/Lexer.fs b/src/FScript.Language/Lexer.fs index 69e5826..2295954 100644 --- a/src/FScript.Language/Lexer.fs +++ b/src/FScript.Language/Lexer.fs @@ -162,14 +162,14 @@ module Lexer = let raw = if contentLen <= 0 then "" else src.Substring(start, contentLen) raw, idx, cLine, cCol - let tokenizeWithSourceName (sourceName: string option) (src: string) : Token list = + let tokenizeWithSourceNameAndOrigin (sourceName: string option) (startLine: int) (startColumn: int) (src: string) : Token list = let tokens = ResizeArray() let indentStack = ResizeArray() indentStack.Add(0) let mutable i = 0 - let mutable line = 1 - let mutable col = 1 + let mutable line = startLine + let mutable col = startColumn let mutable atLineStart = true let mutable inLetBindingHead = false let mutable parenDepth = 0 @@ -412,5 +412,8 @@ module Lexer = addToken EOF (mkSpan sourceName line col 1) tokens tokens |> Seq.toList + let tokenizeWithSourceName (sourceName: string option) (src: string) : Token list = + tokenizeWithSourceNameAndOrigin sourceName 1 1 src + let tokenize (src: string) : Token list = tokenizeWithSourceName None src diff --git a/src/FScript.Language/Library.fs b/src/FScript.Language/Library.fs index 3eccb82..541f349 100644 --- a/src/FScript.Language/Library.fs +++ b/src/FScript.Language/Library.fs @@ -8,6 +8,8 @@ module FScript = let parseSourceWithIncludesResolver = IncludeResolver.parseProgramFromSourceWithIncludesResolver let infer = TypeInfer.inferProgram let inferWithExterns = TypeInfer.inferProgramWithExterns + let inferResolved = TypeInfer.inferResolvedProgram + let inferResolvedWithExterns = TypeInfer.inferResolvedProgramWithExterns let inferWithRegistration = TypeInfer.inferProgramWithRegistration let evalWithRegistration = Eval.evalProgramWithRegistration let eval = Eval.evalProgram diff --git a/src/FScript.Language/Parser.fs b/src/FScript.Language/Parser.fs index 12a9096..edb010e 100644 --- a/src/FScript.Language/Parser.fs +++ b/src/FScript.Language/Parser.fs @@ -60,12 +60,12 @@ module Parser = | BoolLit v -> LBool v | _ -> raise (ParseException { Message = "Expected literal"; Span = t.Span }) - let rec parseProgramWithSourceName (sourceName: string option) (src: string) : Program = - let tokens = Lexer.tokenizeWithSourceName sourceName src + let rec private parseProgramWithSourceNameAndOrigin (sourceName: string option) (startLine: int) (startColumn: int) (src: string) : Program = + let tokens = Lexer.tokenizeWithSourceNameAndOrigin sourceName startLine startColumn src let stream = TokenStream(tokens) - let parseSingleExpression (exprText: string) = - let parsed = parseProgramWithSourceName None exprText + let parseSingleExpression (originLine: int) (originColumn: int) (exprText: string) = + let parsed = parseProgramWithSourceNameAndOrigin sourceName originLine originColumn exprText match parsed with | [ SExpr expr ] -> expr | _ -> @@ -110,7 +110,15 @@ module Parser = let exprText = s.Substring(start, i - start - 1) if System.String.IsNullOrWhiteSpace(exprText) then raise (ParseException { Message = "Interpolation placeholder cannot be empty"; Span = span }) - let expr = parseSingleExpression exprText + let mutable originLine = span.Start.Line + let mutable originColumn = span.Start.Column + 2 + for offset = 0 to start - 1 do + if s.[offset] = '\n' then + originLine <- originLine + 1 + originColumn <- 1 + else + originColumn <- originColumn + 1 + let expr = parseSingleExpression originLine originColumn exprText expr, i let mutable i = 0 @@ -351,7 +359,7 @@ module Parser = argsDone <- true args - and parseTypeDecl () : Stmt = + and parseTypeDecl (backendImport: Attribute option) : Stmt = let typeTok = stream.Expect(Type, "Expected 'type'") let isRec = stream.Match(Rec) let nameTok = stream.ExpectIdent("Expected identifier after 'type'") @@ -463,7 +471,14 @@ module Parser = if not (stream.Match(Dedent)) then raise (ParseException { Message = "Expected dedent after type declaration"; Span = stream.Peek().Span }) while stream.Match(Dedent) do () - SType { Name = name; IsRecursive = isRec; Fields = fields; Cases = cases; Span = mkSpanFrom typeTok.Span endSpan } + let import = + backendImport + |> Option.map (fun attribute -> + match attribute.Arguments with + | [ modulePath; memberName ] when not (System.String.IsNullOrWhiteSpace modulePath) && not (System.String.IsNullOrWhiteSpace memberName) -> + { ModulePath = modulePath; MemberName = memberName; Span = attribute.Span } + | _ -> raise (ParseException { Message = "Import requires module path and member name: []"; Span = attribute.Span })) + SType { Name = name; IsRecursive = isRec; Fields = fields; Cases = cases; Import = import; Span = mkSpanFrom typeTok.Span endSpan } and parsePattern () : Pattern = stream.SkipNewlines() @@ -1458,6 +1473,8 @@ module Parser = raise (ParseException { Message = "Block cannot end with a let binding; add a final expression"; Span = span }) | [SLetRecGroup(_, _, span)] -> raise (ParseException { Message = "Block cannot end with a let binding; add a final expression"; Span = span }) + | SBackendImport(_, _, _, span) :: _ -> + raise (ParseException { Message = "Backend imports are only supported at top level"; Span = span }) | SLet(name, args, returnAnnotation, value, isRec, _, span) :: rest -> let valExpr = Seq.foldBack (fun arg acc -> ELambda(arg, acc, span)) args value let body = desugar rest @@ -1475,6 +1492,8 @@ module Parser = raise (ParseException { Message = "Type declarations are only supported at top level"; Span = def.Span }) | SImport (_, _, span) :: _ -> raise (ParseException { Message = "'import' is only supported at top level"; Span = span }) + | SAttributed(_, _, span) :: _ -> + raise (ParseException { Message = "Attributes are only supported at top level"; Span = span }) desugar (statements |> Seq.toList) and parseLetStmt (isExported: bool) : Stmt = @@ -1561,49 +1580,122 @@ module Parser = | None -> SLet(bindingName, args |> Seq.toList, returnAnnotation, value, false, isExported, mkSpanFrom letTok.Span (Ast.spanOfExpr value)) + and parseAttribute () = + stream.Expect(LBracket, "Expected '[' in attribute") |> ignore + stream.Expect(Less, "Expected '<' in attribute") |> ignore + let nameTok = stream.ExpectIdent("Expected attribute name") + let name = + match nameTok.Kind with + | Ident n -> n + | _ -> "" + let arguments = ResizeArray() + if stream.Match(LParen) then + let mutable doneArguments = false + while not doneArguments do + let argument = stream.Next() + match argument.Kind with + | StringLit value | Ident value -> arguments.Add(value) + | _ -> raise (ParseException { Message = "Attribute arguments must be strings or identifiers"; Span = argument.Span }) + if stream.Match(Comma) then () + else + stream.Expect(RParen, "Expected ')' after attribute arguments") |> ignore + doneArguments <- true + stream.Expect(Greater, "Expected '>' in attribute") |> ignore + stream.Expect(RBracket, "Expected ']' in attribute") |> ignore + { Name = name; Arguments = arguments |> Seq.toList; Span = nameTok.Span } + + and parseBackendImport (attribute: Attribute) = + let letToken = stream.Expect(Let, "Expected 'let' after Import attribute") + let nameToken = stream.ExpectIdent("Expected imported binding name") + let name = match nameToken.Kind with Ident value -> value | _ -> "" + stream.Expect(Colon, "Imported binding requires a complete type signature") |> ignore + let signature = parseTypeRef() + if stream.Peek().Kind = Equals then + raise (ParseException { Message = "Imported bindings must not have a body"; Span = stream.Peek().Span }) + match attribute.Arguments with + | [ modulePath; memberName ] when not (System.String.IsNullOrWhiteSpace modulePath) && not (System.String.IsNullOrWhiteSpace memberName) -> + let span = mkSpanFrom letToken.Span nameToken.Span + SBackendImport(name, signature, { ModulePath = modulePath; MemberName = memberName; Span = attribute.Span }, span) + | _ -> + raise (ParseException { Message = "Import requires module path and member name: []"; Span = attribute.Span }) + and parseStmt () : Stmt = stream.SkipNewlines() - match stream.Peek().Kind with - | Ident "export" when stream.PeekAt(1).Kind = Let -> + if stream.Peek().Kind = Ident "export" && stream.PeekAt(1).Kind = Let then stream.Next() |> ignore parseLetStmt true - | LBracket when stream.PeekAt(1).Kind = Less -> - raise (ParseException { Message = "Attributes are not supported in scripts; use 'export let' for exported bindings"; Span = stream.Peek().Span }) - | Hash -> - let hashTok = stream.Next() - match stream.Next().Kind with - | Include -> - raise (ParseException { Message = "'#include' was removed in 0.32.0; use 'import \"file.fss\" as Alias'"; Span = hashTok.Span }) + else + parseAttributedStmt () + + and parseAttributedStmt () : Stmt = + + let mutable hasAttributes = false + let mutable backendImport: Attribute option = None + let structuredAttributes = ResizeArray() + let mutable parsingAttributes = true + while parsingAttributes do + if stream.Peek().Kind = LBracket && stream.PeekAt(1).Kind = Less then + hasAttributes <- true + let attribute = parseAttribute() + match attribute.Name with + | "export" | "Export" -> + raise (ParseException { Message = "Unexpected attribute"; Span = attribute.Span }) + | "Import" -> + if backendImport.IsSome then + raise (ParseException { Message = "Duplicate attribute 'Import'"; Span = attribute.Span }) + backendImport <- Some attribute + | _ -> structuredAttributes.Add(attribute) + stream.SkipNewlines() + else + parsingAttributes <- false + + let statement = + match stream.Peek().Kind with + | Hash -> + if hasAttributes then + raise (ParseException { Message = "Attributes are not supported on 'import' directives"; Span = stream.Peek().Span }) + let hashTok = stream.Next() + match stream.Next().Kind with + | Include -> + raise (ParseException { Message = "'#include' was removed in 0.32.0; use 'import \"file.fss\" as Alias'"; Span = hashTok.Span }) + | Import -> + raise (ParseException { Message = "'#import' was removed in 0.32.0; use 'import \"file.fss\" as Alias'"; Span = hashTok.Span }) + | _ -> + raise (ParseException { Message = "Unexpected '#'; use 'import \"file.fss\" as Alias'"; Span = hashTok.Span }) | Import -> - raise (ParseException { Message = "'#import' was removed in 0.32.0; use 'import \"file.fss\" as Alias'"; Span = hashTok.Span }) - | _ -> - raise (ParseException { Message = "Unexpected '#'; use 'import \"file.fss\" as Alias'"; Span = hashTok.Span }) - | Import -> - let importTok = stream.Next() - let pathTok = stream.Next() - match pathTok.Kind with - | StringLit path when not (System.String.IsNullOrWhiteSpace path) -> - stream.Expect(As, "Expected 'as' in import directive. Use: import \"file.fss\" as Alias") |> ignore - let aliasTok = stream.ExpectIdent("Expected module alias after 'as'") - let alias = - match aliasTok.Kind with - | Ident value -> value - | _ -> "" - SImport(alias, path, mkSpanFrom importTok.Span aliasTok.Span) - | StringLit _ -> - raise (ParseException { Message = "Import path cannot be empty"; Span = pathTok.Span }) + if hasAttributes then + raise (ParseException { Message = "Attributes are not supported on 'import' directives"; Span = stream.Peek().Span }) + let importTok = stream.Next() + let pathTok = stream.Next() + match pathTok.Kind with + | StringLit path when not (System.String.IsNullOrWhiteSpace path) -> + stream.Expect(As, "Expected 'as' in import directive. Use: import \"file.fss\" as Alias") |> ignore + let aliasTok = stream.ExpectIdent("Expected module alias after 'as'") + let alias = + match aliasTok.Kind with + | Ident value -> value + | _ -> "" + SImport(alias, path, mkSpanFrom importTok.Span aliasTok.Span) + | StringLit _ -> + raise (ParseException { Message = "Import path cannot be empty"; Span = pathTok.Span }) + | _ -> + raise (ParseException { Message = "Expected string literal import path after 'import'"; Span = pathTok.Span }) + | Module -> + raise (ParseException { Message = "'module' declarations are not supported in scripts"; Span = stream.Peek().Span }) + | Type -> + parseTypeDecl backendImport + | Let -> + match backendImport with + | Some attribute -> parseBackendImport attribute + | None -> parseLetStmt false + | _ when hasAttributes -> + raise (ParseException { Message = "Attributes must be followed by a top-level declaration"; Span = stream.Peek().Span }) | _ -> - raise (ParseException { Message = "Expected string literal import path after 'import'"; Span = pathTok.Span }) - | Module -> - raise (ParseException { Message = "'module' declarations are not supported in scripts"; Span = stream.Peek().Span }) - | Type -> - parseTypeDecl() - | Let -> - parseLetStmt false - | _ -> - let expr = parseExpr() - SExpr expr + let expr = parseExpr() + SExpr expr + if structuredAttributes.Count = 0 then statement + else SAttributed(structuredAttributes |> Seq.toList, statement, Ast.spanOfStmt statement) let program = ResizeArray() stream.SkipNewlines() @@ -1617,5 +1709,8 @@ module Parser = stream.SkipNewlines() program |> Seq.toList + let parseProgramWithSourceName (sourceName: string option) (src: string) : Program = + parseProgramWithSourceNameAndOrigin sourceName 1 1 src + let parseProgram (src: string) : Program = parseProgramWithSourceName None src diff --git a/src/FScript.Language/TypeInfer.fs b/src/FScript.Language/TypeInfer.fs index 3814a57..f0a8f05 100644 --- a/src/FScript.Language/TypeInfer.fs +++ b/src/FScript.Language/TypeInfer.fs @@ -211,6 +211,137 @@ module TypeInfer = Span: Span Type: Type } + type ResolvedExpressionType = + { Expr: Expr + Type: Type + Span: Span } + + type ResolvedSymbolReference = + { SymbolId: int + Name: string + Kind: ResolvedSymbolKind + Type: Type + Span: Span } + + and ResolvedSymbolKind = + | TypeSymbol + | DeclarationSymbol + | ParameterSymbol + | PatternBindingSymbol + | LocalSymbol + | BuiltinSymbol + | ExternSymbol + | UnionCaseSymbol + + type ResolvedSymbol = + { SymbolId: int + Name: string + Kind: ResolvedSymbolKind + Span: Span + Scheme: Scheme option } + + type ResolvedPrimitiveOperation = + | NumericAddition | NumericSubtraction | NumericMultiplication | NumericDivision + | IntegerAddition | FloatingAddition + | IntegerSubtraction | FloatingSubtraction + | IntegerMultiplication | FloatingMultiplication + | IntegerDivision | FloatingDivision + | IntegerRemainder | StructuralEquality + | NumericComparison of string + | BooleanOperation of string + + type RecordCoercionEvidence = + { SourceType: Type + TargetType: Type + TargetName: string option } + + type ResolvedLiteral = + | ResolvedUnit + | ResolvedInt of int64 + | ResolvedFloat of float + | ResolvedBool of bool + | ResolvedString of string + + type ResolvedBinding = + { SymbolId: int + Name: string + Type: Type + Span: Span } + + type ResolvedExpression = + { Type: Type + Span: Span + Reference: ResolvedSymbolReference option + Primitive: ResolvedPrimitiveOperation option + RecordCoercion: RecordCoercionEvidence option + Node: ResolvedExpressionNode + Children: ResolvedExpression list } + + and ResolvedExpressionNode = + | ResolvedConstant of ResolvedLiteral + | ResolvedReference of ResolvedSymbolReference + | ResolvedLambda of ResolvedBinding * ResolvedExpression + | ResolvedApply of ResolvedExpression * ResolvedExpression + | ResolvedPipe of ResolvedExpression * ResolvedExpression + | ResolvedIf of ResolvedExpression * ResolvedExpression * ResolvedExpression + | ResolvedPrimitive of ResolvedPrimitiveOperation * ResolvedExpression list + | ResolvedTuple of ResolvedExpression list + | ResolvedList of ResolvedExpression list + | ResolvedRecord of (string * ResolvedExpression) list + | ResolvedFieldGet of ResolvedExpression * string + | ResolvedSome of ResolvedExpression + | ResolvedNone + | ResolvedCons of ResolvedExpression * ResolvedExpression + | ResolvedAppend of ResolvedExpression * ResolvedExpression + | ResolvedLet of ResolvedBinding * bool * ResolvedExpression * ResolvedExpression + | ResolvedLetRecursiveGroup of ResolvedRecursiveBinding list * ResolvedExpression + | ResolvedFail of ResolvedExpression + | ResolvedMatch of ResolvedExpression * ResolvedMatchCase list + | ResolvedRange of ResolvedExpression * ResolvedExpression + | ResolvedRecordUpdate of bool * ResolvedExpression * (string * ResolvedExpression) list + | ResolvedIndexGet of ResolvedExpression * ResolvedExpression + | ResolvedInterpolate of ResolvedInterpolationPart list + | ResolvedMap of ResolvedMapEntry list + | ResolvedForEach of ResolvedBinding * ResolvedExpression * ResolvedExpression + | ResolvedTypeToken of Type + + and ResolvedRecursiveBinding = + { Binding: ResolvedBinding + Value: ResolvedExpression } + + and ResolvedInterpolationPart = + | ResolvedTextPart of string + | ResolvedValuePart of ResolvedExpression + + and ResolvedMapEntry = + | ResolvedKeyValue of ResolvedExpression * ResolvedExpression + | ResolvedSpread of ResolvedExpression + + and ResolvedPattern = + { Type: Type + Span: Span + Node: ResolvedPatternNode } + + and ResolvedPatternNode = + | ResolvedWildcard + | ResolvedPatternBinding of ResolvedBinding + | ResolvedLiteralPattern of ResolvedLiteral + | ResolvedEmptyList + | ResolvedConsPattern of ResolvedPattern * ResolvedPattern + | ResolvedTuplePattern of ResolvedPattern list + | ResolvedRecordPattern of (string * ResolvedPattern) list + | ResolvedMapPattern of (ResolvedPattern * ResolvedPattern) list * ResolvedPattern option + | ResolvedSomePattern of ResolvedPattern + | ResolvedNonePattern + | ResolvedUnionPattern of string * string * ResolvedPattern option + | ResolvedTypePattern of Type + + and ResolvedMatchCase = + { Pattern: ResolvedPattern + Guard: ResolvedExpression option + Body: ResolvedExpression + Span: Span } + type private LocalVariableTypeCapture = { Name: string Span: Span @@ -220,16 +351,76 @@ module TypeInfer = | TSLet of string * Expr * Type * bool * bool * Span | TSLetPattern of Pattern * Expr * Map * bool * Span | TSLetRecGroup of (string * Expr * Type * Span) list * bool * Span + | TSBackendImport of string * Type * BackendImport * Span | TSExpr of TypedExpr type TypedProgram = TypedStmt list + type ResolvedBackendImport = + { ModulePath: string + MemberName: string + Span: Span } + + type ResolvedTypeDeclaration = + { Binding: ResolvedBinding + IsRecursive: bool + Definition: Type + Fields: (string * Type) list + Cases: (string * Type option) list + Import: ResolvedBackendImport option } + + type ResolvedValueDeclaration = + { Binding: ResolvedBinding + Scheme: Scheme + IsRecursive: bool + Value: ResolvedExpression } + + type ResolvedPatternDeclaration = + { Pattern: ResolvedPattern + Value: ResolvedExpression + Bindings: (ResolvedBinding * Scheme) list } + + type ResolvedImportedDeclaration = + { Binding: ResolvedBinding + Scheme: Scheme + Import: ResolvedBackendImport } + + type ResolvedStatementNode = + | ResolvedTypeDeclaration of ResolvedTypeDeclaration + | ResolvedValueDeclaration of ResolvedValueDeclaration + | ResolvedPatternDeclaration of ResolvedPatternDeclaration + | ResolvedRecursiveDeclarations of ResolvedValueDeclaration list + | ResolvedImportedDeclaration of ResolvedImportedDeclaration + | ResolvedExpressionStatement of ResolvedExpression + + type ResolvedStatement = + { Span: Span + Attributes: Attribute list + Export: ResolvedExport option + Node: ResolvedStatementNode + Patterns: ResolvedPattern list + Expressions: ResolvedExpression list } + + and ResolvedExport = + { Name: string + Span: Span } + + type ResolvedProgram = + { Purity: PurityContracts + TypedProgram: TypedProgram + ResolvedStatements: ResolvedStatement list + ExpressionTypes: ResolvedExpressionType list + Symbols: ResolvedSymbol list + SymbolReferences: ResolvedSymbolReference list } + type private InferenceTelemetry = { mutable ScopeStack: Set list - LocalVariableTypes: ResizeArray } + LocalVariableTypes: ResizeArray + ExpressionTypes: ResizeArray } let private createTelemetry () = { ScopeStack = [ Set.empty ] - LocalVariableTypes = ResizeArray() } + LocalVariableTypes = ResizeArray() + ExpressionTypes = ResizeArray() } let private capturedLocalVariableTypes (telemetry: InferenceTelemetry option) : LocalVariableTypeInfo list = match telemetry with @@ -295,6 +486,14 @@ module TypeInfer = let entry = t.LocalVariableTypes[i] entry.Type <- applyType subst entry.Type + let private applySubstToCapturedExpressions (telemetry: InferenceTelemetry option) (startIndex: int) (subst: Subst) = + match telemetry with + | Some t -> + for i = startIndex to t.ExpressionTypes.Count - 1 do + let item = t.ExpressionTypes.[i] + t.ExpressionTypes.[i] <- { item with Type = applyType subst item.Type } + | None -> () + let private currentTelemetryCaptureCount (telemetry: InferenceTelemetry option) = match telemetry with | Some t -> t.LocalVariableTypes.Count @@ -304,7 +503,16 @@ module TypeInfer = { UnionName: string Payload: Type option } - let private asTyped expr t = { Expr = expr; Type = t; Span = Ast.spanOfExpr expr } + let private asTyped (telemetry: InferenceTelemetry option) expr t : TypedExpr = + let span = Ast.spanOfExpr expr + match telemetry with + | Some capture -> + capture.ExpressionTypes.Add + { Expr = expr + Type = t + Span = span } + | None -> () + { Expr = expr; Type = t; Span = span } let private builtinType (name: string) : Type option = match name with @@ -649,16 +857,18 @@ module TypeInfer = loop t let rec private inferExpr (telemetry: InferenceTelemetry option) (typeDefs: Map) (constructors: Map) (env: Map) (expr: Expr) : Subst * Type * TypedExpr = + let expressionStart = match telemetry with Some t -> t.ExpressionTypes.Count | None -> 0 let subst, inferred, _ = inferExprRaw telemetry typeDefs constructors env expr let keySubst = constrainMapKeyTypes typeDefs (Ast.spanOfExpr expr) (applyType subst inferred) let combined = compose keySubst subst let resolved = applyType combined inferred - combined, resolved, asTyped expr resolved + applySubstToCapturedExpressions telemetry expressionStart combined + combined, resolved, { Expr = expr; Type = resolved; Span = Ast.spanOfExpr expr } and private inferExprRaw (telemetry: InferenceTelemetry option) (typeDefs: Map) (constructors: Map) (env: Map) (expr: Expr) : Subst * Type * TypedExpr = match expr with | EUnit _ -> - emptySubst, TUnit, asTyped expr TUnit + emptySubst, TUnit, asTyped telemetry expr TUnit | ELiteral (lit, _) -> let t = match lit with @@ -666,25 +876,25 @@ module TypeInfer = | LFloat _ -> TFloat | LBool _ -> TBool | LString _ -> TString - emptySubst, t, asTyped expr t + emptySubst, t, asTyped telemetry expr t | EVar (name, span) -> match env |> Map.tryFind name with | Some scheme -> let t = instantiate scheme recordLocalVariableUse telemetry name span t - emptySubst, t, asTyped expr t + emptySubst, t, asTyped telemetry expr t | None -> raise (TypeException { Message = sprintf "Unbound variable '%s'" name; Span = span }) | EParen (inner, _) -> let s, t, _ = inferExpr telemetry typeDefs constructors env inner - s, t, asTyped expr t + s, t, asTyped telemetry expr t | ETypeOf (name, span) -> if typeDefs.ContainsKey name then - emptySubst, TTypeToken, asTyped expr TTypeToken + emptySubst, TTypeToken, asTyped telemetry expr TTypeToken else raise (TypeException { Message = sprintf "Unknown type '%s'" name; Span = span }) | ENameOf (name, span) -> if env.ContainsKey name then - emptySubst, TString, asTyped expr TString + emptySubst, TString, asTyped telemetry expr TString else raise (TypeException { Message = sprintf "Unbound variable '%s'" name; Span = span }) | EInterpolatedString (parts, span) -> @@ -695,7 +905,7 @@ module TypeInfer = | IPExpr pexpr -> let s1, _, _ = inferExpr telemetry typeDefs constructors (applyEnv sAcc env) pexpr sAcc <- compose s1 sAcc - sAcc, TString, asTyped expr TString + sAcc, TString, asTyped telemetry expr TString | ELambda (param, body, _) -> let tv = match param.Annotation with @@ -708,7 +918,7 @@ module TypeInfer = inferExpr telemetry typeDefs constructors env' body) let tArg = applyType s1 tv let tFun = TFun (tArg, tBody) - s1, tFun, asTyped expr tFun + s1, tFun, asTyped telemetry expr tFun | EApply (fn, arg, span) -> let s1, t1, _ = inferExpr telemetry typeDefs constructors env fn let env2 = applyEnv s1 env @@ -719,7 +929,7 @@ module TypeInfer = let keySubst = constrainMapKeyTypes typeDefs span (applyType combined (TFun(t2, tv))) let s = compose keySubst combined let tRes = applyType s tv - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | EIf (cond, tExpr, fExpr, span) -> let s1, tCond, _ = inferExpr telemetry typeDefs constructors env cond let sBool = unify typeDefs tCond TBool span @@ -730,13 +940,13 @@ module TypeInfer = let s4 = unify typeDefs (applyType s3 tThen) tElse span let s = compose s4 (compose s3 (compose s2 (compose sBool s1))) let tRes = applyType s tElse - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | ERaise (value, span) -> let s1, t1, _ = inferExpr telemetry typeDefs constructors env value let s2 = unify typeDefs (applyType s1 t1) TString span let s = compose s2 s1 let tRes = Types.freshVar() - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | EFor (name, source, body, span) -> let s1, tSource, _ = inferExpr telemetry typeDefs constructors env source let tv = Types.freshVar() @@ -751,7 +961,7 @@ module TypeInfer = inferExpr telemetry typeDefs constructors envBody body) let sBodyUnit = unify typeDefs (applyType s2 tBody) TUnit (Ast.spanOfExpr body) let s = compose sBodyUnit (compose s2 sSource) - s, TUnit, asTyped expr TUnit + s, TUnit, asTyped telemetry expr TUnit | ELet (name, value, body, isRec, returnAnnotation, span) -> if isRec then let tv = Types.freshVar() @@ -775,7 +985,7 @@ module TypeInfer = withLocalBindings telemetry [ name ] (fun () -> inferExpr telemetry typeDefs constructors env2 body) let s = compose s3 sValue - s, tBody, asTyped expr tBody + s, tBody, asTyped telemetry expr tBody else let s1, t1, _ = inferExpr telemetry typeDefs constructors env value let sDiscard = @@ -798,7 +1008,7 @@ module TypeInfer = withLocalBindings telemetry [ name ] (fun () -> inferExpr telemetry typeDefs constructors env2 body) let s = compose s2 sValue - s, t2, asTyped expr t2 + s, t2, asTyped telemetry expr t2 | ELetPattern (pat, value, body, span) -> let startIndex = currentTelemetryCaptureCount telemetry let s1, tValue, _ = inferExpr telemetry typeDefs constructors env value @@ -818,7 +1028,7 @@ module TypeInfer = withLocalBindings telemetry boundNames (fun () -> inferExpr telemetry typeDefs constructors env2 body) let s = compose sBody sValue - s, tBody, asTyped expr tBody + s, tBody, asTyped telemetry expr tBody | ELetRecGroup (bindings, body, span) -> let foldedBindings = bindings @@ -871,7 +1081,7 @@ module TypeInfer = withLocalBindings telemetry recursiveNames (fun () -> inferExpr telemetry typeDefs constructors envBody body) let s = compose sBody sRec - s, tBody, asTyped expr tBody + s, tBody, asTyped telemetry expr tBody | EMatch (scrutinee, cases, span) -> let s1, tScrut, _ = inferExpr telemetry typeDefs constructors env scrutinee let mutable sAcc = s1 @@ -903,7 +1113,7 @@ module TypeInfer = Some (applyType sEq tPrev) sAcc <- compose sBody (compose sPat sAcc) let tRes = resultTypeOpt |> Option.defaultValue (Types.freshVar()) - sAcc, tRes, asTyped expr tRes + sAcc, tRes, asTyped telemetry expr tRes | EList (items, span) -> let tv = Types.freshVar() let mutable sAcc = emptySubst @@ -912,7 +1122,7 @@ module TypeInfer = let s2 = unify typeDefs (applyType s1 tv) t1 span sAcc <- compose s2 (compose s1 sAcc) let tRes = TList (applyType sAcc tv) - sAcc, tRes, asTyped expr tRes + sAcc, tRes, asTyped telemetry expr tRes | ERange (startExpr, endExpr, span) -> let s1, tStart, _ = inferExpr telemetry typeDefs constructors env startExpr let env2 = applyEnv s1 env @@ -921,7 +1131,7 @@ module TypeInfer = let s4 = unify typeDefs (applyType s3 (applyType s2 tEnd)) TInt span let s = compose s4 (compose s3 (compose s2 s1)) let tRes = TList TInt - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | ETuple (items, _) -> let mutable sAcc = emptySubst let mutable inferred : Type list = [] @@ -930,7 +1140,7 @@ module TypeInfer = sAcc <- compose s1 sAcc inferred <- inferred @ [ applyType sAcc t1 ] let tRes = TTuple inferred - sAcc, tRes, asTyped expr tRes + sAcc, tRes, asTyped telemetry expr tRes | ERecord (fields, span) -> let mutable sAcc = emptySubst let mutable inferred : Map = Map.empty @@ -943,7 +1153,7 @@ module TypeInfer = let sRecord = unify typeDefs (applyType sAcc (TRecord inferred)) expected span let s = compose sRecord sAcc let tRes = applyType s expected - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | EStructuralRecord (fields, _) -> let mutable sAcc = emptySubst let mutable inferred : Map = Map.empty @@ -952,7 +1162,7 @@ module TypeInfer = sAcc <- compose s1 sAcc inferred <- inferred.Add(name, applyType sAcc t1) let tRes = TRecord inferred - sAcc, tRes, asTyped expr tRes + sAcc, tRes, asTyped telemetry expr tRes | EMap (entries, span) -> let ensureSupportedMapKeyType = ensureSupportedMapKeyType typeDefs span @@ -983,7 +1193,7 @@ module TypeInfer = ensureSupportedMapKeyType (applyType sAcc keyType) let tRes = TMap (applyType sAcc keyType, applyType sAcc valueType) - sAcc, tRes, asTyped expr tRes + sAcc, tRes, asTyped telemetry expr tRes | ERecordUpdate (baseExpr, updates, span) -> let sInitial, tBase, _ = inferExpr telemetry typeDefs constructors env baseExpr let sBase = @@ -1013,7 +1223,7 @@ module TypeInfer = sAcc <- compose sEq (compose sField sAcc) let resultFields = baseFields |> Map.map (fun _ t -> applyType sAcc t) let tRes = TRecord resultFields - sAcc, tRes, asTyped expr tRes + sAcc, tRes, asTyped telemetry expr tRes | EStructuralRecordUpdate (baseExpr, updates, span) -> let sInitial, tBase, _ = inferExpr telemetry typeDefs constructors env baseExpr let sBase = @@ -1044,7 +1254,7 @@ module TypeInfer = sAcc <- compose sEq (compose sField sAcc) resultFields <- resultFields |> Map.add name (applyType sAcc tFieldApplied) let tRes = TRecord (resultFields |> Map.map (fun _ t -> applyType sAcc t)) - sAcc, tRes, asTyped expr tRes + sAcc, tRes, asTyped telemetry expr tRes | EFieldGet (target, fieldName, span) -> let inferRecordField s1 tTarget = match applyType s1 tTarget with @@ -1080,6 +1290,8 @@ module TypeInfer = | _ -> raise (TypeException { Message = "Field access requires a record value"; Span = span }) let rec qualifiedTarget = function + // Env combines runtime data with this reserved runtime operation. + | EVar ("Env", _) when fieldName="setExitCode" -> Some "Env" | EVar (name, _) when not (env.ContainsKey name) -> Some name | EFieldGet (parent, name, _) -> qualifiedTarget parent |> Option.map (fun prefix -> prefix + "." + name) | _ -> None @@ -1089,15 +1301,15 @@ module TypeInfer = match env.TryFind qualifiedName with | Some scheme -> let t = instantiate scheme - emptySubst, t, asTyped expr t + emptySubst, t, asTyped telemetry expr t | None -> let s1, tTarget, _ = inferExpr telemetry typeDefs constructors env target let sField, tField = inferRecordField s1 tTarget - sField, tField, asTyped expr tField + sField, tField, asTyped telemetry expr tField | _ -> let s1, tTarget, _ = inferExpr telemetry typeDefs constructors env target let sField, tField = inferRecordField s1 tTarget - sField, tField, asTyped expr tField + sField, tField, asTyped telemetry expr tField | EIndexGet (target, keyExpr, span) -> let s1, tTarget, _ = inferExpr telemetry typeDefs constructors env target let env2 = applyEnv s1 env @@ -1109,26 +1321,26 @@ module TypeInfer = let s3 = unify typeDefs keyType TInt span let s = compose s3 (compose s2 s1) let tRes = TOption (applyType s itemType) - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | TMap (mapKeyType, valueType), _ -> let s3 = unify typeDefs keyType mapKeyType span let s = compose s3 (compose s2 s1) ensureSupportedMapKeyType typeDefs span (applyType s mapKeyType) let tRes = TOption (applyType s valueType) - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | TVar _, TInt -> let itemType = Types.freshVar() let s3 = unify typeDefs targetType (TList itemType) span let s = compose s3 (compose s2 s1) let tRes = TOption (applyType s itemType) - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | TVar _, (TString | TBool | TNamed _) -> let valueType = Types.freshVar() ensureSupportedMapKeyType typeDefs span keyType let s3 = unify typeDefs targetType (TMap (keyType, valueType)) span let s = compose s3 (compose s2 s1) let tRes = TOption (applyType s valueType) - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | TVar _, TVar _ -> raise (TypeException { Message = "Ambiguous index access: annotate the list or map target"; Span = span }) | _ -> @@ -1151,7 +1363,7 @@ module TypeInfer = let keySubst = constrainMapKeyTypes typeDefs span (applyType combined (TFun(tLeft, tv))) let s = compose keySubst combined let tRes = applyType s tv - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | "::" -> let s1, tHead, _ = inferExpr telemetry typeDefs constructors env a let env2 = applyEnv s1 env @@ -1159,7 +1371,7 @@ module TypeInfer = let s3 = unify typeDefs (applyType s2 tTail) (TList tHead) span let s = compose s3 (compose s2 s1) let tRes = applyType s (TList tHead) - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | "@" -> let s1, t1, _ = inferExpr telemetry typeDefs constructors env a let env2 = applyEnv s1 env @@ -1169,7 +1381,7 @@ module TypeInfer = let s4 = unify typeDefs (applyType s3 (applyType s2 t2)) (TList (applyType s3 tv)) span let s = compose s4 (compose s3 (compose s2 s1)) let tRes = TList (applyType s tv) - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | _ -> let s1, t1, _ = inferExpr telemetry typeDefs constructors env a let env2 = applyEnv s1 env @@ -1188,13 +1400,13 @@ module TypeInfer = | "&&" | "||" -> unify typeDefs t TBool span, TBool | _ -> raise (TypeException { Message = sprintf "Unknown operator %s" op; Span = span }) let s = compose sOp (compose s3 (compose s2 s1)) - s, resultType, asTyped expr resultType + s, resultType, asTyped telemetry expr resultType | ESome (value, _) -> let s1, t1, _ = inferExpr telemetry typeDefs constructors env value - s1, TOption t1, asTyped expr (TOption t1) + s1, TOption t1, asTyped telemetry expr (TOption t1) | ENone _ -> let tv = Types.freshVar() - emptySubst, TOption tv, asTyped expr (TOption tv) + emptySubst, TOption tv, asTyped telemetry expr (TOption tv) | ECons (head, tail, span) -> let s1, t1, _ = inferExpr telemetry typeDefs constructors env head let env2 = applyEnv s1 env @@ -1202,7 +1414,7 @@ module TypeInfer = let s3 = unify typeDefs (applyType s2 t2) (TList t1) span let s = compose s3 (compose s2 s1) let tRes = applyType s (TList t1) - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes | EAppend (a, b, span) -> let s1, t1, _ = inferExpr telemetry typeDefs constructors env a let env2 = applyEnv s1 env @@ -1212,7 +1424,7 @@ module TypeInfer = let s4 = unify typeDefs (applyType s3 (applyType s2 t2)) (TList (applyType s3 tv)) span let s = compose s4 (compose s3 (compose s2 s1)) let tRes = TList (applyType s tv) - s, tRes, asTyped expr tRes + s, tRes, asTyped telemetry expr tRes let private envFromExterns (externs: ExternalFunction list) : Map = externs @@ -1244,18 +1456,29 @@ module TypeInfer = | None -> acc loop [] pat + let rec private unwrapStatementAttributes statement = + match statement with + | SAttributed(attributes, inner, _) -> + let nested, unwrapped = unwrapStatementAttributes inner + attributes @ nested, unwrapped + | value -> [], value + + let private unwrapProgramAttributes (program: Program) = + program |> List.map unwrapStatementAttributes |> List.unzip + let private topLevelBindingNames (program: Program) : string list = program - |> List.collect (function + |> List.collect (unwrapStatementAttributes >> snd >> function | SLet(name, _, _, _, _, _, _) -> [ name ] | SLetPattern(pat, _, _, _) -> patternBindingNames pat | SLetRecGroup(bindings, _, _) -> bindings |> List.map (fun (name, _, _, _, _) -> name) | _ -> []) - let private inferProgramWithExternsRawAndLocals (captureLocalVariables: bool) (registration: ExtensionRegistration) (program: Program) : TypedProgram * LocalVariableTypeInfo list = + let private inferProgramWithExternsRawAndLocals (captureTelemetry: bool) (registration: ExtensionRegistration) (program: Program) : TypedProgram * LocalVariableTypeInfo list * ResolvedExpressionType list = + let _, program = unwrapProgramAttributes program let externs = registration.Functions let hostDefinitions = - try HostInterop.typeDefinitions registration ((BuiltinTypes.typeDefs |> List.map (fun d -> d.Name)) @ (program |> List.choose (function SType d -> Some d.Name | _ -> None))) + try HostInterop.typeDefinitions registration (program |> List.choose (function SType d -> Some d.Name | _ -> None)) with EvalException error -> raise (TypeException { Message = error.Message; Span = error.Span }) let decls = (BuiltinTypes.typeDefs |> List.map (fun d -> d.Name, d)) @@ -1311,17 +1534,30 @@ module TypeInfer = ||> List.fold (fun acc (name, scheme) -> acc.Add(name, scheme)) let telemetry = - if captureLocalVariables then Some(createTelemetry ()) + if captureTelemetry then Some(createTelemetry ()) else None let typed = ResizeArray() try for i, stmt in program |> List.indexed do + let expressionStartIndex = + match telemetry with + | Some t -> t.ExpressionTypes.Count + | None -> 0 match stmt with | SType def -> typed.Add(TSType def) | SImport (_, _, span) -> raise (TypeException { Message = "'import' must be resolved before type inference"; Span = span }) + | SAttributed(_, _, span) -> + raise (TypeException { Message = "Attributed statements must be normalized before type inference"; Span = span }) + | SBackendImport(name, signature, import, span) -> + let importedType = annotationTypeFromRef typeDefs span signature + match importedType with + | TFun _ -> + env <- Map.add name (Forall([], importedType)) env + typed.Add(TSBackendImport(name, importedType, import, span)) + | _ -> raise (TypeException { Message = "Backend imports require a complete function signature"; Span = span }) | SLet(name, args, returnAnnotation, expr, isRec, isExported, span) -> let exprVal = Seq.foldBack (fun arg acc -> ELambda(arg, acc, span)) args expr let startIndex = @@ -1343,6 +1579,7 @@ module TypeInfer = | None -> emptySubst let s = compose sRet (compose s2 s1) applySubstToCapturedLocals telemetry startIndex s + applySubstToCapturedExpressions telemetry expressionStartIndex s let env' = applyEnv s env let inferred = applyType s t1 validateMapKeyTypes typeDefs span inferred @@ -1360,6 +1597,7 @@ module TypeInfer = | None -> emptySubst let s = compose sRet s1 applySubstToCapturedLocals telemetry startIndex s + applySubstToCapturedExpressions telemetry expressionStartIndex s let env' = applyEnv s env let inferred = applyType s t1 validateMapKeyTypes typeDefs span inferred @@ -1377,6 +1615,7 @@ module TypeInfer = let s2 = unify typeDefs (applyType s1 tValue) tPat span let s = compose s2 s1 applySubstToCapturedLocals telemetry startIndex s + applySubstToCapturedExpressions telemetry expressionStartIndex s let envBase = applyEnv s env let typedBindings = envPat |> Map.map (fun _ ty -> applyType s ty) typedBindings @@ -1428,6 +1667,7 @@ module TypeInfer = | None -> () applySubstToCapturedLocals telemetry startIndex sRec + applySubstToCapturedExpressions telemetry expressionStartIndex sRec let envGeneralize = applyEnv sRec env let schemes = @@ -1460,18 +1700,24 @@ module TypeInfer = emptySubst let s = compose sDiscard s1 applySubstToCapturedLocals telemetry startIndex s + applySubstToCapturedExpressions telemetry expressionStartIndex s validateMapKeyTypes typeDefs (Ast.spanOfExpr expr) (applyType s t1) env <- applyEnv s env typed.Add(TSExpr typedExpr) - typed |> Seq.toList, capturedLocalVariableTypes telemetry + let expressionTypes = + match telemetry with + | Some value -> value.ExpressionTypes |> Seq.toList + | None -> [] + typed |> Seq.toList, capturedLocalVariableTypes telemetry, expressionTypes with _ -> reraise () let inferProgramWithExternsRaw (externs: ExternalFunction list) (program: Program) : TypedProgram = - inferProgramWithExternsRawAndLocals false (HostInterop.ofExterns externs) program |> fst + let typed, _, _ = inferProgramWithExternsRawAndLocals false (HostInterop.ofExterns externs) program + typed - let inferProgramWithExterns (externs: ExternalFunction list) (program: Program) : TypedProgram = + let private validateProgramBindings (externs: ExternalFunction list) (program: Program) = let reserved = BuiltinSignatures.builtinReservedNames externs @@ -1484,22 +1730,581 @@ module TypeInfer = |> Option.iter (fun name -> raise (TypeException { Message = $"Top-level binding '{name}' collides with reserved stdlib symbol"; Span = unknownSpan })) - inferProgramWithExternsRaw externs program - let inferProgramWithExternsAndLocalVariableTypes (externs: ExternalFunction list) (program: Program) : TypedProgram * LocalVariableTypeInfo list = - let reserved = BuiltinSignatures.builtinReservedNames - - externs - |> List.tryFind (fun ext -> Set.contains ext.Name reserved) - |> Option.iter (fun ext -> - raise (TypeException { Message = $"Host extern '{ext.Name}' collides with reserved stdlib symbol"; Span = unknownSpan })) + validateProgramBindings externs program + let typed, locals, _ = inferProgramWithExternsRawAndLocals true (HostInterop.ofExterns externs) program + typed, locals - topLevelBindingNames program - |> List.tryFind (fun name -> Set.contains name reserved) - |> Option.iter (fun name -> - raise (TypeException { Message = $"Top-level binding '{name}' collides with reserved stdlib symbol"; Span = unknownSpan })) - - inferProgramWithExternsRawAndLocals true (HostInterop.ofExterns externs) program + let inferResolvedProgramWithRegistration (registration: ExtensionRegistration) (program: Program) : ResolvedProgram = + let externs = registration.Functions + validateProgramBindings externs program + let statementAttributes, semanticProgram = unwrapProgramAttributes program + let typed, _, expressions = inferProgramWithExternsRawAndLocals true registration semanticProgram + let expressionTypes = expressions |> List.fold (fun state item -> Map.add item.Expr item.Type state) Map.empty + let mutable nextSymbol = 0 + let symbols = ResizeArray() + let references = ResizeArray() + let patternBindingIds = ResizeArray() + let normalizeScheme (Forall(variables, schemeType)) = + let mapping = variables |> List.mapi (fun index variable -> variable, index) |> Map.ofList + let rec normalize = function + | TVar variable -> TVar(mapping |> Map.tryFind variable |> Option.defaultValue variable) + | TNumeric variable -> TVar(mapping |> Map.tryFind variable |> Option.defaultValue variable) + | TRecordShape(id, fields, constructible) -> TRecordShape(mapping |> Map.tryFind id |> Option.defaultValue id, Map.map (fun _ -> normalize) fields, constructible) + | TList item -> TList(normalize item) | TTask item -> TTask(normalize item) | TOption item -> TOption(normalize item) + | TTuple items -> TTuple(List.map normalize items) + | TRecord fields -> TRecord(Map.map (fun _ value -> normalize value) fields) + | TMap(key, value) -> TMap(normalize key, normalize value) + | TFun(argument, result) -> TFun(normalize argument, normalize result) + | TUnion(name, cases) -> TUnion(name, Map.map (fun _ payload -> Option.map normalize payload) cases) + | value -> value + Forall([ 0 .. variables.Length - 1 ], normalize schemeType) + let normalizeTypeVariables value = + let mutable next = 0 + let mutable mapping = Map.empty + let rec normalize = function + | TVar variable | TNumeric variable -> + match Map.tryFind variable mapping with + | Some normalized -> TVar normalized + | None -> + let normalized = next + next <- next + 1 + mapping <- Map.add variable normalized mapping + TVar normalized + | TRecordShape(id, fields, constructible) -> + let witness = match normalize (TVar id) with TVar value -> value | _ -> id + TRecordShape(witness, Map.map (fun _ -> normalize) fields, constructible) + | TList item -> TList(normalize item) | TTask item -> TTask(normalize item) | TOption item -> TOption(normalize item) + | TTuple items -> TTuple(List.map normalize items) + | TRecord fields -> TRecord(Map.map (fun _ item -> normalize item) fields) + | TMap(key, item) -> TMap(normalize key, normalize item) + | TFun(argument, result) -> TFun(normalize argument, normalize result) + | TUnion(name, cases) -> TUnion(name, Map.map (fun _ payload -> Option.map normalize payload) cases) + | item -> item + normalize value + let allocate name kind span scheme = + let id = nextSymbol + nextSymbol <- nextSymbol + 1 + symbols.Add { SymbolId = id; Name = name; Kind = kind; Span = span; Scheme = Option.map normalizeScheme scheme } + id + let syntheticSpan = Span.mk (Span.pos 0 0) (Span.pos 0 0) + let mutable globalEnvironment = Map.empty + for name, scheme in BuiltinSignatures.builtinSchemes |> Map.toList |> List.sortBy fst do + globalEnvironment <- Map.add name (allocate name BuiltinSymbol syntheticSpan (Some scheme)) globalEnvironment + for external in externs |> List.sortBy _.Name do + globalEnvironment <- Map.add external.Name (allocate external.Name ExternSymbol syntheticSpan (Some external.Scheme)) globalEnvironment + for definition in BuiltinTypes.typeDefs do + globalEnvironment <- Map.add definition.Name (allocate definition.Name TypeSymbol definition.Span None) globalEnvironment + for caseName, _ in definition.Cases do + let id = allocate $"{definition.Name}.{caseName}" UnionCaseSymbol definition.Span None + globalEnvironment <- globalEnvironment |> Map.add caseName id |> Map.add $"{definition.Name}.{caseName}" id + let hostDefinitions = HostInterop.typeDefinitions registration [] + for name, definition in hostDefinitions |> Map.toList do + globalEnvironment <- Map.add name (allocate name TypeSymbol syntheticSpan None) globalEnvironment + match definition with + | TUnion(_, cases) -> + for caseName, _ in cases |> Map.toList do + let id = allocate $"{name}.{caseName}" UnionCaseSymbol syntheticSpan None + globalEnvironment <- globalEnvironment |> Map.add caseName id |> Map.add $"{name}.{caseName}" id + | _ -> () + let builtinEnvironment = globalEnvironment + for statement in typed do + match statement with + | TSType definition -> + globalEnvironment <- Map.add definition.Name (allocate definition.Name TypeSymbol definition.Span None) globalEnvironment + for caseName, _ in definition.Cases do + let id = allocate $"{definition.Name}.{caseName}" UnionCaseSymbol definition.Span None + globalEnvironment <- globalEnvironment |> Map.add caseName id |> Map.add $"{definition.Name}.{caseName}" id + | TSLet(name, _, inferred, _, _, span) -> + globalEnvironment <- Map.add name (allocate name DeclarationSymbol span (Some(Types.generalize Map.empty inferred))) globalEnvironment + | TSLetPattern(_, _, bindings, _, span) -> + for name, inferred in bindings |> Map.toList do + globalEnvironment <- Map.add name (allocate name DeclarationSymbol span (Some(Types.generalize Map.empty inferred))) globalEnvironment + | TSLetRecGroup(bindings, _, _) -> + for name, _, inferred, span in bindings do + globalEnvironment <- Map.add name (allocate name DeclarationSymbol span (Some(Types.generalize Map.empty inferred))) globalEnvironment + | TSBackendImport(name, importedType, _, span) -> + globalEnvironment <- Map.add name (allocate name DeclarationSymbol span (Some(Forall([], importedType)))) globalEnvironment + | TSExpr _ -> () + let recordReference environment name expression span = + environment |> Map.tryFind name |> Option.iter (fun id -> + let symbol = symbols |> Seq.find (fun symbol -> symbol.SymbolId = id) + references.Add + { SymbolId = id + Name = name + Kind = symbol.Kind + Type = expressionTypes |> Map.tryFind expression |> Option.defaultValue TUnit |> normalizeTypeVariables + Span = span }) + let bindPattern kind environment pattern = + let rec bind bindings current pattern = + match pattern with + | PVar(name, span) -> + match Map.tryFind name bindings with + | Some id -> + patternBindingIds.Add(span, id) + bindings, Map.add name id current + | None -> + let id = allocate name kind span None + patternBindingIds.Add(span, id) + Map.add name id bindings, Map.add name id current + | PCons(head, tail, _) -> + let bindings, current = bind bindings current head + bind bindings current tail + | PTuple(items, _) -> items |> List.fold (fun (bindings, current) item -> bind bindings current item) (bindings, current) + | PRecord(fields, _) -> fields |> List.fold (fun (bindings, current) (_, item) -> bind bindings current item) (bindings, current) + | PMap(clauses, tail, _) -> + let bindings, current = + clauses + |> List.fold (fun (bindings, current) (key, value) -> + let bindings, current = bind bindings current key + bind bindings current value) (bindings, current) + tail |> Option.map (bind bindings current) |> Option.defaultValue (bindings, current) + | PSome(item, _) -> bind bindings current item + | PUnionCase(_, _, payload, _) -> payload |> Option.map (bind bindings current) |> Option.defaultValue (bindings, current) + | _ -> bindings, current + bind Map.empty environment pattern |> snd + let rec visit environment expression = + let visitSame item = visit environment item + match expression with + | EVar(name, span) -> recordReference environment name expression span + | ENameOf(name, span) -> recordReference environment name expression span + | ETypeOf(name, span) -> recordReference environment name expression span + | ELambda(parameter, body, _) -> + let id = allocate parameter.Name ParameterSymbol parameter.Span None + visit (Map.add parameter.Name id environment) body + | EApply(fn, argument, _) | EBinOp(_, fn, argument, _) | EAppend(fn, argument, _) | ECons(fn, argument, _) | EIndexGet(fn, argument, _) -> visitSame fn; visitSame argument + | EIf(condition, whenTrue, whenFalse, _) -> visitSame condition; visitSame whenTrue; visitSame whenFalse + | ELet(name, binding, body, recursive, _, span) -> + let id = allocate name LocalSymbol span None + visit (if recursive then Map.add name id environment else environment) binding + visit (Map.add name id environment) body + | ELetPattern(pattern, binding, body, _) -> visitSame binding; visit (bindPattern PatternBindingSymbol environment pattern) body + | ELetRecGroup(bindings, body, _) -> + let recursiveEnvironment = bindings |> List.fold (fun env (name, _, _, _, span) -> Map.add name (allocate name LocalSymbol span None) env) environment + for _, parameters, _, value, span in bindings do + let folded = Seq.foldBack (fun parameter inner -> ELambda(parameter, inner, span)) parameters value + visit recursiveEnvironment folded + visit recursiveEnvironment body + | EMatch(target, cases, _) -> + visitSame target + for pattern, guard, body, _ in cases do + let caseEnvironment = bindPattern PatternBindingSymbol environment pattern + Option.iter (visit caseEnvironment) guard + visit caseEnvironment body + | EFor(name, source, body, span) -> + visitSame source + let id = allocate name LocalSymbol span None + visit (Map.add name id environment) body + | EList(items, _) | ETuple(items, _) -> List.iter visitSame items + | ERecord(fields, _) | EStructuralRecord(fields, _) -> fields |> List.iter (snd >> visitSame) + | EMap(entries, _) -> entries |> List.iter (function MEKeyValue(key, value) -> visitSame key; visitSame value | MESpread value -> visitSame value) + | ERecordUpdate(target, fields, _) | EStructuralRecordUpdate(target, fields, _) -> visitSame target; fields |> List.iter (snd >> visitSame) + | EFieldGet(EVar(moduleName, _), fieldName, span) when Map.containsKey $"{moduleName}.{fieldName}" environment -> recordReference environment $"{moduleName}.{fieldName}" expression span + | EFieldGet(target, _, _) -> visitSame target + | ESome(item, _) | EParen(item, _) | ERaise(item, _) -> visitSame item + | ERange(first, last, _) -> visitSame first; visitSame last + | EInterpolatedString(parts, _) -> parts |> List.iter (function IPText _ -> () | IPExpr item -> visitSame item) + | EUnit _ | ELiteral _ | ENone _ -> () + let allocated kind name span = + symbols + |> Seq.find (fun symbol -> symbol.Kind = kind && symbol.Name = name && symbol.Span = span) + |> _.SymbolId + let mutable resolutionEnvironment = builtinEnvironment + for statement in typed do + match statement with + | TSType definition -> + resolutionEnvironment <- Map.add definition.Name (allocated TypeSymbol definition.Name definition.Span) resolutionEnvironment + for caseName, _ in definition.Cases do + let id = allocated UnionCaseSymbol $"{definition.Name}.{caseName}" definition.Span + resolutionEnvironment <- resolutionEnvironment |> Map.add caseName id |> Map.add $"{definition.Name}.{caseName}" id + | TSLet(name, expression, _, recursive, _, span) -> + let id = allocated DeclarationSymbol name span + visit (if recursive then Map.add name id resolutionEnvironment else resolutionEnvironment) expression + resolutionEnvironment <- Map.add name id resolutionEnvironment + | TSLetPattern(pattern, expression, bindings, _, span) -> + visit resolutionEnvironment expression + bindPattern PatternBindingSymbol resolutionEnvironment pattern |> ignore + for name, _ in bindings |> Map.toList do + resolutionEnvironment <- Map.add name (allocated DeclarationSymbol name span) resolutionEnvironment + | TSLetRecGroup(bindings, _, _) -> + let recursiveEnvironment = + bindings + |> List.fold (fun environment (name, _, _, span) -> + Map.add name (allocated DeclarationSymbol name span) environment) resolutionEnvironment + bindings |> List.iter (fun (_, expression, _, _) -> visit recursiveEnvironment expression) + resolutionEnvironment <- recursiveEnvironment + | TSExpr expression -> visit resolutionEnvironment expression.Expr + | TSBackendImport(name, _, _, span) -> + resolutionEnvironment <- Map.add name (allocated DeclarationSymbol name span) resolutionEnvironment + let resolvedReferences = references |> Seq.toList + let mutable remainingReferenceOccurrences = resolvedReferences + let finalType expression = expressionTypes |> Map.tryFind expression |> Option.defaultValue TUnit |> normalizeTypeVariables + let declarations = + (BuiltinTypes.typeDefs |> List.map (fun definition -> definition.Name, definition)) + @ (typed |> List.choose (function TSType definition -> Some(definition.Name, definition) | _ -> None)) + |> Map.ofList + let resolvedTypeDefinitions = + declarations + |> Map.map (fun name definition -> + if definition.Cases.IsEmpty then + definition.Fields + |> List.map (fun (fieldName, fieldType) -> fieldName, typeFromRef declarations [ name ] fieldType) + |> Map.ofList + |> TRecord + else + definition.Cases + |> List.map (fun (caseName, payload) -> caseName, Option.map (typeFromRef declarations [ name ]) payload) + |> Map.ofList + |> fun cases -> TUnion(name, cases)) + |> fun definitions -> Map.fold (fun state name definition -> Map.add name definition state) definitions hostDefinitions + let resolvedLiteral = function + | LInt value -> ResolvedInt value + | LFloat value -> ResolvedFloat value + | LBool value -> ResolvedBool value + | LString value -> ResolvedString value + let symbolAt kind name span = + symbols + |> Seq.find (fun symbol -> symbol.Kind = kind && symbol.Name = name && symbol.Span = span) + let bindingAt kind name span bindingType = + let id = + if kind = PatternBindingSymbol then + patternBindingIds + |> Seq.tryFind (fst >> (=) span) + |> Option.map snd + |> Option.defaultWith (fun () -> (symbolAt kind name span).SymbolId) + else + (symbolAt kind name span).SymbolId + { SymbolId = id; Name = name; Type = bindingType; Span = span } + let referenceAt expression = + let span = Ast.spanOfExpr expression + let expectedName = + match expression with + | EVar(name, _) | ENameOf(name, _) | ETypeOf(name, _) -> Some name + | EFieldGet(EVar(moduleName, _), fieldName, _) -> Some $"{moduleName}.{fieldName}" + | _ -> None + let matches (item: ResolvedSymbolReference) = + item.Span = span && expectedName |> Option.forall ((=) item.Name) + let rec consume preceding = function + | [] -> None + | item :: tail when matches item -> + remainingReferenceOccurrences <- List.rev preceding @ tail + Some item + | item :: tail -> consume (item :: preceding) tail + consume [] remainingReferenceOccurrences + let rec resolvePattern (expected: Type) (pattern: Pattern) : ResolvedPattern = + let span = Ast.spanOfPattern pattern + let make node : ResolvedPattern = { Type = expected; Span = span; Node = node } + match pattern with + | PWildcard _ -> make ResolvedWildcard + | PVar(name, _) -> make (ResolvedPatternBinding(bindingAt PatternBindingSymbol name span expected)) + | PLiteral(value, _) -> make (ResolvedLiteralPattern(resolvedLiteral value)) + | PNil _ -> make ResolvedEmptyList + | PCons(head, tail, _) -> + let itemType = match expected with TList item -> item | _ -> Types.freshVar() + make (ResolvedConsPattern(resolvePattern itemType head, resolvePattern expected tail)) + | PTuple(items, _) -> + let itemTypes = match expected with TTuple types when types.Length = items.Length -> types | _ -> List.replicate items.Length (Types.freshVar()) + make (ResolvedTuplePattern(List.map2 resolvePattern itemTypes items)) + | PRecord(fields, _) -> + let fieldTypes = + match expected with + | TRecord values | THostManaged(_,values) -> values + | TNamed name -> match Map.tryFind name resolvedTypeDefinitions with Some(TRecord values) | Some(THostManaged(_,values)) -> values | _ -> Map.empty + | _ -> Map.empty + fields + |> List.map (fun (name, item) -> name, resolvePattern (fieldTypes |> Map.tryFind name |> Option.defaultValue (Types.freshVar())) item) + |> ResolvedRecordPattern + |> make + | PMap(clauses, tail, _) -> + let keyType, valueType = match expected with TMap(key, value) -> key, value | _ -> Types.freshVar(), Types.freshVar() + let resolvedClauses = clauses |> List.map (fun (key, value) -> resolvePattern keyType key, resolvePattern valueType value) + make (ResolvedMapPattern(resolvedClauses, Option.map (resolvePattern expected) tail)) + | PSome(item, _) -> + let itemType = match expected with TOption value -> value | _ -> Types.freshVar() + make (ResolvedSomePattern(resolvePattern itemType item)) + | PNone _ -> make ResolvedNonePattern + | PUnionCase(qualifier, caseName, payload, _) -> + let unionName, payloadType = + match expected with + | TNamed name -> + match Map.tryFind name resolvedTypeDefinitions with + | Some(TUnion(_, cases)) -> name, cases |> Map.tryFind caseName |> Option.flatten + | _ -> qualifier |> Option.defaultValue name, None + | TUnion(name, cases) -> name, cases |> Map.tryFind caseName |> Option.flatten + | _ -> + resolvedTypeDefinitions + |> Map.toSeq + |> Seq.tryPick (fun (name, definition) -> + match definition with + | TUnion(_, cases) when Map.containsKey caseName cases -> Some(name, cases.[caseName]) + | _ -> None) + |> Option.defaultValue (qualifier |> Option.defaultValue "", None) + make (ResolvedUnionPattern(unionName, caseName, Option.map (resolvePattern (payloadType |> Option.defaultValue (Types.freshVar()))) payload)) + | PTypeRef(typeRef, _) -> make (ResolvedTypePattern(annotationTypeFromRef resolvedTypeDefinitions span typeRef)) + let rec resolveExpression (expression: Expr) : ResolvedExpression = + let expressionType = finalType expression + let reference = referenceAt expression + let primitive = + match expression with + | EBinOp(op, left, _, _) -> + match op, expressionType with + | "+", TFloat -> Some FloatingAddition | "+", TInt -> Some IntegerAddition | "+", _ -> Some NumericAddition + | "-", TFloat -> Some FloatingSubtraction | "-", TInt -> Some IntegerSubtraction | "-", _ -> Some NumericSubtraction + | "*", TFloat -> Some FloatingMultiplication | "*", TInt -> Some IntegerMultiplication | "*", _ -> Some NumericMultiplication + | "/", TFloat -> Some FloatingDivision | "/", TInt -> Some IntegerDivision | "/", _ -> Some NumericDivision + | "%", TInt -> Some IntegerRemainder | "=", _ -> Some StructuralEquality + | ("<" | ">" | "<=" | ">="), _ -> Some(NumericComparison op) + | ("&&" | "||"), _ -> Some(BooleanOperation op) + | _ -> None + | _ -> None + let node : ResolvedExpressionNode = + match expression with + | EUnit _ -> ResolvedConstant ResolvedUnit + | ELiteral(value, _) -> ResolvedConstant(resolvedLiteral value) + | EVar _ -> ResolvedReference(Option.get reference) + | EParen(inner, _) -> (resolveExpression inner).Node + | ELambda(parameter, body, _) -> + let parameterType = match expressionType with TFun(argument, _) -> argument | _ -> Types.freshVar() + ResolvedLambda(bindingAt ParameterSymbol parameter.Name parameter.Span parameterType, resolveExpression body) + | EApply(fn, argument, _) -> ResolvedApply(resolveExpression fn, resolveExpression argument) + | EIf(condition, whenTrue, whenFalse, _) -> ResolvedIf(resolveExpression condition, resolveExpression whenTrue, resolveExpression whenFalse) + | EBinOp("|>", left, right, _) -> ResolvedPipe(resolveExpression left, resolveExpression right) + | EBinOp("::", head, tail, _) -> ResolvedCons(resolveExpression head, resolveExpression tail) + | EBinOp("@", left, right, _) | EAppend(left, right, _) -> ResolvedAppend(resolveExpression left, resolveExpression right) + | EBinOp(_, left, right, _) -> ResolvedPrimitive(Option.get primitive, [ resolveExpression left; resolveExpression right ]) + | ECons(head, tail, _) -> ResolvedCons(resolveExpression head, resolveExpression tail) + | ETuple(items, _) -> ResolvedTuple(List.map resolveExpression items) + | EList(items, _) -> ResolvedList(List.map resolveExpression items) + | ERecord(fields, _) | EStructuralRecord(fields, _) -> ResolvedRecord(fields |> List.map (fun (name, value) -> name, resolveExpression value)) + | EFieldGet(_, _, _) when reference.IsSome -> ResolvedReference(Option.get reference) + | EFieldGet(target, name, _) -> ResolvedFieldGet(resolveExpression target, name) + | ESome(item, _) -> ResolvedSome(resolveExpression item) + | ENone _ -> ResolvedNone + | ELet(name, value, body, recursive, _, span) -> + let valueType = finalType value + ResolvedLet(bindingAt LocalSymbol name span valueType, recursive, resolveExpression value, resolveExpression body) + | ELetPattern(pattern, value, body, _) -> + let resolvedValue = resolveExpression value + ResolvedMatch(resolvedValue, [ { Pattern = resolvePattern resolvedValue.Type pattern; Guard = None; Body = resolveExpression body; Span = Ast.spanOfPattern pattern } ]) + | ELetRecGroup(bindings, body, _) -> + let values = + bindings |> List.map (fun (name, parameters, _, value, span) -> + let folded = Seq.foldBack (fun parameter inner -> ELambda(parameter, inner, span)) parameters value + let resolvedValue = resolveExpression folded + { Binding = bindingAt LocalSymbol name span resolvedValue.Type; Value = resolvedValue }) + ResolvedLetRecursiveGroup(values, resolveExpression body) + | ERaise(value, _) -> ResolvedFail(resolveExpression value) + | EFor(name, source, body, span) -> + let resolvedSource = resolveExpression source + let itemType = match resolvedSource.Type with TList item -> item | _ -> Types.freshVar() + ResolvedForEach(bindingAt LocalSymbol name span itemType, resolvedSource, resolveExpression body) + | EMatch(target, cases, _) -> + let resolvedTarget = resolveExpression target + let resolvedCases = + cases |> List.map (fun (pattern, guard, body, caseSpan) -> + { Pattern = resolvePattern resolvedTarget.Type pattern + Guard = Option.map resolveExpression guard + Body = resolveExpression body + Span = caseSpan }) + ResolvedMatch(resolvedTarget, resolvedCases) + | ERange(first, last, _) -> ResolvedRange(resolveExpression first, resolveExpression last) + | ERecordUpdate(target, fields, _) -> + ResolvedRecordUpdate(true, resolveExpression target, fields |> List.map (fun (name, value) -> name, resolveExpression value)) + | EStructuralRecordUpdate(target, fields, _) -> + ResolvedRecordUpdate(false, resolveExpression target, fields |> List.map (fun (name, value) -> name, resolveExpression value)) + | EIndexGet(target, index, _) -> ResolvedIndexGet(resolveExpression target, resolveExpression index) + | ENameOf(name, _) -> ResolvedConstant(ResolvedString name) + | ETypeOf(name, _) -> ResolvedTypeToken(Map.find name resolvedTypeDefinitions) + | EInterpolatedString(parts, _) -> + parts + |> List.map (function IPText text -> ResolvedTextPart text | IPExpr item -> ResolvedValuePart(resolveExpression item)) + |> ResolvedInterpolate + | EMap(entries, _) -> + entries + |> List.map (function MEKeyValue(key, value) -> ResolvedKeyValue(resolveExpression key, resolveExpression value) | MESpread value -> ResolvedSpread(resolveExpression value)) + |> ResolvedMap + let children = + match node with + | ResolvedLambda(_, body) | ResolvedSome body | ResolvedFail body -> [ body ] + | ResolvedApply(left, right) | ResolvedPipe(left, right) | ResolvedCons(left, right) | ResolvedAppend(left, right) + | ResolvedRange(left, right) | ResolvedIndexGet(left, right) -> [ left; right ] + | ResolvedIf(condition, whenTrue, whenFalse) -> [ condition; whenTrue; whenFalse ] + | ResolvedPrimitive(_, values) | ResolvedTuple values | ResolvedList values -> values + | ResolvedRecord fields -> List.map snd fields + | ResolvedFieldGet(target, _) -> [ target ] + | ResolvedLet(_, _, value, body) -> [ value; body ] + | ResolvedLetRecursiveGroup(bindings, body) -> (bindings |> List.map _.Value) @ [ body ] + | ResolvedMatch(target, cases) -> target :: (cases |> List.collect (fun case -> Option.toList case.Guard @ [ case.Body ])) + | ResolvedRecordUpdate(_, target, fields) -> target :: List.map snd fields + | ResolvedInterpolate parts -> parts |> List.choose (function ResolvedTextPart _ -> None | ResolvedValuePart value -> Some value) + | ResolvedMap entries -> entries |> List.collect (function ResolvedKeyValue(key, value) -> [ key; value ] | ResolvedSpread value -> [ value ]) + | ResolvedForEach(_, source, body) -> [ source; body ] + | ResolvedConstant _ | ResolvedReference _ | ResolvedNone | ResolvedTypeToken _ -> [] + let coercion = + let recordShape = function + | TRecord fields -> Some fields + | TNamed name -> + match Map.tryFind name resolvedTypeDefinitions with + | Some(TRecord fields) -> Some fields + | _ -> None + | _ -> None + let conversion targetType sourceType = + match recordShape targetType, recordShape sourceType with + | Some targetFields, Some sourceFields + when targetType <> sourceType + && targetFields + |> Map.forall (fun name targetField -> + sourceFields |> Map.tryFind name |> Option.exists ((=) targetField)) -> + Some + { SourceType = sourceType + TargetType = targetType + TargetName = match targetType with TNamed name -> Some name | _ -> None } + | _ -> None + let callParameter (fn: ResolvedExpression) = + let inferred = match fn.Type with TFun(argument, _) -> Some argument | _ -> None + match fn.Node with + | ResolvedReference reference -> + symbols |> Seq.tryFind (fun symbol -> symbol.SymbolId = reference.SymbolId) + |> Option.bind _.Scheme + |> Option.bind (fun (Forall(_, signature)) -> + match signature with TFun(TRecord fields, _) -> Some(TRecord fields) | _ -> None) + |> Option.orElse inferred + | _ -> inferred + match node with + | ResolvedApply(fn, argument) -> + callParameter fn |> Option.bind (fun targetType -> conversion targetType argument.Type) + | ResolvedPipe(argument, fn) -> + callParameter fn |> Option.bind (fun targetType -> conversion targetType argument.Type) + | _ -> None + { Type = expressionType; Span = Ast.spanOfExpr expression; Reference = reference + Primitive = primitive; RecordCoercion = coercion; Node = node; Children = children } + let resolvedStatements = + (statementAttributes, typed) ||> List.map2 (fun declaredAttributes statement -> + let roots = + match statement with + | TSLet(_, expression, _, _, _, _) | TSLetPattern(_, expression, _, _, _) -> [ expression ] + | TSLetRecGroup(bindings, _, _) -> bindings |> List.map (fun (_, expression, _, _) -> expression) + | TSExpr expression -> [ expression.Expr ] + | TSBackendImport _ | TSType _ -> [] + let export = + match statement with + | TSLet(name, _, _, _, true, span) -> Some { Name = name; Span = span } + | TSLetPattern(_, _, _, true, span) -> Some { Name = ""; Span = span } + | TSLetRecGroup(bindings, true, span) -> Some { Name = bindings |> List.map (fun (name, _, _, _) -> name) |> String.concat ","; Span = span } + | _ -> None + let attributes = + match statement with + | TSLet(_, _, _, _, true, span) | TSLetPattern(_, _, _, true, span) | TSLetRecGroup(_, true, span) -> + [ { Name = "Export"; Arguments = []; Span = span } ] + | TSBackendImport(_, _, import, _) -> + [ { Name = "Import"; Arguments = [ import.ModulePath; import.MemberName ]; Span = import.Span } ] + | TSType definition -> + definition.Import + |> Option.map (fun import -> [ { Name = "Import"; Arguments = [ import.ModulePath; import.MemberName ]; Span = import.Span } ]) + |> Option.defaultValue [] + | _ -> [] + let patterns = + match statement with + | TSLetPattern(pattern, expression, _, _, _) -> [ resolvePattern (finalType expression) pattern ] + | _ -> [] + let resolvedRoots = List.map resolveExpression roots + let declarationBinding name span bindingType = bindingAt DeclarationSymbol name span bindingType + let declarationScheme name span fallback = + (symbolAt DeclarationSymbol name span).Scheme |> Option.defaultValue fallback + let importMetadata (import: BackendImport) : ResolvedBackendImport = + { ModulePath = import.ModulePath; MemberName = import.MemberName; Span = import.Span } + let node = + match statement with + | TSType definition -> + ResolvedTypeDeclaration + { Binding = bindingAt TypeSymbol definition.Name definition.Span (TNamed definition.Name) + IsRecursive = definition.IsRecursive + Definition = resolvedTypeDefinitions.[definition.Name] + Fields = + definition.Fields + |> List.map (fun (name, fieldType) -> name, typeFromRef declarations [ definition.Name ] fieldType) + Cases = + definition.Cases + |> List.map (fun (name, payload) -> name, Option.map (typeFromRef declarations [ definition.Name ]) payload) + Import = Option.map importMetadata definition.Import } + | TSLet(name, _, inferred, recursive, _, span) -> + ResolvedValueDeclaration + { Binding = declarationBinding name span (normalizeTypeVariables inferred) + Scheme = declarationScheme name span (Types.generalize Map.empty inferred) + IsRecursive = recursive + Value = List.exactlyOne resolvedRoots } + | TSLetPattern(_, _, bindings, _, span) -> + let resolvedBindings = + bindings + |> Map.toList + |> List.map (fun (name, bindingType) -> + let normalized = normalizeTypeVariables bindingType + declarationBinding name span normalized, + declarationScheme name span (Types.generalize Map.empty normalized)) + ResolvedPatternDeclaration + { Pattern = List.exactlyOne patterns + Value = List.exactlyOne resolvedRoots + Bindings = resolvedBindings } + | TSLetRecGroup(bindings, _, _) -> + List.zip bindings resolvedRoots + |> List.map (fun ((name, _, inferred, span), value) -> + { Binding = declarationBinding name span (normalizeTypeVariables inferred) + Scheme = declarationScheme name span (Types.generalize Map.empty inferred) + IsRecursive = true + Value = value }) + |> ResolvedRecursiveDeclarations + | TSBackendImport(name, importedType, import, span) -> + let normalized = normalizeTypeVariables importedType + ResolvedImportedDeclaration + { Binding = declarationBinding name span normalized + Scheme = declarationScheme name span (Forall([], normalized)) + Import = importMetadata import } + | TSExpr _ -> ResolvedExpressionStatement(List.exactlyOne resolvedRoots) + { Span = + match statement with + | TSType definition -> definition.Span + | TSLet(_, _, _, _, _, span) | TSLetPattern(_, _, _, _, span) + | TSLetRecGroup(_, _, span) | TSBackendImport(_, _, _, span) -> span + | TSExpr expression -> expression.Span + Attributes = + declaredAttributes @ attributes + |> List.sortBy (fun attribute -> attribute.Span.Start.Line, attribute.Span.Start.Column) + Export = export + Node = node + Patterns = patterns + Expressions = resolvedRoots }) + let hostStatements = + hostDefinitions |> Map.toList |> List.map (fun (name, definition) -> + { Span = syntheticSpan; Attributes = []; Export = None; Patterns = []; Expressions = [] + Node = ResolvedTypeDeclaration + { Binding = bindingAt TypeSymbol name syntheticSpan (TNamed name) + IsRecursive = false; Definition = definition + Fields = match definition with TRecord fields | THostManaged(_, fields) -> Map.toList fields | _ -> [] + Cases = match definition with TUnion(_, cases) -> Map.toList cases | _ -> [] + Import = None } }) + { Purity = PurityContracts.empty + TypedProgram = typed + ResolvedStatements = hostStatements @ resolvedStatements + ExpressionTypes = expressions + Symbols = symbols |> Seq.toList + SymbolReferences = resolvedReferences } + + /// Host metadata does not change inference or execute provider code. + let inferResolvedProgramWithRegistrationAndPurity registration purity program = + { inferResolvedProgramWithRegistration registration program with Purity = purity } + + let inferResolvedProgramWithExterns externs program = + inferResolvedProgramWithRegistration (HostInterop.ofExterns externs) program + + let inferResolvedProgram (program: Program) : ResolvedProgram = + inferResolvedProgramWithExterns [] program + + /// The legacy typed-program API is a projection of the semantic resolved + /// result, so both compiler consumers and existing evaluators observe the + /// same inference pass and substitutions. + let inferProgramWithExterns (externs: ExternalFunction list) (program: Program) : TypedProgram = + validateProgramBindings externs program + inferProgramWithExternsRaw externs program let inferProgramWithLocalVariableTypes (program: Program) : TypedProgram * LocalVariableTypeInfo list = inferProgramWithExternsAndLocalVariableTypes [] program @@ -1514,7 +2319,8 @@ module TypeInfer = raise (TypeException { Message = "Host extern collides with reserved stdlib symbol"; Span = unknownSpan }) if topLevelBindingNames program |> List.exists (fun name -> Set.contains name reserved) then raise (TypeException { Message = "Top-level binding collides with reserved stdlib symbol"; Span = unknownSpan }) - inferProgramWithExternsRawAndLocals false registration program |> fst + let typed, _, _ = inferProgramWithExternsRawAndLocals false registration program + typed let inferProgramWithRegistrationAndLocalVariableTypes (registration: ExtensionRegistration) program = let reserved = BuiltinSignatures.builtinReservedNames @@ -1522,4 +2328,5 @@ module TypeInfer = raise (TypeException { Message = "Host extern collides with reserved stdlib symbol"; Span = unknownSpan }) if topLevelBindingNames program |> List.exists (fun name -> Set.contains name reserved) then raise (TypeException { Message = "Top-level binding collides with reserved stdlib symbol"; Span = unknownSpan }) - inferProgramWithExternsRawAndLocals true registration program + let typed, locals, _ = inferProgramWithExternsRawAndLocals true registration program + typed, locals diff --git a/src/FScript.Language/TypedAst.fs b/src/FScript.Language/TypedAst.fs deleted file mode 100644 index 2e8e874..0000000 --- a/src/FScript.Language/TypedAst.fs +++ /dev/null @@ -1,68 +0,0 @@ -namespace FScript.Language - -type TypedExpr = - | TELiteral of Literal * Type * Span - | TEVar of string * Type * Span - | TELambda of string * TypedExpr * Type * Span - | TEApply of TypedExpr * TypedExpr * Type * Span - | TEIf of TypedExpr * TypedExpr * TypedExpr * Type * Span - | TEMatch of TypedExpr * (Pattern * TypedExpr option * TypedExpr * Span) list * Type * Span - | TELet of string * TypedExpr * TypedExpr * bool * Type * Span - | TEList of TypedExpr list * Type * Span - | TETuple of TypedExpr list * Type * Span - | TERecord of (string * TypedExpr) list * Type * Span - | TEFieldGet of TypedExpr * string * Type * Span - | TEConstructor of string * string * Type option * Type * Span - | TECons of TypedExpr * TypedExpr * Type * Span - | TEAppend of TypedExpr * TypedExpr * Type * Span - | TEBinOp of string * TypedExpr * TypedExpr * Type * Span - | TESome of TypedExpr * Type * Span - | TENone of Type * Span - -and TypedStmt = - | TSLet of string * string list * TypedExpr * bool * Span - | TSType of TypeDef - | TSExpr of TypedExpr - -type TypedProgram = TypedStmt list - -module TypedAst = - let spanOfExpr expr = - match expr with - | TELiteral (_, _, s) -> s - | TEVar (_, _, s) -> s - | TELambda (_, _, _, s) -> s - | TEApply (_, _, _, s) -> s - | TEIf (_, _, _, _, s) -> s - | TEMatch (_, _, _, s) -> s - | TELet (_, _, _, _, _, s) -> s - | TEList (_, _, s) -> s - | TETuple (_, _, s) -> s - | TERecord (_, _, s) -> s - | TEFieldGet (_, _, _, s) -> s - | TEConstructor (_, _, _, _, s) -> s - | TECons (_, _, _, s) -> s - | TEAppend (_, _, _, s) -> s - | TEBinOp (_, _, _, _, s) -> s - | TESome (_, _, s) -> s - | TENone (_, s) -> s - - let typeOf expr = - match expr with - | TELiteral (_, t, _) -> t - | TEVar (_, t, _) -> t - | TELambda (_, _, t, _) -> t - | TEApply (_, _, t, _) -> t - | TEIf (_, _, _, t, _) -> t - | TEMatch (_, _, t, _) -> t - | TELet (_, _, _, _, t, _) -> t - | TEList (_, t, _) -> t - | TETuple (_, t, _) -> t - | TERecord (_, t, _) -> t - | TEFieldGet (_, _, t, _) -> t - | TEConstructor (_, _, _, t, _) -> t - | TECons (_, _, t, _) -> t - | TEAppend (_, _, t, _) -> t - | TEBinOp (_, _, _, t, _) -> t - | TESome (_, t, _) -> t - | TENone (t, _) -> t diff --git a/src/FScript.Language/Types.fs b/src/FScript.Language/Types.fs index d867f5c..8e966da 100644 --- a/src/FScript.Language/Types.fs +++ b/src/FScript.Language/Types.fs @@ -38,6 +38,15 @@ type HostUnionDescriptor = [] type Scheme = Forall of int list * Type +/// Trusted host contracts. Function purity includes deterministic, effect-free, +/// successful termination; type purity means deeply immutable values and payloads. +type PurityContracts = + { PureFunctions: Set + PureTypes: Set } + +module PurityContracts = + let empty = { PureFunctions = Set.empty; PureTypes = Set.empty } + module Types = let mutable private nextId = 0 diff --git a/src/FScript.Language/Value.fs b/src/FScript.Language/Value.fs index be83863..28e91ae 100644 --- a/src/FScript.Language/Value.fs +++ b/src/FScript.Language/Value.fs @@ -54,7 +54,8 @@ and ExternalCallContext = Apply: Value -> Value -> Value SpawnTask: Value -> Value AwaitTask: Value -> Value - CheckRuntime: unit -> unit } + CheckRuntime: unit -> unit + SetExitCode: int -> unit } and ExternalFunction = { Name: string diff --git a/src/FScript.Runtime/EnvironmentLoader.fs b/src/FScript.Runtime/EnvironmentLoader.fs index 888f315..9ddafa3 100644 --- a/src/FScript.Runtime/EnvironmentLoader.fs +++ b/src/FScript.Runtime/EnvironmentLoader.fs @@ -10,12 +10,14 @@ open FScript.Language type LoadedEnvironment = { Registration: ExtensionRegistration AssemblyPaths: string list + ProviderMethods: (string list * MethodInfo) list Packages: ResolvedExtensionPackage list } module EnvironmentLoader = let private loadCore (settings: EnvironmentSettings) : Result = + let collectedProviderMethods = ResizeArray() let context : HostContext = { RootDirectory = settings.RootDirectory; DeniedPathGlobs = [] } let defaultSources = if not settings.DefaultExterns then @@ -112,9 +114,11 @@ module EnvironmentLoader = else match rawProvided with | :? (FScript.Extensibility.ExternalFunction list) as provided -> + collectedProviderMethods.Add((provided |> List.map _.Name),providerMethod) let sourceName = $"{Path.GetFileName(assemblyPath)}:{declaringType.FullName}.{providerMethod.Name}" collectProviders tail ((sourceName, FScript.Extensibility.HostInterop.ofExterns provided |> ExtensionBridge.toLanguageRegistration) :: acc) | :? FScript.Extensibility.ExtensionRegistration as provided -> + collectedProviderMethods.Add((provided.Functions |> List.map _.Name),providerMethod) let sourceName = $"{Path.GetFileName(assemblyPath)}:{declaringType.FullName}.{providerMethod.Name}" collectProviders tail ((sourceName, ExtensionBridge.toLanguageRegistration provided) :: acc) | _ -> @@ -194,6 +198,7 @@ module EnvironmentLoader = HostInterop.typeDefinitions registration [] |> ignore Ok { Registration = registration AssemblyPaths = (uniqueAssemblyPaths @ packageEnvironment.AssemblyPaths) |> List.distinct + ProviderMethods = collectedProviderMethods |> Seq.toList Packages = packageEnvironment.Packages } with EvalException error -> Error error.Message else diff --git a/src/FScript.Runtime/ExportSignatures.fs b/src/FScript.Runtime/ExportSignatures.fs index da4ba60..7b28c11 100644 --- a/src/FScript.Runtime/ExportSignatures.fs +++ b/src/FScript.Runtime/ExportSignatures.fs @@ -3,51 +3,6 @@ namespace FScript.Runtime open FScript.Language module ExportSignatures = - type ExportedFunctionSignature = - { Name: string - ParameterNames: string list - ParameterTypes: Type list - ReturnType: Type } + type ExportedFunctionSignature = FScript.Language.ExportSignatures.ExportedFunctionSignature - let private flattenFunctionType (t: Type) : Type list * Type = - let rec loop (acc: Type list) (current: Type) = - match current with - | TFun (arg, ret) -> loop (arg :: acc) ret - | _ -> List.rev acc, current - loop [] t - - let private flattenParameterNames (expr: Expr) : string list = - let rec loop (acc: string list) (current: Expr) = - match current with - | ELambda (param, body, _) -> loop (param.Name :: acc) body - | _ -> List.rev acc - loop [] expr - - let private fromLet (name: string) (expr: Expr) (exprType: Type) : ExportedFunctionSignature option = - let parameterNames = flattenParameterNames expr - let parameterTypes, returnType = flattenFunctionType exprType - if parameterNames.IsEmpty || parameterTypes.IsEmpty then - None - elif parameterNames.Length <> parameterTypes.Length then - raise (HostCommon.evalError $"Signature mismatch for function '{name}'") - else - Some - { Name = name - ParameterNames = parameterNames - ParameterTypes = parameterTypes - ReturnType = returnType } - - let fromTypedProgram (program: TypeInfer.TypedProgram) : Map = - program - |> List.collect (function - | TypeInfer.TSLet(name, expr, exprType, _, isExported, _) when isExported -> - match fromLet name expr exprType with - | Some signature -> [ signature.Name, signature ] - | None -> [] - | TypeInfer.TSLetRecGroup(bindings, isExported, _) when isExported -> - bindings - |> List.choose (fun (name, expr, exprType, _) -> - fromLet name expr exprType - |> Option.map (fun signature -> signature.Name, signature)) - | _ -> []) - |> Map.ofList + let fromTypedProgram = FScript.Language.ExportSignatures.fromTypedProgram diff --git a/src/FScript.Runtime/ScriptHost.fs b/src/FScript.Runtime/ScriptHost.fs index 3a6b237..f3e94d0 100644 --- a/src/FScript.Runtime/ScriptHost.fs +++ b/src/FScript.Runtime/ScriptHost.fs @@ -20,7 +20,8 @@ module ScriptHost = ExportedValueNames: string list ExportedValueSet: Set ExportedValues: Map - LastValue: Value } + LastValue: Value + ExitCode: int } let private isCallable value = match value with @@ -111,7 +112,8 @@ module ScriptHost = ExportedValueNames = valueNames ExportedValueSet = valueSet ExportedValues = values - LastValue = state.LastValue } + LastValue = state.LastValue + ExitCode = state.ExitCode } let loadSourceWithRegistration (registration: ExtensionRegistration) (source: string) : LoadedScript = let program = FScript.parse source @@ -158,7 +160,7 @@ module ScriptHost = | Some value -> value | None -> raise (HostCommon.evalError $"Unknown exported value '{valueName}'") - let invoke (loaded: LoadedScript) (functionName: string) (args: Value list) : Value = + let invokeWithExitCode (loaded: LoadedScript) (functionName: string) (args: Value list) : Eval.InvocationResult = if not (loaded.ExportedFunctionSet |> Set.contains functionName) then if loaded.ExportedValueSet |> Set.contains functionName then raise (HostCommon.evalError $"'{functionName}' is a value and cannot be invoked") @@ -170,13 +172,20 @@ module ScriptHost = match loaded.ExportedFunctionSignatures.TryFind functionName with | Some signature -> let fullType = List.foldBack (fun argument result -> TFun(argument, result)) signature.ParameterTypes signature.ReturnType - HostInterop.validateCall loaded.TypeDefs fullType args (fun () -> Eval.invokeValue loaded.TypeDefs fnValue args) - | None -> Eval.invokeValue loaded.TypeDefs fnValue args + let mutable exitCode=0 + let value=HostInterop.validateCall loaded.TypeDefs fullType args (fun () -> + let result=Eval.invokeValueWithExitCode loaded.TypeDefs fnValue args + exitCode<-result.ExitCode + result.Value) + {Value=value;ExitCode=exitCode} + | None -> Eval.invokeValueWithExitCode loaded.TypeDefs fnValue args | Some _ -> raise (HostCommon.evalError $"'{functionName}' is not callable") | None -> raise (HostCommon.evalError $"Unknown exported function '{functionName}'") + let invoke loaded functionName args = (invokeWithExitCode loaded functionName args).Value + let loadSource externs source = loadSourceWithRegistration (HostInterop.ofExterns externs) source let loadFile externs path = loadFileWithRegistration (HostInterop.ofExterns externs) path let loadSourceWithIncludes externs root entry source resolver = diff --git a/src/FScript/CliArgs.fs b/src/FScript/CliArgs.fs index 514a6d7..d8115f3 100644 --- a/src/FScript/CliArgs.fs +++ b/src/FScript/CliArgs.fs @@ -8,6 +8,7 @@ type CliArgs = | [] Config of path: string | Debug_Adapter | Debug_Capabilities + | No_Result | No_Config | No_Default_Externs | Extern_Assembly of path: string @@ -19,6 +20,7 @@ type CliArgs = | Config _ -> "Override automatic fscript.toml selection with an explicit configuration." | Debug_Adapter -> "Run the Debug Adapter Protocol service (used by editor integrations)." | Debug_Capabilities -> "Report the CLI debugger protocol capabilities as JSON." + | No_Result -> "Do not display the final program value; explicit output and evaluation are preserved." | No_Config -> "Disable automatic fscript.toml loading (script directory, or cwd for stdin/REPL)." | No_Default_Externs -> "Disable default runtime externs from FScript.Runtime.Registry." | Extern_Assembly _ -> "Load external-function providers from an assembly path (repeatable)." diff --git a/src/FScript/FScript.fsproj b/src/FScript/FScript.fsproj index 7701ea2..4835265 100644 --- a/src/FScript/FScript.fsproj +++ b/src/FScript/FScript.fsproj @@ -39,6 +39,10 @@ + + + + diff --git a/src/FScript/Program.fs b/src/FScript/Program.fs index 29f0ce1..1cc60b9 100644 --- a/src/FScript/Program.fs +++ b/src/FScript/Program.fs @@ -7,16 +7,124 @@ open CliArgs open FScript.Language open FScript.Runtime +let writeGeneratedFile (root: string) (file: FScript.Compiler.GeneratedFile) = + let path = Path.Combine(root, file.RelativePath) + match Path.GetDirectoryName(path) with + | null -> () + | directory -> Directory.CreateDirectory(directory) |> ignore + File.WriteAllText(path, file.Content) + +let runCompileCommand (argv: string array) = + let usage () = + Console.Error.WriteLine("Usage: fscript compile --target --output [--reference ] [--single-file|--aot] [--runtime ] [--no-result]") + 1 + if argv.Length < 2 then usage () + else + let scriptPath = Path.GetFullPath(argv.[1]) + let tryOption name = + argv |> Array.tryFindIndex ((=) name) + |> Option.bind (fun index -> if index + 1 < argv.Length then Some argv.[index + 1] else None) + match tryOption "--target", tryOption "--output" with + | Some target, Some output when File.Exists scriptPath -> + let normalizedTarget = target.ToLowerInvariant() + let singleFile=Array.contains "--single-file" argv + let aot=Array.contains "--aot" argv + let executable=singleFile || aot + let hasRuntime=Array.contains "--runtime" argv + let requestedRuntime=tryOption "--runtime" |> Option.filter (fun value -> not (value.StartsWith("--",StringComparison.Ordinal))) + let runtime= + if executable && not hasRuntime then Some System.Runtime.InteropServices.RuntimeInformation.RuntimeIdentifier + else requestedRuntime + if not (List.contains normalizedTarget ["ir"; "csharp"; "dotnet"]) then usage () + elif normalizedTarget="ir" && Array.contains "--no-result" argv then + Console.Error.WriteLine("--no-result applies to script execution and C#/ .NET compilation, not IR artifacts.") + usage () + elif normalizedTarget<>"dotnet" && (executable || Array.contains "--runtime" argv) then + Console.Error.WriteLine("--single-file, --aot, and --runtime are only supported with --target dotnet.") + usage () + elif hasRuntime && requestedRuntime.IsNone then + Console.Error.WriteLine("--runtime requires a value, for example osx-arm64, linux-x64, or win-x64. Omit --runtime to target the current platform.") + usage () + elif not executable && Array.contains "--runtime" argv then + Console.Error.WriteLine("--runtime requires --single-file or --aot.") + usage () + else + try + let outputDirectory = Path.GetFullPath(output) + let sourceRoot = Path.GetDirectoryName(scriptPath) |> Option.ofObj |> Option.defaultValue (Directory.GetCurrentDirectory()) + let program = FScript.parseFileWithIncludes sourceRoot scriptPath + let allOptions name = argv |> Array.indexed |> Array.choose (fun (index,value) -> if value=name && index+1 Array.toList + let loaded = + EnvironmentConfiguration.resolveForCli (tryOption "--config") (Array.contains "--no-config" argv) sourceRoot sourceRoot None (Array.contains "--no-default-externs" argv) (allOptions "--extern-assembly") + |> Result.bind EnvironmentLoader.loadWithInfo + |> function Ok environment -> environment | Error message -> failwith message + let sdkReferences = if loaded.ProviderMethods.IsEmpty then [] else [typeof.Assembly.Location; typeof.Assembly.Location] + let references = allOptions "--reference" @ loaded.AssemblyPaths @ sdkReferences |> List.distinct + let purity = FScript.Compiler.ClrBindings.providerPurity (loaded.ProviderMethods |> List.map snd) + match FScript.Compiler.Compiler.compileWithRegistrationAndPurity loaded.Registration purity { Program = program; Externs = [] } with + | Error diagnostics -> + diagnostics |> List.iter (fun diagnostic -> Console.Error.WriteLine($"{diagnostic.Code}: {diagnostic.Message}")) + 4 + | Ok compiled -> + let lir = loaded.ProviderMethods |> List.fold (fun program (names,method) -> FScript.Compiler.ClrBindings.bindProvider names method program) compiled.Lir + let lir = + if normalizedTarget="dotnet" || normalizedTarget="csharp" then + FScript.Compiler.ClrBindings.bindCompiledProviders (loaded.ProviderMethods |> List.map snd) lir + else lir + Directory.CreateDirectory(outputDirectory) |> ignore + match normalizedTarget with + | "ir" -> + let baseName = + match Path.GetFileNameWithoutExtension(scriptPath) with + | null | "" -> "program" + | value -> value + let name = baseName + ".fsir" + File.WriteAllBytes(Path.Combine(outputDirectory, name), FScript.Compiler.IrArtifact.serialize lir) + 0 + | "csharp" -> + match FScript.Compiler.CSharpBackend.generateWithResultOutput (not (Array.contains "--no-result" argv)) {Namespace="FScript.Generated"; ClassName="Program"; References=references} lir with + | Error diagnostics -> + diagnostics |> List.iter (fun d -> Console.Error.WriteLine($"{d.Code}: {d.Message}")) + 4 + | Ok files -> files |> List.iter (writeGeneratedFile outputDirectory); 0 + | "dotnet" -> + let options: FScript.Compiler.DotNetOptions = + { AssemblyName=Path.GetFileNameWithoutExtension scriptPath |> nonNull; Namespace="FScript.Generated"; ClassName="Program" + OutputKind=FScript.Compiler.ConsoleApplication; References=references } + let generated= + if executable then FScript.Compiler.DotNetBackend.generateExecutableWithResultOutput (not (Array.contains "--no-result" argv)) {RuntimeIdentifier=runtime.Value;AheadOfTime=aot} options lir + else FScript.Compiler.DotNetBackend.generateWithResultOutput (not (Array.contains "--no-result" argv)) options lir + match generated with + | Error diagnostics -> + diagnostics |> List.iter (fun d -> Console.Error.WriteLine($"{d.Code}: {d.Message}")) + 4 + | Ok files -> + for file in files do + let path=Path.Combine(outputDirectory,file.RelativePath) + File.WriteAllBytes(path,file.Content) + if executable && not (OperatingSystem.IsWindows()) && not (runtime.Value.StartsWith("win-",StringComparison.Ordinal)) then + File.SetUnixFileMode(path,UnixFileMode.UserRead ||| UnixFileMode.UserWrite ||| UnixFileMode.UserExecute ||| UnixFileMode.GroupRead ||| UnixFileMode.GroupExecute ||| UnixFileMode.OtherRead ||| UnixFileMode.OtherExecute) + 0 + | _ -> usage () + with + | ParseException error -> Console.Error.WriteLine($"Parse error: {error.Message}"); 1 + | TypeException error -> Console.Error.WriteLine($"Type error: {error.Message}"); 2 + | :? UnauthorizedAccessException as ex -> Console.Error.WriteLine($"FSA5101: Cannot write compiler output: {ex.Message}"); 4 + | :? IOException as ex -> Console.Error.WriteLine($"FSA5101: Cannot write compiler output: {ex.Message}"); 4 + | ex -> Console.Error.WriteLine(ex.Message); 4 + | Some _, Some _ -> Console.Error.WriteLine($"File not found: {scriptPath}"); 1 + | _ -> usage () + let formatSpan (span: Span) = match span.Start.File with | Some file -> sprintf "(%s:%d:%d)" file span.Start.Line span.Start.Column | None -> sprintf "(line %d, col %d)" span.Start.Line span.Start.Column -let runTypedProgram (registration: ExtensionRegistration) (program: Program) = +let runTypedProgram printResult (registration: ExtensionRegistration) (program: Program) = let typed = TypeInfer.inferProgramWithRegistration registration program - let result = Eval.evalProgramWithRegistration registration typed - Console.WriteLine(Pretty.valueToString result) - 0 + let state = Eval.evalProgramWithRegistrationState registration typed + if printResult then Console.WriteLine(Pretty.valueToString state.LastValue) + state.ExitCode let escapeFScriptString (value: string) = value @@ -60,7 +168,7 @@ let parseEnvironmentPrelude (scriptName: string option) (arguments: string list) environmentPrelude scriptName arguments |> FScript.parseWithSourceName (Some "") -let runFile (registration: ExtensionRegistration) (rootDirectory: string) (scriptPath: string) (arguments: string list) = +let runFile printResult (registration: ExtensionRegistration) (rootDirectory: string) (scriptPath: string) (arguments: string list) = if not (File.Exists scriptPath) then Console.Error.WriteLine($"File not found: {scriptPath}") 1 @@ -73,13 +181,13 @@ let runFile (registration: ExtensionRegistration) (rootDirectory: string) (scrip let envProgram = parseEnvironmentPrelude (Some scriptName) arguments let scriptProgram = FScript.parseFileWithIncludes rootDirectory scriptPath let program = envProgram @ scriptProgram - runTypedProgram registration program + runTypedProgram printResult registration program -let runSource (registration: ExtensionRegistration) (_rootDirectory: string) (source: string) (arguments: string list) = +let runSource printResult (registration: ExtensionRegistration) (_rootDirectory: string) (source: string) (arguments: string list) = let combinedSource = $"{environmentPrelude None arguments}\n{source}" let loaded = ScriptHost.loadSourceWithRegistration registration combinedSource - Console.WriteLine(Pretty.valueToString loaded.LastValue) - 0 + if printResult then Console.WriteLine(Pretty.valueToString loaded.LastValue) + loaded.ExitCode let tryGetLastExpressionType (typed: TypeInfer.TypedProgram) = typed @@ -137,10 +245,11 @@ let printVersion () = | null -> "0.0.0" | v -> v.ToString() -let runRepl (registration: ExtensionRegistration) (_rootDirectory: string) = +let runRepl printResult (registration: ExtensionRegistration) (_rootDirectory: string) = let initialProgram = parseEnvironmentPrelude None [] let initialSubmission = Interactive.createWithRegistration registration |> fun session -> Interactive.submit session initialProgram let mutable session = initialSubmission.Session + let mutable exitCode = initialSubmission.State.ExitCode let mutable pendingLines: string list = [] let mutable pendingBlankLines = 0 let mutable running = true @@ -157,12 +266,13 @@ let runRepl (registration: ExtensionRegistration) (_rootDirectory: string) = let submission = Interactive.submit session parsed let typed = submission.TypedProgram let state = submission.State + exitCode <- state.ExitCode let hasExpression = parsed |> List.exists (function | SExpr _ -> true | _ -> false) - if hasExpression then + if hasExpression && printResult then match tryGetLastExpressionType typed with | Some t -> match tryFormatFunctionValueWithType state.LastValue t with @@ -228,7 +338,7 @@ let runRepl (registration: ExtensionRegistration) (_rootDirectory: string) = Console.Error.WriteLine($"Eval error {formatSpan err.Span}: {err.Message}") pendingLines <- [] pendingBlankLines <- 0 - 0 + exitCode // Keep the adapter's assembly and protocol dependencies out of ordinary CLI // startup. The JIT resolves these calls only when a debugger mode is selected. @@ -238,8 +348,7 @@ let runDebugAdapter () = FScript.DebugAdapter.DebuggerEntry.RunAdapter() [] let runDebugHost port token = FScript.DebugAdapter.DebuggerEntry.RunHost(port, token) -[] -let main argv = +let runOrdinaryCommand argv = let parser = ArgumentParser.Create(programName = "fscript") let cliArgv, scriptArguments = splitScriptArguments argv try @@ -288,16 +397,16 @@ let main argv = | Ok registration -> match scriptPath with | Some path -> - runFile registration rootDirectory path scriptArguments + runFile (not (args.Contains <@ No_Result @>)) registration rootDirectory path scriptArguments | None when Console.IsInputRedirected -> let source = Console.In.ReadToEnd() - runSource registration rootDirectory source scriptArguments + runSource (not (args.Contains <@ No_Result @>)) registration rootDirectory source scriptArguments | None -> if not scriptArguments.IsEmpty then Console.Error.WriteLine("Script arguments require file or stdin mode. Use 'fscript -- ' or pipe stdin with '--'.") 1 else - runRepl registration rootDirectory + runRepl (not (args.Contains <@ No_Result @>)) registration rootDirectory with | ParseException err -> Console.Error.WriteLine($"Parse error {formatSpan err.Span}: {err.Message}") @@ -308,7 +417,14 @@ let main argv = | EvalException err -> Console.Error.WriteLine($"Eval error {formatSpan err.Span}: {err.Message}") 3 - with - | :? ArguParseException as ex -> - Console.Error.WriteLine(ex.Message) - 1 + with + | :? ArguParseException as ex -> + Console.Error.WriteLine(ex.Message) + 1 + +[] +let main argv = + if argv.Length > 0 && String.Equals(argv.[0], "compile", StringComparison.OrdinalIgnoreCase) then + runCompileCommand argv + else + runOrdinaryCommand argv diff --git a/tests/FScript.Backend.DotNet.Tests/BackendTests.fs b/tests/FScript.Backend.DotNet.Tests/BackendTests.fs new file mode 100644 index 0000000..a0301b1 --- /dev/null +++ b/tests/FScript.Backend.DotNet.Tests/BackendTests.fs @@ -0,0 +1,511 @@ +namespace FScript.Backend.DotNet.Tests + +open System +open System.IO +open System.Reflection +open System.Reflection.Emit +open System.Runtime.CompilerServices +open FScript.Language +open FScript.Compiler +open NUnit.Framework + +module ProviderFixture = + open FScript.Extensibility + // Test-only instrumentation measures evaluation count; only Calculate is registered. + type CseProbe = + static let mutable calls=0 + static member Reset() = calls<-0 + static member Calls = calls + static member Calculate(value: int64) = calls<-calls+1;value+1L + + type QuietValue() = + member _.Value = 7L + type ConstructedValue(value: int64) = + static let mutable created = 0 + do created <- created+1 + static member Reset() = created <- 0 + static member Created = created + member _.Value = value + type ObservedValue() = + static let mutable reads = 0 + static member Reset() = reads <- 0 + static member Reads = reads + member _.Value = reads <- reads+1; 7L + type Provider = + static member Provide() : ExtensionRegistration = + let descriptor={Name="Secret"; Fields=Map.ofList ["Name",TString]; HostManaged=true} + { Types=[descriptor]; Unions=[{Name="ForeignState"; Cases=Map.ofList ["Ready",None; "Count",Some TInt]}] + Functions= + [ {Name="Sdk.create"; Scheme=Forall([],TFun(TString,TNamed "Secret")); Arity=1 + Impl=fun _ arguments -> match arguments with [VString name] -> VHostManaged {Descriptor=descriptor; Fields=Map.ofList ["Name",VString name]; Payload=box name |> nonNull} | _ -> failwith "arguments"} + {Name="Sdk.apply"; Scheme=Forall([],TFun(TFun(TInt,TInt),TFun(TInt,TInt))); Arity=2 + Impl=fun context arguments -> context.Apply arguments.[0] arguments.[1]} + {Name="Sdk.identity"; Scheme=Forall([0],TFun(TVar 0,TVar 0)); Arity=1; Impl=fun _ arguments -> arguments.[0]} + {Name="Sdk.await"; Scheme=Forall([],TFun(TTask TInt,TInt)); Arity=1; Impl=fun context arguments -> context.AwaitTask arguments.[0]} ] } + type ContextProvider = + static member Provide(context: HostContext) : ExtensionRegistration = + let fn=context.DefaultFunctions |> List.find (fun fn -> fn.Name="Guid.new") + {Types=[]; Unions=[]; Functions=[{fn with Name="Sdk.guid"}]} + +module private Harness = + let legacy source = + let registration=HostInterop.ofExterns (FScript.Runtime.Registry.all {RootDirectory=Directory.GetCurrentDirectory(); DeniedPathGlobs=[]}) + Parser.parseProgram source |> TypeInfer.inferProgramWithRegistration registration |> Eval.evalProgramWithRegistration registration |> Pretty.valueToString + let compile source = + match Compiler.compile {Program=Parser.parseProgram source; Externs=[]} with + | Ok program -> program.Lir + | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + let options: DotNetOptions = + { AssemblyName="CompiledScript"; Namespace="Generated"; ClassName="Program"; OutputKind=Library; References=[] } + let generate options program = + match DotNetBackend.generate options program with + | Ok files -> files + | Error errors -> failwith (String.concat "\n" (errors |> List.map (fun d -> d.Code+": "+d.Message))) + let executeWith options program = + let files=generate options program + let assembly=Assembly.Load((files |> List.find (fun f -> f.RelativePath.EndsWith(".dll"))).Content) + for typ in assembly.GetTypes() do + for method in typ.GetMethods(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static ||| BindingFlags.Instance ||| BindingFlags.DeclaredOnly) do + if not method.IsAbstract && not method.ContainsGenericParameters && not (nonNull method.DeclaringType).ContainsGenericParameters then + RuntimeHelpers.PrepareMethod(method.MethodHandle) + Assert.That(assembly.GetReferencedAssemblies() |> Array.exists (fun a -> List.contains (a.Name |> Option.ofObj |> Option.defaultValue "") ["FScript.Language"; "FScript.Runtime"; "FScript.Interpreter.Lir"]), Is.False) + let programType=assembly.GetType("Generated.Program") |> nonNull + let result=(programType.GetMethod("Run") |> nonNull).Invoke(null,[||]) + ((programType.GetMethod("FormatResult") |> nonNull).Invoke(null,[|result|]) |> nonNull) :?> string + let execute program = executeWith options program + let csharpAssembly references program = + let files=match CSharpBackend.generate {Namespace="Generated";ClassName="Program";References=references} program with Ok files -> files | Error errors -> failwith (string errors) + let directory=Path.Combine(Path.GetTempPath(),"fscript-cse-csharp-"+Guid.NewGuid().ToString("N")) + try + Directory.CreateDirectory directory |> ignore + for file in files do File.WriteAllText(Path.Combine(directory,file.RelativePath),file.Content) + let start=Diagnostics.ProcessStartInfo("dotnet",WorkingDirectory=directory,RedirectStandardOutput=true,RedirectStandardError=true) + for arg in ["build";"-c";"Release";"--output";"compiled"] do start.ArgumentList.Add(arg) + use proc=Diagnostics.Process.Start(start) |> nonNull + let output=proc.StandardOutput.ReadToEndAsync() + let error=proc.StandardError.ReadToEndAsync() + if not (proc.WaitForExit(60000)) then proc.Kill(true);Assert.Fail("Generated C# build timed out.") + Assert.That(proc.ExitCode,Is.EqualTo(0),output.Result+error.Result) + Assembly.Load(File.ReadAllBytes(Path.Combine(directory,"compiled","Program.dll"))) + finally + if Directory.Exists directory then Directory.Delete(directory,true) + + +module private IL = + let instructions (assembly: Assembly) = + let opcodes=typeof.GetFields(BindingFlags.Public ||| BindingFlags.Static) |> Array.map (fun field -> let opcode=field.GetValue(null) :?> OpCode in uint16 opcode.Value,opcode) |> Map.ofArray + [ for typ in assembly.GetTypes() do + for method in typ.GetMethods(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static ||| BindingFlags.Instance ||| BindingFlags.DeclaredOnly) do + let body=method.GetMethodBody() + if not (isNull body) then + let bytes=(nonNull body).GetILAsByteArray() |> nonNull + let mutable offset=0 + while offset Option.ofObj + else None + yield method,opcode,memberInfo + let length= + match opcode.OperandType with + | OperandType.InlineNone -> 0 + | OperandType.ShortInlineBrTarget | OperandType.ShortInlineI | OperandType.ShortInlineVar -> 1 + | OperandType.InlineVar -> 2 + | OperandType.InlineI8 | OperandType.InlineR -> 8 + | OperandType.InlineSwitch -> 4+4*BitConverter.ToInt32(bytes,offset) + | _ -> 4 + offset <- offset+length ] + let load source = + let files=Harness.generate Harness.options (Harness.compile source) + Assembly.Load((files |> List.find (fun file -> file.RelativePath="CompiledScript.dll")).Content) + +[] +type BackendTests() = + [] + [] + [] + [] + member _.``CSharp and assembly backends share only declared pure FFI evaluations`` (assemblyTarget: bool, isPure: bool) = + let external: CompilerExtern={Name="Host.calculate";Scheme=Forall([],TFun(TInt,TInt));Arity=1;Kind=UnsupportedHostExtern} + let contracts=if isPure then {PurityContracts.empty with PureFunctions=Set.singleton external.Name} else PurityContracts.empty + let source="(Host.calculate 7,Host.calculate 7)" + let program=match Compiler.compileWithPurity contracts {Program=Parser.parseProgram source;Externs=[external]} with Ok p -> p.Lir | Error errors -> failwith (string errors) + let native=typeof + let program=ClrBindings.bindMethod external.Name (native.GetMethod("Calculate") |> nonNull) program + let references=[native.Assembly.Location] + let assembly= + if assemblyTarget then + let files=Harness.generate {Harness.options with References=references} program + Assembly.Load((files |> List.find (fun file -> file.RelativePath="CompiledScript.dll")).Content) + else Harness.csharpAssembly references program + ProviderFixture.CseProbe.Reset() + let typ=assembly.GetType("Generated.Program") |> nonNull + let result=(typ.GetMethod("Run") |> nonNull).Invoke(null,[||]) + let formatted=(typ.GetMethod("FormatResult") |> nonNull).Invoke(null,[|result|]) + Assert.That(formatted,Is.EqualTo(box "(8, 8)")) + Assert.That(ProviderFixture.CseProbe.Calls,Is.EqualTo(if isPure then 1 else 2)) + + [] + member _.``A pure external type does not imply a pure constructor`` () = + let native=typeof + let registration: ExtensionRegistration={HostInterop.empty with Types=[{Name="NativeValue";Fields=Map.ofList ["Value",TInt];HostManaged=false}]} + let contracts={PurityContracts.empty with PureTypes=Set.singleton "NativeValue"} + let input={Program=Parser.parseProgram "let discarded = { Value=7 }\n42";Externs=[]} + let program=match Compiler.compileWithRegistrationAndPurity registration contracts input with Ok value -> value.Lir | Error errors -> failwith (string errors) + let linked=ClrBindings.bindType "NativeValue" native program + ProviderFixture.ConstructedValue.Reset() + Assert.That(Harness.executeWith {Harness.options with References=[native.Assembly.Location]} linked,Is.EqualTo("42")) + Assert.That(ProviderFixture.ConstructedValue.Created,Is.EqualTo(1)) + + [ 1 | _ -> 0")>] + [ 1 | _ -> 0")>] + [] + [] + [] + [] + [] + [] + member _.``Native getter pruning requires a pure external type`` (isPure: bool, expression: string) = + let registration: ExtensionRegistration={HostInterop.empty with Types=[{Name="NativeValue";Fields=Map.ofList ["Value",TInt];HostManaged=true}]} + let external: CompilerExtern={Name="Native.create";Scheme=Forall([],TFun(TUnit,TNamed "NativeValue"));Arity=1;Kind=UnsupportedHostExtern} + let contracts=if isPure then {PurityContracts.empty with PureTypes=Set.singleton "NativeValue"} else PurityContracts.empty + let native=typeof + let compiled=match Compiler.compileWithRegistrationAndPurity registration contracts {Program=Parser.parseProgram ("let value = Native.create ()\nlet discarded = "+expression+"\n42");Externs=[external]} with Ok value -> value.Lir | Error errors -> failwith (string errors) + let linked=compiled |> ClrBindings.bindType "NativeValue" native |> ClrBindings.bindMethod "Native.create" (native.GetConstructor(System.Type.EmptyTypes) |> nonNull) + let options={Harness.options with References=[native.Assembly.Location]} + let binary=Harness.generate options linked |> List.find (fun file -> file.RelativePath="CompiledScript.dll") + let assembly=Assembly.Load(binary.Content) + let callsGetter=IL.instructions assembly |> List.exists (fun (_,_,memberInfo) -> memberInfo |> Option.exists (fun info -> info.DeclaringType=native && info.Name="get_Value")) + Assert.That(callsGetter,Is.EqualTo(not isPure)) + Assert.That(Harness.executeWith options linked,Is.EqualTo("42")) + + [] + member _.``Unmarked external getters execute once and cannot be duplicated`` () = + let native=typeof + let registration: ExtensionRegistration={HostInterop.empty with Types=[{Name="NativeValue";Fields=Map.ofList ["Value",TInt];HostManaged=true}]} + let external: CompilerExtern={Name="Native.create";Scheme=Forall([],TFun(TUnit,TNamed "NativeValue"));Arity=1;Kind=UnsupportedHostExtern} + let source="let value = Native.create ()\nlet useValue () =\n let read = value.Value\n (read,read)\nuseValue ()" + let program=match Compiler.compileWithRegistration registration {Program=Parser.parseProgram source;Externs=[external]} with Ok value -> value.Lir | Error errors -> failwith (string errors) + let linked=program |> ClrBindings.bindType "NativeValue" native |> ClrBindings.bindMethod "Native.create" (native.GetConstructor(System.Type.EmptyTypes) |> nonNull) + ProviderFixture.ObservedValue.Reset() + Assert.That(Harness.executeWith {Harness.options with References=[native.Assembly.Location]} linked,Is.EqualTo("(7, 7)")) + Assert.That(ProviderFixture.ObservedValue.Reads,Is.EqualTo(1)) + + [] + [ value+2) 40", "42")>] + [] + [ 42))", "42")>] + [] + [] + [ name", "\"hello\"")>] + member _.``Existing SDK providers marshal compiled values callbacks and tasks`` (source: string, expected: string) = + let registration=ProviderFixture.Provider.Provide() |> FScript.Runtime.ExtensionBridge.toLanguageRegistration + let compiled=match Compiler.compileWithRegistration registration {Program=Parser.parseProgram source; Externs=[]} with Ok p -> p | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + let provider=typeof.GetMethod("Provide") |> nonNull + let program=ClrBindings.bindProvider (registration.Functions |> List.map _.Name) provider compiled.Lir + let program=match IrArtifact.deserialize (IrArtifact.serialize program) with Ok p -> p | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + let references=[typeof.Assembly.Location; typeof.Assembly.Location; typeof.Assembly.Location] + Assert.That(Harness.executeWith {Harness.options with References=references} program,Is.EqualTo(expected)) + + [] + member _.``SDK providers receive compiled default functions through HostContext`` () = + let defaultFunctions=FScript.Runtime.Registry.all {RootDirectory=Directory.GetCurrentDirectory(); DeniedPathGlobs=[]} |> FScript.Runtime.ExtensionBridge.toExtensionFunctions + let context=FScript.Extensibility.HostContext(Directory.GetCurrentDirectory(),[],defaultFunctions) + let registration=ProviderFixture.ContextProvider.Provide(context) |> FScript.Runtime.ExtensionBridge.toLanguageRegistration + let compiled=match Compiler.compileWithRegistration registration {Program=Parser.parseProgram "Sdk.guid () |> Option.isSome"; Externs=[]} with Ok p -> p | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + let provider=typeof.GetMethod("Provide") |> nonNull + let program=ClrBindings.bindProvider ["Sdk.guid"] provider compiled.Lir + let references=[typeof.Assembly.Location; typeof.Assembly.Location; typeof.Assembly.Location] + Assert.That(Harness.executeWith {Harness.options with References=references} program,Is.EqualTo("true")) + [] + [] + [ x+y\nlet add = make 10\nadd 32", "42")>] + [ x+y\nmake 1 40", "42")>] + [] + [ x+1) 40", "42")>] + [ add delta\nList.map (outer 10) [1;2]", "[11;12]")>] + [] + [ f ()) acc else collect (n-1) ((fun () -> n)::acc)\ncollect 3 []", "[1;2;3]")>] + [ n+1) [1;2], List.filter (fun n -> n>1) [1;2], List.fold (fun s n -> s+n) 0 [1;2], List.choose (fun n -> if n>1 then Some n else None) [1;2], List.collect (fun n -> [n;n]) [1;2], List.exists (fun n -> n=2) [1;2], List.tryFind (fun n -> n=2) [1;2], List.tryGet (fun n -> n=2) [1;2])", "([2;3], [2], 3, [2], [1;1;2;2], true, Some 2, Some 1)")>] + [] + [] + [ List.map (fun n -> n*2)", "[6;4;2]")>] + [] + [] + [] + [ a+b | _ -> 0", "3")>] + [ Int.toString n | Text s -> s", "\"ok\"")>] + [ 1 | Blue -> 2", "1")>] + [] + [ (k, Map.count rest) | _ -> (\"\",0)", "(\"\", 0)")>] + [] + [ 42) |> Task.await", "42")>] + [] + [ (x,Map.containsKey 1 rest) | _ -> (0,false)", "(0, false)")>] + [ 1 | _ -> 2", "1")>] + [ 1 | _ -> 2\ncheck { City=\"Paris\"; Zip=75000 }", "1")>] + member _.``Generated assemblies execute core semantics and every closed method JITs`` (source: string, expected: string) = + let actual=Harness.execute (Harness.compile source) + Assert.That(actual, Is.EqualTo(expected)) + Assert.That(actual, Is.EqualTo(Harness.legacy source)) + + [] + [] + [ person")>] + [\"")>] + [ x \"")>] + [] + [] + member _.``Generated formatting JSON XML and interpolation conform to the legacy evaluator`` (source: string) = + Assert.That(Harness.execute (Harness.compile source), Is.EqualTo(Harness.legacy source)) + + [] + [] + [ acc | _ -> walk (n-1) (acc+1)\nwalk 1000000 0")>] + member _.``Self tail recursion runs one million steps with bounded stack`` (source: string) = + Assert.That(Harness.execute (Harness.compile source),Is.EqualTo("1000000")) + + [] + [ x+1) 40")>] + [ x+1) [1;2] |> List.fold (fun s x -> s+x) 0")>] + member _.``Known calls and partial applications contain no delegate invocation in IL`` (source: string) = + let instructions=IL.load source |> IL.instructions + let invokes=instructions |> List.choose (fun (_,_,memberInfo) -> memberInfo |> Option.filter (fun memberInfo -> memberInfo.Name="Invoke" && not (isNull memberInfo.DeclaringType) && typeof.IsAssignableFrom(memberInfo.DeclaringType))) + Assert.That(invokes,Is.Empty) + + [] + member _.``Unused runtime types helpers and record machinery are absent from the assembly`` () = + let assembly=IL.load "40+2" + Assert.That(String.concat "," (assembly.GetTypes() |> Array.map _.Name),Is.EqualTo("Program")) + let names=(assembly.GetType("Generated.Program") |> nonNull).GetMethods(BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.Static) |> Array.map _.Name + Assert.That(names |> Array.exists (fun name -> name.StartsWith("Json",StringComparison.Ordinal) || name.StartsWith("Equal",StringComparison.Ordinal) || name.StartsWith("Encode",StringComparison.Ordinal)),Is.False) + + [] + [] + member _.``Hello with environment and console retains only used stdlib members`` (executable: bool) = + let source="let name = match Env.Arguments with | head :: _ -> head | _ -> \"Unknown\"\nConsole.writeLine $\"Hello {name} !\"" + let options={Harness.options with OutputKind=if executable then ConsoleApplication else Library} + let files=Harness.generate options (Harness.compile source) + let assembly=Assembly.Load((files |> List.find (fun file -> file.RelativePath="CompiledScript.dll")).Content) + let runtime=assembly.GetType("Generated.FsRuntime") |> nonNull + let methods=runtime.GetMethods(BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly) |> Array.map _.Name |> Array.sort + Assert.That(String.concat "," methods,Is.EqualTo("WriteLine")) + Assert.That(assembly.GetType("Generated.OrderedMap`2"),Is.Null) + Assert.That(assembly.GetType("Generated.TypeToken"),Is.Null) + let program=assembly.GetType("Generated.Program") |> nonNull + let helpers=program.GetMethods(BindingFlags.Static ||| BindingFlags.Public ||| BindingFlags.NonPublic ||| BindingFlags.DeclaredOnly) |> Array.map _.Name + Assert.That(helpers |> Array.exists (fun name -> name.StartsWith("Json",StringComparison.Ordinal) || name.StartsWith("Equal",StringComparison.Ordinal) || name.StartsWith("Encode",StringComparison.Ordinal) || name.StartsWith("Decode",StringComparison.Ordinal)),Is.False) + + [] + member _.``A warmed fully static numeric program allocates no managed values`` () = + let assembly=IL.load "export let compute (value: int) =\n let add x y=x+y\n let increment=add 1\n increment value" + let run=((assembly.GetType("Generated.Program") |> nonNull).GetProperty("v_compute") |> nonNull).GetValue(null) |> nonNull :?> Func + for input in 1..1000 do run.Invoke(int64 input) |> ignore + let before=GC.GetAllocatedBytesForCurrentThread() + let mutable result=0L + for input in 1..10000 do result <- run.Invoke(int64 input) + let allocated=GC.GetAllocatedBytesForCurrentThread()-before + Assert.That(result,Is.EqualTo(10001L)) + Assert.That(allocated,Is.Zero) + + [] + member _.``Redundant true checks disappear from IL while CSharp output retains its policy`` () = + let source="export let check value = value && true" + let program=Harness.compile source + let files=match CSharpBackend.generate {Namespace="Generated";ClassName="Program";References=[]} program with Ok files -> files | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + Assert.That((files |> List.find (fun file -> file.RelativePath="Runtime.cs")).Content,Does.Contain("public readonly record struct Unit")) + let instructions=IL.load source |> IL.instructions |> List.filter (fun (method,_,_) -> method.Name.StartsWith("Function",StringComparison.Ordinal) && method.ReturnType=typeof) + Assert.That(instructions,Is.Not.Empty) + Assert.That(instructions |> List.exists (fun (_,opcode,_) -> opcode=OpCodes.Ldc_I4_1),Is.False) + + [] + member _.``String replacement handles empty search and replacement strings`` () = + let source = "(String.replace \"\" \"x\" \"abc\", String.replace \"\" \"x\" \"\", String.replace \"a\" \"\" \"banana\", String.replace \"aa\" \"b\" \"aaaa\")" + Assert.That(Harness.execute (Harness.compile source), Is.EqualTo("(\"abc\", \"\", \"bnn\", \"bb\")")) + + [] + member _.``Closed library exports remain roots without a program entry`` () = + let assembly=IL.load "export let answer=42\nexport let add (value: int)=value+1" + let typ=assembly.GetType("Generated.Program") |> nonNull + Assert.That((typ.GetProperty("v_answer") |> nonNull).GetValue(null),Is.EqualTo(box 42L)) + let add=((typ.GetProperty("v_add") |> nonNull).GetValue(null) |> nonNull) :?> Func + Assert.That(add.Invoke(41L),Is.EqualTo(42L)) + + [] + member _.``Open polymorphic exports cannot silently disappear from native libraries`` () = + match DotNetBackend.generate Harness.options (Harness.compile "export let identity value=value") with + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code,Does.Contain("FSC6009")) + | Ok _ -> Assert.Fail("An exported open function needs a concrete native signature.") + + [] + [] + [] + [] + member _.``Aggregate construction and indexing preserve effect order`` (source: string) = + let capture action = + let previous=Console.Out + use output=new StringWriter() + try + Console.SetOut(output) + let result=action () + result,output.ToString() + finally Console.SetOut(previous) + let expected=capture (fun () -> Harness.legacy source) + let actual=capture (fun () -> Harness.execute (Harness.compile source)) + Assert.That(actual,Is.EqualTo(expected)) + Assert.That(snd actual,Is.EqualTo("first"+Environment.NewLine+"second"+Environment.NewLine)) + + [] + member _.``Filesystem globbing preserves relative paths and recursive selection`` () = + let previous=Directory.GetCurrentDirectory() + let directory=Path.Combine(Path.GetTempPath(),"fscript-native-fs-"+Guid.NewGuid().ToString("N")) + Directory.CreateDirectory(Path.Combine(directory,"nested")) |> ignore + File.WriteAllText(Path.Combine(directory,"root.txt"),"root") + File.WriteAllText(Path.Combine(directory,"nested","child.txt"),"child") + File.WriteAllText(Path.Combine(directory,"nested","skip.log"),"skip") + try + Directory.SetCurrentDirectory(directory) + let source="(Fs.glob \"**/*.txt\", Fs.enumerateFiles \"nested\" \"*.txt\", Fs.enumerateFiles \"missing\" \"*.txt\")" + Assert.That(Harness.execute (Harness.compile source),Is.EqualTo(Harness.legacy source)) + finally + Directory.SetCurrentDirectory(previous) + Directory.Delete(directory,true) + + [] + member _.``Exact CLR calls survive serialization`` () = + let external: CompilerExtern = {Name="Native.abs"; Scheme=Forall([],TFun(TInt,TInt)); Arity=1; Kind=UnsupportedHostExtern} + let compiled = + match Compiler.compile {Program=Parser.parseProgram "Native.abs (0-42)"; Externs=[external]} with + | Ok compiled -> compiled.Lir + | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + let method=typeof.GetMethod("Abs",[|typeof|]) |> nonNull + let linked=ClrBindings.bindMethod "Native.abs" method compiled + let linked=match IrArtifact.deserialize (IrArtifact.serialize linked) with Ok p -> p | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + Assert.That(Harness.execute linked, Is.EqualTo("42")) + + [] + member _.``Host managed CLR values support constructors properties and instance methods`` () = + let registration: ExtensionRegistration = + { Types=[{Name="Buffer"; Fields=Map.ofList ["Length",TInt]; HostManaged=true}]; Unions=[]; Functions=[] } + let externs: CompilerExtern list = + [ {Name="Native.create"; Scheme=Forall([],TFun(TString,TNamed "Buffer")); Arity=1; Kind=UnsupportedHostExtern} + {Name="Native.text"; Scheme=Forall([],TFun(TNamed "Buffer",TString)); Arity=1; Kind=UnsupportedHostExtern} ] + let program=match Compiler.compileWithRegistration registration {Program=Parser.parseProgram "let value = Native.create \"hello\"\n(value.Length, Native.text value)"; Externs=externs} with Ok p -> p.Lir | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + let native=typeof + let program=program |> ClrBindings.bindType "Buffer" native |> ClrBindings.bindMethod "Native.create" (native.GetConstructor([|typeof|]) |> nonNull) |> ClrBindings.bindMethod "Native.text" (native.GetMethod("ToString",[||]) |> nonNull) + Assert.That(Harness.execute program, Is.EqualTo("(5, \"hello\")")) + + [] + member _.``Roslyn produces deterministic portable PE files`` () = + let program=Harness.compile "40+2" + let first=Harness.generate Harness.options program + let second=Harness.generate Harness.options program + Assert.That((first=second), Is.True) + + [] + member _.``Missing managed references return diagnostics without emitting files`` () = + let program=Harness.compile "42" + let missing=Path.Combine(Path.GetTempPath(),Guid.NewGuid().ToString("N")+".dll") + Assert.That(DotNetBackend.generate {Harness.options with References=[missing]} program |> Result.isError,Is.True) + Assert.That(CSharpBackend.generate {Namespace="Generated";ClassName="Program";References=[missing]} program |> Result.isError,Is.True) + + [] + member _.``Executable publishing validates target and output kind before running the SDK`` () = + let program=Harness.compile "42" + let check executable options expected = + match DotNetBackend.generateExecutable executable options program with + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code,Does.Contain(expected)) + | Ok _ -> Assert.Fail("Invalid publishing options must fail before publishing.") + let current=System.Runtime.InteropServices.RuntimeInformation.RuntimeIdentifier + check {RuntimeIdentifier=current;AheadOfTime=false} Harness.options "FSN7101" + let console={Harness.options with OutputKind=ConsoleApplication} + check {RuntimeIdentifier="darwin";AheadOfTime=false} console "FSN7101" + let foreign=if OperatingSystem.IsWindows() then "linux-x64" else "win-x64" + check {RuntimeIdentifier=foreign;AheadOfTime=true} console "FSN7104" + + [] + member _.``Invalid Apple runtime spelling identifies the .NET spelling`` () = + let options={Harness.options with OutputKind=ConsoleApplication} + match DotNetBackend.generateExecutable {RuntimeIdentifier="darwin-arm64";AheadOfTime=true} options (Harness.compile "42") with + | Ok _ -> Assert.Fail("An invalid runtime identifier must not reach SDK publishing.") + | Error diagnostics -> + Assert.That(diagnostics.Head.Code,Is.EqualTo("FSN7101")) + Assert.That(diagnostics.Head.Message,Does.Contain("'darwin-arm64'")) + Assert.That(diagnostics.Head.Message,Does.Contain("use 'osx-arm64'")) + + [] + member _.``Unused provider references and unresolved external types are omitted`` () = + let registration: ExtensionRegistration={Types=[{Name="Unused";Fields=Map.ofList ["Value",TInt];HostManaged=true}];Unions=[];Functions=[]} + let program=match Compiler.compileWithRegistration registration {Program=Parser.parseProgram "42";Externs=[]} with Ok p -> p.Lir | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + let imported: Lir.ImportedRecord={Name="Unused";ModulePath="clr:Missing.Type, Missing.Assembly";MemberName="Missing.Type";Fields=["Value",TInt];IsUnion=false;Span=program.Types.Head.Span} + let program={program with ImportedRecords=[imported];Types=program.Types |> List.map (fun t -> if t.Name="Unused" then {t with Import=Some imported} else t)} + let files=Harness.generate {Harness.options with References=[typeof.Assembly.Location]} program + Assert.That(files.Length,Is.EqualTo(1)) + let assembly=Assembly.Load(files.Head.Content) + Assert.That(assembly.GetReferencedAssemblies() |> Array.exists (fun reference -> List.contains reference.Name ["FScript.Extensibility";"FSharp.Core";"FScript.Backend.DotNet.Tests"]),Is.False) + + [] + member _.``AOT rejects reachable legacy SDK dispatch with a static binding diagnostic`` () = + let registration=ProviderFixture.Provider.Provide() |> FScript.Runtime.ExtensionBridge.toLanguageRegistration + let program=match Compiler.compileWithRegistration registration {Program=Parser.parseProgram "Sdk.apply (fun n -> n+1) 41";Externs=[]} with Ok p -> p.Lir | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + let program=ClrBindings.bindProvider ["Sdk.apply"] (typeof.GetMethod("Provide") |> nonNull) program + let options={Harness.options with OutputKind=ConsoleApplication;References=[typeof.Assembly.Location;typeof.Assembly.Location;typeof.Assembly.Location]} + match DotNetBackend.generateExecutable {RuntimeIdentifier=System.Runtime.InteropServices.RuntimeInformation.RuntimeIdentifier;AheadOfTime=true} options program with + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code,Does.Contain("FSN7105")) + | Ok _ -> Assert.Fail("Opaque factory dispatch requires a static binding for Native AOT.") + + [] + member _.``Dependency pruning uses assembly identity rather than a renamed filename`` () = + let registration=ProviderFixture.Provider.Provide() |> FScript.Runtime.ExtensionBridge.toLanguageRegistration + let program=match Compiler.compileWithRegistration registration {Program=Parser.parseProgram "Sdk.apply (fun n -> n+1) 41";Externs=[]} with Ok p -> p.Lir | Error errors -> failwith (String.concat "; " (errors |> List.map _.Message)) + let program=ClrBindings.bindProvider ["Sdk.apply"] (typeof.GetMethod("Provide") |> nonNull) program + let references=[typeof.Assembly.Location;typeof.Assembly.Location;typeof.Assembly.Location] + let root=Harness.generate {Harness.options with References=references} program |> List.find (fun file -> file.RelativePath="CompiledScript.dll") + let renamed=Path.Combine(Path.GetTempPath(),"renamed-provider-"+Guid.NewGuid().ToString("N")+".dll") + try + File.Copy(typeof.Assembly.Location,renamed) + Assert.That(String.concat "," (ClrBindings.referencedDependencies root.Content [renamed]),Is.EqualTo(renamed)) + let options={Harness.options with References=renamed :: (List.tail references)} + let files=Harness.generate options program + Assert.That(files |> List.map _.RelativePath,Does.Contain("FScript.Backend.DotNet.Tests.dll")) + finally File.Delete renamed + + [] + member _.``CSharp projects compile independently`` () = + let source=Harness.compile "[1..3] |> List.map (fun n -> n+1)" + let files=match CSharpBackend.generate {Namespace="Generated"; ClassName="Program"; References=[]} source with Ok f -> f | Error e -> failwith (String.concat "; " (e |> List.map _.Message)) + let directory=Path.Combine(Path.GetTempPath(), "fscript-csharp-"+Guid.NewGuid().ToString("N")) + try + Directory.CreateDirectory directory |> ignore + for file in files do File.WriteAllText(Path.Combine(directory,file.RelativePath),file.Content) + File.WriteAllText(Path.Combine(directory,"Unused.cs"),"This stale file is not part of the generated project.") + let start=Diagnostics.ProcessStartInfo("dotnet",WorkingDirectory=directory,RedirectStandardOutput=true,RedirectStandardError=true) + start.ArgumentList.Add("run") + start.ArgumentList.Add("--project") + start.ArgumentList.Add("Program.csproj") + use proc=Diagnostics.Process.Start(start) |> nonNull + let output=proc.StandardOutput.ReadToEnd() + let error=proc.StandardError.ReadToEnd() + Assert.That(proc.WaitForExit(60000),Is.True) + Assert.That(proc.ExitCode,Is.EqualTo(0),output+error) + Assert.That(output.Trim(),Is.EqualTo("[2;3;4]")) + finally + if Directory.Exists directory then Directory.Delete(directory,true) + + [] + [] + member _.``Compiled library status is observable without changing host process status`` noResult = + let original=Environment.ExitCode + let program=Harness.compile "Env.setExitCode 7\n42" + let files=match DotNetBackend.generateWithResultOutput (not noResult) Harness.options program with Ok files -> files | Error errors -> failwith (string errors) + let assembly=Assembly.Load((files |> List.find (fun file -> file.RelativePath="CompiledScript.dll")).Content) + let typ=assembly.GetType("Generated.Program") |> nonNull + let value=(typ.GetMethod("Run") |> nonNull).Invoke(null,[||]) + Assert.That((typ.GetProperty("ExitCode") |> nonNull).GetValue(null),Is.EqualTo(box 7)) + Assert.That(Environment.ExitCode,Is.EqualTo(original)) + if not noResult then Assert.That(value,Is.EqualTo(box 42L)) diff --git a/tests/FScript.Backend.DotNet.Tests/FScript.Backend.DotNet.Tests.fsproj b/tests/FScript.Backend.DotNet.Tests/FScript.Backend.DotNet.Tests.fsproj new file mode 100644 index 0000000..59e88d5 --- /dev/null +++ b/tests/FScript.Backend.DotNet.Tests/FScript.Backend.DotNet.Tests.fsproj @@ -0,0 +1,13 @@ + + net10.0falsefalse + + + + + + + + + + + diff --git a/tests/FScript.Backend.DotNet.Tests/Program.fs b/tests/FScript.Backend.DotNet.Tests/Program.fs new file mode 100644 index 0000000..00d05a5 --- /dev/null +++ b/tests/FScript.Backend.DotNet.Tests/Program.fs @@ -0,0 +1,3 @@ +module FScript.Backend.DotNet.Tests.Program +[] +let main _ = 0 diff --git a/tests/FScript.Cli.Tests.Fixtures.Valid/Providers.fs b/tests/FScript.Cli.Tests.Fixtures.Valid/Providers.fs index 0fc16ce..bc59f14 100644 --- a/tests/FScript.Cli.Tests.Fixtures.Valid/Providers.fs +++ b/tests/FScript.Cli.Tests.Fixtures.Valid/Providers.fs @@ -3,6 +3,9 @@ namespace FScript.Cli.Tests.Fixtures.Valid open FScript.Extensibility type ValidExternProvider = + static member AnswerNative() = 42L + static member FScriptCompiledFunctions() : System.Collections.Generic.IEnumerable> = + [|System.Collections.Generic.KeyValuePair("Ext.answer",typeof.GetMethod("AnswerNative") |> nonNull)|] [] static member Provide() : ExternalFunction list = [ { Name = "Ext.answer" @@ -47,3 +50,29 @@ type HostManagedProvider = if node.Context = ctx then node.Value else failwith "Host state was lost") HostFunctions.create registration "Ext.acceptPoint" (fun (point: ProviderPoint) -> point.X) ] } + +[] +type NativeCounter(value: int64) = + [] + member _.Value=value + +type CompiledProvider = + static member Create(value: int64) = NativeCounter(value) + static member Read(value: NativeCounter) = value.Value + static member FScriptPureFunctions() : System.Collections.Generic.IEnumerable = + [| "Ext.createCounter"; "Ext.readCounter" |] + static member FScriptPureTypes() : System.Collections.Generic.IEnumerable = + [| "NativeCounter" |] + // This method must never become an AOT root merely because its provider is loaded. + static member Unused() = System.Reflection.Assembly.Load("Not.A.Runtime.Dependency") |> ignore; 0L + [] + static member Provide() : ExtensionRegistration = + let registration={HostInterop.empty with Types=[HostTypes.describe()]} + {registration with Functions=[HostFunctions.create registration "Ext.createCounter" CompiledProvider.Create + HostFunctions.create registration "Ext.readCounter" CompiledProvider.Read + HostFunctions.create registration "Ext.unusedNative" (fun () -> CompiledProvider.Unused())]} + static member FScriptCompiledTypes() : System.Collections.Generic.IEnumerable> = + [|System.Collections.Generic.KeyValuePair("NativeCounter",typeof)|] + static member FScriptCompiledFunctions() : System.Collections.Generic.IEnumerable> = + [| for name,methodName in ["Ext.createCounter","Create";"Ext.readCounter","Read";"Ext.unusedNative","Unused"] do + yield System.Collections.Generic.KeyValuePair(name,typeof.GetMethod(methodName) |> nonNull) |] diff --git a/tests/FScript.Cli.Tests/CliTests.fs b/tests/FScript.Cli.Tests/CliTests.fs index 35f90c4..c2ad07f 100644 --- a/tests/FScript.Cli.Tests/CliTests.fs +++ b/tests/FScript.Cli.Tests/CliTests.fs @@ -117,6 +117,185 @@ type CliTests() = Assert.That(code, Is.EqualTo(0), $"stderr: {stderr}") Assert.That(Regex.IsMatch(stdout.Trim(), "^\\d+\\.\\d+\\.\\d+"), Is.True) + [] + member _.``Compiles a whole program to versioned IR`` () = + let repoRoot = findRepoRoot () + let tempRoot = Path.Combine(Path.GetTempPath(), $"fscript-compile-ir-{Guid.NewGuid():N}") + let script = Path.Combine(tempRoot, "program.fss") + let output = Path.Combine(tempRoot, "out") + try + Directory.CreateDirectory(tempRoot) |> ignore + File.WriteAllText(script, "let add x y = x + y\nadd 1 2") + let code, _, stderr = runCli repoRoot repoRoot [ "compile"; script; "--target"; "ir"; "--output"; output ] None + Assert.That(code, Is.EqualTo(0), stderr) + let artifact = Path.Combine(output, "program.fsir") + Assert.That(File.Exists artifact, Is.True) + let expected = File.ReadAllBytes(artifact) + Assert.That(File.ReadAllText(artifact), Does.Contain("\"format\": \"fscript-lir\"")) + File.WriteAllText(artifact, "stale") + let secondCode, _, secondError = runCli repoRoot repoRoot [ "compile"; script; "--target"; "ir"; "--output"; output ] None + Assert.That(secondCode, Is.EqualTo(0), secondError) + Assert.That(File.ReadAllBytes(artifact) = expected, Is.True, "IR compilation must deterministically replace an existing artifact") + finally + if Directory.Exists tempRoot then Directory.Delete(tempRoot, true) + + [] + [] + member _.``Native targets produce independently runnable programs with FFI`` (target: string) = + let repoRoot = findRepoRoot () + let tempRoot = Path.Combine(Path.GetTempPath(), $"fscript-native-cli-{Guid.NewGuid():N}") + Directory.CreateDirectory(tempRoot) |> ignore + try + let script=Path.Combine(tempRoot,"native.fss") + File.WriteAllText(script,"Console.writeLine (Int.toString Ext.answer)") + let output=Path.Combine(tempRoot,"output") + let code,_,error=runCli repoRoot tempRoot ["compile";script;"--target";target;"--output";output;"--no-result";"--extern-assembly";validProviderAssemblyPath()] None + Assert.That(code,Is.Zero,error) + let start=ProcessStartInfo("dotnet",WorkingDirectory=tempRoot,RedirectStandardOutput=true,RedirectStandardError=true) + if target="dotnet" then start.ArgumentList.Add(Path.Combine(output,"native.dll")) + else + start.ArgumentList.Add("run") + start.ArgumentList.Add("--project") + start.ArgumentList.Add(Path.Combine(output,"Program.csproj")) + use proc=new Process(StartInfo=start) + proc.Start() |> ignore + let stdout=proc.StandardOutput.ReadToEnd() + let stderr=proc.StandardError.ReadToEnd() + proc.WaitForExit() + Assert.That(proc.ExitCode,Is.Zero,stdout+stderr) + Assert.That(stdout.Trim(),Is.EqualTo("42")) + Assert.That(File.Exists(Path.Combine(output,"FScript.Runtime.dll")),Is.False) + finally Directory.Delete(tempRoot,true) + + [] + member _.``Pure provider calls and their dependencies are pruned from native output`` () = + let root=findRepoRoot () + let directory=Path.Combine(Path.GetTempPath(),"fscript-pure-provider-"+Guid.NewGuid().ToString("N")) + Directory.CreateDirectory(directory) |> ignore + try + let script=Path.Combine(directory,"pure.fss") + File.WriteAllText(script,"let discarded = Ext.readCounter (Ext.createCounter 7)\n42") + let output=Path.Combine(directory,"output") + let args=["compile";script;"--target";"dotnet";"--output";output;"--no-result";"--extern-assembly";validProviderAssemblyPath()] + let code,_,error=runCli root directory args None + Assert.That(code,Is.Zero,error) + Assert.That(Directory.GetFiles(output) |> Array.map Path.GetFileName,Is.EquivalentTo([|"pure.dll";"pure.runtimeconfig.json"|])) + let start=ProcessStartInfo("dotnet",RedirectStandardOutput=true,RedirectStandardError=true) + start.ArgumentList.Add(Path.Combine(output,"pure.dll")) + use proc=new Process(StartInfo=start) + proc.Start() |> ignore + let stdout=proc.StandardOutput.ReadToEnd() + let stderr=proc.StandardError.ReadToEnd() + proc.WaitForExit() + Assert.That(proc.ExitCode,Is.Zero,stderr) + Assert.That(stdout,Is.Empty) + let irOutput=Path.Combine(directory,"ir") + let code,_,error=runCli root directory ["compile";script;"--target";"ir";"--output";irOutput;"--extern-assembly";validProviderAssemblyPath()] None + Assert.That(code,Is.Zero,error) + Assert.That(File.ReadAllText(Path.Combine(irOutput,"pure.fsir")),Does.Contain("\"pure\": true")) + finally Directory.Delete(directory,true) + + [] + [] + [] + member _.``Invalid compile target does not create output`` (target: string) = + let repoRoot = findRepoRoot () + let tempRoot = Path.Combine(Path.GetTempPath(), $"fscript-compile-invalid-{Guid.NewGuid():N}") + let script = Path.Combine(tempRoot, "program.fss") + let output = Path.Combine(tempRoot, "out") + try + Directory.CreateDirectory(tempRoot) |> ignore + File.WriteAllText(script, "1") + let code, _, stderr = runCli repoRoot repoRoot [ "compile"; script; "--target"; target; "--output"; output ] None + Assert.That(code, Is.EqualTo(1)) + Assert.That(stderr, Does.Contain("Usage: fscript compile")) + Assert.That(Directory.Exists(output), Is.False) + finally + if Directory.Exists tempRoot then Directory.Delete(tempRoot, true) + + [] + [] + [] + [] + member _.``Executable options reject invalid combinations before creating output`` (target: string, flag: string) = + let root=findRepoRoot () + let output=Path.Combine(Path.GetTempPath(),"fscript-invalid-publish-"+Guid.NewGuid().ToString("N")) + let code,_,error=runCli root root ["compile";Path.Combine(root,"samples","hello.fss");"--target";target;"--output";output;flag] None + Assert.That(code,Is.EqualTo(1),error) + Assert.That(Directory.Exists output,Is.False) + + [] + [] + member _.``Explicit runtime options still require a value`` flag = + let root=findRepoRoot () + let output=Path.Combine(Path.GetTempPath(),"fscript-missing-rid-"+Guid.NewGuid().ToString("N")) + let code,_,error=runCli root root ["compile";Path.Combine(root,"samples","hello.fss");"--target";"dotnet";"--output";output;flag;"--runtime"] None + Assert.That(code,Is.EqualTo(1),error) + Assert.That(error,Does.Contain("--runtime requires a value")) + Assert.That(Directory.Exists output,Is.False) + + [] + [] + [] + member _.``Invalid runtime identifiers report a FScript diagnostic without SDK publishing`` (rid: string, aot: bool) = + let root=findRepoRoot () + let output=Path.Combine(Path.GetTempPath(),"fscript-invalid-rid-"+Guid.NewGuid().ToString("N")) + try + let flags=if aot then ["--single-file";"--aot"] else ["--single-file"] + let code,_,error=runCli root root (["compile";Path.Combine(root,"samples","hello.fss");"--target";"dotnet";"--output";output;"--runtime";rid] @ flags) None + Assert.That(code,Is.EqualTo(4),error) + Assert.That(error,Does.Contain("FSN7101")) + Assert.That(error,Does.Contain($"'{rid}'")) + Assert.That(error,Does.Contain("osx-arm64")) + Assert.That(error,Does.Not.Contain("NETSDK")) + Assert.That((if Directory.Exists output then Directory.GetFiles(output) else [||]),Is.Empty) + finally + if Directory.Exists output then Directory.Delete(output,true) + + [] + [] + [] + [] + member _.``Self contained executables support default and explicit runtimes and run alone`` (flag: string, ffi: bool) = + let root=findRepoRoot () + let directory=Path.Combine(Path.GetTempPath(),"fscript-contained-"+Guid.NewGuid().ToString("N")) + Directory.CreateDirectory(directory) |> ignore + try + let script=Path.Combine(directory,"native.fss") + let output=Path.Combine(directory,"output") + let standalone=Path.Combine(directory,"standalone") + Directory.CreateDirectory(standalone) |> ignore + let source=if ffi then "Console.writeLine (Int.toString (Ext.readCounter (Ext.createCounter (Ext.answer - 1)) + 1))\n42" else "Console.writeLine (Option.defaultValue \"missing\" (Json.serialize \"hello\"))\nConsole.writeLine (Option.defaultValue \"missing\" Env.ScriptName)\nConsole.writeLine $\"{Env.Arguments}\"" + File.WriteAllText(script,"Env.setExitCode 7\n"+source) + let runtimeArgs=if ffi then ["--runtime";System.Runtime.InteropServices.RuntimeInformation.RuntimeIdentifier] else [] + let args=["compile";script;"--target";"dotnet";"--output";output;"--no-result";flag] @ runtimeArgs @ (if ffi then ["--extern-assembly";validProviderAssemblyPath()] else []) + let code,_,error=runCli root directory args None + Assert.That(code,Is.Zero,error) + let name="native"+(if OperatingSystem.IsWindows() then ".exe" else "") + let files=Directory.GetFiles(output) + Assert.That(files.Length,Is.EqualTo(1)) + let executable=Path.Combine(standalone,name) + File.Copy(Path.Combine(output,name),executable) + if not (OperatingSystem.IsWindows()) then File.SetUnixFileMode(executable,File.GetUnixFileMode(Path.Combine(output,name))) + Directory.Delete(output,true) + File.Delete(script) + let start=ProcessStartInfo(executable,WorkingDirectory=standalone,RedirectStandardOutput=true,RedirectStandardError=true) + start.ArgumentList.Add("hello") + let missingRuntime=Path.Combine(directory,"missing-runtime") + start.Environment.["DOTNET_ROOT"] <- missingRuntime + start.Environment.["DOTNET_ROOT_ARM64"] <- missingRuntime + start.Environment.["DOTNET_ROOT_X64"] <- missingRuntime + start.Environment.["DOTNET_MULTILEVEL_LOOKUP"] <- "0" + use proc=new Process(StartInfo=start) + proc.Start() |> ignore + let stdout=proc.StandardOutput.ReadToEnd() + let stderr=proc.StandardError.ReadToEnd() + Assert.That(proc.WaitForExit(60000),Is.True) + Assert.That(proc.ExitCode,Is.EqualTo(7),stdout+stderr) + let expected=if ffi then "42" else "\"hello\"\n"+name+"\n[hello]" + Assert.That(stdout.Replace("\r\n","\n").Trim(),Is.EqualTo(expected)) + finally Directory.Delete(directory,true) + [] member _.``No args with redirected stdin executes stdin mode`` () = let repoRoot = findRepoRoot () @@ -299,7 +478,28 @@ type CliTests() = let code, _, stderr = runCli repoRoot repoRoot [ scriptPath ] None Assert.That(code, Is.EqualTo(3)) - Assert.That(stderr, Does.Contain("Usage: fscript samples/basic/basic.fss -- ")) + Assert.That(stderr, Does.Contain("Usage: basic.fss ")) + Assert.That(stderr, Does.Not.Contain("Usage: fscript")) + + [] + member _.``Compiled BASIC usage identifies its standalone assembly`` () = + let repoRoot=findRepoRoot () + let output=Path.Combine(Path.GetTempPath(),"fscript-basic-native-"+Guid.NewGuid().ToString("N")) + try + let code,_,error=runCli repoRoot repoRoot ["compile";basicSampleScriptPath repoRoot;"--target";"dotnet";"--output";output] None + Assert.That(code,Is.Zero,error) + let start=ProcessStartInfo("dotnet",WorkingDirectory=repoRoot,RedirectStandardOutput=true,RedirectStandardError=true) + start.ArgumentList.Add(Path.Combine(output,"basic.dll")) + use proc=new Process(StartInfo=start) + proc.Start() |> ignore + let stdout=proc.StandardOutput.ReadToEnd() + let stderr=proc.StandardError.ReadToEnd() + proc.WaitForExit() + Assert.That(proc.ExitCode,Is.Not.Zero,stdout+stderr) + Assert.That(stderr,Does.Contain("Usage: basic.dll ")) + Assert.That(stderr,Does.Not.Contain("Usage: fscript")) + finally + if Directory.Exists(output) then Directory.Delete(output,true) [] member _.``Basic sample reports invalid BASIC source`` () = @@ -512,3 +712,55 @@ type CliTests() = Assert.That(code,Is.Zero,error) Assert.That(output.Trim(),Is.EqualTo("[\"--debug-adapter\"]")) finally File.Delete script + + [] + [] + member _.``Interpreted status is independent of result display`` noResult = + let root=findRepoRoot () + let arguments=if noResult then ["--no-result"] else [] + let code,output,error=runCli root root arguments (Some "Env.setExitCode 7\nEnv.setExitCode 9\nConsole.writeLine \"after\"\n42") + Assert.That(code,Is.EqualTo(9),error) + Assert.That(error,Is.Empty) + Assert.That(output.Replace("\r\n","\n").Trim(),Is.EqualTo(if noResult then "after" else "after\n42")) + + [] + [] + [] + [] + member _.``Compiled status and result policy match scripting`` (target: string,noResult: bool) = + let root=findRepoRoot () + let directory=Path.Combine(Path.GetTempPath(),"fscript-status-"+Guid.NewGuid().ToString("N")) + Directory.CreateDirectory(directory) |> ignore + try + let script=Path.Combine(directory,"status.fss") + File.WriteAllText(script,"Env.setExitCode 7\nConsole.writeLine \"after\"\n42") + let output=Path.Combine(directory,"output") + let flags=if noResult then ["--no-result"] else [] + let code,_,error=runCli root directory (["compile";script;"--target";target;"--output";output] @ flags) None + Assert.That(code,Is.Zero,error) + let start=ProcessStartInfo("dotnet",WorkingDirectory=directory,RedirectStandardOutput=true,RedirectStandardError=true) + let args=if target="dotnet" then [Path.Combine(output,"status.dll")] else ["run";"--project";Path.Combine(output,"Program.csproj")] + for argument in args do start.ArgumentList.Add(argument) + use proc=Process.Start(start) |> nonNull + let stdout=proc.StandardOutput.ReadToEndAsync() + let stderr=proc.StandardError.ReadToEndAsync() + Assert.That(proc.WaitForExit(60000),Is.True) + Assert.That(proc.ExitCode,Is.EqualTo(7),stderr.Result) + Assert.That(stdout.Result.Replace("\r\n","\n").Trim(),Is.EqualTo(if noResult then "after" else "after\n42")) + finally Directory.Delete(directory,true) + + [] + member _.``Quiet display does not suppress failure or replace failure with selected status`` () = + let root=findRepoRoot () + let code,output,error=runCli root root ["--no-result"] (Some "Env.setExitCode 7\nraise \"boom\"") + Assert.That(code,Is.EqualTo(3)) + Assert.That(output,Is.Empty) + Assert.That(error,Does.Contain("boom")) + + [] + member _.``No-result is a build option and is not accepted for IR artifacts`` () = + let root=findRepoRoot () + let output=Path.Combine(Path.GetTempPath(),"fscript-no-result-ir-"+Guid.NewGuid().ToString("N")) + let code,_,error=runCli root root ["compile";Path.Combine(root,"samples","hello.fss");"--target";"ir";"--no-result";"--output";output] None + Assert.That(code,Is.EqualTo(1),error) + Assert.That(Directory.Exists output,Is.False) diff --git a/tests/FScript.Compiler.Tests/CseTests.fs b/tests/FScript.Compiler.Tests/CseTests.fs new file mode 100644 index 0000000..49e17c9 --- /dev/null +++ b/tests/FScript.Compiler.Tests/CseTests.fs @@ -0,0 +1,185 @@ +namespace FScript.Compiler.Tests + +open System +open FScript.Compiler +open FScript.Language +open NUnit.Framework + +[] +type CseTests() = + let span=Span.mk (Span.pos 0 0) (Span.pos 0 0) + let expr t node : Lir.Expression={Type=t;Span=span;Node=node} + let number n=expr TInt (Lir.Constant(Lir.Int n)) + let load id=expr TInt (Lir.Load(Lir.SymbolId id)) + let add a b=expr TInt (Lir.Operation(Lir.IntAdd,[a;b])) + let tuple values=expr (TTuple(List.map (fun (v: Lir.Expression) -> v.Type) values)) (Lir.Tuple values) + let empty entry : Lir.Program={Types=[];ImportedRecords=[];Functions=[];Declarations=[];Entry=Some entry} + let count label program=(Lir.format program).Split('\n') |> Array.filter (fun line -> line.TrimStart().StartsWith(label,StringComparison.Ordinal)) |> Array.length + let optimize p=LirCommonSubexpressions.optimize p + let compile externs purity source = + let p=match Compiler.compileWithPurity purity {Program=Parser.parseProgram source;Externs=externs} with Ok p -> p.Lir | Error errors -> failwith (string errors) + let p=match LirMonomorphization.specialize p with Ok p -> p | Error errors -> failwith (string errors) + LirSimplification.optimize p + let host={Name="Host.calculate";Scheme=Forall([],TFun(TInt,TInt));Arity=1;Kind=UnsupportedHostExtern} + let pureHost={PurityContracts.empty with PureFunctions=Set.singleton host.Name} + let validated p=match LirValidation.validate p with Ok _ -> () | Error errors -> Assert.Fail(string errors) + + [] + member _.``Repeated nested expressions share one evaluation despite different spans`` () = + let first=add (number 1L) (number 2L) + let second={first with Span=Span.mk (Span.pos 2 1) (Span.pos 2 4)} + let p=empty (tuple [first;second]) |> optimize + Assert.That(count "operation IntAdd" p,Is.EqualTo(1)) + Assert.That(count "let " p,Is.EqualTo(1)) + validated p + + [] + member _.``Unshared computations retain their original shape`` () = + let p=empty (add (number 1L) (number 2L)) + Assert.That(Lir.format (optimize p),Is.EqualTo(Lir.format p)) + + [] + member _.``Branches neither hoist nor leak available expressions`` () = + let work=add (number 1L) (number 2L) + let branch=expr TInt (Lir.Branch(expr TBool (Lir.Constant(Lir.Bool true)),work,work)) + let p=empty (tuple [branch;work]) |> optimize + Assert.That(count "operation IntAdd" p,Is.EqualTo(3)) + Assert.That(count "let " p,Is.EqualTo(0)) + validated p + + [] + member _.``Dominating computation is available in both branches`` () = + let work=add (number 1L) (number 2L) + let branch=expr TInt (Lir.Branch(expr TBool (Lir.Constant(Lir.Bool true)),work,work)) + let p=empty (tuple [work;branch]) |> optimize + Assert.That(count "operation IntAdd" p,Is.EqualTo(1)) + validated p + + [] + [] + member _.``FFI calls share only with a pure contract`` isPure = + let original=compile [host] (if isPure then pureHost else PurityContracts.empty) "(Host.calculate 7, Host.calculate 7)" + let optimized=optimize original + Assert.That(count "call-closure" optimized,Is.EqualTo(if isPure then 1 else 2)) + validated optimized + + [] + member _.``Observable work is a reuse barrier`` () = + let original=compile [host] pureHost "(Host.calculate 7,Console.writeLine \"between\",Host.calculate 7)" + Assert.That(count "call-closure" (optimize original),Is.EqualTo(3)) + + [] + member _.``Aliases and top-level declarations preserve value numbers`` () = + let original=compile [host] pureHost "let first=Host.calculate 7\nlet alias=first\n(alias,Host.calculate 7)" + let optimized=optimize original + Assert.That(count "call-closure" optimized,Is.EqualTo(1)) + validated optimized + + [] + member _.``Pattern guards invalidate availability for following alternatives`` () = + let original=compile [host] pureHost "let first=Host.calculate 7\nlet guard () =\n Console.writeLine \"guard\"\n false\n(first, match 1 with | n when guard () -> 0 | _ -> Host.calculate 7)" + let optimized=optimize original + Assert.That(count "call-closure" optimized,Is.GreaterThanOrEqualTo(3)) + validated optimized + + [] + member _.``Function bodies cannot reuse values from another invocation`` () = + let original=compile [host] pureHost "let work value = (Host.calculate value,Host.calculate value)\n(work 1,work 2)" + let optimized=optimize original + Assert.That(count "call-closure" optimized,Is.EqualTo(3)) + validated optimized + + [] + member _.``Signed floating zero keys remain distinct`` () = + let float n=expr TFloat (Lir.Constant(Lir.Float n)) + let divide n=expr TFloat (Lir.Operation(Lir.FloatDivide,[float 1.;float n])) + let optimized=empty (tuple [divide 0.;divide -0.]) |> optimize + Assert.That(count "operation FloatDivide" optimized,Is.EqualTo(2)) + + [] + member _.``NaN payloads have reflexive bit-exact keys`` () = + let n=BitConverter.Int64BitsToDouble(0x7ff8000000000001L) + let work=expr TFloat (Lir.Operation(Lir.FloatAdd,[expr TFloat (Lir.Constant(Lir.Float n));expr TFloat (Lir.Constant(Lir.Float 1.))])) + let optimized=empty (tuple [work;work]) |> optimize + Assert.That(count "operation FloatAdd" optimized,Is.EqualTo(1)) + + [] + member _.``Potential failures are neither shared nor speculated`` () = + let work=expr TInt (Lir.Operation(Lir.IntDivide,[number 1L;number 0L])) + let optimized=empty (tuple [work;work]) |> optimize + Assert.That(count "operation IntDivide" optimized,Is.EqualTo(2)) + + [] + member _.``Optimization is deterministic and idempotent`` () = + let original=compile [host] pureHost "let work n = (Host.calculate (n+1),Host.calculate (n+1))\nwork 7" + let optimized=optimize original + Assert.That(Lir.format (optimize original),Is.EqualTo(Lir.format optimized)) + Assert.That(Lir.format (optimize optimized),Is.EqualTo(Lir.format optimized)) + validated optimized + + [] + member _.``Short circuit right operands stay conditional`` () = + let work=expr TBool (Lir.Operation(Lir.StructuralEqual,[add (number 1L) (number 2L);number 3L])) + let conditional=expr TBool (Lir.Operation(Lir.BooleanAnd,[expr TBool (Lir.Constant(Lir.Bool false));work])) + let p=empty (tuple [conditional;work]) |> optimize + Assert.That(count "operation IntAdd" p,Is.EqualTo(2)) + Assert.That(count "let " p,Is.EqualTo(0)) + validated p + + [] + member _.``Loop iterations and following expressions have separate availability`` () = + let work=add (load 100) (number 1L) + let body=tuple [work;work] + let source=expr (TList TInt) (Lir.List [number 1L;number 2L]) + let loop=expr TUnit (Lir.ForEach(Lir.SymbolId 100,"item",TInt,source,body)) + let p=empty loop |> optimize + Assert.That(count "operation IntAdd" p,Is.EqualTo(1)) + validated p + + [] + member _.``Pure calls with effectful arguments remain distinct`` () = + let arg={Name="Host.input";Scheme=Forall([],TFun(TUnit,TInt));Arity=1;Kind=UnsupportedHostExtern} + let original=compile [host;arg] pureHost "(Host.calculate (Host.input ()),Host.calculate (Host.input ()))" + let p=optimize original + Assert.That(count "call-closure" p,Is.EqualTo(4)) + validated p + + [] + [] + member _.``External observations require immutable type contracts for reuse`` isPure = + let registration={HostInterop.empty with Types=[{Name="Handle";Fields=Map.ofList ["Value",TInt];HostManaged=true}]} + let host={Name="Host.obtain";Scheme=Forall([],TFun(TUnit,TNamed "Handle"));Arity=1;Kind=UnsupportedHostExtern} + let contracts=if isPure then {PurityContracts.empty with PureTypes=Set.singleton "Handle"} else PurityContracts.empty + let p=match Compiler.compileWithRegistrationAndPurity registration contracts {Program=Parser.parseProgram "let handle=Host.obtain ()\n(handle.Value,handle.Value)";Externs=[host]} with Ok p -> p.Lir | Error errors -> failwith (string errors) + let p=match LirMonomorphization.specialize p with Ok p -> p | Error errors -> failwith (string errors) + let p=LirSimplification.optimize p |> optimize + Assert.That(count "field-get Value" p,Is.EqualTo(if isPure then 1 else 2)) + validated p + + [] + member _.``CSE snapshot has stable lexical bindings`` () = + let work=add (number 1L) (number 2L) + let p=empty (tuple [work;work]) |> optimize + let expected=IO.File.ReadAllText(IO.Path.Combine(__SOURCE_DIRECTORY__,"Snapshots","cse.lir")).Replace("\r\n","\n") + Assert.That(Lir.format p,Is.EqualTo(expected)) + + [] + member _.``Function-containing aggregates are not value-numbered`` () = + let fn: Lir.Function={Id=Lir.FunctionId 0;Parameter=Lir.SymbolId 42;Name="identity";ParameterType=TInt;ReturnType=TInt;Captures=[];Span=span;Body=load 42} + let closure=expr (TFun(TInt,TInt)) (Lir.MakeClosure(fn.Id,[])) + let inner=tuple [closure;number 1L] + let p={empty (tuple [inner;inner]) with Functions=[fn]} |> optimize + Assert.That(count "tuple" p,Is.EqualTo(3)) + Assert.That(count "let " p,Is.Zero) + validated p + + [] + member _.``Separately constructed callback handles do not acquire equal value numbers`` () = + let fn: Lir.Function={Id=Lir.FunctionId 0;Parameter=Lir.SymbolId 42;Name="identity";ParameterType=TInt;ReturnType=TInt;Captures=[];Span=span;Body=load 42} + let callback=expr (TFun(TInt,TInt)) (Lir.MakeClosure(fn.Id,[])) + let external=expr (TFun(callback.Type,TInt)) (Lir.HostExternal("Host.inspect",1)) + let binding: Lir.Declaration={Id=Lir.SymbolId 100;Name="Host.inspect";Type=external.Type;IsRecursive=false;IsExported=false;IsPure=true;ExternalArity=Some 1;Export=None;Span=span;Value=external} + let call=expr TInt (Lir.CallClosure(external,callback)) + let p={empty (tuple [call;call]) with Functions=[fn];Declarations=[binding]} |> optimize + Assert.That(count "call-closure" p,Is.EqualTo(2)) + validated p diff --git a/tests/FScript.Compiler.Tests/FScript.Compiler.Tests.fsproj b/tests/FScript.Compiler.Tests/FScript.Compiler.Tests.fsproj new file mode 100644 index 0000000..6760ca8 --- /dev/null +++ b/tests/FScript.Compiler.Tests/FScript.Compiler.Tests.fsproj @@ -0,0 +1,22 @@ + + + net10.0 + false + false + + + + + + + + + + + + + + + + + diff --git a/tests/FScript.Compiler.Tests/HirTests.fs b/tests/FScript.Compiler.Tests/HirTests.fs new file mode 100644 index 0000000..a712460 --- /dev/null +++ b/tests/FScript.Compiler.Tests/HirTests.fs @@ -0,0 +1,346 @@ +namespace FScript.Compiler.Tests + +open System.IO +open FScript.Compiler +open FScript.Language +open NUnit.Framework + +[] +type HirTests() = + let span = Span.mk (Span.pos 1 0) (Span.pos 1 1) + let snapshot name = File.ReadAllText(Path.Combine(__SOURCE_DIRECTORY__, "Snapshots", name)).Replace("\r\n", "\n") + let compiledAdd () = + match Compiler.compile { Program = Parser.parseProgram "let add x y = x + y\nadd 1 2"; Externs = [] } with + | Ok value -> value + | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + + [] + [ value\n(generalized 1, generalized \"x\")", "FSL2108")>] + member _.``Shared specialization reports backend neutral diagnostics`` (source: string, code: string) = + let program = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Ok compiled -> compiled.Lir + | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + match LirMonomorphization.specialize program with + | Ok _ -> Assert.Fail("Expected a specialization diagnostic.") + | Error diagnostics -> + Assert.That(diagnostics |> List.map _.Code, Does.Contain(code)) + Assert.That(diagnostics |> List.forall (fun diagnostic -> diagnostic.Stage = Lowering), Is.True) + + [] + member _.``Local values used only by nested captures survive simplification`` () = + match Compiler.compile {Program=Parser.parseProgram "let make n =\n let x=n+1\n fun y -> fun z -> x+y+z\nmake 1 20 20"; Externs=[]} with + | Error diagnostics -> Assert.Fail(System.String.Join("; ", diagnostics |> List.map _.Message)) + | Ok compiled -> + Assert.That(LirValidation.validate compiled.Lir |> Result.isOk, Is.True) + Assert.That(compiled.Lir.Functions |> List.exists (fun fn -> not fn.Captures.IsEmpty), Is.True) + + [] + member _.``Host types and foreign union metadata survive compiler artifacts`` () = + let fields = Map.ofList [ "Name", TString ] + let registration = + { Types = [ { Name = "Handle"; Fields = fields; HostManaged = true } ] + Unions = [ { Name = "State"; Cases = Map.ofList [ "Ready", None; "Value", Some TInt ] } ] + Functions = [ { Name = "Native.open"; Scheme = Forall([], TFun(TUnit, TNamed "Handle")); Arity = 1; Impl = fun _ _ -> VUnit } ] } + match Compiler.compileWithRegistration registration { Program = Parser.parseProgram "let handle = Native.open ()\nhandle.Name"; Externs = [] } with + | Error diagnostics -> Assert.Fail(System.String.Join("; ", diagnostics |> List.map _.Message)) + | Ok compiled -> + Assert.That(compiled.Hir.Types |> List.exists (fun t -> t.Definition = THostManaged("Handle", fields)), Is.True) + match IrArtifact.deserialize (IrArtifact.serialize compiled.Lir) with + | Error diagnostics -> Assert.Fail(System.String.Join("; ", diagnostics |> List.map _.Message)) + | Ok program -> Assert.That(program.Types |> List.exists (fun t -> t.Definition = THostManaged("Handle", fields)), Is.True) + + [] + member _.``Compiler catalog describes every default runtime external without delegates`` () = + let expected = + [ "Console.readLine"; "Console.writeLine"; "Env" + "Fs.combinePath"; "Fs.createDirectory"; "Fs.enumerateFiles"; "Fs.exists" + "Fs.extension"; "Fs.fileNameWithoutExtension"; "Fs.glob"; "Fs.kind" + "Fs.parentDirectory"; "Fs.readText"; "Fs.writeText" + "Guid.new"; "Hash.md5"; "Json.deserialize"; "Json.serialize" + "Regex.matchGroups"; "Task.await"; "Task.spawn"; "Xml.queryValues" ] + Assert.That((CompilerExternCatalog.defaults |> List.map _.Name |> List.sort) = expected, Is.True) + + match Compiler.compile { Program = Parser.parseProgram "Fs.exists \"missing\""; Externs = [] } with + | Error diagnostics -> Assert.Fail(System.String.Join("; ", diagnostics |> List.map _.Message)) + | Ok compiled -> + Assert.That( + compiled.Lir.Declarations + |> List.exists (fun declaration -> + declaration.Name = "Fs.exists" + && match declaration.Value.Node with Lir.HostExternal("Fs.exists", 1) -> true | _ -> false), + Is.True) + + [] + member _.``Lowers deterministic typed add program`` () = + let source = "let add x y = x + y\nadd 1 2" + let input = { Program = Parser.parseProgram source; Externs = [] } + match Compiler.compile input with + | Error diagnostics -> Assert.Fail(System.String.Join("; ", diagnostics |> List.map _.Message)) + | Ok compiled -> + let actual = Hir.format compiled.Hir + Assert.That(actual, Does.Contain("decl %")) + Assert.That(actual, Does.Contain("primitive NumericAdd")) + Assert.That(actual, Does.Contain("entry")) + Assert.That(Hir.format compiled.Hir, Is.EqualTo(actual)) + + [] + member _.``Compilation exposes exported function signatures from its frontend pass`` () = + let source = "export let pair (prefix: string) (count: int) = (prefix, count)" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(System.String.Join("; ", diagnostics |> List.map _.Message)) + | Ok compiled -> + let signature = compiled.ExportedFunctions.["pair"] + Assert.That(signature.ParameterNames = [ "prefix"; "count" ], Is.True) + Assert.That(signature.ParameterTypes = [ TString; TInt ], Is.True) + Assert.That(signature.ReturnType, Is.EqualTo(TTuple [ TString; TInt ])) + + [] + member _.``Canonical HIR add snapshot is stable`` () = + let compiled = compiledAdd () + let declarations = compiled.Hir.Declarations |> List.filter (fun declaration -> declaration.Name = "add" || declaration.Name.StartsWith("$expression")) + Assert.That(Hir.format { compiled.Hir with Types = []; Declarations = declarations }, Is.EqualTo(snapshot "add.hir")) + + [] + member _.``Canonical LIR add snapshot is stable`` () = + let compiled = compiledAdd () + let declarations = compiled.Lir.Declarations |> List.filter (fun declaration -> declaration.Name = "add" || declaration.Name.StartsWith("$expression")) + Assert.That(Lir.format { compiled.Lir with Types = []; Declarations = declarations }, Is.EqualTo(snapshot "add.lir")) + + [] + member _.``HIR and LIR preserve named type declarations`` () = + let source = "type Person = { Name: string; Age: int }\nlet person = { Name = \"Ada\"; Age = 42 }\nperson.Name" + let compiled = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Ok value -> value + | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + let hirType = compiled.Hir.Types |> List.find (fun item -> item.Name = "Person") + let lirType = compiled.Lir.Types |> List.find (fun item -> item.Name = "Person") + Assert.That(hirType.Name, Is.EqualTo("Person")) + Assert.That((match hirType.Definition with TRecord _ -> true | _ -> false), Is.True) + Assert.That(lirType.Name, Is.EqualTo("Person")) + Assert.That(compiled.Hir.Declarations |> List.exists (fun declaration -> declaration.Value.Type = TNamed "Person"), Is.True) + + [] + member _.``HIR reuses deterministic resolved frontend symbol IDs`` () = + let source = "let first = 1\ntype Choice = | Pick of int\nlet apply x = (let y = x\n match Some y with\n | Some z -> z\n)\napply first" + let program = Parser.parseProgram source + let external name scheme arity = ({ Name = name; Scheme = scheme; Arity = arity; Impl = fun _ _ -> VUnit }: ExternalFunction) + let frontendExterns = + CompilerExternCatalog.defaults + |> List.map (fun descriptor -> external descriptor.Name descriptor.Scheme descriptor.Arity) + let resolved = TypeInfer.inferResolvedProgramWithExterns frontendExterns program + let compiled = match Compiler.compile { Program = program; Externs = [] } with Ok value -> value | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + let resolvedId kind name = resolved.Symbols |> List.find (fun symbol -> symbol.Kind = kind && symbol.Name = name) |> _.SymbolId + let declarationId name = compiled.Hir.Declarations |> List.find (fun declaration -> declaration.Name = name) |> _.Id |> Hir.symbolNumber + Assert.That(declarationId "first", Is.EqualTo(resolvedId TypeInfer.DeclarationSymbol "first")) + Assert.That(declarationId "Choice.Pick", Is.EqualTo(resolvedId TypeInfer.UnionCaseSymbol "Choice.Pick")) + Assert.That(declarationId "apply", Is.EqualTo(resolvedId TypeInfer.DeclarationSymbol "apply")) + let choiceType = compiled.Hir.Types |> List.find (fun item -> item.Name = "Choice") + Assert.That(choiceType.Id |> Hir.symbolNumber, Is.EqualTo(resolvedId TypeInfer.TypeSymbol "Choice")) + let rec bindings (expression: Hir.Expression) = + let patternBindings (pattern: Hir.Pattern) = + let rec collect (pattern: Hir.Pattern) = + match pattern.Node with + | Hir.Binding(id, name) -> [ name, Hir.symbolNumber id ] + | Hir.SomePattern item -> collect item + | _ -> [] + collect pattern + match expression.Node with + | Hir.Lambda(id, name, _, body) -> (name, Hir.symbolNumber id) :: bindings body + | Hir.Let(id, name, _, value, body) -> (name, Hir.symbolNumber id) :: (bindings value @ bindings body) + | Hir.Match(target, cases) -> bindings target @ (cases |> List.collect (fun case -> patternBindings case.Pattern @ bindings case.Body)) + | Hir.Apply(left, right) -> bindings left @ bindings right + | _ -> [] + let applyBindings = compiled.Hir.Declarations |> List.find (fun declaration -> declaration.Name = "apply") |> _.Value |> bindings |> Map.ofList + Assert.That(applyBindings.["x"], Is.EqualTo(resolvedId TypeInfer.ParameterSymbol "x")) + Assert.That(applyBindings.["y"], Is.EqualTo(resolvedId TypeInfer.LocalSymbol "y")) + Assert.That(applyBindings.["z"], Is.EqualTo(resolvedId TypeInfer.PatternBindingSymbol "z")) + + [] + member _.``HIR consumes normalized resolved declaration schemes`` () = + TypeInfer.inferProgram (Parser.parseProgram "let perturb left right = (left, right)") |> ignore + let compiled = match Compiler.compile { Program = Parser.parseProgram "let identity value = value\nidentity 42"; Externs = [] } with Ok value -> value | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + let identity = compiled.Hir.Declarations |> List.find (fun declaration -> declaration.Name = "identity") + Assert.That(identity.Scheme, Is.EqualTo(Forall([ 0 ], TFun(TVar 0, TVar 0)))) + + [] + member _.``HIR lowering consumes only the semantic resolved program`` () = + let program = Parser.parseProgram "let add x y = x + y\nadd 1 2" + let inferenceExterns = + CompilerExternCatalog.defaults + |> List.map (fun descriptor -> + ({ Name = descriptor.Name + Scheme = descriptor.Scheme + Arity = descriptor.Arity + Impl = fun _ _ -> VUnit }: ExternalFunction)) + let resolved = TypeInfer.inferResolvedProgramWithExterns inferenceExterns program + let detached = { resolved with TypedProgram = []; ExpressionTypes = [] } + match HirLowering.lower CompilerExternCatalog.defaults detached with + | Error diagnostics -> Assert.Fail(System.String.Join("; ", diagnostics |> List.map _.Message)) + | Ok hir -> + Assert.That(hir.Declarations |> List.exists (fun declaration -> declaration.Name = "add"), Is.True) + Assert.That(Hir.format hir, Does.Contain("primitive NumericAdd")) + + [] + member _.``HIR attaches structured export and import attributes`` () = + let source = "[] type Person = { Name: string }\nexport let answer = 42" + let compiled = match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with Ok value -> value | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + let personType = compiled.Hir.Types |> List.find (fun item -> item.Name = "Person") + Assert.That((personType.Attributes |> List.map _.Name) = [ "Import" ], Is.True) + let answer = compiled.Hir.Declarations |> List.find (fun declaration -> declaration.Name = "answer") + Assert.That((answer.Attributes |> List.map _.Name) = [ "Export" ], Is.True) + + [] + member _.``HIR retains custom attributes on ordinary declarations`` () = + let source = "[]\ntype Person = { Name: string }\n[] let answer = 42" + let compiled = match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with Ok value -> value | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + let personType = compiled.Hir.Types |> List.find (fun item -> item.Name = "Person") + Assert.That(personType.Attributes.Head.Name, Is.EqualTo("BackendHint")) + Assert.That(personType.Attributes.Head.Arguments = [ "fast"; "stable" ], Is.True) + let answer = compiled.Hir.Declarations |> List.find (fun declaration -> declaration.Name = "answer") + Assert.That(answer.Attributes.Head.Name, Is.EqualTo("Trace")) + + [] + member _.``HIR validation rejects a declaration scheme mismatch`` () = + let value: Hir.Expression = { Type = TInt; Span = span; Node = Hir.Constant(Hir.Int 1L) } + let declaration: Hir.Declaration = + { Id = Hir.SymbolId 0; Name = "value"; Scheme = Forall([], TString) + Attributes = []; IsRecursive = false; IsExported = false; IsPure = false; ExternalArity = None; Export = None; Span = span; Value = value } + match HirValidation.validate { Types = []; ImportedRecords = []; Declarations = [ declaration ]; Entry = None } with + | Ok _ -> Assert.Fail("Expected invalid HIR diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSH1104")) + + [] + member _.``HIR validation rejects unknown semantic types and every unresolved symbol ID`` () = + let unknown = ({ Type = TNamed "Missing"; Span = span; Node = Hir.NoneValue }: Hir.Expression) + match HirValidation.validate { Types = []; ImportedRecords = []; Declarations = []; Entry = Some unknown } with + | Ok _ -> Assert.Fail("Expected unknown HIR type diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSH1109")) + + let reference = ({ Type = TUnit; Span = span; Node = Hir.Reference(Hir.SymbolId 0) }: Hir.Expression) + let declaration: Hir.Declaration = + { Id = Hir.SymbolId 10; Name = "value"; Scheme = Forall([], TUnit) + Attributes = []; IsRecursive = false; IsExported = false; IsPure = false; ExternalArity = None; Export = None; Span = span; Value = reference } + match HirValidation.validate { Types = []; ImportedRecords = []; Declarations = [ declaration ]; Entry = None } with + | Ok _ -> Assert.Fail("Expected unresolved HIR symbol diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSH1102")) + + [] + member _.``LIR validation rejects inconsistent control flow`` () = + let constant valueType value = ({ Type = valueType; Span = span; Node = Lir.Constant value }: Lir.Expression) + let branch: Lir.Expression = + { Type = TInt; Span = span + Node = Lir.Branch(constant TInt (Lir.Int 1L), constant TInt (Lir.Int 2L), constant TString (Lir.String "no")) } + match LirValidation.validate { Types = []; ImportedRecords = []; Functions = []; Declarations = []; Entry = Some branch } with + | Ok _ -> Assert.Fail("Expected invalid LIR diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSL2007")) + + [] + member _.``LIR validation rejects unknown primitives`` () = + let intrinsic = ({ Type = TInt; Span = span; Node = Lir.Intrinsic "Unknown.value" }: Lir.Expression) + match LirValidation.validate { Types = []; ImportedRecords = []; Functions = []; Declarations = []; Entry = Some intrinsic } with + | Ok _ -> Assert.Fail("Expected unavailable primitive diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSL2009")) + + [] + member _.``LIR validation rejects unknown types and invalid nested spans`` () = + let unknown = ({ Type = TNamed "Missing"; Span = span; Node = Lir.NoneValue }: Lir.Expression) + match LirValidation.validate { Types = []; ImportedRecords = []; Functions = []; Declarations = []; Entry = Some unknown } with + | Ok _ -> Assert.Fail("Expected unknown LIR type diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSL2017")) + + let invalidSpan = Span.mk (Span.pos -1 0) (Span.pos -1 1) + let child = ({ Type = TInt; Span = invalidSpan; Node = Lir.Constant(Lir.Int 1L) }: Lir.Expression) + let tuple = ({ Type = TTuple [ TInt ]; Span = span; Node = Lir.Tuple [ child ] }: Lir.Expression) + match LirValidation.validate { Types = []; ImportedRecords = []; Functions = []; Declarations = []; Entry = Some tuple } with + | Ok _ -> Assert.Fail("Expected nested LIR span diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSL2002")) + + [] + member _.``LIR optimization folds constant control flow and unused pure locals`` () = + let constant value = ({ Type = TInt; Span = span; Node = Lir.Constant(Lir.Int value) }: Lir.Expression) + let condition = ({ Type = TBool; Span = span; Node = Lir.Constant(Lir.Bool true) }: Lir.Expression) + let branch = ({ Type = TInt; Span = span; Node = Lir.Branch(condition, constant 1L, constant 2L) }: Lir.Expression) + let expression = ({ Type = TInt; Span = span; Node = Lir.Let(Lir.SymbolId 1, "unused", false, constant 0L, branch) }: Lir.Expression) + let program: Lir.Program = { Types = []; ImportedRecords = []; Functions = []; Declarations = []; Entry = Some expression } + let optimized = LirOptimization.optimize program + Assert.That(optimized.Entry |> Option.map _.Node, Is.EqualTo(Some(Lir.Constant(Lir.Int 1L)))) + + [] + member _.``LIR optimization removes unreachable pure declarations and functions`` () = + let source = "let dead value = value + 1\nlet kept = 42\nkept" + let compiled = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Ok value -> value + | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + Assert.That(compiled.Lir.Declarations |> List.exists (fun declaration -> declaration.Name = "dead"), Is.False) + Assert.That(compiled.Lir.Declarations |> List.exists (fun declaration -> declaration.Name = "kept"), Is.True) + Assert.That(compiled.Lir.Functions, Is.Empty) + + [] + member _.``LIR optimization retains observable top-level initializers`` () = + let source = "let ignored = Console.writeLine \"kept\"\n42" + let compiled = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Ok value -> value + | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + Assert.That(compiled.Lir.Declarations |> List.exists (fun declaration -> declaration.Name = "ignored"), Is.True) + + [] + member _.``LIR optimization marks calls in function tail position`` () = + let source = "let rec loop n = if n <= 0 then n else loop (n - 1)\nloop 10" + let compiled = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Ok value -> value + | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + Assert.That(Lir.format compiled.Lir, Does.Contain("tail-call-closure")) + + [] + member _.``LIR optimization preserves pipeline evaluation order in tail calls`` () = + let source = "let rec loop n = if n <= 0 then n else (n - 1) |> loop\nloop 10" + let compiled = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Ok value -> value + | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + Assert.That(Lir.format compiled.Lir, Does.Contain("tail-pipe-closure")) + + [] + member _.``LIR lowers patterns into projection and check plans`` () = + let compiled = + match Compiler.compile { Program = Parser.parseProgram "match Some (1, 2) with | Some (left, right) -> left + right | None -> 0"; Externs = [] } with + | Ok value -> value + | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + let decision = + compiled.Lir.Declarations + |> List.choose (fun declaration -> match declaration.Value.Node with Lir.DecisionTree(_, cases) -> Some cases | _ -> None) + |> List.exactlyOne + let first = decision.Head.Plan + Assert.That(first.Checks |> List.exists (function Lir.SomeCheck [] -> true | _ -> false), Is.True) + Assert.That(first.Checks |> List.exists (function Lir.TupleArityCheck([ Lir.OptionValue ], 2) -> true | _ -> false), Is.True) + let projections = first.Bindings |> List.map _.Projection + let expected = + [ [ Lir.OptionValue; Lir.TupleItem 0 ] + [ Lir.OptionValue; Lir.TupleItem 1 ] ] + Assert.That((projections = expected), Is.True) + + [] + member _.``Compiler emits intrinsic types and validates their union payload plans`` () = + let source = "match Fs.kind \".\" with | FsKind.Directory path -> path | _ -> \"missing\"" + let compiled = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Ok value -> value + | Error diagnostics -> failwith (System.String.Join("; ", diagnostics |> List.map _.Message)) + Assert.That(compiled.Lir.Types |> List.map _.Name, Does.Contain("Environment")) + Assert.That(compiled.Lir.Types |> List.map _.Name, Does.Contain("FsKind")) + let fsKind = compiled.Lir.Types |> List.find (fun item -> item.Name = "FsKind") + match fsKind.Definition with + | TUnion(_, cases) -> Assert.That(cases |> Map.containsKey "Directory", Is.True) + | _ -> Assert.Fail("Expected intrinsic FsKind union") + + [] + member _.``LIR validates recursive named representations without recursion overflow`` () = + let source = "type rec Tree = | Leaf of int | Branch of (Tree * Tree)\nlet rec sum tree = match tree with | Leaf value -> value | Branch (left, right) -> sum left + sum right\nsum (Branch (Leaf 1, Leaf 2))" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Ok compiled -> Assert.That(compiled.Lir.Types |> List.map _.Name, Does.Contain("Tree")) + | Error diagnostics -> Assert.Fail(System.String.Join("; ", diagnostics |> List.map _.Message)) diff --git a/tests/FScript.Compiler.Tests/IrArtifactTests.fs b/tests/FScript.Compiler.Tests/IrArtifactTests.fs new file mode 100644 index 0000000..1b917b9 --- /dev/null +++ b/tests/FScript.Compiler.Tests/IrArtifactTests.fs @@ -0,0 +1,204 @@ +namespace FScript.Compiler.Tests + +open System +open System.Text +open System.Text.Json +open System.Text.Json.Nodes +open FScript.Compiler +open FScript.Language +open NUnit.Framework + +[] +type IrArtifactTests() = + let compile source = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Ok value -> value + | Error diagnostics -> failwith (String.Join("; ", diagnostics |> List.map _.Message)) + + let parseObject (bytes: byte array) : JsonObject = + match JsonNode.Parse(Encoding.UTF8.GetString(bytes)) with + | null -> failwith "Expected JSON object" + | node -> node.AsObject() + + [] + member _.``IR artifact is deterministic and equivalent after round trip`` () = + let compiled = compile "let add x y = x + y\n(Some (add 1 2), [1] @ [2])" + let first = IrArtifact.serialize compiled.Lir + let second = IrArtifact.serialize compiled.Lir + Assert.That((first = second), Is.True) + match IrArtifact.deserialize first with + | Error diagnostics -> Assert.Fail(String.Join("; ", diagnostics |> List.map _.Message)) + | Ok loaded -> Assert.That(loaded, Is.EqualTo(compiled.Lir)) + + [] + member _.``IR artifact round trips explicit tail calls`` () = + let compiled = compile "let rec loop n = if n <= 0 then n else loop (n - 1)\nloop 10" + let bytes = IrArtifact.serialize compiled.Lir + Assert.That(Encoding.UTF8.GetString(bytes), Does.Contain("\"kind\": \"tail-call\"")) + match IrArtifact.deserialize bytes with + | Error diagnostics -> Assert.Fail(String.Join("; ", diagnostics |> List.map _.Message)) + | Ok loaded -> Assert.That(loaded, Is.EqualTo(compiled.Lir)) + + [] + member _.``IR artifact rejects incompatible versions`` () = + let bytes = compile "1" |> _.Lir |> IrArtifact.serialize + let invalid = Encoding.UTF8.GetString(bytes).Replace("\"irVersion\": 1", "\"irVersion\": 999") |> Encoding.UTF8.GetBytes + match IrArtifact.deserialize invalid with + | Ok _ -> Assert.Fail("Expected incompatible-version diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSA5002")) + + [] + member _.``IR artifact rejects corrupt JSON`` () = + match IrArtifact.deserialize (Encoding.UTF8.GetBytes("{")) with + | Ok _ -> Assert.Fail("Expected corrupt-artifact diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSA5003")) + + [] + member _.``IR artifact rejects missing and non-canonical metadata`` () = + let bytes = compile "1" |> _.Lir |> IrArtifact.serialize + let missing = parseObject bytes + missing.Remove("compilerVersion") |> ignore + match IrArtifact.deserialize (Encoding.UTF8.GetBytes(missing.ToJsonString())) with + | Ok _ -> Assert.Fail("Expected missing-metadata diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSA5004")) + + let invalid = parseObject bytes + let dependencies = JsonArray() + dependencies.Add("z") + dependencies.Add("a") + invalid["dependencies"] <- dependencies + match IrArtifact.deserialize (Encoding.UTF8.GetBytes(invalid.ToJsonString())) with + | Ok _ -> Assert.Fail("Expected non-canonical-metadata diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSA5005")) + + let invalidSource = parseObject bytes + let sourceMetadata = JsonObject() + sourceMetadata["path"] <- "z\\program.fss" + sourceMetadata["sha256"] <- String.replicate 64 "A" + invalidSource["sources"] <- JsonArray(sourceMetadata) + match IrArtifact.deserialize (Encoding.UTF8.GetBytes(invalidSource.ToJsonString())) with + | Ok _ -> Assert.Fail("Expected invalid source-metadata diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSA5005")) + + let invalidVersion = parseObject bytes + invalidVersion["compilerVersion"] <- "" + match IrArtifact.deserialize (Encoding.UTF8.GetBytes(invalidVersion.ToJsonString())) with + | Ok _ -> Assert.Fail("Expected invalid version-metadata diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSA5005")) + + [] + member _.``IR artifact post-load validation rejects unknown semantic types`` () = + let artifact = compile "1" |> _.Lir |> IrArtifact.serialize |> parseObject + let required (name: string) (value: JsonObject) : JsonNode = + match value[name] with + | null -> failwith $"Expected '{name}'" + | node -> node + let program = (required "program" artifact).AsObject() + let entry = (required "entry" program).AsObject() + let unknownType = JsonObject() + unknownType["kind"] <- "named" + unknownType["name"] <- "Missing" + entry["type"] <- unknownType + match IrArtifact.deserialize (Encoding.UTF8.GetBytes(artifact.ToJsonString())) with + | Ok _ -> Assert.Fail("Expected post-load semantic-type diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSL2017")) + + [] + member _.``IR artifact records normalized source paths and SHA256 hashes`` () = + let path = IO.Path.Combine(IO.Path.GetTempPath(), $"fscript-source-{Guid.NewGuid():N}.fss") + try + IO.File.WriteAllText(path, "1") + let input = { Program = Parser.parseProgramWithSourceName (Some path) "1"; Externs = [] } + let compiled = match Compiler.compile input with Ok value -> value | Error diagnostics -> failwith (String.Join("; ", diagnostics |> List.map _.Message)) + use document = JsonDocument.Parse(IrArtifact.serialize compiled.Lir) + let source = document.RootElement.GetProperty("sources")[0] + Assert.That(source.GetProperty("path").GetString(), Is.EqualTo(path.Replace('\\', '/'))) + let expected = Security.Cryptography.SHA256.HashData(IO.File.ReadAllBytes(path)) |> Convert.ToHexString |> _.ToLowerInvariant() + Assert.That(source.GetProperty("sha256").GetString(), Is.EqualTo(expected)) + finally + if IO.File.Exists path then IO.File.Delete path + + [] + member _.``IR artifact round trips lexical let and fail nodes`` () = + for source in + [ "let f x = (let y = x + 1\n y\n)\nf 2" + "raise \"failure\"" + "match Some 2 with\n | Some x when x > 0 -> x\n | None -> 0" + "([1..3][0], $\"answer {42}\")" + "let value = {| Count = 1 |}\n{| value with Count = 2 |}" + "type Shape = | Point | Circle of int\nmatch Circle 2 with\n | Point -> 0\n | Circle radius -> radius" + "{ [\"answer\"] = 42 }[\"answer\"]" + "let sum pair = (let (left, right) = pair\n left + right\n)\nsum (1, 2)" + "for value in [1; 2; 3] do ignore value" + "type Package = { Name: string }\ntypeof Package" + "(let rec even n = if n = 0 then true else odd (n - 1)\nand odd n = if n = 0 then false else even (n - 1)\neven 10\n)" + "match { [\"a\"] = 1 } with\n | { [key] = value; ..tail } -> value\n | {} -> 0" + "match {| Name = \"Ada\" |} with\n | {| Name: string |} -> true\n | _ -> false" + "List.length Env.Arguments" + "[\"a\"; \"b\"] |> String.concat \",\"" + "[] let upper : string -> string\nupper \"hello\"" ] do + let bytes = compile source |> _.Lir |> IrArtifact.serialize + match IrArtifact.deserialize bytes with + | Ok _ -> () + | Error diagnostics -> Assert.Fail(String.Join("; ", diagnostics |> List.map _.Message)) + + [] + member _.``IR artifact serializes lowered pattern plans rather than source patterns`` () = + let bytes = compile "match Some (1, 2) with | Some (left, right) -> left + right | None -> 0" |> _.Lir |> IrArtifact.serialize + let json = Encoding.UTF8.GetString(bytes) + Assert.That(json, Does.Contain("\"plan\"")) + Assert.That(json, Does.Contain("\"projection\"")) + Assert.That(json, Does.Not.Contain("\"pattern\"")) + + [] + member _.``IR artifact preserves explicit structural record conversions`` () = + let source = "type Person = { Name: string; Age: int }\nlet age (person: Person) = person.Age\nage {| Name = \"Ada\"; Age = 42 |}" + let lir = (compile source).Lir + let bytes = IrArtifact.serialize lir + Assert.That(Encoding.UTF8.GetString(bytes), Does.Contain("\"kind\": \"record-convert\"")) + match IrArtifact.deserialize bytes with + | Ok loaded -> Assert.That(loaded, Is.EqualTo(lir)) + | Error diagnostics -> Assert.Fail(String.Join("; ", diagnostics |> List.map _.Message)) + + [] + member _.``IR artifact preserves named type declarations`` () = + let lir = (compile "type Person = { Name: string; Age: int }\n{ Name = \"Ada\"; Age = 42 }").Lir + let bytes = IrArtifact.serialize lir + Assert.That(Encoding.UTF8.GetString(bytes), Does.Contain("\"types\"")) + match IrArtifact.deserialize bytes with + | Ok loaded -> Assert.That(loaded.Types = lir.Types, Is.True) + | Error diagnostics -> Assert.Fail(String.Join("; ", diagnostics |> List.map _.Message)) + + [] + member _.``LIR closures serialize deterministic explicit captures`` () = + let source = "let outer x = (let inner y = x + y\n inner\n)\nouter 40 2" + let lir = (compile source).Lir + Assert.That((lir.Functions |> List.map (fun fn -> Lir.functionNumber fn.Id)) = [ 0; 1 ], Is.True) + Assert.That(lir.Functions |> List.exists (fun fn -> not fn.Captures.IsEmpty), Is.True) + let bytes = lir |> IrArtifact.serialize + let json = Encoding.UTF8.GetString(bytes) + Assert.That(json, Does.Match("\\\"captures\\\": \\[\\s+[0-9]+")) + match IrArtifact.deserialize bytes with + | Ok _ -> () + | Error diagnostics -> Assert.Fail(String.Join("; ", diagnostics |> List.map _.Message)) + + [] + member _.``IR artifact validation rejects forged closure captures`` () = + let source = "let outer x = (let inner y = x + y\n inner\n)\nouter 40 2" + let json = (compile source).Lir |> IrArtifact.serialize |> Encoding.UTF8.GetString + let capturePattern = System.Text.RegularExpressions.Regex("\\\"captures\\\": \\[\\s+[0-9]+\\s+\\]") + let invalid = capturePattern.Replace(json, "\"captures\": [ ]", 1) |> Encoding.UTF8.GetBytes + match IrArtifact.deserialize invalid with + | Ok _ -> Assert.Fail("Expected invalid closure-capture diagnostic") + | Error diagnostics -> Assert.That(diagnostics |> List.map _.Code, Does.Contain("FSL2013")) + + [] + member _.``IR artifact preserves structured export metadata`` () = + let lir = (compile "export let answer = 42").Lir + let exported = lir.Declarations |> List.find _.IsExported + Assert.That(exported.Export |> Option.map _.Name, Is.EqualTo(Some "answer")) + match lir |> IrArtifact.serialize |> IrArtifact.deserialize with + | Error diagnostics -> Assert.Fail(String.Join("; ", diagnostics |> List.map _.Message)) + | Ok loaded -> + let roundTripped = loaded.Declarations |> List.find _.IsExported + Assert.That(roundTripped.Export, Is.EqualTo(exported.Export)) diff --git a/tests/FScript.Compiler.Tests/Program.fs b/tests/FScript.Compiler.Tests/Program.fs new file mode 100644 index 0000000..b2d56f2 --- /dev/null +++ b/tests/FScript.Compiler.Tests/Program.fs @@ -0,0 +1,4 @@ +module FScript.Compiler.Tests.Program + +[] +let main _ = 0 diff --git a/tests/FScript.Compiler.Tests/PurityTests.fs b/tests/FScript.Compiler.Tests/PurityTests.fs new file mode 100644 index 0000000..387fa8b --- /dev/null +++ b/tests/FScript.Compiler.Tests/PurityTests.fs @@ -0,0 +1,169 @@ +namespace FScript.Compiler.Tests + +open System.Text +open System.Text.Json.Nodes +open FScript.Compiler +open FScript.Language +open NUnit.Framework + +[] +type PurityTests() = + let external name valueType arity : CompilerExtern = + { Name=name; Scheme=Forall([],valueType); Arity=arity; Kind=UnsupportedHostExtern } + let compile registration purity externs source = + match Compiler.compileWithRegistrationAndPurity registration purity {Program=Parser.parseProgram source;Externs=externs} with + | Ok value -> value + | Error errors -> failwith (System.String.Join("; ",errors |> List.map _.Message)) + let optimize program = + match LirMonomorphization.specialize program with + | Error errors -> failwith (System.String.Join("; ",errors |> List.map _.Message)) + | Ok value -> + let result=LirSimplification.optimize value + match LirValidation.validate result with + | Ok value -> value + | Error errors -> failwith (System.String.Join("; ",errors |> List.map _.Message)) + let pureFunctions names = {PurityContracts.empty with PureFunctions=Set.ofList names} + + [] + member _.``Purity contracts survive the frontend HIR LIR and artifacts`` () = + let registration={HostInterop.empty with Types=[{Name="Point";Fields=Map.ofList ["X",TInt];HostManaged=true}]} + let purity={PureFunctions=Set.singleton "Host.make";PureTypes=Set.singleton "Point"} + let externs=[external "Host.make" (TFun(TInt,TNamed "Point")) 1] + let source="Host.make 42" + let resolved=TypeInfer.inferResolvedProgramWithRegistrationAndPurity registration purity (Parser.parseProgram "42") + Assert.That(resolved.Purity,Is.EqualTo(purity)) + let compiled=compile registration purity externs source + Assert.That(compiled.Hir.Declarations |> List.find (fun d -> d.Name="Host.make") |> _.IsPure,Is.True) + Assert.That(compiled.Hir.Types |> List.find (fun d -> d.Name="Point") |> _.IsPure,Is.True) + Assert.That(Hir.format compiled.Hir,Does.Contain("pure")) + let bytes=IrArtifact.serialize compiled.Lir + Assert.That((IrArtifact.serialize compiled.Lir = bytes),Is.True) + let loaded=match IrArtifact.deserialize bytes with Ok p -> p | Error errors -> failwith (string errors) + Assert.That(loaded.Declarations |> List.find (fun d -> d.Name="Host.make") |> _.IsPure,Is.True) + Assert.That(loaded.Declarations |> List.find (fun d -> d.Name="Host.make") |> _.ExternalArity,Is.EqualTo(Some 1)) + Assert.That(loaded.Types |> List.find (fun d -> d.Name="Point") |> _.IsPure,Is.True) + // Existing version-1 artifacts have no purity flags; loading stays conservative. + let json=JsonNode.Parse(Encoding.UTF8.GetString bytes) |> nonNull + for category in ["types";"declarations"] do + for value in (nonNull (nonNull json.["program"]).[category]).AsArray() do + (nonNull value).AsObject().Remove("pure") |> ignore + (nonNull value).AsObject().Remove("externalArity") |> ignore + let legacy=match IrArtifact.deserialize (Encoding.UTF8.GetBytes(json.ToJsonString())) with Ok p -> p | Error errors -> failwith (string errors) + Assert.That(legacy.Declarations |> List.exists _.IsPure,Is.False) + Assert.That(legacy.Types |> List.exists _.IsPure,Is.False) + + [] + member _.``A pure factory does not make its returned callback pure`` () = + let externs=[external "Host.make" (TFun(TUnit,TFun(TInt,TInt))) 1] + let compiled=compile HostInterop.empty (pureFunctions ["Host.make"]) externs "let discarded = Host.make () 1\n42" + // Linking must preserve the application boundary independently of function type arity. + let linked = + { compiled.Lir with + Declarations = compiled.Lir.Declarations |> List.map (fun d -> + if d.Name="Host.make" then {d with Value={d.Value with Node=Lir.TargetImport("provider","Make")}} else d) } + let optimized=optimize linked + Assert.That(optimized.Declarations |> List.exists (fun d -> d.Name="discarded"),Is.True) + + [] + member _.``Observable generalized initializers are diagnosed rather than omitted`` () = + let compiled=compile HostInterop.empty PurityContracts.empty [] "let fail () = raise \"boom\"\nlet discarded = fail ()\n42" + match LirMonomorphization.specialize compiled.Lir with + | Ok _ -> Assert.Fail("An observable open initializer must not disappear.") + | Error errors -> Assert.That(errors |> List.map _.Code,Does.Contain("FSL2108")) + + [] + member _.``Artifact validation rejects purity on ordinary values`` () = + let compiled=compile HostInterop.empty PurityContracts.empty [] "42" + let forged={compiled.Lir with Declarations=compiled.Lir.Declarations |> List.map (fun d -> {d with IsPure=true})} + match IrArtifact.deserialize (IrArtifact.serialize forged) with + | Ok _ -> Assert.Fail("A purity contract requires a valid external binding.") + | Error errors -> Assert.That(errors |> List.map _.Code,Does.Contain("FSL2018")) + + [] + [] + member _.``Collection effects follow their callbacks`` effectful = + let callback=if effectful then "let callback value =\n let ignored = Console.writeLine \"callback\"\n value\n" else "let callback value = value + 1\n" + let optimized=(compile HostInterop.empty PurityContracts.empty [] (callback+"let discarded = List.map callback [1;2]\n42")).Lir |> optimize + Assert.That(optimized.Declarations |> List.exists (fun d -> d.Name="discarded"),Is.EqualTo(effectful)) + + [] + [] + member _.``Only declared pure unused FFI calls are pruned`` (isPure: bool) = + let contracts=if isPure then pureFunctions ["Host.add"] else PurityContracts.empty + let externs=[external "Host.add" (TFun(TInt,TFun(TInt,TInt))) 2] + let optimized=(compile HostInterop.empty contracts externs "let discarded = Host.add 1 2\n42").Lir |> optimize + Assert.That(optimized.Declarations |> List.exists (fun d -> d.Name="discarded"),Is.EqualTo(not isPure)) + Assert.That(optimized.Declarations |> List.exists (fun d -> d.Name="Host.add"),Is.EqualTo(not isPure)) + + [] + [] + member _.``External field reads need a pure type contract`` (isPure: bool) = + let registration={HostInterop.empty with Types=[{Name="Handle";Fields=Map.ofList ["Value",TInt];HostManaged=true}]} + let contracts=if isPure then {PurityContracts.empty with PureTypes=Set.singleton "Handle"} else PurityContracts.empty + let externs=[external "Host.obtain" (TFun(TUnit,TNamed "Handle")) 1] + let optimized=(compile registration contracts externs "let handle = Host.obtain ()\nlet discarded = handle.Value\n42").Lir |> optimize + Assert.That(optimized.Declarations |> List.exists (fun d -> d.Name="discarded"),Is.EqualTo(not isPure)) + Assert.That(optimized.Declarations |> List.exists (fun d -> d.Name="handle"),Is.True,"A pure type does not make its factory pure.") + + [] + [ 0\n42")>] + [] + [] + [] + [ 0\nlet discarded = fail 1\n42")>] + member _.``Effects failures and unproven termination remain observable`` source = + let optimized=(compile HostInterop.empty PurityContracts.empty [] source).Lir |> optimize + Assert.That(optimized.Declarations |> List.exists (fun d -> d.Name="discarded"),Is.True,source) + + [] + [] + member _.``Pure calls preserve argument failures and effects`` expression = + let externs=[external "Host.add" (TFun(TInt,TFun(TInt,TInt))) 2] + let optimized=(compile HostInterop.empty (pureFunctions ["Host.add"]) externs ("let argument () =\n let ignored = Console.writeLine \"argument\"\n 1\nlet discarded = "+expression+"\n42")).Lir |> optimize + Assert.That(optimized.Declarations |> List.exists (fun d -> d.Name="discarded"),Is.True) + + [] + [] + member _.``FFI callback effects constrain the pure contract`` effectful = + let externs=[external "Host.apply" (TFun(TFun(TInt,TInt),TFun(TInt,TInt))) 2] + let callback=if effectful then "let callback value =\n let ignored = Console.writeLine \"callback\"\n value\n" else "let callback value = value + 1\n" + let optimized=(compile HostInterop.empty (pureFunctions ["Host.apply"]) externs (callback+"let discarded = Host.apply callback 2\n42")).Lir |> optimize + Assert.That(optimized.Declarations |> List.exists (fun d -> d.Name="discarded"),Is.EqualTo(effectful)) + + [] + member _.``Unused string replacement is total and prunable`` () = + let optimized=(compile HostInterop.empty PurityContracts.empty [] "let discarded = String.replace \"\" \"x\" \"abc\"\n42").Lir |> optimize + Assert.That(optimized.Declarations |> List.exists (fun d -> d.Name="discarded"),Is.False) + + [] + [] + member _.``Purity declarations cannot silently name missing or protected bindings`` name = + match Compiler.compileWithPurity (pureFunctions [name]) {Program=Parser.parseProgram "42";Externs=[]} with + | Ok _ -> Assert.Fail("Expected an invalid purity contract") + | Error errors -> Assert.That(errors |> List.map _.Code,Does.Contain("FSH1000")) + + [] + member _.``Exit code writes are observable and cannot be deduplicated`` () = + let compiled=compile HostInterop.empty PurityContracts.empty [] "Env.setExitCode 7\nEnv.setExitCode 7\n42" + let optimized=compiled.Lir |> optimize |> LirCommonSubexpressions.optimize + let setters=optimized.Declarations |> List.filter (fun d -> d.Name.StartsWith("$expression") && d.Value.Type=TUnit) + Assert.That(setters.Length,Is.EqualTo(2)) + + [] + member _.``Discarding results prunes pure work but preserves status and failures`` () = + let run source = + let compiled=compile HostInterop.empty PurityContracts.empty [] source + compiled.Lir |> LirResultPolicy.discard |> optimize + let discarded=run "let compute n = n*n + 1\ncompute 42" + Assert.That(discarded.Declarations,Is.Empty) + Assert.That(discarded.Functions,Is.Empty) + let setter=run "Env.setExitCode 7\n42" + Assert.That(setter.Declarations |> List.exists (fun d -> d.Value.Type=TUnit && d.Name.StartsWith("$expression")),Is.True) + let failure=run "1/0" + Assert.That(failure.Declarations,Is.Not.Empty) + + [] + member _.``Discard mode accepts an unused open pure result`` () = + let compiled=compile HostInterop.empty PurityContracts.empty [] "None" + let optimized=compiled.Lir |> LirResultPolicy.discard |> optimize + Assert.That(optimized.Declarations,Is.Empty) diff --git a/tests/FScript.Compiler.Tests/Snapshots/add.hir b/tests/FScript.Compiler.Tests/Snapshots/add.hir new file mode 100644 index 0000000..1af4079 --- /dev/null +++ b/tests/FScript.Compiler.Tests/Snapshots/add.hir @@ -0,0 +1,14 @@ +decl %78 add: ('a -> ('a -> 'a)) + lambda %79 x: 'a : ('a -> ('a -> 'a)) + lambda %80 y: 'a : ('a -> 'a) + primitive NumericAdd : 'a + ref %79 : 'a + ref %80 : 'a +decl %81 $expression81: int + apply : int + apply : (int -> int) + ref %78 : (int -> (int -> int)) + const int 1 : int + const int 2 : int +entry + ref %81 : int diff --git a/tests/FScript.Compiler.Tests/Snapshots/add.lir b/tests/FScript.Compiler.Tests/Snapshots/add.lir new file mode 100644 index 0000000..76b5cf1 --- /dev/null +++ b/tests/FScript.Compiler.Tests/Snapshots/add.lir @@ -0,0 +1,16 @@ +function @0 %79 x captures=[]: 'a -> ('a -> 'a) + make-closure @1 captures=[79] : ('a -> 'a) +function @1 %80 y captures=[79]: 'a -> 'a + operation NumericAdd : 'a + load %79 : 'a + load %80 : 'a +decl %78 add: ('a -> ('a -> 'a)) + make-closure @0 captures=[] : ('a -> ('a -> 'a)) +decl %81 $expression81: int + call-closure : int + call-closure : (int -> int) + load %78 : (int -> (int -> int)) + const Int 1L : int + const Int 2L : int +entry + load %81 : int diff --git a/tests/FScript.Compiler.Tests/Snapshots/cse.lir b/tests/FScript.Compiler.Tests/Snapshots/cse.lir new file mode 100644 index 0000000..9bf268b --- /dev/null +++ b/tests/FScript.Compiler.Tests/Snapshots/cse.lir @@ -0,0 +1,8 @@ +entry + let %0 $cse recursive=False : (int * int) + operation IntAdd : int + const Int 1L : int + const Int 2L : int + tuple : (int * int) + load %0 : int + load %0 : int diff --git a/tests/FScript.Conformance.Tests/ConformanceTests.fs b/tests/FScript.Conformance.Tests/ConformanceTests.fs new file mode 100644 index 0000000..5a489e3 --- /dev/null +++ b/tests/FScript.Conformance.Tests/ConformanceTests.fs @@ -0,0 +1,161 @@ +namespace FScript.Conformance.Tests + +open System +open FScript.Compiler +open FScript.Language +open NUnit.Framework + +module private Harness = + type Outcome = { Value: string; Stdout: string list } + type FailureCategory = Raised | MatchFailure | DivisionByZero + + let private quoteString (value: string) = + "\"" + value.Replace("\\", "\\\\").Replace("\"", "\\\"").Replace("\r", "\\r").Replace("\n", "\\n").Replace("\t", "\\t") + "\"" + + let rec private formatLirValue = function + | LirValue.VUnit -> "()" + | LirValue.VInt value -> string value + | LirValue.VFloat value -> value.ToString("R", Globalization.CultureInfo.InvariantCulture) + | LirValue.VBool value -> string value |> _.ToLowerInvariant() + | LirValue.VString value -> quoteString value + | LirValue.VOption None -> "None" + | LirValue.VOption(Some value) -> "Some " + formatLirValue value + | LirValue.VList values -> "[" + (values |> List.map formatLirValue |> String.concat ";") + "]" + | LirValue.VTuple values -> "(" + (values |> List.map formatLirValue |> String.concat ", ") + ")" + | LirValue.VRecord fields -> "{ " + (fields |> Map.toList |> List.map (fun (name, value) -> name + " = " + formatLirValue value) |> String.concat "; ") + " }" + | LirValue.VUnion(_, caseName, None) -> caseName + | LirValue.VUnion(_, caseName, Some value) -> caseName + " " + formatLirValue value + | LirValue.VMap entries -> "map { " + (entries |> List.map (fun (key, value) -> formatLirValue key + " => " + formatLirValue value) |> String.concat "; ") + " }" + | LirValue.VTypeToken value -> "" + | LirValue.VClosure _ | LirValue.VIntrinsic _ | LirValue.VExternal _ | LirValue.VTargetImport _ -> "" + | LirValue.VRuntimeContext -> "" + let formatLir value = formatLirValue value + + let compile source = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Ok value -> value + | Error diagnostics -> failwith (String.Join("; ", diagnostics |> List.map _.Message)) + + let legacy source = + let output = ResizeArray() + let console : ExternalFunction = + { Name = "Console.writeLine"; Scheme = Forall([], TFun(TString, TUnit)); Arity = 1 + Impl = fun _ values -> match values with [ VString value ] -> output.Add(value); VUnit | _ -> VUnit } + let program = Parser.parseProgram source + let value = program |> TypeInfer.inferProgramWithExterns [ console ] |> Eval.evalProgramWithExterns [ console ] |> Pretty.valueToString + { Value = value; Stdout = List.ofSeq output } + + let lir source = + let artifact = compile source |> _.Lir |> IrArtifact.serialize + let loaded = match IrArtifact.deserialize artifact with Ok value -> value | Error diagnostics -> failwith (String.Join("; ", diagnostics |> List.map _.Message)) + match LirInterpreter.execute { ScriptName = None; Arguments = [] } loaded with + | Ok result -> Ok { Value = formatLir result.Value; Stdout = result.Stdout } + | Error diagnostic -> Error diagnostic.Code + + let cse source = + let lir=compile source |> _.Lir + let lir=match LirMonomorphization.specialize lir with Ok p -> p | Error diagnostics -> failwith (string diagnostics) + let lir=LirSimplification.optimize lir |> LirCommonSubexpressions.optimize + let lir=match LirValidation.validate lir with Ok p -> p | Error diagnostics -> failwith (string diagnostics) + let artifact=IrArtifact.serialize lir + let loaded=match IrArtifact.deserialize artifact with Ok p -> p | Error diagnostics -> failwith (string diagnostics) + match LirInterpreter.execute { ScriptName=None;Arguments=[] } loaded with + | Ok result -> Ok {Value=formatLir result.Value;Stdout=result.Stdout} + | Error diagnostic -> Error diagnostic.Code + + let legacyFailure source = + try + legacy source |> ignore + None + with + | :? DivideByZeroException -> Some DivisionByZero + | EvalException error when error.Message = "No match cases matched" -> Some MatchFailure + | EvalException _ -> Some Raised + + let lirFailure source = + match lir source with + | Ok _ -> None + | Error "FSI3005" -> Some DivisionByZero + | Error "FSI3012" -> Some MatchFailure + | Error "FSI3011" -> Some Raised + | Error "FSI3022" -> Some Raised + | Error code -> failwith $"Unexpected LIR failure category {code}" + +[] +type ConformanceTests() = + [] + [] + [ 1 | _ -> 2\ncheck { City=\"Paris\"; Zip=75000 }")>] + [ 0 | Circle radius -> radius")>] + [] + [] + [ state + value) 0 [1; 2; 3]")>] + [] + [ value | None -> 0")>] + [] + [] + [] + [] + [] + [] + [] + [ value + amount\napplyTwice (add 2) 3")>] + [] + [ head | _ -> 0")>] + [ true | _ -> false")>] + [ (k, Map.count rest) | _ -> (\"\",0)")>] + [ (x,Map.containsKey 1 rest) | _ -> (0,false)")>] + [] + [ value + 1) [1; 2], List.iter (fun value -> ignore value) [1; 2], List.choose (fun value -> if value > 1 then Some value else None) [1; 2], List.collect (fun value -> [value; value]) [1; 2], List.exists (fun value -> value = 2) [1; 2], List.contains 2 [1; 2], List.rev [1; 2], List.distinct [1; 1; 2], List.fold (fun state value -> state + value) 0 [1; 2], List.filter (fun value -> value > 1) [1; 2], List.length [1; 2], List.tryFind (fun value -> value > 1) [1; 2], List.tryGet (fun value -> value = 2) [1; 2], List.tryItem 1 [1; 2], List.tryHead [1; 2], List.tail [1; 2], List.append [1] [2])")>] + [ 8) None, Option.isNone None, Option.isSome (Some 1), Option.map (fun value -> value + 1) (Some 1))")>] + [ state + value) 0 (Map.ofList [(\"a\", 1); (\"b\", 2)]), Map.filter (fun key value -> value > 1) (Map.ofList [(\"a\", 1); (\"b\", 2)]), Map.choose (fun key value -> if value > 1 then Some value else None) (Map.ofList [(\"a\", 1); (\"b\", 2)]), Map.map (fun value -> value + 1) (Map.ofList [(\"a\", 1)]), Map.iter (fun key value -> ignore value) (Map.ofList [(\"a\", 1)]), Map.remove \"a\" (Map.ofList [(\"a\", 1); (\"b\", 2)]))")>] + [] + [ String.concat \",\"")>] + [] + [ node.Value + sum next | None -> node.Value\nsum { Value = 1; Next = Some { Value = 2; Next = None } }")>] + [] + [] + [] + [ value) = (fun value -> value)")>] + [] + [] + [ 1.5, 1.5 <= 1.5, 2.0 >= 2.0)")>] + [] + member _.``Legacy and LIR artifact results conform`` (source: string) = + let expected = Harness.legacy source + match Harness.lir source with + | Ok actual -> + Assert.That(actual.Value, Is.EqualTo(expected.Value), source) + Assert.That(System.String.Join("\n", actual.Stdout), Is.EqualTo(System.String.Join("\n", expected.Stdout)), source) + | Error code -> Assert.Fail($"LIR failed with {code}: {source}") + + [] + [ 0")>] + [] + [] + member _.``Failure categories conform`` (source: string) = + let expected = Harness.legacyFailure source + Assert.That(expected.IsSome, Is.True, source) + Assert.That(Harness.lirFailure source, Is.EqualTo(expected), source) + + [] + [] + [] + [] + [] + [ 0 | n when guard n -> 1 | _ -> 2")>] + [0 then (n+1,n+1) else (n-1,n-1)\n(work 1,work 0)")>] + [] + [] + [ (key+value,key+value,Map.count rest) | _ -> (0,0,0)\nwork 3")>] + member _.``CSE preserves values output and serialized LIR execution`` source = + let expected=Harness.legacy source + match Harness.cse source with + | Ok actual -> Assert.That(actual,Is.EqualTo(expected)) + | Error code -> Assert.Fail($"Optimized LIR failed: {code}") + + [] + [] + [ 0\n(fail 1,fail 1)")>] + member _.``CSE preserves failure categories`` source = + Assert.That(Harness.cse source,Is.EqualTo(Harness.lir source)) diff --git a/tests/FScript.Conformance.Tests/FScript.Conformance.Tests.fsproj b/tests/FScript.Conformance.Tests/FScript.Conformance.Tests.fsproj new file mode 100644 index 0000000..4f84dbd --- /dev/null +++ b/tests/FScript.Conformance.Tests/FScript.Conformance.Tests.fsproj @@ -0,0 +1,21 @@ + + + net10.0 + false + false + + + + + + + + + + + + + + + + diff --git a/tests/FScript.Conformance.Tests/Program.fs b/tests/FScript.Conformance.Tests/Program.fs new file mode 100644 index 0000000..b470242 --- /dev/null +++ b/tests/FScript.Conformance.Tests/Program.fs @@ -0,0 +1,4 @@ +module FScript.Conformance.Tests.Program + +[] +let main _ = 0 diff --git a/tests/FScript.Interpreter.Lir.Tests/FScript.Interpreter.Lir.Tests.fsproj b/tests/FScript.Interpreter.Lir.Tests/FScript.Interpreter.Lir.Tests.fsproj new file mode 100644 index 0000000..652fa5f --- /dev/null +++ b/tests/FScript.Interpreter.Lir.Tests/FScript.Interpreter.Lir.Tests.fsproj @@ -0,0 +1,20 @@ + + + net10.0 + false + false + + + + + + + + + + + + + + + diff --git a/tests/FScript.Interpreter.Lir.Tests/LirInterpreterTests.fs b/tests/FScript.Interpreter.Lir.Tests/LirInterpreterTests.fs new file mode 100644 index 0000000..2df38d1 --- /dev/null +++ b/tests/FScript.Interpreter.Lir.Tests/LirInterpreterTests.fs @@ -0,0 +1,471 @@ +namespace FScript.Interpreter.Lir.Tests + +open System.IO +open FScript.Compiler +open FScript.Language +open NUnit.Framework + +[] +type LirInterpreterTests() = + let errorText (value: obj) = + match value with + | :? CompilerDiagnostic as diagnostic -> diagnostic.Message + | :? (CompilerDiagnostic list) as diagnostics -> System.String.Join("; ", diagnostics |> List.map _.Message) + | _ -> string value + + [] + member _.``Loads a program and invokes an exported function repeatedly`` () = + let source = "export let add x y = x + y\n0" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.load { ScriptName = Some "host.fss"; Arguments = [] } [] compiled.Lir with + | Error diagnostic -> Assert.Fail(errorText diagnostic) + | Ok loaded -> + match LirInterpreter.invoke loaded.Program "add" [ LirValue.VInt 20L; LirValue.VInt 22L ] with + | Error diagnostic -> Assert.Fail(errorText diagnostic) + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt 42L)) + + [] + member _.``Executes registered host externals from loaded programs`` () = + let external = + { Name = "Host.bump" + Scheme = Forall([], TFun(TInt, TInt)) + Arity = 1 + Kind = UnsupportedHostExtern } + let hostExternal = + { Name = "Host.bump" + Invoke = function + | [ LirValue.VInt value ] -> Ok(LirValue.VInt(value + 1L)) + | _ -> Error "expected one integer" } + let source = "export let bumpTwice value = Host.bump (Host.bump value)\n0" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [ external ] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.load { ScriptName = None; Arguments = [] } [ hostExternal ] compiled.Lir with + | Error diagnostic -> Assert.Fail(errorText diagnostic) + | Ok loaded -> + match LirInterpreter.invoke loaded.Program "bumpTwice" [ LirValue.VInt 40L ] with + | Error diagnostic -> Assert.Fail(errorText diagnostic) + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt 42L)) + + [] + member _.``Registered host runtime overrides portable intrinsic fallback`` () = + let hostExternal = + { Name = "Fs.readText" + Invoke = fun _ -> Ok(LirValue.VOption(Some(LirValue.VString "sandboxed"))) } + match Compiler.compile { Program = Parser.parseProgram "Fs.readText \"outside\""; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.executeWithHostExternals { ScriptName = None; Arguments = [] } [ hostExternal ] compiled.Lir with + | Error diagnostic -> Assert.Fail(errorText diagnostic) + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VOption(Some(LirValue.VString "sandboxed")))) + + [] + member _.``Trampolines deep tail recursion`` () = + let source = "let rec loop n = if n <= 0 then n else loop (n - 1)\nloop 200000" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt 0L)) + | Error diagnostic -> Assert.Fail(errorText diagnostic) + + [] + member _.``Tail pipeline trampolining preserves value-first evaluation`` () = + let source = "let tap label value = let _ = Console.writeLine label\n value\nlet rec loop total n = if n <= 0 then total else (tap \"last\" (n - 1)) |> loop (tap \"first\" (total + n))\nloop 0 1" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> + Assert.That(result.Value, Is.EqualTo(LirValue.VInt 1L)) + Assert.That(result.Stdout = [ "last"; "first" ], Is.True) + | Error diagnostic -> Assert.Fail(errorText diagnostic) + + [] + member _.``Captures portable console output`` () = + match Compiler.compile { Program = Parser.parseProgram "Console.writeLine \"hello\""; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok result -> + Assert.That(result.Value, Is.EqualTo(LirValue.VUnit)) + Assert.That(System.String.Join("\n", result.Stdout), Is.EqualTo("hello")) + + [] + [] + member _.``Reads portable console input and reports end of input`` () = + let originalInput = System.Console.In + try + System.Console.SetIn(new StringReader("Ada\n")) + match Compiler.compile { Program = Parser.parseProgram "(Console.readLine (), Console.readLine ())"; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok result -> + Assert.That( + result.Value, + Is.EqualTo( + LirValue.VTuple + [ LirValue.VOption(Some(LirValue.VString "Ada")) + LirValue.VOption None ] + ) + ) + finally + System.Console.SetIn(originalInput) + + [] + member _.``Reads portable text files and reports missing files`` () = + let path = Path.GetTempFileName() + try + File.WriteAllText(path, "hello") + let escapedPath = path.Replace("\\", "\\\\").Replace("\"", "\\\"") + let source = $"(Fs.readText \"{escapedPath}\", Fs.readText \"{escapedPath}.missing\")" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok result -> + Assert.That( + result.Value, + Is.EqualTo( + LirValue.VTuple + [ LirValue.VOption(Some(LirValue.VString "hello")) + LirValue.VOption None ] + ) + ) + finally + File.Delete(path) + + + [] + member _.``Executes aggregate expressions in LIR`` () = + let input = { Program = Parser.parseProgram "[1] @ [2; 3]"; Externs = [] } + match Compiler.compile input with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VList [ LirValue.VInt 1L; LirValue.VInt 2L; LirValue.VInt 3L ])) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + [] + member _.``Logical operations short circuit in LIR`` (source: string, expected: bool) = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VBool expected)) + | Error diagnostic -> Assert.Fail(errorText diagnostic) + + [] + member _.``Executes float comparisons`` () = + match Compiler.compile { Program = Parser.parseProgram "(1.5 < 2.0, 2.0 >= 2.0)"; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VTuple [ LirValue.VBool true; LirValue.VBool true ])) + | Error diagnostic -> Assert.Fail(errorText diagnostic) + + [] + member _.``Reports an empty List tail as a runtime error`` () = + match Compiler.compile { Program = Parser.parseProgram "List.tail []"; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok _ -> Assert.Fail("Expected List.tail to fail") + | Error diagnostic -> Assert.That(diagnostic.Code, Is.EqualTo("FSI3022")) + + [] + [] + [] + member _.``Lowers tuples options and records`` (source: string) = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok _ -> Assert.Pass() + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Executes lexical let bindings and recursive closures`` () = + let source = "let f x = (let rec loop n = if n = 0 then x else loop (n - 1)\n loop 2\n)\nf 7" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt 7L)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Raise preserves an interpreter diagnostic`` () = + match Compiler.compile { Program = Parser.parseProgram "raise \"boom\""; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok _ -> Assert.Fail("Expected failure") + | Error diagnostics -> + Assert.That(diagnostics.Code, Is.EqualTo("FSI3011")) + Assert.That(diagnostics.Message, Is.EqualTo("boom")) + + [ x\n | [] -> 0", 1L)>] + [ x + 1\n | None -> 0", 4L)>] + [ x\n | _ -> 0", 1L)>] + [ x\n | _ -> 42", 42L)>] + member _.``Executes deterministic pattern decision trees`` (source: string, expected: int64) = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt expected)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Executes ranges indexing updates and interpolation`` () = + let cases = + [ "[1..3]", LirValue.VList [ LirValue.VInt 1L; LirValue.VInt 2L; LirValue.VInt 3L ] + "[1; 2][1]", LirValue.VOption(Some(LirValue.VInt 2L)) + "let value = {| Count = 1 |}\n{| value with Count = 2 |}.Count", LirValue.VInt 2L + "$\"value {1 + 2}\"", LirValue.VString "value 3" ] + for source, expected in cases do + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(expected), source) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Executes declared union construction and matching`` () = + let source = "type Shape = | Point | Circle of int\nlet radius shape =\n match shape with\n | Point -> 0\n | Circle r -> r\nradius (Circle 3)" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt 3L)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Executes ordered map construction spread and indexing`` () = + let source = "let tail = { [\"a\"] = 2; [\"b\"] = 3 }\nlet values = { [\"a\"] = 1; ..tail }\nvalues[\"b\"]" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VOption(Some(LirValue.VInt 3L)))) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Initializes mutual recursive groups atomically`` () = + let source = "let rec even n =\n if n = 0 then true else odd (n - 1)\nand odd n =\n if n = 0 then false else even (n - 1)\n\neven 10" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VBool true)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + [] + [] + [] + member _.``Executes portable scalar and collection intrinsics`` (source: string, expected: string) = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VString expected)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Retains host linkage but rejects only reachable external calls`` () = + let external : CompilerExtern = + { Name = "Host.echo" + Scheme = Forall([], TFun(TString, TString)) + Arity = 1 + Kind = UnsupportedHostExtern } + let compile source = Compiler.compile { Program = Parser.parseProgram source; Externs = [ external ] } + match compile "1" with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt 1L)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + match compile "Host.echo \"value\"" with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok _ -> Assert.Fail("Expected unsupported external diagnostic") + | Error diagnostics -> Assert.That(diagnostics.Code, Is.EqualTo("FSI3021")) + + [] + member _.``Default host runtime externs remain inert until reached`` () = + let execute source = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Error diagnostics.Head + | Ok compiled -> LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir + + match execute "let unused = Fs.exists\n42" with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt 42L)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + match execute "Fs.exists \"missing\"" with + | Ok _ -> Assert.Fail("Expected unsupported host-runtime diagnostic") + | Error diagnostics -> Assert.That(diagnostics.Code, Is.EqualTo("FSI3021")) + + [] + member _.``Retains tasks in LIR and rejects them only when reached`` () = + let compile source = Compiler.compile { Program = Parser.parseProgram source; Externs = [] } + match compile "let unused = Task.spawn\n1" with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt 1L)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + match compile "Task.await (Task.spawn (fun _ -> 42))" with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + Assert.That(compiled.Lir.Declarations |> List.exists (fun declaration -> match declaration.Value.Node with Lir.HostExternal("Task.spawn", 1) -> true | _ -> false), Is.True) + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok _ -> Assert.Fail("Expected unsupported task diagnostic") + | Error diagnostics -> Assert.That(diagnostics.Code, Is.EqualTo("FSI3021")) + + [] + member _.``Executes local binding patterns iteration and type tokens`` () = + let cases = + [ "let sum pair = (let (left, right) = pair\n left + right\n)\nsum (1, 2)", LirValue.VInt 3L + "for value in [1; 2; 3] do ignore value", LirValue.VUnit + "type Package = { Name: string }\ntypeof Package", LirValue.VTypeToken(TRecord(Map.ofList [ "Name", TString ])) ] + for source, expected in cases do + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(expected), source) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Executes the complete portable collection intrinsic catalog`` () = + let cases = + [ "List.map (fun value -> value + 1) [1; 2]", LirValue.VList [ LirValue.VInt 2L; LirValue.VInt 3L ] + "List.choose (fun value -> if value > 1 then Some value else None) [1; 2; 3]", LirValue.VList [ LirValue.VInt 2L; LirValue.VInt 3L ] + "List.collect (fun value -> [value; value]) [1; 2]", LirValue.VList [ LirValue.VInt 1L; LirValue.VInt 1L; LirValue.VInt 2L; LirValue.VInt 2L ] + "List.fold (fun state value -> state + value) 0 [1; 2; 3]", LirValue.VInt 6L + "List.tryGet (fun value -> value = 2) [1; 2; 3]", LirValue.VOption(Some(LirValue.VInt 1L)) + "Option.map (fun value -> value + 1) (Some 4)", LirValue.VOption(Some(LirValue.VInt 5L)) + "Option.defaultWith (fun _ -> 7) None", LirValue.VInt 7L + "Map.map (fun value -> value + 1) (Map.filter (fun key value -> value > 1) (Map.ofList [(\"b\", 2); (\"a\", 1)]))", LirValue.VMap [ LirValue.VString "b", LirValue.VInt 3L ] + "Map.fold (fun state key value -> state + value) 0 { [\"a\"] = 1; [\"b\"] = 2 }", LirValue.VInt 3L ] + for source, expected in cases do + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(expected), source) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Preserves top-level pattern bindings and expression order`` () = + match Compiler.compile { Program = Parser.parseProgram "let (left, right) = (1, 2)\nleft + right"; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt 3L)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + match Compiler.compile { Program = Parser.parseProgram "raise \"first\"\nraise \"second\""; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok _ -> Assert.Fail("Expected the first top-level expression to fail") + | Error diagnostics -> Assert.That(diagnostics.Message, Is.EqualTo("first")) + + [] + member _.``Stops evaluating expression children after the first failure`` () = + let source = "(raise \"first\", raise \"second\")" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok _ -> Assert.Fail("Expected tuple evaluation to fail") + | Error diagnostic -> Assert.That(diagnostic.Message, Is.EqualTo("first")) + + [] + member _.``Validates LIR before execution`` () = + match Compiler.compile { Program = Parser.parseProgram "1"; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + let entry = compiled.Lir.Entry.Value + let invalid = { compiled.Lir with Entry = Some { entry with Node = Lir.Load(Lir.SymbolId 999999) } } + match LirInterpreter.execute { ScriptName = None; Arguments = [] } invalid with + | Ok _ -> Assert.Fail("Expected invalid LIR to be rejected") + | Error diagnostic -> Assert.That(diagnostic.Code, Does.StartWith("FSL2")) + + [] + member _.``Executes local mutual recursive closure groups`` () = + let source = "(let rec even n = if n = 0 then true else odd (n - 1)\nand odd n = if n = 0 then false else even (n - 1)\neven 10\n)" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VBool true)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [ (key, value, Map.count tail)\n | {} -> (\"\", 0, 0)")>] + [ (\"Name\", 1, 0)\n | _ -> (\"\", 0, 0)")>] + member _.``Executes map and type-reference patterns`` (source: string) = + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok _ -> Assert.Pass() + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Supplies Env from the LIR interpreter context`` () = + let source = "(Env.ScriptName, Env.Arguments)" + match Compiler.compile { Program = Parser.parseProgram source; Externs = [] } with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = Some "sample.fss"; Arguments = [ "one"; "two" ] } compiled.Lir with + | Ok result -> + Assert.That(result.Value, Is.EqualTo(LirValue.VTuple [ LirValue.VOption(Some(LirValue.VString "sample.fss")); LirValue.VList [ LirValue.VString "one"; LirValue.VString "two" ] ])) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + + [] + member _.``Rejects only reachable target imports`` () = + let compile source = Compiler.compile { Program = Parser.parseProgram source; Externs = [] } + match compile "[] let upper : string -> string\n1" with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok result -> Assert.That(result.Value, Is.EqualTo(LirValue.VInt 1L)) + | Error diagnostics -> Assert.Fail(errorText diagnostics) + match compile "[] let upper : string -> string\nupper \"hello\"" with + | Error diagnostics -> Assert.Fail(errorText diagnostics) + | Ok compiled -> + match LirInterpreter.execute { ScriptName = None; Arguments = [] } compiled.Lir with + | Ok _ -> Assert.Fail("Expected target-import diagnostic") + | Error diagnostics -> Assert.That(diagnostics.Code, Is.EqualTo("FSI3023")) + + [] + member _.``Exit status survives artifacts and remains evaluation local`` () = + let compile source = match Compiler.compile {Program=Parser.parseProgram source;Externs=[]} with Ok p -> p.Lir | Error errors -> failwith (string errors) + let run program = match LirInterpreter.execute {ScriptName=None;Arguments=[]} program with Ok result -> result | Error error -> failwith error.Message + let compiled=compile "Env.setExitCode 7\nEnv.setExitCode 9\n42" + let loaded=match IrArtifact.deserialize (IrArtifact.serialize compiled) with Ok p -> p | Error errors -> failwith (string errors) + let result=run loaded + Assert.That(result.ExitCode,Is.EqualTo(9)) + Assert.That(result.Value,Is.EqualTo(LirValue.VInt 42L)) + Assert.That((run (compile "42")).ExitCode,Is.Zero) + + [] + member _.``Invalid exit status reports a structured interpreter error`` () = + let compiled=match Compiler.compile {Program=Parser.parseProgram "Env.setExitCode 256";Externs=[]} with Ok p -> p.Lir | Error errors -> failwith (string errors) + match LirInterpreter.execute {ScriptName=None;Arguments=[]} compiled with + | Ok _ -> Assert.Fail("Expected an invalid exit code") + | Error diagnostic -> Assert.That(diagnostic.Code,Is.EqualTo("FSI3027")) diff --git a/tests/FScript.Interpreter.Lir.Tests/Program.fs b/tests/FScript.Interpreter.Lir.Tests/Program.fs new file mode 100644 index 0000000..9bce492 --- /dev/null +++ b/tests/FScript.Interpreter.Lir.Tests/Program.fs @@ -0,0 +1,4 @@ +module FScript.Interpreter.Lir.Tests.Program + +[] +let main _ = 0 diff --git a/tests/FScript.Language.Tests/EvalTests.fs b/tests/FScript.Language.Tests/EvalTests.fs index d17f75a..2015a3a 100644 --- a/tests/FScript.Language.Tests/EvalTests.fs +++ b/tests/FScript.Language.Tests/EvalTests.fs @@ -302,6 +302,15 @@ type EvalTests () = | VString value -> value |> should equal "2.5" | _ -> Assert.Fail("Expected float to string") + [] + [] + [] + [] + member _.``String replacement always returns`` (oldValue: string, newValue: string, source: string, expected: string) = + match Helpers.eval ($"String.replace \"{oldValue}\" \"{newValue}\" \"{source}\"") with + | VString actual -> Assert.That(actual, Is.EqualTo(expected)) + | _ -> Assert.Fail("Expected a string") + [] member _.``Evaluates string manipulation builtins`` () = match Helpers.eval "String.replace \"world\" \"fscript\" \"hello world\"" with @@ -458,6 +467,11 @@ type EvalTests () = Helpers.eval "1 < 2" |> assertBool true Helpers.eval "true && false" |> assertBool false + [] + member _.``Logical operators short circuit their right operand`` () = + Helpers.eval "false && raise \"and-right\"" |> assertBool false + Helpers.eval "true || raise \"or-right\"" |> assertBool true + [] member _.``Evaluates pipeline operator`` () = Helpers.eval "let inc x = x + 1\n1 |> inc" |> assertInt 2L diff --git a/tests/FScript.Language.Tests/FScript.Language.Tests.fsproj b/tests/FScript.Language.Tests/FScript.Language.Tests.fsproj index 4c38560..98aa467 100644 --- a/tests/FScript.Language.Tests/FScript.Language.Tests.fsproj +++ b/tests/FScript.Language.Tests/FScript.Language.Tests.fsproj @@ -13,6 +13,7 @@ + diff --git a/tests/FScript.Language.Tests/ParserTests.fs b/tests/FScript.Language.Tests/ParserTests.fs index 03978e8..f64f61b 100644 --- a/tests/FScript.Language.Tests/ParserTests.fs +++ b/tests/FScript.Language.Tests/ParserTests.fs @@ -719,6 +719,17 @@ type ParserTests () = | SExpr (EInterpolatedString ([ IPText "hello "; IPExpr (EVar ("name", _)) ], _)) -> () | _ -> Assert.Fail("Expected interpolated string") + [] + member _.``Interpolation placeholders retain absolute source spans`` () = + let program = Parser.parseProgramWithSourceName (Some "sample.fss") "let name = \"Ada\"\n$\"hello {name}\"" + match program with + | [ _; SExpr(EInterpolatedString([ IPText "hello "; IPExpr(EVar("name", span)) ], _)) ] -> + Assert.That(span.Start.File, Is.EqualTo(Some "sample.fss")) + Assert.That(span.Start.Line, Is.EqualTo(2)) + Assert.That(span.Start.Column, Is.EqualTo(10)) + Assert.That(span.End.Column, Is.EqualTo(14)) + | _ -> Assert.Fail("Expected interpolated variable placeholder") + [] member _.``Parses interpolated placeholder containing string literal`` () = let p = Helpers.parse "$\"{if true then \"missing\" else \"none\"}\"" @@ -796,50 +807,44 @@ type ParserTests () = act |> should throw typeof [] - member _.``Rejects attribute export syntax`` () = - let act () = Helpers.parse "[] let y = 1" |> ignore - act |> should throw typeof + member _.``Parses contextual export syntax`` () = + match Helpers.parse "export let y = 1" with + | [ SLet("y", _, _, _, _, true, _) ] -> () + | _ -> Assert.Fail("Expected exported let binding") - [] - member _.``Rejects wrong attribute casing`` () = - let act () = Helpers.parse "[] let y = 1" |> ignore - act |> should throw typeof + [] + [] + member _.``Export attribute forms are plain syntax errors`` (name: string) = + try + Helpers.parse $"[<{name}>] let answer = 42" |> ignore + Assert.Fail("Expected a parse error") + with ParseException error -> + Assert.That(error.Message, Is.EqualTo("Unexpected attribute")) + Assert.That(error.Span.Start.Line, Is.EqualTo(1)) [] member _.``Rejects export prefix in nested expression block`` () = let act () = Helpers.parse "(let x =\n export let y = 1\n y\n)" |> ignore act |> should throw typeof - [] - member _.``Parses exported value`` () = - match Helpers.parse "export let answer = 42" with - | [ SLet("answer", [], None, _, false, true, _) ] -> () - | _ -> Assert.Fail("Expected exported value") + member _.``Parses bodyless backend import attributes`` () = + match Helpers.parse "[] let upper : string -> string" with + | [ SBackendImport("upper", TRFun(TRName "string", TRName "string"), import, _) ] -> + import.ModulePath |> should equal "strings" + import.MemberName |> should equal "ToUpper" + | _ -> Assert.Fail("Expected backend import") [] - member _.``Export remains an ordinary binding and parameter name`` () = - match Helpers.parse "let export = 42\nlet identity export = export\nexport\nidentity export" with - | [ SLet("export", [], _, _, false, false, _) - SLet("identity", [param], _, EVar("export", _), false, false, _) - SExpr(EVar("export", _)) - SExpr(EApply(EVar("identity", _), EVar("export", _), _)) ] -> - Assert.That(param.Name, Is.EqualTo("export")) - | _ -> Assert.Fail("Expected ordinary export identifiers") + member _.``Parses backend import attributes on record types`` () = + match Helpers.parse "[] type Person = { Name: string; Age: int }" with + | [ SType { Name = "Person"; Import = Some import; Fields = fields } ] -> + import.ModulePath |> should equal "example.com/model" + import.MemberName |> should equal "Person" + fields.Length |> should equal 2 + | _ -> Assert.Fail("Expected imported record type") [] - member _.``An exported binding may itself be named export`` () = - match Helpers.parse "export let export export = export" with - | [ SLet("export", [param], _, EVar("export", _), false, true, _) ] -> - Assert.That(param.Name, Is.EqualTo("export")) - | _ -> Assert.Fail("Expected exported function named export") - - [] - [] - [] - member _.``Rejects exported local bindings`` (source: string) = - try - Helpers.parse source |> ignore - Assert.Fail("Expected parse error") - with - | ParseException detail -> Assert.That(detail.Message, Does.Contain("top level")) + member _.``Rejects backend imports with bodies`` () = + let act () = Helpers.parse "[] let upper : string -> string = fun value -> value" |> ignore + act |> should throw typeof diff --git a/tests/FScript.Language.Tests/ResolvedInferenceTests.fs b/tests/FScript.Language.Tests/ResolvedInferenceTests.fs new file mode 100644 index 0000000..e96470d --- /dev/null +++ b/tests/FScript.Language.Tests/ResolvedInferenceTests.fs @@ -0,0 +1,176 @@ +namespace FScript.Language.Tests + +open FScript.Language +open NUnit.Framework + +[] +type ResolvedInferenceTests() = + let rec flatten (expression: TypeInfer.ResolvedExpression) = expression :: List.collect flatten expression.Children + + [] + member _.``Resolved inference captures every expression without changing legacy output`` () = + let program = Helpers.parse "let add x y = x + y\nadd 1 2" + let legacy = TypeInfer.inferProgram program + let resolved = TypeInfer.inferResolvedProgram program + + Assert.That(resolved.TypedProgram.Length, Is.EqualTo(legacy.Length)) + Assert.That(resolved.ExpressionTypes, Is.Not.Empty) + + let finalApplications = + resolved.ExpressionTypes + |> List.choose (fun item -> + match item.Expr with + | EApply _ -> Some item.Type + | _ -> None) + + Assert.That(finalApplications, Does.Contain(TInt)) + + [] + member _.``Legacy inference preserves the resolved typed program shape`` () = + let program = Helpers.parse "let add x y = x + y\nadd 40 2" + let resolved = TypeInfer.inferResolvedProgram program + let legacy = TypeInfer.inferProgram program + + Assert.That(legacy.Length, Is.EqualTo(resolved.TypedProgram.Length)) + Assert.That(resolved.ExpressionTypes |> List.exists (fun item -> item.Type = TInt), Is.True) + + [] + member _.``Resolved inference assigns deterministic semantic symbols and typed references`` () = + let program = Helpers.parse "let apply f value = f value\napply (fun item -> item + 1) 41" + let first = TypeInfer.inferResolvedProgram program + let second = TypeInfer.inferResolvedProgram program + + Assert.That(first.Symbols = second.Symbols, Is.True) + Assert.That(first.SymbolReferences = second.SymbolReferences, Is.True) + Assert.That((first.Symbols |> List.map _.SymbolId) = [ 0 .. first.Symbols.Length - 1 ], Is.True) + Assert.That(first.Symbols |> List.exists (fun symbol -> symbol.Name = "apply" && symbol.Kind = TypeInfer.DeclarationSymbol), Is.True) + Assert.That(first.Symbols |> List.exists (fun symbol -> symbol.Name = "item" && symbol.Kind = TypeInfer.ParameterSymbol), Is.True) + Assert.That(first.SymbolReferences |> List.exists (fun reference -> reference.Name = "apply" && reference.Type = TFun(TFun(TInt, TInt), TFun(TInt, TInt))), Is.True) + + [] + member _.``Resolved declaration schemes normalize type variables`` () = + let resolved = Helpers.parse "let identity value = value\nidentity 1" |> TypeInfer.inferResolvedProgram + let scheme = + resolved.Symbols + |> List.find (fun symbol -> symbol.Name = "identity" && symbol.Kind = TypeInfer.DeclarationSymbol) + |> _.Scheme + Assert.That(scheme, Is.EqualTo(Some(Forall([ 0 ], TFun(TVar 0, TVar 0))))) + + [] + member _.``Resolved frontend exposes a recursively typed operation tree`` () = + let resolved = Helpers.parse "let add x y = x + y\nadd 1 2" |> TypeInfer.inferResolvedProgram + let expressions = resolved.ResolvedStatements |> List.collect _.Expressions |> List.collect flatten + Assert.That(expressions, Is.Not.Empty) + Assert.That(expressions |> List.forall (fun expression -> expression.Type <> TVar -1), Is.True) + Assert.That(expressions |> List.exists (fun expression -> expression.Primitive = Some TypeInfer.NumericAddition), Is.True) + Assert.That(expressions |> List.exists (fun expression -> expression.Reference |> Option.exists (fun reference -> reference.Name = "add")), Is.True) + Assert.That(expressions |> List.exists (fun expression -> match expression.Node with TypeInfer.ResolvedPrimitive(TypeInfer.NumericAddition, _) -> true | _ -> false), Is.True) + Assert.That(expressions |> List.exists (fun expression -> match expression.Node with TypeInfer.ResolvedReference reference when reference.Name = "add" && reference.Kind = TypeInfer.DeclarationSymbol -> true | _ -> false), Is.True) + + [] + member _.``Resolved patterns reuse one symbol for repeated bindings`` () = + let source = "match { [\"a\"] = \"a\" } with\n | { [same] = same } -> true\n | _ -> false" + let resolved = Helpers.parse source |> TypeInfer.inferResolvedProgram + let rec bindingIds (pattern: TypeInfer.ResolvedPattern) = + match pattern.Node with + | TypeInfer.ResolvedPatternBinding binding -> [ binding.SymbolId ] + | TypeInfer.ResolvedMapPattern(clauses, tail) -> + (clauses |> List.collect (fun (key, value) -> bindingIds key @ bindingIds value)) + @ (tail |> Option.map bindingIds |> Option.defaultValue []) + | _ -> [] + let ids = + resolved.ResolvedStatements + |> List.collect (fun statement -> + match statement.Node with + | TypeInfer.ResolvedExpressionStatement { Node = TypeInfer.ResolvedMatch(_, cases) } -> cases |> List.collect (_.Pattern >> bindingIds) + | _ -> []) + Assert.That(ids.Length, Is.EqualTo(2)) + Assert.That(ids |> List.distinct |> List.length, Is.EqualTo(1)) + + [] + member _.``Resolved applications retain record coercion evidence`` () = + let source = "type Person = { Name: string; Age: int }\nlet age (person: Person) = person.Age\nage {| Name = \"Ada\"; Age = 42 |}" + let resolved = Helpers.parse source |> TypeInfer.inferResolvedProgram + let expressions = resolved.ResolvedStatements |> List.collect _.Expressions |> List.collect flatten + let coercion = expressions |> List.choose _.RecordCoercion |> List.tryHead + match coercion with + | Some evidence -> + Assert.That(evidence.TargetName, Is.EqualTo(Some "Person")) + match evidence.SourceType with TRecord fields -> Assert.That(fields.Count, Is.EqualTo(2)) | _ -> Assert.Fail("Expected structural record source") + | None -> Assert.Fail("Expected structural-to-named record coercion evidence") + + [] + member _.``Resolved interpolation references retain their lexical parameter`` () = + let source = "let first (value: int) = $\"{value}\"\nlet second (value: string) = $\"{value}\"\nsecond \"ok\"" + let resolved = Helpers.parse source |> TypeInfer.inferResolvedProgram + let parameterIds = + resolved.Symbols + |> List.filter (fun symbol -> symbol.Kind = TypeInfer.ParameterSymbol && symbol.Name = "value") + |> List.map _.SymbolId + let interpolationReferences = + resolved.ResolvedStatements + |> List.collect _.Expressions + |> List.collect flatten + |> List.choose (fun expression -> + match expression.Node with + | TypeInfer.ResolvedReference reference when reference.Name = "value" -> Some(reference.SymbolId, reference.Type) + | _ -> None) + Assert.That(parameterIds.Length, Is.EqualTo(2)) + let expected = [ (parameterIds.[0], TInt); (parameterIds.[1], TString) ] + Assert.That((interpolationReferences = expected), Is.True) + + [] + member _.``Resolved top-level shadowing keeps sequential lexical identities`` () = + let resolved = Helpers.parse "let value = 1\nlet value = value + 1\nvalue" |> TypeInfer.inferResolvedProgram + let declarations = + resolved.Symbols + |> List.filter (fun symbol -> symbol.Kind = TypeInfer.DeclarationSymbol && symbol.Name = "value") + |> List.map _.SymbolId + let references = + resolved.SymbolReferences + |> List.filter (fun reference -> reference.Kind = TypeInfer.DeclarationSymbol && reference.Name = "value") + |> List.map _.SymbolId + Assert.That(declarations.Length, Is.EqualTo(2)) + Assert.That((references = declarations), Is.True) + + [] + member _.``Resolved structural readers retain the whole argument shape`` () = + let source = "let city (value: {| City: string |}) = value.City\ncity {| City = \"Paris\"; Zip = 75000 |}" + let resolved = Helpers.parse source |> TypeInfer.inferResolvedProgram + let argument = + resolved.ResolvedStatements + |> List.collect _.Expressions + |> List.collect flatten + |> List.choose (fun expression -> match expression.Node with TypeInfer.ResolvedApply(_, argument) -> Some argument | _ -> None) + |> List.exactlyOne + match argument.Type with + | TRecord fields -> Assert.That(fields.Count, Is.EqualTo(2)) + | _ -> Assert.Fail("Expected the complete structural argument") + + [] + member _.``Resolved statements preserve structured export metadata`` () = + let resolved = Helpers.parse "export let answer = 42" |> TypeInfer.inferResolvedProgram + match resolved.ResolvedStatements |> List.tryPick _.Export with + | Some export -> + Assert.That(export.Name, Is.EqualTo("answer")) + Assert.That(export.Span.Start.Line, Is.EqualTo(1)) + | None -> Assert.Fail("Expected resolved export metadata") + let attributes = resolved.ResolvedStatements |> List.collect _.Attributes + Assert.That(attributes |> List.map _.Name, Does.Contain("Export")) + + [] + member _.``Resolved statements attach structured import attributes`` () = + let source = "[] type Person = { Name: string }\n[] let upper : string -> string" + let resolved = Helpers.parse source |> TypeInfer.inferResolvedProgram + let imports = resolved.ResolvedStatements |> List.collect _.Attributes |> List.filter (fun attribute -> attribute.Name = "Import") + Assert.That(imports.Length, Is.EqualTo(2)) + Assert.That(imports |> List.map _.Arguments, Does.Contain([ "strings"; "ToUpper" ])) + + [] + member _.``Resolved statements retain custom structured attributes`` () = + let source = "[]\nlet answer = 42" + let resolved = Helpers.parse source |> TypeInfer.inferResolvedProgram + let attribute = resolved.ResolvedStatements.Head.Attributes |> List.exactlyOne + Assert.That(attribute.Name, Is.EqualTo("BackendHint")) + Assert.That(attribute.Arguments = [ "fast"; "stable" ], Is.True) + Assert.That(attribute.Span.Start.Line, Is.EqualTo(1)) diff --git a/tests/FScript.LanguageServer.Tests/CSharpServerCoreTests.cs b/tests/FScript.LanguageServer.Tests/CSharpServerCoreTests.cs index e3f5310..a8590c4 100644 --- a/tests/FScript.LanguageServer.Tests/CSharpServerCoreTests.cs +++ b/tests/FScript.LanguageServer.Tests/CSharpServerCoreTests.cs @@ -235,7 +235,7 @@ public void CSharp_server_didOpen_accepts_Env_binding_without_unbound_diagnostic ["uri"] = uri, ["languageId"] = "fscript", ["version"] = 1, - ["text"] = "Env.Arguments |> List.length" + ["text"] = "Env.setExitCode 0\nEnv.Arguments |> List.length" } }; LspClient.SendNotification(client, "textDocument/didOpen", didOpenParams); diff --git a/tests/FScript.Runtime.Tests/ExtensionBridgeTests.fs b/tests/FScript.Runtime.Tests/ExtensionBridgeTests.fs index 83a780b..69a17fb 100644 --- a/tests/FScript.Runtime.Tests/ExtensionBridgeTests.fs +++ b/tests/FScript.Runtime.Tests/ExtensionBridgeTests.fs @@ -79,6 +79,7 @@ type ExtensionBridgeTests() = Apply = fun _ _ -> failwith "unused" SpawnTask = fun _ -> failwith "unused" AwaitTask = fun _ -> failwith "unused" + SetExitCode = ignore CheckRuntime = fun () -> raise (OperationCanceledException "host limit") } let error = Assert.Throws(Action(fun () -> registration.Functions.Head.Impl context [VUnit] |> ignore)) |> nonNull Assert.That(error.Message, Is.EqualTo("host limit")) diff --git a/tests/FScript.Runtime.Tests/HostTestHelpers.fs b/tests/FScript.Runtime.Tests/HostTestHelpers.fs index 0e7a069..7f45199 100644 --- a/tests/FScript.Runtime.Tests/HostTestHelpers.fs +++ b/tests/FScript.Runtime.Tests/HostTestHelpers.fs @@ -21,6 +21,7 @@ module HostTestHelpers = Apply = noApply SpawnTask = noSpawnTask AwaitTask = noAwaitTask + SetExitCode = ignore CheckRuntime = fun () -> () } args diff --git a/tests/FScript.Runtime.Tests/ScriptHostTests.fs b/tests/FScript.Runtime.Tests/ScriptHostTests.fs index 2d98354..66f7cfb 100644 --- a/tests/FScript.Runtime.Tests/ScriptHostTests.fs +++ b/tests/FScript.Runtime.Tests/ScriptHostTests.fs @@ -155,3 +155,34 @@ type ScriptHostTests () = match ScriptHost.invoke loaded "export" [VString "value"] with | VString "value" -> () | _ -> Assert.Fail("Expected exported function named export") + + [] + member _.``Exit codes are scoped to evaluation and do not terminate the host`` () = + let original=System.Environment.ExitCode + let loaded=ScriptHost.loadSource [] "Env.setExitCode 7\nEnv.setExitCode 9\n42" + Assert.That(loaded.ExitCode,Is.EqualTo(9)) + Assert.That(Pretty.valueToString loaded.LastValue,Is.EqualTo("42")) + Assert.That((ScriptHost.loadSource [] "42").ExitCode,Is.Zero) + Assert.That(System.Environment.ExitCode,Is.EqualTo(original)) + + [] + member _.``Export invocations return their own exit code`` () = + let loaded=ScriptHost.loadSource [] "export let configure code = Env.setExitCode code\n42" + let result=ScriptHost.invokeWithExitCode loaded "configure" [VInt 7L] + Assert.That(result.ExitCode,Is.EqualTo(7)) + Assert.That(Pretty.valueToString result.Value,Is.EqualTo("()")) + Assert.That(loaded.ExitCode,Is.Zero) + Assert.That((ScriptHost.invokeWithExitCode loaded "configure" [VInt 0L]).ExitCode,Is.Zero) + + [] + member _.``Awaited tasks share status without stopping subsequent evaluation`` () = + let registration=HostInterop.ofExterns [TaskFunctions.spawn;TaskFunctions.awaitTask] + let loaded=ScriptHost.loadSourceWithRegistration registration "let worker=Task.spawn (fun () -> Env.setExitCode 3)\nTask.await worker\nEnv.setExitCode 7\n42" + Assert.That(loaded.ExitCode,Is.EqualTo(7)) + Assert.That(Pretty.valueToString loaded.LastValue,Is.EqualTo("42")) + + [] + [] + member _.``Exit codes use the portable shell range`` source = + let error=Assert.Throws(System.Action(fun () -> ScriptHost.loadSource [] source |> ignore)) |> nonNull + Assert.That(string error,Does.Contain("between 0 and 255")) diff --git a/tests/FScript.Runtime.Tests/SdkTestHost.fs b/tests/FScript.Runtime.Tests/SdkTestHost.fs index 9613405..9af9280 100644 --- a/tests/FScript.Runtime.Tests/SdkTestHost.fs +++ b/tests/FScript.Runtime.Tests/SdkTestHost.fs @@ -10,6 +10,7 @@ module SdkTestHost = Apply = fun _ _ -> failwith "No callbacks in data conversion" SpawnTask = fun _ -> failwith "No tasks in data conversion" AwaitTask = fun _ -> failwith "No tasks in data conversion" + SetExitCode = ignore CheckRuntime = ignore } let invokeExternal (fn: FScript.Extensibility.ExternalFunction) args = fn.Impl (FScript.Extensibility.ExternalCallContext((fun _ _ -> failwith "unused"), (fun _ -> failwith "unused"), (fun _ -> failwith "unused"), ignore)) args diff --git a/website/docs/compiler/compilation.md b/website/docs/compiler/compilation.md new file mode 100644 index 0000000..10d6f0a --- /dev/null +++ b/website/docs/compiler/compilation.md @@ -0,0 +1,62 @@ +--- +id: compilation +title: Compilation +slug: /compiler/overview +--- + +FScript can run inside a host application or compile into a program that runs on its own. Compilation checks the same language types, resolves imported scripts, and produces ordinary .NET code. Generated programs do not load FScript source or start an interpreter. + +## Choose an output + +| Output | Command options | Use it when | +| --- | --- | --- | +| .NET assembly | `--target dotnet` | You want compiled execution with FScript's assembly optimizations. Run the DLL with .NET 10. | +| Self-contained executable | `--target dotnet --single-file [--runtime ]` | You want one distributable executable that includes the .NET runtime. | +| Native AOT executable | `--target dotnet --aot [--runtime ]` | You want dependencies trimmed and compiled into a native executable. | +| C# project | `--target csharp` | You want to inspect, edit, or integrate generated source in a .NET build. | + +The [optimization guide](./compiler-optimizations.md) explains the shared passes and the additional work performed by the assembly target. + +## Compile a first program + +Save this as `hello.fss`: + +```fsharp +let name = + match Env.Arguments with + | first :: _ -> first + | [] -> "world" + +Console.writeLine $"Hello {name}!" +``` + +Compile and run it: + +```sh +fscript compile hello.fss --target dotnet --output out/hello +dotnet out/hello/hello.dll Ada +``` + +The program writes `Hello Ada!`, followed by `()`, its final FScript result. Arguments after the assembly or executable name become `Env.Arguments`. `Env.ScriptName` contains the running assembly or executable filename. + +From a checkout, replace `fscript` with `dotnet run --project src/FScript --` in these commands. + +## Language and runtime behavior + +Records, unions, tuples, lists, options, maps, closures, patterns, and recursive functions retain their FScript semantics. Equality remains structural, collections remain immutable, Boolean operators short-circuit, and top-level effects execute once in source order. An exported binding uses `export let`. + +Script imports are resolved at compile time. An application needs its managed dependencies and any files it reads as input, but does not need the original `.fss` files to execute. + +Standalone applications use the process working directory and operating-system permissions. Interpreter sandbox restrictions and execution budgets are not carried into compiled binaries. + +## Host integration + +Both targets support .NET FFI selected through the normal environment configuration. Existing SDK providers can run through generated adapters. Typed CLR mappings enable direct calls and make provider code suitable for trimming and Native AOT when its dependencies support them. + +See [Compile to .NET](./compile-to-dotnet.md) for FFI configuration, typed bindings, publishing, and runtime identifiers, or [Compile to C#](./compile-to-csharp.md) for project layout and reference handling. + +## Compiling and embedding + +Compilation is an explicit CLI or compiler API operation. Running `fscript program.fss` or using ordinary `ScriptHost` embedding continues to use the AST interpreter. JavaScript embedding also remains interpreted. + +The separate [IR workflow](./interpret-ir.md) produces a versioned `.fsir` artifact and executes it with the LIR interpreter. It is useful for compiler tooling and conformance work; it is not required to run compiled .NET programs. diff --git a/website/docs/compiler/compile-to-csharp.md b/website/docs/compiler/compile-to-csharp.md new file mode 100644 index 0000000..9689a9e --- /dev/null +++ b/website/docs/compiler/compile-to-csharp.md @@ -0,0 +1,71 @@ +--- +id: compile-to-csharp +title: Compile to C# +slug: /compiler/csharp +--- + +The C# backend writes an independently buildable .NET 10 project. Use it when generated source belongs in your build, when you need to inspect a translated program, or when you want to make further changes in C#. + +For FScript's additional call, closure, tail-recursion, and pruning optimizations, use the [.NET assembly target](./compile-to-dotnet.md). Building generated C# does not enable those assembly-only passes. + +## Generate, build, and run + +```sh +fscript compile hello.fss --target csharp --output out/hello-csharp +dotnet build out/hello-csharp/Program.csproj -c Release +dotnet run --project out/hello-csharp/Program.csproj -c Release -- Ada +``` + +Building the generated project requires the .NET 10 SDK. From the FScript checkout, generation can instead use: + +```sh +dotnet run --project src/FScript -- compile samples/hello.fss --target csharp --output out/hello-csharp +``` + +Generation writes source and a project file; it does not invoke the SDK to build that project. After building, execution uses the generated program and its dependencies, without an interpreter, source script, or `.fsir` artifact. + +Generated executables print the final value by default. Add `--no-result` when compiling to suppress that display and permit pure discarded work to be pruned. Explicit `Console.writeLine` calls remain observable. Successful execution returns status `0`, independently of the final value; `Env.setExitCode` selects another status without stopping execution. The generated `Program.ExitCode` property exposes the selected status to callers without changing the host process. See [results and shell status](../reference/cli-reference.md#results-and-shell-status). + +## Project layout + +```text +out/hello-csharp/ + Program.cs + Runtime.cs + Program.csproj + RuntimeSDK.cs # when SDK provider adapters are needed +``` + +`Program.cs` contains generated declarations, concrete data types, helper methods, and the entry point. `Runtime.cs` supplies collection and runtime support. SDK-backed programs also receive `RuntimeSDK.cs` and explicit managed assembly references. + +The default generated class is `FScript.Generated.Program`. Its entry point calls `Run`, formats the final FScript value, and writes it to stdout. Console writes in the script appear before that final result. Exports use typed public properties; genuine function values use typed delegates. + +Generated names and internal layout may change between compiler versions. Regeneration replaces compiler-owned files, so keep hand-written changes separately or work in another directory. + +## Types and functions + +Reachable polymorphic uses are specialized to concrete types. Integers become `long`, floats become `double`, Booleans become `bool`, and strings become `string`. Lists use arrays, options use typed structs, maps use ordered entries, and records, tuples, and unions use generated typed declarations. FScript equality and formatting use dedicated helpers. + +A curried function may appear as nested `Func` delegates. Captures and partial applications can remain visible in the output. The source target shares specialization and simplification with the assembly target, but does not run its additional native-call lowering, self-tail-call loop conversion, or aggressive generated-member pruning. Ordinary C# release compilation and the .NET JIT still perform their own optimizations. + +See [Compilation and optimizations](./compiler-optimizations.md) for the full distinction. + +## .NET FFI and references + +Provider selection uses the same `fscript.toml`, `--config`, `--extern-assembly`, and `--no-default-externs` options as other CLR compilation workflows. Add explicit dependencies with repeated `--reference` arguments: + +```sh +fscript compile extension.fss --target csharp --output out/extension-csharp --extern-assembly path/to/Provider.dll --reference path/to/Dependency.dll +``` + +The generated project records assembly references using paths resolved on the compiling machine. Keep those assemblies available while building. When moving the project, update reference paths or replace them with your own project/package references. The SDK copies private managed dependencies into the application's build output. + +Generated adapters support registered host values, callbacks, and tasks. Compiler-only typed mappings can instead link exact CLR methods and native types. See [typed FFI bindings](./compile-to-dotnet.md#prunable-typed-ffi-bindings) for the provider contract and compatibility requirements. + +`--single-file`, `--aot`, and `--runtime` are FScript CLI options for `--target dotnet`; they are rejected with `--target csharp`. Use that target for FScript-managed publishing. You can also maintain and publish an owned C# project through your normal .NET build process, subject to its dependencies' trimming and AOT requirements. + +## Diagnostics + +The C# backend reports `FSC6xxx` diagnostics, including unsupported CLR signatures and representations that cannot be specialized. Shared frontend and IR errors retain their own codes and source spans. + +An unconstrained result such as `let identity value = value` followed by `identity` has no concrete native signature. Apply it at a concrete type or give its boundary an explicit concrete annotation. A generalized initializer is also rejected when specialization would duplicate an observable effect. diff --git a/website/docs/compiler/compile-to-dotnet.md b/website/docs/compiler/compile-to-dotnet.md new file mode 100644 index 0000000..fc9bd10 --- /dev/null +++ b/website/docs/compiler/compile-to-dotnet.md @@ -0,0 +1,185 @@ +--- +id: compile-to-dotnet +title: Compile to .NET +slug: /compiler/dotnet +--- + +The .NET backend compiles a typed FScript program into an optimized .NET assembly. For a buildable source project, use [the C# backend](./compile-to-csharp.md). Generated programs do not require the source script, a `.fsir` file, `ScriptHost`, or an interpreter. + +## Build-machine requirements + +| Operation | Requirements | +| --- | --- | +| Generate a `.dll` with `--target dotnet` | FScript and a .NET 10 runtime; no SDK required. Roslyn is bundled with FScript and emits the assembly in-process. | +| Publish with `--single-file` | .NET 10 SDK available through `dotnet` on PATH. | +| Publish with `--aot` | .NET 10 SDK plus the target platform's native build tools; build on the target OS. | + +Running FScript itself from source with `dotnet run` requires the SDK to build FScript. That is separate from the installed compiler's requirements. A generated ordinary DLL needs a .NET 10 runtime to run; published single-file and AOT executables do not require a .NET installation on the destination machine. + +## Runnable .NET assembly + +```sh +dotnet run --project src/FScript -- compile samples/fibonacci.fss --target dotnet --output out/fibonacci-dotnet +dotnet out/fibonacci-dotnet/fibonacci.dll +``` + +Compiled entry points print the final value by default. Add `--no-result` when compiling to suppress it and allow proven-pure discarded computations to be pruned. Explicit output, failures, and exit-code writes remain observable. Without this flag, library callers can retrieve the typed value through `Run` and format it explicitly with `FormatResult`; in discard mode, `Run` returns unit. + +Output includes a `.dll`, runtime configuration, and required external managed dependencies. The minimum runtime is .NET 10. Arguments after the assembly name become `Env.Arguments`. + +```sh +dotnet run --project src/FScript -- compile samples/basic/basic.fss --target dotnet --output out/basic-dotnet +dotnet out/basic-dotnet/basic.dll samples/basic/helloworld.bas +``` + +Compiled filesystem operations use the process working directory and OS permissions. Interpreter sandbox and execution-budget settings do not apply to standalone binaries. + +Assembly compilation resolves known calls and partial applications, lowers self tail calls to loops, and removes unused generated support code. Functions that escape into collections or FFI still use typed delegates. These optimizations apply to the assembly target. See [Compilation and optimizations](./compiler-optimizations.md) for the pass-by-pass comparison and its limits. + +## Single-file and Native AOT executables + +Both options produce one executable containing the compiled program and its dependencies. A .NET runtime installation is not required on the destination machine. + +```sh +# Self-contained bundle with the .NET runtime +fscript compile samples/hello.fss --target dotnet --single-file --output out/hello-single +./out/hello-single/hello Ada + +# Ahead-of-time compiled native executable +fscript compile samples/hello.fss --target dotnet --aot --output out/hello-native +./out/hello-native/hello Ada +``` + +These flags are available only for `--target dotnet`. When `--runtime` is omitted, publishing targets the current .NET host runtime identifier (`RuntimeInformation.RuntimeIdentifier`), so both commands above build for the current platform. Pass `--runtime ` to select another target. An explicitly supplied `--runtime` still requires a value. Use .NET runtime identifiers: + +| Platform | x64 | Arm64 | +| --- | --- | --- | +| macOS | `osx-x64` | `osx-arm64` | +| Linux | `linux-x64` | `linux-arm64` | +| Windows | `win-x64` | `win-arm64` | + +Invalid or unsupported identifiers produce `FSN7101` before SDK publishing. The diagnostic includes the supplied identifier and supported values; `darwin-arm64`, for example, suggests `osx-arm64`. + +When invoking FScript from source, put `--` between `dotnet run` options and FScript arguments: + +```sh +dotnet run --project src/FScript -- compile samples/hello.fss --target dotnet --aot --output out/hello-native +``` + +Without that separator, `dotnet run` can consume `--runtime` itself and fail while building FScript, before its CLI starts. Such SDK errors cannot be reported by FScript. + +Windows output has an `.exe` extension; macOS and Linux output has no extension. Use a fresh output directory when switching from DLL output: existing files are not deleted. External data such as BASIC source files remains program input and is not bundled. + +Publishing requires a .NET 10 SDK on the build machine and may restore runtime/compiler packs from NuGet. Native AOT additionally requires the platform's native build tools (Xcode Command Line Tools on macOS; Clang and zlib headers on Linux; Visual Studio C++ build tools on Windows). Native AOT must be built on the target OS; single-file managed publishing can target another OS. The executables still use normal OS libraries. See Microsoft's [single-file](https://learn.microsoft.com/dotnet/core/deploying/single-file/) and [Native AOT](https://learn.microsoft.com/dotnet/core/deploying/native-aot/) deployment documentation. + +Single-file publishing trims dependencies when all reachable FFI calls have static CLR bindings. Reachable legacy provider dispatch disables managed trimming to preserve its registration contract. Bundled native runtime libraries may be extracted by the .NET host at startup. Native AOT trims and compiles dependencies, so FFI libraries must be AOT-compatible. Dynamic loading or reflection-heavy providers may produce SDK diagnostics instead of a runnable native binary. Packaging failures are reported as `FSN710x`, including the SDK's diagnostics. + +The compiler packages its optimized assembly; it does not recompile the script through the C# source target. The ordinary DLL target remains available without invoking `dotnet publish`. + +## C# source project + +`--target csharp` generates source instead of an assembly. Its project layout, build commands, and reference handling are covered in [Compile to C#](./compile-to-csharp.md). + +## Existing FFI providers + +Compilation uses ordinary `fscript.toml` discovery. `--config`, `--no-config`, `--extern-assembly`, and `--no-default-externs` select the environment. Repeat `--reference ` to add managed references. + +```sh +dotnet build samples/ffi/FfiSample.fsproj -c Release +dotnet run --project src/FScript -- compile samples/ffi/main.fss --target dotnet --output out/graphics-dotnet +dotnet out/graphics-dotnet/main.dll --headless +``` + +Generated adapters call existing providers through the extension SDK and transport records, collections, unions, opaque payloads, callbacks, and tasks. `ExternalCallContext.Apply` invokes compiled functions. Provider factories run during compilation for metadata and once in the generated process when needed. + +## Prunable typed FFI bindings + +Existing interpreter providers remain unchanged. To make compiled calls direct and suitable for Native AOT, a provider class can additionally expose these public static parameterless metadata methods: + +- `FScriptCompiledFunctions() : IEnumerable>` +- `FScriptCompiledTypes() : IEnumerable>` + +They run only during compilation. Keys are the registered FScript function/type names. Functions map to exact public, closed CLR methods; instance receivers are explicit first arguments. Types map to their CLR representations. Provide semantically equivalent typed entry points and immutable or snapshot-compatible external values. Unsupported native shapes can use explicit scalar/record adapters. + +For example, an existing provider can map its `Ext.add` declaration to a typed method: + +```csharp +public static long Add(long left, long right) => left + right; + +public static IEnumerable> + FScriptCompiledFunctions() => new[] + { + KeyValuePair.Create("Ext.add", typeof(MyProvider).GetMethod( + nameof(Add), new[] { typeof(long), typeof(long) })!) + }; +``` + +The compiler emits a direct CLR call without constructing the provider registration, searching a function list, or transporting SDK values for that binding. Only used bindings and external types become compilation roots. Unused provider assemblies are omitted from emitted dependencies. The JIT can inline direct calls; trimmed single-file publishing and Native AOT remove unreachable provider methods and types. Metadata methods themselves are not runtime roots. + +No SDK record shape or interpreter registration API change is needed: the optional metadata uses BCL types. `ClrBindings.bindCompiledProviders` exposes the same linking step for compiler API consumers; the CLI discovers the companions automatically for CLR targets. The resulting CLR links remain serializable in LIR. + +Legacy SDK provider factories can still be used in DLL and managed single-file output. Their opaque delegate registrations may retain sibling implementations. Native AOT rejects a reachable legacy SDK dispatch bridge with `FSN7105` and requests typed mappings instead of silently suppressing linker warnings. + +## Pure FFI and external values + +Providers can optionally declare a trusted `Pure` guarantee. Undeclared functions and external types remain conservative. + +- A **pure function** is deterministic, has no observable effects, and terminates successfully for valid inputs. Required runtime initialization is part of this promise. Returning the same value while logging, mutating hidden state, reading a clock, or sometimes failing does not qualify. +- A **pure external type** has deeply immutable visible data and opaque payloads. Registered field reads, structural equality, and formatting must also be deterministic, effect-free, and terminating successfully. A readonly CLR property alone does not establish this guarantee. Constructors and ordinary methods need their own function declarations. + +For callback-taking functions, the promise applies when supplied callbacks satisfy the same guarantee. The optimizer separately checks callback effects and remains conservative for unknown callbacks. A pure factory does not automatically make a returned callable pure. + +Expose these public static parameterless methods on the provider class: + +```csharp +public static IEnumerable FScriptPureFunctions() => new[] +{ + "Ext.add" +}; + +public static IEnumerable FScriptPureTypes() => new[] +{ + "Point" +}; +``` + +Names must exactly match the provider's registered script functions and types. The example assumes the provider registers both `Ext.add` and `Point`. Empty or absent metadata means no guarantees. Unknown names and attempts to override protected runtime contracts are compilation errors. + +The CLI reads this metadata during compilation for IR, C#, and .NET output. It can be used with either existing SDK adapters or direct [typed CLR mappings](#prunable-typed-ffi-bindings). Existing SDK registration records do not need to change. These methods are not runtime roots and do not add FScript declaration syntax. + +Compiler API users can supply the same information explicitly: + +```fsharp +open FScript.Language +open FScript.Compiler + +let purity = + { PurityContracts.empty with + PureFunctions = Set.singleton "Ext.add" + PureTypes = Set.singleton "Point" } + +// registration and input are the host's existing compiler inputs. +Compiler.compileWithRegistrationAndPurity registration purity input +``` + +`Compiler.compileWithPurity` accepts contracts with ordinary `CompileInput.Externs`; `ClrBindings.providerPurity` discovers contracts from provider `MethodInfo` values. Ordinary compilation APIs default to empty contracts. + +The compiler can remove an unused pure call and then prune its binding, adapters, and dependencies when no other retained code needs them. Effects or failures in its argument expressions are still preserved. A type guarantee permits removal of unused field reads, equality, and formatting when the complete computation is proven pure. It does not make its factory or methods pure. + +Declarations are trusted, not verified by executing arbitrary provider code. Incorrect claims can remove behavior or failures after optimization. Normal AST interpretation and SDK boundary validation are unchanged. See [Compilation and optimizations](./compiler-optimizations.md#trusted-external-purity) for the pruning rules. + +## Compiler APIs + +Use `Compiler.compileWithRegistration` for host signatures. `ClrBindings.bindMethod` links an exact public CLR method or constructor; instance receivers are explicit first arguments. `ClrBindings.bindType` projects a native CLR type. `ClrBindings.bindProvider` preserves SDK providers. These declarative links survive IR serialization. + +`DotNetBackend.generate` accepts `OutputKind = Library` for library assemblies or `ConsoleApplication` for executables. Generated classes expose `Run`, `FormatResult`, and exported bindings. `CSharpBackend.generate` emits source files instead. + +Representation and CLR linkage diagnostics use `FSC6xxx`, including failures from the assembly target's shared emitter. Assembly emission and publishing diagnostics use `FSN7xxx`. Frontend and IR errors retain their own codes and source spans. Roslyn errors or warnings prevent assembly output. Reachable open polymorphic results and generalized initializers with effects remain compilation diagnostics under whole-program specialization. + +## Exit status and embedding + +`Env.setExitCode : int -> unit` selects the eventual shell status without stopping evaluation or task execution. Valid codes are `0` through `255`; the default is `0`. The last completed write wins. Writes from tasks are synchronized, but their scheduling order can change the final code. For a predictable code, await the tasks and set it in the main flow. Existing task completion and failure rules still apply; the setter does not add cancellation or bypass shutdown. + +The generated `Program.ExitCode` property exposes status to embedding callers. Calling `Run` or an exported function does not change the host process's `Environment.ExitCode`. The executable `Main` returns the selected status after normal completion. Unhandled failures take precedence and return a nonzero process status. + +The compiler APIs `CSharpBackend.generateWithResultOutput`, `DotNetBackend.generateWithResultOutput`, and `DotNetBackend.generateExecutableWithResultOutput` take a Boolean display policy before their ordinary options. Existing generation APIs default to printing. Passing `false` discards the entry value before specialization and prunes unused pure work; exported library bindings remain roots. diff --git a/website/docs/compiler/compiler-optimizations.md b/website/docs/compiler/compiler-optimizations.md new file mode 100644 index 0000000..a699a29 --- /dev/null +++ b/website/docs/compiler/compiler-optimizations.md @@ -0,0 +1,151 @@ +--- +id: compiler-optimizations +title: Compilation and optimizations +slug: /compiler/optimizations +--- + +Both native targets use the same inferred FScript types. The .NET assembly target adds passes intended to reduce calls, closure work, and unused generated code. The C# target produces a complete buildable source project and does not run those additional assembly passes. + +These passes run automatically. There is no FScript CLI optimization-level switch. Native AOT is a publishing choice after assembly optimization, rather than a separate FScript language mode. + +## Which target performs which work? + +| Transformation | C# project | .NET assembly | +| --- | --- | --- | +| Specialize reachable polymorphic uses | Yes | Yes | +| Simplify constants, branches, aliases, and unused pure bindings in shared IR | Yes | Yes | +| Use declared FFI purity and external-type guarantees | Yes | Yes | +| Eliminate repeated proven-pure expressions | Yes | Yes | +| Additional known-call and partial-application reduction | No | Yes | +| Native methods for saturated calls | No | Yes | +| Proven self-tail calls converted to loops | No | Yes | +| Typed loops for known collection callbacks | No | Yes | +| Aggressive pruning of generated methods, fields, and support types | No | Yes | +| FScript-managed single-file or Native AOT publishing | No | Yes, when requested | + +Building C# in Release mode still enables the C# compiler's normal optimizations. Managed assemblies receive JIT optimization at runtime; Native AOT performs native compilation at publish time. FScript does not guarantee that either toolchain will inline a particular CLR method. + +## Concrete specialization + +A polymorphic declaration can be instantiated at several concrete types: + +```fsharp +let identity value = value +(identity 42, identity "answer") +``` + +Each reachable use receives a concrete representation and function signature. Specialization keys deduplicate matching instantiations and handle recursive functions before traversing their bodies. An unused pure polymorphic declaration need not appear in the output. + +A reachable value must have a representable type. A final unconstrained function is a compilation error; a function with concrete arguments and a concrete result can remain a first-class value. Exported library bindings also need concrete native types. Specialization can increase code size when a function is used at many types. + +## Calls, currying, and captures + +The .NET backend follows known function values through bindings and partial applications. When it can prove the callee and make its captures available, it reduces a nonrecursive call into the caller's body or emits a typed method call with the supplied arguments. + +```fsharp +let add amount value = amount + value +let increment = add 1 +List.map increment [1..4] +``` + +This need not allocate a general partial-application object on each iteration. Known applications can become direct work in a typed collection loop. Captured expressions still evaluate once at the correct source position. + +Functions that escape, depend on an unknown higher-order parameter, or cross an FFI callback boundary may retain typed delegates and captured environments. Compilation does not remove every closure, delegate invocation, or allocation. + +## Tail recursion + +Proven saturated self calls in tail position become loops in the .NET assembly target: + +```fsharp +let rec sum remaining total = + if remaining = 0 then total + else sum (remaining - 1) (total + remaining) + +sum 1000000 0 +``` + +The recursive call is the complete result of that branch. Next arguments are evaluated before parameters are reassigned and execution continues. The compiler recognizes tail calls behind local bindings, conditionals, and pattern decisions. Escaping closures retain captured values from their original iteration. + +A call with pending work is not a tail call: + +```fsharp +let rec fibonacci n = + if n < 2 then n + else fibonacci (n - 1) + fibonacci (n - 2) + +fibonacci 20 +``` + +The additions still need the call results, so this remains recursive. Mutual recursion is also not converted into a native loop by the current assembly pass. Do not assume arbitrary recursion is stack-safe in compiled output. + +## Collections and Boolean expressions + +Known list callbacks can lower to typed loops and direct calls for mapping, iteration, folding, filtering, choosing, collecting, existence tests, and searches. This avoids some delegate machinery; operations that create changed immutable collections still allocate their results. + +Constant Boolean terms and branches are simplified when doing so preserves evaluation. A condition such as `condition && true` can become `condition`. Short-circuiting still skips the right operand when the left operand determines the result. An effectful or potentially failing expression cannot be dropped merely because a later term is constant. + +## Common-subexpression elimination + +Both compiled targets reuse a proven-pure computation when the same typed expression has already been evaluated on every path reaching the later use: + +```fsharp +let score n = + ((n + 1) * (n + 1), (n + 1) * (n + 1)) +``` + +The addition and multiplication can each execute once per call to `score`. The pass also handles repeated intrinsic calls, explicitly pure FFI calls, immutable aggregates, and field observations backed by pure external-type contracts. It follows immutable aliases and preserves concrete types, lexical identities, and floating-point bits, including signed zero. + +Reuse starts at the first evaluation; the compiler does not move branch-local work ahead of its condition. A value computed before a branch can serve either arm, but values computed inside an arm do not escape into another arm or the continuation. Short-circuit operands, pattern guards, and loop bodies retain their conditional execution. Observable operations invalidate available computations; unmarked external values and potentially failing or nonterminating computations remain conservative. + +Shared values are ordinary local bindings or previously initialized globals. Function invocations and loop iterations have separate local evaluations. No runtime lookup table, persistent cache, or memoization is introduced. Computations that are not shared retain their original expression shape after temporary cleanup. + +## Dead code and effects + +Generated-member reachability begins at program execution, result formatting, the executable entry point, and exported bindings. Unused generated methods, fields, runtime helpers, and types can be removed. Closed exports remain available to callers even if the script itself does not invoke them. + +Observable initialization remains ordered: + +```fsharp +let unused value = value + 1 +let announced = Console.writeLine "starting" +42 +``` + +The unused function can disappear, but the console write must remain. Console operations, filesystem access, tasks, imports, unknown callbacks, and failures are treated conservatively. Neither an unused result nor immutability makes I/O pure. + +A generalized initializer cannot be duplicated if it performs observable work. The compiler reports a diagnostic rather than introducing a value restriction or silently repeating the effect. Move one-time effects outside the generalized function or give its boundary a concrete type. + +## Trusted external purity + +[FFI providers](./compile-to-dotnet.md#pure-ffi-and-external-values) can declare the same strong `Pure` guarantee used by the optimizer: deterministic, effect-free, and guaranteed to terminate successfully for valid inputs. External type guarantees additionally cover deep immutability and safe, terminating registered field reads, equality, and formatting. No callable member becomes pure just because its receiver type is pure. Implicit imported-record construction, updates, and conversions remain conservative because they may invoke CLR constructors. A pure type does not make those constructors pure; use an explicitly pure factory binding when that guarantee holds. + +Both source and assembly specialization can use these contracts. An unused pure call may be removed, including through known FScript wrappers. Afterward, unused bindings and adapters can disappear; the assembly target can also omit provider dependencies that are no longer referenced. Argument expressions are analyzed separately, so `pureFunction (1 / 0)` must still fail and an argument that writes to the console must still execute. + +Curried application boundaries are retained in IR. Creating a pure function value and invoking a callable returned from it are separate operations. Callback-taking FFI and known higher-order collection operations require sufficiently strong callback proofs; unknown or effectful callbacks preserve the call. + +Failure is observable. Division is not considered pure unless its divisor and any signed-overflow case are proven safe. Explicit failures, potentially exhausted matches, and unproven recursive cycles remain observable even without mutation or I/O. Tail-call lowering does not establish termination. Observable generalized initializers that cannot be represented safely receive a diagnostic rather than silently disappearing. + +The contracts survive resolved inference, HIR, LIR, CLR linkage, specialization, and `.fsir` serialization. Older artifacts without them load conservatively. Provider declarations are trusted promises; FScript cannot generally verify their implementations. These contracts support pruning, safe local propagation, and common-subexpression elimination in both compiled targets. They do not enable automatic memoization. + +## FFI pruning and executable publishing + +There are two levels of pruning: + +- **Assembly generation:** remove unused generated code and external type declarations, and omit provider assemblies that the emitted program does not reference. Referenced provider DLLs remain intact. +- **Trimmed publishing:** remove unreachable code inside dependencies as well. Managed single-file output enables this when all reachable FFI bindings are static; Native AOT trims dependencies before native compilation. + +SDK provider factories can return opaque delegate registrations. Sibling implementations may remain reachable through registration, and managed single-file output disables trimming when that legacy dispatch path is used. Native AOT reports `FSN7105` for a reachable legacy SDK adapter. [Typed FFI mappings](./compile-to-dotnet.md#prunable-typed-ffi-bindings) provide exact CLR calls so the linker can follow their dependencies and trim unused implementations. + +Self-contained single-file output still includes a managed runtime. Native AOT produces native machine code, but neither mode embeds arbitrary input files or removes the need for normal OS libraries. See [the .NET publishing guide](./compile-to-dotnet.md#single-file-and-native-aot-executables) for runtime identifiers and toolchain requirements. + +## Interpreted execution + +Ordinary CLI execution and `ScriptHost` still use the AST interpreter; JavaScript embedding remains interpreted. Native specialization, call lowering, and assembly pruning are not enabled on those paths. The separate LIR interpreter executes validated IR and has its own tail-call trampoline; it does not run the .NET assembly backend's passes. + +For API contracts, representations, and validation details, see the [.NET backend specification](https://github.com/MagnusOpera/FScript/blob/main/docs/specs/dotnet-backends.md). + +## Discarding the entry value + +Compile with `--no-result` to remove the entry value as a reachability root before specialization. Pure and total computations used only for that value can disappear, including their functions, helpers, and dependencies. This can also permit an unused open pure value such as `None` to be discarded. Observable calls, potential failures, and `Env.setExitCode` writes remain roots; the option never licenses dropping failures or effects. No result-based exit-code inference is performed. + +Printing remains the default. Setting an exit code is never pure, including when two writes use the same integer. Tasks may share this status, so synchronized writes remain scheduling-dependent and are not deduplicated or reordered. diff --git a/website/docs/compiler/interpret-ir.md b/website/docs/compiler/interpret-ir.md new file mode 100644 index 0000000..041376d --- /dev/null +++ b/website/docs/compiler/interpret-ir.md @@ -0,0 +1,62 @@ +--- +id: interpret-ir +title: Interpret IR +slug: /compiler/interpret-ir +--- + +Compile a complete FScript program to versioned LIR: + +```bash +fscript compile program.fss --target ir --output ./out +``` + +This writes `out/program.fsir`, a canonical JSON artifact containing metadata and validated executable LIR. + +## Load from .NET + +Reference both repository-local assemblies: + +```xml + + +``` + +Then deserialize and execute: + +```fsharp +open System.IO +open FScript.Compiler + +match File.ReadAllBytes "out/program.fsir" |> IrArtifact.deserialize with +| Error diagnostics -> + diagnostics + |> List.iter (fun diagnostic -> + eprintfn "%s: %s" diagnostic.Code diagnostic.Message) +| Ok program -> + let context = + { ScriptName = Some "program.fss" + Arguments = [ "first"; "second" ] } + + match LirInterpreter.execute context program with + | Error diagnostic -> + eprintfn "%s: %s" diagnostic.Code diagnostic.Message + | Ok execution -> + execution.Stdout |> List.iter (printfn "%s") + printfn "Result: %A" execution.Value +``` + +`ExecutionResult` contains the final typed `LirValue` and ordered `Console.writeLine` output. `Console.readLine` consumes process stdin and returns `None` at EOF; embedding hosts can control it with `Console.SetIn` around execution. The host supplies `Env.ScriptName` and `Env.Arguments` through `InterpreterContext`; execution does not read process arguments implicitly. + +## Safety checks + +Deserialization checks the artifact format and version, required metadata, DTO structure, and all LIR invariants. Execution validates caller-created LIR again. + +- `FSA5xxx`: artifact failures; +- `FSL2xxx`: invalid LIR; +- `FSI3xxx`: execution failures. + +Reachable target imports, Tasks, and arbitrary host externs are rejected explicitly. Pure core-language programs, portable builtins, console input/output, and read-only `Fs.readText` execute directly from LIR. + +Version-1 `.fsir` is internal and does not promise backward compatibility. Use matching compiler and interpreter builds. + +See the repository's [complete interpreter guide](https://github.com/MagnusOpera/FScript/blob/main/docs/guides/interpret-ir.md). diff --git a/website/docs/embedding/fable-javascript.md b/website/docs/embedding/fable-javascript.md index a36d432..5f0f9f5 100644 --- a/website/docs/embedding/fable-javascript.md +++ b/website/docs/embedding/fable-javascript.md @@ -340,3 +340,7 @@ Try the browser runtime in the [FScript sandbox](/sandbox). Both hosts use the same language rules for provided records, opaque snapshots, and nominal unions. The .NET SDK additionally derives descriptors and typed conversions from CLR types. JavaScript authors supply descriptors explicitly and retain ordinary JavaScript payload objects through `HostTypes`. CLR attributes, assembly providers, and NuGet environments belong to .NET hosting. `fscript.toml` does not load CLR assemblies into a JavaScript host or the browser playground. See [Host-Managed Types](./host-managed-types) and [Environment Configuration](../reference/environment-configuration). + +## Exit status + +JavaScript treats `Env.setExitCode` as a no-op for source portability. It does not change process status or enforce a shell-code range. Arguments are still evaluated normally, and the program's returned value is unchanged. The website continues displaying that value. Existing `run`, `evaluate`, and `invoke` APIs retain their tagged-value results. diff --git a/website/docs/embedding/host-managed-types.md b/website/docs/embedding/host-managed-types.md index 6948140..596a0b1 100644 --- a/website/docs/embedding/host-managed-types.md +++ b/website/docs/embedding/host-managed-types.md @@ -190,3 +190,9 @@ The helper produces a plain `HostUnionDescriptor`: Put every referenced union descriptor in `ExtensionRegistration.Unions`, and every referenced record descriptor in `Types`. Union projections require `ScriptConstructible = true` and nonrecursive supported payloads. `HostTypes.describe` describes records; `describeUnion` describes unions. F# sets use script lists at the boundary. Host snapshots follow set iteration order; converting a script list back to a set sorts and removes duplicates using CLR comparison semantics. + +## Compiler purity guarantees + +Providers can optionally declare `Pure` information for native compilation. Functions promise deterministic, effect-free, successful termination for valid inputs; external types promise deeply immutable visible data and payloads with safe, terminating registered field reads and structural observers. Constructors and ordinary methods do not inherit a receiver type's guarantee. + +The compiler reads optional `FScriptPureFunctions()` and `FScriptPureTypes()` provider methods returning registered script names. These declarations are trusted; ordinary interpreter execution and SDK validation remain unchanged. See [Pure FFI and external values](../compiler/compile-to-dotnet.md#pure-ffi-and-external-values) for the contract, examples, callback rules, and compiler API. diff --git a/website/docs/embedding/register-externs.md b/website/docs/embedding/register-externs.md index b1a4af0..5fd447a 100644 --- a/website/docs/embedding/register-externs.md +++ b/website/docs/embedding/register-externs.md @@ -194,3 +194,11 @@ Manual callbacks and tasks are opaque SDK handles. Use `ExternalCallContext.Appl Package your SDK-only provider as a .NET library with its normal package dependencies. The public static method bearing `[FScriptExternProvider]` remains the discovery entry point and returns the type/function registration; no additional attribute is required. Users declare `[[runtime.packages]]` with your package `name` and optional exact `version` in their manifest. FScript restores dependencies and loads compatible runtime assets without building the package or requiring the .NET SDK. See [Environment Configuration](../reference/environment-configuration#nuget-packages). Complementary extensions may share opaque CLR values, such as NDArray. Depend on the numerical provider’s package, use its descriptors for handler validation, and return only your own registration entries. Provider dependencies are discovered once and all packages in the manifest share one managed dependency context. Do not re-register another provider’s types or functions. + +## Compiler purity guarantees + +Providers can optionally declare `Pure` information for native compilation. Functions promise deterministic, effect-free, successful termination for valid inputs; external types promise deeply immutable visible data and payloads with safe, terminating registered field reads and structural observers. Constructors and ordinary methods do not inherit a receiver type's guarantee. + +The compiler reads optional `FScriptPureFunctions()` and `FScriptPureTypes()` provider methods returning registered script names. These declarations are trusted; ordinary interpreter execution and SDK validation remain unchanged. See [Pure FFI and external values](../compiler/compile-to-dotnet.md#pure-ffi-and-external-values) for the contract, examples, callback rules, and compiler API. + +Scripts can call the core `Env.setExitCode` operation without a registered extern. It updates execution-local status rather than terminating the host. .NET hosts can read `LoadedScript.ExitCode` or use `ScriptHost.invokeWithExitCode`; returned values remain separate from status. diff --git a/website/docs/intro.md b/website/docs/intro.md index a726bca..8be9279 100644 --- a/website/docs/intro.md +++ b/website/docs/intro.md @@ -49,6 +49,7 @@ By the end of this manual, you should be comfortable with: - **Learn**: onboarding and first working scripts. - **Language**: core syntax, data modeling, typing, imports/exports, layout rules. - **Examples**: practical scripts and reusable patterns. +- **Compilation**: .NET assemblies, C# projects, executable publishing, and optimization behavior. - **Stdlib**: detailed function-by-function reference and recipes. - **Embedding**: host integration model, extern registration, safety boundaries. - **Reference**: CLI options, environment configuration, syntax/operators, native types, and the complete function signature index. diff --git a/website/docs/reference/cli-reference.md b/website/docs/reference/cli-reference.md index e5e3509..b07a065 100644 --- a/website/docs/reference/cli-reference.md +++ b/website/docs/reference/cli-reference.md @@ -20,6 +20,33 @@ fscript fscript version ``` +## Compile programs + +Generate one versioned whole-program IR artifact: + +```bash +fscript compile program.fss --target ir --output ./out +``` + +The IR target writes `out/program.fsir`. Unsupported features use structured compiler/backend diagnostic codes. + +Generate a standalone .NET assembly or an independently buildable C# project: + +```bash +fscript compile program.fss --target dotnet --output ./out/dotnet +dotnet ./out/dotnet/program.dll +fscript compile program.fss --target csharp --output ./out/csharp +dotnet run --project ./out/csharp/Program.csproj +``` + +Compiled executables display the final value by default. Compile with `--no-result` to suppress that display; explicit output such as `Console.writeLine` is preserved. + +These targets support .NET FFI providers selected by the normal environment configuration. See [Compile to .NET](../compiler/compile-to-dotnet.md) and [Compile to C#](../compiler/compile-to-csharp.md). + +For a self-contained executable, add `--single-file` to the .NET target. For a Native AOT executable, use `--aot`. Publishing defaults to the current platform; pass `--runtime ` to select another target. An explicitly supplied `--runtime` requires a value. Runtime identifiers use .NET names such as `osx-arm64`, `linux-x64`, and `win-x64`. Both options require a .NET 10 SDK for publishing and are rejected for other backends. + +Continue with [Compilation](../compiler/compilation.md), [Compilation and optimizations](../compiler/compiler-optimizations.md), or [Interpret IR](../compiler/interpret-ir.md). + ## From source ```bash @@ -126,3 +153,25 @@ Use the [VS Code debugger](../learn/debugging.md) to launch the installed CLI in integrated terminal. The adapter's protocol uses separate streams from script input/output. Debugger modes are standalone invocations and cannot be combined with ordinary file-execution flags. + +## Results and shell status + +Printing the final value is the default for interpreted file/stdin execution and compiled applications. Use `--no-result` to suppress that display: + +```sh +fscript --no-result program.fss +fscript compile program.fss --target dotnet --no-result --output out/program +fscript compile program.fss --target csharp --no-result --output out/source +``` + +The compilation flag is baked into the generated entry point; it is not consumed from a compiled application's arguments. Explicit `Console.writeLine` output and diagnostics remain visible. The REPL also accepts `--no-result`. IR artifacts retain their program values and do not accept this compilation flag. + +The final value never becomes a process exit status. Successful execution returns `0` unless `Env.setExitCode` selects another status. An unhandled failure still returns a nonzero status, even if the program selected `0` beforehand. Suppressing a result does not suppress failures or stop evaluation. Compilers may remove discarded work only when it is proven pure and total. + +```fsharp +Env.setExitCode 7 +Console.writeLine "Evaluation continues." +42 +``` + +This prints the explicit message and, by default, `42`; the shell receives status `7`. With `--no-result`, only the explicit message is printed and the status remains `7`. diff --git a/website/docs/reference/stdlib-reference.md b/website/docs/reference/stdlib-reference.md index be15ebe..4461892 100644 --- a/website/docs/reference/stdlib-reference.md +++ b/website/docs/reference/stdlib-reference.md @@ -171,3 +171,5 @@ This is the complete catalog of core functions/values and default .NET runtime e Constructors and syntax are separate from function registration: `Some`/`None`, union cases, literals, ranges, field access, list/map indexers, `typeof`, and `nameof` are covered in [Native Types](./native-types-reference.md) and [Syntax and Operators](./syntax-reference.md). Host-provided type descriptors are covered in [Host-Provided Types](../embedding/host-managed-types). `Json.deserialize` uses a runtime type token; its generic result scheme does not statically encode the relationship between that token and the result. `Guid.new` accepts an ignored argument; use `Guid.new ()`. `List.contains` compares scalars only; use `List.exists` with `=` for composite data. + +`Env.setExitCode : int -> unit` selects the eventual shell status without stopping evaluation; see [core builtins](../stdlib/builtins#envsetexitcode). It is effectful and accepts codes `0..255`. diff --git a/website/docs/stdlib/builtins.md b/website/docs/stdlib/builtins.md index 622be7e..3661464 100644 --- a/website/docs/stdlib/builtins.md +++ b/website/docs/stdlib/builtins.md @@ -59,3 +59,21 @@ Use `ignore` when an expression returns a value you intentionally do not need. I 42 |> ignore String.indexOf "x" "text" |> ignore ``` + +## Env.setExitCode + +`Env.setExitCode : int -> unit` is an always-available core operation, including in embedding and JavaScript. It coexists with host-provided `Env.ScriptName` and `Env.Arguments` without adding a field to the `Environment` record. The qualified operation is reserved even when an `Env` value is in scope. + +On .NET and compiled targets, the code must be in the portable shell range `0..255`; other values fail with an evaluation error. It selects the eventual shell status and returns unit normally. It never calls process exit, cancels tasks, or changes a host process's exit status during embedded evaluation. The default is `0`, repeated calls use the last completed write, and unhandled execution failures still produce failure rather than a selected success code. + +This operation is effectful and is not `Pure`. Its writes survive pruning and common-subexpression elimination. Writes from tasks share the execution status and are synchronized, but their order is scheduling-dependent. For deterministic status, await tasks and set it afterward in the main flow. Existing task lifetime and failure rules are preserved. + +```fsharp +Env.setExitCode 7 +42 // still evaluated; shell status is 7 +``` + +Result printing is independent of this status. `--no-result` suppresses automatic display in the CLI and can be baked into compiled applications. + + +Fable/JavaScript deliberately treats this operation as a no-op (including shell-range validation). Arguments still evaluate normally, returned values remain unchanged, and the website displays the returned value as before. diff --git a/website/docs/stdlib/overview.md b/website/docs/stdlib/overview.md index 4b91876..3cc3a02 100644 --- a/website/docs/stdlib/overview.md +++ b/website/docs/stdlib/overview.md @@ -12,6 +12,7 @@ Start with lists, options, and maps for data transformations. Add runtime module | --- | --- | --- | | Core functions and values | `List`, `Option`, `Map`, `String`, `Int`, `Float`, `Bool`, `ignore` | Always, including JavaScript hosts | | Default .NET runtime externs | `Console`, `Task`, `Fs`, `Json`, `Regex`, `Xml`, `Hash`, `Guid` | The host registers them; the CLI enables them by default | +| Exit status | `Env.setExitCode : int -> unit` | Effectful core operation; never terminates the host | | Execution metadata | `Env : Environment` | Injected by the CLI/REPL or supplied by an embedding host | No imports are needed for registered functions. An embedding host may expose a subset of the runtime catalog, and the CLI's `--no-default-externs` disables that catalog without removing core functions. The browser playground supplies its own capabilities; it does not load the .NET runtime. diff --git a/website/docs/stdlib/string.md b/website/docs/stdlib/string.md index 69dd507..ceb3a6c 100644 --- a/website/docs/stdlib/string.md +++ b/website/docs/stdlib/string.md @@ -8,6 +8,8 @@ slug: /stdlib/string Argument order is `oldValue -> newValue -> source`. +Replaces all non-overlapping occurrences using ordinal, case-sensitive matching. An empty `oldValue` returns `source` unchanged; an empty `newValue` removes matches. This operation always returns a string. + ```fsharp let text = String.replace "-" "_" "a-b-c" ``` diff --git a/website/docs/whats-new.md b/website/docs/whats-new.md index 7fd81fe..99b40e7 100644 --- a/website/docs/whats-new.md +++ b/website/docs/whats-new.md @@ -8,4 +8,4 @@ For the complete history, see the full [CHANGELOG.md](https://github.com/MagnusO ## Unreleased - +- Added typed HIR and executable LIR, versioned `.fsir` artifacts, a standalone LIR interpreter, and standalone .NET and C# backends. diff --git a/website/docusaurus.config.ts b/website/docusaurus.config.ts index 28c14f4..4054fdd 100644 --- a/website/docusaurus.config.ts +++ b/website/docusaurus.config.ts @@ -7,7 +7,7 @@ const latestReleasedVersion = versions[0] ?? 'current'; const config: Config = { title: 'FScript', - tagline: 'A typed language for rules that run inside your application.', + tagline: 'A typed language for embedded rules, executable IR, and native .NET programs.', favicon: 'img/favicon.ico', future: { @@ -86,6 +86,11 @@ const config: Config = { label: 'Playground', position: 'left', }, + { + to: '/manual/compiler/overview', + label: 'Compilation', + position: 'left', + }, { href: 'https://github.com/MagnusOpera/FScript', label: 'GitHub ↗', diff --git a/website/sidebars.ts b/website/sidebars.ts index a256fca..3f57773 100644 --- a/website/sidebars.ts +++ b/website/sidebars.ts @@ -30,6 +30,11 @@ const sidebars: SidebarsConfig = { label: 'Examples', items: ['examples/guided-examples', 'examples/common-patterns', 'examples/ffi-graphics'], }, + { + type: 'category', + label: 'Compilation', + items: ['compiler/compilation', 'compiler/compile-to-dotnet', 'compiler/compile-to-csharp', 'compiler/compiler-optimizations', 'compiler/interpret-ir'], + }, { type: 'category', label: 'Stdlib', diff --git a/website/src/pages/index.module.css b/website/src/pages/index.module.css index 3dbf0b4..66ce09b 100644 --- a/website/src/pages/index.module.css +++ b/website/src/pages/index.module.css @@ -60,8 +60,7 @@ padding-bottom: 6rem; } -.eyebrow, -.sectionKicker { +.eyebrow { margin: 0 0 1.4rem; color: inherit; font: 750 .72rem/1.2 var(--ifm-font-family-monospace); @@ -89,9 +88,7 @@ letter-spacing: -.07em; } -.heroTitle em, -.examplesSection h2 em, -.boundaryCopy h2 em { +.heroTitle em { color: var(--home-green); font-family: Georgia, 'Times New Roman', serif; font-weight: 400; @@ -106,8 +103,7 @@ line-height: 1.62; } -.heroActions, -.ctaActions { +.heroActions { display: flex; gap: .8rem; flex-wrap: wrap; @@ -271,8 +267,7 @@ user-select: none; } -.codeArea pre, -.exampleCard pre { +.codeArea pre { margin: 0; border: 0; border-radius: 0; @@ -281,7 +276,7 @@ } .codeArea pre { padding: 0 1.1rem 0 0; color: #dce5dc; font: .78rem/1.72 var(--ifm-font-family-monospace); white-space: pre-wrap; } -.codeArea code, .exampleCard code { padding: 0; border: 0; color: inherit; background: transparent; } +.codeArea code { padding: 0; border: 0; color: inherit; background: transparent; } .windowFooter { justify-content: space-between; min-height: 2.7rem; border-top: 1px solid #292e29; border-bottom: 0; text-transform: uppercase; } .windowFooter span:first-child { display: flex; align-items: center; gap: .45rem; } @@ -298,105 +293,101 @@ .heroTicker div { display: flex; justify-content: center; gap: 1.6rem; width: max-content; min-width: 100%; padding: 1.05rem; font: 900 .78rem/1 var(--ifm-font-family-monospace); letter-spacing: .16em; } .heroTicker i { font-style: normal; } -.main { color: var(--home-ink); background: var(--home-paper); } +.main { color: var(--home-ink); background: #f4f2e9; } -.statementSection { padding: clamp(6rem, 10vw, 10rem) 0; } -.statementGrid { display: grid; grid-template-columns: minmax(10rem, .24fr) minmax(0, 1fr); gap: clamp(1.5rem, 4vw, 4rem); align-items: start; } -.sectionKicker { color: #61665f; } -.sectionKicker::before { content: ''; display: inline-block; width: 1.7rem; height: 2px; margin-right: .65rem; vertical-align: middle; background: currentColor; } +.sectionLabel { + margin: 0 0 1.7rem; + color: #666c66; + font: 760 .69rem/1.2 var(--ifm-font-family-monospace); + letter-spacing: .14em; + text-transform: uppercase; +} + +.inlineLink { + display: inline-flex; + gap: .55rem; + align-items: center; + font-weight: 780; + text-decoration-thickness: 1px; + text-underline-offset: .28rem; +} + +.inlineLink { color: #16533a; } + +/* The type system is drawn as a field of relationships, not a feature card. */ +.languageScene { + position: relative; + overflow: hidden; + padding: clamp(7rem, 11vw, 11rem) 0 clamp(6rem, 9vw, 9rem); + background: + radial-gradient(circle at 88% 13%, rgba(169,149,255,.24), transparent 25rem), + linear-gradient(110deg, #f5f0e4 0 62%, #ede7dc 62%); +} -.statementTitle, -.sectionHeading h2, -.boundaryCopy h2, -.learningHeader h2, -.ctaInner h2 { +.languageScene::before { + position: absolute; + top: 8rem; + right: -3rem; + width: 13rem; + height: 13rem; + border: 1px solid rgba(10,12,11,.16); + border-radius: 50%; + content: ''; +} + +.sceneIntro { display: grid; grid-template-columns: .34fr 1.05fr .72fr; gap: clamp(2rem, 5vw, 5.5rem); align-items: start; } +.sceneIntro .sectionLabel { padding-top: .85rem; } +.sceneIntro h2, +.javascriptCopy h2 { margin: 0; - color: var(--home-ink); - font-size: clamp(2.7rem, 5.1vw, 5.6rem); - line-height: .98; - letter-spacing: -.06em; + font-size: clamp(3rem, 5.7vw, 6.2rem); + line-height: .94; + letter-spacing: -.065em; text-wrap: balance; } - -.statementTitle { max-width: 19ch; } -.statementCopy { max-width: 42rem; margin: 2rem 0 0; color: #5b605a; font-size: 1.15rem; line-height: 1.75; } - -.metricStrip { display: grid; grid-template-columns: repeat(3, 1fr); margin-top: 5rem; border-top: 1px solid #c8c6bd; border-bottom: 1px solid #c8c6bd; } -.metricStrip > div { display: flex; gap: 1.3rem; align-items: flex-start; padding: 1.7rem 1.2rem; border-right: 1px solid #c8c6bd; } -.metricStrip > div:last-child { border-right: 0; } -.metricStrip strong { color: #9d9d94; font: 600 .72rem/1.5 var(--ifm-font-family-monospace); } -.metricStrip span { font-weight: 760; line-height: 1.45; } - -.examplesSection { padding: clamp(5.5rem, 9vw, 9rem) 0; color: #f7f7f0; background: #121412; } -.sectionHeading { display: grid; grid-template-columns: .65fr 1.25fr .7fr; gap: 2rem; align-items: end; } -.sectionHeading .sectionKicker { align-self: start; color: #858c86; } -.sectionHeading h2 { color: #fff; } -.sectionHeading p:last-child { margin: 0; color: #8e958f; line-height: 1.65; } - -.exampleGrid { display: grid; grid-template-columns: repeat(3, 1fr); gap: 1px; margin-top: 4.5rem; background: #333833; border: 1px solid #333833; } -.exampleCard { display: flex; min-width: 0; flex-direction: column; padding: 2rem; background: #161916; } -.exampleCard:nth-child(2) { background: #191c19; } -.exampleTopline { display: flex; align-items: center; gap: .8rem; color: var(--home-green); font: 700 .7rem/1 var(--ifm-font-family-monospace); } -.exampleTopline i { width: 100%; height: 1px; background: #363b36; } -.exampleCard h3 { margin: 2rem 0 .8rem; color: #fff; font-size: 1.45rem; letter-spacing: -.03em; } -.exampleCard > p { min-height: 5.2rem; color: #929a93; font-size: .92rem; line-height: 1.6; } -.exampleCard pre { flex: 1; margin-top: 1.5rem; padding: 1.25rem; overflow: auto; color: #cbd5cb; background: #0d0f0d; font: .72rem/1.65 var(--ifm-font-family-monospace); } -.examplesLink { margin-top: 2rem; text-align: right; } -.examplesLink a, .textLink { color: var(--home-green); font-weight: 800; text-decoration: none; } -.examplesLink a span, .textLink span { margin-left: .5rem; } - -.boundarySection { overflow: hidden; padding: clamp(6rem, 10vw, 10rem) 0; background: #e8e4ff; } -.boundaryGrid { display: grid; grid-template-columns: .82fr 1.18fr; gap: clamp(3rem, 7vw, 8rem); align-items: center; } -.boundaryCopy h2 em { color: #5e3ee9; } -.boundaryCopy > p:not(.sectionKicker) { max-width: 38rem; margin: 2rem 0; color: #565260; font-size: 1.08rem; line-height: 1.72; } -.boundaryCopy ul { margin: 2.3rem 0; padding: 0; border-top: 1px solid #c5bfea; list-style: none; } -.boundaryCopy li { padding: .85rem 0; border-bottom: 1px solid #c5bfea; font-weight: 750; } -.boundaryCopy li span { display: inline-block; width: 3rem; color: #766ab0; font: .7rem var(--ifm-font-family-monospace); } -.boundaryCopy .textLink { color: #4b2ed0; } - -.boundaryDiagram { position: relative; padding: 3.4rem; border: 1px solid #9d91da; border-radius: 50% 50% 12px 12px; background: rgba(255,255,255,.3); box-shadow: 18px 20px 0 rgba(84,63,181,.1); } -.hostBox, .languageBox { padding: 2rem; border: 1px solid #8c80cc; background: #f6f3ff; box-shadow: 7px 7px 0 #c7bdf4; } -.languageBox { background: #18151f; box-shadow: 7px 7px 0 #8f7de5; } -.hostBox small, .languageBox small { display: block; color: #6f6796; font: 700 .65rem var(--ifm-font-family-monospace); letter-spacing: .13em; } -.hostBox strong, .languageBox strong { display: block; margin: .3rem 0 1.4rem; font-size: 2.4rem; letter-spacing: -.05em; } -.languageBox strong { color: #fff; } -.hostBox div, .languageBox div { display: flex; gap: .45rem; flex-wrap: wrap; } -.hostBox span, .languageBox span { padding: .35rem .55rem; border: 1px solid #c6c0df; border-radius: 99px; color: #5c576c; font: 650 .65rem var(--ifm-font-family-monospace); } -.languageBox span { border-color: #46404f; color: #aaa1b5; } -.bridge { display: grid; grid-template-columns: 1fr auto 1fr; gap: .7rem; align-items: center; padding: 1.4rem 0; color: #5a517f; text-align: center; font: 700 .65rem var(--ifm-font-family-monospace); text-transform: uppercase; } -.bridge i { display: grid; width: 2rem; height: 2rem; place-items: center; border-radius: 50%; color: #fff; background: #5e3ee9; font-style: normal; } -.boundaryLabel { position: absolute; right: 0; bottom: -1.7rem; left: 0; color: #766ab0; text-align: center; font: 750 .64rem var(--ifm-font-family-monospace); letter-spacing: .18em; } - -.learningSection { padding: clamp(6rem, 10vw, 10rem) 0; } -.learningHeader { display: grid; grid-template-columns: 1.2fr .55fr; gap: 4rem; align-items: end; } -.learningHeader > p { margin: 0 0 .4rem; color: #636760; line-height: 1.7; } -.learningGrid { display: grid; grid-template-columns: repeat(3, 1fr); gap: 1.1rem; margin-top: 4rem; } -.learningCard { position: relative; display: flex; min-height: 390px; flex-direction: column; padding: 2rem; border: 1px solid #cbc8bd; color: var(--home-ink) !important; background: #f8f6ee; text-decoration: none !important; transition: transform .2s ease, box-shadow .2s ease, border-color .2s ease; } -.learningCard:nth-child(2) { background: #e7ffbd; } -.learningCard:nth-child(3) { color: #f5f5ee !important; background: #141714; } -.learningCard:hover { transform: translateY(-6px); border-color: #999c92; box-shadow: 9px 10px 0 rgba(10,12,11,.1); } -.learningNumber { color: #999d95; font: 700 .7rem var(--ifm-font-family-monospace); } -.learningIcon { display: grid; width: 4.6rem; height: 4.6rem; margin: 2.5rem 0; place-items: center; border: 1px solid #b9bcb3; border-radius: 50%; font: 800 1.2rem var(--ifm-font-family-monospace); } -.learningCard:nth-child(3) .learningIcon { border-color: #4c514c; color: var(--home-green); } -.learningCard h3 { margin: auto 0 .65rem; color: inherit; font-size: 2rem; letter-spacing: -.05em; } -.learningCard p { min-height: 4.8rem; color: #646861; line-height: 1.55; } -.learningCard:nth-child(3) p { color: #8f968f; } -.learningCard b { display: flex; justify-content: space-between; padding-top: 1rem; border-top: 1px solid rgba(100,104,97,.35); font-size: .8rem; text-transform: uppercase; } - -.ctaSection { padding: 2rem 0 6rem; } -.ctaInner { display: grid; grid-template-columns: auto 1fr auto; gap: clamp(2rem, 5vw, 5rem); align-items: center; padding: clamp(2.5rem, 5vw, 5rem); color: #fff; background: var(--home-ink); box-shadow: 12px 14px 0 var(--home-coral); } -.ctaInner img { border-radius: 50%; background: var(--home-green); transform: rotate(-5deg); } -.ctaInner .sectionKicker { color: #939a94; } -.ctaInner h2 { color: #fff; font-size: clamp(2.4rem, 4vw, 4.6rem); } -.ctaActions { flex-direction: column; min-width: 12rem; } +.sceneIntro h2 em, +.javascriptCopy h2 em { font-family: Georgia, 'Times New Roman', serif; font-weight: 400; } +.sceneIntro h2 em { color: #5845aa; } +.sceneSummary { max-width: 34rem; } +.sceneLead { max-width: 34rem; margin: .65rem 0 0; color: #4f544e; font-size: 1.04rem; line-height: 1.78; } +.sceneSummary .inlineLink { margin-top: 1.35rem; } + +/* JavaScript gets a bright browser-like studio of its own. */ +.javascriptScene { padding: clamp(7rem, 11vw, 11rem) 0; background: #d9ddff; background-image: radial-gradient(circle at 15% 90%, rgba(255,107,74,.28), transparent 25rem); } +.javascriptGrid { display: grid; grid-template-columns: minmax(0, 1.15fr) minmax(22rem, .85fr); gap: clamp(3rem, 8vw, 8rem); align-items: center; } +.browserStage { overflow: hidden; border: 1px solid #1f2040; border-radius: 9px; background: #f8f7f2; box-shadow: 18px 20px 0 #6b62c9, 0 35px 70px rgba(38,31,87,.2); transform: rotate(-1.2deg); } +.browserChrome, +.browserStatus { display: flex; gap: .45rem; align-items: center; min-height: 3rem; padding: 0 1rem; color: #666581; background: #ebeaf6; font: 680 .65rem/1 var(--ifm-font-family-monospace); } +.browserChrome i { width: .62rem; height: .62rem; border-radius: 50%; background: #ff8064; } +.browserChrome i:nth-child(2) { background: #f1c750; } +.browserChrome i:nth-child(3) { background: #62d99d; } +.browserChrome span { margin: 0 auto; padding: .55rem 3rem; border: 1px solid #d1cfe0; border-radius: 3px; background: #f6f5fb; } +.browserBody { display: grid; grid-template-columns: 1fr .42fr; min-height: 385px; } +.browserEditor { padding: clamp(1.7rem, 4vw, 3rem); color: #e7ece6; background: #121512; } +.browserEditor > span { display: block; margin-bottom: 2.4rem; color: #737b74; font: 700 .63rem/1 var(--ifm-font-family-monospace); } +.browserEditor pre { margin: 0; padding: 0; border: 0; color: inherit; background: none; box-shadow: none; font: clamp(.7rem, 1vw, .83rem)/1.75 var(--ifm-font-family-monospace); } +.browserEditor code { padding: 0; border: 0; color: inherit; background: none; } +.browserResult { display: flex; flex-direction: column; padding: 2.2rem 1.4rem; color: #1b1c1a; background: var(--home-green); } +.browserResult span { margin: 0 0 .6rem; font: 800 .58rem/1 var(--ifm-font-family-monospace); letter-spacing: .12em; } +.browserResult code { padding: 0; border: 0; background: none; font-size: .67rem; } +.browserResult span:nth-of-type(2) { margin-top: auto; } +.browserResult strong { font: 400 5rem/.9 Georgia, serif; } +.browserStatus { justify-content: space-between; border-top: 1px solid #d1cfe0; } +.browserStatus span:first-child { display: flex; gap: .45rem; align-items: center; } +.browserStatus i { width: .45rem; height: .45rem; border-radius: 50%; background: #3bc37f; box-shadow: 0 0 7px #3bc37f; } +.javascriptCopy h2 { max-width: 10ch; color: #15162c; } +.javascriptCopy .sectionLabel { color: #534d9e; } +.javascriptCopy > p:not(.sectionLabel) { margin: 2rem 0; color: #4e4e68; font-size: 1.04rem; line-height: 1.78; } + +.finalLinks { padding: 2.4rem 0; color: #d7ddd7; background: #101310; } +.finalLinksInner { display: flex; gap: 2rem; align-items: center; justify-content: space-between; } +.finalLinks p { margin: 0; color: #929a93; } +.finalLinks nav { display: flex; gap: clamp(1rem, 3vw, 2.5rem); flex-wrap: wrap; } +.finalLinks a { color: #e6ebe6; font-weight: 700; text-decoration-color: #596159; text-underline-offset: .25rem; } @media (max-width: 1100px) { .heroInner { grid-template-columns: 1fr 1fr; gap: 2.5rem; } .heroTitle { font-size: clamp(3.5rem, 6.4vw, 5.5rem); } - .exampleCard { padding: 1.35rem; } - .boundaryDiagram { padding: 2.2rem; } - .ctaInner { grid-template-columns: auto 1fr; } - .ctaActions { grid-column: 2; flex-direction: row; } } @media (max-width: 900px) { @@ -404,16 +395,12 @@ .heroCopy { max-width: 48rem; } .heroVisual { margin-top: 4rem; } .mascotMark { right: 1rem; } - .statementGrid, .sectionHeading, .boundaryGrid, .learningHeader { grid-template-columns: 1fr; } - .statementGrid, .sectionHeading { gap: 1rem; } - .metricStrip, .exampleGrid, .learningGrid { grid-template-columns: 1fr; } - .metricStrip > div { border-right: 0; border-bottom: 1px solid #c8c6bd; } - .metricStrip > div:last-child { border-bottom: 0; } - .exampleCard > p { min-height: 0; } - .learningCard { min-height: 320px; } - .ctaInner { grid-template-columns: 1fr; text-align: center; } - .ctaInner img { margin: 0 auto; } - .ctaActions { grid-column: auto; justify-content: center; flex-direction: row; } + .sceneIntro { grid-template-columns: 1fr; gap: 1.5rem; } + .sceneIntro .sectionLabel { padding-top: 0; } + .sceneLead { max-width: 43rem; } + .javascriptGrid { grid-template-columns: 1fr; } + .javascriptCopy h2 { max-width: 15ch; } + .javascriptCopy { order: -1; } } @media (max-width: 600px) { @@ -421,7 +408,7 @@ .heroTitle { font-size: clamp(3.25rem, 16vw, 4.5rem); } .heroLead { font-size: 1rem; } .eyebrow { font-size: .64rem; letter-spacing: .1em; line-height: 2.5; } - .heroActions, .heroActions a, .ctaActions, .ctaActions a { width: 100%; } + .heroActions, .heroActions a { width: 100%; } .heroProof { display: grid; } .mascotMark { top: -3.7rem; right: -.3rem; width: 6.8rem; height: 6.8rem; } .mascotMark img { width: 3.8rem; height: 3.8rem; } @@ -430,13 +417,19 @@ .codeArea { min-height: 350px; grid-template-columns: 2.3rem minmax(0,1fr); } .codeArea pre { font-size: .66rem; } .heroTicker div { justify-content: flex-start; } - .statementTitle, .sectionHeading h2, .boundaryCopy h2, .learningHeader h2, .ctaInner h2 { font-size: 2.65rem; } - .boundaryDiagram { padding: 1.1rem; } - .hostBox, .languageBox { padding: 1.3rem; } - .hostBox strong, .languageBox strong { font-size: 1.8rem; } - .ctaInner { padding: 2rem 1.2rem; } + .sceneIntro h2, .javascriptCopy h2 { font-size: 2.75rem; } + .languageScene { background: #f5f0e4; } + .browserStage { margin-right: -.2rem; margin-left: -.2rem; box-shadow: 8px 9px 0 #6b62c9; transform: none; } + .browserChrome span { padding: .5rem .8rem; } + .browserBody { grid-template-columns: 1fr; } + .browserEditor { min-height: 270px; } + .browserResult { display: grid; grid-template-columns: auto 1fr; gap: .8rem 1rem; } + .browserResult span, .browserResult span:nth-of-type(2) { margin: 0; } + .browserResult strong { font-size: 2.6rem; } + .finalLinksInner { align-items: flex-start; flex-direction: column; } + .finalLinks nav { flex-direction: column; } } @media (prefers-reduced-motion: reduce) { - .primaryAction, .secondaryAction, .learningCard { transition: none; } + .primaryAction, .secondaryAction { transition: none; } } diff --git a/website/src/pages/index.tsx b/website/src/pages/index.tsx index f38bf6d..4e059c9 100644 --- a/website/src/pages/index.tsx +++ b/website/src/pages/index.tsx @@ -68,27 +68,6 @@ const total = invoke(pricing, "quote", [{ }, }; -const examples = [ - { - number: '01', - title: 'Name every outcome', - description: 'Use records and unions to describe the data a rule accepts and every result it can return.', - code: `type Decision =\n | Approve of int\n | Review of string\n | Decline\n\nlet decide score =\n match score with\n | n when n > 80 -> Approve 5000\n | n when n > 55 -> Review "manual"\n | _ -> Decline`, - }, - { - number: '02', - title: 'Choose what scripts can call', - description: 'Register typed host functions for the exact operations a script needs. Leave everything else out.', - code: `let notifyLateInvoice invoice =\n match invoice.Status with\n | "late" ->\n Host.notify invoice.Owner\n $"Invoice {invoice.Id} is late"\n | _ ->\n ()`, - }, - { - number: '03', - title: 'Call exports from your app', - description: 'Load a script, find its exported functions, and invoke them by name from .NET or JavaScript.', - code: `type Event = { Kind: string }\n\nexport let route (event: Event) =\n match event.Kind with\n | "signup" -> "onboarding"\n | "payment.failed" -> "billing"\n | "churn.risk" -> "success"\n | _ -> "archive"`, - }, -]; - function Arrow() { return ; } @@ -141,13 +120,13 @@ function HomepageHeader() {