Merge pull request #259 from dsyme/bug5

Fix problem with System.Void, and bug with finally generation

Author: dsyme

examples/StressProvider.Tests/File1.fs

@@ -1,7 +1,7 @@
 module File1
 
 
-open MyNamespace
+open StressProvider
 
 type Provided = Provider<"">
 let providedTags = Provided.Tags
@@ -13,5 +13,11 @@ let providedTags2a = Provided2a.Tags
 type Provided2empty = Provider2<"">
 let providedTags2empty = Provided2empty.Tags
 
+type Provided3  = Provider3<"three">
+
 //type Provided2missing = Provider2< >
 //let providedTags2missing = Provided2missing.Tags
+
+type Generated1 = GenerativeProvider<3>
+type Generated3 = GenerativeProvider3<"three">
+

examples/StressProvider.Tests/StressProvider.Tests.fs

@@ -4,7 +4,39 @@
 
 module StressProvider.Tests
 
+open Xunit
 
-let x = File1.providedTags.Tag1
-let x2a = File1.providedTags2a.Tag1
-let x2empty = File1.providedTags2empty.Tag1
+[<Fact>]
+let ``StressProvider basic tests 1``() =
+
+    let x = File1.providedTags.Tag1
+    let x2a = File1.providedTags2a.Tag1
+    let x2empty = File1.providedTags2empty.Tag1
+
+    ()
+
+[<Fact>]
+let ``StressProvider basic tests 2``() =
+
+    let v1 = File1.Generated1("innerstate").PropertyWithTryCatch3
+    let v2 = File1.Generated1("innerstate").PropertyWithTryFinally1
+    ()
+
+
+[<Fact>]
+let ``StressProvider erased try/finally``() =
+
+    let mutable disposed = false
+    let disp = { new System.IDisposable with member __.Dispose() = disposed <- true } 
+    let v1 = File1.Provided3.Test(disp)
+    Assert.Equal("[+] Yup, it worked totally.", v1)
+    Assert.Equal(disposed, true)
+
+[<Fact>]
+let ``StressProvider generative try/finally``() =
+
+    let mutable disposed = false
+    let disp = { new System.IDisposable with member __.Dispose() = disposed <- true } 
+    let v1 = File1.Generated3.Test(disp)
+    Assert.Equal("[+] Yup, it worked totally.", v1)
+    Assert.Equal(disposed, true)

examples/StressProvider/StressProvider.fs

@@ -5,6 +5,7 @@ open ProviderImplementation
 open ProviderImplementation.ProvidedTypes
 open FSharp.Quotations
 open FSharp.Core.CompilerServices
+open System
 open System.Reflection
 
 
@@ -19,10 +20,10 @@ type Server (name : string) =
     member x.Name with get() : string = name
 
 [<TypeProvider>]
-type ComboErasingProvider (config : TypeProviderConfig) as this =
+type StressErasingProvider (config : TypeProviderConfig) as this =
     inherit TypeProviderForNamespaces (config)
 
-    let ns = "MyNamespace"
+    let ns = "StressProvider"
     let asm = Assembly.GetExecutingAssembly()
 
     let newProperty t name getter isStatic = ProvidedProperty(name, t, getter, isStatic = isStatic)
@@ -55,7 +56,131 @@ type ComboErasingProvider (config : TypeProviderConfig) as this =
         provided
     )
 
