diff --git a/src/Compiler/AbstractIL/il.fs b/src/Compiler/AbstractIL/il.fs index 363004b2ff6..b438cc1d79d 100644 --- a/src/Compiler/AbstractIL/il.fs +++ b/src/Compiler/AbstractIL/il.fs @@ -184,20 +184,22 @@ type LazyOrderedMultiMap<'Key, 'Data when 'Key: equality>(keyf: 'Data -> 'Key, l t) - member self.Entries() = lazyItems.Force() + member _.Entries() = lazyItems.Force() - member self.Add y = + member _.Add y = new LazyOrderedMultiMap<'Key, 'Data>(keyf, lazyItems |> lazyMap (fun x -> y :: x)) - member self.Filter f = + member _.Filter f = new LazyOrderedMultiMap<'Key, 'Data>(keyf, lazyItems |> lazyMap (List.filter f)) - member self.Item + member _.Item with get x = match quickMap.Force().TryGetValue x with | true, v -> v | _ -> [] + override _.ToString() = "" + //--------------------------------------------------------------------- // SHA1 hash-signing algorithm. Used to get the public key token from // the public key. @@ -422,6 +424,8 @@ type AssemblyRefData = assemRefLocale: Locale option } + override x.ToString() = x.assemRefName + /// Global state: table of all assembly references keyed by AssemblyRefData. let AssemblyRefUniqueStampGenerator = UniqueStampGenerator() @@ -578,6 +582,8 @@ type ILModuleRef = member x.Hash = x.hash + override x.ToString() = x.Name + [] [] type ILScopeRef = @@ -667,6 +673,9 @@ type ILCallingConv = static member Static = ILCallingConvStatics.Static + override x.ToString() = + if x.IsStatic then "static" else "instance" + /// Static storage to amortize the allocation of ILCallingConv.Instance and ILCallingConv.Static. and ILCallingConvStatics() = @@ -986,7 +995,8 @@ type ILMethodRef = member x.ReturnType = x.mrefReturn - member x.CallingSignature = mkILCallSig (x.CallingConv, x.ArgTypes, x.ReturnType) + member x.GetCallingSignature() = + mkILCallSig (x.CallingConv, x.ArgTypes, x.ReturnType) static member Create(enclosingTypeRef, callingConv, name, genericArity, argTypes, returnType) = { @@ -1115,6 +1125,8 @@ type ILSourceDocument = member x.File = x.sourceFile + override x.ToString() = x.File + [] type ILDebugPoint = { @@ -1451,6 +1463,9 @@ type ILLocalDebugInfo = DebugMappings: ILLocalDebugMapping list } + override x.ToString() = + (fst x.Range).ToString() + "-" + (snd x.Range).ToString() + [] type ILCode = { @@ -1460,6 +1475,8 @@ type ILCode = Locals: ILLocalDebugInfo list } + override x.ToString() = "" + [] type ILLocal = { @@ -1468,6 +1485,8 @@ type ILLocal = DebugInfo: (string * int * int) option } + override x.ToString() = "" + type ILLocals = ILLocal list [] @@ -1484,6 +1503,8 @@ type ILDebugImports = Imports: ILDebugImport[] } + override x.ToString() = "" + [] type ILMethodBody = { @@ -1497,6 +1518,8 @@ type ILMethodBody = DebugImports: ILDebugImports option } + override x.ToString() = "" + [] type ILMemberAccess = | Assembly @@ -1737,6 +1760,8 @@ type PInvokeMethod = CharBestFit: PInvokeCharBestFit } + override x.ToString() = x.Name + [] type ILParameter = { @@ -1753,6 +1778,9 @@ type ILParameter = member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex + override x.ToString() = + x.Name |> Option.defaultValue "" + type ILParameters = ILParameter list [] @@ -1764,6 +1792,8 @@ type ILReturn = MetadataIndex: int32 } + override x.ToString() = "" + member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex member x.WithCustomAttrs(customAttrs) = @@ -1778,6 +1808,9 @@ type ILOverridesSpec = member x.DeclaringType = let (OverridesSpec (_mr, ty)) = x in ty + override x.ToString() = + "overrides " + x.DeclaringType.ToString() + "::" + x.MethodRef.ToString() + type ILMethodVirtualInfo = { IsFinal: bool @@ -1800,7 +1833,7 @@ type MethodCodeKind = | Native | Runtime -let typesOfILParams (ps: ILParameters) : ILTypes = ps |> List.map (fun p -> p.Type) +let typesOfILParams (ps: ILParameters) = ps |> List.map (fun p -> p.Type) [] type ILGenericVariance = @@ -1985,7 +2018,7 @@ type ILMethodDef member x.IsZeroInit = x.MethodBody.IsZeroInit - member md.CallingSignature = + member md.GetCallingSignature() = mkILCallSig (md.CallingConv, md.ParameterTypes, md.Return.Type) member x.IsClassInitializer = x.Name = ".cctor" @@ -2149,7 +2182,7 @@ type ILMethodDefs(f: unit -> ILMethodDef[]) = member x.TryFindInstanceByNameAndCallingSignature(nm, callingSig) = x.FindByName nm - |> List.tryFind (fun x -> not x.IsStatic && x.CallingSignature = callingSig) + |> List.tryFind (fun x -> not x.IsStatic && x.GetCallingSignature() = callingSig) [] type ILEventDef @@ -2232,6 +2265,8 @@ type ILEventDefs = member x.LookupByName s = let (ILEvents t) = x in t[s] + override x.ToString() = "" + [] type ILPropertyDef ( @@ -2310,6 +2345,8 @@ type ILPropertyDefs = member x.LookupByName s = let (ILProperties t) = x in t[s] + override x.ToString() = "" + let convertFieldAccess (ilMemberAccess: ILMemberAccess) = match ilMemberAccess with | ILMemberAccess.Assembly -> FieldAttributes.Assembly @@ -2424,6 +2461,8 @@ type ILFieldDefs = member x.LookupByName s = let (ILFields t) = x in t[s] + override x.ToString() = "" + type ILMethodImplDef = { Overrides: ILOverridesSpec @@ -2804,10 +2843,10 @@ and [] ILTypeDefs(f: unit -> ILPreTypeDef[]) = ReadOnlyDictionary t) - member x.AsArray() = + member _.AsArray() = [| for pre in array.Value -> pre.GetTypeDef() |] - member x.AsList() = + member _.AsList() = [ for pre in array.Value -> pre.GetTypeDef() ] interface IEnumerable with @@ -2870,6 +2909,8 @@ type ILNestedExportedType = member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex + override x.ToString() = "exported type " + x.Name + and ILNestedExportedTypes = | ILNestedExportedTypes of Lazy> @@ -2892,6 +2933,8 @@ and [] ILExportedTypeOrForwarder = member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex + override x.ToString() = "exported type " + x.Name + and ILExportedTypesAndForwarders = | ILExportedTypesAndForwarders of Lazy> @@ -2930,6 +2973,8 @@ type ILResource = member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex + override x.ToString() = "resource " + x.Name + type ILResources = | ILResources of ILResource list @@ -2977,6 +3022,8 @@ type ILAssemblyManifest = member x.SecurityDecls = x.SecurityDeclsStored.GetSecurityDecls x.MetadataIndex + override x.ToString() = "assembly manifest " + x.Name + [] type ILNativeResource = | In of fileName: string * linkedResourceBase: int * linkedResourceStart: int * linkedResourceLength: int @@ -3020,6 +3067,8 @@ type ILModuleDef = member x.CustomAttrs = x.CustomAttrsStored.GetCustomAttrs x.MetadataIndex + override x.ToString() = "assembly " + x.Name + // -------------------------------------------------------------------- // Add fields and types to tables, with decent error messages // when clashes occur... diff --git a/src/Compiler/AbstractIL/il.fsi b/src/Compiler/AbstractIL/il.fsi index 13ba8e13d80..34e7d8584e2 100644 --- a/src/Compiler/AbstractIL/il.fsi +++ b/src/Compiler/AbstractIL/il.fsi @@ -354,7 +354,7 @@ type ILMethodRef = member ReturnType: ILType - member CallingSignature: ILCallingSignature + member GetCallingSignature: unit -> ILCallingSignature interface System.IComparable @@ -1089,27 +1089,43 @@ type ILMethodDef = member IsVirtual: bool member IsFinal: bool + member IsNewSlot: bool + member IsCheckAccessOnOverride: bool + member IsAbstract: bool + member MethodBody: ILMethodBody - member CallingSignature: ILCallingSignature + + member GetCallingSignature: unit -> ILCallingSignature + member Access: ILMemberAccess + member IsHideBySig: bool + member IsSpecialName: bool /// The method is exported to unmanaged code using COM interop. member IsUnmanagedExport: bool + member IsReqSecObj: bool /// Some methods are marked "HasSecurity" even if there are no permissions attached, e.g. if they use SuppressUnmanagedCodeSecurityAttribute member HasSecurity: bool + member IsManaged: bool + member IsForwardRef: bool + member IsInternalCall: bool + member IsPreserveSig: bool + member IsSynchronized: bool + member IsNoInline: bool + member IsAggressiveInline: bool /// SafeHandle finalizer must be run. @@ -1129,20 +1145,35 @@ type ILMethodDef = ?genericParams: ILGenericParameterDefs * ?customAttrs: ILAttributes -> ILMethodDef + member internal WithSpecialName: ILMethodDef + member internal WithHideBySig: unit -> ILMethodDef + member internal WithHideBySig: bool -> ILMethodDef + member internal WithFinal: bool -> ILMethodDef + member internal WithAbstract: bool -> ILMethodDef + member internal WithVirtual: bool -> ILMethodDef + member internal WithAccess: ILMemberAccess -> ILMethodDef + member internal WithNewSlot: ILMethodDef + member internal WithSecurity: bool -> ILMethodDef + member internal WithPInvoke: bool -> ILMethodDef + member internal WithPreserveSig: bool -> ILMethodDef + member internal WithSynchronized: bool -> ILMethodDef + member internal WithNoInlining: bool -> ILMethodDef + member internal WithAggressiveInlining: bool -> ILMethodDef + member internal WithRuntime: bool -> ILMethodDef /// Tables of methods. Logically equivalent to a list of methods but @@ -1150,10 +1181,15 @@ type ILMethodDef = /// name and arity. [] type ILMethodDefs = + interface IEnumerable + member AsArray: unit -> ILMethodDef[] + member AsList: unit -> ILMethodDef list + member FindByName: string -> ILMethodDef list + member TryFindInstanceByNameAndCallingSignature: string * ILCallingSignature -> ILMethodDef option /// Field definitions. @@ -1186,20 +1222,32 @@ type ILFieldDef = ILFieldDef member Name: string + member FieldType: ILType + member Attributes: FieldAttributes + member Data: byte[] option + member LiteralValue: ILFieldInit option /// The explicit offset in bytes when explicit layout is used. member Offset: int32 option + member Marshal: ILNativeType option + member CustomAttrs: ILAttributes + member IsStatic: bool + member IsSpecialName: bool + member IsLiteral: bool + member NotSerialized: bool + member IsInitOnly: bool + member Access: ILMemberAccess /// Functional update of the value @@ -1213,12 +1261,19 @@ type ILFieldDef = ?marshal: ILNativeType option * ?customAttrs: ILAttributes -> ILFieldDef + member internal WithAccess: ILMemberAccess -> ILFieldDef + member internal WithInitOnly: bool -> ILFieldDef + member internal WithStatic: bool -> ILFieldDef + member internal WithSpecialName: bool -> ILFieldDef + member internal WithNotSerialized: bool -> ILFieldDef + member internal WithLiteralDefaultValue: ILFieldInit option -> ILFieldDef + member internal WithFieldMarshal: ILNativeType option -> ILFieldDef /// Tables of fields. Logically equivalent to a list of fields but the table is kept in diff --git a/src/Compiler/AbstractIL/ilwrite.fs b/src/Compiler/AbstractIL/ilwrite.fs index 4582821e486..7804e26d97e 100644 --- a/src/Compiler/AbstractIL/ilwrite.fs +++ b/src/Compiler/AbstractIL/ilwrite.fs @@ -404,6 +404,8 @@ type MetadataTable<'T> = member tbl.GetTableEntry x = tbl.dict[x] + override x.ToString() = "table " + x.name + //--------------------------------------------------------------------- // Keys into some of the tables //--------------------------------------------------------------------- @@ -450,6 +452,8 @@ type MethodDefKey(ilg:ILGlobals, tidx: int, garity: int, nm: string, retTy: ILTy isStatic = y.IsStatic | _ -> false + override x.ToString() = nm + /// We use this key type to help find ILFieldDefs for FieldRefs type FieldDefKey(tidx: int, nm: string, ty: ILType) = // precompute the hash. hash doesn't include the type diff --git a/src/Compiler/AbstractIL/ilx.fs b/src/Compiler/AbstractIL/ilx.fs index 75447e06bcb..94bfda1db53 100644 --- a/src/Compiler/AbstractIL/ilx.fs +++ b/src/Compiler/AbstractIL/ilx.fs @@ -15,10 +15,16 @@ let mkLowerName (nm: string) = [] type IlxUnionCaseField(fd: ILFieldDef) = let lowerName = mkLowerName fd.Name - member x.ILField = fd + + member _.ILField = fd + member x.Type = x.ILField.FieldType + member x.Name = x.ILField.Name - member x.LowerName = lowerName + + member _.LowerName = lowerName + + override x.ToString() = x.Name type IlxUnionCase = { @@ -28,11 +34,17 @@ type IlxUnionCase = } member x.FieldDefs = x.altFields + member x.FieldDef n = x.altFields[n] + member x.Name = x.altName + member x.IsNullary = (x.FieldDefs.Length = 0) + member x.FieldTypes = x.FieldDefs |> Array.map (fun fd -> fd.Type) + override x.ToString() = x.Name + type IlxUnionHasHelpers = | NoHelpers | AllHelpers @@ -48,7 +60,9 @@ type IlxUnionSpec = 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 = @@ -58,10 +72,15 @@ type IlxUnionSpec = 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.FieldDef idx fidx = x.Alternative(idx).FieldDef(fidx) + override x.ToString() = x.TypeRef.Name + type IlxClosureLambdas = | Lambdas_forall of ILGenericParameterDef * IlxClosureLambdas | Lambdas_lambda of ILParameter * IlxClosureLambdas @@ -97,6 +116,8 @@ type IlxClosureFreeVar = fvType: ILType } + override x.ToString() = x.fvName + let mkILFreeVar (name, compgen, ty) = { fvName = name @@ -139,6 +160,8 @@ type IlxClosureSpec = let formalCloTy = mkILFormalBoxedTy x.TypeRef (mkILFormalTypars x.GenericArgs) mkILFieldSpecInTy (x.ILType, "@_instance", formalCloTy) + override x.ToString() = x.TypeRef.ToString() + // Define an extension of the IL algebra of type definitions type IlxClosureInfo = { @@ -169,12 +192,14 @@ type IlxUnionInfo = DebugImports: ILDebugImports option } + override _.ToString() = "" + // -------------------------------------------------------------------- // Define these as extensions of the IL types // -------------------------------------------------------------------- -let destTyFuncApp = - function +let destTyFuncApp input = + match input with | Apps_tyapp (b, c) -> b, c | _ -> failwith "destTyFuncApp" diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs index d4c15029ff0..57f13fa8efb 100644 --- a/src/Compiler/Checking/CheckDeclarations.fs +++ b/src/Compiler/Checking/CheckDeclarations.fs @@ -180,12 +180,14 @@ module MutRecShapes = /// Indicates a declaration is contained in the given module -let ModuleOrNamespaceContainerInfo modref = ContainerInfo(Parent modref, Some(MemberOrValContainerInfo(modref, None, None, NoSafeInitInfo, []))) +let ModuleOrNamespaceContainerInfo modref = + ContainerInfo(Parent modref, Some(MemberOrValContainerInfo(modref, None, None, NoSafeInitInfo, []))) /// Indicates a declaration is contained in the given type definition in the given module -let TyconContainerInfo (parent, tcref, declaredTyconTypars, safeInitInfo) = ContainerInfo(parent, Some(MemberOrValContainerInfo(tcref, None, None, safeInitInfo, declaredTyconTypars))) +let TyconContainerInfo (parent, tcref, declaredTyconTypars, safeInitInfo) = + ContainerInfo(parent, Some(MemberOrValContainerInfo(tcref, None, None, safeInitInfo, declaredTyconTypars))) -type TyconBindingDefn = TyconBindingDefn of ContainerInfo * NewSlotsOK * DeclKind * SynMemberDefn * range +type TyconBindingDefn = TyconBindingDefn of ContainerInfo * NewSlotsOK * DeclKind * SynMemberDefn option * range type MutRecSigsInitialData = MutRecShape list type MutRecDefnsInitialData = MutRecShape list @@ -744,23 +746,29 @@ module MutRecBindingChecking = /// Represents one element in a type definition, after the first phase type TyconBindingPhase2A = /// An entry corresponding to the definition of the implicit constructor for a class - | Phase2AIncrClassCtor of IncrClassCtorLhs + | Phase2AIncrClassCtor of StaticCtorInfo * IncrClassCtorInfo option + /// An 'inherit' declaration in an incremental class /// /// Phase2AInherit (ty, arg, baseValOpt, m) | Phase2AInherit of SynType * SynExpr * Val option * range + /// A set of value or function definitions in an incremental class /// /// Phase2AIncrClassBindings (tcref, letBinds, isStatic, isRec, m) | Phase2AIncrClassBindings of TyconRef * SynBinding list * bool * bool * range + /// A 'member' definition in a class | Phase2AMember of PreCheckingRecursiveBinding + #if OPEN_IN_TYPE_DECLARATIONS /// A dummy declaration, should we ever support 'open' in type definitions | Phase2AOpen of SynOpenDeclTarget * range #endif + /// Indicates the super init has just been called, 'this' may now be published | Phase2AIncrClassCtorJustAfterSuperInit + /// Indicates the last 'field' has been initialized, only 'do' comes after | Phase2AIncrClassCtorJustAfterLastLet @@ -773,14 +781,20 @@ module MutRecBindingChecking = /// Represents one element in a type definition, after the second phase type TyconBindingPhase2B = - | Phase2BIncrClassCtor of IncrClassCtorLhs * Binding option - | Phase2BInherit of Expr * Val option + | Phase2BIncrClassCtor of staticCtorInfo: StaticCtorInfo * incrCtorInfoOpt: IncrClassCtorInfo option * safeThisValBindOpt: Binding option + + | Phase2BInherit of inheritsExpr: Expr + /// A set of value of function definitions in a class definition with an implicit constructor. | Phase2BIncrClassBindings of IncrClassBindingGroup list + + /// A member, by index | Phase2BMember of int + /// An intermediate definition that represent the point in an implicit class definition where /// the super type has been initialized. | Phase2BIncrClassCtorJustAfterSuperInit + /// An intermediate definition that represent the point in an implicit class definition where /// the last 'field' has been initialized, i.e. only 'do' and 'member' definitions come after /// this point. @@ -792,12 +806,17 @@ module MutRecBindingChecking = /// Represents one element in a type definition, after the third phase type TyconBindingPhase2C = - | Phase2CIncrClassCtor of IncrClassCtorLhs * Binding option - | Phase2CInherit of Expr * Val option + | Phase2CIncrClassCtor of StaticCtorInfo * IncrClassCtorInfo option * Binding option + + | Phase2CInherit of Expr + | Phase2CIncrClassBindings of IncrClassBindingGroup list + | Phase2CMember of PreInitializationGraphEliminationBinding + // Indicates the last 'field' has been initialized, only 'do' comes after | Phase2CIncrClassCtorJustAfterSuperInit + | Phase2CIncrClassCtorJustAfterLastLet type TyconBindingsPhase2C = TyconBindingsPhase2C of Tycon option * TyconRef * TyconBindingPhase2C list @@ -852,15 +871,14 @@ module MutRecBindingChecking = // Make fresh version of the class type for type checking the members and lets * let _, copyOfTyconTypars, _, objTy, thisTy = FreshenObjectArgType cenv tcref.Range TyparRigidity.WillBeRigid tcref isExtrinsic declaredTyconTypars - // The basic iteration over the declarations in a single type definition let initialInnerState = (None, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) - let defnAs, (_, _envForTycon, tpenv, recBindIdx, uncheckedBindsRev) = + let defnAs, (_, _envForTycon, tpenv, recBindIdx, uncheckedBindsRev) = (initialInnerState, binds) ||> List.collectFold (fun innerState defn -> let (TyconBindingDefn(containerInfo, newslotsOK, declKind, classMemberDef, m)) = defn - let incrClassCtorLhsOpt, envForTycon, tpenv, recBindIdx, uncheckedBindsRev = innerState + let incrCtorInfoOpt, envForTycon, tpenv, recBindIdx, uncheckedBindsRev = innerState if tcref.IsTypeAbbrev then // ideally we'd have the 'm' of the type declaration stored here, to avoid needing to trim to line to approx @@ -871,30 +889,45 @@ module MutRecBindingChecking = error(Error(FSComp.SR.tcEnumerationsMayNotHaveMembers(), (trimRangeToLine m))) match classMemberDef, containerInfo with - | SynMemberDefn.ImplicitCtor (vis, Attributes attrs, SynSimplePats.SimplePats(pats = spats), thisIdOpt, xmlDoc, m, _), ContainerInfo(_, Some(MemberOrValContainerInfo(tcref, _, baseValOpt, safeInitInfo, _))) -> + + | None, ContainerInfo(_, Some memberContainerInfo) -> + + let (MemberOrValContainerInfo(tcref, _, _, _, _)) = memberContainerInfo + let staticCtorInfo = TcStaticImplicitCtorInfo_Phase2A(cenv, envForTycon, tcref, m, copyOfTyconTypars) + let envForTycon = AddDeclaredTypars CheckForDuplicateTypars staticCtorInfo.IncrCtorDeclaredTypars envForTycon + let innerState = (None, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) + [Phase2AIncrClassCtor (staticCtorInfo, None)], innerState + + | Some (SynMemberDefn.ImplicitCtor (vis, Attributes attrs, SynSimplePats.SimplePats(spats, _), thisIdOpt, xmlDoc, m)), ContainerInfo(_, Some memberContainerInfo) -> + + let (MemberOrValContainerInfo(tcref, _, baseValOpt, safeInitInfo, _)) = memberContainerInfo + if tcref.TypeOrMeasureKind = TyparKind.Measure then error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m)) - // Phase2A: make incrClassCtorLhs - ctorv, thisVal etc, type depends on argty(s) - let incrClassCtorLhs = TcImplicitCtorLhs_Phase2A(cenv, envForTycon, tpenv, tcref, vis, attrs, spats, thisIdOpt, baseValOpt, safeInitInfo, m, copyOfTyconTypars, objTy, thisTy, xmlDoc) + // Phase2A: make staticCtorInfo - ctorv, thisVal etc, type depends on argty(s) + let staticCtorInfo = TcStaticImplicitCtorInfo_Phase2A(cenv, envForTycon, tcref, m, copyOfTyconTypars) + + // Phase2A: make incrCtorInfo - ctorv, thisVal etc, type depends on argty(s) + let incrCtorInfo = TcImplicitCtorInfo_Phase2A(cenv, envForTycon, tpenv, tcref, vis, attrs, spats, thisIdOpt, baseValOpt, safeInitInfo, m, copyOfTyconTypars, objTy, thisTy, xmlDoc) - // Phase2A: Add copyOfTyconTypars from incrClassCtorLhs - or from tcref - let envForTycon = AddDeclaredTypars CheckForDuplicateTypars incrClassCtorLhs.InstanceCtorDeclaredTypars envForTycon - let innerState = (Some incrClassCtorLhs, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) + // Phase2A: Add copyOfTyconTypars from incrCtorInfo - or from tcref + let envForTycon = AddDeclaredTypars CheckForDuplicateTypars staticCtorInfo.IncrCtorDeclaredTypars envForTycon + let innerState = (Some incrCtorInfo, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) - [Phase2AIncrClassCtor incrClassCtorLhs], innerState + [Phase2AIncrClassCtor (staticCtorInfo, Some incrCtorInfo)], innerState - | SynMemberDefn.ImplicitInherit (ty, arg, _baseIdOpt, m), _ -> + | Some (SynMemberDefn.ImplicitInherit (ty, arg, _baseIdOpt, m)), _ -> if tcref.TypeOrMeasureKind = TyparKind.Measure then error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m)) // Phase2A: inherit ty(arg) as base - pass through // Phase2A: pick up baseValOpt! - let baseValOpt = incrClassCtorLhsOpt |> Option.bind (fun x -> x.InstanceCtorBaseValOpt) - let innerState = (incrClassCtorLhsOpt, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) + let baseValOpt = incrCtorInfoOpt |> Option.bind (fun x -> x.InstanceCtorBaseValOpt) + let innerState = (incrCtorInfoOpt, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) [Phase2AInherit (ty, arg, baseValOpt, m); Phase2AIncrClassCtorJustAfterSuperInit], innerState - | SynMemberDefn.LetBindings (letBinds, isStatic, isRec, m), _ -> + | Some (SynMemberDefn.LetBindings (letBinds, isStatic, isRec, m)), _ -> match tcref.TypeOrMeasureKind, isStatic with | TyparKind.Measure, false -> error(Error(FSComp.SR.tcMeasureDeclarationsRequireStaticMembers(), m)) | _ -> () @@ -908,14 +941,11 @@ module MutRecBindingChecking = // Code for potential future design change to allow functions-compiled-as-members in structs errorR(Error(FSComp.SR.tcStructsMayNotContainLetBindings(), (trimRangeToLine m))) - if isStatic && Option.isNone incrClassCtorLhsOpt then - errorR(Error(FSComp.SR.tcStaticLetBindingsRequireClassesWithImplicitConstructors(), m)) - // Phase2A: let-bindings - pass through - let innerState = (incrClassCtorLhsOpt, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) + let innerState = (incrCtorInfoOpt, envForTycon, tpenv, recBindIdx, uncheckedBindsRev) [Phase2AIncrClassBindings (tcref, letBinds, isStatic, isRec, m)], innerState - | SynMemberDefn.Member (bind, m), _ -> + | Some (SynMemberDefn.Member (bind, m)), _ -> // Phase2A: member binding - create prelim valspec (for recursive reference) and RecursiveBindingInfo let NormalizedBinding(_, _, _, _, _, _, _, valSynData, _, _, _, _) as bind = BindingNormalization.NormalizeBinding ValOrMemberBinding cenv envForTycon bind let (SynValData(memberFlagsOpt, _, _)) = valSynData @@ -932,7 +962,7 @@ module MutRecBindingChecking = | _ -> () let envForMember = - match incrClassCtorLhsOpt with + match incrCtorInfoOpt with | None -> AddDeclaredTypars CheckForDuplicateTypars copyOfTyconTypars envForTycon | Some _ -> envForTycon @@ -941,12 +971,12 @@ module MutRecBindingChecking = let (binds, _values), (tpenv, recBindIdx) = AnalyzeAndMakeAndPublishRecursiveValue overridesOK false cenv envForMember (tpenv, recBindIdx) rbind let cbinds = [ for rbind in binds -> Phase2AMember rbind ] - let innerState = (incrClassCtorLhsOpt, envForTycon, tpenv, recBindIdx, List.rev binds @ uncheckedBindsRev) + let innerState = (incrCtorInfoOpt, envForTycon, tpenv, recBindIdx, List.rev binds @ uncheckedBindsRev) cbinds, innerState #if OPEN_IN_TYPE_DECLARATIONS - | SynMemberDefn.Open (target, m), _ -> - let innerState = (incrClassCtorLhsOpt, env, tpenv, recBindIdx, prelimRecValuesRev, uncheckedBindsRev) + | Some (SynMemberDefn.Open (target, m)), _ -> + let innerState = (incrCtorInfoOpt, env, tpenv, recBindIdx, prelimRecValuesRev, uncheckedBindsRev) [ Phase2AOpen (target, m) ], innerState #endif @@ -1090,18 +1120,33 @@ module MutRecBindingChecking = match defnA with // Phase2B for the definition of an implicit constructor. Enrich the instance environments // with the implicit ctor args. - | Phase2AIncrClassCtor incrClassCtorLhs -> - - let envInstance = AddDeclaredTypars CheckForDuplicateTypars incrClassCtorLhs.InstanceCtorDeclaredTypars envInstance - let envStatic = AddDeclaredTypars CheckForDuplicateTypars incrClassCtorLhs.InstanceCtorDeclaredTypars envStatic - let envInstance = match incrClassCtorLhs.InstanceCtorSafeThisValOpt with Some v -> AddLocalVal g cenv.tcSink scopem v envInstance | None -> envInstance - let envInstance = List.foldBack (AddLocalValPrimitive g) incrClassCtorLhs.InstanceCtorArgs envInstance - let envNonRec = match incrClassCtorLhs.InstanceCtorSafeThisValOpt with Some v -> AddLocalVal g cenv.tcSink scopem v envNonRec | None -> envNonRec - let envNonRec = List.foldBack (AddLocalValPrimitive g) incrClassCtorLhs.InstanceCtorArgs envNonRec - let safeThisValBindOpt = TcLetrecComputeCtorSafeThisValBind cenv incrClassCtorLhs.InstanceCtorSafeThisValOpt + | Phase2AIncrClassCtor (staticCtorInfo, incrCtorInfoOpt) -> + + let envInstance = AddDeclaredTypars CheckForDuplicateTypars staticCtorInfo.IncrCtorDeclaredTypars envInstance + let envStatic = AddDeclaredTypars CheckForDuplicateTypars staticCtorInfo.IncrCtorDeclaredTypars envStatic + let envInstance = + match incrCtorInfoOpt with + | None -> envInstance + | Some incrCtorInfo -> match incrCtorInfo.InstanceCtorSafeThisValOpt with Some v -> AddLocalVal g cenv.tcSink scopem v envInstance | None -> envInstance + let envInstance = + match incrCtorInfoOpt with + | None -> envInstance + | Some incrCtorInfo -> List.foldBack (AddLocalValPrimitive g) incrCtorInfo.InstanceCtorArgs envInstance + let envNonRec = + match incrCtorInfoOpt with + | None -> envNonRec + | Some incrCtorInfo -> match incrCtorInfo.InstanceCtorSafeThisValOpt with Some v -> AddLocalVal g cenv.tcSink scopem v envNonRec | None -> envNonRec + let envNonRec = + match incrCtorInfoOpt with + | None -> envNonRec + | Some incrCtorInfo -> List.foldBack (AddLocalValPrimitive g) incrCtorInfo.InstanceCtorArgs envNonRec + let safeThisValBindOpt = + match incrCtorInfoOpt with + | None -> None + | Some incrCtorInfo -> TcLetrecComputeCtorSafeThisValBind cenv incrCtorInfo.InstanceCtorSafeThisValOpt let innerState = (tpenv, envInstance, envStatic, envNonRec, generalizedRecBinds, preGeneralizationRecBinds, uncheckedRecBindsTable) - Phase2BIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt), innerState + Phase2BIncrClassCtor (staticCtorInfo, incrCtorInfoOpt, safeThisValBindOpt), innerState // Phase2B: typecheck the argument to an 'inherits' call and build the new object expr for the inherit-call | Phase2AInherit (synBaseTy, arg, baseValOpt, m) -> @@ -1116,7 +1161,7 @@ module MutRecBindingChecking = let envInstance = match baseValOpt with Some baseVal -> AddLocalVal g cenv.tcSink scopem baseVal envInstance | None -> envInstance let envNonRec = match baseValOpt with Some baseVal -> AddLocalVal g cenv.tcSink scopem baseVal envNonRec | None -> envNonRec let innerState = (tpenv, envInstance, envStatic, envNonRec, generalizedRecBinds, preGeneralizationRecBinds, uncheckedRecBindsTable) - Phase2BInherit (inheritsExpr, baseValOpt), innerState + Phase2BInherit inheritsExpr, innerState // Phase2B: let and let rec value and function definitions | Phase2AIncrClassBindings (tcref, binds, isStatic, isRec, mBinds) -> @@ -1190,7 +1235,7 @@ module MutRecBindingChecking = // envStatic contains class typars and the (ungeneralized) members on the class(es). // envStatic has no instance-variables (local let-bindings or ctor args). - let v = rbind.RecBindingInfo .Val + let v = rbind.RecBindingInfo.Val let envForBinding = if v.IsInstanceMember then envInstance else envStatic // Type variables derived from the type definition (or implicit constructor) are always generalizable (we check their generalizability later). @@ -1241,14 +1286,17 @@ module MutRecBindingChecking = // Phase2C: Generalise implicit ctor val match defnB with - | Phase2BIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt) -> - let valscheme = incrClassCtorLhs.InstanceCtorValScheme - let valscheme = ChooseCanonicalValSchemeAfterInference g denv valscheme scopem - AdjustRecType incrClassCtorLhs.InstanceCtorVal valscheme - Phase2CIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt) - - | Phase2BInherit (inheritsExpr, basevOpt) -> - Phase2CInherit (inheritsExpr, basevOpt) + | Phase2BIncrClassCtor (staticCtorInfo, incrCtorInfoOpt, safeThisValBindOpt) -> + match incrCtorInfoOpt with + | Some incrCtorInfo -> + let valscheme = incrCtorInfo.InstanceCtorValScheme + let valscheme = ChooseCanonicalValSchemeAfterInference g denv valscheme scopem + AdjustRecType incrCtorInfo.InstanceCtorVal valscheme + | None -> () + Phase2CIncrClassCtor (staticCtorInfo, incrCtorInfoOpt, safeThisValBindOpt) + + | Phase2BInherit inheritsExpr -> + Phase2CInherit inheritsExpr | Phase2BIncrClassBindings bindRs -> Phase2CIncrClassBindings bindRs @@ -1265,6 +1313,7 @@ module MutRecBindingChecking = let vxbind = TcLetrecAdjustMemberForSpecialVals cenv generalizedBinding let pgbrind = FixupLetrecBind cenv denv generalizedTyparsForRecursiveBlock vxbind Phase2CMember pgbrind) + TyconBindingsPhase2C(tyconOpt, tcref, defnCs)) // Phase2C: Fixup let bindings @@ -1284,7 +1333,7 @@ module MutRecBindingChecking = // let (fixupValueExprBinds, methodBinds) = (envMutRec, defnsCs) ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls (TyconBindingsPhase2C(tyconOpt, tcref, defnCs)) -> match defnCs with - | Phase2CIncrClassCtor (incrClassCtorLhs, safeThisValBindOpt) :: defnCs -> + | Phase2CIncrClassCtor (staticCtorInfo, incrCtorInfoOpt, safeThisValBindOpt) :: defnCs -> // Determine is static fields in this type need to be "protected" against invalid recursive initialization let safeStaticInitInfo = @@ -1325,17 +1374,21 @@ module MutRecBindingChecking = // This is the type definition we're processing - let tcref = incrClassCtorLhs.TyconRef + let tcref = staticCtorInfo.TyconRef // Assumes inherit call immediately follows implicit ctor. Checked by CheckMembersForm - let inheritsExpr, inheritsIsVisible, _, defnCs = + let instanceInfo, defnCs = + match incrCtorInfoOpt with + | None -> None, defnCs + | Some incrCtorInfo -> + match defnCs |> List.partition (function Phase2CInherit _ -> true | _ -> false) with - | [Phase2CInherit (inheritsExpr, baseValOpt)], defnCs -> - inheritsExpr, true, baseValOpt, defnCs + | [Phase2CInherit inheritsExpr], defnCs -> + Some(incrCtorInfo, inheritsExpr, true), defnCs | _ -> if tcref.IsStructOrEnumTycon then - mkUnit g tcref.Range, false, None, defnCs + Some (incrCtorInfo, mkUnit g tcref.Range, false), defnCs else let inheritsExpr, _ = TcNewExpr cenv envForDecls tpenv g.obj_ty None true (SynExpr.Const (SynConst.Unit, tcref.Range)) tcref.Range @@ -1358,7 +1411,7 @@ module MutRecBindingChecking = mkDebugPoint tcref.Range inheritsExpr else inheritsExpr - inheritsExpr, false, None, defnCs + Some (incrCtorInfo, inheritsExpr, false), defnCs let envForTycon = MakeInnerEnvForTyconRef envForDecls tcref false @@ -1380,7 +1433,7 @@ module MutRecBindingChecking = | Some bind -> Phase2CIncrClassBindings [IncrClassBindingGroup([bind], false, false)] :: localDecs // Carve out the initialization sequence and decide on the localRep - let ctorBodyLambdaExpr, cctorBodyLambdaExprOpt, methodBinds, localReps = + let ctorBodyLambdaExprOpt, cctorBodyLambdaExprOpt, methodBinds, localReps = let localDecs = [ for localDec in localDecs do @@ -1390,25 +1443,27 @@ module MutRecBindingChecking = | Phase2CIncrClassCtorJustAfterLastLet -> yield Phase2CCtorJustAfterLastLet | _ -> () ] let memberBinds = memberBindsWithFixups |> List.map (fun x -> x.Binding) - MakeCtorForIncrClassConstructionPhase2C(cenv, envForTycon, incrClassCtorLhs, inheritsExpr, inheritsIsVisible, localDecs, memberBinds, generalizedTyparsForRecursiveBlock, safeStaticInitInfo) + MakeCtorForIncrClassConstructionPhase2C(cenv, envForTycon, staticCtorInfo, instanceInfo, localDecs, memberBinds, generalizedTyparsForRecursiveBlock, safeStaticInitInfo) // Generate the (value, expr) pairs for the implicit // object constructor and implicit static initializer let ctorValueExprBindings = - [ (let ctorValueExprBinding = TBind(incrClassCtorLhs.InstanceCtorVal, ctorBodyLambdaExpr, DebugPointAtBinding.NoneAtSticky) - let rbind = { ValScheme = incrClassCtorLhs.InstanceCtorValScheme ; Binding = ctorValueExprBinding } - FixupLetrecBind cenv envForDecls.DisplayEnv generalizedTyparsForRecursiveBlock rbind) ] - @ - ( match cctorBodyLambdaExprOpt with - | None -> [] + [ match incrCtorInfoOpt, ctorBodyLambdaExprOpt with + | None, _ | _, None -> () + | Some incrCtorInfo, Some ctorBodyLambdaExpr -> + let ctorValueExprBinding = TBind(incrCtorInfo.InstanceCtorVal, ctorBodyLambdaExpr, DebugPointAtBinding.NoneAtSticky) + let rbind = { ValScheme = incrCtorInfo.InstanceCtorValScheme ; Binding = ctorValueExprBinding } + FixupLetrecBind cenv envForDecls.DisplayEnv generalizedTyparsForRecursiveBlock rbind + match cctorBodyLambdaExprOpt with + | None -> () | Some cctorBodyLambdaExpr -> - [ (let _, cctorVal, cctorValScheme = incrClassCtorLhs.StaticCtorValInfo.Force() - let cctorValueExprBinding = TBind(cctorVal, cctorBodyLambdaExpr, DebugPointAtBinding.NoneAtSticky) - let rbind = { ValScheme = cctorValScheme; Binding = cctorValueExprBinding } - FixupLetrecBind cenv envForDecls.DisplayEnv generalizedTyparsForRecursiveBlock rbind) ] ) + let _, cctorVal, cctorValScheme = staticCtorInfo.StaticCtorValInfo.Force() + let cctorValueExprBinding = TBind(cctorVal, cctorBodyLambdaExpr, DebugPointAtBinding.NoneAtSticky) + let rbind = { ValScheme = cctorValScheme; Binding = cctorValueExprBinding } + FixupLetrecBind cenv envForDecls.DisplayEnv generalizedTyparsForRecursiveBlock rbind ] // Publish the fields of the representation to the type - localReps.PublishIncrClassFields (cenv, denv, cpath, incrClassCtorLhs, safeStaticInitInfo) (* mutation *) + localReps.PublishIncrClassFields (cenv, denv, cpath, staticCtorInfo, safeStaticInitInfo) // Fixup members let memberBindsWithFixups = @@ -1567,7 +1622,7 @@ module MutRecBindingChecking = decls |> MutRecShapes.topTycons |> List.collect (fun (TyconBindingsPhase2A(_, _, _, _, _, _, defnAs)) -> [ for defnB in defnAs do match defnB with - | Phase2AIncrClassCtor incrClassCtorLhs -> yield incrClassCtorLhs.InstanceCtorVal + | Phase2AIncrClassCtor (_, Some incrCtorInfo) -> yield incrCtorInfo.InstanceCtorVal | _ -> () ]) let envForDeclsUpdated = @@ -1617,8 +1672,8 @@ module MutRecBindingChecking = for TyconBindingsPhase2B(_tyconOpt, _tcref, defnBs) in MutRecShapes.collectTycons defnsBs do for defnB in defnBs do match defnB with - | Phase2BIncrClassCtor (incrClassCtorLhs, _) -> - yield incrClassCtorLhs.InstanceCtorVal.Type + | Phase2BIncrClassCtor (_, Some incrCtorInfo, _) -> + yield incrCtorInfo.InstanceCtorVal.Type | _ -> () ] @@ -1736,16 +1791,23 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial mBinds scopem mutRecNSInfo (env let interfaceMembersFromTypeDefn tyconMembersData (intfTyR, defn, _) implTySet = let (MutRecDefnsPhase2DataForTycon(_, parent, declKind, tcref, baseValOpt, safeInitInfo, declaredTyconTypars, _, _, newslotsOK, _)) = tyconMembersData let containerInfo = ContainerInfo(parent, Some(MemberOrValContainerInfo(tcref, Some(intfTyR, implTySet), baseValOpt, safeInitInfo, declaredTyconTypars))) - defn |> List.choose (fun mem -> + [ for mem in defn do match mem with - | SynMemberDefn.Member(_, m) -> Some(TyconBindingDefn(containerInfo, newslotsOK, declKind, mem, m)) - | SynMemberDefn.AutoProperty(range=m) -> Some(TyconBindingDefn(containerInfo, newslotsOK, declKind, mem, m)) - | _ -> errorR(Error(FSComp.SR.tcMemberNotPermittedInInterfaceImplementation(), mem.Range)); None) + | SynMemberDefn.Member(_, m) -> TyconBindingDefn(containerInfo, newslotsOK, declKind, Some mem, m) + | SynMemberDefn.AutoProperty(range=m) -> TyconBindingDefn(containerInfo, newslotsOK, declKind, Some mem, m) + | mem -> errorR(Error(FSComp.SR.tcMemberNotPermittedInInterfaceImplementation(), mem.Range)) ] let tyconBindingsOfTypeDefn (MutRecDefnsPhase2DataForTycon(_, parent, declKind, tcref, baseValOpt, safeInitInfo, declaredTyconTypars, members, _, newslotsOK, _)) = let containerInfo = ContainerInfo(parent, Some(MemberOrValContainerInfo(tcref, None, baseValOpt, safeInitInfo, declaredTyconTypars))) - members - |> List.choose (fun memb -> + [ // Yield a fake member marking the ability to do static incremental construction + match members with + | SynMemberDefn.ImplicitCtor _ :: _ -> () + | _ -> + if not tcref.IsFSharpEnumTycon && not tcref.IsFSharpDelegateTycon && not tcref.IsFSharpException && not tcref.IsTypeAbbrev then + TyconBindingDefn(containerInfo, newslotsOK, declKind, None, tcref.Range) + + // Yield the other members + for memb in members do match memb with | SynMemberDefn.ImplicitCtor _ | SynMemberDefn.ImplicitInherit _ @@ -1754,16 +1816,16 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial mBinds scopem mutRecNSInfo (env | SynMemberDefn.Member _ | SynMemberDefn.GetSetMember _ | SynMemberDefn.Open _ - -> Some(TyconBindingDefn(containerInfo, newslotsOK, declKind, memb, memb.Range)) + -> TyconBindingDefn(containerInfo, newslotsOK, declKind, Some memb, memb.Range) // Interfaces exist in the member list - handled above in interfaceMembersFromTypeDefn - | SynMemberDefn.Interface _ -> None + | SynMemberDefn.Interface _ -> () // The following should have been List.unzip out already in SplitTyconDefn | SynMemberDefn.AbstractSlot _ | SynMemberDefn.ValField _ | SynMemberDefn.Inherit _ -> error(InternalError("Unexpected declaration element", memb.Range)) - | SynMemberDefn.NestedType _ -> error(Error(FSComp.SR.tcTypesCannotContainNestedTypes(), memb.Range))) + | SynMemberDefn.NestedType _ -> error(Error(FSComp.SR.tcTypesCannotContainNestedTypes(), memb.Range)) ] let tpenv = emptyUnscopedTyparEnv @@ -1773,19 +1835,19 @@ let TcMutRecDefns_Phase2 (cenv: cenv) envInitial mBinds scopem mutRecNSInfo (env let (MutRecDefnsPhase2DataForTycon(_, _, declKind, tcref, _, _, _, members, m, newslotsOK, _)) = tyconData let tcaug = tcref.TypeContents if tcaug.tcaug_closed && declKind <> ExtrinsicExtensionBinding then - error(InternalError("Intrinsic augmentations of types are only permitted in the same file as the definition of the type", m)) - members |> List.iter (fun mem -> + error(InternalError("Intrinsic augmentations of types are only permitted in the same file as the definition of the type", m)) + for mem in members do match mem with | SynMemberDefn.Member _ | SynMemberDefn.GetSetMember _ - | SynMemberDefn.Interface _ -> () - | SynMemberDefn.Open _ | SynMemberDefn.AutoProperty _ | SynMemberDefn.LetBindings _ // accept local definitions + | SynMemberDefn.Interface _ -> () + | SynMemberDefn.Open _ | SynMemberDefn.ImplicitCtor _ // accept implicit ctor pattern, should be first! | SynMemberDefn.ImplicitInherit _ when newslotsOK = NewSlotsOK -> () // accept implicit ctor pattern, should be first! // The rest should have been removed by splitting, they belong to "core" (they are "shape" of type, not implementation) - | _ -> error(Error(FSComp.SR.tcDeclarationElementNotPermittedInAugmentation(), mem.Range)))) + | _ -> error(Error(FSComp.SR.tcDeclarationElementNotPermittedInAugmentation(), mem.Range))) let binds: MutRecDefnsPhase2Info = @@ -2359,11 +2421,11 @@ module TcExceptionDeclarations = let binds, exnc = TcExnDefnCore cenv envInitial parent core let envMutRec = AddLocalExnDefnAndReport cenv.tcSink scopem (AddLocalTycons g cenv.amap scopem [exnc] envInitial) exnc let ecref = mkLocalEntityRef exnc - let vals, _ = TcTyconMemberSpecs cenv envMutRec (ContainerInfo(parent, Some(MemberOrValContainerInfo(ecref, None, None, NoSafeInitInfo, [])))) ModuleOrMemberBinding tpenv aug + let containerInfo = ContainerInfo(parent, Some(MemberOrValContainerInfo(ecref, None, None, NoSafeInitInfo, []))) + let vals, _ = TcTyconMemberSpecs cenv envMutRec containerInfo ModuleOrMemberBinding tpenv aug binds, vals, Some ecref, envMutRec - /// Bind type definitions /// /// We first establish the cores of a set of type definitions (i.e. everything @@ -2716,10 +2778,8 @@ module EstablishTypeDefinitionCores = InferTyconKind g (SynTypeDefnKind.Opaque, attrs, [], [], inSig, true, m) |> ignore if not inSig && not hasMeasureAttr then errorR(Error(FSComp.SR.tcTypeRequiresDefinition(), m)) - if hasMeasureAttr then - TFSharpObjectRepr { fsobjmodel_kind = TFSharpClass - fsobjmodel_vslots = [] - fsobjmodel_rfields = Construct.MakeRecdFieldsTable [] } + if hasMeasureAttr then + TFSharpTyconRepr (Construct.NewEmptyFSharpTyconData TFSharpClass) else TNoRepr @@ -2749,7 +2809,7 @@ module EstablishTypeDefinitionCores = InferTyconKind g (SynTypeDefnKind.Record, attrs, [], [], inSig, true, m) |> ignore // Note: the table of record fields is initially empty - TFSharpRecdRepr (Construct.MakeRecdFieldsTable []) + TFSharpTyconRepr (Construct.NewEmptyFSharpTyconData TFSharpRecord) | SynTypeDefnSimpleRepr.General (kind, _, slotsigs, fields, isConcrete, _, _, _) -> let kind = InferTyconKind g (kind, attrs, slotsigs, fields, inSig, isConcrete, m) @@ -2765,21 +2825,10 @@ module EstablishTypeDefinitionCores = | SynTypeDefnKind.Struct -> TFSharpStruct | _ -> error(InternalError("should have inferred tycon kind", m)) - let repr = - { fsobjmodel_kind = kind - fsobjmodel_vslots = [] - fsobjmodel_rfields = Construct.MakeRecdFieldsTable [] } - - TFSharpObjectRepr repr + TFSharpTyconRepr (Construct.NewEmptyFSharpTyconData kind) | SynTypeDefnSimpleRepr.Enum _ -> - let kind = TFSharpEnum - let repr = - { fsobjmodel_kind = kind - fsobjmodel_vslots = [] - fsobjmodel_rfields = Construct.MakeRecdFieldsTable [] } - - TFSharpObjectRepr repr + TFSharpTyconRepr (Construct.NewEmptyFSharpTyconData TFSharpEnum) // OK, now fill in the (partially computed) type representation tycon.entity_tycon_repr <- repr @@ -3306,9 +3355,7 @@ module EstablishTypeDefinitionCores = hiddenReprChecks false noAllowNullLiteralAttributeCheck() if hasMeasureAttr then - let repr = TFSharpObjectRepr { fsobjmodel_kind=TFSharpClass - fsobjmodel_vslots=[] - fsobjmodel_rfields= Construct.MakeRecdFieldsTable [] } + let repr = TFSharpTyconRepr (Construct.NewEmptyFSharpTyconData TFSharpClass) repr, None, NoSafeInitInfo else TNoRepr, None, NoSafeInitInfo @@ -3372,7 +3419,15 @@ module EstablishTypeDefinitionCores = let recdFields = TcRecdUnionAndEnumDeclarations.TcNamedFieldDecls cenv envinner innerParent false tpenv fields recdFields |> CheckDuplicates (fun f -> f.Id) "field" |> ignore writeFakeRecordFieldsToSink recdFields - let repr = TFSharpRecdRepr (Construct.MakeRecdFieldsTable recdFields) + let data = + { + fsobjmodel_cases = Construct.MakeUnionCases [] + fsobjmodel_kind = TFSharpRecord + fsobjmodel_vslots = [] + fsobjmodel_rfields = Construct.MakeRecdFieldsTable recdFields + } + + let repr = TFSharpTyconRepr data repr, None, NoSafeInitInfo | SynTypeDefnSimpleRepr.LibraryOnlyILAssembly (s, _) -> @@ -3503,12 +3558,14 @@ module EstablishTypeDefinitionCores = let baseValOpt = MakeAndPublishBaseVal cenv envinner baseIdOpt (superOfTycon g tycon) let safeInitInfo = ComputeInstanceSafeInitInfo cenv envinner thisTyconRef.Range thisTy let safeInitFields = match safeInitInfo with SafeInitField (_, fld) -> [fld] | NoSafeInitInfo -> [] - - let repr = - TFSharpObjectRepr - { fsobjmodel_kind = kind - fsobjmodel_vslots = abstractSlots - fsobjmodel_rfields = Construct.MakeRecdFieldsTable (userFields @ implicitStructFields @ safeInitFields) } + let data = + { + fsobjmodel_cases = Construct.MakeUnionCases [] + fsobjmodel_kind = kind + fsobjmodel_vslots = abstractSlots + fsobjmodel_rfields = Construct.MakeRecdFieldsTable (userFields @ implicitStructFields @ safeInitFields) + } + let repr = TFSharpTyconRepr data repr, baseValOpt, safeInitInfo | SynTypeDefnSimpleRepr.Enum (decls, m) -> @@ -3526,11 +3583,14 @@ module EstablishTypeDefinitionCores = errorR(Error(FSComp.SR.tcInvalidTypeForLiteralEnumeration(), m)) writeFakeRecordFieldsToSink fields' - let repr = - TFSharpObjectRepr - { fsobjmodel_kind=kind - fsobjmodel_vslots=[] - fsobjmodel_rfields= Construct.MakeRecdFieldsTable (vfld :: fields') } + let data = + { + fsobjmodel_cases = Construct.MakeUnionCases [] + fsobjmodel_kind = kind + fsobjmodel_vslots = [] + fsobjmodel_rfields = Construct.MakeRecdFieldsTable (vfld :: fields') + } + let repr = TFSharpTyconRepr data repr, None, NoSafeInitInfo tycon.entity_tycon_repr <- typeRepr @@ -3829,7 +3889,7 @@ module EstablishTypeDefinitionCores = // Phase 1B. Establish the kind of each type constructor // Here we run InferTyconKind and record partial information about the kind of the type constructor. - // This means TyconFSharpObjModelKind is set, which means isSealedTy, isInterfaceTy etc. give accurate results. + // This means FSharpTyconKind is set, which means isSealedTy, isInterfaceTy etc. give accurate results. let withAttrs = (envMutRecPrelim, withEnvs) ||> MutRecShapes.mapTyconsWithEnv (fun envForDecls (origInfo, tyconOpt) -> let res = @@ -4093,6 +4153,116 @@ module TcDeclarations = | SynMemberDefn.NestedType (range=m) :: _ -> errorR(InternalError("CheckMembersForm: List.takeUntil is wrong", m)) | _ -> () + // Check order for static incremental construction + let _, ds2 = ds |> List.takeUntil (function SynMemberDefn.LetBindings _ -> false | _ -> true) + let _, ds2 = ds2 |> List.takeUntil (allFalse [isMember;isAbstractSlot;isInterface;isAutoProperty]) + + match ds2 with + | SynMemberDefn.LetBindings (range=m) :: _ -> errorR(Error(FSComp.SR.tcTypeDefinitionsWithImplicitConstructionMustHaveLocalBindingsBeforeMembers(), m)) + | _ -> () + + + /// Split auto-properties into 'let' and 'member' bindings + let private SplitAutoProps members = + let membersIncludingAutoProps = + members |> List.filter (fun memb -> + match memb with + | SynMemberDefn.Interface _ + | SynMemberDefn.Member _ + | SynMemberDefn.GetSetMember _ + | SynMemberDefn.LetBindings _ + | SynMemberDefn.ImplicitCtor _ + | SynMemberDefn.AutoProperty _ + | SynMemberDefn.Open _ + | SynMemberDefn.ImplicitInherit _ -> true + | SynMemberDefn.NestedType (_, _, m) -> error(Error(FSComp.SR.tcTypesCannotContainNestedTypes(), m)); false + // covered above + | SynMemberDefn.ValField _ + | SynMemberDefn.Inherit _ + | SynMemberDefn.AbstractSlot _ -> false) + + // Convert auto properties to let bindings in the pre-list + let rec preAutoProps memb = + match memb with + | SynMemberDefn.AutoProperty(attributes=Attributes attribs; isStatic=isStatic; ident=id; typeOpt=tyOpt; propKind=propKind; xmlDoc=xmlDoc; synExpr=synExpr; range=mWholeAutoProp) -> + // Only the keep the field-targeted attributes + let attribs = attribs |> List.filter (fun a -> match a.Target with Some t when t.idText = "field" -> true | _ -> false) + let mLetPortion = synExpr.Range + let fldId = ident (CompilerGeneratedName id.idText, mLetPortion) + let headPat = SynPat.LongIdent (SynLongIdent([fldId], [], [None]), None, Some noInferredTypars, SynArgPats.Pats [], None, mLetPortion) + let retInfo = match tyOpt with None -> None | Some ty -> Some (None, SynReturnInfo((ty, SynInfo.unnamedRetVal), ty.Range)) + let isMutable = + match propKind with + | SynMemberKind.PropertySet + | SynMemberKind.PropertyGetSet -> true + | _ -> false + let attribs = mkAttributeList attribs mWholeAutoProp + let binding = mkSynBinding (xmlDoc, headPat) (None, false, isMutable, mLetPortion, DebugPointAtBinding.NoneAtInvisible, retInfo, synExpr, synExpr.Range, [], attribs, None, SynBindingTrivia.Zero) + + [(SynMemberDefn.LetBindings ([binding], isStatic, false, mWholeAutoProp))] + + | SynMemberDefn.Interface (members=Some membs) -> membs |> List.collect preAutoProps + | SynMemberDefn.LetBindings _ + | SynMemberDefn.ImplicitCtor _ + | SynMemberDefn.Open _ + | SynMemberDefn.ImplicitInherit _ -> [memb] + | _ -> [] + + // Convert auto properties to member bindings in the post-list + let rec postAutoProps memb = + match memb with + | SynMemberDefn.AutoProperty(attributes=Attributes attribs; isStatic=isStatic; ident=id; typeOpt=tyOpt; propKind=propKind; memberFlags=memberFlags; memberFlagsForSet=memberFlagsForSet; xmlDoc=xmlDoc; accessibility=access; trivia = { GetSetKeyword = mGetSetOpt }) -> + let mMemberPortion = id.idRange + // Only the keep the non-field-targeted attributes + let attribs = attribs |> List.filter (fun a -> match a.Target with Some t when t.idText = "field" -> false | _ -> true) + let fldId = ident (CompilerGeneratedName id.idText, mMemberPortion) + let headPatIds = if isStatic then [id] else [ident ("__", mMemberPortion);id] + let headPat = SynPat.LongIdent (SynLongIdent(headPatIds, [], List.replicate headPatIds.Length None), None, Some noInferredTypars, SynArgPats.Pats [], None, mMemberPortion) + let memberFlags = { memberFlags with GetterOrSetterIsCompilerGenerated = true } + let memberFlagsForSet = { memberFlagsForSet with GetterOrSetterIsCompilerGenerated = true } + + match propKind, mGetSetOpt with + | SynMemberKind.PropertySet, Some m -> errorR(Error(FSComp.SR.parsMutableOnAutoPropertyShouldBeGetSetNotJustSet(), m)) + | _ -> () + + [ + match propKind with + | SynMemberKind.Member + | SynMemberKind.PropertyGet + | SynMemberKind.PropertyGetSet -> + let getter = + let rhsExpr = SynExpr.Ident fldId + let retInfo = match tyOpt with None -> None | Some ty -> Some (None, SynReturnInfo((ty, SynInfo.unnamedRetVal), ty.Range)) + let attribs = mkAttributeList attribs mMemberPortion + let binding = mkSynBinding (xmlDoc, headPat) (access, false, false, mMemberPortion, DebugPointAtBinding.NoneAtInvisible, retInfo, rhsExpr, rhsExpr.Range, [], attribs, Some memberFlags, SynBindingTrivia.Zero) + SynMemberDefn.Member (binding, mMemberPortion) + yield getter + | _ -> () + + match propKind with + | SynMemberKind.PropertySet + | SynMemberKind.PropertyGetSet -> + let setter = + let vId = ident("v", mMemberPortion) + let headPat = SynPat.LongIdent (SynLongIdent(headPatIds, [], List.replicate headPatIds.Length None), None, Some noInferredTypars, SynArgPats.Pats [mkSynPatVar None vId], None, mMemberPortion) + let rhsExpr = mkSynAssign (SynExpr.Ident fldId) (SynExpr.Ident vId) + let binding = mkSynBinding (xmlDoc, headPat) (access, false, false, mMemberPortion, DebugPointAtBinding.NoneAtInvisible, None, rhsExpr, rhsExpr.Range, [], [], Some memberFlagsForSet, SynBindingTrivia.Zero) + SynMemberDefn.Member (binding, mMemberPortion) + yield setter + | _ -> ()] + | SynMemberDefn.Interface (ty, mWith, Some membs, m) -> + let membs' = membs |> List.collect postAutoProps + [SynMemberDefn.Interface (ty, mWith, Some membs', m)] + | SynMemberDefn.LetBindings _ + | SynMemberDefn.ImplicitCtor _ + | SynMemberDefn.Open _ + | SynMemberDefn.ImplicitInherit _ -> [] + | _ -> [memb] + + let preMembers = membersIncludingAutoProps |> List.collect preAutoProps + let postMembers = membersIncludingAutoProps |> List.collect postAutoProps + + preMembers @ postMembers /// Separates the definition into core (shape) and body. /// @@ -4102,122 +4272,28 @@ module TcDeclarations = /// where members contain methods/overrides, also implicit ctor, inheritCall and local definitions. let rec private SplitTyconDefn (SynTypeDefn(typeInfo=synTyconInfo;typeRepr=trepr; members=extraMembers)) = let extraMembers = desugarGetSetMembers extraMembers - let implements1 = List.choose (function SynMemberDefn.Interface (interfaceType=ty) -> Some(ty, ty.Range) | _ -> None) extraMembers - + let extraMembers = SplitAutoProps extraMembers + let implements1 = extraMembers |> List.choose (function SynMemberDefn.Interface (interfaceType=ty) -> Some(ty, ty.Range) | _ -> None) + match trepr with - | SynTypeDefnRepr.ObjectModel(kind, cspec, m) -> - let cspec = desugarGetSetMembers cspec - CheckMembersForm cspec - let fields = cspec |> List.choose (function SynMemberDefn.ValField (fieldInfo = f) -> Some f | _ -> None) - let implements2 = cspec |> List.choose (function SynMemberDefn.Interface (interfaceType=ty) -> Some(ty, ty.Range) | _ -> None) + | SynTypeDefnRepr.ObjectModel(kind, members, m) -> + let members = desugarGetSetMembers members + + CheckMembersForm members + + let fields = members |> List.choose (function SynMemberDefn.ValField (fieldInfo = f) -> Some f | _ -> None) + let implements2 = members |> List.choose (function SynMemberDefn.Interface (interfaceType=ty) -> Some(ty, ty.Range) | _ -> None) let inherits = - cspec |> List.choose (function + members |> List.choose (function | SynMemberDefn.Inherit (ty, idOpt, m) -> Some(ty, m, idOpt) | SynMemberDefn.ImplicitInherit (ty, _, idOpt, m) -> Some(ty, m, idOpt) | _ -> None) + //let nestedTycons = cspec |> List.choose (function SynMemberDefn.NestedType (x, _, _) -> Some x | _ -> None) - let slotsigs = cspec |> List.choose (function SynMemberDefn.AbstractSlot (slotSig = x; flags = y) -> Some(x, y) | _ -> None) - - let members = - let membersIncludingAutoProps = - cspec |> List.filter (fun memb -> - match memb with - | SynMemberDefn.Interface _ - | SynMemberDefn.Member _ - | SynMemberDefn.GetSetMember _ - | SynMemberDefn.LetBindings _ - | SynMemberDefn.ImplicitCtor _ - | SynMemberDefn.AutoProperty _ - | SynMemberDefn.Open _ - | SynMemberDefn.ImplicitInherit _ -> true - | SynMemberDefn.NestedType (_, _, m) -> error(Error(FSComp.SR.tcTypesCannotContainNestedTypes(), m)); false - // covered above - | SynMemberDefn.ValField _ - | SynMemberDefn.Inherit _ - | SynMemberDefn.AbstractSlot _ -> false) - - // Convert auto properties to let bindings in the pre-list - let rec preAutoProps memb = - match memb with - | SynMemberDefn.AutoProperty(attributes=Attributes attribs; isStatic=isStatic; ident=id; typeOpt=tyOpt; propKind=propKind; xmlDoc=xmlDoc; synExpr=synExpr; range=mWholeAutoProp) -> - // Only the keep the field-targeted attributes - let attribs = attribs |> List.filter (fun a -> match a.Target with Some t when t.idText = "field" -> true | _ -> false) - let mLetPortion = synExpr.Range - let fldId = ident (CompilerGeneratedName id.idText, mLetPortion) - let headPat = SynPat.LongIdent (SynLongIdent([fldId], [], [None]), None, Some noInferredTypars, SynArgPats.Pats [], None, mLetPortion) - let retInfo = match tyOpt with None -> None | Some ty -> Some (None, SynReturnInfo((ty, SynInfo.unnamedRetVal), ty.Range)) - let isMutable = - match propKind with - | SynMemberKind.PropertySet - | SynMemberKind.PropertyGetSet -> true - | _ -> false - let attribs = mkAttributeList attribs mWholeAutoProp - let binding = mkSynBinding (xmlDoc, headPat) (None, false, isMutable, mLetPortion, DebugPointAtBinding.NoneAtInvisible, retInfo, synExpr, synExpr.Range, [], attribs, None, SynBindingTrivia.Zero) - - [(SynMemberDefn.LetBindings ([binding], isStatic, false, mWholeAutoProp))] - - | SynMemberDefn.Interface (members=Some membs) -> membs |> List.collect preAutoProps - | SynMemberDefn.LetBindings _ - | SynMemberDefn.ImplicitCtor _ - | SynMemberDefn.Open _ - | SynMemberDefn.ImplicitInherit _ -> [memb] - | _ -> [] - - // Convert auto properties to member bindings in the post-list - let rec postAutoProps memb = - match memb with - | SynMemberDefn.AutoProperty(attributes=Attributes attribs; isStatic=isStatic; ident=id; typeOpt=tyOpt; propKind=propKind; memberFlags=memberFlags; memberFlagsForSet=memberFlagsForSet; xmlDoc=xmlDoc; accessibility=access; trivia = { GetSetKeywords = mGetSetOpt }) -> - let mMemberPortion = id.idRange - // Only the keep the non-field-targeted attributes - let attribs = attribs |> List.filter (fun a -> match a.Target with Some t when t.idText = "field" -> false | _ -> true) - let fldId = ident (CompilerGeneratedName id.idText, mMemberPortion) - let headPatIds = if isStatic then [id] else [ident ("__", mMemberPortion);id] - let headPat = SynPat.LongIdent (SynLongIdent(headPatIds, [], List.replicate headPatIds.Length None), None, Some noInferredTypars, SynArgPats.Pats [], None, mMemberPortion) - let memberFlags = { memberFlags with GetterOrSetterIsCompilerGenerated = true } - let memberFlagsForSet = { memberFlagsForSet with GetterOrSetterIsCompilerGenerated = true } - - match propKind, mGetSetOpt with - | SynMemberKind.PropertySet, Some gs -> errorR(Error(FSComp.SR.parsMutableOnAutoPropertyShouldBeGetSetNotJustSet(), gs.Range)) - | _ -> () - - [ - match propKind with - | SynMemberKind.Member - | SynMemberKind.PropertyGet - | SynMemberKind.PropertyGetSet -> - let getter = - let rhsExpr = SynExpr.Ident fldId - let retInfo = match tyOpt with None -> None | Some ty -> Some (None, SynReturnInfo((ty, SynInfo.unnamedRetVal), ty.Range)) - let attribs = mkAttributeList attribs mMemberPortion - let binding = mkSynBinding (xmlDoc, headPat) (access, false, false, mMemberPortion, DebugPointAtBinding.NoneAtInvisible, retInfo, rhsExpr, rhsExpr.Range, [], attribs, Some memberFlags, SynBindingTrivia.Zero) - SynMemberDefn.Member (binding, mMemberPortion) - yield getter - | _ -> () - match propKind with - | SynMemberKind.PropertySet - | SynMemberKind.PropertyGetSet -> - let setter = - let vId = ident("v", mMemberPortion) - let headPat = SynPat.LongIdent (SynLongIdent(headPatIds, [], List.replicate headPatIds.Length None), None, Some noInferredTypars, SynArgPats.Pats [mkSynPatVar None vId], None, mMemberPortion) - let rhsExpr = mkSynAssign (SynExpr.Ident fldId) (SynExpr.Ident vId) - let binding = mkSynBinding (xmlDoc, headPat) (access, false, false, mMemberPortion, DebugPointAtBinding.NoneAtInvisible, None, rhsExpr, rhsExpr.Range, [], [], Some memberFlagsForSet, SynBindingTrivia.Zero) - SynMemberDefn.Member (binding, mMemberPortion) - yield setter - | _ -> ()] - | SynMemberDefn.Interface (ty, mWith, Some membs, m) -> - let membs' = membs |> List.collect postAutoProps - [SynMemberDefn.Interface (ty, mWith, Some membs', m)] - | SynMemberDefn.LetBindings _ - | SynMemberDefn.ImplicitCtor _ - | SynMemberDefn.Open _ - | SynMemberDefn.ImplicitInherit _ -> [] - | _ -> [memb] - - let preMembers = membersIncludingAutoProps |> List.collect preAutoProps - let postMembers = membersIncludingAutoProps |> List.collect postAutoProps - - preMembers @ postMembers + let slotsigs = members |> List.choose (function SynMemberDefn.AbstractSlot (x, y, _) -> Some(x, y) | _ -> None) + + let members = SplitAutoProps members let isConcrete = members |> List.exists (function @@ -4259,6 +4335,7 @@ module TcDeclarations = core, members @ extraMembers | SynTypeDefnRepr.Simple(repr, _) -> + let members = [] let isAtOriginalTyconDefn = true let core = MutRecDefnsPhase1DataForTycon(synTyconInfo, repr, implements1, false, false, isAtOriginalTyconDefn) diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs index f18525f47f2..492268a4920 100644 --- a/src/Compiler/Checking/CheckExpressions.fs +++ b/src/Compiler/Checking/CheckExpressions.fs @@ -283,10 +283,10 @@ type LiteralArgumentType = type DeclKind = | ModuleOrMemberBinding - /// Extensions to a type within the same assembly + /// Extensions to a type within the same module or namespace fragment | IntrinsicExtensionBinding - /// Extensions to a type in a different assembly + /// Extensions to a type not within the same module or namespace fragment | ExtrinsicExtensionBinding | ClassLetBinding of isStatic: bool diff --git a/src/Compiler/Checking/CheckIncrementalClasses.fs b/src/Compiler/Checking/CheckIncrementalClasses.fs index ce7a4203cc0..8e9f8927f9f 100644 --- a/src/Compiler/Checking/CheckIncrementalClasses.fs +++ b/src/Compiler/Checking/CheckIncrementalClasses.fs @@ -36,20 +36,32 @@ type IncrClassBindingGroup = | IncrClassDo of expr: Expr * isStatic: bool * range: Range /// Typechecked info for implicit constructor and it's arguments -type IncrClassCtorLhs = +type StaticCtorInfo = { /// The TyconRef for the type being defined TyconRef: TyconRef - /// The type parameters allocated for the implicit instance constructor. - /// These may be equated with other (WillBeRigid) type parameters through equi-recursive inference, and so - /// should always be renormalized/canonicalized when used. - InstanceCtorDeclaredTypars: Typars + /// The type parameters allocated for the implicit construction. + IncrCtorDeclaredTypars: Typars /// The value representing the static implicit constructor. /// Lazy to ensure the static ctor value is only published if needed. StaticCtorValInfo: Lazy + /// The name generator used to generate the names of fields etc. within the type. + NameGenerator: NiceNameGenerator + } + + /// Get the type parameters of the implicit constructor, after taking equi-recursive inference into account. + member ctorInfo.GetNormalizedIncrCtorDeclaredTypars (cenv: cenv) denv m = + let g = cenv.g + let ctorDeclaredTypars = ctorInfo.IncrCtorDeclaredTypars + let ctorDeclaredTypars = ChooseCanonicalDeclaredTyparsAfterInference g denv ctorDeclaredTypars m + ctorDeclaredTypars + +/// Typechecked info for implicit constructor and it's arguments +type IncrClassCtorInfo = + { /// The value representing the implicit constructor. InstanceCtorVal: Val @@ -72,20 +84,46 @@ type IncrClassCtorLhs = /// The value representing the 'this' variable within the implicit instance constructor. InstanceCtorThisVal: Val - /// The name generator used to generate the names of fields etc. within the type. - NameGenerator: NiceNameGenerator } - /// Get the type parameters of the implicit constructor, after taking equi-recursive inference into account. - member ctorInfo.GetNormalizedInstanceCtorDeclaredTypars (cenv: cenv) denv m = - let g = cenv.g - let ctorDeclaredTypars = ctorInfo.InstanceCtorDeclaredTypars - let ctorDeclaredTypars = ChooseCanonicalDeclaredTyparsAfterInference g denv ctorDeclaredTypars m - ctorDeclaredTypars +/// Check and elaborate the "left hand side" of the implicit class construction +/// syntax. +let TcStaticImplicitCtorInfo_Phase2A(cenv: cenv, env, tcref: TyconRef, m, copyOfTyconTypars) = + + let g = cenv.g + + // Add class typars to env + let env = AddDeclaredTypars CheckForDuplicateTypars copyOfTyconTypars env + + // We only generate the cctor on demand, because we don't need it if there are no cctor actions. + // The code below has a side-effect (MakeAndPublishVal), so we only want to run it once if at all. + // The .cctor is never referenced by any other code. + let cctorValInfo = + lazy + let cctorArgs = [ fst(mkCompGenLocal m "unitVar" g.unit_ty) ] + + let cctorTy = mkFunTy g g.unit_ty g.unit_ty + let valSynData = SynValInfo([[]], SynInfo.unnamedRetVal) + let id = ident ("cctor", m) + CheckForNonAbstractInterface ModuleOrMemberBinding tcref ClassCtorMemberFlags id.idRange + let memberInfo = MakeMemberDataAndMangledNameForMemberVal(g, tcref, false, [], [], ClassCtorMemberFlags, valSynData, id, false) + let prelimValReprInfo = TranslateSynValInfo m (TcAttributes cenv env) valSynData + let prelimTyschemeG = GeneralizedType(copyOfTyconTypars, cctorTy) + let valReprInfo = InferGenericArityFromTyScheme prelimTyschemeG prelimValReprInfo + let cctorValScheme = ValScheme(id, prelimTyschemeG, Some valReprInfo, None, Some memberInfo, false, ValInline.Never, NormalVal, Some (SynAccess.Private Range.Zero), false, true, false, false) + + let cctorVal = MakeAndPublishVal cenv env (Parent tcref, false, ModuleOrMemberBinding, ValNotInRecScope, cctorValScheme, [(* no attributes*)], XmlDoc.Empty, None, false) + cctorArgs, cctorVal, cctorValScheme + + { TyconRef = tcref + IncrCtorDeclaredTypars = copyOfTyconTypars + StaticCtorValInfo = cctorValInfo + NameGenerator = NiceNameGenerator() + } /// Check and elaborate the "left hand side" of the implicit class construction /// syntax. -let TcImplicitCtorLhs_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, attrs, spats, thisIdOpt, baseValOpt: Val option, safeInitInfo, m, copyOfTyconTypars, objTy, thisTy, xmlDoc: PreXmlDoc) = +let TcImplicitCtorInfo_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, attrs, spats, thisIdOpt, baseValOpt: Val option, safeInitInfo, m, copyOfTyconTypars, objTy, thisTy, xmlDoc: PreXmlDoc) = let g = cenv.g let baseValOpt = @@ -142,26 +180,6 @@ let TcImplicitCtorLhs_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, attr let ctorVal = MakeAndPublishVal cenv env (Parent tcref, false, ModuleOrMemberBinding, ValInRecScope isComplete, ctorValScheme, attribs, xmlDoc, None, false) ctorValScheme, ctorVal - // We only generate the cctor on demand, because we don't need it if there are no cctor actions. - // The code below has a side-effect (MakeAndPublishVal), so we only want to run it once if at all. - // The .cctor is never referenced by any other code. - let cctorValInfo = - lazy - let cctorArgs = [ fst(mkCompGenLocal m "unitVar" g.unit_ty) ] - - let cctorTy = mkFunTy g g.unit_ty g.unit_ty - let valSynData = SynValInfo([[]], SynInfo.unnamedRetVal) - let id = ident ("cctor", m) - CheckForNonAbstractInterface g ModuleOrMemberBinding tcref ClassCtorMemberFlags false id.idRange - let memberInfo = MakeMemberDataAndMangledNameForMemberVal(g, tcref, false, [], [], ClassCtorMemberFlags, valSynData, id, false) - let prelimValReprInfo = TranslateSynValInfo cenv m (TcAttributes cenv env) valSynData - let prelimTyschemeG = GeneralizedType(copyOfTyconTypars, cctorTy) - let valReprInfo = InferGenericArityFromTyScheme prelimTyschemeG prelimValReprInfo - let cctorValScheme = ValScheme(id, prelimTyschemeG, Some valReprInfo, None, Some memberInfo, false, ValInline.Never, NormalVal, Some (SynAccess.Private Range.Zero), false, true, false, false) - - let cctorVal = MakeAndPublishVal cenv env (Parent tcref, false, ModuleOrMemberBinding, ValNotInRecScope, cctorValScheme, [(* no attributes*)], XmlDoc.Empty, None, false) - cctorArgs, cctorVal, cctorValScheme - let thisVal = // --- Create this for use inside constructor let thisId = ident ("this", m) @@ -169,18 +187,13 @@ let TcImplicitCtorLhs_Phase2A(cenv: cenv, env, tpenv, tcref: TyconRef, vis, attr let thisVal = MakeAndPublishVal cenv env (ParentNone, false, ClassLetBinding false, ValNotInRecScope, thisValScheme, [], XmlDoc.Empty, None, false) thisVal - { TyconRef = tcref - InstanceCtorDeclaredTypars = copyOfTyconTypars - StaticCtorValInfo = cctorValInfo - InstanceCtorArgs = ctorArgs + { InstanceCtorArgs = ctorArgs InstanceCtorVal = ctorVal InstanceCtorValScheme = ctorValScheme InstanceCtorBaseValOpt = baseValOpt InstanceCtorSafeThisValOpt = safeThisValOpt InstanceCtorSafeInitInfo = safeInitInfo InstanceCtorThisVal = thisVal - // For generating names of local fields - NameGenerator = NiceNameGenerator() } @@ -259,13 +272,15 @@ type IncrClassReprInfo = /// /// /// - /// + /// + /// /// The vars forced to be fields due to static member bindings, instance initialization expressions or instance member bindings /// The vars forced to be fields due to instance member bindings /// /// member localRep.ChooseRepresentation (cenv: cenv, env: TcEnv, isStatic, isCtorArg, - ctorInfo: IncrClassCtorLhs, + staticCtorInfo: StaticCtorInfo, + ctorInfoOpt: IncrClassCtorInfo option, staticForcedFieldVars: FreeLocals, instanceForcedFieldVars: FreeLocals, takenFieldNames: Set, @@ -274,7 +289,7 @@ type IncrClassReprInfo = let v = bind.Var let relevantForcedFieldVars = (if isStatic then staticForcedFieldVars else instanceForcedFieldVars) - let tcref = ctorInfo.TyconRef + let tcref = staticCtorInfo.TyconRef let name, takenFieldNames = let isNameTaken = @@ -285,7 +300,7 @@ type IncrClassReprInfo = let nm = if isNameTaken then - ctorInfo.NameGenerator.FreshCompilerGeneratedName (v.LogicalName, v.Range) + staticCtorInfo.NameGenerator.FreshCompilerGeneratedName (v.LogicalName, v.Range) else v.LogicalName nm, takenFieldNames.Add nm @@ -329,7 +344,7 @@ type IncrClassReprInfo = let id = mkSynId v.Range name let memberInfo = MakeMemberDataAndMangledNameForMemberVal(g, tcref, false, [], [], memberFlags, valSynInfo, mkSynId v.Range name, true) - let copyOfTyconTypars = ctorInfo.GetNormalizedInstanceCtorDeclaredTypars cenv env.DisplayEnv ctorInfo.TyconRef.Range + let copyOfTyconTypars = staticCtorInfo.GetNormalizedIncrCtorDeclaredTypars cenv env.DisplayEnv staticCtorInfo.TyconRef.Range AdjustValToHaveValReprInfo v (Parent tcref) valReprInfo @@ -339,10 +354,13 @@ type IncrClassReprInfo = if isStatic then tauTy, valReprInfo else - let tauTy = mkFunTy g ctorInfo.InstanceCtorThisVal.Type v.TauType - let (ValReprInfo(tpNames, args, ret)) = valReprInfo - let valReprInfo = ValReprInfo(tpNames, ValReprInfo.selfMetadata :: args, ret) - tauTy, valReprInfo + match ctorInfoOpt with + | None -> tauTy, valReprInfo + | Some ctorInfo -> + let tauTy = mkFunTy g ctorInfo.InstanceCtorThisVal.Type v.TauType + let (ValReprInfo(tpNames, args, ret)) = valReprInfo + let valReprInfo = ValReprInfo(tpNames, ValReprInfo.selfMetadata :: args, ret) + tauTy, valReprInfo // Add the enclosing type parameters on to the function let valReprInfo = @@ -363,9 +381,9 @@ type IncrClassReprInfo = repr, takenFieldNames /// Extend the known local representations by choosing a representation for a binding - member localRep.ChooseAndAddRepresentation(cenv: cenv, env: TcEnv, isStatic, isCtorArg, ctorInfo: IncrClassCtorLhs, staticForcedFieldVars: FreeLocals, instanceForcedFieldVars: FreeLocals, bind: Binding) = + member localRep.ChooseAndAddRepresentation(cenv, env, isStatic, isCtorArg, staticCtorInfo, ctorInfoOpt, staticForcedFieldVars, instanceForcedFieldVars, bind: Binding) = let v = bind.Var - let repr, takenFieldNames = localRep.ChooseRepresentation (cenv, env, isStatic, isCtorArg, ctorInfo, staticForcedFieldVars, instanceForcedFieldVars, localRep.TakenFieldNames, bind ) + let repr, takenFieldNames = localRep.ChooseRepresentation (cenv, env, isStatic, isCtorArg, staticCtorInfo, ctorInfoOpt, staticForcedFieldVars, instanceForcedFieldVars, localRep.TakenFieldNames, bind ) // OK, representation chosen, now add it {localRep with TakenFieldNames=takenFieldNames @@ -451,8 +469,8 @@ type IncrClassReprInfo = /// Mutate a type definition by adding fields /// Used as part of processing "let" bindings in a type definition. - member localRep.PublishIncrClassFields (cenv, denv, cpath, ctorInfo: IncrClassCtorLhs, safeStaticInitInfo) = - let tcref = ctorInfo.TyconRef + member localRep.PublishIncrClassFields (cenv, denv, cpath, staticCtorInfo: StaticCtorInfo, safeStaticInitInfo) = + let tcref = staticCtorInfo.TyconRef let rfspecs = [ for KeyValue(v, repr) in localRep.ValReprs do match repr with @@ -461,7 +479,7 @@ type IncrClassReprInfo = // constructor arguments. This is important for the "default value" and "does it have an implicit default constructor" // semantic conditions for structs - see bug FSharp 1.0 5304. if isStatic || not tcref.IsFSharpStructOrEnumTycon then - let ctorDeclaredTypars = ctorInfo.GetNormalizedInstanceCtorDeclaredTypars cenv denv ctorInfo.TyconRef.Range + let ctorDeclaredTypars = staticCtorInfo.GetNormalizedIncrCtorDeclaredTypars cenv denv staticCtorInfo.TyconRef.Range // Note: tcrefObjTy contains the original "formal" typars, thisTy is the "fresh" one... f<>fresh. let revTypeInst = List.zip ctorDeclaredTypars (tcref.TyparsNoRange |> List.map mkTyparTy) @@ -474,11 +492,18 @@ type IncrClassReprInfo = | SafeInitField (_, fld) -> yield fld | NoSafeInitInfo -> () ] - let recdFields = Construct.MakeRecdFieldsTable (rfspecs @ tcref.AllFieldsAsList) - - // Mutate the entity_tycon_repr to publish the fields - tcref.Deref.entity_tycon_repr <- TFSharpObjectRepr { tcref.FSharpObjectModelTypeInfo with fsobjmodel_rfields = recdFields} + let allFields = rfspecs @ tcref.AllFieldsAsList + match allFields with + | [] -> () + | _ -> + match tcref.TypeReprInfo with + | TFSharpTyconRepr info -> + let recdFields = Construct.MakeRecdFieldsTable (rfspecs @ tcref.AllFieldsAsList) + // Mutate the entity_tycon_repr to publish the fields + tcref.Deref.entity_tycon_repr <- TFSharpTyconRepr { info with fsobjmodel_rfields = recdFields} + | _ -> + errorR(InternalError("unreachable, anything that can have fields should be a TFSharpTyconRepr", tcref.Range)) /// Given localRep saying how locals have been represented, e.g. as fields. /// Given an expr under a given thisVal context. @@ -536,25 +561,13 @@ type IncrClassConstructionBindingsPhase2C = | Phase2CCtorJustAfterSuperInit | Phase2CCtorJustAfterLastLet -/// /// Given a set of 'let' bindings (static or not, recursive or not) that make up a class, /// generate their initialization expression(s). -/// -/// -/// -/// The lhs information about the implicit constructor -/// The call to the super class constructor -/// Should we place a sequence point at the 'inheritedTys call? -/// The declarations -/// -/// Record any unconstrained type parameters generalized for the outer members as "free choices" in the let bindings -/// let MakeCtorForIncrClassConstructionPhase2C( cenv: cenv, env: TcEnv, - ctorInfo: IncrClassCtorLhs, - inheritsExpr, - inheritsIsVisible, + staticCtorInfo: StaticCtorInfo, + instanceInfo: (IncrClassCtorInfo * Expr * bool) option, decs: IncrClassConstructionBindingsPhase2C list, memberBinds: Binding list, generalizedTyparsForRecursiveBlock, @@ -564,15 +577,30 @@ let MakeCtorForIncrClassConstructionPhase2C( let denv = env.DisplayEnv let g = cenv.g - let thisVal = ctorInfo.InstanceCtorThisVal - let m = thisVal.Range - let ctorDeclaredTypars = ctorInfo.GetNormalizedInstanceCtorDeclaredTypars cenv denv m + let thisValOpt = + match instanceInfo with + | None -> None + | Some (ctorInfo, _, _) -> Some ctorInfo.InstanceCtorThisVal + + let ctorInfoOpt = + match instanceInfo with + | None -> None + | Some (ctorInfo, _, _) -> Some ctorInfo + + let m = + match thisValOpt with + | Some thisVal -> thisVal.Range + | None -> staticCtorInfo.TyconRef.Range + + let ctorDeclaredTypars = staticCtorInfo.GetNormalizedIncrCtorDeclaredTypars cenv denv m ctorDeclaredTypars |> List.iter (SetTyparRigid env.DisplayEnv m) // Reconstitute the type with the correct quantified type variables. - ctorInfo.InstanceCtorVal.SetType (mkForallTyIfNeeded ctorDeclaredTypars ctorInfo.InstanceCtorVal.TauType) + match instanceInfo with + | Some (ctorInfo, _, _) -> ctorInfo.InstanceCtorVal.SetType (mkForallTyIfNeeded ctorDeclaredTypars ctorInfo.InstanceCtorVal.TauType) + | None -> () let freeChoiceTypars = ListSet.subtract typarEq generalizedTyparsForRecursiveBlock ctorDeclaredTypars @@ -627,7 +655,10 @@ let MakeCtorForIncrClassConstructionPhase2C( let instanceForcedFieldVars = (instanceForcedFieldVars, memberBinds) ||> accFreeInBindings // Any references to static variables in the 'inherits' expression force those static variables to be represented as fields - let staticForcedFieldVars = (staticForcedFieldVars, inheritsExpr) ||> accFreeInExpr + let staticForcedFieldVars = + match instanceInfo with + | Some (_, inheritsExpr, _) -> (staticForcedFieldVars, inheritsExpr) ||> accFreeInExpr + | None -> staticForcedFieldVars (staticForcedFieldVars.FreeLocals, instanceForcedFieldVars.FreeLocals) @@ -637,13 +668,16 @@ let MakeCtorForIncrClassConstructionPhase2C( let TransBind (reps: IncrClassReprInfo) (TBind(v, rhsExpr, spBind)) = if v.MustInline then error(Error(FSComp.SR.tcLocalClassBindingsCannotBeInline(), v.Range)) - let rhsExpr = reps.FixupIncrClassExprPhase2C cenv (Some thisVal) safeStaticInitInfo thisTyInst rhsExpr + let rhsExpr = reps.FixupIncrClassExprPhase2C cenv thisValOpt safeStaticInitInfo thisTyInst rhsExpr // The initialization of the 'ref cell' variable for 'this' is the only binding which comes prior to the super init let isPriorToSuperInit = - match ctorInfo.InstanceCtorSafeThisValOpt with + match instanceInfo with | None -> false - | Some v2 -> valEq v v2 + | Some (ctorInfo, _, _) -> + match ctorInfo.InstanceCtorSafeThisValOpt with + | None -> false + | Some v2 -> valEq v v2 match reps.LookupRepr v with | InMethod(isStatic, methodVal, _) -> @@ -661,8 +695,11 @@ let MakeCtorForIncrClassConstructionPhase2C( if isStatic then tauExpr, tauTy else - let e = mkLambda m thisVal (tauExpr, tauTy) - e, tyOfExpr g e + match thisValOpt with + | None -> tauExpr, tauTy + | Some thisVal -> + let e = mkLambda m thisVal (tauExpr, tauTy) + e, tyOfExpr g e // Replace the type parameters that used to be on the rhs with // the full set of type parameters including the type parameters of the enclosing class @@ -684,14 +721,14 @@ let MakeCtorForIncrClassConstructionPhase2C( | DebugPointAtBinding.Yes m, _ -> m | _ -> v.Range - let assignExpr = reps.MakeValueAssign (Some thisVal) thisTyInst NoSafeInitInfo v rhsExpr m + let assignExpr = reps.MakeValueAssign thisValOpt thisTyInst NoSafeInitInfo v rhsExpr m let adjustSafeInitFieldExprOpt = if isStatic then match safeStaticInitInfo with | SafeInitField (rfref, _) -> let setExpr = mkStaticRecdFieldSet (rfref, thisTyInst, mkInt g m idx, m) - let setExpr = reps.FixupIncrClassExprPhase2C cenv (Some thisVal) NoSafeInitInfo thisTyInst setExpr + let setExpr = reps.FixupIncrClassExprPhase2C cenv thisValOpt NoSafeInitInfo thisTyInst setExpr Some setExpr | NoSafeInitInfo -> None @@ -717,7 +754,7 @@ let MakeCtorForIncrClassConstructionPhase2C( match dec with | IncrClassBindingGroup(binds, isStatic, isRec) -> let actions, reps, methodBinds = - let reps = (reps, binds) ||> List.fold (fun rep bind -> rep.ChooseAndAddRepresentation(cenv, env, isStatic, isCtorArg, ctorInfo, staticForcedFieldVars, instanceForcedFieldVars, bind)) // extend + let reps = (reps, binds) ||> List.fold (fun rep bind -> rep.ChooseAndAddRepresentation(cenv, env, isStatic, isCtorArg, staticCtorInfo, ctorInfoOpt, staticForcedFieldVars, instanceForcedFieldVars, bind)) // extend if isRec then // Note: the recursive calls are made via members on the object // or via access to fields. This means the recursive loop is "broken", @@ -736,7 +773,7 @@ let MakeCtorForIncrClassConstructionPhase2C( ([], actions, methodBinds), reps | IncrClassDo (doExpr, isStatic, mFull) -> - let doExpr = reps.FixupIncrClassExprPhase2C cenv (Some thisVal) safeStaticInitInfo thisTyInst doExpr + let doExpr = reps.FixupIncrClassExprPhase2C cenv thisValOpt safeStaticInitInfo thisTyInst doExpr // Extend the range of any immediate debug point to include the 'do' let doExpr = match doExpr with @@ -757,11 +794,14 @@ let MakeCtorForIncrClassConstructionPhase2C( // The call to the base class constructor is done so we can set the ref cell | Phase2CCtorJustAfterSuperInit -> let binders = - [ match ctorInfo.InstanceCtorSafeThisValOpt with + [ match instanceInfo with + | None -> () + | Some (ctorInfo, _, _) -> + match ctorInfo.InstanceCtorSafeThisValOpt with | None -> () | Some v -> let setExpr = mkRefCellSet g m ctorInfo.InstanceCtorThisVal.Type (exprForVal m v) (exprForVal m ctorInfo.InstanceCtorThisVal) - let setExpr = reps.FixupIncrClassExprPhase2C cenv (Some thisVal) safeStaticInitInfo thisTyInst setExpr + let setExpr = reps.FixupIncrClassExprPhase2C cenv thisValOpt safeStaticInitInfo thisTyInst setExpr let binder = (fun e -> mkSequential setExpr.Range setExpr e) let isPriorToSuperInit = false yield (isPriorToSuperInit, binder) ] @@ -772,10 +812,13 @@ let MakeCtorForIncrClassConstructionPhase2C( // which now allows members to be called. | Phase2CCtorJustAfterLastLet -> let binders = - [ match ctorInfo.InstanceCtorSafeInitInfo with + [ match instanceInfo with + | None -> () + | Some (ctorInfo, _, _) -> + match ctorInfo.InstanceCtorSafeInitInfo with | SafeInitField (rfref, _) -> - let setExpr = mkRecdFieldSetViaExprAddr (exprForVal m thisVal, rfref, thisTyInst, mkOne g m, m) - let setExpr = reps.FixupIncrClassExprPhase2C cenv (Some thisVal) safeStaticInitInfo thisTyInst setExpr + let setExpr = mkRecdFieldSetViaExprAddr (exprForVal m ctorInfo.InstanceCtorThisVal, rfref, thisTyInst, mkOne g m, m) + let setExpr = reps.FixupIncrClassExprPhase2C cenv thisValOpt safeStaticInitInfo thisTyInst setExpr let binder = (fun e -> mkSequential setExpr.Range setExpr e) let isPriorToSuperInit = false yield (isPriorToSuperInit, binder) @@ -804,7 +847,11 @@ let MakeCtorForIncrClassConstructionPhase2C( // the value is already available as an argument, and that nothing special needs to be done unless the // value is being stored into a field. let (cctorInitActions1, ctorInitActions1, methodBinds1), reps = - let binds = ctorInfo.InstanceCtorArgs |> List.map (fun v -> mkInvisibleBind v (exprForVal v.Range v)) + let binds = + match instanceInfo with + | None -> [] + | Some (ctorInfo, _, _) -> + ctorInfo.InstanceCtorArgs |> List.map (fun v -> mkInvisibleBind v (exprForVal v.Range v)) TransTrueDec true reps (IncrClassBindingGroup(binds, false, false)) // We expect that only ctorInitActions1 will be non-empty here, and even then only if some elements are stored in the field @@ -818,7 +865,10 @@ let MakeCtorForIncrClassConstructionPhase2C( let ctorInitActions = ctorInitActions1 @ List.concat ctorInitActions2 let methodBinds = methodBinds1 @ List.concat methodBinds2 - let ctorBody = + let ctorBodyOpt = + match instanceInfo with + | None -> None + | Some (ctorInfo, inheritsExpr, inheritsIsVisible) -> // Build the elements of the implicit constructor body, starting from the bottom // // @@ -843,7 +893,7 @@ let MakeCtorForIncrClassConstructionPhase2C( // // As a result, the most natural way to implement this would be to simply capture arg0 if needed // and access all variables via that. This would be done by rewriting the inheritsExpr as follows: - // let inheritsExpr = reps.FixupIncrClassExprPhase2C (Some thisVal) thisTyInst inheritsExpr + // let inheritsExpr = reps.FixupIncrClassExprPhase2C thisValOpt thisTyInst inheritsExpr // However, the rules of IL mean we are not actually allowed to capture arg0 // and store it as a closure field before the base class constructor is called. // @@ -857,7 +907,7 @@ let MakeCtorForIncrClassConstructionPhase2C( // Rewrite the expression to convert it to a load of a field if needed. // We are allowed to load fields from our own object even though we haven't called // the super class constructor yet. - let ldexpr = reps.FixupIncrClassExprPhase2C cenv (Some thisVal) safeStaticInitInfo thisTyInst (exprForVal m v) + let ldexpr = reps.FixupIncrClassExprPhase2C cenv thisValOpt safeStaticInitInfo thisTyInst (exprForVal m v) mkInvisibleLet m v ldexpr inheritsExpr | _ -> inheritsExpr @@ -875,9 +925,9 @@ let MakeCtorForIncrClassConstructionPhase2C( let ctorBody = List.foldBack (fun (_, binder) acc -> binder acc) ctorInitActionsPre ctorBody // Add the final wrapping to make this into a method - let ctorBody = mkMemberLambdas g m [] (Some thisVal) ctorInfo.InstanceCtorBaseValOpt [ctorInfo.InstanceCtorArgs] (ctorBody, g.unit_ty) + let ctorBody = mkMemberLambdas g m [] thisValOpt ctorInfo.InstanceCtorBaseValOpt [ctorInfo.InstanceCtorArgs] (ctorBody, g.unit_ty) - ctorBody + Some ctorBody let cctorBodyOpt = // Omit the .cctor if it's empty @@ -885,11 +935,10 @@ let MakeCtorForIncrClassConstructionPhase2C( | [] -> None | _ -> let cctorInitAction = List.foldBack (fun (_, binder) acc -> binder acc) cctorInitActions (mkUnit g m) - let m = thisVal.Range - let cctorArgs, cctorVal, _ = ctorInfo.StaticCtorValInfo.Force() + let cctorArgs, cctorVal, _ = staticCtorInfo.StaticCtorValInfo.Force() // Reconstitute the type of the implicit class constructor with the correct quantified type variables. cctorVal.SetType (mkForallTyIfNeeded ctorDeclaredTypars cctorVal.TauType) let cctorBody = mkMemberLambdas g m [] None None [cctorArgs] (cctorInitAction, g.unit_ty) Some cctorBody - ctorBody, cctorBodyOpt, methodBinds, reps + ctorBodyOpt, cctorBodyOpt, methodBinds, reps diff --git a/src/Compiler/Checking/CheckIncrementalClasses.fsi b/src/Compiler/Checking/CheckIncrementalClasses.fsi index cef65f2a33f..0de56111ff9 100644 --- a/src/Compiler/Checking/CheckIncrementalClasses.fsi +++ b/src/Compiler/Checking/CheckIncrementalClasses.fsi @@ -13,21 +13,26 @@ open FSharp.Compiler.Xml exception ParameterlessStructCtor of range: range -/// Typechecked info for implicit constructor and it's arguments -type IncrClassCtorLhs = +/// Typechecked info for implicit static constructor +type StaticCtorInfo = { /// The TyconRef for the type being defined TyconRef: TyconRef - /// The type parameters allocated for the implicit instance constructor. - /// These may be equated with other (WillBeRigid) type parameters through equi-recursive inference, and so - /// should always be renormalized/canonicalized when used. - InstanceCtorDeclaredTypars: Typars + /// The copy of the type parameters allocated for implicit construction + IncrCtorDeclaredTypars: Typars /// The value representing the static implicit constructor. /// Lazy to ensure the static ctor value is only published if needed. StaticCtorValInfo: Lazy + /// The name generator used to generate the names of fields etc. within the type. + NameGenerator: NiceNameGenerator + } + +/// Typechecked info for implicit instance constructor and it's arguments +type IncrClassCtorInfo = + { /// The value representing the implicit constructor. InstanceCtorVal: Val @@ -49,9 +54,6 @@ type IncrClassCtorLhs = /// The value representing the 'this' variable within the implicit instance constructor. InstanceCtorThisVal: Val - - /// The name generator used to generate the names of fields etc. within the type. - NameGenerator: NiceNameGenerator } /// Indicates how is a 'let' bound value in a class with implicit construction is represented in @@ -90,7 +92,7 @@ type IncrClassReprInfo = cenv: TcFileState * denv: DisplayEnv * cpath: CompilationPath * - ctorInfo: IncrClassCtorLhs * + staticCtorInfo: StaticCtorInfo * safeStaticInitInfo: SafeInitData -> unit @@ -116,7 +118,12 @@ type IncrClassConstructionBindingsPhase2C = /// Check and elaborate the "left hand side" of the implicit class construction /// syntax. -val TcImplicitCtorLhs_Phase2A: +val TcStaticImplicitCtorInfo_Phase2A: + cenv: TcFileState * env: TcEnv * tcref: TyconRef * m: range * copyOfTyconTypars: Typar list -> StaticCtorInfo + +/// Check and elaborate the "left hand side" of the implicit class construction +/// syntax. +val TcImplicitCtorInfo_Phase2A: cenv: TcFileState * env: TcEnv * tpenv: UnscopedTyparEnv * @@ -132,7 +139,7 @@ val TcImplicitCtorLhs_Phase2A: objTy: TType * thisTy: TType * xmlDoc: PreXmlDoc -> - IncrClassCtorLhs + IncrClassCtorInfo /// /// Given a set of 'let' bindings (static or not, recursive or not) that make up a class, @@ -140,9 +147,8 @@ val TcImplicitCtorLhs_Phase2A: /// /// /// -/// The lhs information about the implicit constructor -/// The call to the super class constructor -/// Should we place a sequence point at the 'inheritedTys call? +/// The information about the static implicit constructor +/// The lhs information about the implicit constructor, the call to the super class constructor and whether we should we place a sequence point at the 'inheritedTys call? /// The declarations /// /// Record any unconstrained type parameters generalized for the outer members as "free choices" in the let bindings @@ -150,11 +156,10 @@ val TcImplicitCtorLhs_Phase2A: val MakeCtorForIncrClassConstructionPhase2C: cenv: TcFileState * env: TcEnv * - ctorInfo: IncrClassCtorLhs * - inheritsExpr: Expr * - inheritsIsVisible: bool * + staticCtorInfo: StaticCtorInfo * + instanceInfo: (IncrClassCtorInfo * Expr * bool) option * decs: IncrClassConstructionBindingsPhase2C list * memberBinds: Binding list * generalizedTyparsForRecursiveBlock: Typar list * safeStaticInitInfo: SafeInitData -> - Expr * Expr option * Binding list * IncrClassReprInfo + Expr option * Expr option * Binding list * IncrClassReprInfo diff --git a/src/Compiler/Checking/InfoReader.fs b/src/Compiler/Checking/InfoReader.fs index 5a6b63722cc..86bbb1b83ca 100644 --- a/src/Compiler/Checking/InfoReader.fs +++ b/src/Compiler/Checking/InfoReader.fs @@ -490,7 +490,7 @@ type InfoReader(g: TcGlobals, amap: Import.ImportMap) as this = | Some name when name = overridesName -> true | _ -> false if canAccumulate then - match mdefs.TryFindInstanceByNameAndCallingSignature (overrideBy.Name, overrideBy.MethodRef.CallingSignature) with + match mdefs.TryFindInstanceByNameAndCallingSignature (overrideBy.Name, overrideBy.MethodRef.GetCallingSignature()) with | Some mdef -> let overridesILTy = ilMethImpl.Overrides.DeclaringType let overridesTyFullName = overridesILTy.TypeRef.FullName diff --git a/src/Compiler/Checking/NicePrint.fs b/src/Compiler/Checking/NicePrint.fs index 7f0779c062e..5bcc2bab760 100644 --- a/src/Compiler/Checking/NicePrint.fs +++ b/src/Compiler/Checking/NicePrint.fs @@ -1750,11 +1750,13 @@ module TastDefinitionPrinting = let breakTypeDefnEqn repr = match repr with | TILObjectRepr _ -> true - | TFSharpObjectRepr _ -> true - | TFSharpRecdRepr _ -> true - | TFSharpUnionRepr r -> - not (isNilOrSingleton r.CasesTable.UnionCasesAsList) || - r.CasesTable.UnionCasesAsList |> List.exists (fun uc -> not uc.XmlDoc.IsEmpty) + | TFSharpTyconRepr d -> + match d.fsobjmodel_kind with + | TFSharpUnion -> + let r = d.fsobjmodel_cases + not (isNilOrSingleton r.UnionCasesAsList) || + r.UnionCasesAsList |> List.exists (fun uc -> not uc.XmlDoc.IsEmpty) + | _ -> true | TAsmRepr _ | TMeasureableRepr _ #if !NO_TYPEPROVIDERS @@ -2066,7 +2068,7 @@ module TastDefinitionPrinting = let typeDeclL = match repr with - | TFSharpRecdRepr _ -> + | TFSharpTyconRepr { fsobjmodel_kind=TFSharpRecord } -> let denv = denv.AddAccessibility tycon.TypeReprAccessibility // For records, use multi-line layout as soon as there is XML doc @@ -2102,7 +2104,7 @@ module TastDefinitionPrinting = |> addMaxMembers |> addLhs - | TFSharpUnionRepr _ -> + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpUnion } -> let denv = denv.AddAccessibility tycon.TypeReprAccessibility tycon.UnionCasesAsList |> layoutUnionCases denv infoReader tcref @@ -2112,7 +2114,7 @@ module TastDefinitionPrinting = |> addMaxMembers |> addLhs - | TFSharpObjectRepr { fsobjmodel_kind = TFSharpDelegate slotSig } -> + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpDelegate slotSig } -> let (TSlotSig(_, _, _, _, paraml, retTy)) = slotSig let retTy = GetFSharpViewOfReturnType denv.g retTy let delegateL = WordL.keywordDelegate ^^ WordL.keywordOf -* layoutTopType denv SimplifyTypes.typeSimplificationInfo0 (paraml |> List.mapSquared (fun sp -> (sp.Type, ValReprInfo.unnamedTopArg1))) retTy [] @@ -2120,10 +2122,10 @@ module TastDefinitionPrinting = |> addLhs // Measure declarations are '[] type kg' unless abbreviations - | TFSharpObjectRepr _ when isMeasure -> + | TFSharpTyconRepr _ when isMeasure -> lhsL - | TFSharpObjectRepr { fsobjmodel_kind = TFSharpEnum } -> + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpEnum } -> tycon.TrueFieldsAsList |> List.map (fun f -> match f.LiteralValue with @@ -2136,7 +2138,7 @@ module TastDefinitionPrinting = |> aboveListL |> addLhs - | TFSharpObjectRepr objRepr when isNil allDecls -> + | TFSharpTyconRepr objRepr when isNil allDecls -> match objRepr.fsobjmodel_kind with | TFSharpClass -> WordL.keywordClass ^^ WordL.keywordEnd @@ -2149,7 +2151,7 @@ module TastDefinitionPrinting = |> addLhs | _ -> lhsL - | TFSharpObjectRepr _ -> + | TFSharpTyconRepr _ -> allDecls |> applyMaxMembers denv.maxMembers |> aboveListL diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs index 145c7e0799c..41645505ff3 100644 --- a/src/Compiler/Checking/PostInferenceChecks.fs +++ b/src/Compiler/Checking/PostInferenceChecks.fs @@ -2463,7 +2463,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = if TyconRefHasAttribute g m g.attrib_IsReadOnlyAttribute tcref && not tycon.IsStructOrEnumTycon then errorR(Error(FSComp.SR.tcIsReadOnlyNotStruct(), tycon.Range)) - // Considers TFSharpObjectRepr, TFSharpRecdRepr and TFSharpUnionRepr. + // Considers TFSharpTyconRepr and TFSharpUnionRepr. // [Review] are all cases covered: TILObjectRepr, TAsmRepr. [Yes - these are FSharp.Core.dll only] tycon.AllFieldsArray |> Array.iter (CheckRecdField false cenv env tycon) @@ -2501,7 +2501,7 @@ let CheckEntityDefn cenv env (tycon: Entity) = if tycon.IsFSharpDelegateTycon then match tycon.TypeReprInfo with - | TFSharpObjectRepr r -> + | TFSharpTyconRepr r -> match r.fsobjmodel_kind with | TFSharpDelegate ss -> //ss.ClassTypars diff --git a/src/Compiler/Checking/SignatureConformance.fs b/src/Compiler/Checking/SignatureConformance.fs index 2aa8bf924db..6ea987ac890 100644 --- a/src/Compiler/Checking/SignatureConformance.fs +++ b/src/Compiler/Checking/SignatureConformance.fs @@ -505,15 +505,13 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = | l -> (errorR (Error (FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesButSignatureDoesNot(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName, k, String.concat ";" l), m)); false) match implTycon.TypeReprInfo, sigTypeRepr with - | (TFSharpRecdRepr _ - | TFSharpUnionRepr _ - | TILObjectRepr _ + | (TILObjectRepr _ #if !NO_TYPEPROVIDERS | TProvidedTypeRepr _ | TProvidedNamespaceRepr _ #endif ), TNoRepr -> true - | TFSharpObjectRepr r, TNoRepr -> + | TFSharpTyconRepr r, TNoRepr -> match r.fsobjmodel_kind with | TFSharpStruct | TFSharpEnum -> (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleImplDefinesStruct(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) @@ -523,23 +521,33 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleDotNetTypeRepresentationIsHidden(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) | TMeasureableRepr _, TNoRepr -> (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsHidden(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) - | TFSharpUnionRepr r1, TFSharpUnionRepr r2 -> + + // Union types are compatible with union types in signature + | TFSharpTyconRepr { fsobjmodel_kind=TFSharpUnion; fsobjmodel_cases=r1}, + TFSharpTyconRepr { fsobjmodel_kind=TFSharpUnion; fsobjmodel_cases=r2} -> let ucases1 = r1.UnionCasesAsList let ucases2 = r2.UnionCasesAsList if ucases1.Length <> ucases2.Length then let names (l: UnionCase list) = l |> List.map (fun c -> c.Id.idText) reportNiceError "union case" (names ucases1) (names ucases2) else List.forall2 (checkUnionCase aenv infoReader implTycon) ucases1 ucases2 - | TFSharpRecdRepr implFields, TFSharpRecdRepr sigFields -> + + // Record types are compatible with union types in signature + | TFSharpTyconRepr { fsobjmodel_kind=TFSharpRecord; fsobjmodel_rfields=implFields}, + TFSharpTyconRepr { fsobjmodel_kind=TFSharpRecord; fsobjmodel_rfields=sigFields} -> checkRecordFields m aenv infoReader implTycon implFields sigFields - | TFSharpObjectRepr r1, TFSharpObjectRepr r2 -> - if not (match r1.fsobjmodel_kind, r2.fsobjmodel_kind with - | TFSharpClass, TFSharpClass -> true - | TFSharpInterface, TFSharpInterface -> true - | TFSharpStruct, TFSharpStruct -> true - | TFSharpEnum, TFSharpEnum -> true - | TFSharpDelegate (TSlotSig(_, typ1, ctps1, mtps1, ps1, rty1)), - TFSharpDelegate (TSlotSig(_, typ2, ctps2, mtps2, ps2, rty2)) -> + + // Record types are compatible with union types in signature + | TFSharpTyconRepr r1, TFSharpTyconRepr r2 -> + let compat = + match r1.fsobjmodel_kind, r2.fsobjmodel_kind with + | TFSharpRecord, TFSharpClass -> true + | TFSharpClass, TFSharpClass -> true + | TFSharpInterface, TFSharpInterface -> true + | TFSharpStruct, TFSharpStruct -> true + | TFSharpEnum, TFSharpEnum -> true + | TFSharpDelegate (TSlotSig(_, typ1, ctps1, mtps1, ps1, rty1)), + TFSharpDelegate (TSlotSig(_, typ2, ctps2, mtps2, ps2, rty2)) -> (typeAEquiv g aenv typ1 typ2) && (ctps1.Length = ctps2.Length) && (let aenv = aenv.BindEquivTypars ctps1 ctps2 @@ -549,8 +557,10 @@ type Checker(g, amap, denv, remapInfo: SignatureRepackageInfo, checkingSig) = (typarsAEquiv g aenv mtps1 mtps2) && ((ps1, ps2) ||> List.lengthsEqAndForall2 (List.lengthsEqAndForall2 (fun p1 p2 -> typeAEquiv g aenv p1.Type p2.Type))) && (returnTypesAEquiv g aenv rty1 rty2))) - | _, _ -> false) then - (errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsDifferentKind(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)); false) + | _ -> false + if not compat then + errorR (Error(FSComp.SR.DefinitionsInSigAndImplNotCompatibleTypeIsDifferentKind(implTycon.TypeOrMeasureKind.ToString(), implTycon.DisplayName), m)) + false else let isStruct = (match r1.fsobjmodel_kind with TFSharpStruct -> true | _ -> false) checkClassFields isStruct m aenv infoReader implTycon r1.fsobjmodel_rfields r2.fsobjmodel_rfields && diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs index 7e14c215a2e..231df9d841a 100644 --- a/src/Compiler/CodeGen/IlxGen.fs +++ b/src/Compiler/CodeGen/IlxGen.fs @@ -1666,7 +1666,7 @@ let AddExternalCcusToIlxGenEnv cenv g eenv ccus = let AddBindingsForTycon allocVal (cloc: CompileLocation) (tycon: Tycon) eenv = let unrealizedSlots = if tycon.IsFSharpObjectModelTycon then - tycon.FSharpObjectModelTypeInfo.fsobjmodel_vslots + tycon.FSharpTyconRepresentationData.fsobjmodel_vslots else [] @@ -1859,29 +1859,29 @@ let MergePropertyDefs m ilPropertyDefs = /// Information collected imperatively for each type definition type TypeDefBuilder(tdef: ILTypeDef, tdefDiscards) = - let gmethods = ResizeArray(0) - let gfields = ResizeArray(0) + let gmethods = ResizeArray(tdef.Methods.AsList()) + let gfields = ResizeArray(tdef.Fields.AsList()) let gproperties: Dictionary = Dictionary<_, _>(3, HashIdentity.Structural) - let gevents = ResizeArray(0) + let gevents = ResizeArray(tdef.Events.AsList()) let gnested = TypeDefsBuilder() - member b.Close() = + member _.Close() = tdef.With( - methods = mkILMethods (tdef.Methods.AsList() @ ResizeArray.toList gmethods), - fields = mkILFields (tdef.Fields.AsList() @ ResizeArray.toList gfields), + methods = mkILMethods (ResizeArray.toList gmethods), + fields = mkILFields (ResizeArray.toList gfields), properties = mkILProperties (tdef.Properties.AsList() @ HashRangeSorted gproperties), - events = mkILEvents (tdef.Events.AsList() @ ResizeArray.toList gevents), + events = mkILEvents (ResizeArray.toList gevents), nestedTypes = mkILTypeDefs (tdef.NestedTypes.AsList() @ gnested.Close()) ) - member b.AddEventDef edef = gevents.Add edef + member _.AddEventDef edef = gevents.Add edef - member b.AddFieldDef ilFieldDef = gfields.Add ilFieldDef + member _.AddFieldDef ilFieldDef = gfields.Add ilFieldDef - member b.AddMethodDef ilMethodDef = + member _.AddMethodDef ilMethodDef = let discard = match tdefDiscards with | Some (mdefDiscard, _) -> mdefDiscard ilMethodDef @@ -2099,27 +2099,32 @@ type AnonTypeGenerationTable() = if isStruct then tycon.SetIsStructRecordOrUnion true - tycon.entity_tycon_repr <- - TFSharpRecdRepr( - Construct.MakeRecdFieldsTable( - (tps, flds) - ||> List.map2 (fun tp (propName, _fldName, _fldTy) -> - Construct.NewRecdField - false - None - (mkSynId m propName) - false - (mkTyparTy tp) - true - false - [] - [] - XmlDoc.Empty - taccessPublic - false) - ) - ) + let rfields = + (tps, flds) + ||> List.map2 (fun tp (propName, _fldName, _fldTy) -> + Construct.NewRecdField + false + None + (mkSynId m propName) + false + (mkTyparTy tp) + true + false + [] + [] + XmlDoc.Empty + taccessPublic + false) + let data = + { + fsobjmodel_cases = Construct.MakeUnionCases [] + fsobjmodel_rfields = Construct.MakeRecdFieldsTable rfields + fsobjmodel_kind = TFSharpRecord + fsobjmodel_vslots = [] + } + + tycon.entity_tycon_repr <- TFSharpTyconRepr data let tcref = mkLocalTyconRef tycon let ty = generalizedTyconRef g tcref let tcaug = tcref.TypeContents @@ -10501,9 +10506,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = | TAsmRepr _ | TILObjectRepr _ | TMeasureableRepr _ -> () - | TFSharpObjectRepr _ - | TFSharpRecdRepr _ - | TFSharpUnionRepr _ -> + | TFSharpTyconRepr _ -> let eenvinner = EnvForTycon tycon eenv let thisTy = generalizedTyconRef g tcref @@ -10669,15 +10672,19 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = let ilTypeDefKind = match tyconRepr with - | TFSharpObjectRepr o -> + | TFSharpTyconRepr o -> match o.fsobjmodel_kind with + | TFSharpUnion + | TFSharpRecord -> + if tycon.IsStructOrEnumTycon then + ILTypeDefKind.ValueType + else + ILTypeDefKind.Class | TFSharpClass -> ILTypeDefKind.Class | TFSharpStruct -> ILTypeDefKind.ValueType | TFSharpInterface -> ILTypeDefKind.Interface | TFSharpEnum -> ILTypeDefKind.Enum | TFSharpDelegate _ -> ILTypeDefKind.Delegate - | TFSharpRecdRepr _ - | TFSharpUnionRepr _ when tycon.IsStructOrEnumTycon -> ILTypeDefKind.ValueType | _ -> ILTypeDefKind.Class let requiresExtraField = @@ -10779,7 +10786,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = let extraAttribs = match tyconRepr with - | TFSharpRecdRepr _ when not useGenuineField -> + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpRecord } when not useGenuineField -> [ g.CompilerGeneratedAttribute; g.DebuggerBrowsableNeverAttribute ] | _ -> [] // don't hide fields in classes in debug display @@ -10983,7 +10990,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = // Build record constructors and the funky methods that go with records and delegate types. // Constructors and delegate methods have the same access as the representation match tyconRepr with - | TFSharpRecdRepr _ when not tycon.IsEnumTycon -> + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpRecord } when not tycon.IsEnumTycon -> // No constructor for enum types // Otherwise find all the non-static, non zero-init fields and build a constructor let relevantFields = @@ -11029,7 +11036,7 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = if not (tycon.HasMember g "ToString" []) then yield! GenToStringMethod cenv eenv ilThisTy m - | TFSharpObjectRepr r when tycon.IsFSharpDelegateTycon -> + | TFSharpTyconRepr r when tycon.IsFSharpDelegateTycon -> // Build all the methods that go with a delegate type match r.fsobjmodel_kind with @@ -11050,7 +11057,8 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = yield! mkILDelegateMethods reprAccess g.ilg (g.iltyp_AsyncCallback, g.iltyp_IAsyncResult) (parameters, ret) | _ -> () - | TFSharpUnionRepr _ when not (tycon.HasMember g "ToString" []) -> yield! GenToStringMethod cenv eenv ilThisTy m + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpUnion } when not (tycon.HasMember g "ToString" []) -> + yield! GenToStringMethod cenv eenv ilThisTy m | _ -> () ] @@ -11059,6 +11067,23 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = let ilEvents = mkILEvents abstractEventDefs let ilFields = mkILFields ilFieldDefs + // For now, generic types always use ILTypeInit.BeforeField. This is because + // there appear to be some cases where ILTypeInit.OnAny causes problems for + // the .NET CLR when used in conjunction with generic classes in cross-DLL + // and NGEN scenarios. + // + // We don't apply this rule to the final file. This is because ALL classes with .cctors in + // the final file (which may in turn trigger the .cctor for the .EXE itself, which + // in turn calls the main() method) must have deterministic initialization + // that is not triggered prior to execution of the main() method. + // If this property doesn't hold then the .cctor can end up running + // before the main method even starts. + let typeDefTrigger = + if eenv.isFinalFile || tycon.TyparsNoRange.IsEmpty then + ILTypeInit.OnAny + else + ILTypeInit.BeforeField + let tdef, tdefDiscards = let isSerializable = (TryFindFSharpBoolAttribute g g.attrib_AutoSerializableAttribute tycon.Attribs @@ -11073,16 +11098,19 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = tdef, None - | TFSharpRecdRepr _ - | TFSharpObjectRepr _ as tyconRepr -> + | TFSharpTyconRepr { fsobjmodel_kind = k } when + (match k with + | TFSharpUnion -> false + | _ -> true) + -> let super = superOfTycon g tycon let ilBaseTy = GenType cenv m eenvinner.tyenv super // Build a basic type definition let isObjectType = - (match tyconRepr with - | TFSharpObjectRepr _ -> true - | _ -> false) + match k with + | TFSharpRecord _ -> false + | _ -> true let ilAttrs = ilCustomAttrs @@ -11099,23 +11127,6 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = )) ] - // For now, generic types always use ILTypeInit.BeforeField. This is because - // there appear to be some cases where ILTypeInit.OnAny causes problems for - // the .NET CLR when used in conjunction with generic classes in cross-DLL - // and NGEN scenarios. - // - // We don't apply this rule to the final file. This is because ALL classes with .cctors in - // the final file (which may in turn trigger the .cctor for the .EXE itself, which - // in turn calls the main() method) must have deterministic initialization - // that is not triggered prior to execution of the main() method. - // If this property doesn't hold then the .cctor can end up running - // before the main method even starts. - let typeDefTrigger = - if eenv.isFinalFile || tycon.TyparsNoRange.IsEmpty then - ILTypeInit.OnAny - else - ILTypeInit.BeforeField - let isKnownToBeAttribute = ExistsSameHeadTypeInHierarchy g cenv.amap m super g.mk_Attribute_ty @@ -11231,7 +11242,11 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = tdef, None - | TFSharpUnionRepr _ -> + | TFSharpTyconRepr { fsobjmodel_kind = k } when + (match k with + | TFSharpUnion -> true + | _ -> false) + -> let alternatives = tycon.UnionCasesArray |> Array.mapi (fun i ucspec -> @@ -11318,7 +11333,14 @@ and GenTypeDef cenv mgbuf lazyInitInfo eenv m (tycon: Tycon) = .WithSealed(true) .WithEncoding(ILDefaultPInvokeEncoding.Auto) .WithAccess(access) - .WithInitSemantics(ILTypeInit.BeforeField) + // If there are static fields in the union, use the same kind of trigger as + // for class types + .WithInitSemantics( + if ilFields.AsList().IsEmpty then + ILTypeInit.BeforeField + else + typeDefTrigger + ) let tdef2 = EraseUnions.mkClassUnionDef diff --git a/src/Compiler/Service/SemanticClassification.fs b/src/Compiler/Service/SemanticClassification.fs index b9576972cfa..18834619d62 100644 --- a/src/Compiler/Service/SemanticClassification.fs +++ b/src/Compiler/Service/SemanticClassification.fs @@ -101,19 +101,19 @@ module TcResolutionsExtensions = let reprToClassificationType g repr tcref = match repr with - | TFSharpObjectRepr om -> + | TFSharpTyconRepr om -> match om.fsobjmodel_kind with + | TFSharpUnion + | TFSharpRecord -> + if isStructTyconRef g tcref then + SemanticClassificationType.ValueType + else + SemanticClassificationType.Type | TFSharpClass -> SemanticClassificationType.ReferenceType | TFSharpInterface -> SemanticClassificationType.Interface | TFSharpStruct -> SemanticClassificationType.ValueType | TFSharpDelegate _ -> SemanticClassificationType.Delegate | TFSharpEnum -> SemanticClassificationType.Enumeration - | TFSharpRecdRepr _ - | TFSharpUnionRepr _ -> - if isStructTyconRef g tcref then - SemanticClassificationType.ValueType - else - SemanticClassificationType.Type | TILObjectRepr (TILObjectReprData (_, _, td)) -> if td.IsClass then SemanticClassificationType.ReferenceType @@ -170,7 +170,7 @@ module TcResolutionsExtensions = let (|EnumCaseFieldInfo|_|) (rfinfo: RecdFieldInfo) = match rfinfo.TyconRef.TypeReprInfo with - | TFSharpObjectRepr x -> + | TFSharpTyconRepr x -> match x.fsobjmodel_kind with | TFSharpEnum -> Some() | _ -> None diff --git a/src/Compiler/Service/ServiceDeclarationLists.fs b/src/Compiler/Service/ServiceDeclarationLists.fs index a0da4745902..957dbd89071 100644 --- a/src/Compiler/Service/ServiceDeclarationLists.fs +++ b/src/Compiler/Service/ServiceDeclarationLists.fs @@ -883,15 +883,15 @@ module internal DescriptionListsImpl = /// Find the glyph for the given representation. let reprToGlyph repr = match repr with - | TFSharpObjectRepr om -> + | TFSharpTyconRepr om -> match om.fsobjmodel_kind with + | TFSharpUnion -> FSharpGlyph.Union + | TFSharpRecord -> FSharpGlyph.Type | TFSharpClass -> FSharpGlyph.Class | TFSharpInterface -> FSharpGlyph.Interface | TFSharpStruct -> FSharpGlyph.Struct | TFSharpDelegate _ -> FSharpGlyph.Delegate | TFSharpEnum -> FSharpGlyph.Enum - | TFSharpRecdRepr _ -> FSharpGlyph.Type - | TFSharpUnionRepr _ -> FSharpGlyph.Union | TILObjectRepr (TILObjectReprData (_, _, td)) -> if td.IsClass then FSharpGlyph.Class elif td.IsStruct then FSharpGlyph.Struct diff --git a/src/Compiler/Symbols/Symbols.fs b/src/Compiler/Symbols/Symbols.fs index ad7af21e718..74ae03269a1 100644 --- a/src/Compiler/Symbols/Symbols.fs +++ b/src/Compiler/Symbols/Symbols.fs @@ -585,7 +585,7 @@ type FSharpEntity(cenv: SymbolEnv, entity: EntityRef) = member _.FSharpDelegateSignature = checkIsResolved() match entity.TypeReprInfo with - | TFSharpObjectRepr r when entity.IsFSharpDelegateTycon -> + | TFSharpTyconRepr r when entity.IsFSharpDelegateTycon -> match r.fsobjmodel_kind with | TFSharpDelegate ss -> FSharpDelegateSignature(cenv, ss) | _ -> invalidOp "not a delegate type" diff --git a/src/Compiler/TypedTree/TypedTree.fs b/src/Compiler/TypedTree/TypedTree.fs index b18cdd1d2a9..497db3c2ab2 100644 --- a/src/Compiler/TypedTree/TypedTree.fs +++ b/src/Compiler/TypedTree/TypedTree.fs @@ -960,7 +960,7 @@ type Entity = /// static fields, 'val' declarations and hidden fields from the compilation of implicit class constructions. member x.AllFieldTable = match x.TypeReprInfo with - | TFSharpRecdRepr x | TFSharpObjectRepr {fsobjmodel_rfields=x} -> x + | TFSharpTyconRepr {fsobjmodel_rfields=x} -> x | _ -> match x.ExceptionInfo with | TExnFresh x -> x @@ -996,12 +996,15 @@ type Entity = member x.GetFieldByName n = x.AllFieldTable.FieldByName n /// Indicate if this is a type whose r.h.s. is known to be a union type definition. - member x.IsUnionTycon = match x.TypeReprInfo with | TFSharpUnionRepr _ -> true | _ -> false + member x.IsUnionTycon = + match x.TypeReprInfo with + | TFSharpTyconRepr {fsobjmodel_kind=TFSharpUnion} -> true + | _ -> false /// Get the union cases and other union-type information for a type, if any member x.UnionTypeInfo = match x.TypeReprInfo with - | TFSharpUnionRepr x -> ValueSome x + | TFSharpTyconRepr {fsobjmodel_kind=TFSharpUnion; fsobjmodel_cases=x} -> ValueSome x | _ -> ValueNone /// Get the union cases for a type, if any @@ -1073,9 +1076,9 @@ type Entity = member x.IsLinked = match box x.entity_attribs with null -> false | _ -> true /// Get the blob of information associated with an F# object-model type definition, i.e. class, interface, struct etc. - member x.FSharpObjectModelTypeInfo = + member x.FSharpTyconRepresentationData = match x.TypeReprInfo with - | TFSharpObjectRepr x -> x + | TFSharpTyconRepr x -> x | _ -> failwith "not an F# object model type definition" /// Indicate if this is a type definition backed by Abstract IL metadata. @@ -1089,10 +1092,17 @@ type Entity = member x.ILTyconRawMetadata = let (TILObjectReprData(_, _, td)) = x.ILTyconInfo in td /// Indicates if this is an F# type definition whose r.h.s. is known to be a record type definition. - member x.IsRecordTycon = match x.TypeReprInfo with | TFSharpRecdRepr _ -> true | _ -> false + member x.IsRecordTycon = + match x.TypeReprInfo with + | TFSharpTyconRepr {fsobjmodel_kind=TFSharpRecord} -> true + | _ -> false /// Indicates if this is an F# type definition whose r.h.s. is known to be a record type definition that is a value type. - member x.IsStructRecordOrUnionTycon = match x.TypeReprInfo with TFSharpRecdRepr _ | TFSharpUnionRepr _ -> x.entity_flags.IsStructRecordOrUnionType | _ -> false + member x.IsStructRecordOrUnionTycon = + match x.TypeReprInfo with + | TFSharpTyconRepr { fsobjmodel_kind=TFSharpRecord } -> x.entity_flags.IsStructRecordOrUnionType + | TFSharpTyconRepr { fsobjmodel_kind=TFSharpUnion } -> x.entity_flags.IsStructRecordOrUnionType + | _ -> false /// The on-demand analysis about whether the entity has the IsByRefLike attribute member x.TryIsByRefLike = x.entity_flags.TryIsByRefLike @@ -1112,8 +1122,21 @@ type Entity = /// Set the on-demand analysis about whether the entity is assumed to be a readonly struct member x.SetIsAssumedReadOnly b = x.entity_flags <- x.entity_flags.WithIsAssumedReadOnly b - /// Indicates if this is an F# type definition whose r.h.s. is known to be some kind of F# object model definition - member x.IsFSharpObjectModelTycon = match x.TypeReprInfo with | TFSharpObjectRepr _ -> true | _ -> false + /// Indicates if this is an F# type definition known to be an F# class, interface, struct, + /// delegate or enum. This isn't generally a particularly useful thing to know, + /// it is better to use more specific predicates. + member x.IsFSharpObjectModelTycon = + match x.TypeReprInfo with + | TFSharpTyconRepr { fsobjmodel_kind = kind } -> + match kind with + | TFSharpRecord + | TFSharpUnion -> false + | TFSharpClass + | TFSharpInterface + | TFSharpDelegate _ + | TFSharpStruct + | TFSharpEnum -> true + | _ -> false /// Indicates if this is an F# type definition which is one of the special types in FSharp.Core.dll which uses /// an assembly-code representation for the type, e.g. the primitive array type constructor. @@ -1128,16 +1151,16 @@ type Entity = member x.IsHiddenReprTycon = match x.TypeAbbrev, x.TypeReprInfo with | None, TNoRepr -> true | _ -> false /// Indicates if this is an F#-defined interface type definition - member x.IsFSharpInterfaceTycon = x.IsFSharpObjectModelTycon && match x.FSharpObjectModelTypeInfo.fsobjmodel_kind with TFSharpInterface -> true | _ -> false + member x.IsFSharpInterfaceTycon = x.IsFSharpObjectModelTycon && match x.FSharpTyconRepresentationData.fsobjmodel_kind with TFSharpInterface -> true | _ -> false /// Indicates if this is an F#-defined delegate type definition - member x.IsFSharpDelegateTycon = x.IsFSharpObjectModelTycon && match x.FSharpObjectModelTypeInfo.fsobjmodel_kind with TFSharpDelegate _ -> true | _ -> false + member x.IsFSharpDelegateTycon = x.IsFSharpObjectModelTycon && match x.FSharpTyconRepresentationData.fsobjmodel_kind with TFSharpDelegate _ -> true | _ -> false /// Indicates if this is an F#-defined enum type definition - member x.IsFSharpEnumTycon = x.IsFSharpObjectModelTycon && match x.FSharpObjectModelTypeInfo.fsobjmodel_kind with TFSharpEnum -> true | _ -> false + member x.IsFSharpEnumTycon = x.IsFSharpObjectModelTycon && match x.FSharpTyconRepresentationData.fsobjmodel_kind with TFSharpEnum -> true | _ -> false /// Indicates if this is an F#-defined class type definition - member x.IsFSharpClassTycon = x.IsFSharpObjectModelTycon && match x.FSharpObjectModelTypeInfo.fsobjmodel_kind with TFSharpClass -> true | _ -> false + member x.IsFSharpClassTycon = x.IsFSharpObjectModelTycon && match x.FSharpTyconRepresentationData.fsobjmodel_kind with TFSharpClass -> true | _ -> false /// Indicates if this is a .NET-defined enum type definition member x.IsILEnumTycon = x.IsILTycon && x.ILTyconRawMetadata.IsEnum @@ -1152,14 +1175,12 @@ type Entity = #endif x.IsILEnumTycon || x.IsFSharpEnumTycon - - /// Indicates if this is an F#-defined struct or enum type definition, i.e. a value type definition + /// Indicates if this is an F#-defined value type definition, including struct records and unions member x.IsFSharpStructOrEnumTycon = match x.TypeReprInfo with - | TFSharpRecdRepr _ -> x.IsStructRecordOrUnionTycon - | TFSharpUnionRepr _ -> x.IsStructRecordOrUnionTycon - | TFSharpObjectRepr info -> + | TFSharpTyconRepr info -> match info.fsobjmodel_kind with + | TFSharpRecord | TFSharpUnion -> x.IsStructRecordOrUnionTycon | TFSharpClass | TFSharpInterface | TFSharpDelegate _ -> false | TFSharpStruct | TFSharpEnum -> true | _ -> false @@ -1169,7 +1190,7 @@ type Entity = x.IsILTycon && x.ILTyconRawMetadata.IsStructOrEnum - /// Indicates if this is a struct or enum type definition, i.e. a value type definition + /// Indicates if this is a struct or enum type definition, i.e. a value type definition, including struct records and unions member x.IsStructOrEnumTycon = #if !NO_TYPEPROVIDERS match x.TypeReprInfo with @@ -1427,13 +1448,7 @@ type TyconAugmentation = type TyconRepresentation = /// Indicates the type is a class, struct, enum, delegate or interface - | TFSharpObjectRepr of TyconObjModelData - - /// Indicates the type is a record - | TFSharpRecdRepr of TyconRecdFields - - /// Indicates the type is a discriminated union - | TFSharpUnionRepr of TyconUnionData + | TFSharpTyconRepr of FSharpTyconData /// Indicates the type is a type from a .NET assembly without F# metadata. | TILObjectRepr of TILObjectReprData @@ -1547,7 +1562,13 @@ type TProvidedTypeInfo = #endif -type TyconFSharpObjModelKind = +type FSharpTyconKind = + /// Indicates the type is an F#-declared record + | TFSharpRecord + + /// Indicates the type is an F#-declared union + | TFSharpUnion + /// Indicates the type is an F#-declared class (also used for units-of-measure) | TFSharpClass @@ -1563,18 +1584,15 @@ type TyconFSharpObjModelKind = /// Indicates the type is an F#-declared enumeration | TFSharpEnum - /// Indicates if the type definition is a value type - member x.IsValueType = - match x with - | TFSharpClass | TFSharpInterface | TFSharpDelegate _ -> false - | TFSharpStruct | TFSharpEnum -> true - /// Represents member values and class fields relating to the F# object model [] -type TyconObjModelData = +type FSharpTyconData = { + /// Indicates the cases of a union type + fsobjmodel_cases: TyconUnionData + /// Indicates whether the type declaration is an F# class, interface, enum, delegate or struct - fsobjmodel_kind: TyconFSharpObjModelKind + fsobjmodel_kind: FSharpTyconKind /// The declared abstract slots of the class, interface or struct fsobjmodel_vslots: ValRef list @@ -1586,7 +1604,7 @@ type TyconObjModelData = [] member x.DebugText = x.ToString() - override x.ToString() = "TyconObjModelData(...)" + override x.ToString() = "FSharpTyconData(...)" /// Represents record fields in an F# type definition [] @@ -1649,6 +1667,7 @@ type TyconUnionCases = [] type TyconUnionData = { + /// The cases contained in the discriminated union. CasesTable: TyconUnionCases @@ -3689,7 +3708,7 @@ type EntityRef = member x.GetUnionCaseByName n = x.Deref.GetUnionCaseByName n /// Get the blob of information associated with an F# object-model type definition, i.e. class, interface, struct etc. - member x.FSharpObjectModelTypeInfo = x.Deref.FSharpObjectModelTypeInfo + member x.FSharpTyconRepresentationData = x.Deref.FSharpTyconRepresentationData /// Gets the immediate interface definitions of an F# type definition. Further interfaces may be supported through class and interface inheritance. member x.ImmediateInterfacesOfFSharpTycon = x.Deref.ImmediateInterfacesOfFSharpTycon @@ -3705,7 +3724,7 @@ type EntityRef = /// Note: result is a indexed table, and for each name the results are in reverse declaration order member x.MembersOfFSharpTyconByName = x.Deref.MembersOfFSharpTyconByName - /// Indicates if this is a struct or enum type definition, i.e. a value type definition + /// Indicates if this is a struct or enum type definition, i.e. a value type definition, including struct records and unions member x.IsStructOrEnumTycon = x.Deref.IsStructOrEnumTycon /// Indicates if this is an F# type definition which is one of the special types in FSharp.Core.dll which uses @@ -3747,7 +3766,9 @@ type EntityRef = /// Indicates if this is an F# type definition whose r.h.s. is known to be a record type definition. member x.IsRecordTycon = x.Deref.IsRecordTycon - /// Indicates if this is an F# type definition whose r.h.s. is known to be some kind of F# object model definition + /// Indicates if this is an F# type definition known to be an F# class, interface, struct, + /// delegate or enum. This isn't generally a particularly useful thing to know, + /// it is better to use more specific predicates. member x.IsFSharpObjectModelTycon = x.Deref.IsFSharpObjectModelTycon /// The on-demand analysis about whether the entity has the IsByRefLike attribute @@ -3787,7 +3808,7 @@ type EntityRef = /// Indicates if this is an enum type definition member x.IsEnumTycon = x.Deref.IsEnumTycon - /// Indicates if this is an F#-defined struct or enum type definition, i.e. a value type definition + /// Indicates if this is an F#-defined value type definition, including struct records and unions member x.IsFSharpStructOrEnumTycon = x.Deref.IsFSharpStructOrEnumTycon /// Indicates if this is a .NET-defined struct or enum type definition, i.e. a value type definition @@ -5762,6 +5783,12 @@ type Construct() = static member NewEmptyModuleOrNamespaceType mkind = Construct.NewModuleOrNamespaceType mkind [] [] + static member NewEmptyFSharpTyconData kind = + { fsobjmodel_cases = Construct.MakeUnionCases [] + fsobjmodel_kind = kind + fsobjmodel_vslots = [] + fsobjmodel_rfields = Construct.MakeRecdFieldsTable [] } + #if !NO_TYPEPROVIDERS /// Create a new node for the representation information for a provided type definition @@ -5890,7 +5917,15 @@ type Construct() = CompiledRepresentation=newCache() } /// Create a node for a union type - static member MakeUnionRepr ucs = TFSharpUnionRepr (Construct.MakeUnionCases ucs) + static member MakeUnionRepr ucs = + let repr = + { + fsobjmodel_cases = Construct.MakeUnionCases ucs + fsobjmodel_rfields = Construct.MakeRecdFieldsTable [] + fsobjmodel_kind = TFSharpUnion + fsobjmodel_vslots = [] + } + TFSharpTyconRepr repr /// Create a new type parameter node static member NewTypar (kind, rigid, SynTypar(id, staticReq, isCompGen), isFromError, dynamicReq, attribs, eqDep, compDep) = diff --git a/src/Compiler/TypedTree/TypedTree.fsi b/src/Compiler/TypedTree/TypedTree.fsi index bcc951ecc4d..749a08900a2 100644 --- a/src/Compiler/TypedTree/TypedTree.fsi +++ b/src/Compiler/TypedTree/TypedTree.fsi @@ -559,7 +559,7 @@ type Entity = member ExceptionInfo: ExceptionInfo /// Get the blob of information associated with an F# object-model type definition, i.e. class, interface, struct etc. - member FSharpObjectModelTypeInfo: TyconObjModelData + member FSharpTyconRepresentationData: FSharpTyconData /// Gets any implicit CompareTo methods added to an F# record, union or struct type definition. member GeneratedCompareToValues: (ValRef * ValRef) option @@ -620,10 +620,12 @@ type Entity = /// Indicates if this is an F#-defined interface type definition member IsFSharpInterfaceTycon: bool - /// Indicates if this is an F# type definition whose r.h.s. is known to be some kind of F# object model definition + /// Indicates if this is an F# type definition known to be an F# class, interface, struct, + /// delegate or enum. This isn't generally a particularly useful thing to know, + /// it is better to use more specific predicates. member IsFSharpObjectModelTycon: bool - /// Indicates if this is an F#-defined struct or enum type definition, i.e. a value type definition + /// Indicates if this is an F#-defined value type definition, including struct records and unions member IsFSharpStructOrEnumTycon: bool /// Indicates if this is an F# type definition whose r.h.s. definition is unknown (i.e. a traditional ML 'abstract' type in a signature, @@ -633,7 +635,7 @@ type Entity = /// Indicates if this is a .NET-defined enum type definition member IsILEnumTycon: bool - /// Indicates if this is a .NET-defined struct or enum type definition, i.e. a value type definition + /// Indicates if this is a .NET-defined struct or enum type definition member IsILStructOrEnumTycon: bool /// Indicate if this is a type definition backed by Abstract IL metadata. @@ -682,7 +684,7 @@ type Entity = member IsStaticInstantiationTycon: bool #endif - /// Indicates if this is a struct or enum type definition, i.e. a value type definition + /// Indicates if this is a struct or enum type definition, i.e. a value type definition, including struct records and unions member IsStructOrEnumTycon: bool /// Indicates if this is an F# type definition whose r.h.s. is known to be a record type definition that is a value type. @@ -879,13 +881,7 @@ type TyconAugmentation = type TyconRepresentation = /// Indicates the type is a class, struct, enum, delegate or interface - | TFSharpObjectRepr of TyconObjModelData - - /// Indicates the type is a record - | TFSharpRecdRepr of TyconRecdFields - - /// Indicates the type is a discriminated union - | TFSharpUnionRepr of TyconUnionData + | TFSharpTyconRepr of FSharpTyconData /// Indicates the type is a type from a .NET assembly without F# metadata. | TILObjectRepr of TILObjectReprData @@ -992,7 +988,12 @@ type TProvidedTypeInfo = #endif -type TyconFSharpObjModelKind = +type FSharpTyconKind = + /// Indicates the type is an F#-declared record + | TFSharpRecord + + /// Indicates the type is an F#-declared union + | TFSharpUnion /// Indicates the type is an F#-declared class (also used for units-of-measure) | TFSharpClass @@ -1009,16 +1010,15 @@ type TyconFSharpObjModelKind = /// Indicates the type is an F#-declared enumeration | TFSharpEnum - /// Indicates if the type definition is a value type - member IsValueType: bool - /// Represents member values type class fields relating to the F# object model [] -type TyconObjModelData = +type FSharpTyconData = { + /// Indicates the cases of a union type + fsobjmodel_cases: TyconUnionData /// Indicates whether the type declaration is an F# class, interface, enum, delegate or struct - fsobjmodel_kind: TyconFSharpObjModelKind + fsobjmodel_kind: FSharpTyconKind /// The declared abstract slots of the class, interface or struct fsobjmodel_vslots: ValRef list @@ -2449,7 +2449,7 @@ type EntityRef = member ExceptionInfo: ExceptionInfo /// Get the blob of information associated with an F# object-model type definition, i.e. class, interface, struct etc. - member FSharpObjectModelTypeInfo: TyconObjModelData + member FSharpTyconRepresentationData: FSharpTyconData /// Gets any implicit CompareTo methods added to an F# record, union or struct type definition. member GeneratedCompareToValues: (ValRef * ValRef) option @@ -2504,10 +2504,12 @@ type EntityRef = /// Indicates if this is an F#-defined interface type definition member IsFSharpInterfaceTycon: bool - /// Indicates if this is an F# type definition whose r.h.s. is known to be some kind of F# object model definition + /// Indicates if this is an F# type definition known to be an F# class, interface, struct, + /// delegate or enum. This isn't generally a particularly useful thing to know, + /// it is better to use more specific predicates. member IsFSharpObjectModelTycon: bool - /// Indicates if this is an F#-defined struct or enum type definition, i.e. a value type definition + /// Indicates if this is an F#-defined value type definition, including struct records and unions member IsFSharpStructOrEnumTycon: bool /// Indicates if this is an F# type definition whose r.h.s. definition is unknown (i.e. a traditional ML 'abstract' type in a signature, @@ -2567,7 +2569,7 @@ type EntityRef = member IsStaticInstantiationTycon: bool #endif - /// Indicates if this is a struct or enum type definition, i.e. a value type definition + /// Indicates if this is a struct or enum type definition, i.e. a value type definition, including struct records and unions member IsStructOrEnumTycon: bool /// Indicates if this entity is an F# type abbreviation definition @@ -4264,10 +4266,9 @@ type FreeVars = member DebugText: string /// A set of static methods for constructing types. +[] type Construct = - new: unit -> Construct - #if !NO_TYPEPROVIDERS /// Compute the definition location of a provided item static member ComputeDefinitionLocationOfProvidedItem<'T when 'T :> IProvidedCustomAttributeProvider> : @@ -4304,6 +4305,9 @@ type Construct = /// Create a new node for an empty module or namespace contents static member NewEmptyModuleOrNamespaceType: mkind: ModuleOrNamespaceKind -> ModuleOrNamespaceType + /// Create a new node for an empty F# tycon data + static member NewEmptyFSharpTyconData: kind: FSharpTyconKind -> FSharpTyconData + /// Create a new TAST Entity node for an F# exception definition static member NewExn: cpath: CompilationPath option -> diff --git a/src/Compiler/TypedTree/TypedTreeOps.fs b/src/Compiler/TypedTree/TypedTreeOps.fs index 1e15447646c..a24ff70124b 100644 --- a/src/Compiler/TypedTree/TypedTreeOps.fs +++ b/src/Compiler/TypedTree/TypedTreeOps.fs @@ -1870,9 +1870,9 @@ let rankOfArrayTy g ty = rankOfArrayTyconRef g (tcrefOfAppTy g ty) let isFSharpObjModelRefTy g ty = isFSharpObjModelTy g ty && let tcref = tcrefOfAppTy g ty - match tcref.FSharpObjectModelTypeInfo.fsobjmodel_kind with + match tcref.FSharpTyconRepresentationData.fsobjmodel_kind with | TFSharpClass | TFSharpInterface | TFSharpDelegate _ -> true - | TFSharpStruct | TFSharpEnum -> false + | TFSharpUnion | TFSharpRecord | TFSharpStruct | TFSharpEnum -> false let isFSharpClassTy g ty = match tryTcrefOfAppTy g ty with @@ -4177,10 +4177,9 @@ module DebugPrint = let tyconReprL (repr, tycon: Tycon) = match repr with - | TFSharpRecdRepr _ -> - tycon.TrueFieldsAsList |> List.map (fun fld -> layoutRecdField fld ^^ rightL(tagText ";")) |> aboveListL - - | TFSharpObjectRepr r -> + | TFSharpTyconRepr { fsobjmodel_kind = TFSharpUnion } -> + tycon.UnionCasesAsList |> layoutUnionCases |> aboveListL + | TFSharpTyconRepr r -> match r.fsobjmodel_kind with | TFSharpDelegate _ -> wordL(tagText "delegate ...") @@ -4215,7 +4214,6 @@ module DebugPrint = if emptyMeasure then emptyL else (wordL (tagText start) @@-- aboveListL alldecls) @@ wordL(tagText "end") - | TFSharpUnionRepr _ -> tycon.UnionCasesAsList |> layoutUnionCases |> aboveListL | TAsmRepr _ -> wordL(tagText "(# ... #)") | TMeasureableRepr ty -> typeL ty | TILObjectRepr (TILObjectReprData(_, _, td)) -> wordL (tagText td.Name) @@ -4497,7 +4495,7 @@ module DebugPrint = |> List.filter (fun v -> isNil (Option.get v.MemberInfo).ImplementedSlotSigs) let iimpls = match tycon.TypeReprInfo with - | TFSharpObjectRepr r when (match r.fsobjmodel_kind with TFSharpInterface -> true | _ -> false) -> [] + | TFSharpTyconRepr r when (match r.fsobjmodel_kind with TFSharpInterface -> true | _ -> false) -> [] | _ -> tycon.ImmediateInterfacesOfFSharpTycon let iimpls = iimpls |> List.filter (fun (_, compgen, _) -> not compgen) // if TFSharpInterface, the iimpls should be printed as inherited interfaces @@ -4738,7 +4736,7 @@ let ComputeRemappingFromInferredSignatureToExplicitSignature g mty msigty = /// virtual slots to aid with finding this babies. let abstractSlotValRefsOfTycons (tycons: Tycon list) = tycons - |> List.collect (fun tycon -> if tycon.IsFSharpObjectModelTycon then tycon.FSharpObjectModelTypeInfo.fsobjmodel_vslots else []) + |> List.collect (fun tycon -> if tycon.IsFSharpObjectModelTycon then tycon.FSharpTyconRepresentationData.fsobjmodel_vslots else []) let abstractSlotValsOfTycons (tycons: Tycon list) = abstractSlotValRefsOfTycons tycons @@ -5085,10 +5083,11 @@ and accLocalTyconRepr opts b fvs = if Zset.contains b fvs.FreeLocalTyconReprs then fvs else { fvs with FreeLocalTyconReprs = Zset.add b fvs.FreeLocalTyconReprs } -and accUsedRecdOrUnionTyconRepr opts (tc: Tycon) fvs = - if match tc.TypeReprInfo with TFSharpObjectRepr _ | TFSharpRecdRepr _ | TFSharpUnionRepr _ -> true | _ -> false - then accLocalTyconRepr opts tc fvs - else fvs +and accUsedRecdOrUnionTyconRepr opts (tc: Tycon) fvs = + if (match tc.TypeReprInfo with TFSharpTyconRepr _ -> true | _ -> false) then + accLocalTyconRepr opts tc fvs + else + fvs and accFreeUnionCaseRef opts ucref fvs = if not opts.includeUnionCases then fvs else @@ -5992,20 +5991,18 @@ and remapUnionCases ctxt tmenv (x: TyconUnionData) = x.UnionCasesAsList |> List.map (remapUnionCase ctxt tmenv) |> Construct.MakeUnionCases and remapFsObjData ctxt tmenv x = - { - fsobjmodel_kind = - match x.fsobjmodel_kind with - | TFSharpDelegate slotsig -> TFSharpDelegate (remapSlotSig (remapAttribs ctxt tmenv) tmenv slotsig) - | TFSharpClass | TFSharpInterface | TFSharpStruct | TFSharpEnum -> x.fsobjmodel_kind - fsobjmodel_vslots = x.fsobjmodel_vslots |> List.map (remapValRef tmenv) - fsobjmodel_rfields = x.fsobjmodel_rfields |> remapRecdFields ctxt tmenv - } + { x with + fsobjmodel_cases = remapUnionCases ctxt tmenv x.fsobjmodel_cases + fsobjmodel_kind = + (match x.fsobjmodel_kind with + | TFSharpDelegate slotsig -> TFSharpDelegate (remapSlotSig (remapAttribs ctxt tmenv) tmenv slotsig) + | _ -> x.fsobjmodel_kind) + fsobjmodel_vslots = x.fsobjmodel_vslots |> List.map (remapValRef tmenv) + fsobjmodel_rfields = x.fsobjmodel_rfields |> remapRecdFields ctxt tmenv } and remapTyconRepr ctxt tmenv repr = match repr with - | TFSharpObjectRepr x -> TFSharpObjectRepr (remapFsObjData ctxt tmenv x) - | TFSharpRecdRepr x -> TFSharpRecdRepr (remapRecdFields ctxt tmenv x) - | TFSharpUnionRepr x -> TFSharpUnionRepr (remapUnionCases ctxt tmenv x) + | TFSharpTyconRepr x -> TFSharpTyconRepr (remapFsObjData ctxt tmenv x) | TILObjectRepr _ -> failwith "cannot remap IL type definitions" #if !NO_TYPEPROVIDERS | TProvidedNamespaceRepr _ -> repr diff --git a/src/Compiler/TypedTree/TypedTreePickle.fs b/src/Compiler/TypedTree/TypedTreePickle.fs index f7f98e5620b..42bdb90c394 100644 --- a/src/Compiler/TypedTree/TypedTreePickle.fs +++ b/src/Compiler/TypedTree/TypedTreePickle.fs @@ -1790,32 +1790,81 @@ let u_istype st = | 2 -> Namespace true | _ -> ufailwith st "u_istype" -let u_cpath st = let a, b = u_tup2 u_ILScopeRef (u_list (u_tup2 u_string u_istype)) st in (CompPath(a, b)) +let u_cpath st = + let a, b = u_tup2 u_ILScopeRef (u_list (u_tup2 u_string u_istype)) st + CompPath(a, b) let rec p_tycon_repr x st = // The leading "p_byte 1" and "p_byte 0" come from the F# 2.0 format, which used an option value at this point. match x with - | TFSharpRecdRepr fs -> p_byte 1 st; p_byte 0 st; p_rfield_table fs st; false - | TFSharpUnionRepr x -> p_byte 1 st; p_byte 1 st; p_array p_unioncase_spec x.CasesTable.CasesByIndex st; false - | TAsmRepr ilTy -> p_byte 1 st; p_byte 2 st; p_ILType ilTy st; false - | TFSharpObjectRepr r -> p_byte 1 st; p_byte 3 st; p_tycon_objmodel_data r st; false - | TMeasureableRepr ty -> p_byte 1 st; p_byte 4 st; p_ty ty st; false - | TNoRepr -> p_byte 0 st; false + // Records + | TFSharpTyconRepr { fsobjmodel_rfields = fs; fsobjmodel_kind = TFSharpRecord } -> + p_byte 1 st + p_byte 0 st + p_rfield_table fs st + false + + // Unions without static fields + | TFSharpTyconRepr { fsobjmodel_cases = x; fsobjmodel_kind = TFSharpUnion; fsobjmodel_rfields = fs } when fs.FieldsByIndex.Length = 0 -> + p_byte 1 st + p_byte 1 st + p_array p_unioncase_spec x.CasesTable.CasesByIndex st + false + + // Unions with static fields, added to format + | TFSharpTyconRepr ({ fsobjmodel_cases = x; fsobjmodel_kind = TFSharpUnion } as r) -> + p_byte 2 st + p_array p_unioncase_spec x.CasesTable.CasesByIndex st + p_tycon_objmodel_data r st + false + + | TAsmRepr ilTy -> + p_byte 1 st + p_byte 2 st + p_ILType ilTy st + false + + | TFSharpTyconRepr r -> + p_byte 1 st + p_byte 3 st + p_tycon_objmodel_data r st + false + + | TMeasureableRepr ty -> + p_byte 1 st + p_byte 4 st + p_ty ty st + false + + | TNoRepr -> + p_byte 0 st + false + #if !NO_TYPEPROVIDERS | TProvidedTypeRepr info -> if info.IsErased then // Pickle erased type definitions as a NoRepr - p_byte 0 st; false + p_byte 0 st + false else // Pickle generated type definitions as a TAsmRepr - p_byte 1 st; p_byte 2 st; p_ILType (mkILBoxedType(ILTypeSpec.Create(TypeProviders.GetILTypeRefOfProvidedType(info.ProvidedType, range0), []))) st; true - | TProvidedNamespaceRepr _ -> p_byte 0 st; false + p_byte 1 st + p_byte 2 st + p_ILType (mkILBoxedType(ILTypeSpec.Create(TypeProviders.GetILTypeRefOfProvidedType(info.ProvidedType, range0), []))) st + true + + | TProvidedNamespaceRepr _ -> + p_byte 0 st + false #endif - | TILObjectRepr (TILObjectReprData (_, _, td)) -> error (Failure("Unexpected IL type definition"+td.Name)) + + | TILObjectRepr (TILObjectReprData (_, _, td)) -> + error (Failure("Unexpected IL type definition"+td.Name)) and p_tycon_objmodel_data x st = - p_tup3 p_tycon_objmodel_kind (p_vrefs "vslots") p_rfield_table - (x.fsobjmodel_kind, x.fsobjmodel_vslots, x.fsobjmodel_rfields) st + p_tycon_objmodel_kind x.fsobjmodel_kind st + p_vrefs "vslots" x.fsobjmodel_vslots st + p_rfield_table x.fsobjmodel_rfields st and p_attribs_ext f x st = p_list_ext f p_attrib x st @@ -1940,6 +1989,8 @@ and p_tycon_objmodel_kind x st = | TFSharpStruct -> p_byte 2 st | TFSharpDelegate ss -> p_byte 3 st; p_slotsig ss st | TFSharpEnum -> p_byte 4 st + | TFSharpUnion -> p_byte 5 st + | TFSharpRecord -> p_byte 6 st and p_vrefFlags x st = match x with @@ -1989,12 +2040,23 @@ and u_tycon_repr st = | 1 -> let tag2 = u_byte st match tag2 with + // Records historically use a different format to other FSharpTyconRepr | 0 -> let v = u_rfield_table st - (fun _flagBit -> TFSharpRecdRepr v) + (fun _flagBit -> + TFSharpTyconRepr + { + fsobjmodel_cases = Construct.MakeUnionCases [] + fsobjmodel_kind=TFSharpRecord + fsobjmodel_vslots=[] + fsobjmodel_rfields=v + }) + + // Unions without static fields historically use a different format to other FSharpTyconRepr | 1 -> let v = u_list u_unioncase_spec st (fun _flagBit -> Construct.MakeUnionRepr v) + | 2 -> let v = u_ILType st // This is the F# 3.0 extension to the format used for F# provider-generated types, which record an ILTypeRef in the format @@ -2020,18 +2082,32 @@ and u_tycon_repr st = TNoRepr else TAsmRepr v) + | 3 -> let v = u_tycon_objmodel_data st - (fun _flagBit -> TFSharpObjectRepr v) + (fun _flagBit -> TFSharpTyconRepr v) + | 4 -> let v = u_ty st (fun _flagBit -> TMeasureableRepr v) + | _ -> ufailwith st "u_tycon_repr" + + // Unions with static fields use a different format to other FSharpTyconRepr + | 2 -> + let cases = u_array u_unioncase_spec st + let data = u_tycon_objmodel_data st + fun _flagBit -> TFSharpTyconRepr { data with fsobjmodel_cases = Construct.MakeUnionCases (Array.toList cases) } | _ -> ufailwith st "u_tycon_repr" and u_tycon_objmodel_data st = let x1, x2, x3 = u_tup3 u_tycon_objmodel_kind u_vrefs u_rfield_table st - {fsobjmodel_kind=x1; fsobjmodel_vslots=x2; fsobjmodel_rfields=x3 } + { + fsobjmodel_cases = Construct.MakeUnionCases [] + fsobjmodel_kind=x1 + fsobjmodel_vslots=x2 + fsobjmodel_rfields=x3 + } and u_attribs_ext extraf st = u_list_ext extraf u_attrib st and u_unioncase_spec st = @@ -2223,6 +2299,8 @@ and u_tycon_objmodel_kind st = | 2 -> TFSharpStruct | 3 -> u_slotsig st |> TFSharpDelegate | 4 -> TFSharpEnum + | 5 -> TFSharpUnion + | 6 -> TFSharpRecord | _ -> ufailwith st "u_tycon_objmodel_kind" and u_vrefFlags st =