diff --git a/src/Compiler/CodeGen/EraseUnions.Emit.fs b/src/Compiler/CodeGen/EraseUnions.Emit.fs new file mode 100644 index 0000000000..5e83590f6d --- /dev/null +++ b/src/Compiler/CodeGen/EraseUnions.Emit.fs @@ -0,0 +1,445 @@ +// 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)) + +let mkSetTagToField ilg _cuspec baseTy = + mkNormalStfld (refToFieldInTy baseTy (mkTagFieldId ilg)) + +let adjustFieldNameForTypeDef hasHelpers nm = + match hasHelpers with + | SpecialFSharpListHelpers -> adjustFieldNameForList nm + | _ -> nm + +let adjustFieldName access nm = + match access with + | DataAccess.ViaListHelpers -> adjustFieldNameForList nm + | _ -> 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)) + | _ -> mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldType ilg)) + +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 + 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 + [ 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 + | DataAccess.ViaOptionHelpers -> + + 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 0000000000..980b8b6954 --- /dev/null +++ b/src/Compiler/CodeGen/EraseUnions.Types.fs @@ -0,0 +1,384 @@ +// 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 (9 cases) — how the union TYPE is structured in IL +// Computed once per union via classifyFromSpec / classifyFromDef. +// +// 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? +// +// 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 + | 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) = + if avoidHelpers then + DataAccess.RawFields + else + match cuspec.HasHelpers with + | IlxUnionHasHelpers.NoHelpers -> DataAccess.RawFields + | IlxUnionHasHelpers.AllHelpers -> DataAccess.ViaHelpers + | IlxUnionHasHelpers.SpecialFSharpOptionHelpers -> DataAccess.ViaOptionHelpers + | 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) + +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 + +/// 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.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) = ilg.typ_Int32 + +let mkTagFieldId ilg = "_tag", mkTagFieldType ilg + +let altOfUnionSpec (cuspec: IlxUnionSpec) cidx = + 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. +[] +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 ef47028b25..7a8f2bb9b2 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,684 +14,115 @@ open FSharp.Compiler.TcGlobals open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types -[] -let TagNil = 0 - -[] -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 - -// 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 Definition Generation for F# Discriminated Unions // -// type Tree = Tip | Node of int * Tree * Tree +// Entry point: mkClassUnionDef (bottom of file, F# requires definitions before use) // -// 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. +// 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 // -// 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 - -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 - -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) - ) - -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 - -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 alt = - cuspecRepr.TypeForAlternative(cuspec, alt) - -let GetILTypeForAlternative cuspec alt = - cuspecRepr.TypeForAlternative(cuspec, cuspec.Alternative 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 = - try - cuspec.Alternative cidx - with _ -> - failwith ("alternative " + string cidx + " not found") - -// 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 - -let mkRuntimeTypeDiscriminate (ilg: ILGlobals) avoidHelpers cuspec alt altName altTy = - let useHelper = doesRuntimeTypeDiscriminateUseHelper avoidHelpers cuspec alt - - if useHelper 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 avoidHelpers cuspec alt altName altTy after = - let useHelper = doesRuntimeTypeDiscriminateUseHelper avoidHelpers cuspec 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 ] - -let mkGetTagFromField ilg cuspec baseTy = - mkNormalLdfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) - -let mkSetTagToField ilg cuspec baseTy = - mkNormalStfld (refToFieldInTy baseTy (mkTagFieldId ilg cuspec)) - -let adjustFieldName hasHelpers nm = - match hasHelpers, nm with - | SpecialFSharpListHelpers, "Head" -> "HeadOrDefault" - | SpecialFSharpListHelpers, "Tail" -> "TailOrNull" - | _ -> nm - -let mkLdData (avoidHelpers, cuspec, cidx, fidx) = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt - 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) - ) - -let mkLdDataAddr (avoidHelpers, cuspec, cidx, fidx) = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt - 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) - -let mkGetTailOrNull avoidHelpers cuspec = - mkLdData (avoidHelpers, cuspec, 1, 1) (* tail is in alternative 1, field number 1 *) - -let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = - let baseTy = baseTyOfUnionSpec cuspec - - if cuspecRepr.RepresentOneAlternativeAsNull cuspec then - mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [ baseTy ], mkTagFieldFormalType ilg cuspec)) - else - mkNormalCall (mkILNonGenericInstanceMethSpecInTy (baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType 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 convNewDataInstrInternal ilg cuspec cidx = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt - let altName = alt.Name - - if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then - [ 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 - - 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)) ] - -// 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 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 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 -> - if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then - [ AI_ldnull ] - elif alt.IsNullary then - viaGetAltNameProperty () - else - viaMakerCall () - - | 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) = - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt - let altName = alt.Name - - if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then - [ 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 cidx with - | TagNil -> [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_ceq ] - | TagCons -> [ mkGetTailOrNull avoidHelpers cuspec; AI_ldnull; AI_cgt_un ] - | _ -> failwith "mkIsData - unexpected" - -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" - } +// 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 = { - Labels = lab2pc - Instrs = instrs.ToArray() - Exceptions = [] - Locals = [] + stampMethodAsGenerated: ILMethodDef -> ILMethodDef + stampPropertyAsGenerated: ILPropertyDef -> ILPropertyDef + stampPropertyAsNever: ILPropertyDef -> ILPropertyDef + stampFieldAsGenerated: ILFieldDef -> ILFieldDef + stampFieldAsNever: ILFieldDef -> ILFieldDef + mkDebuggerTypeProxyAttr: ILType -> ILAttribute } -let mkBrIsData ilg sense (avoidHelpers, cuspec, 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 - [ 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 cidx with - | TagNil -> [ mkGetTailOrNull avoidHelpers cuspec; I_brcmp(neg, tg) ] - | TagCons -> [ mkGetTailOrNull avoidHelpers cuspec; I_brcmp(pos, tg) ] - | _ -> failwith "mkBrIsData - unexpected" - -let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec: IlxUnionSpec) = - // If helpers exist, use them - match cuspec.HasHelpers with - | SpecialFSharpListHelpers - | AllHelpers when not avoidHelpers -> - ldOpt |> Option.iter cg.EmitInstr - cg.EmitInstr(mkGetTagFromHelpers ilg cuspec) - | _ -> - - let alts = cuspec.Alternatives - - match cuspecRepr.DiscriminationTechnique cuspec with - | TailOrNull -> - // 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 - ldOpt |> Option.iter cg.EmitInstr - cg.EmitInstr(mkGetTagFromField ilg cuspec baseTy) - | SingleCase -> - ldOpt |> Option.iter cg.EmitInstr - cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] - | RuntimeTypes -> - let baseTy = baseTyOfUnionSpec cuspec - - 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 - - let outlab = cg.GenerateDelayMark() - - let emitCase cidx = - let alt = altOfUnionSpec cuspec cidx - let internalLab = cg.GenerateDelayMark() - let failLab = cg.GenerateDelayMark() - let cmpNull = cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) - - let test = - I_brcmp((if cmpNull then BI_brtrue else BI_brfalse), cg.CodeLabel failLab) - - let testBlock = - if - cmpNull - || cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass(cuspec, alt) - then - [ test ] - else - let altName = alt.Name - let altTy = tyForAlt cuspec alt - mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy test - - cg.EmitInstrs(ld :: testBlock) - cg.SetMarkToHere internalLab - cg.EmitInstrs [ mkLdcInt32 cidx; I_br(cg.CodeLabel outlab) ] - cg.SetMarkToHere failLab - - // Make the blocks for the remaining tests. - 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>) (avoidHelpers, cuspec: IlxUnionSpec) = - emitLdDataTagPrim ilg None cg (avoidHelpers, cuspec) - -let emitCastData ilg (cg: ICodeGen<'Mark>) (canfail, avoidHelpers, cuspec, cidx) = - let alt = altOfUnionSpec cuspec cidx - - if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then - 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 - else - // If it can't fail, it's still verifiable just to leave the value on the stack unchecked - () - 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 - () - elif cuspecRepr.OptimizeAlternativeToRootClass(cuspec, alt) then - () - else - let altTy = tyForAlt cuspec alt - cg.EmitInstr(I_castclass altTy) - -let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = - let baseTy = baseTyOfUnionSpec cuspec - - match cuspecRepr.DiscriminationTechnique cuspec with - | RuntimeTypes -> - let locn = cg.GenLocal baseTy - - cg.EmitInstr(mkStloc locn) - - for cidx, tg in cases do - let alt = altOfUnionSpec cuspec cidx - let altTy = tyForAlt cuspec alt - let altName = alt.Name - let failLab = cg.GenerateDelayMark() - let cmpNull = cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) - - cg.EmitInstr(mkLdloc locn) - let testInstr = I_brcmp((if cmpNull then BI_brfalse else BI_brtrue), tg) - - if - cmpNull - || cuspecRepr.RepresentAlternativeAsFreshInstancesOfRootClass(cuspec, alt) - then - cg.EmitInstr testInstr - else - cg.EmitInstrs(mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy testInstr) - - cg.SetMarkToHere failLab - - | IntegerTag -> - 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 - dict[i] <- case - - let failLab = cg.GenerateDelayMark() +/// 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 + } - let emitCase i _ = - match dict.TryGetValue i with - | true, res -> res - | _ -> cg.CodeLabel failLab +/// Information about a nullary case's singleton static field. +type NullaryConstFieldInfo = + { + Case: IlxUnionCase + CaseType: ILType + CaseIndex: int + Field: ILFieldDef + InRootClass: bool + } - let dests = Array.mapi emitCase cuspec.AlternativesArray - cg.EmitInstr(mkGetTag ilg cuspec) - cg.EmitInstr(I_switch(Array.toList dests)) - cg.SetMarkToHere failLab +/// 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 + } - | SingleCase -> - 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" +/// DynamicallyAccessedMemberTypes flags for [DynamicDependency] on case ctors +[] +let private DynamicDependencyPublicMembers = 0x660 - | TailOrNull -> failwith "unexpected: switches on lists should have been eliminated to brisdata tests" +/// DynamicallyAccessedMemberTypes flags for [DynamicDependency] on base ctor +[] +let private DynamicDependencyAllCtorsAndPublicMembers = 0x7E0 //--------------------------------------------------- // Generate the union classes -let mkMethodsAndPropertiesForFields - (addMethodGeneratedAttrs, addPropertyGeneratedAttrs) - (g: TcGlobals) - access - attr - imports - hasHelpers - (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 + 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 -> ILPropertyDef( - name = adjustFieldName hasHelpers field.Name, + name = adjustFieldNameForTypeDef hasHelpers field.Name, attributes = PropertyAttributes.None, setMethod = None, getMethod = @@ -699,7 +130,7 @@ let mkMethodsAndPropertiesForFields mkILMethRef ( ilTy.TypeRef, ILCallingConv.Instance, - "get_" + adjustFieldName hasHelpers field.Name, + "get_" + adjustFieldNameForTypeDef hasHelpers field.Name, 0, [], field.Type @@ -728,7 +159,7 @@ let mkMethodsAndPropertiesForFields yield mkILNonGenericInstanceMethod ( - "get_" + adjustFieldName hasHelpers field.Name, + "get_" + adjustFieldNameForTypeDef hasHelpers field.Name, access, [], ilReturn, @@ -740,580 +171,572 @@ let mkMethodsAndPropertiesForFields basicProps, basicMethods -let convAlternativeDef - ( - addMethodGeneratedAttrs, - addPropertyGeneratedAttrs, - addPropertyNeverAttrs, - addFieldGeneratedAttrs, - addFieldNeverAttrs, - mkDebuggerTypeProxyAttribute - ) - (g: TcGlobals) - num - (td: ILTypeDef) - (cud: IlxUnionInfo) - info - cuspec - (baseTy: ILType) - (alt: IlxUnionCase) - = - +/// Generate a debug proxy type for a union alternative. +/// Returns (debugProxyTypeDefs, debugProxyAttrs). +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 attr = cud.DebugPoint - let altName = alt.Name - let fields = alt.FieldDefs - let altTy = tyForAlt cuspec alt - let repr = cudefRepr - // Attributes on unions get attached to the construction methods in the helpers - let addAltAttribs (mdef: ILMethodDef) = - mdef.With(customAttrs = alt.altCustomAttrs) + let debugProxyTypeName = altTy.TypeSpec.Name + "@DebugTypeProxy" - // 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 debugProxyTy = + mkILBoxedTy (mkILNestedTyRef (altTy.TypeSpec.Scope, altTy.TypeSpec.Enclosing, debugProxyTypeName)) altTy.GenericArgs - let makeNonNullaryMakerMethod () = - let locals, ilInstrs = - if repr.RepresentAlternativeAsStructValue info then - let local = mkILLocal baseTy None - let ldloca = I_ldloca(0us) + let debugProxyFieldName = "_obj" - 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, - 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) + let debugProxyFields = + [ + mkILInstanceField (debugProxyFieldName, altTy, None, ILMemberAccess.Assembly) + |> ctx.stamping.stampFieldAsNever + |> ctx.stamping.stampFieldAsGenerated + ] + + 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 DynamicDependencyPublicMembers baseTy ]) + |> ctx.stamping.stampMethodAsGenerated + + 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) + |> ctx.stamping.stampMethodAsGenerated) + |> 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 ) - |> addAltAttribs - |> addMethodGeneratedAttrs + |> ctx.stamping.stampPropertyAsGenerated) + |> Array.toList - mdef + 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 + ) - let altUniqObjMeths = + [ debugProxyTypeDef.WithSpecialName(true) ], + ([ ctx.stamping.mkDebuggerTypeProxyAttr debugProxyTy ] + @ cud.DebugDisplayAttributes) - // 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, - [], - fields.Length, - nonBranchingInstrsToCode [ I_ldsfld(Nonvolatile, mkConstFieldSpec altName baseTy) ], - attr, - imports - ) - ) - |> addMethodGeneratedAttrs +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 altName = alt.Name + let imports = cud.DebugImports + let attr = cud.DebugPoint - [ meth ] + let locals, ilInstrs = + match ctx.layout with + | ValueTypeLayout -> + let local = mkILLocal baseTy None + let ldloca = I_ldloca(0us) - else - [] + let ilInstrs = + [ + ldloca + ILInstr.I_initobj baseTy + 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) + mkNormalStfld (mkILFieldSpecInTy (baseTy, fields[i].LowerName, fields[i].Type)) + mkLdloc 0us + ] - let baseMakerMeths, baseMakerProps = + [ local ], ilInstrs + | ReferenceTypeLayout -> + let ilInstrs = + [ + for i in 0 .. fields.Length - 1 do + mkLdarg (uint16 i) + yield! emitRawNewData g.ilg cuspec num + ] - match cud.HasHelpers with - | AllHelpers - | SpecialFSharpOptionHelpers - | SpecialFSharpListHelpers -> + [], ilInstrs - let baseTesterMeths, baseTesterProps = - if cud.UnionCases.Length <= 1 then - [], [] - elif repr.RepresentOneAlternativeAsNull info then - [], [] + 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.stamping.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 altName = alt.Name + let imports = cud.DebugImports + let attr = cud.DebugPoint + + // No tester needed for single-case unions or null-discriminated (SmallRefWithNullAsTrueValue) + match ctx.layout with + | UnionLayout.SingleCaseRef _ + | UnionLayout.SingleCaseStruct _ + | UnionLayout.SmallRefWithNullAsTrueValue _ -> [], [] + | _ -> + let additionalAttributes = + match ctx.layout with + | 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 + // 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 - 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 |] + mkILCustomAttrsFromArray [| GetNotNullWhenTrueAttribute g fieldNames |] + | _ -> emptyILCustomAttrs - else - emptyILCustomAttrs + [ + (mkILNonGenericInstanceMethod ( + "get_" + mkTesterName altName, + cud.HelpersAccessibility, + [], + mkILReturn g.ilg.typ_Bool, + mkMethodBody ( + true, + [], + 2, + nonBranchingInstrsToCode ([ mkLdarg0 ] @ mkIsData g.ilg (DataAccess.RawFields, cuspec, num)), + attr, + imports + ) + )) + .With(customAttrs = additionalAttributes) + |> ctx.stamping.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 + ) + |> ctx.stamping.stampPropertyAsGenerated + |> ctx.stamping.stampPropertyAsNever + ] - [ - (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 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 altName = alt.Name + let fields = alt.FieldDefs + let imports = cud.DebugImports + let attr = cud.DebugPoint - let baseMakerMeths, baseMakerProps = + let attributes = + match ctx.layout, num with + | CaseIsNull when nullnessCheckingEnabled g -> + let noTypars = td.GenericParams.Length - 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 - else - emptyILCustomAttrs + 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 + | _ -> emptyILCustomAttrs + + let nullaryMeth = + mkILNonGenericStaticMethod ( + "get_" + altName, + cud.HelpersAccessibility, + [], + (mkILReturn baseTy).WithCustomAttrs attributes, + mkMethodBody (true, [], fields.Length, nonBranchingInstrsToCode (emitRawNewData g.ilg cuspec num), attr, imports) + ) + |> (fun mdef -> mdef.With(customAttrs = alt.altCustomAttrs)) + |> ctx.stamping.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.stamping.stampPropertyAsGenerated + |> ctx.stamping.stampPropertyAsNever - 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 + [ nullaryMeth ], [ nullaryProp ] + +let private emitConstantAccessor (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = + let cud = ctx.cud + let baseTy = ctx.baseTy + let altName = alt.Name + let fields = alt.FieldDefs + let imports = cud.DebugImports + let attr = cud.DebugPoint - [ nullaryMeth ], [ nullaryProp ] + // 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 && needsSingletonField ctx.layout alt num then + let methName = "get_" + altName + + let meth = + mkILNonGenericStaticMethod ( + methName, + cud.UnionCasesAccessibility, + [], + mkILReturn baseTy, + mkMethodBody ( + true, + [], + fields.Length, + nonBranchingInstrsToCode [ I_ldsfld(Nonvolatile, mkConstFieldSpec altName baseTy) ], + attr, + imports + ) + ) + |> ctx.stamping.stampMethodAsGenerated + + [ meth ] - else - [ makeNonNullaryMakerMethod () ], [] - - (baseMakerMeths @ baseTesterMeths), (baseMakerProps @ baseTesterProps) - - | NoHelpers when not alt.IsNullary && cuspecRepr.RepresentAlternativeAsStructValue(cuspec) -> - // For non-nullary struct DUs, maker method is used to create their values. - [ makeNonNullaryMakerMethod () ], [] - | NoHelpers -> [], [] - - let typeDefs, altDebugTypeDefs, altNullaryFields = - if repr.RepresentAlternativeAsNull(info, alt) then - [], [], [] - elif repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt) then - [], [], [] - 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 typeDefs, altDebugTypeDefs = - if repr.OptimizeAlternativeToRootClass(info, alt) then - [], [] - else +let private emitNullaryConstField (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = + let cud = ctx.cud + let baseTy = ctx.baseTy + let cuspec = ctx.cuspec + let altName = alt.Name + let altTy = tyForAltIdxWith ctx.layout ctx.baseTy cuspec alt num - let altDebugTypeDefs, debugAttrs = - if not cud.GenerateDebugProxies then - [], [] - else + if needsSingletonField ctx.layout alt num then + let basic: ILFieldDef = + mkILStaticField (constFieldName altName, baseTy, None, None, ILMemberAccess.Assembly) + |> ctx.stamping.stampFieldAsNever + |> ctx.stamping.stampFieldAsGenerated - 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 - ) + let uniqObjField = basic.WithInitOnly(true) + let inRootClass = caseRepresentedOnRoot ctx.layout alt cud.UnionCases num - [ debugProxyTypeDef.WithSpecialName(true) ], - ([ mkDebuggerTypeProxyAttribute debugProxyTy ] @ cud.DebugDisplayAttributes) + [ + { + Case = alt + CaseType = altTy + CaseIndex = num + Field = uniqObjField + InRootClass = 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 altTy = tyForAltIdxWith ctx.layout ctx.baseTy cuspec alt num + let fields = alt.FieldDefs + let imports = cud.DebugImports + let attr = cud.DebugPoint + let isTotallyImmutable = (cud.HasHelpers <> SpecialFSharpListHelpers) - let altTypeDef = - let basicFields = - fields - |> Array.map (fun field -> - let fldName, fldTy, attrs = mkUnionCaseFieldIdAndAttrs g field - let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Assembly) + if caseRepresentedOnRoot ctx.layout alt cud.UnionCases num then + [], [] + else + let altDebugTypeDefs, debugAttrs = + if not cud.GenerateDebugProxies then + [], [] + else + emitDebugProxyType ctx altTy fields - let fdef = - match attrs with - | [] -> fdef - | attrs -> fdef.With(customAttrs = mkILCustomAttrs attrs) + let altTypeDef = + let basicFields = + fields + |> Array.map (fun field -> + let fldName, fldTy, attrs = mkUnionCaseFieldIdAndAttrs g field + let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Assembly) - |> addFieldNeverAttrs - |> addFieldGeneratedAttrs + let fdef = + match attrs with + | [] -> fdef + | attrs -> fdef.With(customAttrs = mkILCustomAttrs attrs) - fdef.WithInitOnly(isTotallyImmutable)) + |> ctx.stamping.stampFieldAsNever + |> ctx.stamping.stampFieldAsGenerated - |> Array.toList + fdef.WithInitOnly(isTotallyImmutable)) - let basicProps, basicMethods = - mkMethodsAndPropertiesForFields - (addMethodGeneratedAttrs, addPropertyGeneratedAttrs) - g - cud.UnionCasesAccessibility - attr - imports - cud.HasHelpers - altTy - fields + |> Array.toList - 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 basicProps, basicMethods = mkMethodsAndPropertiesForFields ctx altTy fields - 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 - ) + let basicCtorInstrs = + [ + yield mkLdarg0 - altTypeDef.WithSpecialName(true).WithSerializable(td.IsSerializable) + match ctx.layout with + | HasTagField -> + yield mkLdcInt32 num + yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [ mkTagFieldType g.ilg ])) + | NoTagField -> yield mkNormalCall (mkILCtorMethSpecForTy (baseTy, [])) + ] - [ altTypeDef ], altDebugTypeDefs + 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 DynamicDependencyPublicMembers baseTy ]) + |> ctx.stamping.stampMethodAsGenerated + + let attrs = + if nullnessCheckingEnabled g 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 + ) - typeDefs, altDebugTypeDefs, altNullaryFields + altTypeDef.WithSpecialName(true).WithSerializable(td.IsSerializable) - baseMakerMeths, baseMakerProps, altUniqObjMeths, typeDefs, altDebugTypeDefs, altNullaryFields + [ altTypeDef ], altDebugTypeDefs -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 private processAlternative (ctx: TypeDefContext) (num: int) (alt: IlxUnionCase) = + let cud = ctx.cud - let cuspec = - IlxUnionSpec(IlxUnionRef(boxity, baseTy.TypeRef, cud.UnionCases, cud.IsNullPermitted, cud.HasHelpers), baseTy.GenericArgs) + let constantAccessors = emitConstantAccessor ctx num alt - let info = (td, cud) - let repr = cudefRepr - let isTotallyImmutable = (cud.HasHelpers <> SpecialFSharpListHelpers) + let baseMakerMeths, baseMakerProps = + match cud.HasHelpers with + | AllHelpers + | SpecialFSharpOptionHelpers + | SpecialFSharpListHelpers -> + let testerMeths, testerProps = emitTesterMethodAndProperty ctx num alt - 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) + let makerMeths, makerProps = + if alt.IsNullary then + emitNullaryCaseAccessor ctx num alt + else + [ emitMakerMethod ctx num alt ], [] - let tagFieldsInObject = - match repr.DiscriminationTechnique info with - | SingleCase - | RuntimeTypes - | TailOrNull -> [] - | IntegerTag -> [ let n, t = mkTagFieldId g.ilg cuspec in n, t, [] ] + (makerMeths @ testerMeths), (makerProps @ testerProps) + | NoHelpers -> + match ctx.layout with + | ValueTypeLayout when not alt.IsNullary -> [ emitMakerMethod ctx num alt ], [] + | _ -> [], [] + + let typeDefs, debugTypeDefs, nullaryFields = + match classifyCaseStorage ctx.layout ctx.cuspec num alt with + | CaseStorage.Null -> [], [], [] + | CaseStorage.OnRoot -> [], [], [] + | CaseStorage.Singleton + | CaseStorage.InNestedType _ -> + let nullaryFields = emitNullaryConstField ctx num alt + let typeDefs, debugTypeDefs = emitNestedAlternativeType ctx num alt + typeDefs, debugTypeDefs, nullaryFields + + { + BaseMakerMethods = baseMakerMeths + BaseMakerProperties = baseMakerProps + ConstantAccessors = constantAccessors + NestedTypeDefs = typeDefs + DebugProxyTypeDefs = debugTypeDefs + 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. 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 _ + | UnionLayout.TaggedStructAllNullary _ when nullnessCheckingEnabled g -> + alt.FieldDefs + |> Array.map (fun field -> + if field.Type.IsNominal && field.Type.Boxity = AsValue then + field + else + let attrs = + rewriteNullableAttrForFlattenedField g (field.ILField.CustomAttrs.AsArray()) + + field.ILField.With(customAttrs = mkILCustomAttrsFromArray attrs) + |> IlxUnionCaseField) + | _ -> 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 && nullnessCheckingEnabled g then + td.CustomAttrs.AsArray() + |> Array.append [| GetNullableAttribute g [ NullnessInfo.WithNull ] |] + |> mkILCustomAttrsFromArray + |> storeILCustomAttrs + else + td.CustomAttrsStored + +/// 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 ctorAccess = @@ -1322,199 +745,148 @@ 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 + let fieldsEmitted = HashSet<_>() - [ - (mkILSimpleStorageCtor ( - baseInit, - baseTy, - [], - (fields @ tagFieldsInObject), - ctorAccess, - cud.DebugPoint, - cud.DebugImports - )) - .With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ]) - |> addMethodGeneratedAttrs - ] + for cidx, alt in Array.indexed cud.UnionCases do + let fieldsOnRoot = + match ctx.layout with + | ValueTypeLayout -> true + | ReferenceTypeLayout -> caseFieldsOnRoot ctx.layout alt cud.UnionCases - 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 + if fieldsOnRoot then - let fieldsToBeAddedIntoType = - fieldDefs - |> Array.filter (fun f -> fieldsEmitted.Add(struct (f.LowerName, f.Type))) + 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 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 + let fields = + alt.FieldDefs |> Array.map (mkUnionCaseFieldIdAndAttrs g) |> Array.toList - let fields = - fieldsToBeAddedIntoType - |> Array.map (mkUnionCaseFieldIdAndAttrs g) - |> Array.toList + [ + (mkILSimpleStorageCtor ( + baseInit, + baseTy, + [], + (fields @ tagFieldsInObject), + ctorAccess, + cud.DebugPoint, + cud.DebugImports + )) + .With( + customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g DynamicDependencyPublicMembers baseTy ] + ) + |> ctx.stamping.stampMethodAsGenerated + ] + + let fieldDefs = rewriteFieldsForStructFlattening g alt ctx.layout + + 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 baseTy fieldsToBeAddedIntoType + + yield (fields, (ctor @ meths), props) + ] + |> List.unzip3 + |> (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) rootCaseFields tagFieldsInObject rootCaseMethods = + let g = ctx.g + let td = ctx.td + let cud = ctx.cud + let baseTy = ctx.baseTy + + // 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 -> caseFieldsOnRoot ctx.layout alt cud.UnionCases) - let props, meths = - mkMethodsAndPropertiesForFields - (addMethodGeneratedAttrs, addPropertyGeneratedAttrs) - g - cud.UnionCasesAccessibility - cud.DebugPoint - cud.DebugImports - cud.HasHelpers - baseTy - fieldsToBeAddedIntoType + let onlyMethodsOnRoot = + List.isEmpty rootCaseFields + && List.isEmpty tagFieldsInObject + && not (List.isEmpty rootCaseMethods) - yield (fields, (ctor @ meths), props) - ] - |> List.unzip3 - |> (fun (a, b, c) -> List.concat a, List.concat b, List.concat c) + if td.IsStruct || allCasesFoldToRoot || onlyMethodsOnRoot then + [] + else + let baseTySpec = + (match td.Extends.Value with + | None -> g.ilg.typ_Object + | Some ilTy -> ilTy) + .TypeSpec - let selfAndTagFields = [ - for fldName, fldTy, attrs in (selfFields @ tagFieldsInObject) do - let fdef = - let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Assembly) - - match attrs with - | [] -> fdef - | attrs -> fdef.With(customAttrs = mkILCustomAttrs attrs) - - |> addFieldNeverAttrs - |> addFieldGeneratedAttrs - - yield fdef.WithInitOnly(not isStruct && isTotallyImmutable) + (mkILSimpleStorageCtor ( + Some baseTySpec, + baseTy, + [], + tagFieldsInObject, + ILMemberAccess.Assembly, + cud.DebugPoint, + cud.DebugImports + )) + .With( + customAttrs = + mkILCustomAttrs + [ + GetDynamicDependencyAttribute g DynamicDependencyAllCtorsAndPublicMembers baseTy + ] + ) + |> ctx.stamping.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 +/// Generate static constructor code to initialize nullary case singleton fields. +let private emitConstFieldInitializers (ctx: TypeDefContext) (altNullaryFields: NullaryConstFieldInfo list) = + let g = ctx.g + let cud = ctx.cud + let baseTy = ctx.baseTy - [] (* 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 - ] - - // Now initialize the constant fields wherever they are stored... - let addConstFieldInit cd = + fun (cd: ILTypeDef) -> if List.isEmpty altNullaryFields then cd else prependInstrsToClassCtor [ - for info, _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 repr.DiscriminationTechnique info with - | SingleCase - | RuntimeTypes - | TailOrNull -> yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy, [])) - | IntegerTag -> - if inRootClass then - yield mkLdcInt32 fidx - yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy, [ mkTagFieldType g.ilg cuspec ])) + match ctx.layout with + | NoTagField -> yield mkNormalNewobj (mkILCtorMethSpecForTy (r.CaseType, [])) + | HasTagField -> + if r.InRootClass then + yield mkLdcInt32 r.CaseIndex + yield mkNormalNewobj (mkILCtorMethSpecForTy (r.CaseType, [ mkTagFieldType g.ilg ])) else - yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy, [])) + yield mkNormalNewobj (mkILCtorMethSpecForTy (r.CaseType, [])) yield mkNormalStsfld constFieldSpec ] @@ -1522,101 +894,151 @@ 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 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 - 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 (DataAccess.RawFields, 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 + match ctx.layout with + | UnionLayout.SmallRefWithNullAsTrueValue _ -> + [ + mkILNonGenericStaticMethod ( + "Get" + tagPropertyName, + cud.HelpersAccessibility, + [ mkILParamAnon baseTy ], + mkILReturn tagFieldType, + body + ) + |> ctx.stamping.stampMethodAsGenerated + ], + [] - tagMeths, tagProps, tagEnumFields + | _ -> + [ + mkILNonGenericInstanceMethod ("get_" + tagPropertyName, cud.HelpersAccessibility, [], mkILReturn tagFieldType, body) + |> ctx.stamping.stampMethodAsGenerated + ], - // The class can be abstract if each alternative is represented by a derived type - let isAbstract = (altTypeDefs.Length = cud.UnionCases.Length) + [ + 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.stamping.stampPropertyAsGenerated + |> ctx.stamping.stampPropertyAsNever + ] - let existingMeths = td.Methods.AsList() - let existingProps = td.Properties.AsList() + tagMeths, tagProps, tagEnumFields - 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) +/// 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 (rootCaseFields @ tagFieldsInObject) do + let fdef = + let fdef = mkILInstanceField (fldName, fldTy, None, ILMemberAccess.Assembly) - Some tdef + match attrs with + | [] -> fdef + | attrs -> fdef.With(customAttrs = mkILCustomAttrs attrs) + + |> ctx.stamping.stampFieldAsNever + |> ctx.stamping.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 + rootCaseMethods + rootAndTagFields + tagMeths + tagProps + tagEnumFields + rootCaseProperties + = + 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 baseTypeDef = + 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 = td .WithInitSemantics(ILTypeInit.BeforeField) .With( @@ -1635,28 +1057,82 @@ let mkClassUnionDef mkILMethods ( ctorMeths @ baseMethsFromAlt - @ selfMeths + @ rootCaseMethods @ tagMeths @ altUniqObjMeths @ existingMeths ), fields = mkILFields ( - selfAndTagFields - @ List.map (fun (_, _, _, _, fdef, _) -> fdef) altNullaryFields + rootAndTagFields + @ List.map (fun r -> r.Field) altNullaryFields @ 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 + properties = mkILProperties (tagProps @ basePropsFromAlt @ rootCaseProperties @ 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 + stamping = + { + stampMethodAsGenerated = addMethodGeneratedAttrs + stampPropertyAsGenerated = addPropertyGeneratedAttrs + stampPropertyAsNever = addPropertyNeverAttrs + stampFieldAsGenerated = addFieldGeneratedAttrs + stampFieldAsNever = addFieldNeverAttrs + mkDebuggerTypeProxyAttr = mkDebuggerTypeProxyAttribute + } + } + + let results = + cud.UnionCases + |> Array.mapi (fun i alt -> processAlternative ctx i alt) + |> Array.toList + + let tagFieldsInObject = + match ctx.layout with + | HasTagField -> [ let n, t = mkTagFieldId g.ilg in n, t, [] ] + | NoTagField -> [] + + 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 rootCaseMethods rootAndTagFields tagMeths tagProps tagEnumFields rootCaseProperties diff --git a/src/Compiler/CodeGen/EraseUnions.fsi b/src/Compiler/CodeGen/EraseUnions.fsi index 9f69dd4a5c..a6a5956524 100644 --- a/src/Compiler/CodeGen/EraseUnions.fsi +++ b/src/Compiler/CodeGen/EraseUnions.fsi @@ -10,28 +10,6 @@ open FSharp.Compiler.AbstractIL.IL open FSharp.Compiler.AbstractIL.ILX.Types open FSharp.Compiler.TcGlobals -/// 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 - -/// Make the instruction for a "lddata" operation -val mkLdData: avoidHelpers: bool * 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 - -/// 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 -> - avoidHelpers: bool * cuspec: IlxUnionSpec * cidx: int * tg: ILCodeLabel -> - ILInstr list - /// Make the type definition for a union type val mkClassUnionDef: addMethodGeneratedAttrs: (ILMethodDef -> ILMethodDef) * @@ -45,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 * avoidHelpers: bool * cuspec: IlxUnionSpec * int -> unit - -/// Emit the instruction sequence for a "lddatatag" operation -val emitLdDataTag: ilg: ILGlobals -> cg: ICodeGen<'Mark> -> avoidHelpers: bool * 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 -> - unit diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 4e3452a2d8..23850b6322 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,9 +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 - EraseUnions.emitCastData g.ilg (UnionCodeGen cgbuf) (false, avoidHelpers, 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 @@ -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 = 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 = @@ -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 = 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 = @@ -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 = 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 @@ -3984,10 +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 - EraseUnions.emitCastData g.ilg (UnionCodeGen cgbuf) (false, avoidHelpers, 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 = @@ -7796,9 +7801,9 @@ 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 = computeDataAccess avoidHelpers cuspec - let tester = - Some(pop 1, Push [ g.ilg.typ_Bool ], Choice1Of2(avoidHelpers, cuspec, idx)) + let tester = Some(pop 1, Push [ g.ilg.typ_Bool ], Choice1Of2(access, cuspec, idx)) GenDecisionTreeTest cenv @@ -7915,7 +7920,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 = 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 @@ -8110,8 +8116,7 @@ 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 (mkIsData g.ilg (access, cuspec, idx)) | Choice2Of2 i -> CG.EmitInstr cgbuf pops pushes i | _ -> () @@ -8202,15 +8207,10 @@ 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 - cenv - cgbuf - eenv - e - (CmpThenBrOrContinue(pop 1, EraseUnions.mkBrIsData g.ilg false (avoidHelpers, cuspec, idx, failure.CodeLabel))) + GenExpr cenv cgbuf eenv e (CmpThenBrOrContinue(pop 1, mkBrIsData g.ilg false (access, cuspec, idx, failure.CodeLabel))) GenDecisionTreeAndTargetsInner cenv @@ -8242,8 +8242,7 @@ 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 (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 8a3782bcb3..17f4b2bab1 100644 --- a/src/Compiler/FSharp.Compiler.Service.fsproj +++ b/src/Compiler/FSharp.Compiler.Service.fsproj @@ -425,6 +425,8 @@ + +