-    do this.AddNamespace(ns, [provider; provider2; tags])
+    let provider3 = ProvidedTypeDefinition(asm, ns, "Provider3", Some typeof<obj>, hideObjectMethods = true)
+
+    do provider3.DefineStaticParameters([ProvidedStaticParameter("Host", typeof<string>)], fun name _ ->
+        let provided = ProvidedTypeDefinition(asm, ns, name, Some typeof<obj>, hideObjectMethods = true)
+
+        let fn = ProvidedMethod("Test", [ ProvidedParameter("disp", typeof<IDisposable>) ], typeof<string>, fun [ arg ] ->
+            <@@
+                use __ = (%%arg : IDisposable)
+                let mutable res = ""
+
+                try 
+                    try
+                        System.Console.WriteLine() // test calling a method with void return type
+                        failwith "This will throw anyway, don't mind it."
+
+                        res <- "[-] Should not get here."
+                    finally
+                        res <- "[+] Caught try-finally, nice."
+
+                        try
+                            failwith "It failed again."
+
+                            res <- "[-] Should not get here."
+                        with
+                        | _ ->
+                            res <- "[+] Caught try-with, nice."
+
+                        try
+                            res <- "[?] Gonna go to finally without throwing..."
+                        finally
+                            res <- "[+] Yup, it worked totally."
+                    res
+                with _ -> 
+                    res
+            @@>
+        , isStatic = true)
+
+        provided.AddMember fn
+        provided
+    )
+
+    do this.AddNamespace(ns, [provider; provider2; provider3; tags])
+
+[<TypeProvider>]
+type StressGenerativeProvider (config : TypeProviderConfig) as this =
+    inherit TypeProviderForNamespaces (config)
+
+    let ns = "StressProvider"
+    let asm = Assembly.GetExecutingAssembly()
+
+    // check we contain a copy of runtime files, and are not referencing the runtime DLL
+    do assert (typeof<SomeRuntimeHelper>.Assembly.GetName().Name = asm.GetName().Name)  
+
+    let createType typeName (count:int) =
+        let asm = ProvidedAssembly()
+        let myType = ProvidedTypeDefinition(asm, ns, typeName, Some typeof<obj>, isErased=false)
+
+        let ctor = ProvidedConstructor([], invokeCode = fun args -> <@@ "My internal state" :> obj @@>)
+        myType.AddMember(ctor)
+
+        let ctor2 = ProvidedConstructor([ProvidedParameter("InnerState", typeof<string>)], invokeCode = fun args -> <@@ (%%(args.[1]):string) :> obj @@>)
+        myType.AddMember(ctor2)
+
+        for i in 1 .. count do 
+            let prop = ProvidedProperty("PropertyWithTryCatch" + string i, typeof<int>, getterCode = fun args -> <@@ try i with _ -> i+1 @@>)
+            myType.AddMember(prop)
+
+        for i in 1 .. count do 
+            let prop = ProvidedProperty("PropertyWithTryFinally" + string i, typeof<int>, getterCode = fun args -> <@@ try i finally ignore i @@>)
+            myType.AddMember(prop)
+
+        let meth = ProvidedMethod("StaticMethod", [], typeof<SomeRuntimeHelper>, isStatic=true, invokeCode = (fun args -> Expr.Value(null, typeof<SomeRuntimeHelper>)))
+        myType.AddMember(meth)
+        asm.AddTypes [ myType ]
+
+        myType
+
+    let provider = 
+        let t = ProvidedTypeDefinition(asm, ns, "GenerativeProvider", Some typeof<obj>, isErased=false)
+        t.DefineStaticParameters( [ProvidedStaticParameter("Count", typeof<int>)], fun typeName args -> createType typeName (unbox<int> args.[0]))
+        t
+
+    let provider3 = ProvidedTypeDefinition(asm, ns, "GenerativeProvider3", Some typeof<obj>, hideObjectMethods = true)
+
+    do provider3.DefineStaticParameters([ProvidedStaticParameter("Host", typeof<string>)], fun name _ ->
+        let provided = ProvidedTypeDefinition(asm, ns, name, Some typeof<obj>, hideObjectMethods = true)
+
+        let fn = ProvidedMethod("Test", [ ProvidedParameter("disp", typeof<IDisposable>) ], typeof<string>, fun [ arg ] ->
+            <@@
+                use __ = (%%arg : IDisposable)
+                let mutable res = ""
+
+                try 
+                    try
+                        System.Console.WriteLine() // test calling a method with void return type
+                        failwith "This will throw anyway, don't mind it."
+
+                        res <- "[-] Should not get here."
+                    finally
+                        res <- "[+] Caught try-finally, nice."
+
+                        try
+                            failwith "It failed again."
+
+                            res <- "[-] Should not get here."
+                        with
+                        | _ ->
+                            res <- "[+] Caught try-with, nice."
+
+                        try
+                            res <- "[?] Gonna go to finally without throwing..."
+                        finally
+                            res <- "[+] Yup, it worked totally."
+                    res
+                with _ -> 
+                    res
+            @@>
+        , isStatic = true)
+
+        provided.AddMember fn
+        provided
+    )
+
+    do
+        this.AddNamespace(ns, [provider; provider3])
 
 
 [<assembly:CompilerServices.TypeProviderAssembly()>]

src/ProvidedTypes.fs

