Skip to content

Commit

Permalink
Export metadata
Browse files Browse the repository at this point in the history
  • Loading branch information
ncave committed Oct 15, 2023
1 parent d848547 commit 2bfe950
Show file tree
Hide file tree
Showing 9 changed files with 251 additions and 2 deletions.
10 changes: 10 additions & 0 deletions .vscode/launch.json
Original file line number Diff line number Diff line change
Expand Up @@ -87,6 +87,16 @@
"justMyCode": true,
"enableStepFiltering": false,
"requireExactSource": false
},
{
"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
}
]
}
4 changes: 2 additions & 2 deletions buildtools/buildtools.targets
Original file line number Diff line number Diff line change
Expand Up @@ -20,7 +20,7 @@
BeforeTargets="CoreCompile">

<PropertyGroup>
<FsLexPath Condition="'$(FsLexPath)' == ''">$(ArtifactsDir)\Bootstrap\fslex\fslex.dll</FsLexPath>
<FsLexPath Condition="'$(FsLexPath)' == ''">$(ArtifactsDir)\bin\fslex\Release\net8.0\fslex.dll</FsLexPath>
</PropertyGroup>

<!-- Create the output directory -->
Expand All @@ -44,7 +44,7 @@
BeforeTargets="CoreCompile">

<PropertyGroup>
<FsYaccPath Condition="'$(FsYaccPath)' == ''">$(ArtifactsDir)\Bootstrap\fsyacc\fsyacc.dll</FsYaccPath>
<FsYaccPath Condition="'$(FsYaccPath)' == ''">$(ArtifactsDir)\bin\fsyacc\Release\net8.0\fsyacc.dll</FsYaccPath>
</PropertyGroup>

<!-- Create the output directory -->
Expand Down
5 changes: 5 additions & 0 deletions fcs/build.sh
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
#!/usr/bin/env bash

dotnet build -c Release buildtools
dotnet build -c Release src/Compiler
dotnet run -c Release --project fcs/fcs-export
10 changes: 10 additions & 0 deletions fcs/fcs-export/NuGet.config
Original file line number Diff line number Diff line change
@@ -0,0 +1,10 @@
<?xml version="1.0" encoding="utf-8"?>
<configuration>
<packageSources>
<clear />
<add key="NuGet.org" value="https://api.nuget.org/v3/index.json" />
</packageSources>
<disabledPackageSources>
<clear />
</disabledPackageSources>
</configuration>
137 changes: 137 additions & 0 deletions fcs/fcs-export/Program.fs
Original file line number Diff line number Diff line change
@@ -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

[<EntryPoint>]
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
31 changes: 31 additions & 0 deletions fcs/fcs-export/fcs-export.fsproj
Original file line number Diff line number Diff line change
@@ -0,0 +1,31 @@
<Project Sdk="Microsoft.NET.Sdk">

<PropertyGroup>
<OutputType>Exe</OutputType>
<TargetFramework>net8.0</TargetFramework>
<DisableImplicitFSharpCoreReference>true</DisableImplicitFSharpCoreReference>
</PropertyGroup>

<ItemGroup>
<Compile Include="Program.fs" />
</ItemGroup>

<ItemGroup>
<!-- <ProjectReference Include="../../src/Compiler/FSharp.Compiler.Service.fsproj" /> -->
<!-- <ProjectReference Include="../../src/Compiler/FSharp.Core/FSharp.Core.fsproj" /> -->
<Reference Include="../../artifacts/bin/FSharp.Compiler.Service/Release/netstandard2.0/FSharp.Core.dll" />
<Reference Include="../../artifacts/bin/FSharp.Compiler.Service/Release/netstandard2.0/FSharp.Compiler.Service.dll" />
</ItemGroup>

<ItemGroup>
<!-- <PackageReference Include="FSharp.Core" Version="8.0.0" /> -->
<PackageReference Include="Buildalyzer" Version="5.0.1" />
<PackageReference Include="Fable.Core" Version="4.1.0" />
<PackageReference Include="Fable.Browser.Blob" Version="*" />
<PackageReference Include="Fable.Browser.Dom" Version="*" />
<PackageReference Include="Fable.Browser.Event" Version="*" />
<PackageReference Include="Fable.Browser.Gamepad" Version="*" />
<PackageReference Include="Fable.Browser.WebGL" Version="*" />
<PackageReference Include="Fable.Browser.WebStorage" Version="*" />
</ItemGroup>
</Project>
14 changes: 14 additions & 0 deletions src/Compiler/AbstractIL/ilwrite.fs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -1102,9 +1106,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
Expand Down Expand Up @@ -2614,6 +2620,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 =
Expand Down Expand Up @@ -2664,6 +2673,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
Expand Down Expand Up @@ -3820,6 +3830,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"
Expand All @@ -3829,6 +3840,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 =
Expand All @@ -3840,11 +3852,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 =
Expand Down
41 changes: 41 additions & 0 deletions src/Compiler/Driver/CompilerImports.fs
Original file line number Diff line number Diff line change
Expand Up @@ -2508,6 +2508,47 @@ and [<Sealed>] 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

_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
}

Expand Down
1 change: 1 addition & 0 deletions src/Compiler/FSharp.Compiler.Service.fsproj
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@
<NoWarn>$(NoWarn);NU5125</NoWarn>
<AssemblyName>FSharp.Compiler.Service</AssemblyName>
<AllowCrossTargeting>true</AllowCrossTargeting>
<DefineConstants>$(DefineConstants);EXPORT_METADATA</DefineConstants>
<DefineConstants>$(DefineConstants);COMPILER</DefineConstants>
<DefineConstants Condition="'$(FSHARPCORE_USE_PACKAGE)' == 'true'">$(DefineConstants);FSHARPCORE_USE_PACKAGE</DefineConstants>
<OtherFlags>$(OtherFlags) --extraoptimizationloops:1</OtherFlags>
Expand Down

0 comments on commit 2bfe950

Please sign in to comment.