Merge commit '2c3ff6d1' into feature/nullness

src/Compiler/AbstractIL/ilwritepdb.fs

@@ -1037,6 +1037,6 @@ let rec pushShadowedLocals (stackGuard: StackGuard) (localsToPush: PdbLocalVar[]
 //     adding the text " (shadowed)" to the names of those with name conflicts.
 let unshadowScopes rootScope =
     // Avoid stack overflow when writing linearly nested scopes
-    let stackGuard = StackGuard(100)
+    let stackGuard = StackGuard(100, "ILPdbWriter.unshadowScopes")
     let result, _ = pushShadowedLocals stackGuard [||] rootScope
     result

src/Compiler/Checking/CheckBasics.fs

@@ -341,7 +341,7 @@ type TcFileState =
         { g = g
           amap = amap
           recUses = ValMultiMap<_>.Empty
-          stackGuard = StackGuard(TcStackGuardDepth)
+          stackGuard = StackGuard(TcStackGuardDepth, "TcFileState")
           createsGeneratedProvidedTypes = false
           thisCcu = thisCcu
           isScript = isScript

src/Compiler/Checking/CheckIncrementalClasses.fs

@@ -527,7 +527,7 @@ type IncrClassReprInfo =
                         PostTransform = (fun _ -> None)
                         PreInterceptBinding = None
                         RewriteQuotations = true
-                        StackGuard = StackGuard(TcClassRewriteStackGuardDepth) } expr 
+                        StackGuard = StackGuard(TcClassRewriteStackGuardDepth, "FixupIncrClassExprPhase2C") } expr 
 
 type IncrClassConstructionBindingsPhase2C =
     | Phase2CBindings of IncrClassBindingGroup list

src/Compiler/Checking/FindUnsolved.fs

@@ -285,7 +285,7 @@ let UnsolvedTyparsOfModuleDef g amap denv mdef extraAttribs =
           amap=amap 
           denv=denv 
           unsolved = [] 
-          stackGuard = StackGuard(FindUnsolvedStackGuardDepth) }
+          stackGuard = StackGuard(FindUnsolvedStackGuardDepth, "UnsolvedTyparsOfModuleDef") }
     accModuleOrNamespaceDef cenv NoEnv mdef
     accAttribs cenv NoEnv extraAttribs
     List.rev cenv.unsolved

src/Compiler/Checking/PostInferenceChecks.fs

@@ -2637,7 +2637,7 @@ let CheckImplFile (g, amap, reportErrors, infoReader, internalsVisibleToPaths, v
           reportErrors = reportErrors 
           boundVals = Dictionary<_, _>(100, HashIdentity.Structural) 
           limitVals = Dictionary<_, _>(100, HashIdentity.Structural) 
-          stackGuard = StackGuard(PostInferenceChecksStackGuardDepth)
+          stackGuard = StackGuard(PostInferenceChecksStackGuardDepth, "CheckImplFile")
           potentialUnboundUsesOfVals = Map.empty 
           anonRecdTypes = StampMap.Empty
           usesQuotations = false 

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"
@@ -11863,7 +11869,7 @@ type IlxAssemblyGenerator(amap: ImportMap, tcGlobals: TcGlobals, tcVal: Constrai
             intraAssemblyInfo = intraAssemblyInfo
             optionsOpt = None
             optimizeDuringCodeGen = (fun _flag expr -> expr)
-            stackGuard = StackGuard(IlxGenStackGuardDepth)
+            stackGuard = StackGuard(IlxGenStackGuardDepth, "IlxAssemblyGenerator")
         }
 
     /// Register a set of referenced assemblies with the ILX code generator

src/Compiler/Facilities/DiagnosticsLogger.fs

@@ -813,7 +813,7 @@ let internal languageFeatureNotSupportedInLibraryError (langFeature: LanguageFea
     error (Error(FSComp.SR.chkFeatureNotSupportedInLibrary (featureStr, suggestedVersionStr), m))
 
 /// Guard against depth of expression nesting, by moving to new stack when a maximum depth is reached
-type StackGuard(maxDepth: int) =
+type StackGuard(maxDepth: int, name: string) =
 
     let mutable depth = 1
 
@@ -828,7 +828,7 @@ type StackGuard(maxDepth: int) =
 
                 async {
                     do! Async.SwitchToNewThread()
-                    Thread.CurrentThread.Name <- "F# Extra Compilation Thread"
+                    Thread.CurrentThread.Name <- $"F# Extra Compilation Thread for {name} (depth {depth})"
                     use _scope = new CompilationGlobalsScope(diagnosticsLogger, buildPhase)
                     return f ()
                 }

src/Compiler/Facilities/DiagnosticsLogger.fsi

@@ -389,7 +389,7 @@ val tryLanguageFeatureErrorOption:
 val languageFeatureNotSupportedInLibraryError: langFeature: LanguageFeature -> m: range -> 'T
 
 type StackGuard =
-    new: maxDepth: int -> StackGuard
+    new: maxDepth: int * name: string -> StackGuard
 
     /// Execute the new function, on a new thread if necessary
     member Guard: f: (unit -> 'T) -> 'T

src/Compiler/Optimize/DetupleArgs.fs

@@ -864,7 +864,7 @@ let passImplFile penv assembly =
           PreInterceptBinding = None
           PostTransform = postTransformExpr penv
           RewriteQuotations = false
-          StackGuard = StackGuard(DetupleRewriteStackGuardDepth) } 
+          StackGuard = StackGuard(DetupleRewriteStackGuardDepth, "RewriteImplFile") } 
     assembly |> RewriteImplFile rwenv
 
 //-------------------------------------------------------------------------

src/Compiler/Optimize/InnerLambdasToTopLevelFuncs.fs

@@ -1366,7 +1366,7 @@ let MakeTopLevelRepresentationDecisions ccu g expr =
                 recShortCallS = recShortCallS
                 envPackM = envPackM
                 fHatM = fHatM
-                stackGuard = StackGuard(InnerLambdasToTopLevelFunctionsStackGuardDepth) }
+                stackGuard = StackGuard(InnerLambdasToTopLevelFunctionsStackGuardDepth, "InnerLambdasToTopLevelFunctionsStackGuardDepth") }
           let z = Pass4_RewriteAssembly.rewriteState0
           Pass4_RewriteAssembly.TransImplFile penv z expr
 