@@ -275,6 +275,19 @@ namespace ProviderImplementation.ProvidedTypes
         let canBindNestedType (bindingFlags: BindingFlags) (c: Type) =
              hasFlag bindingFlags BindingFlags.Public && c.IsNestedPublic || hasFlag bindingFlags BindingFlags.NonPublic && not c.IsNestedPublic
 
+        // We only want to return source types "typeof<Void>" values as _target_ types in one very specific location due to a limitation in the
+        // F# compiler code for multi-targeting.
+        let ImportProvidedMethodBaseAsILMethodRef_OnStack_HACK() = 
+            let rec loop i = 
+                if i > 9 then 
+                    false 
+                else
+                    let frame = StackFrame(i, true)
+                    match frame.GetMethod() with
+                    | null -> loop (i+1)
+                    | m -> m.Name = "ImportProvidedMethodBaseAsILMethodRef" || loop (i+1)
+            loop 1
+
     //--------------------------------------------------------------------------------
     // UncheckedQuotations
 
@@ -1039,17 +1052,36 @@ namespace ProviderImplementation.ProvidedTypes
 
        // Implement overloads
         override __.GetParameters() = parameterInfos 
+
         override __.Attributes = attrs
+
         override __.Name = methodName
+
         override __.DeclaringType = declaringType |> nonNone "DeclaringType" :> Type
+
         override __.IsDefined(_attributeType, _inherit): bool = true
+
         override __.MemberType = MemberTypes.Method
+
         override x.CallingConvention =
             let cc = CallingConventions.Standard
             let cc = if not x.IsStatic then cc ||| CallingConventions.HasThis else cc
             cc
-        override __.ReturnType = returnType
+
+        override __.ReturnType = 
+            if isTgt then 
+                match returnType.Namespace, returnType.Name with 
+                | "System", "Void"->  
+                    if ImportProvidedMethodBaseAsILMethodRef_OnStack_HACK() then 
+                        typeof<Void>
+                    else 
+                        returnType
+                | _ -> returnType
+            else
+                returnType
+
         override __.ReturnParameter = null // REVIEW: Give it a name and type?
+
         override __.ToString() = "Method " + methodName
 
         // These don't have to return fully accurate results - they are used
