Naggum.Assembler

.editorconfig

@@ -4,4 +4,5 @@ root = true
 charset = utf-8
 indent_style = space
 indent_size = 4
+trim_trailing_whitespace = true
 insert_final_newline = true

Naggum.Assembler/App.config

@@ -0,0 +1,6 @@
+<?xml version="1.0" encoding="utf-8"?>
+<configuration>
+  <startup>
+    <supportedRuntime version="v4.0" sku=".NETFramework,Version=v4.6.1" />
+  </startup>
+</configuration>

Naggum.Assembler/Assembler.fs

@@ -0,0 +1,63 @@
+module Naggum.Assembler.Assembler
+
+open System
+open System.Reflection
+open System.Reflection.Emit
+
+open Naggum.Assembler.Representation
+
+let private getMethodAttributes (m : MethodDefinition) =
+    let empty = enum 0
+    let conditions =
+        [ (m.Visibility = Public, MethodAttributes.Public)
+          (true, MethodAttributes.Static) ] // TODO: Proper static method detection
+
+    conditions
+    |> List.map (fun (c, r) -> if c then r else empty)
+    |> List.fold (|||) empty
+
+let private findMethod (signature : MethodSignature) =
+    let ``type`` = signature.ContainingType.Value
+    ``type``.GetMethod (signature.Name, Array.ofList signature.ArgumentTypes)
+
+let private buildMethodBody (m : MethodDefinition) (builder : MethodBuilder) =
+    let generator = builder.GetILGenerator ()
+
+    m.Body
+    |> List.iter (function
+                  | Call signature ->
+                      let methodInfo = findMethod signature
+                      generator.Emit (OpCodes.Call, methodInfo)
+                  | Ldstr string -> generator.Emit (OpCodes.Ldstr, string)
+                  | Ret -> generator.Emit (OpCodes.Ret))
+
+let private assembleUnit (assemblyBuilder : AssemblyBuilder) (builder : ModuleBuilder) = function
+    | Method m ->
+        let name = m.Name
+        let attributes = getMethodAttributes m
+        let returnType = m.ReturnType
+        let argumentTypes = Array.ofList m.ArgumentTypes
+        let methodBuilder = builder.DefineGlobalMethod (name,
+                                                        attributes,
+                                                        returnType,
+                                                        argumentTypes)
+        if Set.contains EntryPoint m.Metadata then
+            assemblyBuilder.SetEntryPoint methodBuilder
+        buildMethodBody m methodBuilder
+
+let private assembleAssembly (assembly : Assembly) =
+    let name = AssemblyName assembly.Name
+    let domain = AppDomain.CurrentDomain
+    let builder = domain.DefineDynamicAssembly (name,
+                                                AssemblyBuilderAccess.Save)
+    let fileName = assembly.Name + ".dll" // TODO: Proper file naming
+    let moduleBuilder = builder.DefineDynamicModule (assembly.Name, fileName)
+    assembly.Units |> List.iter (assembleUnit builder moduleBuilder)
+    moduleBuilder.CreateGlobalFunctions ()
+    builder
+
+/// Assembles the intermediate program representation. Returns a list of
+/// assemblies ready for saving.
+let assemble (assemblies : Assembly seq) : AssemblyBuilder seq =
+    assemblies
+    |> Seq.map assembleAssembly

Naggum.Assembler/AssemblyInfo.fs

@@ -0,0 +1,13 @@
+namespace Naggum.Assembler.AssemblyInfo
+
+open System.Reflection
+open System.Runtime.InteropServices
+
+[<assembly: AssemblyTitle("Naggum.Assembler")>]
+[<assembly: AssemblyProduct("Naggum")>]
+[<assembly: AssemblyCopyright("Copyright © Naggum authors 2015-2016")>]
+[<assembly: ComVisible(false)>]
+[<assembly: Guid("40b84f1e-1823-4255-80d4-1297613025c1")>]
+[<assembly: AssemblyVersion("0.0.1.0")>]
+
+()

Naggum.Assembler/Naggum.Assembler.fsproj

