From 2c3ff6d126964477c7dfdd8b6f86992b96294bc1 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 9 Sep 2022 19:50:13 +0100 Subject: [PATCH] fix 12761 (#13865) --- src/Compiler/CodeGen/IlxGen.fs | 8 ++- src/Compiler/TypedTree/TypedTreeOps.fs | 19 ++++- src/Compiler/TypedTree/TypedTreeOps.fsi | 7 +- .../Microsoft.FSharp.Control/Tasks.fs | 69 +++++++++++++++++++ 4 files changed, 99 insertions(+), 4 deletions(-) diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index e83d70fd7..b886bab1a 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -6804,7 +6804,13 @@ and GetIlxClosureFreeVars cenv m (thisVars: ValRef list) boxity eenvouter takenN NestedTypeRefForCompLoc eenvouter.cloc cloName // Collect the free variables of the closure - let cloFreeVarResults = freeInExpr (CollectTyparsAndLocalsWithStackGuard()) expr + let cloFreeVarResults = + let opts = CollectTyparsAndLocalsWithStackGuard() + let opts = + match eenvouter.tyenv.TemplateReplacement with + | None -> opts + | Some (tcref, _, typars, _) -> opts.WithTemplateReplacement(tyconRefEq g tcref, typars) + freeInExpr opts expr // Partition the free variables when some can be accessed from places besides the immediate environment // Also filter out the current value being bound, if any, as it is available from the "this" diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index b27b27316..7842afdc1 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -2133,7 +2133,10 @@ type FreeVarOptions = includeRecdFields: bool includeUnionCases: bool includeLocals: bool + templateReplacement: ((TyconRef -> bool) * Typars) option stackGuard: StackGuard option } + + member this.WithTemplateReplacement(f, typars) = { this with templateReplacement = Some (f, typars) } let CollectAllNoCaching = { canCache = false @@ -2144,6 +2147,7 @@ let CollectAllNoCaching = includeUnionCases = true includeTypars = true includeLocals = true + templateReplacement = None stackGuard = None} let CollectTyparsNoCaching = @@ -2155,6 +2159,7 @@ let CollectTyparsNoCaching = includeRecdFields = false includeUnionCases = false includeLocals = false + templateReplacement = None stackGuard = None } let CollectLocalsNoCaching = @@ -2166,6 +2171,7 @@ let CollectLocalsNoCaching = includeRecdFields = false includeUnionCases = false includeLocals = true + templateReplacement = None stackGuard = None } let CollectTyparsAndLocalsNoCaching = @@ -2177,6 +2183,7 @@ let CollectTyparsAndLocalsNoCaching = includeUnionCases = false includeTypars = true includeLocals = true + templateReplacement = None stackGuard = None } let CollectAll = @@ -2188,6 +2195,7 @@ let CollectAll = includeUnionCases = true includeTypars = true includeLocals = true + templateReplacement = None stackGuard = None } let CollectTyparsAndLocalsImpl stackGuardOpt = // CollectAll @@ -2199,6 +2207,7 @@ let CollectTyparsAndLocalsImpl stackGuardOpt = // CollectAll includeLocalTyconReprs = false includeRecdFields = false includeUnionCases = false + templateReplacement = None stackGuard = stackGuardOpt } @@ -2219,12 +2228,18 @@ let accFreeLocalTycon opts x acc = if Zset.contains x acc.FreeTycons then acc else { acc with FreeTycons = Zset.add x acc.FreeTycons } -let accFreeTycon opts (tcref: TyconRef) acc = +let rec accFreeTycon opts (tcref: TyconRef) acc = + let acc = + match opts.templateReplacement with + | Some (isTemplateTyconRef, cloFreeTyvars) when isTemplateTyconRef tcref -> + let cloInst = List.map mkTyparTy cloFreeTyvars + accFreeInTypes opts cloInst acc + | _ -> acc if not opts.includeLocalTycons then acc elif tcref.IsLocalRef then accFreeLocalTycon opts tcref.ResolvedTarget acc else acc -let rec boundTypars opts tps acc = +and boundTypars opts tps acc = // Bound type vars form a recursively-referential set due to constraints, e.g. A: I, B: I // So collect up free vars in all constraints first, then bind all variables let acc = List.foldBack (fun (tp: Typar) acc -> accFreeInTyparConstraints opts tp.Constraints acc) tps acc diff --git a/src/Compiler/TypedTree/TypedTreeOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.fsi index b674cd765..2c6ce5274 100755 --- a/src/Compiler/TypedTree/TypedTreeOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.fsi @@ -796,7 +796,12 @@ val emptyFreeLocals: FreeLocals val unionFreeLocals: FreeLocals -> FreeLocals -> FreeLocals -type FreeVarOptions +/// Represents the options to activate when collecting free variables +[] +type FreeVarOptions = + /// During backend code generation of state machines, register a template replacement for struct types. + /// This may introduce new free variables related to the instantiation of the struct type. + member WithTemplateReplacement: (TyconRef -> bool) * Typars -> FreeVarOptions val CollectLocalsNoCaching: FreeVarOptions diff --git a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs index bf6c8cc1e..4af1df56d 100644 --- a/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs +++ b/tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs @@ -1259,6 +1259,75 @@ type BasicsNotInParallel() = require ran "never ran") taskOuter.Wait() + [] + member _.testGenericBackgroundTasks() = + printfn "Running testBackgroundTask..." + for i in 1 .. 5 do + let mutable ran = false + let mutable posted = false + let oldSyncContext = SynchronizationContext.Current + let syncContext = { new SynchronizationContext() with member _.Post(d,state) = posted <- true; d.Invoke(state) } + try + SynchronizationContext.SetSynchronizationContext syncContext + let f (result: 'T ref) (x: 'T) = + backgroundTask { + require (System.Threading.Thread.CurrentThread.IsThreadPoolThread) "expect to be on background thread" + ran <- true + result.Value <- x + } + let t = f (ref "") "hello" + t.Wait() + let t2 = f (ref 1) 1 + t2.Wait() + require ran "never ran" + require (not posted) "did not expect post to sync context" + finally + SynchronizationContext.SetSynchronizationContext oldSyncContext + + +/// https://github.com/dotnet/fsharp/issues/12761 +module Test12761A = + + type Dto = { + DtoValue : string + Key : string + } + + type MyGenericType<'Key,'Value> = { + Value : 'Value + Key : 'Key + } + + type ProblematicType<'Key, 'Value, 'Dto, 'E>( fromDto : 'Dto -> Result,'E> ) = + let myTask = + backgroundTask { + let dto = """{"DtoValue":"1","Key":"key1"}""" |> box |> unbox<'Dto> + return fromDto dto |> printfn "%A" + } + member __.ContainsKey = fun (key: 'Key) -> true + + + type MyType = MyGenericType + + module MyType = + let fromDto (dto: Dto) = + try + { + Value = int dto.DtoValue + Key = dto.Key + } + |> Ok + with | e -> Error e + + +/// https://github.com/dotnet/fsharp/issues/12761 +module Test12761B = + let TestFunction<'Dto>() = + backgroundTask { + let dto = Unchecked.defaultof<'Dto> + System.Console.WriteLine(dto) + } + type Issue12184() = member this.TaskMethod() = task { -- GitLab