From 29eff24d741d68b6e8a84e74428309d8ebd15b3b Mon Sep 17 00:00:00 2001 From: Friedrich von Never Date: Sat, 19 Dec 2015 11:43:54 +0600 Subject: [PATCH 1/6] ngc: more proper stack management (do not emit ldnull when returning from the void method). --- ngc/FormGenerator.fs | 42 +++++++++++++++++++------------ ngc/Generator.fs | 12 ++++----- ngc/GeneratorFactory.fs | 55 ++++++++++++++++++++++++----------------- ngc/IGenerator.fs | 5 ++-- 4 files changed, 65 insertions(+), 49 deletions(-) diff --git a/ngc/FormGenerator.fs b/ngc/FormGenerator.fs index 9121d25..1b1d77c 100644 --- a/ngc/FormGenerator.fs +++ b/ngc/FormGenerator.fs @@ -5,11 +5,8 @@ open System.Collections.Generic open System.Reflection open System.Reflection.Emit open Naggum.Runtime -open Naggum.Compiler.Globals -open Naggum.Compiler.Reader open Naggum.Compiler.Context open Naggum.Compiler.IGenerator -open Naggum.Util.MaybeMonad open Naggum.Compiler.Reader type FormGenerator() = @@ -59,27 +56,34 @@ type SequenceGenerator(context:Context,typeBuilder:TypeBuilder,seq:SExp list, gf member this.ReturnTypes () = List.map (fun (sexp) -> List.head ((gf.MakeGenerator context sexp).ReturnTypes())) seq -type BodyGenerator(context:Context,typeBuilder:TypeBuilder,body:SExp list, gf:IGeneratorFactory) = - member private this.gen_body (ilGen:ILGenerator,body:SExp list) = +type BodyGenerator(context : Context, + methodBuilder : MethodBuilder, + body : SExp list, + gf : IGeneratorFactory) = + let rec genBody (ilGen : ILGenerator) (body : SExp list) = match body with | [] -> ilGen.Emit(OpCodes.Ldnull) | [last] -> let gen = gf.MakeGenerator context last - let val_type = gen.ReturnTypes() + let stackType = Seq.head <| gen.ReturnTypes () + let returnType = methodBuilder.ReturnType gen.Generate ilGen - if ((List.head val_type) = typeof) then - ilGen.Emit(OpCodes.Ldnull) + match (stackType, returnType) with + | (s, r) when s = typeof && r = typeof -> () + | (s, r) when s = typeof && r <> typeof -> ilGen.Emit OpCodes.Ldnull + | (s, r) when s <> typeof && r = typeof -> ilGen.Emit OpCodes.Pop + | _ -> () | sexp :: rest -> let gen = gf.MakeGenerator context sexp let val_type = gen.ReturnTypes() gen.Generate ilGen - if not (List.head val_type = typeof) then + if List.head val_type <> typeof then ilGen.Emit(OpCodes.Pop) - this.gen_body (ilGen,rest) + genBody ilGen rest interface IGenerator with - member this.Generate ilGen = - this.gen_body (ilGen,body) + member __.Generate ilGen = + genBody ilGen body member this.ReturnTypes () = match body with |[] -> [typeof] @@ -89,7 +93,12 @@ type BodyGenerator(context:Context,typeBuilder:TypeBuilder,body:SExp list, gf:IG [typeof] else tail_type -type LetGenerator(context:Context,typeBuilder:TypeBuilder,bindings:SExp,body:SExp list,gf:IGeneratorFactory) = +type LetGenerator(context : Context, + typeBuilder : TypeBuilder, + methodBuilder : MethodBuilder, + bindings:SExp, + body : SExp list, + gf : IGeneratorFactory) = interface IGenerator with member this.Generate ilGen = ilGen.BeginScope() @@ -107,7 +116,7 @@ type LetGenerator(context:Context,typeBuilder:TypeBuilder,bindings:SExp,body:SEx ilGen.Emit (OpCodes.Stloc,local) | other -> failwithf "In let bindings: Expected: (name (form))\nGot: %A\n" other | other -> failwithf "In let form: expected: list of bindings\nGot: %A" other - let bodyGen = (new BodyGenerator (scope_subctx,typeBuilder,body,gf) :> IGenerator) + let bodyGen = new BodyGenerator (scope_subctx, methodBuilder, body, gf) :> IGenerator bodyGen.Generate ilGen ilGen.EndScope() member this.ReturnTypes () = @@ -181,7 +190,8 @@ type DefunGenerator(context:Context,typeBuilder:TypeBuilder,fname:string,paramet let parm_idx = (List.findIndex (fun (p) -> p = parm) parameters) fun_ctx.locals.[new Symbol(parm_name)] <- Arg (parm_idx,arg_types.[parm_idx]) | other -> failwithf "In function %A parameter definition:\nExpected: Atom(Symbol)\nGot: %A" fname parm - let bodyGen = gf.MakeBody fun_ctx body + let methodFactory = gf.MakeGeneratorFactory typeBuilder methodGen + let bodyGen = methodFactory.MakeBody fun_ctx body bodyGen.Generate methodILGen methodILGen.Emit(OpCodes.Ret) methodGen :> MethodInfo) @@ -249,7 +259,6 @@ type TypeGenerator(context : Context, typeBuilder : TypeBuilder, typeName : stri Globals.ModuleBuilder.DefineType(typeName, TypeAttributes.Class ||| TypeAttributes.Public, typeof) else Globals.ModuleBuilder.DefineType(typeName, TypeAttributes.Class ||| TypeAttributes.Public, context.types.[new Symbol(parentTypeName)]) - let newGeneratorFactory = gf.MakeGeneratorFactory newTypeBuilder let mutable fields : string list = [] let generate_field field_name = @@ -266,6 +275,7 @@ type TypeGenerator(context : Context, typeBuilder : TypeBuilder, typeName : stri let parm_idx = (List.findIndex (fun (p) -> p = parm) method_parms) method_ctx.locals.[new Symbol(parm_name)] <- Arg (parm_idx,typeof) | other -> failwithf "In method %A%A parameter definition:\nExpected: Atom(Symbol)\nGot: %A" typeName method_name parm + let newGeneratorFactory = gf.MakeGeneratorFactory newTypeBuilder method_gen let body_gen = newGeneratorFactory.MakeBody method_ctx method_body body_gen.Generate (method_gen.GetILGenerator()) (method_gen.GetILGenerator()).Emit(OpCodes.Ret) diff --git a/ngc/Generator.fs b/ngc/Generator.fs index 97c8c30..f7134c8 100644 --- a/ngc/Generator.fs +++ b/ngc/Generator.fs @@ -2,17 +2,12 @@ open System open System.IO -open System.Collections.Generic open System.Reflection open System.Reflection.Emit -open Naggum.Compiler.Globals open Naggum.Compiler.IGenerator open Naggum.Compiler.GeneratorFactory open Naggum.Compiler.Reader -open Naggum.Runtime - -open Context let private prologue (ilGen : ILGenerator) = ilGen.BeginScope() @@ -38,9 +33,12 @@ let compile (source : Stream) (assemblyName : string) (fileName : string) (asmRe let assemblyBuilder = AppDomain.CurrentDomain.DefineDynamicAssembly(assemblyName, AssemblyBuilderAccess.Save) Globals.ModuleBuilder <- assemblyBuilder.DefineDynamicModule(assemblyBuilder.GetName().Name, fileName) let typeBuilder = Globals.ModuleBuilder.DefineType("Program", TypeAttributes.Public ||| TypeAttributes.Class ||| TypeAttributes.BeforeFieldInit) - let methodBuilder = typeBuilder.DefineMethod("Main", MethodAttributes.Public ||| MethodAttributes.Static, typeof, [| |]) + let methodBuilder = typeBuilder.DefineMethod ("Main", + MethodAttributes.Public ||| MethodAttributes.Static, + typeof, + Array.Empty ()) - let gf = new GeneratorFactory(typeBuilder) :> IGeneratorFactory + let gf = new GeneratorFactory(typeBuilder, methodBuilder) :> IGeneratorFactory assemblyBuilder.SetEntryPoint methodBuilder let context = Context.create () diff --git a/ngc/GeneratorFactory.fs b/ngc/GeneratorFactory.fs index c6ef35b..f8741b2 100644 --- a/ngc/GeneratorFactory.fs +++ b/ngc/GeneratorFactory.fs @@ -11,11 +11,11 @@ open Naggum.Util.MaybeMonad open Naggum.Compiler.Reader open Naggum.Compiler.MathGenerator open System -open System.Reflection open System.Reflection.Emit open System.Text.RegularExpressions -type GeneratorFactory(typeBldr:TypeBuilder) = +type GeneratorFactory(typeBuilder : TypeBuilder, + methodBuilder : MethodBuilder) = member private this.makeObjectGenerator(o:obj) = match o with | :? System.Int32 -> @@ -39,40 +39,44 @@ type GeneratorFactory(typeBldr:TypeBuilder) = member private this.MakeFormGenerator (context:Context, form:SExp list) = match form with | (Atom (Symbol "defun") :: Atom (Symbol name) :: List args :: body) -> - new DefunGenerator(context,typeBldr,name,args,body,this) :> IGenerator + new DefunGenerator(context,typeBuilder,name,args,body,this) :> IGenerator | Atom (Symbol "if") :: condition :: if_true :: if_false :: [] -> //full if form - new FullIfGenerator(context,typeBldr,condition,if_true,if_false,this) :> IGenerator + new FullIfGenerator(context,typeBuilder,condition,if_true,if_false,this) :> IGenerator | Atom (Symbol "if") :: condition :: if_true :: [] -> //reduced if form - new ReducedIfGenerator(context,typeBldr,condition,if_true,this) :> IGenerator - | Atom (Symbol "let") :: bindings :: body -> //let form - new LetGenerator(context,typeBldr,bindings,body,this) :> IGenerator + new ReducedIfGenerator(context,typeBuilder,condition,if_true,this) :> IGenerator + | Atom (Symbol "let") :: bindings :: body -> // let form + new LetGenerator(context, + typeBuilder, + methodBuilder, + bindings, + body, + this) :> IGenerator | Atom (Symbol "quote") :: quotedExp :: [] -> - new QuoteGenerator(context,typeBldr,quotedExp,this) :> IGenerator + new QuoteGenerator(context,typeBuilder,quotedExp,this) :> IGenerator | Atom (Symbol "new") :: Atom (Symbol typeName) :: args -> - new NewObjGenerator(context,typeBldr,typeName,args,this) :> IGenerator + new NewObjGenerator(context,typeBuilder,typeName,args,this) :> IGenerator | Atom (Symbol "+") :: args -> - new ArithmeticGenerator(context,typeBldr,args,OpCodes.Add,this) :> IGenerator + new ArithmeticGenerator(context,typeBuilder,args,OpCodes.Add,this) :> IGenerator | Atom (Symbol "-") :: args -> - new ArithmeticGenerator(context,typeBldr,args,OpCodes.Sub,this) :> IGenerator + new ArithmeticGenerator(context,typeBuilder,args,OpCodes.Sub,this) :> IGenerator | Atom (Symbol "*") :: args -> - new ArithmeticGenerator(context,typeBldr,args,OpCodes.Mul,this) :> IGenerator + new ArithmeticGenerator(context,typeBuilder,args,OpCodes.Mul,this) :> IGenerator | Atom (Symbol "/") :: args -> - new ArithmeticGenerator(context,typeBldr,args,OpCodes.Div,this) :> IGenerator + new ArithmeticGenerator(context,typeBuilder,args,OpCodes.Div,this) :> IGenerator | Atom (Symbol "=") :: arg_a :: arg_b :: [] -> - new SimpleLogicGenerator(context,typeBldr,arg_a,arg_b,OpCodes.Ceq,this) :> IGenerator + new SimpleLogicGenerator(context,typeBuilder,arg_a,arg_b,OpCodes.Ceq,this) :> IGenerator | Atom (Symbol "<") :: arg_a :: arg_b :: [] -> - new SimpleLogicGenerator(context,typeBldr,arg_a,arg_b,OpCodes.Clt,this) :> IGenerator + new SimpleLogicGenerator(context,typeBuilder,arg_a,arg_b,OpCodes.Clt,this) :> IGenerator | Atom (Symbol ">") :: arg_a :: arg_b :: [] -> - new SimpleLogicGenerator(context,typeBldr,arg_a,arg_b,OpCodes.Cgt,this) :> IGenerator + new SimpleLogicGenerator(context,typeBuilder,arg_a,arg_b,OpCodes.Cgt,this) :> IGenerator |Atom (Symbol "call") :: Atom (Symbol fname) :: instance :: args -> - new InstanceCallGenerator(context, typeBldr, instance, fname, args, this) :> IGenerator + new InstanceCallGenerator(context, typeBuilder, instance, fname, args, this) :> IGenerator | Atom (Symbol fname) :: args -> //generic funcall pattern let tryGetType typeName = try Some (context.types.[new Symbol(typeName)]) with | _ -> try Some (Type.GetType typeName) with | _ -> None - let callRegex = new Regex(@"([\w\.]+)\.(\w+)", RegexOptions.Compiled) let callMatch = callRegex.Match fname @@ -86,16 +90,19 @@ type GeneratorFactory(typeBldr:TypeBuilder) = if Option.isSome maybeClrType then let clrType = Option.get maybeClrType let methodName = callMatch.Groups.[2].Value - new ClrCallGenerator(context, typeBldr, clrType, methodName, args, this) :> IGenerator + new ClrCallGenerator(context, typeBuilder, clrType, methodName, args, this) :> IGenerator else - new FunCallGenerator(context,typeBldr,fname,args,this) :> IGenerator + new FunCallGenerator(context,typeBuilder,fname,args,this) :> IGenerator | _ -> failwithf "Form %A is not supported yet" list member private this.makeSequenceGenerator(context: Context,seq:SExp list) = - new SequenceGenerator(context,typeBldr,seq,(this :> IGeneratorFactory)) + new SequenceGenerator(context,typeBuilder,seq,(this :> IGeneratorFactory)) member private this.makeBodyGenerator(context: Context,body:SExp list) = - new BodyGenerator(context,typeBldr,body,(this :> IGeneratorFactory)) + new BodyGenerator(context, + methodBuilder, + body, + (this :> IGeneratorFactory)) interface IGeneratorFactory with member this.MakeGenerator context sexp = @@ -107,4 +114,6 @@ type GeneratorFactory(typeBldr:TypeBuilder) = member this.MakeBody context body = this.makeBodyGenerator (context,body) :> IGenerator - member this.MakeGeneratorFactory newTypeBuilder = (new GeneratorFactory (newTypeBuilder)) :> IGeneratorFactory + member this.MakeGeneratorFactory newTypeBuilder newMethodBuilder = + new GeneratorFactory(newTypeBuilder, + newMethodBuilder) :> IGeneratorFactory diff --git a/ngc/IGenerator.fs b/ngc/IGenerator.fs index c747ef2..fc35fb1 100644 --- a/ngc/IGenerator.fs +++ b/ngc/IGenerator.fs @@ -1,7 +1,6 @@ module Naggum.Compiler.IGenerator open System -open System.Reflection open System.Reflection.Emit open Naggum.Compiler.Reader @@ -19,5 +18,5 @@ type IGeneratorFactory = abstract MakeGenerator : Context -> SExp -> IGenerator abstract MakeSequence : Context -> SExp list -> IGenerator abstract MakeBody : Context -> SExp list -> IGenerator - abstract MakeGeneratorFactory : TypeBuilder -> IGeneratorFactory - end \ No newline at end of file + abstract MakeGeneratorFactory : TypeBuilder -> MethodBuilder -> IGeneratorFactory + end From b463c335d372b1cebd033f2a2b2bb49cd72407af Mon Sep 17 00:00:00 2001 From: Friedrich von Never Date: Sat, 19 Dec 2015 11:54:16 +0600 Subject: [PATCH 2/6] ngc: fix stack inconsistency bug when calling void methods from the reduced if body. --- ngc/FormGenerator.fs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/ngc/FormGenerator.fs b/ngc/FormGenerator.fs index 1b1d77c..cfd0281 100644 --- a/ngc/FormGenerator.fs +++ b/ngc/FormGenerator.fs @@ -66,7 +66,7 @@ type BodyGenerator(context : Context, ilGen.Emit(OpCodes.Ldnull) | [last] -> let gen = gf.MakeGenerator context last - let stackType = Seq.head <| gen.ReturnTypes () + let stackType = List.head <| gen.ReturnTypes () let returnType = methodBuilder.ReturnType gen.Generate ilGen match (stackType, returnType) with @@ -133,6 +133,7 @@ type LetGenerator(context : Context, (gf.MakeBody type_subctx body).ReturnTypes() type ReducedIfGenerator(context:Context,typeBuilder:TypeBuilder,condition:SExp,if_true:SExp,gf:IGeneratorFactory) = + let returnTypes = (gf.MakeGenerator context if_true).ReturnTypes() interface IGenerator with member this.Generate ilGen = let cond_gen = gf.MakeGenerator context condition @@ -141,13 +142,16 @@ type ReducedIfGenerator(context:Context,typeBuilder:TypeBuilder,condition:SExp,i let end_form = ilGen.DefineLabel() cond_gen.Generate ilGen ilGen.Emit (OpCodes.Brtrue, if_true_lbl) - ilGen.Emit OpCodes.Ldnull - ilGen.Emit (OpCodes.Br,end_form) + + if List.head returnTypes <> typeof + then ilGen.Emit OpCodes.Ldnull + + ilGen.Emit (OpCodes.Br, end_form) ilGen.MarkLabel if_true_lbl if_true_gen.Generate ilGen ilGen.MarkLabel end_form member this.ReturnTypes () = - (gf.MakeGenerator context if_true).ReturnTypes() + returnTypes type FullIfGenerator(context:Context,typeBuilder:TypeBuilder,condition:SExp,if_true:SExp,if_false:SExp,gf:IGeneratorFactory) = interface IGenerator with From b73a968076175a46625b24ea8a404e0aed29de61 Mon Sep 17 00:00:00 2001 From: Friedrich von Never Date: Sat, 19 Dec 2015 22:43:26 +0600 Subject: [PATCH 3/6] Add Travis configuration. --- .travis.yml | 9 +++++++++ Naggum.sln | 1 + 2 files changed, 10 insertions(+) create mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..a192e9f --- /dev/null +++ b/.travis.yml @@ -0,0 +1,9 @@ +language: csharp +mono: latest +solution: Naggum.sln +install: + - nuget restore Naggum.sln + - nuget install xunit.runner.console -Version 2.1.0 -OutputDirectory testrunner +script: + - xbuild /p:Configuration=Release /p:TargetFrameworkVersion="v4.5" Naggum.sln + - mono ./testrunner/xunit.runner.console.2.1.0/tools/xunit.console.exe ./Naggum.Test/bin/Release/Naggum.Test.dll diff --git a/Naggum.sln b/Naggum.sln index 29b2bd3..a70824d 100644 --- a/Naggum.sln +++ b/Naggum.sln @@ -25,6 +25,7 @@ EndProject Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Solution items", "Solution items", "{F85A1ACB-4A60-46A9-856D-92A3C9B97402}" ProjectSection(SolutionItems) = preProject .editorconfig = .editorconfig + .travis.yml = .travis.yml appveyor.yml = appveyor.yml License.md = License.md Readme.md = Readme.md From 784348a60e36a8bd20a9df6849914c669486312b Mon Sep 17 00:00:00 2001 From: Friedrich von Never Date: Fri, 18 Dec 2015 20:29:28 +0600 Subject: [PATCH 4/6] Test: use cross-platform path separator. --- Naggum.Test/CompilerTest.fs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Naggum.Test/CompilerTest.fs b/Naggum.Test/CompilerTest.fs index 448fcad..5b7eec7 100644 --- a/Naggum.Test/CompilerTest.fs +++ b/Naggum.Test/CompilerTest.fs @@ -2,6 +2,7 @@ open System.Diagnostics open System.IO +open System.Reflection open Xunit @@ -12,7 +13,7 @@ type CompilerTest() = static let resultExtension = "result" static let executableExtension = "exe" - static let directory = @"..\..\..\tests" + static let directory = Path.Combine ("..", "..", "..", "tests") static let filenames = [@"comment"; @"test"] static member private RunTest testName = From 75b14b250b52d05d45a083cbedaf8630325a4bba Mon Sep 17 00:00:00 2001 From: Friedrich von Never Date: Sat, 19 Dec 2015 12:06:17 +0600 Subject: [PATCH 5/6] ngc: replace Array.Empty with the new array literal because Mono still doesn't support this API. --- ngc/Generator.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ngc/Generator.fs b/ngc/Generator.fs index f7134c8..d21aaf6 100644 --- a/ngc/Generator.fs +++ b/ngc/Generator.fs @@ -36,7 +36,7 @@ let compile (source : Stream) (assemblyName : string) (fileName : string) (asmRe let methodBuilder = typeBuilder.DefineMethod ("Main", MethodAttributes.Public ||| MethodAttributes.Static, typeof, - Array.Empty ()) + [| |]) let gf = new GeneratorFactory(typeBuilder, methodBuilder) :> IGeneratorFactory assemblyBuilder.SetEntryPoint methodBuilder From 087914635263324f92336a7d8e5fc36cbe378cfb Mon Sep 17 00:00:00 2001 From: Friedrich von Never Date: Sat, 19 Dec 2015 21:48:44 +0600 Subject: [PATCH 6/6] Generator: compiler now could accept path for saving the resulting assembly (useful for tests). --- Naggum.Test/CompilerTest.fs | 5 +++-- ngc/Generator.fs | 11 ++++++++--- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/Naggum.Test/CompilerTest.fs b/Naggum.Test/CompilerTest.fs index 5b7eec7..a240522 100644 --- a/Naggum.Test/CompilerTest.fs +++ b/Naggum.Test/CompilerTest.fs @@ -1,8 +1,8 @@ namespace Naggum.Test +open System open System.Diagnostics open System.IO -open System.Reflection open Xunit @@ -20,7 +20,8 @@ type CompilerTest() = let basePath = Path.Combine(directory, testName) let testPath = Path.ChangeExtension(basePath, testExtension) let resultPath = Path.ChangeExtension(basePath, resultExtension) - let executablePath = Path.ChangeExtension(testName, executableExtension) + let executableName = Path.ChangeExtension (testName, executableExtension) + let executablePath = Path.Combine (Environment.CurrentDirectory, executableName) use stream = File.Open(testPath, FileMode.Open) Generator.compile stream testName executablePath [] diff --git a/ngc/Generator.fs b/ngc/Generator.fs index d21aaf6..b430cb3 100644 --- a/ngc/Generator.fs +++ b/ngc/Generator.fs @@ -28,9 +28,14 @@ let compileMethod context (generatorFactory : IGeneratorFactory) body (methodBui epilogue context ilGenerator -let compile (source : Stream) (assemblyName : string) (fileName : string) (asmRefs:string list): unit = - let assemblyName = new AssemblyName(assemblyName) - let assemblyBuilder = AppDomain.CurrentDomain.DefineDynamicAssembly(assemblyName, AssemblyBuilderAccess.Save) +let compile (source : Stream) (assemblyName : string) (filePath : string) (asmRefs:string list): unit = + let assemblyName = AssemblyName assemblyName + let path = Path.GetDirectoryName filePath + let assemblyPath = if path = "" then null else path + let fileName = Path.GetFileName filePath + let appDomain = AppDomain.CurrentDomain + + let assemblyBuilder = appDomain.DefineDynamicAssembly (assemblyName, AssemblyBuilderAccess.Save, assemblyPath) Globals.ModuleBuilder <- assemblyBuilder.DefineDynamicModule(assemblyBuilder.GetName().Name, fileName) let typeBuilder = Globals.ModuleBuilder.DefineType("Program", TypeAttributes.Public ||| TypeAttributes.Class ||| TypeAttributes.BeforeFieldInit) let methodBuilder = typeBuilder.DefineMethod ("Main",