@@ -3049,6 +3081,7 @@ namespace ProviderImplementation.ProvidedTypes.AssemblyReader
     type ILGlobals =
         { typ_Object: ILType
           typ_String: ILType
+          typ_Void: ILType
           typ_Type: ILType
           typ_TypedReference: ILType option
           typ_SByte: ILType
@@ -4537,6 +4570,7 @@ namespace ProviderImplementation.ProvidedTypes.AssemblyReader
               let mkILTyspec nsp nm =  mkILNonGenericTySpec(ILTypeRef(ILTypeRefScope.Top(systemRuntimeScopeRef),USome nsp,nm))
               { typ_Object = ILType.Boxed (mkILTyspec "System" "Object")
                 typ_String = ILType.Boxed (mkILTyspec "System" "String")
+                typ_Void = ILType.Value (mkILTyspec "System" "Void")
                 typ_Type = ILType.Boxed (mkILTyspec "System" "Type")
                 typ_Int64 = ILType.Value (mkILTyspec "System" "Int64")
                 typ_UInt64 = ILType.Value (mkILTyspec "System" "UInt64")
@@ -7465,7 +7499,17 @@ namespace ProviderImplementation.ProvidedTypes
                 override __.Attributes = inp.Attributes
                 override __.GetParameters() = inp.Parameters |> Array.map (txILParameter (gps, gps2))
                 override __.CallingConvention = if inp.IsStatic then CallingConventions.Standard else CallingConventions.HasThis ||| CallingConventions.Standard
-                override __.ReturnType = inp.Return.Type |> txILType (gps, gps2)
+
+                override __.ReturnType = 
+                    let returnType = inp.Return.Type |> txILType (gps, gps2)
+                    match returnType.Namespace, returnType.Name with 
+                    | "System", "Void"->  
+                        if ImportProvidedMethodBaseAsILMethodRef_OnStack_HACK() then 
+                            typeof<Void>
+                        else 
+                            returnType
+                    | t -> returnType
+
                 override __.GetCustomAttributesData() = inp.CustomAttrs |> txCustomAttributesData
                 override __.GetGenericArguments() = gps2
                 override __.IsGenericMethod = (gps2.Length <> 0)
@@ -7629,7 +7673,7 @@ namespace ProviderImplementation.ProvidedTypes
         and txILType gps (ty: ILType) =
 
             match ty with
-            | ILType.Void -> typeof<System.Void>
+            | ILType.Void -> txILType gps ilGlobals.typ_Void
             | ILType.Value tspec
             | ILType.Boxed tspec ->
                 let tdefR = txILTypeRef tspec.TypeRef
@@ -7855,7 +7899,7 @@ namespace ProviderImplementation.ProvidedTypes
                 //     https://github.com/Microsoft/visualfsharp/blob/44fa027b308681a1b78a089e44fa1ab35ff77b41/src/fsharp/MethodCalls.fs#L842
                 // for the accepted types.
                 match inp.Namespace, inp.Name with 
-                | USome "System", "Void"->  typeof<Void>
+                //| USome "System", "Void"->  typeof<Void>
                 (*
                 | USome "System", "Boolean" -> typeof<bool>
                 | USome "System", "String"->  typeof<string>
@@ -8835,6 +8879,12 @@ namespace ProviderImplementation.ProvidedTypes
                 Expr.NewObjectUnchecked (convConstructorRefToTgt c, exprsR)
             | Coerce (expr, t) ->
                 Expr.Coerce (convExprToTgt expr, convTypeToTgt t)
+            | TypeTest (expr, t) ->
+                Expr.TypeTest (convExprToTgt expr, convTypeToTgt t)
+            | TryWith (body, filterVar, filterBody, catchVar, catchBody) ->
+                Expr.TryWith (convExprToTgt body, convVarToTgt filterVar, convExprToTgt filterBody, convVarToTgt catchVar, convExprToTgt catchBody)
+            | TryFinally (body, compensation) ->
+                Expr.TryFinally (convExprToTgt body, convExprToTgt compensation)
             | NewArray (t, exprs) ->
                 Expr.NewArrayUnchecked (convTypeToTgt t, List.map convExprToTgt exprs)
             | NewTuple (exprs) ->
@@ -13260,8 +13310,9 @@ namespace ProviderImplementation.ProvidedTypes
         | FilterCatch of ILCodeLabel * (ILCodeLabel * ILCodeLabel)
         | TypeCatch of ILCodeLabel * ILType
 
-    type ILExceptionBlockBuilder(i: ILCodeLabel) =
+    type ILExceptionBlockBuilder(i: ILCodeLabel, leave: ILCodeLabel) =
         member __.StartIndex = i
+        member __.Leave = leave
         member val EndIndex : int = 0 with get, set
         member val Clause : ILExceptionClauseBuilder option = None with get, set
 
@@ -13291,10 +13342,12 @@ namespace ProviderImplementation.ProvidedTypes
             ILLocalBuilder(idx)
 
         member ilg.BeginExceptionBlock() =
-            exceptionBlocks.Push(ILExceptionBlockBuilder(ilg.DefineLabelHere()))
+            exceptionBlocks.Push(ILExceptionBlockBuilder(ilg.DefineLabelHere(), ilg.DefineLabel()))
 
         member ilg.EndGuardedBlock() =
-            exceptionBlocks.Peek().EndIndex <- ilg.DefineLabelHere()
+            let block = exceptionBlocks.Peek()
+            ilg.Emit(I_leave block.Leave)
+            block.EndIndex <- ilg.DefineLabelHere()
 
         member ilg.BeginCatchBlock(typ: ILType) =
             exceptionBlocks.Peek().Clause <- Some <|
@@ -13314,7 +13367,17 @@ namespace ProviderImplementation.ProvidedTypes
 
         member ilg.EndExceptionBlock() =
             let exnBlock = exceptionBlocks.Pop()
+            match exnBlock.Clause.Value with
+            | ILExceptionClauseBuilder.Finally(start) ->
+               ilg.Emit(I_endfinally)
+            | ILExceptionClauseBuilder.Fault(start) ->
+               ilg.Emit(I_endfinally)
+            | ILExceptionClauseBuilder.FilterCatch _ -> 
+               ilg.Emit(I_leave exnBlock.Leave)
+            | ILExceptionClauseBuilder.TypeCatch _ -> 
+               ilg.Emit(I_leave exnBlock.Leave)
             let endIndex = ilg.DefineLabelHere()
+            ilg.MarkLabel(exnBlock.Leave)
             let clause = 
                 match exnBlock.Clause.Value with
                 | ILExceptionClauseBuilder.Finally(start) ->