fix multi case struct unions (#2811)

* fix multi case struct unions

* fix serialization of struct unions

* fix serialization of struct unions (2)

src/absil/il.fs

@@ -2616,9 +2616,9 @@ let emptyILMethodImpls =  mkILMethodImpls []
 // them in fields.  preblock is how to call the superclass constructor....
 // -------------------------------------------------------------------- 
 
-let mkILStorageCtorWithParamNames(tag,preblock,typ,flds,access) = 
+let mkILStorageCtorWithParamNames(tag,preblock,typ,extraParams,flds,access) = 
     mkILCtor(access,
-            flds |> List.map (fun (pnm,_,ty) -> mkILParamNamed (pnm,ty)),
+            (flds |> List.map (fun (pnm,_,ty) -> mkILParamNamed (pnm,ty))) @ extraParams,
             mkMethodBody
               (false,[],2,
                nonBranchingInstrsToCode
@@ -2632,22 +2632,22 @@ let mkILStorageCtorWithParamNames(tag,preblock,typ,flds,access) =
                      ])  flds)
                  end,tag))
     
-let mkILSimpleStorageCtorWithParamNames(tag,base_tspec,typ,flds,access) = 
+let mkILSimpleStorageCtorWithParamNames(tag,base_tspec,typ,extraParams,flds,access) = 
     let preblock = 
       match base_tspec with 
         None -> []
       | Some tspec -> 
           ([ mkLdarg0; 
              mkNormalCall (mkILCtorMethSpecForTy (mkILBoxedType tspec,[])) ])
-    mkILStorageCtorWithParamNames(tag,preblock,typ,flds,access)
+    mkILStorageCtorWithParamNames(tag,preblock,typ,extraParams,flds,access)
 
 let addParamNames flds = 
     flds |> List.map (fun (nm,ty) -> (nm,nm,ty))
 
-let mkILSimpleStorageCtor(tag,base_tspec,typ,flds,access) = 
-    mkILSimpleStorageCtorWithParamNames(tag,base_tspec,typ, addParamNames flds, access)
+let mkILSimpleStorageCtor(tag,base_tspec,typ,extraParams,flds,access) = 
+    mkILSimpleStorageCtorWithParamNames(tag,base_tspec,typ, extraParams, addParamNames flds, access)
 
-let mkILStorageCtor(tag,preblock,typ,flds,access) = mkILStorageCtorWithParamNames(tag,preblock,typ, addParamNames flds, access)
+let mkILStorageCtor(tag,preblock,typ,flds,access) = mkILStorageCtorWithParamNames(tag, preblock, typ, [], addParamNames flds, access)
 
 
 let mkILGenericClass (nm, access, genparams, extends, impl, methods, fields, nestedTypes, props, events, attrs, init) =

src/absil/il.fsi

@@ -1710,8 +1710,8 @@ val prependInstrsToClassCtor: ILInstr list -> ILSourceMarker option -> ILTypeDef
 
 /// Derived functions for making some simple constructors
 val mkILStorageCtor: ILSourceMarker option * ILInstr list * ILType * (string * ILType) list * ILMemberAccess -> ILMethodDef
-val mkILSimpleStorageCtor: ILSourceMarker option * ILTypeSpec option * ILType * (string * ILType) list * ILMemberAccess -> ILMethodDef
-val mkILSimpleStorageCtorWithParamNames: ILSourceMarker option * ILTypeSpec option * ILType * (string * string * ILType) list * ILMemberAccess -> ILMethodDef
+val mkILSimpleStorageCtor: ILSourceMarker option * ILTypeSpec option * ILType * ILParameter list * (string * ILType) list * ILMemberAccess -> ILMethodDef
+val mkILSimpleStorageCtorWithParamNames: ILSourceMarker option * ILTypeSpec option * ILType * ILParameter list * (string * string * ILType) list * ILMemberAccess -> ILMethodDef
 
 val mkILDelegateMethods: ILGlobals -> ILType * ILType -> ILParameter list * ILReturn -> ILMethodDef list
 

src/fsharp/IlxGen.fs

