Skip to content

Commit

Permalink
[<Struct>] DUs - eliminate dummy .ctor args, fix bug > 49 cases, simp…
Browse files Browse the repository at this point in the history 
…lify IL (dotnet#15695)

* Change construction methods for [<Struct>] unions to enable creating > 49 of cases, simplify IL
  • Loading branch information
@T-Gro
T-Gro authored Sep 8, 2023
1 parent 4dd0341 commit 17c439e
Show file tree
Hide file tree
Showing 4 changed files with 493 additions and 409 deletions.
193 changes: 95 additions & 98 deletions src/Compiler/CodeGen/EraseUnions.fs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -278,6 +278,9 @@ let mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy afte
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"
Expand Down Expand Up @@ -334,29 +337,6 @@ let mkTagDiscriminate ilg cuspec _baseTy cidx =
let mkTagDiscriminateThen ilg cuspec cidx after =
[ mkGetTag ilg cuspec; mkLdcInt32 cidx ] @ mkCeqThen after

/// The compilation for struct unions relies on generating a set of constructors.
/// If necessary some fake types are added to the constructor parameters to distinguish the signature.
let rec extraTysAndInstrsForStructCtor (ilg: ILGlobals) cidx =
match cidx with
| 0 -> [ ilg.typ_Bool ], [ mkLdcInt32 0 ]
| 1 -> [ ilg.typ_Byte ], [ mkLdcInt32 0 ]
| 2 -> [ ilg.typ_SByte ], [ mkLdcInt32 0 ]
| 3 -> [ ilg.typ_Char ], [ mkLdcInt32 0 ]
| 4 -> [ ilg.typ_Int16 ], [ mkLdcInt32 0 ]
| 5 -> [ ilg.typ_Int32 ], [ mkLdcInt32 0 ]
| 6 -> [ ilg.typ_UInt16 ], [ mkLdcInt32 0 ]
| _ ->
let tys, instrs = extraTysAndInstrsForStructCtor ilg (cidx - 7)
(ilg.typ_UInt32 :: tys, mkLdcInt32 0 :: instrs)

let takesExtraParams (alts: IlxUnionCase[]) =
alts.Length > 1
&& (alts |> Array.exists (fun d -> d.FieldDefs.Length > 0)
||
// Check if not all lengths are distinct
alts |> Array.countBy (fun d -> d.FieldDefs.Length) |> Array.length
<> alts.Length)

let convNewDataInstrInternal ilg cuspec cidx =
let alt = altOfUnionSpec cuspec cidx
let altTy = tyForAlt cuspec alt
Expand All @@ -379,27 +359,15 @@ let convNewDataInstrInternal ilg cuspec cidx =

instrs
@ [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, (ctorFieldTys @ tagfields))) ]
elif cuspecRepr.RepresentAlternativeAsStructValue cuspec then
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 instrs, tagfields =
match cuspecRepr.DiscriminationTechnique cuspec with
| IntegerTag -> [ mkLdcInt32 cidx ], [ mkTagFieldType ilg cuspec ]
| _ -> [], []

let ctorFieldTys = alt.FieldTypes |> Array.toList

let extraTys, extraInstrs =
if takesExtraParams cuspec.AlternativesArray then
extraTysAndInstrsForStructCtor ilg cidx
else
[], []

instrs
@ extraInstrs
@ [
mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, (ctorFieldTys @ tagfields @ extraTys)))
]
let tagField = [ mkTagFieldType ilg cuspec ]
[ mkLdcInt32 cidx; mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, tagField)) ]
else
[ mkNormalNewobj (mkILCtorMethSpecForTy (altTy, Array.toList alt.FieldTypes)) ]

Expand All @@ -414,6 +382,24 @@ 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
Expand All @@ -422,30 +408,13 @@ let mkNewData ilg (cuspec, cidx) =
if cuspecRepr.RepresentAlternativeAsNull(cuspec, alt) then
[ AI_ldnull ]
elif alt.IsNullary then
[
mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "get_" + altName, [], constFormalFieldTy baseTy))
]
viaGetAltNameProperty ()
else
[
mkNormalCall (
mkILNonGenericStaticMethSpecInTy (
baseTy,
mkMakerName cuspec altName,
Array.toList alt.FieldTypes,
constFormalFieldTy baseTy
)
)
]
viaMakerCall ()

