Fix stack distribution issues

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 = List.head <| gen.ReturnTypes ()
+                let returnType = methodBuilder.ReturnType
                 gen.Generate ilGen
-                if ((List.head val_type) = typeof<System.Void>) then
-                    ilGen.Emit(OpCodes.Ldnull)
+                match (stackType, returnType) with
+                | (s, r) when s = typeof<Void> && r = typeof<Void> -> ()
+                | (s, r) when s = typeof<Void> && r <> typeof<Void> -> ilGen.Emit OpCodes.Ldnull
+                | (s, r) when s <> typeof<Void> && r = typeof<Void> -> 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<System.Void>) then
+                if List.head val_type <> typeof<Void> 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<System.Void>]
@@ -89,7 +93,12 @@ type BodyGenerator(context:Context,typeBuilder:TypeBuilder,body:SExp list, gf:IG
                     [typeof<obj>]
                 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 () =
@@ -124,6 +133,7 @@ type LetGenerator(context:Context,typeBuilder:TypeBuilder,bindings:SExp,body:SEx
             (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
@@ -132,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<Void>
+            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
@@ -181,7 +194,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 +263,6 @@ type TypeGenerator(context : Context, typeBuilder : TypeBuilder, typeName : stri
             Globals.ModuleBuilder.DefineType(typeName, TypeAttributes.Class ||| TypeAttributes.Public, typeof<obj>)
         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 +279,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<obj>)
             | 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)

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<int>, [| |])
+    let methodBuilder = typeBuilder.DefineMethod ("Main",
+                                                  MethodAttributes.Public ||| MethodAttributes.Static,
+                                                  typeof<Void>,
+                                                  Array.Empty ())
 
-    let gf = new GeneratorFactory(typeBuilder) :> IGeneratorFactory
+    let gf = new GeneratorFactory(typeBuilder, methodBuilder) :> IGeneratorFactory
     assemblyBuilder.SetEntryPoint methodBuilder
 
     let context = Context.create ()

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

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
+        abstract MakeGeneratorFactory : TypeBuilder -> MethodBuilder -> IGeneratorFactory
+    end