From 92bd7d5fd7d00f7db49d58b85473de2d86bf4cfa Mon Sep 17 00:00:00 2001
From: ncave <777696+ncave@users.noreply.github.com>
Date: Sat, 16 Nov 2024 00:15:53 -0800
Subject: [PATCH] Export metadata
---
.vscode/launch.json | 10 ++
buildtools/buildtools.targets | 4 +-
fcs/build.sh | 6 +
fcs/fcs-export/NuGet.config | 10 ++
fcs/fcs-export/Program.fs | 137 ++++++++++++++++++++
fcs/fcs-export/fcs-export.fsproj | 31 +++++
src/Compiler/AbstractIL/ilwrite.fs | 14 ++
src/Compiler/Driver/CompilerImports.fs | 54 ++++++++
src/Compiler/FSharp.Compiler.Service.fsproj | 1 +
9 files changed, 265 insertions(+), 2 deletions(-)
create mode 100644 fcs/build.sh
create mode 100644 fcs/fcs-export/NuGet.config
create mode 100644 fcs/fcs-export/Program.fs
create mode 100644 fcs/fcs-export/fcs-export.fsproj
diff --git a/.vscode/launch.json b/.vscode/launch.json
index b93e358bbc1..d6017039c1c 100644
--- a/.vscode/launch.json
+++ b/.vscode/launch.json
@@ -92,6 +92,16 @@
"enableStepFiltering": false,
"requireExactSource": false,
"allowFastEvaluate": true
+ },
+ {
+ "name": "FCS Export",
+ "type": "coreclr",
+ "request": "launch",
+ "program": "${workspaceFolder}/artifacts/bin/fcs-export/Debug/net8.0/fcs-export.dll",
+ "args": [],
+ "cwd": "${workspaceFolder}/fcs/fcs-export",
+ "console": "internalConsole",
+ "stopAtEntry": false
}
]
}
diff --git a/buildtools/buildtools.targets b/buildtools/buildtools.targets
index 86346fc2a15..ed0259f01c7 100644
--- a/buildtools/buildtools.targets
+++ b/buildtools/buildtools.targets
@@ -20,7 +20,7 @@
BeforeTargets="CoreCompile">
- $(ArtifactsDir)\Bootstrap\fslex\fslex.dll
+ $(ArtifactsDir)\bin\fslex\Release\net9.0\linux-x64\fslex.dll
@@ -44,7 +44,7 @@
BeforeTargets="CoreCompile">
- $(ArtifactsDir)\Bootstrap\fsyacc\fsyacc.dll
+ $(ArtifactsDir)\bin\fsyacc\Release\net9.0\linux-x64\fsyacc.dll
diff --git a/fcs/build.sh b/fcs/build.sh
new file mode 100644
index 00000000000..8ca66840be8
--- /dev/null
+++ b/fcs/build.sh
@@ -0,0 +1,6 @@
+#!/usr/bin/env bash
+
+dotnet build -c Release buildtools/fslex
+dotnet build -c Release buildtools/fsyacc
+dotnet build -c Release src/Compiler
+dotnet run -c Release --project fcs/fcs-export
diff --git a/fcs/fcs-export/NuGet.config b/fcs/fcs-export/NuGet.config
new file mode 100644
index 00000000000..273c7d2db75
--- /dev/null
+++ b/fcs/fcs-export/NuGet.config
@@ -0,0 +1,10 @@
+
+
+
+
+
+
+
+
+
+
diff --git a/fcs/fcs-export/Program.fs b/fcs/fcs-export/Program.fs
new file mode 100644
index 00000000000..58ce2b4f879
--- /dev/null
+++ b/fcs/fcs-export/Program.fs
@@ -0,0 +1,137 @@
+open System.IO
+open System.Text.RegularExpressions
+open FSharp.Compiler.CodeAnalysis
+open Buildalyzer
+
+let getProjectOptionsFromProjectFile (isMain: bool) (projFile: string) =
+
+ let tryGetResult (isMain: bool) (manager: AnalyzerManager) (maybeCsprojFile: string) =
+
+ let analyzer = manager.GetProject(maybeCsprojFile)
+ let env = analyzer.EnvironmentFactory.GetBuildEnvironment(Environment.EnvironmentOptions(DesignTime=true,Restore=false))
+ // If System.the project targets multiple frameworks, multiple results will be returned
+ // For now we just take the first one with non-empty command
+ let results = analyzer.Build(env)
+ results
+ |> Seq.tryFind (fun r -> System.String.IsNullOrEmpty(r.Command) |> not)
+
+ let manager =
+ let log = new StringWriter()
+ let options = AnalyzerManagerOptions(LogWriter = log)
+ let m = AnalyzerManager(options)
+ m
+
+ // Because Buildalyzer works better with .csproj, we first "dress up" the project as if it were a C# one
+ // and try to adapt the results. If it doesn't work, we try again to analyze the .fsproj directly
+ let csprojResult =
+ let csprojFile = projFile.Replace(".fsproj", ".csproj")
+ if File.Exists(csprojFile) then
+ None
+ else
+ try
+ File.Copy(projFile, csprojFile)
+ tryGetResult isMain manager csprojFile
+ |> Option.map (fun (r: IAnalyzerResult) ->
+ // Careful, options for .csproj start with / but so do root paths in unix
+ let reg = Regex(@"^\/[^\/]+?(:?:|$)")
+ let comArgs =
+ r.CompilerArguments
+ |> Array.map (fun line ->
+ if reg.IsMatch(line) then
+ if line.StartsWith("/reference") then "-r" + line.Substring(10)
+ else "--" + line.Substring(1)
+ else line)
+ let comArgs =
+ match r.Properties.TryGetValue("OtherFlags") with
+ | false, _ -> comArgs
+ | true, otherFlags ->
+ let otherFlags = otherFlags.Split(' ', System.StringSplitOptions.RemoveEmptyEntries)
+ Array.append otherFlags comArgs
+ comArgs, r)
+ finally
+ File.Delete(csprojFile)
+
+ let compilerArgs, result =
+ csprojResult
+ |> Option.orElseWith (fun () ->
+ tryGetResult isMain manager projFile
+ |> Option.map (fun r ->
+ // result.CompilerArguments doesn't seem to work well in Linux
+ let comArgs = Regex.Split(r.Command, @"\r?\n")
+ comArgs, r))
+ |> function
+ | Some result -> result
+ // TODO: Get Buildalyzer errors from the log
+ | None -> failwith $"Cannot parse {projFile}"
+
+ let projDir = Path.GetDirectoryName(projFile)
+ let projOpts =
+ compilerArgs
+ |> Array.skipWhile (fun line -> not(line.StartsWith("-")))
+ |> Array.map (fun f ->
+ if f.EndsWith(".fs") || f.EndsWith(".fsi") then
+ if Path.IsPathRooted f then f else Path.Combine(projDir, f)
+ else f)
+ projOpts,
+ Seq.toArray result.ProjectReferences,
+ result.Properties,
+ result.TargetFramework
+
+let mkStandardProjectReferences () =
+ let file = "fcs-export.fsproj"
+ let projDir = __SOURCE_DIRECTORY__
+ let projFile = Path.Combine(projDir, file)
+ let (args, _, _, _) = getProjectOptionsFromProjectFile true projFile
+ args
+ |> Array.filter (fun s -> s.StartsWith("-r:"))
+
+let mkProjectCommandLineArgsForScript (dllName, fileNames) =
+ [| yield "--simpleresolution"
+ yield "--noframework"
+ yield "--debug:full"
+ yield "--define:DEBUG"
+ yield "--targetprofile:netcore"
+ yield "--optimize-"
+ yield "--out:" + dllName
+ yield "--doc:test.xml"
+ yield "--warn:3"
+ yield "--fullpaths"
+ yield "--flaterrors"
+ yield "--target:library"
+ for x in fileNames do
+ yield x
+ let references = mkStandardProjectReferences ()
+ for r in references do
+ yield r
+ |]
+
+let checker = FSharpChecker.Create()
+
+let parseAndCheckScript (file, input) =
+ let dllName = Path.ChangeExtension(file, ".dll")
+ let projName = Path.ChangeExtension(file, ".fsproj")
+ let args = mkProjectCommandLineArgsForScript (dllName, [file])
+ printfn "file: %s" file
+ args |> Array.iter (printfn "args: %s")
+ let projectOptions = checker.GetProjectOptionsFromCommandLineArgs (projName, args)
+ let parseRes, typedRes = checker.ParseAndCheckFileInProject(file, 0, input, projectOptions) |> Async.RunSynchronously
+
+ if parseRes.Diagnostics.Length > 0 then
+ printfn "---> Parse Input = %A" input
+ printfn "---> Parse Error = %A" parseRes.Diagnostics
+
+ match typedRes with
+ | FSharpCheckFileAnswer.Succeeded(res) -> parseRes, res
+ | res -> failwithf "Parsing did not finish... (%A)" res
+
+[]
+let main argv =
+ ignore argv
+ printfn "Exporting metadata..."
+ let file = "/temp/test.fsx"
+ let input = "let a = 42"
+ let sourceText = FSharp.Compiler.Text.SourceText.ofString input
+ // parse script just to export metadata
+ let parseRes, typedRes = parseAndCheckScript(file, sourceText)
+ printfn "Exporting is done. Binaries can be found in ./temp/metadata/"
+ 0
diff --git a/fcs/fcs-export/fcs-export.fsproj b/fcs/fcs-export/fcs-export.fsproj
new file mode 100644
index 00000000000..3587eb1c552
--- /dev/null
+++ b/fcs/fcs-export/fcs-export.fsproj
@@ -0,0 +1,31 @@
+
+
+
+ Exe
+ net9.0
+ true
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/Compiler/AbstractIL/ilwrite.fs b/src/Compiler/AbstractIL/ilwrite.fs
index 3cbdd3c752b..1d87e99825b 100644
--- a/src/Compiler/AbstractIL/ilwrite.fs
+++ b/src/Compiler/AbstractIL/ilwrite.fs
@@ -2,6 +2,10 @@
module internal FSharp.Compiler.AbstractIL.ILBinaryWriter
+#if EXPORT_METADATA
+#nowarn "1182"
+#endif
+
open System
open System.Collections.Generic
open System.IO
@@ -1122,9 +1126,11 @@ let FindMethodDefIdx cenv mdkey =
else sofar) None) with
| Some x -> x
| None -> raise MethodDefNotFound
+#if !EXPORT_METADATA
let (TdKey (tenc, tname)) = typeNameOfIdx mdkey.TypeIdx
dprintn ("The local method '"+(String.concat "." (tenc@[tname]))+"'::'"+mdkey.Name+"' was referenced but not declared")
dprintn ("generic arity: "+string mdkey.GenericArity)
+#endif
cenv.methodDefIdxsByKey.dict |> Seq.iter (fun (KeyValue(mdkey2, _)) ->
if mdkey2.TypeIdx = mdkey.TypeIdx && mdkey.Name = mdkey2.Name then
let (TdKey (tenc2, tname2)) = typeNameOfIdx mdkey2.TypeIdx
@@ -2639,6 +2645,9 @@ let GenMethodDefAsRow cenv env midx (mdef: ILMethodDef) =
if cenv.entrypoint <> None then failwith "duplicate entrypoint"
else cenv.entrypoint <- Some (true, midx)
let codeAddr =
+#if EXPORT_METADATA
+ 0x0000
+#else
(match mdef.Body with
| MethodBody.IL ilmbodyLazy ->
let ilmbody =
@@ -2689,6 +2698,7 @@ let GenMethodDefAsRow cenv env midx (mdef: ILMethodDef) =
| MethodBody.Native ->
failwith "cannot write body of native method - Abstract IL cannot roundtrip mixed native/managed binaries"
| _ -> 0x0000)
+#endif
UnsharedRow
[| ULong codeAddr
@@ -3851,6 +3861,7 @@ let writeBinaryAux (stream: Stream, options: options, modul, normalizeAssemblyRe
match options.signer, modul.Manifest with
| Some _, _ -> options.signer
| _, None -> options.signer
+#if !EXPORT_METADATA
| None, Some {PublicKey=Some pubkey} ->
(dprintn "Note: The output assembly will be delay-signed using the original public"
dprintn "Note: key. In order to load it you will need to either sign it with"
@@ -3860,6 +3871,7 @@ let writeBinaryAux (stream: Stream, options: options, modul, normalizeAssemblyRe
dprintn "Note: private key when converting the assembly, assuming you have access to"
dprintn "Note: it."
Some (ILStrongNameSigner.OpenPublicKey pubkey))
+#endif
| _ -> options.signer
let modul =
@@ -3871,11 +3883,13 @@ let writeBinaryAux (stream: Stream, options: options, modul, normalizeAssemblyRe
with exn ->
failwith ("A call to StrongNameGetPublicKey failed (" + exn.Message + ")")
None
+#if !EXPORT_METADATA
match modul.Manifest with
| None -> ()
| Some m ->
if m.PublicKey <> None && m.PublicKey <> pubkey then
dprintn "Warning: The output assembly is being signed or delay-signed with a strong name that is different to the original."
+#endif
{ modul with Manifest = match modul.Manifest with None -> None | Some m -> Some {m with PublicKey = pubkey} }
let pdbData, pdbInfoOpt, debugDirectoryChunk, debugDataChunk, debugChecksumPdbChunk, debugEmbeddedPdbChunk, debugDeterministicPdbChunk, textV2P, mappings =
diff --git a/src/Compiler/Driver/CompilerImports.fs b/src/Compiler/Driver/CompilerImports.fs
index c54ccc41c58..4c214876505 100644
--- a/src/Compiler/Driver/CompilerImports.fs
+++ b/src/Compiler/Driver/CompilerImports.fs
@@ -2623,6 +2623,60 @@ and [] TcImports
global_g <- Some tcGlobals
#endif
frameworkTcImports.SetTcGlobals tcGlobals
+
+#if EXPORT_METADATA
+ let metadataPath = __SOURCE_DIRECTORY__ + "/../../../temp/metadata/"
+ let writeMetadata (dllInfo: ImportedBinary) =
+ let outfile = Path.GetFullPath(metadataPath + Path.GetFileName(dllInfo.FileName))
+ let ilModule = dllInfo.RawMetadata.TryGetILModuleDef().Value
+ try
+ let args: AbstractIL.ILBinaryWriter.options = {
+ ilg = tcGlobals.ilg
+ outfile = outfile
+ pdbfile = None //pdbfile
+ emitTailcalls = tcConfig.emitTailcalls
+ deterministic = tcConfig.deterministic
+ portablePDB = tcConfig.portablePDB
+ embeddedPDB = tcConfig.embeddedPDB
+ embedAllSource = tcConfig.embedAllSource
+ embedSourceList = tcConfig.embedSourceList
+ allGivenSources = [] //ilSourceDocs
+ sourceLink = tcConfig.sourceLink
+ checksumAlgorithm = tcConfig.checksumAlgorithm
+ signer = None //GetStrongNameSigner signingInfo
+ dumpDebugInfo = tcConfig.dumpDebugInfo
+ referenceAssemblyOnly = false
+ referenceAssemblyAttribOpt = None
+ referenceAssemblySignatureHash = None
+ pathMap = tcConfig.pathMap
+ }
+ AbstractIL.ILBinaryWriter.WriteILBinaryFile (args, ilModule, id)
+ with Failure msg ->
+ printfn "Export error: %s" msg
+
+ let nonFrameworkTcImports = new TcImports(tcConfigP, tcAltResolutions, None, None)
+ let altResolvedAssemblies = tcAltResolutions.GetAssemblyResolutions()
+ let! nonFrameworkAssemblies = nonFrameworkTcImports.RegisterAndImportReferencedAssemblies(ctok, altResolvedAssemblies)
+
+ nonFrameworkAssemblies
+ |> List.iter (function
+ | ResolvedImportedAssembly (asm, m) ->
+ let ilShortAssemName = getNameOfScopeRef asm.ILScopeRef
+ let dllInfo = nonFrameworkTcImports.FindDllInfo(ctok, m, ilShortAssemName)
+ writeMetadata dllInfo
+ | UnresolvedImportedAssembly (_assemblyName, _m) -> ()
+ )
+
+ _assemblies
+ |> List.iter (function
+ | ResolvedImportedAssembly (asm, m) ->
+ let ilShortAssemName = getNameOfScopeRef asm.ILScopeRef
+ let dllInfo = frameworkTcImports.FindDllInfo(ctok, m, ilShortAssemName)
+ writeMetadata dllInfo
+ | UnresolvedImportedAssembly (_assemblyName, _m) -> ()
+ )
+#endif
+
return tcGlobals, frameworkTcImports
}
diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj
index 419746af6c0..250a5391a22 100644
--- a/src/Compiler/FSharp.Compiler.Service.fsproj
+++ b/src/Compiler/FSharp.Compiler.Service.fsproj
@@ -14,6 +14,7 @@
$(OtherFlags) --warnaserror-:1182
FSharp.Compiler.Service
true
+ $(DefineConstants);EXPORT_METADATA
$(DefineConstants);COMPILER
true