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 diff --git a/src/absil/ilx.fs b/src/absil/ilx.fs index b0ea4fdd779..656d58bf816 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.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.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..1de7d0686a2 100644 --- a/src/absil/ilx.fsi +++ b/src/absil/ilx.fsi @@ -40,7 +40,7 @@ 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 @@ -52,6 +52,7 @@ type IlxUnionSpec = member TypeRef : ILTypeRef member IsNullPermitted : bool member HasHelpers : IlxUnionHasHelpers + member VirtualTag : bool member Alternative : int -> IlxUnionAlternative member FieldDef : int -> int -> IlxUnionField @@ -110,6 +111,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.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 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.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) 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) diff --git a/src/fsharp/FSharp.Core/map.fs b/src/fsharp/FSharp.Core/map.fs index 574cba4a53c..383a5a9a2de 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 @@ -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/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/FSharp.Core/set.fs b/src/fsharp/FSharp.Core/set.fs index 7262ae45f24..2113cd3ff14 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 @@ -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) | _ -> 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..2f72194607a 100644 --- a/src/fsharp/TastOps.fs +++ b/src/fsharp/TastOps.fs @@ -7001,13 +7001,18 @@ 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) = @@ -7026,6 +7031,15 @@ let IsUnionTypeWithNullAsTrueValue (g:TcGlobals) (tycon: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 CanHaveUseVirtualTagAttribute (_g:TcGlobals) (tycon:Tycon) = + tycon.IsUnionTycon + +// WARNING: this must match optimizeAlternativeToNull in ilx/cu_erase.fs +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 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..dfb979ed939 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,10 @@ type UnionReprDecisions<'Union,'Alt,'Type> let alts = getAlternatives cu if alts.Length = 1 then SingleCase - elif + elif useVirtualTag cu && + (not (nullPermitted cu && alts.Length = 2 && isNullary alts.[0] <> isNullary alts.[1])) then + VirtualTag + elif not (isStruct cu) && alts.Length < TaggingThresholdFixedConstant && not (repr.RepresentAllAlternativesAsConstantFieldsInRootClass cu) then @@ -88,11 +94,14 @@ 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? *) + member repr.IsVirtual cu = + match repr.DiscriminationTechnique cu with VirtualTag -> true | _ -> false + member repr.RepresentOneAlternativeAsNull cu = let alts = getAlternatives cu nullPermitted cu && @@ -124,13 +133,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) && @@ -163,6 +173,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 +186,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), @@ -280,7 +292,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 @@ -365,6 +381,7 @@ 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 | TailOrNull -> match cidx with @@ -412,6 +429,7 @@ 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)) | TailOrNull -> match cidx with @@ -438,6 +456,34 @@ 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 + let get_Tag = mkILNonGenericInstanceMethSpecInTy(baseTy, "get_" + tagPropertyName, [], mkTagFieldFormalType ilg cuspec) + + 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 ] @@ -558,6 +604,62 @@ 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 ] + | _ -> + let failLab = cg.GenerateDelayMark () + + 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 | [(0,tg)] -> cg.EmitInstrs [ AI_pop; I_br tg ] @@ -751,10 +853,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" @@ -837,8 +940,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 @@ -848,6 +978,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 | SingleCase | RuntimeTypes -> yield mkNormalCall (mkILCtorMethSpecForTy (baseTy,[])) @@ -864,10 +995,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) @@ -885,7 +1016,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) @@ -904,7 +1035,7 @@ let mkClassUnionDef ilg tref td cud = let tagFieldsInObject = match repr.DiscriminationTechnique info with - | SingleCase | RuntimeTypes | TailOrNull -> [] + | SingleCase | RuntimeTypes | TailOrNull | VirtualTag -> [] | IntegerTag -> [ mkTagFieldId ilg cuspec ] let isStruct = match td.tdKind with ILTypeDefKind.ValueType -> true | _ -> false @@ -967,7 +1098,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 @@ -987,37 +1119,51 @@ 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 ] - tagMeths, tagProps, tagEnumFields + 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 ()] - // The class can be abstract if each alternative is represented by a derived type - let isAbstract = (altTypeDefs.Length = cud.cudAlternatives.Length) + tagMeths, tagProps, tagEnumFields + + 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