@@ -0,0 +1,88 @@
+<?xml version="1.0" encoding="utf-8"?>
+<Project ToolsVersion="14.0" DefaultTargets="Build" xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
+  <Import Project="$(MSBuildExtensionsPath)\$(MSBuildToolsVersion)\Microsoft.Common.props" Condition="Exists('$(MSBuildExtensionsPath)\$(MSBuildToolsVersion)\Microsoft.Common.props')" />
+  <PropertyGroup>
+    <Configuration Condition=" '$(Configuration)' == '' ">Debug</Configuration>
+    <Platform Condition=" '$(Platform)' == '' ">AnyCPU</Platform>
+    <SchemaVersion>2.0</SchemaVersion>
+    <ProjectGuid>40b84f1e-1823-4255-80d4-1297613025c1</ProjectGuid>
+    <OutputType>Exe</OutputType>
+    <RootNamespace>Naggum.Assembler</RootNamespace>
+    <AssemblyName>Naggum.Assembler</AssemblyName>
+    <TargetFrameworkVersion>v4.6.1</TargetFrameworkVersion>
+    <AutoGenerateBindingRedirects>true</AutoGenerateBindingRedirects>
+    <TargetFSharpCoreVersion>4.4.0.0</TargetFSharpCoreVersion>
+    <Name>Naggum.Assembler</Name>
+    <TargetFrameworkProfile />
+  </PropertyGroup>
+  <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' ">
+    <DebugSymbols>true</DebugSymbols>
+    <DebugType>full</DebugType>
+    <Optimize>false</Optimize>
+    <Tailcalls>false</Tailcalls>
+    <OutputPath>bin\Debug\</OutputPath>
+    <DefineConstants>DEBUG;TRACE</DefineConstants>
+    <WarningLevel>3</WarningLevel>
+    <PlatformTarget>AnyCPU</PlatformTarget>
+    <DocumentationFile>bin\Debug\Naggum.Assembler.XML</DocumentationFile>
+    <Prefer32Bit>true</Prefer32Bit>
+  </PropertyGroup>
+  <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' ">
+    <DebugType>pdbonly</DebugType>
+    <Optimize>true</Optimize>
+    <Tailcalls>true</Tailcalls>
+    <OutputPath>bin\Release\</OutputPath>
+    <DefineConstants>TRACE</DefineConstants>
+    <WarningLevel>3</WarningLevel>
+    <PlatformTarget>AnyCPU</PlatformTarget>
+    <DocumentationFile>bin\Release\Naggum.Assembler.XML</DocumentationFile>
+    <Prefer32Bit>true</Prefer32Bit>
+  </PropertyGroup>
+  <ItemGroup>
+    <Reference Include="mscorlib" />
+    <Reference Include="FSharp.Core, Version=$(TargetFSharpCoreVersion), Culture=neutral, PublicKeyToken=b03f5f7f11d50a3a">
+      <Private>True</Private>
+    </Reference>
+    <Reference Include="System" />
+    <Reference Include="System.Core" />
+    <Reference Include="System.Numerics" />
+  </ItemGroup>
+  <ItemGroup>
+    <None Include="App.config" />
+    <Compile Include="AssemblyInfo.fs" />
+    <Compile Include="Representation.fs" />
+    <Compile Include="Processor.fs" />
+    <Compile Include="Assembler.fs" />
+    <Compile Include="Program.fs" />
+  </ItemGroup>
+  <ItemGroup>
+    <ProjectReference Include="..\Naggum.Compiler\Naggum.Compiler.fsproj">
+      <Name>Naggum.Compiler</Name>
+      <Project>{a4269c5e-e4ac-44bf-a06e-1b45248910ad}</Project>
+      <Private>True</Private>
+    </ProjectReference>
+  </ItemGroup>
+  <PropertyGroup>
+    <MinimumVisualStudioVersion Condition="'$(MinimumVisualStudioVersion)' == ''">11</MinimumVisualStudioVersion>
+  </PropertyGroup>
+  <Choose>
+    <When Condition="'$(VisualStudioVersion)' == '11.0'">
+      <PropertyGroup Condition="Exists('$(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets')">
+        <FSharpTargetsPath>$(MSBuildExtensionsPath32)\..\Microsoft SDKs\F#\3.0\Framework\v4.0\Microsoft.FSharp.Targets</FSharpTargetsPath>
+      </PropertyGroup>
+    </When>
+    <Otherwise>
+      <PropertyGroup Condition="Exists('$(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets')">
+        <FSharpTargetsPath>$(MSBuildExtensionsPath32)\Microsoft\VisualStudio\v$(VisualStudioVersion)\FSharp\Microsoft.FSharp.Targets</FSharpTargetsPath>
+      </PropertyGroup>
+    </Otherwise>
+  </Choose>
+  <Import Project="$(FSharpTargetsPath)" />
+  <!-- To modify your build process, add your task inside one of the targets below and uncomment it. 
+       Other similar extension points exist, see Microsoft.Common.targets.
+  <Target Name="BeforeBuild">
+  </Target>
+  <Target Name="AfterBuild">
+  </Target>
+  -->
+</Project>

Naggum.Assembler/Processor.fs

