From 1ccd21f9b75e321eaebd2436bc0216f92a446056 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 4 Sep 2016 09:11:41 +1000 Subject: [PATCH 01/10] Add CompilationRepresentationFlags.UseVirtualTag This currently just duplicates the IntegerTag functionality withing EraseUnions.fs --- src/absil/ilx.fs | 23 ++++++------ src/absil/ilx.fsi | 28 +++++++++------ src/fsharp/FSharp.Core/prim-types.fs | 1 + src/fsharp/FSharp.Core/prim-types.fsi | 2 ++ src/fsharp/IlxGen.fs | 4 ++- src/fsharp/TastOps.fs | 39 +++++++++++++-------- src/fsharp/TastOps.fsi | 3 ++ src/ilx/EraseUnions.fs | 50 ++++++++++++++++++++++++--- 8 files changed, 110 insertions(+), 40 deletions(-) diff --git a/src/absil/ilx.fs b/src/absil/ilx.fs index b0ea4fdd779..0def310f250 100644 --- a/src/absil/ilx.fs +++ b/src/absil/ilx.fs @@ -45,22 +45,22 @@ type IlxUnionHasHelpers = | SpecialFSharpOptionHelpers type IlxUnionRef = - | IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionAlternative[] * bool * (* hasHelpers: *) IlxUnionHasHelpers + | IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionAlternative[] * bool * (* hasHelpers: *) IlxUnionHasHelpers * bool type IlxUnionSpec = | IlxUnionSpec of IlxUnionRef * ILGenericArgs - member x.EnclosingType = let (IlxUnionSpec(IlxUnionRef(bx,tref,_,_,_),inst)) = x in mkILNamedTy bx tref inst - member x.Boxity = let (IlxUnionSpec(IlxUnionRef(bx,_,_,_,_),_)) = x in bx - member x.TypeRef = let (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_),_)) = x in tref - member x.GenericArgs = let (IlxUnionSpec(_,inst)) = x in inst - member x.AlternativesArray = let (IlxUnionSpec(IlxUnionRef(_,_,alts,_,_),_)) = x in alts - member x.IsNullPermitted = let (IlxUnionSpec(IlxUnionRef(_,_,_,np,_),_)) = x in np - member x.HasHelpers = let (IlxUnionSpec(IlxUnionRef(_,_,_,_,b),_)) = x in b - member x.Alternatives = Array.toList x.AlternativesArray - member x.Alternative idx = x.AlternativesArray.[idx] + member x.EnclosingType = let (IlxUnionSpec(IlxUnionRef(bx,tref,_,_,_,_),inst)) = x in mkILNamedTy bx tref inst + member x.Boxity = let (IlxUnionSpec(IlxUnionRef(bx,_,_,_,_,_),_)) = x in bx + member x.TypeRef = let (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_,_),_)) = x in tref + member x.GenericArgs = let (IlxUnionSpec(_,inst)) = x in inst + member x.AlternativesArray = let (IlxUnionSpec(IlxUnionRef(_,_,alts,_,_,_),_)) = x in alts + member x.IsNullPermitted = let (IlxUnionSpec(IlxUnionRef(_,_,_,np,_,_),_)) = x in np + member x.HasHelpers = let (IlxUnionSpec(IlxUnionRef(_,_,_,_,b,_),_)) = x in b + member x.VirtualTag = let (IlxUnionSpec(IlxUnionRef(_,_,_,_,_,vt),_)) = x in vt + member x.Alternatives = Array.toList x.AlternativesArray + member x.Alternative idx = x.AlternativesArray.[idx] member x.FieldDef idx fidx = x.Alternative(idx).FieldDef(fidx) - type IlxClosureLambdas = | Lambdas_forall of ILGenericParameterDef * IlxClosureLambdas | Lambdas_lambda of ILParameter * IlxClosureLambdas @@ -134,6 +134,7 @@ type IlxUnionInfo = cudDebugDisplayAttributes: ILAttribute list cudAlternatives: IlxUnionAlternative[] cudNullPermitted: bool + cudVirtualTag: bool /// debug info for generated code for classunions cudWhere: ILSourceMarker option } diff --git a/src/absil/ilx.fsi b/src/absil/ilx.fsi index ce6dfde5007..f5408f36fba 100644 --- a/src/absil/ilx.fsi +++ b/src/absil/ilx.fsi @@ -40,20 +40,27 @@ type IlxUnionHasHelpers = | SpecialFSharpOptionHelpers type IlxUnionRef = - | IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionAlternative[] * bool (* cudNullPermitted *) * IlxUnionHasHelpers (* cudHasHelpers *) + | IlxUnionRef + of boxity: ILBoxity + * ILTypeRef + * IlxUnionAlternative[] + * bool (* cudNullPermitted *) + * IlxUnionHasHelpers (* cudHasHelpers *) + * bool (* cudVirtualTag *) type IlxUnionSpec = | IlxUnionSpec of IlxUnionRef * ILGenericArgs - member EnclosingType : ILType - member GenericArgs : ILGenericArgs - member Alternatives : IlxUnionAlternative list + member EnclosingType : ILType + member GenericArgs : ILGenericArgs + member Alternatives : IlxUnionAlternative list member AlternativesArray : IlxUnionAlternative[] - member Boxity : ILBoxity - member TypeRef : ILTypeRef - member IsNullPermitted : bool - member HasHelpers : IlxUnionHasHelpers - member Alternative : int -> IlxUnionAlternative - member FieldDef : int -> int -> IlxUnionField + member Boxity : ILBoxity + member TypeRef : ILTypeRef + member IsNullPermitted : bool + member HasHelpers : IlxUnionHasHelpers + member VirtualTag : bool + member Alternative : int -> IlxUnionAlternative + member FieldDef : int -> int -> IlxUnionField // -------------------------------------------------------------------- // Closure references @@ -110,6 +117,7 @@ type IlxUnionInfo = cudDebugDisplayAttributes: ILAttribute list cudAlternatives: IlxUnionAlternative[] cudNullPermitted: bool + cudVirtualTag: bool /// Debug info for generated code for classunions. cudWhere: ILSourceMarker option } diff --git a/src/fsharp/FSharp.Core/prim-types.fs b/src/fsharp/FSharp.Core/prim-types.fs index a3b0f055e1d..ca65839bc11 100644 --- a/src/fsharp/FSharp.Core/prim-types.fs +++ b/src/fsharp/FSharp.Core/prim-types.fs @@ -92,6 +92,7 @@ namespace Microsoft.FSharp.Core | ModuleSuffix = 4 // append 'Module' to the end of a non-unique module | UseNullAsTrueValue = 8 // Note if you change this then change CompilationRepresentationFlags_PermitNull further below | Event = 16 + | UseVirtualTag = 32 #if FX_NO_ICLONEABLE module ICloneableExtensions = diff --git a/src/fsharp/FSharp.Core/prim-types.fsi b/src/fsharp/FSharp.Core/prim-types.fsi index 616be0f73e7..b0982790260 100644 --- a/src/fsharp/FSharp.Core/prim-types.fsi +++ b/src/fsharp/FSharp.Core/prim-types.fsi @@ -95,6 +95,8 @@ namespace Microsoft.FSharp.Core | UseNullAsTrueValue = 8 /// Compile a property as a CLI event. | Event = 16 + /// Rather than storing Tag:int for every discriminated union element (or GetType() comparison) use a virtual Tag property + | UseVirtualTag = 32 #if FX_NO_ICLONEABLE module ICloneableExtensions = diff --git a/src/fsharp/IlxGen.fs b/src/fsharp/IlxGen.fs index eec92b5b07c..2cb21415d7b 100644 --- a/src/fsharp/IlxGen.fs +++ b/src/fsharp/IlxGen.fs @@ -479,7 +479,8 @@ and GenUnionRef amap m g (tcref: TyconRef) = let nullPermitted = IsUnionTypeWithNullAsTrueValue g tycon let hasHelpers = ComputeUnionHasHelpers g tcref let boxity = (if tcref.IsStructOrEnumTycon then ILBoxity.AsValue else ILBoxity.AsObject) - IlxUnionRef(boxity, tref,alternatives,nullPermitted,hasHelpers)) + let useVirtualTag = IsUnionTypeWithUseVirtualTag g tycon + IlxUnionRef(boxity, tref,alternatives,nullPermitted,hasHelpers,useVirtualTag)) and ComputeUnionHasHelpers g (tcref : TyconRef) = if tyconRefEq g tcref g.unit_tcr_canon then NoHelpers @@ -6588,6 +6589,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon:Tycon) = let cuinfo = { cudReprAccess=reprAccess cudNullPermitted=IsUnionTypeWithNullAsTrueValue cenv.g tycon + cudVirtualTag=IsUnionTypeWithUseVirtualTag cenv.g tycon cudHelpersAccess=reprAccess cudHasHelpers=ComputeUnionHasHelpers cenv.g tcref cudDebugProxies= generateDebugProxies diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 8e5ddb25045..1fb90c11945 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -7001,30 +7001,41 @@ let enum_CompilationRepresentationAttribute_Instance = 0b0000000000000 let enum_CompilationRepresentationAttribute_StaticInstanceMask = 0b0000000000000011 let enum_CompilationRepresentationAttribute_ModuleSuffix = 0b0000000000000100 let enum_CompilationRepresentationAttribute_PermitNull = 0b0000000000001000 +let enum_CompilationRepresentationAttribute_UseVirtualTag = 0b0000000000100000 -let HasUseNullAsTrueValueAttribute g attribs = - match TryFindFSharpInt32Attribute g g.attrib_CompilationRepresentationAttribute attribs with - | Some(flags) -> ((flags &&& enum_CompilationRepresentationAttribute_PermitNull) <> 0) - | _ -> false +let hasCompilationRepresentationAttribute g attribs enumAttribute = + match TryFindFSharpInt32Attribute g g.attrib_CompilationRepresentationAttribute attribs with + | Some flags -> (flags &&& enumAttribute) = enumAttribute + | None -> false + +let HasUseNullAsTrueValueAttribute g attribs = enum_CompilationRepresentationAttribute_PermitNull |> hasCompilationRepresentationAttribute g attribs +let HasUseVirtualTagAttribute g attribs = enum_CompilationRepresentationAttribute_UseVirtualTag |> hasCompilationRepresentationAttribute g attribs let TyconHasUseNullAsTrueValueAttribute g (tycon:Tycon) = HasUseNullAsTrueValueAttribute g tycon.Attribs +let TyconHasUseVirtualTagAttribute g (tycon:Tycon) = HasUseVirtualTagAttribute g tycon.Attribs -// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs -let CanHaveUseNullAsTrueValueAttribute (_g:TcGlobals) (tycon:Tycon) = +let checkUseNullAsTrueValue (g:TcGlobals) (tycon:Tycon) additionalCheck = (tycon.IsUnionTycon && let ucs = tycon.UnionCasesArray (ucs.Length = 0 || - (ucs |> Array.existsOne (fun uc -> uc.IsNullary) && + (additionalCheck g tycon && + ucs |> Array.existsOne (fun uc -> uc.IsNullary) && ucs |> Array.exists (fun uc -> not uc.IsNullary)))) -// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs -let IsUnionTypeWithNullAsTrueValue (g:TcGlobals) (tycon:Tycon) = +let checkUseVirtualTag (g:TcGlobals) (tycon:Tycon) additionalCheck = + // TODO: maybe there should be some conditions around use of virtual tag?? (tycon.IsUnionTycon && - let ucs = tycon.UnionCasesArray - (ucs.Length = 0 || - (TyconHasUseNullAsTrueValueAttribute g tycon && - ucs |> Array.existsOne (fun uc -> uc.IsNullary) && - ucs |> Array.exists (fun uc -> not uc.IsNullary)))) + (additionalCheck g tycon)) + +// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs +let CanHaveUseNullAsTrueValueAttribute (g:TcGlobals) (tycon:Tycon) = checkUseNullAsTrueValue g tycon (fun _ _ -> true) +// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs +let IsUnionTypeWithNullAsTrueValue (g:TcGlobals) (tycon:Tycon) = checkUseNullAsTrueValue g tycon TyconHasUseNullAsTrueValueAttribute + +// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs +let CanHaveUseVirtualTagAttribute (g:TcGlobals) (tycon:Tycon) = checkUseVirtualTag g tycon (fun _ _ -> true) +// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs +let IsUnionTypeWithUseVirtualTag (g:TcGlobals) (tycon:Tycon) = checkUseVirtualTag g tycon TyconHasUseVirtualTagAttribute let TyconCompilesInstanceMembersAsStatic g tycon = IsUnionTypeWithNullAsTrueValue g tycon let TcrefCompilesInstanceMembersAsStatic g (tcref: TyconRef) = TyconCompilesInstanceMembersAsStatic g tcref.Deref diff --git a/src/fsharp/TastOps.fsi b/src/fsharp/TastOps.fsi index ed924b26921..cc87a5333c8 100755 --- a/src/fsharp/TastOps.fsi +++ b/src/fsharp/TastOps.fsi @@ -1036,6 +1036,9 @@ val (|ByrefTy|_|) : TcGlobals -> TType -> TType option val IsUnionTypeWithNullAsTrueValue: TcGlobals -> Tycon -> bool val TyconHasUseNullAsTrueValueAttribute : TcGlobals -> Tycon -> bool val CanHaveUseNullAsTrueValueAttribute : TcGlobals -> Tycon -> bool +val IsUnionTypeWithUseVirtualTag: TcGlobals -> Tycon -> bool +val TyconHasUseVirtualTagAttribute : TcGlobals -> Tycon -> bool +val CanHaveUseVirtualTagAttribute : TcGlobals -> Tycon -> bool val MemberIsCompiledAsInstance : TcGlobals -> TyconRef -> bool -> ValMemberInfo -> Attribs -> bool val ValSpecIsCompiledAsInstance : TcGlobals -> Val -> bool val ValRefIsCompiledAsInstanceMember : TcGlobals -> ValRef -> bool diff --git a/src/ilx/EraseUnions.fs b/src/ilx/EraseUnions.fs index 4cae9873d59..78382f9b2eb 100644 --- a/src/ilx/EraseUnions.fs +++ b/src/ilx/EraseUnions.fs @@ -38,6 +38,7 @@ type DiscriminationTechnique = // 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 + | VirtualTag // 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 @@ -54,9 +55,11 @@ type DiscriminationTechnique = // 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, + useVirtualTag:'Union->bool, isNullary:'Alt->bool, isList:'Union->bool, isStruct:'Union->bool, @@ -76,7 +79,9 @@ type UnionReprDecisions<'Union,'Alt,'Type> let alts = getAlternatives cu if alts.Length = 1 then SingleCase - elif + elif useVirtualTag cu then + VirtualTag + elif not (isStruct cu) && alts.Length < TaggingThresholdFixedConstant && not (repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu) then @@ -163,6 +168,7 @@ let cuspecRepr = UnionReprDecisions ((fun (cuspec:IlxUnionSpec) -> cuspec.AlternativesArray), (fun (cuspec:IlxUnionSpec) -> cuspec.IsNullPermitted), + (fun (cuspec:IlxUnionSpec) -> cuspec.VirtualTag), (fun (alt:IlxUnionAlternative) -> alt.IsNullary), (fun cuspec -> cuspec.HasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers), (fun cuspec -> cuspec.Boxity = ILBoxity.AsValue), @@ -175,6 +181,7 @@ let cudefRepr = UnionReprDecisions ((fun (_td,cud) -> cud.cudAlternatives), (fun (_td,cud) -> cud.cudNullPermitted), + (fun (_td,cud) -> cud.cudVirtualTag), (fun (alt:IlxUnionAlternative) -> alt.IsNullary), (fun (_td,cud) -> cud.cudHasHelpers = IlxUnionHasHelpers.SpecialFSharpListHelpers), (fun (td,_cud) -> match td.tdKind with ILTypeDefKind.ValueType -> true | _ -> false), @@ -366,6 +373,7 @@ let mkIsData ilg (avoidHelpers, cuspec, cidx) = | SingleCase -> [ mkLdcInt32 1 ] | RuntimeTypes -> mkRuntimeTypeDiscriminate ilg avoidHelpers cuspec alt altName altTy | IntegerTag -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx + | VirtualTag -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx | TailOrNull -> match cidx with | TagNil -> mkGetTailOrNull avoidHelpers cuspec @ [ AI_ldnull; AI_ceq ] @@ -413,6 +421,7 @@ let mkBrIsData ilg sense (avoidHelpers, cuspec,cidx,tg) = | SingleCase -> [ ] | RuntimeTypes -> mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy (I_brcmp (pos,tg)) | IntegerTag -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp (pos,tg)) + | VirtualTag -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp (pos,tg)) | TailOrNull -> match cidx with | TagNil -> mkGetTailOrNull avoidHelpers cuspec @ [I_brcmp (neg,tg)] @@ -438,6 +447,10 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers,cuspec: IlxU let baseTy = baseTyOfUnionSpec cuspec ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs (mkGetTagFromField ilg cuspec baseTy) + | VirtualTag -> + let baseTy = baseTyOfUnionSpec cuspec + ldOpt |> Option.iter cg.EmitInstr + cg.EmitInstrs (mkGetTagFromField ilg cuspec baseTy) | SingleCase -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] @@ -558,6 +571,24 @@ let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = cg.EmitInstr (I_switch (Array.toList dests)) cg.SetMarkToHere failLab + | VirtualTag -> + match cases with + | [] -> cg.EmitInstrs [ AI_pop ] + | _ -> + // Use a dictionary to avoid quadratic lookup in case list + let dict = System.Collections.Generic.Dictionary() + for (i,case) in cases do dict.[i] <- case + let failLab = cg.GenerateDelayMark () + let emitCase i _ = + let mutable res = Unchecked.defaultof<_> + let ok = dict.TryGetValue(i, &res) + if ok then res else cg.CodeLabel failLab + + let dests = Array.mapi emitCase cuspec.AlternativesArray + cg.EmitInstrs (mkGetTag ilg cuspec) + cg.EmitInstr (I_switch (Array.toList dests)) + cg.SetMarkToHere failLab + | SingleCase -> match cases with | [(0,tg)] -> cg.EmitInstrs [ AI_pop; I_br tg ] @@ -751,10 +782,11 @@ let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (a [] let typeDefs, altDebugTypeDefs = - if repr.OptimizeAlternativeToRootClass (info,alt) then [], [] else + if repr.OptimizeAlternativeToRootClass (info,alt) then [], [] + else let altDebugTypeDefs, debugAttrs = - if not cud.cudDebugProxies then [], [] + if not cud.cudDebugProxies then [], [] else let debugProxyTypeName = altTy.TypeSpec.Name + "@DebugTypeProxy" @@ -848,6 +880,9 @@ let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (a | IntegerTag -> yield mkLdcInt32 num yield mkNormalCall (mkILCtorMethSpecForTy (baseTy,[mkTagFieldType ilg cuspec])) + | VirtualTag -> + yield mkLdcInt32 num + yield mkNormalCall (mkILCtorMethSpecForTy (baseTy,[mkTagFieldType ilg cuspec])) | SingleCase | RuntimeTypes -> yield mkNormalCall (mkILCtorMethSpecForTy (baseTy,[])) @@ -885,7 +920,7 @@ let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (a let mkClassUnionDef ilg tref td cud = let boxity = match td.tdKind with ILTypeDefKind.ValueType -> ILBoxity.AsValue | _ -> ILBoxity.AsObject let baseTy = mkILFormalNamedTy boxity tref td.GenericParams - let cuspec = IlxUnionSpec(IlxUnionRef(boxity,baseTy.TypeRef, cud.cudAlternatives, cud.cudNullPermitted, cud.cudHasHelpers), baseTy.GenericArgs) + let cuspec = IlxUnionSpec(IlxUnionRef(boxity,baseTy.TypeRef, cud.cudAlternatives, cud.cudNullPermitted, cud.cudHasHelpers, cud.cudVirtualTag), baseTy.GenericArgs) let info = (td,cud) let repr = cudefRepr let isTotallyImmutable = (cud.cudHasHelpers <> SpecialFSharpListHelpers) @@ -906,6 +941,7 @@ let mkClassUnionDef ilg tref td cud = match repr.DiscriminationTechnique info with | SingleCase | RuntimeTypes | TailOrNull -> [] | IntegerTag -> [ mkTagFieldId ilg cuspec ] + | VirtualTag -> [ mkTagFieldId ilg cuspec ] let isStruct = match td.tdKind with ILTypeDefKind.ValueType -> true | _ -> false @@ -975,6 +1011,12 @@ let mkClassUnionDef ilg tref td cud = yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[mkTagFieldType ilg cuspec] )) else yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[])) + | VirtualTag -> + if inRootClass then + yield mkLdcInt32 fidx + yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[mkTagFieldType ilg cuspec] )) + else + yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[])) yield mkNormalStsfld constFieldSpec ] cud.cudWhere cd From 45bf626e4b0caa2a6dcac8b5e8c904c36393ad90 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 4 Sep 2016 16:20:15 +1000 Subject: [PATCH 02/10] Implement Virtual Tag --- src/ilx/EraseUnions.fs | 138 ++++++++++++++++++++++++++--------------- 1 file changed, 88 insertions(+), 50 deletions(-) diff --git a/src/ilx/EraseUnions.fs b/src/ilx/EraseUnions.fs index 78382f9b2eb..307f841114c 100644 --- a/src/ilx/EraseUnions.fs +++ b/src/ilx/EraseUnions.fs @@ -98,6 +98,9 @@ type UnionReprDecisions<'Union,'Alt,'Type> Array.exists (isNullary >> not) alts && isNullary alt (* is this the one? *) + member repr.IsVirtual cu = + match repr.DiscriminationTechnique cu with VirtualTag -> true | _ -> false + member repr.RepresentOneAlternativeAsNull cu = let alts = getAlternatives cu nullPermitted cu && @@ -129,13 +132,14 @@ type UnionReprDecisions<'Union,'Alt,'Type> 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.RepresentAlternativeAsFreshInstancesOfRootClass(cu,alt) + (not (repr.IsVirtual cu)) && + ( // 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.RepresentAlternativeAsFreshInstancesOfRootClass(cu,alt)) member repr.MaintainPossiblyUniqueConstantFieldForAlternative(cu,alt) = not (isStruct cu) && @@ -287,7 +291,11 @@ let mkGetTagFromHelpers ilg (cuspec: IlxUnionSpec) = if cuspecRepr.RepresentOneAlternativeAsNull cuspec then mkNormalCall (mkILNonGenericStaticMethSpecInTy (baseTy, "Get" + tagPropertyName, [baseTy], mkTagFieldFormalType ilg cuspec)) else - mkNormalCall (mkILNonGenericInstanceMethSpecInTy(baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec)) + let getTagMethod = mkILNonGenericInstanceMethSpecInTy(baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec) + if cuspecRepr.IsVirtual cuspec then + mkNormalCallvirt getTagMethod + else + mkNormalCall getTagMethod let mkGetTag ilg (cuspec: IlxUnionSpec) = match cuspec.HasHelpers with @@ -449,8 +457,9 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers,cuspec: IlxU cg.EmitInstrs (mkGetTagFromField ilg cuspec baseTy) | VirtualTag -> let baseTy = baseTyOfUnionSpec cuspec - ldOpt |> Option.iter cg.EmitInstr - cg.EmitInstrs (mkGetTagFromField ilg cuspec baseTy) + ldOpt |> Option.iter cg.EmitInstr + let get_Tag = mkILNonGenericInstanceMethSpecInTy(baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec) + cg.EmitInstr (mkNormalCallvirt get_Tag) | SingleCase -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] @@ -869,8 +878,35 @@ let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (a |> Array.toList - let basicProps, basicMethods = mkMethodsAndPropertiesForFields ilg cud.cudReprAccess attr cud.cudHasHelpers altTy fields - + let basicProps, basicMethods = mkMethodsAndPropertiesForFields ilg cud.cudReprAccess attr cud.cudHasHelpers altTy fields + + let tagProp, tagMethod = + match repr.DiscriminationTechnique info with + | VirtualTag -> + let tagFieldType = mkTagFieldType ilg cuspec + + let prop = + { Name = tagPropertyName + IsRTSpecialName = false + IsSpecialName = false + SetMethod = None + GetMethod = Some (mkILMethRef (altTy.TypeRef, ILCallingConv.Instance, "get_" + tagPropertyName, 0, [], tagFieldType)) + CallingConv = ILThisConvention.Instance + Type = tagFieldType + Init = None + Args = mkILTypes [] + CustomAttrs = emptyILCustomAttrs } + |> addPropertyGeneratedAttrs ilg + |> addPropertyNeverAttrs ilg + + let meth = + let loadTagNumber = genWith (fun cg -> cg.EmitInstrs [ mkLdcInt32 num; I_ret ]) + let body = mkMethodBody (true, emptyILLocals, 2, loadTagNumber, cud.cudWhere) + mkILNonGenericVirtualMethod ("get_" + tagPropertyName, cud.cudHelpersAccess, [], mkILReturn tagFieldType,body) + |> addMethodGeneratedAttrs ilg + + [prop], [meth] + | _ -> [], [] let basicCtorMeth = mkILStorageCtor @@ -880,9 +916,7 @@ let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (a | IntegerTag -> yield mkLdcInt32 num yield mkNormalCall (mkILCtorMethSpecForTy (baseTy,[mkTagFieldType ilg cuspec])) - | VirtualTag -> - yield mkLdcInt32 num - yield mkNormalCall (mkILCtorMethSpecForTy (baseTy,[mkTagFieldType ilg cuspec])) + | VirtualTag | SingleCase | RuntimeTypes -> yield mkNormalCall (mkILCtorMethSpecForTy (baseTy,[])) @@ -899,10 +933,10 @@ let convAlternativeDef ilg num (td:ILTypeDef) cud info cuspec (baseTy:ILType) (a ILTypeDefAccess.Nested (if alt.IsNullary && cud.cudHasHelpers = IlxUnionHasHelpers.AllHelpers then ILMemberAccess.Assembly else cud.cudReprAccess), td.GenericParams, baseTy, [], - mkILMethods ([basicCtorMeth] @ basicMethods), + mkILMethods ([basicCtorMeth] @ tagMethod @ basicMethods), mkILFields basicFields, emptyILTypeDefs, - mkILProperties basicProps, + mkILProperties (tagProp @ basicProps), emptyILEvents, mkILCustomAttrs debugAttrs, ILTypeInit.BeforeField) @@ -939,9 +973,8 @@ let mkClassUnionDef ilg tref td cud = let tagFieldsInObject = match repr.DiscriminationTechnique info with - | SingleCase | RuntimeTypes | TailOrNull -> [] + | SingleCase | RuntimeTypes | TailOrNull | VirtualTag -> [] | IntegerTag -> [ mkTagFieldId ilg cuspec ] - | VirtualTag -> [ mkTagFieldId ilg cuspec ] let isStruct = match td.tdKind with ILTypeDefKind.ValueType -> true | _ -> false @@ -1003,7 +1036,8 @@ let mkClassUnionDef ilg tref td cud = match repr.DiscriminationTechnique info with | SingleCase | RuntimeTypes - | TailOrNull -> + | TailOrNull + | VirtualTag -> yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[])) | IntegerTag -> if inRootClass then @@ -1011,12 +1045,6 @@ let mkClassUnionDef ilg tref td cud = yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[mkTagFieldType ilg cuspec] )) else yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[])) - | VirtualTag -> - if inRootClass then - yield mkLdcInt32 fidx - yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[mkTagFieldType ilg cuspec] )) - else - yield mkNormalNewobj (mkILCtorMethSpecForTy (altTy,[])) yield mkNormalStsfld constFieldSpec ] cud.cudWhere cd @@ -1029,32 +1057,42 @@ let mkClassUnionDef ilg tref td cud = |> Array.toList - let tagMeths,tagProps = + let tagMeths,tagProps = + let mkTagProperty () = + { Name = tagPropertyName + IsRTSpecialName = false + IsSpecialName = false + SetMethod = None + GetMethod = Some (mkILMethRef (baseTy.TypeRef, ILCallingConv.Instance, "get_" + tagPropertyName, 0, [], tagFieldType)) + CallingConv = ILThisConvention.Instance + Type = tagFieldType + Init = None + Args = mkILTypes [] + CustomAttrs = emptyILCustomAttrs } + |> addPropertyGeneratedAttrs ilg + |> addPropertyNeverAttrs ilg let body = mkMethodBody(true,emptyILLocals,2,genWith (fun cg -> emitLdDataTagPrim ilg (Some mkLdarg0) cg (true, cuspec); cg.EmitInstr I_ret), cud.cudWhere) - // // 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.cudHelpersAccess,[mkILParamAnon baseTy],mkILReturn tagFieldType,body) - |> addMethodGeneratedAttrs ilg ], - [] - - else - [ mkILNonGenericInstanceMethod("get_" + tagPropertyName,cud.cudHelpersAccess,[],mkILReturn tagFieldType,body) - |> addMethodGeneratedAttrs ilg ], - - [ { Name=tagPropertyName - IsRTSpecialName=false - IsSpecialName=false - SetMethod=None - GetMethod=Some(mkILMethRef(baseTy.TypeRef,ILCallingConv.Instance,"get_" + tagPropertyName,0,[], tagFieldType)) - CallingConv=ILThisConvention.Instance - Type=tagFieldType - Init=None - Args=mkILTypes [] - CustomAttrs=emptyILCustomAttrs } - |> addPropertyGeneratedAttrs ilg - |> addPropertyNeverAttrs ilg ] + + let mkTagStaticGetter () = + // If we are using NULL as a representation for an element of this type then we cannot + // use an instance method + mkILNonGenericStaticMethod("Get" + tagPropertyName,cud.cudHelpersAccess,[mkILParamAnon baseTy],mkILReturn tagFieldType,body) + |> addMethodGeneratedAttrs ilg + + let mkVirtualTagGetter () = + mkILNonGenericVirtualMethod("get_" + tagPropertyName,cud.cudHelpersAccess,[],mkILReturn tagFieldType,MethodBody.Abstract) + |> addMethodGeneratedAttrs ilg + + let mkTagGetter () = + mkILNonGenericInstanceMethod("get_" + tagPropertyName,cud.cudHelpersAccess,[],mkILReturn tagFieldType,body) + |> addMethodGeneratedAttrs ilg + + match repr.IsVirtual info, repr.RepresentOneAlternativeAsNull info with + | true, true -> [mkVirtualTagGetter (); mkTagStaticGetter ()], [mkTagProperty ()] + | true, false -> [mkVirtualTagGetter ()], [mkTagProperty ()] + | false, true -> [mkTagStaticGetter ()], [] + | false, false -> [mkTagGetter ()], [mkTagProperty ()] tagMeths, tagProps, tagEnumFields From 6fb0ddfeab3af5f81e214a7f50ff01ede3a3b475 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sun, 4 Sep 2016 18:48:35 +1000 Subject: [PATCH 03/10] Fix build --- src/absil/ilprint.fs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/absil/ilprint.fs b/src/absil/ilprint.fs index 6bdbf62c44d..f3144c05a2e 100644 --- a/src/absil/ilprint.fs +++ b/src/absil/ilprint.fs @@ -439,12 +439,12 @@ let goutput_alternative_ref env os (alt: IlxUnionAlternative) = output_id os alt.Name; alt.FieldDefs |> Array.toList |> output_parens (output_seq "," (fun os fdef -> goutput_typ env os fdef.Type)) os -let goutput_curef env os (IlxUnionRef(_,tref,alts,_,_)) = +let goutput_curef env os (IlxUnionRef(_,tref,alts,_,_,_)) = output_string os " .classunion import "; goutput_tref env os tref; output_parens (output_seq "," (goutput_alternative_ref env)) os (Array.toList alts) -let goutput_cuspec env os (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_),i)) = +let goutput_cuspec env os (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_,_),i)) = output_string os "class /* classunion */ "; goutput_tref env os tref; goutput_gactuals env os i From 7f554e4a1f1a5f9b1c0bffc5b9e388bf23591816 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 6 Sep 2016 19:40:22 +1000 Subject: [PATCH 04/10] Added UseVirtualTag to SurfaceArea test --- src/fsharp/FSharp.Core.Unittests/SurfaceArea.net40.fs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.net40.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.net40.fs index c452c3f31c4..eebaacec2df 100644 --- a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.net40.fs +++ b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.net40.fs @@ -864,6 +864,7 @@ Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.Comp Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags None Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags Static Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseNullAsTrueValue +Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseVirtualTag Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString() Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.IFormatProvider) Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.String) From a040b5f423b68bf7c6704c04f45d5c6cffb394dd Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 7 Sep 2016 18:55:53 +1000 Subject: [PATCH 05/10] UseVirtualTag across Platform's SurfaceArea --- src/fsharp/FSharp.Core.Unittests/SurfaceArea.coreclr.fs | 1 + src/fsharp/FSharp.Core.Unittests/SurfaceArea.net20.fs | 1 + src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable259.fs | 1 + src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable47.fs | 1 + src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable7.fs | 1 + src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable78.fs | 1 + 6 files changed, 6 insertions(+) diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.coreclr.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.coreclr.fs index 10c4389cb95..a2f0bedc031 100644 --- a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.coreclr.fs +++ b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.coreclr.fs @@ -844,6 +844,7 @@ Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.Comp Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags None Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags Static Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseNullAsTrueValue +Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseVirtualTag Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString() Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.IFormatProvider) Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.String) diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.net20.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.net20.fs index 37c48c87ae4..b95707fa825 100644 --- a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.net20.fs +++ b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.net20.fs @@ -833,6 +833,7 @@ Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.Comp Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags None Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags Static Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseNullAsTrueValue +Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseVirtualTag Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString() Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.IFormatProvider) Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.String) diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable259.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable259.fs index 8e5337ef4a8..f49f5d9950b 100644 --- a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable259.fs +++ b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable259.fs @@ -848,6 +848,7 @@ Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.Comp Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags None Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags Static Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseNullAsTrueValue +Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseVirtualTag Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString() Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.IFormatProvider) Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.String) diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable47.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable47.fs index 531eebf0e8f..cccbc4ee791 100644 --- a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable47.fs +++ b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable47.fs @@ -845,6 +845,7 @@ Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.Comp Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags None Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags Static Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseNullAsTrueValue +Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseVirtualTag Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString() Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.IFormatProvider) Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.String) diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable7.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable7.fs index 7d320ad8483..7b2f273b902 100644 --- a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable7.fs +++ b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable7.fs @@ -861,6 +861,7 @@ Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.Comp Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags None Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags Static Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseNullAsTrueValue +Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseVirtualTag Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString() Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.IFormatProvider) Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.String) diff --git a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable78.fs b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable78.fs index f731fcdbcc0..5f6e68ce222 100644 --- a/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable78.fs +++ b/src/fsharp/FSharp.Core.Unittests/SurfaceArea.portable78.fs @@ -848,6 +848,7 @@ Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.Comp Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags None Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags Static Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseNullAsTrueValue +Microsoft.FSharp.Core.CompilationRepresentationFlags: Microsoft.FSharp.Core.CompilationRepresentationFlags UseVirtualTag Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString() Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.IFormatProvider) Microsoft.FSharp.Core.CompilationRepresentationFlags: System.String ToString(System.String) From b5cbd1026a9e6b092354751c1c4fe5aad41a7d55 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Wed, 7 Sep 2016 19:29:15 +1000 Subject: [PATCH 06/10] Restored original spacing It makes my eyes bleed, but rules are rules... --- src/absil/ilx.fs | 20 ++++++++++---------- src/absil/ilx.fsi | 28 +++++++++++----------------- src/fsharp/TastOps.fs | 27 +++++++++++++++------------ 3 files changed, 36 insertions(+), 39 deletions(-) diff --git a/src/absil/ilx.fs b/src/absil/ilx.fs index 0def310f250..656d58bf816 100644 --- a/src/absil/ilx.fs +++ b/src/absil/ilx.fs @@ -49,16 +49,16 @@ type IlxUnionRef = type IlxUnionSpec = | IlxUnionSpec of IlxUnionRef * ILGenericArgs - member x.EnclosingType = let (IlxUnionSpec(IlxUnionRef(bx,tref,_,_,_,_),inst)) = x in mkILNamedTy bx tref inst - member x.Boxity = let (IlxUnionSpec(IlxUnionRef(bx,_,_,_,_,_),_)) = x in bx - member x.TypeRef = let (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_,_),_)) = x in tref - member x.GenericArgs = let (IlxUnionSpec(_,inst)) = x in inst - member x.AlternativesArray = let (IlxUnionSpec(IlxUnionRef(_,_,alts,_,_,_),_)) = x in alts - member x.IsNullPermitted = let (IlxUnionSpec(IlxUnionRef(_,_,_,np,_,_),_)) = x in np - member x.HasHelpers = let (IlxUnionSpec(IlxUnionRef(_,_,_,_,b,_),_)) = x in b - member x.VirtualTag = let (IlxUnionSpec(IlxUnionRef(_,_,_,_,_,vt),_)) = x in vt - member x.Alternatives = Array.toList x.AlternativesArray - member x.Alternative idx = x.AlternativesArray.[idx] + member x.EnclosingType = let (IlxUnionSpec(IlxUnionRef(bx,tref,_,_,_,_),inst)) = x in mkILNamedTy bx tref inst + member x.Boxity = let (IlxUnionSpec(IlxUnionRef(bx,_,_,_,_,_),_)) = x in bx + member x.TypeRef = let (IlxUnionSpec(IlxUnionRef(_,tref,_,_,_,_),_)) = x in tref + member x.GenericArgs = let (IlxUnionSpec(_,inst)) = x in inst + member x.AlternativesArray = let (IlxUnionSpec(IlxUnionRef(_,_,alts,_,_,_),_)) = x in alts + member x.IsNullPermitted = let (IlxUnionSpec(IlxUnionRef(_,_,_,np,_,_),_)) = x in np + member x.HasHelpers = let (IlxUnionSpec(IlxUnionRef(_,_,_,_,b,_),_)) = x in b + member x.VirtualTag = let (IlxUnionSpec(IlxUnionRef(_,_,_,_,_,vt),_)) = x in vt + member x.Alternatives = Array.toList x.AlternativesArray + member x.Alternative idx = x.AlternativesArray.[idx] member x.FieldDef idx fidx = x.Alternative(idx).FieldDef(fidx) type IlxClosureLambdas = diff --git a/src/absil/ilx.fsi b/src/absil/ilx.fsi index f5408f36fba..1de7d0686a2 100644 --- a/src/absil/ilx.fsi +++ b/src/absil/ilx.fsi @@ -40,27 +40,21 @@ type IlxUnionHasHelpers = | SpecialFSharpOptionHelpers type IlxUnionRef = - | IlxUnionRef - of boxity: ILBoxity - * ILTypeRef - * IlxUnionAlternative[] - * bool (* cudNullPermitted *) - * IlxUnionHasHelpers (* cudHasHelpers *) - * bool (* cudVirtualTag *) + | IlxUnionRef of boxity: ILBoxity * ILTypeRef * IlxUnionAlternative[] * bool (* cudNullPermitted *) * IlxUnionHasHelpers (* cudHasHelpers *) * bool (* cudVirtualTag *) type IlxUnionSpec = | IlxUnionSpec of IlxUnionRef * ILGenericArgs - member EnclosingType : ILType - member GenericArgs : ILGenericArgs - member Alternatives : IlxUnionAlternative list + member EnclosingType : ILType + member GenericArgs : ILGenericArgs + member Alternatives : IlxUnionAlternative list member AlternativesArray : IlxUnionAlternative[] - member Boxity : ILBoxity - member TypeRef : ILTypeRef - member IsNullPermitted : bool - member HasHelpers : IlxUnionHasHelpers - member VirtualTag : bool - member Alternative : int -> IlxUnionAlternative - member FieldDef : int -> int -> IlxUnionField + member Boxity : ILBoxity + member TypeRef : ILTypeRef + member IsNullPermitted : bool + member HasHelpers : IlxUnionHasHelpers + member VirtualTag : bool + member Alternative : int -> IlxUnionAlternative + member FieldDef : int -> int -> IlxUnionField // -------------------------------------------------------------------- // Closure references diff --git a/src/fsharp/TastOps.fs b/src/fsharp/TastOps.fs index 1fb90c11945..2f72194607a 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -7014,28 +7014,31 @@ let HasUseVirtualTagAttribute g attribs = enum_CompilationRepresentationAtt let TyconHasUseNullAsTrueValueAttribute g (tycon:Tycon) = HasUseNullAsTrueValueAttribute g tycon.Attribs let TyconHasUseVirtualTagAttribute g (tycon:Tycon) = HasUseVirtualTagAttribute g tycon.Attribs -let checkUseNullAsTrueValue (g:TcGlobals) (tycon:Tycon) additionalCheck = +// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs +let CanHaveUseNullAsTrueValueAttribute (_g:TcGlobals) (tycon:Tycon) = (tycon.IsUnionTycon && let ucs = tycon.UnionCasesArray (ucs.Length = 0 || - (additionalCheck g tycon && - ucs |> Array.existsOne (fun uc -> uc.IsNullary) && + (ucs |> Array.existsOne (fun uc -> uc.IsNullary) && ucs |> Array.exists (fun uc -> not uc.IsNullary)))) -let checkUseVirtualTag (g:TcGlobals) (tycon:Tycon) additionalCheck = - // TODO: maybe there should be some conditions around use of virtual tag?? +// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs +let IsUnionTypeWithNullAsTrueValue (g:TcGlobals) (tycon:Tycon) = (tycon.IsUnionTycon && - (additionalCheck g tycon)) + let ucs = tycon.UnionCasesArray + (ucs.Length = 0 || + (TyconHasUseNullAsTrueValueAttribute g tycon && + ucs |> Array.existsOne (fun uc -> uc.IsNullary) && + ucs |> Array.exists (fun uc -> not uc.IsNullary)))) // WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs -let CanHaveUseNullAsTrueValueAttribute (g:TcGlobals) (tycon:Tycon) = checkUseNullAsTrueValue g tycon (fun _ _ -> true) -// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs -let IsUnionTypeWithNullAsTrueValue (g:TcGlobals) (tycon:Tycon) = checkUseNullAsTrueValue g tycon TyconHasUseNullAsTrueValueAttribute +let CanHaveUseVirtualTagAttribute (_g:TcGlobals) (tycon:Tycon) = + tycon.IsUnionTycon // WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs -let CanHaveUseVirtualTagAttribute (g:TcGlobals) (tycon:Tycon) = checkUseVirtualTag g tycon (fun _ _ -> true) -// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs -let IsUnionTypeWithUseVirtualTag (g:TcGlobals) (tycon:Tycon) = checkUseVirtualTag g tycon TyconHasUseVirtualTagAttribute +let IsUnionTypeWithUseVirtualTag (g:TcGlobals) (tycon:Tycon) = + tycon.IsUnionTycon && + TyconHasUseVirtualTagAttribute g tycon let TyconCompilesInstanceMembersAsStatic g tycon = IsUnionTypeWithNullAsTrueValue g tycon let TcrefCompilesInstanceMembersAsStatic g (tcref: TyconRef) = TyconCompilesInstanceMembersAsStatic g tcref.Deref From 9d5e36a7aa66f029640aa05f96bd7b54907aef81 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Thu, 8 Sep 2016 19:24:23 +1000 Subject: [PATCH 07/10] Fixed CompilationRepresentationFlagsEnum test --- src/fsharp/FSharp.Core.Unittests/FSharp.Core/PrimTypes.fs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/fsharp/FSharp.Core.Unittests/FSharp.Core/PrimTypes.fs b/src/fsharp/FSharp.Core.Unittests/FSharp.Core/PrimTypes.fs index 6aee1af507b..84f47ce6165 100644 --- a/src/fsharp/FSharp.Core.Unittests/FSharp.Core/PrimTypes.fs +++ b/src/fsharp/FSharp.Core.Unittests/FSharp.Core/PrimTypes.fs @@ -630,7 +630,7 @@ type CompilationRepresentationFlagsEnum() = [] member this.Getvalue() = - let names = [| "None";"Static";"Instance";"ModuleSuffix";"UseNullAsTrueValue";"Event" |] + let names = [| "None";"Static";"Instance";"ModuleSuffix";"UseNullAsTrueValue";"Event";"UseVirtualTag" |] Assert.AreEqual(names, SourceConstructFlags.GetNames(typeof)) #endif From a7baa9fa7ab67b8034b3f511c12acaf05c07bd30 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Tue, 13 Sep 2016 19:45:54 +1000 Subject: [PATCH 08/10] Allowed UseNullAsTrueValue with UseVirtualFlag I'm hoping that this will then allow me to be binary serialization compatible with RuntimeTypes --- src/ilx/EraseUnions.fs | 108 +++++++++++++++++++++++++++++++++-------- 1 file changed, 87 insertions(+), 21 deletions(-) diff --git a/src/ilx/EraseUnions.fs b/src/ilx/EraseUnions.fs index 307f841114c..dfb979ed939 100644 --- a/src/ilx/EraseUnions.fs +++ b/src/ilx/EraseUnions.fs @@ -79,7 +79,8 @@ type UnionReprDecisions<'Union,'Alt,'Type> let alts = getAlternatives cu if alts.Length = 1 then SingleCase - elif useVirtualTag cu then + elif useVirtualTag cu && + (not (nullPermitted cu && alts.Length = 2 && isNullary alts.[0] <> isNullary alts.[1])) then VirtualTag elif not (isStruct cu) && @@ -93,7 +94,7 @@ type UnionReprDecisions<'Union,'Alt,'Type> 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 *) + (match repr.DiscriminationTechnique cu with RuntimeTypes | VirtualTag -> true | _ -> false) && (* 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? *) @@ -380,8 +381,8 @@ let mkIsData ilg (avoidHelpers, cuspec, cidx) = match cuspecRepr.DiscriminationTechnique cuspec with | SingleCase -> [ mkLdcInt32 1 ] | RuntimeTypes -> mkRuntimeTypeDiscriminate ilg avoidHelpers cuspec alt altName altTy + | VirtualTag | IntegerTag -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx - | VirtualTag -> mkTagDiscriminate ilg cuspec (baseTyOfUnionSpec cuspec) cidx | TailOrNull -> match cidx with | TagNil -> mkGetTailOrNull avoidHelpers cuspec @ [ AI_ldnull; AI_ceq ] @@ -428,8 +429,8 @@ let mkBrIsData ilg sense (avoidHelpers, cuspec,cidx,tg) = match cuspecRepr.DiscriminationTechnique cuspec with | SingleCase -> [ ] | RuntimeTypes -> mkRuntimeTypeDiscriminateThen ilg avoidHelpers cuspec alt altName altTy (I_brcmp (pos,tg)) + | VirtualTag | IntegerTag -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp (pos,tg)) - | VirtualTag -> mkTagDiscriminateThen ilg cuspec cidx (I_brcmp (pos,tg)) | TailOrNull -> match cidx with | TagNil -> mkGetTailOrNull avoidHelpers cuspec @ [I_brcmp (neg,tg)] @@ -457,9 +458,32 @@ let emitLdDataTagPrim ilg ldOpt (cg: ICodeGen<'Mark>) (avoidHelpers,cuspec: IlxU cg.EmitInstrs (mkGetTagFromField ilg cuspec baseTy) | VirtualTag -> let baseTy = baseTyOfUnionSpec cuspec - ldOpt |> Option.iter cg.EmitInstr let get_Tag = mkILNonGenericInstanceMethSpecInTy(baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec) - cg.EmitInstr (mkNormalCallvirt get_Tag) + + if cuspecRepr.RepresentOneAlternativeAsNull cuspec then + let nullAltIdx, _ = + alts + |> Seq.mapi (fun i a -> i, a) + |> Seq.find (fun (_,a) -> cuspecRepr.RepresentAlternativeAsNull (cuspec, a)) + + let ld = + match ldOpt with + | None -> + let locn = cg.GenLocal baseTy + cg.EmitInstr (mkStloc locn) + mkLdloc locn + | Some i -> i + + let ifNullLab = cg.GenerateDelayMark () + let outLab = cg.GenerateDelayMark() + cg.EmitInstrs [ld; I_brcmp (BI_brfalse, cg.CodeLabel ifNullLab)] + cg.EmitInstrs [ld; mkNormalCallvirt get_Tag; I_br (cg.CodeLabel outLab) ] + cg.SetMarkToHere ifNullLab + cg.EmitInstrs [mkLdcInt32 nullAltIdx] + cg.SetMarkToHere outLab + else + ldOpt |> Option.iter cg.EmitInstr + cg.EmitInstr (mkNormalCallvirt get_Tag) | SingleCase -> ldOpt |> Option.iter cg.EmitInstr cg.EmitInstrs [ AI_pop; mkLdcInt32 0 ] @@ -584,19 +608,57 @@ let emitDataSwitch ilg (cg: ICodeGen<'Mark>) (avoidHelpers, cuspec, cases) = match cases with | [] -> cg.EmitInstrs [ AI_pop ] | _ -> - // Use a dictionary to avoid quadratic lookup in case list - let dict = System.Collections.Generic.Dictionary() - for (i,case) in cases do dict.[i] <- case - let failLab = cg.GenerateDelayMark () - let emitCase i _ = - let mutable res = Unchecked.defaultof<_> - let ok = dict.TryGetValue(i, &res) - if ok then res else cg.CodeLabel failLab + let failLab = cg.GenerateDelayMark () - let dests = Array.mapi emitCase cuspec.AlternativesArray - cg.EmitInstrs (mkGetTag ilg cuspec) - cg.EmitInstr (I_switch (Array.toList dests)) - cg.SetMarkToHere failLab + let indexedAlts = + cuspec.AlternativesArray + |> Array.mapi (fun i a -> i, a) + + let getCase = + let casesDict = cases |> dict // Use a dictionary to avoid quadratic lookup in case list + fun i maybeNullAltIdx -> + match casesDict.TryGetValue i, maybeNullAltIdx with + | (true, res), None -> res + | (true, res), Some nullAltIdx when nullAltIdx <> i -> res + | _ -> cg.CodeLabel failLab + + let locn = cg.GenLocal baseTy + cg.EmitInstr (mkStloc locn) + + let maybeNullAltIdx = + if not (cuspecRepr.RepresentOneAlternativeAsNull cuspec) then None + else + let nullAltIdx, _ = + indexedAlts + |> Seq.find (fun (_,a) -> cuspecRepr.RepresentAlternativeAsNull (cuspec, a)) + + cg.EmitInstr (mkLdloc locn) + cg.EmitInstr (I_brcmp (BI_brfalse, getCase nullAltIdx None)) + Some nullAltIdx + + cg.EmitInstr (mkLdloc locn) + cg.EmitInstr (mkNormalCallvirt (mkILNonGenericInstanceMethSpecInTy(baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec))) + + let maybeTwoChoices = + match indexedAlts, maybeNullAltIdx with + | [|(idxA,_); (idxB,_)|], None -> Some (idxA, idxB) + | [|(idxA,_); (idxB,_); (idxC,_)|], Some nullIdx when nullIdx = idxA -> Some (idxB, idxC) + | [|(idxA,_); (idxB,_); (idxC,_)|], Some nullIdx when nullIdx = idxB -> Some (idxA, idxC) + | [|(idxA,_); (idxB,_); (idxC,_)|], Some nullIdx when nullIdx = idxC -> Some (idxA, idxB) + | _ -> None + + match maybeTwoChoices with + | Some (idxA, idxB) -> + cg.EmitInstrs [mkLdcInt32 idxA; (I_brcmp (BI_beq, getCase idxA None)); I_br (getCase idxB None)] + | None-> + let dests = + indexedAlts + |> Array.map (fun (i,_) -> getCase i maybeNullAltIdx) + |> Array.toList + + cg.EmitInstr (I_switch dests) + + cg.SetMarkToHere failLab | SingleCase -> match cases with @@ -1095,9 +1157,13 @@ let mkClassUnionDef ilg tref td cud = | false, false -> [mkTagGetter ()], [mkTagProperty ()] tagMeths, tagProps, tagEnumFields - - // The class can be abstract if each alternative is represented by a derived type - let isAbstract = (altTypeDefs.Length = cud.cudAlternatives.Length) + + let isAbstract = + match repr.DiscriminationTechnique info with + | VirtualTag -> true + | _ -> + // The class can be abstract if each alternative is represented by a derived type + altTypeDefs.Length = cud.cudAlternatives.Length let existingMeths = td.Methods.AsList let existingProps = td.Properties.AsList From 183bf00bd40722487957544af04e1445f63c42d0 Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 17 Sep 2016 14:06:51 +1000 Subject: [PATCH 09/10] Apply UseVirtualTag to Set and Map Currently Set and Map use RunTimeTypes for discriminating between cases, so changing to UseVirtualTag does not modify any internal fields, and so should remain consistent for existing serialized objects. --- src/fsharp/FSharp.Core/map.fs | 2 +- src/fsharp/FSharp.Core/set.fs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 574cba4a53c..3ae8df23e3e 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -8,7 +8,7 @@ namespace Microsoft.FSharp.Collections open Microsoft.FSharp.Core open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators - [] + [] [] type MapTree<'Key,'Value when 'Key : comparison > = | MapEmpty diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index 7262ae45f24..bbde4058055 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -13,7 +13,7 @@ namespace Microsoft.FSharp.Collections (* A classic functional language implementation of binary trees *) - [] + [] [] type SetTree<'T> when 'T : comparison = | SetEmpty // height = 0 From f2eeeeade13cd04157cf1c9b446343e70f0817dc Mon Sep 17 00:00:00 2001 From: Paul Westcott Date: Sat, 17 Sep 2016 14:08:06 +1000 Subject: [PATCH 10/10] Inline height and mk in Set and Map Optimization for add items to Map and Set objects --- src/fsharp/FSharp.Core/map.fs | 5 +++-- src/fsharp/FSharp.Core/set.fs | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 3ae8df23e3e..383a5a9a2de 100644 --- a/src/fsharp/FSharp.Core/map.fs +++ b/src/fsharp/FSharp.Core/map.fs @@ -64,7 +64,8 @@ namespace Microsoft.FSharp.Collections let empty = MapEmpty - let height = function + let inline height x = + match x with | MapEmpty -> 0 | MapOne _ -> 1 | MapNode(_,_,_,_,h) -> h @@ -74,7 +75,7 @@ namespace Microsoft.FSharp.Collections | MapEmpty -> true | _ -> false - let mk l k v r = + let inline mk l k v r = match l,r with | MapEmpty,MapEmpty -> MapOne(k,v) | _ -> diff --git a/src/fsharp/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index bbde4058055..2113cd3ff14 100644 --- a/src/fsharp/FSharp.Core/set.fs +++ b/src/fsharp/FSharp.Core/set.fs @@ -70,7 +70,7 @@ namespace Microsoft.FSharp.Collections #endif - let height t = + let inline height t = match t with | SetEmpty -> 0 | SetOne _ -> 1 @@ -90,7 +90,7 @@ namespace Microsoft.FSharp.Collections let tolerance = 2 - let mk l k r = + let inline mk l k r = match l,r with | SetEmpty,SetEmpty -> SetOne (k) | _ ->