From 4ddf1ff20ab53c4b5f88eb9c3b84462d4db141b6 Mon Sep 17 00:00:00 2001 From: Don Syme Date: Fri, 7 Apr 2017 16:40:46 +0100 Subject: [PATCH] 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 | 14 ++--- src/absil/il.fsi | 4 +- src/fsharp/IlxGen.fs | 19 +++--- src/ilx/EraseUnions.fs | 55 +++++++++++++++-- tests/fsharp/core/patterns/test.fsx | 93 +++++++++++++++++++++++++++++ 5 files changed, 163 insertions(+), 22 deletions(-) diff --git a/src/absil/il.fs b/src/absil/il.fs index a126b02ba..69558b58a 100644 --- a/src/absil/il.fs +++ b/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) = diff --git a/src/absil/il.fsi b/src/absil/il.fsi index 36234e572..af0eb4586 100644 --- a/src/absil/il.fsi +++ b/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 diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index 844a71281..8216211e1 100644 --- a/src/fsharp/IlxGen.fs +++ b/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 [] diff --git a/src/ilx/EraseUnions.fs b/src/ilx/EraseUnions.fs index 004e6c1f0..1b300c8e7 100644 --- a/src/ilx/EraseUnions.fs +++ b/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 ] diff --git a/tests/fsharp/core/patterns/test.fsx b/tests/fsharp/core/patterns/test.fsx index a0823af57..3c3152b62 100644 --- a/tests/fsharp/core/patterns/test.fsx +++ b/tests/fsharp/core/patterns/test.fsx @@ -1218,6 +1218,99 @@ module StructUnionMultiCaseLibDefns = /// Choice 7 of 7 choices | Choice7Of7 of Item7: 'T7 +module StructUnionsWithConflictingConstructors = + + [] + [] + [] + type StructChoice = + | Choice1Of2 of Item1: double + | Choice2Of2 of Item2: double + + [] + [] + [] + type StructChoice3 = + | Choice1Of3 of Item1: double + | Choice2Of3 of Item2: double + | Choice3Of3 of Item3: double + + [] + [] + [] + type StructChoice4 = + | Choice1Of4 of Item1: int + | Choice2Of4 of Item2: int + | Choice3Of4 of Item3: int + | Choice4Of4 of Item4: float + + [] + [] + [] + type StructChoice5 = + | Choice1Of5 of Item1: string + | Choice2Of5 of Item2: string + | Choice3Of5 of Item3: string + | Choice4Of5 of Item4: string + | Choice5Of5 of Item5: string + + [] + [] + [] + 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 + + [] + [] + [] + 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 = + [] + type Msg0 = + | Zero of key :int + + [] + type Msg1 = + | One of name :string + | Two of key :int + + [] + 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) + + let msg1 = Two 42 + let size1 = Marshal.SizeOf(msg1) + check "clcejefdw2" size1 (sizeof + 2*sizeof) // this size may be bigger than expected + + let msg2 = { name = null; key = 42; tag=1 } + let size2 = Marshal.SizeOf(msg2) + check "clceje" size2 (sizeof + 2*sizeof) + + // ... alternately ... + let buffer = Marshal.AllocHGlobal(64) // HACK: just assumed a much larger size + Marshal.StructureToPtr(msg1, buffer, false) + (* check for failure else sign off "ok" *) -- GitLab