src/Compiler/Optimize/LowerCalls.fs

@@ -49,5 +49,5 @@ let LowerImplFile g assembly =
           PreInterceptBinding=None
           PostTransform= (fun _ -> None)
           RewriteQuotations=false
-          StackGuard = StackGuard(LowerCallsRewriteStackGuardDepth) }
+          StackGuard = StackGuard(LowerCallsRewriteStackGuardDepth, "LowerCallsRewriteStackGuardDepth") }
     assembly |> RewriteImplFile rwenv

src/Compiler/Optimize/LowerLocalMutables.fs

@@ -196,6 +196,6 @@ let TransformImplFile g amap implFile =
                 PreInterceptBinding = Some(TransformBinding g heapValMap)
                 PostTransform = (fun _ -> None)
                 RewriteQuotations = true
-                StackGuard = StackGuard(AutoboxRewriteStackGuardDepth) } 
+                StackGuard = StackGuard(AutoboxRewriteStackGuardDepth, "AutoboxRewriteStackGuardDepth") } 
 
 

src/Compiler/Optimize/LowerStateMachines.fs

@@ -358,7 +358,7 @@ type LowerStateMachine(g: TcGlobals) =
           PostTransform = (fun _ -> None)
           PreInterceptBinding = None
           RewriteQuotations=true 
-          StackGuard = StackGuard(LowerStateMachineStackGuardDepth) }
+          StackGuard = StackGuard(LowerStateMachineStackGuardDepth, "LowerStateMachineStackGuardDepth") }
 
     let ConvertStateMachineLeafExpression (env: env) expr = 
         if sm_verbose then printfn "ConvertStateMachineLeafExpression for %A..." expr

src/Compiler/Optimize/Optimizer.fs

@@ -4325,7 +4325,7 @@ let OptimizeImplFile (settings, ccu, tcGlobals, tcVal, importMap, optEnv, isIncr
           localInternalVals=Dictionary<Stamp, ValInfo>(10000)
           emitTailcalls=emitTailcalls
           casApplied=Dictionary<Stamp, bool>() 
-          stackGuard = StackGuard(OptimizerStackGuardDepth) 
+          stackGuard = StackGuard(OptimizerStackGuardDepth, "OptimizerStackGuardDepth") 
         }
 
     let env, _, _, _ as results = OptimizeImplFileInternal cenv optEnv isIncrementalFragment fsiMultiAssemblyEmit hidden mimpls  

src/Compiler/TypedTree/TypedTreeOps.fs

@@ -2159,7 +2159,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
@@ -2170,6 +2173,7 @@ let CollectAllNoCaching =
       includeUnionCases = true
       includeTypars = true
       includeLocals = true
+      templateReplacement = None
       stackGuard = None}
 
 let CollectTyparsNoCaching = 
@@ -2181,6 +2185,7 @@ let CollectTyparsNoCaching =
       includeRecdFields = false
       includeUnionCases = false
       includeLocals = false
+      templateReplacement = None
       stackGuard = None }
 
 let CollectLocalsNoCaching = 
@@ -2192,6 +2197,7 @@ let CollectLocalsNoCaching =
       includeRecdFields = false 
       includeUnionCases = false
       includeLocals = true