@@ -0,0 +1,96 @@
+module Naggum.Assembler.Processor
+
+open System
+open System.IO
+open System.Reflection
+
+open Naggum.Assembler.Representation
+open Naggum.Compiler
+open Naggum.Compiler.Reader
+
+let private processMetadataItem = function
+    | Atom (Symbol ".entrypoint") -> EntryPoint
+    | other -> failwithf "Unrecognized metadata item definition: %A" other
+
+let private resolveAssembly _ =
+    Assembly.GetAssembly(typeof<Int32>) // TODO: Assembly resolver
+
+let private resolveType name =
+    let result = Type.GetType name // TODO: Resolve types from the assembler context
+    if isNull result then
+        failwithf "Type %s could not be found" name
+
+    result
+
+let private resolveTypes =
+    List.map (function
+              | Atom (Symbol name) -> resolveType name
+              | other -> failwithf "Unrecognized type: %A" other)
+
+let private processMethodSignature = function
+    | [Atom (Symbol assembly)
+       Atom (Symbol typeName)
+       Atom (Symbol methodName)
+       List argumentTypes
+       Atom (Symbol returnType)] ->
+        { Assembly = Some (resolveAssembly assembly) // TODO: Resolve types from current assembly
+          ContainingType = Some (resolveType typeName) // TODO: Resolve methods without a type (e.g. assembly methods)
+          Name = methodName
+          ArgumentTypes = resolveTypes argumentTypes
+          ReturnType = resolveType returnType }
+    | other -> failwithf "Unrecognized method signature: %A" other
+
+let private processInstruction = function
+    | List ([Atom (Symbol "ldstr"); Atom (Object (:? string as s))]) ->
+        Ldstr s
+    | List ([Atom (Symbol "call"); List (calleeSignature)]) ->
+        let signature = processMethodSignature calleeSignature
+        Call signature
+    | List ([Atom (Symbol "ret")]) -> Ret
+    | other -> failwithf "Unrecognized instruction: %A" other
+
+let private addMetadata metadata method' =
+    List.fold (fun ``method`` metadataExpr ->
+                   let metadataItem = processMetadataItem metadataExpr
+                   { ``method`` with Metadata = Set.add metadataItem ``method``.Metadata })
+              method'
+              metadata
+
+let private addBody body method' =
+    List.fold (fun ``method`` bodyClause ->
+                   let instruction = processInstruction bodyClause
+                   { ``method`` with Body = List.append ``method``.Body [instruction] })
+              method'
+              body
+
+let private processAssemblyUnit = function
+    | List (Atom (Symbol ".method")
+            :: Atom (Symbol name)
+            :: List argumentTypes
+            :: Atom (Symbol returnType)
+            :: List metadata
+            :: body) ->
+        let definition =
+            { Metadata = Set.empty
+              Visibility = Public // TODO: Determine method visibility
+              Name = name
+              ArgumentTypes = resolveTypes argumentTypes
+              ReturnType = resolveType returnType
+              Body = List.empty }
+        definition
+        |> addMetadata metadata
+        |> addBody body
+        |> Method
+    | other -> failwithf "Unrecognized assembly unit definition: %A" other
+
+let private prepareTopLevel = function
+    | List (Atom (Symbol ".assembly") :: Atom (Symbol name) :: units) ->
+        { Name = name
+          Units = List.map processAssemblyUnit units }
+    | other -> failwithf "Unknown top-level construct: %A" other
+
+/// Prepares the source file for assembling. Returns the intermediate
+/// representation of the source code.
+let prepare (fileName : string) (stream : Stream) : Assembly seq =
+    let forms = Reader.parse fileName stream
+    forms |> Seq.map prepareTopLevel

Naggum.Assembler/Program.fs

@@ -0,0 +1,52 @@
+module Naggum.Assembler.Program
+
+open System
+open System.IO
+open System.Reflection
+open System.Reflection.Emit
+
+type private ReturnCode =
+    | Success = 0
+    | Error = 1
+    | InvalidArguments = 2
+
+let private printUsage () =
+    let version = Assembly.GetExecutingAssembly().GetName().Version
+    printfn "Naggum Assembler %A" version
+    printfn "Usage: Naggum.Assembler [one or more file names]"
+
+let private printError (error : Exception) =
+    printfn "Error: %s" (error.ToString ())
+
+let private save (assembly : AssemblyBuilder) =
+    let name = assembly.FullName
+    assembly.Save name
+    printfn "Assembly %s saved" name
+
+let private assemble fileName =
+    use stream = File.OpenRead fileName
+    let repr = Processor.prepare fileName stream
+    let assemblies = Assembler.assemble repr
+    assemblies |> Seq.iter save
+
+let private nga =
+    function
+    | [| "--help" |] ->
+        printUsage ()
+        ReturnCode.Success
+    | fileNames when fileNames.Length > 0 ->
+        try
+            fileNames |> Array.iter assemble
+            ReturnCode.Success
+        with
+        | error ->
+            printError error
+            ReturnCode.Error
+    | _ ->
+        printUsage ()
+        ReturnCode.InvalidArguments
+
+[<EntryPoint>]
+let main args =
+    let result = nga args
+    int result

Naggum.Assembler/Representation.fs

@@ -0,0 +1,39 @@
+namespace Naggum.Assembler.Representation
+
+open System.Reflection
+
+type MetadataItem =
+    | EntryPoint
+
+type Visibility =
+    | Public
+
+type Type = System.Type
+
+type MethodSignature =
+    { Assembly : Assembly option
+      ContainingType : Type option
+      Name : string
+      ArgumentTypes : Type list
+      ReturnType : Type }
+
+type Instruction =
+    | Call of MethodSignature
+    | Ldstr of string
+    | Ret
+
+type MethodDefinition =
+    { Metadata : Set<MetadataItem>
+      Visibility : Visibility
+      Name : string
+      ArgumentTypes : Type list
+      ReturnType : Type
+      Body : Instruction list }
+
+type AssemblyUnit =
+    | Method of MethodDefinition
+
+type Assembly =
+    { Name : string
+      Units : AssemblyUnit list }
+    override this.ToString () = sprintf "%A" this