| NoHelpers ->
if cuspecRepr.MaintainPossiblyUniqueConstantFieldForAlternative(cuspec, alt) then
// This method is only available if not AllHelpers. It fetches the unique object for the alternative
// without exposing direct access to the underlying field
[
mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "get_" + altName, [], constFormalFieldTy baseTy))
]
else
convNewDataInstrInternal ilg cuspec cidx
| NoHelpers when (not alt.IsNullary) && cuspecRepr.RepresentAlternativeAsStructValue cuspec -> viaMakerCall ()
| NoHelpers when cuspecRepr.MaintainPossiblyUniqueConstantFieldForAlternative(cuspec, alt) -> viaGetAltNameProperty ()
| NoHelpers -> convNewDataInstrInternal ilg cuspec cidx

let mkIsData ilg (avoidHelpers, cuspec, cidx) =
let alt = altOfUnionSpec cuspec cidx
Expand Down Expand Up @@ -916,13 +885,36 @@ let convAlternativeDef
[ nullaryMeth ], [ nullaryProp ]

else
let ilInstrs =
[
for i in 0 .. fields.Length - 1 do
mkLdarg (uint16 i)
yield! convNewDataInstrInternal g.ilg cuspec num
]
|> nonBranchingInstrsToCode
let locals, ilInstrs =
if repr.RepresentAlternativeAsStructValue info then
let local = mkILLocal baseTy None
let ldloca = I_ldloca(0us)

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 (
Expand All @@ -932,7 +924,7 @@ let convAlternativeDef
|> Array.map (fun fd -> mkILParamNamed (fd.LowerName, fd.Type))
|> Array.toList,
mkILReturn baseTy,
mkMethodBody (true, [], fields.Length, ilInstrs, attr, imports)
mkMethodBody (true, locals, fields.Length + locals.Length, nonBranchingInstrsToCode ilInstrs, attr, imports)
)
|> addMethodGeneratedAttrs
|> addAltAttribs
Expand Down Expand Up @@ -1219,9 +1211,20 @@ let mkClassUnionDef

let isStruct = td.IsStruct

let ctorAccess =
if cuspec.HasHelpers = AllHelpers then
ILMemberAccess.Assembly
else
cud.UnionCasesAccessibility

let selfFields, selfMeths, selfProps =

[
let minNullaryIdx =
cud.UnionCases
|> Array.tryFindIndex (fun t -> t.IsNullary)
|> Option.defaultValue -1

for cidx, alt in Array.indexed cud.UnionCases do
if
repr.RepresentAlternativeAsFreshInstancesOfRootClass(info, alt)
Expand All @@ -1238,31 +1241,25 @@ let mkClassUnionDef
| None -> Some g.ilg.typ_Object.TypeSpec
| Some ilTy -> Some ilTy.TypeSpec

let extraParamsForCtor =
if isStruct && takesExtraParams cud.UnionCases then
let extraTys, _extraInstrs = extraTysAndInstrsForStructCtor g.ilg cidx
List.map mkILParamAnon extraTys
else
[]

let ctorAccess =
(if cuspec.HasHelpers = AllHelpers then
ILMemberAccess.Assembly
else
cud.UnionCasesAccessibility)

let ctor =
(mkILSimpleStorageCtor (
baseInit,
baseTy,
extraParamsForCtor,
(fields @ tagFieldsInObject),
ctorAccess,
cud.DebugPoint,
cud.DebugImports
))
.With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ])
|> addMethodGeneratedAttrs
// 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
[
(mkILSimpleStorageCtor (
baseInit,
baseTy,
[],
(fields @ tagFieldsInObject),
ctorAccess,
cud.DebugPoint,
cud.DebugImports
))
.With(customAttrs = mkILCustomAttrs [ GetDynamicDependencyAttribute g 0x660 baseTy ])
|> addMethodGeneratedAttrs
]

let props, meths =
mkMethodsAndPropertiesForFields
Expand All @@ -1274,7 +1271,7 @@ let mkClassUnionDef
baseTy
alt.FieldDefs

yield (fields, ([ ctor ] @ meths), props)
yield (fields, (ctor @ meths), props)
]
|> List.unzip3
|> (fun (a, b, c) -> List.concat a, List.concat b, List.concat c)
Expand Down
Loading

0 comments on commit 17c439e

Please sign in to comment.