+      templateReplacement = None
       stackGuard = None }
 
 let CollectTyparsAndLocalsNoCaching = 
@@ -2203,6 +2209,7 @@ let CollectTyparsAndLocalsNoCaching =
       includeUnionCases = false
       includeTypars = true
       includeLocals = true
+      templateReplacement = None
       stackGuard = None }
 
 let CollectAll =
@@ -2214,6 +2221,7 @@ let CollectAll =
       includeUnionCases = true
       includeTypars = true
       includeLocals = true
+      templateReplacement = None
       stackGuard = None }
     
 let CollectTyparsAndLocalsImpl stackGuardOpt = // CollectAll
@@ -2225,6 +2233,7 @@ let CollectTyparsAndLocalsImpl stackGuardOpt = // CollectAll
       includeLocalTyconReprs = false
       includeRecdFields = false
       includeUnionCases = false
+      templateReplacement = None
       stackGuard = stackGuardOpt }
 
   
@@ -2235,7 +2244,7 @@ let CollectTypars = CollectTyparsAndLocals
 let CollectLocals = CollectTyparsAndLocals
 
 let CollectTyparsAndLocalsWithStackGuard() =
-    let stackGuard = StackGuard(AccFreeVarsStackGuardDepth)
+    let stackGuard = StackGuard(AccFreeVarsStackGuardDepth, "AccFreeVarsStackGuardDepth")
     CollectTyparsAndLocalsImpl (Some stackGuard)
 
 let CollectLocalsWithStackGuard() = CollectTyparsAndLocalsWithStackGuard()
@@ -2245,12 +2254,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>, B: I<A> 
     // 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
@@ -6296,31 +6311,31 @@ and remapImplFile ctxt compgen tmenv implFile =
 // Entry points
 
 let remapAttrib g tmenv attrib = 
-    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth) }
+    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") }
     remapAttribImpl ctxt tmenv attrib
 
 let remapExpr g (compgen: ValCopyFlag) (tmenv: Remap) expr =
-    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth) }
+    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") }
     remapExprImpl ctxt compgen tmenv expr
 
 let remapPossibleForallTy g tmenv ty =
-    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth) }
+    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") }
     remapPossibleForallTyImpl ctxt tmenv ty
 
 let copyModuleOrNamespaceType g compgen mtyp =
-    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth) }
+    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") }
     copyAndRemapAndBindModTy ctxt compgen Remap.Empty mtyp |> fst
 
 let copyExpr g compgen e =
-    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth) }
+    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") }
     remapExprImpl ctxt compgen Remap.Empty e    
 
 let copyImplFile g compgen e =
-    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth) }
+    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") }
     remapImplFile ctxt compgen Remap.Empty e |> fst
 
 let instExpr g tpinst e =
-    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth) }
+    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") }
     remapExprImpl ctxt CloneAll (mkInstRemap tpinst) e
 
 //--------------------------------------------------------------------------
@@ -7210,7 +7225,7 @@ let ExprFolder0 =
 type ExprFolders<'State> (folders: ExprFolder<'State>) =
     let mutable exprFClosure = Unchecked.defaultof<'State -> Expr -> 'State> // prevent reallocation of closure
     let mutable exprNoInterceptFClosure = Unchecked.defaultof<'State -> Expr -> 'State> // prevent reallocation of closure
-    let stackGuard = StackGuard(FoldExprStackGuardDepth)
+    let stackGuard = StackGuard(FoldExprStackGuardDepth, "FoldExprStackGuardDepth")
 
     let rec exprsF z xs = 
         List.fold exprFClosure z xs
@@ -9574,7 +9589,7 @@ and remapValToNonLocal ctxt tmenv inp =
     inp |> Construct.NewModifiedVal (remapValData ctxt tmenv)
 
 let ApplyExportRemappingToEntity g tmenv x =
-    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth) }
+    let ctxt = { g = g; stackGuard = StackGuard(RemapExprStackGuardDepth, "RemapExprStackGuardDepth") }
     remapTyconToNonLocal ctxt tmenv x
 
 (* Which constraints actually get compiled to .NET constraints? *)

src/Compiler/TypedTree/TypedTreeOps.fsi

@@ -798,7 +798,12 @@ val emptyFreeLocals: FreeLocals
 
 val unionFreeLocals: FreeLocals -> FreeLocals -> FreeLocals
 
-type FreeVarOptions
+/// Represents the options to activate when collecting free variables
+[<Sealed>]
+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
 

tests/FSharp.Core.UnitTests/FSharp.Core/Microsoft.FSharp.Control/Tasks.fs

@@ -1259,6 +1259,75 @@ type BasicsNotInParallel() =
                     require ran "never ran")
             taskOuter.Wait()
                  
+    [<Fact; >]
+    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<MyGenericType<'Key,'Value>,'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<string,int>
+
+    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 {