@@ -3646,7 +3646,7 @@ and GenSequenceExpr cenv (cgbuf:CodeGenBuffer) eenvouter (nextEnumeratorValRef:V
         |> AddNonUserCompilerGeneratedAttribs cenv.g
 
     let ilCtorBody = 
-        mkILSimpleStorageCtor(None, Some ilCloBaseTy.TypeSpec, ilCloTyInner, [], ILMemberAccess.Assembly).MethodBody
+        mkILSimpleStorageCtor(None, Some ilCloBaseTy.TypeSpec, ilCloTyInner, [], [], ILMemberAccess.Assembly).MethodBody
 
     let attrs = GenAttrs cenv eenvinner cloAttribs
     let cloTypeDefs = GenClosureTypeDefs cenv (ilCloTypeRef,ilCloGenericParams,attrs,ilCloFreeVars,ilCloLambdas,ilCtorBody,[generateNextMethod;closeMethod;checkCloseMethod;lastGeneratedMethod;getFreshMethod],[],ilCloBaseTy,[])
@@ -4095,7 +4095,7 @@ and GenDelegateExpr cenv cgbuf eenvouter expr (TObjExprMethod((TSlotSig(_,delega
              ilDelegeeParams, 
              ilDelegeeRet,
              MethodBody.IL ilMethodBody)
-    let delegeeCtorMeth = mkILSimpleStorageCtor(None, Some cenv.g.ilg.typ_Object.TypeSpec, ilDelegeeTyInner, [], ILMemberAccess.Assembly)
+    let delegeeCtorMeth = mkILSimpleStorageCtor(None, Some cenv.g.ilg.typ_Object.TypeSpec, ilDelegeeTyInner, [], [], ILMemberAccess.Assembly)
     let ilCtorBody = delegeeCtorMeth.MethodBody
 
     let ilCloLambdas = Lambdas_return ilCtxtDelTy
@@ -6453,14 +6453,14 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) =
 
                  // No type spec if the record is a value type
                  let spec = if isStructRecord then None else Some(cenv.g.ilg.typ_Object.TypeSpec)
-                 let ilMethodDef = mkILSimpleStorageCtorWithParamNames(None, spec, ilThisTy, ChooseParamNames fieldNamesAndTypes, reprAccess)
+                 let ilMethodDef = mkILSimpleStorageCtorWithParamNames(None, spec, ilThisTy, [], ChooseParamNames fieldNamesAndTypes, reprAccess)
 
                  yield ilMethodDef 
                  // FSharp 1.0 bug 1988: Explicitly setting the ComVisible(true)  attribute on an F# type causes an F# record to be emitted in a way that enables mutation for COM interop scenarios
                  // FSharp 3.0 feature: adding CLIMutable to a record type causes emit of default constructor, and all fields get property setters
                  // Records that are value types do not create a default constructor with CLIMutable or ComVisible
                  if not isStructRecord && (isCLIMutable || (TryFindFSharpBoolAttribute cenv.g cenv.g.attrib_ComVisibleAttribute tycon.Attribs = Some true)) then
-                     yield mkILSimpleStorageCtor(None, Some cenv.g.ilg.typ_Object.TypeSpec, ilThisTy, [], reprAccess) 
+                     yield mkILSimpleStorageCtor(None, Some cenv.g.ilg.typ_Object.TypeSpec, ilThisTy, [], [], reprAccess) 
                  
                  if not (tycon.HasMember cenv.g "ToString" []) then
                     yield! genToString ilThisTy
@@ -6626,9 +6626,14 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) =
                     cudDebugDisplayAttributes= ilDebugDisplayAttributes
                     cudAlternatives= alternatives
                     cudWhere = None}
+               let layout = 
+                   if isStructTy cenv.g thisTy then 
+                       ILTypeDefLayout.Sequential { Size=None; Pack=None } 
+                   else 
+                       ILTypeDefLayout.Auto
                let tdef = 
                    { Name = ilTypeName
-                     Layout = ILTypeDefLayout.Auto
+                     Layout =  layout
                      Access = access
                      GenericParams = ilGenParams
                      CustomAttrs = 
@@ -6725,13 +6730,13 @@ and GenExnDef cenv mgbuf eenv m (exnc:Tycon) =
              |> List.unzip4
 
         let ilCtorDef = 
-            mkILSimpleStorageCtorWithParamNames(None, Some cenv.g.iltyp_Exception.TypeSpec, ilThisTy, ChooseParamNames fieldNamesAndTypes, reprAccess) 
+            mkILSimpleStorageCtorWithParamNames(None, Some cenv.g.iltyp_Exception.TypeSpec, ilThisTy, [], ChooseParamNames fieldNamesAndTypes, reprAccess) 
 
         // In compiled code, all exception types get a parameterless constructor for use with XML serialization
         // This does default-initialization of all fields
         let ilCtorDefNoArgs = 
             if not (isNil fieldNamesAndTypes) then 
-                [ mkILSimpleStorageCtor(None, Some cenv.g.iltyp_Exception.TypeSpec, ilThisTy, [], reprAccess) ]
+                [ mkILSimpleStorageCtor(None, Some cenv.g.iltyp_Exception.TypeSpec, ilThisTy, [], [], reprAccess) ]
             else
                 []
 

src/ilx/EraseUnions.fs

@@ -107,12 +107,14 @@ type UnionReprDecisions<'Union,'Alt,'Type>
         // 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) = 
-        // Flattening
-        isStruct cu ||
-        // Check all nullary constructors are being represented without using sub-classes 
+       not (isStruct cu) && 
+       (// Check all nullary constructors are being represented without using sub-classes 
         (isList cu  && nameOfAlt alt = ALT_NAME_CONS) ||
-        repr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull (cu, alt) 
+        repr.RepresentSingleNonNullaryAlternativeAsInstancesOfRootClassAndAnyOtherAlternativesAsNull (cu, alt) )
 
     member repr.RepresentAlternativeAsConstantFieldInTaggedRootClass (cu,alt) = 
         not (isStruct cu) &&
@@ -130,6 +132,7 @@ type UnionReprDecisions<'Union,'Alt,'Type>
         repr.Flatten cu ||
         repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu ||
         repr.RepresentAlternativeAsConstantFieldInTaggedRootClass (cu,alt) ||
+        repr.RepresentAlternativeAsStructValue(cu) ||
         repr.RepresentAlternativeAsFreshInstancesOfRootClass(cu,alt)
       
     member repr.MaintainPossiblyUniqueConstantFieldForAlternative(cu,alt) = 
@@ -300,6 +303,21 @@ 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 convNewDataInstrInternal ilg cuspec cidx = 
     let alt = altOfUnionSpec cuspec cidx
     let altTy = tyForAlt cuspec alt
@@ -318,6 +336,19 @@ let convNewDataInstrInternal ilg cuspec cidx =
             | _ -> [], []
         let ctorFieldTys = alt.FieldTypes |> Array.toList
         instrs @ [ mkNormalNewobj(mkILCtorMethSpecForTy (baseTy,(ctorFieldTys @ tagfields))) ]
+    elif cuspecRepr.RepresentAlternativeAsStructValue cuspec 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
+        let extraTys, extraInstrs = 
+            if cuspec.AlternativesArray.Length > 1 && cuspec.AlternativesArray |> Array.exists (fun d -> d.FieldDefs.Length > 0) then
+                extraTysAndInstrsForStructCtor ilg cidx
+            else 
+                [], []
+        instrs @ extraInstrs @ [ mkNormalNewobj (mkILCtorMethSpecForTy (baseTy, (ctorFieldTys @ tagfields @ extraTys))) ]
     else 
         [ mkNormalNewobj(mkILCtorMethSpecForTy (altTy,Array.toList alt.FieldTypes)) ]
 
@@ -731,6 +762,7 @@ let convAlternativeDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addP
     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 
@@ -905,8 +937,9 @@ let mkClassUnionDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addProp
 
     let selfFields, selfMeths, selfProps = 
 
-        [ for alt in cud.cudAlternatives do 
-           if repr.RepresentAlternativeAsFreshInstancesOfRootClass (info,alt) then
+        [ for (cidx, alt) in Array.indexed cud.cudAlternatives do 
+           if repr.RepresentAlternativeAsFreshInstancesOfRootClass (info,alt) || 
+              repr.RepresentAlternativeAsStructValue info then
         // TODO
             let fields = alt.FieldDefs |> Array.map mkUnionCaseFieldId |> Array.toList
             let baseInit = 
@@ -915,11 +948,19 @@ let mkClassUnionDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addProp
                 | None -> Some ilg.typ_Object.TypeSpec
                 | Some typ -> Some typ.TypeSpec
 
+            let extraParamsForCtor = 
+                if isStruct && cud.cudAlternatives.Length > 1 && cud.cudAlternatives |> Array.exists (fun d -> d.FieldDefs.Length > 0)  then 
+                    let extraTys, _extraInstrs = extraTysAndInstrsForStructCtor ilg cidx 
+                    List.map mkILParamAnon extraTys 
+                else 
+                    []
+
             let ctor = 
                 mkILSimpleStorageCtor 
                    (cud.cudWhere,
                     baseInit,
                     baseTy,
+                    extraParamsForCtor,
                     (fields @ tagFieldsInObject),
                     (if cuspec.HasHelpers = AllHelpers then ILMemberAccess.Assembly else cud.cudReprAccess))
                 |> addMethodGeneratedAttrs 
@@ -936,6 +977,7 @@ let mkClassUnionDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addProp
 
     let ctorMeths =
         if (List.isEmpty selfFields && List.isEmpty tagFieldsInObject && not (List.isEmpty selfMeths))
+            || isStruct
             ||  cud.cudAlternatives |> Array.forall (fun alt -> repr.RepresentAlternativeAsFreshInstancesOfRootClass (info,alt))  then 
 
             [] (* no need for a second ctor in these cases *)
@@ -945,6 +987,7 @@ let mkClassUnionDef (addMethodGeneratedAttrs, addPropertyGeneratedAttrs, addProp
                  (cud.cudWhere,
                   Some (match td.Extends with None -> ilg.typ_Object | Some typ -> typ).TypeSpec,
                   baseTy,
+                  [],
                   tagFieldsInObject,
                   ILMemberAccess.Assembly) // cud.cudReprAccess)
               |> addMethodGeneratedAttrs ]

tests/fsharp/core/patterns/test.fsx

@@ -1218,6 +1218,99 @@ module StructUnionMultiCaseLibDefns =
       /// <summary>Choice 7 of 7 choices</summary>
       | Choice7Of7 of Item7: 'T7
 
+module StructUnionsWithConflictingConstructors = 
+
+    [<StructuralEquality; StructuralComparison>]
+    [<RequireQualifiedAccess>]
+    [<Struct>]
+    type StructChoice = 
+      | Choice1Of2 of Item1: double
+      | Choice2Of2 of Item2: double
+    
+    [<StructuralEquality; StructuralComparison>]
+    [<RequireQualifiedAccess>]
+    [<Struct>]
+    type StructChoice3 = 
+      | Choice1Of3 of Item1: double
+      | Choice2Of3 of Item2: double
+      | Choice3Of3 of Item3: double
+    
+    [<StructuralEquality; StructuralComparison>]
+    [<RequireQualifiedAccess>]
+    [<Struct>]
+    type StructChoice4 = 
+      | Choice1Of4 of Item1: int
+      | Choice2Of4 of Item2: int
+      | Choice3Of4 of Item3: int
+      | Choice4Of4 of Item4: float
+    
+    [<StructuralEquality; StructuralComparison>]
+    [<RequireQualifiedAccess>]
+    [<Struct>]
+    type StructChoice5 = 
+      | Choice1Of5 of Item1: string
+      | Choice2Of5 of Item2: string
+      | Choice3Of5 of Item3: string
+      | Choice4Of5 of Item4: string
+      | Choice5Of5 of Item5: string
+    
+    [<StructuralEquality; StructuralComparison>]
+    [<RequireQualifiedAccess>]
+    [<Struct>]
+    type StructChoice6<'T1> = 
+      | Choice1Of6 of Item1: 'T1 
+      | Choice2Of6 of Item2: 'T1
+      | Choice3Of6 of Item3: 'T1
+      | Choice4Of6 of Item4: 'T1
+      | Choice5Of6 of Item5: 'T1
+      | Choice6Of6 of Item6: 'T1
+    
+    [<StructuralEquality; StructuralComparison>]
+    [<RequireQualifiedAccess>]
+    [<Struct>]
+    type StructChoice7 = 
+      | Choice1Of7 of Item1: byte 
+      | Choice2Of7 of Item2: byte
+      | Choice3Of7 of Item3: byte
+      | Choice4Of7 of Item4: byte
+      | Choice5Of7 of Item5: byte
+      | Choice6Of7 of Item6: byte
+      | Choice7Of7 of Item7: byte
+
+module StructUnionMarshalingBug = 
+    [<Struct>]
+    type Msg0 = 
+      | Zero of key :int
+
+    [<Struct>]
+    type Msg1 = 
+      | One of name :string
+      | Two of key :int
+
+    [<Struct>]
+    type Msg2 = 
+      { name :string
+        key :int
+        tag :int }
+
+    open System.Runtime.InteropServices
+
+    let msg0 = Zero 42
+    let size0 = Marshal.SizeOf(msg0)  
+    check "clcejefdw" size0 (sizeof<int>)
+
+    let msg1 = Two 42
+    let size1 = Marshal.SizeOf(msg1)  
+    check "clcejefdw2" size1 (sizeof<string> + 2*sizeof<int>) // this size may be bigger than expected
+
+    let msg2 = { name = null; key = 42; tag=1 }
+    let size2 = Marshal.SizeOf(msg2)  
+    check "clceje" size2 (sizeof<string> + 2*sizeof<int>)
+
+    // ... alternately ...
+    let buffer = Marshal.AllocHGlobal(64) // HACK: just assumed a much larger size
+    Marshal.StructureToPtr<Msg1>(msg1, buffer, false) 
+
 (* check for failure else sign off "ok" *)