Compiled ToStrings under -reflectionfree for DUs and Records

docs/release-notes/.FSharp.Compiler.Service/11.0.100.md

@@ -118,6 +118,7 @@
 * Debug: rework for expressions stepping ([PR #19894](https://github.com/dotnet/fsharp/pull/19894))
 * Debug: rework conditional erasure, fix stepping over literals ([PR #19897](https://github.com/dotnet/fsharp/pull/19897))
 * Debug: fix if and match condition sequence points ([PR #19932](https://github.com/dotnet/fsharp/pull/19932))
+* Under `--reflectionfree`, discriminated unions and records now get a generated `ToString` (rendering each field like `Option` does) instead of falling back to the namespace-qualified type name. ([PR #19976](https://github.com/dotnet/fsharp/pull/19976))
 * Checker: recover on checking language version ([PR ##19970](https://github.com/dotnet/fsharp/pull/19970))
 * Implied argument names for function-to-delegate coercions now fall back to the delegate's `Invoke` parameter names when the function has no recoverable names (e.g. a partial application like `System.Func<int, int>((+) 1)`), instead of synthetic `delegateArg0`, `delegateArg1`, … names. ([PR #20001](https://github.com/dotnet/fsharp/pull/20001))
 

src/Compiler/Checking/AugmentWithHashCompare.fs

@@ -81,6 +81,9 @@ let mkGetHashCodeSlotSig (g: TcGlobals) =
 let mkEqualsSlotSig (g: TcGlobals) =
     TSlotSig("Equals", g.obj_ty_noNulls, [], [], [ [ TSlotParam(Some("obj"), g.obj_ty_withNulls, false, false, false, []) ] ], Some g.bool_ty)
 
+let mkToStringSlotSig (g: TcGlobals) =
+    TSlotSig("ToString", g.obj_ty_noNulls, [], [], [ [] ], Some g.string_ty)
+
 //-------------------------------------------------------------------------
 // Helpers associated with code-generation of comparison/hash augmentations
 //-------------------------------------------------------------------------
@@ -112,6 +115,9 @@ let mkEqualsWithComparerTyExact g ty =
 let mkHashTy g ty =
     mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g.int_ty)
 
+let mkToStringTy (g: TcGlobals, ty: TType) =
+    mkFunTy g (mkThisTy g ty) (mkFunTy g g.unit_ty g.string_ty)
+
 let mkHashWithComparerTy g ty =
     mkFunTy g (mkThisTy g ty) (mkFunTy g g.IEqualityComparer_ty g.int_ty)
 
@@ -1697,3 +1703,141 @@ let MakeBindingsForUnionAugmentation g (tycon: Tycon) (vals: ValRef list) =
         let isdata = mkUnionCaseTest g (thise, ucr, tinst, m)
         let expr = mkLambdas g m tps [ thisv; unitv ] (isdata, g.bool_ty)
         mkCompGenBind v.Deref expr)
+
+//-------------------------------------------------------------------------
+// Build reflection-free ToString functions for union and record types.
+//
+// Under --reflectionfree the reflective 'sprintf "%+A"' ToString is unavailable, so we build a structural
+// one here (during type augmentation, so the 'string' operator calls flow through the optimizer and get
+// specialised - e.g. an int field renders via a direct, allocation-free ToString rather than a boxed call).
+//-------------------------------------------------------------------------
+
+// Render one field value as a string the way option/list do (LanguagePrimitives.anyToStringShowingNull):
+// a null reference renders as "null", everything else via the 'string' operator. A value-type field can
+// never be null, so it skips the box+null-guard and renders directly.
+let mkFieldToString (g: TcGlobals, m: Text.range, fe: Expr) =
+    let fieldTy = tyOfExpr g fe
+
+    if isStructTy g fieldTy then
+        mkCallStringOperator g m fieldTy fe
+    else
+        let v, ve = mkCompGenLocal m "field" fieldTy
+        mkCompGenLet m v fe (mkNonNullCond g m g.string_ty (mkCallBox g m fieldTy ve) (mkCallStringOperator g m fieldTy ve) (mkString g m "null"))
+
+// A record's ToString as a single line "{ F1 = v1; F2 = v2 }" (no line breaks, unlike "%+A").
+// openBrace/closeBrace are "{ "/" }" for records and "{| "/" |}" for anonymous records.
+let mkRecdToString (g: TcGlobals, tcref: TyconRef, tycon: Tycon, openBrace: string, closeBrace: string) =
+    let m = tycon.Range
+    let tinst, ty = mkMinimalTy g tcref
+    let thisv, thise = mkThisVar g m ty
+
+    let fieldParts =
+        tcref.AllInstanceFieldsAsList
+        |> List.mapi (fun i fspec ->
+            let fref = tcref.MakeNestedRecdFieldRef fspec
+            let value = mkFieldToString (g, m, mkRecdFieldGetViaExprAddr (thise, fref, tinst, m))
+            let nameEq = mkString g m (fspec.DisplayName + " = ")
+            if i = 0 then [ nameEq; value ] else [ mkString g m "; "; nameEq; value ])
+        |> List.concat
+
+    let parts = mkString g m openBrace :: fieldParts @ [ mkString g m closeBrace ]
+    thisv, mkStringConcat (g, m, parts)
+
+// A union's ToString as a match over the cases building "CaseName(f0, f1, ...)" (or just "CaseName" for a
+// nullary case).
+let mkUnionToString (g: TcGlobals, tcref: TyconRef, tycon: Tycon) =
+    let m = tycon.Range
+    let tinst, ty = mkMinimalTy g tcref
+    let thisv, thise = mkThisVar g m ty
+    let mbuilder = MatchBuilder(DebugPointAtBinding.NoneAtInvisible, m)
+
+    let mkResult (ucase: UnionCase) =
+        let cref = tcref.MakeNestedUnionCaseRef ucase
+        let rfields = ucase.RecdFields
+
+        if isNil rfields then
+            mkString g m ucase.DisplayName
+        else
+            // provene is an expression proven to be of this case (the value itself for struct unions,
+            // otherwise a 'UnionCaseProof'), from which fields can be read.
+            let mkBody (provene: Expr) =
+                let fieldStrs =
+                    rfields
+                    |> List.mapi (fun j _ -> mkFieldToString (g, m, mkUnionCaseFieldGetProvenViaExprAddr (provene, cref, tinst, j, m)))
+
+                let sep = mkString g m ", "
+
+                let fieldsWithSeps =
+                    fieldStrs |> List.mapi (fun i fe -> if i = 0 then [ fe ] else [ sep; fe ]) |> List.concat
+
+                let parts = mkString g m (ucase.DisplayName + "(") :: fieldsWithSeps @ [ mkString g m ")" ]
+                mkStringConcat (g, m, parts)
+
+            if cref.Tycon.IsStructOrEnumTycon then
+                mkBody thise
+            else
+                let ucv, ucve = mkCompGenLocal m "thisCast" (mkProvenUnionCaseTy cref tinst)
+                mkCompGenLet m ucv (mkUnionCaseProof (thise, cref, tinst, m)) (mkBody ucve)
+
+    let cases =
+        tcref.UnionCasesAsList
+        |> List.map (fun ucase ->
+            let cref = tcref.MakeNestedUnionCaseRef ucase
+            mkCase (DecisionTreeTest.UnionCase(cref, tinst), mbuilder.AddResultTarget(mkResult ucase)))
+
+    let dtree = TDSwitch(thise, cases, None, m)
+    thisv, mbuilder.Close(dtree, m, g.string_ty)
+
+let TyconIsCandidateForAugmentationWithToString (g: TcGlobals, tycon: Tycon) =
+    g.useReflectionFreeCodeGen && (tycon.IsUnionTycon || tycon.IsRecordTycon)
+
+let MakeValsForToStringAugmentation (g: TcGlobals, tcref: TyconRef) =
+    let _, ty = mkMinimalTy g tcref
+    let vis = tcref.Accessibility
+    let tps = tcref.Typars
+    mkValSpec g tcref ty vis (Some(mkToStringSlotSig g)) "ToString" (tps +-> (mkToStringTy (g, ty))) unitArg false
+
+let MakeBindingsForToStringAugmentation (g: TcGlobals, tycon: Tycon, toStringVal: Val) =
+    let tcref = mkLocalTyconRef tycon
+    let m = tycon.Range
+    let tps = tycon.Typars
+
+    let thisv, body =
+        if tycon.IsUnionTycon then
+            mkUnionToString (g, tcref, tycon)
+        else
+            mkRecdToString (g, tcref, tycon, "{ ", " }")
+
+    let mightRecurse =
+        let isPrimitive (ty: TType) =
+            isIntegerTy g ty
+            || isFpTy g ty
+            || isDecimalTy g ty
+            || isStringTy g ty
+            || typeEquiv g g.char_ty ty
+            || isBoolTy g ty
+            || isUnitTy g ty
+            || isEnumTy g ty
+
+        let fieldTys =
+            if tycon.IsUnionTycon then
+                tycon.UnionCasesAsList |> List.collect (fun uc -> uc.RecdFields) |> List.map (fun rf -> rf.FormalType)
+            else
+                tycon.AllInstanceFieldsAsList |> List.map (fun rf -> rf.FormalType)
+
+        fieldTys |> List.exists (isPrimitive >> not)
+
+    // Guard deep recursion with a catchable exception, as C# records' PrintMembers do, when the runtime provides it.
+    let body =
+        if mightRecurse then
+            match g.TryFindSysILTypeRef "System.Runtime.CompilerServices.RuntimeHelpers" with
+            | Some tref ->
+                let mspec = mkILNonGenericStaticMethSpecInTy (mkILNonGenericBoxedTy tref, "EnsureSufficientExecutionStack", [], ILType.Void)
+                mkSequential m (mkAsmExpr ([ mkNormalCall mspec ], [], [], [], m)) body
+            | None -> body
+        else
+            body
+
+    let unitv, _ = mkCompGenLocal m "unitArg" g.unit_ty
+    let expr = mkLambdas g m tps [ thisv; unitv ] (body, g.string_ty)
+    [ mkCompGenBind toStringVal expr ]

src/Compiler/Checking/AugmentWithHashCompare.fsi

@@ -51,3 +51,15 @@ val TypeDefinitelyHasEquality: TcGlobals -> TType -> bool
 val MakeValsForUnionAugmentation: TcGlobals -> TyconRef -> Val list
 
 val MakeBindingsForUnionAugmentation: TcGlobals -> Tycon -> ValRef list -> Binding list
+
+/// Build a record's single-line reflection-free ToString body; returns the 'this' value and the body expression.
+val mkRecdToString: g: TcGlobals * tcref: TyconRef * tycon: Tycon * openBrace: string * closeBrace: string -> Val * Expr
+
+/// Whether a reflection-free structural ToString should be generated for this type.
+val TyconIsCandidateForAugmentationWithToString: g: TcGlobals * tycon: Tycon -> bool
+
+/// Make the ToString override slot for a reflection-free record or union.
+val MakeValsForToStringAugmentation: g: TcGlobals * tcref: TyconRef -> Val
+
+/// Build the body binding for a reflection-free record or union ToString override.
+val MakeBindingsForToStringAugmentation: g: TcGlobals * tycon: Tycon * toStringVal: Val -> Binding list

src/Compiler/Checking/CheckDeclarations.fs

@@ -916,6 +916,18 @@ module AddAugmentationDeclarations =
             else []
         else []
 
+    // Under --reflectionfree the structural ToString is generated here (rather than in IlxGen) so the 'string'
+    // operator calls in its body flow through the optimizer and get specialised. Like the Equals override, this
+    // runs late so tycon.HasMember gives correct results for a user-written ToString.
+    let AddReflectionFreeToStringBindings (cenv: cenv, env: TcEnv, tycon: Tycon) =
+        let g = cenv.g
+        if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithToString(g, tycon) && not (tycon.HasMember g "ToString" []) then
+            let tcref = mkLocalTyconRef tycon
+            let toStringVal = AugmentTypeDefinitions.MakeValsForToStringAugmentation(g, tcref)
+            PublishValueDefn cenv env ModuleOrMemberBinding toStringVal
+            AugmentTypeDefinitions.MakeBindingsForToStringAugmentation(g, tycon, toStringVal)
+        else []
+
     let ShouldAugmentUnion (g: TcGlobals) (tycon: Tycon) =
         g.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible &&
         HasDefaultAugmentationAttribute g (mkLocalTyconRef tycon) &&
@@ -4771,8 +4783,9 @@ module TcDeclarations =
                     // We put the hash/compare bindings before the type definitions and the
                     // equality bindings after because tha is the order they've always been generated
                     // in, and there are code generation tests to check that.
-                    let binds = AddAugmentationDeclarations.AddGenericHashAndComparisonBindings cenv tycon 
+                    let binds = AddAugmentationDeclarations.AddGenericHashAndComparisonBindings cenv tycon
                     let binds3 = AddAugmentationDeclarations.AddGenericEqualityBindings cenv envForDecls tycon
+                    let binds5 = AddAugmentationDeclarations.AddReflectionFreeToStringBindings(cenv, envForDecls, tycon)
                     let binds4 =
                         if tycon.IsUnionTycon && AddAugmentationDeclarations.ShouldAugmentUnion g tycon then
                             let unionVals =
@@ -4782,7 +4795,7 @@ module TcDeclarations =
                             AugmentTypeDefinitions.MakeBindingsForUnionAugmentation g tycon (List.map mkLocalValRef unionVals)
                         else
                             []
-                    binds@binds4, binds3)
+                    binds@binds4, binds3@binds5)
 
         // Check for cyclic structs and inheritance all over again, since we may have added some fields to the struct when generating the implicit construction syntax 
         EstablishTypeDefinitionCores.TcTyconDefnCore_CheckForCyclicStructsAndInheritance cenv tycons