From 0a410b7f678de0bb7a808e14f0a8644c3bb201c0 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Thu, 26 Mar 2026 22:19:43 +0100 Subject: [PATCH 01/44] Add UnionLayout taxonomy + assertions (no behavior change) Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 248 ++++++++++++++++++++++++++++ 1 file changed, 248 insertions(+) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index ef47028b256..c444752b986 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -40,6 +40,21 @@ type DiscriminationTechnique = // class (no subclasses), but an integer tag is stored to discriminate between the objects. | IntegerTag +[] +type UnionLayout = + /// F# list<'a> only. Discrimination via tail field == null. + | ListTailOrNull of baseTy: ILType + /// Single case, reference type. No discrimination needed. + | SingleCaseRef of baseTy: ILType + /// Single case, struct. No discrimination needed. + | SingleCaseStruct of baseTy: ILType + /// 2-3 cases, reference, not all-nullary. Discrimination via isinst type checks. + | SmallRefUnion of baseTy: ILType * nullCaseIdx: int option + /// ≥4 cases (or 2-3 all-nullary), reference. Discrimination via integer _tag field. + | TaggedRefUnion of baseTy: ILType * allNullary: bool + /// Any struct DU with >1 case. Discrimination via integer _tag field. + | TaggedStructUnion of baseTy: ILType * allNullary: bool + // A potentially useful additional representation trades an extra integer tag in the root type // for faster discrimination, and in the important single-non-nullary constructor case // @@ -205,6 +220,217 @@ let cudefRepr = (fun ((_td, _cud), _nm) -> NoTypesGeneratedViaThisReprDecider) ) +/// Core classification logic. Computes the UnionLayout for any union. +/// This must produce IDENTICAL decisions to UnionReprDecisions.DiscriminationTechnique. +let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isStruct = + if isList then + UnionLayout.ListTailOrNull baseTy + elif alts.Length = 1 then + if isStruct then + UnionLayout.SingleCaseStruct baseTy + else + UnionLayout.SingleCaseRef baseTy + elif + not isStruct + && alts.Length < 4 + && not (alts |> Array.forall (fun alt -> alt.IsNullary)) + then + let nullCaseIdx = + if + nullPermitted + && alts |> Array.existsOne (fun alt -> alt.IsNullary) + && alts |> Array.exists (fun alt -> not alt.IsNullary) + then + alts |> Array.tryFindIndex (fun alt -> alt.IsNullary) + else + None + + UnionLayout.SmallRefUnion(baseTy, nullCaseIdx) + elif isStruct then + UnionLayout.TaggedStructUnion(baseTy, alts |> Array.forall (fun alt -> alt.IsNullary)) + else + UnionLayout.TaggedRefUnion(baseTy, alts |> Array.forall (fun alt -> alt.IsNullary)) + +/// Classify from an IlxUnionSpec (used in IL instruction generation). +let classifyFromSpec (cuspec: IlxUnionSpec) = + let baseTy = baseTyOfUnionSpec cuspec + let alts = cuspec.AlternativesArray + let nullPermitted = cuspec.IsNullPermitted + let isList = (cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) + let isStruct = (cuspec.Boxity = ILBoxity.AsValue) + classifyUnion baseTy alts nullPermitted isList isStruct + +/// Classify from an ILTypeDef + IlxUnionInfo (used in type definition generation). +let classifyFromDef (td: ILTypeDef) (cud: IlxUnionInfo) (baseTy: ILType) = + let alts = cud.UnionCases + let nullPermitted = cud.IsNullPermitted + let isList = (cud.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) + let isStruct = td.IsStruct + classifyUnion baseTy alts nullPermitted isList isStruct + +/// Maps a UnionLayout to the equivalent DiscriminationTechnique. +/// Used in debug assertions to validate the new classification matches the old one. +let private layoutToTechnique layout = + match layout with + | UnionLayout.ListTailOrNull _ -> TailOrNull + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ -> SingleCase + | UnionLayout.SmallRefUnion _ -> RuntimeTypes + | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedStructUnion _ -> IntegerTag + +#if DEBUG +/// Assert that classifyFromSpec agrees with cuspecRepr.DiscriminationTechnique. +let private assertSpecClassification (cuspec: IlxUnionSpec) = + let layout = classifyFromSpec cuspec + let oldTechnique = cuspecRepr.DiscriminationTechnique cuspec + assert (oldTechnique = layoutToTechnique layout) + +/// Assert that classifyFromDef agrees with cudefRepr.DiscriminationTechnique. +let private assertDefClassification (td: ILTypeDef) (cud: IlxUnionInfo) (baseTy: ILType) = + let layout = classifyFromDef td cud baseTy + let oldTechnique = cudefRepr.DiscriminationTechnique(td, cud) + assert (oldTechnique = layoutToTechnique layout) +#endif + +// ---- Exhaustive Active Patterns for UnionLayout ---- + +/// How to discriminate between cases at runtime. +let (|DiscriminateByTagField|DiscriminateByRuntimeType|DiscriminateByTailNull|NoDiscrimination|) layout = + match layout with + | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedStructUnion _ -> DiscriminateByTagField + | UnionLayout.SmallRefUnion _ -> DiscriminateByRuntimeType + | UnionLayout.ListTailOrNull _ -> DiscriminateByTailNull + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ -> NoDiscrimination + +/// Does the root type have a _tag integer field? +let (|HasTagField|NoTagField|) layout = + match layout with + | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedStructUnion _ -> HasTagField + | UnionLayout.SmallRefUnion _ + | UnionLayout.ListTailOrNull _ + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ -> NoTagField + +/// Where are case fields stored? +let (|FieldsOnRootType|FieldsOnNestedTypes|) layout = + match layout with + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.ListTailOrNull _ + | UnionLayout.TaggedStructUnion _ -> FieldsOnRootType + | UnionLayout.SmallRefUnion _ + | UnionLayout.TaggedRefUnion _ -> FieldsOnNestedTypes + +/// Is a specific case (by index) represented as null? +let (|CaseIsNull|CaseIsAllocated|) (layout, cidx) = + match layout with + | UnionLayout.SmallRefUnion(_, Some nullIdx) when nullIdx = cidx -> CaseIsNull + | UnionLayout.SmallRefUnion _ + | UnionLayout.ListTailOrNull _ + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedStructUnion _ -> CaseIsAllocated + +/// Is this a value type (struct) or reference type layout? +let (|ValueTypeLayout|ReferenceTypeLayout|) layout = + match layout with + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedStructUnion _ -> ValueTypeLayout + | UnionLayout.SingleCaseRef _ + | UnionLayout.SmallRefUnion _ + | UnionLayout.TaggedRefUnion _ + | UnionLayout.ListTailOrNull _ -> ReferenceTypeLayout + +/// Does a non-nullary case fold its fields into the root class (no nested type)? +let (|NonNullaryFoldsToRoot|NonNullaryInNestedType|) (layout, alt: IlxUnionCase) = + match layout with + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedStructUnion _ + | UnionLayout.ListTailOrNull _ -> NonNullaryFoldsToRoot + | UnionLayout.TaggedRefUnion(_, allNullary) when allNullary -> NonNullaryFoldsToRoot + | UnionLayout.TaggedRefUnion _ when not alt.IsNullary -> NonNullaryInNestedType + | UnionLayout.TaggedRefUnion _ -> NonNullaryFoldsToRoot + | UnionLayout.SmallRefUnion _ when not alt.IsNullary -> NonNullaryInNestedType + | UnionLayout.SmallRefUnion _ -> NonNullaryFoldsToRoot + +/// Compile-time validation that all active patterns cover all UnionLayout cases. +/// Also validates that classifyFromSpec and classifyFromDef compile correctly. +let private _validateActivePatterns + (layout: UnionLayout) + (alt: IlxUnionCase) + (cuspec: IlxUnionSpec) + (td: ILTypeDef) + (cud: IlxUnionInfo) + (baseTy: ILType) + = + let _fromSpec = classifyFromSpec cuspec + let _fromDef = classifyFromDef td cud baseTy + let _technique = layoutToTechnique layout + + match layout with + | DiscriminateByTagField + | DiscriminateByRuntimeType + | DiscriminateByTailNull + | NoDiscrimination -> () + + match layout with + | HasTagField + | NoTagField -> () + + match layout with + | FieldsOnRootType + | FieldsOnNestedTypes -> () + + match layout, 0 with + | CaseIsNull + | CaseIsAllocated -> () + + match layout with + | ValueTypeLayout + | ReferenceTypeLayout -> () + + match layout, alt with + | NonNullaryFoldsToRoot + | NonNullaryInNestedType -> () + +// ---- Context Records ---- + +/// Bundles the parameters threaded through type definition generation. +/// Replaces the 6-callback tuple + scattered parameter threading in convAlternativeDef/mkClassUnionDef. +type TypeDefContext = + { + g: TcGlobals + layout: UnionLayout + cuspec: IlxUnionSpec + cud: IlxUnionInfo + td: ILTypeDef + baseTy: ILType + stampMethodAsGenerated: ILMethodDef -> ILMethodDef + stampPropertyAsGenerated: ILPropertyDef -> ILPropertyDef + stampPropertyAsNever: ILPropertyDef -> ILPropertyDef + stampFieldAsGenerated: ILFieldDef -> ILFieldDef + stampFieldAsNever: ILFieldDef -> ILFieldDef + mkDebuggerTypeProxyAttr: ILType -> ILAttribute + } + +/// Result of processing a single union alternative for type definition generation. +/// Replaces the 6-element tuple return from convAlternativeDef. +type AlternativeDefResult = + { + BaseMakerMethods: ILMethodDef list + BaseMakerProperties: ILPropertyDef list + ConstantAccessors: ILMethodDef list + NestedTypeDefs: ILTypeDef list + DebugProxyTypeDefs: ILTypeDef list + NullaryConstFields: ((ILTypeDef * IlxUnionInfo) * IlxUnionCase * ILType * int * ILFieldDef * bool) list + } + let mkTesterName nm = "Is" + nm let tagPropertyName = "Tag" @@ -393,6 +619,9 @@ let mkStData (cuspec, cidx, fidx) = mkNormalStfld (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) let mkNewData ilg (cuspec, cidx) = +#if DEBUG + assertSpecClassification cuspec +#endif let alt = altOfUnionSpec cuspec cidx let altName = alt.Name let baseTy = baseTyOfUnionSpec cuspec @@ -431,6 +660,9 @@ let mkNewData ilg (cuspec, cidx) = | NoHelpers -> convNewDataInstrInternal ilg cuspec cidx let mkIsData ilg (avoidHelpers, cuspec, cidx) = +#if DEBUG + assertSpecClassification cuspec +#endif let alt = altOfUnionSpec cuspec cidx let altTy = tyForAlt cuspec alt let altName = alt.Name @@ -487,6 +719,9 @@ let genWith g : ILCode = } let mkBrIsData ilg sense (avoidHelpers, cuspec, cidx, tg) = +#if DEBUG + assertSpecClassification cuspec +#endif let neg = (if sense then BI_brfalse else BI_brtrue) let pos = (if sense then BI_brtrue else BI_brfalse) let alt = altOfUnionSpec cuspec cidx @@ -510,6 +745,9 @@ let mkBrIsData ilg sense (avoidHelpers, cuspec, cidx, tg) = | _ -> failwith "mkBrIsData - unexpected" let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: IlxUnionSpec) = +#if DEBUG + assertSpecClassification cuspec +#endif // If helpers exist, use them match cuspec.HasHelpers with | SpecialFSharpListHelpers @@ -583,6 +821,9 @@ let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: IlxUnionSpec) emitLdDataTagPrim ilg None cg (avoidHelpers, cuspec) let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, avoidHelpers, cuspec, cidx) = +#if DEBUG + assertSpecClassification cuspec +#endif let alt = altOfUnionSpec cuspec cidx if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then @@ -616,6 +857,9 @@ let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, avoidHelpers, cuspec, cidx) cg.EmitInstr(I_castclass altTy) let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = +#if DEBUG + assertSpecClassification cuspec +#endif let baseTy = baseTyOfUnionSpec cuspec match cuspecRepr.DiscriminationTechnique cuspec with @@ -1273,6 +1517,10 @@ let mkClassUnionDef let boxity = if td.IsStruct then ILBoxity.AsValue else ILBoxity.AsObject let baseTy = mkILFormalNamedTy boxity tref td.GenericParams +#if DEBUG + assertDefClassification td cud baseTy +#endif + let cuspec = IlxUnionSpec(IlxUnionRef(boxity, baseTy.TypeRef, cud.UnionCases, cud.IsNullPermitted, cud.HasHelpers), baseTy.GenericArgs) From 63fab4d7a90808c124fa0a3653fdd5179cca5dba Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 00:13:15 +0100 Subject: [PATCH 02/44] Extract shared concerns (nullability, debug proxy) Extract three helper functions from megafunctions in EraseUnions.fs: - rewriteFieldsForStructFlattening: Nullable attribute rewriting for struct DU field flattening, extracted from mkClassUnionDef - emitDebugProxyType: Debug proxy type generation for union alternatives, extracted from convAlternativeDef - rootTypeNullableAttrs: Root type [Nullable(2)] attribute application, extracted from mkClassUnionDef Zero behavior change - code is moved verbatim into named functions. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 344 +++++++++++++++------------- 1 file changed, 179 insertions(+), 165 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index c444752b986..643560c709b 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -984,6 +984,110 @@ let mkMethodsAndPropertiesForFields basicProps, basicMethods +/// Generate a debug proxy type for a union alternative. +/// Returns (debugProxyTypeDefs, debugProxyAttrs). +let private emitDebugProxyType + (g: TcGlobals) + (td: ILTypeDef) + (altTy: ILType) + (fields: IlxUnionCaseField[]) + (baseTy: ILType) + imports + addMethodGeneratedAttrs + addPropertyGeneratedAttrs + addFieldNeverAttrs + addFieldGeneratedAttrs + mkDebuggerTypeProxyAttribute + (cud: IlxUnionInfo) + = + + let debugProxyTypeName = altTy.TypeSpec.Name + "@DebugTypeProxy" + + let debugProxyTy = + mkILBoxedTy (mkILNestedTyRef (altTy.TypeSpec.Scope, altTy.TypeSpec.Enclosing, debugProxyTypeName)) altTy.GenericArgs + + let debugProxyFieldName = "_obj" + + let debugProxyFields = + [ + mkILInstanceField (debugProxyFieldName, altTy, None, ILMemberAccess.Assembly) + |> addFieldNeverAttrs + |> addFieldGeneratedAttrs + ] + + let debugProxyCode = + [ + mkLdarg0 + mkNormalCall (mkILCtorMethSpecForTy (g.ilg.typ_Object, [])) + mkLdarg0 + mkLdarg 1us + mkNormalStfld (mkILFieldSpecInTy (debugProxyTy, debugProxyFieldName, altTy)) + ] + |> nonBranchingInstrsToCode + + let debugProxyCtor = + (mkILCtor ( + ILMemberAccess.Public (* must always be public - see jared parson blog entry on implementing debugger type proxy *) , + [ mkILParamNamed ("obj", altTy) ], + mkMethodBody (false, [], 3, debugProxyCode, None, imports) + )) + .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) + |> addMethodGeneratedAttrs + + let debugProxyGetterMeths = + fields + |> Array.map (fun field -> + let fldName, fldTy = mkUnionCaseFieldId field + + let instrs = + [ + mkLdarg0 + (if td.IsStruct then mkNormalLdflda else mkNormalLdfld) (mkILFieldSpecInTy (debugProxyTy, debugProxyFieldName, altTy)) + mkNormalLdfld (mkILFieldSpecInTy (altTy, fldName, fldTy)) + ] + |> nonBranchingInstrsToCode + + let mbody = mkMethodBody (true, [], 2, instrs, None, imports) + + mkILNonGenericInstanceMethod ("get_" + field.Name, ILMemberAccess.Public, [], mkILReturn field.Type, mbody) + |> addMethodGeneratedAttrs) + |> Array.toList + + let debugProxyGetterProps = + fields + |> Array.map (fun fdef -> + ILPropertyDef( + name = fdef.Name, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some(mkILMethRef (debugProxyTy.TypeRef, ILCallingConv.Instance, "get_" + fdef.Name, 0, [], fdef.Type)), + callingConv = ILThisConvention.Instance, + propertyType = fdef.Type, + init = None, + args = [], + customAttrs = fdef.ILField.CustomAttrs + ) + |> addPropertyGeneratedAttrs) + |> Array.toList + + let debugProxyTypeDef = + mkILGenericClass ( + debugProxyTypeName, + ILTypeDefAccess.Nested ILMemberAccess.Assembly, + td.GenericParams, + g.ilg.typ_Object, + [], + mkILMethods ([ debugProxyCtor ] @ debugProxyGetterMeths), + mkILFields debugProxyFields, + emptyILTypeDefs, + mkILProperties debugProxyGetterProps, + emptyILEvents, + emptyILCustomAttrs, + ILTypeInit.BeforeField + ) + + [ debugProxyTypeDef.WithSpecialName(true) ], ([ mkDebuggerTypeProxyAttribute debugProxyTy ] @ cud.DebugDisplayAttributes) + let convAlternativeDef ( addMethodGeneratedAttrs, @@ -1296,114 +1400,19 @@ let convAlternativeDef if not cud.GenerateDebugProxies then [], [] else - - let debugProxyTypeName = altTy.TypeSpec.Name + "@DebugTypeProxy" - - let debugProxyTy = - mkILBoxedTy - (mkILNestedTyRef (altTy.TypeSpec.Scope, altTy.TypeSpec.Enclosing, debugProxyTypeName)) - altTy.GenericArgs - - let debugProxyFieldName = "_obj" - - let debugProxyFields = - [ - mkILInstanceField (debugProxyFieldName, altTy, None, ILMemberAccess.Assembly) - |> addFieldNeverAttrs - |> addFieldGeneratedAttrs - ] - - let debugProxyCode = - [ - mkLdarg0 - mkNormalCall (mkILCtorMethSpecForTy (g.ilg.typ_Object, [])) - mkLdarg0 - mkLdarg 1us - mkNormalStfld (mkILFieldSpecInTy (debugProxyTy, debugProxyFieldName, altTy)) - ] - |> nonBranchingInstrsToCode - - let debugProxyCtor = - (mkILCtor ( - ILMemberAccess.Public (* must always be public - see jared parson blog entry on implementing debugger type proxy *) , - [ mkILParamNamed ("obj", altTy) ], - mkMethodBody (false, [], 3, debugProxyCode, None, imports) - )) - .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) - |> addMethodGeneratedAttrs - - let debugProxyGetterMeths = - fields - |> Array.map (fun field -> - let fldName, fldTy = mkUnionCaseFieldId field - - let instrs = - [ - mkLdarg0 - (if td.IsStruct then mkNormalLdflda else mkNormalLdfld) ( - mkILFieldSpecInTy (debugProxyTy, debugProxyFieldName, altTy) - ) - mkNormalLdfld (mkILFieldSpecInTy (altTy, fldName, fldTy)) - ] - |> nonBranchingInstrsToCode - - let mbody = mkMethodBody (true, [], 2, instrs, None, imports) - - mkILNonGenericInstanceMethod ( - "get_" + field.Name, - ILMemberAccess.Public, - [], - mkILReturn field.Type, - mbody - ) - |> addMethodGeneratedAttrs) - |> Array.toList - - let debugProxyGetterProps = + emitDebugProxyType + g + td + altTy fields - |> Array.map (fun fdef -> - ILPropertyDef( - name = fdef.Name, - attributes = PropertyAttributes.None, - setMethod = None, - getMethod = - Some( - mkILMethRef ( - debugProxyTy.TypeRef, - ILCallingConv.Instance, - "get_" + fdef.Name, - 0, - [], - fdef.Type - ) - ), - callingConv = ILThisConvention.Instance, - propertyType = fdef.Type, - init = None, - args = [], - customAttrs = fdef.ILField.CustomAttrs - ) - |> addPropertyGeneratedAttrs) - |> Array.toList - - let debugProxyTypeDef = - mkILGenericClass ( - debugProxyTypeName, - ILTypeDefAccess.Nested ILMemberAccess.Assembly, - td.GenericParams, - g.ilg.typ_Object, - [], - mkILMethods ([ debugProxyCtor ] @ debugProxyGetterMeths), - mkILFields debugProxyFields, - emptyILTypeDefs, - mkILProperties debugProxyGetterProps, - emptyILEvents, - emptyILCustomAttrs, - ILTypeInit.BeforeField - ) - - [ debugProxyTypeDef.WithSpecialName(true) ], - ([ mkDebuggerTypeProxyAttribute debugProxyTy ] @ cud.DebugDisplayAttributes) + baseTy + imports + addMethodGeneratedAttrs + addPropertyGeneratedAttrs + addFieldNeverAttrs + addFieldGeneratedAttrs + mkDebuggerTypeProxyAttribute + cud let altTypeDef = let basicFields = @@ -1500,6 +1509,67 @@ let convAlternativeDef baseMakerMeths, baseMakerProps, altUniqObjMeths, typeDefs, altDebugTypeDefs, altNullaryFields +/// Rewrite field nullable attributes for struct flattening. +/// When a struct DU has multiple cases, all boxed fields become potentially nullable +/// because only one case's fields are valid at a time. +let private rewriteFieldsForStructFlattening (g: TcGlobals) (cud: IlxUnionInfo) (alt: IlxUnionCase) isStruct = + if + isStruct + && cud.UnionCases.Length > 1 + && g.checkNullness + && g.langFeatureNullness + then + alt.FieldDefs + |> Array.map (fun field -> + if field.Type.IsNominal && field.Type.Boxity = AsValue then + field + else + let attrs = + let existingAttrs = field.ILField.CustomAttrs.AsArray() + + let nullableIdx = + existingAttrs |> Array.tryFindIndex (IsILAttrib g.attrib_NullableAttribute) + + match nullableIdx with + | None -> + existingAttrs + |> Array.append [| GetNullableAttribute g [ NullnessInfo.WithNull ] |] + | Some idx -> + let replacementAttr = + match existingAttrs[idx] with + (* + The attribute carries either a single byte, or a list of bytes for the fields itself and all its generic type arguments + The way we lay out DUs does not affect nullability of the typars of a field, therefore we just change the very first byte + If the field was already declared as nullable (value = 2uy) or ambivalent(value = 0uy), we can keep it that way + If it was marked as non-nullable within that UnionCase, we have to convert it to WithNull (2uy) due to other cases being possible + *) + | Encoded(method, _data, [ ILAttribElem.Byte 1uy ]) -> + mkILCustomAttribMethRef (method, [ ILAttribElem.Byte 2uy ], []) + | Encoded(method, _data, [ ILAttribElem.Array(elemType, ILAttribElem.Byte 1uy :: otherElems) ]) -> + mkILCustomAttribMethRef ( + method, + [ ILAttribElem.Array(elemType, (ILAttribElem.Byte 2uy) :: otherElems) ], + [] + ) + | attrAsBefore -> attrAsBefore + + existingAttrs |> Array.replace idx replacementAttr + + field.ILField.With(customAttrs = mkILCustomAttrsFromArray attrs) + |> IlxUnionCaseField) + else + alt.FieldDefs + +/// Add [Nullable(2)] attribute to union root type when null is permitted. +let private rootTypeNullableAttrs (g: TcGlobals) (td: ILTypeDef) (cud: IlxUnionInfo) = + if cud.IsNullPermitted && g.checkNullness && g.langFeatureNullness then + td.CustomAttrs.AsArray() + |> Array.append [| GetNullableAttribute g [ NullnessInfo.WithNull ] |] + |> mkILCustomAttrsFromArray + |> storeILCustomAttrs + else + td.CustomAttrsStored + let mkClassUnionDef ( addMethodGeneratedAttrs, @@ -1617,56 +1687,7 @@ let mkClassUnionDef |> addMethodGeneratedAttrs ] - let fieldDefs = - // Since structs are flattened out for all cases together, all boxed fields are potentially nullable - if - isStruct - && cud.UnionCases.Length > 1 - && g.checkNullness - && g.langFeatureNullness - then - alt.FieldDefs - |> Array.map (fun field -> - if field.Type.IsNominal && field.Type.Boxity = AsValue then - field - else - let attrs = - let existingAttrs = field.ILField.CustomAttrs.AsArray() - - let nullableIdx = - existingAttrs |> Array.tryFindIndex (IsILAttrib g.attrib_NullableAttribute) - - match nullableIdx with - | None -> - existingAttrs - |> Array.append [| GetNullableAttribute g [ NullnessInfo.WithNull ] |] - | Some idx -> - let replacementAttr = - match existingAttrs[idx] with - (* - The attribute carries either a single byte, or a list of bytes for the fields itself and all its generic type arguments - The way we lay out DUs does not affect nullability of the typars of a field, therefore we just change the very first byte - If the field was already declared as nullable (value = 2uy) or ambivalent(value = 0uy), we can keep it that way - If it was marked as non-nullable within that UnionCase, we have to convert it to WithNull (2uy) due to other cases being possible - *) - | Encoded(method, _data, [ ILAttribElem.Byte 1uy ]) -> - mkILCustomAttribMethRef (method, [ ILAttribElem.Byte 2uy ], []) - | Encoded(method, - _data, - [ ILAttribElem.Array(elemType, ILAttribElem.Byte 1uy :: otherElems) ]) -> - mkILCustomAttribMethRef ( - method, - [ ILAttribElem.Array(elemType, (ILAttribElem.Byte 2uy) :: otherElems) ], - [] - ) - | attrAsBefore -> attrAsBefore - - existingAttrs |> Array.replace idx replacementAttr - - field.ILField.With(customAttrs = mkILCustomAttrsFromArray attrs) - |> IlxUnionCaseField) - else - alt.FieldDefs + let fieldDefs = rewriteFieldsForStructFlattening g cud alt isStruct let fieldsToBeAddedIntoType = fieldDefs @@ -1895,14 +1916,7 @@ let mkClassUnionDef @ td.Fields.AsList() ), properties = mkILProperties (tagProps @ basePropsFromAlt @ selfProps @ existingProps), - customAttrs = - if cud.IsNullPermitted && g.checkNullness && g.langFeatureNullness then - td.CustomAttrs.AsArray() - |> Array.append [| GetNullableAttribute g [ NullnessInfo.WithNull ] |] - |> mkILCustomAttrsFromArray - |> storeILCustomAttrs - else - td.CustomAttrsStored + customAttrs = rootTypeNullableAttrs g td cud ) // The .cctor goes on the Cases type since that's where the constant fields for nullary constructors live |> addConstFieldInit From 38c03396df624a65d960cb51ba805f09ee436e2f Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 00:55:18 +0100 Subject: [PATCH 03/44] Migrate instruction functions to exhaustive layout matching Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 335 ++++++++++++++++------------ 1 file changed, 194 insertions(+), 141 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 643560c709b..dd4dc2e3d7c 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -279,20 +279,6 @@ let private layoutToTechnique layout = | UnionLayout.TaggedRefUnion _ | UnionLayout.TaggedStructUnion _ -> IntegerTag -#if DEBUG -/// Assert that classifyFromSpec agrees with cuspecRepr.DiscriminationTechnique. -let private assertSpecClassification (cuspec: IlxUnionSpec) = - let layout = classifyFromSpec cuspec - let oldTechnique = cuspecRepr.DiscriminationTechnique cuspec - assert (oldTechnique = layoutToTechnique layout) - -/// Assert that classifyFromDef agrees with cudefRepr.DiscriminationTechnique. -let private assertDefClassification (td: ILTypeDef) (cud: IlxUnionInfo) (baseTy: ILType) = - let layout = classifyFromDef td cud baseTy - let oldTechnique = cudefRepr.DiscriminationTechnique(td, cud) - assert (oldTechnique = layoutToTechnique layout) -#endif - // ---- Exhaustive Active Patterns for UnionLayout ---- /// How to discriminate between cases at runtime. @@ -577,39 +563,72 @@ let mkTagDiscriminate ilg cuspec _baseTy cidx = let mkTagDiscriminateThen ilg cuspec cidx after = [ mkGetTag ilg cuspec; mkLdcInt32 cidx ] @ mkCeqThen after -let convNewDataInstrInternal ilg cuspec cidx = +/// True when a non-nullary alt in SmallRefUnion with a null sibling is the single +/// non-nullary case whose fields fold into the root class. +/// Encodes RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull: +/// requires nullCaseIdx.IsSome (all nullary alts are null-represented), +/// not alt.IsNullary, and exactly one non-nullary case exists. +let private isSingleNonNullaryFoldedToRoot (cuspec: IlxUnionSpec) (nullCaseIdx: int option) (alt: IlxUnionCase) = + nullCaseIdx.IsSome + && not alt.IsNullary + && cuspec.AlternativesArray |> Array.existsOne (fun a -> not a.IsNullary) + +/// Encodes RepresentAlternativeAsFreshInstancesOfRootClass for a given layout and alt. +/// True when the case is constructed directly on the root type (not a nested type). +/// This covers: ListTailOrNull cons case, or SmallRefUnion with single non-nullary + null sibling. +let private caseFoldsToRootClass (layout: UnionLayout) (cuspec: IlxUnionSpec) (alt: IlxUnionCase) = + match layout with + | UnionLayout.ListTailOrNull _ -> alt.Name = ALT_NAME_CONS + | UnionLayout.SmallRefUnion(_, nullCaseIdx) -> isSingleNonNullaryFoldedToRoot cuspec nullCaseIdx alt + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedStructUnion _ -> false + +let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAlt cuspec alt let altName = alt.Name - if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then + match layout, cidx with + | CaseIsNull -> + // Null-represented case: just load null [ AI_ldnull ] - elif cuspecRepr.MaintainPossiblyUniqueConstantFieldForAlternative(cuspec, alt) then - let baseTy = baseTyOfUnionSpec cuspec - [ I_ldsfld(Nonvolatile, mkConstFieldSpec altName baseTy) ] - elif cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass(cuspec, alt) then - let baseTy = baseTyOfUnionSpec cuspec - - let instrs, tagfields = - match cuspecRepr.DiscriminationTechnique cuspec with - | IntegerTag -> [ mkLdcInt32 cidx ], [ mkTagFieldType ilg cuspec ] - | _ -> [], [] - - let ctorFieldTys = alt.FieldTypes |> Array.toList + | _ -> + match layout with + // MaintainPossiblyUniqueConstantFieldForAlternative: ref type, not null, nullary + // → load the singleton static field + | UnionLayout.SingleCaseRef _ + | UnionLayout.SmallRefUnion _ + | UnionLayout.TaggedRefUnion _ + | UnionLayout.ListTailOrNull _ when alt.IsNullary -> + let baseTy = baseTyOfUnionSpec cuspec + [ I_ldsfld(Nonvolatile, mkConstFieldSpec altName baseTy) ] + // RepresentAlternativeAsFreshInstancesOfRootClass: list cons folds to root + | UnionLayout.ListTailOrNull _ -> + let baseTy = baseTyOfUnionSpec cuspec + let ctorFieldTys = alt.FieldTypes |> Array.toList + [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] + // RepresentAlternativeAsFreshInstancesOfRootClass: single non-nullary with null sibling + | UnionLayout.SmallRefUnion(_, nullCaseIdx) when isSingleNonNullaryFoldedToRoot cuspec nullCaseIdx alt -> + let baseTy = baseTyOfUnionSpec cuspec + let ctorFieldTys = alt.FieldTypes |> Array.toList + [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] + // Struct + IntegerTag + nullary: create via root ctor with tag + | UnionLayout.TaggedStructUnion _ when alt.IsNullary -> + let baseTy = baseTyOfUnionSpec cuspec + let tagField = [ mkTagFieldType ilg cuspec ] + [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] + // Default: use nested type ctor + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.ListTailOrNull _ + | UnionLayout.SmallRefUnion _ + | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedStructUnion _ -> [ mkNormalNewobj (mkILCtorMethSpecForTy (altTy, Array.toList alt.FieldTypes)) ] - instrs - @ [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, (ctorFieldTys @ tagfields))) ] - elif - cuspecRepr.RepresentAlternativeAsStructValue cuspec - && cuspecRepr.DiscriminationTechnique cuspec = IntegerTag - then - // Structs with fields should be created using maker methods (mkMakerName), only field-less cases are created this way - assert alt.IsNullary - let baseTy = baseTyOfUnionSpec cuspec - let tagField = [ mkTagFieldType ilg cuspec ] - [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] - else - [ mkNormalNewobj (mkILCtorMethSpecForTy (altTy, Array.toList alt.FieldTypes)) ] +let convNewDataInstrInternal ilg cuspec cidx = + emitRawConstruction ilg cuspec (classifyFromSpec cuspec) cidx // The stdata 'instruction' is only ever used for the F# "List" type within FSharp.Core.dll let mkStData (cuspec, cidx, fidx) = @@ -619,12 +638,10 @@ let mkStData (cuspec, cidx, fidx) = mkNormalStfld (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) let mkNewData ilg (cuspec, cidx) = -#if DEBUG - assertSpecClassification cuspec -#endif let alt = altOfUnionSpec cuspec cidx let altName = alt.Name let baseTy = baseTyOfUnionSpec cuspec + let layout = classifyFromSpec cuspec let viaMakerCall () = [ @@ -648,40 +665,60 @@ let mkNewData ilg (cuspec, cidx) = | AllHelpers | SpecialFSharpListHelpers | SpecialFSharpOptionHelpers -> - if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then - [ AI_ldnull ] - elif alt.IsNullary then + match layout, cidx with + | CaseIsNull -> [ AI_ldnull ] + | _ -> + if alt.IsNullary then + viaGetAltNameProperty () + else + viaMakerCall () + + | NoHelpers -> + let isStruct = + match layout with + | ValueTypeLayout -> true + | ReferenceTypeLayout -> false + + let isNull = + match layout, cidx with + | CaseIsNull -> true + | CaseIsAllocated -> false + + if not alt.IsNullary && isStruct then + viaMakerCall () + elif not isStruct && not isNull && alt.IsNullary then viaGetAltNameProperty () else - viaMakerCall () + emitRawConstruction ilg cuspec layout cidx - | NoHelpers when (not alt.IsNullary) && cuspecRepr.RepresentAlternativeAsStructValue cuspec -> viaMakerCall () - | NoHelpers when cuspecRepr.MaintainPossiblyUniqueConstantFieldForAlternative(cuspec, alt) -> viaGetAltNameProperty () - | NoHelpers -> convNewDataInstrInternal ilg cuspec cidx - -let mkIsData ilg (avoidHelpers, cuspec, cidx) = -#if DEBUG - assertSpecClassification cuspec -#endif +let private emitIsCase ilg avoidHelpers cuspec (layout: UnionLayout) cidx = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAlt cuspec alt let altName = alt.Name - if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then + match layout, cidx with + | CaseIsNull -> + // Null-represented case: compare with null [ AI_ldnull; AI_ceq ] - elif cuspecRepr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull(cuspec, alt) then - // in this case we can use a null test - [ AI_ldnull; AI_cgt_un ] - else - match cuspecRepr.DiscriminationTechnique cuspec with - | SingleCase -> [ mkLdcInt32 1 ] - | RuntimeTypes -> mkRuntimeTypeDiscriminate ilg avoidHelpers cuspec alt altName altTy - | IntegerTag -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx - | TailOrNull -> + | _ -> + match layout with + | UnionLayout.SmallRefUnion(_, nullCaseIdx) when isSingleNonNullaryFoldedToRoot cuspec nullCaseIdx alt -> + // Single non-nullary with all null siblings: test via non-null + [ AI_ldnull; AI_cgt_un ] + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ -> [ mkLdcInt32 1 ] + | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminate ilg avoidHelpers cuspec alt altName altTy + | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedStructUnion _ -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx + | UnionLayout.ListTailOrNull _ -> match cidx with | TagNil -> [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_ceq ] | TagCons -> [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_cgt_un ] - | _ -> failwith "mkIsData - unexpected" + | _ -> failwith "emitIsCase - unexpected list case index" + +let mkIsData ilg (avoidHelpers, cuspec, cidx) = + let layout = classifyFromSpec cuspec + emitIsCase ilg avoidHelpers cuspec layout cidx type ICodeGen<'Mark> = abstract CodeLabel: 'Mark -> ILCodeLabel @@ -718,36 +755,38 @@ let genWith g : ILCode = Locals = [] } -let mkBrIsData ilg sense (avoidHelpers, cuspec, cidx, tg) = -#if DEBUG - assertSpecClassification cuspec -#endif +let private emitBranchOnCase ilg sense avoidHelpers cuspec (layout: UnionLayout) cidx tg = let neg = (if sense then BI_brfalse else BI_brtrue) let pos = (if sense then BI_brtrue else BI_brfalse) let alt = altOfUnionSpec cuspec cidx let altTy = tyForAlt cuspec alt let altName = alt.Name - if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then + match layout, cidx with + | CaseIsNull -> + // Null-represented case: branch on null [ I_brcmp(neg, tg) ] - elif cuspecRepr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull(cuspec, alt) then - // in this case we can use a null test - [ I_brcmp(pos, tg) ] - else - match cuspecRepr.DiscriminationTechnique cuspec with - | SingleCase -> [] - | RuntimeTypes -> mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy (I_brcmp(pos, tg)) - | IntegerTag -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) - | TailOrNull -> + | _ -> + match layout with + | UnionLayout.SmallRefUnion(_, nullCaseIdx) when isSingleNonNullaryFoldedToRoot cuspec nullCaseIdx alt -> + // Single non-nullary with all null siblings: branch on non-null + [ I_brcmp(pos, tg) ] + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ -> [] + | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy (I_brcmp(pos, tg)) + | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedStructUnion _ -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) + | UnionLayout.ListTailOrNull _ -> match cidx with | TagNil -> [ mkGetTailOrNull avoidHelpers cuspec; I_brcmp(neg, tg) ] | TagCons -> [ mkGetTailOrNull avoidHelpers cuspec; I_brcmp(pos, tg) ] - | _ -> failwith "mkBrIsData - unexpected" + | _ -> failwith "emitBranchOnCase - unexpected list case index" + +let mkBrIsData ilg sense (avoidHelpers, cuspec, cidx, tg) = + let layout = classifyFromSpec cuspec + emitBranchOnCase ilg sense avoidHelpers cuspec layout cidx tg let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: IlxUnionSpec) = -#if DEBUG - assertSpecClassification cuspec -#endif // If helpers exist, use them match cuspec.HasHelpers with | SpecialFSharpListHelpers @@ -756,28 +795,28 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: Ilx cg.EmitInstr(mkGetTagFromHelpers ilg cuspec) | _ -> + let layout = classifyFromSpec cuspec let alts = cuspec.Alternatives - match cuspecRepr.DiscriminationTechnique cuspec with - | TailOrNull -> + match layout with + | UnionLayout.ListTailOrNull _ -> // leaves 1 if cons, 0 if not ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_cgt_un ] - | IntegerTag -> - let baseTy = baseTyOfUnionSpec cuspec + | UnionLayout.TaggedRefUnion(baseTy, _) + | UnionLayout.TaggedStructUnion(baseTy, _) -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstr(mkGetTagFromField ilg cuspec baseTy) - | SingleCase -> + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] - | RuntimeTypes -> - let baseTy = baseTyOfUnionSpec cuspec - + | UnionLayout.SmallRefUnion(baseTy, nullCaseIdx) -> + // RuntimeTypes: emit multi-way isinst chain let ld = match ldOpt with | None -> let locn = cg.GenLocal baseTy - // Add on a branch to the first input label. This gets optimized away by the printer/emitter. cg.EmitInstr(mkStloc locn) mkLdloc locn | Some i -> i @@ -788,16 +827,13 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: Ilx let alt = altOfUnionSpec cuspec cidx let internalLab = cg.GenerateDelayMark() let failLab = cg.GenerateDelayMark() - let cmpNull = cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) + let cmpNull = (nullCaseIdx = Some cidx) let test = I_brcmp((if cmpNull then BI_brtrue else BI_brfalse), cg.CodeLabel failLab) let testBlock = - if - cmpNull - || cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass(cuspec, alt) - then + if cmpNull || caseFoldsToRootClass layout cuspec alt then [ test ] else let altName = alt.Name @@ -820,13 +856,12 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: Ilx let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: IlxUnionSpec) = emitLdDataTagPrim ilg None cg (avoidHelpers, cuspec) -let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, avoidHelpers, cuspec, cidx) = -#if DEBUG - assertSpecClassification cuspec -#endif +let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail avoidHelpers cuspec (layout: UnionLayout) cidx = let alt = altOfUnionSpec cuspec cidx - if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then + match layout, cidx with + | CaseIsNull -> + // Null-represented case if canfail then let outlab = cg.GenerateDelayMark() let internal1 = cg.GenerateDelayMark() @@ -834,36 +869,55 @@ let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, avoidHelpers, cuspec, cidx) cg.SetMarkToHere internal1 cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] cg.SetMarkToHere outlab - else - // If it can't fail, it's still verifiable just to leave the value on the stack unchecked + | _ -> + match layout with + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedStructUnion _ -> + // Flatten (struct): tag check if canfail, else leave on stack + if canfail then + let outlab = cg.GenerateDelayMark() + let internal1 = cg.GenerateDelayMark() + cg.EmitInstr AI_dup + emitLdDataTagPrim ilg None cg (avoidHelpers, cuspec) + cg.EmitInstrs [ mkLdcInt32 cidx; I_brcmp(BI_beq, cg.CodeLabel outlab) ] + cg.SetMarkToHere internal1 + cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] + cg.SetMarkToHere outlab + | UnionLayout.ListTailOrNull _ -> + // List type: all cases fold to root, no cast needed () - elif cuspecRepr.Flatten cuspec then - if canfail then - let outlab = cg.GenerateDelayMark() - let internal1 = cg.GenerateDelayMark() - cg.EmitInstr AI_dup - emitLdDataTagPrim ilg None cg (avoidHelpers, cuspec) - cg.EmitInstrs [ mkLdcInt32 cidx; I_brcmp(BI_beq, cg.CodeLabel outlab) ] - cg.SetMarkToHere internal1 - cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] - cg.SetMarkToHere outlab - else - // If it can't fail, it's still verifiable just to leave the value on the stack unchecked + | UnionLayout.SingleCaseRef _ -> + // Single case ref: always on root () - elif cuspecRepr.OptimizeAlternativeToRootClass(cuspec, alt) then - () - else - let altTy = tyForAlt cuspec alt - cg.EmitInstr(I_castclass altTy) + | UnionLayout.TaggedRefUnion(_, allNullary) -> + if allNullary then + // All-nullary (enum-like): all cases on root + () + elif alt.IsNullary then + // Nullary in tagged ref: constant field in root class, no cast + () + else + // Non-nullary in tagged ref: lives in nested type + let altTy = tyForAlt cuspec alt + cg.EmitInstr(I_castclass altTy) + | UnionLayout.SmallRefUnion _ -> + if caseFoldsToRootClass layout cuspec alt then + // Single non-nullary with all null siblings: folded to root + () + else + // Case lives in a nested type + let altTy = tyForAlt cuspec alt + cg.EmitInstr(I_castclass altTy) -let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = -#if DEBUG - assertSpecClassification cuspec -#endif +let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, avoidHelpers, cuspec, cidx) = + let layout = classifyFromSpec cuspec + emitCastToCase ilg cg canfail avoidHelpers cuspec layout cidx + +let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) avoidHelpers cuspec (layout: UnionLayout) cases = let baseTy = baseTyOfUnionSpec cuspec - match cuspecRepr.DiscriminationTechnique cuspec with - | RuntimeTypes -> + match layout with + | UnionLayout.SmallRefUnion(_, nullCaseIdx) -> let locn = cg.GenLocal baseTy cg.EmitInstr(mkStloc locn) @@ -873,22 +927,20 @@ let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = let altTy = tyForAlt cuspec alt let altName = alt.Name let failLab = cg.GenerateDelayMark() - let cmpNull = cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) + let cmpNull = (nullCaseIdx = Some cidx) cg.EmitInstr(mkLdloc locn) let testInstr = I_brcmp((if cmpNull then BI_brfalse else BI_brtrue), tg) - if - cmpNull - || cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass(cuspec, alt) - then + if cmpNull || caseFoldsToRootClass layout cuspec alt then cg.EmitInstr testInstr else cg.EmitInstrs(mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy testInstr) cg.SetMarkToHere failLab - | IntegerTag -> + | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedStructUnion _ -> match cases with | [] -> cg.EmitInstr AI_pop | _ -> @@ -910,13 +962,18 @@ let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = cg.EmitInstr(I_switch(Array.toList dests)) cg.SetMarkToHere failLab - | SingleCase -> + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ -> match cases with | [ (0, tg) ] -> cg.EmitInstrs [ AI_pop; I_br tg ] | [] -> cg.EmitInstr AI_pop | _ -> failwith "unexpected: strange switch on single-case unions should not be present" - | TailOrNull -> failwith "unexpected: switches on lists should have been eliminated to brisdata tests" + | UnionLayout.ListTailOrNull _ -> failwith "unexpected: switches on lists should have been eliminated to brisdata tests" + +let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = + let layout = classifyFromSpec cuspec + emitCaseSwitch ilg cg avoidHelpers cuspec layout cases //--------------------------------------------------- // Generate the union classes @@ -1587,10 +1644,6 @@ let mkClassUnionDef let boxity = if td.IsStruct then ILBoxity.AsValue else ILBoxity.AsObject let baseTy = mkILFormalNamedTy boxity tref td.GenericParams -#if DEBUG - assertDefClassification td cud baseTy -#endif - let cuspec = IlxUnionSpec(IlxUnionRef(boxity, baseTy.TypeRef, cud.UnionCases, cud.IsNullPermitted, cud.HasHelpers), baseTy.GenericArgs) From 17a0cef69d5c3326f39e81b5d725df9bb45b7456 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 06:10:38 +0100 Subject: [PATCH 04/44] Decompose convAlternativeDef into focused sub-functions - Wire TypeDefContext into mkClassUnionDef for parameter bundling - Change return type from 6-element tuple to AlternativeDefResult record - Extract emitMakerMethod for non-nullary case maker methods - Extract emitTesterMethodAndProperty for Is* test methods/properties - Extract emitNullaryCaseAccessor for nullary case getter properties - Extract emitConstantAccessor for unique singleton object accessors - Extract emitNullaryConstField for nullary case static field definitions - Extract emitNestedAlternativeType for nested case type definitions - Rename convAlternativeDef to processAlternative (~46 lines) - Format with fantomas Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 818 ++++++++++++++-------------- 1 file changed, 417 insertions(+), 401 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index dd4dc2e3d7c..dc106beb035 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -1145,289 +1145,420 @@ let private emitDebugProxyType [ debugProxyTypeDef.WithSpecialName(true) ], ([ mkDebuggerTypeProxyAttribute debugProxyTy ] @ cud.DebugDisplayAttributes) -let convAlternativeDef - ( - addMethodGeneratedAttrs, - addPropertyGeneratedAttrs, - addPropertyNeverAttrs, - addFieldGeneratedAttrs, - addFieldNeverAttrs, - mkDebuggerTypeProxyAttribute - ) - (g: TcGlobals) - num - (td: ILTypeDef) - (cud: IlxUnionInfo) - info - cuspec - (baseTy: ILType) - (alt: IlxUnionCase) - = - - let imports = cud.DebugImports - let attr = cud.DebugPoint - let altName = alt.Name +let private emitMakerMethod (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = + let g = ctx.g + let baseTy = ctx.baseTy + let cuspec = ctx.cuspec + let cud = ctx.cud let fields = alt.FieldDefs - let altTy = tyForAlt cuspec alt + let altName = alt.Name + let info = (ctx.td, cud) let repr = cudefRepr + let imports = cud.DebugImports + let attr = cud.DebugPoint - // Attributes on unions get attached to the construction methods in the helpers - let addAltAttribs (mdef: ILMethodDef) = - mdef.With(customAttrs = alt.altCustomAttrs) + let locals, ilInstrs = + if repr.RepresentAlternativeAsStructValue info then + let local = mkILLocal baseTy None + let ldloca = I_ldloca(0us) - // The stdata instruction is only ever used for the F# "List" type - // - // Microsoft.FSharp.Collections.List`1 is indeed logically immutable, but we use mutation on this type internally - // within FSharp.Core.dll on fresh unpublished cons cells. - let isTotallyImmutable = (cud.HasHelpers <> SpecialFSharpListHelpers) + let ilInstrs = + [ + ldloca + ILInstr.I_initobj baseTy + if (repr.DiscriminationTechnique info) = IntegerTag && num <> 0 then + ldloca + mkLdcInt32 num + mkSetTagToField g.ilg cuspec baseTy + for i in 0 .. fields.Length - 1 do + ldloca + mkLdarg (uint16 i) + mkNormalStfld (mkILFieldSpecInTy (baseTy, fields[i].LowerName, fields[i].Type)) + mkLdloc 0us + ] - let makeNonNullaryMakerMethod () = - let locals, ilInstrs = - if repr.RepresentAlternativeAsStructValue info then - let local = mkILLocal baseTy None - let ldloca = I_ldloca(0us) + [ local ], ilInstrs + else + let ilInstrs = + [ + for i in 0 .. fields.Length - 1 do + mkLdarg (uint16 i) + yield! convNewDataInstrInternal g.ilg cuspec num + ] + + [], ilInstrs + + mkILNonGenericStaticMethod ( + mkMakerName cuspec altName, + cud.HelpersAccessibility, + fields + |> Array.map (fun fd -> + let plainParam = mkILParamNamed (fd.LowerName, fd.Type) + + match getFieldsNullability g fd.ILField with + | None -> plainParam + | Some a -> + { plainParam with + CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrsFromArray [| a |]) + }) + + |> Array.toList, + mkILReturn baseTy, + mkMethodBody (true, locals, fields.Length + locals.Length, nonBranchingInstrsToCode ilInstrs, attr, imports) + ) + |> (fun mdef -> mdef.With(customAttrs = alt.altCustomAttrs)) + |> ctx.stampMethodAsGenerated + +let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = + let g = ctx.g + let cud = ctx.cud + let cuspec = ctx.cuspec + let baseTy = ctx.baseTy + let info = (ctx.td, cud) + let repr = cudefRepr + let altName = alt.Name + let imports = cud.DebugImports + let attr = cud.DebugPoint + + if cud.UnionCases.Length <= 1 then + [], [] + elif repr.RepresentOneAlternativeAsNull info then + [], [] + else + let additionalAttributes = + if + g.checkNullness + && g.langFeatureNullness + && repr.RepresentAlternativeAsStructValue info + && not alt.IsNullary + then + let notnullfields = + alt.FieldDefs + // Fields that are nullable even from F# perspective has an [Nullable] attribute on them + // Non-nullable fields are implicit in F#, therefore not annotated separately + |> Array.filter (fun f -> + f.ILField.HasWellKnownAttribute(g, WellKnownILAttributes.NullableAttribute) + |> not) + + let fieldNames = + notnullfields + |> Array.map (fun f -> f.LowerName) + |> Array.append (notnullfields |> Array.map (fun f -> f.Name)) + + if fieldNames |> Array.isEmpty then + emptyILCustomAttrs + else + mkILCustomAttrsFromArray [| GetNotNullWhenTrueAttribute g fieldNames |] - let ilInstrs = - [ - ldloca - ILInstr.I_initobj baseTy - if (repr.DiscriminationTechnique info) = IntegerTag && num <> 0 then - ldloca - mkLdcInt32 num - mkSetTagToField g.ilg cuspec baseTy - for i in 0 .. fields.Length - 1 do - ldloca - mkLdarg (uint16 i) - mkNormalStfld (mkILFieldSpecInTy (baseTy, fields[i].LowerName, fields[i].Type)) - mkLdloc 0us - ] - - [ local ], ilInstrs else - let ilInstrs = - [ - for i in 0 .. fields.Length - 1 do - mkLdarg (uint16 i) - yield! convNewDataInstrInternal g.ilg cuspec num - ] - - [], ilInstrs - - let mdef = - mkILNonGenericStaticMethod ( - mkMakerName cuspec altName, + emptyILCustomAttrs + + [ + (mkILNonGenericInstanceMethod ( + "get_" + mkTesterName altName, cud.HelpersAccessibility, - fields - |> Array.map (fun fd -> - let plainParam = mkILParamNamed (fd.LowerName, fd.Type) - - match getFieldsNullability g fd.ILField with - | None -> plainParam - | Some a -> - { plainParam with - CustomAttrsStored = storeILCustomAttrs (mkILCustomAttrsFromArray [| a |]) - }) - - |> Array.toList, - mkILReturn baseTy, - mkMethodBody (true, locals, fields.Length + locals.Length, nonBranchingInstrsToCode ilInstrs, attr, imports) + [], + mkILReturn g.ilg.typ_Bool, + mkMethodBody (true, [], 2, nonBranchingInstrsToCode ([ mkLdarg0 ] @ mkIsData g.ilg (true, cuspec, num)), attr, imports) + )) + .With(customAttrs = additionalAttributes) + |> ctx.stampMethodAsGenerated + ], + [ + ILPropertyDef( + name = mkTesterName altName, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some(mkILMethRef (baseTy.TypeRef, ILCallingConv.Instance, "get_" + mkTesterName altName, 0, [], g.ilg.typ_Bool)), + callingConv = ILThisConvention.Instance, + propertyType = g.ilg.typ_Bool, + init = None, + args = [], + customAttrs = additionalAttributes ) - |> addAltAttribs - |> addMethodGeneratedAttrs + |> ctx.stampPropertyAsGenerated + |> ctx.stampPropertyAsNever + ] - mdef +let private emitNullaryCaseAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = + let g = ctx.g + let td = ctx.td + let cud = ctx.cud + let cuspec = ctx.cuspec + let baseTy = ctx.baseTy + let info = (td, cud) + let repr = cudefRepr + let altName = alt.Name + let fields = alt.FieldDefs + let imports = cud.DebugImports + let attr = cud.DebugPoint - let altUniqObjMeths = + let attributes = + if + g.checkNullness + && g.langFeatureNullness + && repr.RepresentAlternativeAsNull(info, alt) + then + let noTypars = td.GenericParams.Length - // This method is only generated if helpers are not available. It fetches the unique object for the alternative - // without exposing direct access to the underlying field - match cud.HasHelpers with - | AllHelpers - | SpecialFSharpOptionHelpers - | SpecialFSharpListHelpers -> [] - | _ -> - if - alt.IsNullary - && repr.MaintainPossiblyUniqueConstantFieldForAlternative(info, alt) - then - let methName = "get_" + altName + GetNullableAttribute + g + [ + yield NullnessInfo.WithNull // The top-level value itself, e.g. option, is nullable + yield! List.replicate noTypars NullnessInfo.AmbivalentToNull + ] // The typars are not (i.e. do not change option into option + |> Array.singleton + |> mkILCustomAttrsFromArray + else + emptyILCustomAttrs - let meth = - mkILNonGenericStaticMethod ( - methName, - cud.UnionCasesAccessibility, + let nullaryMeth = + mkILNonGenericStaticMethod ( + "get_" + altName, + cud.HelpersAccessibility, + [], + (mkILReturn baseTy).WithCustomAttrs attributes, + mkMethodBody (true, [], fields.Length, nonBranchingInstrsToCode (convNewDataInstrInternal g.ilg cuspec num), attr, imports) + ) + |> (fun mdef -> mdef.With(customAttrs = alt.altCustomAttrs)) + |> ctx.stampMethodAsGenerated + + let nullaryProp = + ILPropertyDef( + name = altName, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some(mkILMethRef (baseTy.TypeRef, ILCallingConv.Static, "get_" + altName, 0, [], baseTy)), + callingConv = ILThisConvention.Static, + propertyType = baseTy, + init = None, + args = [], + customAttrs = attributes + ) + |> ctx.stampPropertyAsGenerated + |> ctx.stampPropertyAsNever + + [ nullaryMeth ], [ nullaryProp ] + +let private emitConstantAccessor (ctx: TypeDefContext) (_num: int) (alt: IlxUnionCase) = + let cud = ctx.cud + let baseTy = ctx.baseTy + let info = (ctx.td, cud) + let repr = cudefRepr + let altName = alt.Name + let fields = alt.FieldDefs + let imports = cud.DebugImports + let attr = cud.DebugPoint + + // This method is only generated if helpers are not available. It fetches the unique object for the alternative + // without exposing direct access to the underlying field + match cud.HasHelpers with + | AllHelpers + | SpecialFSharpOptionHelpers + | SpecialFSharpListHelpers -> [] + | _ -> + if + alt.IsNullary + && repr.MaintainPossiblyUniqueConstantFieldForAlternative(info, alt) + then + let methName = "get_" + altName + + let meth = + mkILNonGenericStaticMethod ( + methName, + cud.UnionCasesAccessibility, + [], + mkILReturn baseTy, + mkMethodBody ( + true, [], - mkILReturn baseTy, - mkMethodBody ( - true, - [], - fields.Length, - nonBranchingInstrsToCode [ I_ldsfld(Nonvolatile, mkConstFieldSpec altName baseTy) ], - attr, - imports - ) + fields.Length, + nonBranchingInstrsToCode [ I_ldsfld(Nonvolatile, mkConstFieldSpec altName baseTy) ], + attr, + imports ) - |> addMethodGeneratedAttrs + ) + |> ctx.stampMethodAsGenerated + + [ meth ] + + else + [] + +let private emitNullaryConstField (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = + let cud = ctx.cud + let baseTy = ctx.baseTy + let cuspec = ctx.cuspec + let info = (ctx.td, cud) + let repr = cudefRepr + let altName = alt.Name + let altTy = tyForAlt cuspec alt - [ meth ] + if repr.MaintainPossiblyUniqueConstantFieldForAlternative(info, alt) then + let basic: ILFieldDef = + mkILStaticField (constFieldName altName, baseTy, None, None, ILMemberAccess.Assembly) + |> ctx.stampFieldAsNever + |> ctx.stampFieldAsGenerated + let uniqObjField = basic.WithInitOnly(true) + let inRootClass = cuspecRepr.OptimizeAlternativeToRootClass(cuspec, alt) + [ (info, alt, altTy, num, uniqObjField, inRootClass) ] + else + [] + +let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = + let g = ctx.g + let td = ctx.td + let cud = ctx.cud + let cuspec = ctx.cuspec + let baseTy = ctx.baseTy + let info = (td, cud) + let repr = cudefRepr + let altTy = tyForAlt cuspec alt + let fields = alt.FieldDefs + let imports = cud.DebugImports + let attr = cud.DebugPoint + let isTotallyImmutable = (cud.HasHelpers <> SpecialFSharpListHelpers) + + if repr.OptimizeAlternativeToRootClass(info, alt) then + [], [] + else + let altDebugTypeDefs, debugAttrs = + if not cud.GenerateDebugProxies then + [], [] else - [] + emitDebugProxyType + g + td + altTy + fields + baseTy + imports + ctx.stampMethodAsGenerated + ctx.stampPropertyAsGenerated + ctx.stampFieldAsNever + ctx.stampFieldAsGenerated + ctx.mkDebuggerTypeProxyAttr + cud + + let altTypeDef = + let basicFields = + fields + |> Array.map (fun field -> + let fldName, fldTy, attrs = mkUnionCaseFieldIdAndAttrs g field + let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Assembly) - let baseMakerMeths, baseMakerProps = + let fdef = + match attrs with + | [] -> fdef + | attrs -> fdef.With(customAttrs = mkILCustomAttrs attrs) - match cud.HasHelpers with - | AllHelpers - | SpecialFSharpOptionHelpers - | SpecialFSharpListHelpers -> + |> ctx.stampFieldAsNever + |> ctx.stampFieldAsGenerated - let baseTesterMeths, baseTesterProps = - if cud.UnionCases.Length <= 1 then - [], [] - elif repr.RepresentOneAlternativeAsNull info then - [], [] - else - let additionalAttributes = - if - g.checkNullness - && g.langFeatureNullness - && repr.RepresentAlternativeAsStructValue info - && not alt.IsNullary - then - let notnullfields = - alt.FieldDefs - // Fields that are nullable even from F# perspective has an [Nullable] attribute on them - // Non-nullable fields are implicit in F#, therefore not annotated separately - |> Array.filter (fun f -> - f.ILField.HasWellKnownAttribute(g, WellKnownILAttributes.NullableAttribute) - |> not) - - let fieldNames = - notnullfields - |> Array.map (fun f -> f.LowerName) - |> Array.append (notnullfields |> Array.map (fun f -> f.Name)) - - if fieldNames |> Array.isEmpty then - emptyILCustomAttrs - else - mkILCustomAttrsFromArray [| GetNotNullWhenTrueAttribute g fieldNames |] + fdef.WithInitOnly(isTotallyImmutable)) - else - emptyILCustomAttrs + |> Array.toList - [ - (mkILNonGenericInstanceMethod ( - "get_" + mkTesterName altName, - cud.HelpersAccessibility, - [], - mkILReturn g.ilg.typ_Bool, - mkMethodBody ( - true, - [], - 2, - nonBranchingInstrsToCode ([ mkLdarg0 ] @ mkIsData g.ilg (true, cuspec, num)), - attr, - imports - ) - )) - .With(customAttrs = additionalAttributes) - |> addMethodGeneratedAttrs - ], - [ - ILPropertyDef( - name = mkTesterName altName, - attributes = PropertyAttributes.None, - setMethod = None, - getMethod = - Some( - mkILMethRef ( - baseTy.TypeRef, - ILCallingConv.Instance, - "get_" + mkTesterName altName, - 0, - [], - g.ilg.typ_Bool - ) - ), - callingConv = ILThisConvention.Instance, - propertyType = g.ilg.typ_Bool, - init = None, - args = [], - customAttrs = additionalAttributes - ) - |> addPropertyGeneratedAttrs - |> addPropertyNeverAttrs - ] + let basicProps, basicMethods = + mkMethodsAndPropertiesForFields + (ctx.stampMethodAsGenerated, ctx.stampPropertyAsGenerated) + g + cud.UnionCasesAccessibility + attr + imports + cud.HasHelpers + altTy + fields - let baseMakerMeths, baseMakerProps = + let basicCtorInstrs = + [ + yield mkLdarg0 + match repr.DiscriminationTechnique info with + | IntegerTag -> + yield mkLdcInt32 num + yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [ mkTagFieldType g.ilg cuspec ])) + | SingleCase + | RuntimeTypes -> yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [])) + | TailOrNull -> failwith "unreachable" + ] - if alt.IsNullary then - let attributes = - if - g.checkNullness - && g.langFeatureNullness - && repr.RepresentAlternativeAsNull(info, alt) - then - let noTypars = td.GenericParams.Length - - GetNullableAttribute - g - [ - yield NullnessInfo.WithNull // The top-level value itself, e.g. option, is nullable - yield! List.replicate noTypars NullnessInfo.AmbivalentToNull - ] // The typars are not (i.e. do not change option into option - |> Array.singleton - |> mkILCustomAttrsFromArray + let basicCtorAccess = + (if cuspec.HasHelpers = AllHelpers then + ILMemberAccess.Assembly + else + cud.UnionCasesAccessibility) + + let basicCtorFields = + basicFields + |> List.map (fun fdef -> + let nullableAttr = getFieldsNullability g fdef |> Option.toList + fdef.Name, fdef.FieldType, nullableAttr) + + let basicCtorMeth = + (mkILStorageCtor (basicCtorInstrs, altTy, basicCtorFields, basicCtorAccess, attr, imports)) + .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) + |> ctx.stampMethodAsGenerated + + let attrs = + if g.checkNullness && g.langFeatureNullness then + GetNullableContextAttribute g 1uy :: debugAttrs + else + debugAttrs + + let altTypeDef = + mkILGenericClass ( + altTy.TypeSpec.Name, + // Types for nullary's become private, they also have names like _Empty + ILTypeDefAccess.Nested( + if alt.IsNullary && cud.HasHelpers = IlxUnionHasHelpers.AllHelpers then + ILMemberAccess.Assembly else - emptyILCustomAttrs + cud.UnionCasesAccessibility + ), + td.GenericParams, + baseTy, + [], + mkILMethods ([ basicCtorMeth ] @ basicMethods), + mkILFields basicFields, + emptyILTypeDefs, + mkILProperties basicProps, + emptyILEvents, + mkILCustomAttrs attrs, + ILTypeInit.BeforeField + ) - let nullaryMeth = - mkILNonGenericStaticMethod ( - "get_" + altName, - cud.HelpersAccessibility, - [], - (mkILReturn baseTy).WithCustomAttrs attributes, - mkMethodBody ( - true, - [], - fields.Length, - nonBranchingInstrsToCode (convNewDataInstrInternal g.ilg cuspec num), - attr, - imports - ) - ) - |> addAltAttribs - |> addMethodGeneratedAttrs - - let nullaryProp = - - ILPropertyDef( - name = altName, - attributes = PropertyAttributes.None, - setMethod = None, - getMethod = Some(mkILMethRef (baseTy.TypeRef, ILCallingConv.Static, "get_" + altName, 0, [], baseTy)), - callingConv = ILThisConvention.Static, - propertyType = baseTy, - init = None, - args = [], - customAttrs = attributes - ) - |> addPropertyGeneratedAttrs - |> addPropertyNeverAttrs + altTypeDef.WithSpecialName(true).WithSerializable(td.IsSerializable) + + [ altTypeDef ], altDebugTypeDefs - [ nullaryMeth ], [ nullaryProp ] +let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = + let cud = ctx.cud + let cuspec = ctx.cuspec + let info = (ctx.td, cud) + let repr = cudefRepr + let constantAccessors = emitConstantAccessor ctx num alt + + let baseMakerMeths, baseMakerProps = + match cud.HasHelpers with + | AllHelpers + | SpecialFSharpOptionHelpers + | SpecialFSharpListHelpers -> + let testerMeths, testerProps = emitTesterMethodAndProperty ctx num alt + + let makerMeths, makerProps = + if alt.IsNullary then + emitNullaryCaseAccessor ctx num alt else - [ makeNonNullaryMakerMethod () ], [] + [ emitMakerMethod ctx num alt ], [] - (baseMakerMeths @ baseTesterMeths), (baseMakerProps @ baseTesterProps) + (makerMeths @ testerMeths), (makerProps @ testerProps) - | NoHelpers when not alt.IsNullary && cuspecRepr.RepresentAlternativeAsStructValue(cuspec) -> - // For non-nullary struct DUs, maker method is used to create their values. - [ makeNonNullaryMakerMethod () ], [] + | NoHelpers when not alt.IsNullary && cuspecRepr.RepresentAlternativeAsStructValue(cuspec) -> [ emitMakerMethod ctx num alt ], [] | NoHelpers -> [], [] - let typeDefs, altDebugTypeDefs, altNullaryFields = + let typeDefs, debugTypeDefs, nullaryFields = if repr.RepresentAlternativeAsNull(info, alt) then [], [], [] elif repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt) then @@ -1435,136 +1566,18 @@ let convAlternativeDef elif repr.RepresentAlternativeAsStructValue info then [], [], [] else - let altNullaryFields = - if repr.MaintainPossiblyUniqueConstantFieldForAlternative(info, alt) then - let basic: ILFieldDef = - mkILStaticField (constFieldName altName, baseTy, None, None, ILMemberAccess.Assembly) - |> addFieldNeverAttrs - |> addFieldGeneratedAttrs - - let uniqObjField = basic.WithInitOnly(true) - let inRootClass = cuspecRepr.OptimizeAlternativeToRootClass(cuspec, alt) - [ (info, alt, altTy, num, uniqObjField, inRootClass) ] - else - [] + let nullaryFields = emitNullaryConstField ctx num alt + let typeDefs, debugTypeDefs = emitNestedAlternativeType ctx num alt + typeDefs, debugTypeDefs, nullaryFields - let typeDefs, altDebugTypeDefs = - if repr.OptimizeAlternativeToRootClass(info, alt) then - [], [] - else - - let altDebugTypeDefs, debugAttrs = - if not cud.GenerateDebugProxies then - [], [] - else - emitDebugProxyType - g - td - altTy - fields - baseTy - imports - addMethodGeneratedAttrs - addPropertyGeneratedAttrs - addFieldNeverAttrs - addFieldGeneratedAttrs - mkDebuggerTypeProxyAttribute - cud - - let altTypeDef = - let basicFields = - fields - |> Array.map (fun field -> - let fldName, fldTy, attrs = mkUnionCaseFieldIdAndAttrs g field - let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Assembly) - - let fdef = - match attrs with - | [] -> fdef - | attrs -> fdef.With(customAttrs = mkILCustomAttrs attrs) - - |> addFieldNeverAttrs - |> addFieldGeneratedAttrs - - fdef.WithInitOnly(isTotallyImmutable)) - - |> Array.toList - - let basicProps, basicMethods = - mkMethodsAndPropertiesForFields - (addMethodGeneratedAttrs, addPropertyGeneratedAttrs) - g - cud.UnionCasesAccessibility - attr - imports - cud.HasHelpers - altTy - fields - - let basicCtorInstrs = - [ - yield mkLdarg0 - match repr.DiscriminationTechnique info with - | IntegerTag -> - yield mkLdcInt32 num - yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [ mkTagFieldType g.ilg cuspec ])) - | SingleCase - | RuntimeTypes -> yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [])) - | TailOrNull -> failwith "unreachable" - ] - - let basicCtorAccess = - (if cuspec.HasHelpers = AllHelpers then - ILMemberAccess.Assembly - else - cud.UnionCasesAccessibility) - - let basicCtorFields = - basicFields - |> List.map (fun fdef -> - let nullableAttr = getFieldsNullability g fdef |> Option.toList - fdef.Name, fdef.FieldType, nullableAttr) - - let basicCtorMeth = - (mkILStorageCtor (basicCtorInstrs, altTy, basicCtorFields, basicCtorAccess, attr, imports)) - .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) - |> addMethodGeneratedAttrs - - let attrs = - if g.checkNullness && g.langFeatureNullness then - GetNullableContextAttribute g 1uy :: debugAttrs - else - debugAttrs - - let altTypeDef = - mkILGenericClass ( - altTy.TypeSpec.Name, - // Types for nullary's become private, they also have names like _Empty - ILTypeDefAccess.Nested( - if alt.IsNullary && cud.HasHelpers = IlxUnionHasHelpers.AllHelpers then - ILMemberAccess.Assembly - else - cud.UnionCasesAccessibility - ), - td.GenericParams, - baseTy, - [], - mkILMethods ([ basicCtorMeth ] @ basicMethods), - mkILFields basicFields, - emptyILTypeDefs, - mkILProperties basicProps, - emptyILEvents, - mkILCustomAttrs attrs, - ILTypeInit.BeforeField - ) - - altTypeDef.WithSpecialName(true).WithSerializable(td.IsSerializable) - - [ altTypeDef ], altDebugTypeDefs - - typeDefs, altDebugTypeDefs, altNullaryFields - - baseMakerMeths, baseMakerProps, altUniqObjMeths, typeDefs, altDebugTypeDefs, altNullaryFields + { + BaseMakerMethods = baseMakerMeths + BaseMakerProperties = baseMakerProps + ConstantAccessors = constantAccessors + NestedTypeDefs = typeDefs + DebugProxyTypeDefs = debugTypeDefs + NullaryConstFields = nullaryFields + } /// Rewrite field nullable attributes for struct flattening. /// When a struct DU has multiple cases, all boxed fields become potentially nullable @@ -1651,32 +1664,35 @@ let mkClassUnionDef let repr = cudefRepr let isTotallyImmutable = (cud.HasHelpers <> SpecialFSharpListHelpers) + let layout = classifyFromDef td cud baseTy + + let ctx = + { + g = g + layout = layout + cuspec = cuspec + cud = cud + td = td + baseTy = baseTy + stampMethodAsGenerated = addMethodGeneratedAttrs + stampPropertyAsGenerated = addPropertyGeneratedAttrs + stampPropertyAsNever = addPropertyNeverAttrs + stampFieldAsGenerated = addFieldGeneratedAttrs + stampFieldAsNever = addFieldNeverAttrs + mkDebuggerTypeProxyAttr = mkDebuggerTypeProxyAttribute + } + let results = cud.UnionCases |> List.ofArray - |> List.mapi (fun i alt -> - convAlternativeDef - (addMethodGeneratedAttrs, - addPropertyGeneratedAttrs, - addPropertyNeverAttrs, - addFieldGeneratedAttrs, - addFieldNeverAttrs, - mkDebuggerTypeProxyAttribute) - g - i - td - cud - info - cuspec - baseTy - alt) - - let baseMethsFromAlt = results |> List.collect (fun (a, _, _, _, _, _) -> a) - let basePropsFromAlt = results |> List.collect (fun (_, a, _, _, _, _) -> a) - let altUniqObjMeths = results |> List.collect (fun (_, _, a, _, _, _) -> a) - let altTypeDefs = results |> List.collect (fun (_, _, _, a, _, _) -> a) - let altDebugTypeDefs = results |> List.collect (fun (_, _, _, _, a, _) -> a) - let altNullaryFields = results |> List.collect (fun (_, _, _, _, _, a) -> a) + |> List.mapi (fun i alt -> processAlternative ctx i alt) + + let baseMethsFromAlt = results |> List.collect (fun r -> r.BaseMakerMethods) + let basePropsFromAlt = results |> List.collect (fun r -> r.BaseMakerProperties) + let altUniqObjMeths = results |> List.collect (fun r -> r.ConstantAccessors) + let altTypeDefs = results |> List.collect (fun r -> r.NestedTypeDefs) + let altDebugTypeDefs = results |> List.collect (fun r -> r.DebugProxyTypeDefs) + let altNullaryFields = results |> List.collect (fun r -> r.NullaryConstFields) let tagFieldsInObject = match repr.DiscriminationTechnique info with From ed79b63f430c681f1951072c06a9dc14e5d00efc Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 06:55:42 +0100 Subject: [PATCH 05/44] Decompose mkClassUnionDef into focused sub-functions Extract emitRootClassFields, emitRootConstructors, emitConstFieldInitializers, emitTagInfrastructure, assembleUnionTypeDef, computeSelfAndTagFields, and computeEnumTypeDef from the monolithic mkClassUnionDef function. The main function is now a 54-line orchestrator that delegates to these helpers. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 573 +++++++++++++++------------- 1 file changed, 313 insertions(+), 260 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index dc106beb035..6e92757b440 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -1640,68 +1640,18 @@ let private rootTypeNullableAttrs (g: TcGlobals) (td: ILTypeDef) (cud: IlxUnionI else td.CustomAttrsStored -let mkClassUnionDef - ( - addMethodGeneratedAttrs, - addPropertyGeneratedAttrs, - addPropertyNeverAttrs, - addFieldGeneratedAttrs: ILFieldDef -> ILFieldDef, - addFieldNeverAttrs: ILFieldDef -> ILFieldDef, - mkDebuggerTypeProxyAttribute - ) - (g: TcGlobals) - tref - (td: ILTypeDef) - cud - = - let boxity = if td.IsStruct then ILBoxity.AsValue else ILBoxity.AsObject - let baseTy = mkILFormalNamedTy boxity tref td.GenericParams - - let cuspec = - IlxUnionSpec(IlxUnionRef(boxity, baseTy.TypeRef, cud.UnionCases, cud.IsNullPermitted, cud.HasHelpers), baseTy.GenericArgs) - - let info = (td, cud) - let repr = cudefRepr - let isTotallyImmutable = (cud.HasHelpers <> SpecialFSharpListHelpers) - - let layout = classifyFromDef td cud baseTy - - let ctx = - { - g = g - layout = layout - cuspec = cuspec - cud = cud - td = td - baseTy = baseTy - stampMethodAsGenerated = addMethodGeneratedAttrs - stampPropertyAsGenerated = addPropertyGeneratedAttrs - stampPropertyAsNever = addPropertyNeverAttrs - stampFieldAsGenerated = addFieldGeneratedAttrs - stampFieldAsNever = addFieldNeverAttrs - mkDebuggerTypeProxyAttr = mkDebuggerTypeProxyAttribute - } - - let results = - cud.UnionCases - |> List.ofArray - |> List.mapi (fun i alt -> processAlternative ctx i alt) - - let baseMethsFromAlt = results |> List.collect (fun r -> r.BaseMakerMethods) - let basePropsFromAlt = results |> List.collect (fun r -> r.BaseMakerProperties) - let altUniqObjMeths = results |> List.collect (fun r -> r.ConstantAccessors) - let altTypeDefs = results |> List.collect (fun r -> r.NestedTypeDefs) - let altDebugTypeDefs = results |> List.collect (fun r -> r.DebugProxyTypeDefs) - let altNullaryFields = results |> List.collect (fun r -> r.NullaryConstFields) - - let tagFieldsInObject = - match repr.DiscriminationTechnique info with - | SingleCase - | RuntimeTypes - | TailOrNull -> [] - | IntegerTag -> [ let n, t = mkTagFieldId g.ilg cuspec in n, t, [] ] - +/// Compute fields, methods, and properties that live on the root class. +/// For struct DUs, all fields are flattened onto root. For ref DUs, only +/// cases that fold to root (list Cons, single-non-nullary-with-null-siblings). +let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (string * ILType * 'a list) list) = + let g = ctx.g + let td = ctx.td + let cud = ctx.cud + let baseTy = ctx.baseTy + let cuspec = ctx.cuspec let isStruct = td.IsStruct + let repr = cudefRepr + let info = (td, cud) let ctorAccess = if cuspec.HasHelpers = AllHelpers then @@ -1709,131 +1659,129 @@ let mkClassUnionDef else cud.UnionCasesAccessibility - let selfFields, selfMeths, selfProps = + [ + let minNullaryIdx = + cud.UnionCases + |> Array.tryFindIndex (fun t -> t.IsNullary) + |> Option.defaultValue -1 - [ - let minNullaryIdx = - cud.UnionCases - |> Array.tryFindIndex (fun t -> t.IsNullary) - |> Option.defaultValue -1 - - let fieldsEmitted = HashSet<_>() - - for cidx, alt in Array.indexed cud.UnionCases do - if - repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt) - || repr.RepresentAlternativeAsStructValue info - then - - let baseInit = - if isStruct then - None - else - match td.Extends.Value with - | None -> Some g.ilg.typ_Object.TypeSpec - | Some ilTy -> Some ilTy.TypeSpec - - let ctor = - // Structs with fields are created using static makers methods - // Structs without fields can share constructor for the 'tag' value, we just create one - if isStruct && not (cidx = minNullaryIdx) then - [] - else - let fields = - alt.FieldDefs |> Array.map (mkUnionCaseFieldIdAndAttrs g) |> Array.toList - - [ - (mkILSimpleStorageCtor ( - baseInit, - baseTy, - [], - (fields @ tagFieldsInObject), - ctorAccess, - cud.DebugPoint, - cud.DebugImports - )) - .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) - |> addMethodGeneratedAttrs - ] - - let fieldDefs = rewriteFieldsForStructFlattening g cud alt isStruct - - let fieldsToBeAddedIntoType = - fieldDefs - |> Array.filter (fun f -> fieldsEmitted.Add(struct (f.LowerName, f.Type))) - - let fields = - fieldsToBeAddedIntoType - |> Array.map (mkUnionCaseFieldIdAndAttrs g) - |> Array.toList + let fieldsEmitted = HashSet<_>() - let props, meths = - mkMethodsAndPropertiesForFields - (addMethodGeneratedAttrs, addPropertyGeneratedAttrs) - g - cud.UnionCasesAccessibility - cud.DebugPoint - cud.DebugImports - cud.HasHelpers - baseTy - fieldsToBeAddedIntoType + for cidx, alt in Array.indexed cud.UnionCases do + if + repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt) + || repr.RepresentAlternativeAsStructValue info + then - yield (fields, (ctor @ meths), props) - ] - |> List.unzip3 - |> (fun (a, b, c) -> List.concat a, List.concat b, List.concat c) + let baseInit = + if isStruct then + None + else + match td.Extends.Value with + | None -> Some g.ilg.typ_Object.TypeSpec + | Some ilTy -> Some ilTy.TypeSpec + + let ctor = + // Structs with fields are created using static makers methods + // Structs without fields can share constructor for the 'tag' value, we just create one + if isStruct && not (cidx = minNullaryIdx) then + [] + else + let fields = + alt.FieldDefs |> Array.map (mkUnionCaseFieldIdAndAttrs g) |> Array.toList + + [ + (mkILSimpleStorageCtor ( + baseInit, + baseTy, + [], + (fields @ tagFieldsInObject), + ctorAccess, + cud.DebugPoint, + cud.DebugImports + )) + .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) + |> ctx.stampMethodAsGenerated + ] + + let fieldDefs = rewriteFieldsForStructFlattening g cud alt isStruct + + let fieldsToBeAddedIntoType = + fieldDefs + |> Array.filter (fun f -> fieldsEmitted.Add(struct (f.LowerName, f.Type))) + + let fields = + fieldsToBeAddedIntoType + |> Array.map (mkUnionCaseFieldIdAndAttrs g) + |> Array.toList + + let props, meths = + mkMethodsAndPropertiesForFields + (ctx.stampMethodAsGenerated, ctx.stampPropertyAsGenerated) + g + cud.UnionCasesAccessibility + cud.DebugPoint + cud.DebugImports + cud.HasHelpers + baseTy + fieldsToBeAddedIntoType - let selfAndTagFields = - [ - for fldName, fldTy, attrs in (selfFields @ tagFieldsInObject) do - let fdef = - let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Assembly) + yield (fields, (ctor @ meths), props) + ] + |> List.unzip3 + |> (fun (a, b, c) -> List.concat a, List.concat b, List.concat c) - match attrs with - | [] -> fdef - | attrs -> fdef.With(customAttrs = mkILCustomAttrs attrs) +/// Compute the root class default constructor (when needed). +let private emitRootConstructors (ctx: TypeDefContext) selfFields tagFieldsInObject selfMeths = + let g = ctx.g + let td = ctx.td + let cud = ctx.cud + let baseTy = ctx.baseTy + let repr = cudefRepr + let info = (td, cud) - |> addFieldNeverAttrs - |> addFieldGeneratedAttrs + if + (List.isEmpty selfFields + && List.isEmpty tagFieldsInObject + && not (List.isEmpty selfMeths)) + || td.IsStruct + || cud.UnionCases + |> Array.forall (fun alt -> repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt)) + then + [] + else + let baseTySpec = + (match td.Extends.Value with + | None -> g.ilg.typ_Object + | Some ilTy -> ilTy) + .TypeSpec - yield fdef.WithInitOnly(not isStruct && isTotallyImmutable) + [ + (mkILSimpleStorageCtor ( + Some baseTySpec, + baseTy, + [], + tagFieldsInObject, + ILMemberAccess.Assembly, + cud.DebugPoint, + cud.DebugImports + )) + .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x7E0 baseTy ]) + |> ctx.stampMethodAsGenerated ] - let ctorMeths = - if - (List.isEmpty selfFields - && List.isEmpty tagFieldsInObject - && not (List.isEmpty selfMeths)) - || isStruct - || cud.UnionCases - |> Array.forall (fun alt -> repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt)) - then - - [] (* no need for a second ctor in these cases *) - - else - let baseTySpec = - (match td.Extends.Value with - | None -> g.ilg.typ_Object - | Some ilTy -> ilTy) - .TypeSpec - - [ - (mkILSimpleStorageCtor ( - Some baseTySpec, - baseTy, - [], - tagFieldsInObject, - ILMemberAccess.Assembly, - cud.DebugPoint, - cud.DebugImports - )) - .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x7E0 baseTy ]) - |> addMethodGeneratedAttrs - ] +/// Generate static constructor code to initialize nullary case singleton fields. +let private emitConstFieldInitializers + (ctx: TypeDefContext) + (altNullaryFields: ((ILTypeDef * IlxUnionInfo) * IlxUnionCase * ILType * int * ILFieldDef * bool) list) + = + let g = ctx.g + let cud = ctx.cud + let baseTy = ctx.baseTy + let cuspec = ctx.cuspec + let repr = cudefRepr - // Now initialize the constant fields wherever they are stored... - let addConstFieldInit cd = + fun (cd: ILTypeDef) -> if List.isEmpty altNullaryFields then cd else @@ -1860,101 +1808,152 @@ let mkClassUnionDef cud.DebugImports cd - let tagMeths, tagProps, tagEnumFields = - let tagFieldType = mkTagFieldType g.ilg cuspec +/// Create the Tag property, get_Tag method, and Tags enum-like constants. +let private emitTagInfrastructure (ctx: TypeDefContext) = + let g = ctx.g + let cud = ctx.cud + let baseTy = ctx.baseTy + let cuspec = ctx.cuspec + let repr = cudefRepr + let info = (ctx.td, cud) - let tagEnumFields = - cud.UnionCases - |> Array.mapi (fun num alt -> mkILLiteralField (alt.Name, tagFieldType, ILFieldInit.Int32 num, None, ILMemberAccess.Public)) - |> Array.toList + let tagFieldType = mkTagFieldType g.ilg cuspec - let tagMeths, tagProps = + let tagEnumFields = + cud.UnionCases + |> Array.mapi (fun num alt -> mkILLiteralField (alt.Name, tagFieldType, ILFieldInit.Int32 num, None, ILMemberAccess.Public)) + |> Array.toList - let code = - genWith (fun cg -> - emitLdDataTagPrim g.ilg (Some mkLdarg0) cg (true, cuspec) - cg.EmitInstr I_ret) + let tagMeths, tagProps = - let body = mkMethodBody (true, [], 2, code, cud.DebugPoint, cud.DebugImports) - // // If we are using NULL as a representation for an element of this type then we cannot - // // use an instance method - if (repr.RepresentOneAlternativeAsNull info) then - [ - mkILNonGenericStaticMethod ( - "Get" + tagPropertyName, - cud.HelpersAccessibility, - [ mkILParamAnon baseTy ], - mkILReturn tagFieldType, - body - ) - |> addMethodGeneratedAttrs - ], - [] + let code = + genWith (fun cg -> + emitLdDataTagPrim g.ilg (Some mkLdarg0) cg (true, cuspec) + cg.EmitInstr I_ret) - else - [ - mkILNonGenericInstanceMethod ("get_" + tagPropertyName, cud.HelpersAccessibility, [], mkILReturn tagFieldType, body) - |> addMethodGeneratedAttrs - ], + let body = mkMethodBody (true, [], 2, code, cud.DebugPoint, cud.DebugImports) - [ - ILPropertyDef( - name = tagPropertyName, - attributes = PropertyAttributes.None, - setMethod = None, - getMethod = - Some(mkILMethRef (baseTy.TypeRef, ILCallingConv.Instance, "get_" + tagPropertyName, 0, [], tagFieldType)), - callingConv = ILThisConvention.Instance, - propertyType = tagFieldType, - init = None, - args = [], - customAttrs = emptyILCustomAttrs - ) - |> addPropertyGeneratedAttrs - |> addPropertyNeverAttrs - ] + // If we are using NULL as a representation for an element of this type then we cannot + // use an instance method + if repr.RepresentOneAlternativeAsNull info then + [ + mkILNonGenericStaticMethod ( + "Get" + tagPropertyName, + cud.HelpersAccessibility, + [ mkILParamAnon baseTy ], + mkILReturn tagFieldType, + body + ) + |> ctx.stampMethodAsGenerated + ], + [] + + else + [ + mkILNonGenericInstanceMethod ("get_" + tagPropertyName, cud.HelpersAccessibility, [], mkILReturn tagFieldType, body) + |> ctx.stampMethodAsGenerated + ], - tagMeths, tagProps, tagEnumFields + [ + ILPropertyDef( + name = tagPropertyName, + attributes = PropertyAttributes.None, + setMethod = None, + getMethod = Some(mkILMethRef (baseTy.TypeRef, ILCallingConv.Instance, "get_" + tagPropertyName, 0, [], tagFieldType)), + callingConv = ILThisConvention.Instance, + propertyType = tagFieldType, + init = None, + args = [], + customAttrs = emptyILCustomAttrs + ) + |> ctx.stampPropertyAsGenerated + |> ctx.stampPropertyAsNever + ] - // The class can be abstract if each alternative is represented by a derived type - let isAbstract = (altTypeDefs.Length = cud.UnionCases.Length) + tagMeths, tagProps, tagEnumFields - let existingMeths = td.Methods.AsList() - let existingProps = td.Properties.AsList() +/// Compute instance fields from selfFields and tagFieldsInObject. +/// Compute instance fields from selfFields and tagFieldsInObject. +let private computeSelfAndTagFields (ctx: TypeDefContext) selfFields (tagFieldsInObject: (string * ILType * ILAttribute list) list) = + let isStruct = ctx.td.IsStruct + let isTotallyImmutable = (ctx.cud.HasHelpers <> SpecialFSharpListHelpers) - let enumTypeDef = - // The nested Tags type is elided if there is only one tag - // The Tag property is NOT elided if there is only one tag - if tagEnumFields.Length <= 1 then - None - else - let tdef = - ILTypeDef( - name = "Tags", - nestedTypes = emptyILTypeDefs, - genericParams = td.GenericParams, - attributes = enum 0, - layout = ILTypeDefLayout.Auto, - implements = [], - extends = Some g.ilg.typ_Object, - methods = emptyILMethods, - securityDecls = emptyILSecurityDecls, - fields = mkILFields tagEnumFields, - methodImpls = emptyILMethodImpls, - events = emptyILEvents, - properties = emptyILProperties, - customAttrs = emptyILCustomAttrsStored - ) - .WithNestedAccess(cud.UnionCasesAccessibility) - .WithAbstract(true) - .WithSealed(true) - .WithImport(false) - .WithEncoding(ILDefaultPInvokeEncoding.Ansi) - .WithHasSecurity(false) + [ + for fldName, fldTy, attrs in (selfFields @ tagFieldsInObject) do + let fdef = + let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Assembly) - Some tdef + match attrs with + | [] -> fdef + | attrs -> fdef.With(customAttrs = mkILCustomAttrs attrs) - let baseTypeDef = + |> ctx.stampFieldAsNever + |> ctx.stampFieldAsGenerated + + yield fdef.WithInitOnly(not isStruct && isTotallyImmutable) + ] + +/// Compute the nested Tags type definition (elided when ≤1 case). +let private computeEnumTypeDef (g: TcGlobals) (td: ILTypeDef) (cud: IlxUnionInfo) tagEnumFields = + if List.length tagEnumFields <= 1 then + None + else + let tdef = + ILTypeDef( + name = "Tags", + nestedTypes = emptyILTypeDefs, + genericParams = td.GenericParams, + attributes = enum 0, + layout = ILTypeDefLayout.Auto, + implements = [], + extends = Some g.ilg.typ_Object, + methods = emptyILMethods, + securityDecls = emptyILSecurityDecls, + fields = mkILFields tagEnumFields, + methodImpls = emptyILMethodImpls, + events = emptyILEvents, + properties = emptyILProperties, + customAttrs = emptyILCustomAttrsStored + ) + .WithNestedAccess(cud.UnionCasesAccessibility) + .WithAbstract(true) + .WithSealed(true) + .WithImport(false) + .WithEncoding(ILDefaultPInvokeEncoding.Ansi) + .WithHasSecurity(false) + + Some tdef + +/// Assemble all pieces into the final union ILTypeDef. +let private assembleUnionTypeDef + (ctx: TypeDefContext) + (results: AlternativeDefResult list) + ctorMeths + selfMeths + selfAndTagFields + tagMeths + tagProps + tagEnumFields + selfProps + = + let g = ctx.g + let td = ctx.td + let cud = ctx.cud + + let altNullaryFields = results |> List.collect (fun r -> r.NullaryConstFields) + let baseMethsFromAlt = results |> List.collect (fun r -> r.BaseMakerMethods) + let basePropsFromAlt = results |> List.collect (fun r -> r.BaseMakerProperties) + let altUniqObjMeths = results |> List.collect (fun r -> r.ConstantAccessors) + let altTypeDefs = results |> List.collect (fun r -> r.NestedTypeDefs) + let altDebugTypeDefs = results |> List.collect (fun r -> r.DebugProxyTypeDefs) + let enumTypeDef = computeEnumTypeDef g td cud tagEnumFields + let addConstFieldInit = emitConstFieldInitializers ctx altNullaryFields + + let existingMeths = td.Methods.AsList() + let existingProps = td.Properties.AsList() + let isAbstract = (altTypeDefs.Length = cud.UnionCases.Length) + + let baseTypeDef: ILTypeDef = td .WithInitSemantics(ILTypeInit.BeforeField) .With( @@ -1987,7 +1986,61 @@ let mkClassUnionDef properties = mkILProperties (tagProps @ basePropsFromAlt @ selfProps @ existingProps), customAttrs = rootTypeNullableAttrs g td cud ) - // The .cctor goes on the Cases type since that's where the constant fields for nullary constructors live |> addConstFieldInit baseTypeDef.WithAbstract(isAbstract).WithSealed(altTypeDefs.IsEmpty) + +let mkClassUnionDef + ( + addMethodGeneratedAttrs, + addPropertyGeneratedAttrs, + addPropertyNeverAttrs, + addFieldGeneratedAttrs: ILFieldDef -> ILFieldDef, + addFieldNeverAttrs: ILFieldDef -> ILFieldDef, + mkDebuggerTypeProxyAttribute + ) + (g: TcGlobals) + tref + (td: ILTypeDef) + cud + = + let boxity = if td.IsStruct then ILBoxity.AsValue else ILBoxity.AsObject + let baseTy = mkILFormalNamedTy boxity tref td.GenericParams + + let cuspec = + IlxUnionSpec(IlxUnionRef(boxity, baseTy.TypeRef, cud.UnionCases, cud.IsNullPermitted, cud.HasHelpers), baseTy.GenericArgs) + + let ctx = + { + g = g + layout = classifyFromDef td cud baseTy + cuspec = cuspec + cud = cud + td = td + baseTy = baseTy + stampMethodAsGenerated = addMethodGeneratedAttrs + stampPropertyAsGenerated = addPropertyGeneratedAttrs + stampPropertyAsNever = addPropertyNeverAttrs + stampFieldAsGenerated = addFieldGeneratedAttrs + stampFieldAsNever = addFieldNeverAttrs + mkDebuggerTypeProxyAttr = mkDebuggerTypeProxyAttribute + } + + let results = + cud.UnionCases + |> List.ofArray + |> List.mapi (fun i alt -> processAlternative ctx i alt) + + let tagFieldsInObject = + match cudefRepr.DiscriminationTechnique(td, cud) with + | SingleCase + | RuntimeTypes + | TailOrNull -> [] + | IntegerTag -> [ let n, t = mkTagFieldId g.ilg cuspec in n, t, [] ] + + let selfFields, selfMeths, selfProps = emitRootClassFields ctx tagFieldsInObject + let selfAndTagFields = computeSelfAndTagFields ctx selfFields tagFieldsInObject + let ctorMeths = emitRootConstructors ctx selfFields tagFieldsInObject selfMeths + let tagMeths, tagProps, tagEnumFields = emitTagInfrastructure ctx + + assembleUnionTypeDef ctx results ctorMeths selfMeths selfAndTagFields tagMeths tagProps tagEnumFields selfProps From f942cb30cd45f8f91868f9b91aec3e0cb3e8c8a2 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 07:55:12 +0100 Subject: [PATCH 06/44] Remove old UnionReprDecisions infrastructure Delete DiscriminationTechnique DU, UnionReprDecisions generic class, cuspecRepr/cudefRepr instances, NoTypesGeneratedViaThisReprDecider, and layoutToTechnique bridge function. All code paths now use UnionLayout type with exhaustive active patterns and focused helper functions (altFoldsAsRootInstance, altOptimizesToRoot, maintainConstantField, hasNullCase). Simplify AlternativeDefResult.NullaryConstFields tuple by removing the unused (ILTypeDef * IlxUnionInfo) element. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 395 ++++++++++------------------ 1 file changed, 134 insertions(+), 261 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 6e92757b440..1f403319005 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -23,23 +23,6 @@ let TagCons = 1 [] let ALT_NAME_CONS = "Cons" -type DiscriminationTechnique = - /// Indicates a special representation for the F# list type where the "empty" value has a tail field of value null - | TailOrNull - - /// Indicates a type with either number of cases < 4, and not a single-class type with an integer tag (IntegerTag) - | RuntimeTypes - - /// Indicates a type with a single case, e.g. ``type X = ABC of string * int`` - | SingleCase - - /// Indicates a type with either cases >= 4, or a type like - // type X = A | B | C - // or type X = A | B | C of string - // where at most one case is non-nullary. These can be represented using a single - // class (no subclasses), but an integer tag is stored to discriminate between the objects. - | IntegerTag - [] type UnionLayout = /// F# list<'a> only. Discrimination via tail field == null. @@ -55,133 +38,6 @@ type UnionLayout = /// Any struct DU with >1 case. Discrimination via integer _tag field. | TaggedStructUnion of baseTy: ILType * allNullary: bool -// A potentially useful additional representation trades an extra integer tag in the root type -// for faster discrimination, and in the important single-non-nullary constructor case -// -// type Tree = Tip | Node of int * Tree * Tree -// -// it also flattens so the fields for "Node" are stored in the base class, meaning that no type casts -// are needed to access the data. -// -// However, it can't be enabled because it suppresses the generation -// of C#-facing nested types for the non-nullary case. This could be enabled -// in a binary compatible way by ensuring we continue to generate the C# facing types and use -// them as the instance types, but still store all field elements in the base type. Additional -// accessors would be needed to access these fields directly, akin to HeadOrDefault and TailOrNull. - -// This functor helps us make representation decisions for F# union type compilation -type UnionReprDecisions<'Union, 'Alt, 'Type> - ( - getAlternatives: 'Union -> 'Alt[], - nullPermitted: 'Union -> bool, - isNullary: 'Alt -> bool, - isList: 'Union -> bool, - isStruct: 'Union -> bool, - nameOfAlt: 'Alt -> string, - makeRootType: 'Union -> 'Type, - makeNestedType: 'Union * string -> 'Type - ) = - - static let TaggingThresholdFixedConstant = 4 - - member repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu = - cu |> getAlternatives |> Array.forall isNullary - - member repr.DiscriminationTechnique cu = - if isList cu then - TailOrNull - else - let alts = getAlternatives cu - - if alts.Length = 1 then - SingleCase - elif - not (isStruct cu) - && alts.Length < TaggingThresholdFixedConstant - && not (repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu) - then - RuntimeTypes - else - IntegerTag - - // WARNING: this must match IsUnionTypeWithNullAsTrueValue in the F# compiler - member repr.RepresentAlternativeAsNull(cu, alt) = - let alts = getAlternatives cu - - nullPermitted cu - && (repr.DiscriminationTechnique cu = RuntimeTypes) - && (* don't use null for tags, lists or single-case *) Array.existsOne isNullary alts - && Array.exists (isNullary >> not) alts - && isNullary alt (* is this the one? *) - - member repr.RepresentOneAlternativeAsNull cu = - let alts = getAlternatives cu - - nullPermitted cu - && alts |> Array.existsOne (fun alt -> repr.RepresentAlternativeAsNull(cu, alt)) - - member repr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull(cu, alt) = - // Check all nullary constructors are being represented without using sub-classes - let alts = getAlternatives cu - - not (isStruct cu) - && not (isNullary alt) - && (alts - |> Array.forall (fun alt2 -> not (isNullary alt2) || repr.RepresentAlternativeAsNull(cu, alt2))) - && - // Check this is the one and only non-nullary constructor - Array.existsOne (isNullary >> not) alts - - member repr.RepresentAlternativeAsStructValue cu = isStruct cu - - member repr.RepresentAlternativeAsFreshInstancesOfRootClass(cu, alt) = - not (isStruct cu) - && ((isList // Check all nullary constructors are being represented without using sub-classes - cu - && nameOfAlt alt = ALT_NAME_CONS) - || repr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull(cu, alt)) - - member repr.RepresentAlternativeAsConstantFieldInTaggedRootClass(cu, alt) = - not (isStruct cu) - && isNullary alt - && not (repr.RepresentAlternativeAsNull(cu, alt)) - && (repr.DiscriminationTechnique cu <> RuntimeTypes) - - member repr.Flatten cu = isStruct cu - - member repr.OptimizeAlternativeToRootClass(cu, alt) = - // The list type always collapses to the root class - isList cu - || - // Structs are always flattened - repr.Flatten cu - || repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu - || repr.RepresentAlternativeAsConstantFieldInTaggedRootClass(cu, alt) - || repr.RepresentAlternativeAsStructValue(cu) - || repr.RepresentAlternativeAsFreshInstancesOfRootClass(cu, alt) - - member repr.MaintainPossiblyUniqueConstantFieldForAlternative(cu, alt) = - not (isStruct cu) - && not (repr.RepresentAlternativeAsNull(cu, alt)) - && isNullary alt - - member repr.TypeForAlternative(cuspec, alt) = - if - repr.OptimizeAlternativeToRootClass(cuspec, alt) - || repr.RepresentAlternativeAsNull(cuspec, alt) - then - makeRootType cuspec - else - let altName = nameOfAlt alt - // Add "_" if the thing is nullary or if it is 'List._Cons', which is special because it clashes with the name of the static method "Cons" - let nm = - if isNullary alt || isList cuspec then - "_" + altName - else - altName - - makeNestedType (cuspec, nm) - let baseTyOfUnionSpec (cuspec: IlxUnionSpec) = mkILNamedTy cuspec.Boxity cuspec.TypeRef cuspec.GenericArgs @@ -194,34 +50,7 @@ let mkMakerName (cuspec: IlxUnionSpec) nm = let mkCasesTypeRef (cuspec: IlxUnionSpec) = cuspec.TypeRef -let cuspecRepr = - UnionReprDecisions( - (fun (cuspec: IlxUnionSpec) -> cuspec.AlternativesArray), - (fun (cuspec: IlxUnionSpec) -> cuspec.IsNullPermitted), - (fun (alt: IlxUnionCase) -> alt.IsNullary), - (fun cuspec -> cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers), - (fun cuspec -> cuspec.Boxity = ILBoxity.AsValue), - (fun (alt: IlxUnionCase) -> alt.Name), - (fun cuspec -> cuspec.DeclaringType), - (fun (cuspec, nm) -> mkILNamedTy cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs) - ) - -type NoTypesGeneratedViaThisReprDecider = NoTypesGeneratedViaThisReprDecider - -let cudefRepr = - UnionReprDecisions( - (fun (_td, cud) -> cud.UnionCases), - (fun (_td, cud) -> cud.IsNullPermitted), - (fun (alt: IlxUnionCase) -> alt.IsNullary), - (fun (_td, cud) -> cud.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers), - (fun (td: ILTypeDef, _cud) -> td.IsStruct), - (fun (alt: IlxUnionCase) -> alt.Name), - (fun (_td, _cud) -> NoTypesGeneratedViaThisReprDecider), - (fun ((_td, _cud), _nm) -> NoTypesGeneratedViaThisReprDecider) - ) - /// Core classification logic. Computes the UnionLayout for any union. -/// This must produce IDENTICAL decisions to UnionReprDecisions.DiscriminationTechnique. let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isStruct = if isList then UnionLayout.ListTailOrNull baseTy @@ -268,17 +97,6 @@ let classifyFromDef (td: ILTypeDef) (cud: IlxUnionInfo) (baseTy: ILType) = let isStruct = td.IsStruct classifyUnion baseTy alts nullPermitted isList isStruct -/// Maps a UnionLayout to the equivalent DiscriminationTechnique. -/// Used in debug assertions to validate the new classification matches the old one. -let private layoutToTechnique layout = - match layout with - | UnionLayout.ListTailOrNull _ -> TailOrNull - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ -> SingleCase - | UnionLayout.SmallRefUnion _ -> RuntimeTypes - | UnionLayout.TaggedRefUnion _ - | UnionLayout.TaggedStructUnion _ -> IntegerTag - // ---- Exhaustive Active Patterns for UnionLayout ---- /// How to discriminate between cases at runtime. @@ -357,7 +175,6 @@ let private _validateActivePatterns = let _fromSpec = classifyFromSpec cuspec let _fromDef = classifyFromDef td cud baseTy - let _technique = layoutToTechnique layout match layout with | DiscriminateByTagField @@ -385,6 +202,52 @@ let private _validateActivePatterns | NonNullaryFoldsToRoot | NonNullaryInNestedType -> () +// ---- Layout-Based Helpers ---- +// These replace the old representation decision methods. + +/// Does this non-nullary alternative fold to root class via fresh instances? +/// Equivalent to the old RepresentAlternativeAsFreshInstancesOfRootClass. +let private altFoldsAsRootInstance (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) = + not alt.IsNullary + && (match layout with + | UnionLayout.ListTailOrNull _ -> alt.Name = ALT_NAME_CONS + | UnionLayout.SingleCaseRef _ -> true + | UnionLayout.SmallRefUnion(_, Some _) -> alts |> Array.filter (fun a -> not a.IsNullary) |> Array.length = 1 + | _ -> false) + +/// Does this alternative optimize to root class (no nested type needed)? +/// Equivalent to the old OptimizeAlternativeToRootClass. +let private altOptimizesToRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) (cidx: int) = + match layout with + | UnionLayout.ListTailOrNull _ + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedStructUnion _ -> true + | UnionLayout.TaggedRefUnion(_, true) -> true + | UnionLayout.TaggedRefUnion _ -> alt.IsNullary + | UnionLayout.SmallRefUnion _ -> + (match layout, cidx with + | CaseIsNull -> true + | CaseIsAllocated -> false) + || altFoldsAsRootInstance layout alt alts + +/// Should a static constant field be maintained for this nullary alternative? +/// Equivalent to the old MaintainPossiblyUniqueConstantFieldForAlternative. +let private maintainConstantField (layout: UnionLayout) (alt: IlxUnionCase) (cidx: int) = + alt.IsNullary + && (match layout with + | ValueTypeLayout -> false + | ReferenceTypeLayout -> true) + && (match layout, cidx with + | CaseIsNull -> false + | CaseIsAllocated -> true) + +/// Does any case use null representation? +let private hasNullCase (layout: UnionLayout) = + match layout with + | UnionLayout.SmallRefUnion(_, Some _) -> true + | _ -> false + // ---- Context Records ---- /// Bundles the parameters threaded through type definition generation. @@ -414,7 +277,7 @@ type AlternativeDefResult = ConstantAccessors: ILMethodDef list NestedTypeDefs: ILTypeDef list DebugProxyTypeDefs: ILTypeDef list - NullaryConstFields: ((ILTypeDef * IlxUnionInfo) * IlxUnionCase * ILType * int * ILFieldDef * bool) list + NullaryConstFields: (IlxUnionCase * ILType * int * ILFieldDef * bool) list } let mkTesterName nm = "Is" + nm @@ -452,11 +315,37 @@ let mkConstFieldSpecFromId (baseTy: ILType) constFieldId = refToFieldInTy baseTy let mkConstFieldSpec nm (baseTy: ILType) = mkConstFieldSpecFromId baseTy (constFieldName nm, constFormalFieldTy baseTy) -let tyForAlt cuspec alt = - cuspecRepr.TypeForAlternative(cuspec, alt) +let tyForAlt cuspec (alt: IlxUnionCase) = + let layout = classifyFromSpec cuspec + let baseTy = baseTyOfUnionSpec cuspec + let isList = (cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) + + let optimizedToRootOrNull = + match layout with + | UnionLayout.ListTailOrNull _ + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedStructUnion _ -> true + | UnionLayout.TaggedRefUnion(_, true) -> true + | UnionLayout.TaggedRefUnion _ -> alt.IsNullary + | UnionLayout.SmallRefUnion(_, Some _) when alt.IsNullary -> true + | UnionLayout.SmallRefUnion(_, Some _) -> + cuspec.AlternativesArray + |> Array.filter (fun a -> not a.IsNullary) + |> Array.length = 1 + | UnionLayout.SmallRefUnion(_, None) -> false + + if optimizedToRootOrNull then + baseTy + else + let altName = alt.Name + + let nm = if alt.IsNullary || isList then "_" + altName else altName + + mkILNamedTy cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs let GetILTypeForAlternative cuspec alt = - cuspecRepr.TypeForAlternative(cuspec, cuspec.Alternative alt) + tyForAlt cuspec (cuspec.Alternative alt) let mkTagFieldType (ilg: ILGlobals) _cuspec = ilg.typ_Int32 @@ -541,7 +430,7 @@ let mkGetTailOrNull avoidHelpers cuspec = let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = let baseTy = baseTyOfUnionSpec cuspec - if cuspecRepr.RepresentOneAlternativeAsNull cuspec then + if hasNullCase (classifyFromSpec cuspec) then mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [ baseTy ], mkTagFieldFormalType ilg cuspec)) else mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec)) @@ -1152,13 +1041,12 @@ let private emitMakerMethod (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) let cud = ctx.cud let fields = alt.FieldDefs let altName = alt.Name - let info = (ctx.td, cud) - let repr = cudefRepr let imports = cud.DebugImports let attr = cud.DebugPoint let locals, ilInstrs = - if repr.RepresentAlternativeAsStructValue info then + match ctx.layout with + | ValueTypeLayout -> let local = mkILLocal baseTy None let ldloca = I_ldloca(0us) @@ -1166,10 +1054,12 @@ let private emitMakerMethod (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) [ ldloca ILInstr.I_initobj baseTy - if (repr.DiscriminationTechnique info) = IntegerTag && num <> 0 then + match ctx.layout with + | HasTagField when num <> 0 -> ldloca mkLdcInt32 num mkSetTagToField g.ilg cuspec baseTy + | _ -> () for i in 0 .. fields.Length - 1 do ldloca mkLdarg (uint16 i) @@ -1178,7 +1068,7 @@ let private emitMakerMethod (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) ] [ local ], ilInstrs - else + | ReferenceTypeLayout -> let ilInstrs = [ for i in 0 .. fields.Length - 1 do @@ -1214,22 +1104,22 @@ let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: I let cud = ctx.cud let cuspec = ctx.cuspec let baseTy = ctx.baseTy - let info = (ctx.td, cud) - let repr = cudefRepr let altName = alt.Name let imports = cud.DebugImports let attr = cud.DebugPoint if cud.UnionCases.Length <= 1 then [], [] - elif repr.RepresentOneAlternativeAsNull info then + elif hasNullCase ctx.layout then [], [] else let additionalAttributes = if g.checkNullness && g.langFeatureNullness - && repr.RepresentAlternativeAsStructValue info + && (match ctx.layout with + | ValueTypeLayout -> true + | ReferenceTypeLayout -> false) && not alt.IsNullary then let notnullfields = @@ -1286,8 +1176,6 @@ let private emitNullaryCaseAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUn let cud = ctx.cud let cuspec = ctx.cuspec let baseTy = ctx.baseTy - let info = (td, cud) - let repr = cudefRepr let altName = alt.Name let fields = alt.FieldDefs let imports = cud.DebugImports @@ -1297,7 +1185,9 @@ let private emitNullaryCaseAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUn if g.checkNullness && g.langFeatureNullness - && repr.RepresentAlternativeAsNull(info, alt) + && (match ctx.layout, num with + | CaseIsNull -> true + | CaseIsAllocated -> false) then let noTypars = td.GenericParams.Length @@ -1340,11 +1230,9 @@ let private emitNullaryCaseAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUn [ nullaryMeth ], [ nullaryProp ] -let private emitConstantAccessor (ctx: TypeDefContext) (_num: int) (alt: IlxUnionCase) = +let private emitConstantAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = let cud = ctx.cud let baseTy = ctx.baseTy - let info = (ctx.td, cud) - let repr = cudefRepr let altName = alt.Name let fields = alt.FieldDefs let imports = cud.DebugImports @@ -1357,10 +1245,7 @@ let private emitConstantAccessor (ctx: TypeDefContext) (_num: int) (alt: IlxUnio | SpecialFSharpOptionHelpers | SpecialFSharpListHelpers -> [] | _ -> - if - alt.IsNullary - && repr.MaintainPossiblyUniqueConstantFieldForAlternative(info, alt) - then + if alt.IsNullary && maintainConstantField ctx.layout alt num then let methName = "get_" + altName let meth = @@ -1389,20 +1274,18 @@ let private emitNullaryConstField (ctx: TypeDefContext) (num: int) (alt: IlxUnio let cud = ctx.cud let baseTy = ctx.baseTy let cuspec = ctx.cuspec - let info = (ctx.td, cud) - let repr = cudefRepr let altName = alt.Name let altTy = tyForAlt cuspec alt - if repr.MaintainPossiblyUniqueConstantFieldForAlternative(info, alt) then + if maintainConstantField ctx.layout alt num then let basic: ILFieldDef = mkILStaticField (constFieldName altName, baseTy, None, None, ILMemberAccess.Assembly) |> ctx.stampFieldAsNever |> ctx.stampFieldAsGenerated let uniqObjField = basic.WithInitOnly(true) - let inRootClass = cuspecRepr.OptimizeAlternativeToRootClass(cuspec, alt) - [ (info, alt, altTy, num, uniqObjField, inRootClass) ] + let inRootClass = altOptimizesToRoot ctx.layout alt cud.UnionCases num + [ (alt, altTy, num, uniqObjField, inRootClass) ] else [] @@ -1412,15 +1295,13 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx let cud = ctx.cud let cuspec = ctx.cuspec let baseTy = ctx.baseTy - let info = (td, cud) - let repr = cudefRepr let altTy = tyForAlt cuspec alt let fields = alt.FieldDefs let imports = cud.DebugImports let attr = cud.DebugPoint let isTotallyImmutable = (cud.HasHelpers <> SpecialFSharpListHelpers) - if repr.OptimizeAlternativeToRootClass(info, alt) then + if altOptimizesToRoot ctx.layout alt cud.UnionCases num then [], [] else let altDebugTypeDefs, debugAttrs = @@ -1474,13 +1355,12 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx let basicCtorInstrs = [ yield mkLdarg0 - match repr.DiscriminationTechnique info with - | IntegerTag -> + + match ctx.layout with + | HasTagField -> yield mkLdcInt32 num yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [ mkTagFieldType g.ilg cuspec ])) - | SingleCase - | RuntimeTypes -> yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [])) - | TailOrNull -> failwith "unreachable" + | NoTagField -> yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [])) ] let basicCtorAccess = @@ -1534,9 +1414,6 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = let cud = ctx.cud - let cuspec = ctx.cuspec - let info = (ctx.td, cud) - let repr = cudefRepr let constantAccessors = emitConstantAccessor ctx num alt @@ -1555,20 +1432,28 @@ let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCa (makerMeths @ testerMeths), (makerProps @ testerProps) - | NoHelpers when not alt.IsNullary && cuspecRepr.RepresentAlternativeAsStructValue(cuspec) -> [ emitMakerMethod ctx num alt ], [] + | NoHelpers when + not alt.IsNullary + && (match ctx.layout with + | ValueTypeLayout -> true + | ReferenceTypeLayout -> false) + -> + [ emitMakerMethod ctx num alt ], [] | NoHelpers -> [], [] let typeDefs, debugTypeDefs, nullaryFields = - if repr.RepresentAlternativeAsNull(info, alt) then - [], [], [] - elif repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt) then - [], [], [] - elif repr.RepresentAlternativeAsStructValue info then - [], [], [] - else - let nullaryFields = emitNullaryConstField ctx num alt - let typeDefs, debugTypeDefs = emitNestedAlternativeType ctx num alt - typeDefs, debugTypeDefs, nullaryFields + match ctx.layout, num with + | CaseIsNull -> [], [], [] + | CaseIsAllocated -> + match ctx.layout with + | ValueTypeLayout -> [], [], [] + | ReferenceTypeLayout -> + if altFoldsAsRootInstance ctx.layout alt cud.UnionCases then + [], [], [] + else + let nullaryFields = emitNullaryConstField ctx num alt + let typeDefs, debugTypeDefs = emitNestedAlternativeType ctx num alt + typeDefs, debugTypeDefs, nullaryFields { BaseMakerMethods = baseMakerMeths @@ -1650,8 +1535,6 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin let baseTy = ctx.baseTy let cuspec = ctx.cuspec let isStruct = td.IsStruct - let repr = cudefRepr - let info = (td, cud) let ctorAccess = if cuspec.HasHelpers = AllHelpers then @@ -1669,8 +1552,10 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin for cidx, alt in Array.indexed cud.UnionCases do if - repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt) - || repr.RepresentAlternativeAsStructValue info + altFoldsAsRootInstance ctx.layout alt cud.UnionCases + || (match ctx.layout with + | ValueTypeLayout -> true + | ReferenceTypeLayout -> false) then let baseInit = @@ -1737,8 +1622,6 @@ let private emitRootConstructors (ctx: TypeDefContext) selfFields tagFieldsInObj let td = ctx.td let cud = ctx.cud let baseTy = ctx.baseTy - let repr = cudefRepr - let info = (td, cud) if (List.isEmpty selfFields @@ -1746,7 +1629,7 @@ let private emitRootConstructors (ctx: TypeDefContext) selfFields tagFieldsInObj && not (List.isEmpty selfMeths)) || td.IsStruct || cud.UnionCases - |> Array.forall (fun alt -> repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt)) + |> Array.forall (fun alt -> altFoldsAsRootInstance ctx.layout alt cud.UnionCases) then [] else @@ -1771,15 +1654,11 @@ let private emitRootConstructors (ctx: TypeDefContext) selfFields tagFieldsInObj ] /// Generate static constructor code to initialize nullary case singleton fields. -let private emitConstFieldInitializers - (ctx: TypeDefContext) - (altNullaryFields: ((ILTypeDef * IlxUnionInfo) * IlxUnionCase * ILType * int * ILFieldDef * bool) list) - = +let private emitConstFieldInitializers (ctx: TypeDefContext) (altNullaryFields: (IlxUnionCase * ILType * int * ILFieldDef * bool) list) = let g = ctx.g let cud = ctx.cud let baseTy = ctx.baseTy let cuspec = ctx.cuspec - let repr = cudefRepr fun (cd: ILTypeDef) -> if List.isEmpty altNullaryFields then @@ -1787,15 +1666,13 @@ let private emitConstFieldInitializers else prependInstrsToClassCtor [ - for info, _alt, altTy, fidx, fd, inRootClass in altNullaryFields do + for _alt, altTy, fidx, fd, inRootClass in altNullaryFields do let constFieldId = (fd.Name, baseTy) let constFieldSpec = mkConstFieldSpecFromId baseTy constFieldId - match repr.DiscriminationTechnique info with - | SingleCase - | RuntimeTypes - | TailOrNull -> yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy, [])) - | IntegerTag -> + match ctx.layout with + | NoTagField -> yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy, [])) + | HasTagField -> if inRootClass then yield mkLdcInt32 fidx yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy, [ mkTagFieldType g.ilg cuspec ])) @@ -1814,8 +1691,6 @@ let private emitTagInfrastructure (ctx: TypeDefContext) = let cud = ctx.cud let baseTy = ctx.baseTy let cuspec = ctx.cuspec - let repr = cudefRepr - let info = (ctx.td, cud) let tagFieldType = mkTagFieldType g.ilg cuspec @@ -1835,7 +1710,7 @@ let private emitTagInfrastructure (ctx: TypeDefContext) = // If we are using NULL as a representation for an element of this type then we cannot // use an instance method - if repr.RepresentOneAlternativeAsNull info then + if hasNullCase ctx.layout then [ mkILNonGenericStaticMethod ( "Get" + tagPropertyName, @@ -1980,7 +1855,7 @@ let private assembleUnionTypeDef fields = mkILFields ( selfAndTagFields - @ List.map (fun (_, _, _, _, fdef, _) -> fdef) altNullaryFields + @ List.map (fun (_, _, _, fdef, _) -> fdef) altNullaryFields @ td.Fields.AsList() ), properties = mkILProperties (tagProps @ basePropsFromAlt @ selfProps @ existingProps), @@ -2032,11 +1907,9 @@ let mkClassUnionDef |> List.mapi (fun i alt -> processAlternative ctx i alt) let tagFieldsInObject = - match cudefRepr.DiscriminationTechnique(td, cud) with - | SingleCase - | RuntimeTypes - | TailOrNull -> [] - | IntegerTag -> [ let n, t = mkTagFieldId g.ilg cuspec in n, t, [] ] + match ctx.layout with + | HasTagField -> [ let n, t = mkTagFieldId g.ilg cuspec in n, t, [] ] + | NoTagField -> [] let selfFields, selfMeths, selfProps = emitRootClassFields ctx tagFieldsInObject let selfAndTagFields = computeSelfAndTagFields ctx selfFields tagFieldsInObject From 717bdaea07ae1c18edcbae63d1f2cf23ef68e3cd Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:33:51 +0100 Subject: [PATCH 07/44] Refactor mkNewData: replace boolean deconstruction with pattern match The NoHelpers branch extracted isStruct/isNull into booleans then used if/elif chains. Replace with direct pattern matching on (layout, cidx) and layout active patterns, making the logic readable at a glance. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 1f403319005..4f6a652bf45 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -563,22 +563,16 @@ let mkNewData ilg (cuspec, cidx) = viaMakerCall () | NoHelpers -> - let isStruct = + match layout, cidx with + | CaseIsNull -> [ AI_ldnull ] + | _ -> match layout with - | ValueTypeLayout -> true - | ReferenceTypeLayout -> false - - let isNull = - match layout, cidx with - | CaseIsNull -> true - | CaseIsAllocated -> false - - if not alt.IsNullary && isStruct then - viaMakerCall () - elif not isStruct && not isNull && alt.IsNullary then - viaGetAltNameProperty () - else - emitRawConstruction ilg cuspec layout cidx + // Struct non-nullary: use maker method (handles initobj + field stores) + | ValueTypeLayout when not alt.IsNullary -> viaMakerCall () + // Ref nullary (not null-represented): use property accessor for singleton + | ReferenceTypeLayout when alt.IsNullary -> viaGetAltNameProperty () + // Everything else: raw construction + | _ -> emitRawConstruction ilg cuspec layout cidx let private emitIsCase ilg avoidHelpers cuspec (layout: UnionLayout) cidx = let alt = altOfUnionSpec cuspec cidx From 1e4ebd26a838001177993d065e28d33ecebee1db Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:39:48 +0100 Subject: [PATCH 08/44] Deduplicate tyForAlt by reusing altOptimizesToRoot tyForAlt duplicated the entire altOptimizesToRoot classification logic inline. Extract tyForAltIdx taking cidx for direct calls, and have tyForAlt look up cidx. All internal callers that already have cidx now call tyForAltIdx directly. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 51 +++++++++++------------------ 1 file changed, 19 insertions(+), 32 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 4f6a652bf45..9e2400b5219 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -315,35 +315,22 @@ let mkConstFieldSpecFromId (baseTy: ILType) constFieldId = refToFieldInTy baseTy let mkConstFieldSpec nm (baseTy: ILType) = mkConstFieldSpecFromId baseTy (constFieldName nm, constFormalFieldTy baseTy) -let tyForAlt cuspec (alt: IlxUnionCase) = +let private tyForAltIdx cuspec (alt: IlxUnionCase) cidx = let layout = classifyFromSpec cuspec let baseTy = baseTyOfUnionSpec cuspec - let isList = (cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) - let optimizedToRootOrNull = - match layout with - | UnionLayout.ListTailOrNull _ - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedStructUnion _ -> true - | UnionLayout.TaggedRefUnion(_, true) -> true - | UnionLayout.TaggedRefUnion _ -> alt.IsNullary - | UnionLayout.SmallRefUnion(_, Some _) when alt.IsNullary -> true - | UnionLayout.SmallRefUnion(_, Some _) -> - cuspec.AlternativesArray - |> Array.filter (fun a -> not a.IsNullary) - |> Array.length = 1 - | UnionLayout.SmallRefUnion(_, None) -> false - - if optimizedToRootOrNull then + if altOptimizesToRoot layout alt cuspec.AlternativesArray cidx then baseTy else + let isList = (cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) let altName = alt.Name - let nm = if alt.IsNullary || isList then "_" + altName else altName - mkILNamedTy cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs +let tyForAlt (cuspec: IlxUnionSpec) (alt: IlxUnionCase) = + let cidx = cuspec.AlternativesArray |> Array.findIndex (fun (a: IlxUnionCase) -> a.Name = alt.Name) + tyForAltIdx cuspec alt cidx + let GetILTypeForAlternative cuspec alt = tyForAlt cuspec (cuspec.Alternative alt) @@ -404,7 +391,7 @@ let adjustFieldName hasHelpers nm = let mkLdData (avoidHelpers, cuspec, cidx, fidx) = let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt cidx let fieldDef = alt.FieldDef fidx if avoidHelpers then @@ -416,7 +403,7 @@ let mkLdData (avoidHelpers, cuspec, cidx, fidx) = let mkLdDataAddr (avoidHelpers, cuspec, cidx, fidx) = let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt cidx let fieldDef = alt.FieldDef fidx if avoidHelpers then @@ -476,7 +463,7 @@ let private caseFoldsToRootClass (layout: UnionLayout) (cuspec: IlxUnionSpec) (a let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt cidx let altName = alt.Name match layout, cidx with @@ -522,7 +509,7 @@ let convNewDataInstrInternal ilg cuspec cidx = // The stdata 'instruction' is only ever used for the F# "List" type within FSharp.Core.dll let mkStData (cuspec, cidx, fidx) = let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt cidx let fieldDef = alt.FieldDef fidx mkNormalStfld (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) @@ -576,7 +563,7 @@ let mkNewData ilg (cuspec, cidx) = let private emitIsCase ilg avoidHelpers cuspec (layout: UnionLayout) cidx = let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt cidx let altName = alt.Name match layout, cidx with @@ -642,7 +629,7 @@ let private emitBranchOnCase ilg sense avoidHelpers cuspec (layout: UnionLayout) let neg = (if sense then BI_brfalse else BI_brtrue) let pos = (if sense then BI_brtrue else BI_brfalse) let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt cidx let altName = alt.Name match layout, cidx with @@ -720,7 +707,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: Ilx [ test ] else let altName = alt.Name - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt cidx mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy test cg.EmitInstrs(ld :: testBlock) @@ -781,7 +768,7 @@ let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail avoidHelpers cuspec () else // Non-nullary in tagged ref: lives in nested type - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt cidx cg.EmitInstr(I_castclass altTy) | UnionLayout.SmallRefUnion _ -> if caseFoldsToRootClass layout cuspec alt then @@ -789,7 +776,7 @@ let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail avoidHelpers cuspec () else // Case lives in a nested type - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt cidx cg.EmitInstr(I_castclass altTy) let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, avoidHelpers, cuspec, cidx) = @@ -807,7 +794,7 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) avoidHelpers cuspec (layout for cidx, tg in cases do let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt cidx let altName = alt.Name let failLab = cg.GenerateDelayMark() let cmpNull = (nullCaseIdx = Some cidx) @@ -1269,7 +1256,7 @@ let private emitNullaryConstField (ctx: TypeDefContext) (num: int) (alt: IlxUnio let baseTy = ctx.baseTy let cuspec = ctx.cuspec let altName = alt.Name - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt num if maintainConstantField ctx.layout alt num then let basic: ILFieldDef = @@ -1289,7 +1276,7 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx let cud = ctx.cud let cuspec = ctx.cuspec let baseTy = ctx.baseTy - let altTy = tyForAlt cuspec alt + let altTy = tyForAltIdx cuspec alt num let fields = alt.FieldDefs let imports = cud.DebugImports let attr = cud.DebugPoint From 1a4cfe5ef69ee0d1824f17ff588654c96296418d Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:41:34 +0100 Subject: [PATCH 09/44] Simplify processAlternative NoHelpers branch with pattern match Replace 'not alt.IsNullary && (match ctx.layout with ValueTypeLayout -> true | ReferenceTypeLayout -> false)' with a direct match on ctx.layout with a when guard, collapsing two match arms into one. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 9e2400b5219..bfe883e06a3 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -1413,14 +1413,10 @@ let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCa (makerMeths @ testerMeths), (makerProps @ testerProps) - | NoHelpers when - not alt.IsNullary - && (match ctx.layout with - | ValueTypeLayout -> true - | ReferenceTypeLayout -> false) - -> - [ emitMakerMethod ctx num alt ], [] - | NoHelpers -> [], [] + | NoHelpers -> + match ctx.layout with + | ValueTypeLayout when not alt.IsNullary -> [ emitMakerMethod ctx num alt ], [] + | _ -> [], [] let typeDefs, debugTypeDefs, nullaryFields = match ctx.layout, num with From faf20c35f93febff039fa17ffe12b67adb63e5bd Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:43:29 +0100 Subject: [PATCH 10/44] Simplify emitTesterMethodAndProperty nullness guard Replace the boolean chain 'g.checkNullness && g.langFeatureNullness && (match layout ... -> true | ... -> false) && not alt.IsNullary' with a direct pattern match on ctx.layout with when guard. Also merge the two early-return conditions into one. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index bfe883e06a3..f515277dd75 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -1089,20 +1089,12 @@ let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: I let imports = cud.DebugImports let attr = cud.DebugPoint - if cud.UnionCases.Length <= 1 then - [], [] - elif hasNullCase ctx.layout then + if cud.UnionCases.Length <= 1 || hasNullCase ctx.layout then [], [] else let additionalAttributes = - if - g.checkNullness - && g.langFeatureNullness - && (match ctx.layout with - | ValueTypeLayout -> true - | ReferenceTypeLayout -> false) - && not alt.IsNullary - then + match ctx.layout with + | ValueTypeLayout when g.checkNullness && g.langFeatureNullness && not alt.IsNullary -> let notnullfields = alt.FieldDefs // Fields that are nullable even from F# perspective has an [Nullable] attribute on them @@ -1120,9 +1112,7 @@ let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: I emptyILCustomAttrs else mkILCustomAttrsFromArray [| GetNotNullWhenTrueAttribute g fieldNames |] - - else - emptyILCustomAttrs + | _ -> emptyILCustomAttrs [ (mkILNonGenericInstanceMethod ( From 4d648f05fe8d2a1e0f1706e095e2040cf3d71c60 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:45:28 +0100 Subject: [PATCH 11/44] Simplify emitRootClassFields loop guard with layout match Replace 'altFoldsAsRootInstance || (match layout ValueTypeLayout -> true | ReferenceTypeLayout -> false)' with a clear match: value types always put fields on root, reference types only when they fold as root instance. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index f515277dd75..ec77acdfbbc 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -1518,12 +1518,12 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin let fieldsEmitted = HashSet<_>() for cidx, alt in Array.indexed cud.UnionCases do - if - altFoldsAsRootInstance ctx.layout alt cud.UnionCases - || (match ctx.layout with - | ValueTypeLayout -> true - | ReferenceTypeLayout -> false) - then + let fieldsOnRoot = + match ctx.layout with + | ValueTypeLayout -> true + | ReferenceTypeLayout -> altFoldsAsRootInstance ctx.layout alt cud.UnionCases + + if fieldsOnRoot then let baseInit = if isStruct then From 210eb7022f60312ccff7ead33909a36cf6f870db Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:47:22 +0100 Subject: [PATCH 12/44] Decompose emitRootConstructors complex guard into named conditions Break the 5-line boolean expression into named conditions with comments explaining when the root ctor is needed vs skipped. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index ec77acdfbbc..0f392c427a9 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -1590,14 +1590,17 @@ let private emitRootConstructors (ctx: TypeDefContext) selfFields tagFieldsInObj let cud = ctx.cud let baseTy = ctx.baseTy - if - (List.isEmpty selfFields - && List.isEmpty tagFieldsInObject - && not (List.isEmpty selfMeths)) - || td.IsStruct - || cud.UnionCases - |> Array.forall (fun alt -> altFoldsAsRootInstance ctx.layout alt cud.UnionCases) - then + // The root-class base ctor (taking only tag fields) is needed when: + // - There are nested subtypes that call super(tag) — i.e. not all cases fold to root + // - It's not a struct (structs use static maker methods) + // - There aren't already instance fields from folded cases covering the ctor need + let allCasesFoldToRoot = + cud.UnionCases |> Array.forall (fun alt -> altFoldsAsRootInstance ctx.layout alt cud.UnionCases) + + let hasFieldsOrTagButNoMethods = + not (List.isEmpty selfFields && List.isEmpty tagFieldsInObject && not (List.isEmpty selfMeths)) + + if td.IsStruct || allCasesFoldToRoot || not hasFieldsOrTagButNoMethods then [] else let baseTySpec = From 61bff7a73360bdeb1798abc1810d5a17f9d37082 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:49:51 +0100 Subject: [PATCH 13/44] Replace isStruct bool with layout match in rewriteFieldsForStructFlattening The function took an isStruct bool and checked 'isStruct && cases > 1' which is exactly TaggedStructUnion. Match on layout directly and remove the now-unnecessary cud parameter. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 0f392c427a9..7e47e9d1869 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -1434,13 +1434,9 @@ let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCa /// Rewrite field nullable attributes for struct flattening. /// When a struct DU has multiple cases, all boxed fields become potentially nullable /// because only one case's fields are valid at a time. -let private rewriteFieldsForStructFlattening (g: TcGlobals) (cud: IlxUnionInfo) (alt: IlxUnionCase) isStruct = - if - isStruct - && cud.UnionCases.Length > 1 - && g.checkNullness - && g.langFeatureNullness - then +let private rewriteFieldsForStructFlattening (g: TcGlobals) (alt: IlxUnionCase) (layout: UnionLayout) = + match layout with + | UnionLayout.TaggedStructUnion _ when g.checkNullness && g.langFeatureNullness -> alt.FieldDefs |> Array.map (fun field -> if field.Type.IsNominal && field.Type.Boxity = AsValue then @@ -1479,8 +1475,7 @@ let private rewriteFieldsForStructFlattening (g: TcGlobals) (cud: IlxUnionInfo) field.ILField.With(customAttrs = mkILCustomAttrsFromArray attrs) |> IlxUnionCaseField) - else - alt.FieldDefs + | _ -> alt.FieldDefs /// Add [Nullable(2)] attribute to union root type when null is permitted. let private rootTypeNullableAttrs (g: TcGlobals) (td: ILTypeDef) (cud: IlxUnionInfo) = @@ -1556,7 +1551,7 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin |> ctx.stampMethodAsGenerated ] - let fieldDefs = rewriteFieldsForStructFlattening g cud alt isStruct + let fieldDefs = rewriteFieldsForStructFlattening g alt ctx.layout let fieldsToBeAddedIntoType = fieldDefs From 822e235a8933f7dd4b03a041fea0cb228fd9c02d Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:53:12 +0100 Subject: [PATCH 14/44] Eliminate isSingleNonNullaryFoldedToRoot in favor of altFoldsAsRootInstance isSingleNonNullaryFoldedToRoot duplicated logic already in altFoldsAsRootInstance for SmallRefUnion. Replace all 4 call sites with altFoldsAsRootInstance which encodes the same semantics. Also simplify caseFoldsToRootClass which was a thin wrapper around the eliminated fn. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 7e47e9d1869..2f3f82d5f68 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -439,23 +439,13 @@ let mkTagDiscriminate ilg cuspec _baseTy cidx = let mkTagDiscriminateThen ilg cuspec cidx after = [ mkGetTag ilg cuspec; mkLdcInt32 cidx ] @ mkCeqThen after -/// True when a non-nullary alt in SmallRefUnion with a null sibling is the single -/// non-nullary case whose fields fold into the root class. -/// Encodes RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull: -/// requires nullCaseIdx.IsSome (all nullary alts are null-represented), -/// not alt.IsNullary, and exactly one non-nullary case exists. -let private isSingleNonNullaryFoldedToRoot (cuspec: IlxUnionSpec) (nullCaseIdx: int option) (alt: IlxUnionCase) = - nullCaseIdx.IsSome - && not alt.IsNullary - && cuspec.AlternativesArray |> Array.existsOne (fun a -> not a.IsNullary) - /// Encodes RepresentAlternativeAsFreshInstancesOfRootClass for a given layout and alt. /// True when the case is constructed directly on the root type (not a nested type). /// This covers: ListTailOrNull cons case, or SmallRefUnion with single non-nullary + null sibling. let private caseFoldsToRootClass (layout: UnionLayout) (cuspec: IlxUnionSpec) (alt: IlxUnionCase) = match layout with | UnionLayout.ListTailOrNull _ -> alt.Name = ALT_NAME_CONS - | UnionLayout.SmallRefUnion(_, nullCaseIdx) -> isSingleNonNullaryFoldedToRoot cuspec nullCaseIdx alt + | UnionLayout.SmallRefUnion _ -> altFoldsAsRootInstance layout alt cuspec.AlternativesArray | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ | UnionLayout.TaggedRefUnion _ @@ -486,7 +476,7 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = let ctorFieldTys = alt.FieldTypes |> Array.toList [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] // RepresentAlternativeAsFreshInstancesOfRootClass: single non-nullary with null sibling - | UnionLayout.SmallRefUnion(_, nullCaseIdx) when isSingleNonNullaryFoldedToRoot cuspec nullCaseIdx alt -> + | UnionLayout.SmallRefUnion _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> let baseTy = baseTyOfUnionSpec cuspec let ctorFieldTys = alt.FieldTypes |> Array.toList [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] @@ -572,7 +562,7 @@ let private emitIsCase ilg avoidHelpers cuspec (layout: UnionLayout) cidx = [ AI_ldnull; AI_ceq ] | _ -> match layout with - | UnionLayout.SmallRefUnion(_, nullCaseIdx) when isSingleNonNullaryFoldedToRoot cuspec nullCaseIdx alt -> + | UnionLayout.SmallRefUnion _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> // Single non-nullary with all null siblings: test via non-null [ AI_ldnull; AI_cgt_un ] | UnionLayout.SingleCaseRef _ @@ -638,7 +628,7 @@ let private emitBranchOnCase ilg sense avoidHelpers cuspec (layout: UnionLayout) [ I_brcmp(neg, tg) ] | _ -> match layout with - | UnionLayout.SmallRefUnion(_, nullCaseIdx) when isSingleNonNullaryFoldedToRoot cuspec nullCaseIdx alt -> + | UnionLayout.SmallRefUnion _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> // Single non-nullary with all null siblings: branch on non-null [ I_brcmp(pos, tg) ] | UnionLayout.SingleCaseRef _ From c16a0ef62a616f8196c647734332d1978fffe19d Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:55:28 +0100 Subject: [PATCH 15/44] Eliminate caseFoldsToRootClass, inline via altFoldsAsRootInstance caseFoldsToRootClass was a thin wrapper around altFoldsAsRootInstance for SmallRefUnion. All 3 callers are already inside SmallRefUnion match arms, so they can call altFoldsAsRootInstance directly. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 18 +++--------------- 1 file changed, 3 insertions(+), 15 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 2f3f82d5f68..093acc84367 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -439,18 +439,6 @@ let mkTagDiscriminate ilg cuspec _baseTy cidx = let mkTagDiscriminateThen ilg cuspec cidx after = [ mkGetTag ilg cuspec; mkLdcInt32 cidx ] @ mkCeqThen after -/// Encodes RepresentAlternativeAsFreshInstancesOfRootClass for a given layout and alt. -/// True when the case is constructed directly on the root type (not a nested type). -/// This covers: ListTailOrNull cons case, or SmallRefUnion with single non-nullary + null sibling. -let private caseFoldsToRootClass (layout: UnionLayout) (cuspec: IlxUnionSpec) (alt: IlxUnionCase) = - match layout with - | UnionLayout.ListTailOrNull _ -> alt.Name = ALT_NAME_CONS - | UnionLayout.SmallRefUnion _ -> altFoldsAsRootInstance layout alt cuspec.AlternativesArray - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedRefUnion _ - | UnionLayout.TaggedStructUnion _ -> false - let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAltIdx cuspec alt cidx @@ -693,7 +681,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: Ilx I_brcmp((if cmpNull then BI_brtrue else BI_brfalse), cg.CodeLabel failLab) let testBlock = - if cmpNull || caseFoldsToRootClass layout cuspec alt then + if cmpNull || altFoldsAsRootInstance layout alt cuspec.AlternativesArray then [ test ] else let altName = alt.Name @@ -761,7 +749,7 @@ let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail avoidHelpers cuspec let altTy = tyForAltIdx cuspec alt cidx cg.EmitInstr(I_castclass altTy) | UnionLayout.SmallRefUnion _ -> - if caseFoldsToRootClass layout cuspec alt then + if altFoldsAsRootInstance layout alt cuspec.AlternativesArray then // Single non-nullary with all null siblings: folded to root () else @@ -792,7 +780,7 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) avoidHelpers cuspec (layout cg.EmitInstr(mkLdloc locn) let testInstr = I_brcmp((if cmpNull then BI_brfalse else BI_brtrue), tg) - if cmpNull || caseFoldsToRootClass layout cuspec alt then + if cmpNull || altFoldsAsRootInstance layout alt cuspec.AlternativesArray then cg.EmitInstr testInstr else cg.EmitInstrs(mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy testInstr) From 75c5958b05754acd2cfbcbf2cea82c649bc61a59 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:57:31 +0100 Subject: [PATCH 16/44] Refactor classifyUnion: use match expression for readable classification Replace nested if/elif chain with a match on (isList, alts.Length, isStruct) tuple. Hoist allNullary computation. Each match arm maps cleanly to one UnionLayout case. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 26 ++++++++++---------------- 1 file changed, 10 insertions(+), 16 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 093acc84367..1b1924136f0 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -52,18 +52,14 @@ let mkCasesTypeRef (cuspec: IlxUnionSpec) = cuspec.TypeRef /// Core classification logic. Computes the UnionLayout for any union. let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isStruct = - if isList then - UnionLayout.ListTailOrNull baseTy - elif alts.Length = 1 then - if isStruct then - UnionLayout.SingleCaseStruct baseTy - else - UnionLayout.SingleCaseRef baseTy - elif - not isStruct - && alts.Length < 4 - && not (alts |> Array.forall (fun alt -> alt.IsNullary)) - then + let allNullary = alts |> Array.forall (fun alt -> alt.IsNullary) + + match isList, alts.Length, isStruct with + | true, _, _ -> UnionLayout.ListTailOrNull baseTy + | _, 1, true -> UnionLayout.SingleCaseStruct baseTy + | _, 1, false -> UnionLayout.SingleCaseRef baseTy + | _, n, false when n < 4 && not allNullary -> + // Small ref union (2-3 cases, not all nullary): discriminate by isinst let nullCaseIdx = if nullPermitted @@ -75,10 +71,8 @@ let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isS None UnionLayout.SmallRefUnion(baseTy, nullCaseIdx) - elif isStruct then - UnionLayout.TaggedStructUnion(baseTy, alts |> Array.forall (fun alt -> alt.IsNullary)) - else - UnionLayout.TaggedRefUnion(baseTy, alts |> Array.forall (fun alt -> alt.IsNullary)) + | _, _, true -> UnionLayout.TaggedStructUnion(baseTy, allNullary) + | _, _, false -> UnionLayout.TaggedRefUnion(baseTy, allNullary) /// Classify from an IlxUnionSpec (used in IL instruction generation). let classifyFromSpec (cuspec: IlxUnionSpec) = From 32953dd9f5b8dffeae25725e59cb55380d0df729 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 11:59:46 +0100 Subject: [PATCH 17/44] Simplify maintainConstantField: replace chained AP-to-bool with match Replace 'alt.IsNullary && (match ValueTypeLayout -> false | ...) && (match CaseIsNull -> false | ...)' with a nested match that reads naturally: null-represented cases don't need a constant field, value types don't need one, ref types do. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 1b1924136f0..2cd9fc1a427 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -227,14 +227,16 @@ let private altOptimizesToRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: /// Should a static constant field be maintained for this nullary alternative? /// Equivalent to the old MaintainPossiblyUniqueConstantFieldForAlternative. +/// Only for nullary cases on reference types that are not null-represented. let private maintainConstantField (layout: UnionLayout) (alt: IlxUnionCase) (cidx: int) = alt.IsNullary - && (match layout with + && + match layout, cidx with + | CaseIsNull -> false + | _ -> + match layout with + | ReferenceTypeLayout -> true | ValueTypeLayout -> false - | ReferenceTypeLayout -> true) - && (match layout, cidx with - | CaseIsNull -> false - | CaseIsAllocated -> true) /// Does any case use null representation? let private hasNullCase (layout: UnionLayout) = From 405c27894c3f61adae1667e645c21d8b35ab3974 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 12:04:12 +0100 Subject: [PATCH 18/44] Simplify emitNullaryCaseAccessor: match on CaseIsNull directly Replace 'g.checkNullness && g.langFeatureNullness && (match CaseIsNull -> true | ...)' with a direct match on (layout, num) with a when guard, eliminating the AP-to-bool intermediate. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 2cd9fc1a427..c72728b48f9 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -1127,13 +1127,8 @@ let private emitNullaryCaseAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUn let attr = cud.DebugPoint let attributes = - if - g.checkNullness - && g.langFeatureNullness - && (match ctx.layout, num with - | CaseIsNull -> true - | CaseIsAllocated -> false) - then + match ctx.layout, num with + | CaseIsNull when g.checkNullness && g.langFeatureNullness -> let noTypars = td.GenericParams.Length GetNullableAttribute @@ -1144,8 +1139,7 @@ let private emitNullaryCaseAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUn ] // The typars are not (i.e. do not change option into option |> Array.singleton |> mkILCustomAttrsFromArray - else - emptyILCustomAttrs + | _ -> emptyILCustomAttrs let nullaryMeth = mkILNonGenericStaticMethod ( From 9f3d36a18bc8e402c6096ca201d1b9326bcd87af Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 12:08:19 +0100 Subject: [PATCH 19/44] Apply fantomas formatting Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index c72728b48f9..d4286c1b1bb 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -230,13 +230,12 @@ let private altOptimizesToRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: /// Only for nullary cases on reference types that are not null-represented. let private maintainConstantField (layout: UnionLayout) (alt: IlxUnionCase) (cidx: int) = alt.IsNullary - && - match layout, cidx with - | CaseIsNull -> false - | _ -> - match layout with - | ReferenceTypeLayout -> true - | ValueTypeLayout -> false + && match layout, cidx with + | CaseIsNull -> false + | _ -> + match layout with + | ReferenceTypeLayout -> true + | ValueTypeLayout -> false /// Does any case use null representation? let private hasNullCase (layout: UnionLayout) = @@ -324,7 +323,10 @@ let private tyForAltIdx cuspec (alt: IlxUnionCase) cidx = mkILNamedTy cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs let tyForAlt (cuspec: IlxUnionSpec) (alt: IlxUnionCase) = - let cidx = cuspec.AlternativesArray |> Array.findIndex (fun (a: IlxUnionCase) -> a.Name = alt.Name) + let cidx = + cuspec.AlternativesArray + |> Array.findIndex (fun (a: IlxUnionCase) -> a.Name = alt.Name) + tyForAltIdx cuspec alt cidx let GetILTypeForAlternative cuspec alt = @@ -1558,10 +1560,15 @@ let private emitRootConstructors (ctx: TypeDefContext) selfFields tagFieldsInObj // - It's not a struct (structs use static maker methods) // - There aren't already instance fields from folded cases covering the ctor need let allCasesFoldToRoot = - cud.UnionCases |> Array.forall (fun alt -> altFoldsAsRootInstance ctx.layout alt cud.UnionCases) + cud.UnionCases + |> Array.forall (fun alt -> altFoldsAsRootInstance ctx.layout alt cud.UnionCases) let hasFieldsOrTagButNoMethods = - not (List.isEmpty selfFields && List.isEmpty tagFieldsInObject && not (List.isEmpty selfMeths)) + not ( + List.isEmpty selfFields + && List.isEmpty tagFieldsInObject + && not (List.isEmpty selfMeths) + ) if td.IsStruct || allCasesFoldToRoot || not hasFieldsOrTagButNoMethods then [] From 8ef493f0958d55d2130f791db82685e897fd21e2 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 15:04:10 +0100 Subject: [PATCH 20/44] Wave 1: Replace avoidHelpers bool with DataAccess DU MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Introduce DataAccess = RawFields | ViaHelpers | ViaListHelpers that collapses the per-call-site avoidHelpers:bool × per-union HasHelpers enum into a single DU computed once at entry points. - avoidHelpers parameter eliminated from 16 internal + 7 public functions - doesRuntimeTypeDiscriminateUseHelper simplified from 3-way && to DU match - emitLdDataTagPrim: 'match HasHelpers with AllHelpers when not avoidHelpers' becomes clean 'match access with ViaHelpers | ViaListHelpers' - adjustFieldName split: DataAccess version for access path, adjustFieldNameForTypeDef for type-def path Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 151 ++++++++++++++++----------- src/Compiler/CodeGen/EraseUnions.fsi | 24 +++-- src/Compiler/CodeGen/IlxGen.fs | 33 +++--- 3 files changed, 126 insertions(+), 82 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index d4286c1b1bb..3c8dd6eb6d0 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -14,6 +14,29 @@ open FSharp.Compiler.TcGlobals open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types +/// How to access union data at a given call site. +/// Combines the per-call-site 'avoidHelpers' flag with the per-union 'HasHelpers' setting +/// into a single value computed once at the entry point. +[] +type DataAccess = + /// Use raw field loads/stores (intra-assembly access, or union has no helpers) + | RawFields + /// Use helper methods (get_Tag, get_IsXxx, NewXxx) — inter-assembly with AllHelpers or SpecialFSharpOptionHelpers + | ViaHelpers + /// Use list-specific helper methods (HeadOrDefault, TailOrNull naming) — inter-assembly with SpecialFSharpListHelpers + | ViaListHelpers + +/// Compute the access strategy from the per-call-site flag and per-union helpers setting. +let computeDataAccess (avoidHelpers: bool) (cuspec: IlxUnionSpec) = + if avoidHelpers then + DataAccess.RawFields + else + match cuspec.HasHelpers with + | IlxUnionHasHelpers.NoHelpers -> DataAccess.RawFields + | IlxUnionHasHelpers.AllHelpers + | IlxUnionHasHelpers.SpecialFSharpOptionHelpers -> DataAccess.ViaHelpers + | IlxUnionHasHelpers.SpecialFSharpListHelpers -> DataAccess.ViaListHelpers + [] let TagNil = 0 @@ -347,16 +370,12 @@ let altOfUnionSpec (cuspec: IlxUnionSpec) cidx = // Nullary cases on types with helpers do not reveal their underlying type even when // using runtime type discrimination, because the underlying type is never needed from // C# code and pollutes the visible API surface. In this case we must discriminate by -// calling the IsFoo helper. This only applies to discriminations outside the -// assembly where the type is defined (indicated by 'avoidHelpers' flag - if this is true -// then the reference is intra-assembly). -let doesRuntimeTypeDiscriminateUseHelper avoidHelpers (cuspec: IlxUnionSpec) (alt: IlxUnionCase) = - not avoidHelpers - && alt.IsNullary - && cuspec.HasHelpers = IlxUnionHasHelpers.AllHelpers +// calling the IsFoo helper. This only applies when accessing via helpers (inter-assembly). +let doesRuntimeTypeDiscriminateUseHelper (access: DataAccess) (alt: IlxUnionCase) = + alt.IsNullary && access = DataAccess.ViaHelpers -let mkRuntimeTypeDiscriminate (ilg: ILGlobals) avoidHelpers cuspec alt altName altTy = - let useHelper = doesRuntimeTypeDiscriminateUseHelper avoidHelpers cuspec alt +let mkRuntimeTypeDiscriminate (ilg: ILGlobals) access cuspec alt altName altTy = + let useHelper = doesRuntimeTypeDiscriminateUseHelper access alt if useHelper then let baseTy = baseTyOfUnionSpec cuspec @@ -367,13 +386,13 @@ let mkRuntimeTypeDiscriminate (ilg: ILGlobals) avoidHelpers cuspec alt altName a else [ I_isinst altTy; AI_ldnull; AI_cgt_un ] -let mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy after = - let useHelper = doesRuntimeTypeDiscriminateUseHelper avoidHelpers cuspec alt +let mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy after = + let useHelper = doesRuntimeTypeDiscriminateUseHelper access alt match after with | I_brcmp(BI_brfalse, _) | I_brcmp(BI_brtrue, _) when not useHelper -> [ I_isinst altTy; after ] - | _ -> mkRuntimeTypeDiscriminate ilg avoidHelpers cuspec alt altName altTy @ [ after ] + | _ -> mkRuntimeTypeDiscriminate ilg access cuspec alt altName altTy @ [ after ] let mkGetTagFromField ilg cuspec baseTy = mkNormalLdfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) @@ -381,36 +400,38 @@ let mkGetTagFromField ilg cuspec baseTy = let mkSetTagToField ilg cuspec baseTy = mkNormalStfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) -let adjustFieldName hasHelpers nm = +let adjustFieldNameForTypeDef hasHelpers nm = match hasHelpers, nm with | SpecialFSharpListHelpers, "Head" -> "HeadOrDefault" | SpecialFSharpListHelpers, "Tail" -> "TailOrNull" | _ -> nm -let mkLdData (avoidHelpers, cuspec, cidx, fidx) = +let adjustFieldName access nm = + match access, nm with + | DataAccess.ViaListHelpers, "Head" -> "HeadOrDefault" + | DataAccess.ViaListHelpers, "Tail" -> "TailOrNull" + | _ -> nm + +let mkLdData (access, cuspec, cidx, fidx) = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAltIdx cuspec alt cidx let fieldDef = alt.FieldDef fidx - if avoidHelpers then - mkNormalLdfld (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) - else - mkNormalCall ( - mkILNonGenericInstanceMethSpecInTy (altTy, "get_" + adjustFieldName cuspec.HasHelpers fieldDef.Name, [], fieldDef.Type) - ) + match access with + | DataAccess.RawFields -> mkNormalLdfld (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) + | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (altTy, "get_" + adjustFieldName access fieldDef.Name, [], fieldDef.Type)) -let mkLdDataAddr (avoidHelpers, cuspec, cidx, fidx) = +let mkLdDataAddr (access, cuspec, cidx, fidx) = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAltIdx cuspec alt cidx let fieldDef = alt.FieldDef fidx - if avoidHelpers then - mkNormalLdflda (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) - else - failwith (sprintf "can't load address using helpers, for fieldDef %s" fieldDef.LowerName) + match access with + | DataAccess.RawFields -> mkNormalLdflda (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) + | _ -> failwith (sprintf "can't load address using helpers, for fieldDef %s" fieldDef.LowerName) -let mkGetTailOrNull avoidHelpers cuspec = - mkLdData (avoidHelpers, cuspec, 1, 1) (* tail is in alternative 1, field number 1 *) +let mkGetTailOrNull access cuspec = + mkLdData (access, cuspec, 1, 1) (* tail is in alternative 1, field number 1 *) let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = let baseTy = baseTyOfUnionSpec cuspec @@ -537,7 +558,7 @@ let mkNewData ilg (cuspec, cidx) = // Everything else: raw construction | _ -> emitRawConstruction ilg cuspec layout cidx -let private emitIsCase ilg avoidHelpers cuspec (layout: UnionLayout) cidx = +let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = let alt = altOfUnionSpec cuspec cidx let altTy = tyForAltIdx cuspec alt cidx let altName = alt.Name @@ -553,18 +574,18 @@ let private emitIsCase ilg avoidHelpers cuspec (layout: UnionLayout) cidx = [ AI_ldnull; AI_cgt_un ] | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> [ mkLdcInt32 1 ] - | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminate ilg avoidHelpers cuspec alt altName altTy + | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminate ilg access cuspec alt altName altTy | UnionLayout.TaggedRefUnion _ | UnionLayout.TaggedStructUnion _ -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx | UnionLayout.ListTailOrNull _ -> match cidx with - | TagNil -> [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_ceq ] - | TagCons -> [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_cgt_un ] + | TagNil -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_ceq ] + | TagCons -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] | _ -> failwith "emitIsCase - unexpected list case index" -let mkIsData ilg (avoidHelpers, cuspec, cidx) = +let mkIsData ilg (access, cuspec, cidx) = let layout = classifyFromSpec cuspec - emitIsCase ilg avoidHelpers cuspec layout cidx + emitIsCase ilg access cuspec layout cidx type ICodeGen<'Mark> = abstract CodeLabel: 'Mark -> ILCodeLabel @@ -601,7 +622,7 @@ let genWith g : ILCode = Locals = [] } -let private emitBranchOnCase ilg sense avoidHelpers cuspec (layout: UnionLayout) cidx tg = +let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx tg = let neg = (if sense then BI_brfalse else BI_brtrue) let pos = (if sense then BI_brtrue else BI_brfalse) let alt = altOfUnionSpec cuspec cidx @@ -619,27 +640,26 @@ let private emitBranchOnCase ilg sense avoidHelpers cuspec (layout: UnionLayout) [ I_brcmp(pos, tg) ] | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> [] - | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy (I_brcmp(pos, tg)) + | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy (I_brcmp(pos, tg)) | UnionLayout.TaggedRefUnion _ | UnionLayout.TaggedStructUnion _ -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) | UnionLayout.ListTailOrNull _ -> match cidx with - | TagNil -> [ mkGetTailOrNull avoidHelpers cuspec; I_brcmp(neg, tg) ] - | TagCons -> [ mkGetTailOrNull avoidHelpers cuspec; I_brcmp(pos, tg) ] + | TagNil -> [ mkGetTailOrNull access cuspec; I_brcmp(neg, tg) ] + | TagCons -> [ mkGetTailOrNull access cuspec; I_brcmp(pos, tg) ] | _ -> failwith "emitBranchOnCase - unexpected list case index" -let mkBrIsData ilg sense (avoidHelpers, cuspec, cidx, tg) = +let mkBrIsData ilg sense (access, cuspec, cidx, tg) = let layout = classifyFromSpec cuspec - emitBranchOnCase ilg sense avoidHelpers cuspec layout cidx tg + emitBranchOnCase ilg sense access cuspec layout cidx tg -let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: IlxUnionSpec) = - // If helpers exist, use them - match cuspec.HasHelpers with - | SpecialFSharpListHelpers - | AllHelpers when not avoidHelpers -> +let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionSpec) = + match access with + | DataAccess.ViaHelpers + | DataAccess.ViaListHelpers -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstr(mkGetTagFromHelpers ilg cuspec) - | _ -> + | DataAccess.RawFields -> let layout = classifyFromSpec cuspec let alts = cuspec.Alternatives @@ -648,7 +668,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: Ilx | UnionLayout.ListTailOrNull _ -> // leaves 1 if cons, 0 if not ldOpt |> Option.iter cg.EmitInstr - cg.EmitInstrs [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_cgt_un ] + cg.EmitInstrs [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] | UnionLayout.TaggedRefUnion(baseTy, _) | UnionLayout.TaggedStructUnion(baseTy, _) -> ldOpt |> Option.iter cg.EmitInstr @@ -684,7 +704,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: Ilx else let altName = alt.Name let altTy = tyForAltIdx cuspec alt cidx - mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy test + mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy test cg.EmitInstrs(ld :: testBlock) cg.SetMarkToHere internalLab @@ -699,10 +719,10 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: Ilx cg.EmitInstr(mkLdcInt32 0) cg.SetMarkToHere outlab -let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: IlxUnionSpec) = - emitLdDataTagPrim ilg None cg (avoidHelpers, cuspec) +let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionSpec) = + emitLdDataTagPrim ilg None cg (access, cuspec) -let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail avoidHelpers cuspec (layout: UnionLayout) cidx = +let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layout: UnionLayout) cidx = let alt = altOfUnionSpec cuspec cidx match layout, cidx with @@ -724,7 +744,7 @@ let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail avoidHelpers cuspec let outlab = cg.GenerateDelayMark() let internal1 = cg.GenerateDelayMark() cg.EmitInstr AI_dup - emitLdDataTagPrim ilg None cg (avoidHelpers, cuspec) + emitLdDataTagPrim ilg None cg (access, cuspec) cg.EmitInstrs [ mkLdcInt32 cidx; I_brcmp(BI_beq, cg.CodeLabel outlab) ] cg.SetMarkToHere internal1 cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] @@ -755,11 +775,11 @@ let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail avoidHelpers cuspec let altTy = tyForAltIdx cuspec alt cidx cg.EmitInstr(I_castclass altTy) -let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, avoidHelpers, cuspec, cidx) = +let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, access, cuspec, cidx) = let layout = classifyFromSpec cuspec - emitCastToCase ilg cg canfail avoidHelpers cuspec layout cidx + emitCastToCase ilg cg canfail access cuspec layout cidx -let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) avoidHelpers cuspec (layout: UnionLayout) cases = +let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: UnionLayout) cases = let baseTy = baseTyOfUnionSpec cuspec match layout with @@ -781,7 +801,7 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) avoidHelpers cuspec (layout if cmpNull || altFoldsAsRootInstance layout alt cuspec.AlternativesArray then cg.EmitInstr testInstr else - cg.EmitInstrs(mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy testInstr) + cg.EmitInstrs(mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy testInstr) cg.SetMarkToHere failLab @@ -817,9 +837,9 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) avoidHelpers cuspec (layout | UnionLayout.ListTailOrNull _ -> failwith "unexpected: switches on lists should have been eliminated to brisdata tests" -let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = +let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (access, cuspec, cases) = let layout = classifyFromSpec cuspec - emitCaseSwitch ilg cg avoidHelpers cuspec layout cases + emitCaseSwitch ilg cg access cuspec layout cases //--------------------------------------------------- // Generate the union classes @@ -838,7 +858,7 @@ let mkMethodsAndPropertiesForFields fields |> Array.map (fun field -> ILPropertyDef( - name = adjustFieldName hasHelpers field.Name, + name = adjustFieldNameForTypeDef hasHelpers field.Name, attributes = PropertyAttributes.None, setMethod = None, getMethod = @@ -846,7 +866,7 @@ let mkMethodsAndPropertiesForFields mkILMethRef ( ilTy.TypeRef, ILCallingConv.Instance, - "get_" + adjustFieldName hasHelpers field.Name, + "get_" + adjustFieldNameForTypeDef hasHelpers field.Name, 0, [], field.Type @@ -875,7 +895,7 @@ let mkMethodsAndPropertiesForFields yield mkILNonGenericInstanceMethod ( - "get_" + adjustFieldName hasHelpers field.Name, + "get_" + adjustFieldNameForTypeDef hasHelpers field.Name, access, [], ilReturn, @@ -1096,7 +1116,14 @@ let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: I cud.HelpersAccessibility, [], mkILReturn g.ilg.typ_Bool, - mkMethodBody (true, [], 2, nonBranchingInstrsToCode ([ mkLdarg0 ] @ mkIsData g.ilg (true, cuspec, num)), attr, imports) + mkMethodBody ( + true, + [], + 2, + nonBranchingInstrsToCode ([ mkLdarg0 ] @ mkIsData g.ilg (DataAccess.RawFields, cuspec, num)), + attr, + imports + ) )) .With(customAttrs = additionalAttributes) |> ctx.stampMethodAsGenerated @@ -1643,7 +1670,7 @@ let private emitTagInfrastructure (ctx: TypeDefContext) = let code = genWith (fun cg -> - emitLdDataTagPrim g.ilg (Some mkLdarg0) cg (true, cuspec) + emitLdDataTagPrim g.ilg (Some mkLdarg0) cg (DataAccess.RawFields, cuspec) cg.EmitInstr I_ret) let body = mkMethodBody (true, [], 2, code, cud.DebugPoint, cud.DebugImports) diff --git a/src/Compiler/CodeGen/EraseUnions.fsi b/src/Compiler/CodeGen/EraseUnions.fsi index 9f69dd4a5cf..7b43ecd9e51 100644 --- a/src/Compiler/CodeGen/EraseUnions.fsi +++ b/src/Compiler/CodeGen/EraseUnions.fsi @@ -10,17 +10,27 @@ open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types open FSharp.Compiler.TcGlobals +/// How to access union data at a given call site. +[] +type DataAccess = + | RawFields + | ViaHelpers + | ViaListHelpers + +/// Compute the access strategy from the per-call-site flag and per-union helpers setting. +val computeDataAccess: avoidHelpers: bool -> cuspec: IlxUnionSpec -> DataAccess + /// Make the instruction sequence for a "newdata" operation val mkNewData: ilg: ILGlobals -> cuspec: IlxUnionSpec * cidx: int -> ILInstr list /// Make the instruction sequence for a "isdata" operation -val mkIsData: ilg: ILGlobals -> avoidHelpers: bool * cuspec: IlxUnionSpec * cidx: int -> ILInstr list +val mkIsData: ilg: ILGlobals -> access: DataAccess * cuspec: IlxUnionSpec * cidx: int -> ILInstr list /// Make the instruction for a "lddata" operation -val mkLdData: avoidHelpers: bool * cuspec: IlxUnionSpec * cidx: int * fidx: int -> ILInstr +val mkLdData: access: DataAccess * cuspec: IlxUnionSpec * cidx: int * fidx: int -> ILInstr /// Make the instruction for a "lddataa" operation -val mkLdDataAddr: avoidHelpers: bool * cuspec: IlxUnionSpec * cidx: int * fidx: int -> ILInstr +val mkLdDataAddr: access: DataAccess * cuspec: IlxUnionSpec * cidx: int * fidx: int -> ILInstr /// Make the instruction for a "stdata" operation val mkStData: cuspec: IlxUnionSpec * cidx: int * fidx: int -> ILInstr @@ -29,7 +39,7 @@ val mkStData: cuspec: IlxUnionSpec * cidx: int * fidx: int -> ILInstr val mkBrIsData: ilg: ILGlobals -> sense: bool -> - avoidHelpers: bool * cuspec: IlxUnionSpec * cidx: int * tg: ILCodeLabel -> + access: DataAccess * cuspec: IlxUnionSpec * cidx: int * tg: ILCodeLabel -> ILInstr list /// Make the type definition for a union type @@ -61,14 +71,14 @@ type ICodeGen<'Mark> = /// Emit the instruction sequence for a "castdata" operation val emitCastData: - ilg: ILGlobals -> cg: ICodeGen<'Mark> -> canfail: bool * avoidHelpers: bool * cuspec: IlxUnionSpec * int -> unit + ilg: ILGlobals -> cg: ICodeGen<'Mark> -> canfail: bool * access: DataAccess * cuspec: IlxUnionSpec * int -> unit /// Emit the instruction sequence for a "lddatatag" operation -val emitLdDataTag: ilg: ILGlobals -> cg: ICodeGen<'Mark> -> avoidHelpers: bool * cuspec: IlxUnionSpec -> unit +val emitLdDataTag: ilg: ILGlobals -> cg: ICodeGen<'Mark> -> access: DataAccess * cuspec: IlxUnionSpec -> unit /// Emit the instruction sequence for a "switchdata" operation val emitDataSwitch: ilg: ILGlobals -> cg: ICodeGen<'Mark> -> - avoidHelpers: bool * cuspec: IlxUnionSpec * cases: (int * ILCodeLabel) list -> + access: DataAccess * cuspec: IlxUnionSpec * cases: (int * ILCodeLabel) list -> unit diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 4e3452a2d8e..fea7514ddc8 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -3944,7 +3944,8 @@ and GenUnionCaseProof cenv cgbuf eenv (e, ucref, tyargs, m) sequel = let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let fty = EraseUnions.GetILTypeForAlternative cuspec idx let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef - EraseUnions.emitCastData g.ilg (UnionCodeGen cgbuf) (false, avoidHelpers, cuspec, idx) + let access = EraseUnions.computeDataAccess avoidHelpers cuspec + EraseUnions.emitCastData g.ilg (UnionCodeGen cgbuf) (false, access, cuspec, idx) CG.EmitInstrs cgbuf (pop 1) (Push [ fty ]) [] // push/pop to match the line above GenSequel cenv eenv.cloc cgbuf sequel @@ -3956,7 +3957,8 @@ and GenGetUnionCaseField cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel = let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let fty = actualTypOfIlxUnionField cuspec idx n let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef - CG.EmitInstr cgbuf (pop 1) (Push [ fty ]) (EraseUnions.mkLdData (avoidHelpers, cuspec, idx, n)) + let access = EraseUnions.computeDataAccess avoidHelpers cuspec + CG.EmitInstr cgbuf (pop 1) (Push [ fty ]) (EraseUnions.mkLdData (access, cuspec, idx, n)) GenSequel cenv eenv.cloc cgbuf sequel and GenGetUnionCaseFieldAddr cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel = @@ -3967,7 +3969,8 @@ and GenGetUnionCaseFieldAddr cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel = let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let fty = actualTypOfIlxUnionField cuspec idx n let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef - CG.EmitInstr cgbuf (pop 1) (Push [ ILType.Byref fty ]) (EraseUnions.mkLdDataAddr (avoidHelpers, cuspec, idx, n)) + let access = EraseUnions.computeDataAccess avoidHelpers cuspec + CG.EmitInstr cgbuf (pop 1) (Push [ ILType.Byref fty ]) (EraseUnions.mkLdDataAddr (access, cuspec, idx, n)) GenSequel cenv eenv.cloc cgbuf sequel and GenGetUnionCaseTag cenv cgbuf eenv (e, tcref, tyargs, m) sequel = @@ -3975,7 +3978,8 @@ and GenGetUnionCaseTag cenv cgbuf eenv (e, tcref, tyargs, m) sequel = GenExpr cenv cgbuf eenv e Continue let cuspec = GenUnionSpec cenv m eenv.tyenv tcref tyargs let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore tcref - EraseUnions.emitLdDataTag g.ilg (UnionCodeGen cgbuf) (avoidHelpers, cuspec) + let access = EraseUnions.computeDataAccess avoidHelpers cuspec + EraseUnions.emitLdDataTag g.ilg (UnionCodeGen cgbuf) (access, cuspec) CG.EmitInstrs cgbuf (pop 1) (Push [ g.ilg.typ_Int32 ]) [] // push/pop to match the line above GenSequel cenv eenv.cloc cgbuf sequel @@ -3984,7 +3988,8 @@ and GenSetUnionCaseField cenv cgbuf eenv (e, ucref, tyargs, n, e2, m) sequel = GenExpr cenv cgbuf eenv e Continue let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef - EraseUnions.emitCastData g.ilg (UnionCodeGen cgbuf) (false, avoidHelpers, cuspec, idx) + let access = EraseUnions.computeDataAccess avoidHelpers cuspec + EraseUnions.emitCastData g.ilg (UnionCodeGen cgbuf) (false, access, cuspec, idx) CG.EmitInstrs cgbuf (pop 1) (Push [ cuspec.DeclaringType ]) [] // push/pop to match the line above GenExpr cenv cgbuf eenv e2 Continue CG.EmitInstr cgbuf (pop 2) Push0 (EraseUnions.mkStData (cuspec, idx, n)) @@ -7796,9 +7801,10 @@ and GenDecisionTreeSwitch let cuspec = GenUnionSpec cenv m eenv.tyenv c.TyconRef tyargs let idx = c.Index let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore c.TyconRef + let access = EraseUnions.computeDataAccess avoidHelpers cuspec let tester = - Some(pop 1, Push [ g.ilg.typ_Bool ], Choice1Of2(avoidHelpers, cuspec, idx)) + Some(pop 1, Push [ g.ilg.typ_Bool ], Choice1Of2(access, cuspec, idx)) GenDecisionTreeTest cenv @@ -7915,7 +7921,8 @@ and GenDecisionTreeSwitch | _ -> failwith "error: mixed constructor/const test?") let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore hdc.TyconRef - EraseUnions.emitDataSwitch g.ilg (UnionCodeGen cgbuf) (avoidHelpers, cuspec, dests) + let access = EraseUnions.computeDataAccess avoidHelpers cuspec + EraseUnions.emitDataSwitch g.ilg (UnionCodeGen cgbuf) (access, cuspec, dests) CG.EmitInstrs cgbuf (pop 1) Push0 [] // push/pop to match the line above GenDecisionTreeCases @@ -8110,8 +8117,8 @@ and GenDecisionTreeTest match tester with | Some(pops, pushes, i) -> match i with - | Choice1Of2(avoidHelpers, cuspec, idx) -> - CG.EmitInstrs cgbuf pops pushes (EraseUnions.mkIsData g.ilg (avoidHelpers, cuspec, idx)) + | Choice1Of2(access, cuspec, idx) -> + CG.EmitInstrs cgbuf pops pushes (EraseUnions.mkIsData g.ilg (access, cuspec, idx)) | Choice2Of2 i -> CG.EmitInstr cgbuf pops pushes i | _ -> () @@ -8202,7 +8209,7 @@ and GenDecisionTreeTest contf) // Turn 'isdata' tests that branch into EI_brisdata tests - | Some(_, _, Choice1Of2(avoidHelpers, cuspec, idx)) -> + | Some(_, _, Choice1Of2(access, cuspec, idx)) -> let failure = CG.GenerateDelayMark cgbuf "testFailure" GenExpr @@ -8210,7 +8217,7 @@ and GenDecisionTreeTest cgbuf eenv e - (CmpThenBrOrContinue(pop 1, EraseUnions.mkBrIsData g.ilg false (avoidHelpers, cuspec, idx, failure.CodeLabel))) + (CmpThenBrOrContinue(pop 1, EraseUnions.mkBrIsData g.ilg false (access, cuspec, idx, failure.CodeLabel))) GenDecisionTreeAndTargetsInner cenv @@ -8242,8 +8249,8 @@ and GenDecisionTreeTest GenExpr cenv cgbuf eenv e Continue match i with - | Choice1Of2(avoidHelpers, cuspec, idx) -> - CG.EmitInstrs cgbuf pops pushes (EraseUnions.mkIsData g.ilg (avoidHelpers, cuspec, idx)) + | Choice1Of2(access, cuspec, idx) -> + CG.EmitInstrs cgbuf pops pushes (EraseUnions.mkIsData g.ilg (access, cuspec, idx)) | Choice2Of2 i -> CG.EmitInstr cgbuf pops pushes i CG.EmitInstr cgbuf (pop 1) Push0 (I_brcmp(BI_brfalse, failure.CodeLabel)) From 13c2bfdfded7ae05707715a5c4a114fa00e54318 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 15:06:49 +0100 Subject: [PATCH 21/44] =?UTF-8?q?Wave=202:=20Rename=20nullCaseIdx=E2=86=92?= =?UTF-8?q?nullAsTrueValueIdx,=20ListTailOrNull=E2=86=92FSharpList?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit nullCaseIdx was confusable with 'nullary' (no data). It actually means UseNullAsTrueValue — a case represented as null at runtime. Renamed to nullAsTrueValueIdx throughout. ListTailOrNull renamed to FSharpList for clarity — this layout is exclusively for F# list<'T>. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 50 ++++++++++++++--------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 3c8dd6eb6d0..56f7995fc04 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -49,13 +49,13 @@ let ALT_NAME_CONS = "Cons" [] type UnionLayout = /// F# list<'a> only. Discrimination via tail field == null. - | ListTailOrNull of baseTy: ILType + | FSharpList of baseTy: ILType /// Single case, reference type. No discrimination needed. | SingleCaseRef of baseTy: ILType /// Single case, struct. No discrimination needed. | SingleCaseStruct of baseTy: ILType /// 2-3 cases, reference, not all-nullary. Discrimination via isinst type checks. - | SmallRefUnion of baseTy: ILType * nullCaseIdx: int option + | SmallRefUnion of baseTy: ILType * nullAsTrueValueIdx: int option /// ≥4 cases (or 2-3 all-nullary), reference. Discrimination via integer _tag field. | TaggedRefUnion of baseTy: ILType * allNullary: bool /// Any struct DU with >1 case. Discrimination via integer _tag field. @@ -78,12 +78,12 @@ let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isS let allNullary = alts |> Array.forall (fun alt -> alt.IsNullary) match isList, alts.Length, isStruct with - | true, _, _ -> UnionLayout.ListTailOrNull baseTy + | true, _, _ -> UnionLayout.FSharpList baseTy | _, 1, true -> UnionLayout.SingleCaseStruct baseTy | _, 1, false -> UnionLayout.SingleCaseRef baseTy | _, n, false when n < 4 && not allNullary -> // Small ref union (2-3 cases, not all nullary): discriminate by isinst - let nullCaseIdx = + let nullAsTrueValueIdx = if nullPermitted && alts |> Array.existsOne (fun alt -> alt.IsNullary) @@ -93,7 +93,7 @@ let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isS else None - UnionLayout.SmallRefUnion(baseTy, nullCaseIdx) + UnionLayout.SmallRefUnion(baseTy, nullAsTrueValueIdx) | _, _, true -> UnionLayout.TaggedStructUnion(baseTy, allNullary) | _, _, false -> UnionLayout.TaggedRefUnion(baseTy, allNullary) @@ -122,7 +122,7 @@ let (|DiscriminateByTagField|DiscriminateByRuntimeType|DiscriminateByTailNull|No | UnionLayout.TaggedRefUnion _ | UnionLayout.TaggedStructUnion _ -> DiscriminateByTagField | UnionLayout.SmallRefUnion _ -> DiscriminateByRuntimeType - | UnionLayout.ListTailOrNull _ -> DiscriminateByTailNull + | UnionLayout.FSharpList _ -> DiscriminateByTailNull | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> NoDiscrimination @@ -132,7 +132,7 @@ let (|HasTagField|NoTagField|) layout = | UnionLayout.TaggedRefUnion _ | UnionLayout.TaggedStructUnion _ -> HasTagField | UnionLayout.SmallRefUnion _ - | UnionLayout.ListTailOrNull _ + | UnionLayout.FSharpList _ | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> NoTagField @@ -141,7 +141,7 @@ let (|FieldsOnRootType|FieldsOnNestedTypes|) layout = match layout with | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ - | UnionLayout.ListTailOrNull _ + | UnionLayout.FSharpList _ | UnionLayout.TaggedStructUnion _ -> FieldsOnRootType | UnionLayout.SmallRefUnion _ | UnionLayout.TaggedRefUnion _ -> FieldsOnNestedTypes @@ -151,7 +151,7 @@ let (|CaseIsNull|CaseIsAllocated|) (layout, cidx) = match layout with | UnionLayout.SmallRefUnion(_, Some nullIdx) when nullIdx = cidx -> CaseIsNull | UnionLayout.SmallRefUnion _ - | UnionLayout.ListTailOrNull _ + | UnionLayout.FSharpList _ | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ | UnionLayout.TaggedRefUnion _ @@ -165,7 +165,7 @@ let (|ValueTypeLayout|ReferenceTypeLayout|) layout = | UnionLayout.SingleCaseRef _ | UnionLayout.SmallRefUnion _ | UnionLayout.TaggedRefUnion _ - | UnionLayout.ListTailOrNull _ -> ReferenceTypeLayout + | UnionLayout.FSharpList _ -> ReferenceTypeLayout /// Does a non-nullary case fold its fields into the root class (no nested type)? let (|NonNullaryFoldsToRoot|NonNullaryInNestedType|) (layout, alt: IlxUnionCase) = @@ -173,7 +173,7 @@ let (|NonNullaryFoldsToRoot|NonNullaryInNestedType|) (layout, alt: IlxUnionCase) | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ | UnionLayout.TaggedStructUnion _ - | UnionLayout.ListTailOrNull _ -> NonNullaryFoldsToRoot + | UnionLayout.FSharpList _ -> NonNullaryFoldsToRoot | UnionLayout.TaggedRefUnion(_, allNullary) when allNullary -> NonNullaryFoldsToRoot | UnionLayout.TaggedRefUnion _ when not alt.IsNullary -> NonNullaryInNestedType | UnionLayout.TaggedRefUnion _ -> NonNullaryFoldsToRoot @@ -227,7 +227,7 @@ let private _validateActivePatterns let private altFoldsAsRootInstance (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) = not alt.IsNullary && (match layout with - | UnionLayout.ListTailOrNull _ -> alt.Name = ALT_NAME_CONS + | UnionLayout.FSharpList _ -> alt.Name = ALT_NAME_CONS | UnionLayout.SingleCaseRef _ -> true | UnionLayout.SmallRefUnion(_, Some _) -> alts |> Array.filter (fun a -> not a.IsNullary) |> Array.length = 1 | _ -> false) @@ -236,7 +236,7 @@ let private altFoldsAsRootInstance (layout: UnionLayout) (alt: IlxUnionCase) (al /// Equivalent to the old OptimizeAlternativeToRootClass. let private altOptimizesToRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) (cidx: int) = match layout with - | UnionLayout.ListTailOrNull _ + | UnionLayout.FSharpList _ | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ | UnionLayout.TaggedStructUnion _ -> true @@ -474,11 +474,11 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = | UnionLayout.SingleCaseRef _ | UnionLayout.SmallRefUnion _ | UnionLayout.TaggedRefUnion _ - | UnionLayout.ListTailOrNull _ when alt.IsNullary -> + | UnionLayout.FSharpList _ when alt.IsNullary -> let baseTy = baseTyOfUnionSpec cuspec [ I_ldsfld(Nonvolatile, mkConstFieldSpec altName baseTy) ] // RepresentAlternativeAsFreshInstancesOfRootClass: list cons folds to root - | UnionLayout.ListTailOrNull _ -> + | UnionLayout.FSharpList _ -> let baseTy = baseTyOfUnionSpec cuspec let ctorFieldTys = alt.FieldTypes |> Array.toList [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] @@ -495,7 +495,7 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = // Default: use nested type ctor | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ - | UnionLayout.ListTailOrNull _ + | UnionLayout.FSharpList _ | UnionLayout.SmallRefUnion _ | UnionLayout.TaggedRefUnion _ | UnionLayout.TaggedStructUnion _ -> [ mkNormalNewobj (mkILCtorMethSpecForTy (altTy, Array.toList alt.FieldTypes)) ] @@ -577,7 +577,7 @@ let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminate ilg access cuspec alt altName altTy | UnionLayout.TaggedRefUnion _ | UnionLayout.TaggedStructUnion _ -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx - | UnionLayout.ListTailOrNull _ -> + | UnionLayout.FSharpList _ -> match cidx with | TagNil -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_ceq ] | TagCons -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] @@ -643,7 +643,7 @@ let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy (I_brcmp(pos, tg)) | UnionLayout.TaggedRefUnion _ | UnionLayout.TaggedStructUnion _ -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) - | UnionLayout.ListTailOrNull _ -> + | UnionLayout.FSharpList _ -> match cidx with | TagNil -> [ mkGetTailOrNull access cuspec; I_brcmp(neg, tg) ] | TagCons -> [ mkGetTailOrNull access cuspec; I_brcmp(pos, tg) ] @@ -665,7 +665,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS let alts = cuspec.Alternatives match layout with - | UnionLayout.ListTailOrNull _ -> + | UnionLayout.FSharpList _ -> // leaves 1 if cons, 0 if not ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] @@ -677,7 +677,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS | UnionLayout.SingleCaseStruct _ -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] - | UnionLayout.SmallRefUnion(baseTy, nullCaseIdx) -> + | UnionLayout.SmallRefUnion(baseTy, nullAsTrueValueIdx) -> // RuntimeTypes: emit multi-way isinst chain let ld = match ldOpt with @@ -693,7 +693,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS let alt = altOfUnionSpec cuspec cidx let internalLab = cg.GenerateDelayMark() let failLab = cg.GenerateDelayMark() - let cmpNull = (nullCaseIdx = Some cidx) + let cmpNull = (nullAsTrueValueIdx = Some cidx) let test = I_brcmp((if cmpNull then BI_brtrue else BI_brfalse), cg.CodeLabel failLab) @@ -749,7 +749,7 @@ let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layo cg.SetMarkToHere internal1 cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] cg.SetMarkToHere outlab - | UnionLayout.ListTailOrNull _ -> + | UnionLayout.FSharpList _ -> // List type: all cases fold to root, no cast needed () | UnionLayout.SingleCaseRef _ -> @@ -783,7 +783,7 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: Unio let baseTy = baseTyOfUnionSpec cuspec match layout with - | UnionLayout.SmallRefUnion(_, nullCaseIdx) -> + | UnionLayout.SmallRefUnion(_, nullAsTrueValueIdx) -> let locn = cg.GenLocal baseTy cg.EmitInstr(mkStloc locn) @@ -793,7 +793,7 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: Unio let altTy = tyForAltIdx cuspec alt cidx let altName = alt.Name let failLab = cg.GenerateDelayMark() - let cmpNull = (nullCaseIdx = Some cidx) + let cmpNull = (nullAsTrueValueIdx = Some cidx) cg.EmitInstr(mkLdloc locn) let testInstr = I_brcmp((if cmpNull then BI_brfalse else BI_brtrue), tg) @@ -835,7 +835,7 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: Unio | [] -> cg.EmitInstr AI_pop | _ -> failwith "unexpected: strange switch on single-case unions should not be present" - | UnionLayout.ListTailOrNull _ -> failwith "unexpected: switches on lists should have been eliminated to brisdata tests" + | UnionLayout.FSharpList _ -> failwith "unexpected: switches on lists should have been eliminated to brisdata tests" let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (access, cuspec, cases) = let layout = classifyFromSpec cuspec From e62c110b33cdb33c83c1f4bb0cc6eba719aa509c Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 15:11:00 +0100 Subject: [PATCH 22/44] Wave 3: Split allNullary bool into explicit TaggedRef/TaggedRefAllNullary DU cases MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit TaggedRefUnion(baseTy, allNullary:bool) → TaggedRef baseTy + TaggedRefAllNullary baseTy TaggedStructUnion(baseTy, allNullary:bool) → TaggedStruct baseTy + TaggedStructAllNullary baseTy Eliminates the hidden 3-way logic where TaggedRefUnion(_, true) was enum-like (all on root), TaggedRefUnion(_, false) split nullary→root vs non-nullary→nested. Now explicit DU cases, no boolean field. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 116 ++++++++++++++++++---------- 1 file changed, 74 insertions(+), 42 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 56f7995fc04..a4cbe18941d 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -56,10 +56,14 @@ type UnionLayout = | SingleCaseStruct of baseTy: ILType /// 2-3 cases, reference, not all-nullary. Discrimination via isinst type checks. | SmallRefUnion of baseTy: ILType * nullAsTrueValueIdx: int option - /// ≥4 cases (or 2-3 all-nullary), reference. Discrimination via integer _tag field. - | TaggedRefUnion of baseTy: ILType * allNullary: bool - /// Any struct DU with >1 case. Discrimination via integer _tag field. - | TaggedStructUnion of baseTy: ILType * allNullary: bool + /// ≥4 cases (or 2-3 all-nullary), reference, not all nullary. Discrimination via integer _tag field. + | TaggedRef of baseTy: ILType + /// ≥4 cases (or 2-3 all-nullary), reference, all nullary. Discrimination via integer _tag field. + | TaggedRefAllNullary of baseTy: ILType + /// Struct DU with >1 case, not all nullary. Discrimination via integer _tag field. + | TaggedStruct of baseTy: ILType + /// Struct DU with >1 case, all nullary. Discrimination via integer _tag field. + | TaggedStructAllNullary of baseTy: ILType let baseTyOfUnionSpec (cuspec: IlxUnionSpec) = mkILNamedTy cuspec.Boxity cuspec.TypeRef cuspec.GenericArgs @@ -94,8 +98,10 @@ let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isS None UnionLayout.SmallRefUnion(baseTy, nullAsTrueValueIdx) - | _, _, true -> UnionLayout.TaggedStructUnion(baseTy, allNullary) - | _, _, false -> UnionLayout.TaggedRefUnion(baseTy, allNullary) + | _, _, true when allNullary -> UnionLayout.TaggedStructAllNullary baseTy + | _, _, true -> UnionLayout.TaggedStruct baseTy + | _, _, false when allNullary -> UnionLayout.TaggedRefAllNullary baseTy + | _, _, false -> UnionLayout.TaggedRef baseTy /// Classify from an IlxUnionSpec (used in IL instruction generation). let classifyFromSpec (cuspec: IlxUnionSpec) = @@ -119,8 +125,10 @@ let classifyFromDef (td: ILTypeDef) (cud: IlxUnionInfo) (baseTy: ILType) = /// How to discriminate between cases at runtime. let (|DiscriminateByTagField|DiscriminateByRuntimeType|DiscriminateByTailNull|NoDiscrimination|) layout = match layout with - | UnionLayout.TaggedRefUnion _ - | UnionLayout.TaggedStructUnion _ -> DiscriminateByTagField + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> DiscriminateByTagField | UnionLayout.SmallRefUnion _ -> DiscriminateByRuntimeType | UnionLayout.FSharpList _ -> DiscriminateByTailNull | UnionLayout.SingleCaseRef _ @@ -129,8 +137,10 @@ let (|DiscriminateByTagField|DiscriminateByRuntimeType|DiscriminateByTailNull|No /// Does the root type have a _tag integer field? let (|HasTagField|NoTagField|) layout = match layout with - | UnionLayout.TaggedRefUnion _ - | UnionLayout.TaggedStructUnion _ -> HasTagField + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> HasTagField | UnionLayout.SmallRefUnion _ | UnionLayout.FSharpList _ | UnionLayout.SingleCaseRef _ @@ -142,9 +152,11 @@ let (|FieldsOnRootType|FieldsOnNestedTypes|) layout = | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ | UnionLayout.FSharpList _ - | UnionLayout.TaggedStructUnion _ -> FieldsOnRootType + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> FieldsOnRootType | UnionLayout.SmallRefUnion _ - | UnionLayout.TaggedRefUnion _ -> FieldsOnNestedTypes + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ -> FieldsOnNestedTypes /// Is a specific case (by index) represented as null? let (|CaseIsNull|CaseIsAllocated|) (layout, cidx) = @@ -154,17 +166,21 @@ let (|CaseIsNull|CaseIsAllocated|) (layout, cidx) = | UnionLayout.FSharpList _ | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedRefUnion _ - | UnionLayout.TaggedStructUnion _ -> CaseIsAllocated + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> CaseIsAllocated /// Is this a value type (struct) or reference type layout? let (|ValueTypeLayout|ReferenceTypeLayout|) layout = match layout with | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedStructUnion _ -> ValueTypeLayout + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> ValueTypeLayout | UnionLayout.SingleCaseRef _ | UnionLayout.SmallRefUnion _ - | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ | UnionLayout.FSharpList _ -> ReferenceTypeLayout /// Does a non-nullary case fold its fields into the root class (no nested type)? @@ -172,11 +188,12 @@ let (|NonNullaryFoldsToRoot|NonNullaryInNestedType|) (layout, alt: IlxUnionCase) match layout with | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedStructUnion _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ | UnionLayout.FSharpList _ -> NonNullaryFoldsToRoot - | UnionLayout.TaggedRefUnion(_, allNullary) when allNullary -> NonNullaryFoldsToRoot - | UnionLayout.TaggedRefUnion _ when not alt.IsNullary -> NonNullaryInNestedType - | UnionLayout.TaggedRefUnion _ -> NonNullaryFoldsToRoot + | UnionLayout.TaggedRefAllNullary _ -> NonNullaryFoldsToRoot + | UnionLayout.TaggedRef _ when not alt.IsNullary -> NonNullaryInNestedType + | UnionLayout.TaggedRef _ -> NonNullaryFoldsToRoot | UnionLayout.SmallRefUnion _ when not alt.IsNullary -> NonNullaryInNestedType | UnionLayout.SmallRefUnion _ -> NonNullaryFoldsToRoot @@ -239,9 +256,10 @@ let private altOptimizesToRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: | UnionLayout.FSharpList _ | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedStructUnion _ -> true - | UnionLayout.TaggedRefUnion(_, true) -> true - | UnionLayout.TaggedRefUnion _ -> alt.IsNullary + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> true + | UnionLayout.TaggedRefAllNullary _ -> true + | UnionLayout.TaggedRef _ -> alt.IsNullary | UnionLayout.SmallRefUnion _ -> (match layout, cidx with | CaseIsNull -> true @@ -473,7 +491,8 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = // → load the singleton static field | UnionLayout.SingleCaseRef _ | UnionLayout.SmallRefUnion _ - | UnionLayout.TaggedRefUnion _ + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ | UnionLayout.FSharpList _ when alt.IsNullary -> let baseTy = baseTyOfUnionSpec cuspec [ I_ldsfld(Nonvolatile, mkConstFieldSpec altName baseTy) ] @@ -488,7 +507,8 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = let ctorFieldTys = alt.FieldTypes |> Array.toList [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] // Struct + IntegerTag + nullary: create via root ctor with tag - | UnionLayout.TaggedStructUnion _ when alt.IsNullary -> + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ when alt.IsNullary -> let baseTy = baseTyOfUnionSpec cuspec let tagField = [ mkTagFieldType ilg cuspec ] [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] @@ -497,8 +517,10 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = | UnionLayout.SingleCaseStruct _ | UnionLayout.FSharpList _ | UnionLayout.SmallRefUnion _ - | UnionLayout.TaggedRefUnion _ - | UnionLayout.TaggedStructUnion _ -> [ mkNormalNewobj (mkILCtorMethSpecForTy (altTy, Array.toList alt.FieldTypes)) ] + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> [ mkNormalNewobj (mkILCtorMethSpecForTy (altTy, Array.toList alt.FieldTypes)) ] let convNewDataInstrInternal ilg cuspec cidx = emitRawConstruction ilg cuspec (classifyFromSpec cuspec) cidx @@ -575,8 +597,10 @@ let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> [ mkLdcInt32 1 ] | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminate ilg access cuspec alt altName altTy - | UnionLayout.TaggedRefUnion _ - | UnionLayout.TaggedStructUnion _ -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx | UnionLayout.FSharpList _ -> match cidx with | TagNil -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_ceq ] @@ -641,8 +665,10 @@ let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> [] | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy (I_brcmp(pos, tg)) - | UnionLayout.TaggedRefUnion _ - | UnionLayout.TaggedStructUnion _ -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) | UnionLayout.FSharpList _ -> match cidx with | TagNil -> [ mkGetTailOrNull access cuspec; I_brcmp(neg, tg) ] @@ -669,8 +695,10 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS // leaves 1 if cons, 0 if not ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] - | UnionLayout.TaggedRefUnion(baseTy, _) - | UnionLayout.TaggedStructUnion(baseTy, _) -> + | UnionLayout.TaggedRef baseTy + | UnionLayout.TaggedRefAllNullary baseTy + | UnionLayout.TaggedStruct baseTy + | UnionLayout.TaggedStructAllNullary baseTy -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstr(mkGetTagFromField ilg cuspec baseTy) | UnionLayout.SingleCaseRef _ @@ -738,7 +766,8 @@ let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layo | _ -> match layout with | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedStructUnion _ -> + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> // Flatten (struct): tag check if canfail, else leave on stack if canfail then let outlab = cg.GenerateDelayMark() @@ -755,11 +784,11 @@ let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layo | UnionLayout.SingleCaseRef _ -> // Single case ref: always on root () - | UnionLayout.TaggedRefUnion(_, allNullary) -> - if allNullary then - // All-nullary (enum-like): all cases on root - () - elif alt.IsNullary then + | UnionLayout.TaggedRefAllNullary _ -> + // All-nullary (enum-like): all cases on root + () + | UnionLayout.TaggedRef _ -> + if alt.IsNullary then // Nullary in tagged ref: constant field in root class, no cast () else @@ -805,8 +834,10 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: Unio cg.SetMarkToHere failLab - | UnionLayout.TaggedRefUnion _ - | UnionLayout.TaggedStructUnion _ -> + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> match cases with | [] -> cg.EmitInstr AI_pop | _ -> @@ -1433,7 +1464,8 @@ let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCa /// because only one case's fields are valid at a time. let private rewriteFieldsForStructFlattening (g: TcGlobals) (alt: IlxUnionCase) (layout: UnionLayout) = match layout with - | UnionLayout.TaggedStructUnion _ when g.checkNullness && g.langFeatureNullness -> + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ when g.checkNullness && g.langFeatureNullness -> alt.FieldDefs |> Array.map (fun field -> if field.Type.IsNominal && field.Type.Boxity = AsValue then From 9667156010fb55c29165659cc2551b775810f30e Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 15:21:57 +0100 Subject: [PATCH 23/44] Wave 3+4: Split allNullary and SmallRefUnion into explicit DU cases MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fix SpecialFSharpOptionHelpers mapping (ViaHelpers, not RawFields). TaggedRefUnion(_, allNullary) → TaggedRef + TaggedRefAllNullary TaggedStructUnion(_, allNullary) → TaggedStruct + TaggedStructAllNullary SmallRefUnion(_, opt) → SmallRef + SmallRefWithNullAsTrueValue(_, idx) UnionLayout now has 8 cases, zero boolean fields, zero option fields. Every match arm is explicit — no hidden 3-way logic via bool destructuring. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 87 +++++++++++++++++++++-------- 1 file changed, 63 insertions(+), 24 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index a4cbe18941d..637a4a18cef 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -54,8 +54,10 @@ type UnionLayout = | SingleCaseRef of baseTy: ILType /// Single case, struct. No discrimination needed. | SingleCaseStruct of baseTy: ILType - /// 2-3 cases, reference, not all-nullary. Discrimination via isinst type checks. - | SmallRefUnion of baseTy: ILType * nullAsTrueValueIdx: int option + /// 2-3 cases, reference, not all-nullary, no null-as-true-value. Discrimination via isinst. + | SmallRef of baseTy: ILType + /// 2-3 cases, reference, not all-nullary, one case represented as null. Discrimination via isinst. + | SmallRefWithNullAsTrueValue of baseTy: ILType * nullAsTrueValueIdx: int /// ≥4 cases (or 2-3 all-nullary), reference, not all nullary. Discrimination via integer _tag field. | TaggedRef of baseTy: ILType /// ≥4 cases (or 2-3 all-nullary), reference, all nullary. Discrimination via integer _tag field. @@ -97,7 +99,9 @@ let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isS else None - UnionLayout.SmallRefUnion(baseTy, nullAsTrueValueIdx) + match nullAsTrueValueIdx with + | Some idx -> UnionLayout.SmallRefWithNullAsTrueValue(baseTy, idx) + | None -> UnionLayout.SmallRef baseTy | _, _, true when allNullary -> UnionLayout.TaggedStructAllNullary baseTy | _, _, true -> UnionLayout.TaggedStruct baseTy | _, _, false when allNullary -> UnionLayout.TaggedRefAllNullary baseTy @@ -129,7 +133,8 @@ let (|DiscriminateByTagField|DiscriminateByRuntimeType|DiscriminateByTailNull|No | UnionLayout.TaggedRefAllNullary _ | UnionLayout.TaggedStruct _ | UnionLayout.TaggedStructAllNullary _ -> DiscriminateByTagField - | UnionLayout.SmallRefUnion _ -> DiscriminateByRuntimeType + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ -> DiscriminateByRuntimeType | UnionLayout.FSharpList _ -> DiscriminateByTailNull | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> NoDiscrimination @@ -141,7 +146,8 @@ let (|HasTagField|NoTagField|) layout = | UnionLayout.TaggedRefAllNullary _ | UnionLayout.TaggedStruct _ | UnionLayout.TaggedStructAllNullary _ -> HasTagField - | UnionLayout.SmallRefUnion _ + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ | UnionLayout.FSharpList _ | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> NoTagField @@ -154,15 +160,17 @@ let (|FieldsOnRootType|FieldsOnNestedTypes|) layout = | UnionLayout.FSharpList _ | UnionLayout.TaggedStruct _ | UnionLayout.TaggedStructAllNullary _ -> FieldsOnRootType - | UnionLayout.SmallRefUnion _ + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ | UnionLayout.TaggedRef _ | UnionLayout.TaggedRefAllNullary _ -> FieldsOnNestedTypes /// Is a specific case (by index) represented as null? let (|CaseIsNull|CaseIsAllocated|) (layout, cidx) = match layout with - | UnionLayout.SmallRefUnion(_, Some nullIdx) when nullIdx = cidx -> CaseIsNull - | UnionLayout.SmallRefUnion _ + | UnionLayout.SmallRefWithNullAsTrueValue(_, nullIdx) when nullIdx = cidx -> CaseIsNull + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ | UnionLayout.FSharpList _ | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ @@ -178,7 +186,8 @@ let (|ValueTypeLayout|ReferenceTypeLayout|) layout = | UnionLayout.TaggedStruct _ | UnionLayout.TaggedStructAllNullary _ -> ValueTypeLayout | UnionLayout.SingleCaseRef _ - | UnionLayout.SmallRefUnion _ + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ | UnionLayout.TaggedRef _ | UnionLayout.TaggedRefAllNullary _ | UnionLayout.FSharpList _ -> ReferenceTypeLayout @@ -194,8 +203,10 @@ let (|NonNullaryFoldsToRoot|NonNullaryInNestedType|) (layout, alt: IlxUnionCase) | UnionLayout.TaggedRefAllNullary _ -> NonNullaryFoldsToRoot | UnionLayout.TaggedRef _ when not alt.IsNullary -> NonNullaryInNestedType | UnionLayout.TaggedRef _ -> NonNullaryFoldsToRoot - | UnionLayout.SmallRefUnion _ when not alt.IsNullary -> NonNullaryInNestedType - | UnionLayout.SmallRefUnion _ -> NonNullaryFoldsToRoot + | UnionLayout.SmallRef _ when not alt.IsNullary -> NonNullaryInNestedType + | UnionLayout.SmallRef _ -> NonNullaryFoldsToRoot + | UnionLayout.SmallRefWithNullAsTrueValue _ when not alt.IsNullary -> NonNullaryInNestedType + | UnionLayout.SmallRefWithNullAsTrueValue _ -> NonNullaryFoldsToRoot /// Compile-time validation that all active patterns cover all UnionLayout cases. /// Also validates that classifyFromSpec and classifyFromDef compile correctly. @@ -246,7 +257,7 @@ let private altFoldsAsRootInstance (layout: UnionLayout) (alt: IlxUnionCase) (al && (match layout with | UnionLayout.FSharpList _ -> alt.Name = ALT_NAME_CONS | UnionLayout.SingleCaseRef _ -> true - | UnionLayout.SmallRefUnion(_, Some _) -> alts |> Array.filter (fun a -> not a.IsNullary) |> Array.length = 1 + | UnionLayout.SmallRefWithNullAsTrueValue _ -> alts |> Array.filter (fun a -> not a.IsNullary) |> Array.length = 1 | _ -> false) /// Does this alternative optimize to root class (no nested type needed)? @@ -260,7 +271,8 @@ let private altOptimizesToRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: | UnionLayout.TaggedStructAllNullary _ -> true | UnionLayout.TaggedRefAllNullary _ -> true | UnionLayout.TaggedRef _ -> alt.IsNullary - | UnionLayout.SmallRefUnion _ -> + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ -> (match layout, cidx with | CaseIsNull -> true | CaseIsAllocated -> false) @@ -281,7 +293,7 @@ let private maintainConstantField (layout: UnionLayout) (alt: IlxUnionCase) (cid /// Does any case use null representation? let private hasNullCase (layout: UnionLayout) = match layout with - | UnionLayout.SmallRefUnion(_, Some _) -> true + | UnionLayout.SmallRefWithNullAsTrueValue _ -> true | _ -> false // ---- Context Records ---- @@ -490,7 +502,8 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = // MaintainPossiblyUniqueConstantFieldForAlternative: ref type, not null, nullary // → load the singleton static field | UnionLayout.SingleCaseRef _ - | UnionLayout.SmallRefUnion _ + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ | UnionLayout.TaggedRef _ | UnionLayout.TaggedRefAllNullary _ | UnionLayout.FSharpList _ when alt.IsNullary -> @@ -502,7 +515,11 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = let ctorFieldTys = alt.FieldTypes |> Array.toList [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] // RepresentAlternativeAsFreshInstancesOfRootClass: single non-nullary with null sibling - | UnionLayout.SmallRefUnion _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> + | UnionLayout.SmallRef _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> + let baseTy = baseTyOfUnionSpec cuspec + let ctorFieldTys = alt.FieldTypes |> Array.toList + [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] + | UnionLayout.SmallRefWithNullAsTrueValue _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> let baseTy = baseTyOfUnionSpec cuspec let ctorFieldTys = alt.FieldTypes |> Array.toList [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] @@ -516,7 +533,8 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ | UnionLayout.FSharpList _ - | UnionLayout.SmallRefUnion _ + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ | UnionLayout.TaggedRef _ | UnionLayout.TaggedRefAllNullary _ | UnionLayout.TaggedStruct _ @@ -591,12 +609,16 @@ let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = [ AI_ldnull; AI_ceq ] | _ -> match layout with - | UnionLayout.SmallRefUnion _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> + | UnionLayout.SmallRef _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> + // Single non-nullary with all null siblings: test via non-null + [ AI_ldnull; AI_cgt_un ] + | UnionLayout.SmallRefWithNullAsTrueValue _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> // Single non-nullary with all null siblings: test via non-null [ AI_ldnull; AI_cgt_un ] | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> [ mkLdcInt32 1 ] - | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminate ilg access cuspec alt altName altTy + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ -> mkRuntimeTypeDiscriminate ilg access cuspec alt altName altTy | UnionLayout.TaggedRef _ | UnionLayout.TaggedRefAllNullary _ | UnionLayout.TaggedStruct _ @@ -659,12 +681,16 @@ let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx [ I_brcmp(neg, tg) ] | _ -> match layout with - | UnionLayout.SmallRefUnion _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> + | UnionLayout.SmallRef _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> + // Single non-nullary with all null siblings: branch on non-null + [ I_brcmp(pos, tg) ] + | UnionLayout.SmallRefWithNullAsTrueValue _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> // Single non-nullary with all null siblings: branch on non-null [ I_brcmp(pos, tg) ] | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> [] - | UnionLayout.SmallRefUnion _ -> mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy (I_brcmp(pos, tg)) + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ -> mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy (I_brcmp(pos, tg)) | UnionLayout.TaggedRef _ | UnionLayout.TaggedRefAllNullary _ | UnionLayout.TaggedStruct _ @@ -705,8 +731,14 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS | UnionLayout.SingleCaseStruct _ -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] - | UnionLayout.SmallRefUnion(baseTy, nullAsTrueValueIdx) -> + | UnionLayout.SmallRef baseTy + | UnionLayout.SmallRefWithNullAsTrueValue(baseTy, _) -> // RuntimeTypes: emit multi-way isinst chain + let nullAsTrueValueIdx = + match layout with + | UnionLayout.SmallRefWithNullAsTrueValue(_, idx) -> Some idx + | _ -> None + let ld = match ldOpt with | None -> @@ -795,7 +827,8 @@ let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layo // Non-nullary in tagged ref: lives in nested type let altTy = tyForAltIdx cuspec alt cidx cg.EmitInstr(I_castclass altTy) - | UnionLayout.SmallRefUnion _ -> + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ -> if altFoldsAsRootInstance layout alt cuspec.AlternativesArray then // Single non-nullary with all null siblings: folded to root () @@ -812,7 +845,13 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: Unio let baseTy = baseTyOfUnionSpec cuspec match layout with - | UnionLayout.SmallRefUnion(_, nullAsTrueValueIdx) -> + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ -> + let nullAsTrueValueIdx = + match layout with + | UnionLayout.SmallRefWithNullAsTrueValue(_, idx) -> Some idx + | _ -> None + let locn = cg.GenLocal baseTy cg.EmitInstr(mkStloc locn) From 3e5f1349686640683ec3cd5906c53ac3ec5d599f Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 15:31:41 +0100 Subject: [PATCH 24/44] Wave 5: Remove dead code, eliminate hasNullCase, explicit match arms MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Remove 3 dead SmallRef when-guards (altFoldsAsRootInstance always returns false for SmallRef — dead code since the DU split) - Replace wildcard in altFoldsAsRootInstance with explicit cases for compiler-enforced exhaustiveness - Eliminate hasNullCase function — callers match SmallRefWithNullAsTrueValue directly Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 42 +++++++++++++---------------- 1 file changed, 18 insertions(+), 24 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 637a4a18cef..d9797bdec78 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -258,7 +258,12 @@ let private altFoldsAsRootInstance (layout: UnionLayout) (alt: IlxUnionCase) (al | UnionLayout.FSharpList _ -> alt.Name = ALT_NAME_CONS | UnionLayout.SingleCaseRef _ -> true | UnionLayout.SmallRefWithNullAsTrueValue _ -> alts |> Array.filter (fun a -> not a.IsNullary) |> Array.length = 1 - | _ -> false) + | UnionLayout.SmallRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> false) /// Does this alternative optimize to root class (no nested type needed)? /// Equivalent to the old OptimizeAlternativeToRootClass. @@ -290,12 +295,6 @@ let private maintainConstantField (layout: UnionLayout) (alt: IlxUnionCase) (cid | ReferenceTypeLayout -> true | ValueTypeLayout -> false -/// Does any case use null representation? -let private hasNullCase (layout: UnionLayout) = - match layout with - | UnionLayout.SmallRefWithNullAsTrueValue _ -> true - | _ -> false - // ---- Context Records ---- /// Bundles the parameters threaded through type definition generation. @@ -466,10 +465,10 @@ let mkGetTailOrNull access cuspec = let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = let baseTy = baseTyOfUnionSpec cuspec - if hasNullCase (classifyFromSpec cuspec) then + match classifyFromSpec cuspec with + | UnionLayout.SmallRefWithNullAsTrueValue _ -> mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [ baseTy ], mkTagFieldFormalType ilg cuspec)) - else - mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec)) + | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec)) let mkGetTag ilg (cuspec: IlxUnionSpec) = match cuspec.HasHelpers with @@ -514,11 +513,6 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = let baseTy = baseTyOfUnionSpec cuspec let ctorFieldTys = alt.FieldTypes |> Array.toList [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] - // RepresentAlternativeAsFreshInstancesOfRootClass: single non-nullary with null sibling - | UnionLayout.SmallRef _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> - let baseTy = baseTyOfUnionSpec cuspec - let ctorFieldTys = alt.FieldTypes |> Array.toList - [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] | UnionLayout.SmallRefWithNullAsTrueValue _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> let baseTy = baseTyOfUnionSpec cuspec let ctorFieldTys = alt.FieldTypes |> Array.toList @@ -609,9 +603,6 @@ let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = [ AI_ldnull; AI_ceq ] | _ -> match layout with - | UnionLayout.SmallRef _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> - // Single non-nullary with all null siblings: test via non-null - [ AI_ldnull; AI_cgt_un ] | UnionLayout.SmallRefWithNullAsTrueValue _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> // Single non-nullary with all null siblings: test via non-null [ AI_ldnull; AI_cgt_un ] @@ -681,9 +672,6 @@ let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx [ I_brcmp(neg, tg) ] | _ -> match layout with - | UnionLayout.SmallRef _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> - // Single non-nullary with all null siblings: branch on non-null - [ I_brcmp(pos, tg) ] | UnionLayout.SmallRefWithNullAsTrueValue _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> // Single non-nullary with all null siblings: branch on non-null [ I_brcmp(pos, tg) ] @@ -1155,7 +1143,12 @@ let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: I let imports = cud.DebugImports let attr = cud.DebugPoint - if cud.UnionCases.Length <= 1 || hasNullCase ctx.layout then + if + cud.UnionCases.Length <= 1 + || (match ctx.layout with + | UnionLayout.SmallRefWithNullAsTrueValue _ -> true + | _ -> false) + then [], [] else let additionalAttributes = @@ -1748,7 +1741,8 @@ let private emitTagInfrastructure (ctx: TypeDefContext) = // If we are using NULL as a representation for an element of this type then we cannot // use an instance method - if hasNullCase ctx.layout then + match ctx.layout with + | UnionLayout.SmallRefWithNullAsTrueValue _ -> [ mkILNonGenericStaticMethod ( "Get" + tagPropertyName, @@ -1761,7 +1755,7 @@ let private emitTagInfrastructure (ctx: TypeDefContext) = ], [] - else + | _ -> [ mkILNonGenericInstanceMethod ("get_" + tagPropertyName, cud.HelpersAccessibility, [], mkILReturn tagFieldType, body) |> ctx.stampMethodAsGenerated From 9a80a6bcd1f7a0cee23e014ceba6a5930e35cd86 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 15:45:12 +0100 Subject: [PATCH 25/44] Wave 6: Extract nullnessCheckingEnabled helper, restructure classifyUnion MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Add nullnessCheckingEnabled helper replacing 5 scattered 'g.checkNullness && g.langFeatureNullness' conjunctions - Restructure classifyUnion: replace 4 when-guarded arms with nested match on (isStruct, allNullary) — exhaustive, no guards Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index d9797bdec78..7b8c132c12b 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -102,10 +102,12 @@ let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isS match nullAsTrueValueIdx with | Some idx -> UnionLayout.SmallRefWithNullAsTrueValue(baseTy, idx) | None -> UnionLayout.SmallRef baseTy - | _, _, true when allNullary -> UnionLayout.TaggedStructAllNullary baseTy - | _, _, true -> UnionLayout.TaggedStruct baseTy - | _, _, false when allNullary -> UnionLayout.TaggedRefAllNullary baseTy - | _, _, false -> UnionLayout.TaggedRef baseTy + | _ -> + match isStruct, allNullary with + | true, true -> UnionLayout.TaggedStructAllNullary baseTy + | true, false -> UnionLayout.TaggedStruct baseTy + | false, true -> UnionLayout.TaggedRefAllNullary baseTy + | false, false -> UnionLayout.TaggedRef baseTy /// Classify from an IlxUnionSpec (used in IL instruction generation). let classifyFromSpec (cuspec: IlxUnionSpec) = @@ -335,6 +337,10 @@ let mkUnionCaseFieldId (fdef: IlxUnionCaseField) = // Use the lower case name of a field or constructor as the field/parameter name if it differs from the uppercase name fdef.LowerName, fdef.Type +/// Is nullness checking enabled in the compiler settings? +let inline nullnessCheckingEnabled (g: TcGlobals) = + g.checkNullness && g.langFeatureNullness + let inline getFieldsNullability (g: TcGlobals) (ilf: ILFieldDef) = if g.checkNullness then ilf.CustomAttrs.AsArray() @@ -1153,7 +1159,7 @@ let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: I else let additionalAttributes = match ctx.layout with - | ValueTypeLayout when g.checkNullness && g.langFeatureNullness && not alt.IsNullary -> + | ValueTypeLayout when nullnessCheckingEnabled g && not alt.IsNullary -> let notnullfields = alt.FieldDefs // Fields that are nullable even from F# perspective has an [Nullable] attribute on them @@ -1220,7 +1226,7 @@ let private emitNullaryCaseAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUn let attributes = match ctx.layout, num with - | CaseIsNull when g.checkNullness && g.langFeatureNullness -> + | CaseIsNull when nullnessCheckingEnabled g -> let noTypars = td.GenericParams.Length GetNullableAttribute @@ -1412,7 +1418,7 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx |> ctx.stampMethodAsGenerated let attrs = - if g.checkNullness && g.langFeatureNullness then + if nullnessCheckingEnabled g then GetNullableContextAttribute g 1uy :: debugAttrs else debugAttrs @@ -1497,7 +1503,7 @@ let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCa let private rewriteFieldsForStructFlattening (g: TcGlobals) (alt: IlxUnionCase) (layout: UnionLayout) = match layout with | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ when g.checkNullness && g.langFeatureNullness -> + | UnionLayout.TaggedStructAllNullary _ when nullnessCheckingEnabled g -> alt.FieldDefs |> Array.map (fun field -> if field.Type.IsNominal && field.Type.Boxity = AsValue then @@ -1540,7 +1546,7 @@ let private rewriteFieldsForStructFlattening (g: TcGlobals) (alt: IlxUnionCase) /// Add [Nullable(2)] attribute to union root type when null is permitted. let private rootTypeNullableAttrs (g: TcGlobals) (td: ILTypeDef) (cud: IlxUnionInfo) = - if cud.IsNullPermitted && g.checkNullness && g.langFeatureNullness then + if cud.IsNullPermitted && nullnessCheckingEnabled g then td.CustomAttrs.AsArray() |> Array.append [| GetNullableAttribute g [ NullnessInfo.WithNull ] |] |> mkILCustomAttrsFromArray From 62d3700353b7705b4ed0fc5b6a2ac8e65b78966c Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 15:50:59 +0100 Subject: [PATCH 26/44] Wave 7: Inline doesRuntimeTypeDiscriminateUseHelper, match-based tester guard MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Inline doesRuntimeTypeDiscriminateUseHelper (1-line function, 2 call sites) directly into mkRuntimeTypeDiscriminate and mkRuntimeTypeDiscriminateThen - Replace 'cud.UnionCases.Length <= 1 || (match SmallRefWithNull -> true)' with clean match on layout cases (SingleCaseRef, SingleCaseStruct, SmallRefWithNullAsTrueValue → skip tester) Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 28 +++++++++++----------------- 1 file changed, 11 insertions(+), 17 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 7b8c132c12b..87bc891be93 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -406,13 +406,8 @@ let altOfUnionSpec (cuspec: IlxUnionSpec) cidx = // using runtime type discrimination, because the underlying type is never needed from // C# code and pollutes the visible API surface. In this case we must discriminate by // calling the IsFoo helper. This only applies when accessing via helpers (inter-assembly). -let doesRuntimeTypeDiscriminateUseHelper (access: DataAccess) (alt: IlxUnionCase) = - alt.IsNullary && access = DataAccess.ViaHelpers - -let mkRuntimeTypeDiscriminate (ilg: ILGlobals) access cuspec alt altName altTy = - let useHelper = doesRuntimeTypeDiscriminateUseHelper access alt - - if useHelper then +let mkRuntimeTypeDiscriminate (ilg: ILGlobals) (access: DataAccess) cuspec (alt: IlxUnionCase) altName altTy = + if alt.IsNullary && access = DataAccess.ViaHelpers then let baseTy = baseTyOfUnionSpec cuspec [ @@ -421,8 +416,8 @@ let mkRuntimeTypeDiscriminate (ilg: ILGlobals) access cuspec alt altName altTy = else [ I_isinst altTy; AI_ldnull; AI_cgt_un ] -let mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy after = - let useHelper = doesRuntimeTypeDiscriminateUseHelper access alt +let mkRuntimeTypeDiscriminateThen ilg (access: DataAccess) cuspec (alt: IlxUnionCase) altName altTy after = + let useHelper = alt.IsNullary && access = DataAccess.ViaHelpers match after with | I_brcmp(BI_brfalse, _) @@ -1149,14 +1144,13 @@ let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: I let imports = cud.DebugImports let attr = cud.DebugPoint - if - cud.UnionCases.Length <= 1 - || (match ctx.layout with - | UnionLayout.SmallRefWithNullAsTrueValue _ -> true - | _ -> false) - then - [], [] - else + // No tester needed for single-case unions or null-discriminated (SmallRefWithNullAsTrueValue) + match ctx.layout with + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.SmallRefWithNullAsTrueValue _ -> [], [] + | _ when cud.UnionCases.Length <= 1 -> [], [] + | _ -> let additionalAttributes = match ctx.layout with | ValueTypeLayout when nullnessCheckingEnabled g && not alt.IsNullary -> From fdf3d1ceb3a5369882a41819dce6dacb5ad45f06 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 15:59:37 +0100 Subject: [PATCH 27/44] Wave 8: Split TaggedStructAllNullary from when guard, remove dead fallthrough MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit TaggedStructAllNullary + when alt.IsNullary was redundant — all cases are nullary by definition. Split into explicit arm without guard. Remove TaggedStructAllNullary from default fallthrough (already handled). Remove dead 'when cud.UnionCases.Length <= 1' guard (covered by layout). Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 87bc891be93..c86b9bdc13c 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -518,9 +518,13 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = let baseTy = baseTyOfUnionSpec cuspec let ctorFieldTys = alt.FieldTypes |> Array.toList [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] - // Struct + IntegerTag + nullary: create via root ctor with tag - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ when alt.IsNullary -> + // Struct + all nullary: create via root ctor with tag + | UnionLayout.TaggedStructAllNullary _ -> + let baseTy = baseTyOfUnionSpec cuspec + let tagField = [ mkTagFieldType ilg cuspec ] + [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] + // Struct + nullary case in mixed struct: create via root ctor with tag + | UnionLayout.TaggedStruct _ when alt.IsNullary -> let baseTy = baseTyOfUnionSpec cuspec let tagField = [ mkTagFieldType ilg cuspec ] [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] @@ -532,8 +536,7 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = | UnionLayout.SmallRefWithNullAsTrueValue _ | UnionLayout.TaggedRef _ | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> [ mkNormalNewobj (mkILCtorMethSpecForTy (altTy, Array.toList alt.FieldTypes)) ] + | UnionLayout.TaggedStruct _ -> [ mkNormalNewobj (mkILCtorMethSpecForTy (altTy, Array.toList alt.FieldTypes)) ] let convNewDataInstrInternal ilg cuspec cidx = emitRawConstruction ilg cuspec (classifyFromSpec cuspec) cidx @@ -1149,7 +1152,6 @@ let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: I | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ | UnionLayout.SmallRefWithNullAsTrueValue _ -> [], [] - | _ when cud.UnionCases.Length <= 1 -> [], [] | _ -> let additionalAttributes = match ctx.layout with From 14f4a650cfaf9c72739a9a16b54a498fc77c5f2d Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 16:50:37 +0100 Subject: [PATCH 28/44] F10+F11: Remove duplicate comment, clean unreachable match arm Remove duplicate XML doc comment at line 1785. Remove dead FSharpList arm from emitRawConstruction default (already handled by when alt.IsNullary and non-nullary Cons arms above). Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index c86b9bdc13c..66956810e72 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -528,10 +528,9 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = let baseTy = baseTyOfUnionSpec cuspec let tagField = [ mkTagFieldType ilg cuspec ] [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] - // Default: use nested type ctor + // Default: use nested type ctor (or root ctor for single-case/small unions) | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ - | UnionLayout.FSharpList _ | UnionLayout.SmallRef _ | UnionLayout.SmallRefWithNullAsTrueValue _ | UnionLayout.TaggedRef _ @@ -1781,7 +1780,6 @@ let private emitTagInfrastructure (ctx: TypeDefContext) = tagMeths, tagProps, tagEnumFields -/// Compute instance fields from selfFields and tagFieldsInObject. /// Compute instance fields from selfFields and tagFieldsInObject. let private computeSelfAndTagFields (ctx: TypeDefContext) selfFields (tagFieldsInObject: (string * ILType * ILAttribute list) list) = let isStruct = ctx.td.IsStruct From f44dc98fe5e152f4a09d568b90bb93c0035bad9b Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 17:02:43 +0100 Subject: [PATCH 29/44] Round 2: Domain model improvements (F1+F5+F7+F8+F4) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit F1: Replace NullaryConstFields 5-tuple with NullaryConstFieldInfo record — named fields instead of opaque (IlxUnionCase*ILType*int*ILFieldDef*bool) F5: Introduce CaseStorage DU (Null|Singleton|OnRoot|InNestedType|StructTag) — classifyCaseStorage computes once per case, used in emitCastToCase and processAlternative to eliminate duplicated decision trees F7: Rename helpers HOW→WHAT for domain clarity: altFoldsAsRootInstance → caseFieldsOnRoot altOptimizesToRoot → caseRepresentedOnRoot maintainConstantField → needsSingletonField convNewDataInstrInternal → emitRawNewData F8: emitDebugProxyType: 11 positional params → TypeDefContext + 2 params F4: Extract ILStamping record from TypeDefContext, separating domain data (layout, cuspec, cud) from infrastructure callbacks Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 340 +++++++++++++++------------- 1 file changed, 177 insertions(+), 163 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 66956810e72..bacad717150 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -254,7 +254,7 @@ let private _validateActivePatterns /// Does this non-nullary alternative fold to root class via fresh instances? /// Equivalent to the old RepresentAlternativeAsFreshInstancesOfRootClass. -let private altFoldsAsRootInstance (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) = +let private caseFieldsOnRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) = not alt.IsNullary && (match layout with | UnionLayout.FSharpList _ -> alt.Name = ALT_NAME_CONS @@ -269,7 +269,7 @@ let private altFoldsAsRootInstance (layout: UnionLayout) (alt: IlxUnionCase) (al /// Does this alternative optimize to root class (no nested type needed)? /// Equivalent to the old OptimizeAlternativeToRootClass. -let private altOptimizesToRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) (cidx: int) = +let private caseRepresentedOnRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) (cidx: int) = match layout with | UnionLayout.FSharpList _ | UnionLayout.SingleCaseRef _ @@ -283,12 +283,12 @@ let private altOptimizesToRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: (match layout, cidx with | CaseIsNull -> true | CaseIsAllocated -> false) - || altFoldsAsRootInstance layout alt alts + || caseFieldsOnRoot layout alt alts /// Should a static constant field be maintained for this nullary alternative? /// Equivalent to the old MaintainPossiblyUniqueConstantFieldForAlternative. /// Only for nullary cases on reference types that are not null-represented. -let private maintainConstantField (layout: UnionLayout) (alt: IlxUnionCase) (cidx: int) = +let private needsSingletonField (layout: UnionLayout) (alt: IlxUnionCase) (cidx: int) = alt.IsNullary && match layout, cidx with | CaseIsNull -> false @@ -297,8 +297,57 @@ let private maintainConstantField (layout: UnionLayout) (alt: IlxUnionCase) (cid | ReferenceTypeLayout -> true | ValueTypeLayout -> false +let private tyForAltIdx cuspec (alt: IlxUnionCase) cidx = + let layout = classifyFromSpec cuspec + let baseTy = baseTyOfUnionSpec cuspec + + if caseRepresentedOnRoot layout alt cuspec.AlternativesArray cidx then + baseTy + else + let isList = (cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) + let altName = alt.Name + let nm = if alt.IsNullary || isList then "_" + altName else altName + mkILNamedTy cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs + +/// How a specific union case is physically stored. +[] +type CaseStorage = + /// Represented as null reference (UseNullAsTrueValue) + | Null + /// Singleton static field on root class (nullary, reference type) + | Singleton + /// Fields stored directly on root class (single-case, list cons, struct, folded SmallRef) + | OnRoot + /// Fields stored in a nested subtype + | InNestedType of nestedType: ILType + +let classifyCaseStorage (layout: UnionLayout) (cuspec: IlxUnionSpec) (cidx: int) (alt: IlxUnionCase) = + match layout, cidx with + | CaseIsNull -> CaseStorage.Null + | _ -> + if caseRepresentedOnRoot layout alt cuspec.AlternativesArray cidx then + if alt.IsNullary then + match layout with + | ValueTypeLayout -> CaseStorage.OnRoot + | ReferenceTypeLayout -> CaseStorage.Singleton + else + CaseStorage.OnRoot + else + CaseStorage.InNestedType(tyForAltIdx cuspec alt cidx) + // ---- Context Records ---- +/// Bundles the IL attribute-stamping callbacks used during type definition generation. +type ILStamping = + { + stampMethodAsGenerated: ILMethodDef -> ILMethodDef + stampPropertyAsGenerated: ILPropertyDef -> ILPropertyDef + stampPropertyAsNever: ILPropertyDef -> ILPropertyDef + stampFieldAsGenerated: ILFieldDef -> ILFieldDef + stampFieldAsNever: ILFieldDef -> ILFieldDef + mkDebuggerTypeProxyAttr: ILType -> ILAttribute + } + /// Bundles the parameters threaded through type definition generation. /// Replaces the 6-callback tuple + scattered parameter threading in convAlternativeDef/mkClassUnionDef. type TypeDefContext = @@ -309,12 +358,17 @@ type TypeDefContext = cud: IlxUnionInfo td: ILTypeDef baseTy: ILType - stampMethodAsGenerated: ILMethodDef -> ILMethodDef - stampPropertyAsGenerated: ILPropertyDef -> ILPropertyDef - stampPropertyAsNever: ILPropertyDef -> ILPropertyDef - stampFieldAsGenerated: ILFieldDef -> ILFieldDef - stampFieldAsNever: ILFieldDef -> ILFieldDef - mkDebuggerTypeProxyAttr: ILType -> ILAttribute + stamping: ILStamping + } + +/// Information about a nullary case's singleton static field. +type NullaryConstFieldInfo = + { + Case: IlxUnionCase + CaseType: ILType + CaseIndex: int + Field: ILFieldDef + InRootClass: bool } /// Result of processing a single union alternative for type definition generation. @@ -326,7 +380,7 @@ type AlternativeDefResult = ConstantAccessors: ILMethodDef list NestedTypeDefs: ILTypeDef list DebugProxyTypeDefs: ILTypeDef list - NullaryConstFields: (IlxUnionCase * ILType * int * ILFieldDef * bool) list + NullaryConstFields: NullaryConstFieldInfo list } let mkTesterName nm = "Is" + nm @@ -368,18 +422,6 @@ let mkConstFieldSpecFromId (baseTy: ILType) constFieldId = refToFieldInTy baseTy let mkConstFieldSpec nm (baseTy: ILType) = mkConstFieldSpecFromId baseTy (constFieldName nm, constFormalFieldTy baseTy) -let private tyForAltIdx cuspec (alt: IlxUnionCase) cidx = - let layout = classifyFromSpec cuspec - let baseTy = baseTyOfUnionSpec cuspec - - if altOptimizesToRoot layout alt cuspec.AlternativesArray cidx then - baseTy - else - let isList = (cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) - let altName = alt.Name - let nm = if alt.IsNullary || isList then "_" + altName else altName - mkILNamedTy cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs - let tyForAlt (cuspec: IlxUnionSpec) (alt: IlxUnionCase) = let cidx = cuspec.AlternativesArray @@ -514,7 +556,7 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = let baseTy = baseTyOfUnionSpec cuspec let ctorFieldTys = alt.FieldTypes |> Array.toList [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] - | UnionLayout.SmallRefWithNullAsTrueValue _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> + | UnionLayout.SmallRefWithNullAsTrueValue _ when caseFieldsOnRoot layout alt cuspec.AlternativesArray -> let baseTy = baseTyOfUnionSpec cuspec let ctorFieldTys = alt.FieldTypes |> Array.toList [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] @@ -537,7 +579,7 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = | UnionLayout.TaggedRefAllNullary _ | UnionLayout.TaggedStruct _ -> [ mkNormalNewobj (mkILCtorMethSpecForTy (altTy, Array.toList alt.FieldTypes)) ] -let convNewDataInstrInternal ilg cuspec cidx = +let emitRawNewData ilg cuspec cidx = emitRawConstruction ilg cuspec (classifyFromSpec cuspec) cidx // The stdata 'instruction' is only ever used for the F# "List" type within FSharp.Core.dll @@ -606,7 +648,7 @@ let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = [ AI_ldnull; AI_ceq ] | _ -> match layout with - | UnionLayout.SmallRefWithNullAsTrueValue _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> + | UnionLayout.SmallRefWithNullAsTrueValue _ when caseFieldsOnRoot layout alt cuspec.AlternativesArray -> // Single non-nullary with all null siblings: test via non-null [ AI_ldnull; AI_cgt_un ] | UnionLayout.SingleCaseRef _ @@ -675,7 +717,7 @@ let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx [ I_brcmp(neg, tg) ] | _ -> match layout with - | UnionLayout.SmallRefWithNullAsTrueValue _ when altFoldsAsRootInstance layout alt cuspec.AlternativesArray -> + | UnionLayout.SmallRefWithNullAsTrueValue _ when caseFieldsOnRoot layout alt cuspec.AlternativesArray -> // Single non-nullary with all null siblings: branch on non-null [ I_brcmp(pos, tg) ] | UnionLayout.SingleCaseRef _ @@ -750,7 +792,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS I_brcmp((if cmpNull then BI_brtrue else BI_brfalse), cg.CodeLabel failLab) let testBlock = - if cmpNull || altFoldsAsRootInstance layout alt cuspec.AlternativesArray then + if cmpNull || caseFieldsOnRoot layout alt cuspec.AlternativesArray then [ test ] else let altName = alt.Name @@ -775,9 +817,10 @@ let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionSpec) = let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layout: UnionLayout) cidx = let alt = altOfUnionSpec cuspec cidx + let storage = classifyCaseStorage layout cuspec cidx alt - match layout, cidx with - | CaseIsNull -> + match storage with + | CaseStorage.Null -> // Null-represented case if canfail then let outlab = cg.GenerateDelayMark() @@ -786,47 +829,25 @@ let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layo cg.SetMarkToHere internal1 cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] cg.SetMarkToHere outlab - | _ -> + | CaseStorage.OnRoot -> + // Fields on root: tag check if canfail for structs, else leave on stack match layout with - | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> - // Flatten (struct): tag check if canfail, else leave on stack - if canfail then - let outlab = cg.GenerateDelayMark() - let internal1 = cg.GenerateDelayMark() - cg.EmitInstr AI_dup - emitLdDataTagPrim ilg None cg (access, cuspec) - cg.EmitInstrs [ mkLdcInt32 cidx; I_brcmp(BI_beq, cg.CodeLabel outlab) ] - cg.SetMarkToHere internal1 - cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] - cg.SetMarkToHere outlab - | UnionLayout.FSharpList _ -> - // List type: all cases fold to root, no cast needed - () - | UnionLayout.SingleCaseRef _ -> - // Single case ref: always on root - () - | UnionLayout.TaggedRefAllNullary _ -> - // All-nullary (enum-like): all cases on root - () - | UnionLayout.TaggedRef _ -> - if alt.IsNullary then - // Nullary in tagged ref: constant field in root class, no cast - () - else - // Non-nullary in tagged ref: lives in nested type - let altTy = tyForAltIdx cuspec alt cidx - cg.EmitInstr(I_castclass altTy) - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ -> - if altFoldsAsRootInstance layout alt cuspec.AlternativesArray then - // Single non-nullary with all null siblings: folded to root - () - else - // Case lives in a nested type - let altTy = tyForAltIdx cuspec alt cidx - cg.EmitInstr(I_castclass altTy) + | ValueTypeLayout when canfail -> + let outlab = cg.GenerateDelayMark() + let internal1 = cg.GenerateDelayMark() + cg.EmitInstr AI_dup + emitLdDataTagPrim ilg None cg (access, cuspec) + cg.EmitInstrs [ mkLdcInt32 cidx; I_brcmp(BI_beq, cg.CodeLabel outlab) ] + cg.SetMarkToHere internal1 + cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] + cg.SetMarkToHere outlab + | _ -> () + | CaseStorage.Singleton -> + // Nullary case with singleton field on root class, no cast needed + () + | CaseStorage.InNestedType altTy -> + // Case lives in a nested subtype: emit castclass + cg.EmitInstr(I_castclass altTy) let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, access, cuspec, cidx) = let layout = classifyFromSpec cuspec @@ -857,7 +878,7 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: Unio cg.EmitInstr(mkLdloc locn) let testInstr = I_brcmp((if cmpNull then BI_brfalse else BI_brtrue), tg) - if cmpNull || altFoldsAsRootInstance layout alt cuspec.AlternativesArray then + if cmpNull || caseFieldsOnRoot layout alt cuspec.AlternativesArray then cg.EmitInstr testInstr else cg.EmitInstrs(mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy testInstr) @@ -970,20 +991,12 @@ let mkMethodsAndPropertiesForFields /// Generate a debug proxy type for a union alternative. /// Returns (debugProxyTypeDefs, debugProxyAttrs). -let private emitDebugProxyType - (g: TcGlobals) - (td: ILTypeDef) - (altTy: ILType) - (fields: IlxUnionCaseField[]) - (baseTy: ILType) - imports - addMethodGeneratedAttrs - addPropertyGeneratedAttrs - addFieldNeverAttrs - addFieldGeneratedAttrs - mkDebuggerTypeProxyAttribute - (cud: IlxUnionInfo) - = +let private emitDebugProxyType (ctx: TypeDefContext) (altTy: ILType) (fields: IlxUnionCaseField[]) = + let g = ctx.g + let td = ctx.td + let baseTy = ctx.baseTy + let cud = ctx.cud + let imports = cud.DebugImports let debugProxyTypeName = altTy.TypeSpec.Name + "@DebugTypeProxy" @@ -995,8 +1008,8 @@ let private emitDebugProxyType let debugProxyFields = [ mkILInstanceField (debugProxyFieldName, altTy, None, ILMemberAccess.Assembly) - |> addFieldNeverAttrs - |> addFieldGeneratedAttrs + |> ctx.stamping.stampFieldAsNever + |> ctx.stamping.stampFieldAsGenerated ] let debugProxyCode = @@ -1016,7 +1029,7 @@ let private emitDebugProxyType mkMethodBody (false, [], 3, debugProxyCode, None, imports) )) .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) - |> addMethodGeneratedAttrs + |> ctx.stamping.stampMethodAsGenerated let debugProxyGetterMeths = fields @@ -1034,7 +1047,7 @@ let private emitDebugProxyType let mbody = mkMethodBody (true, [], 2, instrs, None, imports) mkILNonGenericInstanceMethod ("get_" + field.Name, ILMemberAccess.Public, [], mkILReturn field.Type, mbody) - |> addMethodGeneratedAttrs) + |> ctx.stamping.stampMethodAsGenerated) |> Array.toList let debugProxyGetterProps = @@ -1051,7 +1064,7 @@ let private emitDebugProxyType args = [], customAttrs = fdef.ILField.CustomAttrs ) - |> addPropertyGeneratedAttrs) + |> ctx.stamping.stampPropertyAsGenerated) |> Array.toList let debugProxyTypeDef = @@ -1070,7 +1083,9 @@ let private emitDebugProxyType ILTypeInit.BeforeField ) - [ debugProxyTypeDef.WithSpecialName(true) ], ([ mkDebuggerTypeProxyAttribute debugProxyTy ] @ cud.DebugDisplayAttributes) + [ debugProxyTypeDef.WithSpecialName(true) ], + ([ ctx.stamping.mkDebuggerTypeProxyAttr debugProxyTy ] + @ cud.DebugDisplayAttributes) let private emitMakerMethod (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = let g = ctx.g @@ -1111,7 +1126,7 @@ let private emitMakerMethod (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) [ for i in 0 .. fields.Length - 1 do mkLdarg (uint16 i) - yield! convNewDataInstrInternal g.ilg cuspec num + yield! emitRawNewData g.ilg cuspec num ] [], ilInstrs @@ -1135,7 +1150,7 @@ let private emitMakerMethod (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) mkMethodBody (true, locals, fields.Length + locals.Length, nonBranchingInstrsToCode ilInstrs, attr, imports) ) |> (fun mdef -> mdef.With(customAttrs = alt.altCustomAttrs)) - |> ctx.stampMethodAsGenerated + |> ctx.stamping.stampMethodAsGenerated let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = let g = ctx.g @@ -1190,7 +1205,7 @@ let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: I ) )) .With(customAttrs = additionalAttributes) - |> ctx.stampMethodAsGenerated + |> ctx.stamping.stampMethodAsGenerated ], [ ILPropertyDef( @@ -1204,8 +1219,8 @@ let private emitTesterMethodAndProperty (ctx: TypeDefContext) (num: int) (alt: I args = [], customAttrs = additionalAttributes ) - |> ctx.stampPropertyAsGenerated - |> ctx.stampPropertyAsNever + |> ctx.stamping.stampPropertyAsGenerated + |> ctx.stamping.stampPropertyAsNever ] let private emitNullaryCaseAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = @@ -1240,10 +1255,10 @@ let private emitNullaryCaseAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUn cud.HelpersAccessibility, [], (mkILReturn baseTy).WithCustomAttrs attributes, - mkMethodBody (true, [], fields.Length, nonBranchingInstrsToCode (convNewDataInstrInternal g.ilg cuspec num), attr, imports) + mkMethodBody (true, [], fields.Length, nonBranchingInstrsToCode (emitRawNewData g.ilg cuspec num), attr, imports) ) |> (fun mdef -> mdef.With(customAttrs = alt.altCustomAttrs)) - |> ctx.stampMethodAsGenerated + |> ctx.stamping.stampMethodAsGenerated let nullaryProp = ILPropertyDef( @@ -1257,8 +1272,8 @@ let private emitNullaryCaseAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUn args = [], customAttrs = attributes ) - |> ctx.stampPropertyAsGenerated - |> ctx.stampPropertyAsNever + |> ctx.stamping.stampPropertyAsGenerated + |> ctx.stamping.stampPropertyAsNever [ nullaryMeth ], [ nullaryProp ] @@ -1277,7 +1292,7 @@ let private emitConstantAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUnion | SpecialFSharpOptionHelpers | SpecialFSharpListHelpers -> [] | _ -> - if alt.IsNullary && maintainConstantField ctx.layout alt num then + if alt.IsNullary && needsSingletonField ctx.layout alt num then let methName = "get_" + altName let meth = @@ -1295,7 +1310,7 @@ let private emitConstantAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUnion imports ) ) - |> ctx.stampMethodAsGenerated + |> ctx.stamping.stampMethodAsGenerated [ meth ] @@ -1309,15 +1324,24 @@ let private emitNullaryConstField (ctx: TypeDefContext) (num: int) (alt: IlxUnio let altName = alt.Name let altTy = tyForAltIdx cuspec alt num - if maintainConstantField ctx.layout alt num then + if needsSingletonField ctx.layout alt num then let basic: ILFieldDef = mkILStaticField (constFieldName altName, baseTy, None, None, ILMemberAccess.Assembly) - |> ctx.stampFieldAsNever - |> ctx.stampFieldAsGenerated + |> ctx.stamping.stampFieldAsNever + |> ctx.stamping.stampFieldAsGenerated let uniqObjField = basic.WithInitOnly(true) - let inRootClass = altOptimizesToRoot ctx.layout alt cud.UnionCases num - [ (alt, altTy, num, uniqObjField, inRootClass) ] + let inRootClass = caseRepresentedOnRoot ctx.layout alt cud.UnionCases num + + [ + { + Case = alt + CaseType = altTy + CaseIndex = num + Field = uniqObjField + InRootClass = inRootClass + } + ] else [] @@ -1333,26 +1357,14 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx let attr = cud.DebugPoint let isTotallyImmutable = (cud.HasHelpers <> SpecialFSharpListHelpers) - if altOptimizesToRoot ctx.layout alt cud.UnionCases num then + if caseRepresentedOnRoot ctx.layout alt cud.UnionCases num then [], [] else let altDebugTypeDefs, debugAttrs = if not cud.GenerateDebugProxies then [], [] else - emitDebugProxyType - g - td - altTy - fields - baseTy - imports - ctx.stampMethodAsGenerated - ctx.stampPropertyAsGenerated - ctx.stampFieldAsNever - ctx.stampFieldAsGenerated - ctx.mkDebuggerTypeProxyAttr - cud + emitDebugProxyType ctx altTy fields let altTypeDef = let basicFields = @@ -1366,8 +1378,8 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx | [] -> fdef | attrs -> fdef.With(customAttrs = mkILCustomAttrs attrs) - |> ctx.stampFieldAsNever - |> ctx.stampFieldAsGenerated + |> ctx.stamping.stampFieldAsNever + |> ctx.stamping.stampFieldAsGenerated fdef.WithInitOnly(isTotallyImmutable)) @@ -1375,7 +1387,7 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx let basicProps, basicMethods = mkMethodsAndPropertiesForFields - (ctx.stampMethodAsGenerated, ctx.stampPropertyAsGenerated) + (ctx.stamping.stampMethodAsGenerated, ctx.stamping.stampPropertyAsGenerated) g cud.UnionCasesAccessibility attr @@ -1410,7 +1422,7 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx let basicCtorMeth = (mkILStorageCtor (basicCtorInstrs, altTy, basicCtorFields, basicCtorAccess, attr, imports)) .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) - |> ctx.stampMethodAsGenerated + |> ctx.stamping.stampMethodAsGenerated let attrs = if nullnessCheckingEnabled g then @@ -1470,18 +1482,17 @@ let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCa | _ -> [], [] let typeDefs, debugTypeDefs, nullaryFields = - match ctx.layout, num with - | CaseIsNull -> [], [], [] - | CaseIsAllocated -> - match ctx.layout with - | ValueTypeLayout -> [], [], [] - | ReferenceTypeLayout -> - if altFoldsAsRootInstance ctx.layout alt cud.UnionCases then - [], [], [] - else - let nullaryFields = emitNullaryConstField ctx num alt - let typeDefs, debugTypeDefs = emitNestedAlternativeType ctx num alt - typeDefs, debugTypeDefs, nullaryFields + match classifyCaseStorage ctx.layout ctx.cuspec num alt with + | CaseStorage.Null -> [], [], [] + | CaseStorage.OnRoot -> [], [], [] + | CaseStorage.Singleton -> + let nullaryFields = emitNullaryConstField ctx num alt + let typeDefs, debugTypeDefs = emitNestedAlternativeType ctx num alt + typeDefs, debugTypeDefs, nullaryFields + | CaseStorage.InNestedType _ -> + let nullaryFields = emitNullaryConstField ctx num alt + let typeDefs, debugTypeDefs = emitNestedAlternativeType ctx num alt + typeDefs, debugTypeDefs, nullaryFields { BaseMakerMethods = baseMakerMeths @@ -1578,7 +1589,7 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin let fieldsOnRoot = match ctx.layout with | ValueTypeLayout -> true - | ReferenceTypeLayout -> altFoldsAsRootInstance ctx.layout alt cud.UnionCases + | ReferenceTypeLayout -> caseFieldsOnRoot ctx.layout alt cud.UnionCases if fieldsOnRoot then @@ -1610,7 +1621,7 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin cud.DebugImports )) .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) - |> ctx.stampMethodAsGenerated + |> ctx.stamping.stampMethodAsGenerated ] let fieldDefs = rewriteFieldsForStructFlattening g alt ctx.layout @@ -1626,7 +1637,7 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin let props, meths = mkMethodsAndPropertiesForFields - (ctx.stampMethodAsGenerated, ctx.stampPropertyAsGenerated) + (ctx.stamping.stampMethodAsGenerated, ctx.stamping.stampPropertyAsGenerated) g cud.UnionCasesAccessibility cud.DebugPoint @@ -1653,7 +1664,7 @@ let private emitRootConstructors (ctx: TypeDefContext) selfFields tagFieldsInObj // - There aren't already instance fields from folded cases covering the ctor need let allCasesFoldToRoot = cud.UnionCases - |> Array.forall (fun alt -> altFoldsAsRootInstance ctx.layout alt cud.UnionCases) + |> Array.forall (fun alt -> caseFieldsOnRoot ctx.layout alt cud.UnionCases) let hasFieldsOrTagButNoMethods = not ( @@ -1682,11 +1693,11 @@ let private emitRootConstructors (ctx: TypeDefContext) selfFields tagFieldsInObj cud.DebugImports )) .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x7E0 baseTy ]) - |> ctx.stampMethodAsGenerated + |> ctx.stamping.stampMethodAsGenerated ] /// Generate static constructor code to initialize nullary case singleton fields. -let private emitConstFieldInitializers (ctx: TypeDefContext) (altNullaryFields: (IlxUnionCase * ILType * int * ILFieldDef * bool) list) = +let private emitConstFieldInitializers (ctx: TypeDefContext) (altNullaryFields: NullaryConstFieldInfo list) = let g = ctx.g let cud = ctx.cud let baseTy = ctx.baseTy @@ -1698,18 +1709,18 @@ let private emitConstFieldInitializers (ctx: TypeDefContext) (altNullaryFields: else prependInstrsToClassCtor [ - for _alt, altTy, fidx, fd, inRootClass in altNullaryFields do - let constFieldId = (fd.Name, baseTy) + for r in altNullaryFields do + let constFieldId = (r.Field.Name, baseTy) let constFieldSpec = mkConstFieldSpecFromId baseTy constFieldId match ctx.layout with - | NoTagField -> yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy, [])) + | NoTagField -> yield mkNormalNewobj (mkILCtorMethSpecForTy (r.CaseType, [])) | HasTagField -> - if inRootClass then - yield mkLdcInt32 fidx - yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy, [ mkTagFieldType g.ilg cuspec ])) + if r.InRootClass then + yield mkLdcInt32 r.CaseIndex + yield mkNormalNewobj (mkILCtorMethSpecForTy (r.CaseType, [ mkTagFieldType g.ilg cuspec ])) else - yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy, [])) + yield mkNormalNewobj (mkILCtorMethSpecForTy (r.CaseType, [])) yield mkNormalStsfld constFieldSpec ] @@ -1752,14 +1763,14 @@ let private emitTagInfrastructure (ctx: TypeDefContext) = mkILReturn tagFieldType, body ) - |> ctx.stampMethodAsGenerated + |> ctx.stamping.stampMethodAsGenerated ], [] | _ -> [ mkILNonGenericInstanceMethod ("get_" + tagPropertyName, cud.HelpersAccessibility, [], mkILReturn tagFieldType, body) - |> ctx.stampMethodAsGenerated + |> ctx.stamping.stampMethodAsGenerated ], [ @@ -1774,8 +1785,8 @@ let private emitTagInfrastructure (ctx: TypeDefContext) = args = [], customAttrs = emptyILCustomAttrs ) - |> ctx.stampPropertyAsGenerated - |> ctx.stampPropertyAsNever + |> ctx.stamping.stampPropertyAsGenerated + |> ctx.stamping.stampPropertyAsNever ] tagMeths, tagProps, tagEnumFields @@ -1794,8 +1805,8 @@ let private computeSelfAndTagFields (ctx: TypeDefContext) selfFields (tagFieldsI | [] -> fdef | attrs -> fdef.With(customAttrs = mkILCustomAttrs attrs) - |> ctx.stampFieldAsNever - |> ctx.stampFieldAsGenerated + |> ctx.stamping.stampFieldAsNever + |> ctx.stamping.stampFieldAsGenerated yield fdef.WithInitOnly(not isStruct && isTotallyImmutable) ] @@ -1887,7 +1898,7 @@ let private assembleUnionTypeDef fields = mkILFields ( selfAndTagFields - @ List.map (fun (_, _, _, fdef, _) -> fdef) altNullaryFields + @ List.map (fun r -> r.Field) altNullaryFields @ td.Fields.AsList() ), properties = mkILProperties (tagProps @ basePropsFromAlt @ selfProps @ existingProps), @@ -1925,12 +1936,15 @@ let mkClassUnionDef cud = cud td = td baseTy = baseTy - stampMethodAsGenerated = addMethodGeneratedAttrs - stampPropertyAsGenerated = addPropertyGeneratedAttrs - stampPropertyAsNever = addPropertyNeverAttrs - stampFieldAsGenerated = addFieldGeneratedAttrs - stampFieldAsNever = addFieldNeverAttrs - mkDebuggerTypeProxyAttr = mkDebuggerTypeProxyAttribute + stamping = + { + stampMethodAsGenerated = addMethodGeneratedAttrs + stampPropertyAsGenerated = addPropertyGeneratedAttrs + stampPropertyAsNever = addPropertyNeverAttrs + stampFieldAsGenerated = addFieldGeneratedAttrs + stampFieldAsNever = addFieldNeverAttrs + mkDebuggerTypeProxyAttr = mkDebuggerTypeProxyAttribute + } } let results = From 91044fff5eade1299e358d2eb8f8cced735ceb38 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 17:29:11 +0100 Subject: [PATCH 30/44] Round 2b: CaseIdentity, CaseStorage broadened, renames, dedup MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit G1: Introduce CaseIdentity record + resolveCase — eliminates repeated (alt, altTy, altName) computation in 4 emit functions G3: Use CaseStorage in emitRawConstruction — replaces nested layout match + 4 when guards with flat match on precomputed CaseStorage. Fix: needsSingletonField fallback for nullary SmallRef cases. G4: Merge duplicate Singleton/InNestedType branches (OR-pattern) G5: Remove mkTagFieldFormalType (identical to mkTagFieldType) G9: Rename self* → rootCase* for domain clarity Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 156 ++++++++++++++-------------- 1 file changed, 78 insertions(+), 78 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index bacad717150..827d6c793ef 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -332,6 +332,8 @@ let classifyCaseStorage (layout: UnionLayout) (cuspec: IlxUnionSpec) (cidx: int) | ReferenceTypeLayout -> CaseStorage.Singleton else CaseStorage.OnRoot + elif needsSingletonField layout alt cidx then + CaseStorage.Singleton else CaseStorage.InNestedType(tyForAltIdx cuspec alt cidx) @@ -434,8 +436,6 @@ let GetILTypeForAlternative cuspec alt = let mkTagFieldType (ilg: ILGlobals) _cuspec = ilg.typ_Int32 -let mkTagFieldFormalType (ilg: ILGlobals) _cuspec = ilg.typ_Int32 - let mkTagFieldId ilg cuspec = "_tag", mkTagFieldType ilg cuspec let altOfUnionSpec (cuspec: IlxUnionSpec) cidx = @@ -444,6 +444,26 @@ let altOfUnionSpec (cuspec: IlxUnionSpec) cidx = with _ -> failwith ("alternative " + string cidx + " not found") +/// Resolved identity of a union case within a union spec. +type CaseIdentity = + { + Index: int + Case: IlxUnionCase + CaseType: ILType + CaseName: string + } + +/// Resolve a case by index, computing its type and name. +let resolveCase (cuspec: IlxUnionSpec) (cidx: int) = + let alt = altOfUnionSpec cuspec cidx + + { + Index = cidx + Case = alt + CaseType = tyForAltIdx cuspec alt cidx + CaseName = alt.Name + } + // Nullary cases on types with helpers do not reveal their underlying type even when // using runtime type discrimination, because the underlying type is never needed from // C# code and pollutes the visible API surface. In this case we must discriminate by @@ -510,8 +530,8 @@ let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = match classifyFromSpec cuspec with | UnionLayout.SmallRefWithNullAsTrueValue _ -> - mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [ baseTy ], mkTagFieldFormalType ilg cuspec)) - | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec)) + mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [ baseTy ], mkTagFieldType ilg cuspec)) + | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldType ilg cuspec)) let mkGetTag ilg (cuspec: IlxUnionSpec) = match cuspec.HasHelpers with @@ -531,53 +551,33 @@ let mkTagDiscriminateThen ilg cuspec cidx after = [ mkGetTag ilg cuspec; mkLdcInt32 cidx ] @ mkCeqThen after let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAltIdx cuspec alt cidx - let altName = alt.Name + let ci = resolveCase cuspec cidx + let storage = classifyCaseStorage layout cuspec cidx ci.Case - match layout, cidx with - | CaseIsNull -> + match storage with + | CaseStorage.Null -> // Null-represented case: just load null [ AI_ldnull ] - | _ -> - match layout with - // MaintainPossiblyUniqueConstantFieldForAlternative: ref type, not null, nullary - // → load the singleton static field - | UnionLayout.SingleCaseRef _ - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.FSharpList _ when alt.IsNullary -> - let baseTy = baseTyOfUnionSpec cuspec - [ I_ldsfld(Nonvolatile, mkConstFieldSpec altName baseTy) ] - // RepresentAlternativeAsFreshInstancesOfRootClass: list cons folds to root - | UnionLayout.FSharpList _ -> - let baseTy = baseTyOfUnionSpec cuspec - let ctorFieldTys = alt.FieldTypes |> Array.toList - [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] - | UnionLayout.SmallRefWithNullAsTrueValue _ when caseFieldsOnRoot layout alt cuspec.AlternativesArray -> - let baseTy = baseTyOfUnionSpec cuspec - let ctorFieldTys = alt.FieldTypes |> Array.toList - [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] - // Struct + all nullary: create via root ctor with tag - | UnionLayout.TaggedStructAllNullary _ -> - let baseTy = baseTyOfUnionSpec cuspec - let tagField = [ mkTagFieldType ilg cuspec ] - [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] - // Struct + nullary case in mixed struct: create via root ctor with tag - | UnionLayout.TaggedStruct _ when alt.IsNullary -> - let baseTy = baseTyOfUnionSpec cuspec + | CaseStorage.Singleton -> + // Nullary ref type: load the singleton static field + let baseTy = baseTyOfUnionSpec cuspec + [ I_ldsfld(Nonvolatile, mkConstFieldSpec ci.CaseName baseTy) ] + | CaseStorage.OnRoot -> + let baseTy = baseTyOfUnionSpec cuspec + + if ci.Case.IsNullary then + // Struct + nullary: create via root ctor with tag let tagField = [ mkTagFieldType ilg cuspec ] [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] - // Default: use nested type ctor (or root ctor for single-case/small unions) - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.TaggedStruct _ -> [ mkNormalNewobj (mkILCtorMethSpecForTy (altTy, Array.toList alt.FieldTypes)) ] + else + // Non-nullary fields on root: create via root ctor with fields + let ctorFieldTys = ci.Case.FieldTypes |> Array.toList + [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] + | CaseStorage.InNestedType _ -> + // Case lives in a nested subtype + [ + mkNormalNewobj (mkILCtorMethSpecForTy (ci.CaseType, Array.toList ci.Case.FieldTypes)) + ] let emitRawNewData ilg cuspec cidx = emitRawConstruction ilg cuspec (classifyFromSpec cuspec) cidx @@ -638,9 +638,7 @@ let mkNewData ilg (cuspec, cidx) = | _ -> emitRawConstruction ilg cuspec layout cidx let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAltIdx cuspec alt cidx - let altName = alt.Name + let ci = resolveCase cuspec cidx match layout, cidx with | CaseIsNull -> @@ -648,13 +646,13 @@ let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = [ AI_ldnull; AI_ceq ] | _ -> match layout with - | UnionLayout.SmallRefWithNullAsTrueValue _ when caseFieldsOnRoot layout alt cuspec.AlternativesArray -> + | UnionLayout.SmallRefWithNullAsTrueValue _ when caseFieldsOnRoot layout ci.Case cuspec.AlternativesArray -> // Single non-nullary with all null siblings: test via non-null [ AI_ldnull; AI_cgt_un ] | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> [ mkLdcInt32 1 ] | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ -> mkRuntimeTypeDiscriminate ilg access cuspec alt altName altTy + | UnionLayout.SmallRefWithNullAsTrueValue _ -> mkRuntimeTypeDiscriminate ilg access cuspec ci.Case ci.CaseName ci.CaseType | UnionLayout.TaggedRef _ | UnionLayout.TaggedRefAllNullary _ | UnionLayout.TaggedStruct _ @@ -707,9 +705,7 @@ let genWith g : ILCode = let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx tg = let neg = (if sense then BI_brfalse else BI_brtrue) let pos = (if sense then BI_brtrue else BI_brfalse) - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAltIdx cuspec alt cidx - let altName = alt.Name + let ci = resolveCase cuspec cidx match layout, cidx with | CaseIsNull -> @@ -717,13 +713,14 @@ let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx [ I_brcmp(neg, tg) ] | _ -> match layout with - | UnionLayout.SmallRefWithNullAsTrueValue _ when caseFieldsOnRoot layout alt cuspec.AlternativesArray -> + | UnionLayout.SmallRefWithNullAsTrueValue _ when caseFieldsOnRoot layout ci.Case cuspec.AlternativesArray -> // Single non-nullary with all null siblings: branch on non-null [ I_brcmp(pos, tg) ] | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> [] | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ -> mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy (I_brcmp(pos, tg)) + | UnionLayout.SmallRefWithNullAsTrueValue _ -> + mkRuntimeTypeDiscriminateThen ilg access cuspec ci.Case ci.CaseName ci.CaseType (I_brcmp(pos, tg)) | UnionLayout.TaggedRef _ | UnionLayout.TaggedRefAllNullary _ | UnionLayout.TaggedStruct _ @@ -816,8 +813,8 @@ let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionSpec) = emitLdDataTagPrim ilg None cg (access, cuspec) let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layout: UnionLayout) cidx = - let alt = altOfUnionSpec cuspec cidx - let storage = classifyCaseStorage layout cuspec cidx alt + let ci = resolveCase cuspec cidx + let storage = classifyCaseStorage layout cuspec cidx ci.Case match storage with | CaseStorage.Null -> @@ -1485,10 +1482,7 @@ let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCa match classifyCaseStorage ctx.layout ctx.cuspec num alt with | CaseStorage.Null -> [], [], [] | CaseStorage.OnRoot -> [], [], [] - | CaseStorage.Singleton -> - let nullaryFields = emitNullaryConstField ctx num alt - let typeDefs, debugTypeDefs = emitNestedAlternativeType ctx num alt - typeDefs, debugTypeDefs, nullaryFields + | CaseStorage.Singleton | CaseStorage.InNestedType _ -> let nullaryFields = emitNullaryConstField ctx num alt let typeDefs, debugTypeDefs = emitNestedAlternativeType ctx num alt @@ -1652,7 +1646,7 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin |> (fun (a, b, c) -> List.concat a, List.concat b, List.concat c) /// Compute the root class default constructor (when needed). -let private emitRootConstructors (ctx: TypeDefContext) selfFields tagFieldsInObject selfMeths = +let private emitRootConstructors (ctx: TypeDefContext) rootCaseFields tagFieldsInObject rootCaseMethods = let g = ctx.g let td = ctx.td let cud = ctx.cud @@ -1668,9 +1662,9 @@ let private emitRootConstructors (ctx: TypeDefContext) selfFields tagFieldsInObj let hasFieldsOrTagButNoMethods = not ( - List.isEmpty selfFields + List.isEmpty rootCaseFields && List.isEmpty tagFieldsInObject - && not (List.isEmpty selfMeths) + && not (List.isEmpty rootCaseMethods) ) if td.IsStruct || allCasesFoldToRoot || not hasFieldsOrTagButNoMethods then @@ -1791,13 +1785,13 @@ let private emitTagInfrastructure (ctx: TypeDefContext) = tagMeths, tagProps, tagEnumFields -/// Compute instance fields from selfFields and tagFieldsInObject. -let private computeSelfAndTagFields (ctx: TypeDefContext) selfFields (tagFieldsInObject: (string * ILType * ILAttribute list) list) = +/// Compute instance fields from rootCaseFields and tagFieldsInObject. +let private computeRootInstanceFields (ctx: TypeDefContext) rootCaseFields (tagFieldsInObject: (string * ILType * ILAttribute list) list) = let isStruct = ctx.td.IsStruct let isTotallyImmutable = (ctx.cud.HasHelpers <> SpecialFSharpListHelpers) [ - for fldName, fldTy, attrs in (selfFields @ tagFieldsInObject) do + for fldName, fldTy, attrs in (rootCaseFields @ tagFieldsInObject) do let fdef = let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Assembly) @@ -1847,12 +1841,12 @@ let private assembleUnionTypeDef (ctx: TypeDefContext) (results: AlternativeDefResult list) ctorMeths - selfMeths - selfAndTagFields + rootCaseMethods + rootAndTagFields tagMeths tagProps tagEnumFields - selfProps + rootCaseProperties = let g = ctx.g let td = ctx.td @@ -1890,18 +1884,18 @@ let private assembleUnionTypeDef mkILMethods ( ctorMeths @ baseMethsFromAlt - @ selfMeths + @ rootCaseMethods @ tagMeths @ altUniqObjMeths @ existingMeths ), fields = mkILFields ( - selfAndTagFields + rootAndTagFields @ List.map (fun r -> r.Field) altNullaryFields @ td.Fields.AsList() ), - properties = mkILProperties (tagProps @ basePropsFromAlt @ selfProps @ existingProps), + properties = mkILProperties (tagProps @ basePropsFromAlt @ rootCaseProperties @ existingProps), customAttrs = rootTypeNullableAttrs g td cud ) |> addConstFieldInit @@ -1957,9 +1951,15 @@ let mkClassUnionDef | HasTagField -> [ let n, t = mkTagFieldId g.ilg cuspec in n, t, [] ] | NoTagField -> [] - let selfFields, selfMeths, selfProps = emitRootClassFields ctx tagFieldsInObject - let selfAndTagFields = computeSelfAndTagFields ctx selfFields tagFieldsInObject - let ctorMeths = emitRootConstructors ctx selfFields tagFieldsInObject selfMeths + let rootCaseFields, rootCaseMethods, rootCaseProperties = + emitRootClassFields ctx tagFieldsInObject + + let rootAndTagFields = + computeRootInstanceFields ctx rootCaseFields tagFieldsInObject + + let ctorMeths = + emitRootConstructors ctx rootCaseFields tagFieldsInObject rootCaseMethods + let tagMeths, tagProps, tagEnumFields = emitTagInfrastructure ctx - assembleUnionTypeDef ctx results ctorMeths selfMeths selfAndTagFields tagMeths tagProps tagEnumFields selfProps + assembleUnionTypeDef ctx results ctorMeths rootCaseMethods rootAndTagFields tagMeths tagProps tagEnumFields rootCaseProperties From fb95901f003e977375654e85ee1e07084b9b745b Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 18:58:04 +0100 Subject: [PATCH 31/44] Perf: struct CaseIdentity, inline CaseIsNull AP, eliminate allocations MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - [] on CaseIdentity record — allocated per-instruction-site, immediately destructured, no need to heap-allocate - inline on (|CaseIsNull|CaseIsAllocated|) AP — avoids tuple allocation at 8 call sites (tuple was (layout, cidx)) - Array.filter |> Array.length = 1 → Array.existsOne in caseFieldsOnRoot — eliminates intermediate array allocation per call - cuspec.Alternatives → cuspec.AlternativesArray in emitLdDataTagPrim — avoids Array.toList allocation Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 827d6c793ef..8d0678db497 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -168,7 +168,7 @@ let (|FieldsOnRootType|FieldsOnNestedTypes|) layout = | UnionLayout.TaggedRefAllNullary _ -> FieldsOnNestedTypes /// Is a specific case (by index) represented as null? -let (|CaseIsNull|CaseIsAllocated|) (layout, cidx) = +let inline (|CaseIsNull|CaseIsAllocated|) (layout, cidx) = match layout with | UnionLayout.SmallRefWithNullAsTrueValue(_, nullIdx) when nullIdx = cidx -> CaseIsNull | UnionLayout.SmallRef _ @@ -259,7 +259,7 @@ let private caseFieldsOnRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: Il && (match layout with | UnionLayout.FSharpList _ -> alt.Name = ALT_NAME_CONS | UnionLayout.SingleCaseRef _ -> true - | UnionLayout.SmallRefWithNullAsTrueValue _ -> alts |> Array.filter (fun a -> not a.IsNullary) |> Array.length = 1 + | UnionLayout.SmallRefWithNullAsTrueValue _ -> alts |> Array.existsOne (fun a -> not a.IsNullary) | UnionLayout.SmallRef _ | UnionLayout.SingleCaseStruct _ | UnionLayout.TaggedRef _ @@ -445,6 +445,7 @@ let altOfUnionSpec (cuspec: IlxUnionSpec) cidx = failwith ("alternative " + string cidx + " not found") /// Resolved identity of a union case within a union spec. +[] type CaseIdentity = { Index: int @@ -744,7 +745,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS | DataAccess.RawFields -> let layout = classifyFromSpec cuspec - let alts = cuspec.Alternatives + let alts = cuspec.AlternativesArray match layout with | UnionLayout.FSharpList _ -> From 30319c55fb16634dc9c9f1ada83841c4c764641f Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 19:22:54 +0100 Subject: [PATCH 32/44] Eliminate redundant classifyFromSpec/baseTyOfUnionSpec in EraseUnions Add tyForAltIdxWith and resolveCaseWith that accept precomputed layout and baseTy. Update emit functions (emitRawConstruction, emitIsCase, emitBranchOnCase, emitCastToCase, emitCaseSwitch, emitLdDataTagPrim) and type-def functions (emitNullaryConstField, emitNestedAlternativeType) to use the precomputed values instead of recomputing per call. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 40 +++++++++++++++-------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 8d0678db497..3731ceda280 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -297,10 +297,7 @@ let private needsSingletonField (layout: UnionLayout) (alt: IlxUnionCase) (cidx: | ReferenceTypeLayout -> true | ValueTypeLayout -> false -let private tyForAltIdx cuspec (alt: IlxUnionCase) cidx = - let layout = classifyFromSpec cuspec - let baseTy = baseTyOfUnionSpec cuspec - +let private tyForAltIdxWith (layout: UnionLayout) (baseTy: ILType) (cuspec: IlxUnionSpec) (alt: IlxUnionCase) cidx = if caseRepresentedOnRoot layout alt cuspec.AlternativesArray cidx then baseTy else @@ -309,6 +306,9 @@ let private tyForAltIdx cuspec (alt: IlxUnionCase) cidx = let nm = if alt.IsNullary || isList then "_" + altName else altName mkILNamedTy cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs +let private tyForAltIdx cuspec (alt: IlxUnionCase) cidx = + tyForAltIdxWith (classifyFromSpec cuspec) (baseTyOfUnionSpec cuspec) cuspec alt cidx + /// How a specific union case is physically stored. [] type CaseStorage = @@ -335,7 +335,7 @@ let classifyCaseStorage (layout: UnionLayout) (cuspec: IlxUnionSpec) (cidx: int) elif needsSingletonField layout alt cidx then CaseStorage.Singleton else - CaseStorage.InNestedType(tyForAltIdx cuspec alt cidx) + CaseStorage.InNestedType(tyForAltIdxWith layout (baseTyOfUnionSpec cuspec) cuspec alt cidx) // ---- Context Records ---- @@ -454,14 +454,14 @@ type CaseIdentity = CaseName: string } -/// Resolve a case by index, computing its type and name. -let resolveCase (cuspec: IlxUnionSpec) (cidx: int) = +/// Resolve a case by index using precomputed layout and base type. +let private resolveCaseWith (layout: UnionLayout) (baseTy: ILType) (cuspec: IlxUnionSpec) (cidx: int) = let alt = altOfUnionSpec cuspec cidx { Index = cidx Case = alt - CaseType = tyForAltIdx cuspec alt cidx + CaseType = tyForAltIdxWith layout baseTy cuspec alt cidx CaseName = alt.Name } @@ -552,7 +552,8 @@ let mkTagDiscriminateThen ilg cuspec cidx after = [ mkGetTag ilg cuspec; mkLdcInt32 cidx ] @ mkCeqThen after let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = - let ci = resolveCase cuspec cidx + let baseTy = baseTyOfUnionSpec cuspec + let ci = resolveCaseWith layout baseTy cuspec cidx let storage = classifyCaseStorage layout cuspec cidx ci.Case match storage with @@ -561,10 +562,8 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = [ AI_ldnull ] | CaseStorage.Singleton -> // Nullary ref type: load the singleton static field - let baseTy = baseTyOfUnionSpec cuspec [ I_ldsfld(Nonvolatile, mkConstFieldSpec ci.CaseName baseTy) ] | CaseStorage.OnRoot -> - let baseTy = baseTyOfUnionSpec cuspec if ci.Case.IsNullary then // Struct + nullary: create via root ctor with tag @@ -639,7 +638,8 @@ let mkNewData ilg (cuspec, cidx) = | _ -> emitRawConstruction ilg cuspec layout cidx let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = - let ci = resolveCase cuspec cidx + let baseTy = baseTyOfUnionSpec cuspec + let ci = resolveCaseWith layout baseTy cuspec cidx match layout, cidx with | CaseIsNull -> @@ -657,7 +657,7 @@ let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = | UnionLayout.TaggedRef _ | UnionLayout.TaggedRefAllNullary _ | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx + | UnionLayout.TaggedStructAllNullary _ -> mkTagDiscriminate ilg cuspec baseTy cidx | UnionLayout.FSharpList _ -> match cidx with | TagNil -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_ceq ] @@ -706,7 +706,8 @@ let genWith g : ILCode = let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx tg = let neg = (if sense then BI_brfalse else BI_brtrue) let pos = (if sense then BI_brtrue else BI_brfalse) - let ci = resolveCase cuspec cidx + let baseTy = baseTyOfUnionSpec cuspec + let ci = resolveCaseWith layout baseTy cuspec cidx match layout, cidx with | CaseIsNull -> @@ -794,7 +795,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS [ test ] else let altName = alt.Name - let altTy = tyForAltIdx cuspec alt cidx + let altTy = tyForAltIdxWith layout baseTy cuspec alt cidx mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy test cg.EmitInstrs(ld :: testBlock) @@ -814,7 +815,8 @@ let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionSpec) = emitLdDataTagPrim ilg None cg (access, cuspec) let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layout: UnionLayout) cidx = - let ci = resolveCase cuspec cidx + let baseTy = baseTyOfUnionSpec cuspec + let ci = resolveCaseWith layout baseTy cuspec cidx let storage = classifyCaseStorage layout cuspec cidx ci.Case match storage with @@ -868,7 +870,7 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: Unio for cidx, tg in cases do let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAltIdx cuspec alt cidx + let altTy = tyForAltIdxWith layout baseTy cuspec alt cidx let altName = alt.Name let failLab = cg.GenerateDelayMark() let cmpNull = (nullAsTrueValueIdx = Some cidx) @@ -1320,7 +1322,7 @@ let private emitNullaryConstField (ctx: TypeDefContext) (num: int) (alt: IlxUnio let baseTy = ctx.baseTy let cuspec = ctx.cuspec let altName = alt.Name - let altTy = tyForAltIdx cuspec alt num + let altTy = tyForAltIdxWith ctx.layout ctx.baseTy cuspec alt num if needsSingletonField ctx.layout alt num then let basic: ILFieldDef = @@ -1349,7 +1351,7 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx let cud = ctx.cud let cuspec = ctx.cuspec let baseTy = ctx.baseTy - let altTy = tyForAltIdx cuspec alt num + let altTy = tyForAltIdxWith ctx.layout ctx.baseTy cuspec alt num let fields = alt.FieldDefs let imports = cud.DebugImports let attr = cud.DebugPoint From 9885a7ec5625a4bfda58360e87ff0a27b1953aa8 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 19:31:38 +0100 Subject: [PATCH 33/44] Readability: extract nullable rewrite helper, improve comments MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Extract rewriteNullableAttrForFlattenedField from rewriteFieldsForStructFlattening — reduces nesting from 3→1 level, documents the byte semantics clearly - Add comments: reverse iteration rationale in emitLdDataTagPrim, minNullaryIdx ctor sharing logic, isAbstract derivation Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 61 ++++++++++++++--------------- 1 file changed, 29 insertions(+), 32 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 3731ceda280..243a28d85aa 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -803,7 +803,7 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS cg.EmitInstrs [ mkLdcInt32 cidx; I_br(cg.CodeLabel outlab) ] cg.SetMarkToHere failLab - // Make the blocks for the remaining tests. + // Emit type tests in reverse order; case 0 is the fallback (loaded after the loop). for n in alts.Length - 1 .. -1 .. 1 do emitCase n @@ -1503,6 +1503,29 @@ let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCa /// Rewrite field nullable attributes for struct flattening. /// When a struct DU has multiple cases, all boxed fields become potentially nullable /// because only one case's fields are valid at a time. +/// When a struct DU has multiple cases, all boxed fields become potentially nullable +/// because only one case's fields are valid at a time. This rewrites the [Nullable] attribute +/// on a field to WithNull (2uy) if it was marked as non-nullable (1uy) within its case. +let private rewriteNullableAttrForFlattenedField (g: TcGlobals) (existingAttrs: ILAttribute[]) = + let nullableIdx = + existingAttrs |> Array.tryFindIndex (IsILAttrib g.attrib_NullableAttribute) + + match nullableIdx with + | None -> + existingAttrs + |> Array.append [| GetNullableAttribute g [ NullnessInfo.WithNull ] |] + | Some idx -> + let replacementAttr = + match existingAttrs[idx] with + // Single byte: change non-nullable (1) to WithNull (2); leave nullable (2) and ambivalent (0) as-is + | Encoded(method, _data, [ ILAttribElem.Byte 1uy ]) -> mkILCustomAttribMethRef (method, [ ILAttribElem.Byte 2uy ], []) + // Array of bytes: change first element only (field itself); leave generic type arg nullability unchanged + | Encoded(method, _data, [ ILAttribElem.Array(elemType, ILAttribElem.Byte 1uy :: otherElems) ]) -> + mkILCustomAttribMethRef (method, [ ILAttribElem.Array(elemType, (ILAttribElem.Byte 2uy) :: otherElems) ], []) + | attrAsBefore -> attrAsBefore + + existingAttrs |> Array.replace idx replacementAttr + let private rewriteFieldsForStructFlattening (g: TcGlobals) (alt: IlxUnionCase) (layout: UnionLayout) = match layout with | UnionLayout.TaggedStruct _ @@ -1513,35 +1536,7 @@ let private rewriteFieldsForStructFlattening (g: TcGlobals) (alt: IlxUnionCase) field else let attrs = - let existingAttrs = field.ILField.CustomAttrs.AsArray() - - let nullableIdx = - existingAttrs |> Array.tryFindIndex (IsILAttrib g.attrib_NullableAttribute) - - match nullableIdx with - | None -> - existingAttrs - |> Array.append [| GetNullableAttribute g [ NullnessInfo.WithNull ] |] - | Some idx -> - let replacementAttr = - match existingAttrs[idx] with - (* - The attribute carries either a single byte, or a list of bytes for the fields itself and all its generic type arguments - The way we lay out DUs does not affect nullability of the typars of a field, therefore we just change the very first byte - If the field was already declared as nullable (value = 2uy) or ambivalent(value = 0uy), we can keep it that way - If it was marked as non-nullable within that UnionCase, we have to convert it to WithNull (2uy) due to other cases being possible - *) - | Encoded(method, _data, [ ILAttribElem.Byte 1uy ]) -> - mkILCustomAttribMethRef (method, [ ILAttribElem.Byte 2uy ], []) - | Encoded(method, _data, [ ILAttribElem.Array(elemType, ILAttribElem.Byte 1uy :: otherElems) ]) -> - mkILCustomAttribMethRef ( - method, - [ ILAttribElem.Array(elemType, (ILAttribElem.Byte 2uy) :: otherElems) ], - [] - ) - | attrAsBefore -> attrAsBefore - - existingAttrs |> Array.replace idx replacementAttr + rewriteNullableAttrForFlattenedField g (field.ILField.CustomAttrs.AsArray()) field.ILField.With(customAttrs = mkILCustomAttrsFromArray attrs) |> IlxUnionCaseField) @@ -1599,8 +1594,9 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin | Some ilTy -> Some ilTy.TypeSpec let ctor = - // Structs with fields are created using static makers methods - // Structs without fields can share constructor for the 'tag' value, we just create one + // Structs use static maker methods for non-nullary cases. + // For nullary struct cases, we emit a single shared ctor (for the min-index nullary) + // that takes only the tag value — all other nullary cases reuse it via the maker. if isStruct && not (cidx = minNullaryIdx) then [] else @@ -1866,6 +1862,7 @@ let private assembleUnionTypeDef let existingMeths = td.Methods.AsList() let existingProps = td.Properties.AsList() + // The root type is abstract when every case has its own nested subtype. let isAbstract = (altTypeDefs.Length = cud.UnionCases.Length) let baseTypeDef: ILTypeDef = From 9a3f9f6376db0c0d43d66f36d511a279ad9558ba Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 20:48:35 +0100 Subject: [PATCH 34/44] =?UTF-8?q?Phase=204:=20emitIsCase+emitBranchOnCase?= =?UTF-8?q?=20=E2=86=92=20CaseStorage=20=C3=97=20DiscriminationMethod?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Replace inline re-derivation from raw UnionLayout with two-axis classification: CaseStorage (WHERE) × DiscriminationMethod AP (HOW). emitIsCase: match storage with Null→null-ceq, then match (storage, layout) with OnRoot+RuntimeType→non-null-test, NoDiscrimination→ always-true, RuntimeType→isinst, TagField→tag-ceq, TailNull→tail-check. emitBranchOnCase: same two-axis structure with branch instructions. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 51 +++++++++++------------------ 1 file changed, 20 insertions(+), 31 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 243a28d85aa..81e02fc6ccc 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -640,25 +640,20 @@ let mkNewData ilg (cuspec, cidx) = let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = let baseTy = baseTyOfUnionSpec cuspec let ci = resolveCaseWith layout baseTy cuspec cidx + let storage = classifyCaseStorage layout cuspec cidx ci.Case - match layout, cidx with - | CaseIsNull -> + match storage with + | CaseStorage.Null -> // Null-represented case: compare with null [ AI_ldnull; AI_ceq ] | _ -> - match layout with - | UnionLayout.SmallRefWithNullAsTrueValue _ when caseFieldsOnRoot layout ci.Case cuspec.AlternativesArray -> - // Single non-nullary with all null siblings: test via non-null - [ AI_ldnull; AI_cgt_un ] - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ -> [ mkLdcInt32 1 ] - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ -> mkRuntimeTypeDiscriminate ilg access cuspec ci.Case ci.CaseName ci.CaseType - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> mkTagDiscriminate ilg cuspec baseTy cidx - | UnionLayout.FSharpList _ -> + match storage, layout with + // Single non-nullary folded to root with null siblings: test non-null + | CaseStorage.OnRoot, DiscriminateByRuntimeType -> [ AI_ldnull; AI_cgt_un ] + | _, NoDiscrimination -> [ mkLdcInt32 1 ] + | _, DiscriminateByRuntimeType -> mkRuntimeTypeDiscriminate ilg access cuspec ci.Case ci.CaseName ci.CaseType + | _, DiscriminateByTagField -> mkTagDiscriminate ilg cuspec baseTy cidx + | _, DiscriminateByTailNull -> match cidx with | TagNil -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_ceq ] | TagCons -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] @@ -708,26 +703,20 @@ let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx let pos = (if sense then BI_brtrue else BI_brfalse) let baseTy = baseTyOfUnionSpec cuspec let ci = resolveCaseWith layout baseTy cuspec cidx + let storage = classifyCaseStorage layout cuspec cidx ci.Case - match layout, cidx with - | CaseIsNull -> + match storage with + | CaseStorage.Null -> // Null-represented case: branch on null [ I_brcmp(neg, tg) ] | _ -> - match layout with - | UnionLayout.SmallRefWithNullAsTrueValue _ when caseFieldsOnRoot layout ci.Case cuspec.AlternativesArray -> - // Single non-nullary with all null siblings: branch on non-null - [ I_brcmp(pos, tg) ] - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ -> [] - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ -> - mkRuntimeTypeDiscriminateThen ilg access cuspec ci.Case ci.CaseName ci.CaseType (I_brcmp(pos, tg)) - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) - | UnionLayout.FSharpList _ -> + match storage, layout with + // Single non-nullary folded to root with null siblings: branch on non-null + | CaseStorage.OnRoot, DiscriminateByRuntimeType -> [ I_brcmp(pos, tg) ] + | _, NoDiscrimination -> [] + | _, DiscriminateByRuntimeType -> mkRuntimeTypeDiscriminateThen ilg access cuspec ci.Case ci.CaseName ci.CaseType (I_brcmp(pos, tg)) + | _, DiscriminateByTagField -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) + | _, DiscriminateByTailNull -> match cidx with | TagNil -> [ mkGetTailOrNull access cuspec; I_brcmp(neg, tg) ] | TagCons -> [ mkGetTailOrNull access cuspec; I_brcmp(pos, tg) ] From b9a283fbdd817df85e9a8996942e827974a5b7ae Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 20:56:44 +0100 Subject: [PATCH 35/44] Phase 4: Architecture docs, InteropCapability, reduce mkMethodsAndProps params MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Add two-axis architecture comment documenting UnionLayout×CaseStorage model - Add InteropCapability type + classifier for fslang-suggestions/1463 readiness (ClosedHierarchy|UnionProtocol|UnionProtocolWithTupleBoxing|NoInterop) - Reduce mkMethodsAndPropertiesForFields from 8 params to 3 (ctx, ilTy, fields) Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 93 ++++++++++++++++++++--------- 1 file changed, 64 insertions(+), 29 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 81e02fc6ccc..25d3e45455e 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -14,6 +14,27 @@ open FSharp.Compiler.TcGlobals open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types +// ============================================================================ +// Architecture: Two-axis classification model +// +// Every decision in this module is driven by two independent classifications: +// +// 1. UnionLayout (8 cases) — how the union TYPE is structured in IL +// Computed once per union via classifyFromSpec / classifyFromDef. +// +// 2. CaseStorage (5 cases) — how each individual CASE is stored +// Computed per case via classifyCaseStorage. Answers: is this case null? +// A singleton field? Fields on root? In a nested subtype? Struct tag-only? +// +// Orthogonal concerns read from these: +// - DataAccess (3 cases) — how callers access data (raw fields vs helpers) +// - DiscriminationMethod (AP) — how to distinguish cases (tag/isinst/tail-null) +// +// The emit functions match on CaseStorage first (WHERE is it?), then on +// DiscriminationMethod (HOW to tell it apart?). This two-axis pattern +// ensures each function reads as a simple decision table, not a re-derivation. +// ============================================================================ + /// How to access union data at a given call site. /// Combines the per-call-site 'avoidHelpers' flag with the per-union 'HasHelpers' setting /// into a single value computed once at the entry point. @@ -337,6 +358,37 @@ let classifyCaseStorage (layout: UnionLayout) (cuspec: IlxUnionSpec) (cidx: int) else CaseStorage.InNestedType(tyForAltIdxWith layout (baseTyOfUnionSpec cuspec) cuspec alt cidx) +/// What C# interop mechanisms this union layout can support. +/// See https://github.com/fsharp/fslang-suggestions/discussions/1463 +[] +type InteropCapability = + /// Can emit [Closed] hierarchy for C# exhaustive pattern matching via subtypes + | ClosedHierarchy + /// Can emit [Union]+IUnion for C# union protocol + | UnionProtocol + /// Can emit [Union]+IUnion but multi-field cases need ValueTuple boxing + | UnionProtocolWithTupleBoxing + /// Cannot emit C# interop (null represents a case — calling Value on null would throw NRE) + | NoInterop + +/// Classify what C# interop mechanisms this union layout supports. +let _classifyInteropCapability (layout: UnionLayout) = + match layout with + // Abstract root + nested subclasses → natural [Closed] hierarchy + | UnionLayout.SmallRef _ + | UnionLayout.TaggedRef _ -> InteropCapability.ClosedHierarchy + // Single value or enum-like → [Union]+IUnion, Value boxes on demand + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStructAllNullary _ -> InteropCapability.UnionProtocol + // Struct with data cases → [Union]+IUnion, multi-field cases need ValueTuple + | UnionLayout.TaggedStruct _ -> InteropCapability.UnionProtocolWithTupleBoxing + // null = case (option-like) → cannot implement IUnion safely + | UnionLayout.SmallRefWithNullAsTrueValue _ -> InteropCapability.NoInterop + // Hardcoded special type + | UnionLayout.FSharpList _ -> InteropCapability.NoInterop + // ---- Context Records ---- /// Bundles the IL attribute-stamping callbacks used during type definition generation. @@ -915,16 +967,16 @@ let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (access, cuspec, cases) = //--------------------------------------------------- // Generate the union classes -let mkMethodsAndPropertiesForFields - (addMethodGeneratedAttrs, addPropertyGeneratedAttrs) - (g: TcGlobals) - access - attr - imports - hasHelpers - (ilTy: ILType) - (fields: IlxUnionCaseField[]) - = +let mkMethodsAndPropertiesForFields (ctx: TypeDefContext) (ilTy: ILType) (fields: IlxUnionCaseField[]) = + let g = ctx.g + let cud = ctx.cud + let access = cud.UnionCasesAccessibility + let attr = cud.DebugPoint + let imports = cud.DebugImports + let hasHelpers = cud.HasHelpers + let addMethodGeneratedAttrs = ctx.stamping.stampMethodAsGenerated + let addPropertyGeneratedAttrs = ctx.stamping.stampPropertyAsGenerated + let basicProps = fields |> Array.map (fun field -> @@ -1374,16 +1426,7 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx |> Array.toList - let basicProps, basicMethods = - mkMethodsAndPropertiesForFields - (ctx.stamping.stampMethodAsGenerated, ctx.stamping.stampPropertyAsGenerated) - g - cud.UnionCasesAccessibility - attr - imports - cud.HasHelpers - altTy - fields + let basicProps, basicMethods = mkMethodsAndPropertiesForFields ctx altTy fields let basicCtorInstrs = [ @@ -1618,15 +1661,7 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin |> Array.toList let props, meths = - mkMethodsAndPropertiesForFields - (ctx.stamping.stampMethodAsGenerated, ctx.stamping.stampPropertyAsGenerated) - g - cud.UnionCasesAccessibility - cud.DebugPoint - cud.DebugImports - cud.HasHelpers - baseTy - fieldsToBeAddedIntoType + mkMethodsAndPropertiesForFields ctx baseTy fieldsToBeAddedIntoType yield (fields, (ctor @ meths), props) ] From 74db0808f6a981b4b4e6e9680f7a0496c9abfe12 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 23:19:24 +0100 Subject: [PATCH 36/44] Remove speculative InteropCapability code Dead code for a future feature that hasn't been approved. Only code that is actually used belongs in the codebase. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 31 ----------------------------- 1 file changed, 31 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 25d3e45455e..28556fb536e 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -358,37 +358,6 @@ let classifyCaseStorage (layout: UnionLayout) (cuspec: IlxUnionSpec) (cidx: int) else CaseStorage.InNestedType(tyForAltIdxWith layout (baseTyOfUnionSpec cuspec) cuspec alt cidx) -/// What C# interop mechanisms this union layout can support. -/// See https://github.com/fsharp/fslang-suggestions/discussions/1463 -[] -type InteropCapability = - /// Can emit [Closed] hierarchy for C# exhaustive pattern matching via subtypes - | ClosedHierarchy - /// Can emit [Union]+IUnion for C# union protocol - | UnionProtocol - /// Can emit [Union]+IUnion but multi-field cases need ValueTuple boxing - | UnionProtocolWithTupleBoxing - /// Cannot emit C# interop (null represents a case — calling Value on null would throw NRE) - | NoInterop - -/// Classify what C# interop mechanisms this union layout supports. -let _classifyInteropCapability (layout: UnionLayout) = - match layout with - // Abstract root + nested subclasses → natural [Closed] hierarchy - | UnionLayout.SmallRef _ - | UnionLayout.TaggedRef _ -> InteropCapability.ClosedHierarchy - // Single value or enum-like → [Union]+IUnion, Value boxes on demand - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.TaggedStructAllNullary _ -> InteropCapability.UnionProtocol - // Struct with data cases → [Union]+IUnion, multi-field cases need ValueTuple - | UnionLayout.TaggedStruct _ -> InteropCapability.UnionProtocolWithTupleBoxing - // null = case (option-like) → cannot implement IUnion safely - | UnionLayout.SmallRefWithNullAsTrueValue _ -> InteropCapability.NoInterop - // Hardcoded special type - | UnionLayout.FSharpList _ -> InteropCapability.NoInterop - // ---- Context Records ---- /// Bundles the IL attribute-stamping callbacks used during type definition generation. From f852f5cc8d6598700962d4011681111565f46214 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 23:26:38 +0100 Subject: [PATCH 37/44] Remove dead code: _validateActivePatterns, NonNullaryFoldsToRoot, FieldsOnRootType APs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit All three were never called by any live code path: - _validateActivePatterns: 'compile-time check' trick — real match sites enforce exhaustiveness - NonNullaryFoldsToRoot AP: only consumed by the removed validation function - FieldsOnRootType AP: same Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 68 ----------------------------- 1 file changed, 68 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 28556fb536e..2ee89719079 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -175,19 +175,6 @@ let (|HasTagField|NoTagField|) layout = | UnionLayout.SingleCaseRef _ | UnionLayout.SingleCaseStruct _ -> NoTagField -/// Where are case fields stored? -let (|FieldsOnRootType|FieldsOnNestedTypes|) layout = - match layout with - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ - | UnionLayout.FSharpList _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> FieldsOnRootType - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ -> FieldsOnNestedTypes - /// Is a specific case (by index) represented as null? let inline (|CaseIsNull|CaseIsAllocated|) (layout, cidx) = match layout with @@ -215,61 +202,6 @@ let (|ValueTypeLayout|ReferenceTypeLayout|) layout = | UnionLayout.TaggedRefAllNullary _ | UnionLayout.FSharpList _ -> ReferenceTypeLayout -/// Does a non-nullary case fold its fields into the root class (no nested type)? -let (|NonNullaryFoldsToRoot|NonNullaryInNestedType|) (layout, alt: IlxUnionCase) = - match layout with - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ - | UnionLayout.FSharpList _ -> NonNullaryFoldsToRoot - | UnionLayout.TaggedRefAllNullary _ -> NonNullaryFoldsToRoot - | UnionLayout.TaggedRef _ when not alt.IsNullary -> NonNullaryInNestedType - | UnionLayout.TaggedRef _ -> NonNullaryFoldsToRoot - | UnionLayout.SmallRef _ when not alt.IsNullary -> NonNullaryInNestedType - | UnionLayout.SmallRef _ -> NonNullaryFoldsToRoot - | UnionLayout.SmallRefWithNullAsTrueValue _ when not alt.IsNullary -> NonNullaryInNestedType - | UnionLayout.SmallRefWithNullAsTrueValue _ -> NonNullaryFoldsToRoot - -/// Compile-time validation that all active patterns cover all UnionLayout cases. -/// Also validates that classifyFromSpec and classifyFromDef compile correctly. -let private _validateActivePatterns - (layout: UnionLayout) - (alt: IlxUnionCase) - (cuspec: IlxUnionSpec) - (td: ILTypeDef) - (cud: IlxUnionInfo) - (baseTy: ILType) - = - let _fromSpec = classifyFromSpec cuspec - let _fromDef = classifyFromDef td cud baseTy - - match layout with - | DiscriminateByTagField - | DiscriminateByRuntimeType - | DiscriminateByTailNull - | NoDiscrimination -> () - - match layout with - | HasTagField - | NoTagField -> () - - match layout with - | FieldsOnRootType - | FieldsOnNestedTypes -> () - - match layout, 0 with - | CaseIsNull - | CaseIsAllocated -> () - - match layout with - | ValueTypeLayout - | ReferenceTypeLayout -> () - - match layout, alt with - | NonNullaryFoldsToRoot - | NonNullaryInNestedType -> () - // ---- Layout-Based Helpers ---- // These replace the old representation decision methods. From 3e7e8a7ffaba3a6bdfa47c1dbf70dd807dc93acf Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 23:36:20 +0100 Subject: [PATCH 38/44] Enrich DiscriminationMethod AP to carry baseTy and nullAsTrueValueIdx Active patterns can carry data. The DiscriminationMethod AP now returns: - DiscriminateByTagField baseTy - DiscriminateByRuntimeType(baseTy, nullAsTrueValueIdx: int option) - DiscriminateByTailNull baseTy - NoDiscrimination baseTy This eliminates 3 separate baseTyOfUnionSpec calls and 2 re-matches on SmallRefWithNullAsTrueValue to extract nullIdx in emit functions. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.fs | 78 +++++++++++------------------ 1 file changed, 28 insertions(+), 50 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 2ee89719079..7389daa12e6 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -152,15 +152,15 @@ let classifyFromDef (td: ILTypeDef) (cud: IlxUnionInfo) (baseTy: ILType) = /// How to discriminate between cases at runtime. let (|DiscriminateByTagField|DiscriminateByRuntimeType|DiscriminateByTailNull|NoDiscrimination|) layout = match layout with - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> DiscriminateByTagField - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ -> DiscriminateByRuntimeType - | UnionLayout.FSharpList _ -> DiscriminateByTailNull - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ -> NoDiscrimination + | UnionLayout.TaggedRef baseTy + | UnionLayout.TaggedRefAllNullary baseTy + | UnionLayout.TaggedStruct baseTy + | UnionLayout.TaggedStructAllNullary baseTy -> DiscriminateByTagField baseTy + | UnionLayout.SmallRef baseTy -> DiscriminateByRuntimeType(baseTy, None) + | UnionLayout.SmallRefWithNullAsTrueValue(baseTy, nullIdx) -> DiscriminateByRuntimeType(baseTy, Some nullIdx) + | UnionLayout.FSharpList baseTy -> DiscriminateByTailNull baseTy + | UnionLayout.SingleCaseRef baseTy -> NoDiscrimination baseTy + | UnionLayout.SingleCaseStruct baseTy -> NoDiscrimination baseTy /// Does the root type have a _tag integer field? let (|HasTagField|NoTagField|) layout = @@ -602,11 +602,11 @@ let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = | _ -> match storage, layout with // Single non-nullary folded to root with null siblings: test non-null - | CaseStorage.OnRoot, DiscriminateByRuntimeType -> [ AI_ldnull; AI_cgt_un ] - | _, NoDiscrimination -> [ mkLdcInt32 1 ] - | _, DiscriminateByRuntimeType -> mkRuntimeTypeDiscriminate ilg access cuspec ci.Case ci.CaseName ci.CaseType - | _, DiscriminateByTagField -> mkTagDiscriminate ilg cuspec baseTy cidx - | _, DiscriminateByTailNull -> + | CaseStorage.OnRoot, DiscriminateByRuntimeType _ -> [ AI_ldnull; AI_cgt_un ] + | _, NoDiscrimination _ -> [ mkLdcInt32 1 ] + | _, DiscriminateByRuntimeType _ -> mkRuntimeTypeDiscriminate ilg access cuspec ci.Case ci.CaseName ci.CaseType + | _, DiscriminateByTagField baseTy -> mkTagDiscriminate ilg cuspec baseTy cidx + | _, DiscriminateByTailNull _ -> match cidx with | TagNil -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_ceq ] | TagCons -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] @@ -665,11 +665,12 @@ let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx | _ -> match storage, layout with // Single non-nullary folded to root with null siblings: branch on non-null - | CaseStorage.OnRoot, DiscriminateByRuntimeType -> [ I_brcmp(pos, tg) ] - | _, NoDiscrimination -> [] - | _, DiscriminateByRuntimeType -> mkRuntimeTypeDiscriminateThen ilg access cuspec ci.Case ci.CaseName ci.CaseType (I_brcmp(pos, tg)) - | _, DiscriminateByTagField -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) - | _, DiscriminateByTailNull -> + | CaseStorage.OnRoot, DiscriminateByRuntimeType _ -> [ I_brcmp(pos, tg) ] + | _, NoDiscrimination _ -> [] + | _, DiscriminateByRuntimeType _ -> + mkRuntimeTypeDiscriminateThen ilg access cuspec ci.Case ci.CaseName ci.CaseType (I_brcmp(pos, tg)) + | _, DiscriminateByTagField _ -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) + | _, DiscriminateByTailNull _ -> match cidx with | TagNil -> [ mkGetTailOrNull access cuspec; I_brcmp(neg, tg) ] | TagCons -> [ mkGetTailOrNull access cuspec; I_brcmp(pos, tg) ] @@ -691,28 +692,18 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS let alts = cuspec.AlternativesArray match layout with - | UnionLayout.FSharpList _ -> + | DiscriminateByTailNull _ -> // leaves 1 if cons, 0 if not ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] - | UnionLayout.TaggedRef baseTy - | UnionLayout.TaggedRefAllNullary baseTy - | UnionLayout.TaggedStruct baseTy - | UnionLayout.TaggedStructAllNullary baseTy -> + | DiscriminateByTagField baseTy -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstr(mkGetTagFromField ilg cuspec baseTy) - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ -> + | NoDiscrimination _ -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] - | UnionLayout.SmallRef baseTy - | UnionLayout.SmallRefWithNullAsTrueValue(baseTy, _) -> + | DiscriminateByRuntimeType(baseTy, nullAsTrueValueIdx) -> // RuntimeTypes: emit multi-way isinst chain - let nullAsTrueValueIdx = - match layout with - | UnionLayout.SmallRefWithNullAsTrueValue(_, idx) -> Some idx - | _ -> None - let ld = match ldOpt with | None -> @@ -796,16 +787,8 @@ let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, access, cuspec, cidx) = emitCastToCase ilg cg canfail access cuspec layout cidx let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: UnionLayout) cases = - let baseTy = baseTyOfUnionSpec cuspec - match layout with - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ -> - let nullAsTrueValueIdx = - match layout with - | UnionLayout.SmallRefWithNullAsTrueValue(_, idx) -> Some idx - | _ -> None - + | DiscriminateByRuntimeType(baseTy, nullAsTrueValueIdx) -> let locn = cg.GenLocal baseTy cg.EmitInstr(mkStloc locn) @@ -827,14 +810,10 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: Unio cg.SetMarkToHere failLab - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> + | DiscriminateByTagField _ -> match cases with | [] -> cg.EmitInstr AI_pop | _ -> - // Use a dictionary to avoid quadratic lookup in case list let dict = Dictionary() for i, case in cases do @@ -852,14 +831,13 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: Unio cg.EmitInstr(I_switch(Array.toList dests)) cg.SetMarkToHere failLab - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ -> + | NoDiscrimination _ -> match cases with | [ (0, tg) ] -> cg.EmitInstrs [ AI_pop; I_br tg ] | [] -> cg.EmitInstr AI_pop | _ -> failwith "unexpected: strange switch on single-case unions should not be present" - | UnionLayout.FSharpList _ -> failwith "unexpected: switches on lists should have been eliminated to brisdata tests" + | DiscriminateByTailNull _ -> failwith "unexpected: switches on lists should have been eliminated to brisdata tests" let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (access, cuspec, cases) = let layout = classifyFromSpec cuspec From eed5871868b2e38b850104204f368374d29982b4 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Fri, 27 Mar 2026 23:58:51 +0100 Subject: [PATCH 39/44] Split EraseUnions.fs into 3 files by semantic boundary MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit EraseUnions.Types.fs (421 lines): Domain model, classification, APs UnionLayout, CaseStorage, DataAccess, CaseIdentity, all active patterns, classification functions, layout-based helpers. EraseUnions.Emit.fs (442 lines): IL instruction emission Per-instruction-site IL: construct, discriminate, branch, cast, switch, load field, load tag. Public API consumed by IlxGen.fs. EraseUnions.fs (1039 lines): Type definition generation Per-union-definition: generate ILTypeDef with nested types, methods, properties, fields, debug proxies. The orchestrator. Dependency flow: Types ← Emit ← TypeDef (one-directional). Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.Emit.fs | 442 +++++++++++ src/Compiler/CodeGen/EraseUnions.Types.fs | 421 ++++++++++ src/Compiler/CodeGen/EraseUnions.fs | 831 +------------------- src/Compiler/CodeGen/EraseUnions.fsi | 59 -- src/Compiler/CodeGen/IlxGen.fs | 42 +- src/Compiler/FSharp.Compiler.Service.fsproj | 2 + 6 files changed, 887 insertions(+), 910 deletions(-) create mode 100644 src/Compiler/CodeGen/EraseUnions.Emit.fs create mode 100644 src/Compiler/CodeGen/EraseUnions.Types.fs diff --git a/src/Compiler/CodeGen/EraseUnions.Emit.fs b/src/Compiler/CodeGen/EraseUnions.Emit.fs new file mode 100644 index 00000000000..3bab4a31f09 --- /dev/null +++ b/src/Compiler/CodeGen/EraseUnions.Emit.fs @@ -0,0 +1,442 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +/// Erase discriminated unions - IL instruction emission. +[] +module internal FSharp.Compiler.AbstractIL.ILX.EraseUnionsEmit + +open FSharp.Compiler.IlxGenSupport + +open System.Collections.Generic +open System.Reflection +open Internal.Utilities.Library +open FSharp.Compiler.TypedTree +open FSharp.Compiler.TypedTreeOps +open FSharp.Compiler.TcGlobals +open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.AbstractIL.ILX.Types + +// Nullary cases on types with helpers do not reveal their underlying type even when +// using runtime type discrimination, because the underlying type is never needed from +// C# code and pollutes the visible API surface. In this case we must discriminate by +// calling the IsFoo helper. This only applies when accessing via helpers (inter-assembly). +let mkRuntimeTypeDiscriminate (ilg: ILGlobals) (access: DataAccess) cuspec (alt: IlxUnionCase) altName altTy = + if alt.IsNullary && access = DataAccess.ViaHelpers then + let baseTy = baseTyOfUnionSpec cuspec + + [ + mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + mkTesterName altName, [], ilg.typ_Bool)) + ] + else + [ I_isinst altTy; AI_ldnull; AI_cgt_un ] + +let mkRuntimeTypeDiscriminateThen ilg (access: DataAccess) cuspec (alt: IlxUnionCase) altName altTy after = + let useHelper = alt.IsNullary && access = DataAccess.ViaHelpers + + match after with + | I_brcmp(BI_brfalse, _) + | I_brcmp(BI_brtrue, _) when not useHelper -> [ I_isinst altTy; after ] + | _ -> mkRuntimeTypeDiscriminate ilg access cuspec alt altName altTy @ [ after ] + +let mkGetTagFromField ilg cuspec baseTy = + mkNormalLdfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) + +let mkSetTagToField ilg cuspec baseTy = + mkNormalStfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) + +let adjustFieldNameForTypeDef hasHelpers nm = + match hasHelpers, nm with + | SpecialFSharpListHelpers, "Head" -> "HeadOrDefault" + | SpecialFSharpListHelpers, "Tail" -> "TailOrNull" + | _ -> nm + +let adjustFieldName access nm = + match access, nm with + | DataAccess.ViaListHelpers, "Head" -> "HeadOrDefault" + | DataAccess.ViaListHelpers, "Tail" -> "TailOrNull" + | _ -> nm + +let mkLdData (access, cuspec, cidx, fidx) = + let alt = altOfUnionSpec cuspec cidx + let altTy = tyForAltIdx cuspec alt cidx + let fieldDef = alt.FieldDef fidx + + match access with + | DataAccess.RawFields -> mkNormalLdfld (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) + | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (altTy, "get_" + adjustFieldName access fieldDef.Name, [], fieldDef.Type)) + +let mkLdDataAddr (access, cuspec, cidx, fidx) = + let alt = altOfUnionSpec cuspec cidx + let altTy = tyForAltIdx cuspec alt cidx + let fieldDef = alt.FieldDef fidx + + match access with + | DataAccess.RawFields -> mkNormalLdflda (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) + | _ -> failwith (sprintf "can't load address using helpers, for fieldDef %s" fieldDef.LowerName) + +let mkGetTailOrNull access cuspec = + mkLdData (access, cuspec, 1, 1) (* tail is in alternative 1, field number 1 *) + +let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = + let baseTy = baseTyOfUnionSpec cuspec + + match classifyFromSpec cuspec with + | UnionLayout.SmallRefWithNullAsTrueValue _ -> + mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [ baseTy ], mkTagFieldType ilg cuspec)) + | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldType ilg cuspec)) + +let mkGetTag ilg (cuspec: IlxUnionSpec) = + match cuspec.HasHelpers with + | AllHelpers -> mkGetTagFromHelpers ilg cuspec + | _hasHelpers -> mkGetTagFromField ilg cuspec (baseTyOfUnionSpec cuspec) + +let mkCeqThen after = + match after with + | I_brcmp(BI_brfalse, a) -> [ I_brcmp(BI_bne_un, a) ] + | I_brcmp(BI_brtrue, a) -> [ I_brcmp(BI_beq, a) ] + | _ -> [ AI_ceq; after ] + +let mkTagDiscriminate ilg cuspec _baseTy cidx = + [ mkGetTag ilg cuspec; mkLdcInt32 cidx; AI_ceq ] + +let mkTagDiscriminateThen ilg cuspec cidx after = + [ mkGetTag ilg cuspec; mkLdcInt32 cidx ] @ mkCeqThen after + +let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = + let baseTy = baseTyOfUnionSpec cuspec + let ci = resolveCaseWith layout baseTy cuspec cidx + let storage = classifyCaseStorage layout cuspec cidx ci.Case + + match storage with + | CaseStorage.Null -> + // Null-represented case: just load null + [ AI_ldnull ] + | CaseStorage.Singleton -> + // Nullary ref type: load the singleton static field + [ I_ldsfld(Nonvolatile, mkConstFieldSpec ci.CaseName baseTy) ] + | CaseStorage.OnRoot -> + + if ci.Case.IsNullary then + // Struct + nullary: create via root ctor with tag + let tagField = [ mkTagFieldType ilg cuspec ] + [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] + else + // Non-nullary fields on root: create via root ctor with fields + let ctorFieldTys = ci.Case.FieldTypes |> Array.toList + [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] + | CaseStorage.InNestedType _ -> + // Case lives in a nested subtype + [ + mkNormalNewobj (mkILCtorMethSpecForTy (ci.CaseType, Array.toList ci.Case.FieldTypes)) + ] + +let emitRawNewData ilg cuspec cidx = + emitRawConstruction ilg cuspec (classifyFromSpec cuspec) cidx + +// The stdata 'instruction' is only ever used for the F# "List" type within FSharp.Core.dll +let mkStData (cuspec, cidx, fidx) = + let alt = altOfUnionSpec cuspec cidx + let altTy = tyForAltIdx cuspec alt cidx + let fieldDef = alt.FieldDef fidx + mkNormalStfld (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) + +let mkNewData ilg (cuspec, cidx) = + let alt = altOfUnionSpec cuspec cidx + let altName = alt.Name + let baseTy = baseTyOfUnionSpec cuspec + let layout = classifyFromSpec cuspec + + let viaMakerCall () = + [ + mkNormalCall ( + mkILNonGenericStaticMethSpecInTy ( + baseTy, + mkMakerName cuspec altName, + Array.toList alt.FieldTypes, + constFormalFieldTy baseTy + ) + ) + ] + + let viaGetAltNameProperty () = + [ + mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "get_" + altName, [], constFormalFieldTy baseTy)) + ] + + // If helpers exist, use them + match cuspec.HasHelpers with + | AllHelpers + | SpecialFSharpListHelpers + | SpecialFSharpOptionHelpers -> + match layout, cidx with + | CaseIsNull -> [ AI_ldnull ] + | _ -> + if alt.IsNullary then + viaGetAltNameProperty () + else + viaMakerCall () + + | NoHelpers -> + match layout, cidx with + | CaseIsNull -> [ AI_ldnull ] + | _ -> + match layout with + // Struct non-nullary: use maker method (handles initobj + field stores) + | ValueTypeLayout when not alt.IsNullary -> viaMakerCall () + // Ref nullary (not null-represented): use property accessor for singleton + | ReferenceTypeLayout when alt.IsNullary -> viaGetAltNameProperty () + // Everything else: raw construction + | _ -> emitRawConstruction ilg cuspec layout cidx + +let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = + let baseTy = baseTyOfUnionSpec cuspec + let ci = resolveCaseWith layout baseTy cuspec cidx + let storage = classifyCaseStorage layout cuspec cidx ci.Case + + match storage with + | CaseStorage.Null -> + // Null-represented case: compare with null + [ AI_ldnull; AI_ceq ] + | _ -> + match storage, layout with + // Single non-nullary folded to root with null siblings: test non-null + | CaseStorage.OnRoot, DiscriminateByRuntimeType _ -> [ AI_ldnull; AI_cgt_un ] + | _, NoDiscrimination _ -> [ mkLdcInt32 1 ] + | _, DiscriminateByRuntimeType _ -> mkRuntimeTypeDiscriminate ilg access cuspec ci.Case ci.CaseName ci.CaseType + | _, DiscriminateByTagField baseTy -> mkTagDiscriminate ilg cuspec baseTy cidx + | _, DiscriminateByTailNull _ -> + match cidx with + | TagNil -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_ceq ] + | TagCons -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] + | _ -> failwith "emitIsCase - unexpected list case index" + +let mkIsData ilg (access, cuspec, cidx) = + let layout = classifyFromSpec cuspec + emitIsCase ilg access cuspec layout cidx + +type ICodeGen<'Mark> = + abstract CodeLabel: 'Mark -> ILCodeLabel + abstract GenerateDelayMark: unit -> 'Mark + abstract GenLocal: ILType -> uint16 + abstract SetMarkToHere: 'Mark -> unit + abstract EmitInstr: ILInstr -> unit + abstract EmitInstrs: ILInstr list -> unit + abstract MkInvalidCastExnNewobj: unit -> ILInstr + +let genWith g : ILCode = + let instrs = ResizeArray() + let lab2pc = Dictionary() + + g + { new ICodeGen with + member _.CodeLabel(m) = m + member _.GenerateDelayMark() = generateCodeLabel () + member _.GenLocal(ilTy) = failwith "not needed" + member _.SetMarkToHere(m) = lab2pc[m] <- instrs.Count + member _.EmitInstr x = instrs.Add x + + member cg.EmitInstrs xs = + for i in xs do + cg.EmitInstr i + + member _.MkInvalidCastExnNewobj() = failwith "not needed" + } + + { + Labels = lab2pc + Instrs = instrs.ToArray() + Exceptions = [] + Locals = [] + } + +let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx tg = + let neg = (if sense then BI_brfalse else BI_brtrue) + let pos = (if sense then BI_brtrue else BI_brfalse) + let baseTy = baseTyOfUnionSpec cuspec + let ci = resolveCaseWith layout baseTy cuspec cidx + let storage = classifyCaseStorage layout cuspec cidx ci.Case + + match storage with + | CaseStorage.Null -> + // Null-represented case: branch on null + [ I_brcmp(neg, tg) ] + | _ -> + match storage, layout with + // Single non-nullary folded to root with null siblings: branch on non-null + | CaseStorage.OnRoot, DiscriminateByRuntimeType _ -> [ I_brcmp(pos, tg) ] + | _, NoDiscrimination _ -> [] + | _, DiscriminateByRuntimeType _ -> + mkRuntimeTypeDiscriminateThen ilg access cuspec ci.Case ci.CaseName ci.CaseType (I_brcmp(pos, tg)) + | _, DiscriminateByTagField _ -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) + | _, DiscriminateByTailNull _ -> + match cidx with + | TagNil -> [ mkGetTailOrNull access cuspec; I_brcmp(neg, tg) ] + | TagCons -> [ mkGetTailOrNull access cuspec; I_brcmp(pos, tg) ] + | _ -> failwith "emitBranchOnCase - unexpected list case index" + +let mkBrIsData ilg sense (access, cuspec, cidx, tg) = + let layout = classifyFromSpec cuspec + emitBranchOnCase ilg sense access cuspec layout cidx tg + +let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionSpec) = + match access with + | DataAccess.ViaHelpers + | DataAccess.ViaListHelpers -> + ldOpt |> Option.iter cg.EmitInstr + cg.EmitInstr(mkGetTagFromHelpers ilg cuspec) + | DataAccess.RawFields -> + + let layout = classifyFromSpec cuspec + let alts = cuspec.AlternativesArray + + match layout with + | DiscriminateByTailNull _ -> + // leaves 1 if cons, 0 if not + ldOpt |> Option.iter cg.EmitInstr + cg.EmitInstrs [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] + | DiscriminateByTagField baseTy -> + ldOpt |> Option.iter cg.EmitInstr + cg.EmitInstr(mkGetTagFromField ilg cuspec baseTy) + | NoDiscrimination _ -> + ldOpt |> Option.iter cg.EmitInstr + cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] + | DiscriminateByRuntimeType(baseTy, nullAsTrueValueIdx) -> + // RuntimeTypes: emit multi-way isinst chain + let ld = + match ldOpt with + | None -> + let locn = cg.GenLocal baseTy + cg.EmitInstr(mkStloc locn) + mkLdloc locn + | Some i -> i + + let outlab = cg.GenerateDelayMark() + + let emitCase cidx = + let alt = altOfUnionSpec cuspec cidx + let internalLab = cg.GenerateDelayMark() + let failLab = cg.GenerateDelayMark() + let cmpNull = (nullAsTrueValueIdx = Some cidx) + + let test = + I_brcmp((if cmpNull then BI_brtrue else BI_brfalse), cg.CodeLabel failLab) + + let testBlock = + if cmpNull || caseFieldsOnRoot layout alt cuspec.AlternativesArray then + [ test ] + else + let altName = alt.Name + let altTy = tyForAltIdxWith layout baseTy cuspec alt cidx + mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy test + + cg.EmitInstrs(ld :: testBlock) + cg.SetMarkToHere internalLab + cg.EmitInstrs [ mkLdcInt32 cidx; I_br(cg.CodeLabel outlab) ] + cg.SetMarkToHere failLab + + // Emit type tests in reverse order; case 0 is the fallback (loaded after the loop). + for n in alts.Length - 1 .. -1 .. 1 do + emitCase n + + // Make the block for the last test. + cg.EmitInstr(mkLdcInt32 0) + cg.SetMarkToHere outlab + +let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionSpec) = + emitLdDataTagPrim ilg None cg (access, cuspec) + +let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layout: UnionLayout) cidx = + let baseTy = baseTyOfUnionSpec cuspec + let ci = resolveCaseWith layout baseTy cuspec cidx + let storage = classifyCaseStorage layout cuspec cidx ci.Case + + match storage with + | CaseStorage.Null -> + // Null-represented case + if canfail then + let outlab = cg.GenerateDelayMark() + let internal1 = cg.GenerateDelayMark() + cg.EmitInstrs [ AI_dup; I_brcmp(BI_brfalse, cg.CodeLabel outlab) ] + cg.SetMarkToHere internal1 + cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] + cg.SetMarkToHere outlab + | CaseStorage.OnRoot -> + // Fields on root: tag check if canfail for structs, else leave on stack + match layout with + | ValueTypeLayout when canfail -> + let outlab = cg.GenerateDelayMark() + let internal1 = cg.GenerateDelayMark() + cg.EmitInstr AI_dup + emitLdDataTagPrim ilg None cg (access, cuspec) + cg.EmitInstrs [ mkLdcInt32 cidx; I_brcmp(BI_beq, cg.CodeLabel outlab) ] + cg.SetMarkToHere internal1 + cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] + cg.SetMarkToHere outlab + | _ -> () + | CaseStorage.Singleton -> + // Nullary case with singleton field on root class, no cast needed + () + | CaseStorage.InNestedType altTy -> + // Case lives in a nested subtype: emit castclass + cg.EmitInstr(I_castclass altTy) + +let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, access, cuspec, cidx) = + let layout = classifyFromSpec cuspec + emitCastToCase ilg cg canfail access cuspec layout cidx + +let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: UnionLayout) cases = + match layout with + | DiscriminateByRuntimeType(baseTy, nullAsTrueValueIdx) -> + let locn = cg.GenLocal baseTy + + cg.EmitInstr(mkStloc locn) + + for cidx, tg in cases do + let alt = altOfUnionSpec cuspec cidx + let altTy = tyForAltIdxWith layout baseTy cuspec alt cidx + let altName = alt.Name + let failLab = cg.GenerateDelayMark() + let cmpNull = (nullAsTrueValueIdx = Some cidx) + + cg.EmitInstr(mkLdloc locn) + let testInstr = I_brcmp((if cmpNull then BI_brfalse else BI_brtrue), tg) + + if cmpNull || caseFieldsOnRoot layout alt cuspec.AlternativesArray then + cg.EmitInstr testInstr + else + cg.EmitInstrs(mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy testInstr) + + cg.SetMarkToHere failLab + + | DiscriminateByTagField _ -> + match cases with + | [] -> cg.EmitInstr AI_pop + | _ -> + let dict = Dictionary() + + for i, case in cases do + dict[i] <- case + + let failLab = cg.GenerateDelayMark() + + let emitCase i _ = + match dict.TryGetValue i with + | true, res -> res + | _ -> cg.CodeLabel failLab + + let dests = Array.mapi emitCase cuspec.AlternativesArray + cg.EmitInstr(mkGetTag ilg cuspec) + cg.EmitInstr(I_switch(Array.toList dests)) + cg.SetMarkToHere failLab + + | NoDiscrimination _ -> + match cases with + | [ (0, tg) ] -> cg.EmitInstrs [ AI_pop; I_br tg ] + | [] -> cg.EmitInstr AI_pop + | _ -> failwith "unexpected: strange switch on single-case unions should not be present" + + | DiscriminateByTailNull _ -> failwith "unexpected: switches on lists should have been eliminated to brisdata tests" + +let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (access, cuspec, cases) = + let layout = classifyFromSpec cuspec + emitCaseSwitch ilg cg access cuspec layout cases + diff --git a/src/Compiler/CodeGen/EraseUnions.Types.fs b/src/Compiler/CodeGen/EraseUnions.Types.fs new file mode 100644 index 00000000000..8a9452727b0 --- /dev/null +++ b/src/Compiler/CodeGen/EraseUnions.Types.fs @@ -0,0 +1,421 @@ +// Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. + +/// Erase discriminated unions - types, classification, and active patterns. +[] +module internal FSharp.Compiler.AbstractIL.ILX.EraseUnionsTypes + +open FSharp.Compiler.IlxGenSupport + +open System.Collections.Generic +open System.Reflection +open Internal.Utilities.Library +open FSharp.Compiler.TypedTree +open FSharp.Compiler.TypedTreeOps +open FSharp.Compiler.TcGlobals +open FSharp.Compiler.AbstractIL.IL +open FSharp.Compiler.AbstractIL.ILX.Types + +// ============================================================================ +// Architecture: Two-axis classification model +// +// Every decision in this module is driven by two independent classifications: +// +// 1. UnionLayout (8 cases) — how the union TYPE is structured in IL +// Computed once per union via classifyFromSpec / classifyFromDef. +// +// 2. CaseStorage (5 cases) — how each individual CASE is stored +// Computed per case via classifyCaseStorage. Answers: is this case null? +// A singleton field? Fields on root? In a nested subtype? Struct tag-only? +// +// Orthogonal concerns read from these: +// - DataAccess (3 cases) — how callers access data (raw fields vs helpers) +// - DiscriminationMethod (AP) — how to distinguish cases (tag/isinst/tail-null) +// +// The emit functions match on CaseStorage first (WHERE is it?), then on +// DiscriminationMethod (HOW to tell it apart?). This two-axis pattern +// ensures each function reads as a simple decision table, not a re-derivation. +// ============================================================================ + +/// How to access union data at a given call site. +/// Combines the per-call-site 'avoidHelpers' flag with the per-union 'HasHelpers' setting +/// into a single value computed once at the entry point. +[] +type DataAccess = + /// Use raw field loads/stores (intra-assembly access, or union has no helpers) + | RawFields + /// Use helper methods (get_Tag, get_IsXxx, NewXxx) — inter-assembly with AllHelpers or SpecialFSharpOptionHelpers + | ViaHelpers + /// Use list-specific helper methods (HeadOrDefault, TailOrNull naming) — inter-assembly with SpecialFSharpListHelpers + | ViaListHelpers + +/// Compute the access strategy from the per-call-site flag and per-union helpers setting. +let computeDataAccess (avoidHelpers: bool) (cuspec: IlxUnionSpec) = + if avoidHelpers then + DataAccess.RawFields + else + match cuspec.HasHelpers with + | IlxUnionHasHelpers.NoHelpers -> DataAccess.RawFields + | IlxUnionHasHelpers.AllHelpers + | IlxUnionHasHelpers.SpecialFSharpOptionHelpers -> DataAccess.ViaHelpers + | IlxUnionHasHelpers.SpecialFSharpListHelpers -> DataAccess.ViaListHelpers + +[] +let TagNil = 0 + +[] +let TagCons = 1 + +[] +let ALT_NAME_CONS = "Cons" + +[] +type UnionLayout = + /// F# list<'a> only. Discrimination via tail field == null. + | FSharpList of baseTy: ILType + /// Single case, reference type. No discrimination needed. + | SingleCaseRef of baseTy: ILType + /// Single case, struct. No discrimination needed. + | SingleCaseStruct of baseTy: ILType + /// 2-3 cases, reference, not all-nullary, no null-as-true-value. Discrimination via isinst. + | SmallRef of baseTy: ILType + /// 2-3 cases, reference, not all-nullary, one case represented as null. Discrimination via isinst. + | SmallRefWithNullAsTrueValue of baseTy: ILType * nullAsTrueValueIdx: int + /// ≥4 cases (or 2-3 all-nullary), reference, not all nullary. Discrimination via integer _tag field. + | TaggedRef of baseTy: ILType + /// ≥4 cases (or 2-3 all-nullary), reference, all nullary. Discrimination via integer _tag field. + | TaggedRefAllNullary of baseTy: ILType + /// Struct DU with >1 case, not all nullary. Discrimination via integer _tag field. + | TaggedStruct of baseTy: ILType + /// Struct DU with >1 case, all nullary. Discrimination via integer _tag field. + | TaggedStructAllNullary of baseTy: ILType + +let baseTyOfUnionSpec (cuspec: IlxUnionSpec) = + mkILNamedTy cuspec.Boxity cuspec.TypeRef cuspec.GenericArgs + +let mkMakerName (cuspec: IlxUnionSpec) nm = + match cuspec.HasHelpers with + | SpecialFSharpListHelpers + | SpecialFSharpOptionHelpers -> nm // Leave 'Some', 'None', 'Cons', 'Empty' as is + | AllHelpers + | NoHelpers -> "New" + nm + +let mkCasesTypeRef (cuspec: IlxUnionSpec) = cuspec.TypeRef + +/// Core classification logic. Computes the UnionLayout for any union. +let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isStruct = + let allNullary = alts |> Array.forall (fun alt -> alt.IsNullary) + + match isList, alts.Length, isStruct with + | true, _, _ -> UnionLayout.FSharpList baseTy + | _, 1, true -> UnionLayout.SingleCaseStruct baseTy + | _, 1, false -> UnionLayout.SingleCaseRef baseTy + | _, n, false when n < 4 && not allNullary -> + // Small ref union (2-3 cases, not all nullary): discriminate by isinst + let nullAsTrueValueIdx = + if + nullPermitted + && alts |> Array.existsOne (fun alt -> alt.IsNullary) + && alts |> Array.exists (fun alt -> not alt.IsNullary) + then + alts |> Array.tryFindIndex (fun alt -> alt.IsNullary) + else + None + + match nullAsTrueValueIdx with + | Some idx -> UnionLayout.SmallRefWithNullAsTrueValue(baseTy, idx) + | None -> UnionLayout.SmallRef baseTy + | _ -> + match isStruct, allNullary with + | true, true -> UnionLayout.TaggedStructAllNullary baseTy + | true, false -> UnionLayout.TaggedStruct baseTy + | false, true -> UnionLayout.TaggedRefAllNullary baseTy + | false, false -> UnionLayout.TaggedRef baseTy + +/// Classify from an IlxUnionSpec (used in IL instruction generation). +let classifyFromSpec (cuspec: IlxUnionSpec) = + let baseTy = baseTyOfUnionSpec cuspec + let alts = cuspec.AlternativesArray + let nullPermitted = cuspec.IsNullPermitted + let isList = (cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) + let isStruct = (cuspec.Boxity = ILBoxity.AsValue) + classifyUnion baseTy alts nullPermitted isList isStruct + +/// Classify from an ILTypeDef + IlxUnionInfo (used in type definition generation). +let classifyFromDef (td: ILTypeDef) (cud: IlxUnionInfo) (baseTy: ILType) = + let alts = cud.UnionCases + let nullPermitted = cud.IsNullPermitted + let isList = (cud.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) + let isStruct = td.IsStruct + classifyUnion baseTy alts nullPermitted isList isStruct + +// ---- Exhaustive Active Patterns for UnionLayout ---- + +/// How to discriminate between cases at runtime. +let (|DiscriminateByTagField|DiscriminateByRuntimeType|DiscriminateByTailNull|NoDiscrimination|) layout = + match layout with + | UnionLayout.TaggedRef baseTy + | UnionLayout.TaggedRefAllNullary baseTy + | UnionLayout.TaggedStruct baseTy + | UnionLayout.TaggedStructAllNullary baseTy -> DiscriminateByTagField baseTy + | UnionLayout.SmallRef baseTy -> DiscriminateByRuntimeType(baseTy, None) + | UnionLayout.SmallRefWithNullAsTrueValue(baseTy, nullIdx) -> DiscriminateByRuntimeType(baseTy, Some nullIdx) + | UnionLayout.FSharpList baseTy -> DiscriminateByTailNull baseTy + | UnionLayout.SingleCaseRef baseTy -> NoDiscrimination baseTy + | UnionLayout.SingleCaseStruct baseTy -> NoDiscrimination baseTy + +/// Does the root type have a _tag integer field? +let (|HasTagField|NoTagField|) layout = + match layout with + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> HasTagField + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ + | UnionLayout.FSharpList _ + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ -> NoTagField + +/// Is a specific case (by index) represented as null? +let inline (|CaseIsNull|CaseIsAllocated|) (layout, cidx) = + match layout with + | UnionLayout.SmallRefWithNullAsTrueValue(_, nullIdx) when nullIdx = cidx -> CaseIsNull + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ + | UnionLayout.FSharpList _ + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> CaseIsAllocated + +/// Is this a value type (struct) or reference type layout? +let (|ValueTypeLayout|ReferenceTypeLayout|) layout = + match layout with + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> ValueTypeLayout + | UnionLayout.SingleCaseRef _ + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.FSharpList _ -> ReferenceTypeLayout + +// ---- Layout-Based Helpers ---- +// These replace the old representation decision methods. + +/// Does this non-nullary alternative fold to root class via fresh instances? +/// Equivalent to the old RepresentAlternativeAsFreshInstancesOfRootClass. +let caseFieldsOnRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) = + not alt.IsNullary + && (match layout with + | UnionLayout.FSharpList _ -> alt.Name = ALT_NAME_CONS + | UnionLayout.SingleCaseRef _ -> true + | UnionLayout.SmallRefWithNullAsTrueValue _ -> alts |> Array.existsOne (fun a -> not a.IsNullary) + | UnionLayout.SmallRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedRef _ + | UnionLayout.TaggedRefAllNullary _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> false) + +/// Does this alternative optimize to root class (no nested type needed)? +/// Equivalent to the old OptimizeAlternativeToRootClass. +let caseRepresentedOnRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) (cidx: int) = + match layout with + | UnionLayout.FSharpList _ + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.TaggedStruct _ + | UnionLayout.TaggedStructAllNullary _ -> true + | UnionLayout.TaggedRefAllNullary _ -> true + | UnionLayout.TaggedRef _ -> alt.IsNullary + | UnionLayout.SmallRef _ + | UnionLayout.SmallRefWithNullAsTrueValue _ -> + (match layout, cidx with + | CaseIsNull -> true + | CaseIsAllocated -> false) + || caseFieldsOnRoot layout alt alts + +/// Should a static constant field be maintained for this nullary alternative? +/// Equivalent to the old MaintainPossiblyUniqueConstantFieldForAlternative. +/// Only for nullary cases on reference types that are not null-represented. +let needsSingletonField (layout: UnionLayout) (alt: IlxUnionCase) (cidx: int) = + alt.IsNullary + && match layout, cidx with + | CaseIsNull -> false + | _ -> + match layout with + | ReferenceTypeLayout -> true + | ValueTypeLayout -> false + +let tyForAltIdxWith (layout: UnionLayout) (baseTy: ILType) (cuspec: IlxUnionSpec) (alt: IlxUnionCase) cidx = + if caseRepresentedOnRoot layout alt cuspec.AlternativesArray cidx then + baseTy + else + let isList = (cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) + let altName = alt.Name + let nm = if alt.IsNullary || isList then "_" + altName else altName + mkILNamedTy cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs + +let tyForAltIdx cuspec (alt: IlxUnionCase) cidx = + tyForAltIdxWith (classifyFromSpec cuspec) (baseTyOfUnionSpec cuspec) cuspec alt cidx + +/// How a specific union case is physically stored. +[] +type CaseStorage = + /// Represented as null reference (UseNullAsTrueValue) + | Null + /// Singleton static field on root class (nullary, reference type) + | Singleton + /// Fields stored directly on root class (single-case, list cons, struct, folded SmallRef) + | OnRoot + /// Fields stored in a nested subtype + | InNestedType of nestedType: ILType + +let classifyCaseStorage (layout: UnionLayout) (cuspec: IlxUnionSpec) (cidx: int) (alt: IlxUnionCase) = + match layout, cidx with + | CaseIsNull -> CaseStorage.Null + | _ -> + if caseRepresentedOnRoot layout alt cuspec.AlternativesArray cidx then + if alt.IsNullary then + match layout with + | ValueTypeLayout -> CaseStorage.OnRoot + | ReferenceTypeLayout -> CaseStorage.Singleton + else + CaseStorage.OnRoot + elif needsSingletonField layout alt cidx then + CaseStorage.Singleton + else + CaseStorage.InNestedType(tyForAltIdxWith layout (baseTyOfUnionSpec cuspec) cuspec alt cidx) + +// ---- Context Records ---- + +/// Bundles the IL attribute-stamping callbacks used during type definition generation. +type ILStamping = + { + stampMethodAsGenerated: ILMethodDef -> ILMethodDef + stampPropertyAsGenerated: ILPropertyDef -> ILPropertyDef + stampPropertyAsNever: ILPropertyDef -> ILPropertyDef + stampFieldAsGenerated: ILFieldDef -> ILFieldDef + stampFieldAsNever: ILFieldDef -> ILFieldDef + mkDebuggerTypeProxyAttr: ILType -> ILAttribute + } + +/// Bundles the parameters threaded through type definition generation. +/// Replaces the 6-callback tuple + scattered parameter threading in convAlternativeDef/mkClassUnionDef. +type TypeDefContext = + { + g: TcGlobals + layout: UnionLayout + cuspec: IlxUnionSpec + cud: IlxUnionInfo + td: ILTypeDef + baseTy: ILType + stamping: ILStamping + } + +/// Information about a nullary case's singleton static field. +type NullaryConstFieldInfo = + { + Case: IlxUnionCase + CaseType: ILType + CaseIndex: int + Field: ILFieldDef + InRootClass: bool + } + +/// Result of processing a single union alternative for type definition generation. +/// Replaces the 6-element tuple return from convAlternativeDef. +type AlternativeDefResult = + { + BaseMakerMethods: ILMethodDef list + BaseMakerProperties: ILPropertyDef list + ConstantAccessors: ILMethodDef list + NestedTypeDefs: ILTypeDef list + DebugProxyTypeDefs: ILTypeDef list + NullaryConstFields: NullaryConstFieldInfo list + } + +let mkTesterName nm = "Is" + nm + +let tagPropertyName = "Tag" + +let mkUnionCaseFieldId (fdef: IlxUnionCaseField) = + // Use the lower case name of a field or constructor as the field/parameter name if it differs from the uppercase name + fdef.LowerName, fdef.Type + +/// Is nullness checking enabled in the compiler settings? +let inline nullnessCheckingEnabled (g: TcGlobals) = + g.checkNullness && g.langFeatureNullness + +let inline getFieldsNullability (g: TcGlobals) (ilf: ILFieldDef) = + if g.checkNullness then + ilf.CustomAttrs.AsArray() + |> Array.tryFind (IsILAttrib g.attrib_NullableAttribute) + else + None + +let mkUnionCaseFieldIdAndAttrs g fdef = + let nm, t = mkUnionCaseFieldId fdef + let attrs = getFieldsNullability g fdef.ILField + nm, t, attrs |> Option.toList + +let refToFieldInTy ty (nm, fldTy) = mkILFieldSpecInTy (ty, nm, fldTy) + +let formalTypeArgs (baseTy: ILType) = + List.mapi (fun i _ -> mkILTyvarTy (uint16 i)) baseTy.GenericArgs + +let constFieldName nm = "_unique_" + nm + +let constFormalFieldTy (baseTy: ILType) = + mkILNamedTy baseTy.Boxity baseTy.TypeRef (formalTypeArgs baseTy) + +let mkConstFieldSpecFromId (baseTy: ILType) constFieldId = refToFieldInTy baseTy constFieldId + +let mkConstFieldSpec nm (baseTy: ILType) = + mkConstFieldSpecFromId baseTy (constFieldName nm, constFormalFieldTy baseTy) + +let tyForAlt (cuspec: IlxUnionSpec) (alt: IlxUnionCase) = + let cidx = + cuspec.AlternativesArray + |> Array.findIndex (fun (a: IlxUnionCase) -> a.Name = alt.Name) + + tyForAltIdx cuspec alt cidx + +let GetILTypeForAlternative cuspec alt = + tyForAlt cuspec (cuspec.Alternative alt) + +let mkTagFieldType (ilg: ILGlobals) _cuspec = ilg.typ_Int32 + +let mkTagFieldId ilg cuspec = "_tag", mkTagFieldType ilg cuspec + +let altOfUnionSpec (cuspec: IlxUnionSpec) cidx = + try + cuspec.Alternative cidx + with _ -> + failwith ("alternative " + string cidx + " not found") + +/// Resolved identity of a union case within a union spec. +[] +type CaseIdentity = + { + Index: int + Case: IlxUnionCase + CaseType: ILType + CaseName: string + } + +/// Resolve a case by index using precomputed layout and base type. +let resolveCaseWith (layout: UnionLayout) (baseTy: ILType) (cuspec: IlxUnionSpec) (cidx: int) = + let alt = altOfUnionSpec cuspec cidx + + { + Index = cidx + Case = alt + CaseType = tyForAltIdxWith layout baseTy cuspec alt cidx + CaseName = alt.Name + } + diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 7389daa12e6..1e08caab041 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -1,6 +1,6 @@ // Copyright (c) Microsoft Corporation. All Rights Reserved. See License.txt in the project root for license information. -/// Erase discriminated unions. +/// Erase discriminated unions - type definition generation. module internal FSharp.Compiler.AbstractIL.ILX.EraseUnions open FSharp.Compiler.IlxGenSupport @@ -14,835 +14,6 @@ open FSharp.Compiler.TcGlobals open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types -// ============================================================================ -// Architecture: Two-axis classification model -// -// Every decision in this module is driven by two independent classifications: -// -// 1. UnionLayout (8 cases) — how the union TYPE is structured in IL -// Computed once per union via classifyFromSpec / classifyFromDef. -// -// 2. CaseStorage (5 cases) — how each individual CASE is stored -// Computed per case via classifyCaseStorage. Answers: is this case null? -// A singleton field? Fields on root? In a nested subtype? Struct tag-only? -// -// Orthogonal concerns read from these: -// - DataAccess (3 cases) — how callers access data (raw fields vs helpers) -// - DiscriminationMethod (AP) — how to distinguish cases (tag/isinst/tail-null) -// -// The emit functions match on CaseStorage first (WHERE is it?), then on -// DiscriminationMethod (HOW to tell it apart?). This two-axis pattern -// ensures each function reads as a simple decision table, not a re-derivation. -// ============================================================================ - -/// How to access union data at a given call site. -/// Combines the per-call-site 'avoidHelpers' flag with the per-union 'HasHelpers' setting -/// into a single value computed once at the entry point. -[] -type DataAccess = - /// Use raw field loads/stores (intra-assembly access, or union has no helpers) - | RawFields - /// Use helper methods (get_Tag, get_IsXxx, NewXxx) — inter-assembly with AllHelpers or SpecialFSharpOptionHelpers - | ViaHelpers - /// Use list-specific helper methods (HeadOrDefault, TailOrNull naming) — inter-assembly with SpecialFSharpListHelpers - | ViaListHelpers - -/// Compute the access strategy from the per-call-site flag and per-union helpers setting. -let computeDataAccess (avoidHelpers: bool) (cuspec: IlxUnionSpec) = - if avoidHelpers then - DataAccess.RawFields - else - match cuspec.HasHelpers with - | IlxUnionHasHelpers.NoHelpers -> DataAccess.RawFields - | IlxUnionHasHelpers.AllHelpers - | IlxUnionHasHelpers.SpecialFSharpOptionHelpers -> DataAccess.ViaHelpers - | IlxUnionHasHelpers.SpecialFSharpListHelpers -> DataAccess.ViaListHelpers - -[] -let TagNil = 0 - -[] -let TagCons = 1 - -[] -let ALT_NAME_CONS = "Cons" - -[] -type UnionLayout = - /// F# list<'a> only. Discrimination via tail field == null. - | FSharpList of baseTy: ILType - /// Single case, reference type. No discrimination needed. - | SingleCaseRef of baseTy: ILType - /// Single case, struct. No discrimination needed. - | SingleCaseStruct of baseTy: ILType - /// 2-3 cases, reference, not all-nullary, no null-as-true-value. Discrimination via isinst. - | SmallRef of baseTy: ILType - /// 2-3 cases, reference, not all-nullary, one case represented as null. Discrimination via isinst. - | SmallRefWithNullAsTrueValue of baseTy: ILType * nullAsTrueValueIdx: int - /// ≥4 cases (or 2-3 all-nullary), reference, not all nullary. Discrimination via integer _tag field. - | TaggedRef of baseTy: ILType - /// ≥4 cases (or 2-3 all-nullary), reference, all nullary. Discrimination via integer _tag field. - | TaggedRefAllNullary of baseTy: ILType - /// Struct DU with >1 case, not all nullary. Discrimination via integer _tag field. - | TaggedStruct of baseTy: ILType - /// Struct DU with >1 case, all nullary. Discrimination via integer _tag field. - | TaggedStructAllNullary of baseTy: ILType - -let baseTyOfUnionSpec (cuspec: IlxUnionSpec) = - mkILNamedTy cuspec.Boxity cuspec.TypeRef cuspec.GenericArgs - -let mkMakerName (cuspec: IlxUnionSpec) nm = - match cuspec.HasHelpers with - | SpecialFSharpListHelpers - | SpecialFSharpOptionHelpers -> nm // Leave 'Some', 'None', 'Cons', 'Empty' as is - | AllHelpers - | NoHelpers -> "New" + nm - -let mkCasesTypeRef (cuspec: IlxUnionSpec) = cuspec.TypeRef - -/// Core classification logic. Computes the UnionLayout for any union. -let private classifyUnion baseTy (alts: IlxUnionCase[]) nullPermitted isList isStruct = - let allNullary = alts |> Array.forall (fun alt -> alt.IsNullary) - - match isList, alts.Length, isStruct with - | true, _, _ -> UnionLayout.FSharpList baseTy - | _, 1, true -> UnionLayout.SingleCaseStruct baseTy - | _, 1, false -> UnionLayout.SingleCaseRef baseTy - | _, n, false when n < 4 && not allNullary -> - // Small ref union (2-3 cases, not all nullary): discriminate by isinst - let nullAsTrueValueIdx = - if - nullPermitted - && alts |> Array.existsOne (fun alt -> alt.IsNullary) - && alts |> Array.exists (fun alt -> not alt.IsNullary) - then - alts |> Array.tryFindIndex (fun alt -> alt.IsNullary) - else - None - - match nullAsTrueValueIdx with - | Some idx -> UnionLayout.SmallRefWithNullAsTrueValue(baseTy, idx) - | None -> UnionLayout.SmallRef baseTy - | _ -> - match isStruct, allNullary with - | true, true -> UnionLayout.TaggedStructAllNullary baseTy - | true, false -> UnionLayout.TaggedStruct baseTy - | false, true -> UnionLayout.TaggedRefAllNullary baseTy - | false, false -> UnionLayout.TaggedRef baseTy - -/// Classify from an IlxUnionSpec (used in IL instruction generation). -let classifyFromSpec (cuspec: IlxUnionSpec) = - let baseTy = baseTyOfUnionSpec cuspec - let alts = cuspec.AlternativesArray - let nullPermitted = cuspec.IsNullPermitted - let isList = (cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) - let isStruct = (cuspec.Boxity = ILBoxity.AsValue) - classifyUnion baseTy alts nullPermitted isList isStruct - -/// Classify from an ILTypeDef + IlxUnionInfo (used in type definition generation). -let classifyFromDef (td: ILTypeDef) (cud: IlxUnionInfo) (baseTy: ILType) = - let alts = cud.UnionCases - let nullPermitted = cud.IsNullPermitted - let isList = (cud.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) - let isStruct = td.IsStruct - classifyUnion baseTy alts nullPermitted isList isStruct - -// ---- Exhaustive Active Patterns for UnionLayout ---- - -/// How to discriminate between cases at runtime. -let (|DiscriminateByTagField|DiscriminateByRuntimeType|DiscriminateByTailNull|NoDiscrimination|) layout = - match layout with - | UnionLayout.TaggedRef baseTy - | UnionLayout.TaggedRefAllNullary baseTy - | UnionLayout.TaggedStruct baseTy - | UnionLayout.TaggedStructAllNullary baseTy -> DiscriminateByTagField baseTy - | UnionLayout.SmallRef baseTy -> DiscriminateByRuntimeType(baseTy, None) - | UnionLayout.SmallRefWithNullAsTrueValue(baseTy, nullIdx) -> DiscriminateByRuntimeType(baseTy, Some nullIdx) - | UnionLayout.FSharpList baseTy -> DiscriminateByTailNull baseTy - | UnionLayout.SingleCaseRef baseTy -> NoDiscrimination baseTy - | UnionLayout.SingleCaseStruct baseTy -> NoDiscrimination baseTy - -/// Does the root type have a _tag integer field? -let (|HasTagField|NoTagField|) layout = - match layout with - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> HasTagField - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ - | UnionLayout.FSharpList _ - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ -> NoTagField - -/// Is a specific case (by index) represented as null? -let inline (|CaseIsNull|CaseIsAllocated|) (layout, cidx) = - match layout with - | UnionLayout.SmallRefWithNullAsTrueValue(_, nullIdx) when nullIdx = cidx -> CaseIsNull - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ - | UnionLayout.FSharpList _ - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> CaseIsAllocated - -/// Is this a value type (struct) or reference type layout? -let (|ValueTypeLayout|ReferenceTypeLayout|) layout = - match layout with - | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> ValueTypeLayout - | UnionLayout.SingleCaseRef _ - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.FSharpList _ -> ReferenceTypeLayout - -// ---- Layout-Based Helpers ---- -// These replace the old representation decision methods. - -/// Does this non-nullary alternative fold to root class via fresh instances? -/// Equivalent to the old RepresentAlternativeAsFreshInstancesOfRootClass. -let private caseFieldsOnRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) = - not alt.IsNullary - && (match layout with - | UnionLayout.FSharpList _ -> alt.Name = ALT_NAME_CONS - | UnionLayout.SingleCaseRef _ -> true - | UnionLayout.SmallRefWithNullAsTrueValue _ -> alts |> Array.existsOne (fun a -> not a.IsNullary) - | UnionLayout.SmallRef _ - | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedRef _ - | UnionLayout.TaggedRefAllNullary _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> false) - -/// Does this alternative optimize to root class (no nested type needed)? -/// Equivalent to the old OptimizeAlternativeToRootClass. -let private caseRepresentedOnRoot (layout: UnionLayout) (alt: IlxUnionCase) (alts: IlxUnionCase[]) (cidx: int) = - match layout with - | UnionLayout.FSharpList _ - | UnionLayout.SingleCaseRef _ - | UnionLayout.SingleCaseStruct _ - | UnionLayout.TaggedStruct _ - | UnionLayout.TaggedStructAllNullary _ -> true - | UnionLayout.TaggedRefAllNullary _ -> true - | UnionLayout.TaggedRef _ -> alt.IsNullary - | UnionLayout.SmallRef _ - | UnionLayout.SmallRefWithNullAsTrueValue _ -> - (match layout, cidx with - | CaseIsNull -> true - | CaseIsAllocated -> false) - || caseFieldsOnRoot layout alt alts - -/// Should a static constant field be maintained for this nullary alternative? -/// Equivalent to the old MaintainPossiblyUniqueConstantFieldForAlternative. -/// Only for nullary cases on reference types that are not null-represented. -let private needsSingletonField (layout: UnionLayout) (alt: IlxUnionCase) (cidx: int) = - alt.IsNullary - && match layout, cidx with - | CaseIsNull -> false - | _ -> - match layout with - | ReferenceTypeLayout -> true - | ValueTypeLayout -> false - -let private tyForAltIdxWith (layout: UnionLayout) (baseTy: ILType) (cuspec: IlxUnionSpec) (alt: IlxUnionCase) cidx = - if caseRepresentedOnRoot layout alt cuspec.AlternativesArray cidx then - baseTy - else - let isList = (cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers) - let altName = alt.Name - let nm = if alt.IsNullary || isList then "_" + altName else altName - mkILNamedTy cuspec.Boxity (mkILTyRefInTyRef (mkCasesTypeRef cuspec, nm)) cuspec.GenericArgs - -let private tyForAltIdx cuspec (alt: IlxUnionCase) cidx = - tyForAltIdxWith (classifyFromSpec cuspec) (baseTyOfUnionSpec cuspec) cuspec alt cidx - -/// How a specific union case is physically stored. -[] -type CaseStorage = - /// Represented as null reference (UseNullAsTrueValue) - | Null - /// Singleton static field on root class (nullary, reference type) - | Singleton - /// Fields stored directly on root class (single-case, list cons, struct, folded SmallRef) - | OnRoot - /// Fields stored in a nested subtype - | InNestedType of nestedType: ILType - -let classifyCaseStorage (layout: UnionLayout) (cuspec: IlxUnionSpec) (cidx: int) (alt: IlxUnionCase) = - match layout, cidx with - | CaseIsNull -> CaseStorage.Null - | _ -> - if caseRepresentedOnRoot layout alt cuspec.AlternativesArray cidx then - if alt.IsNullary then - match layout with - | ValueTypeLayout -> CaseStorage.OnRoot - | ReferenceTypeLayout -> CaseStorage.Singleton - else - CaseStorage.OnRoot - elif needsSingletonField layout alt cidx then - CaseStorage.Singleton - else - CaseStorage.InNestedType(tyForAltIdxWith layout (baseTyOfUnionSpec cuspec) cuspec alt cidx) - -// ---- Context Records ---- - -/// Bundles the IL attribute-stamping callbacks used during type definition generation. -type ILStamping = - { - stampMethodAsGenerated: ILMethodDef -> ILMethodDef - stampPropertyAsGenerated: ILPropertyDef -> ILPropertyDef - stampPropertyAsNever: ILPropertyDef -> ILPropertyDef - stampFieldAsGenerated: ILFieldDef -> ILFieldDef - stampFieldAsNever: ILFieldDef -> ILFieldDef - mkDebuggerTypeProxyAttr: ILType -> ILAttribute - } - -/// Bundles the parameters threaded through type definition generation. -/// Replaces the 6-callback tuple + scattered parameter threading in convAlternativeDef/mkClassUnionDef. -type TypeDefContext = - { - g: TcGlobals - layout: UnionLayout - cuspec: IlxUnionSpec - cud: IlxUnionInfo - td: ILTypeDef - baseTy: ILType - stamping: ILStamping - } - -/// Information about a nullary case's singleton static field. -type NullaryConstFieldInfo = - { - Case: IlxUnionCase - CaseType: ILType - CaseIndex: int - Field: ILFieldDef - InRootClass: bool - } - -/// Result of processing a single union alternative for type definition generation. -/// Replaces the 6-element tuple return from convAlternativeDef. -type AlternativeDefResult = - { - BaseMakerMethods: ILMethodDef list - BaseMakerProperties: ILPropertyDef list - ConstantAccessors: ILMethodDef list - NestedTypeDefs: ILTypeDef list - DebugProxyTypeDefs: ILTypeDef list - NullaryConstFields: NullaryConstFieldInfo list - } - -let mkTesterName nm = "Is" + nm - -let tagPropertyName = "Tag" - -let mkUnionCaseFieldId (fdef: IlxUnionCaseField) = - // Use the lower case name of a field or constructor as the field/parameter name if it differs from the uppercase name - fdef.LowerName, fdef.Type - -/// Is nullness checking enabled in the compiler settings? -let inline nullnessCheckingEnabled (g: TcGlobals) = - g.checkNullness && g.langFeatureNullness - -let inline getFieldsNullability (g: TcGlobals) (ilf: ILFieldDef) = - if g.checkNullness then - ilf.CustomAttrs.AsArray() - |> Array.tryFind (IsILAttrib g.attrib_NullableAttribute) - else - None - -let mkUnionCaseFieldIdAndAttrs g fdef = - let nm, t = mkUnionCaseFieldId fdef - let attrs = getFieldsNullability g fdef.ILField - nm, t, attrs |> Option.toList - -let refToFieldInTy ty (nm, fldTy) = mkILFieldSpecInTy (ty, nm, fldTy) - -let formalTypeArgs (baseTy: ILType) = - List.mapi (fun i _ -> mkILTyvarTy (uint16 i)) baseTy.GenericArgs - -let constFieldName nm = "_unique_" + nm - -let constFormalFieldTy (baseTy: ILType) = - mkILNamedTy baseTy.Boxity baseTy.TypeRef (formalTypeArgs baseTy) - -let mkConstFieldSpecFromId (baseTy: ILType) constFieldId = refToFieldInTy baseTy constFieldId - -let mkConstFieldSpec nm (baseTy: ILType) = - mkConstFieldSpecFromId baseTy (constFieldName nm, constFormalFieldTy baseTy) - -let tyForAlt (cuspec: IlxUnionSpec) (alt: IlxUnionCase) = - let cidx = - cuspec.AlternativesArray - |> Array.findIndex (fun (a: IlxUnionCase) -> a.Name = alt.Name) - - tyForAltIdx cuspec alt cidx - -let GetILTypeForAlternative cuspec alt = - tyForAlt cuspec (cuspec.Alternative alt) - -let mkTagFieldType (ilg: ILGlobals) _cuspec = ilg.typ_Int32 - -let mkTagFieldId ilg cuspec = "_tag", mkTagFieldType ilg cuspec - -let altOfUnionSpec (cuspec: IlxUnionSpec) cidx = - try - cuspec.Alternative cidx - with _ -> - failwith ("alternative " + string cidx + " not found") - -/// Resolved identity of a union case within a union spec. -[] -type CaseIdentity = - { - Index: int - Case: IlxUnionCase - CaseType: ILType - CaseName: string - } - -/// Resolve a case by index using precomputed layout and base type. -let private resolveCaseWith (layout: UnionLayout) (baseTy: ILType) (cuspec: IlxUnionSpec) (cidx: int) = - let alt = altOfUnionSpec cuspec cidx - - { - Index = cidx - Case = alt - CaseType = tyForAltIdxWith layout baseTy cuspec alt cidx - CaseName = alt.Name - } - -// Nullary cases on types with helpers do not reveal their underlying type even when -// using runtime type discrimination, because the underlying type is never needed from -// C# code and pollutes the visible API surface. In this case we must discriminate by -// calling the IsFoo helper. This only applies when accessing via helpers (inter-assembly). -let mkRuntimeTypeDiscriminate (ilg: ILGlobals) (access: DataAccess) cuspec (alt: IlxUnionCase) altName altTy = - if alt.IsNullary && access = DataAccess.ViaHelpers then - let baseTy = baseTyOfUnionSpec cuspec - - [ - mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + mkTesterName altName, [], ilg.typ_Bool)) - ] - else - [ I_isinst altTy; AI_ldnull; AI_cgt_un ] - -let mkRuntimeTypeDiscriminateThen ilg (access: DataAccess) cuspec (alt: IlxUnionCase) altName altTy after = - let useHelper = alt.IsNullary && access = DataAccess.ViaHelpers - - match after with - | I_brcmp(BI_brfalse, _) - | I_brcmp(BI_brtrue, _) when not useHelper -> [ I_isinst altTy; after ] - | _ -> mkRuntimeTypeDiscriminate ilg access cuspec alt altName altTy @ [ after ] - -let mkGetTagFromField ilg cuspec baseTy = - mkNormalLdfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) - -let mkSetTagToField ilg cuspec baseTy = - mkNormalStfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) - -let adjustFieldNameForTypeDef hasHelpers nm = - match hasHelpers, nm with - | SpecialFSharpListHelpers, "Head" -> "HeadOrDefault" - | SpecialFSharpListHelpers, "Tail" -> "TailOrNull" - | _ -> nm - -let adjustFieldName access nm = - match access, nm with - | DataAccess.ViaListHelpers, "Head" -> "HeadOrDefault" - | DataAccess.ViaListHelpers, "Tail" -> "TailOrNull" - | _ -> nm - -let mkLdData (access, cuspec, cidx, fidx) = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAltIdx cuspec alt cidx - let fieldDef = alt.FieldDef fidx - - match access with - | DataAccess.RawFields -> mkNormalLdfld (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) - | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (altTy, "get_" + adjustFieldName access fieldDef.Name, [], fieldDef.Type)) - -let mkLdDataAddr (access, cuspec, cidx, fidx) = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAltIdx cuspec alt cidx - let fieldDef = alt.FieldDef fidx - - match access with - | DataAccess.RawFields -> mkNormalLdflda (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) - | _ -> failwith (sprintf "can't load address using helpers, for fieldDef %s" fieldDef.LowerName) - -let mkGetTailOrNull access cuspec = - mkLdData (access, cuspec, 1, 1) (* tail is in alternative 1, field number 1 *) - -let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = - let baseTy = baseTyOfUnionSpec cuspec - - match classifyFromSpec cuspec with - | UnionLayout.SmallRefWithNullAsTrueValue _ -> - mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [ baseTy ], mkTagFieldType ilg cuspec)) - | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldType ilg cuspec)) - -let mkGetTag ilg (cuspec: IlxUnionSpec) = - match cuspec.HasHelpers with - | AllHelpers -> mkGetTagFromHelpers ilg cuspec - | _hasHelpers -> mkGetTagFromField ilg cuspec (baseTyOfUnionSpec cuspec) - -let mkCeqThen after = - match after with - | I_brcmp(BI_brfalse, a) -> [ I_brcmp(BI_bne_un, a) ] - | I_brcmp(BI_brtrue, a) -> [ I_brcmp(BI_beq, a) ] - | _ -> [ AI_ceq; after ] - -let mkTagDiscriminate ilg cuspec _baseTy cidx = - [ mkGetTag ilg cuspec; mkLdcInt32 cidx; AI_ceq ] - -let mkTagDiscriminateThen ilg cuspec cidx after = - [ mkGetTag ilg cuspec; mkLdcInt32 cidx ] @ mkCeqThen after - -let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = - let baseTy = baseTyOfUnionSpec cuspec - let ci = resolveCaseWith layout baseTy cuspec cidx - let storage = classifyCaseStorage layout cuspec cidx ci.Case - - match storage with - | CaseStorage.Null -> - // Null-represented case: just load null - [ AI_ldnull ] - | CaseStorage.Singleton -> - // Nullary ref type: load the singleton static field - [ I_ldsfld(Nonvolatile, mkConstFieldSpec ci.CaseName baseTy) ] - | CaseStorage.OnRoot -> - - if ci.Case.IsNullary then - // Struct + nullary: create via root ctor with tag - let tagField = [ mkTagFieldType ilg cuspec ] - [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] - else - // Non-nullary fields on root: create via root ctor with fields - let ctorFieldTys = ci.Case.FieldTypes |> Array.toList - [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, ctorFieldTys)) ] - | CaseStorage.InNestedType _ -> - // Case lives in a nested subtype - [ - mkNormalNewobj (mkILCtorMethSpecForTy (ci.CaseType, Array.toList ci.Case.FieldTypes)) - ] - -let emitRawNewData ilg cuspec cidx = - emitRawConstruction ilg cuspec (classifyFromSpec cuspec) cidx - -// The stdata 'instruction' is only ever used for the F# "List" type within FSharp.Core.dll -let mkStData (cuspec, cidx, fidx) = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAltIdx cuspec alt cidx - let fieldDef = alt.FieldDef fidx - mkNormalStfld (mkILFieldSpecInTy (altTy, fieldDef.LowerName, fieldDef.Type)) - -let mkNewData ilg (cuspec, cidx) = - let alt = altOfUnionSpec cuspec cidx - let altName = alt.Name - let baseTy = baseTyOfUnionSpec cuspec - let layout = classifyFromSpec cuspec - - let viaMakerCall () = - [ - mkNormalCall ( - mkILNonGenericStaticMethSpecInTy ( - baseTy, - mkMakerName cuspec altName, - Array.toList alt.FieldTypes, - constFormalFieldTy baseTy - ) - ) - ] - - let viaGetAltNameProperty () = - [ - mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "get_" + altName, [], constFormalFieldTy baseTy)) - ] - - // If helpers exist, use them - match cuspec.HasHelpers with - | AllHelpers - | SpecialFSharpListHelpers - | SpecialFSharpOptionHelpers -> - match layout, cidx with - | CaseIsNull -> [ AI_ldnull ] - | _ -> - if alt.IsNullary then - viaGetAltNameProperty () - else - viaMakerCall () - - | NoHelpers -> - match layout, cidx with - | CaseIsNull -> [ AI_ldnull ] - | _ -> - match layout with - // Struct non-nullary: use maker method (handles initobj + field stores) - | ValueTypeLayout when not alt.IsNullary -> viaMakerCall () - // Ref nullary (not null-represented): use property accessor for singleton - | ReferenceTypeLayout when alt.IsNullary -> viaGetAltNameProperty () - // Everything else: raw construction - | _ -> emitRawConstruction ilg cuspec layout cidx - -let private emitIsCase ilg access cuspec (layout: UnionLayout) cidx = - let baseTy = baseTyOfUnionSpec cuspec - let ci = resolveCaseWith layout baseTy cuspec cidx - let storage = classifyCaseStorage layout cuspec cidx ci.Case - - match storage with - | CaseStorage.Null -> - // Null-represented case: compare with null - [ AI_ldnull; AI_ceq ] - | _ -> - match storage, layout with - // Single non-nullary folded to root with null siblings: test non-null - | CaseStorage.OnRoot, DiscriminateByRuntimeType _ -> [ AI_ldnull; AI_cgt_un ] - | _, NoDiscrimination _ -> [ mkLdcInt32 1 ] - | _, DiscriminateByRuntimeType _ -> mkRuntimeTypeDiscriminate ilg access cuspec ci.Case ci.CaseName ci.CaseType - | _, DiscriminateByTagField baseTy -> mkTagDiscriminate ilg cuspec baseTy cidx - | _, DiscriminateByTailNull _ -> - match cidx with - | TagNil -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_ceq ] - | TagCons -> [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] - | _ -> failwith "emitIsCase - unexpected list case index" - -let mkIsData ilg (access, cuspec, cidx) = - let layout = classifyFromSpec cuspec - emitIsCase ilg access cuspec layout cidx - -type ICodeGen<'Mark> = - abstract CodeLabel: 'Mark -> ILCodeLabel - abstract GenerateDelayMark: unit -> 'Mark - abstract GenLocal: ILType -> uint16 - abstract SetMarkToHere: 'Mark -> unit - abstract EmitInstr: ILInstr -> unit - abstract EmitInstrs: ILInstr list -> unit - abstract MkInvalidCastExnNewobj: unit -> ILInstr - -let genWith g : ILCode = - let instrs = ResizeArray() - let lab2pc = Dictionary() - - g - { new ICodeGen with - member _.CodeLabel(m) = m - member _.GenerateDelayMark() = generateCodeLabel () - member _.GenLocal(ilTy) = failwith "not needed" - member _.SetMarkToHere(m) = lab2pc[m] <- instrs.Count - member _.EmitInstr x = instrs.Add x - - member cg.EmitInstrs xs = - for i in xs do - cg.EmitInstr i - - member _.MkInvalidCastExnNewobj() = failwith "not needed" - } - - { - Labels = lab2pc - Instrs = instrs.ToArray() - Exceptions = [] - Locals = [] - } - -let private emitBranchOnCase ilg sense access cuspec (layout: UnionLayout) cidx tg = - let neg = (if sense then BI_brfalse else BI_brtrue) - let pos = (if sense then BI_brtrue else BI_brfalse) - let baseTy = baseTyOfUnionSpec cuspec - let ci = resolveCaseWith layout baseTy cuspec cidx - let storage = classifyCaseStorage layout cuspec cidx ci.Case - - match storage with - | CaseStorage.Null -> - // Null-represented case: branch on null - [ I_brcmp(neg, tg) ] - | _ -> - match storage, layout with - // Single non-nullary folded to root with null siblings: branch on non-null - | CaseStorage.OnRoot, DiscriminateByRuntimeType _ -> [ I_brcmp(pos, tg) ] - | _, NoDiscrimination _ -> [] - | _, DiscriminateByRuntimeType _ -> - mkRuntimeTypeDiscriminateThen ilg access cuspec ci.Case ci.CaseName ci.CaseType (I_brcmp(pos, tg)) - | _, DiscriminateByTagField _ -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp(pos, tg)) - | _, DiscriminateByTailNull _ -> - match cidx with - | TagNil -> [ mkGetTailOrNull access cuspec; I_brcmp(neg, tg) ] - | TagCons -> [ mkGetTailOrNull access cuspec; I_brcmp(pos, tg) ] - | _ -> failwith "emitBranchOnCase - unexpected list case index" - -let mkBrIsData ilg sense (access, cuspec, cidx, tg) = - let layout = classifyFromSpec cuspec - emitBranchOnCase ilg sense access cuspec layout cidx tg - -let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionSpec) = - match access with - | DataAccess.ViaHelpers - | DataAccess.ViaListHelpers -> - ldOpt |> Option.iter cg.EmitInstr - cg.EmitInstr(mkGetTagFromHelpers ilg cuspec) - | DataAccess.RawFields -> - - let layout = classifyFromSpec cuspec - let alts = cuspec.AlternativesArray - - match layout with - | DiscriminateByTailNull _ -> - // leaves 1 if cons, 0 if not - ldOpt |> Option.iter cg.EmitInstr - cg.EmitInstrs [ mkGetTailOrNull access cuspec; AI_ldnull; AI_cgt_un ] - | DiscriminateByTagField baseTy -> - ldOpt |> Option.iter cg.EmitInstr - cg.EmitInstr(mkGetTagFromField ilg cuspec baseTy) - | NoDiscrimination _ -> - ldOpt |> Option.iter cg.EmitInstr - cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] - | DiscriminateByRuntimeType(baseTy, nullAsTrueValueIdx) -> - // RuntimeTypes: emit multi-way isinst chain - let ld = - match ldOpt with - | None -> - let locn = cg.GenLocal baseTy - cg.EmitInstr(mkStloc locn) - mkLdloc locn - | Some i -> i - - let outlab = cg.GenerateDelayMark() - - let emitCase cidx = - let alt = altOfUnionSpec cuspec cidx - let internalLab = cg.GenerateDelayMark() - let failLab = cg.GenerateDelayMark() - let cmpNull = (nullAsTrueValueIdx = Some cidx) - - let test = - I_brcmp((if cmpNull then BI_brtrue else BI_brfalse), cg.CodeLabel failLab) - - let testBlock = - if cmpNull || caseFieldsOnRoot layout alt cuspec.AlternativesArray then - [ test ] - else - let altName = alt.Name - let altTy = tyForAltIdxWith layout baseTy cuspec alt cidx - mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy test - - cg.EmitInstrs(ld :: testBlock) - cg.SetMarkToHere internalLab - cg.EmitInstrs [ mkLdcInt32 cidx; I_br(cg.CodeLabel outlab) ] - cg.SetMarkToHere failLab - - // Emit type tests in reverse order; case 0 is the fallback (loaded after the loop). - for n in alts.Length - 1 .. -1 .. 1 do - emitCase n - - // Make the block for the last test. - cg.EmitInstr(mkLdcInt32 0) - cg.SetMarkToHere outlab - -let emitLdDataTag ilg (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionSpec) = - emitLdDataTagPrim ilg None cg (access, cuspec) - -let private emitCastToCase ilg (cg: ICodeGen<'Mark>) canfail access cuspec (layout: UnionLayout) cidx = - let baseTy = baseTyOfUnionSpec cuspec - let ci = resolveCaseWith layout baseTy cuspec cidx - let storage = classifyCaseStorage layout cuspec cidx ci.Case - - match storage with - | CaseStorage.Null -> - // Null-represented case - if canfail then - let outlab = cg.GenerateDelayMark() - let internal1 = cg.GenerateDelayMark() - cg.EmitInstrs [ AI_dup; I_brcmp(BI_brfalse, cg.CodeLabel outlab) ] - cg.SetMarkToHere internal1 - cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] - cg.SetMarkToHere outlab - | CaseStorage.OnRoot -> - // Fields on root: tag check if canfail for structs, else leave on stack - match layout with - | ValueTypeLayout when canfail -> - let outlab = cg.GenerateDelayMark() - let internal1 = cg.GenerateDelayMark() - cg.EmitInstr AI_dup - emitLdDataTagPrim ilg None cg (access, cuspec) - cg.EmitInstrs [ mkLdcInt32 cidx; I_brcmp(BI_beq, cg.CodeLabel outlab) ] - cg.SetMarkToHere internal1 - cg.EmitInstrs [ cg.MkInvalidCastExnNewobj(); I_throw ] - cg.SetMarkToHere outlab - | _ -> () - | CaseStorage.Singleton -> - // Nullary case with singleton field on root class, no cast needed - () - | CaseStorage.InNestedType altTy -> - // Case lives in a nested subtype: emit castclass - cg.EmitInstr(I_castclass altTy) - -let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, access, cuspec, cidx) = - let layout = classifyFromSpec cuspec - emitCastToCase ilg cg canfail access cuspec layout cidx - -let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: UnionLayout) cases = - match layout with - | DiscriminateByRuntimeType(baseTy, nullAsTrueValueIdx) -> - let locn = cg.GenLocal baseTy - - cg.EmitInstr(mkStloc locn) - - for cidx, tg in cases do - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAltIdxWith layout baseTy cuspec alt cidx - let altName = alt.Name - let failLab = cg.GenerateDelayMark() - let cmpNull = (nullAsTrueValueIdx = Some cidx) - - cg.EmitInstr(mkLdloc locn) - let testInstr = I_brcmp((if cmpNull then BI_brfalse else BI_brtrue), tg) - - if cmpNull || caseFieldsOnRoot layout alt cuspec.AlternativesArray then - cg.EmitInstr testInstr - else - cg.EmitInstrs(mkRuntimeTypeDiscriminateThen ilg access cuspec alt altName altTy testInstr) - - cg.SetMarkToHere failLab - - | DiscriminateByTagField _ -> - match cases with - | [] -> cg.EmitInstr AI_pop - | _ -> - let dict = Dictionary() - - for i, case in cases do - dict[i] <- case - - let failLab = cg.GenerateDelayMark() - - let emitCase i _ = - match dict.TryGetValue i with - | true, res -> res - | _ -> cg.CodeLabel failLab - - let dests = Array.mapi emitCase cuspec.AlternativesArray - cg.EmitInstr(mkGetTag ilg cuspec) - cg.EmitInstr(I_switch(Array.toList dests)) - cg.SetMarkToHere failLab - - | NoDiscrimination _ -> - match cases with - | [ (0, tg) ] -> cg.EmitInstrs [ AI_pop; I_br tg ] - | [] -> cg.EmitInstr AI_pop - | _ -> failwith "unexpected: strange switch on single-case unions should not be present" - - | DiscriminateByTailNull _ -> failwith "unexpected: switches on lists should have been eliminated to brisdata tests" - -let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (access, cuspec, cases) = - let layout = classifyFromSpec cuspec - emitCaseSwitch ilg cg access cuspec layout cases - //--------------------------------------------------- // Generate the union classes diff --git a/src/Compiler/CodeGen/EraseUnions.fsi b/src/Compiler/CodeGen/EraseUnions.fsi index 7b43ecd9e51..a6a59565242 100644 --- a/src/Compiler/CodeGen/EraseUnions.fsi +++ b/src/Compiler/CodeGen/EraseUnions.fsi @@ -10,38 +10,6 @@ open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types open FSharp.Compiler.TcGlobals -/// How to access union data at a given call site. -[] -type DataAccess = - | RawFields - | ViaHelpers - | ViaListHelpers - -/// Compute the access strategy from the per-call-site flag and per-union helpers setting. -val computeDataAccess: avoidHelpers: bool -> cuspec: IlxUnionSpec -> DataAccess - -/// Make the instruction sequence for a "newdata" operation -val mkNewData: ilg: ILGlobals -> cuspec: IlxUnionSpec * cidx: int -> ILInstr list - -/// Make the instruction sequence for a "isdata" operation -val mkIsData: ilg: ILGlobals -> access: DataAccess * cuspec: IlxUnionSpec * cidx: int -> ILInstr list - -/// Make the instruction for a "lddata" operation -val mkLdData: access: DataAccess * cuspec: IlxUnionSpec * cidx: int * fidx: int -> ILInstr - -/// Make the instruction for a "lddataa" operation -val mkLdDataAddr: access: DataAccess * cuspec: IlxUnionSpec * cidx: int * fidx: int -> ILInstr - -/// Make the instruction for a "stdata" operation -val mkStData: cuspec: IlxUnionSpec * cidx: int * fidx: int -> ILInstr - -/// Make the instruction sequence for a "brisnotdata" operation -val mkBrIsData: - ilg: ILGlobals -> - sense: bool -> - access: DataAccess * cuspec: IlxUnionSpec * cidx: int * tg: ILCodeLabel -> - ILInstr list - /// Make the type definition for a union type val mkClassUnionDef: addMethodGeneratedAttrs: (ILMethodDef -> ILMethodDef) * @@ -55,30 +23,3 @@ val mkClassUnionDef: td: ILTypeDef -> cud: IlxUnionInfo -> ILTypeDef - -/// Make the IL type for a union type alternative -val GetILTypeForAlternative: cuspec: IlxUnionSpec -> alt: int -> ILType - -/// Used to emit instructions (an interface to the IlxGen.fs code generator) -type ICodeGen<'Mark> = - abstract CodeLabel: 'Mark -> ILCodeLabel - abstract GenerateDelayMark: unit -> 'Mark - abstract GenLocal: ILType -> uint16 - abstract SetMarkToHere: 'Mark -> unit - abstract EmitInstr: ILInstr -> unit - abstract EmitInstrs: ILInstr list -> unit - abstract MkInvalidCastExnNewobj: unit -> ILInstr - -/// Emit the instruction sequence for a "castdata" operation -val emitCastData: - ilg: ILGlobals -> cg: ICodeGen<'Mark> -> canfail: bool * access: DataAccess * cuspec: IlxUnionSpec * int -> unit - -/// Emit the instruction sequence for a "lddatatag" operation -val emitLdDataTag: ilg: ILGlobals -> cg: ICodeGen<'Mark> -> access: DataAccess * cuspec: IlxUnionSpec -> unit - -/// Emit the instruction sequence for a "switchdata" operation -val emitDataSwitch: - ilg: ILGlobals -> - cg: ICodeGen<'Mark> -> - access: DataAccess * cuspec: IlxUnionSpec * cases: (int * ILCodeLabel) list -> - unit diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index fea7514ddc8..55ee8110e11 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -698,7 +698,7 @@ and GenTypeAux cenv m (tyenv: TypeReprEnv) voidOK ptrsOK ty = | TType_ucase(ucref, args) -> let cuspec, idx = GenUnionCaseSpec cenv m tyenv ucref args - EraseUnions.GetILTypeForAlternative cuspec idx + GetILTypeForAlternative cuspec idx | TType_forall(tps, tau) -> let tps = DropErasedTypars tps @@ -3464,7 +3464,7 @@ and GenAllocExn cenv cgbuf eenv (c, args, m) sequel = and GenAllocUnionCaseCore cenv cgbuf eenv (c, tyargs, n, m) = let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv c tyargs - CG.EmitInstrs cgbuf (pop n) (Push [ cuspec.DeclaringType ]) (EraseUnions.mkNewData cenv.g.ilg (cuspec, idx)) + CG.EmitInstrs cgbuf (pop n) (Push [ cuspec.DeclaringType ]) (mkNewData cenv.g.ilg (cuspec, idx)) and GenAllocUnionCase cenv cgbuf eenv (c, tyargs, args, m) sequel = GenExprs cenv cgbuf eenv args @@ -3918,7 +3918,7 @@ and GenSetExnField cenv cgbuf eenv (e, ecref, fieldNum, e2, m) sequel = GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel and UnionCodeGen (cgbuf: CodeGenBuffer) = - { new EraseUnions.ICodeGen with + { new ICodeGen with member _.CodeLabel m = m.CodeLabel member _.GenerateDelayMark() = @@ -3942,10 +3942,10 @@ and GenUnionCaseProof cenv cgbuf eenv (e, ucref, tyargs, m) sequel = let g = cenv.g GenExpr cenv cgbuf eenv e Continue let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs - let fty = EraseUnions.GetILTypeForAlternative cuspec idx + let fty = GetILTypeForAlternative cuspec idx let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef - let access = EraseUnions.computeDataAccess avoidHelpers cuspec - EraseUnions.emitCastData g.ilg (UnionCodeGen cgbuf) (false, access, cuspec, idx) + let access = computeDataAccess avoidHelpers cuspec + emitCastData g.ilg (UnionCodeGen cgbuf) (false, access, cuspec, idx) CG.EmitInstrs cgbuf (pop 1) (Push [ fty ]) [] // push/pop to match the line above GenSequel cenv eenv.cloc cgbuf sequel @@ -3957,8 +3957,8 @@ and GenGetUnionCaseField cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel = let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let fty = actualTypOfIlxUnionField cuspec idx n let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef - let access = EraseUnions.computeDataAccess avoidHelpers cuspec - CG.EmitInstr cgbuf (pop 1) (Push [ fty ]) (EraseUnions.mkLdData (access, cuspec, idx, n)) + let access = computeDataAccess avoidHelpers cuspec + CG.EmitInstr cgbuf (pop 1) (Push [ fty ]) (mkLdData (access, cuspec, idx, n)) GenSequel cenv eenv.cloc cgbuf sequel and GenGetUnionCaseFieldAddr cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel = @@ -3969,8 +3969,8 @@ and GenGetUnionCaseFieldAddr cenv cgbuf eenv (e, ucref, tyargs, n, m) sequel = let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let fty = actualTypOfIlxUnionField cuspec idx n let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef - let access = EraseUnions.computeDataAccess avoidHelpers cuspec - CG.EmitInstr cgbuf (pop 1) (Push [ ILType.Byref fty ]) (EraseUnions.mkLdDataAddr (access, cuspec, idx, n)) + let access = computeDataAccess avoidHelpers cuspec + CG.EmitInstr cgbuf (pop 1) (Push [ ILType.Byref fty ]) (mkLdDataAddr (access, cuspec, idx, n)) GenSequel cenv eenv.cloc cgbuf sequel and GenGetUnionCaseTag cenv cgbuf eenv (e, tcref, tyargs, m) sequel = @@ -3978,8 +3978,8 @@ and GenGetUnionCaseTag cenv cgbuf eenv (e, tcref, tyargs, m) sequel = GenExpr cenv cgbuf eenv e Continue let cuspec = GenUnionSpec cenv m eenv.tyenv tcref tyargs let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore tcref - let access = EraseUnions.computeDataAccess avoidHelpers cuspec - EraseUnions.emitLdDataTag g.ilg (UnionCodeGen cgbuf) (access, cuspec) + let access = computeDataAccess avoidHelpers cuspec + emitLdDataTag g.ilg (UnionCodeGen cgbuf) (access, cuspec) CG.EmitInstrs cgbuf (pop 1) (Push [ g.ilg.typ_Int32 ]) [] // push/pop to match the line above GenSequel cenv eenv.cloc cgbuf sequel @@ -3988,11 +3988,11 @@ and GenSetUnionCaseField cenv cgbuf eenv (e, ucref, tyargs, n, e2, m) sequel = GenExpr cenv cgbuf eenv e Continue let cuspec, idx = GenUnionCaseSpec cenv m eenv.tyenv ucref tyargs let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore ucref.TyconRef - let access = EraseUnions.computeDataAccess avoidHelpers cuspec - EraseUnions.emitCastData g.ilg (UnionCodeGen cgbuf) (false, access, cuspec, idx) + let access = computeDataAccess avoidHelpers cuspec + emitCastData g.ilg (UnionCodeGen cgbuf) (false, access, cuspec, idx) CG.EmitInstrs cgbuf (pop 1) (Push [ cuspec.DeclaringType ]) [] // push/pop to match the line above GenExpr cenv cgbuf eenv e2 Continue - CG.EmitInstr cgbuf (pop 2) Push0 (EraseUnions.mkStData (cuspec, idx, n)) + CG.EmitInstr cgbuf (pop 2) Push0 (mkStData (cuspec, idx, n)) GenUnitThenSequel cenv eenv m eenv.cloc cgbuf sequel and GenGetRecdFieldAddr cenv cgbuf eenv (e, f, tyargs, m) sequel = @@ -7801,7 +7801,7 @@ and GenDecisionTreeSwitch let cuspec = GenUnionSpec cenv m eenv.tyenv c.TyconRef tyargs let idx = c.Index let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore c.TyconRef - let access = EraseUnions.computeDataAccess avoidHelpers cuspec + let access = computeDataAccess avoidHelpers cuspec let tester = Some(pop 1, Push [ g.ilg.typ_Bool ], Choice1Of2(access, cuspec, idx)) @@ -7921,8 +7921,8 @@ and GenDecisionTreeSwitch | _ -> failwith "error: mixed constructor/const test?") let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore hdc.TyconRef - let access = EraseUnions.computeDataAccess avoidHelpers cuspec - EraseUnions.emitDataSwitch g.ilg (UnionCodeGen cgbuf) (access, cuspec, dests) + let access = computeDataAccess avoidHelpers cuspec + emitDataSwitch g.ilg (UnionCodeGen cgbuf) (access, cuspec, dests) CG.EmitInstrs cgbuf (pop 1) Push0 [] // push/pop to match the line above GenDecisionTreeCases @@ -8118,7 +8118,7 @@ and GenDecisionTreeTest | Some(pops, pushes, i) -> match i with | Choice1Of2(access, cuspec, idx) -> - CG.EmitInstrs cgbuf pops pushes (EraseUnions.mkIsData g.ilg (access, cuspec, idx)) + CG.EmitInstrs cgbuf pops pushes (mkIsData g.ilg (access, cuspec, idx)) | Choice2Of2 i -> CG.EmitInstr cgbuf pops pushes i | _ -> () @@ -8217,7 +8217,7 @@ and GenDecisionTreeTest cgbuf eenv e - (CmpThenBrOrContinue(pop 1, EraseUnions.mkBrIsData g.ilg false (access, cuspec, idx, failure.CodeLabel))) + (CmpThenBrOrContinue(pop 1, mkBrIsData g.ilg false (access, cuspec, idx, failure.CodeLabel))) GenDecisionTreeAndTargetsInner cenv @@ -8250,7 +8250,7 @@ and GenDecisionTreeTest match i with | Choice1Of2(access, cuspec, idx) -> - CG.EmitInstrs cgbuf pops pushes (EraseUnions.mkIsData g.ilg (access, cuspec, idx)) + CG.EmitInstrs cgbuf pops pushes (mkIsData g.ilg (access, cuspec, idx)) | Choice2Of2 i -> CG.EmitInstr cgbuf pops pushes i CG.EmitInstr cgbuf (pop 1) Push0 (I_brcmp(BI_brfalse, failure.CodeLabel)) diff --git a/src/Compiler/FSharp.Compiler.Service.fsproj b/src/Compiler/FSharp.Compiler.Service.fsproj index 8a3782bcb35..17f4b2bab11 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -425,6 +425,8 @@ + + From a104cd20838c8f242fd315cb7a0b115f98454ddd Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Sat, 28 Mar 2026 00:29:03 +0100 Subject: [PATCH 40/44] Fix bug + review findings: bounds check, stale comments, magic numbers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit BUG FIX: emitRawConstruction for SingleCaseStruct nullary — was emitting tag-ctor for CaseStorage.OnRoot+IsNullary but SingleCaseStruct has no tag field (NoTagField). Now checks HasTagField|NoTagField before choosing ctor shape. Review fixes (3-model voted, 8/10 unanimous): - H1: altOfUnionSpec blanket 'with _' catch → bounds check - H2: tyForAlt Array.findIndex → tryFindIndex + meaningful error - H3+H4: Fix stale case counts in architecture comment (8→9, 5→4) - H5: Remove unused _cuspec param from mkTagFieldType (10 call sites) - H7: List.ofArray|>List.mapi → Array.mapi|>Array.toList - H8: Rename quadruple negation hasFieldsOrTagButNoMethods → onlyMethodsOnRoot - H9: Named constants for DynamicDependency flags 0x660/0x7E0 Also revert unrelated FSharp.Core doc/test changes (per expert review). Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.Emit.fs | 24 ++++++----- src/Compiler/CodeGen/EraseUnions.Types.fs | 22 +++++----- src/Compiler/CodeGen/EraseUnions.fs | 49 ++++++++++++++--------- 3 files changed, 57 insertions(+), 38 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.Emit.fs b/src/Compiler/CodeGen/EraseUnions.Emit.fs index 3bab4a31f09..e07edc2dccb 100644 --- a/src/Compiler/CodeGen/EraseUnions.Emit.fs +++ b/src/Compiler/CodeGen/EraseUnions.Emit.fs @@ -37,11 +37,11 @@ let mkRuntimeTypeDiscriminateThen ilg (access: DataAccess) cuspec (alt: IlxUnion | I_brcmp(BI_brtrue, _) when not useHelper -> [ I_isinst altTy; after ] | _ -> mkRuntimeTypeDiscriminate ilg access cuspec alt altName altTy @ [ after ] -let mkGetTagFromField ilg cuspec baseTy = - mkNormalLdfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) +let mkGetTagFromField ilg _cuspec baseTy = + mkNormalLdfld (refToFieldInTy baseTy (mkTagFieldId ilg)) -let mkSetTagToField ilg cuspec baseTy = - mkNormalStfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) +let mkSetTagToField ilg _cuspec baseTy = + mkNormalStfld (refToFieldInTy baseTy (mkTagFieldId ilg)) let adjustFieldNameForTypeDef hasHelpers nm = match hasHelpers, nm with @@ -81,8 +81,8 @@ let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = match classifyFromSpec cuspec with | UnionLayout.SmallRefWithNullAsTrueValue _ -> - mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [ baseTy ], mkTagFieldType ilg cuspec)) - | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldType ilg cuspec)) + mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [ baseTy ], mkTagFieldType ilg)) + | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldType ilg)) let mkGetTag ilg (cuspec: IlxUnionSpec) = match cuspec.HasHelpers with @@ -116,9 +116,14 @@ let private emitRawConstruction ilg cuspec (layout: UnionLayout) cidx = | CaseStorage.OnRoot -> if ci.Case.IsNullary then - // Struct + nullary: create via root ctor with tag - let tagField = [ mkTagFieldType ilg cuspec ] - [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] + match layout with + | HasTagField -> + // Multi-case struct nullary: create via root ctor with tag + let tagField = [ mkTagFieldType ilg ] + [ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ] + | NoTagField -> + // Single-case nullary: create via parameterless root ctor + [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, [])) ] else // Non-nullary fields on root: create via root ctor with fields let ctorFieldTys = ci.Case.FieldTypes |> Array.toList @@ -439,4 +444,3 @@ let private emitCaseSwitch ilg (cg: ICodeGen<'Mark>) access cuspec (layout: Unio let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (access, cuspec, cases) = let layout = classifyFromSpec cuspec emitCaseSwitch ilg cg access cuspec layout cases - diff --git a/src/Compiler/CodeGen/EraseUnions.Types.fs b/src/Compiler/CodeGen/EraseUnions.Types.fs index 8a9452727b0..1a2b0b60a54 100644 --- a/src/Compiler/CodeGen/EraseUnions.Types.fs +++ b/src/Compiler/CodeGen/EraseUnions.Types.fs @@ -20,10 +20,10 @@ open FSharp.Compiler.AbstractIL.ILX.Types // // Every decision in this module is driven by two independent classifications: // -// 1. UnionLayout (8 cases) — how the union TYPE is structured in IL +// 1. UnionLayout (9 cases) — how the union TYPE is structured in IL // Computed once per union via classifyFromSpec / classifyFromDef. // -// 2. CaseStorage (5 cases) — how each individual CASE is stored +// 2. CaseStorage (4 cases) — how each individual CASE is stored // Computed per case via classifyCaseStorage. Answers: is this case null? // A singleton field? Fields on root? In a nested subtype? Struct tag-only? // @@ -381,22 +381,25 @@ let mkConstFieldSpec nm (baseTy: ILType) = let tyForAlt (cuspec: IlxUnionSpec) (alt: IlxUnionCase) = let cidx = cuspec.AlternativesArray - |> Array.findIndex (fun (a: IlxUnionCase) -> a.Name = alt.Name) + |> Array.tryFindIndex (fun (a: IlxUnionCase) -> a.Name = alt.Name) + |> Option.defaultWith (fun () -> failwith $"tyForAlt: case '{alt.Name}' not in union spec") tyForAltIdx cuspec alt cidx let GetILTypeForAlternative cuspec alt = tyForAlt cuspec (cuspec.Alternative alt) -let mkTagFieldType (ilg: ILGlobals) _cuspec = ilg.typ_Int32 +let mkTagFieldType (ilg: ILGlobals) = ilg.typ_Int32 -let mkTagFieldId ilg cuspec = "_tag", mkTagFieldType ilg cuspec +let mkTagFieldId ilg = "_tag", mkTagFieldType ilg let altOfUnionSpec (cuspec: IlxUnionSpec) cidx = - try - cuspec.Alternative cidx - with _ -> - failwith ("alternative " + string cidx + " not found") + let alts = cuspec.AlternativesArray + + if cidx < 0 || cidx >= alts.Length then + failwith $"alternative {cidx} not found (union has {alts.Length} cases)" + else + alts[cidx] /// Resolved identity of a union case within a union spec. [] @@ -418,4 +421,3 @@ let resolveCaseWith (layout: UnionLayout) (baseTy: ILType) (cuspec: IlxUnionSpec CaseType = tyForAltIdxWith layout baseTy cuspec alt cidx CaseName = alt.Name } - diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 1e08caab041..7e1993844a4 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -14,6 +14,14 @@ open FSharp.Compiler.TcGlobals open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types +/// DynamicallyAccessedMemberTypes flags for [DynamicDependency] on case ctors +[] +let private DynamicDependencyPublicMembers = 0x660 + +/// DynamicallyAccessedMemberTypes flags for [DynamicDependency] on base ctor +[] +let private DynamicDependencyAllCtorsAndPublicMembers = 0x7E0 + //--------------------------------------------------- // Generate the union classes @@ -119,7 +127,7 @@ let private emitDebugProxyType (ctx: TypeDefContext) (altTy: ILType) (fields: Il [ mkILParamNamed ("obj", altTy) ], mkMethodBody (false, [], 3, debugProxyCode, None, imports) )) - .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) + .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g DynamicDependencyPublicMembers baseTy ]) |> ctx.stamping.stampMethodAsGenerated let debugProxyGetterMeths = @@ -485,7 +493,7 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx match ctx.layout with | HasTagField -> yield mkLdcInt32 num - yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [ mkTagFieldType g.ilg cuspec ])) + yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [ mkTagFieldType g.ilg ])) | NoTagField -> yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [])) ] @@ -503,7 +511,7 @@ let private emitNestedAlternativeType (ctx: TypeDefContext) (num: int) (alt: Ilx let basicCtorMeth = (mkILStorageCtor (basicCtorInstrs, altTy, basicCtorFields, basicCtorAccess, attr, imports)) - .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) + .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g DynamicDependencyPublicMembers baseTy ]) |> ctx.stamping.stampMethodAsGenerated let attrs = @@ -695,7 +703,9 @@ let private emitRootClassFields (ctx: TypeDefContext) (tagFieldsInObject: (strin cud.DebugPoint, cud.DebugImports )) - .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) + .With( + customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g DynamicDependencyPublicMembers baseTy ] + ) |> ctx.stamping.stampMethodAsGenerated ] @@ -733,14 +743,12 @@ let private emitRootConstructors (ctx: TypeDefContext) rootCaseFields tagFieldsI cud.UnionCases |> Array.forall (fun alt -> caseFieldsOnRoot ctx.layout alt cud.UnionCases) - let hasFieldsOrTagButNoMethods = - not ( - List.isEmpty rootCaseFields - && List.isEmpty tagFieldsInObject - && not (List.isEmpty rootCaseMethods) - ) + let onlyMethodsOnRoot = + List.isEmpty rootCaseFields + && List.isEmpty tagFieldsInObject + && not (List.isEmpty rootCaseMethods) - if td.IsStruct || allCasesFoldToRoot || not hasFieldsOrTagButNoMethods then + if td.IsStruct || allCasesFoldToRoot || onlyMethodsOnRoot then [] else let baseTySpec = @@ -759,7 +767,13 @@ let private emitRootConstructors (ctx: TypeDefContext) rootCaseFields tagFieldsI cud.DebugPoint, cud.DebugImports )) - .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x7E0 baseTy ]) + .With( + customAttrs = + mkILCustomAttrs + [ + GetDynamicDependencyAttribute g DynamicDependencyAllCtorsAndPublicMembers baseTy + ] + ) |> ctx.stamping.stampMethodAsGenerated ] @@ -768,7 +782,6 @@ let private emitConstFieldInitializers (ctx: TypeDefContext) (altNullaryFields: let g = ctx.g let cud = ctx.cud let baseTy = ctx.baseTy - let cuspec = ctx.cuspec fun (cd: ILTypeDef) -> if List.isEmpty altNullaryFields then @@ -785,7 +798,7 @@ let private emitConstFieldInitializers (ctx: TypeDefContext) (altNullaryFields: | HasTagField -> if r.InRootClass then yield mkLdcInt32 r.CaseIndex - yield mkNormalNewobj (mkILCtorMethSpecForTy (r.CaseType, [ mkTagFieldType g.ilg cuspec ])) + yield mkNormalNewobj (mkILCtorMethSpecForTy (r.CaseType, [ mkTagFieldType g.ilg ])) else yield mkNormalNewobj (mkILCtorMethSpecForTy (r.CaseType, [])) @@ -802,7 +815,7 @@ let private emitTagInfrastructure (ctx: TypeDefContext) = let baseTy = ctx.baseTy let cuspec = ctx.cuspec - let tagFieldType = mkTagFieldType g.ilg cuspec + let tagFieldType = mkTagFieldType g.ilg let tagEnumFields = cud.UnionCases @@ -1017,12 +1030,12 @@ let mkClassUnionDef let results = cud.UnionCases - |> List.ofArray - |> List.mapi (fun i alt -> processAlternative ctx i alt) + |> Array.mapi (fun i alt -> processAlternative ctx i alt) + |> Array.toList let tagFieldsInObject = match ctx.layout with - | HasTagField -> [ let n, t = mkTagFieldId g.ilg cuspec in n, t, [] ] + | HasTagField -> [ let n, t = mkTagFieldId g.ilg in n, t, [] ] | NoTagField -> [] let rootCaseFields, rootCaseMethods, rootCaseProperties = From e565cb4336dbea63bcbaaa0971e3e91d03c7c0c8 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Mon, 30 Mar 2026 11:09:31 +0200 Subject: [PATCH 41/44] DDD review: pure classification in Types.fs, architecture docs, section headers MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit P1: Move TypeDefContext/ILStamping/AlternativeDefResult/NullaryConstFieldInfo from Types.fs to EraseUnions.fs — they're type-def scaffolding, not classification algebra. Types.fs is now purely: DU types, classifiers, APs. P2+P6: Add architecture overview at top of EraseUnions.fs with pipeline description and concrete DU→UnionLayout→CaseStorage example mappings (Option, Color, Result, Shape, Token). P3: Add section header before nullable-attr rewriting functions. P7: Fix duplicate comment in rewriteNullableAttrForFlattenedField. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.Types.fs | 48 ------------ src/Compiler/CodeGen/EraseUnions.fs | 90 ++++++++++++++++++++++- 2 files changed, 88 insertions(+), 50 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.Types.fs b/src/Compiler/CodeGen/EraseUnions.Types.fs index 1a2b0b60a54..e2d799fd63a 100644 --- a/src/Compiler/CodeGen/EraseUnions.Types.fs +++ b/src/Compiler/CodeGen/EraseUnions.Types.fs @@ -291,54 +291,6 @@ let classifyCaseStorage (layout: UnionLayout) (cuspec: IlxUnionSpec) (cidx: int) else CaseStorage.InNestedType(tyForAltIdxWith layout (baseTyOfUnionSpec cuspec) cuspec alt cidx) -// ---- Context Records ---- - -/// Bundles the IL attribute-stamping callbacks used during type definition generation. -type ILStamping = - { - stampMethodAsGenerated: ILMethodDef -> ILMethodDef - stampPropertyAsGenerated: ILPropertyDef -> ILPropertyDef - stampPropertyAsNever: ILPropertyDef -> ILPropertyDef - stampFieldAsGenerated: ILFieldDef -> ILFieldDef - stampFieldAsNever: ILFieldDef -> ILFieldDef - mkDebuggerTypeProxyAttr: ILType -> ILAttribute - } - -/// Bundles the parameters threaded through type definition generation. -/// Replaces the 6-callback tuple + scattered parameter threading in convAlternativeDef/mkClassUnionDef. -type TypeDefContext = - { - g: TcGlobals - layout: UnionLayout - cuspec: IlxUnionSpec - cud: IlxUnionInfo - td: ILTypeDef - baseTy: ILType - stamping: ILStamping - } - -/// Information about a nullary case's singleton static field. -type NullaryConstFieldInfo = - { - Case: IlxUnionCase - CaseType: ILType - CaseIndex: int - Field: ILFieldDef - InRootClass: bool - } - -/// Result of processing a single union alternative for type definition generation. -/// Replaces the 6-element tuple return from convAlternativeDef. -type AlternativeDefResult = - { - BaseMakerMethods: ILMethodDef list - BaseMakerProperties: ILPropertyDef list - ConstantAccessors: ILMethodDef list - NestedTypeDefs: ILTypeDef list - DebugProxyTypeDefs: ILTypeDef list - NullaryConstFields: NullaryConstFieldInfo list - } - let mkTesterName nm = "Is" + nm let tagPropertyName = "Tag" diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index 7e1993844a4..d734dda22a1 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -14,6 +14,89 @@ open FSharp.Compiler.TcGlobals open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types +// ============================================================================ +// Type Definition Generation for F# Discriminated Unions +// +// Entry point: mkClassUnionDef (bottom of file, F# requires definitions before use) +// +// Pipeline: +// 1. Classify union layout (Types.fs: classifyFromDef → UnionLayout) +// 2. For each case: classify storage (Types.fs: classifyCaseStorage → CaseStorage) +// 3. For each case: emit maker methods, tester properties, nested types, debug proxies +// 4. Emit root class: fields, constructors, tag infrastructure +// 5. Assemble everything into the final ILTypeDef +// +// Key context: TypeDefContext bundles all generation parameters. +// Results per case: AlternativeDefResult collects methods/fields/types. +// +// Example mappings (DU → UnionLayout → CaseStorage): +// type Option<'T> = None | Some of 'T +// → SmallRefWithNullAsTrueValue +// → None=Null, Some=OnRoot +// +// type Color = Red | Green | Blue | Yellow +// → TaggedRefAllNullary +// → all cases=Singleton +// +// [] type Result<'T,'E> = Ok of 'T | Error of 'E +// → TaggedStruct +// → Ok=OnRoot, Error=OnRoot +// +// type Shape = Circle of float | Square of float | Point +// → SmallRef (3 cases, ref, not all-nullary) +// → Circle=InNestedType, Square=InNestedType, Point=Singleton +// +// type Token = Ident of string | IntLit of int | Plus | Minus | Star +// → TaggedRef (≥4 cases, ref) +// → Ident=InNestedType, IntLit=InNestedType, Plus/Minus/Star=Singleton +// ============================================================================ + +/// Bundles the IL attribute-stamping callbacks used during type definition generation. +type ILStamping = + { + stampMethodAsGenerated: ILMethodDef -> ILMethodDef + stampPropertyAsGenerated: ILPropertyDef -> ILPropertyDef + stampPropertyAsNever: ILPropertyDef -> ILPropertyDef + stampFieldAsGenerated: ILFieldDef -> ILFieldDef + stampFieldAsNever: ILFieldDef -> ILFieldDef + mkDebuggerTypeProxyAttr: ILType -> ILAttribute + } + +/// Bundles the parameters threaded through type definition generation. +/// Replaces the 6-callback tuple + scattered parameter threading in convAlternativeDef/mkClassUnionDef. +type TypeDefContext = + { + g: TcGlobals + layout: UnionLayout + cuspec: IlxUnionSpec + cud: IlxUnionInfo + td: ILTypeDef + baseTy: ILType + stamping: ILStamping + } + +/// Information about a nullary case's singleton static field. +type NullaryConstFieldInfo = + { + Case: IlxUnionCase + CaseType: ILType + CaseIndex: int + Field: ILFieldDef + InRootClass: bool + } + +/// Result of processing a single union alternative for type definition generation. +/// Replaces the 6-element tuple return from convAlternativeDef. +type AlternativeDefResult = + { + BaseMakerMethods: ILMethodDef list + BaseMakerProperties: ILPropertyDef list + ConstantAccessors: ILMethodDef list + NestedTypeDefs: ILTypeDef list + DebugProxyTypeDefs: ILTypeDef list + NullaryConstFields: NullaryConstFieldInfo list + } + /// DynamicallyAccessedMemberTypes flags for [DynamicDependency] on case ctors [] let private DynamicDependencyPublicMembers = 0x660 @@ -590,10 +673,13 @@ let private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCa NullaryConstFields = nullaryFields } +// ---- Nullable Attribute Rewriting ---- +// When struct DUs have multiple cases, all boxed fields become potentially nullable +// because only one case's fields are valid at a time. These helpers rewrite [Nullable] +// attributes accordingly. rootTypeNullableAttrs handles the union type itself. + /// Rewrite field nullable attributes for struct flattening. /// When a struct DU has multiple cases, all boxed fields become potentially nullable -/// because only one case's fields are valid at a time. -/// When a struct DU has multiple cases, all boxed fields become potentially nullable /// because only one case's fields are valid at a time. This rewrites the [Nullable] attribute /// on a field to WithNull (2uy) if it was marked as non-nullable (1uy) within its case. let private rewriteNullableAttrForFlattenedField (g: TcGlobals) (existingAttrs: ILAttribute[]) = From d62972907602ad977bfb5e60fcbfee1714f1513d Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Mon, 30 Mar 2026 14:27:15 +0200 Subject: [PATCH 42/44] Council fixes: private mkMethodsAndPropertiesForFields, shared adjustFieldNameForList MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - mkMethodsAndPropertiesForFields → private (internal-only, flagged by Opus) - Extract adjustFieldNameForList to Types.fs as shared naming core (adjustFieldNameForTypeDef and adjustFieldName both delegate to it, eliminating duplicated Head→HeadOrDefault / Tail→TailOrNull mapping) - Flagged by 4/7 council models across 2 rounds Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.Emit.fs | 10 ++++------ src/Compiler/CodeGen/EraseUnions.Types.fs | 7 +++++++ src/Compiler/CodeGen/EraseUnions.fs | 2 +- 3 files changed, 12 insertions(+), 7 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.Emit.fs b/src/Compiler/CodeGen/EraseUnions.Emit.fs index e07edc2dccb..f0d9a234659 100644 --- a/src/Compiler/CodeGen/EraseUnions.Emit.fs +++ b/src/Compiler/CodeGen/EraseUnions.Emit.fs @@ -44,15 +44,13 @@ let mkSetTagToField ilg _cuspec baseTy = mkNormalStfld (refToFieldInTy baseTy (mkTagFieldId ilg)) let adjustFieldNameForTypeDef hasHelpers nm = - match hasHelpers, nm with - | SpecialFSharpListHelpers, "Head" -> "HeadOrDefault" - | SpecialFSharpListHelpers, "Tail" -> "TailOrNull" + match hasHelpers with + | SpecialFSharpListHelpers -> adjustFieldNameForList nm | _ -> nm let adjustFieldName access nm = - match access, nm with - | DataAccess.ViaListHelpers, "Head" -> "HeadOrDefault" - | DataAccess.ViaListHelpers, "Tail" -> "TailOrNull" + match access with + | DataAccess.ViaListHelpers -> adjustFieldNameForList nm | _ -> nm let mkLdData (access, cuspec, cidx, fidx) = diff --git a/src/Compiler/CodeGen/EraseUnions.Types.fs b/src/Compiler/CodeGen/EraseUnions.Types.fs index e2d799fd63a..ab35c67b88b 100644 --- a/src/Compiler/CodeGen/EraseUnions.Types.fs +++ b/src/Compiler/CodeGen/EraseUnions.Types.fs @@ -295,6 +295,13 @@ let mkTesterName nm = "Is" + nm let tagPropertyName = "Tag" +/// Adjust field names for F# list type (Head→HeadOrDefault, Tail→TailOrNull). +let adjustFieldNameForList nm = + match nm with + | "Head" -> "HeadOrDefault" + | "Tail" -> "TailOrNull" + | _ -> nm + let mkUnionCaseFieldId (fdef: IlxUnionCaseField) = // Use the lower case name of a field or constructor as the field/parameter name if it differs from the uppercase name fdef.LowerName, fdef.Type diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs index d734dda22a1..7a8f2bb9b2a 100644 --- a/src/Compiler/CodeGen/EraseUnions.fs +++ b/src/Compiler/CodeGen/EraseUnions.fs @@ -108,7 +108,7 @@ let private DynamicDependencyAllCtorsAndPublicMembers = 0x7E0 //--------------------------------------------------- // Generate the union classes -let mkMethodsAndPropertiesForFields (ctx: TypeDefContext) (ilTy: ILType) (fields: IlxUnionCaseField[]) = +let private mkMethodsAndPropertiesForFields (ctx: TypeDefContext) (ilTy: ILType) (fields: IlxUnionCaseField[]) = let g = ctx.g let cud = ctx.cud let access = cud.UnionCasesAccessibility From f5c859605c0cd18b3e0eb58779ee4063326e4c44 Mon Sep 17 00:00:00 2001 From: Tomas Grosup Date: Mon, 30 Mar 2026 16:44:34 +0200 Subject: [PATCH 43/44] =?UTF-8?q?Fix:=20preserve=20exact=20IL=20for=20Opti?= =?UTF-8?q?on=20=E2=80=94=20add=20DataAccess.ViaOptionHelpers?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit SpecialFSharpOptionHelpers needs helpers for FIELD access (private fields) but raw discrimination for TAG access (inline isinst, not GetTag call). The old code made these decisions independently. DataAccess.ViaOptionHelpers: field access uses get_X helpers (like ViaHelpers), tag access uses raw isinst chain (like RawFields). This preserves exact IL output — zero .bsl changes. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- src/Compiler/CodeGen/EraseUnions.Emit.fs | 3 ++- src/Compiler/CodeGen/EraseUnions.Types.fs | 8 +++++--- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/src/Compiler/CodeGen/EraseUnions.Emit.fs b/src/Compiler/CodeGen/EraseUnions.Emit.fs index f0d9a234659..5e83590f6d6 100644 --- a/src/Compiler/CodeGen/EraseUnions.Emit.fs +++ b/src/Compiler/CodeGen/EraseUnions.Emit.fs @@ -286,7 +286,8 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (access, cuspec: IlxUnionS | DataAccess.ViaListHelpers -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstr(mkGetTagFromHelpers ilg cuspec) - | DataAccess.RawFields -> + | DataAccess.RawFields + | DataAccess.ViaOptionHelpers -> let layout = classifyFromSpec cuspec let alts = cuspec.AlternativesArray diff --git a/src/Compiler/CodeGen/EraseUnions.Types.fs b/src/Compiler/CodeGen/EraseUnions.Types.fs index ab35c67b88b..980b8b69541 100644 --- a/src/Compiler/CodeGen/EraseUnions.Types.fs +++ b/src/Compiler/CodeGen/EraseUnions.Types.fs @@ -43,10 +43,12 @@ open FSharp.Compiler.AbstractIL.ILX.Types type DataAccess = /// Use raw field loads/stores (intra-assembly access, or union has no helpers) | RawFields - /// Use helper methods (get_Tag, get_IsXxx, NewXxx) — inter-assembly with AllHelpers or SpecialFSharpOptionHelpers + /// Use helper methods (get_Tag, get_IsXxx, NewXxx) — inter-assembly with AllHelpers | ViaHelpers /// Use list-specific helper methods (HeadOrDefault, TailOrNull naming) — inter-assembly with SpecialFSharpListHelpers | ViaListHelpers + /// Use helper methods for field access, but raw discrimination for tag access — SpecialFSharpOptionHelpers + | ViaOptionHelpers /// Compute the access strategy from the per-call-site flag and per-union helpers setting. let computeDataAccess (avoidHelpers: bool) (cuspec: IlxUnionSpec) = @@ -55,8 +57,8 @@ let computeDataAccess (avoidHelpers: bool) (cuspec: IlxUnionSpec) = else match cuspec.HasHelpers with | IlxUnionHasHelpers.NoHelpers -> DataAccess.RawFields - | IlxUnionHasHelpers.AllHelpers - | IlxUnionHasHelpers.SpecialFSharpOptionHelpers -> DataAccess.ViaHelpers + | IlxUnionHasHelpers.AllHelpers -> DataAccess.ViaHelpers + | IlxUnionHasHelpers.SpecialFSharpOptionHelpers -> DataAccess.ViaOptionHelpers | IlxUnionHasHelpers.SpecialFSharpListHelpers -> DataAccess.ViaListHelpers [] From af061d4dd9816c95810cc54279b70fcb9891b0f1 Mon Sep 17 00:00:00 2001 From: GH Actions Date: Tue, 31 Mar 2026 08:50:25 +0000 Subject: [PATCH 44/44] Apply patch from /run fantomas --- src/Compiler/CodeGen/IlxGen.fs | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 55ee8110e11..23850b6322c 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -7803,8 +7803,7 @@ and GenDecisionTreeSwitch let avoidHelpers = entityRefInThisAssembly g.compilingFSharpCore c.TyconRef let access = computeDataAccess avoidHelpers cuspec - let tester = - Some(pop 1, Push [ g.ilg.typ_Bool ], Choice1Of2(access, cuspec, idx)) + let tester = Some(pop 1, Push [ g.ilg.typ_Bool ], Choice1Of2(access, cuspec, idx)) GenDecisionTreeTest cenv @@ -8117,8 +8116,7 @@ and GenDecisionTreeTest match tester with | Some(pops, pushes, i) -> match i with - | Choice1Of2(access, cuspec, idx) -> - CG.EmitInstrs cgbuf pops pushes (mkIsData g.ilg (access, cuspec, idx)) + | Choice1Of2(access, cuspec, idx) -> CG.EmitInstrs cgbuf pops pushes (mkIsData g.ilg (access, cuspec, idx)) | Choice2Of2 i -> CG.EmitInstr cgbuf pops pushes i | _ -> () @@ -8212,12 +8210,7 @@ and GenDecisionTreeTest | Some(_, _, Choice1Of2(access, cuspec, idx)) -> let failure = CG.GenerateDelayMark cgbuf "testFailure" - GenExpr - cenv - cgbuf - eenv - e - (CmpThenBrOrContinue(pop 1, mkBrIsData g.ilg false (access, cuspec, idx, failure.CodeLabel))) + GenExpr cenv cgbuf eenv e (CmpThenBrOrContinue(pop 1, mkBrIsData g.ilg false (access, cuspec, idx, failure.CodeLabel))) GenDecisionTreeAndTargetsInner cenv @@ -8249,8 +8242,7 @@ and GenDecisionTreeTest GenExpr cenv cgbuf eenv e Continue match i with - | Choice1Of2(access, cuspec, idx) -> - CG.EmitInstrs cgbuf pops pushes (mkIsData g.ilg (access, cuspec, idx)) + | Choice1Of2(access, cuspec, idx) -> CG.EmitInstrs cgbuf pops pushes (mkIsData g.ilg (access, cuspec, idx)) | Choice2Of2 i -> CG.EmitInstr cgbuf pops pushes i CG.EmitInstr cgbuf (pop 1) Push0 (I_brcmp(BI_brfalse, failure.CodeLabel))