diff --git a/src/Compiler/Checking/Expressions/CheckExpressions.fs b/src/Compiler/Checking/Expressions/CheckExpressions.fs index 65e6de7f094..7b4e2290168 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressions.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressions.fs @@ -7308,6 +7308,15 @@ and TcObjectExpr (cenv: cenv) env tpenv (objTy, realObjTy, argopt, binds, extraI DispatchSlotChecking.CheckDispatchSlotsAreImplemented (env.DisplayEnv, cenv.infoReader, m, env.NameEnv, cenv.tcSink, isOverallTyAbstract, true, implTy, dispatchSlots, availPriorOverrides, overrideSpecs) |> ignore // 3. create the specs of overrides + + // Fix for struct object expressions: extract captured struct members to avoid byref fields + // This transformation is only applied when ALL of the following conditions are met: + // 1. The object expression derives from a base class (not just implementing an interface) + // 2. The object expression captures instance members from an enclosing struct + // See CheckExpressionsOps.TryExtractStructMembersFromObjectExpr for implementation details + let capturedStructMembers, methodBodyRemap = + CheckExpressionsOps.TryExtractStructMembersFromObjectExpr isInterfaceTy overridesAndVirts mWholeExpr + let allTypeImpls = overridesAndVirts |> List.map (fun (m, implTy, _, dispatchSlotsKeyed, _, overrides) -> let overrides' = @@ -7331,7 +7340,14 @@ and TcObjectExpr (cenv: cenv) env tpenv (objTy, realObjTy, argopt, binds, extraI | Some x -> x | None -> error(Error(FSComp.SR.tcAtLeastOneOverrideIsInvalid(), mObjTy)) - yield TObjExprMethod(overridden.GetSlotSig(cenv.amap, m), bindingAttribs, mtps, [thisVal] :: methodVars, bindingBody, id.idRange) ] + // Remap method body to use local copies of struct members + let bindingBody' = + if methodBodyRemap.valRemap.IsEmpty then + bindingBody + else + remapExpr g CloneAll methodBodyRemap bindingBody + + yield TObjExprMethod(overridden.GetSlotSig(cenv.amap, m), bindingAttribs, mtps, [thisVal] :: methodVars, bindingBody', id.idRange) ] (implTy, overrides')) let objtyR, overrides' = allTypeImpls.Head @@ -7345,6 +7361,14 @@ and TcObjectExpr (cenv: cenv) env tpenv (objTy, realObjTy, argopt, binds, extraI // 4. Build the implementation let expr = mkObjExpr(objtyR, baseValOpt, ctorCall, overrides', extraImpls, mWholeExpr) let expr = mkCoerceIfNeeded g realObjTy objtyR expr + + // Wrap with bindings for captured struct members + let expr = + if capturedStructMembers.IsEmpty then + expr + else + List.foldBack (fun (v, e) body -> mkInvisibleLet mWholeExpr v e body) capturedStructMembers expr + expr, tpenv //------------------------------------------------------------------------- diff --git a/src/Compiler/Checking/Expressions/CheckExpressionsOps.fs b/src/Compiler/Checking/Expressions/CheckExpressionsOps.fs index 6c12485c4ed..0f149996df6 100644 --- a/src/Compiler/Checking/Expressions/CheckExpressionsOps.fs +++ b/src/Compiler/Checking/Expressions/CheckExpressionsOps.fs @@ -4,6 +4,7 @@ module internal FSharp.Compiler.CheckExpressionsOps open Internal.Utilities.Library open Internal.Utilities.Library.Extras +open Internal.Utilities.Collections open FSharp.Compiler.CheckBasics open FSharp.Compiler.ConstraintSolver open FSharp.Compiler.DiagnosticsLogger @@ -389,3 +390,76 @@ let inline mkOptionalParamTyBasedOnAttribute (g: TcGlobals.TcGlobals) tyarg attr mkValueOptionTy g tyarg else mkOptionTy g tyarg + +/// Extract captured struct instance members from object expressions to avoid illegal byref fields in closures. +/// When an object expression inside a struct instance member method captures struct fields, the generated +/// closure would contain a byref field which violates CLI rules. This function extracts those struct +/// member values into local variables and rewrites the object expression methods to use the locals instead. +/// +/// Returns: (capturedMemberBindings, methodBodyRemap) where: +/// - capturedMemberBindings: list of (localVar, valueExpr) pairs to prepend before the object expression +/// - methodBodyRemap: Remap to apply to object expression method bodies to use the captured locals +let TryExtractStructMembersFromObjectExpr + (isInterfaceTy: bool) + overridesAndVirts + (mWholeExpr: range) : (Val * Expr) list * Remap = + + // Early guard: Only apply for object expressions deriving from base classes, not pure interface implementations + // Interface implementations don't pass struct members to base constructors, so they don't have the byref issue + if isInterfaceTy then + [], Remap.Empty + else + // Collect all method bodies from the object expression overrides + let allMethodBodies = + overridesAndVirts + |> List.collect (fun (_, _, _, _, _, overrides) -> + overrides |> List.map (fun (_, (_, _, _, _, bindingBody)) -> bindingBody)) + + // Early exit if no methods to analyze + if allMethodBodies.IsEmpty then + [], Remap.Empty + else + // Find all free variables in the method bodies + let freeVars = + allMethodBodies + |> List.fold (fun acc body -> + let bodyFreeVars = freeInExpr CollectTyparsAndLocals body + unionFreeVars acc bodyFreeVars) emptyFreeVars + + // Filter to only instance members of struct types + // This identifies the problematic case: when an object expression inside a struct + // captures instance members, which would require capturing 'this' as a byref + let structMembers = + freeVars.FreeLocals + |> Zset.elements + |> List.filter (fun (v: Val) -> + // Must be an instance member (not static) + v.IsInstanceMember && + // Must have a declaring entity + v.HasDeclaringEntity && + // The declaring entity must be a struct type + isStructTyconRef v.DeclaringEntity) + + // Early exit if no struct members captured + if structMembers.IsEmpty then + [], Remap.Empty + else + // Create local variables for each captured struct member + let bindings = + structMembers + |> List.map (fun (memberVal: Val) -> + // Create a new local to hold the member's value + let localVal, _ = mkCompGenLocal mWholeExpr memberVal.DisplayName memberVal.Type + // The value expression is just a reference to the member + let valueExpr = exprForVal mWholeExpr memberVal + (memberVal, localVal, valueExpr)) + + // Build a remap from original member vals to new local vals + let remap = + bindings + |> List.fold (fun (remap: Remap) (origVal, localVal, _) -> + { remap with valRemap = remap.valRemap.Add origVal (mkLocalValRef localVal) }) Remap.Empty + + // Return the bindings to be added before the object expression + let bindPairs = bindings |> List.map (fun (_, localVal, valueExpr) -> (localVal, valueExpr)) + bindPairs, remap diff --git a/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ObjectExpressions/StructObjectExpression.fs b/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ObjectExpressions/StructObjectExpression.fs new file mode 100644 index 00000000000..60c5a4d15bf --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/Conformance/Expressions/ObjectExpressions/StructObjectExpression.fs @@ -0,0 +1,62 @@ +namespace FSharp.Compiler.ComponentTests.Conformance.Expressions + +open Xunit +open FSharp.Test.Compiler + +module StructObjectExpression = + + [] + let ``Object expression in struct should not generate byref field - simple case`` () = + FSharp """ +type Class(test : obj) = class end + +[] +type Struct(test : obj) = + member _.Test() = { + new Class(test) with + member _.ToString() = "" + } + +let s = Struct(42) +let obj = s.Test() + """ + |> compile + |> shouldSucceed + + [] + let ``Object expression in struct with multiple fields`` () = + FSharp """ +type Base(x: int, y: string) = class end + +[] +type MyStruct(x: int, y: string) = + member _.CreateObj() = { + new Base(x, y) with + member _.ToString() = y + string x + } + +let s = MyStruct(42, "test") +let obj = s.CreateObj() + """ + |> compile + |> shouldSucceed + + [] + let ``Object expression in struct referencing field in override method`` () = + FSharp """ +type IFoo = + abstract member DoSomething : unit -> int + +[] +type MyStruct(value: int) = + member _.CreateFoo() = { + new IFoo with + member _.DoSomething() = value * 2 + } + +let s = MyStruct(21) +let foo = s.CreateFoo() +let result = foo.DoSomething() + """ + |> compile + |> shouldSucceed diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 8f5ace7aade..b5359280c1f 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -87,6 +87,7 @@ +