diff --git a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md b/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md index 992ccf70881..50306ca1e84 100644 --- a/docs/release-notes/.FSharp.Compiler.Service/11.0.100.md +++ b/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((+) 1)`), instead of synthetic `delegateArg0`, `delegateArg1`, … names. ([PR #20001](https://github.com/dotnet/fsharp/pull/20001)) diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fs b/src/Compiler/Checking/AugmentWithHashCompare.fs index c5ae2d1459f..13797279de0 100644 --- a/src/Compiler/Checking/AugmentWithHashCompare.fs +++ b/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 ] diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fsi b/src/Compiler/Checking/AugmentWithHashCompare.fsi index b57e25f32cc..13899af4d36 100644 --- a/src/Compiler/Checking/AugmentWithHashCompare.fsi +++ b/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 diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index b5055ce2dd9..68fe74c5933 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/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 diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 1a5719f03b5..b93404c1b2e 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -2284,7 +2284,6 @@ type AnonTypeGenerationTable() = mkLdfldMethodDef ("get_" + propName, ILMemberAccess.Public, false, ilTy, fldName, fldTy, ILAttributes.Empty, attrs) |> g.AddMethodGeneratedAttributes - yield! genToStringMethod ilTy ] let ilBaseTy = (if isStruct then g.iltyp_ValueType else g.ilg.typ_Object) @@ -2387,6 +2386,10 @@ type AnonTypeGenerationTable() = Some(mkLocalValRef augmentation.EqualsExactWithComparer) ) + // Generate ToString through the synthetic record tycon (renders "{| Name = value; ... |}" under + // --reflectionfree, otherwise sprintf "%+A"). Done here, not in ilMethods above, because it needs the tycon. + let ilToStringMethodDefs = genToStringMethod (ilTy, tycon) + // Build the ILTypeDef. We don't rely on the normal record generation process because we want very specific field names let ilTypeDefAttribs = @@ -2409,7 +2412,7 @@ type AnonTypeGenerationTable() = ilGenericParams, ilBaseTy, ilInterfaceTys, - mkILMethods (ilCtorDef :: ilMethods), + mkILMethods (ilCtorDef :: ilMethods @ ilToStringMethodDefs), ilFieldDefs, emptyILTypeDefs, ilProperties, @@ -3888,7 +3891,11 @@ and GenAllocRecd cenv cgbuf eenv ctorInfo (tcref, argTys, args, m) sequel = and GenAllocAnonRecd cenv cgbuf eenv (anonInfo: AnonRecdTypeInfo, tyargs, args, m) sequel = let anonCtor, _anonMethods, anonType = - cgbuf.mgbuf.LookupAnonType((fun ilThisTy -> GenToStringMethod cenv eenv ilThisTy m), anonInfo) + cgbuf.mgbuf.LookupAnonType( + (fun (ilThisTy, tycon) -> + GenRecordToStringMethod(cenv, cgbuf.mgbuf, EnvForTycon tycon eenv, ilThisTy, mkLocalTyconRef tycon, m, "{| ", " |}")), + anonInfo + ) let boxity = anonType.Boxity GenExprs cenv cgbuf eenv args @@ -3902,7 +3909,11 @@ and GenAllocAnonRecd cenv cgbuf eenv (anonInfo: AnonRecdTypeInfo, tyargs, args, and GenGetAnonRecdField cenv cgbuf eenv (anonInfo: AnonRecdTypeInfo, e, tyargs, n, m) sequel = let _anonCtor, anonMethods, anonType = - cgbuf.mgbuf.LookupAnonType((fun ilThisTy -> GenToStringMethod cenv eenv ilThisTy m), anonInfo) + cgbuf.mgbuf.LookupAnonType( + (fun (ilThisTy, tycon) -> + GenRecordToStringMethod(cenv, cgbuf.mgbuf, EnvForTycon tycon eenv, ilThisTy, mkLocalTyconRef tycon, m, "{| ", " |}")), + anonInfo + ) let boxity = anonType.Boxity let ilTypeArgs = GenTypeArgs cenv m eenv.tyenv tyargs @@ -10987,7 +10998,11 @@ and GenImplFile cenv (mgbuf: AssemblyBuilder) mainInfoOpt eenv (implFile: Checke // Generate all the anonymous record types mentioned anywhere in this module for anonInfo in anonRecdTypes.Values do - mgbuf.GenerateAnonType((fun ilThisTy -> GenToStringMethod cenv eenv ilThisTy m), anonInfo) + mgbuf.GenerateAnonType( + (fun (ilThisTy, tycon) -> + GenRecordToStringMethod(cenv, mgbuf, EnvForTycon tycon eenv, ilThisTy, mkLocalTyconRef tycon, m, "{| ", " |}")), + anonInfo + ) let withQName (loc: CompileLocation) = { loc with @@ -11355,11 +11370,8 @@ and GenAbstractBinding cenv eenv tref (vref: ValRef) = else [], [], [] -and GenToStringMethod cenv eenv ilThisTy m = - GenPrintingMethod cenv eenv "ToString" ilThisTy m - /// Generate a ToString/get_Message method that calls 'sprintf "%A"' -and GenPrintingMethod cenv eenv methName ilThisTy m = +and GenSprintfPrintingMethod cenv eenv methName ilThisTy m = let g = cenv.g [ @@ -11424,6 +11436,42 @@ and GenPrintingMethod cenv eenv methName ilThisTy m = | _ -> () ] +/// Emit a [] virtual ToString override whose body is the given string-typed expression. +/// 'thisv' is the 'this' value (stored at arg 0) referenced by bodyExpr. +and EmitToStringMethodDef (cenv: cenv, mgbuf: AssemblyBuilder, eenv: IlxGenEnv, thisv: Val, bodyExpr: Expr) = + let g = cenv.g + let eenvForMeth = AddStorageForLocalVals g [ (thisv, Arg 0) ] eenv + + let ilMethodBody = + CodeGenMethodForExpr cenv mgbuf ([], "ToString", eenvForMeth, 0, Some thisv, bodyExpr, Return) + + let mdef = + mkILNonGenericVirtualInstanceMethod ( + "ToString", + ILMemberAccess.Public, + [], + mkILReturn g.ilg.typ_String, + MethodBody.IL(InterruptibleLazy.FromValue ilMethodBody) + ) + + [ mdef.With(customAttrs = mkILCustomAttrs [ g.CompilerGeneratedAttribute ]) ] + +/// Generate an anonymous record's ToString as a single line "{| F1 = v1; F2 = v2 |}". Nominal records and +/// unions get their reflection-free ToString from the type-augmentation phase instead (so the 'string' +/// operator calls are optimized), but anonymous record types are synthesized too late for that, so they are +/// generated here. Under non-reflection-free codegen, falls back to sprintf "%+A". +and GenRecordToStringMethod + (cenv: cenv, mgbuf: AssemblyBuilder, eenv: IlxGenEnv, ilThisTy: ILType, tcref: TyconRef, m: range, openBrace: string, closeBrace: string) = + let g = cenv.g + + if not g.useReflectionFreeCodeGen then + GenSprintfPrintingMethod cenv eenv "ToString" ilThisTy m + else + let thisv, body = + AugmentTypeDefinitions.mkRecdToString (g, tcref, tcref.Deref, openBrace, closeBrace) + + EmitToStringMethodDef(cenv, mgbuf, eenv, thisv, body) + and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) : ILTypeRef option = let g = cenv.g let tcref = mkLocalTyconRef tycon @@ -12007,8 +12055,10 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) : ILTypeRef option then yield mkILSimpleStorageCtor (Some g.ilg.typ_Object.TypeSpec, ilThisTy, [], [], reprAccess, None, eenv.imports) - if not (tycon.HasMember g "ToString" []) then - yield! GenToStringMethod cenv eenv ilThisTy m + // Reflection-free nominal records get their ToString from the type-augmentation phase; here we + // only emit the sprintf "%+A" ToString for the non-reflection-free case. + if not g.useReflectionFreeCodeGen && not (tycon.HasMember g "ToString" []) then + yield! GenSprintfPrintingMethod cenv eenvinner "ToString" ilThisTy m | TFSharpTyconRepr r when tycon.IsFSharpDelegateTycon -> @@ -12031,8 +12081,12 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) : ILTypeRef option yield! mkILDelegateMethods reprAccess g.ilg (g.iltyp_AsyncCallback, g.iltyp_IAsyncResult) (parameters, ret) | _ -> () - | TFSharpTyconRepr { fsobjmodel_kind = TFSharpUnion } when not (tycon.HasMember g "ToString" []) -> - yield! GenToStringMethod cenv eenv ilThisTy m + // Reflection-free nominal unions get their ToString from the type-augmentation phase; here we + // only emit the sprintf "%+A" ToString for the non-reflection-free case. + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpUnion } when + not g.useReflectionFreeCodeGen && not (tycon.HasMember g "ToString" []) + -> + yield! GenSprintfPrintingMethod cenv eenvinner "ToString" ilThisTy m | _ -> () ] @@ -12656,7 +12710,7 @@ and GenExnDef cenv mgbuf eenv m (exnc: Tycon) : ILTypeRef option = && not (exnc.HasMember g "Message" []) && not (fspecs |> List.exists (fun rf -> rf.DisplayNameCore = "Message")) then - yield! GenPrintingMethod cenv eenv "get_Message" ilThisTy m + yield! GenSprintfPrintingMethod cenv eenv "get_Message" ilThisTy m ] let interfaces = diff --git a/src/Compiler/Optimize/Optimizer.fs b/src/Compiler/Optimize/Optimizer.fs index 866ddedf916..d9c2d018db2 100644 --- a/src/Compiler/Optimize/Optimizer.fs +++ b/src/Compiler/Optimize/Optimizer.fs @@ -2544,19 +2544,7 @@ and MakeOptimizedSystemStringConcatCall cenv env m args = let args = optimizeArgs args [] - let expr = - match args with - | [ arg ] -> - arg - | [ arg1; arg2 ] -> - mkStaticCall_String_Concat2 g m arg1 arg2 - | [ arg1; arg2; arg3 ] -> - mkStaticCall_String_Concat3 g m arg1 arg2 arg3 - | [ arg1; arg2; arg3; arg4 ] -> - mkStaticCall_String_Concat4 g m arg1 arg2 arg3 arg4 - | args -> - let arg = mkArray (g.string_ty, args, m) - mkStaticCall_String_Concat_Array g m arg + let expr = mkStringConcat (g, m, args) match expr with | Expr.Op(TOp.ILCall(_, _, _, _, _, _, _, ilMethRef, _, _, _) as op, tyargs, args, m) diff --git a/src/Compiler/TypedTree/TcGlobals.fs b/src/Compiler/TypedTree/TcGlobals.fs index 237ec492651..5b55012f907 100644 --- a/src/Compiler/TypedTree/TcGlobals.fs +++ b/src/Compiler/TypedTree/TcGlobals.fs @@ -806,6 +806,7 @@ type TcGlobals( let v_byte_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "byte" , None , Some "ToByte", [vara], ([[varaTy]], v_byte_ty)) let v_sbyte_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "sbyte" , None , Some "ToSByte", [vara], ([[varaTy]], v_sbyte_ty)) + let v_string_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "string" , None , Some "ToString", [vara], ([[varaTy]], v_string_ty)) let v_int16_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "int16" , None , Some "ToInt16", [vara], ([[varaTy]], v_int16_ty)) let v_uint16_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "uint16" , None , Some "ToUInt16", [vara], ([[varaTy]], v_uint16_ty)) let v_int32_operator_info = makeIntrinsicValRef(fslib_MFOperators_nleref, "int32" , None , Some "ToInt32", [vara], ([[varaTy]], v_int32_ty)) @@ -1610,6 +1611,7 @@ type TcGlobals( member _.byte_operator_info = v_byte_operator_info member _.sbyte_operator_info = v_sbyte_operator_info + member _.string_operator_info = v_string_operator_info member _.int16_operator_info = v_int16_operator_info member _.uint16_operator_info = v_uint16_operator_info member _.int32_operator_info = v_int32_operator_info diff --git a/src/Compiler/TypedTree/TcGlobals.fsi b/src/Compiler/TypedTree/TcGlobals.fsi index 214ad0d17cd..8ecc7e83f00 100644 --- a/src/Compiler/TypedTree/TcGlobals.fsi +++ b/src/Compiler/TypedTree/TcGlobals.fsi @@ -941,6 +941,8 @@ type internal TcGlobals = member sbyte_operator_info: IntrinsicValRef + member string_operator_info: IntrinsicValRef + member sbyte_tcr: TypedTree.EntityRef member sbyte_ty: TypedTree.TType diff --git a/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs b/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs index bdebaf40ff5..a87c12325a1 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fs @@ -1366,6 +1366,9 @@ module internal Makers = let mkCallNewFormat (g: TcGlobals) m aty bty cty dty ety formatStringExpr = mkApps g (typedExprForIntrinsic g m g.new_format_info, [ [ aty; bty; cty; dty; ety ] ], [ formatStringExpr ], m) + let mkCallStringOperator (g: TcGlobals) m argTy e = + mkApps g (typedExprForIntrinsic g m g.string_operator_info, [ [ argTy ] ], [ e ], m) + let tryMkCallBuiltInWitness (g: TcGlobals) traitInfo argExprs m = let info, tinst = g.MakeBuiltInWitnessInfo traitInfo let vref = ValRefForIntrinsic info @@ -1570,6 +1573,17 @@ module internal Makers = m ) + /// Concatenate string-valued expressions, choosing the cheapest String.Concat overload by arity. + /// An empty list yields "" and a singleton yields itself. + let mkStringConcat (g: TcGlobals, m: range, exprs: Expr list) = + match exprs with + | [] -> mkString g m "" + | [ arg ] -> arg + | [ arg1; arg2 ] -> mkStaticCall_String_Concat2 g m arg1 arg2 + | [ arg1; arg2; arg3 ] -> mkStaticCall_String_Concat3 g m arg1 arg2 arg3 + | [ arg1; arg2; arg3; arg4 ] -> mkStaticCall_String_Concat4 g m arg1 arg2 arg3 arg4 + | _ -> mkStaticCall_String_Concat_Array g m (mkArray (g.string_ty, exprs, m)) + // Quotations can't contain any IL. // As a result, we aim to get rid of all IL generation in the typechecker and pattern match // compiler, or else train the quotation generator to understand the generated IL. diff --git a/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fsi b/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fsi index ad90c5c818c..70379648e63 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fsi +++ b/src/Compiler/TypedTree/TypedTreeOps.ExprOps.fsi @@ -208,6 +208,9 @@ module internal Makers = val mkCallNewFormat: TcGlobals -> range -> TType -> TType -> TType -> TType -> TType -> formatStringExpr: Expr -> Expr + /// Build a call to the 'string' operator (Operators.ToString) at the given argument type. + val mkCallStringOperator: TcGlobals -> range -> argTy: TType -> Expr -> Expr + val mkCallGetGenericComparer: TcGlobals -> range -> Expr val mkCallGetGenericEREqualityComparer: TcGlobals -> range -> Expr @@ -446,6 +449,10 @@ module internal Makers = val mkStaticCall_String_Concat_Array: TcGlobals -> range -> Expr -> Expr + /// Concatenate string-valued expressions, choosing the cheapest String.Concat overload by arity. + /// An empty list yields "" and a singleton yields itself. + val mkStringConcat: TcGlobals * range * Expr list -> Expr + val mkDecr: TcGlobals -> range -> Expr -> Expr val mkIncr: TcGlobals -> range -> Expr -> Expr diff --git a/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsc/reflectionfree.fs b/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsc/reflectionfree.fs index 65b96d7d9c8..e7171a3ad65 100644 --- a/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsc/reflectionfree.fs +++ b/tests/FSharp.Compiler.ComponentTests/CompilerOptions/fsc/reflectionfree.fs @@ -35,15 +35,239 @@ let someCode = """ [] -let ``Records and DUs don't have generated ToString`` () = +let ``Classes don't have a generated ToString`` () = someCode |> withOptions [ "--reflectionfree" ] |> compileExeAndRun |> shouldSucceed - |> withStdOutContains "Thing says: Test+MyRecord" - |> withStdOutContains "Thing says: Test+MyUnion+B" |> withStdOutContains "Thing says: Test+MyClass" +[] +let ``Records get a generated single-line ToString`` () = + FSharp """ +module Test +type Point = { X: int; Y: int } +type Nested = { P: Point; S: string } + +[] +let main _ = + { X = 1; Y = 2 } |> string |> System.Console.WriteLine + { P = { X = 1; Y = 2 }; S = null } |> string |> System.Console.WriteLine // nested record + null field + 0 + """ + |> asExe + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "{ X = 1; Y = 2 }" + |> withStdOutContains "{ P = { X = 1; Y = 2 }; S = null }" + +[] +let ``Unions have a generated ToString that matches on the case`` () = + someCode + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "Thing says: B(foo)" + +[] +let ``Generic unions get a correct generated ToString`` () = + FSharp """ +module Test +type Box<'T> = + | Box of 'T + | Empty +type Single<'T> = | Just of 'T + +[] +let main _ = + Box 42 |> string |> System.Console.WriteLine + Box (Box 7) |> string |> System.Console.WriteLine // nested generic + (Empty: Box) |> string |> System.Console.WriteLine + Just 5 |> string |> System.Console.WriteLine // single-case generic union + 0 + """ + |> asExe + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "Box(42)" + |> withStdOutContains "Box(Box(7))" + |> withStdOutContains "Empty" + |> withStdOutContains "Just(5)" + +[] +let ``Generated ToString renders a field the same way option does`` () = + FSharp """ +module Test +type Wrapper = | Wrap of string + +[] +let main _ = + let value: string = null + // A union field should render its content the same way option does. Compare the two directly rather + // than asserting a fixed rendering. "Wrap" and "Some" are both 4 chars, so dropping them leaves the + // field rendering to compare. + let fromUnion = (Wrap value |> string).Substring 4 + let fromOption = ((Some value).ToString()).Substring 4 + if fromUnion = fromOption then System.Console.WriteLine "fields-render-alike" + else System.Console.WriteLine("DIFFER: " + fromUnion + " vs " + fromOption) + 0 + """ + |> asExe + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "fields-render-alike" + +[] +let ``A hand-written ToString override is kept, not replaced by the generated one`` () = + FSharp """ +module Test +type MyDU = + | A of int + override _.ToString() = "custom-du" + +type MyRecord = + { X: int } + override _.ToString() = "custom-record" + +[] +let main _ = + A 1 |> string |> System.Console.WriteLine + { X = 1 } |> string |> System.Console.WriteLine + 0 + """ + |> asExe + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "custom-du" + |> withStdOutContains "custom-record" + +[] +let ``Union field shapes: multiple fields versus a single tuple field`` () = + FSharp """ +module Test +type TwoFields = | Two of int * int +type OneTupleField = | OneTup of (int * int) +type NamedFields = | Named of x: int * y: int + +[] +let main _ = + Two (1, 2) |> string |> System.Console.WriteLine + OneTup (1, 2) |> string |> System.Console.WriteLine // a single tuple field keeps its own parens + Named (1, 2) |> string |> System.Console.WriteLine // named fields render positionally, names are not shown + 0 + """ + |> asExe + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "Two(1, 2)" + |> withStdOutContains "OneTup((1, 2))" + |> withStdOutContains "Named(1, 2)" + +[] +let ``Explicit field names do not change the rendering`` () = + FSharp """ +module Test +type Labelled = | WithNames of first: int * second: string +type Plain = | WithoutNames of int * string + +[] +let main _ = + WithNames (1, "a") |> string |> System.Console.WriteLine + WithoutNames (1, "a") |> string |> System.Console.WriteLine // unnamed fields render the same way as named ones + 0 + """ + |> asExe + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "WithNames(1, a)" + |> withStdOutContains "WithoutNames(1, a)" + +[] +let ``Struct unions and struct records get a generated ToString`` () = + FSharp """ +module Test +[] type StructUnion = | SA of a: int +[] type StructRecord = { SX: int; SY: int } + +[] +let main _ = + SA 7 |> string |> System.Console.WriteLine + { SX = 1; SY = 2 } |> string |> System.Console.WriteLine + 0 + """ + |> asExe + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "SA(7)" + |> withStdOutContains "{ SX = 1; SY = 2 }" + +[] +let ``Anonymous records get a generated single-line ToString`` () = + FSharp """ +module Test +[] +let main _ = + {| A = 1; B = "hi" |} |> string |> System.Console.WriteLine + (struct {| A = 1; B = "hi" |}) |> string |> System.Console.WriteLine // a struct anonymous record renders identically + 0 + """ + |> asExe + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "{| A = 1; B = hi |}" + +[] +let ``Recursively defined types render when the data is finite`` () = + FSharp """ +module Test +type Tree = | Leaf | Node of Tree * int * Tree +type TreeNode = { Value: int; Parent: TreeNode option } // an upward-only parent pointer stays finite + +[] +let main _ = + Node (Node (Leaf, 1, Leaf), 2, Leaf) |> string |> System.Console.WriteLine + let root = { Value = 0; Parent = None } + { Value = 1; Parent = Some root } |> string |> System.Console.WriteLine + 0 + """ + |> asExe + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "Node(Node(Leaf, 1, Leaf), 2, Leaf)" + |> withStdOutContains "{ Value = 1; Parent = Some({ Value = 0; Parent = null }) }" + +[] +let ``Deeply nested data fails the generated ToString with a catchable exception, not a hard overflow`` () = + FSharp """ +module Test +type Chain = | End | Link of int * Chain + +[] +let main _ = + let mutable c = End + for i in 1 .. 1_000_000 do c <- Link(i, c) + try + c.ToString() |> ignore + System.Console.WriteLine "rendered" + with :? System.InsufficientExecutionStackException -> + System.Console.WriteLine "caught" + 0 + """ + |> asExe + |> withOptions [ "--reflectionfree" ] + |> compileExeAndRun + |> shouldSucceed + |> withStdOutContains "caught" + [] let ``No debug display attribute`` () = someCode diff --git a/tests/FSharp.Compiler.ComponentTests/EmittedIL/ReflectionFreeToString.fs b/tests/FSharp.Compiler.ComponentTests/EmittedIL/ReflectionFreeToString.fs new file mode 100644 index 00000000000..c14608f9989 --- /dev/null +++ b/tests/FSharp.Compiler.ComponentTests/EmittedIL/ReflectionFreeToString.fs @@ -0,0 +1,118 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +namespace EmittedIL + +open Xunit +open FSharp.Test.Compiler + +module ``ReflectionFreeToString`` = + + // Under --reflectionfree, records and unions get a structural ToString (fields joined with String.Concat, + // value-type fields rendered via a direct allocation-free ToString, no PrintfFormat) instead of sprintf "%+A". + + [] + let ``Record ToString is generated structurally without printf`` () = + FSharp """ +module ReflectionFreeToString +type Point = { X: int; Y: int } + """ + |> withOptions [ "--reflectionfree" ] + |> compile + |> shouldSucceed + |> verifyIL [""" +.method public hidebysig virtual final instance string ToString() cil managed +{ +.custom instance void [runtime]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + +.maxstack 8 +.locals init (int32 V_0) +IL_0000: ldc.i4.7 +IL_0001: newarr [runtime]System.String +IL_0006: dup +IL_0007: ldc.i4.0 +IL_0008: ldstr "{ " +IL_000d: stelem [runtime]System.String +IL_0012: dup +IL_0013: ldc.i4.1 +IL_0014: ldstr "X = " +IL_0019: stelem [runtime]System.String +IL_001e: dup +IL_001f: ldc.i4.2 +IL_0020: ldarg.0 +IL_0021: ldfld int32 ReflectionFreeToString/Point::X@ +IL_0026: stloc.0 +IL_0027: ldloca.s V_0 +IL_0029: ldnull +IL_002a: call class [netstandard]System.Globalization.CultureInfo [netstandard]System.Globalization.CultureInfo::get_InvariantCulture() +IL_002f: call instance string [netstandard]System.Int32::ToString(string, +class [netstandard]System.IFormatProvider) +IL_0034: stelem [runtime]System.String +IL_0039: dup +IL_003a: ldc.i4.3 +IL_003b: ldstr "; " +IL_0040: stelem [runtime]System.String +IL_0045: dup +IL_0046: ldc.i4.4 +IL_0047: ldstr "Y = " +IL_004c: stelem [runtime]System.String +IL_0051: dup +IL_0052: ldc.i4.5 +IL_0053: ldarg.0 +IL_0054: ldfld int32 ReflectionFreeToString/Point::Y@ +IL_0059: stloc.0 +IL_005a: ldloca.s V_0 +IL_005c: ldnull +IL_005d: call class [netstandard]System.Globalization.CultureInfo [netstandard]System.Globalization.CultureInfo::get_InvariantCulture() +IL_0062: call instance string [netstandard]System.Int32::ToString(string, +class [netstandard]System.IFormatProvider) +IL_0067: stelem [runtime]System.String +IL_006c: dup +IL_006d: ldc.i4.6 +IL_006e: ldstr " }" +IL_0073: stelem [runtime]System.String +IL_0078: call string [runtime]System.String::Concat(string[]) +IL_007d: ret +}"""] + + [] + let ``Union ToString is generated structurally without printf`` () = + FSharp """ +module ReflectionFreeToString +type Color = | Red | Custom of int + """ + |> withOptions [ "--reflectionfree" ] + |> compile + |> shouldSucceed + |> verifyIL [""" +.method public hidebysig virtual final instance string ToString() cil managed +{ +.custom instance void [runtime]System.Runtime.CompilerServices.CompilerGeneratedAttribute::.ctor() = ( 01 00 00 00 ) + +.maxstack 6 +.locals init (class ReflectionFreeToString/Color/Custom V_0, +int32 V_1) +IL_0000: ldarg.0 +IL_0001: isinst ReflectionFreeToString/Color/_Red +IL_0006: brfalse.s IL_000e + +IL_0008: ldstr "Red" +IL_000d: ret + +IL_000e: ldarg.0 +IL_000f: castclass ReflectionFreeToString/Color/Custom +IL_0014: stloc.0 +IL_0015: ldstr "Custom(" +IL_001a: ldloc.0 +IL_001b: ldfld int32 ReflectionFreeToString/Color/Custom::item +IL_0020: stloc.1 +IL_0021: ldloca.s V_1 +IL_0023: ldnull +IL_0024: call class [netstandard]System.Globalization.CultureInfo [netstandard]System.Globalization.CultureInfo::get_InvariantCulture() +IL_0029: call instance string [netstandard]System.Int32::ToString(string, +class [netstandard]System.IFormatProvider) +IL_002e: ldstr ")" +IL_0033: call string [runtime]System.String::Concat(string, +string, +string) +IL_0038: ret +}"""] diff --git a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj index 210aee2444f..6e7648f9e5a 100644 --- a/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj +++ b/tests/FSharp.Compiler.ComponentTests/FSharp.Compiler.ComponentTests.fsproj @@ -249,6 +249,7 @@ +