[WIP] Virtual Tags for Discriminated Unions

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

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 }
 

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  
     }

src/fsharp/FSharp.Core.Unittests/FSharp.Core/PrimTypes.fs

@@ -630,7 +630,7 @@ type CompilationRepresentationFlagsEnum() =
 
     [<Test>]
     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<CompilationRepresentationFlags>))
 #endif
 

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)

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)

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)

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)

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)

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)

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)

src/fsharp/FSharp.Core/map.fs

@@ -8,7 +8,7 @@ namespace Microsoft.FSharp.Collections
     open Microsoft.FSharp.Core
     open Microsoft.FSharp.Core.LanguagePrimitives.IntrinsicOperators
 
-    [<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue)>]
+    [<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue ||| CompilationRepresentationFlags.UseVirtualTag)>]
     [<NoEquality; NoComparison>]
     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)
             | _ -> 

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 =

src/fsharp/FSharp.Core/prim-types.fsi

@@ -95,6 +95,8 @@ namespace Microsoft.FSharp.Core
        | UseNullAsTrueValue = 8
        /// <summary>Compile a property as a CLI event.</summary>
        | Event = 16
+       /// <summary>Rather than storing Tag:int for every discriminated union element (or GetType() comparison) use a virtual Tag property</summary>
+       | UseVirtualTag = 32
 
 #if FX_NO_ICLONEABLE
     module ICloneableExtensions =

src/fsharp/FSharp.Core/set.fs

@@ -13,7 +13,7 @@ namespace Microsoft.FSharp.Collections
 
     (* A classic functional language implementation of binary trees *)
 
-    [<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue)>]
+    [<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue ||| CompilationRepresentationFlags.UseVirtualTag)>]
     [<NoEquality; NoComparison>]
     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)
             | _ -> 

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

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
 

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